      SUBROUTINE MB03IZ( COMPQ, COMPU, N, A, LDA, C, LDC, D, LDD, B,
     $                   LDB, F, LDF, Q, LDQ, U1, LDU1, U2, LDU2, NEIG,
     $                   TOL, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To move the eigenvalues with strictly negative real parts of an
C     N-by-N complex skew-Hamiltonian/Hamiltonian pencil aS - bH in
C     structured Schur form, with
C
C                                (  0  I  )
C       S = J Z' J' Z, where J = (        ),
C                                ( -I  0  )
C
C     to the leading principal subpencil, while keeping the triangular
C     form. On entry, we have
C
C           (  A  D  )      (  B  F  )
C       Z = (        ), H = (        ),
C           (  0  C  )      (  0 -B' )
C
C     where A and B are upper triangular and C is lower triangular.
C     Z and H are transformed by a unitary symplectic matrix U and a
C     unitary matrix Q such that
C
C                       (  Aout  Dout  )
C       Zout = U' Z Q = (              ), and
C                       (    0   Cout  )
C                                                                    (1)
C                            (  Bout  Fout  )
C       Hout = J Q' J' H Q = (              ),
C                            (    0  -Bout' )
C
C     where Aout, Bout and Cout remain in triangular form. The notation
C     M' denotes the conjugate transpose of the matrix M.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the unitary matrix Q
C     that fulfills (1) is computed.
C     Optionally, if COMPU = 'I' or COMPU = 'U', the unitary symplectic
C     matrix
C
C           (  U1  U2  )
C       U = (          )
C           ( -U2  U1  )
C
C     that fulfills (1) is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the unitary transformations
C             should be accumulated in the array Q, as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the unitary matrix Q is returned;
C             = 'U':  the array Q contains a unitary matrix Q0 on
C                     entry, and the matrix Q0*Q is returned, where Q
C                     is the product of the unitary transformations
C                     that are applied to the pencil aS - bH to reorder
C                     the eigenvalues.
C
C     COMPU   CHARACTER*1
C             Specifies whether or not the unitary symplectic
C             transformations should be accumulated in the arrays U1 and
C             U2, as follows:
C             = 'N':  U1 and U2 are not computed;
C             = 'I':  the arrays U1 and U2 are initialized internally,
C                     and the submatrices U1 and U2 defining the
C                     unitary symplectic matrix U are returned;
C             = 'U':  the arrays U1 and U2 contain the corresponding
C                     submatrices of a unitary symplectic matrix U0
C                     on entry, and the updated submatrices U1 and U2
C                     of the matrix product U0*U are returned, where U
C                     is the product of the unitary symplectic
C                     transformations that are applied to the pencil
C                     aS - bH to reorder the eigenvalues.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix A.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Aout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     C       (input/output) COMPLEX*16 array, dimension (LDC, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the lower triangular matrix C.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Cout.
C             The strictly upper triangular part of this array is not
C             referenced.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1, N/2).
C
C     D       (input/output) COMPLEX*16 array, dimension (LDD, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix D.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Dout.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1, N/2).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix B.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Bout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (input/output) COMPLEX*16 array, dimension (LDF, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the Hermitian matrix
C             F.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Fout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)
C             On entry, if COMPQ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q0, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q0 and the transformation matrix Q
C             used to transform the matrices S and H.
C             On exit, if COMPQ = 'I', then the leading N-by-N part of
C             this array contains the unitary transformation matrix Q.
C             If COMPQ = 'N' this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,         if COMPQ = 'N';
C             LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.
C
C     U1      (input/output) COMPLEX*16 array, dimension (LDU1, N/2)
C             On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
C             of this array must contain the upper left block of a
C             given matrix U0, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper left block U1 of
C             the product of the input matrix U0 and the transformation
C             matrix U used to transform the matrices S and H.
C             On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper left block U1 of the
C             unitary symplectic transformation matrix U.
C             If COMPU = 'N' this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.
C             LDU1 >= 1,           if COMPU = 'N';
C             LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'.
C
C     U2      (input/output) COMPLEX*16 array, dimension (LDU2, N/2)
C             On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
C             of this array must contain the upper right block of a
C             given matrix U0, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper right block U2 of
C             the product of the input matrix U0 and the transformation
C             matrix U used to transform the matrices S and H.
C             On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper right block U2 of the
C             unitary symplectic transformation matrix U.
C             If COMPU = 'N' this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.
C             LDU2 >= 1,           if COMPU = 'N';
C             LDU2 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'.
C
C     NEIG    (output) INTEGER
C             The number of eigenvalues in aS - bH with strictly
C             negative real part.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance used to decide the sign of the eigenvalues.
C             If the user sets TOL > 0, then the given value of TOL is
C             used. If the user sets TOL <= 0, then an implicitly
C             computed, default tolerance, defined by MIN(N,10)*EPS, is
C             used instead, where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH). A larger value might be
C             needed for pencils with multiple eigenvalues.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value.
C
C     METHOD
C
C     The algorithm reorders the eigenvalues like the following scheme:
C
C     Step 1: Reorder the eigenvalues in the subpencil aC'*A - bB.
C          I. Reorder the eigenvalues with negative real parts to the
C             top.
C         II. Reorder the eigenvalues with positive real parts to the
C             bottom.
C
C     Step 2: Reorder the remaining eigenvalues with negative real
C             parts.
C          I. Exchange the eigenvalues between the last diagonal block
C             in aC'*A - bB and the last diagonal block in aS - bH.
C         II. Move the eigenvalues in the N/2-th place to the (MM+1)-th
C             place, where MM denotes the current number of eigenvalues
C             with negative real parts in aC'*A - bB.
C
C     The algorithm uses a sequence of unitary transformations as
C     described on page 38 in [1]. To achieve those transformations the
C     elementary SLICOT Library subroutines MB03CZ and MB03GZ are called
C     for the corresponding matrix structures.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     complex floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 29, 2009.
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFNX).
C
C     REVISIONS
C
C     V. Sima, Dec. 2010, Jan. 2011.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue reordering, upper triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, TEN
      PARAMETER          ( ZERO = 0.0D+0, TEN = 1.0D+1 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                     CONE  = ( 1.0D+0, 0.0D+0 ) )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPU
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDF, LDQ, LDU1, LDU2,
     $                   N, NEIG
      DOUBLE PRECISION   TOL
C
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), F( LDF, * ), Q( LDQ, * ),
     $                   U1( LDU1, * ), U2( LDU2, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LCMPU, LINIQ, LINIU, LUPDQ, LUPDU
      INTEGER            IUPD, J, K, M, MM, MP, UPDS
      DOUBLE PRECISION   CO1, CO2, CO3, EPS, NRMA, NRMB
      COMPLEX*16         CJF, SI1, SI2, SI3, TMP
C
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
      COMPLEX*16         HLP( 2, 2 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, ZLANTR
      EXTERNAL           DLAMCH, LSAME, ZLANTR
C
C     .. External Subroutines ..
      EXTERNAL           MB03CZ, MB03GZ, XERBLA, ZLASET, ZROT
C
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCONJG, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M     = N/2
      NEIG  = 0
      LINIQ = LSAME( COMPQ, 'I' )
      LUPDQ = LSAME( COMPQ, 'U' )
      LCMPQ = LINIQ .OR. LUPDQ
      LINIU = LSAME( COMPU, 'I' )
      LUPDU = LSAME( COMPU, 'U' )
      LCMPU = LINIU .OR. LUPDU
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -13
      ELSE IF( LDQ.LT.1  .OR. ( LCMPQ .AND. LDQ.LT.N  ) ) THEN
         INFO = -15
      ELSE IF( LDU1.LT.1 .OR. ( LCMPU .AND. LDU1.LT.M ) ) THEN
         INFO = -17
      ELSE IF( LDU2.LT.1 .OR. ( LCMPU .AND. LDU2.LT.M ) ) THEN
         INFO = -19
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03IZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         RETURN
      END IF
C
      EPS = TOL
      IF ( EPS.LE.ZERO ) THEN
C
C        Use the default tolerance.
C
         EPS = MIN( DBLE( N ), TEN )*DLAMCH( 'Precision' )
      END IF
C
C     STEP 0. Initializations.
C
      IF( LINIQ ) THEN
         IUPD = M + 1
         UPDS = M
         CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
      ELSE IF( LUPDQ ) THEN
         IUPD = 1
         UPDS = N
      END IF
C
      IF( LINIU ) THEN
         CALL ZLASET( 'Full', M, M, CZERO, CONE,  U1, LDU1 )
         CALL ZLASET( 'Full', M, M, CZERO, CZERO, U2, LDU2 )
      END IF
C
C     STEP 1. Reorder the eigenvalues in the subpencil aC'*A - bB.
C
      MM = 0
      MP = M + 1
      NRMA = ZLANTR( 'One', 'Upper', 'Non-Unit', M, M, A, LDA, DUM )*
     $       ZLANTR( 'One', 'Lower', 'Non-Unit', M, M, C, LDC, DUM )
      NRMB = ZLANTR( 'One', 'Upper', 'Non-Unit', M, M, B, LDB, DUM )
C
C     I. Reorder the eigenvalues with negative real parts to the top.
C
      DO 20 K = 1, M
         IF( DBLE( B( K, K )*C( K, K )*DCONJG( A( K, K ) ) )*NRMB.LE.
     $      -EPS*NRMA ) THEN
            DO 10 J = K - 1, MM + 1, -1
C
C              Perform eigenvalue exchange.
C
               HLP( 1, 1 ) = DCONJG( C( J, J ) )
               HLP( 1, 2 ) = DCONJG( C( J+1, J ) )
               HLP( 2, 2 ) = DCONJG( C( J+1, J+1 ) )
C
               CALL MB03CZ( HLP, 2, A( J, J ), LDA, B( J, J ),
     $                      LDB, CO1, SI1, CO2, SI2, CO3, SI3 )
C
C              Update A, C, and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*DCONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
               CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA,
     $                    CO2, -SI2 )
C
               CALL ZROT( M, D( 1, J+1 ), 1, D( 1, J ), 1, CO3, SI3 )
               CALL ZROT( M, D( J, 1 ), LDD, D( J+1, 1 ), LDD, CO2, -SI2
     $                     )
C
               CALL ZROT( M-J, C( J+1, J+1 ), 1, C( J+1, J ), 1, CO3,
     $                    SI3 )
               C( J+1, J+1 ) = CO2*C( J+1, J+1 ) +
     $                         SI3*C( J, J )*DCONJG( SI2 )
               C( J, J )     = CO3*C( J, J )
               CALL ZROT( J, C( J, 1 ), LDC, C( J+1, 1 ), LDC, CO2,
     $                    -SI2 )
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO3*B( J, J ) +
     $                         SI3*B( J+1, J+1 )*DCONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
               CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB,
     $                    CO3, -SI3 )
C
               CJF = DCONJG( F( J, J+1 ) )
               TMP = CO3*CJF - DCONJG( SI3 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO3, SI3 )
               F( J, J )     = CO3*F( J, J )     - SI3*TMP
               F( J+1, J+1 ) = CO3*F( J+1, J+1 ) + SI3*CJF
               CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF,
     $                    CO3, -SI3 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO3, SI3 )
               END IF
C
               IF( LCMPU ) THEN
C
C                 Update U.
C
                  CALL ZROT( M, U1( 1, J+1 ), 1, U1( 1, J ), 1, CO2, SI2
     $                        )
                  IF( LUPDU ) THEN
                     CALL ZROT( M, U2( 1, J+1 ), 1, U2( 1, J ), 1, CO2,
     $                          SI2 )
                  END IF
               END IF
   10       CONTINUE
            MM = MM + 1
         END IF
   20 CONTINUE
C
C     II. Reorder the eigenvalues with positive real parts to the bottom.
C
      DO 40 K = M, MM + 1, -1
         IF( DBLE( B( K, K )*C( K, K )*DCONJG( A( K, K ) ) )*NRMB.GE.
     $       EPS*NRMA ) THEN
            DO 30 J = K, MP - 2
C
C              Perform eigenvalue exchange.
C
               HLP( 1, 1 ) = DCONJG( C( J, J ) )
               HLP( 1, 2 ) = DCONJG( C( J+1, J ) )
               HLP( 2, 2 ) = DCONJG( C( J+1, J+1 ) )
C
               CALL MB03CZ( HLP, 2, A( J, J ), LDA, B( J, J ),
     $                      LDB, CO1, SI1, CO2, SI2, CO3, SI3 )
C
C              Update A, C, and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*DCONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
               CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA,
     $                    CO2, -SI2 )
C
               CALL ZROT( M, D( 1, J+1 ), 1, D( 1, J ), 1, CO3, SI3 )
               CALL ZROT( M, D( J, 1 ), LDD, D( J+1, 1 ), LDD, CO2, -SI2
     $                     )
C
               CALL ZROT( M-J, C( J+1, J+1 ), 1, C( J+1, J ), 1, CO3,
     $                    SI3 )
               C( J+1, J+1 ) = CO2*C( J+1, J+1 ) +
     $                         SI3*C( J, J )*DCONJG( SI2 )
               C( J, J )     = CO3*C( J, J )
               CALL ZROT( J, C( J, 1 ), LDC, C( J+1, 1 ), LDC, CO2,
     $                    -SI2 )
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO3*B( J, J ) +
     $                         SI3*B( J+1, J+1 )*DCONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
               CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB,
     $                    CO3, -SI3 )
C
               CJF = DCONJG( F( J, J+1 ) )
               TMP = CO3*CJF - DCONJG( SI3 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO3, SI3 )
               F( J, J )     = CO3*F( J, J )     - SI3*TMP
               F( J+1, J+1 ) = CO3*F( J+1, J+1 ) + SI3*CJF
               CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF,
     $                    CO3, -SI3 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO3, SI3 )
               END IF
C
               IF( LCMPU ) THEN
C
C                 Update U.
C
                  CALL ZROT( M, U1( 1, J+1 ), 1, U1( 1, J ), 1, CO2, SI2
     $                        )
                  IF( LUPDU ) THEN
                     CALL ZROT( M, U2( 1, J+1 ), 1, U2( 1, J ), 1, CO2,
     $                          SI2 )
                  END IF
               END IF
   30       CONTINUE
            MP = MP - 1
         END IF
   40 CONTINUE
C
C     The remaining M-MP+1 eigenvalues with negative real part are now in
C     the bottom right subpencil of aS - bH.
C
C     STEP 2. Reorder the remaining M-MP+1 eigenvalues.
C
      DO 60 K = M, MP, -1
C
C        I. Exchange the eigenvalues between two diagonal blocks.
C
C        Perform eigenvalue exchange.
C
         CALL MB03GZ( A( M, M ), D( M, M ), C( M, M ), B( M, M ),
     $                F( M, M ), CO1, SI1, CO2, SI2 )
C
C        Update A, C, and D.
C
         CALL ZROT( M, D( 1, M ), 1, A( 1, M ), 1, CO1, SI1 )
         TMP = -DCONJG( SI1 )*C( M, M )
         C( M, M ) = CO1*C( M, M )
         CALL ZROT( M, D( M, 1 ), LDD, C( M, 1 ), LDC, CO2,
     $              -DCONJG( SI2 ) )
         A( M, M ) = CO2*A( M, M ) - DCONJG( SI2 )*TMP
C
C        Update B and F.
C
         TMP = -DCONJG( B( M, M ) )
         CALL ZROT( M, F( 1, M ), 1, B( 1, M ), 1, CO1, SI1 )
         B( M, M ) = B( M, M )*CO1 + TMP*DCONJG( SI1 )**2
         F( M, M ) = F( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
            CALL ZROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO1, SI1 )
         END IF
C
         IF( LCMPU ) THEN
C
C           Update U.
C
            CALL ZROT( M, U2( 1, M ), 1, U1( 1, M ), 1, CO2, SI2 )
         END IF
C
C        II. Move the eigenvalue in the M-th diagonal position to the
C            (MM+1)-th position.
C
         MM = MM + 1
         DO 50 J = M - 1, MM, -1
C
C           Perform eigenvalue exchange.
C
            HLP( 1, 1 ) = DCONJG( C( J, J ) )
            HLP( 1, 2 ) = DCONJG( C( J+1, J ) )
            HLP( 2, 2 ) = DCONJG( C( J+1, J+1 ) )
C
            CALL MB03CZ( HLP, 2, A( J, J ), LDA, B( J, J ), LDB, CO1,
     $                   SI1, CO2, SI2, CO3, SI3 )
C
C           Update A, C, and D.
C
            CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
            A( J, J )     = CO2*A( J, J ) +
     $                      SI2*A( J+1, J+1 )*DCONJG( SI1 )
            A( J+1, J+1 ) = CO1*A( J+1, J+1 )
            CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO2,
     $                 -SI2 )
C
            CALL ZROT( M, D( 1, J+1 ), 1, D( 1, J ), 1, CO3, SI3 )
            CALL ZROT( M, D( J, 1 ), LDD, D( J+1, 1 ), LDD, CO2, -SI2 )
C
            CALL ZROT( M-J, C( J+1, J+1 ), 1, C( J+1, J ), 1, CO3, SI3 )
            C( J+1, J+1 ) = CO2*C( J+1, J+1 ) +
     $                      SI3*C( J, J )*DCONJG( SI2 )
            C( J, J )     = CO3*C( J, J )
            CALL ZROT( J, C( J, 1 ), LDC, C( J+1, 1 ), LDC, CO2, -SI2 )
C
C           Update B and F.
C
            CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
            B( J, J )     = CO3*B( J, J ) +
     $                      SI3*B( J+1, J+1 )*DCONJG( SI1 )
            B( J+1, J+1 ) = CO1*B( J+1, J+1 )
            CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO3,
     $                 -SI3 )
C
            CJF = DCONJG( F( J, J+1 ) )
            TMP = CO3*CJF - DCONJG( SI3 )*F( J+1, J+1 )
            CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO3, SI3 )
            F( J, J )     = CO3*F( J, J )     - SI3*TMP
            F( J+1, J+1 ) = CO3*F( J+1, J+1 ) + SI3*CJF
            CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, CO3,
     $                 -SI3 )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL ZROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, SI1 )
               CALL ZROT( N, Q( 1, M+J+1 ), 1, Q( 1, M+J ), 1, CO3, SI3
     $                     )
            END IF
C
            IF( LCMPU ) THEN
C
C              Update U.
C
               CALL ZROT( M, U1( 1, J+1 ), 1, U1( 1, J ), 1, CO2, SI2 )
               CALL ZROT( M, U2( 1, J+1 ), 1, U2( 1, J ), 1, CO2, SI2 )
            END IF
   50    CONTINUE
   60 CONTINUE
C
      NEIG = MM
C
      RETURN
C *** Last line of MB03IZ ***
      END


*+ find_mfit

       subroutine find_mfit( nn, xd, yd, nc, cd, model, res, status )
C      --------------------------------------------------------------
C
C Perform the fitting
C
C Given:
C  number of data points
       integer    nn
C  input "x" and "y" data
       real*4     xd(*), yd(*)
C  number of user-specified constants
       integer    nc
C  user-supplied constants
       real*4     cd(*)
C  type of fitting model to use
       integer    model
C Returned:
C  results of the fit
       real*4     res(*)
C Updated:
C  return code
       integer    status
C
C Perform one of number of different fitting models:
C
C model   Fit-decription
C -------------------------------------------------------------------
C   1     y = res(1) exp( -x/res(2) )
C   2     y = res(1) [ 1 - exp( -x/res(2) ) ]
C   3     y = res(1) exp( -res(2) [cd(1) x**2 - cd(2) x**3] )
C   4     y = res(1) + res(2) x
C   5     y = res(1) + res(2) [ cd(1)x + cd(2)x**2 + cd(3)x**3 ]
C -------------------------------------------------------------------
C
C The fit is performed using a least-squares minimization using the
C NAG routine E04FDF.
C
C P.Alexander MRAO, 06/04/92
*-

C local variables
       integer     len_work, len_iwork
       parameter  (len_work=1000, len_iwork=100)
       real*8      xx(5), fsumsq, work(len_work)
       integer     iwork(len_iwork), nvar, istat

C counters etc.
       integer     n

C data passed in common to LSFUN1
       real*8      x(50), y(50), c(10)
       integer     itype, ndata, nconst
       common /local_fitr8/ x, y, c
       common /local_fiti4/ itype, ndata, nconst

       if (status.ne.0) return

C set itype
       if (model.le.0) then
         itype = 1
       else if (model.gt.5) then
         itype = 3
       else
         itype = model
       end if
C copy data
       ndata = nn
       nconst = nc
       do n=1,nn
         x(n) = xd(n)
         y(n) = yd(n)
       end do
       do n=1,nc
         c(n) = cd(n)
       end do

C call minimization routine
       nvar = 2
       istat = 1
       xx(1) = yd(1)
       xx(2) = xd(2) - xd(1)
       call e04fdf( ndata, nvar, xx, fsumsq,
     *              iwork, len_iwork, work, len_work, istat )
       do n=1,nvar
         res(n) = xx(n)
       end do
       res(nvar+1) = fsumsq
       end
C
C
       subroutine lsfun1( m, n, xx, f )
       integer    n, m, i
       real*8     xx(n), f(m)
C data passed in common to LSFUN1
       real*8      x(50), y(50), c(10)
       integer     itype, ndata, nconst
       common /local_fitr8/ x, y, c
       common /local_fiti4/ itype, ndata, nconst

       if (itype.eq.1) then
         do i = 1,ndata
           f(i) = xx(1)*exp(-x(i)/xx(2)) - y(i)
         end do
       elseif (itype.eq.2) then
         do i = 1,ndata
           f(i) = xx(1)*(1.0D+0 - exp(-x(i)/xx(2))) - y(i)
         end do
       elseif (itype.eq.3) then
         do i = 1,ndata
           f(i) = xx(1)*exp(-xx(2)*(c(1)*(x(i)**2)-c(2)*(x(i)**3) ))
     *            - y(i)
         end do
       elseif (itype.eq.4) then
         do i = 1,ndata
           f(i) = xx(1) + xx(2)*x(i) - y(i)
         end do
       elseif (itype.eq.5) then
         do i = 1,ndata
           f(i) = xx(1) +
     *            xx(2)*(c(1)*x(i) + c(2)*(x(i)**2) + c(3)*(x(i)**3))
     *            - y(i)
         end do
       endif
       end


      SUBROUTINE STCST (A, TCS, MODE, M, ND, MS, S)
c>> 1997-03-31 STCST Krogh  Increased KEDIM, more sine table checks.
c>> 1996-01-23 STCST Krogh  Changes to simplify conversion to C.
C>> 1994-11-11 STCST Krogh  Declared all vars.
c>> 1994-10-20 STCST Krogh  Changes to use M77CON
c>> 1989-06-16 STCST FTK Fix error message on MODE, and TCS.
c>> 1989-06-05 WVS Change length of MODE and TCS from (ND) to (*)
c>> 1989-05-08 FTK & CLL
c>> 1989-04-21 FTK & CLL
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c
c     This subroutine computes trigonometirc (sine-cosine), sine, or
c     cosine transforms of real data in up to 6 dimensions using the
c     Cooley-Tukey fast Fourier transform.
c
c     Variables in the calling sequence have the following types
      REAL             A(*), S(*)
      INTEGER   ND, M(ND), MS, KEDIM
      CHARACTER*(*) TCS, MODE
c
c     Programmed by Fred F. Krogh at the Jet Propulsion Laboratory,
c     Pasadena, Calif.   August 1, 1969.
c     Revised for portability by Krogh -- January 29, 1988
c
c     Values for A, TCS, MODE, M, ND, and MS must be specified before
c     calling the subroutine.
c
c     In describing the usage the following notation is used
c     N(K) = 2 ** M(K)
c     MA = M(1) + M(2) + ... + M(ND)
c     NA = 2 ** MA
c
c     MTCS(K) = M(K)     TCS(K:K) = 'T'
c             = M(K)+1   otherwise
c
c     MX = MAX(MTCS(1), MTCS(2), ..., MTCS(ND))
c     NX = 2 ** MX
c
c     T(L,j,k) is defined differently for different values of TCS(L)
c
c       if TCS(L:L) = 'T' and MODE(L:L) = 'S', T(L,j,k)
c         =1/2                     if k = 0
c         =(1/2)*(-1)**j           if k = 1
c         =COS(j*k*PI/N(L))        if k IS EVEN  (k = 2, 4, ..., N(L)-2)
c         =SIN(j*(k-1)*PI/N(L))    if k IS ODD   (k = 3, 5, ..., N(L)-1)
c                    and if MODE(L:L) = 'A', T(L,j,k)
c         = (4/N) * (value of T(L,k,j) defined above)   If j<2
c         = (2/N) * (value of T(L,k,j) defined above)   Otherwise
c
c       if TCS(L:L) = 'C' and MODE(L:L) = 'S', T(L,j,k)
c         =1/2                     if k = 0
c         =COS(j*k*PI/N(L))           k = 1, 2, ..., N(L)-1
c         =(1/2)*(-1)**j           if k = N(L)
c                    and if MODE(L:L) = 'A', T(L,j,k)
c         = (2/N) * (value of T(L,j,k) defined above)
c
c       if TCS(L:L) = 'S' and MODE(L:L) = 'S', T(L,j,k)
c         =SIN(j*k*PI/N(L))           k = 0, 1, ..., N(L)-1
c                    and if MODE(L:L) = 'A', T(L,j,k)
c         = (2/N) * (value of T(L,j,k) defined above)
c
c     D(L) = N(L)     if TCS(L:L) .ne. 'C'
c          = N(L)+1   if TCS(L:L) = 'C'
c
c     The usage is as follows
c
c A() on input is an array of function values if one is doing Fourier
c   analysis, and is an array of Fourier coefficients if one is doing
c   Fourier synthesis.  On output, these are reversed.  In either case
c   A() is a real array with dimension A(D(1), D(2), ..., D(ND)).
c
c TCS  is a character variable of length ND.  The k-th character must be
c   'T' or 't' to select the general Trigonometric transform, or
c   'C' or 'c' to select the Cosine transform, or
c   'S' or 's' to select the Sine transform.
c     See the description of T(L,j,k) and M above.
c
c MODE  A character variable of length ND.  The k-th character must be
c   'A' or 'a' to select Analysis in the k-th dimension, or
c   'S' or 's' to select Synthesis in the k-th dimension.
c   One may be doing analysis, MODE(k:k) = 'A', with respect to one
c   dimension and synthesis, MODE(k:k) = 'S', with respect to
c   another.  A(j1+1, j2+1, ..., jND+1) is replaced by the sum over
c   0 .le. k1 .le. D(1)-1, 0 .le. k2 .le. D(2)-1, ..., 0 .le. kND .le.
c   D(ND)-1, of A(k1+1, k2+1, ..., kND+1) * T(1, k1, j1) * T(2, k2, j2)
c   ... * T(ND, kND, jND), 0 .le. j1 .le. D(1)-1, ..., 0 .le. jND .le.
c   D(ND)-1.

c M() is a vector used to indicate N(k) = 2**M(k)).  The number of
c   points in the k-th variable is then given by D(k) (see above).  M
c   must be specified in such a way that 0 < M(k) < 22
c   for k = 1, 2, ..., ND.
c
c ND is the dimension of (i.e. the number of subscripts in) the
c    array A.  ND must satisfy 1 .le. ND .le. 6.
c
c MS gives the state of the sine table.  If MS > 0, there are NT =
c    2 ** (MS-2) good entries in the sine table.  On the initial call,
c    MS must be set to 0, and when the return is made, it will be set
c    to MX, which is the value of MS required for computing a
c    transform of size N.  If MS = -1, the sine table will be computed
c    as for the case MS = 0, and then a return to the user will be made
c    with MS set as before, but no transform will be computed.  This
c    option is useful if the user would like access to the sine table
c    before computing the FFT.
c    On detected errors the error message subrs are called and
c    execution stops.  If the user overrides the stop to cause
c    continuation, then this subr will return with MS = -2.
c
c S() is a vector, S(j) = sin(pi*j/2*NT)), j = 1, 2, ..., NT-1, where
c  NT is defined in the description of MS above.  S is computed by the
c  subroutine if MX .gt. MS.  (If S is altered, set MS=0 so that S
c  is recomputed.)
c     -----------------------------------------------------------------
c                Notes on COMMON, PARAMETER's, and local variables
c
c     NDMAX = the maximum value for ND, and MAXMX = the maximum
c     permitted for MTCS(1), ..., MTCS(ND)
c
c     NF(1) = 1, NF(K+1) = NF(K) * D(K) K = 1, 2, ..., ND
c
c     MU is used in the process of eliminating transforms with respect
c     to the first subscript of transforms with TCS(:) = 'S'.
c     (This is only necessary if ND.GT.1.)
c
c     The dimension of KE must be at least as large as MAXMX-1.
c     The named common CSFFTC is used for communication between this
c     subroutine and the subroutine SFFT which computes a one
c     dimensional complex Fourier transform and computes the sine table.
c     The use of the variables in CSFFTC is contained in the listing
c     of SFFT.
c
c     The input character variable TCS is mapped to the internal
c     integer array ITCS() by mapping 'T' to 1, 'C' to 2, 'S' to 3.
c
c     -----------------------------------------------------------------
c--S replaces "?": ?TCST, ?FFT, C?FFTC
c     Both versions use IERM1
c     and need ERFIN, IERV1
c     -----------------------------------------------------------------
      INTEGER MAXMX, NDMAX
      PARAMETER (NDMAX = 6)

      INTEGER I, I1, II, IR, ITCS(NDMAX), ITCSK
      INTEGER J, JDIF, JJ, JK
      INTEGER K, KDR
      INTEGER KII, KIN, KK, KKI, KKL, KKN
      INTEGER L
      INTEGER MA, MI, MMAX, MSI, MU(NDMAX)
      INTEGER N, NDD, NDIV, NF(NDMAX+1)
      INTEGER NI, NI1, NI2, NI2I, NTOT2

      CHARACTER  MSG1*13, MSG2*12

      REAL             FN, FOUR, ONE
      REAL             SPI4, SUM, T, T1, TP, TPI, TS, TS1, TWO
      REAL             WI, WR, ZERO

      PARAMETER (ZERO = 0.0E0)
      PARAMETER (ONE = 1.0E0)
      PARAMETER (TWO = 2.0E0)
      PARAMETER (FOUR = 4.0E0)
      PARAMETER (SPI4 = .70710 67811 86547 52440 08443 62104 8490E0)
c Common variables
      PARAMETER (KEDIM=30)
      LOGICAL NEEDST
      INTEGER MT, NT, MM, KS, ILAST, KE(KEDIM), KEE(KEDIM+1)
c Note that KEE(1) is equivalent to ILAST.
      EQUIVALENCE (KE(1), KEE(2))
      COMMON /CSFFTC/ NEEDST, MT, NT, MM, KS, ILAST, KE
      SAVE /CSFFTC/
      PARAMETER (MAXMX = KEDIM+1)
      DATA MSG1 / 'MODE(K:K) = ?' /
      DATA MSG2 / 'TCS(K:K) = ?' /
c     -----------------------------------------------------------------
c
      NDD = ND
      IF ((NDD .LE. 0) .OR. (NDD .GT. NDMAX)) THEN
C                               FATAL ERROR, DEFAULT IS TO STOP IN IERM1
         CALL IERM1 ('STCST', 1, 2, 'BAD ND', 'ND', ND, '.')
         MS = -2
         RETURN
      END IF
      MA = 0
      MMAX = 0
      NDIV = 1
c Every element in the array A is divided by NDIV before computing
c the transform.  The value computed for NDIV depends on whether
c one is doing analysis or synthesis and on the type of
c transform being computed.
      DO 10 K = 1, NDD
         MM = M(K)
         IF ((MM .LT. 0) .OR. (MM .GT. MAXMX)) GO TO 200
         MA = MA + MM
         N = 2 ** MM
         IF (MODE(K:K) .eq. 'A' .or. MODE(K:K) .eq. 'a') THEN
            NDIV = NDIV * N
         ELSE IF (MODE(K:K) .eq. 'S' .or. MODE(K:K) .eq. 's') THEN
            NDIV = 2 * NDIV
         else
            MSG1(13:13) = MODE(K:K)
            CALL IERM1 ('STCST',2,2, MSG1, 'for K =',  K, '.')
            MS = -2
            return
         END IF
         ITCSK = (index('TtCcSs', TCS(K:K)) + 1) / 2
         ITCS(K) = ITCSK
         if(ITCSK .eq. 0) then
            MSG2(12:12) = TCS(K:K)
            CALL IERM1 ('STCST', 3, 2, MSG2, 'for K =', K, '.')
            return
         endif
         NF(1) = 1
         IF (ITCSK .GE. 2) THEN
            IF (ITCSK .EQ. 2) N = N + 1
            NDIV = 2 * NDIV
            MM = MM + 1
         END IF
         NF(K+1) = NF(K) * N
         IF (MM .GT. MMAX) THEN
            MMAX = MM
         END IF
   10 CONTINUE
c
      MSI = MS
      NEEDST = MMAX .GT. MSI

      if (.NOT. NEEDST) then
c  Check internal parameters to catch certain user errors.
         if (MT .lt. KEDIM) then
            if (MMAX .le. MT + 2) then
c              Skip sine table computation if all appears O.K.
               if (MT .le. 0) go to 15
               if (abs(S(NT/2) - SPI4) .le. 1.E-7) go to 15
            end if
         end if
         NEEDST = .true.
         call ERMSG('STCST', 3, 1,
     1      'Invalid sine table (re)computed', '.')
      end if
      MS = MMAX
      MT = MMAX - 2
      CALL SFFT (A, A, S)
      IF (MSI .EQ. -1) RETURN
c                   All setup for computation now
   15 NTOT2 = NF(NDD+1)
c
      FN = ONE / REAL(NDIV)
c     Divide every element of A by NDIV
      DO 20 I = 1, NTOT2
         A(I) = A(I) * FN
   20 CONTINUE
c
c     Beginning of loop for computing multiple sum
      DO 170 K = 1, NDD
         ITCSK = ITCS(K)
         MI = M(K)
         MM = MI - 1
         if(MODE(K:K) .eq. 'A' .or. MODE(K:K) .eq. 'a') MI = -MI
         KDR = NF(K)
         KS = KDR + KDR
         ILAST = NF(K+1)
         IF (ITCSK .EQ. 2) ILAST = ILAST - KDR
         DO 30 L = 1, MM
            KEE(L+1) = KEE(L) / 2
   30    CONTINUE
c
         I = 1
         J = NDD
   40    DO 50 L = 1, J
            MU(L) = 0
            IF ((L .NE. K) .AND. (ITCS(L) .GT. 2)) THEN
c           Skip the part of the array left empty by the sine transform
               MU(L) = NF(L)
               I = I + NF(L)
            END IF
   50    CONTINUE
c
c        Compute indices associated with the current value of I (and K)
   60    I1 = I + KDR
         NI1 = I + NF(K+1)
         IF (ITCSK .EQ. 2) NI1 = NI1 - KDR
         NI = NI1 - KDR
         NI2 = (NI1 + I) / 2
         NI2I = NI2 + KDR
         IF (ITCSK .NE. 1) THEN
c                Doing a cosine or a sine transform -- set MI = 0 and do
c                calculations not required for sine-cosine transforms
            MI = 0
            J = NI
            SUM = A(I1)
            T = A(J)
   70       JK = J - KS
               IF (JK .GE.I1) THEN
                  SUM = SUM + A(J)
                  A(J) = A(JK) - A(J)
                  J = JK
                  GO TO 70
               END IF
            IF (ITCSK .NE. 2) THEN
c                                Calculations for the sine transform
               A(I) = TWO * A(I1)
               A(I1) = -TWO * T
               IF (MM.EQ.0) GO TO 90
               T = TWO * A(NI2)
               A(NI2) = -TWO * A(NI2I)
               A(NI2I) = T
               GO TO 90
            END IF
c                               Set for cosine transform
            A(I1) = A(NI1)
         END IF
         IF (MM.EQ.0) GO TO 90
         if (MI .lt. 0) go to 160
c        Begin calculations for the sine-cosine transform
   80    A(NI2) = TWO * A(NI2)
         A(NI2I) = TWO * A(NI2I)
   90    T = A(I) + A(I1)
         A(I1) = A(I) - A(I1)
         IF (MI .LT. 0) THEN
            IF (ITCSK .EQ. 1) THEN
               A(I1) = TWO * A(I1)
               T = TWO * T
            END IF
         END IF
         A(I) = T
         J = 0
         JDIF = 2 ** (MT - MM + 1)
         KKL = KE(1) - KDR
         IF (MM .GT. 1) THEN
            DO 100 KK = KS, KKL, KS
               KKI = I + KK
               KII = KKI + KDR
               KKN = NI1 - KK
               KIN = KKN + KDR
               J = J + JDIF
               WI = S(J)
               JJ = NT - J
               WR = S(JJ)
               T = A(KKI) + A(KKN)
               TS = A(KKN) - A(KKI)
               T1 = A(KIN) - A(KII)
               TS1 = A(KIN) + A(KII)
               IF (ITCSK .GT. 2) THEN
c                         The sine-cosine transform must be computed
c                         differently in the case of the sine transform
c                         because the input data is stored differently.
                  TP = WR * T - WI * T1
                  TPI = WI * T + WR * T1
                  A(KKI) = TP - TS1
                  A(KKN) = -TP - TS1
                  A(KII) = TPI + TS
                  A(KIN) = TPI - TS
               ELSE
                  TP = WR * TS1 + WI * TS
                  TPI = WI * TS1 - WR * TS
                  A(KKI) = T + TP
                  A(KKN) = T - TP
                  A(KII) = T1 + TPI
                  A(KIN) = TPI - T1
               END IF
  100       CONTINUE
         ELSE IF (MM .EQ. 0) THEN
            GO TO 120
         END IF
c        End of computing sine-cosine transform
c
         IF (MI .LT. 0) GO TO 140
         IR = I
         II = IR + KDR
c
c        Compute a one-dimensional complex Fourier transform
  110    CALL SFFT (A(IR), A(II), S)
         IF (MI .LT. 0) GO TO 80
         IF (MI .NE. 0) GO TO 140
  120    IF (ITCSK .EQ. 1) GO TO 140
         IF (ITCSK .EQ. 3) THEN
            A(I) = ZERO
         ELSE
c                Compute first and last elements of the cosine transform
            SUM = FOUR * SUM
            T = TWO * A(I)
            A(NI1) = T - SUM
            A(I) = T + SUM
            IF (MM.GE.0) A(NI2) = TWO * A(NI2)
         END IF
         IF (MM .GT. 0) THEN
c               Extra calculations required by sine and cosine transform
            J = 0
            JDIF = JDIF / 2
            DO 130 KK = KDR, KKL, KDR
               KKI = I + KK
               KKN = NI1 - KK
               J = J + JDIF
               WI = TWO * S(J)
               T = A(KKI) + A(KKN)
               TS = A(KKI) - A(KKN)
               IF (ITCSK .NE. 2) THEN
                  T = T / WI
               ELSE
                  TS = TS / WI
               END IF
               A(KKI) = T + TS
               A(KKN) = T - TS
  130       CONTINUE
         END IF
c
c        Logic for deciding which one-dimensional transform to do next
  140    J = 0
  150    J = J + 1
            IF (J .EQ. K) THEN
               J = J + 1
               I = I + NF(J) - NF(J-1)
            END IF
            IF (J.GT.NDD) GO TO 170
            MU(J) = MU(J) + NF(J)
            IF (MU(J).GE.NF(J+1)) GO TO 150
         I = I + NF(1)
         J = J - 1
         IF (J .NE. 0) GO TO 40
         GO TO 60
c
c        Set for Fourier analysis
  160    II = I
         IR = II + KDR
         GO TO 110
c
  170 CONTINUE
c     End of K loop
      RETURN
c
c                               Fatal error, default is to stop in IERM1
  200 CALL IERM1 ('STCST', 4, 2, 'Require 0 .le. max(M(K)) .le. 31',
     1  'M', MM, '.')
      MS = -2
      RETURN
c
      END


! ==========================================================================
!
! Basic VMC/DMC code for educational purposes.
! This file: system-specific subroutines for He atom (parahelium = spin
! singlet), it is good for any helium-like ion, for instance H^-
!
! Copyright (C) 2012 Jindrich Kolorenc
!
! The software is released under MIT/X11 license.
!
! ==========================================================================

! Trial wave function:
! Hylleraas-type ansatz with a single variational parameter 'a'. The wave
! function fulfills electron-ion as well as electron-electron cusp conditions.
!
! \begin{equation}
! \Psi_\text{T}(\mathbf r_1,\mathbf r_2)
! =\biggl(1+\frac12 r_{12}\biggr)\Bigl[1+a\bigl(r_1^2+r_2^2\bigr)\Bigr]
!   \,\rme^{-Z(r_1+r_2)}
! \end{equation}
!
! The total energy can be calculated analytically. The optimal value of the
! variational parameter is a=0.0878628 and gives the energy -2.89537.

! Hartree-Fock limit: -2.8617
! [Donald Allan McQuarrie, John Douglas Simon: "Physical chemistry: a molecular
! approach", p. 283]

! Exact energy: -2.903724
! [C. Schwartz, Int. J. Mod. Phys. E 15, 877 (2006)] also available as
! [arXiv:physics/0208004v1]

module qmc_input
  use types_const, only: dp, finish_line
  implicit none
  private

  public :: sys_dim
  public :: t_walker, t_sys
  public :: init_sys
  public :: EL_drift, psiT2

  ! logically, this should go to t_sys, but I really want to keep static arrays
  ! in t_walker, which enforces 'sys_dim' to be a global constant
  integer, parameter :: sys_dim=6       ! dimension of walker

  type t_walker
     real(dp), dimension(sys_dim) :: r  ! position
     real(dp), dimension(sys_dim) :: vD ! drift velocity
     real(dp) :: EL                     ! local energy
     real(dp) :: psiTsq                 ! square of trial wavefunction
     real(dp) :: wt=1.0_dp              ! DMC weight
     integer :: sgn=1                   ! sign of trial wavefunction at r
     integer :: age=0                   ! how many times rejected by det. bal.
  end type t_walker

  type t_sys
     ! identification of the system
     character(36) :: id="parahelium (Hylleraas wave function)"

     ! nuclear charge
     real(dp) :: Znuc=2.0_dp

     ! parameter in the Hylleraas ansatz
     ! a=4*(-123371.0_dp+sqrt(32098719641.0_dp))/2539875.0_dp for Znuc=2
     ! a=2*(-685.0_dp+3*sqrt(153862015.0_dp))/800167.0_dp for Znuc=1
     real(dp) :: a=0.08786283656089399052453400224163986218292_dp !Znuc=2
  end type t_sys

contains

  subroutine init_sys(sys,words)
    ! {{{ initialize the system and wave-function parameters
    use cfparser, only: t_words, readsection, readvalue, clear
    type(t_sys), intent(inout) :: sys
    type(t_words), intent(in) :: words
    type(t_words) :: syswords
    logical :: Znuc_given, a_given
    real(dp) :: Znuc, Etot

    ! read the parameters of the system and the trial wave function from the
    ! configuration file
    Znuc_given=.false.
    a_given=.false.
    if ( readsection(words,syswords,"system") ) then
       Znuc_given=readvalue(syswords,sys%Znuc,"Znuc")
       a_given=readvalue(syswords,sys%a,"a")
    end if
    call clear(syswords)

    ! set helium (Z=2) if the nuclear charge is not given
    if ( .not.Znuc_given ) sys%Znuc=2.0_dp

    ! if the variational parameter a is not given then use the optimal value
    Znuc=sys%Znuc
    if ( .not.a_given ) then
       !sys%Z1=Znuc-5.0_dp/16.0_dp
       sys%a=(2*(Znuc**2*(18105 -                &
                 2*Znuc*(-18912 +                &
                    Znuc*(-1848 + Znuc*(16329 + 8*Znuc*(1301 + 256*Znuc))) &
                    )) + sqrt(Znuc**4*           &
                (128388465 +                     &
                  2*Znuc*(327330432 +            &
                     Znuc*(667667520 +           &
                        Znuc*(730902672 +        &
                           Znuc*                 &
                            (733280304 +         &
                             Znuc*               &
                             (1064874760 +       &
                             Znuc*               &
                             (1264584679 +       &
                             16*Znuc*            &
                             (56671967 +         &
                             8*Znuc*             &
                             (2950393 + 512*Znuc*(1309 + 128*Znuc))) &
                             ))))))))))/         &
          (3.0_dp*(-98910 + Znuc*(-43776 +           &
                    Znuc*(304160 + Znuc*(413413 + 4096*Znuc*(47 + 8*Znuc))))) &
          )
    end if

    ! analytically calculated total energy
    Etot=(Znuc*(-8*sys%a*Znuc**2*(-567 + 32*Znuc*(27 + 8*Znuc*(7 + 3*Znuc))) - &
            8*Znuc**4*(-35 + 4*Znuc*(4 + Znuc*(25 + 16*Znuc))) -               &
            3*sys%a**2*(-10065 + 4*Znuc*(4992 + Znuc*(6903 + 2176*Znuc)))))/   &
         (4.0_dp*(8*Znuc**4*(24 + Znuc*(35 + 16*Znuc)) +     &
            24*sys%a*Znuc**2*(168 + Znuc*(189 + 64*Znuc)) +  &
            9*sys%a**2*(3680 + Znuc*(3355 + 896*Znuc))))

    ! output the settings to STDOUT
    write(unit=*,fmt='(1x,a)') "system and trial wave function:"
    write(unit=*,fmt='(3x,a)') sys%id

    write(unit=*,fmt='(3x,a,f12.8)',advance="no") &
            "nuclear charge                 [Znuc]:", sys%Znuc
    call finish_line(Znuc_given,"(default)")

    write(unit=*,fmt='(3x,a,f12.8)',advance="no") &
            "parameter in the wave function [a]   :", sys%a
    call finish_line(a_given,"(the optimal value)")

    write(unit=*,fmt='(3x,a,f12.8)') &
            "analytically computed total energy   :", Etot

    write(unit=*,fmt=*)
    ! }}}
  end subroutine init_sys

  ! ===========================================================================
  ! wave function of the Hylleraas form, cusps fullfiled; there is only a
  ! single variational parameter and hence the energy is no miracle, but it is
  ! possible to analytically optimize this single parameter from start to
  ! finish (although it is tedious for sure);
  ! see [Hylleraas, Z. Phys. 54, 347 (1929)] but he does not care about cusps
  ! (English translation is in the Hettema's book)
  ! ===========================================================================

  pure subroutine EL_drift(sys,wlkr)
    ! {{{ local energy, drift velocity, wave function squared
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    real(dp), dimension(3) :: r1, r2, r12
    real(dp) :: u, v, w, u2, v2, w2, v2_w2, vw, twouvw, vDu, vDv, vDw, Xa, u_2
    r1=wlkr%r(1:3)
    r2=wlkr%r(4:6)
    v2=sum(r1**2)
    w2=sum(r2**2)
    r12=r1-r2
    u2=sum(r12**2)
    u=sqrt(u2)
    v=sqrt(v2)
    w=sqrt(w2)
    v2_w2=v2+w2
    vw=v*w
    twouvw=2.0_dp*u*vw
    Xa=1.0_dp + sys%a*v2_w2
    u_2=u+2.0_dp
    wlkr%PsiTsq=(u_2**2*Xa**2)/(4.0_dp*exp(2.0_dp*(v + w)*sys%Znuc))
    wlkr%EL=(twouvw*(Xa + sys%a*(-12.0_dp - 8.0_dp*u)) + &
         (v + w)*(4.0_dp*sys%a*twouvw - (v - w)**2*Xa + &
            u2*(Xa + sys%a*4.0_dp*vw))*sys%Znuc)/(u_2*twouvw*Xa) - &
         sys%Znuc**2
    vDu=1.0_dp/(u_2*u)
    vDv=2.0_dp*sys%a/Xa
    vDw=vDv-sys%Znuc/w
    vDv=vDv-sys%Znuc/v
    wlkr%vD(1:3)=vDu*r12
    wlkr%vD(4:6)=vDw*r2-wlkr%vD(1:3)
    wlkr%vD(1:3)=vDv*r1+wlkr%vD(1:3)
    ! }}}
  end subroutine EL_drift

  pure subroutine psiT2(sys,wlkr)
    ! {{{ trial wave function squared
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    real(dp), dimension(3) :: r1, r2, r12
    real(dp) :: u, v, w, u2, v2, w2, v2_w2
    r1=wlkr%r(1:3)
    r2=wlkr%r(4:6)
    v2=sum(r1**2)
    w2=sum(r2**2)
    r12=r1-r2
    u2=sum(r12**2)
    u=sqrt(u2)
    v=sqrt(v2)
    w=sqrt(w2)
    v2_w2=v2+w2
    wlkr%PsiTsq=((2.0_dp + u)**2*(1.0_dp + sys%a*v2_w2)**2)/(4.0_dp*exp(2.0_dp*(v + w)*sys%Znuc))
    ! }}}
  end subroutine PsiT2

end module qmc_input

! Local variables:
! folded-file: t
! End:


C
C      **********************************************************************
C      ********************** SUBROUTINE BHK  *******************************
C      **********************************************************************
C
       SUBROUTINE BHK(IND,X,Y,NTOT,Z,PROB,TAU,IAA,IBB)
C
C      *             GENERALIZED KENDALL'S TAU CORRELATION COEFFICIENT      *
C      *                         FOR CENSORED DATA                          *
C
C      *      THIS PROGRAM COMPUTES KENDALL'S TAU FOR BIVARIATE DATA        *
C      *      SETS. THE DATA SETS CAN CONTAIN CENSORED POINTS IN THE        *
C      *      INDEPENDENT VARIABLE AND/OR THE DEPENDENT VARIABLE.           *
C      *      ALTHOUGH THIS PROGRAM GIVES ANSWERS FOR DATA SETS WHICH       *
C      *      CONTAIN TIES, IT MAY NOT BE ACCURATE.                         *
C      *    PARAMETERS :                                                    *
C      *     INPUT                                                          *
C      *     NTOT          : NUMBER OF OBSERVATIONS                         *
C      *     X(I)          : INDEPENDENT PARAMETER OF I-TH OBSERVATION      *
C      *     Y(I)          : DEPENDENT PARAMETER OF I-TH OBSERVATION        *
C      *     IND(I)        : INDICATOR OF CENSORED STATUS                   *
C      *      EACH POINT MUST BE SPECIFIED ITS CENSORED STATUS :            *
C      *        FOR THE LOWER LIMITS                                        *
C      *                0   :   DETECTED POINT                              *
C      *                1   :   ONLY DEPENDENT VARIABLE IS LOWER LIMIT      *
C      *                2   :   ONLY INDEPENDENT VARIABLE IS LOWER LIMIT    *
C      *                3   :   BOTH VARIABLES ARE LOWER LIMIT              *
C      *                4   :   INDEPENDENT VARIABLE IS LOWER LIMIT AND     *
C      *                        DEPENDENT VARIABLE IS UPPER LIMIT           *
C      *      FOR THE UPPER LIMITS, CHANGE THE SIGN OF ABOVE INDICATORS.    *
C      *                                                                    *
C      *     WORK                                                           *
C      *     IAA(I)         : CONCORDANCE INFORMATION FOR X                 *
C      *     IBB(I)         : CONCORDANCE INFORMATION FOR Y                 *
C      *                                                                    *
C      *     OUTPUT                                                         *
C      *     Z             : Z-VALUE                                        *
C      *     PROB          : SIGNIFICANCE LEVEL FOR THE HYPOTHESIS THAT     *
C      *                     X AND Y ARE NOT CORRELATED UNDER THE           *
C      *                     GAUSSIAN DISTRIBUTION                          *
C      *     TAU           : TAU; USE CRC STATISTICAL TABLES TO INTERPRET   *
C      *                                                                    *
C      *     SUBROUTINES                                                    *
C      *               CENS, COEFF                                          *
C      *                                                                    *
C      *      REF. BROWN, HOLLANDER, AND KORWAR 1974, IN RELIABILITY        *
C      *           AND BIOMETRY P.327, EQNS 1 TO 8, PROSCHAN AND            *
C      *           SERFLING EDS (SIAM)                                      *
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)

       DIMENSION X(NTOT),Y(NTOT),IND(NTOT)
       DIMENSION IAA(NTOT),IBB(NTOT)
C
       SIS =0.0
       ASUM =0.0
       BSUM =0.0
       AASUM=0.0
       BBSUM=0.0
C
C
C      *      THE SUBROUTINE CENS ADDS OR SUBTRACTS A SMALL NUMBER          *
C      *      FROM EACH CENSORED POINT SO THAT NO TIES WITH DETECTED        *
C      *      POINTS OCCUR.                                                 *
C
C
       CALL CENS(X,Y,IND,NTOT)
C
C
C      *      START MAKING INFORMATION FOR CONCORDANCE                      *
C
C
       DO 1900 I=1,NTOT
C
C      *      INFORMATION OF CONCORDANCE  FOR THE INDEPENDENT VAR.          *
C
          IA=2
          IB=3
          IC=4
          ID=-2
          IE=-3
          IG=-4
          IH=1
          IJ=-1
C
C      *       SUBROUTINE WHICH FINDS CONCORDANCE INFORMATION               *
C
          CALL COEFF(I,X,IND,NTOT,IAA,IA,IB,IC,ID,IE,IG,IH,IJ)
C
C      *       INFORMATION OF CONCORDANCE FOR THE DEPENDENT VAR.            *
C
          IA=1
          IB=3
          IC=-4
          ID=-1
          IE=-3
          IG=4
          IH=2
          IJ=-2

          CALL COEFF(I,Y,IND,NTOT,IBB,IA,IB,IC,ID,IE,IG,IH,IJ)
C
C      *        START COMPUTING QUANTITIES IS, IASUM, IBSUM,                *
C      *        IAASUM, AND IBBSUM.                                         *
C
          DO 1800 J=1,NTOT
             IF((IAA(J).EQ.0).AND.(IBB(J).EQ.0)) GOTO 1800
             SIS=SIS+IAA(J)*IBB(J)
             ASUM=ASUM+IAA(J)**2
             BSUM=BSUM+IBB(J)**2

 1650        DO 1700 K=1,NTOT
                IF(IAA(J).NE.0) THEN
                   IF(IAA(K).NE.0) THEN
                      AASUM=AASUM+IAA(J)*IAA(K)
                   ENDIF
                ENDIF
 1670           IF(IBB(J).NE.0) THEN
                   IF(IBB(K).NE.0) THEN
                      BBSUM=BBSUM+IBB(J)*IBB(K)
                   ENDIF
                ENDIF
 1700        CONTINUE
 1800     CONTINUE
 1900  CONTINUE
C
C      *    NOW COMPUTE THE STATISTIC AND THE PROBABILITY                   *
C
       D1=NTOT*(NTOT-1)
       D2=D1*(NTOT-2)
       TAU=2.0*SIS/D1
       ALP=2.0*(ASUM*BSUM)/D1
       GAM=4.0*((AASUM-ASUM)*(BBSUM-BSUM))/D2
       VAR=ALP+GAM
       SIGMA=DSQRT(VAR)
       Z=SIS/SIGMA
       PROB=1.0-AGAUSS(Z)
C
       RETURN
       END


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_full2eig( n, A, U, lam )

!  A is an n x n PSD matrix with eigen-decomposition:
!  A = U * lam^2 * U^T.  This routine returns U and lam.

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: a(n,n)
real(k_dp), intent(out) :: u(n,n), lam(n)

real(k_dp) :: vt(n,n), work(5*n*n+20*n)
integer    :: lwork, info, i

lwork = 5*n*n+20*n

vt = a
call dgesvd( 'A', 'N', n, n, vt, n, lam, u, n, vt, n, work, lwork, info)

if( info /= 0 ) then
   write(0,*)'ell_full2eig: info, lwork, work(1) = ', info, lwork, work(1)
   stop
endif

do i = 1, n
   lam(i) = sqrt( lam(i) )
end do

return
end subroutine ell_full2eig


subroutine smear01(drsq, pol12, a, ts0, ts1)
implicit none
double precision, parameter :: g23=1.3541179394264d0
double precision, intent(in) :: drsq, pol12, a
double precision, intent(out) :: ts0, ts1
double precision :: dd,dri,drsqi,AA, rA,rA3,exp1, a_sqrt3
double precision, external :: gammq

dd = dsqrt(drsq)
dri = 1.d0/dd
drsqi = dri*dri

AA = (pol12)**(1.d0/6.d0)
rA = dd/AA
rA3 = rA**3
exp1 = dexp(-a*rA3)
a_sqrt3 = a**(1.d0/3.d0)

ts0 = (1.d0-exp1 + a_sqrt3*rA*g23*gammq(2.d0/3.d0,a*ra3))*dri
ts1 = (1.d0 -exp1)*dri*drsqi
end subroutine smear01
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine smear1(drsq, pol12, a, ts1)
implicit none
double precision, intent(in) :: drsq, pol12, a
double precision, intent(out) :: ts1
double precision :: dd,dri,drsqi,AA, rA,rA3,exp1
double precision, external :: gammq

dd = dsqrt(drsq)
dri = 1.d0/dd
drsqi = dri*dri

AA = (pol12)**(1.d0/6.d0)
rA = dd/AA
rA3 = rA**3
exp1 = dexp(-a*rA3)
ts1 = (1.d0 -exp1)*dri*drsqi
end subroutine smear1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine smear2(drsq, pol12, a, ts1, ts2)
implicit none
double precision, intent(in) :: drsq, pol12, a
double precision, intent(out) :: ts1, ts2
double precision :: dd,dri,drsqi,AA, rA,rA3,exp1

dd = dsqrt(drsq)
dri = 1.d0/dd
drsqi = dri*dri

AA = (pol12)**(1.d0/6.d0)
rA = dd/AA
rA3 = rA**3
exp1 = dexp(-a*rA3)
ts1 = (1.d0 -exp1)*dri*drsqi
ts2 = (ts1 - exp1*a/AA**3) *drsqi
end subroutine smear2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine smear3(drsq, pol12, a, ts1, ts2, ts3)
implicit none
double precision, intent(in) :: drsq, pol12, a
double precision, intent(out) :: ts1, ts2, ts3
double precision :: dd,dri,drsqi,AA, rA,rA3,exp1

dd = dsqrt(drsq)
dri = 1.d0/dd
drsqi = dri*dri

AA = (pol12)**(1.d0/6.d0)
rA = dd/AA
rA3 = rA**3
exp1 = dexp(-a*rA3)
ts1 = (1.d0 -exp1)*dri*drsqi
ts2 = (ts1 - exp1*a/AA**3) *drsqi
ts3 = (ts2 - 0.6d0*exp1*dd*a*a/AA**6) * drsqi

end subroutine smear3


! { dg-do run }

! Type-bound procedures
! Check they can actually be called and run correctly.
! This also checks for correct module save/restore.

! FIXME: Check that calls to inherited bindings work once CLASS allows that.

MODULE m
  IMPLICIT NONE

  TYPE mynum
    REAL :: num_real
    INTEGER :: num_int
  CONTAINS
    PROCEDURE, PASS, PRIVATE :: add_mynum ! Check that this may be PRIVATE.
    PROCEDURE, PASS :: add_int
    PROCEDURE, PASS :: add_real
    PROCEDURE, PASS :: assign_int
    PROCEDURE, PASS :: assign_real
    PROCEDURE, PASS(from) :: assign_to_int
    PROCEDURE, PASS(from) :: assign_to_real
    PROCEDURE, PASS :: get_all

    GENERIC :: OPERATOR(+) => add_mynum, add_int, add_real
    GENERIC :: OPERATOR(.GET.) => get_all
    GENERIC :: ASSIGNMENT(=) => assign_int, assign_real, &
                                assign_to_int, assign_to_real
  END TYPE mynum

CONTAINS

  TYPE(mynum) FUNCTION add_mynum (a, b)
    CLASS(mynum), INTENT(IN) :: a, b
    add_mynum = mynum (a%num_real + b%num_real, a%num_int + b%num_int)
  END FUNCTION add_mynum

  TYPE(mynum) FUNCTION add_int (a, b)
    CLASS(mynum), INTENT(IN) :: a
    INTEGER, INTENT(IN) :: b
    add_int = mynum (a%num_real, a%num_int + b)
  END FUNCTION add_int

  TYPE(mynum) FUNCTION add_real (a, b)
    CLASS(mynum), INTENT(IN) :: a
    REAL, INTENT(IN) :: b
    add_real = mynum (a%num_real + b, a%num_int)
  END FUNCTION add_real

  REAL FUNCTION get_all (me)
    CLASS(mynum), INTENT(IN) :: me
    get_all = me%num_real + me%num_int
  END FUNCTION get_all

  SUBROUTINE assign_real (dest, from)
    CLASS(mynum), INTENT(INOUT) :: dest
    REAL, INTENT(IN) :: from
    dest%num_real = from
  END SUBROUTINE assign_real

  SUBROUTINE assign_int (dest, from)
    CLASS(mynum), INTENT(INOUT) :: dest
    INTEGER, INTENT(IN) :: from
    dest%num_int = from
  END SUBROUTINE assign_int

  SUBROUTINE assign_to_real (dest, from)
    REAL, INTENT(OUT) :: dest
    CLASS(mynum), INTENT(IN) :: from
    dest = from%num_real
  END SUBROUTINE assign_to_real

  SUBROUTINE assign_to_int (dest, from)
    INTEGER, INTENT(OUT) :: dest
    CLASS(mynum), INTENT(IN) :: from
    dest = from%num_int
  END SUBROUTINE assign_to_int

  ! Test it works basically within the module.
  SUBROUTINE check_in_module ()
    IMPLICIT NONE
    TYPE(mynum) :: num

    num = mynum (1.0, 2)
    num = num + 7
    IF (num%num_real /= 1.0 .OR. num%num_int /= 9) CALL abort ()
  END SUBROUTINE check_in_module

END MODULE m

! Here we see it also works for use-associated operators loaded from a module.
PROGRAM main
  USE m, ONLY: mynum, check_in_module
  IMPLICIT NONE

  TYPE(mynum) :: num1, num2, num3
  REAL :: real_var
  INTEGER :: int_var

  CALL check_in_module ()

  num1 = mynum (1.0, 2)
  num2 = mynum (2.0, 3)

  num3 = num1 + num2
  IF (num3%num_real /= 3.0 .OR. num3%num_int /= 5) CALL abort ()

  num3 = num1 + 5
  IF (num3%num_real /= 1.0 .OR. num3%num_int /= 7) CALL abort ()

  num3 = num1 + (-100.5)
  IF (num3%num_real /= -99.5 .OR. num3%num_int /= 2) CALL abort ()

  num3 = 42
  num3 = -1.2
  IF (num3%num_real /= -1.2 .OR. num3%num_int /= 42) CALL abort ()

  real_var = num3
  int_var = num3
  IF (real_var /= -1.2 .OR. int_var /= 42) CALL abort ()

  IF (.GET. num1 /= 3.0) CALL abort ()
END PROGRAM main

! { dg-final { cleanup-modules "m" } }


!  { dg-do run }
!  Tests the fix for PR35740, where the trick of interchanging the descriptor
!  dimensions to implement TRANSPOSE did not work if it is an argument of
!  an elemental function - eg. CONJG.  The fix forces a library call for such
!  cases.  During the diagnosis of the PR, it was found that the scalarizer was
!  completely thrown if the argument of TRANSPOSE was a non-variable
!  expression; eg a + c below.  This is also fixed by the library call.
!
!  Contributed by Dominik Muth <dominik.muth@gmx.de>
!
program main
  implicit none
  complex, dimension(2,2) :: a,b,c,d
  a(1,1) = (1.,1.)
  a(2,1) = (2.,2.)
  a(1,2) = (3.,3.)
  a(2,2) = (4.,4.)
!
  b = a
  b = conjg(transpose(b))
  d = a
  d = transpose(conjg(d))
  if (any (b /= d)) STOP 1
!
  d = matmul (b,  a )
  if (any (d /= matmul (transpose(conjg(a)), a))) STOP 2
  if (any (d /= matmul (conjg(transpose(a)), a))) STOP 3
!
  c = (0.0,1.0)
  b = conjg(transpose(a + c))
  d = transpose(conjg(a + c))
  if (any (b /= d)) STOP 4
!
  d = matmul (b,  a + c)
  if (any (d /= matmul (transpose(conjg(a + c)), a + c))) STOP 5
  if (any (d /= matmul (conjg(transpose(a + c)), a + c))) STOP 6
 END program main


! =====================================================================
! subroutine GRDR
!
! This subroutine generates the radial coordinate grid points.
! ---------------------------------------------------------------------
      subroutine GRDR(nR,rA,rB,dR,R,RH)
      implicit none

      integer :: nR
      double precision :: rA
      double precision :: rB
      double precision :: dR
      double precision :: R(nR)
      double precision :: RH(nR+1)

      integer :: i

      do i = 1, nR
         R(i) = rA + dfloat(i)*dR
         RH(i) = R(i) - 0.5d0*dR
      enddo
      RH(nR+1) = rB - 0.5d0*dR

      return
      end
! =====================================================================


!--------------------------------------------------
!PHY2063 Task 3
!URN 6309823 - Penguin Lab Group 1B
!November 5th 2015
!--------------------------------------------------
!
Program Task3
  IMPLICIT NONE
!
  REAL          ::  ran,lambda,distance,sum_distance,ave_distance
  INTEGER       ::  i,iseed,first,n
  real,external ::  rand,ran_exp
!
  first=0
  iseed=971739
  ran=rand(iseed,first)
!
  write(6,*)'How many scattering events are there?'
  read(5,*) n
  write(6,'(a,i9)')'seed value that generates this sequence is ',iseed
! now the exponential distribution has one parameter
! this is its mean, given by the variable: lambda
! distribution for is then p(x)=exp(-x/lambda) / lambda
! set lambda
  write(6,*)'What is your value of lambda?'
  read (5,*)lambda
! call lambda
  ran=ran_exp(iseed,first,lambda)
! this gives a ran number distributed according
! to an exponential distribution with mean = lambda
  dist=0
!
  do i=1,n
    do i=1,n
      distance=distance+ran.exp(iseed,first,lambda)
    end do
    sum_distance=sum_distance+distance
    ave_distance=sum_distance/real(n)
  end do
End Program Task3
!
!
real function rand(iseed,first)
!
!  This function returns a pseudo-random number for each invocation.
!  It is an f90 adaptation of an
!  FORTRAN 77 adaptation
!  by Dick Valent and Fred Clare
!  http://www.cisl.ucar.edu/zine/96/spring/articles/3.random-6.html
!  of the "Integer Version 2" minimal
!  standard number generator whose Pascal code appears in the article:
!
!     Park, Steven K. and Miller, Keith W., "Random Number Generators:
!     Good Ones are Hard to Find", Communications of the ACM,
!     October, 1988.
!
  implicit none
  integer, parameter :: MPLIER=16807
  integer, parameter :: MODLUS=2147483647
  integer, parameter :: MOBYMP=127773
  integer, parameter :: MOMDMP=2836
  integer :: hvlue,lvlue,testv,nextn,first,iseed
  save nextn
!
  if(first == 0) THEN
    nextn=iseed
    first=1
  endif
!
  hvlue=nextn/mobymp
  lvlue=mod(nextn,mobymp)
  testv=mplier*lvlue-momdmp*hvlue
  if(testv > 0)then
    nextn=testv
  else
    nextn=testv+modlus
  endif
  rand = real(nextn)/real(modlus)
!
end function rand


T{ 1 0 < -> FALSE }T
T{ 0 1 < -> TRUE }T
T{ 1 -1 < -> FALSE }T
T{ -1 1 < -> TRUE }T
T{ -1 0 < -> TRUE }T
T{ 0 -1 < -> FALSE }T

T{ 1 0 > -> TRUE }T
T{ 0 1 > -> FALSE }T
T{ 1 -1 > -> TRUE }T
T{ -1 1 > -> FALSE }T
T{ -1 0 > -> FALSE }T
T{ 0 -1 > -> TRUE }T

T{ 1 1 <= -> TRUE }T
T{ 0 0 <= -> TRUE }T
T{ -1 -1 <= -> TRUE }T
T{ 1 0 <= -> FALSE }T
T{ 0 1 <= -> TRUE }T
T{ 1 -1 <= -> FALSE }T
T{ -1 1 <= -> TRUE }T
T{ -1 0 <= -> TRUE }T
T{ 0 -1 <= -> FALSE }T

T{ 1 1 >= -> TRUE }T
T{ 0 0 >= -> TRUE }T
T{ -1 -1 >= -> TRUE }T
T{ 1 0 >= -> TRUE }T
T{ 0 1 >= -> FALSE }T
T{ 1 -1 >= -> TRUE }T
T{ -1 1 >= -> FALSE }T
T{ -1 0 >= -> FALSE }T
T{ 0 -1 >= -> TRUE }T

T{ 1 1 = -> TRUE }T
T{ 1 0 = -> FALSE }T
T{ 0 0 = -> TRUE }T
T{ 1 -1 = -> FALSE }T
T{ -1 -1 = -> TRUE }T

T{ 1 1 <> -> FALSE }T
T{ 1 0 <> -> TRUE }T
T{ 0 0 <> -> FALSE }T
T{ 1 -1 <> -> TRUE }T
T{ -1 -1 <> -> FALSE }T

T{ 1 0= -> FALSE }T
T{ 0 0= -> TRUE }T
T{ -1 0= -> FALSE }T

T{ 1 0<> -> TRUE }T
T{ 0 0<> -> FALSE }T
T{ -1 0<> -> TRUE }T

T{ 1 0< -> FALSE }T
T{ 0 0< -> FALSE }T
T{ -1 0< -> TRUE }T

T{ 1 0> -> TRUE }T
T{ 0 0> -> FALSE }T
T{ -1 0> -> FALSE }T

T{ 1 0<= -> FALSE }T
T{ 0 0<= -> TRUE }T
T{ -1 0<= -> TRUE }T

T{ 1 0>= -> TRUE }T
T{ 0 0>= -> TRUE }T
T{ -1 0>= -> FALSE }T


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Tue May 21 22:55:08
!
!a=./f && make $a && OMP_NUM_THREADS=2 $a 1223334444
!gfortran -std=f2008 -Wall -ffree-form -fall-intrinsics f.f08 -o f
!  1
!  2  3
!  4  5  6
!  7  8  9 10
! 11 12 13 14 15
!
!
!  1
!  2  3
!  4  5  6
!  7  8  9 10
! 11 12 13 14 15
! 16 17 18 19 20 21
! 22 23 24 25 26 27 28
! 29 30 31 32 33 34 35 36
! 37 38 39 40 41 42 43 44  45
! 46 47 48 49 50 51 52 53  54  55
! 56 57 58 59 60 61 62 63  64  65  66
! 67 68 69 70 71 72 73 74  75  76  77  78
! 79 80 81 82 83 84 85 86  87  88  89  90  91
! 92 93 94 95 96 97 98 99 100 101 102 103 104 105
!
!
!
!Compilation finished at Tue May 21 22:55:08

program p
  integer, dimension(2) :: examples = [5, 14]
  integer :: i
  do i=1, size(examples)
    call floyd(examples(i))
    write(6, '(/)')
  end do

contains

  subroutine floyd(rows)
    integer, intent(in) :: rows
    integer :: n, i, j, k
    integer, dimension(60) :: L
    character(len=504) :: fmt
    n = (rows*(rows+1))/2 ! Gauss's formula
    do i=1,rows ! compute format of final row
      L(i) = 2+int(log10(real(n-rows+i)))
    end do
    k = 0
    do i=1,rows
      do j=1,i
        k = k+1
        write(fmt,'(a2,i1,a1)')'(i',L(j),')'
        write(6,fmt,advance='no') k
      enddo
      write(6,*) ''
    end do
  end subroutine floyd

end program p


C    %W% %G%
      real function tzldlg (t2,t1,dt,x0,x1,y0,ndivs)
      implicit none
      real t2,t1,dt,x0,x1,y0
      integer ndivs

c     -  solves a first order lead block:
c            1 + sT2
c            -------
c            1 + sT1
c
c     -  Time step subdivision used if ndivs > 1
c
c     -   subscript 0 means value at start of interval
c             "     1  "      "   "   end  "     "
c     -   x is input var
c         y is output var
c
      real aa,bb,v0,v1,w0,w1
      real rdivs,r0wt,r1wt,va,vb,wa,wb,dts
      integer la

c     -     begin     begin     begin     begin     begin     begin

      if (t1 .eq. 0.0) then
        if (t2 .eq. 0.0) then
          tzldlg = x1
          return
        else
          write (*,'(a)')
     +      ' TZLDLG [f] Lead-lag block has denom time constant = 0.0.'
          stop
        endif
      endif
      if (dt .eq. 0.0) then
        tzldlg = y0 + ((x1 - x0) * t2 / t1)
        return
      endif
c     -  No time step subdivisions
      if (ndivs .le. 1) then
        aa = dt / 2.0 / t1
        bb = ( 1.0 - (t2 / t1)) * (x0 + x1)
        v0 = y0 - (x0 * t2 / t1)
        v1 = ( v0 - aa * v0 + aa * bb) / (aa + 1.0)
        tzldlg = (x1 * t2 / t1) + v1
        return
      endif
c     -  Using time step subdivisions.  Find v1 = F (w0,w1,v0)
      rdivs = ndivs
      r0wt = rdivs
      r1wt = 0.0
      dts = dt / rdivs
      aa = dts / 2.0 / t1
      w0 = x0 * (1.0 - (t2 / t1))
      w1 = x1 * (1.0 - (t2 / t1))
      wa = w0
      va = y0 - (x0 * t2 / t1)
      do la = 1,ndivs
        r0wt = r0wt - 1.0
        r1wt = r1wt + 1.0
        wb = ((r0wt * w0) + (r1wt * w1)) / rdivs
        bb = wa + wb
        vb = ( va - aa * va + aa * bb) / (aa + 1.0)
        wa = wb
        va = vb
      enddo
      tzldlg = (x1 * t2 / t1) + vb
c
      return
      end


program problem99
  implicit none
  integer, parameter      :: n=1000
  integer, dimension(2,n) :: pairs
  integer                 :: i
  real*16, dimension(n)   :: logs

  open(33,file='./data/problem99.dat')
  read(33,*) pairs

  do i=1,n
     logs(i)=real(pairs(2,i),16)*log(real(pairs(1,i),16))
  end do

  print *, maxloc(logs)

end program problem99


module prutil     !precision and utils

integer, parameter :: SP=4  ! single precision
integer, parameter :: DP=8  ! double precision

integer, parameter :: cp=DP ! current precision used in computation

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!       Matrix inversion with cholesky
!           Single Precision
! mxout = invert(mxin), n*n matrix
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine invmat_chol_sp(n,mxin,mxout)
implicit none
integer, intent(in) :: n
integer :: info ! error info of LAPACK Call
real(kind=SP), intent(in), dimension(n,n) :: mxin
real(kind=SP), intent(out), dimension(n,n) :: mxout
integer :: i,j

forall(i=1:n,j=1:n)
mxout(i,j)=mxin(i,j)
end forall
! use cholesky decomposition to calculate the inverse of symmetric positive
! definitive matrix

!call potrf(mxout,'U',info)
call SPOTRF('U', n, mxout, n, info)
if (info.ne.0) then
write(*,*) 'info potrf= ', info
stop
end if

!call potri(mxout,'U',info)
call SPOTRI('U', n, mxout, n, info)
if (info.ne.0) then
write(*,*) 'info potri= ', info
stop
end if

do i=1,n
        do j=1,i
                mxout(i,j)=mxout(j,i)
        end do
end do

end subroutine invmat_chol_sp

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!       Matrix vector multiplication
!           Single Precision
! mxout = invert(mxin), n*n matrix
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine mvmul_blas_sp(m,n,mxin,vecin,vecout)
! vecout=mxin*vecin
implicit none
integer, intent(in) :: m,n
real(kind=SP), dimension(m,n), intent(in) :: mxin
real(kind=SP), dimension(n), intent(in) :: vecin
real(kind=SP), dimension(m), intent(out) :: vecout
! prepare vecout for calculation
vecout=0.0_SP
!call gemv(mxin,vecin,vecout)
call SGEMV('N',m,n,1.0,mxin,m,vecin,1,0.0,vecout,1)

end subroutine mvmul_blas_sp

! Kronecker delta
pure function kd(i,j)
integer, intent(in) :: i,j
integer :: kd
kd=0
if(i.eq.j) then
kd = 1
else
kd = 0
end if
end function kd

! permutation  symbol
pure function per(i,j,k)
integer,intent(in) :: i,j,k
integer :: per
per=0
if((i.eq.1).and.(j.eq.2).and.(k.eq.3)) then
per = 1
else if((i.eq.2).and.(j.eq.3).and.(k.eq.1)) then
per = 1
else if((i.eq.3).and.(j.eq.1).and.(k.eq.2)) then
per = 1
else if((i.eq.1).and.(j.eq.3).and.(k.eq.2)) then
per = -1
else if((i.eq.2).and.(j.eq.1).and.(k.eq.3)) then
per = -1
else if((i.eq.3).and.(j.eq.2).and.(k.eq.1)) then
per = -1
else
        per=0
end if
end function per

end module prutil


!************************************************************
!*      Fortran implementation of the Kalman filter
!*      and Rauch smoother
!************************************************************

module lapackMod
contains

! Returns the inverse of a matrix calculated by finding the LU
! decomposition.  Depends on LAPACK.
function inv(A) result(Ainv)
  implicit none
  double precision,intent(in) :: A(:,:)
  double precision            :: Ainv(size(A,1),size(A,2))
  double precision            :: work(size(A,1))            ! work array for LAPACK
  integer         :: n,info,ipiv(size(A,1))     ! pivot indices

  ! Store A in Ainv to prevent it from being overwritten by LAPACK
  Ainv = A
  n = size(A,1)
  ! SGETRF computes an LU factorization of a general M-by-N matrix A
  ! using partial pivoting with row interchanges.
  call DGETRF(n,n,Ainv,n,ipiv,info)
  if (info.ne.0) stop 'Matrix is numerically singular!'
  ! SGETRI computes the inverse of a matrix using the LU factorization
  ! computed by SGETRF.
  call DGETRI(n,Ainv,n,ipiv,work,n,info)
  if (info.ne.0) stop 'Matrix inversion failed!'
end function inv
end module lapackMod

subroutine filtersmoother(lenTraj, dim_x, dim_h, Xtplus, mutilde, R, diff, mu0, Sig0,muh, Sigh)
  implicit none
  integer,intent(in)::lenTraj,dim_x,dim_h
  double precision,dimension(0:lenTraj,dim_x),intent(in)::Xtplus
  double precision,dimension(0:lenTraj,dim_x+dim_h),intent(in)::mutilde
  double precision,dimension(dim_x+dim_h,dim_h),intent(in)::R
  double precision,dimension(dim_x+dim_h,dim_x+dim_h),intent(in)::diff
  double precision,dimension(dim_h),intent(in)::mu0
  double precision,dimension(dim_h,dim_h),intent(in)::Sig0
  double precision,dimension(0:lenTraj,2*dim_h),intent(out)::muh
  double precision,dimension(0:lenTraj,2*dim_h,2*dim_h),intent(out)::Sigh
  double precision,dimension(0:lenTraj,dim_h)::muf,mus
  double precision,dimension(0:lenTraj,dim_h,dim_h)::Sigf,Sigs
  integer::i

  !! Forward Proba
  muf(0,:) = mu0
  Sigf(0, :, :) = Sig0
  if (dim_x == 0) then
     !! Iterate and compute possible value for h at the same point
     do i=1,lenTraj !! for i in range(1, lenTraj):
        call filter_kalman_noiseless(muf(i - 1, :), Sigf(i - 1, :, :), mutilde(i - 1,:), R, diff, dim_h,&
             muf(i, :), Sigf(i, :, :), muh(i - 1, :), Sigh(i - 1, :, :))

     end do
  else if (dim_x == 1) then ! There is a speed-up for 1D visible case
     !! Iterate and compute possible value for h at the same point
     do i=1,lenTraj !! for i in range(1, lenTraj):
        call filter_kalman_1D(muf(i - 1, :), Sigf(i - 1, :, :), Xtplus(i - 1,:), mutilde(i - 1,:), R,diff, dim_x, dim_h,&
             muf(i, :), Sigf(i, :, :), muh(i - 1, :), Sigh(i - 1, :, :))

     end do
  else
     !! Iterate and compute possible value for h at the same point
     do i=1,lenTraj !! for i in range(1, lenTraj):
        call filter_kalman(muf(i - 1, :), Sigf(i - 1, :, :), Xtplus(i - 1,:), mutilde(i - 1,:), R,diff, dim_x, dim_h,&
             muf(i, :), Sigf(i, :, :), muh(i - 1, :), Sigh(i - 1, :, :))

     end do
  end if

  !! The last step comes only from the forward recursion
  Sigs(lenTraj, :, :) = Sigf(lenTraj, :, :)
  mus(lenTraj, :) = muf(lenTraj, :)
  !! Backward proba
  if (dim_x == 0) then
     do i=lenTraj-1,0,-1   !!   for i in range(lenTraj - 2, -1, -1):  # From T-1 to 0
        call smoothing_rauch_noiseless(muf(i, :), Sigf(i, :, :), mus(i + 1, :), Sigs(i + 1, :, :), &
             mutilde(i,:), R, diff, dim_h, mus(i, :), Sigs(i, :, :), muh(i, :), Sigh(i, :, :))
     end do
  else
     do i=lenTraj-1,0,-1   !!   for i in range(lenTraj - 2, -1, -1):  # From T-1 to 0
        call smoothing_rauch(muf(i, :), Sigf(i, :, :), mus(i + 1, :), Sigs(i + 1, :, :), &
             Xtplus(i,:), mutilde(i,:), R, diff, dim_x, dim_h,&
             mus(i, :), Sigs(i, :, :), muh(i, :), Sigh(i, :, :))
     end do
  end if

end subroutine filtersmoother

!!$    Compute the foward step using Kalman filter, predict and update step
!!$    Parameters
!!$    ----------
!!$    mutm, Sigtm: Values of the foward distribution at t-1
!!$    Xt, mutilde_tm: Values of the trajectories at T and t-1
!!$    expAh, SST: Coefficients parameters["expA"][:, dim_x:] (dim_x+dim_h, dim_h) and SS^T (dim_x+dim_h, dim_x+dim_h)
!!$    dim_x,dim_h: Dimension of visibles and hidden variables
subroutine filter_kalman(mutm, Sigtm, Xt, mutilde_tm, expAh, SST, dim_x, dim_h, marg_mu, marg_sig, mu_pair, Sig_pair)
  use lapackMod
  implicit none
  integer,intent(in)::dim_x,dim_h
  double precision,dimension(dim_h),intent(in)::mutm
  double precision,dimension(dim_h,dim_h),intent(in)::Sigtm
  double precision,dimension(dim_x),intent(in)::Xt
  double precision,dimension(dim_x+dim_h),intent(in)::mutilde_tm
  double precision,dimension(dim_x+dim_h,dim_h),intent(in)::expAh
  double precision,dimension(dim_x+dim_h,dim_x+dim_h),intent(in)::SST

  double precision,dimension(dim_h),intent(out)::marg_mu
  double precision,dimension(dim_h,dim_h),intent(out)::marg_sig
  double precision,dimension(2*dim_h),intent(out)::mu_pair
  double precision,dimension(2*dim_h,2*dim_h),intent(out)::Sig_pair

  double precision,dimension(dim_x+dim_h)::mutemp
  double precision,dimension(dim_x+dim_h,dim_x+dim_h)::Sigtemp
  double precision,dimension(dim_x,dim_x)::invSYY

  !! Predict step marginalization Normal Gaussian
  mutemp = mutilde_tm + matmul(expAh, mutm)
  Sigtemp = SST + matmul(expAh, matmul(Sigtm, transpose(expAh)))
  !! Update step conditionnal Normal Gaussian
  invSYY = inv(Sigtemp(:dim_x, :dim_x))
  marg_mu = mutemp(1+dim_x:) + matmul(Sigtemp(1+dim_x:, :dim_x), matmul(invSYY, Xt - mutemp(:dim_x)))
  marg_sig = Sigtemp(1+dim_x:, 1+dim_x:) -&
       matmul(Sigtemp(1+dim_x:, :dim_x),matmul(invSYY, transpose(Sigtemp(1+dim_x:, :dim_x))))
  marg_sig = 0.5*marg_sig+0.5*transpose(marg_sig) ! To enforce symmetry
  !! Pair probability distibution Z_t,Z_{t-1}
  mu_pair(:dim_h) = marg_mu
  mu_pair(1+dim_h:) = mutm
  Sig_pair(:dim_h, :dim_h) = marg_sig
  Sig_pair(1+dim_h:, :dim_h) = matmul(expAh(1+dim_x:, :) - &
       matmul(Sigtemp(1+dim_x:, :dim_x), matmul(invSYY, expAh(:dim_x, :))), Sigtm)
  Sig_pair(:dim_h, 1+dim_h:) = transpose(Sig_pair(1+dim_h:, :dim_h))
  Sig_pair(1+dim_h:, 1+dim_h:) = Sigtm

end subroutine filter_kalman

!!$    Compute the backward step using Kalman smoother
subroutine smoothing_rauch(muft, Sigft, muStp, SigStp, Xtplus, mutilde_t, expAh, SST&
     , dim_x, dim_h, marg_mu, marg_sig, mu_pair, Sig_pair)
  use lapackMod
  implicit none
  integer,intent(in)::dim_x,dim_h
  double precision,dimension(dim_h),intent(in)::muft,muStp
  double precision,dimension(dim_h,dim_h),intent(in)::Sigft,SigStp
  double precision,dimension(dim_x),intent(in)::Xtplus
  double precision,dimension(dim_x+dim_h),intent(in)::mutilde_t
  double precision,dimension(dim_x+dim_h,dim_h),intent(in)::expAh
  double precision,dimension(dim_x+dim_h,dim_x+dim_h),intent(in)::SST

  double precision,dimension(dim_h),intent(out)::marg_mu
  double precision,dimension(dim_h,dim_h),intent(out)::marg_sig
  double precision,dimension(2*dim_h),intent(out)::mu_pair
  double precision,dimension(2*dim_h,2*dim_h),intent(out)::Sig_pair

  double precision,dimension(dim_x+dim_h,dim_x+dim_h)::invTemp
  double precision,dimension(dim_h,dim_x+dim_h)::R

  invTemp = inv(SST + matmul(expAh, matmul(Sigft, transpose(expAh))))
  R = matmul(matmul(Sigft, transpose(expAh)), invTemp)

  marg_mu =  muft + matmul(R(:, :dim_x), Xtplus) - matmul(R, matmul(expAh, muft) + mutilde_t) + matmul(R(:, 1+dim_x:), muStp)
  marg_sig = matmul(R(:, 1+dim_x:), matmul(SigStp, transpose(R(:, 1+dim_x:)))) + Sigft - matmul(matmul(R, expAh), Sigft)

  !! Pair probability distibution Z_{t+1},Z_{t}
  mu_pair(:dim_h) = muStp
  mu_pair(1+dim_h:) = marg_mu

  Sig_pair(:dim_h, :dim_h) = SigStp
  Sig_pair(1+dim_h:, :dim_h) = matmul(R(:, 1+dim_x:), SigStp)
  Sig_pair(:dim_h, 1+dim_h:) = transpose(Sig_pair(1+dim_h:, :dim_h))
  Sig_pair(1+dim_h:, 1+dim_h:) = marg_sig

end subroutine smoothing_rauch

!!$    Compute the foward step using Kalman filter, predict and update step
!!$    Avoid matrix inversion when possible
!!$    Parameters
!!$    ----------
!!$    mutm, Sigtm: Values of the foward distribution at t-1
!!$    Xt, mutilde_tm: Values of the trajectories at T and t-1
!!$    expAh, SST: Coefficients parameters["expA"][:, dim_x:] (dim_x+dim_h, dim_h) and SS^T (dim_x+dim_h, dim_x+dim_h)
!!$    dim_x,dim_h: Dimension of visibles and hidden variables
subroutine filter_kalman_1D(mutm, Sigtm, Xt, mutilde_tm, expAh, SST, dim_x, dim_h, marg_mu, marg_sig, mu_pair, Sig_pair)
  implicit none
  integer,intent(in)::dim_x,dim_h
  double precision,dimension(dim_h),intent(in)::mutm
  double precision,dimension(dim_h,dim_h),intent(in)::Sigtm
  double precision,dimension(dim_x),intent(in)::Xt
  double precision,dimension(dim_x+dim_h),intent(in)::mutilde_tm
  double precision,dimension(dim_x+dim_h,dim_h),intent(in)::expAh
  double precision,dimension(dim_x+dim_h,dim_x+dim_h),intent(in)::SST

  double precision,dimension(dim_h),intent(out)::marg_mu
  double precision,dimension(dim_h,dim_h),intent(out)::marg_sig
  double precision,dimension(2*dim_h),intent(out)::mu_pair
  double precision,dimension(2*dim_h,2*dim_h),intent(out)::Sig_pair

  double precision,dimension(dim_x+dim_h)::mutemp
  double precision,dimension(dim_x+dim_h,dim_x+dim_h)::Sigtemp
  double precision,dimension(dim_x,dim_x)::invSYY

  !! Predict step marginalization Normal Gaussian
  mutemp = mutilde_tm + matmul(expAh, mutm)
  Sigtemp = SST + matmul(expAh, matmul(Sigtm, transpose(expAh)))
  !! Update step conditionnal Normal Gaussian
  marg_mu = mutemp(1+dim_x:) + matmul(Sigtemp(1+dim_x:, :dim_x), Xt - mutemp(:dim_x))/ Sigtemp(1,1)
  marg_sig = Sigtemp(1+dim_x:, 1+dim_x:) -&
       matmul(Sigtemp(1+dim_x:, :dim_x), transpose(Sigtemp(1+dim_x:, :dim_x)))/ Sigtemp(1,1)
  marg_sig = 0.5*marg_sig+0.5*transpose(marg_sig) ! To enforce symmetry
  !! Pair probability distibution Z_t,Z_{t-1}
  mu_pair(:dim_h) = marg_mu
  mu_pair(1+dim_h:) = mutm
  Sig_pair(:dim_h, :dim_h) = marg_sig
  Sig_pair(1+dim_h:, :dim_h) = matmul(expAh(1+dim_x:, :) - &
       matmul(Sigtemp(1+dim_x:, :dim_x), matmul(invSYY, expAh(:dim_x, :))), Sigtm)
  Sig_pair(:dim_h, 1+dim_h:) = transpose(Sig_pair(1+dim_h:, :dim_h))
  Sig_pair(1+dim_h:, 1+dim_h:) = Sigtm

end subroutine filter_kalman_1D

!!$    Compute the foward step using Kalman filter, predict and update step
!!$    Parameters
!!$    ----------
!!$    mutm, Sigtm: Values of the foward distribution at t-1
!!$    Xt, mutilde_tm: Values of the trajectories at T and t-1
!!$    expAh, SST: Coefficients parameters["expA"][:, dim_x:] (dim_x+dim_h, dim_h) and SS^T (dim_x+dim_h, dim_x+dim_h)
!!$    dim_x,dim_h: Dimension of visibles and hidden variables
subroutine filter_kalman_noiseless(mutm, Sigtm, mutilde_tm, expAhh, SST, dim_h, marg_mu, marg_sig, mu_pair, Sig_pair)
  implicit none
  integer,intent(in)::dim_h
  double precision,dimension(dim_h),intent(in)::mutm
  double precision,dimension(dim_h,dim_h),intent(in)::Sigtm
  double precision,dimension(dim_h),intent(in)::mutilde_tm
  double precision,dimension(dim_h,dim_h),intent(in)::expAhh
  double precision,dimension(dim_h,dim_h),intent(in)::SST

  double precision,dimension(dim_h),intent(out)::marg_mu
  double precision,dimension(dim_h,dim_h),intent(out)::marg_sig
  double precision,dimension(2*dim_h),intent(out)::mu_pair
  double precision,dimension(2*dim_h,2*dim_h),intent(out)::Sig_pair

  !! Predict step marginalization Normal Gaussian
  marg_mu = mutilde_tm + matmul(expAhh, mutm)
  marg_sig = SST + matmul(expAhh, matmul(Sigtm, transpose(expAhh)))

  !! Pair probability distibution Z_t,Z_{t-1}
  mu_pair(:dim_h) = marg_mu
  mu_pair(1+dim_h:) = mutm
  Sig_pair(:dim_h, :dim_h) = marg_sig
  Sig_pair(1+dim_h:, :dim_h) = matmul(expAhh, Sigtm)
  Sig_pair(:dim_h, 1+dim_h:) = transpose(Sig_pair(1+dim_h:, :dim_h))
  Sig_pair(1+dim_h:, 1+dim_h:) = Sigtm

end subroutine filter_kalman_noiseless

!!$    Compute the backward step using Kalman smoother
subroutine smoothing_rauch_noiseless(muft, Sigft, muStp, SigStp,  mutilde_t, expAhh, SST&
     ,  dim_h, marg_mu, marg_sig, mu_pair, Sig_pair)
  use lapackMod
  implicit none
  integer,intent(in)::dim_h
  double precision,dimension(dim_h),intent(in)::muft,muStp
  double precision,dimension(dim_h,dim_h),intent(in)::Sigft,SigStp
  double precision,dimension(dim_h),intent(in)::mutilde_t
  double precision,dimension(dim_h,dim_h),intent(in)::expAhh
  double precision,dimension(dim_h,dim_h),intent(in)::SST

  double precision,dimension(dim_h),intent(out)::marg_mu
  double precision,dimension(dim_h,dim_h),intent(out)::marg_sig
  double precision,dimension(2*dim_h),intent(out)::mu_pair
  double precision,dimension(2*dim_h,2*dim_h),intent(out)::Sig_pair

  double precision,dimension(dim_h,dim_h)::invTemp
  double precision,dimension(dim_h,dim_h)::R

  invTemp = inv(SST + matmul(expAhh, matmul(Sigft, transpose(expAhh))))
  R = matmul(matmul(Sigft, transpose(expAhh)), invTemp)

  marg_mu =  muft - matmul(R, matmul(expAhh, muft) + mutilde_t) + matmul(R, muStp)
  marg_sig = matmul(R, matmul(SigStp, transpose(R))) + Sigft - matmul(matmul(R, expAhh), Sigft)

  !! Pair probability distibution Z_{t+1},Z_{t}
  mu_pair(:dim_h) = muStp
  mu_pair(1+dim_h:) = marg_mu

  Sig_pair(:dim_h, :dim_h) = SigStp
  Sig_pair(1+dim_h:, :dim_h) = matmul(R, SigStp)
  Sig_pair(:dim_h, 1+dim_h:) = transpose(Sig_pair(1+dim_h:, :dim_h))
  Sig_pair(1+dim_h:, 1+dim_h:) = marg_sig

end subroutine smoothing_rauch_noiseless


!
! Copyright (C) 2001 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!---------------------------------------------------------------------

subroutine recips (a1, a2, a3, b1, b2, b3)
  !---------------------------------------------------------------------
  !
  !   This routine generates the reciprocal lattice vectors b1,b2,b3
  !   given the real space vectors a1,a2,a3. The b's are units of 2 pi/a.
  !
  !     first the input variables
  !
  use kinds, ONLY: DP
  implicit none
  real(DP) :: a1 (3), a2 (3), a3 (3), b1 (3), b2 (3), b3 (3)
  ! input: first direct lattice vector
  ! input: second direct lattice vector
  ! input: third direct lattice vector
  ! output: first reciprocal lattice vector
  ! output: second reciprocal lattice vector
  ! output: third reciprocal lattice vector
  !
  !   then the local variables
  !
  real(DP) :: den, s
  ! the denominator
  ! the sign of the permutations
  integer :: iperm, i, j, k, l, ipol
  ! counter on the permutations
  !\
  !  Auxiliary variables
  !/
  !
  ! Counter on the polarizations
  !
  !    first we compute the denominator
  !
  den = 0
  i = 1
  j = 2
  k = 3
  s = 1.d0
100 do iperm = 1, 3
     den = den + s * a1 (i) * a2 (j) * a3 (k)
     l = i
     i = j
     j = k
     k = l
  enddo
  i = 2
  j = 1
  k = 3
  s = - s
  if (s.lt.0.d0) goto 100
  !
  !    here we compute the reciprocal vectors
  !
  i = 1
  j = 2
  k = 3
  do ipol = 1, 3
     b1 (ipol) = (a2 (j) * a3 (k) - a2 (k) * a3 (j) ) / den
     b2 (ipol) = (a3 (j) * a1 (k) - a3 (k) * a1 (j) ) / den
     b3 (ipol) = (a1 (j) * a2 (k) - a1 (k) * a2 (j) ) / den
     l = i
     i = j
     j = k
     k = l
  enddo
  return
end subroutine recips


program main
  use adjac

  integer, parameter :: n = 100, filliter = 10

  double precision :: xval(n), yval(n), J(n,n)
  integer :: rep, i

  do i = 1, n
     xval(i) = 1d0 + i
  end do

  do rep = 1, int(1e8/(n*n))
     call doit(xval, yval, J)
  end do

  do i = 1, 5
     write(*,*) yval(i)
  end do
  do i = 1, 5
     write(*,*) real(J(i,1:5))
  end do

contains
  subroutine doit(xval, yval, J)
    implicit none
    double precision, intent(in) :: xval(n)
    double precision, intent(out) :: yval(n), J(n,n)
    double precision :: x(n), y(n)
    integer :: i
    double precision, parameter :: eps = 1d-7

    call laplacian(xval, yval)

    x = xval

    do i = 1, n
        x(i) = xval(i) + eps
        call laplacian(x, y)
        J(:,i) = (y - yval) / eps
        x(i) = xval(i)
    end do
  end subroutine doit

  subroutine laplacian(x, y)
    implicit none
    double precision, dimension(n), intent(in) :: x
    double precision, dimension(n), intent(out) :: y
    integer :: i, p

    y(1) = -2*x(1) + x(2)
    y(n) = -2*x(n) + x(n-1)
    do i = 2, n-1
       y(i) = x(i+1) - 2*x(i) + x(i-1)
    end do

    do p = 1, filliter
       do i = 2, n-1
          y(i) = y(i-1) - 2*y(i) + y(i+1)/(3.1415d0 + y(i))
       end do
    end do

  end subroutine laplacian
end program main


      real function getz(pval,nt,vr,cdf,zmin,zmax,ltail,ltpar,
     +                   utail,utpar)
c-----------------------------------------------------------------------
c
c           Back Transform Univariate Data from Normal Scores
c           *************************************************
c
c This subroutine backtransforms a standard normal deviate from a
c specified back transform table and option for the tails of the
c distribution.  Call once with "first" set to true then set to false
c unless one of the options for the tail changes.
c
c
c
c INPUT VARIABLES:
c
c   pval             probability value to use
c   nt               number of values in the back transform tbale
c   vr(nt)           original data values that were transformed
c   cdf(nt)          the corresponding transformed values
c   zmin,zmax        limits possibly used for linear or power model
c   ltail            option to handle values less than cdf(1)
c   ltpar            parameter required for option ltail
c   utail            option to handle values greater than cdf(nt)
c   utpar            parameter required for option utail
c
c
c
c-----------------------------------------------------------------------
      parameter(EPSLON=1.0e-20)
      dimension vr(nt),cdf(nt)
      real      ltpar,utpar,lambda
      integer   ltail,utail
c
c Value in the lower tail?    1=linear, 2=power, (3 and 4 are invalid):
c
      if(pval.le.cdf(1)) then
                  getz = vr(1)
            if(ltail.eq.1) then
                  getz = powint(0.0,cdf(1),zmin,vr(1),pval,1.0)
            else if(ltail.eq.2) then
                  cpow = 1.0 / ltpar
                  getz = powint(0.0,cdf(1),zmin,vr(1),pval,cpow)
            endif
c
c Value in the upper tail?     1=linear, 2=power, 4=hyperbolic:
c
      else if(pval.ge.cdf(nt)) then
                  cdfhi  = cdf(nt)
                  getz   = vr(nt)
            if(utail.eq.1) then
                  getz   = powint(cdfhi,1.0,vr(nt),zmax,pval,1.0)
            else if(utail.eq.2) then
                  cpow   = 1.0 / utpar
                  getz   = powint(cdfhi,1.0,vr(nt),zmax,pval,cpow)
            else if(utail.eq.4) then
                  lambda = (vr(nt)**utpar)*(1.0-cdf(nt))
                  getz   = (lambda/(1.0-pval))**(1.0/utpar)
            endif
      else
c
c Value within the transformation table:
c
            call locate(cdf,nt,1,nt,pval,j)
            j    = max(min((nt-1),j),1)
            getz = powint(cdf(j),cdf(j+1),vr(j),vr(j+1),pval,1.0)
      endif
      if(getz.lt.zmin) getz = zmin
      if(getz.gt.zmax) getz = zmax
      return
      end


      subroutine mkres(v,n1v,nrow,nv,r,n1r)
c-------------------------------------------------------------------
c        forms resolution matrix for inverse obtained from a
c  trucated singular value decomposition.
c
c  arguments-
c    v   - nrow by nv array of right singular vectors from svd.
c          vectors are assumed to be in the columns of v.  only
c          nv vectors are used to form r.  (recall if nv = nrow
c          then r will be an identity matrix)
c    n1v - first dimension of v in calling program
c    nrow- number of rows in v = number of columns in matrix
c          that svd was performed on.
c    nv  - number of singular vectors to keep.  this normally
c          would correspond to the number of singular values kept
c          in a generalized inverse generated by a trucated svd.
c    r   - matrix of size at least nrow by nrow to hold resolution
c          matrix.  (no size checks are made)
c    n1r - first dimension of r in calling program.
c
c  language - fortran
c  author   - gary l. pavlis
c  written  - may 1981
c-------------------------------------------------------------------
      real v(n1v,nv),r(n1r,nrow)
      do 200 j=1,nrow
            do 100 i=j,nrow
                  r(i,j) = sdot(nv,v(i,1),n1v,v(j,1),n1v)
  100       continue
  200 continue
      call cpltut(r,n1r,nrow)
      return
      end

c $Id$


MODULE JULIANMOD
  ! ** AUTHOR: DANG HUU CHUNG
  ! ** DATE  : 2010-06-26
  USE GLOBAL

  IMPLICIT NONE
   ! ** JULIAN TIME
    INTEGER(IK4),PRIVATE  :: DA0             !BASE DAY
    INTEGER(IK4),PRIVATE  :: MN0             !BASE MONTH
    INTEGER(IK4),PRIVATE  :: YR0             !BASE YEAR
    INTEGER(IK4),PRIVATE  :: HH0             !BASE HH
    INTEGER(IK4),PRIVATE  :: MM0             !BASE MM
    INTEGER(IK4),PRIVATE  :: SS0             !BASE SS
    REAL(8),   PRIVATE  :: HR0

  CONTAINS

  FUNCTION JULIDAY(MM,ID,IYYY) RESULT(JULDAY)
    ! ** FROM A BOOK OF NUMERICAL METHODS
    INTEGER(IK4) :: JULDAY,ID,IYYY,MM,IGREG
    PARAMETER (IGREG=15+31*(10+12*1582))
    INTEGER(IK4) :: JA,JM,JY
    JY=IYYY
    IF( JY == 0) STOP 'JULDAY: THERE IS NO YEAR ZERO'
    IF( JY < 0) JY=JY+1
    IF( MM > 2 )THEN
      JM=MM+1
    ELSE
      JY=JY-1
      JM=MM+13
    ENDIF
    JULDAY=365*JY+INT(0.25D0*JY+2000D0)+INT(30.6001D0*JM)+ID+1718995
    IF( ID+31*(MM+12*IYYY).GE.IGREG )THEN
      JA=INT(0.01D0*JY)
      JULDAY=JULDAY+2-JA+INT(0.25D0*JA)
    ENDIF
    RETURN
  END FUNCTION

  SUBROUTINE CALDAT(JULIAN,MM,ID,IYYY)
    ! ** FROM A BOOK OF NUMERICAL METHODS
    INTEGER(IK4) :: ID,IYYY,JULIAN,MM,IGREG
    PARAMETER (IGREG=2299161)
    INTEGER(IK4) :: JA,JALPHA,JB,JC,JD,JE
    IF( JULIAN.GE.IGREG )THEN
      JALPHA=INT(((JULIAN-1867216)-0.25D0)/36524.25D0)
      JA=JULIAN+1+JALPHA-INT(0.25D0*JALPHA)
    ELSEIF( JULIAN < 0 )THEN
      JA=JULIAN+36525*(1-JULIAN/36525)
    ELSE
      JA=JULIAN
    ENDIF
    JB=JA+1524
    JC=INT(6680.0D0+((JB-2439870)-122.1D0)/365.25D0)
    JD=365*JC+INT(0.25D0*JC)
    JE=INT((JB-JD)/30.6001D0)
    ID=JB-JD-INT(30.6001D0*JE)
    MM=JE-1
    IF( MM > 12 )MM=MM-12
    IYYY=JC-4715
    IF( MM > 2 )IYYY=IYYY-1
    IF( IYYY <= 0)IYYY=IYYY-1
    IF( JULIAN < 0 ) IYYY=IYYY-100*(1-JULIAN/36525)
    RETURN
  END SUBROUTINE

   SUBROUTINE DATEPRO(STR,YR,MN,DD)

     CHARACTER(*),INTENT(IN) :: STR
     CHARACTER(LEN=LEN_TRIM(STR)) :: SS
     INTEGER(IK4),INTENT(OUT) :: DD,MN,YR
     INTEGER(IK4) :: M,NL

     SS = STR
     NL=LEN_TRIM(SS)
     DO M=1,NL
       IF( SS(M:M) == '-' .OR. SS(M:M) == ':' .OR. SS(M:M) == '/' )THEN
         SS(M:M) =''
       ENDIF
     ENDDO
     READ(SS,*) YR,MN,DD

   END SUBROUTINE

  SUBROUTINE TOGREGOR(SDATETIME,DAYTIME)

    REAL(8),INTENT(IN) :: DAYTIME
    CHARACTER(*),INTENT(OUT) :: SDATETIME
    INTEGER(IK4) :: JD0,JULIAN,MN,DD,YR

    CALL DATEPRO(BASETIME,HH0,MM0,SS0)
    CALL DATEPRO(BASEDATE,YR0,MN0,DA0)

    HR0 = HH0+MM0/60._8+SS0/3600._8
    JD0 = JULIDAY(MN0,DA0,YR0)

    JULIAN = IDINT(DAYTIME+JD0)
    CALL CALDAT(JULIAN,MN,DD,YR)

    WRITE(SDATETIME,'(I4,I2.2,I2.2)') YR,MN,DD

  END SUBROUTINE

END MODULE