      SUBROUTINE IB03AD( INIT, ALG, STOR, NOBR, M, L, NSMP, N, NN,
     $                   ITMAX1, ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX,
     $                   TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a set of parameters for approximating a Wiener system
C     in a least-squares sense, using a neural network approach and a
C     Levenberg-Marquardt algorithm. Conjugate gradients (CG) or
C     Cholesky algorithms are used to solve linear systems of equations.
C     The Wiener system is represented as
C
C        x(t+1) = A*x(t) + B*u(t)
C        z(t)   = C*x(t) + D*u(t),
C
C        y(t)   = f(z(t),wb(1:L)),
C
C     where t = 1, 2, ..., NSMP, and f is a nonlinear function,
C     evaluated by the SLICOT Library routine NF01AY. The parameter
C     vector X is partitioned as X = ( wb(1), ..., wb(L), theta ),
C     where wb(i), i = 1 : L, correspond to the nonlinear part, and
C     theta corresponds to the linear part. See SLICOT Library routine
C     NF01AD for further details.
C
C     The sum of squares of the error functions, defined by
C
C        e(t) = y(t) - Y(t),  t = 1, 2, ..., NSMP,
C
C     is minimized, where Y(t) is the measured output vector. The
C     functions and their Jacobian matrices are evaluated by SLICOT
C     Library routine NF01BB (the FCN routine in the call of MD03AD).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     INIT    CHARACTER*1
C             Specifies which parts have to be initialized, as follows:
C             = 'L' : initialize the linear part only, X already
C                     contains an initial approximation of the
C                     nonlinearity;
C             = 'S' : initialize the static nonlinearity only, X
C                     already contains an initial approximation of the
C                     linear part;
C             = 'B' : initialize both linear and nonlinear parts;
C             = 'N' : do not initialize anything, X already contains
C                     an initial approximation.
C             If INIT = 'S' or 'B', the error functions for the
C             nonlinear part, and their Jacobian matrices, are evaluated
C             by SLICOT Library routine NF01BA (used as a second FCN
C             routine in the MD03AD call for the initialization step,
C             see METHOD).
C
C     ALG     CHARACTER*1
C             Specifies the algorithm used for solving the linear
C             systems involving a Jacobian matrix J, as follows:
C             = 'D' :  a direct algorithm, which computes the Cholesky
C                      factor of the matrix J'*J + par*I is used, where
C                      par is the Levenberg factor;
C             = 'I' :  an iterative Conjugate Gradients algorithm, which
C                      only needs the matrix J, is used.
C             In both cases, matrix J is stored in a compressed form.
C
C     STOR    CHARACTER*1
C             If ALG = 'D', specifies the storage scheme for the
C             symmetric matrix J'*J, as follows:
C             = 'F' :  full storage is used;
C             = 'P' :  packed storage is used.
C             The option STOR = 'F' usually ensures a faster execution.
C             This parameter is not relevant if ALG = 'I'.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             If INIT = 'L' or 'B', NOBR is the number of block rows, s,
C             in the input and output block Hankel matrices to be
C             processed for estimating the linear part.  NOBR > 0.
C             (In the MOESP theory,  NOBR  should be larger than  n,
C             the estimated dimension of state vector.)
C             This parameter is ignored if INIT is 'S' or 'N'.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L >= 0, and L > 0, if
C             INIT = 'L' or 'B'.
C
C     NSMP    (input) INTEGER
C             The number of input and output samples, t.  NSMP >= 0, and
C             NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'.
C
C     N       (input/output) INTEGER
C             The order of the linear part.
C             If INIT = 'L' or 'B', and N < 0 on entry, the order is
C             assumed unknown and it will be found by the routine.
C             Otherwise, the input value will be used. If INIT = 'S'
C             or 'N', N must be non-negative. The values N >= NOBR,
C             or N = 0, are not acceptable if INIT = 'L' or 'B'.
C
C     NN      (input) INTEGER
C             The number of neurons which shall be used to approximate
C             the nonlinear part.  NN >= 0.
C
C     ITMAX1  (input) INTEGER
C             The maximum number of iterations for the initialization of
C             the static nonlinearity.
C             This parameter is ignored if INIT is 'N' or 'L'.
C             Otherwise, ITMAX1 >= 0.
C
C     ITMAX2  (input) INTEGER
C             The maximum number of iterations.  ITMAX2 >= 0.
C
C     NPRINT  (input) INTEGER
C             This parameter enables controlled printing of iterates if
C             it is positive. In this case, FCN is called with IFLAG = 0
C             at the beginning of the first iteration and every NPRINT
C             iterations thereafter and immediately prior to return,
C             and the current error norm is printed. Other intermediate
C             results could be printed by modifying the corresponding
C             FCN routine (NF01BA and/or NF01BB). If NPRINT <= 0, no
C             special calls of FCN with IFLAG = 0 are made.
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU, M)
C             The leading NSMP-by-M part of this array must contain the
C             set of input samples,
C             U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ).
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= MAX(1,NSMP).
C
C     Y       (input) DOUBLE PRECISION array, dimension (LDY, L)
C             The leading NSMP-by-L part of this array must contain the
C             set of output samples,
C             Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ).
C
C     LDY     INTEGER
C             The leading dimension of array Y.  LDY >= MAX(1,NSMP).
C
C     X       (input/output) DOUBLE PRECISION array dimension (LX)
C             On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part
C             of this array must contain the initial parameters for
C             the nonlinear part of the system.
C             On entry, if INIT = 'S', the elements lin1 : lin2 of this
C             array must contain the initial parameters for the linear
C             part of the system, corresponding to the output normal
C             form, computed by SLICOT Library routine TB01VD, where
C                lin1 = (NN*(L+2) + 1)*L + 1;
C                lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M.
C             On entry, if INIT = 'N', the elements 1 : lin2 of this
C             array must contain the initial parameters for the
C             nonlinear part followed by the initial parameters for the
C             linear part of the system, as specified above.
C             This array need not be set on entry if INIT = 'B'.
C             On exit, the elements 1 : lin2 of this array contain the
C             optimal parameters for the nonlinear part followed by the
C             optimal parameters for the linear part of the system, as
C             specified above.
C
C     LX      (input/output) INTEGER
C             On entry, this parameter must contain the intended length
C             of X. If N >= 0, then LX >= NX := lin2 (see parameter X).
C             If N is unknown (N < 0 on entry), a large enough estimate
C             of N should be used in the formula of lin2.
C             On exit, if N < 0 on entry, but LX is not large enough,
C             then this parameter contains the actual length of X,
C             corresponding to the computed N. Otherwise, its value
C             is unchanged.
C
C     Tolerances
C
C     TOL1    DOUBLE PRECISION
C             If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance
C             which measures the relative error desired in the sum of
C             squares, for the initialization step of nonlinear part.
C             Termination occurs when the actual relative reduction in
C             the sum of squares is at most TOL1. In addition, if
C             ALG = 'I', TOL1 also measures the relative residual of
C             the solutions computed by the CG algorithm (for the
C             initialization step). Termination of a CG process occurs
C             when the relative residual is at most TOL1.
C             If the user sets  TOL1 < 0,  then  SQRT(EPS)  is used
C             instead TOL1, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH).
C             This parameter is ignored if INIT is 'N' or 'L'.
C
C     TOL2    DOUBLE PRECISION
C             If TOL2 >= 0, TOL2 is the tolerance which measures the
C             relative error desired in the sum of squares, for the
C             whole optimization process. Termination occurs when the
C             actual relative reduction in the sum of squares is at
C             most TOL2.
C             If ALG = 'I', TOL2 also measures the relative residual of
C             the solutions computed by the CG algorithm (for the whole
C             optimization). Termination of a CG process occurs when the
C             relative residual is at most TOL2.
C             If the user sets  TOL2 < 0,  then  SQRT(EPS)  is used
C             instead TOL2. This default value could require many
C             iterations, especially if TOL1 is larger. If INIT = 'S'
C             or 'B', it is advisable that TOL2 be larger than TOL1,
C             and spend more time with cheaper iterations.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX( 3, LIW1, LIW2 )), where
C             LIW1 = LIW2 = 0,  if INIT = 'S' or 'N'; otherwise,
C             LIW1 = M+L;
C             LIW2 = MAX(M*NOBR+N,M*(N+L)).
C             On output, if INFO = 0, IWORK(1) and IWORK(2) return the
C             (total) number of function and Jacobian evaluations,
C             respectively (including the initialization step, if it was
C             performed), and if INIT = 'L' or INIT = 'B', IWORK(3)
C             specifies how many locations of DWORK contain reciprocal
C             condition number estimates (see below); otherwise,
C             IWORK(3) = 0.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On entry, if desired, and if INIT = 'S' or 'B', the
C             entries DWORK(1:4) are set to initialize the random
C             numbers generator for the nonlinear part parameters (see
C             the description of the argument XINIT of SLICOT Library
C             routine MD03AD); this enables to obtain reproducible
C             results. The same seed is used for all outputs.
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, DWORK(2) returns the residual error norm (the
C             sum of squares), DWORK(3) returns the number of iterations
C             performed, DWORK(4) returns the number of conjugate
C             gradients iterations performed, and DWORK(5) returns the
C             final Levenberg factor, for optimizing the parameters of
C             both the linear part and the static nonlinearity part.
C             If INIT = 'S' or INIT = 'B' and INFO = 0, then the
C             elements DWORK(6) to DWORK(10) contain the corresponding
C             five values for the initialization step (see METHOD).
C             (If L > 1, DWORK(10) contains the maximum of the Levenberg
C             factors for all outputs.) If INIT = 'L' or INIT = 'B', and
C             INFO = 0, DWORK(11) to DWORK(10+IWORK(3)) contain
C             reciprocal condition number estimates set by SLICOT
C             Library routines IB01AD, IB01BD, and IB01CD.
C             On exit, if  INFO = -23,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             In the formulas below, N should be taken not larger than
C             NOBR - 1, if N < 0 on entry.
C             LDWORK = MAX( LW1, LW2, LW3, LW4 ), where
C             LW1 = 0, if INIT = 'S' or 'N'; otherwise,
C             LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR,
C                        4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) +
C                        MAX( LDW1, LDW2 ),
C                        (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) +
C                        MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ),
C                 where,
C                 LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N,
C                              L*NOBR*N +
C                              MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L,
C                                   2*(L*NOBR-L)*N+N*N+8*N,
C                                   N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) )
C                 LDW2 >= 0,                                  if M = 0;
C                 LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) +
C                         MAX( (N+L)**2, 4*M*(N+L)+1 ),       if M > 0;
C                 LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ),
C                 LDW4 = N*(N+1) + 2*N +
C                        MAX( N*L*(N+1) + 2*N*N + L*N, 4*N );
C                 LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L;
C                 LDW6 = NSMP*L + (N+L)*(N+M) + N +
C                        MAX(1, N*N*L + N*L + N, N*N +
C                            MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L),
C                                N*M));
C             LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise,
C             LW2 = NSMP*L +
C                   MAX( 5, NSMP + 2*BSN + NSMP*BSN +
C                           MAX( 2*NN + BSN, LDW7 ) );
C                 LDW7 = BSN*BSN,       if ALG = 'D' and STOR = 'F';
C                 LDW7 = BSN*(BSN+1)/2, if ALG = 'D' and STOR = 'P';
C                 LDW7 = 3*BSN + NSMP,  if ALG = 'I';
C             LW3 = MAX( LDW8, NSMP*L + (N+L)*(2*N+M) + 2*N );
C                 LDW8 = NSMP*L + (N+L)*(N+M) + 3*N+M+L,  if M > 0;
C                 LDW8 = NSMP*L + (N+L)*N + 2*N+L,        if M = 0;
C             LW4 = MAX( 5, NSMP*L + 2*NX + NSMP*L*( BSN + LTHS ) +
C                           MAX( L1 + NX, NSMP*L + L1, L2 ) ),
C                  L0 = MAX( N*(N+L), N+M+L ),    if M > 0;
C                  L0 = MAX( N*(N+L), L ),        if M = 0;
C                  L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0);
C                  L2 = NX*NX,          if ALG = 'D' and STOR = 'F';
C                  L2 = NX*(NX+1)/2,    if ALG = 'D' and STOR = 'P';
C                  L2 = 3*NX + NSMP*L,  if ALG = 'I',
C                  with BSN  = NN*( L + 2 ) + 1,
C                       LTHS = N*( L + M + 1 ) + L*M.
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             < 0:  the user set IFLAG = IWARN in (one of) the
C                   subroutine(s) FCN, i.e., NF01BA, if INIT = 'S'
C                   or 'B', and/or NF01BB; this value cannot be returned
C                   without changing the FCN routine(s);
C                   otherwise, IWARN has the value k*100 + j*10 + i,
C                   where k is defined below, i refers to the whole
C                   optimization process, and j refers to the
C                   initialization step (j = 0, if INIT = 'L' or 'N'),
C                   and the possible values for i and j have the
C                   following meaning (where TOL* denotes TOL1 or TOL2,
C                   and similarly for ITMAX*):
C             = 1:  the number of iterations has reached ITMAX* without
C                   satisfying the convergence condition;
C             = 2:  if alg = 'I' and in an iteration of the Levenberg-
C                   Marquardt algorithm, the CG algorithm finished
C                   after 3*NX iterations (or 3*(lin1-1) iterations, for
C                   the initialization phase), without achieving the
C                   precision required in the call;
C             = 3:  the cosine of the angle between the vector of error
C                   function values and any column of the Jacobian is at
C                   most FACTOR*EPS in absolute value (FACTOR = 100);
C             = 4:  TOL* is too small: no further reduction in the sum
C                   of squares is possible.
C             The digit k is normally 0, but if INIT = 'L' or 'B', it
C             can have a value in the range 1 to 6 (see IB01AD, IB01BD
C             and IB01CD). In all these cases, the entries DWORK(1:5),
C             DWORK(6:10) (if INIT = 'S' or 'B'), and
C             DWORK(11:10+IWORK(3)) (if INIT = 'L' or 'B'), are set as
C             described above.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C                   otherwise, INFO has the value k*100 + j*10 + i,
C                   where k is defined below, i refers to the whole
C                   optimization process, and j refers to the
C                   initialization step (j = 0, if INIT = 'L' or 'N'),
C                   and the possible values for i and j have the
C                   following meaning:
C             = 1:  the routine FCN returned with INFO <> 0 for
C                   IFLAG = 1;
C             = 2:  the routine FCN returned with INFO <> 0 for
C                   IFLAG = 2;
C             = 3:  ALG = 'D' and SLICOT Library routines MB02XD or
C                   NF01BU (or NF01BV, if INIT = 'S' or 'B') or
C                   ALG = 'I' and SLICOT Library routines MB02WD or
C                   NF01BW (or NF01BX, if INIT = 'S' or 'B') returned
C                   with INFO <> 0.
C             In addition, if INIT = 'L' or 'B', i could also be
C             = 4:  if a Lyapunov equation could not be solved;
C             = 5:  if the identified linear system is unstable;
C             = 6:  if the QR algorithm failed on the state matrix
C                   of the identified linear system.
C             The digit k is normally 0, but if INIT = 'L' or 'B', it
C             can have a value in the range 1 to 10 (see IB01AD/IB01BD).
C
C     METHOD
C
C     If INIT = 'L' or 'B', the linear part of the system is
C     approximated using the combined MOESP and N4SID algorithm. If
C     necessary, this algorithm can also choose the order, but it is
C     advantageous if the order is already known.
C
C     If INIT = 'S' or 'B', the output of the approximated linear part
C     is computed and used to calculate an approximation of the static
C     nonlinearity using the Levenberg-Marquardt algorithm [1].
C     This step is referred to as the (nonlinear) initialization step.
C
C     As last step, the Levenberg-Marquardt algorithm is used again to
C     optimize the parameters of the linear part and the static
C     nonlinearity as a whole. Therefore, it is necessary to parametrise
C     the matrices of the linear part. The output normal form [2]
C     parameterisation is used.
C
C     The Jacobian is computed analytically, for the nonlinear part, and
C     numerically, for the linear part.
C
C     REFERENCES
C
C     [1] Kelley, C.T.
C         Iterative Methods for Optimization.
C         Society for Industrial and Applied Mathematics (SIAM),
C         Philadelphia (Pa.), 1999.
C
C     [2] Peeters, R.L.M., Hanzon, B., and Olivi, M.
C         Balanced realizations of discrete-time stable all-pass
C         systems and the tangential Schur algorithm.
C         Proceedings of the European Control Conference,
C         31 August - 3 September 1999, Karlsruhe, Germany.
C         Session CP-6, Discrete-time Systems, 1999.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Oct. 2000, during a stay at University of Twente, NL.
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001,
C     Mar. 2002, Apr. 2002, Feb. 2004, March 2005, Nov. 2005.
C
C     KEYWORDS
C
C     Conjugate gradients, least-squares approximation,
C     Levenberg-Marquardt algorithm, matrix operations, optimization.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     The upper triangular part is used in MD03AD;
      CHARACTER         UPLO
      PARAMETER         ( UPLO = 'U' )
C     For INIT = 'L' or 'B', additional parameters are set:
C     The following six parameters are used in the call of IB01AD;
      CHARACTER         IALG, BATCH, CONCT, CTRL, JOBD, METH
      PARAMETER         ( IALG  = 'Fast QR',     BATCH = 'One batch',
     $                    CONCT = 'Not connect', CTRL  = 'Not confirm',
     $                    JOBD  = 'Not MOESP',   METH  = 'MOESP' )
C     The following three parameters are used in the call of IB01BD;
      CHARACTER         JOB, JOBCK, METHB
      PARAMETER         ( JOB   = 'All matrices',
     $                    JOBCK = 'No Kalman gain',
     $                    METHB = 'Combined MOESP+N4SID' )
C     The following two parameters are used in the call of IB01CD;
      CHARACTER         COMUSE, JOBXD
      PARAMETER         ( COMUSE = 'Use B, D',
     $                    JOBXD  = 'D also' )
C     TOLN controls the estimated order in IB01AD (default value);
      DOUBLE PRECISION  TOLN
      PARAMETER         ( TOLN = -1.0D0 )
C     RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD
C     (default);
      DOUBLE PRECISION  RCOND
      PARAMETER         ( RCOND = -1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         ALG, INIT, STOR
      INTEGER           INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK,
     $                  LDY, LX, M, N, NN, NOBR, NPRINT, NSMP
      DOUBLE PRECISION  TOL1, TOL2
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), U(LDU, *), X(*), Y(LDY, *)
      INTEGER           IWORK(*)
C     .. Local Scalars ..
      INTEGER           AC, BD, BSN, I, IA, IB, IK, INFOL, IQ, IR,
     $                  IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, IW2,
     $                  IWARNL, IX, IX0, J, JWORK, LDAC, LDR, LIPAR,
     $                  LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, NSML,
     $                  NTHS, NX, WRKOPT, Z
      LOGICAL           CHOL, FULL, INIT1, INIT2
C     .. Local Arrays ..
      LOGICAL           BWORK(1)
      INTEGER           IPAR(7)
      DOUBLE PRECISION  RCND(16), SEED(4), WORK(5)
C     .. External Functions ..
      EXTERNAL          LSAME
      LOGICAL           LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY,  IB01AD, IB01BD, IB01CD, MD03AD, NF01BA,
     $                  NF01BB, NF01BU, NF01BV, NF01BW, NF01BX, TB01VD,
     $                  TB01VY, TF01MX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      CHOL  = LSAME( ALG,  'D' )
      FULL  = LSAME( STOR, 'F' )
      INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' )
      INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' )
C
      ML    = M + L
      INFO  = 0
      IWARN = 0
      IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN
         INFO = -1
      ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG,  'I' ) ) ) THEN
         INFO = -2
      ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN
         INFO = -3
      ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN
         INFO = -4
      ELSEIF ( M.LT.0 ) THEN
         INFO = -5
      ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN
         INFO = -6
      ELSEIF ( NSMP.LT.0 .OR.
     $         ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN
         INFO = -7
      ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR.
     $       ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN
         INFO = -8
      ELSEIF ( NN.LT.0 ) THEN
         INFO = -9
      ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN
         INFO = -10
      ELSEIF ( ITMAX2.LT.0 ) THEN
         INFO = -11
      ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN
         INFO = -14
      ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN
         INFO = -16
      ELSE
         LNOL = L*NOBR - L
         MNO  = M*NOBR
         BSN  = NN*( L + 2 ) + 1
         NTHS =  BSN*L
         NSML = NSMP*L
         IF ( N.GT.0 ) THEN
            LDAC = N + L
            ISAD = LDAC*( N + M )
            N2   = N*N
         END IF
C
C        Check the workspace size.
C
         JWORK = 0
         IF ( INIT1 ) THEN
C           Workspace for IB01AD.
            JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR
            IF ( N.GT.0 ) THEN
C              Workspace for IB01BD.
               IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N +
     $                    MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L,
     $                         2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) +
     $                         1, MNO + 3*N + L ) )
               IF ( M.GT.0 ) THEN
                  IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) +
     $                  MAX( LDAC**2, 4*M*LDAC + 1 )
               ELSE
                  IW2 = 0
               END IF
               JWORK = MAX( JWORK,
     $                      ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) )
C              Workspace for IB01CD.
               IW1   = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N )
               IW2   = N*( N + 1 ) + 2*N +
     $                 MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N )
               JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) +
     $                     MAX( 5*N, 2, MIN( IW1, IW2 ) ) )
C              Workspace for TF01MX.
               JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M )
C              Workspace for TB01VD.
               JWORK = MAX( JWORK, NSML + ISAD + N +
     $                      MAX( 1, N2*L + N*L + N,
     $                           N2 + MAX( N2 + N*MAX( N, L ) +
     $                                     6*N +  MIN( N, L ), N*M ) ) )
            END IF
         END IF
C
         IF ( INIT2 ) THEN
C           Workspace for MD03AD (initialization of the nonlinear part).
            IF ( CHOL ) THEN
               IF ( FULL ) THEN
                  IW1 = BSN**2
               ELSE
                  IW1 = ( BSN*( BSN + 1 ) )/2
               END IF
            ELSE
               IW1 = 3*BSN + NSMP
            END IF
            JWORK = MAX( JWORK, NSML +
     $                   MAX( 5, NSMP + 2*BSN + NSMP*BSN +
     $                        MAX( 2*NN + BSN, IW1 ) ) )
            IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN
C              Workspace for TB01VY.
               JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N )
C              Workspace for TF01MX.
               IF ( M.GT.0 ) THEN
                  IW1 = N + M
               ELSE
                  IW1 = 0
               END IF
               JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N )
            END IF
         END IF
C
         IF ( N.GE.0 ) THEN
C
C           Find the number of parameters.
C
            LTHS = N*( ML + 1 ) + L*M
            NX   = NTHS + LTHS
C
            IF ( LX.LT.NX ) THEN
               INFO = -18
               CALL XERBLA( 'IB03AD', -INFO )
               RETURN
            END IF
C
C           Workspace for MD03AD (whole optimization).
C
            IF ( M.GT.0 ) THEN
               IW1 = LDAC + M
            ELSE
               IW1 = L
            END IF
            IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) )
            IF ( CHOL ) THEN
               IF ( FULL ) THEN
                  IW2 = NX**2
               ELSE
                  IW2 = ( NX*( NX + 1 ) )/2
               END IF
            ELSE
               IW2 = 3*NX + NSML
            END IF
            JWORK = MAX( JWORK,
     $                   5, NSML + 2*NX + NSML*( BSN + LTHS ) +
     $                      MAX( IW1 + NX, NSML + IW1, IW2 ) )
         END IF
C
         IF ( LDWORK.LT.JWORK ) THEN
            INFO = -23
            DWORK(1) = JWORK
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB03AD', -INFO )
         RETURN
      ENDIF
C
C     Initialize the pointers to system matrices and save the possible
C     seed for random numbers generation.
C
      Z  = 1
      AC = Z + NSML
      CALL DCOPY( 4, DWORK, 1, SEED, 1 )
C
      WRKOPT = 1
C
      IF ( INIT1 ) THEN
C
C        Initialize the linear part.
C        If N < 0, the order of the system is determined by IB01AD;
C        otherwise, the given order will be used.
C        The workspace needed is defined for the options set above
C        in the PARAMETER statements.
C        Workspace:  need:   2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR;
C                    prefer: larger.
C        Integer workspace:  M+L. (If METH = 'N', (M+L)*NOBR.)
C
         NS  = N
         IR  = 1
         ISV = 2*ML*NOBR
         LDR = ISV
         IF ( LSAME( JOBD, 'M' ) )
     $      LDR = MAX( LDR, 3*MNO )
         ISV   = IR  + LDR*ISV
         JWORK = ISV + L*NOBR
C
         CALL IB01AD( METH, IALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L,
     $                NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR,
     $                DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK),
     $                LDWORK-JWORK+1, IWARNL, INFOL )
C
         IF( INFOL.NE.0 ) THEN
            INFO = 100*INFOL
            RETURN
         END IF
         IF( IWARNL.NE.0 )
     $      IWARN = 100*IWARNL
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         IRCND  = 0
         IF ( LSAME( METH, 'N' ) ) THEN
            IRCND = 2
            CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 )
         END IF
C
         IF ( NS.GE.0 ) THEN
            N = NS
         ELSE
C
C           Find the number of parameters.
C
            LDAC = N + L
            ISAD = LDAC*( N + M )
            N2   = N*N
            LTHS = N*( ML + 1 ) + L*M
            NX   = NTHS + LTHS
C
            IF ( LX.LT.NX ) THEN
               LX   = NX
               INFO = -18
               CALL XERBLA( 'IB03AD', -INFO )
               RETURN
            END IF
C           Workspace for IB01BD.
            IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N +
     $                 MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L,
     $                      2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1,
     $                      MNO + 3*N + L ) )
            IF ( M.GT.0 ) THEN
               IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) +
     $               MAX( LDAC**2, 4*M*LDAC + 1 )
            ELSE
               IW2 = 0
            END IF
            JWORK = ISV + ISAD + MAX( IW1, IW2 )
C           Workspace for IB01CD.
            IW1   = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N )
            IW2   = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N,
     $                                       4*N )
            JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) +
     $                   MAX( 5*N, 2, MIN( IW1, IW2 ) ) )
C           Workspace for TF01MX.
            JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M )
C           Workspace for TB01VD.
            JWORK = MAX( JWORK, NSML + ISAD + N +
     $                   MAX( 1, N2*L + N*L + N,
     $                        N2 + MAX( N2 + N*MAX( N, L ) +
     $                                  6*N +  MIN( N, L ), N*M ) ) )
C           Workspace for MD03AD (whole optimization).
            IF ( M.GT.0 ) THEN
               IW1 = LDAC + M
            ELSE
               IW1 = L
            END IF
            IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) )
            IF ( CHOL ) THEN
               IF ( FULL ) THEN
                  IW2 = NX**2
               ELSE
                  IW2 = ( NX*( NX + 1 ) )/2
               END IF
            ELSE
               IW2 = 3*NX + NSML
            END IF
            JWORK = MAX( JWORK,
     $                   5, NSML + 2*NX + NSML*( BSN + LTHS ) +
     $                      MAX( IW1 + NX, NSML + IW1, IW2 ) )
            IF ( LDWORK.LT.JWORK ) THEN
               INFO = -23
               DWORK(1) = JWORK
               CALL XERBLA( 'IB03AD', -INFO )
               RETURN
            END IF
         END IF
C
         BD = AC + LDAC*N
         IX = BD + LDAC*M
         IA = ISV
         IB = IA + LDAC*N
         IQ = IB + LDAC*M
         IF ( LSAME( JOBCK, 'N' ) ) THEN
            IRY   = IQ
            IS    = IQ
            IK    = IQ
            JWORK = IQ
         ELSE
            IRY   = IQ  + N2
            IS    = IRY + L*L
            IK    = IS  + N*L
            JWORK = IK  + N*L
         END IF
C
C        The workspace needed is defined for the options set above
C        in the PARAMETER statements.
C        Workspace:
C          need:  4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) +
C                 max( LDW1,LDW2 ), where,
C                 LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N,
C                              L*NOBR*N +
C                              max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L,
C                                   2*(L*NOBR-L)*N+N*N+8*N,
C                                   N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) )
C                 LDW2 >= 0,                                  if M = 0;
C                 LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+
C                         max( (N+L)**2, 4*M*(N+L)+1 ),       if M > 0;
C          prefer: larger.
C        Integer workspace:  MAX(M*NOBR+N,M*(N+L)).
C
         CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR),
     $                LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC,
     $                DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N,
     $                DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND,
     $                IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK,
     $                IWARNL, INFOL )
C
         IF( INFOL.EQ.-30 ) THEN
            INFO = -23
            DWORK(1) = DWORK(JWORK)
            CALL XERBLA( 'IB03AD', -INFO )
            RETURN
         END IF
         IF( INFOL.NE.0 ) THEN
            INFO = 100*INFOL
            RETURN
         END IF
         IF( IWARNL.NE.0 )
     $      IWARN = 100*IWARNL
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         IRCNDB = 4
         IF ( LSAME( JOBCK, 'K' ) )
     $      IRCNDB = IRCNDB + 8
         CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 )
         IRCND = IRCND + IRCNDB
C
C        Copy the system matrices to the beginning of DWORK, to save
C        space, and redefine the pointers.
C
         CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 )
         IA  = 1
         IB  = IA  + LDAC*N
         IX0 = IB  + LDAC*M
         IV  = IX0 + N
C
C        Compute the initial condition of the system. On normal exit,
C           DWORK(i), i = JWORK+2:JWORK+1+N*N,
C           DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N,  and
C           DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M,
C        contain the transformed system matrices  At, Ct, and Bt,
C        respectively, corresponding to the real Schur form of the
C        estimated system state matrix  A. The transformation matrix is
C        stored in DWORK(IV:IV+N*N-1).
C        The workspace needed is defined for the options set above
C        in the PARAMETER statements.
C        Workspace:
C          need:   (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) +
C                  max( 5*N, 2, min( LDW1, LDW2 ) ), where,
C                  LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N),
C                  LDW2 = N*(N + 1) + 2*N +
C                         max( N*L*(N + 1) + 2*N*N + L*N, 4*N);
C          prefer: larger.
C        Integer workspace:  N.
C
         JWORK = IV + N2
         CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP,
     $                DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N),
     $                LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY,
     $                DWORK(IX0), DWORK(IV), N, RCOND, IWORK,
     $                DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL )
C
         IF( INFOL.EQ.-26 ) THEN
            INFO = -23
            DWORK(1) = DWORK(JWORK)
            CALL XERBLA( 'IB03AD', -INFO )
            RETURN
         END IF
         IF( INFOL.EQ.1 )
     $      INFOL = 10
         IF( INFOL.NE.0 ) THEN
            INFO = 100*INFOL
            RETURN
         END IF
         IF( IWARNL.NE.0 )
     $      IWARN = 100*IWARNL
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         IRCND  = IRCND + 1
         RCND(IRCND) = DWORK(JWORK+1)
C
C        Now, save the system matrices and x0 in the final location.
C
         IF ( IV.LT.AC ) THEN
            CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 )
         ELSE
            DO 5 J = AC + ISAD + N - 1, AC, -1
               DWORK(J) = DWORK(IA+J-AC)
    5       CONTINUE
         END IF
C
C        Compute the output of the linear part.
C        Workspace: need   NSMP*L + (N + L)*(N + M) + 3*N + M + L,
C                                                              if M > 0;
C                          NSMP*L + (N + L)*N + 2*N + L,       if M = 0;
C                   prefer larger.
C
         JWORK = IX + N
         CALL DCOPY(  N, DWORK(IX), 1, X(NTHS+1), 1 )
         CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1),
     $                DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1,
     $                INFO )
C
C        Convert the state-space representation to output normal form.
C        Workspace:
C          need:   NSMP*L + (N + L)*(N + M) + N +
C                  MAX(1, N*N*L + N*L + N, N*N +
C                      MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M));
C          prefer: larger.
C
         CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD),
     $                LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC,
     $                DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFOL )
C
         IF( INFOL.GT.0 ) THEN
            INFO = INFOL + 3
            RETURN
         END IF
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
      END IF
C
      LIPAR = 7
      IW1   = 0
      IW2   = 0
C
      IF ( INIT2 ) THEN
C
C        Initialize the nonlinear part.
C
         IF ( .NOT.INIT1 ) THEN
            BD = AC + LDAC*N
            IX = BD + LDAC*M
C
C           Convert the output normal form to state-space model.
C           Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N.
C           (NSMP*L locations are reserved for the output of the linear
C           part.)
C
            JWORK = IX + N
            CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC),
     $                   LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC,
     $                   DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
C
C           Compute the output of the linear part.
C           Workspace: need   NSMP*L + (N + L)*(N + M) + 3*N + M + L,
C                                                              if M > 0;
C                             NSMP*L + (N + L)*N + 2*N + L,    if M = 0;
C                      prefer larger.
C
            CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU,
     $                   DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
         END IF
C
C        Optimize the parameters of the nonlinear part.
C        Workspace:
C          need   NSMP*L +
C                 MAX( 5, NSMP + 2*BSN + NSMP*BSN +
C                         MAX( 2*NN + BSN, DW( sol ) ) ),
C                 where, if ALG = 'D',
C                      DW( sol ) = BSN*BSN,        if STOR = 'F';
C                      DW( sol ) = BSN*(BSN+1)/2,  if STOR = 'P';
C                 and  DW( sol ) = 3*BSN + NSMP,   if ALG  = 'I';
C          prefer larger.
C
         JWORK   = AC
         WORK(1) = ZERO
         CALL DCOPY( 4, WORK(1), 0, WORK(2), 1 )
C
C        Set the integer parameters needed, including the number of
C        neurons.
C
         IPAR(1) = NSMP
         IPAR(2) = L
         IPAR(3) = NN
C
         DO 10 I = 0, L - 1
            CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 )
            IF ( CHOL ) THEN
               CALL MD03AD( 'Random initialization', ALG, STOR, UPLO,
     $                      NF01BA, NF01BV, NSMP, BSN, ITMAX1, NPRINT,
     $                      IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY,
     $                      X(I*BSN+1), NFEV, NJEV, TOL1, TOL1,
     $                      DWORK(JWORK), LDWORK-JWORK+1, IWARNL,
     $                      INFOL )
            ELSE
               CALL MD03AD( 'Random initialization', ALG, STOR, UPLO,
     $                      NF01BA, NF01BX, NSMP, BSN, ITMAX1, NPRINT,
     $                      IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY,
     $                      X(I*BSN+1), NFEV, NJEV, TOL1, TOL1,
     $                      DWORK(JWORK), LDWORK-JWORK+1, IWARNL,
     $                      INFOL )
            END IF
C
            IF( INFOL.NE.0 ) THEN
               INFO = 10*INFOL
               RETURN
            END IF
            IF ( IWARNL.LT.0 ) THEN
               INFO  = INFOL
               IWARN = IWARNL
               GO TO 20
            ELSEIF ( IWARNL.GT.0 ) THEN
               IF ( IWARN.GT.100 ) THEN
                  IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL )
               ELSE
                  IWARN = MAX( IWARN, 10*IWARNL )
               END IF
            END IF
            WORK(1) = MAX( WORK(1), DWORK(JWORK) )
            WORK(2) = MAX( WORK(2), DWORK(JWORK+1) )
            WORK(5) = MAX( WORK(5), DWORK(JWORK+4) )
            WORK(3) = WORK(3) + DWORK(JWORK+2)
            WORK(4) = WORK(4) + DWORK(JWORK+3)
            IW1     = NFEV + IW1
            IW2     = NJEV + IW2
   10    CONTINUE
C
      ENDIF
C
C     Main iteration.
C     Workspace: need   MAX( 5, NFUN + 2*NX + NFUN*( BSN + LTHS ) +
C                            MAX( LDW1 + NX, NFUN + LDW1, DW( sol ) ) ),
C                       where NFUN = NSMP*L, and
C                       LDW1 = NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N +
C                                          MAX( N*(N + L), N + M + L )),
C                                                              if M > 0,
C                       LDW1 = NFUN + MAX( 2*NN, (N + L)*N + 2*N +
C                                          MAX( N*(N + L), L ) ),
C                                                              if M = 0;
C                       if ALG = 'D',
C                             DW( sol ) = NX*NX,        if STOR = 'F';
C                             DW( sol ) = NX*(NX+1)/2,  if STOR = 'P';
C                       and   DW( sol ) = 3*NX + NFUN,  if ALG  = 'I',
C                       and DW( f ) is the workspace needed by the
C                       subroutine f;
C                prefer larger.
C
C     Set the integer parameters describing the Jacobian structure
C     and the number of neurons.
C
      IPAR(1) = LTHS
      IPAR(2) = L
      IPAR(3) = NSMP
      IPAR(4) = BSN
      IPAR(5) = M
      IPAR(6) = N
      IPAR(7) = NN
C
      IF ( CHOL ) THEN
         CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB,
     $                NF01BU, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR,
     $                U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2,
     $                DWORK, LDWORK, IWARNL, INFO )
      ELSE
         CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB,
     $                NF01BW, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR,
     $                U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2,
     $                DWORK, LDWORK, IWARNL, INFO )
      END IF
C
      IF( INFO.NE.0 )
     $   RETURN
C
   20 CONTINUE
      IWORK(1) = IW1 + NFEV
      IWORK(2) = IW2 + NJEV
      IF ( IWARNL.LT.0 ) THEN
         IWARN = IWARNL
      ELSE
         IWARN = IWARN + IWARNL
      END IF
      IF ( INIT2 )
     $   CALL DCOPY( 5, WORK, 1, DWORK(6), 1 )
      IF ( INIT1 ) THEN
         IWORK(3) = IRCND
         CALL DCOPY( IRCND, RCND, 1, DWORK(11), 1 )
      ELSE
         IWORK(3) = 0
      END IF
      RETURN
C
C *** Last line of IB03AD ***
      END


module gravity_module

  use amrex_error_module
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  public

  ! Data for the multipole gravity

  real(rt)        , save :: volumeFactor, parityFactor
  real(rt)        , save :: edgeTolerance = 1.0e-2_rt
  real(rt)        , save :: rmax
  logical,          save :: doSymmetricAddLo(3), doSymmetricAddHi(3), doSymmetricAdd
  logical,          save :: doReflectionLo(3), doReflectionHi(3)
  integer,          save :: lnum_max
  real(rt)        , allocatable, save :: factArray(:,:)
  real(rt)        , allocatable, save :: parity_q0(:), parity_qC_qS(:,:)

contains

! ::
! :: ----------------------------------------------------------
! ::

  ! Returns the gravitational constant, G

  subroutine get_grav_const(Gconst_out) bind(C, name="get_grav_const")

    use fundamental_constants_module, only: Gconst

    use amrex_fort_module, only : rt => amrex_real
    real(rt), intent(inout) :: Gconst_out

    Gconst_out = Gconst

  end subroutine get_grav_const

  ! ::
  ! :: ----------------------------------------------------------
  ! ::

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Given a radial mass distribution, this computes the gravitational
  ! acceleration as a function of radius by computing the mass enclosed
  ! in successive spherical shells.
  ! Inputs: mass(r), dr, numpts_1d
  ! Outputs: grav(r)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine ca_integrate_grav (mass,den,grav,max_radius,dr,numpts_1d) &
       bind(C, name="ca_integrate_grav")

    use fundamental_constants_module, only : Gconst
    use amrex_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none
    integer , intent(in   ) :: numpts_1d
    real(rt), intent(in   ) :: mass(0:numpts_1d-1)
    real(rt), intent(in   ) ::  den(0:numpts_1d-1)
    real(rt), intent(inout) :: grav(0:numpts_1d-1)
    real(rt), intent(in   ) :: max_radius,dr

    integer          :: i
    real(rt)         :: rc,rlo,rhi,halfdr
    real(rt)         :: mass_encl
    real(rt)         :: vol_inner_shell, vol_outer_shell
    real(rt)         :: vol_lower_shell, vol_upper_shell
    real(rt)         :: vol_total_im1, vol_total_i

    real(rt)        , parameter ::  fourthirdspi = 4.e0_rt * M_PI / 3.e0_rt

    halfdr = 0.5e0_rt * dr

    mass_encl = 0.e0_rt
    do i = 0,numpts_1d-1
       rlo = (dble(i)      ) * dr
       rc  = (dble(i)+0.5e0_rt) * dr
       rhi = (dble(i)+1.0e0_rt) * dr

       if (i.eq.0) then

          ! The mass at (i) is distributed into these two regions
          vol_outer_shell = fourthirdspi * rc**3
          vol_upper_shell = fourthirdspi * (rhi**3 - rc**3)
          vol_total_i     = vol_outer_shell + vol_upper_shell

          mass_encl = vol_outer_shell * mass(i)  / vol_total_i

       else if (rc .lt. max_radius) then

          ! The mass at (i-1) is distributed into these two shells
          vol_lower_shell = vol_outer_shell   ! This copies from the previous i
          vol_inner_shell = vol_upper_shell   ! This copies from the previous i
          vol_total_im1   = vol_total_i       ! This copies from the previous i

          ! The mass at (i)   is distributed into these two shells
          vol_outer_shell = fourthirdspi * halfdr * ( rc**2 + rlo*rc + rlo**2)
          vol_upper_shell = fourthirdspi * halfdr * ( rc**2 + rhi*rc + rhi**2)
          vol_total_i     = vol_outer_shell + vol_upper_shell

          mass_encl = mass_encl + (vol_inner_shell/vol_total_im1) * mass(i-1) + &
               (vol_outer_shell/vol_total_i  ) * mass(i  )

       else

          ! The mass at (i-1) is distributed into these two shells
          vol_lower_shell = vol_outer_shell   ! This copies from the previous i
          vol_inner_shell = vol_upper_shell   ! This copies from the previous i
          vol_total_im1   = vol_total_i       ! This copies from the previous i

          ! The mass at (i)   is distributed into these two shells
          vol_outer_shell = fourthirdspi * halfdr * ( rc**2 + rlo*rc + rlo**2)
          vol_upper_shell = fourthirdspi * halfdr * ( rc**2 + rhi*rc + rhi**2)
          vol_total_i     = vol_outer_shell + vol_upper_shell

          mass_encl = mass_encl + vol_inner_shell*den(i-1) + vol_outer_shell*den(i  )
       end if

       grav(i) = -Gconst * mass_encl / rc**2
       !        print *,'GRAV MASS ',rc, mass_encl

    enddo

  end subroutine ca_integrate_grav

  ! ::
  ! :: ----------------------------------------------------------
  ! ::

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Integrates radial mass elements of a spherically symmetric
  ! mass distribution to calculate both the gravitational acceleration,
  ! grav, and the gravitational potential, phi. Here the mass variable
  ! gives the mass contained in each radial shell.
  !
  ! The convention in Castro for Poisson's equation is
  !
  !     laplacian(phi) = 4*pi*G*rho
  !
  ! The gravitational acceleration is then
  !
  !     g(r) = -G*M(r) / r**2
  !
  ! where M(r) is the mass interior to radius r.
  !
  ! The strategy for calculating the potential is to calculate the potential
  ! at the boundary assuming all the mass is enclosed:
  !
  !     phi(R) = -G * M / R
  !
  ! Then, the potential in all other zones can be found using
  !
  !     d(phi)/dr = g    ==>    phi(r < R) = phi(R) - int(g * dr)
  !
  ! Inputs: mass, grav, dr, numpts_1d
  ! Outputs: phi
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine ca_integrate_phi (mass,grav,phi,dr,numpts_1d) &
                               bind(C, name="ca_integrate_phi")

    use fundamental_constants_module, only : Gconst

    use amrex_fort_module, only : rt => amrex_real
    implicit none
    integer , intent(in   ) :: numpts_1d
    real(rt), intent(in   ) :: mass(0:numpts_1d-1)
    real(rt), intent(inout) :: grav(0:numpts_1d-1)
    real(rt), intent(inout) :: phi(0:numpts_1d-1)
    real(rt), intent(in   ) :: dr

    real(rt)         :: gravBC, phiBC
    integer          :: i
    real(rt)         :: mass_encl,rhi

    mass_encl = 0.e0_rt
    grav(0)   = 0.e0_rt
    do i = 1,numpts_1d-1
       rhi = dble(i) * dr
       mass_encl = mass_encl + mass(i-1)
       grav(i) = -Gconst * mass_encl / rhi**2
    enddo

    mass_encl = mass_encl + mass(numpts_1d-1)
    phiBC = -Gconst * mass_encl / (numpts_1d*dr)
    gravBC = -Gconst * mass_encl / (numpts_1d*dr)**2
    phi(numpts_1d-1) = phiBC + gravBC * dr

    do i = numpts_1d-2,0,-1
       phi(i) = phi(i+1) + grav(i+1) * dr
    enddo

  end subroutine ca_integrate_phi

  ! ::
  ! :: ----------------------------------------------------------
  ! ::

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Same as ca_integrate_grav above, but includes general relativistic effects.
  ! Inputs: rho, mass, pressure, dr, numpts_1d
  ! Outputs: grav
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine ca_integrate_gr_grav (rho,mass,pres,grav,dr,numpts_1d) &
       bind(C, name="ca_integrate_gr_grav")

    use fundamental_constants_module, only : Gconst, c_light
    use amrex_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none
    integer , intent(in   ) :: numpts_1d
    real(rt), intent(in   ) ::  rho(0:numpts_1d-1)
    real(rt), intent(in   ) :: mass(0:numpts_1d-1)
    real(rt), intent(in   ) :: pres(0:numpts_1d-1)
    real(rt), intent(inout) :: grav(0:numpts_1d-1)
    real(rt), intent(in   ):: dr

    integer          :: i
    real(rt)         :: mass_encl,rc,rlo,rhi,halfdr
    real(rt)         :: ga, gb, gc, P,R
    real(rt)         :: vol_inner_shell, vol_outer_shell
    real(rt)         :: vol_lower_shell, vol_upper_shell
    real(rt)         :: vol_total_im1, vol_total_i

    real(rt)        , parameter ::  fourpi       = 4.e0_rt * M_PI
    real(rt)        , parameter ::  fourthirdspi = 4.e0_rt * M_PI / 3.e0_rt
    real(rt)        , parameter ::  sqvc         = c_light**2

    halfdr = 0.5e0_rt * dr

    mass_encl = 0.e0_rt
    do i = 0,numpts_1d-1
       rlo = (dble(i)      ) * dr
       rc  = (dble(i)+0.5e0_rt) * dr
       rhi = (dble(i)+1.0e0_rt) * dr

       if (i.eq.0) then

          ! The mass at (i) is distributed into these two regions
          vol_outer_shell = fourthirdspi * rc**3
          vol_upper_shell = fourthirdspi * (rhi**3 - rc**3)
          vol_total_i     = vol_outer_shell + vol_upper_shell

          mass_encl = vol_outer_shell * mass(i)  / vol_total_i

       else

          ! The mass at (i-1) is distributed into these two shells
          vol_lower_shell = vol_outer_shell   ! This copies from the previous i
          vol_inner_shell = vol_upper_shell   ! This copies from the previous i
          vol_total_im1   = vol_total_i       ! This copies from the previous i

          ! The mass at (i)   is distributed into these two shells
          vol_outer_shell = fourthirdspi * halfdr * ( rc**2 + rlo*rc + rlo**2)
          vol_upper_shell = fourthirdspi * halfdr * ( rc**2 + rhi*rc + rhi**2)
          vol_total_i     = vol_outer_shell + vol_upper_shell

          mass_encl = mass_encl + vol_inner_shell / vol_total_im1 * mass(i-1) + &
               vol_outer_shell / vol_total_i   * mass(i  )
       end if
       grav(i) = -Gconst * mass_encl / rc**2

       !!       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       !!       This adds the post-Newtonian correction
       !!       Added by Ken Chen, 6/9 2010
       !!       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

       !!       Tolman-Oppenheimer-Volkoff(TOV) case

       if (rho(i) .gt. 0.e0_rt) then
          P =  pres(i)
          R =  rho(i)
          ga = (1.e0_rt + P/(R*sqvc))
          gb = (1.e0_rt + fourpi * rc**3 * P / (mass_encl*sqvc))
          gc = 1.e0_rt / (1.e0_rt - 2.e0_rt * Gconst * mass_encl / (rc*sqvc))

          print *, i, grav(i), ga, gb, gc

          grav(i) = grav(i)*ga*gb*gc
       end if

       !!       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       !!       This ends the post-Newtonian correction
       !!       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    enddo

  end subroutine ca_integrate_gr_grav

  ! ::
  ! :: ----------------------------------------------------------
  ! ::

  subroutine init_multipole_gravity(lnum, lo_bc, hi_bc) bind(C,name="init_multipole_gravity")

    use amrex_constants_module
    use prob_params_module, only: coord_type, Symmetry, problo, probhi, center, dim

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: lnum, lo_bc(3), hi_bc(3)

    integer :: b, l, m

    ! If any of the boundaries are symmetric, we need to account for the mass that is assumed
    ! to lie on the opposite side of the symmetric axis. If the center in any direction
    ! coincides with the boundary, then we can simply double the mass as a result of that reflection.
    ! Otherwise, we need to do a more general solve. We include a logical that is set to true
    ! if any boundary is symmetric, so that we can avoid unnecessary function calls.

    volumeFactor = ONE
    parityFactor = ONE

    doSymmetricAddLo(:) = .false.
    doSymmetricAddHi(:) = .false.

    doSymmetricAdd      = .false.

    doReflectionLo(:)   = .false.
    doReflectionHi(:)   = .false.

    do b = 1, 3

       if ( (lo_bc(b) .eq. Symmetry) .and. (coord_type .eq. 0) ) then
          if ( abs(center(b) - problo(b)) < edgeTolerance ) then
             volumeFactor = volumeFactor * TWO
             doReflectionLo(b) = .true.
          else
             doSymmetricAddLo(b) = .true.
             doSymmetricAdd      = .true.
          endif
       endif

       if ( (hi_bc(b) .eq. Symmetry) .and. (coord_type .eq. 0) ) then
          if ( abs(center(b) - probhi(b)) < edgeTolerance ) then
             volumeFactor = volumeFactor * TWO
             doReflectionHi(b) = .true.
          else
             doSymmetricAddHi(b) = .true.
             doSymmetricAdd      = .true.
          endif
       endif

    enddo

    ! Compute pre-factors now to save computation time, for qC and qS

    lnum_max = lnum

    allocate(factArray(0:lnum_max, 0:lnum_max))
    allocate(parity_q0(0:lnum_max))
    allocate(parity_qC_qS(0:lnum_max, 0:lnum_max))

    factArray(:,:) = ZERO
    parity_q0 = ONE
    parity_qC_qS = ONE

    do l = 0, lnum_max

       ! The odd l Legendre polynomials are odd in their argument, so
       ! a symmetric reflection about the z axis leads to a total cancellation.

       parity_q0(l) = ONE

       if ( MODULO(l,2) /= 0 ) then
          if ( dim .eq. 3 .and. ( doReflectionLo(3) .or. doReflectionHi(3) ) ) then
             parity_q0(l) = ZERO
          else if ( dim .eq. 2 .and. coord_type .eq. 1 ) then
             parity_q0(l) = ZERO
          endif
       endif

       do m = 1, l

          ! The parity properties of the associated Legendre polynomials are:
          ! P_l^m (-x) = (-1)^(l+m) P_l^m (x)
          ! Therefore, a complete cancellation occurs if l+m is odd and
          ! we are reflecting about the z axis.

          ! Additionally, the cosine and sine terms flip sign when reflected
          ! about the x or y axis, so if we have a reflection about x or y
          ! then the terms have a complete cancellation.

          if (dim .eq. 3) then
             parity_qC_qS(l,m) = ONE
          else if (dim .eq. 2 .and. coord_type .eq. 1) then
             parity_qC_qS(l,m) = ZERO
          endif

          if ( MODULO(l+m,2) /= 0 .and. ( doReflectionLo(3) .or. doReflectionHi(3) ) ) then
             parity_qC_qS(l,m) = ZERO
          endif

          if ( doReflectionLo(1) .or. doReflectionLo(2) .or. doReflectionHi(1) .or. doReflectionHi(2) ) then
             parity_qC_qS(l,m) = ZERO
          endif

          factArray(l,m) = TWO * factorial(l-m) / factorial(l+m) * volumeFactor

       enddo

    enddo

    ! Now let's take care of a safety issue. The multipole calculation involves taking powers of r^l,
    ! which can overflow the real(rt)         exponent limit if lnum is very large. Therefore,
    ! we will normalize all distances to the maximum possible physical distance from the center,
    ! which is the diagonal from the center to the edge of the box. Then r^l will always be
    ! less than or equal to one. For large enough lnum, this may still result in roundoff
    ! errors that don't make your answer any more precise, but at least it avoids
    ! possible NaN issues from having numbers that are too large for real(rt)        .
    ! We will put the rmax factor back in at the end of ca_put_multipole_phi.

    rmax = HALF * maxval(probhi(1:dim) - problo(1:dim)) * sqrt(dble(dim))

  end subroutine init_multipole_gravity

  subroutine ca_put_multipole_phi (lo,hi,domlo,domhi,dx, &
                                   phi,p_lo,p_hi, &
                                   lnum,qL0,qLC,qLS,qU0,qUC,qUS, &
                                   npts,boundary_only) &
                                   bind(C, name="ca_put_multipole_phi")

    use prob_params_module, only: problo, center, dim, coord_type
    use fundamental_constants_module, only: Gconst
    use amrex_constants_module
    use amrex_fort_module, only : rt => amrex_real

    implicit none

    integer , intent(in   ) :: lo(3), hi(3)
    integer , intent(in   ) :: domlo(3), domhi(3)
    real(rt), intent(in   ) :: dx(3)

    integer , intent(in   ) :: lnum, npts, boundary_only
    real(rt), intent(in   ) :: qL0(0:lnum,0:npts-1), qLC(0:lnum,0:lnum,0:npts-1), qLS(0:lnum,0:lnum,0:npts-1)
    real(rt), intent(in   ) :: qU0(0:lnum,0:npts-1), qUC(0:lnum,0:lnum,0:npts-1), qUS(0:lnum,0:lnum,0:npts-1)

    integer , intent(in   ) :: p_lo(3), p_hi(3)
    real(rt), intent(inout) :: phi(p_lo(1):p_hi(1),p_lo(2):p_hi(2),p_lo(3):p_hi(3))

    integer          :: i, j, k
    integer          :: l, m, n, nlo
    real(rt)         :: x, y, z, r, cosTheta, phiAngle
    real(rt)         :: legPolyArr(0:lnum), assocLegPolyArr(0:lnum,0:lnum)
    real(rt)         :: r_L, r_U

    ! If we're using this to construct boundary values, then only use
    ! the outermost bin.

    if (boundary_only .eq. 1) then
       nlo = npts-1
    else
       nlo = 0
    endif

    if (lnum > lnum_max) then
       call amrex_error("Error: ca_compute_multipole_moments: requested more multipole moments than we allocated data for.")
    endif

    do k = lo(3), hi(3)
       if (k .gt. domhi(3)) then
          z = problo(3) + (dble(k  )     ) * dx(3) - center(3)
       else if (k .lt. domlo(3)) then
          z = problo(3) + (dble(k+1)     ) * dx(3) - center(3)
       else
          z = problo(3) + (dble(k  )+HALF) * dx(3) - center(3)
       end if

       z = z / rmax

       do j = lo(2), hi(2)
          if (j .gt. domhi(2)) then
             y = problo(2) + (dble(j  )     ) * dx(2) - center(2)
          else if (j .lt. domlo(2)) then
             y = problo(2) + (dble(j+1)     ) * dx(2) - center(2)
          else
             y = problo(2) + (dble(j  )+HALF) * dx(2) - center(2)
          end if

          y = y / rmax

          do i = lo(1), hi(1)
             if (i .gt. domhi(1)) then
                x = problo(1) + (dble(i  )     ) * dx(1) - center(1)
             else if (i .lt. domlo(1)) then
                x = problo(1) + (dble(i+1)     ) * dx(1) - center(1)
             else
                x = problo(1) + (dble(i  )+HALF) * dx(1) - center(1)
             end if

             x = x / rmax

             ! Only adjust ghost zones here

             if ( i .lt. domlo(1) .or. i .gt. domhi(1) .or. &
                  j .lt. domlo(2) .or. j .gt. domhi(2) .or. &
                  k .lt. domlo(3) .or. k .gt. domhi(3) ) then

                ! There are some cases where r == 0. This might occur, for example,
                ! when we have symmetric BCs and our corner is at one edge.
                ! In this case, we'll set phi to zero for safety, to avoid NaN issues.
                ! These cells should not be accessed anyway during the gravity solve.

                r = sqrt( x**2 + y**2 + z**2 )

                if ( r < 1.0e-12_rt ) then
                   phi(i,j,k) = ZERO
                   cycle
                endif

                if (dim .eq. 3) then
                   cosTheta = z / r
                   phiAngle = atan2(y,x)
                else if (dim .eq. 2 .and. coord_type .eq. 1) then
                   cosTheta = y / r
                   phiAngle = ZERO
                endif

                phi(i,j,k) = ZERO

                ! First, calculate the Legendre polynomials.

                legPolyArr(:) = ZERO
                assocLegPolyArr(:,:) = ZERO

                call fill_legendre_arrays(legPolyArr, assocLegPolyArr, cosTheta, lnum)

                ! We want to undo the volume scaling; tack that onto the polynomial arrays.

                legPolyArr = legPolyArr * rmax**3
                assocLegPolyArr = assocLegPolyArr * rmax**3

                ! Now compute the potentials on the ghost cells.

                do n = nlo, npts-1

                   do l = 0, lnum

                      r_L = r**dble( l  )
                      r_U = r**dble(-l-1)

                      phi(i,j,k) = phi(i,j,k) + qL0(l,n) * legPolyArr(l) * r_U

                      do m = 1, l

                         phi(i,j,k) = phi(i,j,k) + (qLC(l,m,n) * cos(m * phiAngle) + qLS(l,m,n) * sin(m * phiAngle)) * &
                                      assocLegPolyArr(l,m) * r_U

                      enddo

                   enddo

                enddo

                phi(i,j,k) = -Gconst * phi(i,j,k) / rmax

             endif

          enddo
       enddo
    enddo

  end subroutine ca_put_multipole_phi

  subroutine ca_compute_multipole_moments (lo,hi,domlo,domhi, &
                                           dx,rho,r_lo,r_hi, &
                                           vol,v_lo,v_hi, &
                                           lnum,qL0,qLC,qLS,qU0,qUC,qUS, &
                                           npts,boundary_only) &
                                           bind(C, name="ca_compute_multipole_moments")

    use prob_params_module, only: problo, center, probhi, dim, coord_type
    use amrex_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer , intent(in   ) :: lo(3),hi(3)
    integer , intent(in   ) :: domlo(3),domhi(3)
    real(rt), intent(in   ) :: dx(3)
    integer , intent(in   ) :: boundary_only, npts, lnum

    real(rt), intent(inout) :: qL0(0:lnum,0:npts-1), qLC(0:lnum,0:lnum,0:npts-1), qLS(0:lnum,0:lnum,0:npts-1)
    real(rt), intent(inout) :: qU0(0:lnum,0:npts-1), qUC(0:lnum,0:lnum,0:npts-1), qUS(0:lnum,0:lnum,0:npts-1)

    integer          :: r_lo(3), r_hi(3)
    integer          :: v_lo(3), v_hi(3)
    real(rt)         :: rho(r_lo(1):r_hi(1),r_lo(2):r_hi(2),r_lo(3):r_hi(3))
    real(rt)         :: vol(v_lo(1):v_hi(1),v_lo(2):v_hi(2),v_lo(3):v_hi(3))

    integer          :: i, j, k
    integer          :: nlo, index

    real(rt)         :: x, y, z, r, drInv, cosTheta, phiAngle

    ! If we're using this to construct boundary values, then only fill
    ! the outermost bin.

    if (boundary_only .eq. 1) then
       nlo = npts-1
    else
       nlo = 0
    endif

    ! Note that we don't currently support dx != dy != dz, so this is acceptable.

    drInv = rmax / dx(1)

    ! Sanity check

    if (lnum > lnum_max) then
       call amrex_error("Error: ca_compute_multipole_moments: requested more multipole moments than we allocated data for.")
    endif

    do k = lo(3), hi(3)
       z = ( problo(3) + (dble(k)+HALF) * dx(3) - center(3) ) / rmax

       do j = lo(2), hi(2)
          y = ( problo(2) + (dble(j)+HALF) * dx(2) - center(2) ) / rmax

          do i = lo(1), hi(1)
             x = ( problo(1) + (dble(i)+HALF) * dx(1) - center(1) ) / rmax

             r = sqrt( x**2 + y**2 + z**2 )

             if (dim .eq. 3) then
                index = int(r * drInv)
                cosTheta = z / r
                phiAngle = atan2(y, x)
             else if (dim .eq. 2 .and. coord_type .eq. 1) then
                index = nlo ! We only do the boundary potential in 2D.
                cosTheta = y / r
                phiAngle = z
             endif

             ! Now, compute the multipole moments.

             call multipole_add(cosTheta, phiAngle, r, rho(i,j,k), vol(i,j,k) / rmax**3, &
                                qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index, .true.)

             ! Now add in contributions if we have any symmetric boundaries in 3D.
             ! The symmetric boundary in 2D axisymmetric is handled separately.

             if ( doSymmetricAdd ) then

                call multipole_symmetric_add(doSymmetricAddLo, doSymmetricAddHi, &
                                             x, y, z, problo, probhi, &
                                             rho(i,j,k), vol(i,j,k) / rmax**3, &
                                             qL0, qLC, qLS, qU0, qUC, qUS, &
                                             lnum, npts, nlo, index)

             endif

          enddo
       enddo
    enddo

  end subroutine ca_compute_multipole_moments

  function factorial(n)

    use amrex_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: n, i
    real(rt)         :: factorial

    factorial = ONE

    do i = 2, n
       factorial = factorial * dble(i)
    enddo

  end function factorial

  subroutine fill_legendre_arrays(legPolyArr, assocLegPolyArr, x, lnum)

    use amrex_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lnum
    integer :: l, m, n
    real(rt)         :: x
    real(rt)         :: legPolyArr(0:lnum), assocLegPolyArr(0:lnum,0:lnum)

    legPolyArr(:)        = ZERO
    assocLegPolyArr(:,:) = ZERO

    ! First we'll do the associated Legendre polynomials. There are a number of
    ! recurrence relations, but many are unstable. We'll use one that is known
    ! to be stable for the reasonably low values of l we care about in a simulation:
    ! (l-m)P_l^m(x) = x(2l-1)P_{l-1}^m(x) - (l+m-1)P_{l-2}^m(x).
    ! This uses the following two expressions as initial conditions:
    ! P_m^m(x) = (-1)^m (2m-1)!! (1-x^2)^(m/2)
    ! P_{m+1}^m(x) = x (2m+1) P_m^m (x)

    do m = 1, lnum

       ! P_m^m

       assocLegPolyArr(m,m) = (-1)**m * ( (ONE - x) * (ONE + x) )**(dble(m)/TWO)

       ! Multiply by the double factorial term

       do n = (2*m-1), 3, -2

          assocLegPolyArr(m,m) = assocLegPolyArr(m,m) * n

       enddo

       ! P_{m+1}^m
       ! We need to be careful at m = lnum, because we could reference a non-existent array subscript.

       if ( m < lnum ) then

          assocLegPolyArr(m+1,m) = x * (2*m + 1) * assocLegPolyArr(m,m)

       endif

       ! All other l
       ! The loop will automatically be avoided if we're close to lnum here.

       do l = m+2, lnum

          assocLegPolyArr(l,m) = (x * (2*l - 1) * assocLegPolyArr(l-1,m) - (l + m - 1) * assocLegPolyArr(l-2,m) ) / (l-m)

       enddo

    enddo

    ! Now we'll do the normal Legendre polynomials. We use a stable recurrence relation:
    ! (l+1) P_{l+1}(x) = (2l+1) x P_l(x) - l P_{l-1}(x). This uses initial conditions:
    ! P_0(x) = 1
    ! P_1(x) = x

    do l = 0, lnum

       if ( l == 0 ) then

          legPolyArr(0) = ONE

       elseif ( l == 1 ) then

          legPolyArr(1) = x

       else

          legPolyArr(l) = ( (2*l - 1) * x * legPolyArr(l-1) - (l-1) * legPolyArr(l-2) ) / l

       endif

    enddo

  end subroutine fill_legendre_arrays

  subroutine multipole_symmetric_add(doSymmetricAddLo, doSymmetricAddHi, &
                                     x, y, z, problo, probhi, &
                                     rho, vol, &
                                     qU0, qUC, qUS, qL0, qLC, qLS, &
                                     lnum, npts, nlo, index)

    use prob_params_module, only: center
    use amrex_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer,          intent(in) :: lnum, npts, nlo, index
    real(rt)        , intent(in) :: x, y, z
    real(rt)        , intent(in) :: problo(3), probhi(3)
    real(rt)        , intent(in) :: rho, vol

    logical,          intent(in) :: doSymmetricAddLo(3), doSymmetricAddHi(3)

    real(rt)        , intent(inout) :: qL0(0:lnum,0:npts-1)
    real(rt)        , intent(inout) :: qLC(0:lnum,0:lnum,0:npts-1), qLS(0:lnum,0:lnum,0:npts-1)

    real(rt)        , intent(inout) :: qU0(0:lnum,0:npts-1)
    real(rt)        , intent(inout) :: qUC(0:lnum,0:lnum,0:npts-1), qUS(0:lnum,0:lnum,0:npts-1)

    real(rt)         :: cosTheta, phiAngle, r
    real(rt)         :: xLo, yLo, zLo, xHi, yHi, zHi

    xLo = ( TWO * (problo(1) - center(1)) ) / rmax - x
    xHi = ( TWO * (probhi(1) - center(1)) ) / rmax - x

    yLo = ( TWO * (problo(2) - center(2)) ) / rmax - y
    yHi = ( TWO * (probhi(2) - center(2)) ) / rmax - y

    zLo = ( TWO * (problo(3) - center(3)) ) / rmax - z
    zHi = ( TWO * (probhi(3) - center(3)) ) / rmax - z

    if ( doSymmetricAddLo(1) ) then

       r        = sqrt( xLo**2 + y**2 + z**2 )
       phiAngle = atan2(y, xLo)
       cosTheta = z / r

       call multipole_add(cosTheta, phiAngle, r, rho, vol, qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index)

       if ( doSymmetricAddLo(2) ) then

          r        = sqrt( xLo**2 + yLo**2 + z**2 )
          phiAngle = atan2(yLo, xLo)
          cosTheta = z / r

          call multipole_add(cosTheta, phiAngle, r, rho, vol, qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index)

       endif

       if ( doSymmetricAddLo(3) ) then

          r        = sqrt( xLo**2 + y**2 + zLo**2 )
          phiAngle = atan2(y, xLo)
          cosTheta = zLo / r

          call multipole_add(cosTheta, phiAngle, r, rho, vol, qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index)

       endif

       if ( doSymmetricAddLo(2) .and. doSymmetricAddLo(3) ) then

          r        = sqrt( xLo**2 + yLo**2 + zLo**2 )
          phiAngle = atan2(yLo, xLo)
          cosTheta = zLo / r

          call multipole_add(cosTheta, phiAngle, r, rho, vol, qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index)

       endif

    endif

    if ( doSymmetricAddLo(2) ) then

       r        = sqrt( x**2 + yLo**2 + z**2 )
       phiAngle = atan2(yLo, x)
       cosTheta = z / r

       call multipole_add(cosTheta, phiAngle, r, rho, vol, qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index)

       if ( doSymmetricAddLo(3) ) then

          r        = sqrt( x**2 + yLo**2 + zLo**2 )
          phiAngle = atan2(yLo, x)
          cosTheta = zLo / r

          call multipole_add(cosTheta, phiAngle, r, rho, vol, qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index)

       endif

    endif

    if ( doSymmetricAddLo(3) ) then

       r        = sqrt( x**2 + y**2 + zLo**2 )
       phiAngle = atan2(y, x)
       cosTheta = zLo / r

       call multipole_add(cosTheta, phiAngle, r, rho, vol, qL0, qLC, qLS, qU0, qUC, qUS, lnum, npts, nlo, index)

    endif

  end subroutine multipole_symmetric_add

  subroutine multipole_add(cosTheta, phiAngle, r, rho, vol, &
                           qL0, qLC, qLS, qU0, qUC, qUS, &
                           lnum, npts, nlo, index, do_parity)

    use amrex_constants_module, only: ONE

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer,          intent(in)    :: lnum, npts, nlo, index
    real(rt)        , intent(in)    :: cosTheta, phiAngle, r, rho, vol

    real(rt)        , intent(inout) :: qL0(0:lnum,0:npts-1), qLC(0:lnum,0:lnum,0:npts-1), qLS(0:lnum,0:lnum,0:npts-1)
    real(rt)        , intent(inout) :: qU0(0:lnum,0:npts-1), qUC(0:lnum,0:lnum,0:npts-1), qUS(0:lnum,0:lnum,0:npts-1)

    logical, optional, intent(in)   :: do_parity

    integer :: l, m, n

    real(rt)         :: legPolyArr(0:lnum), assocLegPolyArr(0:lnum,0:lnum)

    real(rt)         :: rho_r_L, rho_r_U

    real(rt)         :: p0(0:lnum), pCS(0:lnum,0:lnum)

    call fill_legendre_arrays(legPolyArr, assocLegPolyArr, cosTheta, lnum)

    ! Absorb factorial terms into associated Legendre polynomials

    assocLegPolyArr = assocLegPolyArr * factArray

    p0 = ONE
    pCS = ONE

    if (present(do_parity)) then
       if (do_parity) then
          p0 = parity_q0
          pCS = parity_qC_qS
       endif
    endif

    do n = nlo, npts-1

       do l = 0, lnum

          rho_r_L = rho * (r ** dble( l  ))
          rho_r_U = rho * (r ** dble(-l-1))

          if (index .le. n) then
             qL0(l,n) = qL0(l,n) + legPolyArr(l) * rho_r_L * vol * volumeFactor * p0(l)
          else
             qU0(l,n) = qU0(l,n) + legPolyArr(l) * rho_r_U * vol * volumeFactor * p0(l)
          endif

          do m = 1, l

             if (index .le. n) then
                qLC(l,m,n) = qLC(l,m,n) + assocLegPolyArr(l,m) * cos(m * phiAngle) * rho_r_L * vol * pCS(l,m)
                qLS(l,m,n) = qLS(l,m,n) + assocLegPolyArr(l,m) * sin(m * phiAngle) * rho_r_L * vol * pCS(l,m)
             else
                qUC(l,m,n) = qUC(l,m,n) + assocLegPolyArr(l,m) * cos(m * phiAngle) * rho_r_U * vol * pCS(l,m)
                qUS(l,m,n) = qUS(l,m,n) + assocLegPolyArr(l,m) * sin(m * phiAngle) * rho_r_U * vol * pCS(l,m)
             endif

          enddo

       enddo

    enddo

  end subroutine multipole_add

end module gravity_module


      subroutine quantum_potential(m1,x,w,Ntraj,qp,qfx,c)
      implicit real*8(a-h,o-z)
      integer*4,intent(IN) :: Ntraj

      integer INFO
      integer, parameter :: nb=3
      real*8,intent(IN) :: m1
      real*8,intent(IN) :: w(Ntraj),x(Ntraj)
      real*8, intent(OUT) :: qfx(Ntraj),qp(Ntraj),c(nb,1)
      real*8 :: f(nb),rx(Ntraj)
      real*8 ::  s(nb,nb),dr(ntraj)

! define c matrix = -1/2*df/dx
      c(1,1) =-0.5d0
      c(2,1) = 0d0
c      c(3,1) = 0d0

      do i=1,ntraj
        c(2,1) = c(2,1)+w(i)*2d0*x(i)
c        c(3,1) = c(3,1)+w(i)*3d0*x(i)**2
      enddo

      c(2,1) = -0.5d0*c(2,1)
c      c(3,1) = -0.5d0*c(3,1)
c      c(4,1) = 0d0

!     f*transpose(f) matrix
      s=0d0
      do i=1,Ntraj
      f=(/x(i),x(i)**2,1d0/)
        do m=1,nb
          do n=1,nb
            s(m,n)=w(i)*f(m)*f(n)+s(m,n)
          end do
        end do
      end do

! calculate matrix c(t)
        call DPOSV('U',nb,1,s,nb,c,nb,INFO)
        if(INFO/=0) then
        print *, "info=",info
        print *, "matrix fails"
        stop
        end if

! the momentum operator r=cf
      ams = -1d0/2d0/m1
      do i=1,Ntraj
        rx(i) = c(1,1)*x(i)+c(2,1)*x(i)**2+c(3,1)

! calculate quantum potential
        dr(i) = c(1,1)+2d0*c(2,1)*x(i)
        qp(i)=ams*(rx(i)**2+dr(i))
        qfx(i)=-ams*(2d0*rx(i)*dr(i)+2d0*c(2,1))
      end do

      return
      end subroutine


!==============================================================================!
  subroutine CalcVISt_RSM(grid)
!------------------------------------------------------------------------------!
!   Computes the turbulent viscosity for RSM models (EBM and HJ).              !
!   If hybrid option is used turbulent diffusivity is modeled by VISt.         !
!   Otherwise, VISt is used as false diffusion in order to increase            !
!   stability of computation.                                                  !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use pro_mod
  use les_mod
  use rans_mod
  use Grid_Mod
  use Parameters_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer :: c
  real    :: Cmu_mod
!==============================================================================!

  call Compute_Shear_And_Vorticity(grid)

  if(SIMULA == HJ) then
    do c=1, grid % n_cells
      Kin % n(c) = 0.5*max(uu%n(c)+vv%n(c)+ww%n(c),1.0e-12)

      Cmu_mod = max(-(  uu % n(c) * u % x(c)  &
                      + vv % n(c) * v % y(c)  &
                      + ww % n(c) * w % z(c)  &
                      + uv % n(c) * (v % x(c) + u % y(c))  &
                      + uw % n(c) * (u % z(c) + w % x(c))  &
                      + vw % n(c) * (v % z(c) + w % y(c))) &
               / max(Kin % n(c)**2 / Eps_tot(c) * Shear(c)**2, 1.0e-12), 0.0)

      Cmu_mod = min(0.12,Cmu_mod)
      VISt(c) = Cmu_mod * DENc(material(c)) * Kin % n(c)**2 / Eps_tot(c)
    end do
  else if(SIMULA==EBM) then
    do c=1, grid % n_cells
      Kin % n(c) = 0.5*max(uu%n(c)+vv%n(c)+ww%n(c),1.0e-12)

      Cmu_mod = max(-(  uu % n(c) * u % x(c)  &
                      + vv % n(c) * v % y(c)  &
                      + ww % n(c) * w % z(c)  &
                      + uv % n(c) * (v % x(c) + u % y(c))  &
                      + uw % n(c) * (u % z(c) + w % x(c))  &
                      + vw % n(c) * (v % z(c) + w % y(c))) &
               / max(Kin % n(c)**2 / Eps % n(c) * Shear(c)**2, 1.0e-12), 0.0)

      Cmu_mod = min(0.12,Cmu_mod)
      VISt(c) = Cmu_mod*DENc(material(c)) * Kin%n(c) * Kin%n(c) / Eps % n(c)
    end do
  end if

  call Exchange(grid, VISt)

  end subroutine


module vegetables_assert_equals_within_absolute_m
    use iso_varying_string, only: varying_string, var_str
    use strff, only: to_string
    use vegetables_messages_m, only: &
            make_within_failure_message, &
            make_within_success_message, &
            with_user_message
    use vegetables_result_m, only: result_t, fail, succeed
    use vegetables_utilities_m, only: equals_within_absolute

    implicit none
    private
    public :: assert_equals_within_absolute

    interface assert_equals_within_absolute
        module procedure assert_equals_within_absolute_basic
        module procedure assert_equals_within_absolute_with_message_c
        module procedure assert_equals_within_absolute_with_message_s
        module procedure assert_equals_within_absolute_with_messages_cc
        module procedure assert_equals_within_absolute_with_messages_cs
        module procedure assert_equals_within_absolute_with_messages_sc
        module procedure assert_equals_within_absolute_with_messages_ss
    end interface
contains
    pure function assert_equals_within_absolute_basic( &
            expected, &
            actual, &
            tolerance) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(result_t) :: result__

        result__ = assert_equals_within_absolute( &
                expected, &
                actual, &
                tolerance, &
                var_str(""), &
                var_str(""))
    end function

    pure function assert_equals_within_absolute_with_message_c( &
            expected, &
            actual, &
            tolerance, &
            message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        character(len=*), intent(in) :: message
        type(result_t) :: result__

        result__ = assert_equals_within_absolute( &
                expected, &
                actual, &
                tolerance, &
                var_str(message), &
                var_str(message))
    end function

    pure function assert_equals_within_absolute_with_message_s( &
            expected, &
            actual, &
            tolerance, &
            message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(varying_string), intent(in) :: message
        type(result_t) :: result__

        result__ = assert_equals_within_absolute( &
                expected, &
                actual, &
                tolerance, &
                message, &
                message)
    end function

    pure function assert_equals_within_absolute_with_messages_cc( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        character(len=*), intent(in) :: success_message
        character(len=*), intent(in) :: failure_message
        type(result_t) :: result__

        result__ = assert_equals_within_absolute( &
                expected, &
                actual, &
                tolerance, &
                var_str(success_message), &
                var_str(failure_message))
    end function

    pure function assert_equals_within_absolute_with_messages_cs( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        character(len=*), intent(in) :: success_message
        type(varying_string), intent(in) :: failure_message
        type(result_t) :: result__

        result__ = assert_equals_within_absolute( &
                expected, &
                actual, &
                tolerance, &
                var_str(success_message), &
                failure_message)
    end function

    pure function assert_equals_within_absolute_with_messages_sc( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(varying_string), intent(in) :: success_message
        character(len=*), intent(in) :: failure_message
        type(result_t) :: result__

        result__ = assert_equals_within_absolute( &
                expected, &
                actual, &
                tolerance, &
                success_message, &
                var_str(failure_message))
    end function

    pure function assert_equals_within_absolute_with_messages_ss( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(varying_string), intent(in) :: success_message
        type(varying_string), intent(in) :: failure_message
        type(result_t) :: result__

        if (equals_within_absolute(expected, actual, tolerance)) then
            result__ = succeed(with_user_message( &
                    make_within_success_message( &
                            to_string(expected), &
                            to_string(actual), &
                            to_string(tolerance)), &
                    success_message))
        else
            result__ = fail(with_user_message( &
                    make_within_failure_message( &
                            to_string(expected), &
                            to_string(actual), &
                            to_string(tolerance)), &
                    failure_message))
        end if
    end function
end module


!
!===============================================================================
!-- Math Module Tests
!> Tests for math_mod module
!===============================================================================
!/****/h* modules|math/test_math_mod
!* SYNOPSIS
MODULE test_math_mod
!* PURPOSE
!*   Tests for math_mod module
!* INCLUDES
!*   math_mod
!* CONTAINS
!*   Subroutine              Purpose
!*   math_tests(cnt)
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/21: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/21
!> Tests for math_mod module
!===============================================================================

  !-----------------------------------------------------------------------------
  ! use statements and implicit none
  !-----------------------------------------------------------------------------
  USE math_mod

  IMPLICIT NONE

!===============================================================================
CONTAINS
!===============================================================================
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! /****s*/ /src/math/test_math_mod|math_test
!* SYNOPSIS
  SUBROUTINE math_tests(cnt)
!* PURPOSE
!*   tests math_mod
!* INPUTS
!*   test counter
!* OUTPUTS
!*   test counter
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/21: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/21
!> tests math_mod
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !---------------------------------------------------------------------
    ! arguments
    !---------------------------------------------------------------------
    INTEGER, INTENT(INOUT) :: cnt             !> test counter

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !---------------------------------------------------------------------
    !*   int_merge_sort_rows()   merge sort rows of integer array in ascending order
    !*   int_merge_rows()        merge rows of integer array in ascending order
    !*   int_insertion_sort()    insertion sort for integer array
    !*   any_element_in_list()   test if any element of one array is in another
    !*   num_element_in_list()   determine how many elements of one array are in another
    !---------------------------------------------------------------------

  END SUBROUTINE
! test_math_mod|math_test
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!

END MODULE
! math_test
!===============================================================================
!