      SUBROUTINE MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, IHIZ, H,
     $                   LDH1, LDH2, Z, LDZ1, LDZ2, WR, WI, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Schur decomposition and the eigenvalues of a
C     product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper
C     Hessenberg matrix and H_2, ..., H_p upper triangular matrices,
C     without evaluating the product. Specifically, the matrices Z_i
C     are computed, such that
C
C             Z_1' * H_1 * Z_2 = T_1,
C             Z_2' * H_2 * Z_3 = T_2,
C                    ...
C             Z_p' * H_p * Z_1 = T_p,
C
C     where T_1 is in real Schur form, and T_2, ..., T_p are upper
C     triangular.
C
C     The routine works primarily with the Hessenberg and triangular
C     submatrices in rows and columns ILO to IHI, but optionally applies
C     the transformations to all the rows and columns of the matrices
C     H_i, i = 1,...,p. The transformations can be optionally
C     accumulated.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Indicates whether the user wishes to compute the full
C             Schur form or the eigenvalues only, as follows:
C             = 'E':  Compute the eigenvalues only;
C             = 'S':  Compute the factors T_1, ..., T_p of the full
C                     Schur form, T = T_1*T_2*...*T_p.
C
C     COMPZ   CHARACTER*1
C             Indicates whether or not the user wishes to accumulate
C             the matrices Z_1, ..., Z_p, as follows:
C             = 'N':  The matrices Z_1, ..., Z_p are not required;
C             = 'I':  Z_i is initialized to the unit matrix and the
C                     orthogonal transformation matrix Z_i is returned,
C                     i = 1, ..., p;
C             = 'V':  Z_i must contain an orthogonal matrix Q_i on
C                     entry, and the product Q_i*Z_i is returned,
C                     i = 1, ..., p.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix H.  N >= 0.
C
C     P       (input) INTEGER
C             The number of matrices in the product H_1*H_2*...*H_p.
C             P >= 1.
C
C     ILO     (input) INTEGER
C     IHI     (input) INTEGER
C             It is assumed that all matrices H_j, j = 2, ..., p, are
C             already upper triangular in rows and columns 1:ILO-1 and
C             IHI+1:N, and H_1 is upper quasi-triangular in rows and
C             columns 1:ILO-1 and IHI+1:N, with H_1(ILO,ILO-1) = 0
C             (unless ILO = 1), and H_1(IHI+1,IHI) = 0 (unless IHI = N).
C             The routine works primarily with the Hessenberg submatrix
C             in rows and columns ILO to IHI, but applies the
C             transformations to all the rows and columns of the
C             matrices H_i, i = 1,...,p, if JOB = 'S'.
C             1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N.
C
C     ILOZ    (input) INTEGER
C     IHIZ    (input) INTEGER
C             Specify the rows of Z to which the transformations must be
C             applied if COMPZ = 'I' or COMPZ = 'V'.
C             1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
C
C     H       (input/output) DOUBLE PRECISION array, dimension
C             (LDH1,LDH2,P)
C             On entry, the leading N-by-N part of H(*,*,1) must contain
C             the upper Hessenberg matrix H_1 and the leading N-by-N
C             part of H(*,*,j) for j > 1 must contain the upper
C             triangular matrix H_j, j = 2, ..., p.
C             On exit, if JOB = 'S', the leading N-by-N part of H(*,*,1)
C             is upper quasi-triangular in rows and columns ILO:IHI,
C             with any 2-by-2 diagonal blocks corresponding to a pair of
C             complex conjugated eigenvalues, and the leading N-by-N
C             part of H(*,*,j) for j > 1 contains the resulting upper
C             triangular matrix T_j.
C             If JOB = 'E', the contents of H are unspecified on exit.
C
C     LDH1    INTEGER
C             The first leading dimension of the array H.
C             LDH1 >= max(1,N).
C
C     LDH2    INTEGER
C             The second leading dimension of the array H.
C             LDH2 >= max(1,N).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension
C             (LDZ1,LDZ2,P)
C             On entry, if COMPZ = 'V', the leading N-by-N-by-P part of
C             this array must contain the current matrix Q of
C             transformations accumulated by SLICOT Library routine
C             MB03VY.
C             If COMPZ = 'I', Z need not be set on entry.
C             On exit, if COMPZ = 'V', or COMPZ = 'I', the leading
C             N-by-N-by-P part of this array contains the transformation
C             matrices which produced the Schur form; the
C             transformations are applied only to the submatrices
C             Z_j(ILOZ:IHIZ,ILO:IHI), j = 1, ..., P.
C             If COMPZ = 'N', Z is not referenced.
C
C     LDZ1    INTEGER
C             The first leading dimension of the array Z.
C             LDZ1 >= 1,        if COMPZ = 'N';
C             LDZ1 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'.
C
C     LDZ2    INTEGER
C             The second leading dimension of the array Z.
C             LDZ2 >= 1,        if COMPZ = 'N';
C             LDZ2 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             The real and imaginary parts, respectively, of the
C             computed eigenvalues ILO to IHI are stored in the
C             corresponding elements of WR and WI. If two eigenvalues
C             are computed as a complex conjugate pair, they are stored
C             in consecutive elements of WR and WI, say the i-th and
C             (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the
C             eigenvalues are stored in the same order as on the
C             diagonal of the Schur form returned in H.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= IHI-ILO+P-1.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, ILO <= i <= IHI, the QR algorithm
C                   failed to compute all the eigenvalues ILO to IHI
C                   in a total of 30*(IHI-ILO+1) iterations;
C                   the elements i+1:IHI of WR and WI contain those
C                   eigenvalues which have been successfully computed.
C
C     METHOD
C
C     A refined version of the QR algorithm proposed in [1] and [2] is
C     used. The elements of the subdiagonal, diagonal, and the first
C     supradiagonal of current principal submatrix of H are computed
C     in the process.
C
C     REFERENCES
C
C     [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P.
C         The periodic Schur decomposition: algorithms and applications.
C         Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
C         1992.
C
C     [2] Sreedhar, J. and Van Dooren, P.
C         Periodic Schur form and some matrix equations.
C         Proc. of the Symposium on the Mathematical Theory of Networks
C         and Systems (MTNS'93), Regensburg, Germany (U. Helmke,
C         R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable.
C
C     FURTHER COMMENTS
C
C     Note that for P = 1, the LAPACK Library routine DHSEQR could be
C     more efficient on some computer architectures than this routine,
C     because DHSEQR uses a block multishift QR algorithm.
C     When P is large and JOB = 'S', it could be more efficient to
C     compute the product matrix H, and use the LAPACK Library routines.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga,
C     German Aerospace Center, DLR Oberpfaffenhofen, February 1999.
C     Partly based on the routine PSHQR by A. Varga
C     (DLR Oberpfaffenhofen), January 22, 1996.
C
C     REVISIONS
C
C     Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Eigenvalue, eigenvalue decomposition, Hessenberg form,
C     orthogonal transformation, periodic systems, (periodic) Schur
C     form, real Schur form, similarity transformation, triangular form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, HALF
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
      DOUBLE PRECISION  DAT1, DAT2
      PARAMETER         ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER         COMPZ, JOB
      INTEGER           IHI, IHIZ, ILO, ILOZ, INFO, LDH1, LDH2, LDWORK,
     $                  LDZ1, LDZ2, N, P
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK( * ), H( LDH1, LDH2, * ), WI( * ),
     $                  WR( * ), Z( LDZ1, LDZ2, * )
C     ..
C     .. Local Scalars ..
      LOGICAL           INITZ, WANTT, WANTZ
      INTEGER           I, I1, I2, ITN, ITS, J, JMAX, JMIN, K, L, M,
     $                  NH, NR, NROW, NZ
      DOUBLE PRECISION  AVE, CS, DISC, H11, H12, H21, H22, H33, H33S,
     $                  H43H34, H44, H44S, HH10, HH11, HH12, HH21, HH22,
     $                  HP00, HP01, HP02, HP11, HP12, HP22, OVFL, S,
     $                  SMLNUM, SN, TAU, TST1, ULP, UNFL, V1, V2, V3
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION  V( 3 )
C     ..
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANHS, DLANTR
      EXTERNAL          DLAMCH, DLANHS, DLANTR, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLABAD, DLANV2, DLARFG, DLARFX, DLARTG,
     $                  DLASET, DROT, MB04PY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, MIN, SIGN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      WANTT = LSAME( JOB,   'S' )
      INITZ = LSAME( COMPZ, 'I' )
      WANTZ = LSAME( COMPZ, 'V' ) .OR. INITZ
      INFO = 0
      IF( .NOT. ( WANTT .OR. LSAME( JOB, 'E' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( WANTZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.1 ) THEN
         INFO = -4
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -6
      ELSE IF( ILOZ.LT.1 .OR. ILOZ.GT.ILO ) THEN
         INFO = -7
      ELSE IF( IHIZ.LT.IHI .OR. IHIZ.GT.N ) THEN
         INFO = -8
      ELSE IF( LDH1.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDH2.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDZ1.LT.1 .OR. ( WANTZ .AND. LDZ1.LT.N ) ) THEN
         INFO = -13
      ELSE IF( LDZ2.LT.1 .OR. ( WANTZ .AND. LDZ2.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDWORK.LT.IHI - ILO + P - 1 ) THEN
         INFO = -18
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( ILO.GT.1 ) THEN
            IF( H( ILO, ILO-1, 1 ).NE.ZERO )
     $         INFO = -5
         ELSE IF( IHI.LT.N ) THEN
            IF( H( IHI+1, IHI, 1 ).NE.ZERO )
     $         INFO = -6
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03WD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Initialize Z, if necessary.
C
      IF( INITZ ) THEN
C
         DO 10 J = 1, P
            CALL DLASET( 'Full', N, N, ZERO, ONE, Z( 1, 1, J ), LDZ1 )
   10    CONTINUE
C
      END IF
C
      NH = IHI - ILO + 1
C
      IF( NH.EQ.1 ) THEN
         HP00 = ONE
C
         DO 20 J = 1, P
            HP00 = HP00 * H( ILO, ILO, J )
   20    CONTINUE
C
         WR( ILO ) = HP00
         WI( ILO ) = ZERO
         RETURN
      END IF
C
C     Set machine-dependent constants for the stopping criterion.
C     If norm(H) <= sqrt(OVFL), overflow should not occur.
C
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      SMLNUM = UNFL*( DBLE( NH ) / ULP )
C
C     Set the elements in rows and columns ILO to IHI to zero below the
C     first subdiagonal in H(*,*,1) and below the first diagonal in
C     H(*,*,j), j >= 2. In the same loop, compute and store in
C     DWORK(NH:NH+P-2) the 1-norms of the matrices H_2, ..., H_p, to be
C     used later.
C
      I = NH
      S = ULP * DBLE( N )
      IF( NH.GT.2 )
     $   CALL DLASET( 'Lower', NH-2, NH-2, ZERO, ZERO,
     $                H( ILO+2, ILO, 1 ), LDH1 )
C
      DO 30 J = 2, P
         CALL DLASET( 'Lower', NH-1, NH-1, ZERO, ZERO,
     $                H( ILO+1, ILO, J ), LDH1 )
         DWORK( I ) = S * DLANTR( '1-norm', 'Upper', 'NonUnit', NH, NH,
     $                            H( ILO, ILO, J ), LDH1, DWORK )
         I = I + 1
   30 CONTINUE
C
C     I1 and I2 are the indices of the first row and last column of H
C     to which transformations must be applied. If eigenvalues only are
C     being computed, I1 and I2 are set inside the main loop.
C
      IF( WANTT ) THEN
         I1 = 1
         I2 = N
      END IF
C
      IF( WANTZ )
     $   NZ = IHIZ - ILOZ + 1
C
C     ITN is the total number of QR iterations allowed.
C
      ITN = 30*NH
C
C     The main loop begins here. I is the loop index and decreases from
C     IHI to ILO in steps of 1 or 2. Each iteration of the loop works
C     with the active submatrix in rows and columns L to I.
C     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
C     H(L,L-1) is negligible so that the matrix splits.
C
      I = IHI
C
   40 CONTINUE
      L = ILO
C
C     Perform QR iterations on rows and columns ILO to I until a
C     submatrix of order 1 or 2 splits off at the bottom because a
C     subdiagonal element has become negligible.
C
C     Let T = H_2*...*H_p, and H = H_1*T. Part of the currently
C     free locations of WR and WI are temporarily used as workspace.
C
C     WR(L:I):      the current diagonal elements of h = H(L:I,L:I);
C     WI(L+1:I):    the current elements of the first subdiagonal of h;
C     DWORK(NH-I+L:NH-1): the current elements of the first
C                   supradiagonal of h.
C
      DO 160 ITS = 0, ITN
C
C        Initialization: compute H(I,I) (and H(I,I-1) if I > L).
C
         HP22 = ONE
         IF( I.GT.L ) THEN
            HP12 = ZERO
            HP11 = ONE
C
            DO 50 J = 2, P
               HP22 = HP22*H( I,   I,   J )
               HP12 = HP11*H( I-1, I,   J ) + HP12*H( I, I, J )
               HP11 = HP11*H( I-1, I-1, J )
   50       CONTINUE
C
            HH21 = H( I, I-1, 1 )*HP11
            HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22
C
            WR( I ) = HH22
            WI( I ) = HH21
         ELSE
C
            DO 60 J = 1, P
               HP22 = HP22*H( I, I, J )
   60       CONTINUE
C
            WR( I ) = HP22
         END IF
C
C        Look for a single small subdiagonal element.
C        The loop also computes the needed current elements of the
C        diagonal and the first two supradiagonals of T, as well as
C        the current elements of the central tridiagonal of H.
C
         DO 80 K = I, L + 1, -1
C
C           Evaluate H(K-1,K-1), H(K-1,K) (and H(K-1,K-2) if K > L+1).
C
            HP00 = ONE
            HP01 = ZERO
            IF( K.GT.L+1 ) THEN
               HP02 = ZERO
C
               DO 70 J = 2, P
                  HP02 = HP00*H( K-2, K,   J ) + HP01*H( K-1, K,   J )
     $                                         + HP02*H( K,   K,   J )
                  HP01 = HP00*H( K-2, K-1, J ) + HP01*H( K-1, K-1, J )
                  HP00 = HP00*H( K-2, K-2, J )
   70          CONTINUE
C
               HH10 = H( K-1, K-2, 1 )*HP00
               HH11 = H( K-1, K-2, 1 )*HP01 + H( K-1, K-1, 1 )*HP11
               HH12 = H( K-1, K-2, 1 )*HP02 + H( K-1, K-1, 1 )*HP12
     $                                      + H( K-1, K,   1 )*HP22
               WI( K-1 ) = HH10
            ELSE
               HH10 = ZERO
               HH11 = H( K-1, K-1, 1 )*HP11
               HH12 = H( K-1, K-1, 1 )*HP12 + H( K-1, K, 1 )*HP22
            END IF
            WR( K-1 ) = HH11
            DWORK( NH-I+K-1) = HH12
C
C           Test for a negligible subdiagonal element.
C
            TST1 = ABS( HH11 ) + ABS( HH22 )
            IF( TST1.EQ.ZERO )
     $         TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1,
     $                        DWORK )
            IF( ABS( HH21 ).LE.MAX( ULP*TST1, SMLNUM ) )
     $         GO TO 90
C
C           Update the values for the next cycle.
C
            HP22 = HP11
            HP11 = HP00
            HP12 = HP01
            HH22 = HH11
            HH21 = HH10
   80    CONTINUE
C
   90    CONTINUE
         L = K
C
         IF( L.GT.ILO ) THEN
C
C           H(L,L-1) is negligible.
C
            IF( WANTT ) THEN
C
C              If H(L,L-1,1) is also negligible, set it to 0; otherwise,
C              annihilate the subdiagonal elements bottom-up, and
C              restore the triangular form of H(*,*,j). Since H(L,L-1)
C              is negligible, the second case can only appear when the
C              product of H(L-1,L-1,j), j >= 2, is negligible.
C
               TST1 = ABS( H( L-1, L-1, 1 ) ) + ABS( H( L, L, 1 ) )
               IF( TST1.EQ.ZERO )
     $            TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1,
     $                           DWORK )
               IF( ABS( H( L, L-1, 1 ) ).GT.MAX( ULP*TST1, SMLNUM ) )
     $            THEN
C
                  DO 110 K = I, L, -1
C
                     DO 100 J = 1, P - 1
C
C                       Compute G to annihilate from the right the
C                       (K,K-1) element of the matrix H_j.
C
                        V( 1 ) = H( K, K-1, J )
                        CALL DLARFG( 2, H( K, K, J ), V, 1, TAU )
                        H( K, K-1, J ) = ZERO
                        V( 2 ) = ONE
C
C                       Apply G from the right to transform the columns
C                       of the matrix H_j in rows I1 to K-1.
C
                        CALL DLARFX( 'Right', K-I1, 2, V, TAU,
     $                               H( I1, K-1, J ), LDH1, DWORK )
C
C                       Apply G from the left to transform the rows of
C                       the matrix H_(j+1) in columns K-1 to I2.
C
                        CALL DLARFX( 'Left', 2, I2-K+2, V, TAU,
     $                               H( K-1, K-1, J+1 ), LDH1, DWORK )
C
                        IF( WANTZ ) THEN
C
C                          Accumulate transformations in the matrix
C                          Z_(j+1).
C
                           CALL DLARFX( 'Right', NZ, 2, V, TAU,
     $                                  Z( ILOZ, K-1, J+1 ), LDZ1,
     $                                  DWORK )
                        END IF
  100                CONTINUE
C
                     IF( K.LT.I ) THEN
C
C                       Compute G to annihilate from the right the
C                       (K+1,K) element of the matrix H_p.
C
                        V( 1 ) = H( K+1, K, P )
                        CALL DLARFG( 2, H( K+1, K+1, P ), V, 1, TAU )
                        H( K+1, K, P ) = ZERO
                        V( 2 ) = ONE
C
C                       Apply G from the right to transform the columns
C                       of the matrix H_p in rows I1 to K.
C
                        CALL DLARFX( 'Right', K-I1+1, 2, V, TAU,
     $                               H( I1, K, P ), LDH1, DWORK )
C
C                       Apply G from the left to transform the rows of
C                       the matrix H_1 in columns K to I2.
C
                        CALL DLARFX( 'Left', 2, I2-K+1, V, TAU,
     $                               H( K, K, 1 ), LDH1, DWORK )
C
                        IF( WANTZ ) THEN
C
C                          Accumulate transformations in the matrix Z_1.
C
                           CALL DLARFX( 'Right', NZ, 2, V, TAU,
     $                                  Z( ILOZ, K, 1 ), LDZ1, DWORK )
                        END IF
                     END IF
  110             CONTINUE
C
                  H( L, L-1, P ) = ZERO
               END IF
               H( L, L-1, 1 ) = ZERO
            END IF
         END IF
C
C        Exit from loop if a submatrix of order 1 or 2 has split off.
C
         IF( L.GE.I-1 )
     $      GO TO 170
C
C        Now the active submatrix is in rows and columns L to I. If
C        eigenvalues only are being computed, only the active submatrix
C        need be transformed.
C
         IF( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
C
         IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
C
C           Exceptional shift.
C
            S   = ABS( WI( I ) ) + ABS( WI( I-1 ) )
            H44 = DAT1*S + WR( I )
            H33 = H44
            H43H34 = DAT2*S*S
         ELSE
C
C           Prepare to use Francis' double shift (i.e., second degree
C           generalized Rayleigh quotient).
C
            H44 = WR( I )
            H33 = WR( I-1 )
            H43H34 = WI( I )*DWORK( NH-1 )
            DISC = ( H33 - H44 )*HALF
            DISC = DISC*DISC + H43H34
            IF( DISC.GT.ZERO ) THEN
C
C              Real roots: use Wilkinson's shift twice.
C
               DISC = SQRT( DISC )
               AVE  = HALF*( H33 + H44 )
               IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN
                  H33 = H33*H44 - H43H34
                  H44 = H33 / ( SIGN( DISC, AVE ) + AVE )
               ELSE
                  H44 = SIGN( DISC, AVE ) + AVE
               END IF
               H33 = H44
               H43H34 = ZERO
            END IF
         END IF
C
C        Look for two consecutive small subdiagonal elements.
C
         DO 120 M = I - 2, L, -1
C
C           Determine the effect of starting the double-shift QR
C           iteration at row M, and see if this would make H(M,M-1)
C           negligible.
C
            H11  = WR( M )
            H12  = DWORK( NH-I+M )
            H21  = WI( M+1 )
            H22  = WR( M+1 )
            H44S = H44 - H11
            H33S = H33 - H11
            V1   = ( H33S*H44S - H43H34 ) / H21 + H12
            V2   = H22 - H11 - H33S - H44S
            V3   = WI( M+2 )
            S    = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
            V1   = V1 / S
            V2   = V2 / S
            V3   = V3 / S
            V( 1 ) = V1
            V( 2 ) = V2
            V( 3 ) = V3
            IF( M.EQ.L )
     $         GO TO 130
            TST1 = ABS( V1 )*( ABS( WR( M-1 ) ) +
     $                         ABS( H11 ) + ABS( H22 ) )
            IF( ABS( WI( M ) )*( ABS( V2 ) + ABS( V3 ) ).LE.ULP*TST1 )
     $         GO TO 130
  120    CONTINUE
C
  130    CONTINUE
C
C        Double-shift QR step.
C
         DO 150 K = M, I - 1
C
C           The first iteration of this loop determines a reflection G
C           from the vector V and applies it from left and right to H,
C           thus creating a nonzero bulge below the subdiagonal.
C
C           Each subsequent iteration determines a reflection G to
C           restore the Hessenberg form in the (K-1)th column, and thus
C           chases the bulge one step toward the bottom of the active
C           submatrix. NR is the order of G.
C
            NR   = MIN( 3, I-K+1 )
            NROW = MIN( K+NR, I ) - I1 + 1
            IF( K.GT.M )
     $         CALL DCOPY( NR, H( K, K-1, 1 ), 1, V, 1 )
            CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU )
            IF( K.GT.M ) THEN
               H( K,   K-1, 1 ) = V( 1 )
               H( K+1, K-1, 1 ) = ZERO
               IF( K.LT.I-1 )
     $            H( K+2, K-1, 1 ) = ZERO
            ELSE IF( M.GT.L ) THEN
               H( K, K-1, 1 ) = -H( K, K-1, 1 )
            END IF
C
C           Apply G from the left to transform the rows of the matrix
C           H_1 in columns K to I2.
C
            CALL MB04PY( 'Left', NR, I2-K+1, V( 2 ), TAU, H( K, K, 1 ),
     $                   LDH1, DWORK )
C
C           Apply G from the right to transform the columns of the
C           matrix H_p in rows I1 to min(K+NR,I).
C
            CALL MB04PY( 'Right', NROW, NR, V( 2 ), TAU, H( I1, K, P ),
     $                   LDH1, DWORK )
C
            IF( WANTZ ) THEN
C
C              Accumulate transformations in the matrix Z_1.
C
               CALL MB04PY( 'Right', NZ, NR, V( 2 ), TAU,
     $                      Z( ILOZ, K, 1 ), LDZ1, DWORK )
            END IF
C
            DO 140 J = P, 2, -1
C
C              Apply G1 (and G2, if NR = 3) from the left to transform
C              the NR-by-NR submatrix of H_j in position (K,K) to upper
C              triangular form.
C
C              Compute G1.
C
               CALL DCOPY( NR-1, H( K+1, K, J ), 1, V, 1 )
               CALL DLARFG( NR, H( K, K, J ), V, 1, TAU )
               H( K+1, K, J ) = ZERO
               IF( NR.EQ.3 )
     $            H( K+2, K, J ) = ZERO
C
C              Apply G1 from the left to transform the rows of the
C              matrix H_j in columns K+1 to I2.
C
               CALL MB04PY( 'Left', NR, I2-K, V, TAU, H( K, K+1, J ),
     $                      LDH1, DWORK )
C
C              Apply G1 from the right to transform the columns of the
C              matrix H_(j-1) in rows I1 to min(K+NR,I).
C
               CALL MB04PY( 'Right', NROW, NR, V, TAU, H( I1, K, J-1 ),
     $                      LDH1, DWORK )
C
               IF( WANTZ ) THEN
C
C                 Accumulate transformations in the matrix Z_j.
C
                  CALL MB04PY( 'Right', NZ, NR, V, TAU, Z( ILOZ, K, J ),
     $                         LDZ1, DWORK )
               END IF
C
               IF( NR.EQ.3 ) THEN
C
C                 Compute G2.
C
                  V( 1 ) = H( K+2, K+1, J )
                  CALL DLARFG( 2, H( K+1, K+1, J ), V, 1, TAU )
                  H( K+2, K+1, J ) = ZERO
C
C                 Apply G2 from the left to transform the rows of the
C                 matrix H_j in columns K+2 to I2.
C
                  CALL MB04PY( 'Left', 2, I2-K-1, V, TAU,
     $                         H( K+1, K+2, J ), LDH1, DWORK )
C
C                 Apply G2 from the right to transform the columns of
C                 the matrix H_(j-1) in rows I1 to min(K+3,I).
C
                  CALL MB04PY( 'Right', NROW, 2, V, TAU,
     $                         H( I1, K+1, J-1 ), LDH1, DWORK )
C
                  IF( WANTZ ) THEN
C
C                    Accumulate transformations in the matrix Z_j.
C
                     CALL MB04PY( 'Right', NZ, 2, V, TAU,
     $                            Z( ILOZ, K+1, J ), LDZ1, DWORK )
                  END IF
               END IF
  140       CONTINUE
C
  150    CONTINUE
C
  160 CONTINUE
C
C     Failure to converge in remaining number of iterations.
C
      INFO = I
      RETURN
C
  170 CONTINUE
C
      IF( L.EQ.I ) THEN
C
C        H(I,I-1,1) is negligible: one eigenvalue has converged.
C        Note that WR(I) has already been set.
C
         WI( I ) = ZERO
      ELSE IF( L.EQ.I-1 ) THEN
C
C        H(I-1,I-2,1) is negligible: a pair of eigenvalues have
C        converged.
C
C        Transform the 2-by-2 submatrix of H_1*H_2*...*H_p in position
C        (I-1,I-1) to standard Schur form, and compute and store its
C        eigenvalues. If the Schur form is not required, then the
C        previously stored values of a similar submatrix are used.
C        For real eigenvalues, a Givens transformation is used to
C        triangularize the submatrix.
C
         IF( WANTT ) THEN
            HP22 = ONE
            HP12 = ZERO
            HP11 = ONE
C
            DO 180 J = 2, P
               HP22 = HP22*H( I,   I,   J )
               HP12 = HP11*H( I-1, I,   J ) + HP12*H( I, I, J )
               HP11 = HP11*H( I-1, I-1, J )
  180       CONTINUE
C
            HH21 = H( I,   I-1, 1 )*HP11
            HH22 = H( I,   I-1, 1 )*HP12 + H( I,   I, 1 )*HP22
            HH11 = H( I-1, I-1, 1 )*HP11
            HH12 = H( I-1, I-1, 1 )*HP12 + H( I-1, I, 1 )*HP22
         ELSE
            HH11 = WR( I-1 )
            HH12 = DWORK( NH-1 )
            HH21 = WI( I )
            HH22 = WR( I )
         END IF
C
         CALL DLANV2( HH11, HH12, HH21, HH22, WR( I-1 ), WI( I-1 ),
     $                WR( I ), WI( I ), CS, SN )
C
         IF( WANTT ) THEN
C
C           Detect negligible diagonal elements in positions (I-1,I-1)
C           and (I,I) in H_j, J > 1.
C
            JMIN = 0
            JMAX = 0
C
            DO 190 J = 2, P
               IF( JMIN.EQ.0 ) THEN
                  IF( ABS( H( I-1, I-1, J ) ).LE.DWORK( NH+J-2 ) )
     $                JMIN = J
               END IF
               IF( ABS( H( I, I, J ) ).LE.DWORK( NH+J-2 ) ) JMAX = J
  190       CONTINUE
C
            IF( JMIN.NE.0 .AND. JMAX.NE.0 ) THEN
C
C              Choose the shorter path if zero elements in both
C              (I-1,I-1) and (I,I) positions are present.
C
               IF( JMIN-1.LE.P-JMAX+1 ) THEN
                  JMAX = 0
               ELSE
                  JMIN = 0
               END IF
            END IF
C
            IF( JMIN.NE.0 ) THEN
C
               DO 200 J = 1, JMIN - 1
C
C                 Compute G to annihilate from the right the (I,I-1)
C                 element of the matrix H_j.
C
                  V( 1 ) = H( I, I-1, J )
                  CALL DLARFG( 2, H( I, I, J ), V, 1, TAU )
                  H( I, I-1, J ) = ZERO
                  V( 2 ) = ONE
C
C                 Apply G from the right to transform the columns of the
C                 matrix H_j in rows I1 to I-1.
C
                  CALL DLARFX( 'Right', I-I1, 2, V, TAU,
     $                         H( I1, I-1, J ), LDH1, DWORK )
C
C                 Apply G from the left to transform the rows of the
C                 matrix H_(j+1) in columns I-1 to I2.
C
                  CALL DLARFX( 'Left', 2, I2-I+2, V, TAU,
     $                         H( I-1, I-1, J+1 ), LDH1, DWORK )
C
                  IF( WANTZ ) THEN
C
C                    Accumulate transformations in the matrix Z_(j+1).
C
                     CALL DLARFX( 'Right', NZ, 2, V, TAU,
     $                            Z( ILOZ, I-1, J+1 ), LDZ1, DWORK )
                  END IF
  200          CONTINUE
C
               H( I, I-1, JMIN ) = ZERO
C
            ELSE
               IF( JMAX.GT.0 .AND. WI( I-1 ).EQ.ZERO )
     $            CALL DLARTG( H( I-1, I-1, 1 ), H( I, I-1, 1 ), CS, SN,
     $                         TAU )
C
C              Apply the transformation to H.
C
               CALL DROT( I2-I+2, H( I-1, I-1, 1 ), LDH1,
     $                    H( I, I-1, 1 ), LDH1, CS, SN )
               CALL DROT( I-I1+1, H( I1, I-1, P ), 1, H( I1, I, P ), 1,
     $                    CS, SN )
               IF( WANTZ ) THEN
C
C                 Apply transformation to Z_1.
C
                  CALL DROT( NZ, Z( ILOZ, I-1, 1 ), 1, Z( ILOZ, I, 1 ),
     $                       1, CS, SN )
               END IF
C
               DO 210 J = P, MAX( 2, JMAX+1 ), -1
C
C                 Compute G1 to annihilate from the left the (I,I-1)
C                 element of the matrix H_j.
C
                  V( 1 ) = H( I, I-1, J )
                  CALL DLARFG( 2, H( I-1, I-1, J ), V, 1, TAU )
                  H( I, I-1, J ) = ZERO
C
C                 Apply G1 from the left to transform the rows of the
C                 matrix H_j in columns I to I2.
C
                  CALL MB04PY( 'Left', 2, I2-I+1, V, TAU,
     $                         H( I-1, I, J ), LDH1, DWORK )
C
C                 Apply G1 from the right to transform the columns of
C                 the matrix H_(j-1) in rows I1 to I.
C
                  CALL MB04PY( 'Right', I-I1+1, 2, V, TAU,
     $                         H( I1, I-1, J-1 ), LDH1, DWORK )
C
                  IF( WANTZ ) THEN
C
C                    Apply G1 to Z_j.
C
                     CALL MB04PY( 'Right', NZ, 2, V, TAU,
     $                            Z( ILOZ, I-1, J ), LDZ1, DWORK )
                  END IF
  210          CONTINUE
C
               IF( JMAX.GT.0 ) THEN
                  H( I, I-1, 1 )    = ZERO
                  H( I, I-1, JMAX ) = ZERO
               ELSE
                  IF( HH21.EQ.ZERO )
     $               H( I, I-1, 1 ) = ZERO
               END IF
            END IF
         END IF
      END IF
C
C     Decrement number of remaining iterations, and return to start of
C     the main loop with new value of I.
C
      ITN = ITN - ITS
      I = L - 1
      IF( I.GE.ILO )
     $   GO TO 40
C
      RETURN
C
C *** Last line of MB03WD ***
      END


	subroutine astr(d1,h,pp,s,p,np,dh,dpp,ds,dp,dnp)
c	this subroutine calculates the following five ephermides
c	of the sun and moon
c	h = mean longitude of the sum
c	pp = mean longitude of the solar perigee
c	s = mean longitude of the moon
c	p = mean longitude of the lunar perigee
c	np = negative of the longitude of the mean ascending node
c	and their rates of change.
c	Units for the ephermides are cycles and for their derivatives
c	are cycles/365 days
c	The formulae for calculating this ephermides were taken from
c	pages 98 and 107 of the Explanatory Supplement to the
c	Astronomical Ephermeris and the American Ephermis and
c	Nautical Almanac (1961)
c
c	implicit real*8(a-h,o-z)
	real*8      np,d1,h,pp,s,p,dh,dpp,ds,dp,dnp,d2,f,f2
	d2=d1*1.d-4
	f=360.d0
	f2=f/365.d0
	h=279.696678d0+.9856473354d0*d1+.00002267d0*d2*d2
	pp=281.220833d0+.0000470684d0*d1+.0000339d0*d2*d2+
     1  .00000007d0*d2**3
	s=270.434164d0+13.1763965268d0*d1-.000085d0*d2*d2+
     1  .000000039d0*d2**3
	p=334.329556d0+.1114040803d0*d1-.0007739d0*d2*d2-
     1  .00000026d0*d2**3
	np=-259.183275d0+.0529539222d0*d1-.0001557d0*d2*d2-
     1  .00000005d0*d2**3
	h=h/f
	pp=pp/f
	s=s/f
	p=p/f
	np=np/f
	h=h-dint(h)
	pp=pp-dint(pp)
	s=s-dint(s)
	p=p-dint(p)
	np=np-dint(np)
	dh=.9856473354d0+2.d-8*.00002267d0*d1
	dpp=.0000470684d0+2.d-8*.0000339d0*d1
     1  +3.d-12*.00000007d0*d1**2
	ds=13.1763965268d0-2.d-8*.000085d0*d1+
     1  3.d-12*.000000039d0*d1**2
	dp=.1114040803d0-2.d-8*.0007739d0*d1-
     1  3.d-12*.00000026d0*d1**2
	dnp=+.0529539222d0-2.d-8*.0001557d0*d1-
     1  3.d-12*.00000005d0*d1**2
	dh=dh/f2
	dpp=dpp/f2
	ds=ds/f2
	dp=dp/f2
	dnp=dnp/f2
	return
	end


program functions_02
implicit none
integer :: i
real :: f, g
i = 1
f = 3.5

g = mysum(i, f)

if (myabs(g-4.5) > 1e-5) error stop

contains

    real function mysum(a, b) result(c)
    integer, intent(in) :: a
    real, intent(in) :: b
    c = a + b
    end function

    real function myabs(a) result(c)
    real, intent(in) :: a
    if (a >= 0) then
        c = a
    else
        c = -a
    end if
    end function

end program


! Mikayla Webber
! 4670 Numerical Analysis
! Homework IVP Due 12.6.17

program testeuler
  implicit none
  integer :: i, neq, nsteps
  double precision, allocatable, dimension(:,:) :: archive
  double precision :: tin, tout, dt, a, b, x, y, xactual, yactual
  double precision, allocatable, dimension(:) :: yin, yout, t, f1, f2, u

  neq = 1
  nsteps = 50
  allocate(yin(neq), yout(neq), t(0:nsteps), u(neq), f1(neq), f2(neq), archive(neq, 0:nsteps))

  a = 1.0d0
  b = 2.0d0
  archive(:,0) = (/ 1.0d0, 0.0d0, 0.0d0, 1.0d0 /)
  dt = (b - a) / dble(nsteps)

  do i = 0, nsteps
    t(i) = (a + dble(i) * dt)
  end do

  archive(:,0) = (/ 1.0d0, 0.0d0, 0.0d0, 1.0d0 /)
  yin = archive(:,0)

  do i = 0, (nsteps - 1)
    tin = t(i)
    tout = t(i + 1)
    yin = archive(:,i)
    call computef(neq, tin, yin, f1)
    yout = (yin + (tout - tin) * (f1 + f2) / 2.0d0)
    archive(:,i+1) = yout
  end do

  print*, 'creating "out1"'
  open(unit=8, file='q1out1', status='replace')

  do i = 0, nsteps
    write(8,*) t(i), archive(1,i)
  end do

  close(8)

  print*, 'writing pcerror'
  open(unit=8, file='pcerror', status='replace')

  do i = 0, nsteps
    x = archive(1,i)
    y = archive(2,i)
    xactual = cos(t(i))
    yactual = t(i) / (1 + log(t(i)))
    write(8,*) i, sqrt((x - xactual)**2 + (y - yactual)**2)
  end do

  deallocate(yin, yout, archive, t, f1, f2)
  stop
end program testeuler

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

subroutine computef(neq, t, y, f)
  implicit none
  integer :: neq
  double precision :: f(neq)
  double precision, intent(in) :: t, y(neq)

  f(1) = (((1 + y(1)) / t) - (y(1) / t)**2)

  return
end


    Program dggevx_example

!     DGGEVX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dnrm2
      Use lapack_example_aux, Only: nagf_sort_realvec_rank, &
        nagf_sort_realvec_rank_rearrange
      Use lapack_interfaces, Only: dggevx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
      Logical, Parameter :: verbose = .False.
!     .. Local Scalars ..
      Complex (Kind=dp) :: eig
      Real (Kind=dp) :: abnrm, bbnrm, eps, jswap, rcnd, scal_i, scal_r, small
      Integer :: i, ifail, ihi, ilo, info, j, k, lda, ldb, ldvr, lwork, n
      Logical :: pair
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), alphai(:), alphar(:), b(:, :), &
        beta(:), lscale(:), rconde(:), rcondv(:), rscale(:), vr(:, :), &
        vr_row(:), work(:)
      Real (Kind=dp) :: dummy(1, 1)
      Integer, Allocatable :: iwork(:)
      Logical, Allocatable :: bwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, all, cmplx, epsilon, max, maxloc, nint, sqrt, sum, &
        tiny
!     .. Executable Statements ..
      Write (nout, *) 'DGGEVX Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvr = n
      Allocate (a(lda,n), alphai(n), alphar(n), b(ldb,n), beta(n), lscale(n), &
        rconde(n), rcondv(n), rscale(n), vr(ldvr,n), iwork(n+6), bwork(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dggevx('Balance', 'No vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, b, ldb, alphar, &
        alphai, beta, dummy, 1, vr, ldvr, ilo, ihi, lscale, rscale, abnrm, &
        bbnrm, rconde, rcondv, dummy, lwork, iwork, bwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+2*n)*n, nint(dummy(1,1)))
      Allocate (work(lwork))

!     Read in the matrices A and B

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Solve the generalized eigenvalue problem

      Call dggevx('Balance', 'No vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, b, ldb, alphar, &
        alphai, beta, dummy, 1, vr, ldvr, ilo, ihi, lscale, rscale, abnrm, &
        bbnrm, rconde, rcondv, work, lwork, iwork, bwork, info)

      If (info>0) Then
        Write (nout, *)
        Write (nout, 100) 'Failure in DGGEVX. INFO =', info
      Else

!       Compute the machine precision and the safe range parameter
!       small

        eps = epsilon(1.0E0_dp)
        small = tiny(1.0E0_dp)

!       If beta(:) > eps, Order eigenvalues by ascending real parts
        If (all(abs(beta(1:n))>eps)) Then
          work(1:n) = alphar(1:n)/beta(1:n)
          ifail = 0
          Call nagf_sort_realvec_rank(work, 1, n, 'Ascending', iwork, ifail)
          Call nagf_sort_realvec_rank_rearrange(alphar, 1, n, iwork, ifail)
          Call nagf_sort_realvec_rank_rearrange(alphai, 1, n, iwork, ifail)
          Call nagf_sort_realvec_rank_rearrange(beta, 1, n, iwork, ifail)
!         Order the eigenvectors in the same way
          Allocate (vr_row(n))
          Do j = 1, n
            vr_row(1:n) = vr(j, 1:n)
            Call nagf_sort_realvec_rank_rearrange(vr_row, 1, n, iwork, ifail)
            vr(j, 1:n) = vr_row(1:n)
          End Do
          Deallocate (vr_row)
        End If

!       Print out eigenvalues and vectors and associated condition
!       number and bounds

        pair = .False.
        Do j = 1, n

!         Print out information on the j-th eigenvalue

          Write (nout, *)
          If ((abs(alphar(j))+abs(alphai(j)))*small>=abs(beta(j))) Then
            Write (nout, 110) 'Eigenvalue(', j, ')', &
              ' is numerically infinite or undetermined', 'ALPHAR(', j, &
              ') = ', alphar(j), ', ALPHAI(', j, ') = ', alphai(j), ', BETA(', &
              j, ') = ', beta(j)
          Else
            If (.Not. pair) Then
              jswap = 1.0_dp
              If (alphai(j)>0.0_dp) Then
                jswap = -jswap
              End If
            End If
            If (alphai(j)==0.0E0_dp) Then
              Write (nout, 120) 'Eigenvalue(', j, ') = ', alphar(j)/beta(j)
            Else
              eig = cmplx(alphar(j), jswap*alphai(j), kind=dp)/ &
                cmplx(beta(j), kind=dp)
              Write (nout, 130) 'Eigenvalue(', j, ') = ', eig
            End If
          End If

          If (verbose) Then
            rcnd = rconde(j)
            Write (nout, *)
            Write (nout, 140) '  Reciprocal condition number = ', rcnd
          End If

!         Print out information on the j-th eigenvector

          Write (nout, *)
          Write (nout, 150) 'Eigenvector(', j, ')'
          If (alphai(j)==0.0E0_dp) Then
!           Let largest element be positive
            work(1:n) = abs(vr(1:n,j))
            k = maxloc(work(1:n), 1)
            If (vr(k,j)<0.0_dp) Then
              vr(1:n, j) = -vr(1:n, j)/dnrm2(n, vr(1,j), 1)
            End If
            Write (nout, 160)(vr(i,j), i=1, n)
          Else
            If (pair) Then
              Write (nout, 170)(vr(i,j-1), -jswap*vr(i,j), i=1, n)
            Else
!             Let largest element be real (and positive).
              work(1:n) = vr(1:n, j)**2 + vr(1:n, j+1)**2
              k = maxloc(work(1:n), 1)
              scal_r = vr(k, j)/sqrt(work(k))/sqrt(sum(work(1:n)))
              scal_i = -vr(k, j+1)/sqrt(work(k))/sqrt(sum(work(1:n)))
              work(1:n) = vr(1:n, j)
              vr(1:n, j) = scal_r*work(1:n) - scal_i*vr(1:n, j+1)
              vr(1:n, j+1) = scal_r*vr(1:n, j+1) + scal_i*work(1:n)
              vr(k, j+1) = 0.0_dp
              Write (nout, 170)(vr(i,j), jswap*vr(i,j+1), i=1, n)
            End If
            pair = .Not. pair
          End If
          If (verbose) Then
            rcnd = rcondv(j)
            Write (nout, *)
            Write (nout, 140) '  Reciprocal condition number = ', rcnd
          End If
        End Do

      End If

100   Format (1X, A, I4)
110   Format (/, 1X, A, I2, 2A, /, 1X, 2(A,I2,A,F11.5), A, I2, A, F11.5)
120   Format (/, 1X, A, I2, A, F11.5)
130   Format (/, 1X, A, I2, A, '(', F11.5, ',', F11.5, ')')
140   Format (1X, A, 1P, E8.1)
150   Format (1X, A, I2, A)
160   Format (1X, F11.5)
170   Format (1X, '(', F11.5, ',', F11.5, ')')
    End Program


module correlation

! JLR 30/6/2014
!
! uneven sampled correlation using Gaussian kernel using method of
! Rehfeld et al, Nonlinear Processes in Geophysics, 2011

implicit none

contains

function correlate_gaussian(x,y,tx,ty)
real :: correlate_gaussian

real, intent(in) :: x(:),y(:),tx(:),ty(:)
integer :: n,m,i,j
real :: b,h,d,xmean,ymean,txmean,tymean,delta_t,pi
real :: sdx(size(x)),sdy(size(x)),num(size(x))
real :: sdxg,sdyg,numg,deng

n=size(x,1)
m=size(y,1)

pi=abs(atan2(0.0,-1.0))

! calc mean for x series
xmean=0.0
do i=1,n
  xmean=xmean+x(i)
enddo
xmean=xmean/n
txmean=(tx(n)-tx(1))/(n-1)

! calc mean for y series
ymean=0.0
do j=1,m
  ymean=ymean+y(j)
enddo
ymean=ymean/m
tymean=(ty(m)-ty(1))/(m-1)

sdx=0.0
sdy=0.0
num=0.0
delta_t=max(txmean,tymean)
h=delta_t/4

!$acc kernels loop gang, vector(64)
do i=1,n
  do j=1,m
    d=ty(j)-tx(i)
    b=exp(-d**2/(2*h**2))/sqrt(2*pi*h)
    num(i)=num(i)+(x(i)-xmean)*(y(j)-ymean)*b
    sdx(i)=sdx(i)+b*(x(i)-xmean)**2
    sdy(i)=sdy(i)+b*(y(j)-ymean)**2
  enddo
enddo
!$acc end kernels

sdxg=0.0
sdyg=0.0
numg=0.0

do i=1,n
  sdxg=sdxg+sdx(i)
  sdyg=sdyg+sdy(i)
  numg=numg+num(i)
enddo

correlate_gaussian=numg/sqrt(sdxg*sdyg)

end function

end module


function r8_hypot ( x, y )

!*****************************************************************************80
!
!! R8_HYPOT returns the value of sqrt ( X^2 + Y^2).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 March 2012
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X, Y, the arguments.
!
!    Output, real ( kind = 8 ) R8_HYPOT, the value of sqrt ( X^2 + Y^2 ).
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) c
  real ( kind = 8 ) r8_hypot
  real ( kind = 8 ) x
  real ( kind = 8 ) y

  if ( abs ( x ) < abs ( y ) ) then
    a = abs ( y )
    b = abs ( x )
  else
    a = abs ( x )
    b = abs ( y )
  end if
!
!  A contains the larger value.
!
  if ( a == 0.0D+00 ) then
    c = 0.0D+00
  else
    c = a * sqrt ( 1.0D+00 + ( b / a )**2 )
  end if

  r8_hypot = c

  return
end

subroutine minfit_fort ( m, n, tol, ab, q )

!*****************************************************************************80
!
!! MINFIT computes the singular value decomposition of an N by N array.
!
!  Discussion:
!
!    This is an improved version of the EISPACK routine MINFIT
!    restricted to the case M = N and P = 0.
!
!    The singular values of the array AB are returned in Q.  AB is
!    overwritten with the orthogonal matrix V such that u.diag(q) = ab.v,
!    where U is another orthogonal matrix.
!
!    Thanks to Andreas Zuend for pointing out a potential for overflow in
!    the computation z = sqrt ( f*f + 1 ), 22 March 2012.
!
!  Modified:
!
!    22 March 2012
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, Jack Dongarra, Burton Garbow, Y Ikebe,
!    Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the leading dimension of AB, which must be
!    at least N.
!
!    Input, integer ( kind = 4 ) N, the order of the matrix AB.
!
!    Input, real ( kind = 8 ) TOL, a tolerance which determines when a vector
!    (a column or part of a column of the matrix) may be considered
!    "essentially" equal to zero.
!
!    Input/output, real ( kind = 8 ) AB(M,N).  On input, an N by N array whose
!    singular value decomposition is desired.  On output, ?
!
!    Input, real ( kind = 8 ) Q(N), ?
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) ab(m,n)
  real ( kind = 8 ) c
  real ( kind = 8 ) e(n)
  real ( kind = 8 ) eps
  real ( kind = 8 ) f
  real ( kind = 8 ) g
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kk
  integer ( kind = 4 ) kt
  integer ( kind = 4 ), parameter :: kt_max = 30
  integer ( kind = 4 ) l
  integer ( kind = 4 ) ll
  real ( kind = 8 ) q(n)
  real ( kind = 8 ) r8_hypot
  real ( kind = 8 ) s
  real ( kind = 8 ) temp
  real ( kind = 8 ) tol
  real ( kind = 8 ) x
  real ( kind = 8 ) y
  real ( kind = 8 ) z
!
!  Householder's reduction to bidiagonal form.
!
  if ( n == 1 ) then
    q(1) = ab(1,1)
    ab(1,1) = 1.0D+00
    return
  end if

  eps = epsilon ( eps )
  g = 0.0D+00
  x = 0.0D+00

  do i = 1, n

    e(i) = g
    l = i + 1

    s = sum ( ab(i:n,i)**2 )

    g = 0.0D+00

    if ( tol <= s ) then

      f = ab(i,i)

      g = sqrt ( s )
      if ( 0.0D+00 <= f ) then
        g = -g
      end if

      h = f * g - s
      ab(i,i) = f - g

      do j = l, n

        f = dot_product ( ab(i:n,i), ab(i:n,j) ) / h

        ab(i:n,j) = ab(i:n,j) + f * ab(i:n,i)

      end do

    end if

    q(i) = g

    s = sum ( ab(i,l:n)**2 )

    g = 0.0D+00

    if ( tol <= s ) then

      if ( i /= n ) then
        f = ab(i,i+1)
      end if

      g = sqrt ( s )
      if ( 0.0D+00 <= f ) then
        g = - g
      end if

      h = f * g - s

      if ( i /= n ) then

        ab(i,i+1) = f - g
        e(l:n) = ab(i,l:n) / h

        do j = l, n

          s = dot_product ( ab(j,l:n), ab(i,l:n) )

          ab(j,l:n) = ab(j,l:n) + s * e(l:n)

        end do

      end if

    end if

    y = abs ( q(i) ) + abs ( e(i) )

    x = max ( x, y )

  end do

!
!  Accumulation of right-hand transformations.
!
  ab(n,n) = 1.0D+00
  g = e(n)
  l = n

  do ii = 2, n

    i = n - ii + 1

    if ( g /= 0.0D+00 ) then

      h = ab(i,i+1) * g

      ab(l:n,i) = ab(i,l:n) / h

      do j = l, n

        s = dot_product ( ab(i,l:n), ab(l:n,j) )

        ab(l:n,j) = ab(l:n,j) + s * ab(l:n,i)

      end do

    end if

    ab(i,l:n) = 0.0D+00
    ab(l:n,i) = 0.0D+00
    ab(i,i) = 1.0D+00

    g = e(i)

    l = i
  end do

!
!  Diagonalization of the bidiagonal form.
!
  eps = eps * x

  do kk = 1, n

    k = n - kk + 1
    kt = 0

10  continue

    kt = kt + 1

    if ( kt_max < kt ) then
      e(k) = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'MINFIT - Warning!'
      write ( *, '(a)' ) '  The QR algorithm failed to converge.'
    end if

    do ll = 1, k

      l = k - ll + 1

      if ( abs ( e(l) ) <= eps ) then
        go to 20
      end if

      if ( l /= 1  .and. abs ( q(l-1) ) <= eps ) then
        exit
      end if

    end do
!
!  Cancellation of E(L) if 1 < L.
!
    c = 0.0D+00
    s = 1.0D+00

    do i = l, k

      f = s * e(i)
      e(i) = c * e(i)
      if ( abs ( f ) <= eps ) then
        exit
      end if
      g = q(i)
!
!  q(i) = h = sqrt(g*g + f*f).
!
      h = r8_hypot ( f, g )

      q(i) = h

      if ( h == 0.0D+00 ) then
        g = 1.0D+00
        h = 1.0D+00
      end if

      c = g / h
      s = - f / h

    end do
!
!  Test for convergence.
!
20  continue

    z = q(k)

    if ( l == k ) then
      if ( z < 0.0D+00 ) then
        q(k) = - z
        ab(1:n,k) = - ab(1:n,k)
      end if
      cycle
    end if
!
!  Shift from bottom 2*2 minor.
!
    x = q(l)
    y = q(k-1)
    g = e(k-1)
    h = e(k)
    f = ( ( y - z ) * ( y + z ) + ( g - h ) * ( g + h ) ) / ( 2.0D+00 * h * y )

    g = r8_hypot ( f, 1.0D+00 )

    if ( f < 0.0D+00 ) then
      temp = f - g
    else
      temp = f + g
    end if

    f = ( ( x - z ) * ( x + z ) + h * ( y / temp - h ) ) / x
!
!  Next QR transformation.
!
    c = 1.0D+00
    s = 1.0D+00

    do i = l + 1, k

      g = e(i)
      y = q(i)
      h = s * g
      g = g * c

      z = r8_hypot ( f, h )

      e(i-1) = z

      if ( z == 0.0D+00 ) then
        f = 1.0D+00
        z = 1.0D+00
      end if

      c = f / z
      s = h / z
      f =   x * c + g * s
      g = - x * s + g * c
      h = y * s
      y = y * c

      do j = 1, n
        x = ab(j,i-1)
        z = ab(j,i)
        ab(j,i-1) = x * c + z * s
        ab(j,i) = - x * s + z * c
      end do

      z = r8_hypot ( f, h )

      q(i-1) = z

      if ( z == 0.0D+00 ) then
        f = 1.0D+00
        z = 1.0D+00
      end if

      c = f / z
      s = h / z
      f = c * g + s * y
      x = - s * g + c * y

    end do

    e(l) = 0.0D+00
    e(k) = f
    q(k) = x
    go to 10

  end do

  return
end


!------------------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in           !
!  continuous development by various groups and is based on information        !
!  from these groups: Federal Government employees, contractors working        !
!  within a United States Government contract, and non-Federal sources         !
!  including research institutions.  These groups give the Government          !
!  permission to use, prepare derivative works of, and distribute copies       !
!  of their work in the CMAQ system to the public and to permit others         !
!  to do so.  The United States Environmental Protection Agency                !
!  therefore grants similar permission to use the CMAQ system software,        !
!  but users are requested to provide copies of derivative works or            !
!  products designed to operate in the CMAQ system to the United States        !
!  Government without restrictions as to use by others.  Software              !
!  that is used with the CMAQ system but distributed under the GNU             !
!  General Public License or the GNU Lesser General Public License is          !
!  subject to their copyright restrictions.                                    !
!------------------------------------------------------------------------------!

REAL FUNCTION mapfac_merc (phi)

!-------------------------------------------------------------------------------
! Name:     Map-Scale Factor for Mercator projection
! Purpose:  Calculates map-scale factors for Mercator projection from latitude.
! Notes:    Equation taken from "Numerical Prediction and Dynamic Meteorology",
!           Second Edition, by George J. Haltiner and Roger Terry Williams
!           (1980), pp. 13.
! Revised:  15 Sep 2009  Original version.  (T. Otte)
!           07 Sep 2011  Updated disclaimer.  (T. Otte)
!-------------------------------------------------------------------------------

  IMPLICIT NONE

  REAL(8)                      :: deg2rad ! convert degrees to radians
  REAL,          INTENT(IN)    :: phi     ! latitude [deg]
  REAL(8)                      :: phirad  ! latitude [rad]
  REAL(8)                      :: pi
  REAL(8)                      :: piover4 ! pi/4

!-------------------------------------------------------------------------------
! Compute constants.
!-------------------------------------------------------------------------------

  piover4 = DATAN(1.0d0)
  pi      = 4.0d0 * piover4
  deg2rad = pi / 1.8d2

!-------------------------------------------------------------------------------
! Compute map-scale factor, MAPFAC.
!
! M(phi) = COS phi0 / COS phi
!
!   where phi0 is the latitude of the "true" projection (assumed to be equator)
!-------------------------------------------------------------------------------

  phirad = DBLE(phi) * deg2rad  ! convert PHI from degrees to radians

  mapfac_merc = REAL( 1.0d0 / DCOS(phirad) )

END FUNCTION mapfac_merc


program complex_02
implicit none

complex :: x, z, w, i_
real :: a, b

x = (1.0,-3.0)
a = 3.0
b = 4.0
i_ = (0, 1)
z = a + i_*b
w = a+b + i_*(a-b)

print *, x, z, w

end program


      SUBROUTINE PEARSN(X,Y,N,R,PROB,Z)
      PARAMETER (TINY=1.E-20)
      DIMENSION X(N),Y(N)
      AX=0.
      AY=0.
      DO 11 J=1,N
        AX=AX+X(J)
        AY=AY+Y(J)
11    CONTINUE
      AX=AX/N
      AY=AY/N
      SXX=0.
      SYY=0.
      SXY=0.
      DO 12 J=1,N
        XT=X(J)-AX
        YT=Y(J)-AY
        SXX=SXX+XT**2
        SYY=SYY+YT**2
        SXY=SXY+XT*YT
12    CONTINUE
      R=SXY/SQRT(SXX*SYY)
      Z=0.5*ALOG(((1.+R)+TINY)/((1.-R)+TINY))
      DF=N-2
      T=R*SQRT(DF/(((1.-R)+TINY)*((1.+R)+TINY)))
      PROB=BETAI(0.5*DF,0.5,DF/(DF+T**2))
C     PROB=ERFCC(ABS(Z*SQRT(N-1.))/1.4142136)
      RETURN
      END


subroutine julian (year, month, day, hour, minute, second, julian_date)
    implicit none
    integer, intent(in) :: year, month, day, hour, minute
    real*8, intent(in) :: second
    real*8, intent(out) :: julian_date

    real*8 UT, Term1
    integer Term2, Term3

    Term1 = 367.000 * year
    Term2 = INT((7 * (year + INT((month + 9) / 12))) / 4)
    Term3 = INT(275 * month / 9)
    UT = ((second / 60.000 + minute) / 60.000 + hour) / 24.000

    julian_date = (Term1 - Term2 + Term3) + Day + 1721013.500 + UT

    return
    end subroutine

real*8 function greenwich_sidereal (julian_date)
    use constants
    implicit none
    real*8, intent(in) :: julian_date
    real*8 temp, tu

    tu = ( DINT(julian_date) + 0.500 - 2451545.000 ) / (36525.000)
    temp = 1.75336855900 + 628.331970500 * tu + 6.7707081270 - 06 * tu ** 2 + radperday * DBLE (julian_date-DINT(julian_date) - 0.5)

    temp = DMOD (temp, twopi)
    if ( temp<0.000) then
        temp = temp + twopi
    endif

    greenwich_sidereal = temp

    return
    end function

subroutine local_sidereal (julian_date, lon, lst)
    use constants
    implicit none
    real*8, intent(in) :: julian_date, lon
    real*8, intent(out) :: lst

    external greenwich_sidereal
    real*8 greenwich_sidereal, gst

    gst = greenwich_sidereal(julian_date)
    lst = lon + gst

    lst = DMOD ( lst, twopi)
    if (lst<0.000) then
        lst = lst + twopi
    endif

    return
    end subroutine

!subroutine inverse_julian (julian_date)
!    implicit none
!    real*8 temp, tu, days
!    integer year, month, day, hour, minute, sec, leapyears
!
!    temp = julian_date - 2415019.5
!    tu = temp / 365.25
!    year = 1900 + trunc(tu)
!    leapyears = trunc((year - 1900 - 1) / 4.0)
!    days = temp - ((year - 1900) * 365.0 + leapyears)
!
!    if (days < 1.0) then
!        year = year - 1
!        leapyears = trunc((year - 1900 - 1) / 4.0)
!        days = temp - ((year - 1900) * 365.0 + leapyears)
!    end if
!
!    return
!    end subroutine

!subroutine sunrise_sunset (julian_date, lat, lon, which, sunrise, sunset)
!    use constants
!    implicit none
!
!    real*8 julian_date, lat, lon, sunrise, sunset
!    character which
!    real*8 z, t, m, l, ra, sindelta, delta, h, sec, days, rad
!    integer year, month, day, hr, min
!
!    rad = 57.2957795130823000
!
!    if (which == 's') then
!        z = (90.000 + 50.000 / 60.000) / rad
!    elseif (which == 'c') then
!        z = 96.000 / rad
!    elseif (which == 'n') then
!        z = 102.000 / rad
!    elseif (which == 'a') then
!        z = 108.000 / rad
!    end if
!
!    end subroutine


C
C**************************  NUDWXY ************************************
C
C  calculate horizontal weighting function W(x,y) for nudging
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION NUDWXY(WFLAG,XX,YY,XXO,YYO,RXY)
C
      IMPLICIT NONE
      INTEGER  WFLAG
      REAL*8   R2,D2
      REAL*8   XX,YY,XXO,YYO,RXY
C
      R2=RXY*RXY
      D2=(XX-XXO)*(XX-XXO) + (YY-YYO)*(YY-YYO)
      IF (WFLAG .EQ. 0) THEN
         IF (D2 .LE. R2) THEN
            NUDWXY=(R2-D2)/(R2+D2)
         ELSE
            NUDWXY=0.0D0
         END IF
      ELSE
         NUDWXY=DEXP(-1.0d0*(D2/R2))
      END IF
C
      RETURN
      END


!!!!!!!!!!!!!!!!!NOTE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!! O2- species 1;O - species 2;!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!Adaptive Explicit Method!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program main

implicit none

real(8),parameter :: Runiv=8314.34d0,M1=32d0,M2=16d0,TB1=1d0,TB2=3d0,Cf=2.75e16,eta=-1d0, &
                     theta=59500d0,Ti= 4150,rhoi=3.35e-4                                                   ! intial,fixed values
real(8),parameter,dimension(7) :: A1=(/3.660960830d+00,6.56365523d-04,-1.41149485d-07, &                   ! O2 aboveT=1000K
                                       2.05797658d-11,-1.29913248d-15,-1.21597725d+03,3.41536184d+00/), &
                                  A2=(/2.54363697d+00,-2.73162486d-05,-4.19029520d-09, &                   ! O  aboveT=1000K
                                       4.95481845d-12,-4.79553694d-16,2.92260120d+04,4.92229457d+00/)
real(8),parameter,dimension(7) :: B1=(/3.78245636d+00,-2.99673415d-03,9.84730200d-06,  &
                                      -9.68129508d-09,3.24372836d-12,-1.06394356d+03,3.65767573d+00/), &    ! O2 below T=1000K
                                  B2=(/3.16826710d+00,-3.27931884d-03,6.64306396d-06,  &
                                      -6.12806624d-09,2.11265971d-12,2.91222592d+04,2.05193346d+00/)        ! O below T=1000K
real(8),dimension(7):: A,B,A1h,B1h,A2h,B2h

real(8) :: T,rho1,rho2,kf,hi,ei,e1,e2,engi,eng,eng1,eng2,h1,h2,d1dt,gp,gr,dg,keq,dt,deng,dengdT,time,  &
           res0,res,res0T,resT,relax,dt0,Told
integer :: nitermax,nmax,n,i
rho1=0d0
rho2=0d0
T=Ti
dt0= 1e-3
nitermax = 1000
nmax = 1000000
time=0
relax=0.5

 A1h=A1/32;
 A2h=A2/16;
 B1h=B1/32;
 B2h=B2/16;

rho1=rhoi
rho2=rhoi-rho1

hi =Runiv*(A1h(1)*Ti        &
      +A1h(2)*(Ti**2)/2     &
      +A1h(3)*(Ti**3)/3     &
      +A1h(4)*(Ti**4)/4     &
      +A1h(5)*(Ti**5)/5     &
      +A1h(6))

ei  = hi - Runiv*Ti/M1
engi=rhoi*ei

open (unit = 2, file = "data.dat")
dt =dt0
!!!Loop starts!!!!!!!!!!!

do i=1,nmax

if (T<=1000) then
A=B1h
B=B2h
elseif (T>1000) then
A=A1h
B=A2h
endif

!!!!!!keq,kf computation!!!!!!!!!

gr = Runiv*M1*(A(1)*(1-log(T))*T         &
   -A(7)*T                               &
   -A(2)*(T**2)/2                        &
   -A(3)*(T**3)/6                        &
   -A(4)*(T**4)/12                       &
   -A(5)*(T**5)/20+A(6))

gp = Runiv*2*M2*(B(1)*(1-log(T))*T      &
   -B(7)*T                              &
   -B(2)*(T**2)/2                       &
   -B(3)*(T**3)/6                       &
   -B(4)*(T**4)/12                      &
   -B(5)*(T**5)/20+B(6))

dg = gp-gr

keq =(101325d0/Runiv/T)*exp(-dg/Runiv/T)
kf = (2.75d16/T)* exp(-59500d0/T)

d1dt= -1*M1*(kf)*((rho1/M1)- rho2*rho2/(M2*M2*keq))*(TB1*rho1/M1 + TB2*rho2/M2)

rho1 = rho1 +dt*d1dt
rho2=rhoi-rho1

!!!!!!!!!!!!!!!!!!!!!!!!
!!Net energy change = 0!
!!!!!!!!!!!!!!!!!!!!!!!!

do n = 1,nitermax

if (T<=1000) then
  A=B1h
  B=B2h
elseif (T>1000) then
  A=A1h
  B=A2h
endif

h1 = (A(1)*T           &
   + A(2)*(T**2)/2     &
   + A(3)*(T**3)/3     &
   + A(4)*(T**4)/4     &
   + A(5)*(T**5)/5     &
   + A(6))*Runiv

e1 = h1- Runiv*T/M1
eng1=rho1*e1

h2 =  (B(1)*T           &
    + B(2)*(T**2)/2     &
    + B(3)*(T**3)/3     &
    + B(4)*(T**4)/4     &
    + B(5)*(T**5)/5     &
    + B(6))*Runiv

e2 = h2- Runiv*T/M2
eng2=rho2*e2

eng=eng1+eng2
deng=eng-engi

!!!!!!!!! Update T to make deng =0
Told=T
dengdT = (rho1*( (A(1)+A(2)*(T) + A(3)*(T**2)+A(4)*(T**3)+                     &
       A(5)*(T**4)) - 1/M1) + rho2*(B(1)+B(2)*(T)/2 + B(3)*(T**2)+B(4)*(T**3)+ &
       B(5)*(T**4) - 1/M2))*Runiv

T = T - deng/dengdT

if (n.eq.1) res0T = abs(deng/dengdT)
resT = abs(deng/dengdT)/res0

if (resT < 1e-6) then

   exit

end if

end do

if (i.eq.1) res0=d1dt
res = d1dt/res0
if ((res < 1e-6).AND.(T-Told <1e-6)) then
   exit
end if
write(2,*) i,dt,time,T,abs(T-Told)
print *, i,time,rho1/rhoi,T,dt,abs(T-Told)
!print*, res

!!!!!!!!adaptive time step!!!!!!!

dt = 1/relax * abs(res0/res)*dt0

time = time + dt

end do

close(2)

end


c     # ------------------------------------------------------------------
c     # MAPC2M_PILLOWSPHERE
c     # ------------------------------------------------------------------
c     #
c     # Maps a logically rectangular Cartesian grid in [-1,1]x[-1,1] to
c     # either the upper hemisphere (blockno == 0) or the lower hemisphere
c     # (blockno == 1).
c     #
c     # ------------------------------------------------------------------
      subroutine mapc2m_pillowsphere(blockno, xc1,yc1,xp,yp,zp)
      implicit none

      external mapc2m_cart
      double precision xc1,yc1, xp, yp, zp

      double precision x1, y1, d, rp2, xc, yc, zc
      integer blockno
      logical l1, l2
      logical ispillowsphere

c     # Map to [-1,1]x[-1,1]
      call mapc2m_cart(blockno,xc1,yc1,xc,yc,zc)

c     # Map xc and yc from ghost cells to interior
      d = max(xc - 1.0,0.d0) + max(-1 - xc,0.d0)
      x1 = ((1-d)/(1+d))*xc

      d = max(yc - 1,0.d0) + max(-1 - yc,0.d0)
      y1 = ((1-d)/(1+d))*yc

c     # Get circle of radius sqrt(2.d0).  Cluster radial
c     # direction towards boundary
      call mapc2p_circle_sp(x1,y1,xp,yp)

c     # Set z value
      rp2 = xp**2 + yp**2
      if (abs(rp2 - 2.d0) .lt. 1d-10) then
         zp = 0.d0
      else
         zp = sqrt(2.d0 - rp2)
      endif

c     # Values that are outside of [-1,1]x[-1,1] (in ghost cell regions)
c     # to the lower hemisphere
c     # Juqueen complained about the 'xor', because it is not in the
c     # Fortran standard.  Use .neqv. instead.
      l1 = abs(xc) .gt. 1
      l2 = abs(yc) .gt. 1
      if (l1 .neqv. l2) then
         zp = -zp
      endif

c     # This maps everything to the unit sphere
      xp = xp/sqrt(2.d0)
      yp = yp/sqrt(2.d0)
      zp = zp/sqrt(2.d0)

c     # Set lower hemisphere
      if (ispillowsphere()) then
         if (blockno .eq. 1) then
            zp = -zp
         endif
      endif

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

c     # Map single grid to the disk.  Since this disk will be used for the
c     #
      subroutine mapc2p_circle_sp(x1,y1,xp,yp)
      implicit none

      double precision xc,yc,xp,yp, x1,y1
      double precision xi,eta,x,y, minxy,maxxy
      double precision xit, etat, dd

      double precision pi, pi2
      common /compi/ pi, pi2

      xc = x1
      yc = y1

      if (x1 .lt. -1.d0) then
         xc = -(xc + 2)
      endif

      xi = min(abs(xc),abs(yc))
      eta = max(abs(xc),abs(yc))
      eta = max(eta,1.d-10)

      dd = sin(pi*eta/2.d0)
c      dd = eta*(2-eta)

      xit = (xi/eta)*dd
      etat = dd

      call map_north_sector_sp(xit,etat,x,y)

      minxy = min(abs(x),abs(y))
      maxxy = max(abs(x),abs(y))

      if (abs(xc) .le. abs(yc))  then
c        # In NS sectors
         xp = sign(1.d0,xc)*minxy
         yp = sign(1.d0,yc)*maxxy
      else
c        # In EW sectors
         xp = sign(1.d0,xc)*maxxy
         yp = sign(1.d0,yc)*minxy
      endif

      end

      subroutine map_north_sector_sp(xi,eta,x,y)
      implicit none

      double precision xi,eta,x,y

      x = xi
      y = sqrt(2 - xi**2) - sqrt(2 - eta**2) + eta

      end


!>
!! This module provides two time stepping methods to solve the initial value problem
!!
!! \\( q_t = F(q) = F_{\\text{adv}}(q) + F_{\\text{diff}}(q) \\)
!!
!! Depending on the preprocessor flag *linear*, the right hand side stems either from Burger's equation
!!
!! \\( F(q) = -q \\cdot \\nabla q + \\nu \\Delta q \\)
!!
!! or a linear advection diffusion equation
!!
!! \\( F(q) = -\\nabla q + \\nu \Delta q \\)
!!
!! The contributions to \\( F \\) from advection and diffusion are computed in the corresponding modules.
MODULE timestepper

USE omp_lib,   only : omp_get_thread_num
USE Advection, only : GetRHSAdvection, InitializeAdvection, FinalizeAdvection
USE Diffusion, only : GetRHSDiffusion, InitializeDiffusion
USE boundaries, only : periodic, InitializeBoundaries, FinalizeBoundaries

IMPLICIT NONE

PRIVATE
PUBLIC :: Euler, Rk3Ssp, InitializeTimestepper, FinalizeTimestepper

!> Auxiliary buffer holding intermediate solutions in the stage computations for the 3rd order RK-SSP
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Q_aux

!> Buffer holding the values \\( F(q) \\)
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: FQ

TYPE timestepper_parameter
    INTEGER :: i_max, j_max, k_max
END TYPE

TYPE(timestepper_parameter) :: param

CONTAINS

    !> Forward Euler method. In every step, it computes \\( F_{\\text{adv}} \\) and \\( F_{\\text{diff}} \\) and performs the update
    !> \\( Q_{n+1} = Q_{n} + \\Delta t F(Q_n) \\).
    !> @param[inout] Q Initial value which is then overwritten with the solution after completing the time stepping
    !> @param[in] T0 Starting time
    !> @param[in] T1 Final time
    !> @param[in] Nsteps Number of time steps to take from T0 to T1
    SUBROUTINE Euler(Q, T0, T1, Nsteps, dx, dy, dz, order_adv, order_diff)

        DOUBLE PRECISION, DIMENSION(-2:,-2:,-2:), INTENT(INOUT) :: Q
        DOUBLE PRECISION,                         INTENT(IN)    :: dx, dy, dz, T0, T1
        INTEGER,                                  INTENT(IN)    :: Nsteps, order_adv, order_diff

        DOUBLE PRECISION :: dt
        INTEGER :: n, thread_nr

        thread_nr = omp_get_thread_num();
        dt = (T1-T0)/DBLE(Nsteps)

        DO n=1,Nsteps

            CALL periodic(Q)

            CALL GetRHSAdvection(Q, FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_adv)
            CALL GetRHSDiffusion(Q, FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_diff)

            Q = Q + dt*FQ(:,:,:,thread_nr)

        END DO

    END SUBROUTINE Euler

    !> Third order strong stability preserving Runge-Kutta scheme from Shu and Osher (1988),
    !> see e.g. Durran, "Numerical Methods for Fluid Dynamics", pp. 55f
    !> @param[inout] Q Initial value which is then overwritten with the solution after completing the time stepping
    !> @param[in] T0 Starting time
    !> @param[in] T1 Final time
    !> @param[in] Nsteps Number of time steps to take from T0 to T1
    SUBROUTINE Rk3Ssp(Q, T0, T1, Nsteps, dx, dy, dz, order_adv, order_diff)

        DOUBLE PRECISION, DIMENSION(:,:,:), INTENT(INOUT) :: Q
        DOUBLE PRECISION,                   INTENT(IN)    :: dx, dy, dz, T0, T1
        INTEGER,                            INTENT(IN)    :: Nsteps, order_adv, order_diff

        DOUBLE PRECISION :: dt
        INTEGER :: i, thread_nr

        thread_nr = omp_get_thread_num();
        dt = (T1-T0)/DBLE(Nsteps)

        DO i=1,Nsteps

                CALL periodic(Q)

                ! Q_1 = Q_n + dt*f(Q_n)
                CALL GetRHSAdvection(Q, FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_adv)
                CALL GetRHSDiffusion(Q, FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_diff)
                Q_aux(:,:,:,thread_nr) = Q + dt*FQ(:,:,:,thread_nr)

                CALL periodic(Q_aux(:,:,:,thread_nr))
                ! Q_2 = (3/4)*Q_n + (1/4)*( Q_1 + dt*f(Q_1) )
                CALL GetRHSAdvection(Q_aux(:,:,:,thread_nr), FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_adv)
                CALL GetRHSDiffusion(Q_aux(:,:,:,thread_nr), FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_diff)
                Q_aux(:,:,:,thread_nr) = (3.0/4.0)*Q + (1.0/4.0)*( Q_aux(:,:,:,thread_nr) + dt*FQ(:,:,:,thread_nr) )

                CALL periodic(Q_aux(:,:,:,thread_nr))
                ! Q_n+1 = (1/3)*Q_n + (2/3)*( Q_2 + dt*f(Q_2) )
                CALL GetRHSAdvection(Q_aux(:,:,:,thread_nr), FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_adv)
                CALL GetRHSDiffusion(Q_aux(:,:,:,thread_nr), FQ(:,:,:,thread_nr), dx, dy, dz, 1, param%i_max, 1, param%j_max, 1, param%k_max, order_diff)
                Q = (1.0/3.0)*Q + (2.0/3.0)*( Q_aux(:,:,:,thread_nr) + dt*FQ(:,:,:,thread_nr) )
        END DO

    END SUBROUTINE Rk3Ssp

    !> Initialize the time stepper. Also initializes the modules required to compute the right hand side \\( F(q) \\)
    SUBROUTINE InitializeTimestepper(nu, i_max, j_max, k_max, nthreads)

        DOUBLE PRECISION, INTENT(IN) :: nu
        INTEGER, INTENT(IN) :: i_max, j_max, k_max, nthreads

        INTEGER :: i

        param%i_max = i_max
        param%j_max = j_max
        param%k_max = k_max

        ! Use indexing from 1,...,i_max and account for three halo cells in each direction
        CALL InitializeAdvection(-2, i_max+3, -2, j_max+3, -2, k_max+3, nthreads, .false.)
        CALL InitializeDiffusion(-2, i_max+3, -2, j_max+3, -2, k_max+3, nu)
        CALL InitializeBoundaries(i_max, j_max, k_max)

        ALLOCATE(Q_aux(-2:i_max+3, -2:j_max+3, -2:k_max+3,0:nthreads-1))
        ALLOCATE(FQ(   -2:i_max+3, -2:j_max+3, -2:k_max+3,0:nthreads-1))

        !$OMP PARALLEL DO schedule(static)
        DO i=0,nthreads-1
            Q_aux(:,:,:,i) = 0.0
            FQ(:,:,:,i)    = 0.0
        END DO
        !$OMP END PARALLEL DO

    END SUBROUTINE InitializeTimestepper

    !> Finalize the time stepper and all used modules.
    SUBROUTINE FinalizeTimestepper()
            CALL FinalizeAdvection
            CALL FinalizeBoundaries
            DEALLOCATE(Q_aux)
            DEALLOCATE(FQ)
    END SUBROUTINE FinalizeTimestepper

END MODULE timestepper


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Schrodinger equation in 3 dimensions
	! i*u_t+Es*|u|^2u+u_{xx}+u_{yy}+u_{zz}=0
	! using a second order time spectral splitting scheme
	!
	! The boundary conditions are u(x=0,y,z)=u(2*Lx*\pi,y,z),
	!	u(x,y=0,z)=u(x,y=2*Ly*\pi,z), u(x,y,z=0)=u(x,y,z=2*Lz*\pi)
	! The initial condition is u=exp(-x^2-y^2)
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus		= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate			= variable for clock count rate
	!  dt				= timestep
	!  modescalereal		= Number to scale after backward FFT
	!  myid				= Process id
	!  ierr				= error code
	!  p_row			= number of rows for domain decomposition
	!  p_col			= number of columns for domain decomposition
	!  filesize			= total filesize
	!  disp				= displacement to start writing data from
	!  ind				= index in array to write
	!  plotnum			= number of plot to save
	!  numberfile			= number of the file to be saved to disk
	!  stat				= error indicator when reading inputfile
	! .. Arrays ..
	!  u 				= approximate solution
	!  v				= Fourier transform of approximate solution
	!  pot				= potential
	!  uabs				= Absolute value of the field
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!  time				= times at which save data
	!  nameconfig		= array to store filename for data to be saved
	!  InputFileName	= name of the Input File
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!					see http://www.2decomp.org/ for more information
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library

	PROGRAM main
	USE decomp_2d
	USE decomp_2d_fft
	USE decomp_2d_io
	USE MPI
	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4)		::  Nx=2**5
	INTEGER(kind=4) 	::  Ny=2**5
	INTEGER(kind=4) 	::  Nz=2**5
	INTEGER(kind=4)		::  Nt=50
	INTEGER(kind=4)		::  plotgap=10
	REAL(kind=8), PARAMETER	::&
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8)		::  Lx=2.0d0,Ly=2.0d0,Lz=2.0d0
	REAL(kind=8)		::  Es=1.0d0
	REAL(kind=8)		::  dt=0.0010d0
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	::  kx,ky,kz
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  x,y,z
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE	::  u,v,pot
	REAL(kind=8), 	 DIMENSION(:,:,:), ALLOCATABLE  ::  uabs
	REAL(kind=8), 	 DIMENSION(:), ALLOCATABLE	::  time
	INTEGER(KIND=4), DIMENSION(1:5)	::  intcomm
	REAL(KIND=8), DIMENSION(1:5)	::  dpcomm
	REAL(kind=8) :: modescalereal
	INTEGER(kind=4)	::  i,j,k,n,AllocateStatus,stat
	INTEGER(kind=4)	:: myid,numprocs,ierr
	TYPE(DECOMP_INFO)	::  decomp
	INTEGER(kind=MPI_OFFSET_KIND) :: filesize, disp
	INTEGER(kind=4)	::  p_row=0, p_col=0
 	INTEGER(kind=4)	::  start, finish, count_rate, ind, plotnum
	CHARACTER*50	::	nameconfig
	CHARACTER*20	::	numberfile, InputFileName
	    ! initialisation of MPI
	CALL MPI_INIT(ierr)
	CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
	CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)

	IF(myid.eq.0) THEN
		CALL GET_ENVIRONMENT_VARIABLE(NAME='inputfile',VALUE=InputFileName, STATUS=stat)
	END IF
	CALL MPI_BCAST(stat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

	IF(stat.NE.0) THEN
		IF(myid.eq.0) THEN
				PRINT*,"Need to set environment variable inputfile to the name of the &
						file where the simulation parameters are set"
		END IF
		STOP
	END IF
	IF(myid.eq.0) THEN
		InputFileName='./INPUTFILE'
		OPEN(unit=11,FILE=trim(InputFileName),status="OLD")
		REWIND(11)
		READ(11,*) intcomm(1), intcomm(2), intcomm(3), intcomm(4), intcomm(5), &
			 		dpcomm(1), dpcomm(2),  dpcomm(3),  dpcomm(4),  dpcomm(5)
		CLOSE(11)
		PRINT *,"NX ",intcomm(1)
		PRINT *,"NY ",intcomm(2)
		PRINT *,"NZ ",intcomm(3)
		PRINT *,"NT ",intcomm(4)
		PRINT *,"plotgap ",intcomm(5)
		PRINT *,"Lx ",dpcomm(1)
		PRINT *,"Ly ",dpcomm(2)
		PRINT *,"Lz ",dpcomm(3)
		PRINT *,"Es ",dpcomm(4)
		PRINT *,"Dt ",dpcomm(5)
		PRINT *,"Read inputfile"
	END IF
	CALL MPI_BCAST(dpcomm,5,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
	CALL MPI_BCAST(intcomm,5,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

	Nx=intcomm(1)
	Ny=intcomm(2)
	Nz=intcomm(3)
	Nt=intcomm(4)
	plotgap=intcomm(5)
	Lx=dpcomm(1)
	Ly=dpcomm(2)
	Lz=dpcomm(3)
	Es=dpcomm(4)
	DT=dpcomm(5)

	! initialisation of 2decomp
	! do automatic domain decomposition
	CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
	! get information about domain decomposition choosen
	CALL decomp_info_init(Nx,Ny,Nz,decomp)
	! initialise FFT library
	CALL decomp_2d_fft_init
	ALLOCATE(u(decomp%xst(1):decomp%xen(1),&
   				decomp%xst(2):decomp%xen(2),&
   				decomp%xst(3):decomp%xen(3)),&
            v(decomp%zst(1):decomp%zen(1),&
            	decomp%zst(2):decomp%zen(2),&
            	decomp%zst(3):decomp%zen(3)),&
            pot(decomp%xst(1):decomp%xen(1),&
            	decomp%xst(2):decomp%xen(2),&
            	decomp%xst(3):decomp%xen(3)),&
            uabs(decomp%xst(1):decomp%xen(1),&
                decomp%xst(2):decomp%xen(2),&
                decomp%xst(3):decomp%xen(3)),&
   		kx(1:Nx),ky(1:Ny),kz(1:Nz),&
   		x(1:Nx),y(1:Ny),z(1:Nz),&
   		time(1:1+Nt/plotgap),stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP

	IF (myid.eq.0) THEN
		PRINT *,'allocated space'
	END IF

	modescalereal=1.0d0/REAL(Nx,KIND(0d0))
	modescalereal=modescalereal/REAL(Ny,KIND(0d0))
	modescalereal=modescalereal/REAL(Nz,KIND(0d0))

	! setup fourier frequencies and grid points
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	END DO
	kx(1+Nx/2)=0.0d0
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
  	DO i=1,Nx
		x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
	END DO
	DO j=1,1+Ny/2
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	ky(1+Ny/2)=0.0d0
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
  	DO j=1,Ny
		y(j)=(-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
	END DO
	DO k=1,1+Nz/2
		kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
	END DO
	kz(1+Nz/2)=0.0d0
	DO k = 1,Nz/2 -1
		kz(k+1+Nz/2)=-kz(1-k+Nz/2)
	END DO
  	DO k=1,Nz
		z(k)=(-1.0d0 + 2.0d0*REAL(k-1,kind(0d0))/REAL(Nz,kind(0d0)))*pi*Lz
	END DO

	IF (myid.eq.0) THEN
		PRINT *,'Setup grid and fourier frequencies'
	END IF

	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				u(i,j,k)=exp(-1.0d0*(x(i)**2 +y(j)**2+z(k)**2))
				uabs(i,j,k)=abs(u(i,j,k))
			END DO
		END DO
	END DO

	! write out using 2DECOMP&FFT MPI-IO routines
	nameconfig='./data/u'
	plotnum=0
	WRITE(numberfile,'(i0)') 10000000+plotnum
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//numberfile
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//'.datbin'
	CALL decomp_2d_write_one(1,uabs,nameconfig)

	CALL decomp_2d_fft_3d(u,v,DECOMP_2D_FFT_FORWARD)
	IF (myid.eq.0) THEN
		PRINT *,'Got initial data, starting timestepping'
	END IF
	CALL system_clock(start,count_rate)
	time(1)=0
	DO n=1,Nt
		! Use Strang splitting
		DO k=decomp%zst(3),decomp%zen(3)
			DO j=decomp%zst(2),decomp%zen(2)
				DO i=decomp%zst(1),decomp%zen(1)
					v(i,j,k)=exp(0.50d0*dt*&
						(kz(k)*kz(k) + kx(i)*kx(i) + ky(j)*ky(j))&
						*cmplx(0.0d0,1.0d0))*v(i,j,k)
				END DO
			END DO
		END DO

		CALL decomp_2d_fft_3d(v,u,DECOMP_2D_FFT_BACKWARD)

		DO k=decomp%xst(3),decomp%xen(3)
			DO j=decomp%xst(2),decomp%xen(2)
				DO i=decomp%xst(1),decomp%xen(1)
					u(i,j,k)=u(i,j,k)*modescalereal
					pot(i,j,k)=Es*u(i,j,k)*conjg(u(i,j,k))
					u(i,j,k)=exp(cmplx(0.0d0,-1.0d0)*dt*pot(i,j,k))*u(i,j,k)
				END DO
			END DO
		END DO
		CALL decomp_2d_fft_3d(u,v,DECOMP_2D_FFT_FORWARD)

		DO k=decomp%zst(3),decomp%zen(3)
			DO j=decomp%zst(2),decomp%zen(2)
				DO i=decomp%zst(1),decomp%zen(1)
					v(i,j,k)=exp(dt*0.5d0*&
						(kx(i)*kx(i) +ky(j)*ky(j) +kz(k)*kz(k))&
						*cmplx(0.0d0,1.0d0))*v(i,j,k)
				END DO
			END DO
		END DO
		IF (mod(n,plotgap)==0) THEN
			time(1+n/plotgap)=n*dt
			IF (myid.eq.0) THEN
				PRINT *,'time',n*dt
			END IF
			CALL decomp_2d_fft_3d(v,u,DECOMP_2D_FFT_BACKWARD)
			u=u*modescalereal
        		DO k=decomp%xst(3),decomp%xen(3)
                		DO j=decomp%xst(2),decomp%xen(2)
                        		DO i=decomp%xst(1),decomp%xen(1)
                                		uabs(i,j,k)=abs(u(i,j,k))
                        		END DO
                		END DO
        		END DO
			nameconfig='./data/u'
			plotnum=plotnum+1
			WRITE(numberfile,'(i0)') 10000000+plotnum
			ind=index(nameconfig,' ') -1
			nameconfig=nameconfig(1:ind)//numberfile
			ind=index(nameconfig,' ') -1
			nameconfig=nameconfig(1:ind)//'.datbin'
			! write out using 2DECOMP&FFT MPI-IO routines
			CALL decomp_2d_write_one(1,uabs,nameconfig)
		END IF
	END DO
	IF (myid.eq.0) THEN
		PRINT *,'Finished time stepping'
	END IF

	CALL system_clock(finish,count_rate)

	IF (myid.eq.0) THEN
		PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),'for execution'
	END IF

	IF (myid.eq.0) THEN
		! Save times at which output was made in text format
		nameconfig = './data/tdata.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO j=1,1+Nt/plotgap
			WRITE(11,*) time(j)
		END DO
		CLOSE(11)
		! Save x grid points in text format
		nameconfig = './data/xcoord.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO i=1,Nx
			WRITE(11,*) x(i)
		END DO
		CLOSE(11)
		! Save y grid points in text format
		nameconfig = './data/ycoord.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO j=1,Ny
			WRITE(11,*) y(j)
		END DO
		CLOSE(11)
		! Save z grid points in text format
		nameconfig = './data/zcoord.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO k=1,Nz
			WRITE(11,*) z(k)
		END DO
		CLOSE(11)
		PRINT *,'Saved data'
	END IF

	! clean up
  	CALL decomp_2d_fft_finalize
  	CALL decomp_2d_finalize
 	DEALLOCATE(u,v,pot,uabs,&
   		kx,ky,kz,x,y,z,&
   		time,stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	IF (myid.eq.0) THEN
	   	PRINT *,'Program execution complete'
	END IF
	CALL MPI_FINALIZE(ierr)
	END PROGRAM main


      SUBROUTINE cntab1(nn,ni,nj,chisq,df,prob,cramrv,ccc)
      INTEGER ni,nj,nn(ni,nj),MAXI,MAXJ
      REAL ccc,chisq,cramrv,df,prob,TINY
      PARAMETER (MAXI=100,MAXJ=100,TINY=1.e-30)
CU    USES gammq
      INTEGER i,j,nni,nnj
      REAL expctd,sum,sumi(MAXI),sumj(MAXJ),gammq
      sum=0
      nni=ni
      nnj=nj
      do 12 i=1,ni
        sumi(i)=0.
        do 11 j=1,nj
          sumi(i)=sumi(i)+nn(i,j)
          sum=sum+nn(i,j)
11      continue
        if(sumi(i).eq.0.)nni=nni-1
12    continue
      do 14 j=1,nj
        sumj(j)=0.
        do 13 i=1,ni
          sumj(j)=sumj(j)+nn(i,j)
13      continue
        if(sumj(j).eq.0.)nnj=nnj-1
14    continue
      df=nni*nnj-nni-nnj+1
      chisq=0.
      do 16 i=1,ni
        do 15 j=1,nj
          expctd=sumj(j)*sumi(i)/sum
          chisq=chisq+(nn(i,j)-expctd)**2/(expctd+TINY)
15      continue
16    continue
      prob=gammq(0.5*df,0.5*chisq)
      cramrv=sqrt(chisq/(sum*min(nni-1,nnj-1)))
      ccc=sqrt(chisq/(chisq+sum))
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/cntab1.for


      MODULE FACTORSTUFF	!This protocol evades the need for multiple parameters, or COMMON, or one shapeless main line...
Concocted by R.N.McLean, MMXV.
       INTEGER LOTS		!The span..
       PARAMETER (LOTS = 20000)!Nor is computer storage infinite.
       INTEGER KNOWNSUM(LOTS)	!Calculate these once.
       CONTAINS		!Assistants.
        SUBROUTINE PREPARESUMF	!Initialise the KNOWNSUM array.
Convert the Sieve of Eratoshenes to have each slot contain the sum of the proper divisors of its slot number.
Changes to instead count the number of factors, or prime factors, etc. would be simple enough.
         INTEGER F		!A factor for numbers such as 2F, 3F, 4F, 5F, ...
          KNOWNSUM(1) = 0		!Proper divisors of N do not include N.
          KNOWNSUM(2:LOTS) = 1		!So, although 1 divides all N without remainder, 1 is excluded for itself.
          DO F = 2,LOTS/2		!Step through all the possible divisors of numbers not exceeding LOTS.
            FORALL(I = F + F:LOTS:F) KNOWNSUM(I) = KNOWNSUM(I) + F	!And augment each corresponding slot.
          END DO			!Different divisors can hit the same slot. For instance, 6 by 2 and also by 3.
        END SUBROUTINE PREPARESUMF	!Could alternatively generate all products of prime numbers.
         PURE INTEGER FUNCTION SIGN3(N)	!Returns -1, 0, +1 according to the sign of N.
Confounded by the intrinsic function SIGN distinguishing only two states: < 0 from >= 0. NOT three-way.
         INTEGER, INTENT(IN):: N	!The number.
          IF (N) 1,2,3	!A three-way result calls for a three-way test.
    1     SIGN3 = -1	!Negative.
          RETURN
    2     SIGN3 = 0	!Zero.
          RETURN
    3     SIGN3 = +1	!Positive.
        END FUNCTION SIGN3	!Rather basic.
      END MODULE FACTORSTUFF	!Enough assistants.
       PROGRAM THREEWAYS	!Classify N against the sum of proper divisors of N, for N up to 20,000.
       USE FACTORSTUFF		!This should help.
       INTEGER I		!Stepper.
       INTEGER TEST(LOTS)	!Assesses the three states in one pass.
        WRITE (6,*) "Inspecting sums of proper divisors for 1 to",LOTS
        CALL PREPARESUMF		!Values for every N up to the search limit will be called for at least once.
        FORALL(I = 1:LOTS) TEST(I) = SIGN3(KNOWNSUM(I) - I)	!How does KnownSum(i) compare to i?
        WRITE (6,*) "Deficient",COUNT(TEST .LT. 0)	!This means one pass through the array
        WRITE (6,*) "Perfect! ",COUNT(TEST .EQ. 0)	!For each of three types.
        WRITE (6,*) "Abundant ",COUNT(TEST .GT. 0)	!Alternatively, make one pass with three counts.
      END			!Done.


program problem_9

!! What is the first number that does not have this property?

use aoc_utilities, only: read_file_to_integer64_array
use iso_fortran_env

implicit none

integer(int64),dimension(:),allocatable :: iarray
integer :: i, j, k, n
logical :: ok
integer(int64) :: invalid_value, smallest, largest, weakness

iarray = read_file_to_integer64_array('input.txt')
n = size(iarray)

main: do i = 26, n
    write(*,*) 'try: ', i
    ok = .false.
    loop: do j = 1, n-2
        do k = j+1, n-1
            if (iarray(i) == iarray(j) + iarray(k)) then
                ok = .true.
                exit loop
            end if
        end do
    end do loop
    if (.not. ok) then
        invalid_value = iarray(i)
        write(*,*) 'found: entry ', i, ' value = ', invalid_value
        exit main
    end if

end do main

! What is the encryption weakness in your XMAS-encrypted list of numbers?

write(*,*) ''
write(*,*) 'Part 2'
write(*,*) ''

do i = 1, n-1
    do j = 1, n
        if (sum(iarray(i:j)) == invalid_value) then
            write(*,*) 'found sequence: ', iarray(i:j)
            smallest = minval(iarray(i:j))
            largest  = maxval(iarray(i:j))
            weakness = smallest + largest
            write(*,*) 'weakness: ', weakness
            stop
        end if
    end do
end do

end program problem_9


module test_math

    use testdrive, only: new_unittest, unittest_type, error_type, check
    use forlab_math, only: operator(.c.), all_close, angle, is_close
    use, intrinsic :: iso_fortran_env, only: int8
    implicit none
    private

    public :: collect_math

contains

    subroutine collect_math(testsuite)
        type(unittest_type), allocatable, intent(out) :: testsuite(:)
        testsuite = [&
        new_unittest("angle_real vaild", test_math_angle_real), &
        new_unittest("cross_int vaild", test_math_cross_int), &
        new_unittest("cross_real vaild", test_math_cross_real) &
        ]
    end subroutine collect_math

    subroutine test_math_cross_int(error)
        type(error_type), allocatable, intent(out) :: error
        integer(int8), dimension(3) :: x, y
        x = 1_int8;  y = 2_int8

        call check(error, all((x.c.y) == [integer(int8) :: 0, 0, 0]))
        if (allocated(error)) return

    end subroutine test_math_cross_int

    subroutine test_math_cross_real(error)
        type(error_type), allocatable, intent(out) :: error
        real, dimension(3) :: x, y
        x = 1_int8;  y = 2_int8

        call check(error, all_close((x.c.y), [real :: 0, 0, 0]))
        if (allocated(error)) return

    end subroutine test_math_cross_real

    module subroutine test_math_angle_real(error)
        type(error_type), allocatable, intent(out) :: error
        real, dimension(3) :: x, y
        x = 1_int8;  y = 2_int8

        call check(error, is_close(angle(x, y), 0.0))
        if (allocated(error)) return

    end subroutine test_math_angle_real

end module test_math


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!> @brief compute "i,j,k"-index of "m", depending on "i0,j0,k0"
!> @param[in] m continuous memory cell-index
!> @param[out] i cell index, direction I0
!> @param[out] j cell index, direction J0
!> @param[out] k cell index, direction K0
!> @details
!> Compute k cell index: \n\n
!>
!>    k = (m-1) / (i0*j0) + 1 \n\n
!>
!> Explanations:\n
!> 1) m-1: The integer steps between k-indices are at elements m =
!>    n*(i0*j0 + 1) for some positive integer n [f.e.: m=i0*j0 is
!>    still in the lowest layer, m=i0*j0+1 is in the second lowest
!>    layer]. The steps of the division are at m_div = n*(i0*j0). \n
!> 2) +1 at end: The division gives k = 0 for the lowest layer, k = 1
!>    for the second-lowest, and so on. The layer-counting starts at
!>    k=1, so 1 is added. \n\n
!>
!> Compute j cell index: \n\n
!>
!>    j = (m-1 - (k-1)*i0*j0) / i0 + 1 \n\n
!>
!> Explanations:\n
!> 1) (m-1 - (k-1)*i0*j0): The index is projected onto its
!>    partner-index on the lowest layer by subtracting the number of
!>    z-layers on top, then one is subtracted, since the steps between
!>    j-indices should be at m=n*(i0+1), but the steps of the division
!>    by i0 are at m=n*i0. \n
!> 2) +1 at end: The division by i0 gives j = 0 for the first line in
!>    x-direction, j = 1 for the second, and so on. The line-counting
!>    should start at j=1, so 1 is added. \n\n
!>
!> Compute i cell index: \n\n
!>
!>    i = m - (k-1)*i0*j0 - (j-1)*i0\n\n
!>
!> Explanations:\n
!> 1) (m - (k-1)*i0*j0): The index is projected onto its
!>    partner-index on the lowest layer by subtracting the number of
!>    z-layers on top. \n
!> 2) - (j-1)*i0: The index is projected onto its
!>    partner-index on the first line by subtracting the number of
!>    y-lines . \n\n
      subroutine ijk_m(m,i,j,k)

        use mod_genrl, only: i0, j0, k0

        implicit none

        ! Continuous linear index
        integer, intent (in) :: m

        ! i-cell/j-cell/k-cell index
        integer, intent (out) :: i, j, k

        ! Compute k-cell index
        k = (m-1) / (i0*j0) + 1

        ! Compute j-cell index
        j = (m-1 - (k-1)*i0*j0) / i0 + 1

        ! Compute i-cell index
        i = m - (k-1)*i0*j0 - (j-1)*i0

        return

      end subroutine ijk_m


!
! ej1c.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program ej1c

use precision,  pr => dp
use mtmod
use ising

implicit none
integer :: i, j, k
integer, dimension(:), allocatable  :: s
integer                             :: tmc, n_down, n_up, n_left, n_right
integer                             :: spinadd, loc, L, ntermal=10e4, nmtc=10e6
real(pr)                            :: e, m, d_e, r, T, Rp
real(pr)                            :: prob(-4:4, -1:1)
! histogram
integer, parameter                  :: nbins=16
integer                             :: counts(1:nbins)
real(pr)                            :: bins(0:nbins), lo_lim, hi_lim, delta

36 format(I12, ES14.6e2)

T = 1.05

! posibles deltas de energia
call probability(prob, T)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
L = 10
allocate(s(0:(L*L)-1))

open(unit=10, file='ej1c_L10_T_hi.dat', status='unknown')
write(10, *) "#counts    center"

! Inicializo la red de spines.
!  1 = up
! -1 = down
print*, 'Iniciando spins up'
call spin_initialize(s, L)
! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)
!inicio histograma
lo_lim = -1.1
hi_lim =  1.1
call histo_init(bins, counts, nbins, lo_lim, hi_lim, delta)
! pasos de montecarlo
do tmc =1, nmtc
    ! recorro la red
    do k = 0, (L*L) -1
        call metropolis_pbc(k, L, s, e, prob)
    end do
    if (tmc > ntermal) then  ! descarto transitorio
        m = sum(s)/real(L*L, pr)
        call histogram(bins, m, counts, nbins, delta)
    end if
end do
! Inicializo la red de spines.
!  1 = up
! -1 = down
print*, 'Iniciando spins down'
call spin_initialize(s, L)
s = -1*s
! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)
! pasos de montecarlo
do tmc =1, nmtc
    ! recorro la red
    do k = 0, (L*L) -1
        call metropolis_pbc(k, L, s, e, prob)
    end do
    if (tmc > ntermal) then  ! descarto transitorio
        m = sum(s)/real(L*L, pr)
        call histogram(bins, m, counts, nbins, delta)
    end if
end do

do j = 1, nbins
    write(10, 36) counts(j), lo_lim + (j-0.5)*(delta)
end do

close(10)
deallocate(s)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
L = 20
allocate(s(0:(L*L)-1))

open(unit=10, file='ej1c_L20_T_hi.dat', status='unknown')
write(10, *) "#counts    center"

! Inicializo la red de spines.
!  1 = up
! -1 = down
print*, 'Iniciando spins up'
call spin_initialize(s, L)
! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)
!inicio histograma
lo_lim = -1.1
hi_lim =  1.1
call histo_init(bins, counts, nbins, lo_lim, hi_lim, delta)
! pasos de montecarlo
do tmc =1, nmtc
    ! recorro la red
    do k = 0, (L*L) -1
        call metropolis_pbc(k, L, s, e, prob)
    end do
    if (tmc > ntermal) then  ! descarto transitorio
        m = sum(s)/real(L*L, pr)
        call histogram(bins, m, counts, nbins, delta)
    end if
end do
! Inicializo la red de spines.
!  1 = up
! -1 = down
print*, 'Iniciando spins down'
call spin_initialize(s, L)
s = -1*s
! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)
! pasos de montecarlo
do tmc =1, nmtc
    ! recorro la red
    do k = 0, (L*L) -1
        call metropolis_pbc(k, L, s, e, prob)
    end do
    if (tmc > ntermal) then  ! descarto transitorio
        m = sum(s)/real(L*L, pr)
        call histogram(bins, m, counts, nbins, delta)
    end if
end do

do j = 1, nbins
    write(10, 36) counts(j), lo_lim + (j-0.5)*(delta)
end do

close(10)
deallocate(s)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
L = 40
allocate(s(0:(L*L)-1))

open(unit=10, file='ej1c_L40_T_hi.dat', status='unknown')
write(10, *) "#counts    center"

! Inicializo la red de spines.
!  1 = up
! -1 = down
print*, 'Iniciando spins up'
call spin_initialize(s, L)
! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)
!inicio histograma
lo_lim = -1.1
hi_lim =  1.1
call histo_init(bins, counts, nbins, lo_lim, hi_lim, delta)
! pasos de montecarlo
do tmc =1, nmtc
    ! recorro la red
    do k = 0, (L*L) -1
        call metropolis_pbc(k, L, s, e, prob)
    end do
    if (tmc > ntermal) then  ! descarto transitorio
        m = sum(s)/real(L*L, pr)
        call histogram(bins, m, counts, nbins, delta)
    end if
end do
! Inicializo la red de spines.
!  1 = up
! -1 = down
print*, 'Iniciando spins down'
call spin_initialize(s, L)
s = -1*s
! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)
! pasos de montecarlo
do tmc =1, nmtc
    ! recorro la red
    do k = 0, (L*L) -1
        call metropolis_pbc(k, L, s, e, prob)
    end do
    if (tmc > ntermal) then  ! descarto transitorio
        m = sum(s)/real(L*L, pr)
        call histogram(bins, m, counts, nbins, delta)
    end if
end do

do j = 1, nbins
    write(10, 36) counts(j), lo_lim + (j-0.5)*(delta)
end do

close(10)
deallocate(s)

end program


      SUBROUTINE chder(a,b,c,cder,n)
      INTEGER n
      REAL a,b,c(n),cder(n)
      INTEGER j
      REAL con
      cder(n)=0.
      cder(n-1)=2*(n-1)*c(n)
      do 11 j=n-2,1,-1
        cder(j)=cder(j+2)+2*j*c(j+1)
11    continue
      con=2./(b-a)
      do 12 j=1,n
        cder(j)=cder(j)*con
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/chder.for