C$PROCEDURE         AINVD

	SUBROUTINE  AINVD (A, IDA, N, *, WORK)

C$   PURPOSE
C%
C%      This subroutine computes the inverse of an N x N matrix, A.
C%
C$   INPUT_ARGUMENTS
C%
C%      A(IDA,>=N)     Array containing the N x N matrix, A.  Double precision.
C%
C%      IDA            The dimension of the first subscript of the array A( ).
C%                     IDA must be greater than or equal to N.  Integer.
C%
C%      N              Order of the square matrix, A.  N must be greater than
C%                     or equal to one.  Integer.
C%
C%      *m             m is the line number of the statement in the user's
C%                     program to which control is to be passed, if the matrix
C%                     is singular, or so nearly singular that it cannot be
C%                     definitely distinguished by the program from being
C%                     singular.  This line number must appear literally in the
C%                     call statement and must be prefixed by a *.  For
C%                     instance, while *20 would be acceptable, *IRETURN, where
C%                     IRETURN is a Fortran variable, would give an error.
C%
C%      WORK(>=4*N)    Temporary working space used by the subroutine.  Double
C%                     precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      The inverse matrix is returned in the array A( ).  See input arguments
C%      for further details.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           The computation is done using Householder orthonormal
C%      transformations.
C%
C$   SUBROUTINES_CALLED
C%
C%      FTSD.
C%
C$   RESTRICTIONS
C%                                                           ~
C%      Do not use the matrix inverse to solve the system, Ax=b.  That method
C%      is not the most reliable way to solve a linear system.
C%
C$   NON_STANDARD_FORTRAN
C%
C%      None.
C%
C$   EXAMPLE
C%
C%           The following program finds the inverse of a 4 x 4 matrix.
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DEMONSTRATION DRIVER FOR AINVD                                C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%              PROGRAM  DEMOAINVD
C%
C%
C%              DOUBLE PRECISION  A(4,4)
C%              DOUBLE PRECISION  W(16)
C%
C%              INTEGER  N,NDA
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C        DATA BLOCKS                                                  C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              DATA  A / 5.D0, 7.D0, 6.D0, 5.D0,
C%           *            7.D0, 10.D0, 8.D0, 7.D0,
C%           *            6.D0, 8.D0, 10.D0, 9.D0,
C%           *            5.D0, 7.D0, 9.D0, 10.D0 /
C%
C%              DATA  N / 4 /
C%              DATA  NDA / 4 /
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       HEADER                                                        C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              WRITE(6,1)
C%      1       FORMAT(///' EXAMPLE OUTPUT FOR THE AINVD SUBROUTINE:'//)
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       AINVD TESTED                                                  C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              WRITE(6,10)
C%      10      FORMAT(///' TEST OUTPUT FOR AINVD:'//)
C%
C%              CALL  DMOUT (A, NDA, N, N, 11, ' MATRIX A =')
C%              CALL  AINVD (A, NDA, N, *50, W)
C%              CALL  DMOUT (A, NDA, N, N, 18, ' INVERSE OF MATRIX')
C%
C%
C%              CALL EXIT
C%
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       MATRIX IS EITHER SINGULAR OR NEARLY SINGULAR.                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%      50      WRITE(6,230)
C%      230     FORMAT(15X,26H MATRIX IS NEARLY SINGULAR)
C%
C%
C%              CALL EXIT
C%              END
C%
C%
C%      EXAMPLE OUTPUT FOR THE AINVD SUBROUTINE:
C%
C%
C%  TEST OUTPUT FOR AINVD:
C%
C%  MATRIX A =
C%            COL   1          COL   2          COL   3          COL   4
C%  ROW 1  5.000000000D+00  7.000000000D+00  6.000000000D+00  5.000000000D+00
C%  ROW 2  7.000000000D+00  1.000000000D+01  8.000000000D+00  7.000000000D+00
C%  ROW 3  6.000000000D+00  8.000000000D+00  1.000000000D+01  9.000000000D+00
C%  ROW 4  5.000000000D+00  7.000000000D+00  9.000000000D+00  1.000000000D+01
C%
C%  INVERSE OF MATRIX
C%            COL   1          COL   2          COL   3          COL   4
C%  ROW 1  6.800000000D+01 -4.100000000D+01 -1.700000000D+01  1.000000000D+01
C%  ROW 2 -4.100000000D+01  2.500000000D+01  1.000000000D+01 -6.000000000D+00
C%  ROW 3 -1.700000000D+01  1.000000000D+01  5.000000000D+00 -3.000000000D+00
C%  ROW 4  1.000000000D+01 -6.000000000D+00 -3.000000000D+00  2.000000000D+00
C%
C%
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C	                                                                      C
C	C. L. LAWSON, JPL                                                     C
C	AUGUST 1974                                                           C
C                                                                             C
C	F. A. MCCREARY, JPL                                                   C
C	MARCH 1985                                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	INTEGER  IDA,IDB
	INTEGER  N,NB

	DOUBLE PRECISION  A(IDA,N)
	DOUBLE PRECISION  B(IDB,NB),BDUM(1,1)
	DOUBLE PRECISION  DETDUM,DETERM
	DOUBLE PRECISION  WORK(*)

	LOGICAL  WNTDET,WNTAIV,WNTSLV

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	WNTAIV:  FIND THE INVERSE.                                            C
C	WNTDET:  FIND THE DETERMINANT.                                        C
C	WNTSLV:  SOLVE THE SYSTEM.                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	WNTAIV = .TRUE.
	WNTDET = .FALSE.
	WNTSLV = .FALSE.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     								              C
C     WITH THIS ENTRY THE INVERSE OF THE N X N MATRIX IN A GETS	PLACED        C
C     INTO A ON OUTPUT, PROVIDED IT IS NON-SINGULAR.		              C
C									      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	CALL  FTSD (*30, A, IDA, N, BDUM, 1, 1, DETDUM, WNTDET,
     *              WNTAIV, WNTSLV, WORK(1), WORK(N+1), WORK(2*N+1),
     *              WORK(3*N+1))

	RETURN

C$PROCEDURE    AINVDD

	ENTRY  AINVDD (A, IDA, N, *, WORK, DETERM)

C$   PURPOSE
C%
C%      This subroutine computes the inverse and determinant of an N x N
C%      matrix, A.
C%
C$   INPUT_ARGUMENTS
C%
C%      A(IDA,>=N)     Array containing the N x N matrix, A.  Double precision.
C%
C%      IDA            The dimension of the first subscript of the array A( ).
C%                     IDA must be greater than or equal to N.  Integer.
C%
C%      N              Order of the square matrix, A.  N must be greater than
C%                     or equal to 1.  Integer.
C%
C%      *m             m is the line number of the statement in the user's
C%                     program to which control is to be passed, if the matrix
C%                     is singular, or so nearly singular that it cannot be
C%                     definitely distinguished from being singular.  The line
C%                     number must appear literally in the call statement and
C%                     must be prefixed by a *.  For instance, while *20 would
C%                     be acceptable, *IRETURN, where IRETURN is a Fortran
C%                     variable, would give an error.
C%
C%      WORK(>=4*N)    Temporary working space used by the subroutine.  Double
C%                     precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      The inverse matrix is returned in the array A( ).  See input arguments
C%      for further details.
C%
C%      DETERM        The determinant is returned in this variable.  Double
C%                    Precision.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           The computation is done using Householder orthonormal
C%      transformations.
C%
C$   SUBROUTINES_CALLED
C%
C%      FTSD.
C%
C$   RESTRICTIONS
C%                                                           ~
C%      Do not use the matrix inverse to solve the system, Ax=b.  That method
C%      is not the most reliable way to solve a linear system.
C%
C$   NON_STANDARD_FORTRAN
C%
C%      None.
C%
C$   EXAMPLE
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C      DEMONSTRATION DRIVER FOR AINVDD                                C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%             PROGRAM  DEAINVDD
C%
C%
C%             DOUBLE PRECISION  A(4,4)
C%             DOUBLE PRECISION  DETERM
C%             DOUBLE PRECISION  W(16)
C%
C%             INTEGER  N,NDA
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DATA BLOCKS                                                   C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%             DATA  A / 5.D0, 7.D0, 6.D0, 5.D0,
C%          *            7.D0, 10.D0, 8.D0, 7.D0,
C%          *            6.D0, 8.D0, 10.D0, 9.D0,
C%          *            5.D0, 7.D0, 9.D0, 10.D0 /
C%
C%             DATA  N / 4 /
C%             DATA  NDA / 4 /
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       AINVDD TESTED                                                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%             WRITE(6,100)
C%      100    FORMAT(///' TEST OUTPUT FOR AINVDD:'//)
C%
C%             CALL  DMOUT (A, NDA, N, N, 11, ' MATRIX A =')
C%             CALL  AINVDD (A, NDA, N, *50, W, DETERM)
C%             CALL  DMOUT (A, NDA, N, N, 18, ' INVERSE OF MATRIX')
C%
C%             WRITE(6,160)  DETERM
C%      160    FORMAT(/' THE DETERMINANT IS ',D20.5)
C%
C%
C%             CALL EXIT
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       MATRIX IS EITHER SINGULAR OR NEARLY SINGULAR.                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%      50     PRINT 230
C%      230    FORMAT(15X,26H MATRIX IS NEARLY SINGULAR)
C%
C%
C%             CALL EXIT
C%             END
C%
C%
C%   TEST OUTPUT FOR AINVDD:
C%
C%   MATRIX A =
C%             COL   1          COL   2           COL   3         COL   4
C%   ROW 1  5.000000000D+00  7.000000000D+00  6.000000000D+00  5.000000000D+00
C%   ROW 2  7.000000000D+00  1.000000000D+01  8.000000000D+00  7.000000000D+00
C%   ROW 3  6.000000000D+00  8.000000000D+00  1.000000000D+01  9.000000000D+00
C%   ROW 4  5.000000000D+00  7.000000000D+00  9.000000000D+00  1.000000000D+01
C%
C%   INVERSE OF MATRIX
C%             COL   1          COL   2           COL   3         COL   4
C%   ROW 1  6.800000000D+01 -4.100000000D+01 -1.700000000D+01  1.000000000D+01
C%   ROW 2 -4.100000000D+01  2.500000000D+01  1.000000000D+01 -6.000000000D+00
C%   ROW 3 -1.700000000D+01  1.000000000D+01  5.000000000D+00 -3.000000000D+00
C%   ROW 4  1.000000000D+01 -6.000000000D+00 -3.000000000D+00  2.000000000D+00
C%
C%   THE DETERMINANT IS          0.10000D+01
C%
C%
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	WNTAIV:  FIND THE INVERSE.                                            C
C	WNTDET:  FIND THE DETERMINANT.                                        C
C	WNTSLV:  SOLVE THE SYSTEM.                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	WNTAIV = .TRUE.
	WNTDET = .TRUE.
	WNTSLV = .FALSE.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     								              C
C     	WITH THIS ENTRY THE INVERSE OF THE N X N MATRIX IN A GETS PLACED      C
C	INTO A ON OUTPUT, PROVIDED IT IS NON-SINGULAR.		              C
C									      C
C	WITH THIS ENTRY THE DETERMINANT OF THE MATRIX IN A GETS PLACED INTO   C
C	THE DOUBLE PRECISION CELL DETERM ON OUTPUT.			      C
C									      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	CALL  FTSD(*30, A, IDA, N, BDUM, 1, 1, DETERM, WNTDET, WNTAIV,
     *             WNTSLV, WORK(1), WORK(N+1), WORK(2*N+1), WORK(3*N+1))

	RETURN

C$PROCEDURE    SID

	ENTRY  SID (A, IDA, N, B, IDB, NB, *, WORK)

C$   PURPOSE
C%
C%      This subroutine solves a system of linear equations and computes the
C%      inverse of the coefficient matrix.  The system has the matrix form
C%
C%              Ax = b
C%
C%      where A is the N x N coeficient matrix, x is the solution N x NB matrix
C%      and b is the N x NB matrix of known values.  In general, NB will equal
C%      one, and x and b will be N-vectors.
C%
C$   INPUT_ARGUMENTS
C%
C%      A(IDA,>=N)     Array containing the N x N coefficient matrix, A.
C%                     Double precision.
C%
C%      IDA            The dimension of the first subscript of the array A( ).
C%                     IDA must be greater than or equal to N.  Integer.
C%
C%      N              Order of the square coefficient matrix, A, and the
C%                     number of rows in the right-side matrix,b.  N is greater
C%                     than or equal to 1.  Integer.
C%
C%      B(IDB,>=NB)    Array containing the right-side NxNB matrix, b.  If NB
C%                     equals 1, the right-side array can be of the form
C%                     (B(I), I = 1,N).  Double precision.
C%
C%      IDB            The dimension of the first subscript of the array B( ).
C%                     IDB must be greater than or equal to N.  Integer.
C%
C%      NB             Number of columns in the right-side matrix, b.  NB must
C%                     be greater than or equal to 1.  Integer.
C%
C%      *m             The number m is the line number of the statement in the
C%                     user's program to which control is to be passed, if the
C%                     coefficient matrix is singular, or so nearly singular
C%                     that it cannot be definitely distinguished from being
C%                     singular.  The line number must appear literally in the
C%                     call statement and must be prefixed by a *.  For
C%                     instance, while *20 would be acceptable, *IRETURN, where
C%                     IRETURN is a Fortran variable, would give an error.
C%
C%      WORK(>=4*N)    Temporary working space used by the subroutine.  Double
C%                     precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      The inverse matrix is returned in the array A( ) and the solution
C%      vector in the array B( ).  See input arguments for further details.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           The computation is done using Householder orthonormal
C%      transformations.  Columns and rows are equilibrated before the
C%      computation and columns are interchanged during the computation, with
C%      compensating adjustments being made to the results.  The inverse of the
C%      matrix is not required to solve a system of equations.  The inverse
C%      should only be calculated, when the inverse matrix is explicitly needed
C%      at some point in the user's program.  When a matrix inverse is needed,
C%      it is recommended the programming be done in terms of solving a system
C%      of equations.
C%
C$   SUBROUTINES_CALLED
C%
C%      FTSD.
C%
C$   RESTRICTIONS
C%
C%      None.
C%
C$   NON_STANDARD_FORTRAN
C%
C%      None.
C%
C$   EXAMPLE
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DEMONSTRATION DRIVER FOR SID                                  C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%            PROGRAM  DEMOSID
C%
C%
C%            DOUBLE PRECISION  B(3,1)
C%            DOUBLE PRECISION  C(3,3)
C%            DOUBLE PRECISION  W(16)
C%
C%            INTEGER  ND,NB
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C      DATA BLOCKS                                                    C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%            DATA  B / 6.D0, 9.D0, 1.D0 /
C%
C%            DATA  NB / 1.D0 /
C%
C%            DATA  C / -3.D0, 2.D0, 1.D0,
C%           *            8.D0, -7.D0, 9.D0,
C%           *            5.D0, 4.D0, -6.D0 /
C%
C%            DATA  ND / 3 /
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C      SID TESTED                                                     C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%            WRITE(6,190)
C%      190   FORMAT(///' TEST OUTPUT FOR SID:'//)
C%
C%
C%            CALL  DMOUT (C, ND, ND, ND, 23, ' COEFFICIENT MATRIX C =')
C%            CALL  DMOUT (B, ND, ND, NB, 22, ' RIGHT-SIDE MATRIX B =')
C%
C%            CALL  SID (C, ND, ND, B, ND, NB, *50, W)
C%
C%            CALL  DMOUT (B, ND, ND, NB, 20, ' SOLUTION MATRIX X =')
C%            CALL  DMOUT (C, ND, ND, ND, 23, 'INVERSE OF COEFF MATRIX')
C%
C%
C%            CALL EXIT
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C      MATRIX IS EITHER SINGULAR OR NEARLY SINGULAR.                  C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%      50     PRINT 230
C%      230    FORMAT(15X,26H MATRIX IS NEARLY SINGULAR)
C%
C%
C%            CALL EXIT
C%            END
C%
C%
C%      TEST OUTPUT FOR SID:
C%
C%      COEFFICIENT MATRIX C =
C%                      COL   1             COL   2             COL   3
C%      ROW   1     -3.000000000000D+00  8.000000000000D+00  5.000000000000D+00
C%      ROW   2      2.000000000000D+00 -7.000000000000D+00  4.000000000000D+00
C%      ROW   3      1.000000000000D+00  9.000000000000D+00 -6.000000000000D+00
C%
C%      RIGHT-SIDE MATRIX B =
C%                      COL   1
C%      ROW   1      6.000000000000D+00
C%      ROW   2      9.000000000000D+00
C%      ROW   3      1.000000000000D+00
C%
C%      SOLUTION MATRIX X =
C%                      COL   1
C%      ROW   1      4.000000000000D+00
C%      ROW   2      1.000000000000D+00
C%      ROW   3      2.000000000000D+00
C%
C%      INVERSE OF COEFF MATRIX
C%                      COL   1             COL   2             COL   3
C%      ROW   1      2.553191489362D-02  3.957446808511D-01  2.851063829787D-01
C%      ROW   2      6.808510638298D-02  5.531914893617D-02  9.361702127660D-02
C%      ROW   3      1.063829787234D-01  1.489361702128D-01  2.127659574468D-02
C%
C%
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	WNTAIV:  FIND THE INVERSE.                                            C
C	WNTDET:  FIND THE DETERMINANT.                                        C
C	WNTSLV:  SOLVE THE SYSTEM.                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	WNTAIV = .TRUE.
	WNTDET = .FALSE.
	WNTSLV = .TRUE.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     								              C
C     	WITH THIS ENTRY THE INVERSE OF THE N X N MATRIX IN A GETS PLACED      C
C	INTO A ON OUTPUT, PROVIDED IT IS NON-SINGULAR.		              C
C									      C
C	WITH THIS ENTRY THE SOLUTION OF THE SYSTEM A*X  =  B GETS PLACED      C
C	INTO THE B ARRAY, PROVIDED A IS NON-SINGULAR.		              C
C									      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	CALL  FTSD (*30, A, IDA, N, B, IDB, NB, DETDUM, WNTDET, WNTAIV,
     *              WNTSLV, WORK(1), WORK(N+1), WORK(2*N+1),
     *              WORK(3*N+1))

	RETURN

C$PROCEDURE    SOD

	ENTRY  SOD (A, IDA, N, B, IDB, NB, *, WORK)

C$   PURPOSE
C%
C%      This subroutine solves a system of linear equations given by
C%
C%              Ax = b
C%
C%      where A is the N x N coeficient matrix, x is the solution N x NB matrix
C%      and b is the N x NB matrix of known values.  In general, NB will equal
C%      one, and x and b will be N-vectors.
C%
C$   INPUT_ARGUMENTS
C%
C%      A(IDA,>=N)     Array containing the N x N coefficient matrix, A, on
C%                     entry.  Double precision.
C%
C%      IDA            The dimension of the first subscript of the array A( ).
C%                     IDA must be greater than or equal to N.  Integer.
C%
C%      N              Order of the square coefficient matrix, A, and the
C%                     number of rows in the right-side matrix,b.  N is
C%                     greater than or equal to 1.  Integer.
C%
C%      B(IDB,>=NB)    Array containing the right-side NxNB matrix, b.  If NB
C%                     equals 1, the right-side array can be of the form
C%                     (B(I), I=1,N).  Double precision.
C%
C%      IDB            The dimension of the first subscript of the array B( ).
C%                     IDB must be greater than or equal to N.  Integer.
C%
C%      NB             Number of columns in the right-side matrix, b.  NB must
C%                     be greater than or equal to 1.  Integer.
C%
C%      *m             The number m is the line number of the statement in the
C%                     user's program to which control is to be passed, if the
C%                     coefficient matrix is singular, or so nearly singular
C%                     that it cannot be definitely distinguished from being
C%                     singular.  The line number must appear literally in the
C%                     call statement and must be prefixed by a *.  For
C%                     instance, while *20 would be acceptable, *IRETURN, where
C%                     IRETURN is a Fortran variable, would give an error.
C%
C%      WORK(>=4*N)    Temporary working space used by the subroutine.  Double
C%                     precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      Computational by-products, which are no interest to the user, will be
C%      in the array A( ) and the solution vector in the array B( ).  See input
C%      arguments for further details.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           The computation is done using Householder orthonormal
C%      transformations.  Columns and rows are equilibrated before the
C%      computation and columns are interchanged during the computation, with
C%      compensating adjustments being made to the results.
C%
C$   SUBROUTINES_CALLED
C%
C%      FTSD.
C%
C$   RESTRICTIONS
C%
C%      None.
C%
C$   NON_STANDARD_FORTRAN
C%
C%      None.
C%
C$   EXAMPLE
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DEMONSTRATION DRIVER FOR SOD                                  C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%             PROGRAM  DEMOSOD
C%
C%
C%             DOUBLE PRECISION  B(3,2)
C%             DOUBLE PRECISION  C(3,3)
C%             DOUBLE PRECISION  W(12)
C%
C%             INTEGER  ND,NB
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DATA BLOCKS                                                   C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              DATA  B / 1.D0, 2.D0, 3.D0, 4.D0, 5.D0, 6.D0 /
C%
C%              DATA  NB / 2.D0 /
C%
C%              DATA  C / 1.D0, .2D0, .3D0,
C%           *            .4D0, 5.D0, .6D0,
C%           *            .7D0, .8D0, 9.D0 /
C%
C%              DATA  ND / 3 /
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       SOD TESTED                                                    C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              WRITE(6,330)
C%      330     FORMAT(///' TEST OUTPUT FOR SOD:'//)
C%
C%
C%              CALL  DMOUT (C, ND, ND, ND, 23, ' COEFFICIENT MATRIX C =')
C%              CALL  DMOUT (B, ND, ND, NB, 22, ' RIGHT-SIDE MATRIX B =')
C%
C%              CALL  SOD (C, ND, ND, B, ND, NB, *50, W)
C%
C%              CALL  DMOUT (B, ND, ND, NB, 20, ' SOLUTION MATRIX X =')
C%
C%
C%              CALL EXIT
C%
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       MATRIX IS EITHER SINGULAR OR NEARLY SINGULAR.                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%      50      PRINT 230
C%      230     FORMAT(15X,26H MATRIX IS NEARLY SINGULAR)
C%
C%
C%              CALL EXIT
C%              END
C%
C%
C%
C%      TEST OUTPUT FOR SOD:
C%
C%      COEFFICIENT MATRIX C =
C%                      COL   1             COL   2             COL   3
C%      ROW   1      1.000000000000D+00  4.000000000000D-01  7.000000000000D-01
C%      ROW   2      2.000000000000D-01  5.000000000000D+00  8.000000000000D-01
C%      ROW   3      3.000000000000D-01  6.000000000000D-01  9.000000000000D+00
C%
C%      RIGHT-SIDE MATRIX B =
C%                      COL   1             COL   2
C%      ROW   1      1.000000000000D+00  4.000000000000D+00
C%      ROW   2      2.000000000000D+00  5.000000000000D+00
C%      ROW   3      3.000000000000D+00  6.000000000000D+00
C%
C%      SOLUTION MATRIX X =
C%                      COL   1             COL   2
C%      ROW   1      6.666666666667D-01  3.333333333333D+00
C%      ROW   2      3.270440251572D-01  7.861635220126D-01
C%      ROW   3      2.893081761006D-01  5.031446540881D-01
C%
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	WNTAIV:  FIND THE INVERSE.                                            C
C	WNTDET:  FIND THE DETERMINANT.                                        C
C	WNTSLV:  SOLVE THE SYSTEM.                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	WNTDET = .FALSE.
	WNTAIV = .FALSE.
	WNTSLV = .TRUE.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     								              C
C	WITH THIS ENTRY THE SOLUTION OF THE SYSTEM A*X = B GETS	PLACED        C
C	INTO THE B ARRAY, PROVIDED A IS NON-SINGULAR.		              C
C									      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	CALL  FTSD (*30, A, IDA, N, B, IDB, NB, DETDUM, WNTDET,
     *              WNTAIV, WNTSLV, WORK(1), WORK(N+1), WORK(2*N+1),
     *              WORK(3*N+1))

	RETURN

C$PROCEDURE    SDETD

	ENTRY  SDETD (A, IDA, N, B, IDB, NB, *, WORK, DETERM)

C$   PURPOSE
C%
C%      This subroutine solves a system of linear equations and finds the
C%      determinant of the coefficient matrix.  The linear system has the
C%      matrix form
C%
C%              Ax = b
C%
C%      where A is the N x N coeficient matrix, x is the solution N x NB matrix
C%      and b is the N x NB matrix of known values.  In general, NB will equal
C%      one, and x and b will be N-vectors.
C%
C$   INPUT_ARGUMENTS
C%
C%      A(IDA,>=N)     Array containing the N x N coefficient matrix, A, on
C%                     entry.  Double precision.
C%
C%      IDA            The dimension of the first subscript of the array A( ).
C%                     IDA must be greater than or equal to N.  Integer.
C%
C%      N              Order of the square coefficient matrix, A, and the
C%                     number of rows in the right-side matrix,b.  N is
C%                     greater than or equal to 1.  Integer.
C%
C%      B(IDB,>=NB)    Array containing the right-side NxNB matrix, b.  If NB
C%                     equal 1, the right-side array can be of the form
C%                     (B(I), I = 1,N).  Double precision.
C%
C%      IDB            The dimension of the first subscript of the array B( ).
C%                     IDB must be greater than or equal to N.  Integer.
C%
C%      NB             Number of columns in the right-side matrix, b.  NB must
C%                     be greater than or equal to 1.  Integer.
C%
C%      *m             The number m is the line number of the statement in the
C%                     user's program to which control is to be passed, if the
C%                     coefficient matrix is singular, or so nearly singular
C%                     that it cannot be definitely distinguished from being
C%                     singular.  The line number must appear literally in the
C%                     call statement and must be prefixed by a *.  For
C%                     instance, while *20 would be acceptable, *IRETURN, where
C%                     IRETURN is a Fortran variable, would give an error.
C%
C%      WORK(>=4*N)    Temporary working space used by the subroutine.  Double
C%                     precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      Computational by-products, which are no interest to the user, will be
C%      in the array A( ) and the solution vector in the array B( ).  See input
C%      arguments for further details.
C%
C%      DETERM         The determinant.  Double precision.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           The computation is done using Householder orthonormal
C%      transformations.  Columns and rows are equilibrated before the
C%      computation and columns are interchanged during the computation,
C%      with compensating adjustments being made to the results.
C%
C$   SUBROUTINES_CALLED
C%
C%      FTSD.
C%
C$   RESTRICTIONS
C%
C%      None.
C%
C$   NON_STANDARD_FORTRAN
C%
C%      None.
C%
C$   EXAMPLE
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DEMONSTRATION DRIVER FOR SDETD                                C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%              PROGRAM  DEMOSDETD
C%
C%
C%              DOUBLE PRECISION  B(3,1)
C%              DOUBLE PRECISION  C(3,3)
C%              DOUBLE PRECISION  DETERM
C%              DOUBLE PRECISION  W(16)
C%
C%              INTEGER  ND,NB
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DATA BLOCKS                                                   C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              DATA  B / 6.D0, 9.D0, 1.D0 /
C%
C%              DATA  NB / 1.D0 /
C%
C%              DATA  C / -3.D0, 2.D0, 1.D0,
C%           *            8.D0, -7.D0, 9.D0,
C%           *            5.D0, 4.D0, -6.D0 /
C%
C%              DATA  ND / 3 /
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       SDETD TESTED                                                  C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              WRITE(6,170)
C%      170     FORMAT(///' TEST OUTPUT FOR SDETD:'//)
C%
C%
C%              CALL  DMOUT (C, ND, ND, ND, 23, ' COEFFICIENT MATRIX C =')
C%              CALL  DMOUT (B, ND, ND, NB, 22, ' RIGHT-SIDE MATRIX B =')
C%
C%              CALL  SDETD (C, ND, ND, B, ND, NB, *50, W, DETERM)
C%
C%              CALL  DMOUT (B, ND, ND, NB, 20, ' SOLUTION MATRIX X =')
C%
C%              WRITE(6,160)DETERM
C%      160     FORMAT(/' THE DETERMINANT IS ',D20.5)
C%
C%
C%              CALL EXIT
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       MATRIX IS EITHER SINGULAR OR NEARLY SINGULAR.                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%      50      PRINT 230
C%      230     FORMAT(15X,26H MATRIX IS NEARLY SINGULAR)
C%
C%
C%              CALL EXIT
C%              END
C%
C%
C%      TEST OUTPUT FOR SDETD:
C%
C%      COEFFICIENT MATRIX C =
C%                      COL   1             COL   2             COL   3
C%      ROW   1     -3.000000000000D+00  8.000000000000D+00  5.000000000000D+00
C%      ROW   2      2.000000000000D+00 -7.000000000000D+00  4.000000000000D+00
C%      ROW   3      1.000000000000D+00  9.000000000000D+00 -6.000000000000D+00
C%
C%      RIGHT-SIDE MATRIX B =
C%                      COL   1
C%      ROW   1      6.000000000000D+00
C%      ROW   2      9.000000000000D+00
C%      ROW   3      1.000000000000D+00
C%
C%      SOLUTION MATRIX X =
C%                      COL   1
C%      ROW   1      4.000000000000D+00
C%      ROW   2      1.000000000000D+00
C%      ROW   3      2.000000000000D+00
C%
C%      THE DETERMINANT IS          0.23500D+03
C%
C%
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	WNTAIV:  FIND THE INVERSE.                                            C
C	WNTDET:  FIND THE DETERMINANT.                                        C
C	WNTSLV:  SOLVE THE SYSTEM.                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	WNTDET = .TRUE.
	WNTAIV = .FALSE.
	WNTSLV = .TRUE.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     								              C
C	WITH THIS ENTRY THE SOLUTION OF THE SYSTEM A*X = B GETS	PLACED        C
C	INTO THE B ARRAY, PROVIDED A IS NON-SINGULAR.		              C
C									      C
C	WITH THIS ENTRY THE DETERMINANT OF THE MATRIX IN A GETS PLACED        C
C	INTO THE DOUBLE PRECISION CELL DETERM ON OUTPUT.		      C
C									      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	CALL  FTSD (*30, A, IDA, N, B, IDB, NB, DETERM, WNTDET,
     *              WNTAIV, WNTSLV, WORK(1), WORK(N+1), WORK(2*N+1),
     *              WORK(3*N+1))

	RETURN

C$PROCEDURE    SIDETD

	ENTRY  SIDETD (A, IDA, N, B, IDB, NB, *, WORK, DETERM)

C$   PURPOSE
C%
C%      This subroutine solves a system of linear equations, and finds the
C%      determinant and inverse of the coefficient matrix.  The linear system
C%      has the matrix form
C%
C%              Ax = b
C%
C%      where A is the N x N coeficient matrix, x is the solution N x NB matrix
C%      and b is the N x NB matrix of known values.  In general, NB will equal
C%      one, and x and b will be N-vectors.
C%
C$   INPUT_ARGUMENTS
C%
C%      A(IDA,>=N)     Array containing the N x N coefficient matrix, A, on
C%                     entry.  Double precision.
C%
C%      IDA            The dimension of the first subscript of the array A( ).
C%                     IDA must be greater than or equal to N.  Integer.
C%
C%      N              Order of the square coefficient matrix, A, and the
C%                     number of rows in the right-side matrix,b.  N is greater
C%                     than or equal to 1.  Integer.
C%
C%      B(IDB,>=NB)    Array containing the right-side NxNB matrix, b.  If NB
C%                     equals 1, the right-side array can be of the form
C%                     (B(I), I = 1,N).  Double precision.
C%
C%      IDB            The dimension of the first subscript of the array B( ).
C%                     IDB must be greater than or equal to N.  Integer.
C%
C%      NB             Number of columns in the right-side matrix, b.  NB is
C%                     always greater than or equal to 1.  Integer.
C%
C%      *m             The number m is the line number of the statement in the
C%                     user's program to which control is to be passed, if the
C%                     coefficient matrix is singular, or so nearly singular
C%                     that it cannot be definitely distinguished from being
C%                     singular.  The line number must appear literally in the
C%                     call statement and must be prefixed by a *.  For
C%                     instance, while *20 would be acceptable, *IRETURN, where
C%                     IRETURN is a Fortran variable, would give an error.
C%
C%      WORK(>=4*N)    Temporary working space used by the subroutine.  Double
C%                     precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      The inverse matrix will be in the array A( ) and the solution vector
C%      in the array B( ).  See input arguments for further details.
C%
C%      DETERM         The determinant.  Double precision.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           The computation is done using Householder orthonormal
C%      transformations.  Columns and rows are equilibrated before the
C%      computation and columns are interchanged during the computation, with
C%      compensating adjustments being made to the results.  Calculation of the
C%      inverse is not essential for solving the system.  The inverse should
C%      only be requested, when it is explicitly needed for some computation.
C%
C$   SUBROUTINES_CALLED
C%
C%      FTSD.
C%
C$   RESTRICTIONS
C%
C%      None.
C%
C$   NON_STANDARD_FORTRAN
C%
C%      None.
C%
C$   EXAMPLE
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DEMONSTRATION DRIVER FOR SIDETD                               C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%             PROGRAM  DESIDETD
C%
C%
C%             DOUBLE PRECISION  B(3,1)
C%             DOUBLE PRECISION  C(3,3)
C%             DOUBLE PRECISION  DETERM
C%             DOUBLE PRECISION  W(16)
C%
C%             INTEGER  ND,NB
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DATA BLOCKS                                                   C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%             DATA  B / 6.D0, 9.D0, 1.D0 /
C%
C%             DATA  NB / 1.D0 /
C%
C%             DATA  C / -3.D0, 2.D0, 1.D0,
C%           *            8.D0, -7.D0, 9.D0,
C%           *            5.D0, 4.D0, -6.D0 /
C%
C%             DATA  ND / 3 /
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       SIDETD TESTED                                                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%             WRITE(6,300)
C%      300    FORMAT(///' TEST OUTPUT FOR SIDETD:'//)
C%
C%
C%             CALL  DMOUT (C, ND, ND, ND, 23, ' COEFFICIENT MATRIX C =')
C%             CALL  DMOUT (B, ND, ND, NB, 22, ' RIGHT-SIDE MATRIX B =')
C%
C%             CALL  SIDETD (C, ND, ND, B, ND, NB, *50, W, DETERM)
C%
C%             CALL  DMOUT (B, ND, ND, NB, 20, ' SOLUTION MATRIX X =')
C%             CALL  DMOUT (C, ND, ND, ND, 23, 'INVERSE OF COEFF MATRIX')
C%
C%             WRITE(6,160)  DETERM
C%      160    FORMAT(//' The determinant is ',D15.7)
C%
C%             CALL EXIT
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       MATRIX IS EITHER SINGULAR OR NEARLY SINGULAR.                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%      50     PRINT 230
C%      230    FORMAT(15X,26H MATRIX IS NEARLY SINGULAR)
C%
C%
C%             CALL EXIT
C%             END
C%
C%
C%
C%      TEST OUTPUT FOR SIDETD:
C%
C%
C%      COEFFICIENT MATRIX C =
C%                      COL   1             COL   2             COL   3
C%      ROW   1     -3.000000000000D+00  8.000000000000D+00  5.000000000000D+00
C%      ROW   2      2.000000000000D+00 -7.000000000000D+00  4.000000000000D+00
C%      ROW   3      1.000000000000D+00  9.000000000000D+00 -6.000000000000D+00
C%
C%      RIGHT-SIDE MATRIX B =
C%                      COL   1
C%      ROW   1      6.000000000000D+00
C%      ROW   2      9.000000000000D+00
C%      ROW   3      1.000000000000D+00
C%
C%      SOLUTION MATRIX X =
C%                      COL   1
C%      ROW   1      4.000000000000D+00
C%      ROW   2      1.000000000000D+00
C%      ROW   3      2.000000000000D+00
C%
C%      INVERSE OF COEFF MATRIX
C%                      COL   1             COL   2             COL   3
C%      ROW   1      2.553191489362D-02  3.957446808511D-01  2.851063829787D-01
C%      ROW   2      6.808510638298D-02  5.531914893617D-02  9.361702127660D-02
C%      ROW   3      1.063829787234D-01  1.489361702128D-01  2.127659574468D-02
C%
C%      The determinant is   0.2350000D+03
C%
C%
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	WNTAIV:  FIND THE INVERSE.                                            C
C	WNTDET:  FIND THE DETERMINANT.                                        C
C	WNTSLV:  SOLVE THE SYSTEM.                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	WNTDET = .TRUE.
	WNTAIV = .TRUE.
	WNTSLV = .TRUE.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     								              C
C     	WITH THIS ENTRY THE INVERSE OF THE N X N MATRIX IN A GETS PLACED      C
C	INTO A ON OUTPUT, PROVIDED IT IS NON-SINGULAR.		              C
C									      C
C	WITH THIS ENTRY THE SOLUTION OF THE SYSTEM A*X = B GETS	PLACED        C
C	INTO THE B ARRAY, PROVIDED A IS NON-SINGULAR.		              C
C									      C
C	WITH THIS ENTRY THE DETERMINANT OF THE MATRIX IN A GETS PLACED        C
C	INTO THE DOUBLE PRECISION CELL DETERM ON OUTPUT.		      C
C									      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	CALL  FTSD (*30, A, IDA, N, B, IDB, NB, DETERM, WNTDET, WNTAIV,
     *              WNTSLV, WORK(1), WORK(N+1), WORK(2*N+1),
     *              WORK(3*N+1))

	RETURN

C$PROCEDURE    DETD

	ENTRY  DETD (A, IDA, N, WORK, DETERM)

C$   PURPOSE
C%
C%      This subroutine computes the determinant of a square matrix.
C%
C$   INPUT_ARGUMENTS
C%
C%      A(IDA,>=N)     Array containing the N x N matrix, A.  Double precision.
C%
C%      IDA            The dimension of the first subscript of the array A( ).
C%                     IDA must be greater than or equal to N.  Integer.
C%
C%      N              Order of the square matrix, A.  N must be greater than
C%                     or equal to 1.  Integer.
C%
C%      WORK(>=4*N)    Temporary working space used by the subroutine.  Double
C%                     precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      Computational by-products, which are no interest to the user, will be
C%      in the array A( ).
C%
C%      DETERM         The determinant.  Double precision.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           The computation is done using Householder orthonormal
C%      transformations.
C%
C$   SUBROUTINES_CALLED
C%
C%      FTSD.
C%
C$   RESTRICTIONS
C%
C%      None.
C%
C$   NON_STANDARD_FORTRAN
C%
C%      None.
C%
C$   EXAMPLE
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C        DEMONSTRATION DRIVER FOR DETD                                C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%              PROGRAM  DEMODETD
C%
C%
C%              DOUBLE PRECISION  A(4,4)
C%              DOUBLE PRECISION  DETERM
C%              DOUBLE PRECISION  W(16)
C%
C%              INTEGER  N,NDA
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DATA BLOCKS                                                   C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              DATA  A / 5.D0, 7.D0, 6.D0, 5.D0,
C%           *            7.D0, 10.D0, 8.D0, 7.D0,
C%           *            6.D0, 8.D0, 10.D0, 9.D0,
C%           *            5.D0, 7.D0, 9.D0, 10.D0 /
C%
C%              DATA  N / 4 /
C%              DATA  NDA / 4 /
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DETD TESTED                                                   C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%              WRITE(6,150)
C%      150     FORMAT(///' TEST OUTPUT FOR DETD:'//)
C%
C%
C%              CALL  DMOUT (A, NDA, N, N, 4, ' A =')
C%              CALL  DETD (A, NDA, N, W, DETERM)
C%
C%              WRITE(6,160)DETERM
C%      160     FORMAT(/' THE DETERMINANT IS ',D20.5)
C%
C%
C%
C%              CALL EXIT
C%
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       MATRIX IS EITHER SINGULAR OR NEARLY SINGULAR.                 C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%      50      PRINT 230
C%      230     FORMAT(15X,26H MATRIX IS NEARLY SINGULAR)
C%
C%
C%              CALL EXIT
C%              END
C%
C%
C%   TEST OUTPUT FOR DETD:
C%
C%   A =
C%             COL   1          COL   2          COL   3          COL   4
C%   ROW 1  5.000000000D+00  7.000000000D+00  6.000000000D+00  5.000000000D+00
C%   ROW 2  7.000000000D+00  1.000000000D+01  8.000000000D+00  7.000000000D+00
C%   ROW 3  6.000000000D+00  8.000000000D+00  1.000000000D+01  9.000000000D+00
C%   ROW 4  5.000000000D+00  7.000000000D+00  9.000000000D+00  1.000000000D+01
C%
C%   THE DETERMINANT IS          0.10000D+01
C%
C%
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	WNTAIV:  FIND THE INVERSE.                                            C
C	WNTDET:  FIND THE DETERMINANT.                                        C
C	WNTSLV:  SOLVE THE SYSTEM.                                            C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	WNTDET = .TRUE.
	WNTAIV = .FALSE.
	WNTSLV = .FALSE.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     								              C
C	WITH THIS ENTRY THE DETERMINANT OF THE MATRIX IN A GETS PLACED INTO   C
C	THE DOUBLE PRECISION CELL DETERM ON OUTPUT.			      C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	CALL  FTSD(*30, A, IDA, N, BDUM, 1, 1, DETERM, WNTDET, WNTAIV,
     *             WNTSLV, WORK(1), WORK(N+1), WORK(2*N+1),
     *             WORK(3*N+1))

	RETURN

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	THE MATRIX IS SINGULAR OR NEARLY SINGULAR                             C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

30 	RETURN  1

	END


program raytr
  use, intrinsic :: iso_fortran_env, dp=>real64
  use geq_sphax_base
  include "gensrc/raytr-metricname.f90"
  use indiv_ngeod_solver
  implicit none
  real(dp), parameter :: pi = 3.1415192d0
  real(dp), dimension(0:3,0:3) :: g
  real(dp), dimension(1:3) :: pos, k, k0
  integer :: outputfile,logfile,metafile
  real(dp) :: dlmin, tol, sepgeod
  character(len=128) :: dataid, metricname
  integer :: view,i,imax,imin,ifactor

  selected_pot_func => get_potential
  selected_dpot_func => get_deriv_potential
  selected_get_metric => get_metric
  selected_geqrhs => geqrhs
  selected_surf => surface_sph

  indiv_ngeod_solver__logfile = logfile

  read(*,'(a)') dataid
  read(*,'(a)') metricname

  read(*,*) m
  read(*,*) a
  read(*,*) q
  read(*,*) asp_ratio
  read(*,*) view
  read(*,*) tol
  read(*,*) dlmin

  include "gensrc/raytr-paramtransf.f90"

  open(newunit=logfile, file="log.txt", status="replace", action="write")
  open(newunit=outputfile, file="data/raytr/"//trim(dataid)//"/"//trim(metricname)//".dat",&
    & form="unformatted", access="stream", status="replace")
  open(newunit=metafile, file="data/raytr/"//trim(dataid)//"/meta/"//trim(metricname)//".txt",&
    & status="replace", action="write")

  if (asp_ratio < 0 .and. asp_ratio >= -1) then
    !! Calculate aspect ratio, assuming solid body =====
    !!   >>> J2 = (Iz - Ix)/M*R^2 = Q/(M_g*R^2);  R=Req
    !!  If solid ellipsoid, Iz = 2/5*M*R^2, Ix = 1/5*M*(R^2 + Rp^2)
    !!      => (M_g/R) - (M_g/R)*Rp^2/R^2 = (Q/R^3)*5/2
    !!  /!\ The abs is added assuming that's always oblate!
    asp_ratio = sqrt(1-5*abs(q)/(2*m))
  end if

  surf_r_eq = 1d0
  coord_bl_a = a
  call set_coordinates(coord_bl)

  ! print*, get_potential([1d0,10d0,pi/2,0d0])

  include "print_art.f90"

  select case(view)
  case(1) !! xy plane
  !! Horizontal

    ifactor = 4
    imax = 640/ifactor
    imin = -640/ifactor

    do i = imin,imax
      write(*,'(a,a,f5.1,a,$)') char(13), "computing...", (imax+i)/(1.0*abs(imin)+abs(imax))*100.0, "%"

      sepgeod = 0.003125*ifactor
      pos = [15d0,sepgeod*real(i,dp),0d0]
      k = [-1d0,0d0,0d0]
      k0 = k

      !call ngeod_cart_rkf(pos,k,1d0,40d0,1d-5,2d0,1d-7,outputfile)
      ! call ngeod_cart_rkf(pos,k,1d0,50d0,1d-9,2d0,1d-11,outputfile)
      ! call ngeod_cart_rkf(pos,k,1d0,50d0,1d-8,5d0,1d-10,outputfile)
      call ngeod_cart_rkf(pos,k,1d0,50d0,dlmin,5d0,tol,outputfile)
      !write(logfile,*) i,0.25*i,k
      ! !  ngeod_cart_rkf(r  , k ,om,lmax,dlmin,dlmax,tol,outputfile)
      ! print*, acos(dot_product(k0,k)/sqrt(dot_product(k,k)*dot_product(k0,k0)))*180/pi
    end do

  case(2)
    !! Vertical

    ifactor = 64
    imax = 640/ifactor
    imin = -640/ifactor

    do i = imin,imax
      write(*,'(a,a,f5.1,a,$)') char(13), "computing...", (imax+i)/(1.0*abs(imin)+abs(imax))*100.0, "%"

      sepgeod = 0.003125*ifactor
      pos = [6d0,0.02d0,sepgeod*real(i,dp)]
      k = [-1d0,0d0,0d0]
      k0 = k
      ! call ngeod_cart_eul(pos,k,1d0,50d0,0.1d0,outputfile)

      ! call ngeod_cart_rkf(pos,k,1d0,40d0,1d-5,2d0,1d-7,outputfile)
      ! call ngeod_cart_rkf(pos,k,1d0,50d0,1d-8,2d0,1d-12,outputfile)

      call ngeod_cart_rkf(pos,k,1d0,20d0,dlmin,2d0,tol,outputfile)
      ! !  ngeod_cart_rkf(r  , k ,om,lmax,dlmin,dlmax,tol,outputfile)
      ! print*, acos(dot_product(k0,k)/sqrt(dot_product(k,k)*dot_product(k0,k0)))*180/pi
    end do
  end select

print*, ""
! print '(a)', "[Report]"
write(metafile,*) " dataid = ", dataid
write(metafile,*) " metricname = ", metricname
write(metafile,*) " m = ", m
write(metafile,*) " a = ", a
write(metafile,*) " q = ", q
write(metafile,*) " asp_ratio =", asp_ratio
write(metafile,*) " view = ", view
write(metafile,*) " dlmin = ", dlmin
write(metafile,*) " tol = ", tol
write(metafile,*) " imax = ", imax
write(metafile,*) " sepgeod = ", sepgeod
write(metafile,*) "8< - - - - - - - - - - - - - - -"

end program


module m_MeshAndMetries
  use m_TypeDef
  use m_LogInfo
  use m_Parameters
  use decomp_2d
  implicit none
  private

  real(RK),public,save::dx,  dy,  dz   ! average mesh intervals in three directions
  real(RK),public,save::dx2, dy2, dz2  ! square of average mesh intervals in three directions
  real(RK),public,save::rdx, rdy, rdz  ! inverse average mesh intervals in three directions
  real(RK),public,save::rdx2,rdy2,rdz2 ! square of the inverse average mesh intervals in three directions
#if defined CFDDEM || defined CFDACM
  real(RK),public,save:: dyUniform,rdyUniform
#endif

  real(RK),public,save,allocatable,dimension(:):: yp   ! point coordinate in y-dir. Suffix 'v' means 'vector'
  real(RK),public,save,allocatable,dimension(:):: xc   ! center coordinate in x-dir
  real(RK),public,save,allocatable,dimension(:):: yc   ! center coordinate in y-dir
  real(RK),public,save,allocatable,dimension(:):: zc   ! center coordinate in z-dir
  real(RK),public,save,allocatable,dimension(:):: VolCell   ! cell volume
  real(RK),public,save,allocatable,dimension(:):: DeltaCell ! (dx*dy*dz)^(1/3)

  real(RK),public,save,allocatable,dimension(:):: dyp  ! point coordinate interval in y-dir
  real(RK),public,save,allocatable,dimension(:):: dyc  ! center coordinate interval in y-dir
  real(RK),public,save,allocatable,dimension(:):: rdyp ! inverse point coordinate interval in y-dir
  real(RK),public,save,allocatable,dimension(:):: rdyc ! inverse center coordinate interval in y-dir

  ! Pressure Laplacian metries in y-dir
  real(RK),public,save,allocatable,dimension(:):: ap2ph
  real(RK),public,save,allocatable,dimension(:):: ac2ph
  real(RK),public,save,allocatable,dimension(:):: am2ph

  ! uy/uz Laplacian metries in x-dir (STAGGERED VARIABLE)
  real(RK),public,save,allocatable,dimension(:):: am1c
  real(RK),public,save,allocatable,dimension(:):: ac1c
  real(RK),public,save,allocatable,dimension(:):: ap1c
  ! uy/uz Laplacian metries in x-dir (for Crank-Nicolson scheme purpose)
  real(RK),public,save,allocatable,dimension(:):: am1cForCN
  real(RK),public,save,allocatable,dimension(:):: ap1cForCN

  ! ux/uz Laplacian metries in y-dir (STAGGERED VARIABLE)
  real(RK),public,save,allocatable,dimension(:):: am2c
  real(RK),public,save,allocatable,dimension(:):: ac2c
  real(RK),public,save,allocatable,dimension(:):: ap2c
  ! ux/uz Laplacian metries in y-dir (for Crank-Nicolson scheme purpose)
  real(RK),public,save,allocatable,dimension(:):: am2cForCN
  real(RK),public,save,allocatable,dimension(:):: ap2cForCN

  ! uy Laplacian metries in y-dir (CENTERED VARIABLE)
  real(RK),public,save,allocatable,dimension(:):: am2p
  real(RK),public,save,allocatable,dimension(:):: ac2p
  real(RK),public,save,allocatable,dimension(:):: ap2p

  ! ux/uy Laplacian metries in z-dir (STAGGERED VARIABLE)
  real(RK),public,save,allocatable,dimension(:):: am3c
  real(RK),public,save,allocatable,dimension(:):: ac3c
  real(RK),public,save,allocatable,dimension(:):: ap3c
  ! ux/uy Laplacian metries in z-dir (for Crank-Nicolson scheme purpose)
  real(RK),public,save,allocatable,dimension(:):: am3cForCN
  real(RK),public,save,allocatable,dimension(:):: ap3cForCN

  ! for linear interpolation in y-dir
  real(RK),public,save,allocatable,dimension(:):: YinterpCoe

  public:: InitMeshAndMetries
contains

  !******************************************************************
  ! InitMeshAndMetries
  !******************************************************************
  subroutine InitMeshAndMetries()
    implicit none

    ! locals
    character(64) :: chFile
    real(RK):: tstr,xi,y0,ylyt,ystart
    integer:: j,nypt,iErrSum,nUnitFile,myistat
    integer:: iErr01,iErr02,iErr03,iErr04,iErr05,iErr06,iErr07,iErr08,iErr09,iErr10,iErr11
    integer:: iErr12,iErr13,iErr14,iErr15,iErr16,iErr17,iErr18,iErr19,iErr20,iErr21,iErr22
    integer:: iErr23,iErr24,iErr25,iErr26,iErr27,iErr28,iErr29,iErr30,iErr31,iErr32

    dx = xlx/real(nxc,kind=RK)
    dy = yly/real(nyc,kind=RK)
    dz = zlz/real(nzc,kind=RK)
    rdx= real(nxc,kind=RK)/xlx
    rdy= real(nyc,kind=RK)/yly
    rdz= real(nzc,kind=RK)/zlz
    dx2= dx*dx;  rdx2= rdx*rdx
    dy2= dy*dy;  rdy2= rdy*rdy
    dz2= dz*dz;  rdz2= rdz*rdz

    allocate(yp(0:nyp),   Stat = iErr01)
    allocate(yc(0:nyp),   Stat = iErr02)
    allocate(dyp(0:nyp),  Stat = iErr03)
    allocate(rdyp(0:nyp), Stat = iErr04)
    allocate(dyc(0:nyp),  Stat = iErr05)
    allocate(rdyc(0:nyp), Stat = iErr06)

    allocate(ap2ph(1:nyc), Stat=iErr07)
    allocate(ac2ph(1:nyc), Stat=iErr08)
    allocate(am2ph(1:nyc), Stat=iErr09)

    allocate(ap1c(1:nxc), Stat=iErr10)
    allocate(ac1c(1:nxc), Stat=iErr11)
    allocate(am1c(1:nxc), Stat=iErr12)
    allocate(ap1cForCN(1:nxc), Stat=iErr13)
    allocate(am1cForCN(1:nxc), Stat=iErr14)

    allocate(ap2c(1:nyc), Stat=iErr15)
    allocate(ac2c(1:nyc), Stat=iErr16)
    allocate(am2c(1:nyc), Stat=iErr17)
    allocate(ap2cForCN(1:nyc), Stat=iErr18)
    allocate(am2cForCN(1:nyc), Stat=iErr19)

    allocate(ap2p(1:nyc), Stat=iErr20)
    allocate(ac2p(1:nyc), Stat=iErr21)
    allocate(am2p(1:nyc), Stat=iErr22)

    allocate(ap3c(1:nzc), Stat=iErr23)
    allocate(ac3c(1:nzc), Stat=iErr24)
    allocate(am3c(1:nzc), Stat=iErr25)
    allocate(ap3cForCN(1:nzc), Stat=iErr26)
    allocate(am3cForCN(1:nzc), Stat=iErr27)

    allocate(xc(0:nxp),        Stat = iErr28)
    allocate(zc(0:nzp),        Stat = iErr29)
    allocate(VolCell(0:nyp),   Stat = iErr30)
    allocate(DeltaCell(0:nyp), Stat = iErr31)

    allocate(YinterpCoe(0:nyc), Stat = iErr32)
    iErrSum=abs(iErr01)+abs(iErr02)+abs(iErr03)+abs(iErr04)+abs(iErr05)+abs(iErr06)+abs(iErr07)+abs(iErr08)+  &
            abs(iErr09)+abs(iErr10)+abs(iErr11)+abs(iErr12)+abs(iErr13)+abs(iErr14)+abs(iErr15)+abs(iErr16)+  &
            abs(iErr17)+abs(iErr18)+abs(iErr19)+abs(iErr20)+abs(iErr21)+abs(iErr22)+abs(iErr23)+abs(iErr24)+  &
            abs(iErr25)+abs(iErr26)+abs(iErr27)+abs(iErr28)+abs(iErr29)+abs(iErr30)+abs(iErr31)+abs(iErr32)
    if(iErrSum/=0) call MainLog%CheckForError(ErrT_Abort,"InitMeshAndMetries","Allocation failed")

    ! yp, point coordinate in y-dir
    if(BcOption(ym_dir)==BC_PERIOD .and. istret /= 0 .and. nrank==0) then
      call MainLog%CheckForError(ErrT_Abort,"InitMeshAndMetries","Bc=Peroidic in y-dir, while mesh is also stretching, WRONG!")
    endif

    ! Here:
    !   istret = 0, No clustering;
    !   istret = 1, Clustered in the center;
    !   istret = 2, Two walls clustering;
    !   istret = 3, Bottom wall clustering.
    ! Besides:
    !   If nyUniform>0 and istret /= 0, the first nyUniform grids in [0,yUniform] will be uniform.
    if(nyUniform<0)nyUniform=0
    if(istret<0 .or. istret>3)       call MainLog%CheckForError(ErrT_Abort,"InitMeshAndMetries"," istret WRONG!")
    if(istret/=0 .and. nrank==0 .and. nyUniform>nyc) call MainLog%CheckForError(ErrT_Abort,"InitMeshAndMetries","nyUniform>nyc WRONG!")
    if(istret/=0 .and. nrank==0 .and. yUniform>yly ) call MainLog%CheckForError(ErrT_Abort,"InitMeshAndMetries"," yUniform>yly WRONG!")
#if defined CFDDEM || defined CFDACM
    dyUniform=dy; rdyUniform=rdy
    if(istret/=0 .and. nyUniform>0) then
      dyUniform = yUniform/real(nyUniform,kind=RK)
      rdyUniform= real(nyUniform,kind=RK)/yUniform
    endif
#endif

    if(istret==0) then
      do j=1,nyp
        yp(j)=dy*real(j-1,kind=RK)
      enddo
    else
      if(nyUniform>0) then
        do j=1,nyUniform
          yp(j)=(yUniform/real(nyUniform,RK))*real(j-1,RK)
        enddo
        ystart=yUniform
        ylyt=yly-yUniform
        nypt=nyp-nyUniform
      else
        ystart=zero
        ylyt=yly
        nypt=nyp
      endif

      SELECT CASE(istret)
      CASE(1)
        tstr= tanh(cStret)
        do j= 1,nypt/2
          xi= real(j-1,kind=RK)/real(nypt-1,RK)       ! For j: [1,nypt/2],  xi: [0,1/2]
          y0= half*tanh(two*cStret*xi)/tstr           ! For j: [1,nypt/2],  y0: [0,1/2]
          yp(nyUniform+j)       = ystart +ylyt*y0
          yp(nyUniform+nypt+1-j)= ystart +ylyt*(one-y0)
        enddo
        if(mod(nypt,2)==1)yp(nyUniform+nypt/2+1)=half*ylyt+ystart
      CASE(2)
        tstr= tanh(cStret*half)
        do j= 1,nypt/2
          xi= real(j-1,kind=RK)/real(nypt-1,RK)       ! For j: [1,nypt/2],  xi: [0,1/2]
          y0= half*tanh(cStret*(xi-half))/tstr+ half  ! For j: [1,nypt/2],  y0: [0,1/2]
          yp(nyUniform+j)       = ystart +ylyt*y0
          yp(nyUniform+nypt+1-j)= ystart +ylyt*(one-y0)
        enddo
        if (mod(nypt,2)==1)yp(nyUniform+nypt/2+1)=half*ylyt+ystart
      CASE(3)
        tstr= tanh(cStret)
        do j= 1,nypt
          xi= real(j-1,kind=RK)/real(nypt-1)          ! For j: [1,nypt],    xi: [0,1]
          y0= tanh(cStret*(xi-one))/tstr + one        ! For j: [1,nypt],    y0: [0,1]
          yp(nyUniform+j)       = ystart +ylyt*y0
        enddo
      ENDSELECT
    endif
    yp(1)=zero; yp(nyp)=yly

    write(chFile,"(A)") trim(Res_Dir)//"yMeshFor"//trim(RunName)//".txt"
    nUnitFile=GetFileUnit()
    if(nrank==0) then
      open(unit=nUnitFile, file=chfile,status='replace',form='formatted',IOSTAT=myistat)
      if(myistat/=0) call MainLog%CheckForError(ErrT_Abort,"InitMeshAndMetries","Cannot open file: "//trim(chFile))
      do j=1,nyp
        write(nUnitFile,*)j,yp(j)
      enddo
      close(nUnitFile,IOSTAT=myistat)
    endif

    ! yc, center coordinate interval in y-dir
    do j=1,nyc
      yc(j) = half*(yp(j)+yp(j+1))
    enddo
    yc(0)=two*yp(1)-yc(1)
    yc(nyp)=two*yp(nyp)-yc(nyc)

    ! xc,zc, center coordinate interval in x-dir and z-dir
    do j=0,nxp
      xc(j)=dx*(real(j,RK)-half)
    enddo
    do j=0,nzp
      zc(j)=dz*(real(j,RK)-half)
    enddo

    ! dyp, point coordinate interval in y-dir
    do j=1,nyc
      dyp(j) = yp(j+1) - yp(j)
    enddo
    dyp(0)  =dyp(1)
    dyp(nyp)=dyp(nyc)

    !VolCell,volume of the cell
    do j=0,nyp
      VolCell(j)=dyp(j)*dx*dz
    enddo

    !DeltaCell, (VolCell)^(1/3)
    do j=0,nyp
      DeltaCell(j)=(dyp(j)*dx*dz)**(one/three)
    enddo

    ! dyc, center coordinate interval in y-dir
    do j=2,nyc
      dyc(j) = yc(j)-yc(j-1)
    enddo
    dyc(1)=dyp(1)
    dyc(nyp)=dyp(nyc)

    ! rdyp and rdyc, the reverse of the dyp and dyc, respectively.
    do j=0, nyp
      rdyp(j) = one/dyp(j)
    enddo
    do j=1,nyp
      rdyc(j) = one/dyc(j)
    enddo

    ! for linear interpolation in y-dir
    do j=0,nyc
      YinterpCoe(j)= dyp(j)/(dyp(j)+dyp(j+1))
    enddo

    ! Pressure Laplacian metries in y-dir
    do j=1,nyc
      am2ph(j)= rdyp(j)*rdyc(j)
      ap2ph(j)= rdyp(j)*rdyc(j+1)
    enddo
    if(BcOption(ym_dir)==BC_NSLIP .or. BcOption(ym_dir)==BC_FSLIP) then
      am2ph(1)= zero
      ap2ph(1)= rdyp(1)*rdyc(2)
    endif
    if(BcOption(yp_dir)==BC_NSLIP .or. BcOption(yp_dir)==BC_FSLIP) then
      am2ph(nyc)= rdyp(nyc)*rdyc(nyc)
      ap2ph(nyc)= zero
    endif
    ac2ph = -(am2ph+ap2ph)

    ! uy/uz Laplacian metries in x-dir (STAGGERED VARIABLE)=====================
    am1c = rdx2;  ap1c=rdx2
    if(BcOption(xm_dir)==BC_NSLIP ) then
      am1c(1)= four/three*rdx2
      ap1c(1)= four/three*rdx2
    elseif(BcOption(xm_dir)==BC_FSLIP ) then
      am1c(1)= zero
      ap1c(1)= rdx2
    endif
    if(BcOption(xp_dir)==BC_NSLIP ) then
      am1c(nxc)= four/three*rdx2
      ap1c(nxc)= four/three*rdx2
    elseif(BcOption(xp_dir)==BC_FSLIP ) then
      am1c(nxc)= rdx2
      ap1c(nxc)= zero
    endif
    ac1c= -(am1c+ap1c)

    ! uy/uz Laplacian metries in x-dir (for Crank-Nicolson scheme purpose)
    ap1cForCN = ap1c;   am1cForCN = am1c;
    if(BcOption(xm_dir)==BC_NSLIP) then
      ap1cForCN(1)= ap1c(1)
      am1cForCN(1)= two*am1c(1)
    endif
    if(BcOption(xp_dir)==BC_NSLIP) then
      am1cForCN(nxc)= am1c(nxc)
      ap1cForCN(nxc)= two*ap1c(nxc)
    endif

    ! ux/uz Laplacian metries in y-dir (STAGGERED VARIABLE)=====================
    do j=1,nyc
      am2c(j)= rdyp(j)*rdyc(j)
      ap2c(j)= rdyp(j)*rdyc(j+1)
    enddo
    if(BcOption(ym_dir)==BC_NSLIP ) then
      am2c(1)= four*rdyc(1)/( dyc(1)+two*dyc(2) )
      ap2c(1)= four*rdyc(2)/( dyc(1)+two*dyc(2) )
    elseif(BcOption(ym_dir)==BC_FSLIP) then
      am2c(1)= zero
      ap2c(1)= rdyp(1)*rdyc(2)
    endif
    if(BcOption(yp_dir)==BC_NSLIP ) then
      am2c(nyc)= four*rdyc(nyc)/( dyc(nyp)+two*dyc(nyc) )
      ap2c(nyc)= four*rdyc(nyp)/( dyc(nyp)+two*dyc(nyc) )
    elseif(BcOption(yp_dir)==BC_FSLIP) then
      am2c(nyc)= rdyp(nyc)*rdyc(nyc)
      ap2c(nyc)= zero
    endif
    ac2c= -(am2c+ap2c)

    ! ux/uz Laplacian metries in y-dir (for Crank-Nicolson scheme purpose)
    ap2cForCN = ap2c;   am2cForCN = am2c;
    if(BcOption(ym_dir)==BC_NSLIP) then
      ap2cForCN(1)= ap2c(1)
      am2cForCN(1)= two*am2c(1)
    endif
    if(BcOption(yp_dir)==BC_NSLIP) then
      am2cForCN(nyc)= am2c(nyc)
      ap2cForCN(nyc)= two*ap2c(nyc)
    endif

    ! ux/uy Laplacian metries in z-dir (STAGGERED VARIABLE)=====================
    am3c = rdz2;  ap3c=rdz2;
    if(BcOption(zm_dir)==BC_NSLIP ) then
      am3c(1)= four/three*rdz2
      ap3c(1)= four/three*rdz2
    elseif(BcOption(zm_dir)==BC_FSLIP ) then
      am3c(1)= zero
      ap3c(1)= rdz2
    endif
    if(BcOption(zp_dir)==BC_NSLIP ) then
      am3c(nzc)= four/three*rdz2
      ap3c(nzc)= four/three*rdz2
    elseif(BcOption(zp_dir)==BC_FSLIP) then
      am3c(nzc)= rdz2
      ap3c(nzc)= zero
    endif
    ac3c= -(am3c+ap3c)

    ! ux/uy Laplacian metries in z-dir (for Crank-Nicolson scheme purpose)
    ap3cForCN = ap3c;   am3cForCN = am3c;
    if(BcOption(zm_dir)==BC_NSLIP) then
      ap3cForCN(1)= ap3c(1)
      am3cForCN(1)= two*am3c(1)
    endif
    if(BcOption(zp_dir)==BC_NSLIP) then
      am3cForCN(nzc)= am3c(nzc)
      ap3cForCN(nzc)= two*ap3c(nzc)
    endif

    ! uy Laplacian metries in y-dir (CENTERED VARIABLE)
    do j=1,nyc
      am2p(j)= rdyc(j)*rdyp(j-1)
      ap2p(j)= rdyc(j)*rdyp(j)
    enddo
    ac2p= -(am2p+ap2p)

  end subroutine InitMeshAndMetries

end module m_MeshAndMetries


subroutine dot(v1,v2,n,vdot)
   use typre
   implicit none
   integer(ip) :: n
   real(rp) :: v1(n),v2(n),vdot

   integer(ip) :: idime

   vdot = 0.0_rp
   do idime = 1,n
      vdot = vdot + v1(idime)*v2(idime)
   enddo
end subroutine

subroutine MPIdot(v1,v2,n,vdot,mpicomm,mpiroot)
   use typre
   use MPI
   implicit none
   integer(ip) :: n, mpicomm,mpiroot
   real(rp) :: v1(n), v2(n), vdot

   real(rp) :: rwa, rwa2

   integer                  :: ierr

   rwa =  dot_product(v1(1:n),v2(1:n))

   call  MPI_REDUCE( rwa, vdot, 1, MPI_REAL8, MPI_SUM, mpiroot,MPIcomm, ierr )

end subroutine


! written by jxzou at 20191029
! updated by jxzou at 20200403: move check_orthonormal into this file

! Currently this file contains
! subroutine check_orthonormal: check whether a given set of MOs are orthonormal
! subroutine can_ortho: generate canonical orthonormalized atomic orbitals
! subroutine sym_ortho: generate symmetric orthonormalized atomic orbitals

! TO DO: Schmidt orthogonalization

!  For GNU compiler, use
! ----------------------------------------------
!  f2py -m ortho -c ortho.f90 --link-lapack_opt
! ----------------------------------------------
!  For INTEL compiler, use
! -------------------------------------------------------------------------------------
!  f2py -m ortho -c ortho.f90 --link-lapack_opt --fcompiler=intelem --compiler=intelem
! -------------------------------------------------------------------------------------
!  to compile this file (a ortho.so file will be generated). Then in Python
!  you can import the sym_ortho module.

! check whether a given set of MOs are orthonormal
subroutine check_orthonormal(nbf, nif, coeff, S)
 implicit none
 integer :: i, j, i0, j0
 integer :: nbf, nif
!f2py intent(in) :: nbf, nif
 integer, parameter :: iout = 6
 real(kind=8) :: coeff(nbf,nif), S(nbf,nbf)
!f2py intent(in) :: coeff, S
!f2py depend(nbf,nif) :: coeff
!f2py depend(nbf) :: S
 real(kind=8) :: maxv
 real(kind=8), allocatable :: C_T_S_C(:,:)

 allocate(C_T_S_C(nif,nif), source=0d0)

 C_T_S_C = MATMUL(TRANSPOSE(coeff),MATMUL(S,coeff))

 forall(i=1:nif) C_T_S_C(i,i) = C_T_S_C(i,i) - 1d0
 forall(i=1:nif,j=1:nif) C_T_S_C(i,j) = DABS(C_T_S_C(i,j))

 i0 = 1; j0 = 1
 maxv = C_T_S_C(1,1)
 do i = 1, nif, 1
  do j = 1, nif, 1
   if(C_T_S_C(j,i) > maxv) then
    maxv = C_T_S_C(j,i)
    i0 = i; j0 = j
   end if
  end do ! for j
 end do ! for i

 write(iout,'(/,2(A,I4,1X),A5,ES15.8)') 'Orthonormality check: j=',j0,'i=',i0,'maxv=',maxv
 deallocate(C_T_S_C)
 return
end subroutine check_orthonormal

! generate canonical orthonormalized atomic orbitals
subroutine can_ortho(nbf, nif, ao_ovlp, mo_coeff)
 implicit none
 integer :: i, nif0
 integer :: nbf, nif
!f2py intent(in) :: nbf, nif
 integer, parameter :: iout = 6
 real(kind=8), parameter :: thresh = 1d-6
 real(kind=8) :: ao_ovlp(nbf,nbf), mo_coeff(nbf,nif)
!f2py depend(nbf) :: ao_ovlp
!f2py intent(in,copy) :: ao_ovlp
!f2py depend(nbf,nif) :: mo_coeff
!f2py intent(out) :: mo_coeff
 real(kind=8), allocatable :: U(:,:), s(:)

 mo_coeff = 0d0
 allocate(s(nbf), source=0d0)
 call diag_get_e_and_vec(nbf, ao_ovlp, s) ! S = UsU^T, U stored in ao_ovlp

 nif0 = COUNT(s>thresh)
 if(nif0 /= nif) then
  write(iout,'(A)') 'ERROR in subroutine can_ortho: nif /= nif0. This is because&
                   & the linear dependence threshold here and outside subroutine&
                   & is not consistent.'
  write(iout,'(A,ES15.8)') 'Default threshold here:', thresh
  stop
 end if

 ! reverse the eigenvalues
 allocate(U(nbf,1), source=0d0)
 forall(i = 1:nbf) U(i,1) = s(nbf-i+1)
 s = U(:,1)
 deallocate(U)
 ! now s1 > s2 > s3 > ...

 ! reverse the eigenvectors, according to the descending order of eigenvalues
 allocate(U(nbf, nbf), source=0d0)
 forall(i = 1:nbf) U(:,i) = ao_ovlp(:,nbf-i+1)

 ! compute s^(-1/2) (only the first nif ones), stored as diagonal in ao_ovlp
 ao_ovlp = 0d0
 forall(i = 1:nif) ao_ovlp(i,i) = 1d0/DSQRT(s(i))
 deallocate(s)
 ! ao_ovlp now is a nif*nif diagonal matrix

 ! compute Us^(-1/2), where s^(-1/2) is symmetric (in fact, diagonal)
 ! ?symm: Computes a matrix-matrix product where one input matrix is symmetric.
 ! Syntax FORTRAN 77:
 ! call dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
 call dsymm('R', 'U', nbf, nif, 1d0, ao_ovlp, nif, U, nbf, 0d0, mo_coeff, nbf)

 deallocate(U)
 return
end subroutine can_ortho

! generate symmetric orthonormalized atomic orbitals
subroutine sym_ortho(nbf, ao_ovlp, mo_coeff)
 implicit none
 integer :: i
 integer :: nbf
!f2py intent(in) :: nbf
 integer, parameter :: iout = 6
 real(kind=8), parameter :: thresh = 1d-6
 real(kind=8) :: ao_ovlp(nbf,nbf), mo_coeff(nbf,nbf)
!f2py depend(nbf) :: ao_ovlp, mo_coeff
!f2py intent(in,copy) :: ao_ovlp
!f2py intent(out) :: mo_coeff
 real(kind=8), allocatable :: X(:,:), U(:,:), s(:)

 mo_coeff = 0d0
 allocate(s(nbf), source=0d0)
 call diag_get_e_and_vec(nbf, ao_ovlp, s) ! S = UsU^T, U stored in ao_ovlp

 if(ANY(s<thresh)) then
  write(iout,'(A)') 'Warning: linear dependence detected in symmetric orthogonalization!'
  write(iout,'(A,ES15.8)') 'Default threshold here:', thresh
 end if

 ! reverse the eigenvalues
 allocate(X(nbf,1), source=0d0)
 forall(i = 1:nbf) X(i,1) = s(nbf-i+1)
 s = X(:,1)
 deallocate(X)
 ! now s1 > s2 > s3 > ...

 ! reverse the eigenvectors, according to the descending order of eigenvalues
 allocate(U(nbf, nbf), source=0d0)
 forall(i = 1:nbf) U(:,i) = ao_ovlp(:,nbf-i+1)

 ! compute s^(-1/2), stored as diagonal in ao_ovlp
 ao_ovlp = 0d0
 forall(i = 1:nbf) ao_ovlp(i,i) = 1d0/DSQRT(s(i))
 deallocate(s)

 ! compute Us^(-1/2), where s^(-1/2) is symmetric (in fact, diagonal)
 ! ?symm: Computes a matrix-matrix product where one input matrix is symmetric.
 ! Syntax FORTRAN 77:
 ! call dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
 allocate(X(nbf,nbf), source=0d0)
 call dsymm('R', 'U', nbf, nbf, 1d0, ao_ovlp, nbf, U, nbf, 0d0, X, nbf)

 ! compute X1*U^T, where X1 is Us^(-1/2)
 ! ?gemm: Computes a matrix-matrix product with general matrices.
 ! Syntax FORTRAN 77:
 ! call dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
 call dgemm('N', 'T', nbf, nbf, nbf, 1d0, X, nbf, U, nbf, 0d0, mo_coeff, nbf)

 deallocate(X, U)
 return
end subroutine sym_ortho


module sphericaldfMod

 private
 public :: initdf,maxE,distf,gasRfromq,rho,rhofromfi, &
  &         fifromr,totalmass,rmax,rmin,setparameters

 integer,parameter :: ngrid=1000
 real, parameter :: pi=3.1415926535897932385
 real :: r(0:ngrid),dens(0:ngrid),ddensdr(0:ngrid)
 real :: cmass(0:ngrid),fi(0:ngrid),df(0:ngrid)
 real :: ddrhodfi2(0:ngrid)
 real :: extdens(0:ngrid),extmass(0:ngrid),tmass(0:ngrid)

 real, parameter :: F_ZERO_R_LIMIT=0.

 integer, parameter :: ntheta=50

! density parameters
 real :: halfmassradius,mass,nindex
 real :: dn,rho0,rmax,rmin,alpha,halfmassrho

 contains

 real function rho(r)
  real :: r
  rho=rho0*exp(-dn*(r/halfmassradius)**alpha)
 end function

 real function drhodr(r)
  real :: r
  drhodr=-rho(r)*(dn*alpha*(r/halfmassradius)**(alpha-1)/halfmassradius)
 end function

 real function ddrhodr2(r)
  real :: r
  ddrhodr2=-rho(r)*(dn*alpha*(r/halfmassradius)**(alpha-2)/halfmassradius**2) &
           *(alpha-1-dn*alpha*(r/halfmassradius)**alpha)
 end function

 function maxE()
  real maxE
  maxE=fi(0)
 end function

 function totalmass()
  real totalmass
  totalmass=tmass(ngrid)
 end function

 function totalcmass()
  real totalcmass
  totalcmass=cmass(ngrid)
 end function

 function distf(e) result(f)
  real :: f,e
  f=invertcumul(ngrid+1,df,fi,e)
 end function

 function gasRfromq(q) result(gasr)
  real :: gasr,q,cm
  cm=q*cmass(ngrid)
  gasr=invertcumul(ngrid+1,r,cmass,cm)
 end function

 function fifromr(rad) result (lfi)
  real :: rad,lfi
  lfi=invertcumul(ngrid+1,fi,r,rad)
 end function

 function rhofromfi(rad) result (lrho)
  real :: rad,lrho
  lrho=invertcumul(ngrid+1,dens,fi,rad)
 end function

 function int_theta(densfunc,r) result(s)
 real,external :: densfunc
 real :: dctheta,s,r
 integer :: is
  s=0
  dctheta=1.0/ntheta
  s=s+densfunc(0.,r)+densfunc(r,0.)
  do is=1,ntheta-1,2
    ctheta=is*dctheta
    s=s+4*densfunc(r*sqrt(1-ctheta**2),r*ctheta)
  enddo
  do is=2,ntheta-2,2
    ctheta=is*dctheta
    s=s+2*densfunc(r*sqrt(1-ctheta**2),r*ctheta)
  enddo
  s=s*dctheta/3.
  s=s
 end function

 subroutine setparameters(halfmassr,nin,totalm)
  real, optional :: halfmassr,nin,totalm
  external gamma

  if(present(halfmassr)) then
   halfmassradius=halfmassr
  else
   print*,'Einasto halfmass radius?'
   read*,halfmassradius
  endif

  if(present(nin)) then
   nindex=nin
  else
   print*,'Einasto n?'
   read*,nindex
  endif

  if(present(totalm)) then
   mass=totalm
  else
   print*,'Einasto total mass?'
   read*,mass
  endif

  alpha=1./nindex
  dn=3*nindex-1./3+0.0079/nindex
  call gamma(3*nindex,ga)
  halfmassrho= &
    mass/(4*pi*nindex*halfmassradius**3*exp(dn)*dn**(-3*nindex)*ga)
  rho0=halfmassrho*exp(dn)
  rmin=1.e-4*halfmassradius
  rmax=1000*halfmassradius

 end subroutine

 subroutine initdf(densfunc)
  integer :: i,j
  real :: fac,int
  real, external :: densfunc

  fac=exp(log(rmax/rmin)/(1.*(ngrid-1)))
!  fac=(rmax-rmin)/(ngrid-1.)

  r(1)=rmin
  dens(1)=rho(rmin)
  ddensdr(1)=drhodr(rmin)
  do i=2,ngrid-1
   r(i)=r(i-1)*fac
!   r(i)=r(i-1)+fac
   dens(i)=rho(r(i))
   ddensdr(i)=drhodr(r(i))
  enddo
  r(ngrid)=rmax
  dens(ngrid)=rho(rmax)
  ddensdr(ngrid)=drhodr(rmax)
  r(0)=0.
  dens(0)=dens(1) ! assumption !
  ddensdr(0)=0.
!  dens(0)=(4*dens(1)-dens(2))/3.
!  ddensdr(0)=(dens(1)-dens(0))/r(1)

! external density  averaged over theta
  extdens(0)=1/3.*densfunc(0.,rmin)+2./3.*densfunc(rmin,0.)
  do i=1,ngrid
   extdens(i)=int_theta(densfunc,r(i))
  enddo

  cmass(0.)=0.
  cmass(1.)=4/3.*Pi*r(1)**3*dens(0)
  do i=2,ngrid
   cmass(i)=cmass(i-1)+4*Pi*(r(i)-r(i-1))*(r(i)**2*dens(i)+r(i-1)**2*dens(i-1))/2.
  enddo

  extmass(0)=0.
  extmass(1)=4/3.*Pi*r(1)**3*extdens(0)
  do i=2,ngrid
   extmass(i)=extmass(i-1)+4*Pi*(r(i)-r(i-1))*(r(i)**2*extdens(i)+r(i-1)**2*extdens(i-1))/2.
  enddo

  print*,'halo reports a mass of:', cmass(ngrid)
  print*,'and an external mass of:', extmass(ngrid)

  tmass=cmass+extmass

  fi(ngrid)=0
  do i=ngrid-1,1,-1
   fi(i)=fi(i+1)+(r(i+1)-r(i))*(tmass(i)/r(i)**2+tmass(i+1)/r(i+1)**2)/2.
  enddo
  fi(0)=fi(1)+r(1)*(F_ZERO_R_LIMIT+tmass(1)/r(1)**2)/2.

  do i=1,ngrid
   ddrhodfi2(i)=(r(i)**2/tmass(i))**2* &
    ((2/r(i)-4*Pi*r(i)**2*(dens(i)+extdens(i))/tmass(i))*ddensdr(i)+ddrhodr2(r(i)))
  enddo
  ddrhodfi2(0)=ddrhodfi2(1)

  df(ngrid)=0.
  do i=ngrid-1,1,-1
   int=0
   do j=ngrid-1,i+1,-1
   int=int+(fi(j)-fi(j+1))* &
       (ddrhodfi2(j)/sqrt(fi(i)-fi(j))+ddrhodfi2(j+1)/sqrt(fi(i)-fi(j+1)))/2.
   enddo
   int=int+2./3.*Sqrt((fi(i)-fi(i+1)))*(2*ddrhodfi2(i)+ddrhodfi2(i+1))
   df(i)=1/sqrt(8.)/pi**2*(int-1/sqrt(fi(i))*ddensdr(ngrid)*r(ngrid)**2/cmass(ngrid))
  enddo
  df(0)=df(1)

  open(unit=1,file='halo.df',status='UNKNOWN')
  do i=1,ngrid
  write(1,*) fi(i),df(i)
  enddo
  close(1)

! print*,'rmax,fi0,cmass:', rmax,fi(0),cmass(ngrid)

 end subroutine

  function invertcumul(n,xlist,ylist,y) result(x)
  integer :: n,bin,up,low
  real :: xlist(n),ylist(n),x,y,u,s

  if(ylist(1).LT.ylist(n)) then
   s=1
  else
   s=-1
  endif

  if(s*y.LE.s*ylist(1)) then
   x=xlist(1)
   return
  endif
  if(s*y.GE.s*ylist(n)) then
   x=xlist(n)
   return
  endif
  up=n
  low=1
  do while((up-low).GT.1)
   bin=(low+up)/2
   if(s*y.LT.s*ylist(bin)) then
    up=bin
   else
    low=bin
   endif
  enddo
  bin=up
  u=(y-ylist(bin-1))/(ylist(bin)-ylist(bin-1))
  x=(1-u)*xlist(bin-1)+u*xlist(bin)
  return
  end function

end module sphericaldfMod

        SUBROUTINE GAMMA(X,GA)
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION G(26)
!        PI=3.141592653589793D0
        IF (X.EQ.INT(X)) THEN
           IF (X.GT.0.0D0) THEN
              GA=1.0D0
              M1=X-1
              DO 10 K=2,M1
10               GA=GA*K
           ELSE
              GA=1.0D+300
           ENDIF
        ELSE
           IF (DABS(X).GT.1.0D0) THEN
              Z=DABS(X)
              M=INT(Z)
              R=1.0D0
              DO 15 K=1,M
15               R=R*(Z-K)
              Z=Z-M
           ELSE
              Z=X
           ENDIF
           DATA G/1.0D0,0.5772156649015329D0, &
     &          -0.6558780715202538D0, -0.420026350340952D-1, &
     &          0.1665386113822915D0,-.421977345555443D-1, &
     &          -.96219715278770D-2, .72189432466630D-2, &
     &          -.11651675918591D-2, -.2152416741149D-3, &
     &          .1280502823882D-3, -.201348547807D-4, &
     &          -.12504934821D-5, .11330272320D-5, &
     &          -.2056338417D-6, .61160950D-8, &
     &          .50020075D-8, -.11812746D-8, &
     &          .1043427D-9, .77823D-11, &
     &          -.36968D-11, .51D-12, &
     &          -.206D-13, -.54D-14, .14D-14, .1D-15/
           GR=G(26)
           DO 20 K=25,1,-1
20            GR=GR*Z+G(K)
           GA=1.0D0/(GR*Z)
           IF (DABS(X).GT.1.0D0) THEN
              GA=GA*R
              IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X))
           ENDIF
        ENDIF
        RETURN
        END SUBROUTINE

 real function zerofunc(r,z)
  zerofunc=0.
 end function

subroutine sethalodf(halfmassr,nin,totalm)
 use sphericaldfMod
 real halfmassr,nin,totalm
 call setparameters(halfmassr,nin,totalm)
end subroutine

subroutine inithalodf(densfunc)
 use sphericaldfMod
 real, external :: zerofunc
 real, external, optional :: densfunc
 if(present(densfunc)) then
  call initdf(densfunc)
 else
  call initdf(zerofunc)
 endif
end subroutine

function halodfpsi00()
 use sphericaldfMod
 real halodfpsi00
 halodfpsi00=-maxE()
end function

function halodffi(r)
 use sphericaldfMod
 real halodffi,r
! r>rmax??
 if(r.LT.rmax) then
  halodffi=-fifromr(r)
 else
  halodffi=totalmass()*(1/rmax-1/r)
 endif
end function

function Fhalo3(E)
 use sphericaldfMod
 real Fhalo3,E,nE
 Fhalo3=0
 if(E.LT.-maxE()) then
  print*, 'EEEEKS'
  print*, E, -maxE()
  stop
 endif
 nE=-E ! note: E is expected always to be > psi0!!
 if(nE.LE.0) return
 Fhalo3=distf(nE)
end function

function halodfdenspsi(psi,psi0)
 use sphericaldfMod
  real halodfdenspsi,psi,psi0,npsi
 halodfdenspsi=0
 npsi=-(psi-psi0+halodfpsi00())
 if(npsi.LE.0) return
 halodfdenspsi=rhofromfi(npsi)
end function

function halodfdens(r,z) result(x)
 use sphericaldfMod
  real r,z,x
  x=rho(sqrt(r*r+z*z))
end function

function halormax()
 use sphericaldfMod
 real halormax
 halormax=rmax
end function

function halormin()
 use sphericaldfMod
 real halormin
 halormin=rmin
end function

 function sdens(r,z)
  real r,z,sdens
  real rmdisk,zdisk,outdisk,drtrunc,erfarg,truncfac,con,diskconst,rdisk
  zdisk=0.5
  rdisk=3
  rmdisk=50.
  diskconst=rmdisk/(4.0*3.1415*rdisk**2*zdisk)
  outdisk=12
  drtrunc=.5
  sdens = 0
  if( abs(z/zdisk) .gt. 30.) return
   erfarg=(r-outdisk)/1.4142136/drtrunc
  if (erfarg.gt.4.) return
  if (erfarg.lt.-4) then
   trunfac=1
  else
   trunfac=0.5*erfc(erfarg)
  endif
  if (z.eq.0.) then
   con=1
  else
   con = exp(-abs(z/zdisk))
   con = (2.0*con/(1.0 + con*con))**2
  endif
  sdens = diskconst*exp(-r/rdisk)*con*trunfac
  end function

 program test
  use sphericaldfMod
  implicit none
    real :: r
    integer i,j,np,count
    real, external ::sdens,zerofunc

  call setparameters()
  call initdf(zerofunc)

  do i=0,100
    r=i/100.
    print*, r, rho(r), rhofromfi(fifromr(r))
  enddo
!  do i=0,ngrid-1
!   print*,r(i),dens(i),ddensdr(i)
!   print*,r(i),extdens(i),extmass(i)
!   print*,r(i),fi(i),df(i)
!  enddo
 end program


!	probvec is used to compute underlying item probabilities.
!   	numcat indicates the number of underlying categories per item.
!	mask indicates which items were presented.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
function probvec(numcat,mask,locations,scales,theta)
implicit none
interface
!	probvecitem is used to compute underlying item probabilities for one probability.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
	function probvecitem(locations,scales,theta)
		implicit none

		real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
		real(kind=8)::probvecitem(size(locations))
	end function probvecitem
end interface
integer,intent(in)::numcat(:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
real(kind=8)::probvec(size(locations))

!

!	item is the item number.

!	nloc1 is the first location of the item category and location parameter.
!	nloc2 is the end location of the item category and location parameter.

integer::item,nloc1,nloc2

!	Initialize locations.

nloc1=1
nloc2=0
probvec=0.0_8
do item=1,size(mask)
	nloc2=nloc2+numcat(item)
	if(mask(item))probvec(nloc1:nloc2)=probvecitem(locations(nloc1:nloc2),scales(:,nloc1:nloc2),theta)
	nloc1=nloc2+1
end do
return
end function probvec


      subroutine wdrdiv(ar,ai,ia,br,ib,rr,ri,ir,n,ierr)
c!    purpose
c     computes r=a./b with a real vector and b complex vector
c
c     ia,ib,ir : increment between two consecutive element of vectors a
c                b and r
c     ar,ai    : arrays containing a real and imaginary parts
c     br       : array  containing b vector
c     rr,ri    : arrays containing r real and imaginary parts
c     n        : vectors length
c     ierr     : returned error flag:
c                o   : ok
c                <>0 : b(ierr)=0
c!
c     Copyright INRIA
      double precision ar(*),ai(*),br(*),rr(*),ri(*)
      integer ia,ib,ir,n
c     wr, wi used because rr, ri may share same mem as ar,ai or br,bi
      double precision wr,wi
      jr=1
      jb=1
      ja=1
      ierr=0
      if (ia.eq.0) then
         do 10 k=1,n
            call wddiv(ar(ja),ai(ja),br(jb),wr,wi,ierr1)
            rr(jr)=wr
            ri(jr)=wi
            if(ierr1.ne.0) then
               ierr=k
c               return
            endif
            jr=jr+ir
            jb=jb+ib
 10      continue
      elseif(ib.eq.0) then
         if(br(jb).eq.0.0d0) then
            ierr=1
c            return
         endif
         do 11 k=1,n
            call wddiv(ar(ja),ai(ja),br(jb),wr,wi,ierr1)
            rr(jr)=wr
            ri(jr)=wi
            jr=jr+ir
            ja=ja+ia
 11      continue
      else
         do 12 k=1,n
            call wddiv(ar(ja),ai(ja),br(jb),wr,wi,ierr1)
            rr(jr)=wr
            ri(jr)=wi
            if(ierr1.ne.0) then
               ierr=k
c               return
            endif
            jr=jr+ir
            jb=jb+ib
            ja=ja+ia
 12      continue
      endif
      end


program hmipt
  USE DMFT_IPT
  USE SCIFOR
  USE DMFT_TOOLS
  implicit none

  logical                :: converged
  real(8)                :: n,dw,Wband
  integer                :: i,L,Lk,iloop
  complex(8)             :: zeta
  complex(8),allocatable :: sigma(:),fg(:),fg0(:)
  real(8),allocatable    :: wr(:)

  call parse_input_variable(L,"L",'inputIPT.in',default=10000)
  call parse_input_variable(Wband,'wband','inputIPT.in',default=1d0)
  call read_input("inputIPT.in")

  allocate(fg(L))
  allocate(sigma(L))
  allocate(fg0(L))
  allocate(wr(L))

  !build freq. array
  wr  = linspace(-wmax,wmax,L,mesh=dw)
  sigma=zero ; iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     !GET GLOC:
     fg=zero
     do i=1,L
        zeta = cmplx(wr(i),eps) - sigma(i)
        fg(i) = gfbether(wr(i),zeta,Wband)
     enddo
     fg0     = one/(one/fg + sigma)
     sigma   = ipt_solve_keldysh(fg0,wmax)
     converged=check_convergence(sigma,dmft_error,nsuccess,nloop)
  enddo
  call splot("G0_realw.ipt",wr,-dimag(fg0)/pi,dreal(fg0))
  call splot("G_realw.ipt",wr,-dimag(fg)/pi,dreal(fg))
  call splot("Sigma_realw.ipt",wr,sigma)

end program hmipt