      SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA,
     $                   B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a solution, optionally corresponding to specified free
C     elements, to a real linear least squares problem:
C
C         minimize || A * X - B ||
C
C     using a complete orthogonal factorization of the M-by-N matrix A,
C     which may be rank-deficient.
C
C     Several right hand side vectors b and solution vectors x can be
C     handled in a single call; they are stored as the columns of the
C     M-by-NRHS right hand side matrix B and the N-by-NRHS solution
C     matrix X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies whether or not a standard least squares solution
C             must be computed, as follows:
C             = 'L':  Compute a standard least squares solution (Y = 0);
C             = 'F':  Compute a solution with specified free elements
C                     (given in Y).
C
C     INIPER  CHARACTER*1
C             Specifies whether an initial column permutation, defined
C             by JPVT, must be performed, as follows:
C             = 'P':  Perform an initial column permutation;
C             = 'N':  Do not perform an initial column permutation.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     NRHS    (input) INTEGER
C             The number of right hand sides, i.e., the number of
C             columns of the matrices B and X.  NRHS >= 0.
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest leading triangular
C             submatrix R11 in the QR factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             0 <= RCOND <= 1.
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix C, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of C
C             (for instance, the Frobenius norm of C).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the given matrix A.
C             On exit, the leading M-by-N part of this array contains
C             details of its complete orthogonal factorization:
C             the leading RANK-by-RANK upper triangular part contains
C             the upper triangular factor T11 (see METHOD);
C             the elements below the diagonal, with the entries 2 to
C             min(M,N)+1 of the array DWORK, represent the orthogonal
C             matrix Q as a product of min(M,N) elementary reflectors
C             (see METHOD);
C             the elements of the subarray A(1:RANK,RANK+1:N), with the
C             next RANK entries of the array DWORK, represent the
C             orthogonal matrix Z as a product of RANK elementary
C             reflectors (see METHOD).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,NRHS)
C             On entry, the leading M-by-NRHS part of this array must
C             contain the right hand side matrix B.
C             On exit, the leading N-by-NRHS part of this array contains
C             the solution matrix X.
C             If M >= N and RANK = N, the residual sum-of-squares for
C             the solution in the i-th column is given by the sum of
C             squares of elements N+1:M in that column.
C             If NRHS = 0, this array is not referenced, and the routine
C             returns the effective rank of A, and its QR factorization.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,M,N).
C
C     Y       (input) DOUBLE PRECISION array, dimension ( N*NRHS )
C             If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as
C             free elements in computing the solution (see METHOD).
C             The remaining elements are not referenced.
C             If JOB = 'L', or NRHS = 0, this array is not referenced.
C
C     JPVT    (input/output) INTEGER array, dimension (N)
C             On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th
C             column of A is an initial column, otherwise it is a free
C             column.  Before the QR factorization of A, all initial
C             columns are permuted to the leading positions; only the
C             remaining free columns are moved as a result of column
C             pivoting during the factorization.
C             If INIPER = 'N', JPVT need not be set on entry.
C             On exit, if JPVT(i) = k, then the i-th column of A*P
C             was the k-th column of A.
C
C     RANK    (output) INTEGER
C             The effective rank of A, i.e., the order of the submatrix
C             R11.  This is the same as the order of the submatrix T11
C             in the complete orthogonal factorization of A.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R11:
C             SVAL(1): largest singular value of  R(1:RANK,1:RANK);
C             SVAL(2): smallest singular value of R(1:RANK,1:RANK);
C             SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
C                      if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
C                      otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the leading columns were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(1:RANK,1:RANK).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and the entries 2 to min(M,N) + RANK + 1
C             contain the scalar factors of the elementary reflectors
C             used in the complete orthogonal factorization of A.
C             Among the entries 2 to min(M,N) + 1, only the first RANK
C             elements are useful, if INIPER = 'N'.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS )
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     If INIPER = 'P', the routine first computes a QR factorization
C     with column pivoting:
C         A * P = Q * [ R11 R12 ]
C                     [  0  R22 ]
C     with R11 defined as the largest leading submatrix whose estimated
C     condition number is less than 1/RCOND.  The order of R11, RANK,
C     is the effective rank of A.
C     If INIPER = 'N', the effective rank is estimated during a
C     truncated QR factorization (with column pivoting) process, and
C     the submatrix R22 is not upper triangular, but full and of small
C     norm. (See SLICOT Library routines MB03OD or MB03OY, respectively,
C     for further details.)
C
C     Then, R22 is considered to be negligible, and R12 is annihilated
C     by orthogonal transformations from the right, arriving at the
C     complete orthogonal factorization:
C        A * P = Q * [ T11 0 ] * Z
C                    [  0  0 ]
C     The solution is then
C        X = P * Z' [ inv(T11)*Q1'*B ]
C                   [        Y       ]
C     where Q1 consists of the first RANK columns of Q, and Y contains
C     free elements (if JOB = 'F'), or is zero (if JOB = 'L').
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     FURTHER COMMENTS
C
C     Significant gain in efficiency is possible for small-rank problems
C     using truncated QR factorization (option INIPER = 'N').
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, Technical University of Sofia, Oct. 1998,
C     modification of the LAPACK routine DGELSX.
C     V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library
C     version.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005.
C
C     KEYWORDS
C
C     Least squares problems, QR factorization.
C
C     ******************************************************************
C
      DOUBLE PRECISION   ZERO, ONE, DONE, NTDONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO,
     $                     NTDONE = ONE )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          INIPER, JOB
      INTEGER            INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     ..
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   SVAL( 3 ), Y ( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEASTS, PERMUT
      INTEGER            I, IASCL, IBSCL, J, K, MAXWRK, MINWRK, MN
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMLNUM, T1, T2
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLABAD, DLACPY, DLASCL, DLASET, DORMQR, DORMRZ,
     $                   DTRSM, DTZRZF, MB03OD, MB03OY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      MN = MIN( M, N )
      LEASTS = LSAME( JOB, 'L' )
      PERMUT = LSAME( INIPER, 'P' )
C
C     Test the input scalar arguments.
C
      INFO   = 0
      MINWRK = MAX( MN + 3*N + 1, 2*MN + NRHS )
      IF( .NOT. ( LEASTS .OR. LSAME( JOB, 'F' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( PERMUT .OR. LSAME( INIPER, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN
         INFO = -6
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -11
      ELSE IF( LDWORK.LT.MINWRK ) THEN
         INFO = -17
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02QD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MN.EQ.0 ) THEN
         RANK = 0
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Get machine parameters.
C
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
C
C     Scale A, B if max entries outside range [SMLNUM,BIGNUM].
C
      ANRM = DLANGE( 'M', M, N, A, LDA, DWORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
C
C        Scale matrix norm up to SMLNUM.
C
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
C
C        Scale matrix norm down to BIGNUM.
C
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
C
C        Matrix all zero. Return zero solution.
C
         IF( NRHS.GT.0 )
     $      CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         RANK = 0
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      IF( NRHS.GT.0 ) THEN
         BNRM = DLANGE( 'M', M, NRHS, B, LDB, DWORK )
         IBSCL = 0
         IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
C
C           Scale matrix norm up to SMLNUM.
C
            CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB,
     $                   INFO )
            IBSCL = 1
         ELSE IF( BNRM.GT.BIGNUM ) THEN
C
C           Scale matrix norm down to BIGNUM.
C
            CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB,
     $                   INFO )
            IBSCL = 2
         END IF
      END IF
C
C     Compute a rank-revealing QR factorization of A and estimate its
C     effective rank using incremental condition estimation:
C        A * P = Q * R.
C     Workspace need   min(M,N)+3*N+1;
C               prefer min(M,N)+2*N+N*NB.
C     Details of Householder transformations stored in DWORK(1:MN).
C     (Note: Comments in the code beginning "Workspace:" describe the
C      minimal amount of workspace needed at that point in the code,
C      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
      MAXWRK = MINWRK
      IF( PERMUT ) THEN
         CALL MB03OD( 'Q', M, N, A, LDA, JPVT, RCOND, SVLMAX,
     $                DWORK( 1 ), RANK, SVAL, DWORK( MN+1 ), LDWORK-MN,
     $                INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( MN+1 ) ) + MN )
      ELSE
         CALL MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                DWORK( 1 ), DWORK( MN+1 ), INFO )
      END IF
C
C     Logically partition R = [ R11 R12 ]
C                             [  0  R22 ],
C     where R11 = R(1:RANK,1:RANK).
C
C     [R11,R12] = [ T11, 0 ] * Z.
C
C     Details of Householder transformations stored in DWORK(MN+1:2*MN).
C     Workspace need   3*min(M,N);
C               prefer 2*min(M,N)+min(M,N)*NB.
C
      IF( RANK.LT.N ) THEN
         CALL DTZRZF( RANK, N, A, LDA, DWORK( MN+1 ), DWORK( 2*MN+1 ),
     $                LDWORK-2*MN, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN )
      END IF
C
      IF( NRHS.GT.0 ) THEN
C
C        B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS).
C
C        Workspace: need   2*min(M,N)+NRHS;
C                   prefer   min(M,N)+NRHS*NB.
C
         CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA,
     $                DWORK( 1 ), B, LDB, DWORK( 2*MN+1 ), LDWORK-2*MN,
     $                INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN )
C
C        B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS).
C
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
     $               NRHS, ONE, A, LDA, B, LDB )
C
         IF( RANK.LT.N ) THEN
C
C           Set B(RANK+1:N,1:NRHS).
C
            IF( LEASTS ) THEN
               CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO,
     $                      B(RANK+1,1), LDB )
            ELSE
               CALL DLACPY( 'Full', N-RANK, NRHS, Y, N-RANK,
     $                      B(RANK+1,1), LDB )
            END IF
C
C           B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS).
C
C           Workspace need   2*min(M,N)+NRHS;
C                     prefer 2*min(M,N)+NRHS*NB.
C
            CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
     $                   LDA, DWORK( MN+1 ), B, LDB, DWORK( 2*MN+1 ),
     $                   LDWORK-2*MN, INFO )
            MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN )
         END IF
C
C        Additional workspace: NRHS.
C
C        B(1:N,1:NRHS) := P * B(1:N,1:NRHS).
C
         DO 50 J = 1, NRHS
            DO 20 I = 1, N
               DWORK( 2*MN+I ) = NTDONE
   20       CONTINUE
            DO 40 I = 1, N
               IF( DWORK( 2*MN+I ).EQ.NTDONE ) THEN
                  IF( JPVT( I ).NE.I ) THEN
                     K  = I
                     T1 = B( K, J )
                     T2 = B( JPVT( K ), J )
   30                CONTINUE
                     B( JPVT( K ), J ) = T1
                     DWORK( 2*MN+K ) = DONE
                     T1 = T2
                     K  = JPVT( K )
                     T2 = B( JPVT( K ), J )
                     IF( JPVT( K ).NE.I )
     $                  GO TO 30
                     B( I, J ) = T1
                     DWORK( 2*MN+K ) = DONE
                  END IF
               END IF
   40       CONTINUE
   50    CONTINUE
C
C        Undo scaling for B.
C
         IF( IBSCL.EQ.1 ) THEN
            CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB,
     $                   INFO )
         ELSE IF( IBSCL.EQ.2 ) THEN
            CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB,
     $                   INFO )
         END IF
      END IF
C
C     Undo scaling for A.
C
      IF( IASCL.EQ.1 ) THEN
         IF( NRHS.GT.0 )
     $      CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB,
     $                   INFO )
         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         IF( NRHS.GT.0 )
     $      CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB,
     $                   INFO )
         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      END IF
C
      DO 60 I = MN + RANK, 1, -1
         DWORK( I+1 ) = DWORK( I )
   60 CONTINUE
C
      DWORK( 1 ) = MAXWRK
      RETURN
C *** Last line of MB02QD ***
      END


!     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!     M. Behr [AHPCRC]                                                     c
!     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
subroutine get_hg(x, hg)
  use fluid_variables
  implicit none

  real(8) :: x(nsd,nen)
  real(8) :: hg

  if((etype.eq.tet).or.(etype.eq.tets))then
     hg = max(sqrt((x(1,2)-x(1,1))**2 &
                  +(x(2,2)-x(2,1))**2 &
                  +(x(3,2)-x(3,1))**2 &
           ), sqrt((x(1,3)-x(1,2))**2 &
                  +(x(2,3)-x(2,2))**2 &
                  +(x(3,3)-x(3,2))**2 &
           ), sqrt((x(1,1)-x(1,3))**2 &
                  +(x(2,1)-x(2,3))**2 &
                  +(x(3,1)-x(3,3))**2 &
           ), sqrt((x(1,4)-x(1,1))**2 &
                  +(x(2,4)-x(2,1))**2 &
                  +(x(3,4)-x(3,1))**2 &
           ), sqrt((x(1,4)-x(1,2))**2 &
                  +(x(2,4)-x(2,2))**2 &
                  +(x(3,4)-x(3,2))**2 &
           ), sqrt((x(1,4)-x(1,3))**2 &
                  +(x(2,4)-x(2,3))**2 &
                  +(x(3,4)-x(3,3))**2))

  else if((etype.eq.hex).or.(etype.eq.hexs))then
     hg = 0.577350269 * max(        &
          sqrt((x(1,7)-x(1,1))**2   &
             + (x(2,7)-x(2,1))**2   &
             + (x(3,7)-x(3,1))**2), &
          sqrt((x(1,5)-x(1,3))**2   &
             + (x(2,5)-x(2,3))**2   &
             + (x(3,5)-x(3,3))**2), &
          sqrt((x(1,8)-x(1,2))**2   &
             + (x(2,8)-x(2,2))**2   &
             + (x(3,8)-x(3,2))**2), &
          sqrt((x(1,6)-x(1,4))**2   &
             + (x(2,6)-x(2,4))**2   &
             + (x(3,6)-x(3,4))**2))
  else
     call error("get_hg: unsupported element type", -999, .true.)
  end if

  return
end


      DOUBLE PRECISION FUNCTION RZINTD(IP,IQ,R,Z,NGRIDS)
      DOUBLE PRECISION R(4),Z(4),PT(3),H(3)
      DOUBLE PRECISION XINT,RRP,ZZQ,DRDXI,DZDXI,DRDETA,DZDETA,DETJ
      DOUBLE PRECISION RR,ZZ
      IF(NGRIDS.EQ.3)GO TO 200
      NPT=3
      PT(1)=-.7745966692D0
      PT(2)=0.D0
      PT(3)=-PT(1)
      H(1)=5.D0/9.D0
      H(2)=8.D0/9.D0
      H(3)=H(1)
      XINT=0.D0
      DO 100 III=1,NPT
      DO 100 JJJ=1,NPT
      RR=.25D0*((1.D0-PT(III))*(1.D0-PT(JJJ))*R(1)
     1         +(1.D0+PT(III))*(1.D0-PT(JJJ))*R(2)
     1         +(1.D0+PT(III))*(1.D0+PT(JJJ))*R(3)
     1         +(1.D0-PT(III))*(1.D0+PT(JJJ))*R(4))
      ZZ=.25D0*((1.D0-PT(III))*(1.D0-PT(JJJ))*Z(1)
     1         +(1.D0+PT(III))*(1.D0-PT(JJJ))*Z(2)
     1         +(1.D0+PT(III))*(1.D0+PT(JJJ))*Z(3)
     1         +(1.D0-PT(III))*(1.D0+PT(JJJ))*Z(4))
      RRP=RR**IP
      ZZQ=ZZ**IQ
      DRDXI=.25D0*((1.D0-PT(JJJ))*(R(2)-R(1))+(1.D0+PT(JJJ))*(R(3)-R(4))
     1)
      DZDXI=.25D0*((1.D0-PT(JJJ))*(Z(2)-Z(1))+(1.D0+PT(JJJ))*(Z(3)-Z(4))
     1)
      DRDETA=.25D0*((1.D0-PT(III))*(R(4)-R(1))+(1.D0+PT(III))*(R(3)-R(2)
     1))
      DZDETA=.25D0*((1.D0-PT(III))*(Z(4)-Z(1))+(1.D0+PT(III))*(Z(3)-Z(2)
     1))
      DETJ=DRDXI*DZDETA-DZDXI*DRDETA
      DETJ=DABS(DETJ)
      XINT=XINT+RRP*ZZQ*H(III)*H(JJJ)*DETJ
  100 CONTINUE
      RZINTD=XINT
  200 RETURN
      END


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! Tests REAL lowering
subroutine test_real()
  real(4) :: r4
  real(8) :: r8

  r4 = real(z'40', kind=4)
  r8 = real(z'40', kind=8)

end subroutine

! CHECK-LABEL: func @_QPtest_real() {
! CHECK:  %[[VAL_0:.*]] = fir.alloca f32 {bindc_name = "r4", uniq_name = "_QFtest_realEr4"}
! CHECK:  %[[VAL_1:.*]] = fir.alloca f64 {bindc_name = "r8", uniq_name = "_QFtest_realEr8"}
! CHECK:  %[[CST_0:.*]] = arith.constant 8.968310e-44 : f32
! CHECK:  fir.store %[[CST_0]] to %[[VAL_0]] : !fir.ref<f32>
! CHECK:  %[[CST_1:.*]] = arith.constant 3.162020e-322 : f64
! CHECK:  fir.store %[[CST_1]] to %[[VAL_1]] : !fir.ref<f64>
! CHECK:  return


      real*8 function fctrl(i)
c
c     This subroutine returns the factorial function. The factorials
c     from 0! to 10! are programmed into a data statement.
c
c     This subroutine is called by:
c
c       Any
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       i     = argument
c
c     Output:
c
c       fctrl = factorial
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer i
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ifac(0:10),ifactr,j
c
c-----------------------------------------------------------------------
c
c     Set low factorials.
c
      data (ifac(j), j = 0,10) /1,1,2,6,24,120,720,5040,40320,
     $ 362880,3628800/
c
c-----------------------------------------------------------------------
c
      if ( i.ge.0 .and. i.le.10) then
        fctrl = ifac(i)
      elseif (i.gt.10) then
        ifactr = ifac(10)
        do j = 10 + 1,i
          ifactr = ifactr*j
        enddo
        fctrl = ifactr
      endif
c
      end


c Set up Cartesian coordinate system by short distance conversion.
c Unrotated coordinate system with pos. x-axis toward WEST
c and pos. y-axis toward NORTH.
c pos. z-axis toward EARTH`s CENTER.

	subroutine setorg(orlat, orlon, rota, ifil)  !22. Okt. 1990

	implicit none

c	Parameters:
	real	orlat, orlon
	real	rota		! Anticlockwise rotation (degrees)
	integer	ifil

	include "geocoord.inc"

	real	arota
	doubleprecision r, lat1, lat2, dela, delb, PHI, BETA

c     O(r)LAT & O(r)LON : origin of cartesian coordinate system
c      north  w e s t

c if orlat and orlon are both set to zero , the Swiss Cartesian
c coordinate system will be used (this system cannot be rotated).
c  For all other cases, orlat and orlon denote the origin of
c  the SDC.

       rad = 0.017453292d0

      if(orlat.eq.0.0.and.orlon.eq.0.0)then
         olat=46.95240  ! BERN North
         olon=-7.439583  ! BERN West
         rotate=0.0
      else
         olat=orlat
         olon=orlon
         rotate=rota*rad
      endif

      olat=olat*60. ! minutes N
      olon=olon*60. ! minutes W

C  NEW ELLIPSOID FOR WHOLE EARTH:   WGS72 == WORLD GEODETIC SYSTEM 1972

C  ALSO SET RLATC ACCORDING TO ORIGIN

      REARTH=6378.135D0
      ELLIP=298.26         ! (flattening)

C CALCULATE RLATC:  CONVERSION FROM GEOGRAPHICAL LAT TO GEOCENTRICAL LAT

      PHI=OLAT*RAD/60.0              !  phi=geogr. lat
      BETA=PHI-DSIN(PHI*2.)/ELLIP    !  beta=geoc. lat
      RLATC=DTAN(BETA)/DTAN(PHI)

C WRITE ELLIPSOIDE CONSTANTS

      if(ifil.gt.0)then
         write(ifil,*)
         write(ifil,*)
         write(ifil,*)'SHORT DISTANCE CONVERSION on ELLIPSOIDE of'//
     &                ' WORLD GEODETIC SYSTEM 1972 (WGS72)'
         write(ifil,*)'=========================================='//
     &                '==================================='
         write(ifil,*)
         write(ifil,'('' Radius at equator (REARTH)= '',f10.5,
     &                ''  km'')') rearth
         write(ifil,'(''   1. / (ellipticity)      = '',f10.3)') ellip
         write(ifil,*)
         write(ifil,*)'Origin of cartesian coordinates [degrees]:'
         if(orlat.eq.0.0.and.orlon.eq.0.0)then
            write(ifil,*)
            write(ifil,*)' SWISS COORDINATE SYSTEM (we have to be'
            write(ifil,*)'                               special)'
            write(ifil,*)' (Origin = city of BERNE, Switzerland)'
            write(ifil,*)
            write(ifil,*) ' no rotation of grid, pos. y-axis toward N'
            write(ifil,*) '                      pos. x-axis toward E'
            write(ifil,*)
         else
           write(ifil,'(1x,f12.7,'' N'',5x,f12.7,'' W'')')
     &               olat/60.,olon/60.

           write(ifil,*)
           write(ifil,*) ' without rotation of grid, '
           write(ifil,*) '             pos. x-axis toward WEST'
           write(ifil,*) '             pos. y-axis toward NORTH'
           write(ifil,*)
           write(ifil,*) ' Rotation of y-axis from North anticlock-'
           write(ifil,*) ' wise with pos. angle given in degrees'
           write(ifil,*)
           IF(ROTA.GE.0.) THEN
             write(ifil,*) ' Rotation of grid anticlockwise by'
             write(ifil,*)'  ', rota,' degrees'
             write(ifil,*)
           ELSE
             write(ifil,*) ' Rotation of grid clockwise by'
             arota=-1.*rota
             write(ifil,*)'  ', arota,' degrees'
             write(ifil,*)
           ENDIF
         endif
      endif

c   calculate aa &  bb
c   length of one minute of lat and lon in km

      lat1 = datan(rlatc*dtan(olat*rad/60.0))       ! geoc. lat for OLAT
      lat2 = datan(rlatc*dtan((olat+1.)*rad/60.0))  ! geoc. lat for (OLAT+1min)
      dela = lat2 - lat1
      r = rearth*(1.0 - (dsin(lat1)**2)/ellip)      ! kugelradius fuer lat=OLAT
      aa = r*dela   ! aa = 1 min geogr. lat
      delb = dacos(dsin(lat1)**2 + dcos(rad/60.)*dcos(lat1)**2)
      bc=r*delb     ! bc = 1 min geogr. lon
      bb = r*delb/dcos(lat1)
      if(ifil.gt.0)then
         write(ifil,'('' Radius of sphere at OLAT = '',f10.3,'' km'')')r
         write(ifil,*)
         write(ifil,*)'Conversion of GEOGRAPHICAL LATITUDE to '//
     &                'GEOCENTRICAL LATITUDE:'
         write(ifil,*)'RLATC = TAN(GEOCENTR.LAT) / TAN(GEOGRAPH.LAT)'
         write(ifil,'(1x,''RLATC = '',f12.8)') rlatc
         write(ifil,*)
         write(ifil,4) aa, bc
 4       format (10x,'Short distance conversions:',/,
     &           10x,'one min lat ~ ', f7.4,' km ',/,
     &           10x,'one min lon ~ ', f7.4,' km ',/)
         write(ifil,*)
         write(ifil,*)
      endif

c***  convert coordinates with rotation cosines (stored in Common)
      sint=sin(rotate)
      cost=cos(rotate)

      return
      end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of tk in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: *temp *propunit *pres tk
!   with respect to varying inputs: *temp *propunit *pres
!   Plus diff mem management of: temp:in propunit:in pres:in
!>    @brief harmonic mean Kz on cell faces in z direction over delz*
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return z hydraulic conductivity over delz*  (1/s)
!>    @details
!>    Compute the harmonic mean of Kz on the cell face in positive
!>    z-direction from the current node (i, j, k) divided by the
!>    z-distance of the current node (i, j, k) to the neighboring node
!>    (i, j, k+1).
!>
!>    delz* = 0.5 ( delz(k) + delz(k+1) )
!>
!>    Kz / delz* = [ 0.5*delz(k+1)/K(k+1) + 0.5*delz(k)/K(k) ]**-1
!>
!>               = [ ( 0.5* K(k)* delz(k+1) + 0.5*K(k+1)* delz(k) ) / ( K(k)*K(k+1) ) ]**-1
!>
!>               = [ ( 0.5 * summ ) / (prod) ]**-1 = 2.0*prod/summ
SUBROUTINE TK_AD(i, j, k, ismpl, tk_adv)
  use arrays

  USE ARRAYS_AD

  USE MOD_GENRL
  USE MOD_FLOW
  IMPLICIT NONE
  double precision :: tk_adv
  INTEGER :: ismpl
  INTEGER :: i, j, k
  EXTERNAL KZ, RHOF, VISF
  EXTERNAL KZ_AD, RHOF_AD, VISF_AD
  DOUBLE PRECISION :: f1, f2, prod, summ, KZ, RHOF, &
& VISF
  DOUBLE PRECISION :: f1_ad, f2_ad, prod_ad, summ_ad
  DOUBLE PRECISION :: result1
  DOUBLE PRECISION :: result1_ad
  DOUBLE PRECISION :: result2
  DOUBLE PRECISION :: result2_ad
  DOUBLE PRECISION :: result3
  DOUBLE PRECISION :: result3_ad
  INTEGER :: arg1
  INTEGER :: arg2
  INTEGER :: arg3
  DOUBLE PRECISION :: temporary_ad
  DOUBLE PRECISION :: tk
  IF (k0 .GT. 1 .AND. k .LT. k0) THEN
    result1 = KZ(i, j, k, ismpl)
    result2 = RHOF(i, j, k, ismpl)
    result3 = VISF(i, j, k, ismpl)
    f1 = result1*result2*grav/result3
    arg1 = k + 1
    CALL PUSHREAL8(result1)
    result1 = KZ(i, j, arg1, ismpl)
    arg2 = k + 1
    CALL PUSHREAL8(result2)
    result2 = RHOF(i, j, arg2, ismpl)
    arg3 = k + 1
    CALL PUSHREAL8(result3)
    result3 = VISF(i, j, arg3, ismpl)
    f2 = result1*result2*grav/result3
    prod = f1*f2
    summ = f1*delz(k+1) + f2*delz(k)
    IF (summ .GT. 0.d0) THEN
      temporary_ad = 2.d0*tk_adv/summ
      prod_ad = temporary_ad
      summ_ad = -(prod*temporary_ad/summ)
    ELSE
      prod_ad = 0.D0
      summ_ad = 0.D0
    END IF
    f1_ad = delz(k+1)*summ_ad + f2*prod_ad
    f2_ad = delz(k)*summ_ad + f1*prod_ad
    temporary_ad = grav*f2_ad/result3
    result1_ad = result2*temporary_ad
    result2_ad = result1*temporary_ad
    result3_ad = -(result1*result2*temporary_ad/result3)
    CALL POPREAL8(result3)
    CALL VISF_AD(i, j, arg3, ismpl, result3_ad)
    CALL POPREAL8(result2)
    CALL RHOF_AD(i, j, arg2, ismpl, result2_ad)
    CALL POPREAL8(result1)
    CALL KZ_AD(i, j, arg1, ismpl, result1_ad)
    temporary_ad = grav*f1_ad/result3
    result1_ad = result2*temporary_ad
    result2_ad = result1*temporary_ad
    result3_ad = -(result1*result2*temporary_ad/result3)
    CALL VISF_AD(i, j, k, ismpl, result3_ad)
    CALL RHOF_AD(i, j, k, ismpl, result2_ad)
    CALL KZ_AD(i, j, k, ismpl, result1_ad)
  END IF
END SUBROUTINE TK_AD


      SUBROUTINE TG01LD( JOB, JOBA, COMPQ, COMPZ, N, M, P, A, LDA,
     $                   E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF, ND,
     $                   NIBLCK, IBLCK, 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 compute orthogonal transformation matrices Q and Z which
C     reduce the regular pole pencil A-lambda*E of the descriptor system
C     (A-lambda*E,B,C) to the form (if JOB = 'F')
C
C                ( Af  *  )             ( Ef  *  )
C       Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,                 (1)
C                ( 0   Ai )             ( 0   Ei )
C
C     or to the form (if JOB = 'I')
C
C                ( Ai  *  )             ( Ei  *  )
C       Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,                 (2)
C                ( 0   Af )             ( 0   Ef )
C
C     where the subpencil Af-lambda*Ef, with Ef nonsingular and upper
C     triangular, contains the finite eigenvalues, and the subpencil
C     Ai-lambda*Ei, with Ai nonsingular and upper triangular, contains
C     the infinite eigenvalues. The subpencil Ai-lambda*Ei is in a
C     staircase form (see METHOD). If JOBA = 'H', the submatrix Af
C     is further reduced to an upper Hessenberg form.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             = 'F':  perform the finite-infinite separation;
C             = 'I':  perform the infinite-finite separation.
C
C     JOBA    CHARACTER*1
C             = 'H':  reduce Af further to an upper Hessenberg form;
C             = 'N':  keep Af unreduced.
C
C     COMPQ   CHARACTER*1
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix B, the number of columns
C             of the matrix C and the order of the square matrices A
C             and E.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C.  P >= 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 N-by-N state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q'*A*Z,
C
C                                ( Af  *  )                 ( Ai  *  )
C                       Q'*A*Z = (        ) ,  or  Q'*A*Z = (        ) ,
C                                ( 0   Ai )                 ( 0   Af )
C
C             depending on JOB, with Af an NF-by-NF matrix, and Ai an
C             (N-NF)-by-(N-NF) nonsingular and upper triangular matrix.
C             If JOBA = 'H', Af is in an upper Hessenberg form.
C             Otherwise, Af is unreduced.
C             Ai has a block structure as in (3) or (4), where A0,0 is
C             ND-by-ND and Ai,i , for i = 1, ..., NIBLCK, is
C             IBLCK(i)-by-IBLCK(i).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N descriptor matrix E.
C             On exit, the leading N-by-N part of this array contains
C             the transformed descriptor matrix Q'*E*Z,
C
C                                ( Ef  *  )                 ( Ei  *  )
C                       Q'*E*Z = (        ) ,  or  Q'*E*Z = (        ) ,
C                                ( 0   Ei )                 ( 0   Ef )
C
C             depending on JOB, with Ef an NF-by-NF nonsingular matrix,
C             and Ei an (N-NF)-by-(N-NF) nilpotent matrix in an upper
C             block triangular form, as in (3) or (4).
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,K),
C             where K = M if JOB = 'F', and K = MAX(M,P) if JOB = 'I'.
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,K),
C             where K = P if JOB = 'F', and K = MAX(M,P) if JOB = 'I'.
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If COMPQ = 'N':  Q is not referenced.
C             If COMPQ = 'I':  on entry, Q need not be set;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix Q,
C                              where Q' is the product of Householder
C                              transformations applied to A, E, and B on
C                              the left.
C             If COMPQ = 'U':  on entry, the leading N-by-N part of this
C                              array must contain an orthogonal matrix
C                              Q1;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix
C                              Q1*Q.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,N), if COMPQ = 'I' or 'U'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N':  Z is not referenced.
C             If COMPZ = 'I':  on entry, Z need not be set;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix Z,
C                              which is the product of Householder
C                              transformations applied to A, E, and C on
C                              the right.
C             If COMPZ = 'U':  on entry, the leading N-by-N part of this
C                              array must contain an orthogonal matrix
C                              Z1;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix
C                              Z1*Z.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'I' or 'U'.
C
C     NF      (output) INTEGER.
C             The order of the reduced matrices Af and Ef; also, the
C             number of finite generalized eigenvalues of the pencil
C             A-lambda*E.
C
C     ND      (output) INTEGER.
C             The number of non-dynamic infinite eigenvalues of the
C             pair (A,E). Note: N-ND is the rank of the matrix E.
C
C     NIBLCK  (output) INTEGER
C             If ND > 0, the number of infinite blocks minus one.
C             If ND = 0, then NIBLCK = 0.
C
C     IBLCK   (output) INTEGER array, dimension (N)
C             IBLCK(i) contains the dimension of the i-th block in the
C             staircase form (3) or (4), with i = 1,2, ..., NIBLCK.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR factorization with column pivoting whose estimated
C             condition number is less than 1/TOL. If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             TOLDEF = N**2*EPS,  is used instead, where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH).
C             TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
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.  LDWORK >= 1, and if N > 0,
C             LDWORK >= N + MAX(3*N,M,P).
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
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             = 1:  the pencil A-lambda*E is not regular.
C
C     METHOD
C
C     The subroutine is based on the reduction algorithm of [1].
C     If JOB = 'F', the matrices Ai and Ei have the form
C
C           ( A0,0  A0,k ... A0,1 )         ( 0  E0,k ... E0,1 )
C      Ai = (  0    Ak,k ... Ak,1 ) ,  Ei = ( 0   0   ... Ek,1 ) ;   (3)
C           (  :     :    .    :  )         ( :   :    .    :  )
C           (  0     0   ... A1,1 )         ( 0   0   ...   0  )
C
C     if JOB = 'I', the matrices Ai and Ei have the form
C
C           ( A1,1 ... A1,k  A1,0 )         ( 0 ... E1,k  E1,0 )
C      Ai = (  :    .    :    :   ) ,  Ei = ( :  .    :    :   ) ,   (4)
C           (  :   ... Ak,k  Ak,0 )         ( : ...   0   Ek,0 )
C           (  0   ...   0   A0,0 )         ( 0 ...   0     0  )
C
C     where Ai,i , for i = 0, 1, ..., k, are nonsingular upper
C     triangular matrices. A0,0 corresponds to the non-dynamic infinite
C     modes of the system.
C
C     REFERENCES
C
C     [1] Misra, P., Van Dooren, P., and Varga, A.
C         Computation of structural invariants of generalized
C         state-space systems.
C         Automatica, 30, pp. 1921-1936, 1994.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     FURTHER COMMENTS
C
C     The number of infinite poles is computed as
C
C                   NIBLCK
C        NINFP =     Sum  IBLCK(i) = N - ND - NF.
C                    i=1
C
C     The multiplicities of infinite poles can be computed as follows:
C     there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity
C     k, for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0.
C     Note that each infinite pole of multiplicity k corresponds to
C     an infinite eigenvalue of multiplicity k+1.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     July 1999. Based on the RASP routines SRISEP and RPDSGH.
C
C     REVISIONS
C
C     A. Varga, 3-11-2002.
C     V. Sima, Dec. 2016, June 2017.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, system poles, multivariable
C     system, orthogonal transformation, structural invariant.
C
C     ******************************************************************
C
C     ..
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOB, JOBA
      INTEGER            INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M,
     $                   N, ND, NF, NIBLCK, P
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IBLCK( * ), IWORK(*)
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      CHARACTER          JOBQ, JOBZ
      LOGICAL            ILQ, ILZ, LQUERY, REDA, REDIF
      INTEGER            I, ICOMPQ, ICOMPZ, IHI, ILO, MINWRK, RANKE,
     $                   RNKA22, WRKOPT
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           AB07MD, DSWAP, MA02BD, MA02CD, TB01XD, TG01BD,
     $                   TG01FD, TG01LY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX
C     .. Executable Statements ..
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
      REDIF = LSAME( JOB,  'I' )
      REDA  = LSAME( JOBA, 'H' )
C
C     Test the input parameters.
C
      INFO = 0
      IF( .NOT.LSAME( JOB, 'F' ) .AND. .NOT.REDIF ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN
         INFO = -2
      ELSE IF( ICOMPQ.LE.0 ) THEN
         INFO = -3
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( P.LT.0 ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( ( .NOT.REDIF .AND. LDC.LT.MAX( 1, P ) ) .OR.
     $         ( REDIF .AND. LDC.LT.MAX( 1, M, P ) ) )THEN
         INFO = -15
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -17
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -19
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -24
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF( N.EQ.0 ) THEN
            MINWRK = 1
         ELSE
            MINWRK = N + MAX( 3*N, M, P )
         END IF
         IF( LQUERY ) THEN
            RANKE  = MAX( 1, INT( N/2 ) )
            RNKA22 = N - RANKE
C
            IF( REDIF ) THEN
               CALL TG01FD( COMPZ, COMPQ, 'Trapezoidal', N, N, P, M, A,
     $                      LDA, E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ,
     $                      RANKE, RNKA22, TOL, IWORK, DWORK, -1, INFO )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
               CALL TG01LY( ILZ, ILQ, N, P, M, RANKE, RNKA22, A, LDA,
     $                      E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NF,
     $                      NIBLCK, IBLCK, TOL, IWORK, DWORK, -1, INFO )
            ELSE
               CALL TG01FD( COMPQ, COMPZ, 'Trapezoidal', N, N, M, P, A,
     $                      LDA, E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ,
     $                      RANKE, RNKA22, TOL, IWORK, DWORK, -1, INFO )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
               CALL TG01LY( ILQ, ILZ, N, M, P, RANKE, RNKA22, A, LDA,
     $                      E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF,
     $                      NIBLCK, IBLCK, TOL, IWORK, DWORK, -1, INFO )
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -27
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01LD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 ) THEN
         NF = 0
         ND = 0
         NIBLCK = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( REDIF ) THEN
C
C       Build the dual system.
C
         CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1,
     $                INFO )
         DO 10 I = 2, N
            CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 )
   10    CONTINUE
C
C        Reduce to SVD-like form with A22 in QR-form.
C
         CALL TG01FD( COMPZ, COMPQ, 'Trapezoidal', N, N, P, M, A, LDA,
     $                E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, RANKE,
     $                RNKA22, TOL, IWORK, DWORK, LDWORK, INFO )
         WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
C
C        Perform finite-infinite separation.
C
         CALL TG01LY( ILZ, ILQ, N, P, M, RANKE, RNKA22, A, LDA,
     $                E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NF,
     $                NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, INFO )
         ILO = N - NF + 1
         IHI = N
      ELSE
C
C        Reduce to SVD-like form with A22 in QR-form.
C
         CALL TG01FD( COMPQ, COMPZ, 'Trapezoidal', N, N, M, P, A, LDA,
     $                E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE,
     $                RNKA22, TOL, IWORK, DWORK, LDWORK, INFO )
         WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
C
C        Perform finite-infinite separation.
C
         CALL TG01LY( ILQ, ILZ, N, M, P, RANKE, RNKA22, A, LDA,
     $                E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF,
     $                NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, INFO )
         ILO = 1
         IHI = NF
      END IF
C
      IF( INFO.NE.0 )
     $   RETURN
      WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
      ND = N - RANKE
C
      IF( REDIF ) THEN
C
C        Compute the pertransposed dual system exploiting matrix shapes.
C
         CALL TB01XD( 'Z', N, P, M, MAX( 0, NF-1 ), MAX( 0, N-1 ),
     $                A, LDA, B, LDB, C, LDC, DUM, 1, INFO )
         CALL MA02CD( N, 0, MAX( 0, N-1 ), E, LDE )
         IF( ILQ )
     $      CALL MA02BD( 'Right', N, N, Q, LDQ )
         IF( ILZ )
     $      CALL MA02BD( 'Right', N, N, Z, LDZ )
      END IF
C
C     If required, reduce (A,E) to generalized Hessenberg form.
C
      IF( REDA ) THEN
         IF( ILQ) THEN
            JOBQ = 'V'
         ELSE
            JOBQ = 'N'
         END IF
         IF( ILZ) THEN
            JOBZ = 'V'
         ELSE
            JOBZ = 'N'
         END IF
         CALL TG01BD( 'Upper', JOBQ, JOBZ, N, M, P, ILO, IHI, A, LDA,
     $                E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK,
     $                LDWORK, INFO )
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TG01LD ***
      END


C$Procedure      CHBINT ( Interpolate a Chebyshev expansion )

      SUBROUTINE CHBINT ( CP, DEGP, X2S, X, P, DPDX )

C$ Abstract
C
C     Given the coefficients for the Chebyshev expansion of a
C     polynomial, this returns the value of the polynomial and its
C     derivative evaluated at the input X.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      INTERPOLATION,  MATH,  POLYNOMIAL
C
C$ Declarations

      DOUBLE PRECISION   CP  ( * )
      INTEGER            DEGP
      DOUBLE PRECISION   X2S ( 2 )
      DOUBLE PRECISION   X
      DOUBLE PRECISION   P
      DOUBLE PRECISION   DPDX

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      CP         I   NDEG+1 Chebyshev polynomial coefficients.
C      DEGP       I   Degree of polynomial.
C      X2S        I   Transformation parameters of polynomial.
C      X          I   Value for which the polynomial is to be evaluated
C      P          O   Value of the polynomial at X
C      DPDX       O   Value of the derivative of the polynomial at X
C
C$ Detailed_Input
C
C      CP         is an array of coefficients OF a polynomial with
C                 respect to the Chebyshev basis.  The polynomial to be
C                 evaluated is assumed to be of the form:
C
C                   CP(DEGP+1)*T(DEGP,S) + CP(DEGP)*T(DEGP-1,S) + ...
C
C                                    ... + CP(2)*T(1,S) + CP(1)*T(0,S)
C
C                 where T(I,S) is the I'th Chebyshev polynomial
C                 evaluated  at a number S whose double precision
C                 value lies between -1 and 1.  The value of S is
C                 computed from the input variables X2S(1), X2S(2) and X
C
C      DEGP       is the degree of the Chebyshev polynomial to be
C                 evaluated.
C
C      X2S        is an array of two parameters.  These parameters are
C                 used to transform the domain of the input variable X
C                 into the standard domain of the Chebyshev polynomial.
C                 X2S(1) should be a reference point in the domain of X;
C                 X2S(2) should be the radius by which points are
C                 allowed to deviate from the reference point and while
C                 remaining within the domain of X.  The value of
C                 X is transformed into the value S given by
C
C                           S = ( X - X2S(1) ) / X2S(2)
C
C                 Typically X2S(1) is the midpoint of the interval over
C                 which X is allowed to vary and X2S(2) is the radius of
C                 the interval.
C
C                 The main reason for doing this is that a Chebyshev
C                 expansion is usually fit to data over a span
C                 from A to B where A and B are not -1 and 1
C                 respectively.  Thus to get the "best fit" the
C                 data was transformed to the interval [-1,1] and
C                 coefficients generated. These coefficients are
C                 not rescaled to the interval of the data so that
C                 the numerical "robustness" of the Chebyshev fit will
C                 not be lost. Consequently, when the "best fitting"
C                 polynomial needs to be evaluated at an intermediate
C                 point, the point of evaluation must be transformed
C                 in the same way that the generating points were
C                 transformed.
C
C      X          Value for which the polynomial is to be evaluated.
C
C$ Detailed_Output
C
C      P          is the value of the polynomial to be evaluated.  It
C                 is given by
C
C                   CP(DEGP+1)*T(DEGP,S) + CP(DEGP)*T(DEGP-1,S) + ...
C
C                                    ... + CP(2)*T(1,S) + CP(1)*T(0,S)
C
C                 where T(I,S) is the I'th Chebyshev polynomial
C                 evaluated  at a number S = ( X - X2S(1) )/X2S(2)
C
C      DPDX       is the value of the derivative of the polynomial at X.
C                 It is given by
C
C                   1/X2S(2) [    CP(DEGP+1)*T'(DEGP,S)
C                               + CP(DEGP)*T'(DEGP-1,S) + ...
C                               .
C                               .
C                               .
C                           ... + CP(2)*T'(1,S)
C                               + CP(1)*T'(0,S) ]
C
C                 where T(I,S) and T'(I,S)  are the I'th Chebyshev
C                 polynomial and its derivative, respectively,
C                 evaluated  at a number S = ( X - X2S(1) )/X2S(2)
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      This routine computes the value of a Chebyshev polynomial
C      expansion and the derivative of the expansion with respect to X.
C      The polynomial is given by
C
C           CP(DEGP+1)*T(DEGP,S) + CP(DEGP)*T(DEGP-1,S) + ...
C
C                            ... + CP(2)*T(1,S) + CP(1)*T(0,S)
C
C      where
C
C           S  =  ( X - X2S(1) ) / X2S(2)
C
C      and
C
C           T(i,S) is the i'th Chebyshev polynomial of the first kind
C           evaluated at S.
C
C$ Examples
C
C
C     Depending upon the user's needs, there are 3 routines available
C     for evaluating Chebyshev polynomials.
C
C        CHBVAL for evaluating a Chebyshev polynomial when no
C               derivatives are desired.
C
C        CHBINT for evaluating a Chebyshev polynomial and its
C               first derivative.
C
C        CHBDER for evaluating a Chebyshev polynomial and a user
C               or application dependent number of derivatives.
C
C     Of these 3 the one most commonly employed by NAIF software
C     is CHBINT as it is used to interpolate ephemeris state
C     vectors which requires the evaluation of a polynomial
C     and its derivative.  When no derivatives are desired one
C     should use CHBVAL, or when more than one or an unknown
C     number of derivatives are desired one should use CHBDER.
C
C     The code fragment below illustrates how this routine might
C     be used to obtain points for plotting a polynomial
C     and its derivatives.
C
C           fetch the pieces needed for describing the polynomial
C           to be evaluated.
C
C           READ  (*,*) DEGP, ( CP(I), I = 1, DEG+1 ),  BEG, END
C
C           check to see that BEG is actually less than END
C
C           IF ( BEG .GE. END ) THEN
C
C              take some appropriate action
C
C           ELSE
C
C              X2S(1) = ( END + BEG ) / 2.0D0
C              X2S(2) = ( END - BEG ) / 2.0D0
C
C           END IF
C
C           STEP = END - BEG / <number of points used for plotting>
C           X    = BEG
C
C           DO WHILE ( X .LE. END )
C
C              CALL CHBINT ( CP, DEGP, X2S, X, P, DPDX )
C
C              do something with the pairs (X,P) and (X,DPDX)
C
C              X = X + STEP
C
C           END DO
C
C$ Restrictions
C
C      One needs to be careful that the value (X-X2S(1)) / X2S(2) lies
C      between -1 and 1.  Otherwise, the routine may fail spectacularly
C      (for example with a floating point overflow).
C
C$ Exceptions
C
C     Error free
C
C     No tests are performed for exceptional values (DEGP negative,
C     etc.) This routine is expected to be used at a low level in
C     ephemeris evaluations. For that reason it has been elected as a
C     routine that will not participate in error handling.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      "Numerical Recipes -- The Art of Scientific Computing" by
C       William H. Press, Brian P. Flannery, Saul A. Teukolsky,
C       Willam T. Vetterling.  (See Clenshaw's Recurrance Formula)
C
C      "The Chebyshev Polynomials" by Theodore J. Rivlin
C
C      "CRC Handbook of Tables for Mathematics"
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     interpolate a chebyshev expansion
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 30-DEC-1988 (WLT)
C
C     The Error free specification was added to the routine as
C     well as an explanation for this designation. Examples added.
C
C-&

C
C     Local variables
C
      INTEGER          J
      DOUBLE PRECISION W (3)
      DOUBLE PRECISION DW(3)
      DOUBLE PRECISION S
      DOUBLE PRECISION S2
C
C     Transform X to S and initialize temporary variables.
C
      S     = (X-X2S(1)) / X2S(2)
      S2    = 2.0D0 * S
      J     = DEGP  + 1
      W (1) = 0.D0
      W (2) = 0.D0
      DW(1) = 0.D0
      DW(2) = 0.D0
C
C     Evaluate the polynomial and its derivative using recursion.
C
      DO WHILE ( J .GT. 1 )

         W (3) = W (2)
         W (2) = W (1)
         W (1) = CP(J)  + ( S2*W(2)  - W(3) )

         DW(3) = DW(2)
         DW(2) = DW(1)
         DW(1) = W(2)*2.0D0 + DW(2)*S2 - DW(3)

         J     = J - 1

      END DO

      P    = CP(1) + ( S*W (1) - W (2) )
      DPDX =  W(1) + S*DW(1) - DW(2)
C
C     Scale the derivative by 1/X2S(2) so that we have the derivative
C
C                       d P(S)
C                       ------
C                         dX
C
      DPDX = DPDX / X2S(2)

      RETURN
      END


subroutine third_stage(k,k_t)

use definiciones
implicit none
integer(4)::i,j,k,k_t

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Tercera etapa del esquema RK3
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

do i=2,nx_i

do j=2,nz_i

k_omega(1,1)=-u_old(i,j)*(omega_old(i+1,j)-omega_old(i-1,j))/(2.0d0*delta_x)-&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
w_old(i,j)*(omega_old(i,j+1)-omega_old(i,j-1))/(2.0d0*delta_z)+&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(omega_old(i+1,j)-2.0d0*omega_old(i,j)+omega_old(i-1,j))/(sqrt(gr)*delta_x**2)+&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(omega_old(i,j+1)-2.0d0*omega_old(i,j)+omega_old(i,j-1))/(sqrt(gr)*delta_z**2)

k_omega(2,1)=-u_aprox(i,j)*(omega_aprox(i+1,j)-omega_aprox(i-1,j))/(2.0d0*delta_x)-&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
w_aprox(i,j)*(omega_aprox(i,j+1)-omega_aprox(i,j-1))/(2.0d0*delta_z)+&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(omega_aprox(i+1,j)-2.0d0*omega_aprox(i,j)+omega_aprox(i-1,j))/(sqrt(gr)*delta_x**2)+&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(omega_aprox(i,j+1)-2.0d0*omega_aprox(i,j)+omega_aprox(i,j-1))/(sqrt(gr)*delta_z**2)

k_omega(3,1)=-u_aprox_1(i,j)*(omega_aprox_1(i+1,j)-omega_aprox_1(i-1,j))/(2.0d0*delta_x)-&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
w_aprox_1(i,j)*(omega_aprox_1(i,j+1)-omega_aprox_1(i,j-1))/(2.0d0*delta_z)+&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(omega_aprox_1(i+1,j)-2.0d0*omega_aprox_1(i,j)+omega_aprox_1(i-1,j))/(sqrt(gr)*delta_x**2)+&
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
(omega_aprox_1(i,j+1)-2.0d0*omega_aprox_1(i,j)+omega_aprox_1(i,j-1))/(sqrt(gr)*delta_z**2)

omega_new(i,j)=omega_old(i,j)+delta_t/6.0d0*(k_omega(1,1)+4.0d0*k_omega(2,1)+k_omega(3,1))

end do

end do

end subroutine third_stage


program sorting
use sorting_subroutines
implicit none

real(kind=8), allocatable, dimension(:) :: A1, A2
real(kind=8) :: B
integer :: n, i

write(*,*) 'size of array?'
read(*,*) n

allocate (A1(n), A2(n))

call random_seed()
do i = 1, n
   call random_number(B)
   A1(i) = B*500.00
   A2(i) = A1(i)
end do

call bubble_sort(n, A1)

!call first_and_last(n, A2)

end program sorting


      PROGRAM xmachar
C     driver for routine machar
      INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
      REAL eps,epsneg,xmax,xmin
      call machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
     *     maxexp,eps,epsneg,xmin,xmax)
      write(*,*) 'ibeta=',ibeta
      write(*,*) 'it=',it
      write(*,*) 'irnd=',irnd
      write(*,*) 'ngrd=',ngrd
      write(*,*) 'machep=',machep
      write(*,*) 'negep=',negep
      write(*,*) 'iexp=',iexp
      write(*,*) 'minexp=',minexp
      write(*,*) 'maxexp=',maxexp
      write(*,*) 'eps=',eps
      write(*,*) 'epsneg=',epsneg
      write(*,*) 'xmin=',xmin
      write(*,*) 'xmax=',xmax
      END

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


PROGRAM main

  USE mo_kind,        ONLY: dp, sp, i4
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_percentile,  ONLY: median, percentile, qmedian, n_element
  USE mo_orderpack,   ONLY: sort
  USE mo_utils,       ONLY: eq, ne

  IMPLICIT NONE

  REAL(dp), DIMENSION(10) :: dat
  REAL(dp), DIMENSION(2)  :: dqua
  REAL(sp), DIMENSION(10) :: sat
  REAL(sp), DIMENSION(2)  :: squa

  real(sp) :: stmp
  real(dp) :: dtmp

#ifndef __ABSOFT__
#ifdef __GFORTRAN__
  ! If arrays re too big, the flag -frecursive gives either
  !   Illegal instruction: 4
  ! or
  !   Segmentation fault: 11
  ! The large numbers work with gfortran if not -frecursive. Then it states
  ! Warning: Array 'big' at (1) is larger than limit set by '-fmax-stack-var-size=',
  ! moved from stack to static storage. This makes the procedure unsafe when called
  ! recursively, or concurrently from multiple threads. Consider using '-frecursive',
  ! or increase the -fmax-stack-var-size=' limit, or change the code to use an
  ! ALLOCATABLE array. [-Wsurprising]
  integer,  parameter :: nele = 100000
#else
  integer,  parameter :: nele = 10000000
#endif
  real(dp), dimension(nele) :: big, buf
  real(dp) :: med
  integer  :: i, istart, istop
#endif

  LOGICAL :: isgood

  write(*,*) ''
  write(*,*) 'Test mo_percentile.f90'

  ! Double precision
  isgood = .true.
  dat = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  dtmp = median(dat)
  isgood = isgood .and. eq(dtmp, 5.5_dp)
  dtmp = median(dat, mask=ne(dat, 10._dp))
  isgood = isgood .and. eq(dtmp, 5._dp)
  dtmp = n_element(dat, 4)
  isgood = isgood .and. eq(dtmp, 4._dp)
  dtmp = percentile(dat, 95._dp)
  isgood = isgood .and. eq(dtmp, 10._dp)
  dqua = percentile(dat, (/50._dp, 95._dp/))
  isgood = isgood .and. eq(dqua(1), 5._dp)
  isgood = isgood .and. eq(dqua(2), 10._dp)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=1_i4)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=3_i4)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=4_i4)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=5_i4)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=6_i4)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=7_i4)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=8_i4)
  dqua = percentile(dat,(/50._dp, 75._dp/), mode_in=2_i4)
  isgood = isgood .and. eq(dqua(1), 5._dp)
  isgood = isgood .and. eq(dqua(2), 7.5_dp)

  if (isgood) then
     write(*,*) 'mo_percentile double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_percentile double precision ', color('failed!', c_red)
  endif

  ! Single precision
  isgood = .true.
  sat = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  stmp = median(sat)
  isgood = isgood .and. eq(stmp, 5.5_sp)
  stmp = median(sat, mask=ne(sat, 10._sp))
  isgood = isgood .and. eq(stmp, 5._sp)
  stmp = n_element(sat,4)
  isgood = isgood .and. eq(stmp, 4._sp)
  stmp = percentile(sat,95._sp)
  isgood = isgood .and. eq(stmp, 10._sp)
  squa = percentile(sat,(/50._sp, 95._sp/))
  isgood = isgood .and. eq(squa(1), 5._sp)
  isgood = isgood .and. eq(squa(2), 10._sp)
  squa = percentile(sat,(/50._sp, 75._sp/), mode_in=2_i4)
  isgood = isgood .and. eq(squa(1), 5._sp)
  isgood = isgood .and. eq(squa(2), 7.5_sp)

  if (isgood) then
     write(*,*) 'mo_percentile single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_percentile single precision ', color('failed!', c_red)
  endif

! Absoft gives segmentation fault on all of the following test, do not know why
#ifndef __ABSOFT__
  ! Test speed
  do i = 1, nele
     call random_number(big(i))
  enddo
  ! forall(i=1:nele) big(i) = real(i,dp)
  ! forall(i=1:nele/2) big(2*i) = real(i,dp)

  buf = big
  call system_clock(istart)
  med =  median(buf)
  call system_clock(istop)
  write(*,*) "median: ", med, istop - istart

  buf = big
  call system_clock(istart)
  med =  n_element(buf,nele/2+1)
  call system_clock(istop)
  write(*,*) "n_element: ", med, istop - istart

  buf = big
  call system_clock(istart)
  med =  median(buf)
  call system_clock(istop)
  write(*,*) "median: ", med, istop - istart

  buf = big
  call system_clock(istart)
  med = qmedian(buf)
  call system_clock(istop)
  write(*,*) "qmedian: ", med, istop - istart

  buf = big
  call system_clock(istart)
  call sort(buf)
  med = buf(nele/2+1)
  call system_clock(istop)
  write(*,*) "sort: ", med, istop - istart
#endif

END PROGRAM main


! email: personal@auliakhalqillah.com
program deretfibbonacci
    implicit none
    integer :: i,n
    real :: x,y,collect

    x = 0 ! deret pertama fibbonacci
    y = 1
    n = 10 ! banyak deret data yang dihasilkan
    write(*,*) 'Deret Fibbonacci'
    do i = 1,n
        write(*,*) x
        collect = x + y
        x = y
        y = collect
    end do

end program