      SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U,
     $                   LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the matrices A and B using (and optionally accumulating)
C     state-space and input-space transformations U and V respectively,
C     such that the pair of matrices
C
C        Ac = U' * A * U,    Bc = U' * B * V
C
C     are in upper "staircase" form. Specifically,
C
C             [ Acont     *    ]         [ Bcont ]
C        Ac = [                ],   Bc = [       ],
C             [   0    Auncont ]         [   0   ]
C
C        and
C
C                [ A11 A12  . . .  A1,p-1 A1p ]         [ B1 ]
C                [ A21 A22  . . .  A2,p-1 A2p ]         [ 0  ]
C                [  0  A32  . . .  A3,p-1 A3p ]         [ 0  ]
C        Acont = [  .   .   . . .    .     .  ],   Bc = [ .  ],
C                [  .   .     . .    .     .  ]         [ .  ]
C                [  .   .       .    .     .  ]         [ .  ]
C                [  0   0   . . .  Ap,p-1 App ]         [ 0  ]
C
C     where the blocks  B1, A21, ..., Ap,p-1  have full row ranks and
C     p is the controllability index of the pair.  The size of the
C     block Auncont is equal to the dimension of the uncontrollable
C     subspace of the pair (A, B).  The first stage of the reduction,
C     the "forward" stage, accomplishes the reduction to the orthogonal
C     canonical form (see SLICOT library routine AB01ND). The blocks
C     B1, A21, ..., Ap,p-1 are further reduced in a second, "backward"
C     stage to upper triangular form using RQ factorization. Each of
C     these stages is optional.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     STAGES  CHARACTER*1
C             Specifies the reduction stages to be performed as follows:
C             = 'F':  Perform the forward stage only;
C             = 'B':  Perform the backward stage only;
C             = 'A':  Perform both (all) stages.
C
C     JOBU    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix U the state-space transformations as follows:
C             = 'N':  Do not form U;
C             = 'I':  U is internally initialized to the unit matrix (if
C                     STAGES <> 'B'), or updated (if STAGES = 'B'), and
C                     the orthogonal transformation matrix U is
C                     returned.
C
C     JOBV    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix V the input-space transformations as follows:
C             = 'N':  Do not form V;
C             = 'I':  V is initialized to the unit matrix and the
C                     orthogonal transformation matrix V is returned.
C             JOBV is not referenced if STAGES = 'F'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The actual state dimension, i.e. the order of the
C             matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The actual input dimension.  M >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state transition matrix A to be transformed.
C             If STAGES = 'B', A should be in the orthogonal canonical
C             form, as returned by SLICOT library routine AB01ND.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state transition matrix U' * A * U.
C             The leading NCONT-by-NCONT part contains the upper block
C             Hessenberg state matrix Acont in Ac, given by U' * A * U,
C             of a controllable realization for the original system.
C             The elements below the first block-subdiagonal are set to
C             zero.  If STAGES <> 'F', the subdiagonal blocks of A are
C             triangularized by RQ factorization, and the annihilated
C             elements are explicitly zeroed.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B to be transformed.
C             If STAGES = 'B', B should be in the orthogonal canonical
C             form, as returned by SLICOT library routine AB01ND.
C             On exit with STAGES = 'F', the leading N-by-M part of
C             this array contains the transformed input matrix U' * B,
C             with all elements but the first block set to zero.
C             On exit with STAGES <> 'F', the leading N-by-M part of
C             this array contains the transformed input matrix
C             U' * B * V, with all elements but the first block set to
C             zero and the first block in upper triangular form.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
C             If STAGES <> 'B' or JOBU = 'N', then U need not be set
C             on entry.
C             If STAGES = 'B' and JOBU = 'I', then, on entry, the
C             leading N-by-N part of this array must contain the
C             transformation matrix U that reduced the pair to the
C             orthogonal canonical form.
C             On exit, if JOBU = 'I', the leading N-by-N part of this
C             array contains the transformation matrix U that performed
C             the specified reduction.
C             If JOBU = 'N', the array U is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDU = 1 and
C             declare this array to be U(1,1) in the calling program).
C
C     LDU     INTEGER
C             The leading dimension of array U.
C             If JOBU = 'I', LDU >= MAX(1,N);  if JOBU = 'N', LDU >= 1.
C
C     V       (output) DOUBLE PRECISION array, dimension (LDV,M)
C             If JOBV = 'I', then the leading M-by-M part of this array
C             contains the transformation matrix V.
C             If STAGES = 'F', or JOBV = 'N', the array V is not
C             referenced and can be supplied as a dummy array (i.e. set
C             parameter  LDV = 1 and declare this array to be V(1,1) in
C             the calling program).
C
C     LDV     INTEGER
C             The leading dimension of array V.
C             If STAGES <> 'F' and JOBV = 'I', LDV >= MAX(1,M);
C             if STAGES = 'F' or JOBV = 'N', LDV >= 1.
C
C     NCONT   (input/output) INTEGER
C             The order of the controllable state-space representation.
C             NCONT is input only if STAGES = 'B'.
C
C     INDCON  (input/output) INTEGER
C             The number of stairs in the staircase form (also, the
C             controllability index of the controllable part of the
C             system representation).
C             INDCON is input only if STAGES = 'B'.
C
C     KSTAIR  (input/output) INTEGER array, dimension (N)
C             The leading INDCON elements of this array contain the
C             dimensions of the stairs, or, also, the orders of the
C             diagonal blocks of Acont.
C             KSTAIR is input if STAGES = 'B', and output otherwise.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determination when
C             transforming (A, B). If the user sets TOL > 0, then
C             the given value of TOL is used as a lower bound for the
C             reciprocal condition number (see the description of the
C             argument RCOND in the SLICOT routine MB03OD);  a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
C             is the machine precision (see LAPACK Library routine
C             DLAMCH).
C             TOL is not referenced if STAGES = 'B'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C             IWORK is not referenced if STAGES = 'B'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             If STAGES <> 'B', LDWORK >= MAX(1, N + MAX(N,3*M));
C             If STAGES =  'B', LDWORK >= MAX(1, M + MAX(N,M)).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Staircase reduction of the pencil [B|sI - A] is used. Orthogonal
C     transformations U and V are constructed such that
C
C
C                        |B |sI-A      *  . . .  *      *       |
C                        | 1|    11       .      .      .       |
C                        |  |  A    sI-A    .    .      .       |
C                        |  |   21      22    .  .      .       |
C                        |  |        .     .     *      *       |
C     [U'BV|sI - U'AU] = |0 |     0    .     .                  |
C                        |  |            A     sI-A     *       |
C                        |  |             p,p-1    pp           |
C                        |  |                                   |
C                        |0 |         0          0   sI-A       |
C                        |  |                            p+1,p+1|
C
C
C     where the i-th diagonal block of U'AU has dimension KSTAIR(i),
C     for i = 1,...,p. The value of p is returned in INDCON. The last
C     block contains the uncontrollable modes of the (A,B)-pair which
C     are also the generalized eigenvalues of the above pencil.
C
C     The complete reduction is performed in two stages. The first,
C     forward stage accomplishes the reduction to the orthogonal
C     canonical form. The second, backward stage consists in further
C     reduction to triangular form by applying left and right orthogonal
C     transformations.
C
C     REFERENCES
C
C     [1] Van Dooren, P.
C         The generalized eigenvalue problem in linear system theory.
C         IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981.
C
C     [2] Miminis, G. and Paige, C.
C         An algorithm for pole assignment of time-invariant multi-input
C         linear systems.
C         Proc. 21st IEEE CDC, Orlando, Florida, 1, pp. 62-67, 1982.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O((N + M) x N**2) operations and is
C     backward stable (see [1]).
C
C     FURTHER COMMENTS
C
C     If the system matrices A and B are badly scaled, it would be
C     useful to scale them with SLICOT routine TB01ID, before calling
C     the routine.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
C     Supersedes Release 2.0 routine AB01CD by M. Vanbegin, and
C     P. Van Dooren, Philips Research Laboratory, Brussels, Belgium.
C
C     REVISIONS
C
C     January 14, 1997, February 12, 1998, September 22, 2003.
C
C     KEYWORDS
C
C     Controllability, generalized eigenvalue problem, orthogonal
C     transformation, staircase form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBU, JOBV, STAGES
      INTEGER           INDCON, INFO, LDA, LDB, LDU, LDV, LDWORK, M, N,
     $                  NCONT
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*), KSTAIR(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      LOGICAL           LJOBUI, LJOBVI, LSTAGB, LSTGAB
      INTEGER           I, I0, IBSTEP, ITAU, J0, JINI, JWORK, MCRT, MM,
     $                  NCRT, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          AB01ND, DGERQF, DLACPY, DLASET, DORGRQ, DORMRQ,
     $                  DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LJOBUI = LSAME( JOBU, 'I' )
C
      LSTAGB = LSAME( STAGES, 'B' )
      LSTGAB = LSAME( STAGES, 'A' ).OR.LSTAGB
C
      IF ( LSTGAB ) THEN
         LJOBVI = LSAME( JOBV, 'I' )
      END IF
C
C     Test the input scalar arguments.
C
      IF( .NOT.LSTGAB .AND. .NOT.LSAME( STAGES, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LJOBUI .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDU.LT.1 .OR. ( LJOBUI .AND. LDU.LT.N ) ) THEN
         INFO = -11
      ELSE IF( .NOT.LSTAGB .AND. LDWORK.LT.MAX( 1, N + MAX( N, 3*M ) )
     $         .OR. LSTAGB .AND. LDWORK.LT.MAX( 1, M + MAX( N, M ) ) )
     $         THEN
         INFO = -20
      ELSE IF( LSTAGB .AND. NCONT.GT.N ) THEN
         INFO = -14
      ELSE IF( LSTAGB .AND. INDCON.GT.N ) THEN
         INFO = -15
      ELSE IF( LSTGAB ) THEN
         IF( .NOT.LJOBVI .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN
            INFO = -3
         ELSE IF( LDV.LT.1 .OR. ( LJOBVI .AND. LDV.LT.M ) ) THEN
            INFO = -13
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB01OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( N, M ).EQ.0 ) THEN
         NCONT  = 0
         INDCON = 0
         IF( N.GT.0 .AND. LJOBUI )
     $      CALL DLASET( 'F', N, N, ZERO, ONE, U, LDU )
         IF( LSTGAB ) THEN
            IF( M.GT.0 .AND. LJOBVI )
     $         CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV )
         END IF
         DWORK(1) = ONE
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      ITAU = 1
      WRKOPT = 1
C
      IF ( .NOT.LSTAGB ) THEN
C
C        Perform the forward stage computations of the staircase
C        algorithm on B and A: reduce the (A, B) pair to orthogonal
C        canonical form.
C
C        Workspace: N + MAX(N,3*M).
C
         JWORK = N + 1
         CALL AB01ND( JOBU, N, M, A, LDA, B, LDB, NCONT, INDCON,
     $                KSTAIR, U, LDU, DWORK(ITAU), TOL, IWORK,
     $                DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
         WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1
      END IF
C
C     Exit if no further reduction to triangularize B1 and subdiagonal
C     blocks of A is required, or if the order of the controllable part
C     is 0.
C
      IF ( .NOT.LSTGAB ) THEN
         DWORK(1) = WRKOPT
         RETURN
      ELSE IF ( NCONT.EQ.0 .OR. INDCON.EQ.0 ) THEN
         IF( LJOBVI )
     $      CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV )
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Now perform the backward steps except the last one.
C
      MCRT = KSTAIR(INDCON)
      I0 = NCONT - MCRT + 1
      JWORK = M + 1
C
      DO 10 IBSTEP = INDCON, 2, -1
         NCRT = KSTAIR(IBSTEP-1)
         J0 = I0 - NCRT
         MM = MIN( NCRT, MCRT )
C
C        Compute the RQ factorization of the current subdiagonal block
C        of A, Ai,i-1 = R*Q (where i is IBSTEP), of dimension
C        MCRT-by-NCRT, starting in position (I0,J0).
C        The matrix Q' should postmultiply U, if required.
C        Workspace: need   M + MCRT;
C                   prefer M + MCRT*NB.
C
         CALL DGERQF( MCRT, NCRT, A(I0,J0), LDA, DWORK(ITAU),
     $                DWORK(JWORK), LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Set JINI to the first column number in A where the current
C        transformation Q is to be applied, taking the block Hessenberg
C        form into account.
C
         IF ( IBSTEP.GT.2 ) THEN
            JINI = J0 - KSTAIR(IBSTEP-2)
         ELSE
            JINI = 1
C
C           Premultiply the first block row (B1) of B by Q.
C           Workspace: need   2*M;
C                      prefer M + M*NB.
C
            CALL DORMRQ( 'Left', 'No transpose', NCRT, M, MM, A(I0,J0),
     $                   LDA, DWORK(ITAU), B, LDB, DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
         END IF
C
C        Premultiply the appropriate block row of A by Q.
C        Workspace: need   M + N;
C                   prefer M + N*NB.
C
         CALL DORMRQ( 'Left', 'No transpose', NCRT, N-JINI+1, MM,
     $                A(I0,J0), LDA, DWORK(ITAU), A(J0,JINI), LDA,
     $                DWORK(JWORK), LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Postmultiply the appropriate block column of A by Q'.
C        Workspace: need   M +  I0-1;
C                   prefer M + (I0-1)*NB.
C
         CALL DORMRQ( 'Right', 'Transpose', I0-1, NCRT, MM, A(I0,J0),
     $                LDA, DWORK(ITAU), A(1,J0), LDA, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
         IF ( LJOBUI ) THEN
C
C           Update U, postmultiplying it by Q'.
C           Workspace: need   M + N;
C                      prefer M + N*NB.
C
            CALL DORMRQ( 'Right', 'Transpose', N, NCRT, MM, A(I0,J0),
     $                   LDA, DWORK(ITAU), U(1,J0), LDU, DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
         END IF
C
C        Zero the subdiagonal elements of the current subdiagonal block
C        of A.
C
         CALL DLASET( 'F', MCRT, NCRT-MCRT, ZERO, ZERO, A(I0,J0), LDA )
         IF ( I0.LT.N )
     $      CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO,
     $                   A(I0+1,I0-MCRT), LDA )
C
         MCRT = NCRT
         I0 = J0
C
   10 CONTINUE
C
C     Now perform the last backward step on B, V = Qb'.
C
C     Compute the RQ factorization of the first block of B, B1 = R*Qb.
C     Workspace: need   M + MCRT;
C                prefer M + MCRT*NB.
C
      CALL DGERQF( MCRT, M, B, LDB, DWORK(ITAU), DWORK(JWORK),
     $             LDWORK-JWORK+1, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
      IF ( LJOBVI ) THEN
C
C        Accumulate the input-space transformations V.
C        Workspace: need 2*M;  prefer M + M*NB.
C
         CALL DLACPY( 'F', MCRT, M-MCRT, B, LDB, V(M-MCRT+1,1), LDV )
         IF ( MCRT.GT.1 )
     $      CALL DLACPY( 'L', MCRT-1, MCRT-1, B(2,M-MCRT+1), LDB,
     $                   V(M-MCRT+2,M-MCRT+1), LDV )
         CALL DORGRQ( M, M, MCRT, V, LDV, DWORK(ITAU), DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
C
         DO 20 I = 2, M
            CALL DSWAP( I-1, V(I,1), LDV, V(1,I), 1 )
   20    CONTINUE
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
      END IF
C
C     Zero the subdiagonal elements of the submatrix B1.
C
      CALL DLASET( 'F', MCRT, M-MCRT, ZERO, ZERO, B, LDB )
      IF ( MCRT.GT.1 )
     $   CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, B(2,M-MCRT+1),
     $                LDB )
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of AB01OD ***
      END


!!# FUNCTION MODULE: <FUN_xyINTEGRALXY>
MODULE FUN_xyINTEGRALXY

!!## PURPOSE
!! Integrates the function $XY$ over a polygon in 2D.

!*******************************************************************************
!
!! xyINTEGRALXY_Pg integrates the function X*Y over a polygon in 2D.
!
!  Discussion:
!
!    The polygon is bounded by the points (X(1:N), Y(1:N)).
!
!    INTEGRAL = (1/24) * sum ( 1 <= I <= N )
!      ( Y(I)   * ( 3 * X(I)**2 + 2 * X(I) * X(I-1) +     X(I-1)**2 )
!      + Y(I-1) * (     X(I)**2 + 2 * X(I) * X(I-1) + 3 * X(I-1)**2 ) )
!      * ( Y(I) - Y(I-1) )
!
!    where X(0) and Y(0) should be replaced by X(N) and Y(N).
!
!  Modified:
!
!    10 July 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    SF Bockman,
!    Generalizing the Formula for Areas of Polygons to Moments,
!    American Mathematical Society Monthly,
!    1989, pages 131-132.
!
!  Parameters:
!
!    Input, integer N, the number of vertices of the polygon.
!    N should be at least 3 for a nonzero INTEGRALXY.
!
!    Input, real ( kind = 8 ) Pg(2,N), the coordinates of the vertices
!    of the polygon.  These vertices should be given in
!    counter clockwise order.
!
!    Output, real ( kind = 8 ) INTEGRALXY, the value of the integral.
!

!!## EXTERNAL MODULES
USE FUN_Error                                   !!((04-A-FUN_Error.f90))
USE FUN_xyAVERAGEX                              !!((05-A-FUN_xyAVERAGEX.f90))
USE FUN_xyINTEGRAL1                             !!((06-A-FUN_xyINTEGRAL1.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALXY_Pg
 MODULE PROCEDURE xyINTEGRALXY_Pg_Rsp
 MODULE PROCEDURE xyINTEGRALXY_Pg_Rdp
END INTERFACE

!!## PROCEDURE OVERLOADING
!INTERFACE xyINTEGRALXY_Ls
! MODULE PROCEDURE xyINTEGRALXY_Ls_Rsp
! MODULE PROCEDURE xyINTEGRALXY_Ls_Rdp
!END INTERFACE
!
!!!## PUBLIC ACCESS LIST
!PUBLIC :: xyINTEGRALXY_Ls
!PUBLIC :: xyINTEGRALXY_Ls_Rsp
!PUBLIC :: xyINTEGRALXY_Ls_Rdp

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALXY_Pg
PUBLIC :: xyINTEGRALXY_Pg_Rsp
PUBLIC :: xyINTEGRALXY_Pg_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!
!!!### FUNCTION <xyINTEGRALXY_Ls_Rsp>
!FUNCTION xyINTEGRALXY_Ls_Rsp( Ls ) RESULT(INTEGRALX)
!
!!!#### LOCAL MAPPINGS
!USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
!USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
!INCLUDE "06-A-FUN_xyINTEGRALXY_Ls.f90.hdr"
!!!--begin--
!INCLUDE "06-A-FUN_xyINTEGRALXY_Ls.f90.bdy"
!!!--end--
!END FUNCTION
!
!
!
!!!### FUNCTION <xyINTEGRALXY_Ls_Rdp>
!FUNCTION xyINTEGRALXY_Ls_Rdp( Ls ) RESULT(INTEGRALX)
!
!!!#### LOCAL MAPPINGS
!USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rsp.f90))
!USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
!INCLUDE "06-A-FUN_xyINTEGRALXY_Ls.f90.hdr"
!!!--begin--
!INCLUDE "06-A-FUN_xyINTEGRALXY_Ls.f90.bdy"
!!!--end--
!END FUNCTION

!!### FUNCTION <xyINTEGRALXY_Pg_Rsp>
FUNCTION xyINTEGRALXY_Pg_Rsp( N , Pg ) RESULT(INTEGRALXY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALXY_Pg.f90.hdr"

!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALXY_Pg.f90.bdy"
!!--end--

END FUNCTION

!!### FUNCTION <xyINTEGRALXY_Pg_Rdp>
FUNCTION xyINTEGRALXY_Pg_Rdp( N , Pg ) RESULT(INTEGRALXY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALXY_Pg.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALXY_Pg.f90.bdy"

!!--end--
END FUNCTION

END MODULE


      subroutine spline_cubic(x,y,xx,yy,n,iflag)
      USE stel_kinds
      implicit none
!----------------------------------------------------------------------
! iflag = 0   normal return
! iflag =-1   x-request outside of bounds
! iflag =-2   xx arrays with two equal entries or not in correct order
!----------------------------------------------------------------------
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer, intent(in)  :: n
      integer, intent(inout)  :: iflag
      real(rprec), intent(in)  :: x
      real(rprec), dimension(n), intent(in)  :: xx,yy
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      real(rprec), intent(out) :: y
      real(rprec), dimension(n)  :: y2, dxx
      real(rprec) :: yp1, ypn
      real(rprec) :: c
!-----------------------------------------------

      iflag = 0  !initialization
      if(x < xx(1) .or. x > xx(n)) then
        iflag = -1
        y=0.d+0
        return
      endif
      dxx(1:n-1)=xx(2:n)-xx(1:n-1)
      if(minval(dxx(1:n-1)) <= 0.d+0) then
        iflag=-2
        return
      endif

! fix boundary derivatives by quadratic fit
! left part
      c=((yy(3)-yy(1))/(xx(3)-xx(1))-(yy(2)-yy(1))/(xx(2)-xx(1)))
     >  /(xx(3)-xx(2))
      yp1=(yy(2)-yy(1))/(xx(2)-xx(1))-c*(xx(2)-xx(1))
! right part
      c=((yy(n-2)-yy(n))/(xx(n-2)-xx(n))
     >  -(yy(n-1)-yy(n))/(xx(n-1)-xx(n)))
     >  /(xx(n-2)-xx(n-1))
      ypn=(yy(n-1)-yy(n))/(xx(n-1)-xx(n))-c*(xx(n-1)-xx(n))

      call spline_nr(xx,yy,n,yp1,ypn,y2)
      call splint_nr(xx,yy,y2,n,x,y)

      return

      contains

      subroutine spline_nr(x,y,n,yp1,ypn,y2)
! taken from numerical recipes f77 and recoded.
! Given the arrays x(1:n) and y(1:n) containing the tabulated function
! with x(1) < x(2) <...< x(n) and given values yp1 and ypn for the first
! derivative of the interpolating function at points q and n, respectively,
! this routine returns an array y2(1:n) of length n which contains the
! second derivatives of the interpolating function at the tabulated points x(i).
! If yp1 and/or ypn are equatl to 1ed+30 or larger, the routine is signaled
! to set the correspoinding boundary condition for a natural spline with zero
! derivative on that boundary.
! nmax is the largest anticipated value of n.
      integer, intent(in) :: n
      integer, parameter :: nmax=500
      real(rprec), intent(in) :: yp1, ypn
      real(rprec), dimension(n), intent(in) :: x, y
      real(rprec), dimension(n), intent(out) :: y2
      integer :: i,k
      real(rprec) :: p, qn, sig, un
      real(rprec), dimension(n) :: u

      if(yp1 > .99d+30) then
        y2(1)=0.d+0
        u(1) =0.d+0
      else
        y2(1)=-0.5d+0
        u(1)=(3.d+0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      endif

      do i=2,n-1
        sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        p=sig*y2(i-1)+2.d+0
        y2(i)=(sig-1.d+0)/p
        u(i)=(6.d+0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
     >       /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
      enddo
      if (ypn > .99d+30)then
        qn=0.d+0
        un=0.d+0
      else
        qn=0.5d+0
        un=(3.d+0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      endif
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.d+0)
      do k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
      enddo
      return
      end subroutine spline_nr

      subroutine splint_nr(xa,ya,y2a,n,x,y)
! Given the arrays xa(1:n) and ya(1:n) of length n, which tabulate a function
! with the xa(i)'s in order), and given the array y2a(1:n), which is the
! output from spline above, and given a value of x, this routine returns
! a cubic-spline interpolated value y.
      implicit none
      integer, intent(in) :: n
      real(rprec), intent(in) :: x
      real(rprec), intent(out) :: y
      real(rprec), dimension(n), intent(in) :: xa, ya, y2a
!- local -------------------
      real(rprec) :: a, b, h
      integer :: k, khi, klo

      klo=1
      khi=n
      do
        if (khi-klo <= 1) exit  !inverted num.rec. condition for endless do-loop exit
        k=(khi+klo)/2
        if(xa(k) > x) then
          khi=k
        else
          klo=k
        endif
      enddo

      h=xa(khi)-xa(klo)
      if(h ==0.d+0)
     >    stop "spline_cubic: bad xa input! xa(i) have to be distinct!"
      a=(xa(khi)-x)/h
      b=(x-xa(klo))/h
      y=a*ya(klo)+b*ya(khi) +
     >  ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.d+0
      return
      end subroutine splint_nr

      end subroutine spline_cubic


      PROGRAM xgaucof
C     driver for routine gaucof
      INTEGER NP
      REAL SQRTPI
      PARAMETER(NP=64,SQRTPI=1.7724539)
      INTEGER i,n
      REAL amu0,check,a(NP),b(NP),x(NP),w(NP)
1     write(*,*) 'Enter N'
      read(*,*,END=99) n
      do 11 i=1,n-1
        a(i)=0.
        b(i+1)=i*.5
11    continue
      a(n)=0.
C     b(1) is arbitrary for call to TQLI
      amu0=SQRTPI
      call gaucof(n,a,b,amu0,x,w)
      write(*,'(/1x,t3,a,t10,a,t22,a/)') '#','X(I)','W(I)'
      do 12 i=1,n
        write(*,'(1x,i2,2e14.6)') i,x(i),w(i)
12    continue
      check=0.
      do 13 i=1,n
        check=check+w(i)
13    continue
      write(*,'(/1x,a,e15.7,a,e15.7)') 'Check value:',check,
     *  '  should be:',SQRTPI
      go to 1
99    stop
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xgaucof.for


      SUBROUTINE  SPOINT(ALP,X,Y,D,SD,CD,DISL1,DISL2,DISL3,
     *                   U1,U2,U3,U11,U12,U21,U22,U31,U32)
C*****
C*****    SURFACE DISPLACEMENT,STRAIN,TILT DUE TO BURIED POINT SOURCE
C*****    IN A SEMIINFINITE MEDIUM     CODED BY  Y.OKADA ... JAN 1985
C*****
C***** INPUT
C*****   ALP   : MEDIUM CONSTANT  MYU/(LAMDA+MYU)
C*****   X,Y   : COORDINATE OF STATION
C*****   D     : SOURCE DEPTH
C*****   SD,CD : SIN,COS OF DIP-ANGLE
C*****          (CD=0.D0, SD=+/-1.D0 SHOULD BE GIVEN FOR VERTICAL FAULT)
C*****   DISL1,DISL2,DISL3 : STRIKE-, DIP- AND TENSILE-DISLOCATION
C*****
C***** OUTPUT
C*****   U1, U2, U3      : DISPLACEMENT ( UNIT= UNIT OF DISL / AREA )
C*****   U11,U12,U21,U22 : STRAIN       ( UNIT= UNIT OF DISL /
C*****   U31,U32         : TILT                 UNIT OF X,Y,D /AREA )
C*****
      IMPLICIT REAL*8 (A-H,O-Z)
      DATA  F0,F1,F2,F3,F4,F5,F8,F9
     *      /0.D0, 1.D0, 2.D0, 3.D0, 4.D0, 5.D0, 8.D0, 9.D0/
      PI2=6.283185307179586D0
C*****
      P =Y*CD + D*SD
      Q =Y*SD - D*CD
      S =P*SD + Q*CD
      X2=X*X
      Y2=Y*Y
      XY=X*Y
      D2=D*D
      R2=X2 + Y2 + D2
      R =SQRT(R2)
      R3=R *R2
      R5=R3*R2
      QR=F3*Q/R5
      XR =F5*X2/R2
      YR =F5*Y2/R2
      XYR=F5*XY/R2
      DR =F5*D /R2
      RD =R + D
      R12=F1/(R*RD*RD)
      R32=R12*(F2*R + D)/ R2
      R33=R12*(F3*R + D)/(R2*RD)
      R53=R12*(F8*R2 + F9*R*D + F3*D2)/(R2*R2*RD)
      R54=R12*(F5*R2 + F4*R*D +    D2)/R3*R12
C*****
      A1= ALP*Y*(R12-X2*R33)
      A2= ALP*X*(R12-Y2*R33)
      A3= ALP*X/R3 - A2
      A4=-ALP*XY*R32
      A5= ALP*( F1/(R*RD) - X2*R32 )
      B1= ALP*(-F3*XY*R33      + F3*X2*XY*R54)
      B2= ALP*( F1/R3 - F3*R12 + F3*X2*Y2*R54)
      B3= ALP*( F1/R3 - F3*X2/R5) - B2
      B4=-ALP*F3*XY/R5 - B1
      C1=-ALP*Y*(R32 - X2*R53)
      C2=-ALP*X*(R32 - Y2*R53)
      C3=-ALP*F3*X*D/R5 - C2
C*****
      U1 =F0
      U2 =F0
      U3 =F0
      U11=F0
      U12=F0
      U21=F0
      U22=F0
      U31=F0
      U32=F0
C**************************************
C*****                            *****
C*****  STRIKE-SLIP CONTRIBUTION  *****
C*****                            *****
C**************************************
      IF(DISL1.EQ.F0)  GO TO 200
      UN=DISL1/PI2
      QRX=QR*X
      FX=F3*X/R5*SD
      U1 =U1 - UN*( QRX*X + A1*SD )
      U2 =U2 - UN*( QRX*Y + A2*SD )
      U3 =U3 - UN*( QRX*D + A4*SD )
      U11=U11- UN*( QRX* (F2-XR)        + B1*SD )
      U12=U12- UN*(-QRX*XYR      + FX*X + B2*SD )
      U21=U21- UN*( QR*Y*(F1-XR)        + B2*SD )
      U22=U22- UN*( QRX *(F1-YR) + FX*Y + B4*SD )
      U31=U31- UN*( QR*D*(F1-XR)        + C1*SD )
      U32=U32- UN*(-QRX*DR*Y     + FX*D + C2*SD )
C**************************************
C*****                            *****
C*****    DIP-SLIP CONTRIBUTION   *****
C*****                            *****
C**************************************
  200 IF(DISL2.EQ.F0)  GO TO 300
      UN=DISL2/PI2
      SDCD=SD*CD
      QRP=QR*P
      FS=F3*S/R5
      U1 =U1 - UN*( QRP*X - A3*SDCD )
      U2 =U2 - UN*( QRP*Y - A1*SDCD )
      U3 =U3 - UN*( QRP*D - A5*SDCD )
      U11=U11- UN*( QRP*(F1-XR)        - B3*SDCD )
      U12=U12- UN*(-QRP*XYR     + FS*X - B1*SDCD )
      U21=U21- UN*(-QRP*XYR            - B1*SDCD )
      U22=U22- UN*( QRP*(F1-YR) + FS*Y - B2*SDCD )
      U31=U31- UN*(-QRP*DR*X           - C3*SDCD )
      U32=U32- UN*(-QRP*DR*Y    + FS*D - C1*SDCD )
C****************************************
C*****                              *****
C*****  TENSILE-FAULT CONTRIBUTION  *****
C*****                              *****
C****************************************
  300 IF(DISL3.EQ.F0)  GO TO 900
      UN=DISL3/PI2
      SDSD=SD*SD
      QRQ=QR*Q
      FQ=F2*QR*SD
      U1 =U1 + UN*( QRQ*X - A3*SDSD )
      U2 =U2 + UN*( QRQ*Y - A1*SDSD )
      U3 =U3 + UN*( QRQ*D - A5*SDSD )
      U11=U11+ UN*( QRQ*(F1-XR)        - B3*SDSD )
      U12=U12+ UN*(-QRQ*XYR     + FQ*X - B1*SDSD )
      U21=U21+ UN*(-QRQ*XYR            - B1*SDSD )
      U22=U22+ UN*( QRQ*(F1-YR) + FQ*Y - B2*SDSD )
      U31=U31+ UN*(-QRQ*DR*X           - C3*SDSD )
      U32=U32+ UN*(-QRQ*DR*Y    + FQ*D - C1*SDSD )
C*****
  900 RETURN
      END
      SUBROUTINE  SRECTF(ALP,X,Y,DEP,AL,AW,SD,CD,DISL1,DISL2,DISL3,
     *                   U1,U2,U3,U11,U12,U21,U22,U31,U32)
C*****
C*****   SURFACE DISPLACEMENTS,STRAINS AND TILTS DUE TO RECTANGULAR
C*****   FAULT IN A HALF-SPACE       CODED BY  Y.OKADA ... JAN 1985
C*****
C***** INPUT
C*****   ALP   : MEDIUM CONSTANT  MYU/(LAMDA+MYU)
C*****   X,Y   : COORDINATE OF STATION
C*****   DEP   : SOURCE DEPTH
C*****   AL,AW : LENGTH AND WIDTH OF FAULT
C*****   SD,CD : SIN,COS OF DIP-ANGLE
C*****          (CD=0.D0, SD=+/-1.D0 SHOULD BE GIVEN FOR VERTICAL FAULT)
C*****   DISL1,DISL2,DISL3 : STRIKE-, DIP- AND TENSILE-DISLOCATION
C*****
C***** OUTPUT
C*****   U1, U2, U3      : DISPLACEMENT ( UNIT= UNIT OF DISL     )
C*****   U11,U12,U21,U22 : STRAIN       ( UNIT= UNIT OF DISL /
C*****   U31,U32         : TILT                 UNIT OF X,Y,,,AW )
C*****
C***** SUBROUTINE USED...SRECTG
C*****
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  U(9),DU(9)
      DATA  F0, F1 / 0.D0, 1.D0 /
C*****
      P = Y*CD + DEP*SD
      Q = Y*SD - DEP*CD
C*****
      DO 1111  I=1,9
 1111 U(I)=F0
C*****
      DO 5555  K=1,2
       IF(K.EQ.1)  ET=P
       IF(K.EQ.2)  ET=P-AW
       DO 4444  J=1,2
        IF(J.EQ.1)  XI=X
        IF(J.EQ.2)  XI=X-AL
        JK=J+K
        IF(JK.NE.3)  SIGN= F1
        IF(JK.EQ.3)  SIGN=-F1
        CALL SRECTG(ALP,XI,ET,Q,SD,CD,DISL1,DISL2,DISL3,
     *           DU(1),DU(2),DU(3),DU(4),DU(5),DU(6),DU(7),DU(8),DU(9))
        DO 3333  I=1,9
         U(I)=U(I)+SIGN*DU(I)
 3333   CONTINUE
 4444  CONTINUE
 5555 CONTINUE
      U1 =U(1)
      U2 =U(2)
      U3 =U(3)
      U11=U(4)
      U12=U(5)
      U21=U(6)
      U22=U(7)
      U31=U(8)
      U32=U(9)
      RETURN
      END
      SUBROUTINE  SRECTG(ALP,XI,ET,Q,SD,CD,DISL1,DISL2,DISL3,
     *                   U1,U2,U3,U11,U12,U21,U22,U31,U32)
C*****
C*****   INDEFINITE INTEGRAL OF SURFACE DISPLACEMENTS, STRAINS AND TILTS
C*****   DUE TO FINITE FAULT IN A SEMIINFINITE MEDIUM
C*****                                    CODED BY  Y.OKADA ... JAN 1985
C***** INPUT
C*****   ALP     : MEDIUM CONSTANT  MYU/(LAMDA+MYU)
C*****   XI,ET,Q : FAULT COORDINATE
C*****   SD,CD   : SIN,COS OF DIP-ANGLE
C*****          (CD=0.D0, SD=+/-1.D0 SHOULD BE GIVEN FOR VERTICAL FAULT)
C*****   DISL1,DISL2,DISL3 : STRIKE-, DIP- AND TENSILE-DISLOCATION
C*****
C***** OUTPUT
C*****   U1, U2, U3      : DISPLACEMENT ( UNIT= UNIT OF DISL    )
C*****   U11,U12,U21,U22 : STRAIN       ( UNIT= UNIT OF DISL /
C*****   U31,U32         : TILT                 UNIT OF XI,ET,Q )
C*****
      IMPLICIT REAL*8 (A-H,O-Z)
      DATA  F0,F1,F2/ 0.D0, 1.D0, 2.D0 /
      PI2=6.283185307179586D0
C*****
      XI2=XI*XI
      ET2=ET*ET
      Q2=Q*Q
      R2=XI2+ET2+Q2
      R =DSQRT(R2)
      R3=R*R2
      D =ET*SD-Q*CD
      Y =ET*CD+Q*SD
      RET=R+ET
      IF(RET.LT.F0)  RET=F0
      RD =R+D
      RRD=F1/(R*RD)
C*****
      IF( Q .NE.F0)  TT = DATAN( XI*ET/(Q*R) )
      IF( Q .EQ.F0)  TT = F0
      IF(RET.NE.F0)  RE = F1/RET
      IF(RET.EQ.F0)  RE = F0
      IF(RET.NE.F0)  DLE= DLOG(RET)
      IF(RET.EQ.F0)  DLE=-DLOG(R-ET)
! === Modification to prevent zero-division. ===================================
!     RRX=F1/(R*(R+XI))
      IF(ABS(R*(R+XI)).LT.1.0D-6) THEN
         RRX=1.0D6
      ELSE
         RRX=F1/(R*(R+XI))
      ENDIF
! ==============================================================================
      RRE=RE/R
      AXI=(F2*R+XI)*RRX*RRX/R
      AET=(F2*R+ET)*RRE*RRE/R
      IF(CD.EQ.F0)  GO TO 20
C*****
C***** INCLINED FAULT
C*****
      TD=SD/CD
      X =DSQRT(XI2+Q2)
      IF(XI.EQ.F0)  A5=F0
      IF(XI.NE.F0)
     *A5= ALP*F2/CD*DATAN( (ET*(X+Q*CD)+X*(R+X)*SD) / (XI*(R+X)*CD) )
      A4= ALP/CD*( DLOG(RD) - SD*DLE )
      A3= ALP*(Y/RD/CD - DLE) + TD*A4
      A1=-ALP/CD*XI/RD        - TD*A5
      C1= ALP/CD*XI*(RRD - SD*RRE)
      C3= ALP/CD*(Q*RRE - Y*RRD)
      B1= ALP/CD*(XI2*RRD - F1)/RD - TD*C3
      B2= ALP/CD*XI*Y*RRD/RD       - TD*C1
      GO TO 30
C*****
C***** VERTICAL FAULT
C*****
   20 RD2=RD*RD
      A1=-ALP/F2*XI*Q/RD2
      A3= ALP/F2*( ET/RD + Y*Q/RD2 - DLE )
      A4=-ALP*Q/RD
      A5=-ALP*XI*SD/RD
      B1= ALP/F2*  Q  /RD2*(F2*XI2*RRD - F1)
      B2= ALP/F2*XI*SD/RD2*(F2*Q2 *RRD - F1)
      C1= ALP*XI*Q*RRD/RD
      C3= ALP*SD/RD*(XI2*RRD - F1)
C*****
   30 A2=-ALP*DLE - A3
      B3=-ALP*XI*RRE - B2
      B4=-ALP*( CD/R + Q*SD*RRE ) - B1
      C2= ALP*(-SD/R + Q*CD*RRE ) - C3
C*****
      U1 =F0
      U2 =F0
      U3 =F0
      U11=F0
      U12=F0
      U21=F0
      U22=F0
      U31=F0
      U32=F0
C**************************************
C*****                            *****
C*****  STRIKE-SLIP CONTRIBUTION  *****
C*****                            *****
C**************************************
      IF(DISL1.EQ.F0)  GO TO 200
      UN=DISL1/PI2
      REQ=RRE*Q
      U1 =U1 - UN*( REQ*XI +   TT    + A1*SD )
      U2 =U2 - UN*( REQ*Y  + Q*CD*RE + A2*SD )
      U3 =U3 - UN*( REQ*D  + Q*SD*RE + A4*SD )
      U11=U11+ UN*( XI2*Q*AET - B1*SD )
      U12=U12+ UN*( XI2*XI*( D/(ET2+Q2)/R3 - AET*SD ) - B2*SD )
      U21=U21+ UN*( XI*Q/R3*CD + (XI*Q2*AET - B2)*SD )
      U22=U22+ UN*( Y *Q/R3*CD + (Q*SD*(Q2*AET-F2*RRE)
     *                            -(XI2+ET2)/R3*CD - B4)*SD )
      U31=U31+ UN*(-XI*Q2*AET*CD + (XI*Q/R3 - C1)*SD )
      U32=U32+ UN*( D*Q/R3*CD + (XI2*Q*AET*CD - SD/R + Y*Q/R3 - C2)*SD )
C**************************************
C*****                            *****
C*****    DIP-SLIP CONTRIBUTION   *****
C*****                            *****
C**************************************
  200 IF(DISL2.EQ.F0)  GO TO 300
      UN=DISL2/PI2
      SDCD=SD*CD
      U1 =U1 - UN*( Q/R             - A3*SDCD )
      U2 =U2 - UN*( Y*Q*RRX + CD*TT - A1*SDCD )
      U3 =U3 - UN*( D*Q*RRX + SD*TT - A5*SDCD )
      U11=U11+ UN*( XI*Q/R3            + B3*SDCD )
      U12=U12+ UN*( Y *Q/R3 - SD/R     + B1*SDCD )
      U21=U21+ UN*( Y *Q/R3 + Q*CD*RRE + B1*SDCD )
      U22=U22+ UN*( Y*Y*Q*AXI - (F2*Y*RRX + XI*CD*RRE)*SD + B2*SDCD )
      U31=U31+ UN*( D *Q/R3 + Q*SD*RRE + C3*SDCD )
      U32=U32+ UN*( Y*D*Q*AXI - (F2*D*RRX + XI*SD*RRE)*SD + C1*SDCD )
C****************************************
C*****                              *****
C*****  TENSILE-FAULT CONTRIBUTION  *****
C*****                              *****
C****************************************
  300 IF(DISL3.EQ.F0)  GO TO 900
      UN=DISL3/PI2
      SDSD=SD*SD
      U1 =U1 + UN*( Q2*RRE                       - A3*SDSD )
      U2 =U2 + UN*(-D*Q*RRX - SD*(XI*Q*RRE - TT) - A1*SDSD )
      U3 =U3 + UN*( Y*Q*RRX + CD*(XI*Q*RRE - TT) - A5*SDSD )
      U11=U11- UN*( XI*Q2*AET             + B3*SDSD )
      U12=U12- UN*(-D*Q/R3 - XI2*Q*AET*SD + B1*SDSD )
      U21=U21- UN*( Q2*(CD/R3 + Q*AET*SD) + B1*SDSD )
      U22=U22- UN*((Y*CD-D*SD)*Q2*AXI - F2*Q*SD*CD*RRX
     *                      - (XI*Q2*AET - B2)*SDSD )
      U31=U31- UN*( Q2*(SD/R3 - Q*AET*CD) + C3*SDSD )
      U32=U32- UN*((Y*SD+D*CD)*Q2*AXI + XI*Q2*AET*SD*CD
     *                       - (F2*Q*RRX - C1)*SDSD )
C*****
  900 RETURN
      END


!==========================================================================
elemental function gsw_z_from_p (p, lat)
!==========================================================================
!
! Calculates the height z from pressure p
!
! p      : sea pressure                                    [dbar]
! lat    : latitude                                        [deg]
!
! gsw_z_from_p : height                                    [m]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_enthalpy_sso_0

use gsw_mod_teos10_constants, only : deg2rad, gamma

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: p, lat

real (r8) :: gsw_z_from_p

real (r8) :: sin2, b, c, a

sin2 = sin(lat*deg2rad)**2
b = 9.780327_r8*(1.0_r8 + (5.2792e-3_r8 + (2.32e-5_r8*sin2))*sin2)
a = -0.5_r8*gamma*b
c = gsw_enthalpy_sso_0(p)

gsw_z_from_p = -2.0_r8*c/(b + sqrt(b*b - 4.0_r8*a*c))

return
end function

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


* STERN-BROCOT SEQUENCE - FORTRAN IV
      DIMENSION ISB(2400)
      NN=2400
      ISB(1)=1
      ISB(2)=1
      I=1
      J=2
      K=2
 1    IF(K.GE.NN) GOTO 2
        K=K+1
        ISB(K)=ISB(K-I)+ISB(K-J)
        K=K+1
        ISB(K)=ISB(K-J)
        I=I+1
        J=J+1
        GOTO 1
 2    N=15
      WRITE(*,101) N
  101 FORMAT(1X,'FIRST',I4)
      WRITE(*,102) (ISB(I),I=1,15)
  102 FORMAT(15I4)
      DO 5 J=1,11
        JJ=J
        IF(J.EQ.11) JJ=100
        DO 3 I=1,K
          IF(ISB(I).EQ.JJ) GOTO 4
 3      CONTINUE
 4      WRITE(*,103) JJ,I
  103   FORMAT(1X,'FIRST',I4,' AT ',I4)
 5    CONTINUE
      END


      SUBROUTINE KPLTST (G1,G2,G3,G4)
C
C     THIS ROUTINE WILL VERIFY THAT THE 4 GRID POINTS IN 3 SPACE LIE IN
C     AN APPROXIMATE PLANE. IF NOT THE NOGO FLAG IS SET TRUE AND A
C     MESSAGE IS WRITEN.
C
      LOGICAL         NOGO
      INTEGER         OUT
      REAL            G1(3),G2(3),G3(3),G4(3)
      CHARACTER       UFM*23,UWM*25
      COMMON /XMSSG / UFM,UWM
      COMMON /SYSTEM/ SYSBUF,OUT,NOGO
      COMMON /SMA1ET/ ID
      COMMON /SMA1DP/ R13(3),R24(3),RXR(3),R(3)
C
      R13(1) = G3(1) - G1(1)
      R13(2) = G3(2) - G1(2)
      R13(3) = G3(3) - G1(3)
      R24(1) = G4(1) - G2(1)
      R24(2) = G4(2) - G2(2)
      R24(3) = G4(3) - G2(3)
      CALL SAXB (R13,R24,RXR)
C
C     NORMALIZE
C
      DL     = SQRT(RXR(1)**2 + RXR(2)**2 + RXR(3)**2)
      IF (DL) 20,20,10
   10 RXR(1) = RXR(1)/DL
      RXR(2) = RXR(2)/DL
      RXR(3) = RXR(3)/DL
      R1L    = SQRT(R13(1)**2 + R13(2)**2 + R13(3)**2)
      R2L    = SQRT(R24(1)**2 + R24(2)**2 + R24(3)**2)
      DL     = AMIN1(R1L,R2L)
      R(1)   = G2(1) - G1(1)
      R(2)   = G2(2) - G1(2)
      R(3)   = G2(3) - G1(3)
      DH     = SADOTB(R,RXR)
      IF (DL) 20,20,15
   15 IF (ABS(DH/DL) .LE. 0.10) RETURN
C
C     NOT PLANER
C
   20 CALL PAGE2 (-2)
      WRITE  (OUT,30) UWM,ID
   30 FORMAT (A25,' 4000, ONE SIDE OF ELEMENT',I10,
     1       ' CONNECTING FOUR POINTS IS NOT APPROXIMATELY PLANER.')
      RETURN
      END


    subroutine gauinv(p,xp,ierr)
!-----------------------------------------------------------------------

! Computes the inverse of the standard normal cumulative distribution
! function with a numerical approximation from : Statistical Computing,
! by W.J. Kennedy, Jr. and James E. Gentle, 1980, p. 95.

! INPUT/OUTPUT:

!   p    = double precision cumulative probability value: dble(psingle)
!   xp   = G^-1 (p) in single precision
!   ierr = 1 - then error situation (p out of range), 0 - OK

!-----------------------------------------------------------------------
    real*8 :: p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,y,pp,lim,p
    save   p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,lim

! Coefficients of approximation:

    data lim/1.0e-10/
    data p0/-0.322232431088/,p1/-1.0/,p2/-0.342242088547/, &
    p3/-0.0204231210245/,p4/-0.0000453642210148/
    data q0/0.0993484626060/,q1/0.588581570495/,q2/0.531103462366/, &
    q3/0.103537752850/,q4/0.0038560700634/

! Check for an error situation:

    ierr = 1
    if(p < lim) then
        xp = -1.0e10
        return
    end if
    if(p > (1.0-lim)) then
        xp =  1.0e10
        return
    end if
    ierr = 0

! Get k for an error situation:

    pp   = p
    if(p > 0.5) pp = 1 - pp
    xp   = 0.0
    if(p == 0.5) return

! Approximate the function:

    y  = dsqrt(dlog(1.0/(pp*pp)))
    xp = real( y + ((((y*p4+p3)*y+p2)*y+p1)*y+p0) / &
    ((((y*q4+q3)*y+q2)*y+q1)*y+q0) )
    if(real(p) == real(pp)) xp = -xp

! Return with G^-1(p):

    return
    end subroutine gauinv


program matrix
    implicit none
    integer, parameter :: ROWS = 3, COLS = 5
    real, dimension(ROWS, COLS) :: A
    integer :: i, j
    real :: total

    A = reshape([ (((i - 1)*size(A, 2) + j, j=1,size(A, 2)), i=1,size(A, 1)) ], &
                shape(A))
    do i = 1, size(A, 1)
        print *, A(i, :)
    end do
    total = 0.0
    do j = 1, size(A, 2)
        do i = 1, size(A, 1)
            total = total + A(i, j)**2
        end do
    end do
    print '(/, A, F10.2)', 'total = ', total
end program matrix


program ch0501
    ! Simple Arithmetic Expressions in Fortran
    implicit none

    real :: gross_wage, net_wage, tax
    real :: tax_rate = 0.25
    integer :: personal_allowance = 10000
    character(60) :: their_name

    print *, ' Input employees name'
    read *, their_name
    print *, ' Input Gross wage'
    read *, gross_wage
    tax = (gross_wage-personal_allowance)*tax_rate
    net_wage = gross_wage-tax
    print *, ' Employee: ', their_name
    print *, ' Gross Pay: ', gross_wage
    print *, ' Tax: ', tax
    print *, ' Net Pay:', net_wage
end program


| simple Body Mass Index calculator

variable height
variable weight

: hello cr ." BMI calculator 1.0" cr ;
: getheight
	cr
	." Please enter your height, in centimeters: "
	pad 10 accept
	dup if
		pad swap eval height !
	;then
	drop
	getheight
	;
: getweight
	cr
	." Please enter your weight in kilograms: "
	pad 10 accept
	dup if
		pad swap eval weight !
	;then
	drop
	getweight
	;

: showbmi
	cr
	." For a weight of " weight ? ." kg,"
	." and height of " height ? ." cm,"
	." the BMI is: "
		weight @
		100000 height @ dup * */
		10 /mod (.) type '. emit .
	cr
	;
hello getheight getweight showbmi bye


!
! Spin-weighted associated Legendre function routines, along with
! Legendre polynomial roots and weights for Gaussian qudrature to
! go to/from coefficient and real space
!
module mod_swal
!=============================================================================
   use mod_prec
   use mod_field,  only: field, set_level
   use mod_io,     only: set_arr
   use mod_params, only: &
      nx, ny, nl, max_l, &
      min_m, max_m, min_s, max_s

   implicit none
!=============================================================================
   private

   ! gauss points y, cos(y), sin(y)
   real(rp), allocatable, protected, public :: Yvec(:),   cyvec(:),   syvec(:)
   real(rp), allocatable, protected, public :: Yarr(:,:), cyarr(:,:), syarr(:,:)

   ! subroutines
   public :: swal_init, compute_swal_laplacian, swal_lower, swal_raise

   public :: swal_filter

   public :: swal_test_orthonormal, swal_test_to_from

   public :: swal_real_to_coef

   ! weights for Gaussian integration
   real(rp), allocatable :: weights(:)

   ! going to/from swal sapce
   real(rp), allocatable, protected, public :: swal(:,:,:,:)

   ! evaluate in real space
   real(rp), allocatable :: &
      laplacian(:,:,:,:), lower(:,:,:,:), raise(:,:,:,:), low_pass(:,:,:,:)
!=============================================================================
contains
!=============================================================================
   integer(ip) function compute_lmin(spin, m_ang) result(lmin)
      integer(ip), intent(in)  :: spin, m_ang

      lmin = max(abs(spin),abs(m_ang))
   end function compute_lmin
!=============================================================================
   subroutine swal_init()
      character(:), allocatable :: mstr, sstr
      integer(ip) :: m_ang, spin, i, j, k, min_l
      !-----------------------------------------------------------------
      allocate(Yvec(ny))
      allocate(cyvec(ny))
      allocate(syvec(ny))
      allocate(Yarr(nx,ny))
      allocate(cyarr(nx,ny))
      allocate(syarr(nx,ny))

      allocate(weights(ny))

      allocate(swal(ny,0:max_l,min_m:max_m,min_s:max_s))
      allocate(laplacian(ny,ny,min_m:max_m,min_s:max_s))
      allocate(lower(    ny,ny,min_m:max_m,min_s:max_s))
      allocate(raise(    ny,ny,min_m:max_m,min_s:max_s))
      allocate(low_pass( ny,ny,min_m:max_m,min_s:max_s))
      !-----------------------------------------------------------------
      call set_arr('roots_legendre.txt', ny, Yvec)

      call set_arr('cos.txt', ny, cyvec)
      call set_arr('sin.txt', ny, syvec)

      do i=1,nx
         Yarr(i,:)  = Yvec
         cyarr(i,:) = cyvec
         syarr(i,:) = syvec
      end do
      !-----------------------------------------------------------------
      ! weights for Gaussian quadrature
      call set_arr('weights_legendre.txt', ny, weights)
      !-----------------------------------------------------------------
      ! spin-weighted spherical associated Legendre polynomials
      do spin=min_s,max_s

         sstr = '     '
         write (sstr,'(i5)') spin
         sstr = trim(adjustl(sstr))

         do m_ang=min_m,max_m

            mstr = '     '
            write (mstr,'(i5)') m_ang
            mstr = trim(adjustl(mstr))

            call set_arr('s_'//sstr//'_m_' //mstr//'.txt', ny,nl,swal(:,:,m_ang,spin))
         end do
      end do
      !-----------------------------------------------------------------
      ! precompute swal laplacian array
      !-----------------------------------------------------------------
      laplacian = 0
      do spin =min_s,max_s
      do m_ang=min_m,max_m
         do i=1,ny
         do j=1,ny
            min_l = compute_lmin(spin, m_ang)

            do k=min_l,max_l
               laplacian(j,i,m_ang,spin) = laplacian(j,i,m_ang,spin) &
               -  real(k-spin,rp)*real(k+spin+1,rp)   &
                  *weights(j)*swal(j,k,m_ang,spin)  &
                  *swal(i,k,m_ang,spin)
            end do
         end do
         end do
      end do
      end do
      !-----------------------------------------------------------------
      ! precompute raising array
      !-----------------------------------------------------------------
      raise = 0
      do spin =min_s,max_s-1
      do m_ang=min_m,max_m
         do i=1,ny
         do j=1,ny
            min_l = max(abs(spin), abs(spin+1), abs(m_ang))

            do k=min_l,max_l
               raise(j,i,m_ang,spin) = raise(j,i,m_ang,spin) &
               +  sqrt(real(k-spin,rp)*real(k+spin+1.0_rp,rp)) &
                  *weights(j)*swal(j,k,m_ang,spin)  &
                  *swal(i,k,m_ang,spin+1)
            end do
         end do
         end do
      end do
      end do
      !-----------------------------------------------------------------
      ! precompute lowering array
      !-----------------------------------------------------------------
      lower = 0
      do spin =min_s+1,max_s
      do m_ang=min_m,  max_m
         do i=1,ny
         do j=1,ny
            min_l = max(abs(spin), abs(spin-1), abs(m_ang))

            do k=min_l,max_l
               lower(j,i,m_ang,spin) = lower(j,i,m_ang,spin) &
               -  sqrt(real(k+spin,rp)*real(k-spin+1,rp))   &
                  *weights(j)*swal(j,k,m_ang,spin)  &
                  *swal(i,k,m_ang,spin-1)
            end do
         end do
         end do
      end do
      end do
      !-----------------------------------------------------------------
      ! precompute swal low-pass filter array
      !-----------------------------------------------------------------
      low_pass = 0
      do spin =min_s,max_s
      do m_ang=min_m,max_m
         do i=1,ny
         do j=1,ny
            do k=0,max_l
               low_pass(j,i,m_ang,spin) = low_pass(j,i,m_ang,spin) &
               +  exp(-40.0_rp*(real(k,rp)/real(max_l,rp))**16) &
                  *weights(j)*swal(j,k,m_ang,spin)  &
                  *swal(i,k,m_ang,spin)
            end do
         end do
         end do
      end do
      end do
      !-----------------------------------------------------------------
      !-----------------------------------------------------------------
   end subroutine swal_init
!=============================================================================
! Gaussian quadrature.
! Integrate against complex conjugate cc[s_Y^m_l]=(-1)^{m+s} {-s}_Y^{-m}_l
!=============================================================================
   subroutine swal_real_to_coef(spin,m_ang,vals,coefs)
      integer(ip), intent(in) :: spin
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,     ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,0:max_l,min_m:max_m), intent(out) :: coefs

      integer(ip) :: lmin, j, k

      lmin  = compute_lmin(spin,m_ang)

      coefs(:,:,m_ang) = 0.0_rp

      do k=lmin,max_l
      do j=1,ny
         coefs(:,k,m_ang) =  &
            coefs(:,k,m_ang) &
         +  (vals(:,j,m_ang) * weights(j) * swal(j,k,m_ang,spin))
      end do
      end do
   end subroutine swal_real_to_coef
!=============================================================================
! coefficient synthesis
!=============================================================================
   subroutine swal_coef_to_real(spin,m_ang,coefs,vals)
      integer(ip), intent(in) :: spin
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,0:max_l,min_m:max_m), intent(in)  :: coefs
      complex(rp), dimension(nx,     ny,min_m:max_m), intent(out) :: vals

      integer(ip) :: lmin, j, k

      lmin = compute_lmin(spin,m_ang)
      vals(:,:,m_ang) = 0.0_rp

      do j=1,ny
      do k=lmin,max_l
         vals(:,j,m_ang) = &
            vals(:,j,m_ang) &
         + (coefs(:,k,m_ang) * swal(j,k,m_ang,spin))
      end do
      end do
   end subroutine swal_coef_to_real
!=============================================================================
   subroutine swal_laplacian(spin,m_ang,vals,vals_lap)
      integer(ip), intent(in) :: spin
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: vals_lap

      integer(ip) :: j, jp

      vals_lap(:,:,m_ang) = 0

      do j =1,ny
      do jp=1,ny
         vals_lap(:,j,m_ang) = vals_lap(:,j,m_ang) &
         +  vals(:,jp,m_ang)*laplacian(jp,j,m_ang,spin)
      end do
      end do

   end subroutine swal_laplacian
!=============================================================================
   subroutine compute_swal_laplacian(step,m_ang,f)
      integer(ip), intent(in) :: step, m_ang
      type(field), intent(inout) :: f

      call set_level(step,m_ang,f)

      call swal_laplacian(f%spin,m_ang,f%level,f%swal_lap)

   end subroutine compute_swal_laplacian
!=============================================================================
   subroutine swal_lower(spin,m_ang,vals,vals_lowered)
      integer(ip), intent(in) :: spin
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: vals_lowered

      integer(ip) :: j, jp

      vals_lowered(:,:,m_ang) = 0

      do j =1,ny
      do jp=1,ny
         vals_lowered(:,j,m_ang) = vals_lowered(:,j,m_ang) &
         +  vals(:,jp,m_ang)*lower(jp,j,m_ang,spin)
      end do
      end do

   end subroutine swal_lower
!=============================================================================
   subroutine swal_raise(spin,m_ang,vals,vals_raised)
      integer(ip), intent(in) :: spin
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: vals_raised

      integer(ip) :: j, jp

      vals_raised(:,:,m_ang) = 0

      do j =1,ny
      do jp=1,ny
         vals_raised(:,j,m_ang) = vals_raised(:,j,m_ang) &
         +  vals(:,jp,m_ang)*raise(jp,j,m_ang,spin)
      end do
      end do

   end subroutine swal_raise
!=============================================================================
! Low pass filter. A smooth filter appears to help prevent Gibbs-like ringing
!=============================================================================
   subroutine swal_filter(m_ang,f)
      integer(ip), intent(in) :: m_ang
      type(field), intent(inout) :: f

      integer(ip) :: j, jp

      f%level(:,:,m_ang) = 0

      do j =1,ny
      do jp=1,ny
         f%level(:,j,m_ang) = f%level(:,j,m_ang) &
         +  f%np1(:,jp,m_ang)*low_pass(jp,j,m_ang,f%spin)
      end do
      end do

      f%np1(:,:,m_ang) = f%level(:,:,m_ang)

   end subroutine swal_filter
!=============================================================================
! test that the swal are orthogonal
!=============================================================================
   subroutine swal_test_orthonormal()

      integer(ip) :: s, m, l1, l2, j
      real(rp)    :: integral

      write (*,*) 'swal_test_orthonormal'

      do s=min_s,max_s
      do m=min_m,max_m
      do l1= 0,max_l
      do l2=l1,max_l
         integral = 0.0_rp
         do j=1,ny
            integral = integral + weights(j)*swal(j,l1,m,s)*swal(j,l2,m,s)!*(((-1.0_rp)**(m+s))*swal(j,l2,-m,-s))
         end do
         if (abs(integral)>1e-14) then
            write (*,*) s,m,l1,l2,integral
         end if
      end do
      end do
      end do
      end do

   end subroutine swal_test_orthonormal
!=============================================================================
   subroutine swal_test_to_from(spin,m_ang,vals_in,coefs,vals_out)
      integer(ip), intent(in) :: spin, m_ang
      complex(rp), dimension(nx,ny,     min_m:max_m), intent(in)    :: vals_in
      complex(rp), dimension(nx,0:max_l,min_m:max_m), intent(inout) :: coefs
      complex(rp), dimension(nx,ny,     min_m:max_m), intent(out)   :: vals_out

      write(*,*) "swal_test_to_from. spin: ", spin, ", m_ang: ", m_ang

      call swal_real_to_coef(spin,m_ang,vals_in,coefs)
      call swal_coef_to_real(spin,m_ang,coefs,vals_out)

   end subroutine swal_test_to_from
!=============================================================================
end module mod_swal


!==============================================================================
! CALCULO DE LOS COEFICIENTES DE VAN DER WAALS A PARTIR DE LOS ARCHIVOS DE
! LOS ARCHIVOS DE LA G(r) OBTENIDOS DE LA SIMULACION CON POTENCIAL SW
!
! AUTOR : MARTIN ALEJANDRO PAREDES SOSA
!==============================================================================

!DECLARACION DE VARIABLES
Program Waals
  !Use Basic
  Implicit None
  Integer :: DENS                                 ! PARA NOMBRE DE ARCHIVO
  Integer :: State                                ! ESTADO DE LECTURA
  Integer :: k, i, j                              ! CONTADOR
  Character (len=3), Parameter :: Start = "gdr"   ! NOMBRE DE ARCHIVO DE ENTRADA
  Character (len=4), Parameter :: En = ".dat"     ! EXTENSION ARCHIVO DE ENTRADA
  Character (len=10):: Filename, cons             ! NOMBRE DE ARCHIVO
  Real, Parameter :: PI = 4.0 * ATAN(1.0)         ! VALOR DE PI
  Real, Parameter :: TP = 1.0                     ! TEMPERATURA REDUCIDA
  Real, Parameter :: Lambda = 1.25                ! FIN POZO
  Real, Dimension(:),Allocatable ::  R , G        ! RADIO | DISTRIBUCION RADIAL
  Real :: a, b, a74                               ! PARAMETROS VAN DER WAALS
  Real :: ctea, ctea74, cteb, delta , gr1         ! PARAMETROS PARA CALCULO DE a Y b VAN DER WAALS
  Real :: Intg                                    ! ACUMULADOR PARA INTEGRACION

  Write(*,*) "========================"
  Open(8, File = "a_starT1.dat", Action= "write") !ARCHIVO DE SALIDA T*=1.0
  Open(9, File = "a_starT74.dat", Action= "write") !ARCHIVO DE SALIDA T*=0.74
  Archivo:  Do Dens = 1, 10
     !TAMANO DEL ARCHIVO POR LEER
     Write(Cons,256) Dens
     Filename = start//trim(Cons)//En
     Write(*,*) "Archivo: ",Filename

     Open( 1, File = Trim(Filename), action= "read", Status ="old" ) !ARCHIVO DE ENTRADA
     k = 0 !REINICIA CONTADOR
     Sizes: Do                         !BUSCANDO TAMAÑO DE ARCHIVO (RENGLONES QUE QUE TIENE)

        Read( 1,*, iostat = state  )
        k = k + 1
        If ( state .LT. 0 ) Exit

     End Do Sizes

     Write(*,*) "Tiene", k, "Renglones" !DEBUG LINE (SIZE OF FILE)

     Rewind 1 !REINICIAR ARCHIVO DE ENTRADA
     Allocate ( R(k), G(k) )

     !SAVING FILE DATA
     Saves : Do i = 1, k+1

        Read( 1,*, iostat = state  ) R(i), G(i)
        If ( state .LT. 0 ) Exit

     End Do Saves

     Write(*,*) "DATOS GUARDADOS EN MEMORIA"

     !CALC DE a VAN DER WAALS
     Ctea = (2.0*Pi) / TP
     Ctea74 = (2.0*Pi)/ 0.74
     Cteb = (2.0/3.0)*PI
     Delta = 0.05                  ! CAMBIAR SEGUN EL ARCHIVO

     Locate: Do i = 1, k           ! BUSCANDO EL PRIMER DATO .GE. 1.0

        If (R(i) .GE. 1.0) Exit

     End Do Locate

     gr1 = G(i)                    ! Ghd(1+)
     b = cteb*gr1                  ! b DE VAN DER WAALS

     ! ALGORITMO DE INTEGRACION POR TRAPECIO
     Intg = R(i)*R(i)*G(i)*0.5
     IntegrandoA: Do j = i+1 ,k

        If ( R(j+1) .GT. lambda) Exit
        Intg = Intg + R(j)*R(j) * G(j)

     End Do IntegrandoA

     Intg = Intg + 0.5*R(j)*R(j)*G(j)

     a = Intg*delta*ctea         ! a DE VAN DER WAALS
     a74 = Intg*delta*ctea74
     Write(*,*) "a*= ", a
      Write(*,*) "a74*= ", a74
     Write(*,*) "b*= ", b
     Write(8,*) Dens*0.1, a  , b
     Write(9,*) Dens*0.1, a74, b

     Deallocate(R,G)
     Write(*,*) "========================"
  End Do Archivo

512 Format (I5.5)
256 Format (I2.2)
End Program Waals


SUBROUTINE LUDCMP(A,N,NP,INDX,D)
  IMPLICIT NONE

  !Transferred variables
  INTEGER::N,NP,INDX(N)
  REAL(8)::D,A(NP,NP)

  !Local variables
  INTEGER,PARAMETER::NMAX=500
  REAL(8),PARAMETER::TINY=1D-20
  INTEGER::I,IMAX,J,K
  REAL(8)::AAMAX,DUM,SUM,VV(NMAX)

  D=1.0
  DO I=1,N
    AAMAX=0.0
    DO J=1,N
      IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
    END DO
    IF (AAMAX.EQ.0.0) PAUSE 'Singular matrix.'
    VV(I)=1.0/AAMAX
  END DO
  DO J=1,N
    IF (J.GT.1) THEN
      DO I=1,J-1
        SUM=A(I,J)
        IF (I.GT.1)THEN
          DO K=1,I-1
            SUM=SUM-A(I,K)*A(K,J)
          END DO
          A(I,J)=SUM
        END IF
      END DO
    END IF
    AAMAX=0.0
    DO I=J,N
      SUM=A(I,J)
      IF (J.GT.1) THEN
        DO K=1,J-1
          SUM=SUM-A(I,K)*A(K,J)
        END DO
        A(I,J)=SUM
      END IF
      DUM=VV(I)*ABS(SUM)
      IF (DUM.GE.AAMAX) THEN
        IMAX=I
        AAMAX=DUM
      END IF
    END DO
    IF (J.NE.IMAX) THEN
      DO K=1,N
        DUM=A(IMAX,K)
        A(IMAX,K)=A(J,K)
        A(J,K)=DUM
      END DO
      D=-D
      VV(IMAX)=VV(J)
    END IF
    INDX(J)=IMAX
    IF (J.NE.N) THEN
      IF (A(J,J).EQ.0.0) A(J,J)=TINY
      DUM=1.0/A(J,J)
      DO I=J+1,N
        A(I,J)=A(I,J)*DUM
      END DO
    END IF
  END DO
  IF (A(N,N).EQ.0.0) A(N,N)=TINY

END SUBROUTINE LUDCMP