      SUBROUTINE SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, F, LDF, H, LDH, TU, LDTU, TY,
     $                   LDTY, X, LDX, Y, LDY, AK, LDAK, BK, LDBK, CK,
     $                   LDCK, DK, LDDK, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrices of an H-infinity (sub)optimal controller
C
C              | AK | BK |
C          K = |----|----|,
C              | CK | DK |
C
C     from the state feedback matrix F and output injection matrix H as
C     determined by the SLICOT Library routine SB10QD.
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     GAMMA   (input) DOUBLE PRECISION
C             The value of gamma. It is assumed that gamma is
C             sufficiently large so that the controller is admissible.
C             GAMMA >= 0.
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.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     F       (input) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading M-by-N part of this array must contain the
C             state feedback matrix F.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= max(1,M).
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,NP)
C             The leading N-by-NP part of this array must contain the
C             output injection matrix H.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     TU      (input) DOUBLE PRECISION array, dimension (LDTU,M2)
C             The leading M2-by-M2 part of this array must contain the
C             control transformation matrix TU, as obtained by the
C             SLICOT Library routine SB10PD.
C
C     LDTU    INTEGER
C             The leading dimension of the array TU.  LDTU >= max(1,M2).
C
C     TY      (input) DOUBLE PRECISION array, dimension (LDTY,NP2)
C             The leading NP2-by-NP2 part of this array must contain the
C             measurement transformation matrix TY, as obtained by the
C             SLICOT Library routine SB10PD.
C
C     LDTY    INTEGER
C             The leading dimension of the array TY.
C             LDTY >= max(1,NP2).
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array must contain the
C             matrix X, solution of the X-Riccati equation, as obtained
C             by the SLICOT Library routine SB10QD.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     Y       (input) DOUBLE PRECISION array, dimension (LDY,N)
C             The leading N-by-N part of this array must contain the
C             matrix Y, solution of the Y-Riccati equation, as obtained
C             by the SLICOT Library routine SB10QD.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= max(1,N).
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     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK), where
C             LIWORK = max(2*(max(NP,M)-M2-NP2,M2,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, M2*NP2 + NP2*NP2 + M2*M2 +
C                           max(D1*D1 + max(2*D1, (D1+D2)*NP2),
C                               D2*D2 + max(2*D2, D2*M2), 3*N,
C                               N*(2*NP2 + M2) +
C                               max(2*N*M2, M2*NP2 +
C                                           max(M2*M2+3*M2, NP2*(2*NP2+
C                                                  M2+max(NP2,N))))))
C             where D1 = NP1 - M2, D2 = M1 - NP2,
C                  NP1 = NP - NP2, M1 = M - M2.
C             For good performance, LDWORK must generally be larger.
C             Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
C             max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, 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 controller is not admissible (too small value
C                   of gamma);
C             = 2:  if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero.
C
C     METHOD
C
C     The routine implements the Glover's and Doyle's formulas [1],[2].
C
C     REFERENCES
C
C     [1] Glover, K. and Doyle, J.C.
C         State-space formulae for all stabilizing controllers that
C         satisfy an Hinf norm bound and relations to risk sensitivity.
C         Systems and Control Letters, vol. 11, pp. 167-172, 1988.
C
C     [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
C         Smith, R.
C         mu-Analysis and Synthesis Toolbox.
C         The MathWorks Inc., Natick, Mass., 1995.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of the result depends on the condition numbers of the
C     input and output transformations.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 1999,
C     Sept. 1999, Oct. 2001.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, H-infinity optimal control, robust
C     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, LDF, LDH, LDTU, LDTY, LDWORK, LDX, LDY,
     $                   M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   GAMMA
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( * ),
     $                   F( LDF, * ), H( LDH, * ), TU( LDTU, * ),
     $                   TY( LDTY, * ), X( LDX, * ), Y( LDY, * )
C     ..
C     .. Local Scalars ..
      INTEGER            I, ID11, ID12, ID21, IJ, INFO2, IW1, IW2, IW3,
     $                   IW4, IWB, IWC, IWRK, J, LWAMAX, M1, M2, MINWRK,
     $                   ND1, ND2, NP1, NP2
      DOUBLE PRECISION   ANORM, EPS, RCOND
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANSY
      EXTERNAL           DLAMCH, DLANGE, DLANSY
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGECON, DGEMM, DGETRF, DGETRI, DGETRS, DLACPY,
     $                   DLASET, DPOTRF, DSYCON, DSYRK, DSYTRF, DSYTRS,
     $                   DTRMM, MA02AD, MB01RX, 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( GAMMA.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -12
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -14
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -16
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -18
      ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN
         INFO = -20
      ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN
         INFO = -22
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -24
      ELSE IF( LDY.LT.MAX( 1, N ) ) THEN
         INFO = -26
      ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN
         INFO = -28
      ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN
         INFO = -30
      ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN
         INFO = -32
      ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN
         INFO = -34
      ELSE
C
C        Compute workspace.
C
         ND1 = NP1 - M2
         ND2 = M1 - NP2
         MINWRK = MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 +
     $                 MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ),
     $                      ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N,
     $                      N*( 2*NP2 + M2 ) +
     $                         MAX( 2*N*M2, M2*NP2 +
     $                                MAX( M2*M2 + 3*M2, NP2*( 2*NP2 +
     $                                     M2 + MAX( NP2, N ) ) ) ) ) )
         IF( LDWORK.LT.MINWRK )
     $      INFO = -37
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10RD', -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
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Get the machine precision.
C
      EPS = DLAMCH( 'Epsilon' )
C
C     Workspace usage.
C
      ID11 = 1
      ID21 = ID11 + M2*NP2
      ID12 = ID21 + NP2*NP2
      IW1  = ID12 + M2*M2
      IW2  = IW1  + ND1*ND1
      IW3  = IW2  + ND1*NP2
      IWRK = IW2
C
C     Set D11HAT := -D1122 .
C
      IJ = ID11
      DO 20 J = 1, NP2
         DO 10 I = 1, M2
            DWORK( IJ ) = -D( ND1+I, ND2+J )
            IJ = IJ + 1
   10    CONTINUE
   20 CONTINUE
C
C     Set D21HAT := Inp2 .
C
      CALL DLASET( 'Upper', NP2, NP2, ZERO, ONE, DWORK( ID21 ), NP2 )
C
C     Set D12HAT := Im2 .
C
      CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( ID12 ), M2 )
C
C     Compute D11HAT, D21HAT, D12HAT .
C
      LWAMAX = 0
      IF( ND1.GT.0 ) THEN
         IF( ND2.EQ.0 ) THEN
C
C           Compute D21HAT'*D21HAT = Inp2 - D1112'*D1112/gamma^2 .
C
            CALL DSYRK( 'U', 'T', NP2, ND1, -ONE/GAMMA**2, D, LDD, ONE,
     $                  DWORK( ID21 ), NP2 )
         ELSE
C
C           Compute gdum = gamma^2*Ind1 - D1111*D1111' .
C
            CALL DLASET( 'U', ND1, ND1, ZERO, GAMMA**2, DWORK( IW1 ),
     $                   ND1 )
            CALL DSYRK( 'U', 'N', ND1, ND2, -ONE, D, LDD, ONE,
     $                  DWORK( IW1 ), ND1 )
            ANORM = DLANSY( 'I', 'U', ND1, DWORK( IW1 ), ND1,
     $                      DWORK( IWRK ) )
            CALL DSYTRF( 'U', ND1, DWORK( IW1 ), ND1, IWORK,
     $                   DWORK( IWRK ), LDWORK-IWRK+1, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 1
               RETURN
            END IF
            LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1
            CALL DSYCON( 'U', ND1, DWORK( IW1 ), ND1, IWORK, ANORM,
     $                   RCOND, DWORK( IWRK ), IWORK( ND1+1 ), INFO2 )
C
C           Return if the matrix is singular to working precision.
C
            IF( RCOND.LT.EPS ) THEN
               INFO = 1
               RETURN
            END IF
C
C           Compute inv(gdum)*D1112 .
C
            CALL DLACPY( 'Full', ND1, NP2, D( 1, ND2+1 ), LDD,
     $                   DWORK( IW2 ), ND1 )
            CALL DSYTRS( 'U', ND1, NP2, DWORK( IW1 ), ND1, IWORK,
     $                   DWORK( IW2 ), ND1, INFO2 )
C
C           Compute D11HAT = -D1121*D1111'*inv(gdum)*D1112 - D1122 .
C
            CALL DGEMM( 'T', 'N', ND2, NP2, ND1, ONE, D, LDD,
     $                  DWORK( IW2 ), ND1, ZERO, DWORK( IW3 ), ND2 )
            CALL DGEMM( 'N', 'N', M2, NP2, ND2, -ONE, D( ND1+1, 1 ),
     $                  LDD, DWORK( IW3 ), ND2, ONE, DWORK( ID11 ), M2 )
C
C           Compute D21HAT'*D21HAT = Inp2 - D1112'*inv(gdum)*D1112 .
C
            CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, ND1, ONE,
     $                   -ONE, DWORK( ID21 ), NP2, D( 1, ND2+1 ), LDD,
     $                   DWORK( IW2 ), ND1, INFO2 )
C
            IW2  = IW1 + ND2*ND2
            IWRK = IW2
C
C           Compute gdum = gamma^2*Ind2 - D1111'*D1111 .
C
            CALL DLASET( 'L', ND2, ND2, ZERO, GAMMA**2, DWORK( IW1 ),
     $                   ND2 )
            CALL DSYRK( 'L', 'T', ND2, ND1, -ONE, D, LDD, ONE,
     $                  DWORK( IW1 ), ND2 )
            ANORM = DLANSY( 'I', 'L', ND2, DWORK( IW1 ), ND2,
     $                      DWORK( IWRK ) )
            CALL DSYTRF( 'L', ND2, DWORK( IW1 ), ND2, IWORK,
     $                   DWORK( IWRK ), LDWORK-IWRK+1, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 1
               RETURN
            END IF
            LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
            CALL DSYCON( 'L', ND2, DWORK( IW1 ), ND2, IWORK, ANORM,
     $                   RCOND, DWORK( IWRK ), IWORK( ND2+1 ), INFO2 )
C
C           Return if the matrix is singular to working precision.
C
            IF( RCOND.LT.EPS ) THEN
               INFO = 1
               RETURN
            END IF
C
C           Compute inv(gdum)*D1121' .
C
            CALL MA02AD( 'Full', M2, ND2, D( ND1+1, 1 ), LDD,
     $                   DWORK( IW2 ), ND2 )
            CALL DSYTRS( 'L', ND2, M2, DWORK( IW1 ), ND2, IWORK,
     $                   DWORK( IW2 ), ND2, INFO2 )
C
C           Compute D12HAT*D12HAT' = Im2 - D1121*inv(gdum)*D1121' .
C
            CALL MB01RX( 'Left', 'Lower', 'NoTranspose', M2, ND2, ONE,
     $                   -ONE, DWORK( ID12 ), M2, D( ND1+1, 1 ), LDD,
     $                   DWORK( IW2 ), ND2, INFO2 )
         END IF
      ELSE
         IF( ND2.GT.0 ) THEN
C
C           Compute D12HAT*D12HAT' = Im2 - D1121*D1121'/gamma^2 .
C
            CALL DSYRK( 'L', 'N', M2, ND2, -ONE/GAMMA**2, D, LDD, ONE,
     $                  DWORK( ID12 ), M2 )
         END IF
      END IF
C
C     Compute D21HAT using Cholesky decomposition.
C
      CALL DPOTRF( 'U', NP2, DWORK( ID21 ), NP2, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
C     Compute D12HAT using Cholesky decomposition.
C
      CALL DPOTRF( 'L', M2, DWORK( ID12 ), M2, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
C             _
C     Compute Z = In - Y*X/gamma^2 and its LU factorization in AK .
C
      IWRK = IW1
      CALL DLASET( 'Full', N, N, ZERO, ONE, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, N, -ONE/GAMMA**2, Y, LDY, X, LDX,
     $            ONE, AK, LDAK )
      ANORM = DLANGE( '1', N, N, AK, LDAK, DWORK( IWRK ) )
      CALL DGETRF( N, N, AK, LDAK, IWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
      CALL DGECON( '1', N, AK, LDAK, ANORM, RCOND, DWORK( IWRK ),
     $             IWORK( N+1 ), INFO )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND.LT.EPS ) THEN
         INFO = 1
         RETURN
      END IF
C
      IWB = IW1
      IWC = IWB + N*NP2
      IW1 = IWC + ( M2 + NP2 )*N
      IW2 = IW1 + N*M2
C
C     Compute C2' + F12' in BK .
C
      DO 40 J = 1, N
         DO 30 I = 1, NP2
            BK( J, I ) = C( NP1 + I, J ) + F( ND2 + I, J )
   30    CONTINUE
   40 CONTINUE
C                                                          _
C     Compute the transpose of (C2 + F12)*Z , with Z = inv(Z) .
C
      CALL DGETRS( 'Transpose', N, NP2, AK, LDAK, IWORK, BK, LDBK,
     $             INFO2 )
C
C     Compute the transpose of F2*Z .
C
      CALL MA02AD( 'Full', M2, N, F( M1+1, 1 ), LDF, DWORK( IW1 ), N )
      CALL DGETRS( 'Transpose', N, M2, AK, LDAK, IWORK, DWORK( IW1 ), N,
     $             INFO2 )
C
C     Compute the transpose of C1HAT = F2*Z - D11HAT*(C2 + F12)*Z .
C
      CALL DGEMM( 'N', 'T', N, M2, NP2, -ONE, BK, LDBK, DWORK( ID11 ),
     $            M2, ONE, DWORK( IW1 ), N )
C
C     Compute CHAT .
C
      CALL DGEMM( 'N', 'T', M2, N, M2, ONE, TU, LDTU, DWORK( IW1 ), N,
     $            ZERO, DWORK( IWC ), M2+NP2 )
      CALL MA02AD( 'Full', N, NP2, BK, LDBK, DWORK( IWC+M2 ), M2+NP2 )
      CALL DTRMM( 'L', 'U', 'N', 'N', NP2, N, -ONE, DWORK( ID21 ), NP2,
     $            DWORK( IWC+M2 ), M2+NP2 )
C
C     Compute B2 + H12 .
C
      IJ = IW2
      DO 60 J = 1, M2
         DO 50 I = 1, N
            DWORK( IJ ) = B( I, M1 + J ) + H( I, ND1 + J )
            IJ = IJ + 1
   50    CONTINUE
   60 CONTINUE
C
C     Compute A + HC in AK .
C
      CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, NP, ONE, H, LDH, C, LDC, ONE, AK,
     $            LDAK )
C
C     Compute AHAT = A + HC + (B2 + H12)*C1HAT in AK .
C
      CALL DGEMM( 'N', 'T', N, N, M2, ONE, DWORK( IW2 ), N,
     $            DWORK( IW1 ), N, ONE, AK, LDAK )
C
C     Compute B1HAT = -H2 + (B2 + H12)*D11HAT in BK .
C
      CALL DLACPY( 'Full', N, NP2, H( 1, NP1+1 ), LDH, BK, LDBK )
      CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, DWORK( IW2 ), N,
     $            DWORK( ID11 ), M2, -ONE, BK, LDBK )
C
C     Compute the first block of BHAT, BHAT1 .
C
      CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO,
     $            DWORK( IWB ), N )
C
C     Compute Tu*D11HAT .
C
      CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DWORK( ID11 ),
     $            M2, ZERO, DWORK( IW1 ), M2 )
C
C     Compute Tu*D11HAT*Ty in DK .
C
      CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK( IW1 ), M2, TY,
     $            LDTY, ZERO, DK, LDDK )
C
C     Compute P = Im2 + Tu*D11HAT*Ty*D22 and its condition.
C
      IW2  = IW1 + M2*NP2
      IWRK = IW2 + M2*M2
      CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 )
      CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK,
     $            D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 )
      ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) )
      CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
      CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND,
     $             DWORK( IWRK ), IWORK( M2+1 ), INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND.LT.EPS ) THEN
         INFO = 2
         RETURN
      END IF
C
C     Find the controller matrix CK, CK = inv(P)*CHAT(1:M2,:) .
C
      CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK )
      CALL DGETRS( 'NoTranspose', M2, N, DWORK( IW2 ), M2, IWORK, CK,
     $             LDCK, INFO2 )
C
C     Find the controller matrices AK, BK, and DK, exploiting the
C     special structure of the relations.
C
C     Compute Q = Inp2 + D22*Tu*D11HAT*Ty and its LU factorization.
C
      IW3  = IW2 + NP2*NP2
      IW4  = IW3 + NP2*M2
      IWRK = IW4 + NP2*NP2
      CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 )
      CALL DGEMM( 'N', 'N', NP2, NP2, M2, ONE, D( NP1+1, M1+1 ), LDD,
     $            DK, LDDK, ONE, DWORK( IW2 ), NP2 )
      CALL DGETRF( NP2, NP2, DWORK( IW2 ), NP2, IWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
C
C     Compute A1 = inv(Q)*D22 and inv(Q) .
C
      CALL DLACPY( 'Full', NP2, M2, D( NP1+1, M1+1 ), LDD, DWORK( IW3 ),
     $             NP2 )
      CALL DGETRS( 'NoTranspose', NP2, M2, DWORK( IW2 ), NP2, IWORK,
     $             DWORK( IW3 ), NP2, INFO2 )
      CALL DGETRI( NP2, DWORK( IW2 ), NP2, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Compute A2 = ( inv(Ty) - inv(Q)*inv(Ty) -
C                    A1*Tu*D11HAT )*inv(D21HAT) .
C
      CALL DLACPY( 'Full', NP2, NP2, TY, LDTY, DWORK( IW4 ), NP2 )
      CALL DGETRF( NP2, NP2, DWORK( IW4 ), NP2, IWORK, INFO2 )
      CALL DGETRI( NP2, DWORK( IW4 ), NP2, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
C
      CALL DLACPY( 'Full', NP2, NP2, DWORK( IW4 ), NP2, DWORK( IWRK ),
     $             NP2 )
      CALL DGEMM( 'N', 'N', NP2, NP2, NP2, -ONE, DWORK( IW2), NP2,
     $            DWORK( IWRK ), NP2, ONE, DWORK( IW4 ), NP2 )
      CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, DWORK( IW3), NP2,
     $            DWORK( IW1 ), M2, ONE, DWORK( IW4 ), NP2 )
      CALL DTRMM( 'R', 'U', 'N', 'N', NP2, NP2, ONE, DWORK( ID21 ), NP2,
     $            DWORK( IW4 ), NP2 )
C
C     Compute [ A1  A2 ]*CHAT .
C
      CALL DGEMM( 'N', 'N', NP2, N, M2+NP2, ONE, DWORK( IW3 ), NP2,
     $            DWORK( IWC ), M2+NP2, ZERO, DWORK( IWRK ), NP2 )
C
C     Compute AK := AHAT - BHAT1*[ A1  A2 ]*CHAT .
C
      CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, DWORK( IWB ), N,
     $            DWORK( IWRK ), NP2, ONE, AK, LDAK )
C
C     Compute BK := BHAT1*inv(Q) .
C
      CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, DWORK( IWB ), N,
     $            DWORK( IW2 ), NP2, ZERO, BK, LDBK )
C
C     Compute DK := Tu*D11HAT*Ty*inv(Q) .
C
      CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DK, LDDK, DWORK( IW2 ),
     $            NP2, ZERO, DWORK( IW3 ), M2 )
      CALL DLACPY( 'Full', M2, NP2, DWORK( IW3 ), M2, DK, LDDK )
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10RD ***
      END


!>
!! This module contains definitions for various useful constants.
!! By Allan P. Engsig-Karup.
!<
MODULE Constants
USE Precision
IMPLICIT NONE
! Constant parameters
REAL(KIND=long), PARAMETER :: zero=0.0_long, half=0.5_long,          &
       one=1.0_long,  two=2.0_long, three=3._long,  four=4.0_long,   &
       five=5.0_long, six=6.0_long, seven=7.0_long, eight=8.0_long,  &
       nine=9.0_long, ten=10.0_long
REAL(KIND=long) :: pi, deg2rad
END MODULE


SUBROUTINE quick_sort(list, order, n)

  ! Quick sort routine from:
  ! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to
  ! Fortran 90", McGraw-Hill  ISBN 0-07-000248-7, pages 149-150.
  ! Modified by Alan Miller to include an associated integer array which gives
  ! the positions of the elements in the original order.

  use amr_parameters, ONLY: qdp
  IMPLICIT NONE
  INTEGER :: n
  REAL(qdp), DIMENSION (1:n), INTENT(INOUT)  :: list
  INTEGER, DIMENSION (1:n), INTENT(OUT)  :: order

  ! Local variable
  INTEGER :: i

  DO i = 1, n
     order(i) = i
  END DO

  CALL quick_sort_1(1, n)

CONTAINS

  RECURSIVE SUBROUTINE quick_sort_1(left_end, right_end)

    use amr_parameters, ONLY: qdp
    INTEGER, INTENT(IN) :: left_end, right_end

    !     Local variables
    INTEGER             :: i, j, itemp
    REAL(qdp)              :: reference, temp
    INTEGER, PARAMETER  :: max_simple_sort_size = 6

    IF (right_end < left_end + max_simple_sort_size) THEN
       ! Use interchange sort for small lists
       CALL interchange_sort(left_end, right_end)

    ELSE
       ! Use partition ("quick") sort
       reference = list((left_end + right_end)/2)
       i = left_end - 1; j = right_end + 1

       DO
          ! Scan list from left end until element >= reference is found
          DO
             i = i + 1
             IF (list(i) >= reference) EXIT
          END DO
          ! Scan list from right end until element <= reference is found
          DO
             j = j - 1
             IF (list(j) <= reference) EXIT
          END DO

          IF (i < j) THEN
             ! Swap two out-of-order elements
             temp = list(i); list(i) = list(j); list(j) = temp
             itemp = order(i); order(i) = order(j); order(j) = itemp
          ELSE IF (i == j) THEN
             i = i + 1
             EXIT
          ELSE
             EXIT
          END IF
       END DO

       IF (left_end < j) CALL quick_sort_1(left_end, j)
       IF (i < right_end) CALL quick_sort_1(i, right_end)
    END IF

  END SUBROUTINE quick_sort_1

  SUBROUTINE interchange_sort(left_end, right_end)

    use amr_parameters, ONLY: qdp
    INTEGER, INTENT(IN) :: left_end, right_end

    !     Local variables
    INTEGER             :: i, j, itemp
    REAL(qdp)           :: temp

    DO i = left_end, right_end - 1
       DO j = i+1, right_end
          IF (list(i) > list(j)) THEN
             temp = list(i); list(i) = list(j); list(j) = temp
             itemp = order(i); order(i) = order(j); order(j) = itemp
          END IF
       END DO
    END DO

  END SUBROUTINE interchange_sort

END SUBROUTINE quick_sort
!########################################################################
!########################################################################
!########################################################################
!########################################################################
!########################################################################
SUBROUTINE quick_sort_dp(list, order, n)
  use amr_parameters, ONLY: dp
  IMPLICIT NONE
  ! Quick sort routine from:
  ! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to
  ! Fortran 90", McGraw-Hill  ISBN 0-07-000248-7, pages 149-150.
  ! Modified by Alan Miller to include an associated integer array which gives
  ! the positions of the elements in the original order.

  INTEGER :: n
  REAL(dp), DIMENSION (1:n), INTENT(INOUT)  :: list
  INTEGER, DIMENSION (1:n), INTENT(OUT)  :: order

  ! Local variable
  INTEGER :: i

  DO i = 1, n
     order(i) = i
  END DO

  CALL quick_sort_1_dp(1, n)

CONTAINS

  RECURSIVE SUBROUTINE quick_sort_1_dp(left_end, right_end)

    INTEGER, INTENT(IN) :: left_end, right_end

    !     Local variables
    INTEGER             :: i, j, itemp
    REAL(kind=8)              :: reference, temp
    INTEGER, PARAMETER  :: max_simple_sort_size = 6

    IF (right_end < left_end + max_simple_sort_size) THEN
       ! Use interchange sort for small lists
       CALL interchange_sort_dp(left_end, right_end)

    ELSE
       ! Use partition ("quick") sort
       reference = list((left_end + right_end)/2)
       i = left_end - 1; j = right_end + 1

      DO
          ! Scan list from left end until element >= reference is found
          DO
             i = i + 1
             IF (list(i) >= reference) EXIT
          END DO
          ! Scan list from right end until element <= reference is found
          DO
             j = j - 1
             IF (list(j) <= reference) EXIT
          END DO

          IF (i < j) THEN
             ! Swap two out-of-order elements
             temp = list(i); list(i) = list(j); list(j) = temp
             itemp = order(i); order(i) = order(j); order(j) = itemp
          ELSE IF (i == j) THEN
             i = i + 1
             EXIT
          ELSE
             EXIT
          END IF
       END DO
       IF (left_end < j) CALL quick_sort_1_dp(left_end, j)
       IF (i < right_end) CALL quick_sort_1_dp(i, right_end)
    END IF

  END SUBROUTINE quick_sort_1_dp

  SUBROUTINE interchange_sort_dp(left_end, right_end)

    INTEGER, INTENT(IN) :: left_end, right_end

    !     Local variables
    INTEGER             :: i, j, itemp
    REAL(kind=8)           :: temp

    DO i = left_end, right_end - 1
       DO j = i+1, right_end
          IF (list(i) > list(j)) THEN
             temp = list(i); list(i) = list(j); list(j) = temp
             itemp = order(i); order(i) = order(j); order(j) = itemp
          END IF
       END DO
    END DO

  END SUBROUTINE interchange_sort_dp

END SUBROUTINE quick_sort_dp


program main

use euler

implicit none

        ! Constants
        integer (kind=8), parameter :: MAXIMUM = 1000000000
        integer (kind=8), parameter :: BASE = 10

        integer (kind=8) :: n, i

        n = 0

        do i = 11, MAXIMUM, 2

                if(is_reversible(i)) then
                        call inc(n, ONE)
                end if

        end do

        n = n * 2

        print*, n

contains

        pure function is_reversible(i)

                integer (kind=8), intent(in) :: i
                logical :: is_reversible

                integer (kind=8) :: rev

                ! We know that intrev must be a pure function by
                ! definition thus `i` will not be modified.
                rev = intrev(i)

                is_reversible = .false.

                if(mod(rev, 2) /= 0) then
                        return
                endif

                is_reversible = only_odds(rev + i)

                return

        end function is_reversible

        pure function only_odds(x)

                integer (kind=8), intent(in) :: x
                logical :: only_odds

                integer (kind=8) :: i

                i = x

                ! Innocent until proven guilty
                only_odds = .true.

                do while(i /= 0)

                        if (mod(mod(i, BASE), 2) == 0) then
                                only_odds = .false.
                                exit
                        endif

                        i = i / BASE

                end do

                return

        end function only_odds

end program main


! { dg-do compile }

  implicit none
  integer, parameter :: arr(2) = [ 1, 3 ]
  real, parameter :: arr2(2) = [ 1.5, 2.1 ]
  integer, parameter :: j = int(sum(arr))
  integer, parameter :: k = ceiling(sum(arr2))
  real(kind=j) :: x1
  real(kind=k) :: x2

  print *, j, k
  print *, x1, x2

  end


program ch0805
    ! Rank 1 Array Initialisation - Explicit Values
    implicit none

    integer, parameter :: n = 12
    real :: total = 0., average = 0.
    real, dimension(1:n) :: rainfall = &
    [ 3.1, 2.0, 2.4, 2.1, 2.2, 2.2, 1.8, 2.2, 2.7, 2.9, 3.1, 3.1 ]
    integer :: month

    do month = 1, n
        total = total+rainfall(month)
    end do
    average = total/n
    print *, ' Average monthly rainfall was'
    print *, average
end program


Program TestExpandDH
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will expand a grid containing n samples in both longitude and
!	latitude into spherical harmonics using the sampling theorems given in
!	Driscoll and Heally (1994).
!
!
!	Written by Mark Wieczorek (May 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS

	implicit none
	integer, parameter ::	maxdeg = 120, maxgrid = 800
	character*80 ::		infile
	real*8 ::		cilm(2, maxdeg+1, maxdeg+1), grid(maxgrid, maxgrid), &
				griddh(maxgrid, maxgrid), cilm2(2, maxdeg+1, maxdeg+1), interval, &
				error, maxerror
	integer ::		lmax, n, nlat, nlong, lmax2, l, m, i

	infile = "../../ExampleDataFiles/MarsTopo719.shape"

	call SHRead(infile, cilm, lmax)
	print*, "Lmax of data file = ", lmax

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Create equally sampled grid
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	lmax = 89
	print*, "For this test of SHExpandDH, the initial grid will be created with lmax = ", lmax

	interval = 1.0d0

	print*, "Making grid using MakeGrid2D..."

	call MakeGrid2D(grid, cilm, lmax, interval, nlat, nlong)
	print*, "nlat, nlong = ", nlat, nlong

	print*, "Minimum and maximum values of the input grid = ", minval(grid(1:nlat, 1:nlong)), maxval(grid(1:nlat,1:nlong))

	n = nlat -1

	print*, "Number of samples in latitude used with SHExpandDH = ", n

	griddh(1:n,1:2*n) = grid(1:n, 1:2*n)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Expand equally spaced grid using Driscoll and Heally
	!	routine, and compute relative error between
	!	input and output spherical harmonic coefficients.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call SHExpandDH(griddh, n, cilm2, lmax2, sampling = 2)
	print*, "Lmax of Driscoll Heally expansion = ", lmax2

	maxerror = 0.0d0

	do l=0, lmax
		error = (cilm2(1,l+1,1)-cilm(1,l+1,1))/cilm(1,l+1,1)
		if (error > maxerror) maxerror = error
		do m=1, l, 1
			error = (cilm2(1,l+1,m+1)-cilm(1,l+1,m+1))/cilm(1,l+1,m+1)
			if (error > maxerror) maxerror = error
			error = (cilm2(2,l+1,m+1)-cilm(2,l+1,m+1))/cilm(2,l+1,m+1)
			if (error > maxerror) maxerror = error
		enddo
	enddo

	print*, "Maximum relative error between initial and output spherical harmonic coefficients = ", maxerror

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Re-expand coefficients in the space domain, and compare
	!	with input grid.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	griddh = 0.0d0
	call MakeGridDH(griddh, n, cilm2, lmax2)
	print*, "Number of samples in latitude and longitude = ", n

	maxerror = 0.0d0

	do i=1, n
		error = maxval( abs( griddh(1:n,i) - grid(1:n, 2*i-1) ) )
		if (error > maxerror) maxerror = error
	enddo

	print*, "Maximum error (meters) in the space domain = ", maxerror

end program TestExpandDH


PROGRAM capacitor
!
!  Purpose:
!    To calculate the behavior of a capacitor as follows:
!    1.  If capacitance and voltage are known, calculate
!        charge, number of electrons, and energy stored.
!    2.  If charge and voltage are known, calculate capa-
!        citance, number of electrons, and energy stored.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     11/18/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare constants
REAL, PARAMETER :: ELECTRONS_PER_COULOMB = 6.241461E18

! Data dictionary: declare variable types, definitions, & units
REAL :: c         ! Capacitance of the capacitor (farads).
REAL :: charge    ! Charge on the capacitor (coulombs).
REAL :: electrons ! Number of electrons on the plates of the capacitor
REAL :: energy    ! Energy stored in the electric field (joules)
INTEGER :: type   ! Type of input data available for the calculation:
                  !  1:  C and V
                  !  2:  CHARGE and V
REAL :: v         ! Voltage on the capacitor (volts).

! Prompt user for the type of input data available.
WRITE (*, 100)
100 FORMAT (' This program calculates information about a ' &
            'capacitor.',/, ' Please specify the type of information',&
            ' available from the following list:',/,&
            '   1 -- capacitance and voltage ',/,&
            '   2 -- charge and voltage ',//,&
            ' Select options 1 or 2: ')

! Get response and validate it.
DO
   READ (*,*) type
   IF ( (type == 1) .OR. (type == 2) ) EXIT
   WRITE (*,110) type
   110 FORMAT (' Invalid response: ', I6, '.  Please enter 1 or 2:')
END DO

! Get additional data based upon the type of calculation.
input: IF ( type == 1 ) THEN

   ! Get capacitance.
   WRITE (*,' Enter capacitance in farads: ')
   READ (*,*) c

   ! Get voltage.
   WRITE (*,' Enter voltage in volts: ')
   READ (*,*) v

ELSE

   ! Get charge
   WRITE (*,' Enter charge in coulombs: ')
   READ (*,*) charge

   ! Get voltage.
   WRITE (*,' Enter voltage in volts: ')
   READ (*,*) v

END IF input

! Calculate the unknown quantities.
calculate: IF ( type == 1 ) THEN
   charge = c * v                            ! Charge
ELSE
   c = charge / v                            ! Capacitance
END IF calculate
electrons = charge * ELECTRONS_PER_COULOMB   ! Electrons
energy = 0.5 * c * v**2                      ! Energy

! Write out answers.
WRITE (*,120) v, c, charge, electrons, energy
120 FORMAT (' For this capacitor: ',/, &
            '   Voltage             = ', F10.2, ' V',/, &
            '   Capacitance         = ', ES10.3, ' F',/, &
            '   Total charge        = ', ES10.3, ' C',/, &
            '   Number of electrons = ', ES10.3,/, &
            '   Total energy        = ', F10.4, ' joules' )

END PROGRAM capacitor


C
        SUBROUTINE FTIGE(NN,T,TH,F,RPAR,IPAR)
C ---RIGHT-HAND SIDE OF THE BEAM EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION F(NN),TH(150),U(150),V(150),W(150)
        DIMENSION ALPHA(150),BETA(150),STH(150),CTH(150)
        COMMON/NNNN/N,NNCOM,NSQ,NQUATR,DELTAS
C ----- CALCUL DES TH(I) ET DES SIN ET COS -------------
        DO 22 I=2,N
        THDIFF=TH(I)-TH(I-1)
        STH(I)=DSIN(THDIFF)
   22   CTH(I)=DCOS(THDIFF)
C -------- CALCUL DU COTE DROIT DU SYSTEME LINEAIRE -----
        IF(T.GT.3.14159265358979324D0)THEN
C --------- CASE T GREATER PI ------------
C ---------- I=1 ------------
            TERM1=(-3.D0*TH(1)+TH(2))*NQUATR
            V(1)=TERM1
C -------- I=2,..,N-1 -----------
            DO 32 I=2,N-1
            TERM1=(TH(I-1)-2.D0*TH(I)+TH(I+1))*NQUATR
  32        V(I)=TERM1
C ----------- I=N -------------
            TERM1=(TH(N-1)-TH(N))*NQUATR
            V(N)=TERM1
        ELSE
C --------- CASE T LESS EQUAL PI ------------
            FABS=1.5D0*DSIN(T)*DSIN(T)
            FX=-FABS
            FY= FABS
C ---------- I=1 ------------
            TERM1=(-3.D0*TH(1)+TH(2))*NQUATR
            TERM2=NSQ*(FY*DCOS(TH(1))-FX*DSIN(TH(1)))
            V(1)=TERM1+TERM2
C -------- I=2,..,N-1 -----------
            DO 34 I=2,N-1
            TERM1=(TH(I-1)-2.D0*TH(I)+TH(I+1))*NQUATR
            TERM2=NSQ*(FY*DCOS(TH(I))-FX*DSIN(TH(I)))
  34        V(I)=TERM1+TERM2
C ----------- I=N -------------
            TERM1=(TH(N-1)-TH(N))*NQUATR
            TERM2=NSQ*(FY*DCOS(TH(N))-FX*DSIN(TH(N)))
            V(N)=TERM1+TERM2
        END IF
C -------- COMPUTE PRODUCT DV=W ------------
        W(1)=STH(2)*V(2)
        DO 43 I=2,N-1
   43   W(I)=-STH(I)*V(I-1)+STH(I+1)*V(I+1)
        W(N)=-STH(N)*V(N-1)
C -------- TERME 3 -----------------
        DO 435 I=1,N
  435   W(I)=W(I)+TH(N+I)*TH(N+I)
C ------- SOLVE SYSTEM CW=W ---------
        ALPHA(1)=1.D0
        DO 44 I=2,N
        ALPHA(I)=2.D0
   44   BETA(I-1)=-CTH(I)
        ALPHA(N)=3.D0
        DO 45 I=N-1,1,-1
        Q=BETA(I)/ALPHA(I+1)
        W(I)=W(I)-W(I+1)*Q
   45   ALPHA(I)=ALPHA(I)-BETA(I)*Q
        W(1)=W(1)/ALPHA(1)
        DO 46 I=2,N
   46   W(I)=(W(I)-BETA(I-1)*W(I-1))/ALPHA(I)
C -------- COMPUTE U=CV+DW ---------
        U(1)=V(1)-CTH(2)*V(2)+STH(2)*W(2)
        DO 47 I=2,N-1
   47   U(I)=2.D0*V(I)-CTH(I)*V(I-1)-CTH(I+1)*V(I+1)
     &                -STH(I)*W(I-1)+STH(I+1)*W(I+1)
        U(N)=3.D0*V(N)-CTH(N)*V(N-1)-STH(N)*W(N-1)
C -------- PUT  DERIVATIVES IN RIGHT PLACE -------------
        DO 54 I=1,N
        F(I)=TH(N+I)
  54    F(N+I)=U(I)
        RETURN
        END


! ******************************************************************************************************************************** !
! sedgem_nnutils.f90
! NETCDF UTILITIES MODULE
! ******************************************************************************************************************************** !

module sedgem_nnutils

  use genie_control
  USE gem_cmn
  IMPLICIT NONE
  SAVE

  ! ****************************************************************************************************************************** !
  ! PARAMETERS AND VARIABLES
  ! ****************************************************************************************************************************** !

  ! ***  ***
  INTEGER,PARAMETER::nl = 2  ! number of layers
  INTEGER,PARAMETER::par_nn_input   = 5
  INTEGER,PARAMETER::par_nn_neurons = 12
  INTEGER,PARAMETER::par_nn_target  = 1
  INTEGER,dimension(2)::par_nn_ifuna  = (/3, 1/)  ! 1:linear, 2:logsig, 3:tansig
  real,dimension(2)::par_nn_funcoa = (/1, 1/) ! coefficients for functions

  ! *** ***
  ! NOTE: order; D(m), dco3(mol kg-1), o2(mol kg-1), calpc (dim-less fraction), rainorg (mol cm-2 yr-1)
  real,dimension(5)::nn_min = (/    0.0, -100.0e-6, 200.0e-6, 0.0,  0.0e-6/)
  real,dimension(5)::nn_max = (/10000.0,  100.0e-6, 200.0e-6, 1.0, 49.0e-6/)
  real,allocatable,target:: &
       a0(:), &
       w1(:,:),b1(:),a1(:),dadn1(:),dw1(:,:),db1(:),s1(:), &
       w2(:,:),b2(:),a2(:),dadn2(:),dw2(:,:),db2(:),s2(:), &
       w3(:,:),b3(:),a3(:),dadn3(:),dw3(:,:),db3(:),s3(:)
  real,pointer::w(:,:),wp(:,:),b(:),dadn(:),dw(:,:),db(:),s(:),am(:),sp(:)
  real,allocatable::p(:),t(:)
  integer::nn_current_layer,nn_ifun
  real::nn_funco
  real::nn_mint,nn_maxt
  real,dimension(par_nn_input)::nn_minp,nn_maxp
  real,pointer::nn_a(:)

contains

  ! ****************************************************************************************************************************** !
  !
  function fun_nn_parnorm(dum_x,dum_min,dum_max,dum_isize)
    ! dummy arguments
    integer::dum_isize
    real,dimension(dum_isize),intent(in)::dum_x,dum_min,dum_max
    ! result variable
    real,dimension(dum_isize)::fun_nn_parnorm
    ! local variables
    integer::i
    real,dimension(dum_isize)::loc_parnorm
    !
    do i=1,dum_isize
       if (dum_max(i) - dum_min(i) < const_real_nullsmall) then
          loc_parnorm(i) = 1.0
       else
          loc_parnorm(i) = 2.0*(dum_x(i) - dum_min(i))/(dum_max(i) - dum_min(i)) - 1.0
          if (loc_parnorm(i) < -1.0) loc_parnorm(i) = -1.0
          if (loc_parnorm(i) > 1.0)  loc_parnorm(i) = 1.0
       end if
    end do
    ! return value
    fun_nn_parnorm(:) = loc_parnorm(:)
  end function fun_nn_parnorm
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  !
  function fun_nn_premn(dum_x,dum_min,dum_max,dum_isize)
    ! dummy arguments
    integer::dum_isize
    real,dimension(dum_isize),intent(in)::dum_x,dum_min,dum_max
    ! result variable
    real,dimension(dum_isize)::fun_nn_premn
    ! return value
    fun_nn_premn = 2.0*(dum_x - dum_min)/(dum_max - dum_min) - 1.0
  end function fun_nn_premn
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  !
  function fun_nn_posmn(dum_x,dum_mint,dum_maxt)
    ! result variable
    real::fun_nn_posmn
    ! dummy arguments
    real,intent(in)::dum_x,dum_mint,dum_maxt
    ! return value
    fun_nn_posmn = 0.5*(dum_x + 1.0)*(dum_maxt - dum_mint) + dum_mint
  end function fun_nn_posmn
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  !
  subroutine sub_nn_allocate_network
    USE genie_util, ONLY: check_iostat
    ! local variables
    INTEGER::i,j,alloc_stat
    !
    i=par_nn_input
    allocate(a0(i))
    j=i
    i=par_nn_neurons
    allocate(w1(i,j),b1(i),dw1(i,j),db1(i),a1(i),dadn1(i),s1(i))
    j=i
    i=par_nn_target
    allocate(w2(i,j),b2(i),dw2(i,j),db2(i),a2(i),dadn2(i),s2(i),stat=alloc_stat)
    call check_iostat(alloc_stat,__LINE__,__FILE__)
    allocate(p(par_nn_input),t(par_nn_target),stat=alloc_stat)
    call check_iostat(alloc_stat,__LINE__,__FILE__)
  end subroutine sub_nn_allocate_network
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  !
  subroutine sub_nn_point_layer(dum_m)
    ! dummy arguments
    integer dum_m
    !
    if (dum_m.eq.1) then
       am=>a0
       nn_a=>a1
       dadn=>dadn1
       s=>s1
       sp=>s2
       w=>w1
       dw=>dw1
       b=>b1
       db=>db1
       wp=>w2
       nn_ifun=par_nn_ifuna(1)
       nn_funco=par_nn_funcoa(1)
    else if (dum_m.eq.2) then
       am=>a1
       nn_a=>a2
       dadn=>dadn2
       s=>s2
       sp=>s3
       w=>w2
       dw=>dw2
       b=>b2
       db=>db2
       wp=>w3
       nn_ifun=par_nn_ifuna(2)
       nn_funco=par_nn_funcoa(2)
    else if (dum_m.eq.3) then
       am=>a2
       nn_a=>a3
       dadn=>dadn3
       s=>s3
       w=>w3
       dw=>dw3
       b=>b3
       db=>db3
       nullify(sp)
       nullify(wp)
    else
       print *,' m not in range, cannot repoint. m=',dum_m,' ,nl=',nl
       stop
    endif
    nn_current_layer = dum_m
  end subroutine sub_nn_point_layer
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  !
  subroutine sub_nn_forward_model(dum_p)
    ! dummy arguments
    real,optional::dum_p(:)
    ! local variables
    integer::m
    !
    if (present(dum_p)) a0 = dum_p
    do m=1,nl
       call sub_nn_point_layer(m)
       call fun_nn_f(dadn,nn_a,matmul(w,am)+b,nn_funco,nn_ifun)
    enddo
  end subroutine sub_nn_forward_model
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  !
  subroutine fun_nn_f(dum_dadn,dum_a,dum_n,dum_coef,dum_ifun)
    ! dummy arguments
    integer::dum_ifun
    real::dum_dadn(:),dum_a(:),dum_n(:),dum_coef
    ! local variables
    integer::i
    !
    select case(dum_ifun)
    case(1) ! linear transfer function
       forall (i=1:size(dum_n,1))
          dum_a(i)=dum_n(i)*dum_coef
          dum_dadn(i)=dum_coef
       end forall
    case(2) ! logsig transfer function
       do i=1,size(dum_n,1)
          dum_a(i)=1./(1.+exp(-dum_coef*dum_n(i)))
          dum_dadn(i)=dum_coef*dum_a(i)*(1-dum_a(i))!derivative from logsig
       enddo
    case(3) ! tansig transfer function
       do i=1,size(dum_n,1)
          dum_a(i)=2./(1.+exp(-2*dum_n(i)))-1.
          dum_dadn(i)=1.-dum_a(i)**2 !derivative from tansig
       enddo
    case default
       print *, 'cannot find a function for ',dum_ifun,' ...stopping'
         stop
      endselect
    end subroutine fun_nn_f
  ! ****************************************************************************************************************************** !

end module sedgem_nnutils


! { dg-do run }
! PR 21127:  Reshape of complex didn't work.
! PR 21480:  Reshape of packed complex arrays didn't work either.
program main
  complex, dimension(8) :: b
  complex, dimension(2,2) :: a
  complex, dimension(2) :: c,d
  integer :: i
  b = (/(i,i=1,8)/)
  a = reshape(b(1:8:2),shape(a))
  if (a(1,1) /= (1.0, 0.0) .or. a(2,1) /= (3.0, 0.0) .or.  &
      a(1,2) /= (5.0, 0.0) .or. a(2,2) /= (7.0, 0.0)) STOP 1
  c = (/( 3.14, -3.14), (2.71, -2.71)/)
  d = reshape(c, shape (d))
  if (any (c .ne. d)) STOP 2
end


module worker_module
use iso_fortran_env, only: real64
contains

  function my_scalar_add(x1, x2) result(res)
    implicit none
    real(real64),intent(in) :: x1, x2
    real(real64) :: res

    res = x1 + x2

  end function my_scalar_add

  function my_scalar_add_omp(x1, x2) result(res)
    !$omp declare simd(my_scalar_add_omp)
    implicit none
    real(real64),intent(in) :: x1, x2
    real(real64) :: res

    res = x1 + x2

  end function my_scalar_add_omp

  pure function my_scalar_add_pure(x1, x2) result(res)
    implicit none
    real(real64),intent(in) :: x1, x2
    real(real64) :: res

    res = x1 + x2

  end function my_scalar_add_pure

  elemental subroutine my_scalar_add_elemental_value(res, x1, x2)
    implicit none
    real(real64),value,intent(in) :: x1, x2
    real(real64),intent(out) :: res

    res = x1 + x2

  end subroutine my_scalar_add_elemental_value

  elemental function my_scalar_add_elemental(x1, x2) result(res)
    implicit none
    real(real64),intent(in) :: x1, x2
    real(real64) :: res

    res = x1 + x2

  end function my_scalar_add_elemental

end module worker_module


      PROGRAM xdfridr
C     driver for routine dfridr
      REAL dfridr,dx,err,func,h,x
      EXTERNAL func
1     write(*,*) 'input x,h '
      read(*,*,END=999) x,h
      dx=dfridr(func,x,h,err)
      write(*,*) 'DFRIDR=',dx,1./cos(x)**2,err
      goto 1
999   END
      REAL FUNCTION func(x)
      REAL x
      func=tan(x)
      return
      END

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


! { dg-do run }
! pr 19071
! test case provided by
!   Thomas.Koenig@online.de
       program cio
       complex a
       real r1,r2
       a = cmplx(1.0, 2.0)
       open(unit=74,status='scratch')
       write(74,'(1P,E13.5)')a
       rewind(74)
!  can read the complex in as two reals, one on each line
       read(74,'(E13.5)')r1,r2
       if (r1.ne.1.0 .and. r2.ne.2.0) call abort
       end


c-----------------------2--------------------------
c
c This file tests the routines for the eigenvalues
c of a clamped plate on a domain from Antunes 2011,
c for which the first eigenvalue should be 9.466464562432
c (k = 3.07676202564)
c this domain is interesting b/c it is a relatively
c simple shape for which the first eigenfunction has
c a sign change (it is a convex domain with analytic
c boundary)
c
c In particular, this routine takes in points A and B
c and an integer N (a power of 2 is a good choice)
c and computes the determinant of the appropriately
c scaled system matrix for the value k at each of the
c N+1 second kind chebyshev points on [a,b]
c
c

      program main
      implicit real *8 (a-h,o-z)
      real *8 w(1000000)
      real *8 a, b, pi
      complex *16, allocatable :: zks(:), zdets(:)
      complex *16 q1, q2
      integer n, nchs(100)
      real *8 cms(2,100)

      integer, allocatable :: adjs(:,:)
      real *8, allocatable :: hs(:)
c
      real *8, allocatable :: chunks(:,:,:),ders(:,:,:),
     1     ders2(:,:,:), wgeo(:), xs(:), ys(:)

      real *8 pars(100)
c
      external fcurve_antunes

      character *100 filename, format_string

      call prini(6,13)

      pi = 4.0d0*datan(1.0d0)

c
c     define then chunk up domain
c
      eps10=1.0d-14
      nover1=1
      k=16
c
      maxchunks=1000
      allocate(chunks(2,k,maxchunks),hs(maxchunks),adjs(2,maxchunks))
      allocate(ders(2,k,maxchunks))
      allocate(ders2(2,k,maxchunks))
c
      ifclosed=1
      chsmall=1000
      ta=0
      tb=2*pi

      call chunkfunc(eps10,ifclosed,chsmall,ta,tb,fcurve_antunes,
     1     pars,nover1,k,nch,chunks,adjs,ders,ders2,hs)

      if (nch .gt. maxchunks) then
         write(*,*) 'MAX CHUNKS EXCEEDED. ABORT'
         stop
      endif

      call prinf('k*',k,1)
      call prinf('nch*',nch,1)
      call prinf('npts*',nch*k,1)

      allocate(xs(nch*k),ys(nch*k))
      do i = 1,nch
         do j = 1,k
            xs((i-1)*k+j) = chunks(1,j,i)
            ys((i-1)*k+j) = chunks(2,j,i)
         enddo
      enddo

      ifile = 37
      call pyplot(ifile,xs,ys,nch*k,2,'a*')

      lwgeo = 1000000
      allocate(wgeo(lwgeo))

      call chunkpack(k,nch,chunks,adjs,ders,ders2,hs,wgeo,lused)
      if (lused .gt. lwgeo) then
         write(*,*) 'LWGEO EXCEEDED. ABORT'
         stop
      endif

c     this is a simply connected domain (cms(1:2,1) is a point outside)

      ncomp = 1
      nchs(1) = nch
      cms(1,1) = 3.0d0
      cms(2,1) = 3.0d0

      call prin2('Enter a (left end-point)*',n,0)
      read *, a
      call prin2('Enter b* (right end-point)*',n,0)
      read *, b
      call prin2('Enter n (integer bigger than 0)*',n,0)
      read *, n

      if (b .lt. a .or. a .lt. 1d-15 .or. n .lt. 1) then
         write(*,*) 'bad values for a,b,or n'
         stop
      endif

      allocate(zks(0:n),zdets(0:n))

      do i = 0,n
         zks(i) = 0.5*(a+b) + 0.5*(b-a)*cos((n-i)*pi/n)
      enddo

c     set q2 so that the operator is of the form I + K

      q1 = (0.0d0,0.0d0)
      q2 = (-2.0d0,0.0d0)

c     flag for square root scaling
      ifss = 1

      do i = 0,n
         write(*,*) '******************************'
         write(*,*) '******************************'
         write(*,*) 'i = ', i
         write(*,*) 'zks(i) ', zks(i)

         call prin2('evaluating determinant ...*',zdets,0)
         call zhbhdir_det(zks(i),wgeo,ncomp,nchs,cms,q1,q2,
     1     ifss,zdets(i))

         call prin2('found determinant*',zdets(i),2)
      enddo

      iw = 16

      format_string = "(A7,I0.6)"
      write(filename,format_string) "antunes", n
      open(unit=iw,FILE=filename)

      do i=0,n

      write(iw,*) real(zks(i)), imag(zks(i)), real(zdets(i)),
     1        imag(zdets(i))

      enddo

      stop
      end

c------------------------------------------------------
c
      subroutine zhbhdir_det(zk,wgeo,ncomp,nchs,cms,q1,q2,
     1     ifss,zdetval)

      implicit none
c     inputs
      real *8 :: wgeo(*), cms(2,*)
      complex *16 zk, q1, q2, zdetval
      integer :: ncomp, nchs(*), ifss

c     local
      complex *16, allocatable :: sysmat(:,:)
      real *8, allocatable :: whts(:,:)
      integer ntot, k, nch, ichunks,iadjs,iders,iders2,ihs
      integer :: ier, ich, jch, inode, jnode, info, ipt, jpt
      integer, allocatable :: ipiv(:)
      real *8 :: time1, time2, rr

      call chunkunpack1(wgeo,k,nch,ichunks,iadjs,iders,iders2,ihs)

      allocate(whts(k,nch))

      call chunkwhts(k,nch,wgeo(ichunks),wgeo(iders),wgeo(ihs),whts)

      ntot = 2*k*nch + ncomp
      allocate(sysmat(ntot,ntot))

      call prinf('k=*',k,1)
      call prinf('ntot=*',ntot,1)

      call prinf('building system matrix ...*',ier,0)
      time1 = second()
      call zhbhstokesmatbuild(zk,wgeo,ncomp,nchs,cms,
     1     q1,q2,ntot,sysmat,ier)
      time2 = second()
      call prin2('done*',time2-time1,1)

c
c     square root scale the matrix (if requested)
c
      if (ifss .eq. 1) then

         call prinf('square root scaling matrix ...*',ifss,0)
         time1 = second()

         do ich = 1,nch
            do inode =1,k

               ipt = (ich-1)*k + inode

               do jch = 1,nch
                  do jnode = 1,k

                     jpt = (jch-1)*k + jnode

                     rr = sqrt(whts(inode,ich)/whts(jnode,jch))
                     sysmat(2*ipt-1,2*jpt-1) =
     1                    sysmat(2*ipt-1,2*jpt-1)*rr
                     sysmat(2*ipt-1,2*jpt) = sysmat(2*ipt-1,2*jpt)*rr
                     sysmat(2*ipt,2*jpt-1) = sysmat(2*ipt,2*jpt-1)*rr
                     sysmat(2*ipt,2*jpt) = sysmat(2*ipt,2*jpt)*rr

                  enddo
               enddo
            enddo
         enddo

         do ipt=2*k*nch+1,ntot
            do jch=1,nch
               do jnode=1,k

                  jpt = (jch-1)*k+jnode

                  rr = 1.0d0/sqrt(whts(jnode,jch))
                  sysmat(ipt,2*jpt-1) = sysmat(ipt,2*jpt-1)*rr
                  sysmat(ipt,2*jpt) = sysmat(ipt,2*jpt)*rr

               enddo
            enddo
         enddo

         do ich=1,nch
            do inode=1,k
               ipt = (ich-1)*k+inode

               rr = sqrt(whts(inode,ich))

               do jpt = 2*k*nch+1,ntot

                  sysmat(2*ipt-1,jpt) = sysmat(2*ipt-1,jpt)*rr
                  sysmat(2*ipt,jpt) = sysmat(2*ipt,jpt)*rr

               enddo
            enddo
         enddo
         time2 = second()
         call prin2('done*',time2-time1,1)

      endif

      call prinf('calling zgetrf ...*',ier,0)
      allocate(ipiv(ntot))
      time1 = second()
      call zgetrf( ntot, ntot, sysmat, ntot, ipiv, info )
      time2 = second()
      call prin2('done*',time2-time1,1)
      call prinf('info*',info,1)
      call prinf('extracting determinant ...*',info,0)
      call zgetr_det(ntot,sysmat,ipiv,info,zdetval)

      return
      end
c----------------------------------------------------------------------

      subroutine zgetr_det(n,a,ipiv,info,zdet)
      implicit none
      integer :: n, info
      complex *16 :: a(n,n), zdet
      integer :: ipiv(*)

      integer i

      zdet = 0d0
      if (info.ne.0) then
         return
      endif
      zdet = 1d0
      do i=1,n
         if (ipiv(i).ne.i) then
            zdet = -zdet * a(i,i)
         else
            zdet = zdet * a(i,i)
         endif
      enddo
      end

      subroutine fcurve_antunes(t,pars,x,y,dxdt,dydt,dxdt2,dydt2)
      implicit real *8 (a-h,o-z)
      integer n
      real *8 pars(100), t, pert, x0,y0, r0,r,rp,rpp
c
      x = 2.0d0*cos(t)
      dxdt = -2.0d0*sin(t)
      dxdt2 = -2.0d0*cos(t)

      y = sin(t) + 0.25d0*sin(2.0d0*t)
      dydt = cos(t) + 0.5d0*cos(2.0d0*t)
      dydt2 = -sin(t) - sin(2.0d0*t)
c
      return
      end