      SUBROUTINE SB10SD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK,
     $                   X, LDX, Y, LDY, RCOND, TOL, IWORK, DWORK,
     $                   LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrices of the H2 optimal controller
C
C              | AK | BK |
C          K = |----|----|,
C              | CK | DK |
C
C     for the normalized discrete-time system
C
C                   | A  | B1  B2  |   | A | B |
C               P = |----|---------| = |---|---|
C                   | C1 | D11 D12 |   | C | D |
C                   | C2 | D21  0  |
C
C     where B2 has as column size the number of control inputs (NCON)
C     and C2 has as row size the number of measurements (NMEAS) being
C     provided to the controller.
C
C     It is assumed that
C
C     (A1) (A,B2) is stabilizable and (C2,A) is detectable,
C
C     (A2) D12 is full column rank with D12 = | 0 | and D21 is
C                                             | I |
C          full row rank with D21 = | 0 I | as obtained by the
C          SLICOT Library routine SB10PD,
C
C               j*Theta
C     (A3) | A-e       *I  B2  | has full column rank for all
C          |    C1         D12 |
C
C          0 <= Theta < 2*Pi ,
C
C
C               j*Theta
C     (A4) | A-e       *I  B1  | has full row rank for all
C          |    C2         D21 |
C
C          0 <= Theta < 2*Pi .
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     NCON    (input) INTEGER
C             The number of control inputs (M2).  M >= NCON >= 0,
C             NP-NMEAS >= NCON.
C
C     NMEAS   (input) INTEGER
C             The number of measurements (NP2).  NP >= NMEAS >= 0,
C             M-NCON >= NMEAS.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading NP-by-M part of this array must contain the
C             system input/output matrix D. Only the leading
C             (NP-NP2)-by-(M-M2) submatrix D11 is used.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
C             The leading N-by-N part of this array contains the
C             controller state matrix AK.
C
C     LDAK    INTEGER
C             The leading dimension of the array AK.  LDAK >= max(1,N).
C
C     BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
C             The leading N-by-NMEAS part of this array contains the
C             controller input matrix BK.
C
C     LDBK    INTEGER
C             The leading dimension of the array BK.  LDBK >= max(1,N).
C
C     CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
C             The leading NCON-by-N part of this array contains the
C             controller output matrix CK.
C
C     LDCK    INTEGER
C             The leading dimension of the array CK.
C             LDCK >= max(1,NCON).
C
C     DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
C             The leading NCON-by-NMEAS part of this array contains the
C             controller input/output matrix DK.
C
C     LDDK    INTEGER
C             The leading dimension of the array DK.
C             LDDK >= max(1,NCON).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array contains the matrix
C             X, solution of the X-Riccati equation.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
C             The leading N-by-N part of this array contains the matrix
C             Y, solution of the Y-Riccati equation.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= max(1,N).
C
C     RCOND   (output) DOUBLE PRECISION array, dimension (4)
C             RCOND contains estimates of the reciprocal condition
C             numbers of the matrices which are to be inverted and the
C             reciprocal condition numbers of the Riccati equations
C             which have to be solved during the computation of the
C             controller. (See the description of the algorithm in [2].)
C             RCOND(1) contains the reciprocal condition number of the
C                      matrix Im2 + B2'*X2*B2;
C             RCOND(2) contains the reciprocal condition number of the
C                      matrix Ip2 + C2*Y2*C2';
C             RCOND(3) contains the reciprocal condition number of the
C                      X-Riccati equation;
C             RCOND(4) contains the reciprocal condition number of the
C                      Y-Riccati equation.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Tolerance used in determining the nonsingularity of the
C             matrices which must be inverted. If TOL <= 0, then a
C             default value equal to sqrt(EPS) is used, where EPS is the
C             relative machine precision.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (max(M2,2*N,N*N,NP2))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal
C             LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= max(1, 14*N*N+6*N+max(14*N+23,16*N),
C                              M2*(N+M2+max(3,M1)), NP2*(N+NP2+3)),
C             where M1 = M - M2.
C             For good performance, LDWORK must generally be larger.
C
C     BWORK   LOGICAL array, dimension (2*N)
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:  if the X-Riccati equation was not solved
C                   successfully;
C             = 2:  if the matrix Im2 + B2'*X2*B2 is not positive
C                   definite, or it is numerically singular (with
C                   respect to the tolerance TOL);
C             = 3:  if the Y-Riccati equation was not solved
C                   successfully;
C             = 4:  if the matrix Ip2 + C2*Y2*C2' is not positive
C                   definite, or it is numerically singular (with
C                   respect to the tolerance TOL).
C
C     METHOD
C
C     The routine implements the formulas given in [1]. The X- and
C     Y-Riccati equations are solved with condition estimates.
C
C     REFERENCES
C
C     [1] Zhou, K., Doyle, J.C., and Glover, K.
C         Robust and Optimal Control.
C         Prentice-Hall, Upper Saddle River, NJ, 1996.
C
C     [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
C         Fortran 77 routines for Hinf and H2 design of linear
C         discrete-time control systems.
C         Report 99-8, Department of Engineering, Leicester University,
C         April 1999.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of the result depends on the condition numbers of the
C     matrices which are to be inverted and on the condition numbers of
C     the matrix Riccati equations which are to be solved in the
C     computation of the controller. (The corresponding reciprocal
C     condition numbers are given in the output array RCOND.)
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 1999,
C     January 2003.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal
C     regulator, robust control.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, LDX, LDY, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   TOL
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AK( LDAK, * ), B( LDB, * ),
     $                   BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ),
     $                   D( LDD, * ), DK( LDDK, * ), DWORK( * ),
     $                   RCOND( * ), X( LDX, * ), Y( LDY, * )
      LOGICAL            BWORK( * )
C     ..
C     .. Local Scalars ..
      INTEGER            INFO2, IW2, IWB, IWC, IWG, IWI, IWQ, IWR, IWRK,
     $                   IWS, IWT, IWU, IWV, J, LWAMAX, M1, M2, MINWRK,
     $                   ND1, ND2, NP1, NP2
      DOUBLE PRECISION   ANORM, FERR, RCOND2, SEPD, TOLL
C     ..
C     .. External functions ..
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           DLAMCH, DLANSY
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLASET, DPOCON, DPOTRF, DPOTRS,
     $                   DSWAP, DSYRK, DTRSM, MB01RX, SB02OD, SB02SD,
     $                   XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      M1  = M - NCON
      M2  = NCON
      NP1 = NP - NMEAS
      NP2 = NMEAS
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN
         INFO = -4
      ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) 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( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -11
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -13
      ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN
         INFO = -19
      ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN
         INFO = -21
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -23
      ELSE IF( LDY.LT.MAX( 1, N ) ) THEN
         INFO = -25
      ELSE
C
C        Compute workspace.
C
         MINWRK = MAX( 1, 14*N*N + 6*N + MAX( 14*N + 23, 16*N ),
     $            M2*( N + M2 + MAX( 3, M1 ) ), NP2*( N + NP2 + 3 ) )
         IF( LDWORK.LT.MINWRK )
     $      INFO = -30
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10SD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0
     $    .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN
         RCOND( 1 ) = ONE
         RCOND( 2 ) = ONE
         RCOND( 3 ) = ONE
         RCOND( 4 ) = ONE
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      ND1  = NP1 - M2
      ND2  = M1 - NP2
      TOLL = TOL
      IF( TOLL.LE.ZERO ) THEN
C
C        Set the default value of the tolerance for nonsingularity test.
C
         TOLL = SQRT( DLAMCH( 'Epsilon' )  )
      END IF
C
C     Workspace usage.
C
      IWQ  = 1
      IWG  = IWQ + N*N
      IWR  = IWG + N*N
      IWI  = IWR + 2*N
      IWB  = IWI + 2*N
      IWS  = IWB + 2*N
      IWT  = IWS + 4*N*N
      IWU  = IWT + 4*N*N
      IWRK = IWU + 4*N*N
      IWC  = IWR
      IWV  = IWC + N*N
C
C     Compute Ax = A - B2*D12'*C1 in AK .
C
      CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB,
     $            C( ND1+1, 1), LDC, ONE, AK, LDAK )
C
C     Compute Cx = C1'*C1 - C1'*D12*D12'*C1 .
C
      IF( ND1.GT.0 ) THEN
         CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ),
     $               N )
      ELSE
         CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N )
      END IF
C
C     Compute Dx = B2*B2' .
C
      CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO,
     $            DWORK( IWG ), N )
C
C     Solution of the discrete-time Riccati equation
C        Ax'*inv(In + X2*Dx)*X2*Ax - X2 + Cx  = 0 .
C     Workspace:  need   14*N*N + 6*N + max(14*N+23,16*N);
C                 prefer larger.
C
      CALL SB02OD( 'D', 'G', 'N', 'L', 'Z', 'S', N, M2, NP1, AK, LDAK,
     $             DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M,
     $             DWORK( IWRK ), N, RCOND2, X, LDX, DWORK( IWR ),
     $             DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N,
     $             DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
      LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1
C
C     Condition estimation.
C     Workspace:  need   4*N*N + max(N*N+5*N,max(3,2*N*N)+N*N);
C                 prefer larger.
C
      IWRK = IWV + N*N
      CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, AK, LDAK, DWORK( IWC ),
     $             N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N,
     $             X, LDX, SEPD, RCOND( 3 ), FERR, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) RCOND( 3 ) = ZERO
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Workspace usage.
C
      IW2  = M2*N + 1
      IWRK = IW2 + M2*M2
C
C     Compute B2'*X2 .
C
      CALL DGEMM( 'T', 'N', M2, N, N, ONE, B( 1, M1+1 ), LDB, X, LDX,
     $            ZERO, DWORK, M2 )
C
C     Compute Im2 + B2'*X2*B2 .
C
      CALL DLASET( 'L', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 )
      CALL MB01RX( 'Left', 'Lower', 'N', M2, N, ONE, ONE, DWORK( IW2 ),
     $            M2, DWORK, M2, B( 1, M1+1 ), LDB, INFO2 )
C
C     Compute the Cholesky factorization of Im2 + B2'*X2*B2 .
C     Workspace:  need   M2*N + M2*M2 + max(3*M2,M2*M1);
C                 prefer larger.
C
      ANORM = DLANSY( 'I', 'L', M2, DWORK( IW2 ), M2, DWORK( IWRK ) )
      CALL DPOTRF( 'L', M2, DWORK( IW2 ), M2, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
      CALL DPOCON( 'L', M2, DWORK( IW2 ), M2, ANORM, RCOND( 1 ),
     $             DWORK( IWRK ), IWORK, INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 1 ).LT.TOLL ) THEN
         INFO = 2
         RETURN
      END IF
C
C     Compute -( B2'*X2*A + D12'*C1 ) in CK .
C
      CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, CK, LDCK )
      CALL DGEMM( 'N', 'N', M2, N, N, -ONE, DWORK, M2, A, LDA, -ONE, CK,
     $            LDCK )
C
C     Compute F2 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*A + D12'*C1 ) .
C
      CALL DPOTRS( 'L', M2, N, DWORK( IW2 ), M2, CK, LDCK, INFO2 )
C
C     Compute -( B2'*X2*B1 + D12'*D11 ) .
C
      CALL DLACPY( 'Full', M2, M1, D( ND1+1, 1 ), LDD, DWORK( IWRK ),
     $              M2 )
      CALL DGEMM( 'N', 'N', M2, M1, N, -ONE, DWORK, M2, B, LDB, -ONE,
     $            DWORK( IWRK ), M2 )
C
C     Compute F0 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*B1 + D12'*D11 ) .
C
      CALL DPOTRS( 'L', M2, M1, DWORK( IW2 ), M2, DWORK( IWRK ), M2,
     $             INFO2 )
C
C     Save F0*D21' in DK .
C
      CALL DLACPY( 'Full', M2, NP2, DWORK( IWRK+ND2*M2 ), M2, DK,
     $             LDDK )
C
C     Workspace usage.
C
      IWRK = IWU + 4*N*N
C
C     Compute Ay = A - B1*D21'*C2 in AK .
C
      CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB,
     $            C( NP1+1, 1 ), LDC, ONE, AK, LDAK )
C
C     Transpose Ay in-situ.
C
      DO 20 J = 1, N - 1
         CALL DSWAP( J, AK( J+1, 1 ), LDAK, AK( 1, J+1 ), 1 )
   20 CONTINUE
C
C     Compute Cy = B1*B1' - B1*D21'*D21*B1' .
C
      IF( ND2.GT.0 ) THEN
         CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ),
     $               N )
      ELSE
         CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N )
      END IF
C
C     Compute Dy = C2'*C2 .
C
      CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO,
     $            DWORK( IWG ), N )
C
C     Solution of the discrete-time Riccati equation
C        Ay*inv( In + Y2*Dy )*Y2*Ay' - Y2 + Cy = 0 .
C
      CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, NP2, M1, AK, LDAK,
     $             DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M,
     $             DWORK( IWRK ), N, RCOND2, Y, LDY, DWORK( IWR ),
     $             DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N,
     $             DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 3
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Condition estimation.
C
      IWRK = IWV + N*N
      CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWC ),
     $             N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N,
     $             Y, LDY, SEPD, RCOND( 4 ), FERR, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) RCOND( 4 ) = ZERO
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Workspace usage.
C
      IW2  = N*NP2 + 1
      IWRK = IW2 + NP2*NP2
C
C     Compute Y2*C2' .
C
      CALL DGEMM( 'N', 'T', N, NP2, N, ONE, Y, LDY, C( NP1+1, 1 ), LDC,
     $            ZERO, DWORK, N )
C
C     Compute Ip2 + C2*Y2*C2' .
C
      CALL DLASET( 'U', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 )
      CALL MB01RX( 'Left', 'Upper', 'N', NP2, N, ONE, ONE, DWORK( IW2 ),
     $            NP2, C( NP1+1, 1 ), LDC, DWORK, N, INFO2 )
C
C     Compute the Cholesky factorization of Ip2 + C2*Y2*C2' .
C
      ANORM = DLANSY( 'I', 'U', NP2, DWORK( IW2 ), NP2, DWORK( IWRK ) )
      CALL DPOTRF( 'U', NP2, DWORK( IW2 ), NP2, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 4
         RETURN
      END IF
      CALL DPOCON( 'U', NP2, DWORK( IW2 ), NP2, ANORM, RCOND( 2 ),
     $             DWORK( IWRK ), IWORK, INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 2 ).LT.TOLL ) THEN
         INFO = 4
         RETURN
      END IF
C
C     Compute A*Y2*C2' + B1*D21' in BK .
C
      CALL DLACPY ( 'Full', N, NP2, B( 1, ND2+1 ), LDB, BK, LDBK )
      CALL DGEMM( 'N', 'N', N, NP2, N, ONE, A, LDA, DWORK, N, ONE,
     $            BK, LDBK )
C
C     Compute L2 = -( A*Y2*C2' + B1*D21' )*inv( Ip2 + C2*Y2*C2' ) .
C
      CALL DTRSM( 'R', 'U', 'N', 'N', N, NP2, -ONE, DWORK( IW2 ), NP2,
     $            BK, LDBK )
      CALL DTRSM( 'R', 'U', 'T', 'N', N, NP2, ONE, DWORK( IW2 ), NP2,
     $            BK, LDBK )
C
C     Compute F2*Y2*C2' + F0*D21' .
C
      CALL DGEMM( 'N', 'N', M2, NP2, N, ONE, CK, LDCK, DWORK, N, ONE,
     $            DK, LDDK )
C
C     Compute DK = L0 = ( F2*Y2*C2' + F0*D21' )*inv( Ip2 + C2*Y2*C2' ) .
C
      CALL DTRSM( 'R', 'U', 'N', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2,
     $            DK, LDDK )
      CALL DTRSM( 'R', 'U', 'T', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2,
     $            DK, LDDK )
C
C     Compute CK = F2 - L0*C2 .
C
      CALL DGEMM( 'N', 'N', M2, N, NP2, -ONE, DK, LDDK, C( NP1+1, 1),
     $            LDC, ONE, CK, LDCK )
C
C     Find AK = A + B2*( F2 - L0*C2 ) + L2*C2 .
C
      CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, M2, ONE, B(1, M1+1 ), LDB, CK, LDCK,
     $            ONE, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, C( NP1+1, 1),
     $            LDC, ONE, AK, LDAK )
C
C     Find BK = -L2 + B2*L0 .
C
      CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, B( 1, M1+1 ), LDB, DK,
     $            LDDK, -ONE, BK, LDBK )
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10SD ***
      END


      program fraer01

C     Example from Fraer's PhD, P. 72

C     We do get the convex approximation of the postcondition.

C     The redundancy elimination used in PIPS fails in this case.

C     To get a stronger postcondition by bounding x, y and z: see fraer03

      integer x, y, z

      read *, x, y, z

      if(x.lt.y) then
         max2 = y
         min2 = x
      else
         max2 = x
         min2 = y
      endif

      call printmin2(min2, x, y)
      call printmax2(max2, x, y)

      if(max2.lt.z) then
         max3 = z
         min3 = min 2
      else
         max3 = max2
         if(min2.gt.z) then
            min3 = z
         else
            min3 = min2
         endif
      endif

      call printmin3(min3, x, y, z)
      call printmax3(max3, x, y, z)

      print *, min2, max2, min3, max3

      end

      subroutine printmin2(min2, x, y)

      integer x, y

      print *, min2, x, y

      end

      subroutine printmax2(max2, x, y)

      integer x, y

      print *, max2, x, y

      end

      subroutine printmin3(min3, x, y, z)

      integer x, y, z

      print *, min3, x, y, z

      end

      subroutine printmax3(max3, x, y, z)

      integer x, y, z

      print *, max3, x, y, z

      end


! { dg-do run }

module e_53_4_mod
  !$omp declare target (N, Q)
  integer, parameter :: N = 10
  real :: Q(N,N)
contains
  real function Pfun (i, k)
    !$omp declare target
    integer, intent(in) :: i, k
    Pfun = (Q(i,k) * Q(k,i))
  end function
end module

real function accum (k) result (tmp)
  use e_53_4_mod
  integer :: i, k
  tmp = 0.0e0
  !$omp target map(tmp)
    !$omp parallel do reduction(+:tmp)
    do i = 1, N
      tmp = tmp + Pfun (k, i)
    end do
  !$omp end target
end function

real function accum_ref (k) result (tmp)
  use e_53_4_mod
  integer :: i, k
  tmp = 0.0e0
  do i = 1, N
    tmp = tmp + Pfun (k, i)
  end do
end function

subroutine init ()
  use e_53_4_mod
  integer :: i, j
  do i = 1, N
    do j = 1, N
      Q(i,j) = 0.001 * i * j
    end do
  end do
end subroutine

subroutine check (a, b)
  real :: a, b, err
  real, parameter :: EPS = 0.00001
  if (b == 0.0) then
    err = a
  else if (a == 0.0) then
    err = b
  else
    err = (a - b) / b
  end if
  if (err > EPS .or. err < -EPS) call abort
end subroutine

program e_53_4
  use e_53_4_mod
  integer :: i
  real :: accum, accum_ref
  call init ()
  !$omp target update to(Q)
  do i = 1, N
    call check (accum (i), accum_ref (i))
  end do
end program


! { dg-do compile }
!
! Test the fix for PR79402, in which the module procedure 'fun1' picked
! up a spurious symbol for the dummy 'n' in the specification expression
! for the result 'y'.
!
! Contributed by Chris Coutinho  <chrisbcoutinho@gmail.com>
!
module mod
  interface myfun
    module function fun1(n) result(y)
      integer,  intent(in)    :: n
      real, dimension(n)  :: y
    end function fun1
  end interface myfun

end module mod

submodule (mod) submod
contains
  module procedure fun1
    integer :: i
    y = [(float (i), i = 1, n)]
  end procedure fun1
end submodule

  use mod
  print *, fun1(10)
end


program gemv_omp

USE OMP_LIB

implicit none
integer,parameter:: N=64
real(8),allocatable :: A(:),V(:),Vout(:)
real(8) :: alpha=1.0
integer :: ti,tj,tk
integer :: err
integer :: val

!!starts here
call system_clock(ti,tk)
allocate(A(1:N*N),stat=err)
if(err/=0) print'(a30,i9,i3)', 'ERROR in allocation for A',err
allocate(V(1:N),stat=err)
if(err/=0) print'(a30,i9,i3)', 'ERROR in allocation for V',err
allocate(Vout(1:N),stat=err)
if(err/=0) print'(a30,i9,i3)', 'ERROR in allocation for Vout',err

A(:) = 1.0
V(:) = 1.0
call gemv(N,alpha,A,V,Vout)
do val=1,N
   if (int(Vout(val)) .NE. N) then
        write(*,*) "Value does not match at",val,int(Vout(val))
   end if
end do

deallocate(A)
if(err/=0) print'(a30,i9,i3)', 'ERROR in deallocation for A',err
deallocate(V)
if(err/=0) print'(a30,i9,i3)', 'ERROR in deallocation for V',err
deallocate(Vout)
if(err/=0) print'(a30,i9,i3)', 'ERROR in deallocation for Vout',err
call system_clock(tj,tk)

print'(a20,3x,f12.4)',"total time: ", dble(tj-ti)/dble(tk)

stop
end

!-------------------------------------------------------
subroutine gemv(nval,alpha,A,V,Vout)

USE OMP_LIB
implicit none

integer:: row,col,A_row
integer:: nval,tid
real(8) :: alpha,sum_val
real(8),intent(in) :: A(1:nval*nval),V(1:nval)
real(8),intent(out):: Vout(1:nval)

!$omp parallel do default(shared) private(tid,row,col,A_row,sum_val)
do row=1,nval
   !tid=OMP_GET_THREAD_NUM()
   sum_val = 0.0
   A_row =(row-1)*nval
   !write(*,*) "total number of threads: ",tid,A_row,A_row+nval,nval*nval
   do col=1,nval
      sum_val = sum_val + A(A_row+col)*V(col)
   end do
   Vout(row) = sum_val * alpha
end do
!$omp end parallel do

end subroutine


PROGRAM LA_DSTEVD_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_STEVD
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, INFO, N
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: D(:), DD(:), E(:), EE(:), Z(:,:), DUMMY(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'DSTEVD ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N
   PRINT *, 'N = ', N
   ALLOCATE ( D(N), DD(N), E(N-1), EE(N-1), Z(N,N) )
!
   READ (NIN, *) DD, EE
   WRITE(NOUT,*) 'The matrix A:'
   WRITE (NOUT,*) 'D  '; WRITE (NOUT,FMT) DD
   WRITE (NOUT,*) 'EE '; WRITE (NOUT,FMT) EE
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_DSTEVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVD( D, E, Z, INFO )'
   D = DD; E = EE
   CALL LA_STEVD( D, E, Z, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
   WRITE(NOUT,FMT) D
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVD( D, E, Z )'
   D = DD; E = EE
   CALL LA_STEVD( D, E, Z )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) D
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVD( D, E )'
   D = DD; E = EE
   CALL LA_STEVD( D, E )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) D
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVD( DUMMY, E, INFO=INFO )'
   D = DD; E = EE
   CALL LA_STEVD( DUMMY, E, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVD( D, E(1:N), INFO=INFO )'
   D = DD; E = EE
   CALL LA_STEVD( D, E(1:N), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVD( D, E, Z=Z(1:N-1,:), INFO=INFO )'
   D = DD; E = EE
   CALL LA_STEVD( D, E, Z=Z(1:N-1,:), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVD( D, E, Z=Z(:,1:N-1) )'
   D = DD; E = EE
   CALL LA_STEVD( D, E, Z=Z(:,1:N-1) )
!
END PROGRAM LA_DSTEVD_ET_EXAMPLE


c     program DRDERFI
c>> 1996-06-27 DRDERFI  Krogh Minor change in formats for C conversion.
c>> 1996-05-28 DRDERFI  Krogh Added external statement.
c>> 1994-10-19 DRDERFI  Krogh  Changes to use M77CON
c>> 1992-04-21 DRDERFI  CLL
c>> 1991-11-19 CLL
c>> 1987-12-09 DRDERFI  Snyder  Initial Code.
c
c     Demonstration driver for DERFI and DERFCI.
c     ------------------------------------------------------------------
      external D1MACH, DERFI, DERFCI
      double precision DERFI, DERFCI, R, X, D1MACH, FLOOR
      integer I
c     ------------------------------------------------------------------
c--D replaces "?": DR?ERFI, ?ERFI, ?ERFCI
c     ------------------------------------------------------------------
   90 format (11x,1p,g12.5,g29.14)
      print '(/11x,''DRDERFI.. Demo driver for DERFI and DERFCI''//
     *   16x,''X'',13x,''DERFI(X) = DERFCI(1-X)'')'
      R = 1.0d-5
      do 10 I = 1,4
         X = 1.0d0 - R
         R = 10.0d0 * R
         print 90, X, DERFI(x)
   10 continue
      X = 0.9d0
      do 20 I = 1,9
         print 90, X, DERFI(x)
         X = X - 0.1d0
   20 continue
      print 90, 1.0d-10, DERFI(1.0d-10)
      print 90, 0.0d0, DERFI(0.0d0)
c
      print '(/16x,''X'',13x,''DERFCI(X) = DERFI(1-X)'')'
      X = 1.0d-10
      FLOOR = D1MACH(1) * 1.0d11
      do 30 I = 1,10
        print 90, X, DERFCI(X)
        if (X .lt. FLOOR) go to 40
        X = 1.0d-10 * X
   30 continue
   40 continue
      stop
      end


program test_reverse
use iso_fortran_env, only:int8, int16, int32, int64, real32, real64, real128
use testing, only:assert, initialize_tests, report_tests
use functional

implicit none

logical, dimension(:), allocatable :: tests
logical :: test_failed
integer :: n, ntests

n = 1
ntests = 12
call initialize_tests(tests, ntests)

tests(n) = assert(all(reverse(arange(1_int8, 3_int8)) == [3, 2, 1]), &
                  'reverse,  int8')
n = n + 1

tests(n) = assert(all(reverse(arange(1_int16, 3_int16)) == [3, 2, 1]), &
                  'reverse,  int16')
n = n + 1

tests(n) = assert(all(reverse(arange(1_int32, 3_int32)) == [3, 2, 1]), &
                  'reverse,  int32')
n = n + 1

tests(n) = assert(all(reverse(arange(1_int64, 3_int64)) == [3, 2, 1]), &
                  'reverse,  int64')
n = n + 1

tests(n) = assert(all(reverse(arange(1._real32, 3._real32)) == [3, 2, 1]), &
                  'reverse,  real32')
n = n + 1

tests(n) = assert(all(reverse(arange(1._real64, 3._real64)) == [3, 2, 1]), &
                  'reverse,  real64')
n = n + 1

tests(n) = assert(all(reverse(arange(1._real128, 3._real128)) == [3, 2, 1]), &
                  'reverse,  real128')
n = n + 1

tests(n) = assert(all(reverse(arange(cmplx(1._real32, 0._real32), &
                                     cmplx(3._real32, 0._real32)))&
                       == arange(cmplx(3._real32, 0._real32), &
                                 cmplx(1._real32, 0._real32), &
                                 cmplx(-1._real32, 0._real32))), &
                  'reverse,  complex real32')
n = n + 1

tests(n) = assert(all(reverse(arange(cmplx(1._real64, 0._real64), &
                                     cmplx(3._real64, 0._real64)))&
                       == arange(cmplx(3._real64, 0._real64), &
                                 cmplx(1._real64, 0._real64), &
                                 cmplx(-1._real64, 0._real64))), &
                  'reverse,  complex real64')
n = n + 1

tests(n) = assert(all(reverse(arange(cmplx(1._real128, 0._real128), &
                                     cmplx(3._real128, 0._real128)))&
                       == arange(cmplx(3._real128, 0._real128), &
                                 cmplx(1._real128, 0._real128), &
                                 cmplx(-1._real128, 0._real128))), &
                  'reverse,  complex real128')
n = n + 1

tests(n) = assert(reverse('Hello') == 'olleH', 'reverse character string')
n = n + 1

tests(n) = assert(all(reverse([1, 2, 3]) == .reverse.[1, 2, 3]), &
                  'reverse operator,  .reverse.x')
n = n + 1

test_failed = .false.
call report_tests(tests, test_failed)
if(test_failed)stop 1

end program test_reverse


      function appdiskdens(s,z)

      include 'commonblocks'

c  This is the density corresponding to the first-guess disk potential
c  f(r)*erfc((r-outdisk)/sqrt(2)drtrunc)/2 * 4 pi G zdisk**2 log(z/zdisk)
c  where r is spherical radius. f(r) is here taken as an exponential.
c
c  The corresponding density is:
c  f(r)*erfc*sech(z/zdisk)**2 + radial gradient terms.
c  For radii below one scale radius, we have replaced the radial exponential
c  (which gives rise to a singular laplacian) with a quartic that joins on
c  smoothly.
c
      r=sqrt(s*s+z*z)
c     radial truncation factors
      t=sqrt(0.5d0)*(r-outdisk)/drtrunc
      t2=t*t
      if (t.lt.-4.0) then
         eexp=0.
         eerfc=1.
      elseif (t.lt.4.0) then
         eexp=exp(-t2)/sqrt(2*pi)/drtrunc
         eerfc=0.5*erfc(t)
      else
         eexp=0
         eerfc=0
      endif
c     radial density
c     f is radial density, f1r is f'/r, f2 is f".
      if (r.gt.0.) then
         fac1=diskconst*zdisk**2*exp(-r/rdisk)
         f=fac1*eerfc
         f1r=-fac1*(eerfc/rdisk+eexp)/r
         f2=fac1*(eerfc/rdisk2+eexp*(2/rdisk+(r-outdisk)/drtrunc**2))
      else
         fac1=diskconst*zdisk**2
         f=fac1*eerfc
         f1r=0
         f2=0
      endif
c     vertical factors
      zz=abs(z/zdisk)
      ezz=exp(-zz)
      e2zz=ezz*ezz
      tlncosh=zz+log(0.5*(1+e2zz))
      tztanh=zz*(1-e2zz)/(1+e2zz)
      tsech2=(2*ezz/(1+e2zz))**2
      appdiskdens=f2*tlncosh+2*f1r*(tztanh+tlncosh)+f*tsech2/zdisk**2

      return
      end


      function RMP2(m_N, tau, taup, term, j_chi, coupling_Array)
      implicit none
      double precision :: RMP2, m_N, j_chi
      double precision :: coupling_Array(14,2)
      integer :: tau,taup
      integer :: term
      integer :: c, q2
      double precision :: c3, c1p
      double precision :: c12, c15, c11p
c
      c = 0
      q2 = 2
c
      c3 = coupling_Array(2,tau)
      c1p = coupling_Array(1,taup)
      c12 = coupling_Array(11,tau)
      c15 = coupling_Array(14,tau)
      c11p = coupling_Array(10,taup)
c
      if (term.eq.c) then
         RMP2 = c3*c1p + (j_chi*(j_chi+1))/3. * c12*c11p
      else if (term.eq.q2) then
         RMP2 = 1/m_N**2 * (j_chi*(j_chi+1))/3. * (-c15*c11p)
      else
         RMP2 = 0.
      end if
c
      end function RMP2


      subroutine scaleset_Msqpt345sq(p,mu0)
c--- subroutine to calculate dynamic scale equal to
c---  sqrt(M^2+pt345^2), where M is the mass of the particle (345)
      implicit none
      include 'constants.f'
      include 'process.f'
      include 'breit.f'
      double precision p(mxpart,4),mu0

      if((case .eq. 'tt_bbl') .or.
     &   (case .eq. 'tt_bbu') .or.
     &   (case .eq. 'tt_bbh')) then
        mu0=(p(3,4)+p(4,4)+p(5,4))**2-(p(3,3)+p(4,3)+p(5,3))**2
        mu0=dsqrt(dabs(mu0))
      else
        write(6,*) 'dynamicscale sqrt(M^2+pt345^2)'//
     &             ' not supported for this process.'
        stop
      endif

      return
      end


! pointsets.f90 --
!     Collection of routines to generate sets of points in
!     one, two or three dimensions with certain properties
!
!     TODO: 3D, circles, spheres, on spherical surface
!
!     $Id: pointsets.f90,v 1.2 2006/06/25 07:24:31 arjenmarkus Exp $
!
module pointsets
    use select_precision
    implicit none

    real, parameter, private :: pi = 3.1415926_wp ! Alas, no atan() possible

contains

! arithmetic_spacing --
!     Generate uniformly spaced coordinates
! Arguments:
!     x       Array to be filled
!     begin   First bound of the interval
!     end     Second bound of the interval
! Result:
!     Array x filled with values between begin and end
!
subroutine arithmetic_spacing( x, begin, end )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), intent(in)                  :: begin
    real(kind=wp), intent(in)                  :: end

    integer                                    :: i
    real(kind=wp)                              :: step

    if ( size(x) <= 1 ) return

    step = (end-begin)/(size(x)-1)
    x(1) = begin
    do i = 2,size(x)
        x(i) = x(i-1) + step
    enddo
end subroutine arithmetic_spacing

! geometric_spacing --
!     Generate coordinates spaced as a geometric series
! Arguments:
!     x       Array to be filled
!     begin   First bound of the interval
!     end     Second bound of the interval
!     ratio   Ratio between successive spacings
! Result:
!     Array x filled with values between begin and end
!
subroutine geometric_spacing( x, begin, end, ratio )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), intent(in)                  :: begin
    real(kind=wp), intent(in)                  :: end
    real(kind=wp), intent(in)                  :: ratio

    integer                                    :: i
    real(kind=wp)                              :: step
    real(kind=wp)                              :: scale

    if ( size(x) <= 1 ) return
    if ( ratio <= 0.0 ) return
    if ( ratio == 1.0 ) return

    step  = ratio
    x(1)  = 0.0
    do i = 2,size(x)
        x(i) = x(i-1) + step
        step = step * ratio
    enddo

    scale = (end-begin) / (x(size(x))-x(1))
    x = begin + scale * x
end subroutine geometric_spacing

! random_spacing --
!     Generate coordinates randomly spaced over an interval
! Arguments:
!     x       Array to be filled
!     begin   First bound of the interval
!     end     Second bound of the interval
! Result:
!     Array x filled with values between begin and end,
!     all coordinates non-decreasing
!
subroutine random_spacing( x, begin, end )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), intent(in)                  :: begin
    real(kind=wp), intent(in)                  :: end

    integer                                    :: i
    real(kind=wp)                              :: scale

    if ( size(x) <= 1 ) return

    call random_number( x )
    scale = end-begin
    x(1)  = 0.0
    do i = 2,size(x)
        x(i) = x(i-1) + x(i)
    enddo

    scale = (end-begin) / x(size(x))
    x = begin + scale * x
end subroutine random_spacing

! random_rectangle --
!     Generate points within a rectangle
!     that are uniformly distributed
! Arguments:
!     x       Array of x-coordinates to be filled
!     y       Array of y-coordinates to be filled
!     length  Length of the block
!     width   Width of the block
! Result:
!     Points uniformly distributed in the sense
!     that the expected number of points in a
!     region of the block depends only on the
!     region's area
!     Coordinates from 0 to length and 0 to width
!
subroutine random_rectangle( x, y, length, width )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), dimension(:), intent(inout) :: y
    real(kind=wp), intent(in)                  :: length
    real(kind=wp), intent(in)                  :: width

    integer                                    :: i
    integer                                    :: n
    real(kind=wp)                              :: range

    if ( length <= 0.0 ) return
    if ( width  <= 0.0 ) return

    range = max( length, width )

    i = 1
    n = size(x)

    do while ( i < n )
        call random_number( x(i) )
        call random_number( y(i) )
        x(i) = range * x(i)
        y(i) = range * y(i)
        if ( x(i) <= length .and. y(i) <= width ) then
            i = i + 1
        endif
    enddo
end subroutine random_rectangle

! random_block --
!     Generate points within a (three-dimensional) block
!     that are uniformly distributed
! Arguments:
!     x       Array of x-coordinates to be filled
!     y       Array of y-coordinates to be filled
!     z       Array of z-coordinates to be filled
!     length  Length of the block
!     width   Width of the block
!     height  Height of the block
! Result:
!     Points uniformly distributed in the sense
!     that the expected number of points in a
!     region of the block depends only on the
!     region's area
!     Coordinates from 0 to length, 0 to width
!     and 0 to height
!
subroutine random_block( x, y, z, length, width, height )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), dimension(:), intent(inout) :: y
    real(kind=wp), dimension(:), intent(inout) :: z
    real(kind=wp), intent(in)                  :: length
    real(kind=wp), intent(in)                  :: width
    real(kind=wp), intent(in)                  :: height

    integer                                    :: i
    integer                                    :: n
    real(kind=wp)                              :: range

    if ( length <= 0.0 ) return
    if ( width  <= 0.0 ) return
    if ( height <= 0.0 ) return

    range = max( length, width, height )

    i = 1
    n = size(x)

    do while ( i < n )
        call random_number( x(i) )
        call random_number( y(i) )
        call random_number( z(i) )
        x(i) = range * x(i)
        y(i) = range * y(i)
        z(i) = range * z(i)
        if ( x(i) <= length .and. y(i) <= width .and. z(i) <= height ) then
            i = i + 1
        endif
    enddo
end subroutine random_block

! random_rectangle_filter --
!     Generate points within a two-dimensional block
!     that are uniformly distributed
! Arguments:
!     x       Array of x-coordinates to be filled
!     y       Array of y-coordinates to be filled
!     length  Length of the block
!     width   Width of the block
!     filter  Filter function
!     params  Array of parameters for the filter
! Result:
!     The points are generated as in random_rectangle
!     but are passed to the filter function as well,
!     only if they pass the filter are they accepted
!
subroutine random_rectangle_filter( x, y, length, width, filter, params )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), dimension(:), intent(inout) :: y
    real(kind=wp), intent(in)                  :: length
    real(kind=wp), intent(in)                  :: width
    real(kind=wp), dimension(:), intent(in)    :: params

    interface
        logical function filter( xp, yp, x, y, params )
            use select_precision
            real(kind=wp), intent(inout)            :: xp
            real(kind=wp), intent(inout)            :: yp
            real(kind=wp), dimension(:), intent(in) :: x
            real(kind=wp), dimension(:), intent(in) :: y
            real(kind=wp), dimension(:), intent(in) :: params
        end function filter
    end interface

    integer                                    :: i
    integer                                    :: n
    real(kind=wp)                              :: range

    if ( length <= 0.0 ) return
    if ( width  <= 0.0 ) return

    range = max( length, width )

    i = 1
    n = size(x)

    do while ( i < n )
        call random_number( x(i) )
        call random_number( y(i) )
        x(i) = range * x(i)
        y(i) = range * y(i)
        if ( x(i) <= length .and. y(i) <= width .and. &
            filter( x(i), y(i), x(1:i-1), y(1:i-1), params ) ) then
            i = i + 1
        endif
    enddo
end subroutine random_rectangle_filter

! filter_triangle --
!     Filter points that do not lie in a triangle
! Arguments:
!     xp      X-coordinate of candidate point
!     yp      Y-coordinate of candidate point
!     x       Array of x-coordinates filled so far
!     y       Array of y-coordinates filled so far
!     params  Array of parameters for the filter
! Result:
!     True if the point lies within the triangle,
!     false otherwise
!
logical function filter_triangle( xp, yp, x, y, params )
    use select_precision
    real(kind=wp), intent(inout)            :: xp
    real(kind=wp), intent(inout)            :: yp
    real(kind=wp), dimension(:), intent(in) :: x
    real(kind=wp), dimension(:), intent(in) :: y
    real(kind=wp), dimension(:), intent(in) :: params

    if ( xp/params(1)+yp/params(2) < 1.0 ) then
        filter_triangle = .true.
    else
        filter_triangle = .false.
    endif
end function filter_triangle

! random_triangle --
!     Generate points within the triangle (0,0)-(length,0)-(0,width)
!     that are uniformly distributed
! Arguments:
!     x       Array of x-coordinates to be filled
!     y       Array of y-coordinates to be filled
!     length  Length of the block
!     width   Width of the block
! Result:
!     Uniformly random points
!
subroutine random_triangle( x, y, length, width )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), dimension(:), intent(inout) :: y
    real(kind=wp), intent(in)                  :: length
    real(kind=wp), intent(in)                  :: width

    real(kind=wp), dimension(1:2)              :: params

    params(1) = length
    params(2) = width

    call random_rectangle_filter( x, y, length, width, filter_triangle, params )
end subroutine random_triangle

! random_disk --
!     Generate points within a circle of given radius.
!     The points are uniformly distributed
! Arguments:
!     x       Array of x-coordinates to be filled
!     y       Array of y-coordinates to be filled
!     radius  Radius of the circle
! Result:
!     Uniformly random points (that is: average
!     number of points depends only on the area,
!     not the position)
!
subroutine random_disk( x, y, radius )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), dimension(:), intent(inout) :: y
    real(kind=wp), intent(in)                  :: radius

    real(kind=wp)                              :: xp
    real(kind=wp)                              :: yp
    integer                                    :: i

    call random_rectangle( x, y, 1.0_wp, 1.0_wp )

    x = sqrt(x)
    y = 2.0_wp * pi * y

    do i = 1,size(x)
        xp = x(i)
        yp = y(i)
        x(i) = xp * cos(yp)
        y(i) = yp * sin(yp)
    enddo

end subroutine random_disk

! random_ball --
!     Generate points within a sphere of given radius.
!     The points are uniformly distributed
! Arguments:
!     x       Array of x-coordinates to be filled
!     y       Array of y-coordinates to be filled
!     z       Array of z-coordinates to be filled
!     radius  Radius of the sphere
! Result:
!     Uniformly random points (that is: average
!     number of points depends only on the area,
!     not the position)
!
subroutine random_ball( x, y, z, radius )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), dimension(:), intent(inout) :: y
    real(kind=wp), dimension(:), intent(inout) :: z
    real(kind=wp), intent(in)                  :: radius

    real(kind=wp)                              :: xp
    real(kind=wp)                              :: yp
    real(kind=wp)                              :: zp
    integer                                    :: i

    call random_block( x, y, z, 1.0_wp, 1.0_wp, 1.0_wp )

    x = x**(1.0_wp/3.0_wp)
    y = 2.0_wp * pi * y
    z = acos( 2.0_wp*z-1.0_wp )

    do i = 1,size(x)
        xp = x(i)
        yp = y(i)
        zp = z(i)
        x(i) = xp * cos(yp) * cos(zp)
        y(i) = xp * sin(yp) * sin(zp)
        z(i) = xp * sin(zp)
    enddo

end subroutine random_ball

! random_sphere --
!     Generate points on the surface of a sphere of
!     given radius. The points are uniformly distributed
! Arguments:
!     x       Array of x-coordinates to be filled
!     y       Array of y-coordinates to be filled
!     z       Array of z-coordinates to be filled
!     radius  Radius of the sphere
! Result:
!     Uniformly random points (that is: average
!     number of points depends only on the area,
!     not the position)
!
subroutine random_sphere( x, y, z, radius )
    real(kind=wp), dimension(:), intent(inout) :: x
    real(kind=wp), dimension(:), intent(inout) :: y
    real(kind=wp), dimension(:), intent(inout) :: z
    real(kind=wp), intent(in)                  :: radius

    real(kind=wp)                              :: yp
    real(kind=wp)                              :: zp
    integer                                    :: i

    call random_rectangle( x, y, 1.0_wp, 1.0_wp )

    y = 2.0_wp * pi * y
    z = acos( 2.0_wp*z-1.0_wp )

    do i = 1,size(x)
        yp = y(i)
        zp = z(i)
        x(i) = radius * cos(yp) * cos(zp)
        y(i) = radius * sin(yp) * sin(zp)
        z(i) = radius * sin(zp)
    enddo
end subroutine random_sphere

end module pointsets


program assumed
    implicit none
    integer :: i
    integer, dimension(5) :: array1d = [ 2, 3, 5, 7, 11 ]

    print *, array1d
    call factorial(array1d)
    print *, array1d
contains

    integer function fac(n)
        implicit none
        integer, value :: n
        integer :: i

        fac = 1
        do i = 2, n
            fac = fac*i
        end do
    end function fac

    subroutine factorial(A)
        implicit none
        integer, dimension(:), intent(inout) :: A
        integer :: i

        do i = 1, size(A)
            A(i) = fac(A(i))
        end do
    end subroutine factorial

end program assumed


program main

interface
    subroutine mxv(m, n, a, b, c)
        integer(kind=4), intent(in)    :: m,n
        real   (kind=8), intent(in)    :: b(1:m,1:n), c(1:n)
        real   (kind=8), intent(inout) :: a(1:m)
    end subroutine mxv
end interface
real(kind=8), allocatable :: a(:), b(:,:), c(:)
integer(kind=4)           :: m, n, i, memstat

print *, 'Enter values for m and n:'; read(*,*) m, n

allocate( a(1:m), stat=memstat )
if ( memstat /= 0 ) stop 'Error in memory allocation for a'
allocate( b(1:m,1:n), stat=memstat )
if ( memstat /= 0 ) stop 'Error in memory allocation for b'
allocate( c(1:n), stat=memstat )
if ( memstat /= 0 ) stop 'Error in memory allocation for c'

print *, 'Initializing matrix B and vector c'
c(1:n) = 1.0
do i = 1, m
    b(i, 1:n) = i
end do

print *, 'Executing mxv routine for m =', m, 'n=', n

call mxv(m, n, a, b, c)

if ( allocated(a) ) deallocate(a,stat=memstat)
if ( allocated(b) ) deallocate(b,stat=memstat)
if ( allocated(c) ) deallocate(c,stat=memstat)

stop
end program main

subroutine mxv(m, n, a, b, c)

implicit none
integer(kind=4) :: m, n
real   (kind=8) :: a(1:m), b(1:m,1:n), c(1:n)

integer(kind=4) :: i, j

!$OMP PARALLEL DO DEFAULT(NONE) &
!$OMP SHARED(m,n,a,b,c) PRIVATE(i,j)
do i = 1, m
    a(i) = 0.0
    do j = 1, n
        a(i) = a(i) + b(i,j)*c(j)
        ! print *, i, j, a(i)
    end do
end do
!$OMP END PARALLEL DO

! print *, 'A = ', a
! print *
! print *, 'B = '
! do i = 1, m
!     print *, b(i,:)
! end do
! print *
! print *, 'C = ', c

return
end subroutine mxv


Module numbers_module

  !! Little module to set the precision of real numbers that we shall use

  Implicit None

  Integer, Public, Parameter :: wp = Selected_real_kind( 14, 70 )  !! Kind for real numbers

  Private

End Module numbers_module


program data_creator
    use, intrinsic :: iso_fortran_env
    implicit none
    integer, parameter :: sp=REAL32
    integer :: x_points = 10, y_points = 10, z_points = 10, &
               time_points = 5
    real(kind=sp), parameter :: x_delta = 0.1_sp, &
                                y_delta = 0.1_sp, &
                                z_delta = 0.1_sp, &
                                f_alpha = 0.7_sp
    real(kind=sp) :: x = 0.0_sp, y = 0.0_sp, z = 0.0_sp, alpha = 1.0_sp, &
                     value
    integer :: i, j, k, t
    integer :: istat = 0
    character(len=40) :: buffer
    character(len=1024) :: base_file_name
    character(len=128) :: file_name_fmt = "(A, '-', I0.3, '.bin')"
    character(len=2014) :: file_name

    if (command_argument_count() >= 1) then
        call get_command_argument(1, base_file_name)
    else
        base_file_name = 'data'
    end if
    if (command_argument_count() >= 2) then
        call get_command_argument(2, buffer)
        read (unit=buffer, fmt='(I4)') x_points
        y_points = x_points
        z_points = x_points
    end if
    if (command_argument_count() >= 3) then
        call get_command_argument(2, buffer)
        read (unit=buffer, fmt='(I4)') time_points
    end if
    do t = 1, time_points
        write (unit=file_name, fmt=file_name_fmt) trim(base_file_name), t
        open(unit=1, file=file_name, form='unformatted', &
             access='stream', iostat=istat)
        if (istat /= 0) then
            print *, '# error: I/O error: can not open'
            stop
        end if
        x = 0.0_sp
        do i = 1, x_points
            y = 0.0_sp
            do j = 1, y_points
                z = 0.0_sp
                do k = 1, z_points
                    value = exp(-alpha*(x**2 + y**2 + z**2))
                    write(unit=1) value
                    z = z + z_delta
                end do
                y = y + y_delta
            end do
            x = x + x_delta
        end do
        alpha = alpha * f_alpha
        close(unit=1)
    end do

end program data_creator


!! R704 mult-operand
!    is level-1-expr [ power-op mult-operand ]
!
!  mult-operand is a power-op

a = 1 ** 2
a = 1 ** (-2) ** 3
end


C File: arrays-constr-02.f
C This program has a simple 1-D array with the default lower bound of 1.
C It shows the use of an array constructor to initialize the array.

      program main
      implicit none

C     arr and X are 1-D arrays of integers with an implicit lower-bound = 1
C     and upper bound of 10.
      integer, dimension(10) :: X = (/11,22,33,44,55,66,77,88,99,110/)
      integer, dimension(10) :: arr
      integer :: i

C     array constructor I -- array expression
      arr = (/ 10, 20, X(3:8), 90, 100/)

      do i = 1, 10
          write (*,10) arr(i)
      end do

 10   format(I5)

      stop
      end program main


        subroutine pixcrot(i,j,iref,jref,crota2,irot,jrot)

! Transform pixel coordinates into a rotated frame where the y-axis
! corresponds to north.

        implicit real(8) (a-h, o-z)
        real(8),   parameter   :: dtor    = 0.0174533   ! degrees to radians
        real(8) i, j, iref, jref, irot, jrot

        st = sin(crota2*dtor)
        ct = cos(crota2*dtor)
        xp = (i-iref)*ct + (j-jref)*st
        yp = (j-jref)*ct - (i-iref)*st
        irot = iref + xp
        jrot = jref + yp
        return

        end subroutine pixcrot


      SUBROUTINE CORREL(DATA1,DATA2,N,ANS)
      PARAMETER(NMAX=8192)
      DIMENSION DATA1(N),DATA2(N)
      COMPLEX FFT(NMAX),ANS(N)
      CALL TWOFFT(DATA1,DATA2,FFT,ANS,N)
      NO2=FLOAT(N)/2.0
      DO 11 I=1,N/2+1
        ANS(I)=FFT(I)*CONJG(ANS(I))/NO2
11    CONTINUE
      ANS(1)=CMPLX(REAL(ANS(1)),REAL(ANS(N/2+1)))
      CALL REALFT(ANS,N/2,-1)
      RETURN
      END


      SUBROUTINE MF_FCTVAL (thetaz,f)

c***********************************************************************

c     Routine for computing F-function values wrt THETA at arbitrary
c     values of THETA.  Called on principally by routine MF_FZEROS.
c     This is the modified F-function which has no poles and which has
c     no zeros at THETA=(90,0).

c  Change History:
c     26 Oct 95     Changed to get the LOG unit from LWPC_LUN.CMN.

c*******************!***************************************************

      implicit complex (a-h,o-z)

c     LWPC parameters
      include      'lwpc_lun.cmn'

      real           omega,wavenr
      complex        num11,num22

      common/mf_flag/iexact,iovflo,kexact,lowg,nodivd,noevct,
     &               nofinl,nointg,nomesh,notlin
     &      /mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_rbrs/num11,num22,den11,den22,dnum11,dnum22,dden11,
     &               dden22,f1,f2,hg
     &      /mf_rntg/r11,r21,r12,r22,dr11,dr21,dr12,dr22,drdh(8),
     &               roe(8),rnum11,rnum21,rnum12,rnum22,rden

      theta=thetaz
cxx      write(lwpcLOG_lun,
cxx     &    '(''MF_FCTVAL: theta, noevct'',2f10.3,i3)')
cxx     &        theta,noevct
      ideriv=0
      call mf_r bars
cxx      write(lwpcLOG_lun,
cxx     &    '(''MF_FCTVAL: num'',1p8e12.3)')
cxx     &        num11,num22,den11,den22
      if (noevct .eq. 0) then
         call mf_int roe
         f=(rden*num11-rnum11*den11)*(rden*num22-rnum22*den22)
     &     -rnum12*rnum21*den11*den22
cxx         write(lwpcLOG_lun,
cxx     &       '(''MF_FCTVAL: rnum'',1p10e12.3)')
cxx     &           rnum11,rnum22,rnum12,rnum21,rden
      else
         call mf_lagrng
         f=(num11-r11*den11)*(num22-r22*den22)
     &     -r12*r21*den11*den22
cxx         write(lwpcLOG_lun,
cxx     &       '(''MF_FCTVAL: rnum'',1p10e12.3)')
cxx     &           r11,r22,r12,r21
      end if
      RETURN
      END      ! MF_FCTVAL


      program main
      n=5
      k = ifact(n)
      print *,k
      end
      function ifact(n)
      if(n.eq.1) then
        ifact=n
      else
        ifact = n*ifact(n-1)
      endif
      return
      end


module nf_random

  !! Provides a random number generator with
  !! normal distribution, centered on zero.

  implicit none

  private
  public :: randn

  interface randn

    module function randn_1d(i) result(r)
      !! Generates i random numbers with a normal distribution,
      !! using the Box-Muller method.
      implicit none
      integer, intent(in) :: i
      real :: r(i)
    end function randn_1d

    module function randn_2d(i, j) result(r)
      !! Generates i x j random numbers with a normal distribution,
      !! using the Box-Muller method.
      implicit none
      integer, intent(in) :: i, j
      real :: r(i,j)
    end function randn_2d

    module function randn_4d(i, j, k, l) result(r)
      !! Generates i x j x k x l random numbers with a normal distribution,
      !! using the Box-Muller method.
      implicit none
      integer, intent(in) :: i, j, k, l
      real :: r(i,j,k,l)
    end function randn_4d

  end interface randn

end module nf_random


        subroutine idz_snorm(m,n,matveca,p1a,p2a,p3a,p4a,
     1                       matvec,p1,p2,p3,p4,its,snorm,v,u)
c
c       estimates the spectral norm of a matrix a specified
c       by a routine matvec for applying a to an arbitrary vector,
c       and by a routine matveca for applying a^*
c       to an arbitrary vector. This routine uses the power method
c       with a random starting vector.
c
c       input:
c       m -- number of rows in a
c       n -- number of columns in a
c       matveca -- routine which applies the adjoint of a
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matveca(m,x,n,y,p1a,p2a,p3a,p4a),
c
c                  where m is the length of x,
c                  x is the vector to which the adjoint of a
c                  is to be applied,
c                  n is the length of y,
c                  y is the product of the adjoint of a and x,
c                  and p1a, p2a, p3a, and p4a are user-specified
c                  parameters
c       p1a -- parameter to be passed to routine matveca
c       p2a -- parameter to be passed to routine matveca
c       p3a -- parameter to be passed to routine matveca
c       p4a -- parameter to be passed to routine matveca
c       matvec -- routine which applies the matrix a
c                 to an arbitrary vector; this routine must have
c                 a calling sequence of the form
c
c                 matvec(n,x,m,y,p1,p2,p3,p4),
c
c                 where n is the length of x,
c                 x is the vector to which a is to be applied,
c                 m is the length of y,
c                 y is the product of a and x,
c                 and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvec
c       p2 -- parameter to be passed to routine matvec
c       p3 -- parameter to be passed to routine matvec
c       p4 -- parameter to be passed to routine matvec
c       its -- number of iterations of the power method to conduct
c
c       output:
c       snorm -- estimate of the spectral norm of a
c       v -- estimate of a normalized right singular vector
c            corresponding to the greatest singular value of a
c
c       work:
c       u -- must be at least m complex*16 elements long
c
c       reference:
c       Kuczynski and Wozniakowski, "Estimating the largest eigenvalue
c            by the power and Lanczos algorithms with a random start,"
c            SIAM Journal on Matrix Analysis and Applications,
c            13 (4): 1992, 1094-1122.
c
        implicit none
        integer m,n,its,it,n2,k
        real*8 snorm,enorm
        complex*16 p1a,p2a,p3a,p4a,p1,p2,p3,p4,u(m),v(n)
        external matveca,matvec
c
c
c       Fill the real and imaginary parts of each entry
c       of the initial vector v with i.i.d. random variables
c       drawn uniformly from [-1,1].
c
        n2 = 2*n
        call id_srand(n2,v)
c
        do k = 1,n
          v(k) = 2*v(k)-1
        enddo ! k
c
c
c       Normalize v.
c
        call idz_enorm(n,v,enorm)
c
        do k = 1,n
          v(k) = v(k)/enorm
        enddo ! k
c
c
        do it = 1,its
c
c         Apply a to v, obtaining u.
c
          call matvec(n,v,m,u,p1,p2,p3,p4)
c
c         Apply a^* to u, obtaining v.
c
          call matveca(m,u,n,v,p1a,p2a,p3a,p4a)
c
c         Normalize v.
c
          call idz_enorm(n,v,snorm)
c
          if(snorm .ne. 0) then
c
            do k = 1,n
              v(k) = v(k)/snorm
            enddo ! k
c
          endif
c
          snorm = sqrt(snorm)
c
        enddo ! it
c
c
        return
        end
c
c
c
c


!---------------------------------------------------------------------------!
!Computing true SGS from velocity field
!---------------------------------------------------------------------------!
!Omer San, Oklahoma State University, cfdlab.osu@gmail.com
!Updated: Jan 30, 2018
!---------------------------------------------------------------------------!

program sgscompute3d
implicit none
integer::nx,ny,nz,nxc,nyc,nzc,nr,i,j,k,nbin,if1,ns,nf
double precision,dimension(:,:,:),allocatable::x,y,z
double precision,dimension(:,:,:),allocatable::u,v,w
double precision,dimension(:,:,:),allocatable::xc,yc,zc
double precision,dimension(:,:,:),allocatable::uc,vc,wc
double precision,dimension(:,:,:),allocatable::t11,t12,t13,t22,t23,t33
character(80):: snapID,corID,filename

!number of files:
ns=1
nf=5

!DNS resolution
nx=512
ny=nx
nz=nx

!LES grid ratio:
nr = 8

write(corID,'(i5)') nr  !index for coarsining ratio

!LES resolution
nxc=nx/nr
nyc=nxc
nzc=nxc

!perform for all data sets:
do if1=ns,nf

!DNS grid
allocate(x(0:nx,0:ny,0:nz))
allocate(y(0:nx,0:ny,0:nz))
allocate(z(0:nx,0:ny,0:nz))

!DNS velocity components
allocate(u(0:nx,0:ny,0:nz))
allocate(v(0:nx,0:ny,0:nz))
allocate(w(0:nx,0:ny,0:nz))

!LES grid
allocate(xc(0:nxc,0:nyc,0:nzc))
allocate(yc(0:nxc,0:nyc,0:nzc))
allocate(zc(0:nxc,0:nyc,0:nzc))

!LES velocity components
allocate(uc(0:nxc,0:nyc,0:nzc))
allocate(vc(0:nxc,0:nyc,0:nzc))
allocate(wc(0:nxc,0:nyc,0:nzc))

!true SGS stress (deviatoric part) on LES grid
allocate(t11(0:nxc,0:nyc,0:nzc))
allocate(t12(0:nxc,0:nyc,0:nzc))
allocate(t13(0:nxc,0:nyc,0:nzc))
allocate(t22(0:nxc,0:nyc,0:nzc))
allocate(t23(0:nxc,0:nyc,0:nzc))
allocate(t33(0:nxc,0:nyc,0:nzc))

write(snapID,'(i5)') if1  !index for time snapshot

!Reading the DNS data
filename = 'a_vel_'// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
read(19,*)
read(19,*)
do k=0,nz
do j=0,ny
do i=0,nx
read(19,*)x(i,j,k),y(i,j,k),z(i,j,k),u(i,j,k),v(i,j,k),w(i,j,k)
end do
end do
end do
close(19)

filename='AA'// trim(adjustl(corID)) //'_spectrum_DNS_'// trim(adjustl(snapID)) //'.plt'
call spectrum3d(nx,ny,nz,u,v,w,filename)

!obtain LES field:
!direct coarsening:old way
do k=0,nzc
do j=0,nyc
do i=0,nxc
xc(i,j,k)=x(nr*i,nr*j,nr*k)
yc(i,j,k)=y(nr*i,nr*j,nr*k)
zc(i,j,k)=z(nr*i,nr*j,nr*k)
uc(i,j,k)=u(nr*i,nr*j,nr*k)
vc(i,j,k)=v(nr*i,nr*j,nr*k)
wc(i,j,k)=w(nr*i,nr*j,nr*k)
end do
end do
end do

filename='AA'// trim(adjustl(corID)) //'_spectrum_CRS_'// trim(adjustl(snapID)) //'.plt'
call spectrum3d(nxc,nyc,nzc,uc,vc,wc,filename)

filename ='AA'// trim(adjustl(corID)) //'_velocity_CRS_'// trim(adjustl(snapID)) //'.plt'
open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z","u","v","w"'
write(19,*) 'zone T=','Zone_ i=', nxc+1, ' j=', nyc+1,',k=',nzc+1,' f=point'
do k=0,nzc
do j=0,nyc
do i=0,nxc
write(19,*)xc(i,j,k),yc(i,j,k),zc(i,j,k),uc(i,j,k),vc(i,j,k),wc(i,j,k)
end do
end do
end do
close(19)

!fft coarsening:correct way
call coarsen(nx,ny,nz,nxc,nyc,nzc,u,uc)
call coarsen(nx,ny,nz,nxc,nyc,nzc,v,vc)
call coarsen(nx,ny,nz,nxc,nyc,nzc,w,wc)

filename='AA'// trim(adjustl(corID)) //'_spectrum_LES_'// trim(adjustl(snapID)) //'.plt'
call spectrum3d(nxc,nyc,nzc,uc,vc,wc,filename)

filename ='AA'// trim(adjustl(corID)) //'_velocity_LES_'// trim(adjustl(snapID)) //'.plt'
open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z","u","v","w"'
write(19,*) 'zone T=','Zone_ i=', nxc+1, ' j=', nyc+1,',k=',nzc+1,' f=point'
do k=0,nzc
do j=0,nyc
do i=0,nxc
write(19,*)xc(i,j,k),yc(i,j,k),zc(i,j,k),uc(i,j,k),vc(i,j,k),wc(i,j,k)
end do
end do
end do
close(19)

!compute true SGS stress (deviatoric part) on LES grid
call sgs(nx,ny,nz,nxc,nyc,nzc,u,v,w,uc,vc,wc,t11,t12,t13,t22,t23,t33)

filename ='AA'// trim(adjustl(corID)) //'_trueSGS_field_'// trim(adjustl(snapID)) //'.plt'
open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z","t11","t12","t13","t22","t23","t33"'
write(19,*) 'zone T=','Zone_ i=', nxc+1, ' j=', nyc+1,',k=',nzc+1,' f=point'
do k=0,nzc
do j=0,nyc
do i=0,nxc
write(19,*)xc(i,j,k),yc(i,j,k),zc(i,j,k),t11(i,j,k),t12(i,j,k),t13(i,j,k),t22(i,j,k),t23(i,j,k),t33(i,j,k)
end do
end do
end do
close(19)

!Compute PDF of true SGS terms:64 bins
nbin=64

filename = 'AA'// trim(adjustl(corID)) //'_PDF_64bin_trueSGS_t11_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t11,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_64bin_trueSGS_t12_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t12,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_64bin_trueSGS_t13_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t13,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_64bin_trueSGS_t22_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t22,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_64bin_trueSGS_t23_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t23,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_64bin_trueSGS_t33_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t33,filename)

!Compute PDF of true SGS terms:32 bins
nbin=32

filename = 'AA'// trim(adjustl(corID)) //'_PDF_32bin_trueSGS_t11_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t11,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_32bin_trueSGS_t12_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t12,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_32bin_trueSGS_t13_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t13,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_32bin_trueSGS_t22_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t22,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_32bin_trueSGS_t23_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t23,filename)

filename = 'AA'// trim(adjustl(corID)) //'_PDF_32bin_trueSGS_t33_'// trim(adjustl(snapID)) //'.plt'
call pdf_calc(nxc,nyc,nzc,nbin,t33,filename)

deallocate(x,y,z,xc,yc,zc,u,v,w,uc,vc,wc,t11,t12,t13,t22,t23,t33)
end do

end

!-----------------------------------------------------------------!
!Compute coarsening using FFT
!-----------------------------------------------------------------!
subroutine coarsen(nx,ny,nz,nxc,nyc,nzc,u,uc)
implicit none
integer::nx,ny,nz
integer::nxc,nyc,nzc
double precision ::u(0:nx,0:ny,0:nz)
double precision ::uc(0:nxc,0:nyc,0:nzc)
integer::i,j,k,p
double precision,dimension(:),allocatable:: data1d
double precision,dimension(:),allocatable:: data1c
complex*16, dimension(:,:,:),allocatable::gm(:,:,:),gc(:,:,:)
integer,parameter::ndim=3
integer::nn(ndim),isign
double precision ::temp

allocate(data1d(2*nx*ny*nz))
allocate(data1c(2*nxc*nyc*nzc))

!finding fourier coefficients
p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j,k)
data1d(p+1)=0.0d0
p=p+2
end do
end do
end do

!normalize
temp=1.0d0/dfloat(nx*ny*nz)
do p=1,2*nx*ny*nz
data1d(p)=data1d(p)*temp
end do

!invese fourier transform
nn(1)= nx
nn(2)= ny
nn(3)= nz
isign=-1
call fourn(data1d,nn,ndim,isign)

!in the following: gm=fine data & gc=coarsen data

!finding fourier coefficients: real and imaginary
allocate(gm(0:nx-1,0:ny-1,0:nz-1))
p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
gm(i,j,k)= dcmplx(data1d(p),data1d(p+1))
p=p+2
end do
end do
end do

!coarsen:
allocate(gc(0:nxc-1,0:nyc-1,0:nzc-1))

do k=0,nzc/2
	do j=0,nyc/2
		do i=0,nxc/2
		gc(i,j,k) = gm(i,j,k)
		end do
		do i=nxc/2+1,nxc-1
		gc(i,j,k) = gm(i+(nx-nxc),j,k)
		end do
	end do
end do

do k=0,nzc/2
	do j=nyc/2+1,nyc-1
		do i=0,nxc/2
		gc(i,j,k) = gm(i,j+(ny-nyc),k)
		end do
		do i=nxc/2+1,nxc-1
		gc(i,j,k) = gm(i+(nx-nxc),j+(ny-nyc),k)
		end do
	end do
end do

do k=nzc/2+1,nzc-1
	do j=0,nyc/2
		do i=0,nxc/2
		gc(i,j,k) = gm(i,j,k+(nz-nzc))
		end do
		do i=nxc/2+1,nxc-1
		gc(i,j,k) = gm(i+(nx-nxc),j,k+(nz-nzc))
		end do
	end do
end do

do k=nzc/2+1,nzc-1
	do j=nyc/2+1,nyc-1
		do i=0,nxc/2
		gc(i,j,k) = gm(i,j+(ny-nyc),k+(nz-nzc))
		end do
		do i=nxc/2+1,nxc-1
		gc(i,j,k) = gm(i+(nx-nxc),j+(ny-nyc),k+(nz-nzc))
		end do
	end do
end do

!coarsening
p=1
do k=0,nzc-1
do j=0,nyc-1
do i=0,nxc-1
data1c(p)=dreal(gc(i,j,k))
data1c(p+1)=dimag(gc(i,j,k))
p=p+2
end do
end do
end do

!forward fourier transform
nn(1)= nxc
nn(2)= nyc
nn(3)= nzc
isign= 1
call fourn(data1c,nn,ndim,isign)

p=1
do k=0,nzc-1
do j=0,nyc-1
do i=0,nxc-1
uc(i,j,k) = data1c(p)
p=p+2
end do
end do
end do

deallocate(data1d,data1c,gc,gm)

return
end

!-----------------------------------------------------------------------------------------!
!SGS tensor (deviatoric part)
!-----------------------------------------------------------------------------------------!
subroutine sgs(nx,ny,nz,nxc,nyc,nzc,u,v,w,uc,vc,wc,t11,t12,t13,t22,t23,t33)
implicit none
integer :: nx,ny,nz,nxc,nyc,nzc,i,j,k
double precision,dimension(0:nx,0:ny,0:nz) :: u,v,w
double precision,dimension(0:nxc,0:nyc,0:nzc) :: uc,vc,wc,t11,t12,t13,t22,t23,t33
double precision,dimension(:,:,:),allocatable :: t11a,t12a,t13a,t22a,t23a,t33a,tii

allocate(t11a(0:nx,0:ny,0:nz))
allocate(t12a(0:nx,0:ny,0:nz))
allocate(t13a(0:nx,0:ny,0:nz))
allocate(t22a(0:nx,0:ny,0:nz))
allocate(t23a(0:nx,0:ny,0:nz))
allocate(t33a(0:nx,0:ny,0:nz))

allocate(tii(0:nxc,0:nyc,0:nzc))

!compute nonlinear interatcions on DNS grid
do k = 0,nz
do j = 0,ny
do i = 0,nx
t11a(i,j,k) = u(i,j,k)*u(i,j,k)
t12a(i,j,k) = u(i,j,k)*v(i,j,k)
t13a(i,j,k) = u(i,j,k)*w(i,j,k)
t22a(i,j,k) = v(i,j,k)*v(i,j,k)
t23a(i,j,k) = v(i,j,k)*w(i,j,k)
t33a(i,j,k) = w(i,j,k)*w(i,j,k)
end do
end do
end do

!Coarsen to LES grid:
call coarsen(nx,ny,nz,nxc,nyc,nzc,t11a,t11)
call coarsen(nx,ny,nz,nxc,nyc,nzc,t12a,t12)
call coarsen(nx,ny,nz,nxc,nyc,nzc,t13a,t13)
call coarsen(nx,ny,nz,nxc,nyc,nzc,t22a,t22)
call coarsen(nx,ny,nz,nxc,nyc,nzc,t23a,t23)
call coarsen(nx,ny,nz,nxc,nyc,nzc,t33a,t33)

!Compute SGS:
do k = 0,nzc
do j = 0,nyc
do i = 0,nxc
t11(i,j,k) = uc(i,j,k)*uc(i,j,k)-t11(i,j,k)
t12(i,j,k) = uc(i,j,k)*vc(i,j,k)-t12(i,j,k)
t13(i,j,k) = uc(i,j,k)*wc(i,j,k)-t13(i,j,k)
t22(i,j,k) = vc(i,j,k)*vc(i,j,k)-t22(i,j,k)
t23(i,j,k) = vc(i,j,k)*wc(i,j,k)-t23(i,j,k)
t33(i,j,k) = wc(i,j,k)*wc(i,j,k)-t33(i,j,k)
end do
end do
end do

!compute deviatoric part:
do k = 0,nzc
do j = 0,nyc
do i = 0,nxc
tii(i,j,k) = (t11(i,j,k)+t22(i,j,k)+t33(i,j,k))/3.0d0
end do
end do
end do

do k = 0,nzc
do j = 0,nyc
do i = 0,nxc
t11(i,j,k) = t11(i,j,k) - tii(i,j,k)
t22(i,j,k) = t22(i,j,k) - tii(i,j,k)
t33(i,j,k) = t33(i,j,k) - tii(i,j,k)
end do
end do
end do

deallocate(t11a,t12a,t13a,t22a,t23a,t33a,tii)
return
end

!-----------------------------------------------------------------------------------------!
!PDF Calculator (nx,ny,np,jcff,filename)
!-----------------------------------------------------------------------------------------!
subroutine pdf_calc(nx,ny,nz,np,f,filename)
implicit none
integer :: nx,ny,nz,np,i,j,k,n
character(80) :: filename
real*8,dimension(0:nx,0:ny,0:nz) :: f
real*8 :: mean,sd,s_ij_max,s_ij_min,sum1
real*8,allocatable :: sij(:),fsij(:),psij(:),pdf_sij(:)

!compute mean:
mean = 0.0d0
do k = 1,nz
do j = 1,ny
do i = 1,nx
mean = mean + f(i,j,k)
end do
end do
end do
mean = mean/dfloat(nx*ny*nz)

!standard deviation:
sd = 0.0d0
do k = 1,nz
do j = 1,ny
do i = 1,nx
sd = sd + (f(i,j,k)-mean)**2
end do
end do
end do
sd = sd/dfloat(nx*ny*nz)
sd = dsqrt(sd)

!PDF requirements
s_ij_max = + sd*4.0d0
s_ij_min = - sd*4.0d0

!s_ij_max = min(mean + sd*4.0d0, maxval(f))
!s_ij_min = max(mean - sd*4.0d0, minval(f))

allocate(fsij(0:np))
allocate(sij(1:np))

do n = 0,np
  fsij(n) = s_ij_min + (s_ij_max-s_ij_min)*dfloat(n)/dfloat(np)
end do

allocate(pdf_sij(1:np))
do n = 1,np
  pdf_sij(n) = 0.0d0
end do

do n = 1,np
  do k = 0,nz
	do j = 0,ny
  		do i = 0,nx
			if (f(i,j,k).lt.fsij(n).and.f(i,j,k).ge.fsij(n-1)) then
        	pdf_sij(n) = pdf_sij(n)+1.0d0
        	end if
    	end do
  	end do
  end do
  sij(n) = 0.5d0*(fsij(n)+fsij(n-1))
end do

sum1 = 0.0d0
do n = 1,np
  sum1 = sum1 + pdf_sij(n)*(fsij(n)-fsij(n-1))
end do

if (dabs(sum1).le.1.0d-10) sum1 = 1.0d-10

!normalize
allocate(psij(1:np))
do n = 1,np
  psij(n)=pdf_sij(n)/sum1
end do

! writing rhpdf:
open(unit=19, file=filename)
write(19,*) 'variables = "SGS", "PDF", "PDF_max"'
do n=1,np
write(19,*)sij(n),psij(n),psij(n)/maxval(psij)
end do
close(19)

return
end

!-----------------------------------------------------------------!
!Compute spectrum from by definition of Kida
!S Kida, Y. Murakami, et al. 1990
!-----------------------------------------------------------------!
subroutine spectrum3d(nx,ny,nz,u,v,w,filename)
implicit none
integer::nx,ny,nz
character(80) :: filename
real*8 ::u(0:nx,0:ny,0:nz),v(0:nx,0:ny,0:nz),w(0:nx,0:ny,0:nz)
integer::i,j,k,p,np
real*8 ::kx(0:nx),ky(0:ny),kz(0:nz)
real*8,dimension(:),allocatable:: data1d,data2d,data3d,ae
real*8,dimension(:,:,:),allocatable::ee
integer,parameter::ndim=3
integer::nn(ndim),isign
real*8 ::temp,kr

allocate(data1d(2*nx*ny*nz))
allocate(data2d(2*nx*ny*nz))
allocate(data3d(2*nx*ny*nz))

nn(1)= nx
nn(2)= ny
nn(3)= nz

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do

p=0
do k=0,nz/2
kz(k) = dfloat(p)
p=p+1
end do
p=-nz/2+1
do k=nz/2+1,nz-1
kz(k) = dfloat(p)
p=p+1
end do

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j,k)
data1d(p+1)=0.0d0
data2d(p)  =v(i,j,k)
data2d(p+1)=0.0d0
data3d(p)  =w(i,j,k)
data3d(p+1)=0.0d0
p=p+2
end do
end do
end do

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)
call fourn(data3d,nn,ndim,isign)

temp=1.0d0/dfloat(nx*ny*nz)

!normalize
do p=1,2*nx*ny*nz
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
data3d(p)=data3d(p)*temp
end do

!Energy density
allocate(ee(0:nx-1,0:ny-1,0:nz-1))

p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
ee(i,j,k)=0.5d0*(data1d(p)*data1d(p) + data1d(p+1)*data1d(p+1) &
                +data2d(p)*data2d(p) + data2d(p+1)*data2d(p+1) &
                +data3d(p)*data3d(p) + data3d(p+1)*data3d(p+1) )
p=p+2
end do
end do
end do

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2 + (kz(nz/2))**2))

allocate(ae(np))

!averaging!
do p=1,np
	ae(p)=0.0d0
    do k=0,nz-1
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k))
        if (kr.ge.(dfloat(p)-0.5d0).and.kr.lt.(dfloat(p)+0.5d0)) then
		ae(p)=ae(p)+ee(i,j,k)
		end if
	end do
    end do
    end do
end do

! Define the file name
open(unit=802, file=filename)
write(802,*)'variables ="k","E(k)"'
do p=1,np
write(802,*)dfloat(p),ae(p)
end do
close(802)

deallocate(data1d,data2d,ee,ae)

return
end

!-----------------------------------------------------------------!
! fft routine from numerical recipes
! ndim: dimension of the transform (i.e.; 2 for 2d problems)
! nn  : number of points in each direction
! data: one-dimensional array including real and imaginary part
!-----------------------------------------------------------------!
subroutine fourn(data,nn,ndim,isign)
implicit none
integer:: ndim,isign
integer:: nn(ndim)
real*8:: data(*)
real*8:: wr,wi,wpr,wpi,wtemp,theta,tempr,tempi
integer::ntot,n,nrem,nprev,idim,ip1,ip2,ip3,i1,i2,i3
integer::i2rev,i3rev,ibit,ifp1,ifp2,k1,k2

      ntot=1
      do 11 idim=1,ndim
        ntot=ntot*nn(idim)
11    continue
      nprev=1
      do 18 idim=1,ndim
        n=nn(idim)
        nrem=ntot/(n*nprev)
        ip1=2*nprev
        ip2=ip1*n
        ip3=ip2*nrem
        i2rev=1
        do 14 i2=1,ip2,ip1
          if(i2.lt.i2rev)then
            do 13 i1=i2,i2+ip1-2,2
              do 12 i3=i1,ip3,ip2
                i3rev=i2rev+i3-i2
                tempr=data(i3)
                tempi=data(i3+1)
                data(i3)=data(i3rev)
                data(i3+1)=data(i3rev+1)
                data(i3rev)=tempr
                data(i3rev+1)=tempi
12            continue
13          continue
          endif
          ibit=ip2/2
1         if ((ibit.ge.ip1).and.(i2rev.gt.ibit)) then
            i2rev=i2rev-ibit
            ibit=ibit/2
          go to 1
          endif
          i2rev=i2rev+ibit
14      continue
        ifp1=ip1
2       if(ifp1.lt.ip2)then
          ifp2=2*ifp1
          theta=isign*6.28318530717959d0/(ifp2/ip1)
          wpr=-2.d0*dsin(0.5d0*theta)**2
          wpi=dsin(theta)
          wr=1.d0
          wi=0.d0
          do 17 i3=1,ifp1,ip1
            do 16 i1=i3,i3+ip1-2,2
              do 15 i2=i1,ip3,ifp2
                k1=i2
                k2=k1+ifp1
                tempr=sngl(wr)*data(k2)-sngl(wi)*data(k2+1)
                tempi=sngl(wr)*data(k2+1)+sngl(wi)*data(k2)
                data(k2)=data(k1)-tempr
                data(k2+1)=data(k1+1)-tempi
                data(k1)=data(k1)+tempr
                data(k1+1)=data(k1+1)+tempi
15            continue
16          continue
            wtemp=wr
            wr=wr*wpr-wi*wpi+wr
            wi=wi*wpr+wtemp*wpi+wi
17        continue
          ifp1=ifp2
        go to 2
        endif
        nprev=n*nprev
18    continue

return
end

!------------------------------------------------------------------!
! compact interpolations for derivarives
!------------------------------------------------------------------!

!------------------------------------------------------------------!
! a second order scheme for first-degree derivative(up)
!------------------------------------------------------------------!
subroutine c2dp(u,up,h,n)
implicit none
integer :: n,i
double precision   :: h!,alpha,beta
double precision , dimension (0:n)  :: u,up
!double precision , dimension (0:n-1):: a,b,c,r,x

do i=1,n-1
up(i) = (u(i+1)-u(i-1))/(2.0d0*h)
end do
up(0) = (u(0+1)-u(n-1))/(2.0d0*h)
up(n) = (u(0+1)-u(n-1))/(2.0d0*h)

return
end

!------------------------------------------------------------------!
! c4dp:  4th-order compact scheme for first-degree derivative(up)
!        periodic boundary conditions (0=n), h=grid spacing
!        tested
!
!------------------------------------------------------------------!
subroutine c4dp(u,up,h,n)
implicit none
integer :: n,i
double precision   :: h,alpha,beta
double precision , dimension (0:n)  :: u,up
double precision , dimension (0:n-1):: a,b,c,r,x

do i=0,n-1
a(i) = 1.0d0/4.0d0
b(i) = 1.0d0
c(i) = 1.0d0/4.0d0
end do

do i=1,n-1
r(i) = 3.0d0/2.0d0*(u(i+1)-u(i-1))/(2.0d0*h)
end do
r(0) = 3.0d0/2.0d0*(u(1)-u(n-1))/(2.0d0*h)

alpha = 1.0d0/4.0d0
beta  = 1.0d0/4.0d0

call ctdms(a,b,c,alpha,beta,r,x,0,n-1)

do i=0,n-1
up(i)=x(i)
end do
up(n)=up(0)

return
end

!------------------------------------------------------------------!
! c6dp:  6th-order compact scheme for first-degree derivative(up)
!        periodic boundary conditions (0=n), h=grid spacing
!        tested
!------------------------------------------------------------------!
subroutine c6dp(u,up,h,n)
implicit none
integer :: n,i
double precision   :: h,alpha,beta
double precision , dimension (0:n)  :: u,up
double precision , dimension (0:n-1):: a,b,c,r,x

do i=0,n-1
a(i) = 1.0d0/3.0d0
b(i) = 1.0d0
c(i) = 1.0d0/3.0d0
end do

do i=2,n-2
r(i) = 14.0d0/9.0d0*(u(i+1)-u(i-1))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(i+2)-u(i-2))/(4.0d0*h)
end do
r(1) = 14.0d0/9.0d0*(u(2)-u(0))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(3)-u(n-1))/(4.0d0*h)

r(n-1) = 14.0d0/9.0d0*(u(n)-u(n-2))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(1)-u(n-3))/(4.0d0*h)

r(0) = 14.0d0/9.0d0*(u(1)-u(n-1))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(2)-u(n-2))/(4.0d0*h)

alpha = 1.0d0/3.0d0
beta  = 1.0d0/3.0d0

call ctdms(a,b,c,alpha,beta,r,x,0,n-1)

do i=0,n-1
up(i)=x(i)
end do
up(n)=up(0)

return
end

!------------------------------------------------------------------!
! a second order scheme for second-degree derivative(upp)
!------------------------------------------------------------------!
subroutine c2ddp(u,upp,h,n)
implicit none
integer :: n,i
double precision   :: h!,alpha,beta
double precision , dimension (0:n)  :: u,upp
!double precision , dimension (0:n-1):: a,b,c,r,x

do i=1,n-1
upp(i) = (u(i-1)-2.0d0*u(i)+u(i+1))/(h*h)
end do
upp(0) = (u(n-1)-2.0d0*u(0)+u(0+1))/(h*h)
upp(n) = (u(n-1)-2.0d0*u(n)+u(0+1))/(h*h)

return
end

!------------------------------------------------------------------!
! c4ddp: 4th-order compact scheme for second-degree derivative(upp)
!        periodic boundary conditions (0=n), h=grid spacing
!        tested
!------------------------------------------------------------------!
subroutine c4ddp(u,upp,h,n)
implicit none
integer :: n,i
double precision   :: h,alpha,beta
double precision , dimension (0:n)  :: u,upp
double precision , dimension (0:n-1):: a,b,c,r,x

do i=0,n-1
a(i) = 1.0d0/10.0d0
b(i) = 1.0d0
c(i) = 1.0d0/10.0d0
end do

do i=1,n-1
r(i) = 6.0d0/5.0d0*(u(i-1)-2.0d0*u(i)+u(i+1))/(h*h)
end do
r(0) = 6.0d0/5.0d0*(u(n-1)-2.0d0*u(0)+u(1))/(h*h)

alpha = 1.0d0/10.0d0
beta  = 1.0d0/10.0d0

call ctdms(a,b,c,alpha,beta,r,x,0,n-1)

do i=0,n-1
upp(i)=x(i)
end do
upp(n)=upp(0)

return
end

!------------------------------------------------------------------!
! c6ddp: 6th-order compact scheme for second-degree derivative(upp)
!        periodic boundary conditions (0=n), h=grid spacing
!        tested
!------------------------------------------------------------------!
subroutine c6ddp(u,upp,h,n)
implicit none
integer :: n,i
double precision   :: h,alpha,beta
double precision , dimension (0:n)  :: u,upp
double precision , dimension (0:n-1):: a,b,c,r,x

do i=0,n-1
a(i) = 2.0d0/11.0d0
b(i) = 1.0d0
c(i) = 2.0d0/11.0d0
end do

do i=2,n-2
r(i) = 12.0d0/11.0d0*(u(i-1)-2.0d0*u(i)+u(i+1))/(h*h) &
     + 3.0d0/11.0d0*(u(i-2)-2.0d0*u(i)+u(i+2))/(4.0d0*h*h)
end do
r(1) = 12.0d0/11.0d0*(u(0)-2.0d0*u(1)+u(2))/(h*h) &
     + 3.0d0/11.0d0*(u(n-1)-2.0d0*u(1)+u(3))/(4.0d0*h*h)

r(n-1) = 12.0d0/11.0d0*(u(n-2)-2.0d0*u(n-1)+u(n))/(h*h) &
     + 3.0d0/11.0d0*(u(n-3)-2.0d0*u(n-1)+u(1))/(4.0d0*h*h)

r(0) = 12.0d0/11.0d0*(u(n-1)-2.0d0*u(0)+u(1))/(h*h) &
     + 3.0d0/11.0d0*(u(n-2)-2.0d0*u(0)+u(2))/(4.0d0*h*h)

alpha = 2.0d0/11.0d0
beta  = 2.0d0/11.0d0

call ctdms(a,b,c,alpha,beta,r,x,0,n-1)

do i=0,n-1
upp(i)=x(i)
end do
upp(n)=upp(0)

return
end

!----------------------------------------------------!
! solution tridiagonal systems (regular tri-diagonal)
! a:subdiagonal, b: diagonal, c:superdiagonal
! r:rhs, u:results
! s: starting index
! e: ending index
!----------------------------------------------------!
subroutine tdms(a,b,c,r,u,s,e)
implicit none
integer::s,e
double precision ::a(s:e),b(s:e),c(s:e),r(s:e),u(s:e)
integer::j
double precision ::bet,gam(s:e)
bet=b(s)
u(s)=r(s)/bet
do j=s+1,e
gam(j)=c(j-1)/bet
bet=b(j)-a(j)*gam(j)
u(j)=(r(j)-a(j)*u(j-1))/bet
end do
do j=e-1,s,-1
u(j)=u(j)-gam(j+1)*u(j+1)
end do
return
end

!-------------------------------------------------------------------!
! solution of cyclic tridiagonal systems (periodic tridiagonal)
! n:matrix size (starting from 1)
! a:subdiagonal, b: diagonal, c:superdiagonal
! r:rhs, x:results
! alpha:sub entry (first value in e-th eq.)
! beta: super entry (last value in s-th eq.)
!-------------------------------------------------------------------!
subroutine ctdms(a,b,c,alpha,beta,r,x,s,e)
implicit none
integer:: s,e
double precision :: alpha,beta,a(s:e),b(s:e),c(s:e),r(s:e),x(s:e)
integer:: i
double precision :: fact,gamma,bb(s:e),u(s:e),z(s:e)
if((e-s).le.2) then
write(*,*) ' matrix too small in cyclic'
stop
end if
gamma=-b(s)
bb(s)=b(s)-gamma
bb(e)=b(e)-alpha*beta/gamma
do i=s+1,e-1
bb(i)=b(i)
end do
call tdms(a,bb,c,r,x,s,e)
u(s)=gamma
u(e)=alpha
do i=s+1,e-1
u(i)=0.0d0
end do
call tdms(a,bb,c,u,z,s,e)
fact=(x(s)+beta*x(e)/gamma)/(1.0d0+z(s)+beta*z(e)/gamma)
do i=s,e
x(i)=x(i)-fact*z(i)
end do
return
end


! -----------------------------------------------------------------------------
!
! Copyright (c) 2017 Sam Cox, Roberto Sommariva
!
! This file is part of the AtChem2 software package.
!
! This file is covered by the MIT license which can be found in the file
! LICENSE.md at the top level of the AtChem2 distribution.
!
! -----------------------------------------------------------------------------

module solar_test
  use fruit
  use types_mod
  use solar_functions_mod
  implicit none

contains

  subroutine test_calcTheta
    use date_mod, only : currentYear, currentDayOfYear
    real(kind=DP) :: theta, pi, threshold

    threshold = 1.0e-8_DP
    pi = 4.0_DP * atan( 1.0_DP )

    currentYear = 2000_DI
    currentDayOfYear = 0_DI
    theta = calcTheta()
    call assert_true( theta == 0.0_DP, "calcTheta(), first day of 2000" )
    currentDayOfYear = 365_DI
    theta = calcTheta()
    call assert_true( theta == 2.0_DP*pi*365_DI/366_DI, "calcTheta(), last day of 2000" )

    currentYear = 2001_DI
    currentDayOfYear = 0_DI
    theta = calcTheta()
    call assert_true( theta == 0.0_DP, "calcTheta(), first day of 2001" )
    currentDayOfYear = 364_DI
    theta = calcTheta()
    call assert_true( abs(theta - 2.0_DP*pi*364_DI/365_DI) <= threshold, "calcTheta(), last day of 2001" )

    currentYear = 2004_DI
    currentDayOfYear = 0_DI
    theta = calcTheta()
    call assert_true( theta == 0.0_DP, "calcTheta(), first day of 2004" )
    currentDayOfYear = 365_DI
    theta = calcTheta()
    call assert_true( theta == 2.0_DP*pi*365_DI/366_DI, "calcTheta(), last day of 2004" )
  end subroutine test_calcTheta

  subroutine test_decFromTheta
    real(kind=DP) :: dec, pi, theta

    pi = 4.0_DP * atan( 1.0_DP )

    theta = 0.0_DP
    dec = decFromTheta( theta )
    call assert_true( dec == -0.402449_DP, "decFromTheta( theta ), theta = 0" )

    theta = pi
    dec = decFromTheta( theta )
    call assert_true( dec == 0.40276899999999999_DP, "decFromTheta( theta ), theta = pi" )

    theta = pi/2.0_DP
    dec = decFromTheta( theta )
    call assert_true( dec == 8.2452999999999985E-002_DP, "decFromTheta( theta ), theta = pi/2" )

    theta = pi*3.0_DP/2.0_DP
    dec = decFromTheta( theta )
    call assert_true( dec == -5.5100999999999921E-002_DP, "decFromTheta( theta ), theta = 3pi/2" )
  end subroutine test_decFromTheta

  subroutine test_calcDec
    use types_mod
    use date_mod, only : currentYear, currentDayOfYear
    real(kind=DP) :: dec0, dec364over365, dec365over366, threshold

    threshold = 1.0e-6_DP
    dec0 = 0.006918_DP - 0.399912_DP - 0.006758_DP - 0.002697_DP
    dec364over365 = -0.40369912461219781
    dec365over366 = -0.40369589165596537

    currentYear = 2000_DI
    currentDayOfYear = 0_DI
    call assert_true( calcDec() == dec0, "calcDec(), first day of 2000" )
    currentDayOfYear = 365_DI
    call assert_true( abs( calcDec() - dec365over366 ) < threshold, "calcDec(), last day of 2000" )

    currentYear = 2001_DI
    currentDayOfYear = 0_DI
    call assert_true( calcDec() == dec0, "calcDec(), first day of 2001" )
    currentDayOfYear = 364_DI
    call assert_true( abs( calcDec() - dec364over365 ) < threshold, "calcDec(), last day of 2001" )

    currentYear = 2004_DI
    currentDayOfYear = 0_DI
    call assert_true( calcDec() == dec0, "calcDec(), first day of 2004" )
    currentDayOfYear = 365_DI
    call assert_true( abs( calcDec() - dec365over366 ) < threshold, "calcDec(), last day of 2004" )
  end subroutine test_calcDec

  subroutine test_calcEQT
    use types_mod
    use date_mod, only : currentYear, currentDayOfYear
    real(kind=DP) :: eqt0, threshold

    threshold = 1.0e-8_DP
    eqt0 = 0.000075_DP + 0.001868_DP - 0.014615_DP

    currentYear = 2000_DI
    currentDayOfYear = 0_DI
    call assert_true( abs( calcEQT() - eqt0 ) < threshold, "calcEQT(), first day of 2000" )
    currentDayOfYear = 365_DI
    call assert_true( abs( calcEQT() + 1.0710769160677822E-002 ) < threshold, "calcEQT(), last day of 2000" )

    currentYear = 2001_DI
    currentDayOfYear = 0_DI
    call assert_true( abs( calcEQT() - eqt0 ) < threshold, "calcEQT(), first day of 2001" )
    currentDayOfYear = 364_DI
    call assert_true( abs( calcEQT() + 1.0705374687579837E-002 ) < threshold, "calcEQT(), last day of 2001" )

    currentYear = 2004_DI
    currentDayOfYear = 0_DI
    call assert_true( abs( calcEQT() - eqt0 ) < threshold, "calcEQT(), first day of 2004" )
    currentDayOfYear = 365_DI
    call assert_true( abs( calcEQT() + 1.0710769160677822E-002 ) < threshold, "calcEQT(), last day of 2004" )
  end subroutine test_calcEQT

  ! TODO:  subroutine test_calcZenith

end module solar_test


module randomness
	use constants, only : dbl, bigint
#ifdef __INTEL_COMPILER
        use ifport
#endif
	implicit none
contains
	function random_int(minv, maxv)
		integer(bigint), intent(in) :: minv
		integer(bigint), intent(in) :: maxv
		integer(bigint)		:: random_int
		real(dbl)			:: rn, scale

		rn     = rand()
		scale  = maxv-minv
		random_int = minv + floor(rn*scale)
	end function random_int

	subroutine n_random_ints(n, minv, maxv, res)
		integer(bigint), intent(in)							:: n, minv, maxv
		integer(bigint), dimension(n), intent(out) 	:: res

		real(dbl)	:: rn, scale
		integer(bigint)		:: ix
		scale = maxv - minv
		do ix=1, n
			rn = rand()
			res(ix) = minv + floor(rn*scale)
		end do
	end subroutine n_random_ints

	subroutine n_random_ints_weighted(n, nvals, plusminus, weights, res)
		integer(bigint), intent(in)					:: n, nvals
		integer(bigint), dimension(2), intent(in)	:: plusminus
		real(dbl), dimension(nvals), intent(inout)	:: weights
		integer(bigint), dimension(n), intent(out) 	:: res

		integer(bigint), dimension(:), allocatable	:: expanded_ints
		integer(bigint)								:: mults(nvals), posres(n), negres(n)
		integer(bigint)								:: ix, nt, ctr, pmmin, unity
		real(dbl)									:: mv

		pmmin = min(plusminus(1), plusminus(2))
		unity = 1

		! Prob distribution for adding occupations
		mv = minval(weights)
		if (mv .eq. 0) mv = 0.01d0
		weights = log10(weights / mv)
		do ix=1,nvals
			weights(ix) = max(weights(ix), 0d0)
		end do
		mults = ceiling(weights)+1
		nt = sum(mults)
		allocate(expanded_ints(nt))
		ctr = 1
		do ix=1,nvals
			expanded_ints(ctr:ctr+mults(ix)-1) = ix
			ctr = ctr + mults(ix)
		end do
		call n_random_ints(plusminus(1), unity, nt+1, posres)
		do ix=1,pmmin
			res(2*ix-1) = expanded_ints(posres(ix))
		end do
		if (pmmin .eq. plusminus(2)) res(2*pmmin+1:) = [(expanded_ints(posres(ix)), ix=pmmin+1,plusminus(1))]

		! Prob distribution for lowering occupations
		mults = maxval(mults) - mults + 1
		nt = sum(mults)
		deallocate(expanded_ints)
		allocate(expanded_ints(nt))
		ctr = 1
		do ix=1,nvals
			expanded_ints(ctr:ctr+mults(ix)-1) = ix
			ctr = ctr + mults(ix)
		end do
		call n_random_ints(plusminus(2), unity, nt+1, negres)
		do ix=1,pmmin
			res(2*ix) = expanded_ints(negres(ix))
		end do
		if (pmmin .eq. plusminus(1)) res(2*pmmin+1:) = [(expanded_ints(negres(ix)), ix=pmmin+1,plusminus(2))]

		deallocate(expanded_ints)
	end subroutine n_random_ints_weighted
end module randomness


module Climate

   use Constants
   use Random

   implicit none

   real                              :: accumulated_tmin, accumulated_tmax
   real, dimension(12)               :: accumulated_precip

contains

   subroutine set_site_climate(same_climate,fixed_seed)
      logical :: same_climate,fixed_seed

      call set_climate_rng_seed(same_climate,fixed_seed)

      accumulated_tmin=0.0
      accumulated_tmax=0.0
      accumulated_precip=0.0

   end subroutine set_site_climate

   !cbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
   !c
   !c	cov365: convert monthly state data into daily data
   !c	by Yan Xiaodong 1996 Ver 1.0
   !c
   !c----------------------------------------------------------------------
   subroutine cov365(ta1,vta)
      real, dimension(:), intent(in)    :: ta1
      real, dimension(:), intent(inout) :: vta

      real, dimension(13)               :: ta
      real, dimension(381)              :: vt
      real                              :: tyxd
      integer :: ltmt(13), k, md
      data ltmt/16,45,75,105,136,166,196,227,258,288,319,349,381/

      ta(13)=ta1(1)
      do k=1,12
         ta(k)=ta1(k)
      end do
      do k=1,12
         tyxd=(ta(k+1)-ta(k))/float(ltmt(k+1)-  ltmt(k))
         do md=ltmt(k),ltmt(k+1)
            vt(md)=ta(k)+tyxd*float(md- ltmt(k))
         end do
      end do
      do md=16,365
         vta(md)=vt(md)
      end do
      do md=1,15
         vta(md)=vt(365+md)
      end do
      return
   end subroutine cov365

   !cbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
   !c
   !c	cov365a: convert monthly integreted data into daily data randomly
   !c	by Yan Xiaodong 1996 Ver 1.0
   !c	number of rain days is function of rainfall amount(cm)
   !c	basic feature is: 100cm rain......25 days
   !c					  	1cm rain......1 day
   !c
   !c-----------------------------------------------------------------------
   subroutine cov365a(ta,vta)
      real, dimension(:), intent(in)    :: ta
      real, dimension(:), intent(inout) :: vta

      real    :: raindays, rr, ss, yxdr
      integer :: ltmt(12), md,i, k, ik, inum
      data ltmt/31,28,31,30,31,30,31,31,30,31,30,31/
      md=0
      do k=1,12
         raindays=min1(25.0,ta(k)/4.0+1.0)
         ik=int(raindays)
         rr=ta(k)/float(ik)
         ss=raindays/ltmt(k)
         inum=ik
         do i=1, ltmt(k)
            md=md+1
            if (inum.gt.0) then
               ! old function
               !yxdr=uniform()
               yxdr=clim_urand()
               if(yxdr.le.ss) then
                  vta(md)=rr
                  inum=inum-1
               else
                  vta(md)=0.0
               end if
            else
               vta(md)=0.0
            end if
         end do
         if (inum.gt.0) then
            vta(md-15)=float(inum)*rr
         end if
      end do
      return
   end subroutine cov365a

   !<----------------------------------------------------------------------------->
   !
   !		ex_rad: Extraterrestial Radiation
   !		By Yan Xiaodong  1996 version 1.0
   !		Input variables:	julia:	Julian Days Number
   !					latit: 	Latitude (South: "-") degree o
   !		Output variables:	erad: 	daily radiation (mj/m2/day)
   !					daylength: light dady length (hours)
   !					exradmx:noon radiation (mj/m2/min)
   !
   !<----------------------------------------------------------------------------->
   subroutine ex_rad(julia,latit,erad,daylength,exradmx)
      integer,  intent(in) :: julia
      real,     intent(in) :: latit
      real,     intent(out):: erad,daylength,exradmx

      real    :: yxd,rlat,dr,dairta,omega
      !
      !dr=1+0.033cos(2PAI/365*julia)
      !dairta=0.409sin(2PAI/365*julia-1.39)
      !omega=arccos(-tan(latit)*tan(dairta))
      !erad=Gsc*dr*24*60/PAI*cos(latit)*cos(dairta)*(sin(omega)-omega*cos(omega))
      !Gsc=0.0820 (mj/m2/min)

      rlat=deg2rad*latit

      dr=1.0+Ac*cos(b*float(julia))
      dairta=As*sin(b*float(julia)+phase)
      yxd=-tan(rlat)*tan(dairta)

      if (yxd .ge. 1.0) then
         omega=0.0
      else if (yxd .le. -1.0) then
         omega= pi
      else
         omega=acos(yxd)
      end if

      erad=Amp*cos(rlat)*cos(dairta)*(sin(omega)-omega*cos(omega))
      daylength=dl_omega*omega
      exradmx=exrad_coef*dr*cos(rlat-dairta)

      return

   end subroutine ex_rad

   !<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++>

   !<----------------------------------------------------------------------------->
   !
   !  Hargreaves Evaporation formulation
   !  by Yan Xiaodong 1996 version 1.0
   !  hargrea(tmin,tmax,exrad): function output (cm/day)
   !  tmin: minimum temperature degree oC
   !  tmax: maximum temperature degree oC
   !  exrad: extraterrestrial rediation (mj/m2/day)
   !  hargrea= 0.00023/2.45*(tmax-tmin)^0.5*(tmean+17.8)*exrad
   !         = 0.000093876*(tmax-tmin)^0.5*(tmean+17.8)*exrad
   !  I think we can model the potential evaporation more exactly by factoring air
   !  humidity (%):
   !               100%     *1/10
   !	              90%     *3/10
   !                80%	    *5/10
   !                70%     *7/10
   !                60%	    *8/10
   !                50%     *9/10
   !                40%     *10/10
   !                30%     *11/10
   !                20%     *12/10
   !                10%     *13/10
   !                 0%     *13/10
   !<----------------------------------------------------------------------------->
   function hargrea(tmin,tmax,ta,exrad)
      real              :: hargrea
      real, intent(in)  :: tmin, tmax, ta, exrad

      if (ta .le. 0.0) then
         hargrea=0.0
      else
         hargrea= H_coeff*(tmax - tmin)**0.5 * (ta + H_addon ) * exrad
      end if

   end function hargrea

end module Climate


program ch0515
    ! Initialisation of Physical Constants, Version 1
    implicit none

    real, parameter ::  atomic_mass_constant = &
        1.660538921*10.**(-27)
    real, parameter :: avogadro_constant = &
        6.02214129*10.**23
    real, parameter :: boltzmann_constant = &
        1.3806488*10.**(-23)
    real, parameter :: electron_mass = &
        9.10938291*10.**(-31)
    real, parameter :: elementary_charge = &
        1.602176565*10.**(-19)
    real, parameter :: proton_mass = &
        1.672621777*10.**(-27)
    real, parameter :: speed_of_light_in_vacuum = &
        299792458.
    real, parameter :: newtonian_constant_of_gravitation = &
        6.67384*10.**(-11)

    print *, atomic_mass_constant
    print *, avogadro_constant
    print *, boltzmann_constant
    print *, electron_mass
    print *, elementary_charge
    print *, proton_mass
    print *, speed_of_light_in_vacuum
    print *, newtonian_constant_of_gravitation
end program