      SUBROUTINE MB04IZ( N, M, P, L, A, LDA, B, LDB, TAU, ZWORK, LZWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a QR factorization of an n-by-m matrix A (A = Q * R),
C     having a p-by-min(p,m) zero triangle in the lower left-hand side
C     corner, as shown below, for n = 8, m = 7, and p = 2:
C
C            [ x x x x x x x ]
C            [ x x x x x x x ]
C            [ x x x x x x x ]
C            [ x x x x x x x ]
C        A = [ x x x x x x x ],
C            [ x x x x x x x ]
C            [ 0 x x x x x x ]
C            [ 0 0 x x x x x ]
C
C     and optionally apply the transformations to an n-by-l matrix B
C     (from the left). The problem structure is exploited. This
C     computation is useful, for instance, in combined measurement and
C     time update of one iteration of the time-invariant Kalman filter
C     (square root information filter).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix A.  M >= 0.
C
C     P       (input) INTEGER
C             The order of the zero triagle.  P >= 0.
C
C     L       (input) INTEGER
C             The number of columns of the matrix B.  L >= 0.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA,M)
C             On entry, the leading N-by-M part of this array must
C             contain the matrix A. The elements corresponding to the
C             zero P-by-MIN(P,M) lower trapezoidal/triangular part
C             (if P > 0) are not referenced.
C             On exit, the elements on and above the diagonal of this
C             array contain the MIN(N,M)-by-M upper trapezoidal matrix
C             R (R is upper triangular, if N >= M) of the QR
C             factorization, and the relevant elements below the
C             diagonal contain the trailing components (the vectors v,
C             see Method) of the elementary reflectors used in the
C             factorization.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB,L)
C             On entry, the leading N-by-L part of this array must
C             contain the matrix B.
C             On exit, the leading N-by-L part of this array contains
C             the updated matrix B.
C             If L = 0, this array is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,N) if L > 0;
C             LDB >= 1        if L = 0.
C
C     TAU     (output) COMPLEX*16 array, dimension MIN(N,M)
C             The scalar factors of the elementary reflectors used.
C
C     Workspace
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the optimal value
C             of LZWORK.
C
C     LZWORK  The length of the array ZWORK.
C             LZWORK >= MAX(1,M-1,M-P,L).
C             For optimum performance LZWORK should be larger.
C
C             If LZWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             ZWORK array, returns this value as the first entry of
C             the ZWORK array, and no error message related to LZWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine uses min(N,M) Householder transformations exploiting
C     the zero pattern of the matrix.  A Householder matrix has the form
C
C                                     ( 1 ),
C        H  = I - tau *u *u',    u  = ( v )
C         i          i  i  i      i   (  i)
C
C     where v  is an (N-P+I-2)-vector.  The components of v  are stored
C            i                                             i
C     in the i-th column of A, beginning from the location i+1, and
C     tau  is stored in TAU(i).
C        i
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Complex version: V. Sima, Research Institute for Informatics,
C     Bucharest, Nov. 2008.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009,
C     Apr. 2011.
C
C     KEYWORDS
C
C     Elementary reflector, QR factorization, unitary transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16        ZERO, ONE
      PARAMETER         ( ZERO = ( 0.0D+0, 0.0D+0 ),
     $                    ONE  = ( 1.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, LDB, LZWORK, M, N, P
C     .. Array Arguments ..
      COMPLEX*16        A(LDA,*), B(LDB,*), TAU(*), ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY
      INTEGER           I, WRKOPT
      COMPLEX*16        FIRST
C     .. External Subroutines ..
      EXTERNAL          XERBLA, ZGEQRF, ZLARF, ZLARFG, ZUNMQR
C     .. Intrinsic Functions ..
      INTRINSIC         DCONJG, INT, MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      LQUERY = LZWORK.EQ.-1
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( L.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN
         INFO = -8
      ELSE
         I = MAX( 1, M - 1, M - P, L )
         IF( LQUERY ) THEN
            IF( M.GT.P ) THEN
               CALL ZGEQRF( N-P, M-P, A, LDA, TAU, ZWORK, -1, INFO )
               WRKOPT = MAX( I, INT( ZWORK( 1 ) ) )
               IF ( L.GT.0 ) THEN
                  CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P,
     $                         A, LDA, TAU, B, LDB, ZWORK, -1, INFO )
                  WRKOPT = MAX( WRKOPT, INT( ZWORK( 1 ) ) )
               END IF
            END IF
         ELSE IF( LZWORK.LT.I ) THEN
            INFO = -11
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB04IZ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         ZWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( M, N ).EQ.0 ) THEN
         ZWORK(1) = ONE
         RETURN
      ELSE IF( N.LE.P+1 ) THEN
         DO 5 I = 1, MIN( N, M )
            TAU(I) = ZERO
    5    CONTINUE
         ZWORK(1) = ONE
         RETURN
      END IF
C
C     Annihilate the subdiagonal elements of A and apply the
C     transformations to B, if L > 0.
C     Workspace: need MAX(M-1,L).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of complex workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      DO 10 I = 1, MIN( P, M )
C
C        Exploit the structure of the I-th column of A.
C
         CALL ZLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) )
         IF( TAU(I).NE.ZERO ) THEN
C
            FIRST = A(I,I)
            A(I,I) = ONE
C
            IF ( I.LT.M ) CALL ZLARF( 'Left', N-P, M-I, A(I,I), 1,
     $                                DCONJG( TAU(I) ), A(I,I+1), LDA,
     $                                ZWORK )
            IF ( L.GT.0 ) CALL ZLARF( 'Left', N-P, L, A(I,I), 1,
     $                                DCONJG( TAU(I) ), B(I,1), LDB,
     $                                ZWORK )
C
            A(I,I) = FIRST
         END IF
   10 CONTINUE
C
      WRKOPT = MAX( 1, M - 1, L )
C
C     Fast QR factorization of the remaining right submatrix, if any.
C     Workspace: need M-P;  prefer (M-P)*NB.
C
      IF( M.GT.P ) THEN
         CALL ZGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), ZWORK,
     $                LZWORK, INFO )
         WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) )
C
         IF ( L.GT.0 ) THEN
C
C           Apply the transformations to B.
C           Workspace: need L;  prefer L*NB.
C
            CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P,
     $                   A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB,
     $                   ZWORK, LZWORK, INFO )
            WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) )
         END IF
      END IF
C
      ZWORK(1) = WRKOPT
      RETURN
C *** Last line of MB04IZ ***
      END


      SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To generate an orthogonal symplectic matrix U, which is defined as
C     a product of symplectic reflectors and Givens rotations
C
C     U = diag( H(1),H(1) )      G(1)  diag( F(1),F(1) )
C         diag( H(2),H(2) )      G(2)  diag( F(2),F(2) )
C                                ....
C         diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ).
C
C     as returned by MB04PU. The matrix U is returned in terms of its
C     first N rows
C
C                      [  U1   U2 ]
C                  U = [          ].
C                      [ -U2   U1 ]
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices U1 and U2.  N >= 0.
C
C     ILO     (input) INTEGER
C             ILO must have the same value as in the previous call of
C             MB04PU. U is equal to the unit matrix except in the
C             submatrix
C             U([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]).
C             1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.
C
C     U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
C             On entry, the leading N-by-N part of this array must
C             contain in its i-th column the vector which defines the
C             elementary reflector F(i).
C             On exit, the leading N-by-N part of this array contains
C             the matrix U1.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.  LDU1 >= MAX(1,N).
C
C     U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
C             On entry, the leading N-by-N part of this array must
C             contain in its i-th column the vector which defines the
C             elementary reflector H(i) and, on the subdiagonal, the
C             scalar factor of H(i).
C             On exit, the leading N-by-N part of this array contains
C             the matrix U2.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.  LDU2 >= MAX(1,N).
C
C     CS      (input) DOUBLE PRECISION array, dimension (2N-2)
C             On entry, the first 2N-2 elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (N-1)
C             On entry, the first N-1 elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(i).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -10,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK. LDWORK >= MAX(1,2*(N-ILO)).
C             For optimum performance LDWORK should be larger. (See
C             SLICOT Library routine MB04WD).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(N**3) floating point operations and is
C     strongly backward stable.
C
C     REFERENCES
C
C     [1] C. F. VAN LOAN:
C         A symplectic method for approximating all the eigenvalues of
C         a Hamiltonian matrix.
C         Linear Algebra and its Applications, 61, pp. 233-251, 1984.
C
C     [2] D. KRESSNER:
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C
C     V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DOSGPV).
C     V. Sima, Aug. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      INTEGER           ILO, INFO, LDU1, LDU2, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), U1(LDU1,*), U2(LDU2,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY
      INTEGER           I, IERR, J, MINWRK, NH, WRKOPT
C     .. External Subroutines ..
      EXTERNAL          DLASET, MB04WD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      NH   = N - ILO
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE
         LQUERY = LDWORK.EQ.-1
         MINWRK = MAX( 1, 2*NH )
         IF ( LQUERY ) THEN
            IF ( N.EQ.0 ) THEN
               WRKOPT = ONE
            ELSE
               CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH,
     $                      U1, LDU1, U2, LDU2, CS, TAU, DWORK, -1,
     $                      IERR )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
            END IF
            DWORK(1) = DBLE( WRKOPT )
            RETURN
         ELSE IF ( LDWORK.LT.MINWRK ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -10
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04WP', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Shift the vectors which define the elementary reflectors one
C     column to the right, and set the first ilo rows and columns to
C     those of the unit matrix.
C
      DO 30 J = N, ILO + 1, -1
         DO 10 I = 1, J-1
            U1(I,J) = ZERO
   10    CONTINUE
         DO 20 I = J+1, N
            U1(I,J) = U1(I,J-1)
   20    CONTINUE
   30 CONTINUE
      CALL DLASET( 'All', N, ILO, ZERO, ONE, U1, LDU1 )
      DO 60 J = N, ILO + 1, -1
         DO 40 I = 1, J-1
            U2(I,J) = ZERO
   40    CONTINUE
         DO 50 I = J, N
            U2(I,J) = U2(I,J-1)
   50    CONTINUE
   60 CONTINUE
      CALL DLASET( 'All', N, ILO, ZERO, ZERO, U2, LDU2 )
      IF ( NH.GT.0 ) THEN
         CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH,
     $                U1(ILO+1,ILO+1), LDU1, U2(ILO+1,ILO+1), LDU2,
     $                CS(ILO), TAU(ILO), DWORK, LDWORK, IERR )
      ELSE
         DWORK(1) = ONE
      END IF
      RETURN
C *** Last line of MB04WP ***
      END


      SUBROUTINE SSVDRS (A,LDA,M1,N1,B,LDB,NB,S,WORK)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-05-25 SSVDRS Krogh Minor change for making .f90 version.
C>> 1999-08-12 SSVDRS Krogh  Loop at 180 => 2 loops for Sun optimizer.
C>> 1994-10-20 SSVDRS Krogh  Changes to use M77CON
C>> 1992-06-16 SSVDRS CLL
C>> 1992-03-13 SSVDRS FTK  Removed implicit statements.
C>> 1989-10-20 CLL
C>> 1989-06-05 SSVDRS Snyder  Add END statement, polish a little.
C>> 1987-11-24 SSVDRS Lawson  Adaptation to Fortran 77 and MATH77.
c>> 1974-01-01 Lawson and Hanson initial code.
c
C          This subr computes the singular value decomposition of the
c     given M1 x N1 matrix, A, and optionally applys the transformations
c     from the left to the NB column vectors of the M1 x NB matrix B.
c     Either M1 .ge. N1  or  M1 .lt. N1 is permitted.
c
c          The singular value decomposition of A is of the form
c
C                     A  =  U * S * V**t
c
c     where U is M1 x M1 orthogonal, S is M1 x N1 diagonal with the
c     diagonal terms nonnegative and ordered from large to small, and
c     V is N1 x N1 orthogonal.  Note that these matrices also satisfy
c
c                     S = (U**t) * A * V
c
c          The matrix V is returned in the leading N1 rows and
c     columns of the array A(,).
c
c          The singular values, i.e. the diagonal terms of the matrix S,
c     are returned in the array S().  If M1 .lt. N1, positions M1+1
c     through N1 of S() will be set to zero.
c
c          The product matrix  G = U**t * B replaces the given matrix B
c     in the array B(,).
c
c          If the user wishes to obtain a minimum length least squares
c     solution of the linear system
c
c                           A * X ~=~ B
c
c     the solution X can be constructed, following use of this subr,
c     by computing the sum for i = 1, ..., R of the outer products
c
c             (Col i of V) * (1/S(i)) * (Row i of G)
c
c     Here R denotes the pseudorank of A which the user may choose
c     in the range 0 through Min(M1, N1) based on the sizes of the
c     singular values.
C     ------------------------------------------------------------------
C          Subroutine Arguments
c
c     A(,)     (In/Out)  On input contains the M1 x N1 matrix A.
c              On output contains the N1 x N1 matrix V.
c
c     LDA      (In)  First dimensioning parameter for A(,).
c              Require LDA .ge. Max(M1, N1).
c
c     M1       (In)  No. of rows of matrices A, B, and G.
c              Require M1 > 0.
c
c     N1       (In)  No. of cols of matrix A, No. of rows and cols of
c              matrix V.  Permit M1 .ge. N1  or  M1 .lt. N1.
c              Require N1 > 0.
c
c     B(,)     (In/Out)  If NB .gt. 0 this array must contain an
C              M1 x NB matrix on input and will contain the
c              M1 x NB product matrix, G = (U**t) * B on output.
c
c     LDB      (In)  First dimensioning parameter for B(,).
c              Require LDB .ge. M1.
c
c     NB       (In)  No. of cols in the matrices B and G.
c              Require NB .ge. 0.
c
c     S()      (Out)  Must be dimensioned at least N1.  On return will
c              contain the singular values of A, with the ordering
c                   S(1) .ge. S(2) .ge. ... .ge. S(N1) .ge. 0.
c              If M1 .lt. N1 the singular values indexed from M1+1
c              through N1 will be zero.
c              If the given integer arguments are not consistent, this
c              subr will return immediately, setting S(1) = -1.0.
c
c     WORK()  (Scratch)  Work space of total size at least 2*N1.
c              Locations 1 thru N1 will hold the off-diagonal terms of
c              the bidiagonal matrix for subr _QRBD.  Locations N1+1
c              thru 2*N1 will save info from one call to the next of
c              _HTGEN.
c     ------------------------------------------------------------------
c     Subprograms referenced directly: SCOPY, SHTCC, SHTGEN,SQRBD,SSWAP,
c        ERMSG, ERMOR, IERV1
c     Other subprograms needed: ERFIN, *1MACH (Fortran 77 only), *ROT,
c     *ROTG (* = S or D)
C     ------------------------------------------------------------------
c          This subr gives special treatment to the cases of entire rows
c     and/or columns of A being zero. This provides the feature that
c     singular values that are zero because of the zero structure of A
c     will be produced as exact zeros rather than as relatively small
c     nonzero values.  This is convenient for cases in which a user
c     wishes to remove a variable from a problem by simply zeroing the
c     corresponding column of A.
c
c          Method for this special feature:
c
C      1. EXCHANGE COLS OF A TO PACK NONZERO COLS TO THE LEFT.
C         SET NWORK  =  NO. OF NONZERO COLS.
C         USE LOCATIONS A(1,NWORK+1),...,A(1,N1) TO RECORD THE
C         COL PERMUTATIONS.
C      2. EXCHANGE ROWS OF A TO PACK NONZERO ROWS TO THE TOP.
C         QUIT PACKING IF FIND NWORK NONZERO ROWS.  MAKE SAME ROW
C         EXCHANGES IN B.  SET MWORK SO THAT ALL NONZERO ROWS OF THE
C         PERMUTED A ARE IN FIRST MWORK ROWS.  IF MWORK .LE. NWORK THEN
C         ALL MWORK ROWS ARE NONZERO.  IF MWORK .GT. NWORK THEN THE
C         FIRST NWORK ROWS ARE KNOWN TO BE NONZERO, AND ROWS NWORK+1
C         THRU MWORK MAY BE ZERO OR NONZERO.
C      3. APPLY THE BASIC SVD ALGORITHM TO THE MWORK BY NWORK PROBLEM.
C      4. MOVE PERMUTATION RECORD FROM A(,) TO S(I),I = NWORK+1,...,N1.
C      5. BUILD V UP FROM  NWORK BY NWORK TO N1 BY N1 BY PLACING ONES ON
C         THE DIAGONAL AND ZEROS ELSEWHERE.  THIS IS ONLY PARTLY DONE
C         EXPLICITLY.  IT IS COMPLETED DURING STEP 6.
C      6. EXCHANGE ROWS OF V TO COMPENSATE FOR COL EXCHANGES OF STEP 2.
C      7. PLACE ZEROS IN  S(I),I = NWORK+1,...,N1  TO REPRESENT ZERO
C         SING VALS.
C
c     ------------------------------------------------------------------
c          This code was originally developed by Charles L. Lawson and
c     Richard J. Hanson at Jet Propulsion Laboratory in 1973.  The
c     original code was described and listed in the book,
c
c                  Solving Least Squares Problems
c                  C. L. Lawson and R. J. Hanson
c                  Prentice-Hall, 1974
c
c     Feb 1985, Mar 1987, C. L. Lawson & S. Y. Chiu, JPL.  Adapted code
c     from the Lawson & Hanson book to Fortran 77 for use in the
c     JPL MATH77 library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for intrinsic functions.
c     Adding calls to BLAS and MATH77 error processing subrs in some
c     program units.
c     1989-10-20 CLL  Moved integer declaration to earlier position to
c     avoid warning msg from Cray compiler.
C     1992-06-16 CLL.  Using "min" fcn in arg list of calls to _HTCC
c     and _HTGEN to avoid "index out of range" when using a bounds
c     checker, even though no reference would be made to the "out of
c     range" location.
c     ------------------------------------------------------------------
C--S replaces "?": ?SVDRS, ?COPY, ?HTCC, ?HTGEN, ?QRBD, ?SWAP
c     ------------------------------------------------------------------
      integer I,IPASS,J,K,L,LBASE,LDA,LDB,M1,MWORK,N1,NB,NP1,NS,NWORK
      real             A(LDA,N1),B(LDB,*),ONE,S(N1),UPARAM,WORK(2*N1)
      real             ZERO
      logical COL, ROW
      parameter( ZERO = 0.0E0, ONE = 1.0E0, COL = .true., ROW = .false.)
c     ------------------------------------------------------------------
      NWORK = N1
      LBASE = NWORK
      if(LDA .lt. max(M1,NWORK) .or. M1 .le. 0 .or. NWORK .le. 0 .or.
     *   (NB .gt. 0 .and. LDB .lt. M1)) then
         call ERMSG('SSVDRS',1,0,
     *   'Bad argument values.  Require LDA .ge. max(M,N), M > 0,',
     *   ',')
         call ERMOR('N > 0, LDB .ge. M if NB > 0', ',')
         call IERV1('LDA',LDA,   ',')
         call IERV1('M',  M1,    ',')
         call IERV1('N',  NWORK, ',')
         call IERV1('LDB',LDB,   ',')
         call IERV1('NB', NB,    '.')
         S(1) = -ONE
         return
      endif
C                             BEGIN.. SPECIAL FOR ZERO ROWS AND COLS.
C
C                             PACK THE NONZERO COLS TO THE LEFT
C
      DO 50 J = NWORK, 1, -1
         DO 20 I = 1,M1
            IF (A(I,J) .NE. ZERO) GO TO 50
   20    CONTINUE
C
C         COL J  IS ZERO. EXCHANGE IT WITH COL NWORK.
C
         IF (J .ne. NWORK) then
            DO 30 I = 1, M1
   30       A(I,J) = A(I,NWORK)
         end if
         A(1,NWORK) = J
         NWORK = NWORK - 1
   50 CONTINUE
C                          IF NWORK = 0 THEN A IS ENTIRELY ZERO AND SVD
C                          COMPUTATION CAN BE SKIPPED
      NS = 0
      IF (NWORK .ne. 0) then
C        ---------------------------------------------------------------
C                             PACK NONZERO ROWS TO THE TOP
C                             QUIT PACKING IF FIND NWORK NONZERO ROWS
         I = 1
         MWORK = M1
   60    IF (I.le.NWORK .and. I.lt.MWORK) then
            DO 80 J = I, NWORK
               IF (A(I,J) .NE. ZERO) GO TO 145
   80       CONTINUE
            DO 85 J = 1, I-1
               IF(A(I,J) .NE. ZERO) GO TO 145
   85       CONTINUE
C                             ROW I IS ZERO
C                             EXCHANGE ROWS I AND MWORK
            IF (NB .GT. 0)
     *         CALL SSWAP(   NB, B(MWORK,1), LDB, B(I,1), LDB)
               CALL SCOPY(NWORK, A(MWORK,1), LDA, A(I,1), LDA)
            IF (MWORK .LE. NWORK) THEN
               DO 130 J = 1,NWORK
  130             A(MWORK,J) = ZERO
            ENDIF
C                             EXCHANGE IS FINISHED
            MWORK = MWORK - 1
            GO TO 60
c           Here when row I is not all zero.  No exchange needed.
  145       I = I + 1
            GO TO 60
         end if
C                             END.. SPECIAL FOR ZERO ROWS AND COLUMNS
c        ---------------------------------------------------------------
C                             BEGIN.. SVD ALGORITHM
C     METHOD..
C     (1)     REDUCE THE MATRIX TO UPPER BIDIAGONAL FORM WITH
C     HOUSEHOLDER TRANSFORMATIONS.
C          H(NWORK)...H(1)AQ(1)...Q(NWORK-2)  =  (D**T,0)**T
C     WHERE D IS UPPER BIDIAGONAL.
C
C     (2)     APPLY H(NWORK)...H(1) TO B.  HERE H(NWORK)...H(1)*B REPLAC
C     IN STORAGE.
C
C     (3)     THE MATRIX PRODUCT W =  Q(1)...Q(NWORK-2) OVERWRITES THE F
C     NWORK ROWS OF A IN STORAGE.
C
C     (4)     AN SVD FOR D IS COMPUTED.  HERE K ROTATIONS RI AND PI ARE
C     COMPUTED SO THAT
C          RK...R1*D*P1**(T)...PK**(T)  =  DIAG(S1,...,S.NS)
C     TO WORKING ACCURACY.  THE SI ARE NONNEGATIVE AND NONINCREASING.
C     HERE RK...R1*B OVERWRITES B IN STORAGE WHILE
C     A*P1**(T)...PK**(T)  OVERWRITES A IN STORAGE.
C
C     (5)     IT FOLLOWS THAT,WITH THE PROPER DEFINITIONS,
C     U**(T)*B OVERWRITES B, WHILE V OVERWRITES THE FIRST NWORK ROW AND
C     COLUMNS OF A.
C     ------------------------------------------------------------------
         L = MIN(MWORK,NWORK)
C             THE FOLLOWING LOOP REDUCES A TO UPPER BIDIAGONAL AND
C             ALSO APPLIES THE PREMULTIPLYING TRANSFORMATIONS TO B.
C
         DO 170 J = 1,L
            IF(J .LT. MWORK) THEN
               CALL SHTCC(1,J,J+1,MWORK,A(1,J),UPARAM,
     *            A(1,min(J+1,NWORK)),LDA,NWORK-J)
               CALL SHTCC(2,J,J+1,MWORK,A(1,J),UPARAM,B,LDB,NB)
            ENDIF
            IF (J .LT. NWORK-1) THEN
               CALL SHTGEN (1,J+1,J+2,NWORK,A(J,1),LDA,ROW,
     *            WORK(LBASE + J),A(min(J+1,MWORK),1),LDA,MWORK-J,ROW)
            ENDIF
  170    CONTINUE
C                            Copy the bidiagonal matrix into the arrays
c                            S() and WORK(1:N1) for _QRBD.
         DO 180 J = 1, L
  180    S(J) = A(J,J)
         DO 190 J = 2, L
  190    WORK(J) = A(J-1,J)
C
         NS = NWORK
         IF (MWORK .LT. NWORK) THEN
            NS = MWORK + 1
            S(NS) = ZERO
            WORK(NS) = A(MWORK,MWORK+1)
         ENDIF
C
C     CONSTRUCT THE EXPLICIT NWORK BY NWORK PRODUCT MATRIX,
C     W = Q1*Q2*...*QL*I IN THE ARRAY A().
C
         DO 230 I = NWORK, 1, -1
            IF (I .LE. MIN(MWORK,NWORK-2))
     *         CALL SHTGEN(2,I+1,I+2,NWORK,A(I,1),LDA,ROW,
     *            WORK(LBASE+I),A(1,min(I+1,NWORK)),LDA,NWORK-I,COL)
C
            DO 220 J = 1, NWORK
  220          A(I,J) = ZERO
  230    A(I,I) = ONE
C
C        COMPUTE THE SVD OF THE BIDIAGONAL MATRIX
C
         CALL SQRBD (IPASS,S,WORK(1),NS,A,LDA,NWORK,B,LDB,NB)
C
C          If the above subr has a convergence failure it will report
c          the error via the MATH77 error message subrs and return
c          with IPASS = 2.  Since the error has been reported, we don't
c          report it again here but just return.
c
         IF (IPASS .EQ. 2) RETURN
C        ---------------------------------------------------------------
      end if
      DO 250 J = NS+1, NWORK
  250    S(J) = ZERO
      IF (NWORK .EQ. N1) RETURN
      NP1 = NWORK + 1
C                                  MOVE RECORD OF PERMUTATIONS
C                                  AND STORE ZEROS
      DO 280 J = NP1, N1
         S(J) = A(1,J)
         DO 270 I = 1,NWORK
  270       A(I,J) = ZERO
  280 CONTINUE
C                             PERMUTE ROWS AND SET ZERO SINGULAR VALUES.
      DO 300 K = NP1, N1
         I = S(K)
         S(K) = ZERO
         DO 290 J = 1,N1
            A(K,J) = A(I,J)
  290       A(I,J) = ZERO
         A(I,K) = ONE
  300 CONTINUE
c          End.. Special for zero rows and columns.
      RETURN
      END


program test_schroed
use types, only: dp
use bsplines, only: bspline, bspline_der, bspline_der2
use mesh, only: meshexp
use quadrature, only: gauss_pts, gauss_wts
use linalg, only: eigh
use utils, only: stop_error
use schroed_util, only: lho, radial
implicit none

integer, parameter :: n = 30, k = 6, Nq=7
integer, parameter :: N_intervals = n-k+1
integer, parameter :: Nq_total = Nq*N_intervals, Nb=n-2
real(dp) :: t(n+k), rmin, rmax, a
real(dp) :: xiq(Nq), wtq(Nq), xa, xb, jac, x(Nq)
real(dp), allocatable :: xq(:), wq(:), hq(:)
real(dp), allocatable :: B(:,:), Bp(:,:), Bpp(:,:)
real(dp), allocatable :: Am(:,:), Bm(:,:), c(:,:), lam(:)
real(dp) :: En, condA, condB
integer :: i, j, u, l, Z

allocate(Am(Nb,Nb), Bm(Nb,Nb), c(Nb,Nb), lam(Nb))
allocate(xq(Nq_total), wq(Nq_total), hq(Nq_total))
allocate(B(Nq_total, n), Bp(Nq_total, n), Bpp(Nq_total, n))

rmin = -10
rmax = 10
a = 1
call construct_basis()
call lho(xq, wq, B(:,:Nb), Bp(:,:Nb), lam, condA, condB)

rmin = 0
rmax = 30
a = 30
Z = 2
l = 2
call construct_basis()
call radial(Nb, xq, wq, B, Bp, Z, l)

open(newunit=u, file="bspline_basis.txt", status="replace")
write(u,*) t
write(u,*) xq
do i = 1, n
    write(u,*) B(:,i)
end do
close(u)

contains

    subroutine construct_basis()
    t(:k-1) = rmin
    t(k:n+1) = meshexp(rmin, rmax, a, N_intervals)
    t(n+2:) = rmax

    print *, "Constructing quadrature rule"
    ! Loop over knot spans (intervals), and constract a global quadrature rule
    ! Integrals of a function hq evaluated at the points xq are calculated using:
    ! sum(wq*hq)
    xiq = gauss_pts(Nq)
    wtq = gauss_wts(Nq)
    do i = 1, n-k+1
        xa = t(i+k-1)
        xb = t(i+k)
        jac = (xb-xa)/2
        x = (xiq(:)+1) * jac + xa
        xq((i-1)*Nq+1:i*Nq) = x
        wq((i-1)*Nq+1:i*Nq) = wtq*jac
    end do

    print *, "Evaluating basis functions"
    ! Evaluate basis functions and their derivatives on quadrature grid
    ! Skip the first and last B-spline (that's why Nb=n-2).
    do i = 1, Nb
        B(:,i)   = bspline     (t, i+1, k, xq)
        Bp(:,i)  = bspline_der (t, i+1, k, xq)
        Bpp(:,i) = bspline_der2(t, i+1, k, xq)
    end do
    end subroutine

end program


module barotropic_dynamics_mod

use               fms_mod, only: open_namelist_file,   &
                                 open_restart_file,    &
                                 file_exist,           &
                                 check_nml_error,      &
                                 error_mesg,           &
                                 FATAL, WARNING,       &
                                 write_version_number, &
                                 mpp_pe,               &
                                 mpp_root_pe,          &
                                 read_data,            &
                                 write_data,           &
                                 set_domain,           &
                                 close_file,           &
                                 stdlog

use    time_manager_mod,  only : time_type,      &
                                 get_time,       &
                                 operator(==),   &
                                 operator(-)

use         constants_mod,  only: radius, omega

use         transforms_mod, only: transforms_init,         transforms_end,          &
                                  get_grid_boundaries,                              &
                                  trans_spherical_to_grid, trans_grid_to_spherical, &
                                  compute_laplacian,                                &
                                  get_sin_lat,             get_cos_lat,             &
                                  get_deg_lon,             get_deg_lat,             &
                                  get_grid_domain,         get_spec_domain,         &
                                  spectral_domain,         grid_domain,             &
                                  vor_div_from_uv_grid,    uv_grid_from_vor_div,    &
                                  horizontal_advection

use   spectral_damping_mod, only: spectral_damping_init,  &
                                  compute_spectral_damping

use           leapfrog_mod, only: leapfrog

use       fv_advection_mod, only: fv_advection_init, &
                                  a_grid_horiz_advection

!===============================================================================================
implicit none
private
!===============================================================================================

public :: barotropic_dynamics_init, &
          barotropic_dynamics,      &
          barotropic_dynamics_end,  &
          dynamics_type,            &
          grid_type,                &
          spectral_type,            &
          tendency_type

! version information
!===================================================================
character(len=128) :: version = '$Id: barotropic_dynamics.f90,v 10.0 2003/10/24 22:00:57 fms Exp $'
character(len=128) :: tagname = '$Name: latest $'
!===================================================================

type grid_type
   real, pointer, dimension(:,:,:) :: u=>NULL(), v=>NULL(), vor=>NULL(), trs=>NULL(), tr=>NULL()
   real, pointer, dimension(:,:)   :: pv=>NULL(), stream=>NULL()
end type
type spectral_type
   complex, pointer, dimension(:,:,:) :: vor=>NULL(), trs=>NULL()
end type
type tendency_type
   real, pointer, dimension(:,:) :: u=>NULL(), v=>NULL(), trs=>NULL(), tr=>NULL()
end type
type dynamics_type
   type(grid_type)     :: grid
   type(spectral_type) :: spec
   type(tendency_type) :: tend
   integer             :: num_lon, num_lat
   logical             :: grid_tracer, spec_tracer
end type

integer, parameter :: num_time_levels = 2

integer :: is, ie, js, je, ms, me, ns, ne

logical :: module_is_initialized = .false.

real,  allocatable, dimension(:)   :: sin_lat, cos_lat, rad_lat, rad_lon, &
                                      deg_lat, deg_lon, &
                                      coriolis, glon_bnd, glat_bnd

integer :: pe, npes

! namelist parameters with default values

logical :: check_fourier_imag = .false.
logical :: south_to_north     = .true.
logical :: triang_trunc       = .true.

real    :: robert_coeff       = 0.04
real    :: longitude_origin   = 0.0

character(len=64) :: damping_option = 'resolution_dependent'
integer :: damping_order      = 4
real    :: damping_coeff      = 1.e-04

real     :: zeta_0     = 8.e-05
integer  :: m_0        = 4
real     :: eddy_width = 15.0
real     :: eddy_lat   = 45.0

logical :: spec_tracer      = .true.
logical :: grid_tracer      = .true.

integer :: num_lat            = 128
integer :: num_lon            = 256
integer :: num_fourier        = 85
integer :: num_spherical      = 86
integer :: fourier_inc        = 1

real, dimension(2) :: valid_range_v = (/-1.e3,1.e3/)

namelist /barotropic_dynamics_nml/ check_fourier_imag, south_to_north, &
                                 triang_trunc,                         &
                                 num_lon, num_lat, num_fourier,        &
                                 num_spherical, fourier_inc,           &
                                 longitude_origin, damping_option,     &
                                 damping_order,     damping_coeff,     &
                                 robert_coeff,                         &
                                 spec_tracer, grid_tracer,             &
                                 eddy_lat, eddy_width, zeta_0, m_0,    &
                                 valid_range_v

contains

!===============================================================================================

subroutine barotropic_dynamics_init (Dyn,  Time, Time_init)

type(dynamics_type), intent(inout)  :: Dyn
type(time_type)    , intent(in)     :: Time, Time_init

integer :: i, j

real,    allocatable, dimension(:)   :: glon_bnd, glat_bnd
complex, allocatable, dimension(:,:) :: div
real :: xx, yy, dd

integer  :: ierr, io, unit, pe
logical  :: root

! < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < >

call write_version_number (version, tagname)

pe   =  mpp_pe()
root = (pe == mpp_root_pe())

if (file_exist('input.nml')) then
  unit = open_namelist_file ()
  ierr=1
  do while (ierr /= 0)
    read  (unit, nml=barotropic_dynamics_nml, iostat=io, end=10)
    ierr = check_nml_error (io, 'barotropic_dynamics_nml')
  enddo
  10 call close_file (unit)
endif

if (root) write (stdlog(), nml=barotropic_dynamics_nml)

call transforms_init(radius, num_lat, num_lon, num_fourier, fourier_inc, num_spherical, &
         south_to_north=south_to_north,   &
         triang_trunc=triang_trunc,       &
         longitude_origin=longitude_origin       )

call get_grid_domain(is,ie,js,je)
call get_spec_domain(ms,me,ns,ne)

Dyn%num_lon      = num_lon
Dyn%num_lat      = num_lat
Dyn%spec_tracer  = spec_tracer
Dyn%grid_tracer  = grid_tracer

allocate (sin_lat   (js:je))
allocate (cos_lat   (js:je))
allocate (deg_lat   (js:je))
allocate (deg_lon   (is:ie))
allocate (rad_lat   (js:je))
allocate (rad_lon   (is:ie))
allocate (coriolis  (js:je))

allocate (glon_bnd  (num_lon + 1))
allocate (glat_bnd  (num_lat + 1))

call get_deg_lon (deg_lon)
call get_deg_lat (deg_lat)
call get_sin_lat (sin_lat)
call get_cos_lat (cos_lat)
call get_grid_boundaries (glon_bnd, glat_bnd, global=.true.)

coriolis = 2*omega*sin_lat

rad_lat = deg_lat*atan(1.0)/45.0
rad_lon = deg_lon*atan(1.0)/45.0

call spectral_damping_init(damping_coeff, damping_order, damping_option, num_fourier, num_spherical, 1, 0., 0., 0.)

allocate (Dyn%spec%vor (ms:me, ns:ne, num_time_levels))
allocate (Dyn%grid%u   (is:ie, js:je, num_time_levels))
allocate (Dyn%grid%v   (is:ie, js:je, num_time_levels))
allocate (Dyn%grid%vor (is:ie, js:je, num_time_levels))

allocate (Dyn%tend%u        (is:ie, js:je))
allocate (Dyn%tend%v        (is:ie, js:je))
allocate (Dyn%grid%stream   (is:ie, js:je))
allocate (Dyn%grid%pv       (is:ie, js:je))

allocate (div (ms:me, ns:ne))

call fv_advection_init(num_lon, num_lat, glat_bnd, 360./float(fourier_inc))
if(Dyn%grid_tracer) then
  allocate(Dyn%Grid%tr (is:ie, js:je, num_time_levels))
  allocate(Dyn%Tend%tr (is:ie, js:je))
endif

if(Dyn%spec_tracer) then
  allocate(Dyn%Grid%trs (is:ie, js:je, num_time_levels))
  allocate(Dyn%Tend%trs (is:ie, js:je))
  allocate(Dyn%Spec%trs (ms:me, ns:ne, num_time_levels))
endif

if(Time == Time_init) then

  do j = js, je
    Dyn%Grid%u(:,j,1) =   25.0*cos_lat(j)                       &
                        - 30.0*(cos_lat(j)**3)                  &
                        + 300.0*(sin_lat(j)**2)*(cos_lat(j)**6)
    Dyn%Grid%v(:,j,1) = 0.0
  end do

  call vor_div_from_uv_grid(Dyn%Grid%u  (:,:,1), Dyn%Grid%v  (:,:,1),   &
                            Dyn%Spec%vor(:,:,1), div)

  call trans_spherical_to_grid(Dyn%Spec%vor(:,:,1), Dyn%Grid%vor(:,:,1))

  do j = js, je
    do i = is, ie
      yy = (deg_lat(j)- eddy_lat)/eddy_width
      Dyn%Grid%vor(i,j,1) = Dyn%Grid%vor(i,j,1) + &
              0.5*zeta_0*cos_lat(j)*exp(-yy*yy)*cos(m_0*rad_lon(i))
    end do
  end do

  call trans_grid_to_spherical(Dyn%Grid%vor(:,:,1), Dyn%Spec%vor(:,:,1))

  div = (0.,0.)
  call uv_grid_from_vor_div   (Dyn%Spec%vor(:,:,1), div,        &
                               Dyn%Grid%u  (:,:,1), Dyn%Grid%v  (:,:,1))

  if(Dyn%grid_tracer) then
    Dyn%Grid%tr = 0.0
    do j = js, je
      if(deg_lat(j) > 10.0 .and. deg_lat(j) < 20.0) Dyn%Grid%tr(:,j,1) =  1.0
      if(deg_lat(j) > 70.0 )                        Dyn%Grid%tr(:,j,1) = -1.0
    end do
  endif

  if(Dyn%spec_tracer) then
    Dyn%Grid%trs = 0.0
    do j = js, je
      if(deg_lat(j) > 10.0 .and. deg_lat(j) < 20.0) Dyn%Grid%trs(:,j,1) =  1.0
      if(deg_lat(j) > 70.0 )                        Dyn%Grid%trs(:,j,1) = -1.0
    end do
    call trans_grid_to_spherical(Dyn%Grid%trs(:,:,1), Dyn%Spec%trs(:,:,1))
  endif

else

  call read_restart(Dyn)

endif

module_is_initialized = .true.

return
end subroutine barotropic_dynamics_init

!===============================================================================================

subroutine barotropic_dynamics(Time, Time_init, Dyn, previous, current, future, delta_t)

type(time_type)    , intent(in)     :: Time, Time_init
type(dynamics_type), intent(inout)  :: Dyn
integer, intent(in   )  :: previous, current, future
real,    intent(in   )  :: delta_t

! < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < >

complex, dimension(ms:me, ns:ne)  :: dt_vors, dt_divs, stream, zeros, spec_diss
real,    dimension(is:ie, js:je)  :: dt_vorg
integer :: j

! < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < >

if(.not.module_is_initialized) then
  call error_mesg('barotropic_dynamics','dynamics has not been initialized ', FATAL)
endif

zeros = (0.,0.)

do j = js, je
  Dyn%grid%pv(:,j)  = Dyn%grid%vor(:,j,current)  + coriolis(j)
end do

Dyn%Tend%u = Dyn%Tend%u + Dyn%grid%pv*Dyn%Grid%v(:,:,current)
Dyn%Tend%v = Dyn%Tend%v - Dyn%grid%pv*Dyn%Grid%u(:,:,current)

call vor_div_from_uv_grid (Dyn%Tend%u, Dyn%Tend%v, dt_vors, dt_divs)

call compute_spectral_damping(Dyn%Spec%vor(:,:,previous), dt_vors, delta_t)

call leapfrog(Dyn%Spec%vor , dt_vors  , previous, current, future, delta_t, robert_coeff)

call trans_spherical_to_grid(Dyn%Spec%vor(:,:,future), Dyn%Grid%vor(:,:,future))

call uv_grid_from_vor_div  (Dyn%Spec%vor (:,:,future),  zeros, &
                            Dyn%Grid%u   (:,:,future),  Dyn%Grid%v  (:,:,future))

if(minval(Dyn%Grid%v) < valid_range_v(1) .or. maxval(Dyn%Grid%v) > valid_range_v(2)) then
  call error_mesg('barotropic_dynamics','meridional wind out of valid range', FATAL)
endif

if(Dyn%spec_tracer) call update_spec_tracer(Dyn%Spec%trs, Dyn%Grid%trs, Dyn%Tend%trs, &
                         Dyn%Grid%u, Dyn%Grid%v, previous, current, future, delta_t)

if(Dyn%grid_tracer) call update_grid_tracer(Dyn%Grid%tr, Dyn%Tend%tr, &
                         Dyn%Grid%u, Dyn%Grid%v, previous, current, future, delta_t)

stream = compute_laplacian(Dyn%Spec%vor(:,:,current), -1)
call trans_spherical_to_grid(stream, Dyn%grid%stream)

return
end subroutine barotropic_dynamics

!===================================================================================

subroutine update_spec_tracer(tr_spec, tr_grid, dt_tr, ug, vg, &
                              previous, current, future, delta_t)

complex, intent(inout), dimension(ms:me, ns:ne, num_time_levels) :: tr_spec
real   , intent(inout), dimension(is:ie, js:je, num_time_levels) :: tr_grid
real   , intent(inout), dimension(is:ie, js:je                 ) :: dt_tr
real   , intent(in   ), dimension(is:ie, js:je, num_time_levels) :: ug, vg
real   , intent(in   )  :: delta_t
integer, intent(in   )  :: previous, current, future

complex, dimension(ms:me, ns:ne) :: dt_trs

call horizontal_advection     (tr_spec(:,:,current), ug(:,:,current), vg(:,:,current), dt_tr)
call trans_grid_to_spherical  (dt_tr, dt_trs)
call compute_spectral_damping (tr_spec(:,:,previous), dt_trs, delta_t)
call leapfrog                 (tr_spec, dt_trs, previous, current, future, delta_t, robert_coeff)
call trans_spherical_to_grid  (tr_spec(:,:,future), tr_grid(:,:,future))

return
end subroutine update_spec_tracer
!==========================================================================

subroutine update_grid_tracer(tr_grid, dt_tr_grid, ug, vg, &
                              previous, current, future, delta_t)

real   , intent(inout), dimension(is:ie, js:je, num_time_levels) :: tr_grid
real   , intent(inout), dimension(is:ie, js:je                 ) :: dt_tr_grid
real   , intent(in   ), dimension(is:ie, js:je, num_time_levels) :: ug, vg

real   , intent(in   )  :: delta_t
integer, intent(in   )  :: previous, current, future

real, dimension(size(tr_grid,1),size(tr_grid,2)) :: tr_current, tr_future

tr_future = tr_grid(:,:,previous) + delta_t*dt_tr_grid
dt_tr_grid = 0.0
call a_grid_horiz_advection (ug(:,:,current), vg(:,:,current), tr_future, delta_t, dt_tr_grid)
tr_future = tr_future + delta_t*dt_tr_grid
tr_current = tr_grid(:,:,current) + &
    robert_coeff*(tr_grid(:,:,previous) + tr_future - 2.0*tr_grid(:,:,current))
tr_grid(:,:,current) = tr_current
tr_grid(:,:,future)  = tr_future

return
end subroutine update_grid_tracer

!==========================================================================

subroutine read_restart(Dyn)

type(dynamics_type), intent(inout)  :: Dyn

integer :: unit, m, n, nt
real, dimension(ms:me, ns:ne) :: real_part, imag_part

if(file_exist('INPUT/barotropic_dynamics.res.nc')) then
  do nt = 1, 2
    call read_data('INPUT/barotropic_dynamics.res.nc', 'vors_real', real_part, spectral_domain, timelevel=nt)
    call read_data('INPUT/barotropic_dynamics.res.nc', 'vors_imag', imag_part, spectral_domain, timelevel=nt)
    do n=ns,ne
      do m=ms,me
        Dyn%Spec%vor(m,n,nt) = cmplx(real_part(m,n),imag_part(m,n))
      end do
    end do
    if(Dyn%spec_tracer) then
      call read_data('INPUT/barotropic_dynamics.res.nc', 'trs_real', real_part, spectral_domain, timelevel=nt)
      call read_data('INPUT/barotropic_dynamics.res.nc', 'trs_imag', imag_part, spectral_domain, timelevel=nt)
      do n=ns,ne
        do m=ms,me
           Dyn%Spec%trs(m,n,nt) = cmplx(real_part(m,n),imag_part(m,n))
        end do
      end do
    endif
    call read_data('INPUT/barotropic_dynamics.res.nc', 'u',   Dyn%Grid%u  (:,:,nt), grid_domain, timelevel=nt)
    call read_data('INPUT/barotropic_dynamics.res.nc', 'v',   Dyn%Grid%v  (:,:,nt), grid_domain, timelevel=nt)
    call read_data('INPUT/barotropic_dynamics.res.nc', 'vor', Dyn%Grid%vor(:,:,nt), grid_domain, timelevel=nt)
    if(Dyn%spec_tracer) then
      call read_data('INPUT/barotropic_dynamics.res.nc', 'trs', Dyn%Grid%trs(:,:,nt), grid_domain, timelevel=nt)
    endif
    if(Dyn%grid_tracer) then
      call read_data('INPUT/barotropic_dynamics.res.nc', 'tr', Dyn%Grid%tr(:,:,nt), grid_domain, timelevel=nt)
    endif
  end do
else if(file_exist('INPUT/barotropic_dynamics.res')) then
  unit = open_restart_file(file='INPUT/barotropic_dynamics.res',action='read')

  do nt = 1, 2
    call set_domain(spectral_domain)
    call read_data(unit,Dyn%Spec%vor(:,:, nt))
    if(Dyn%spec_tracer) call read_data(unit,Dyn%Spec%trs(:,:, nt))

    call set_domain(grid_domain)
    call read_data(unit,Dyn%Grid%u   (:,:, nt))
    call read_data(unit,Dyn%Grid%v   (:,:, nt))
    call read_data(unit,Dyn%Grid%vor (:,:, nt))
    if(Dyn%spec_tracer) call read_data(unit,Dyn%Grid%trs(:,:, nt))
    if(Dyn%grid_tracer) call read_data(unit,Dyn%Grid%tr (:,:, nt))

  end do
  call close_file(unit)

else
  call error_mesg('read_restart', 'restart does not exist', FATAL)
endif

return
end subroutine read_restart

!====================================================================

subroutine write_restart(Dyn, previous, current)

type(dynamics_type), intent(in)  :: Dyn
integer, intent(in) :: previous, current

integer :: unit, nt, nn

do nt = 1, 2
  if(nt == 1) nn = previous
  if(nt == 2) nn = current
  call write_data('RESTART/barotropic_dynamics.res.nc', 'vors_real',  real(Dyn%Spec%vor(:,:,nn)), spectral_domain)
  call write_data('RESTART/barotropic_dynamics.res.nc', 'vors_imag', aimag(Dyn%Spec%vor(:,:,nn)), spectral_domain)
  if(Dyn%spec_tracer) then
    call write_data('RESTART/barotropic_dynamics.res.nc', 'trs_real',  real(Dyn%Spec%trs(:,:,nn)), spectral_domain)
    call write_data('RESTART/barotropic_dynamics.res.nc', 'trs_imag', aimag(Dyn%Spec%trs(:,:,nn)), spectral_domain)
  endif
  call write_data('RESTART/barotropic_dynamics.res.nc', 'u',   Dyn%Grid%u  (:,:,nn), grid_domain)
  call write_data('RESTART/barotropic_dynamics.res.nc', 'v',   Dyn%Grid%v  (:,:,nn), grid_domain)
  call write_data('RESTART/barotropic_dynamics.res.nc', 'vor', Dyn%Grid%vor(:,:,nn), grid_domain)
  if(Dyn%spec_tracer) then
    call write_data('RESTART/barotropic_dynamics.res.nc', 'trs', Dyn%Grid%trs(:,:,nn), grid_domain)
  endif
  if(Dyn%grid_tracer) then
    call write_data('RESTART/barotropic_dynamics.res.nc', 'tr', Dyn%Grid%tr(:,:,nn), grid_domain)
  endif
enddo

!unit = open_restart_file(file='RESTART/barotropic_dynamics.res', action='write')

!do nt = 1, 2
!  if(nt == 1) nn = previous
!  if(nt == 2) nn = current

!  call set_domain(spectral_domain)
!  call write_data(unit,Dyn%Spec%vor(:,:, nn))
!  if(Dyn%spec_tracer) call write_data(unit,Dyn%Spec%trs(:,:, nn))

!  call set_domain(grid_domain)
!  call write_data(unit,Dyn%Grid%u   (:,:, nn))
!  call write_data(unit,Dyn%Grid%v   (:,:, nn))
!  call write_data(unit,Dyn%Grid%vor (:,:, nn))
!  if(Dyn%spec_tracer) call write_data(unit,Dyn%Grid%trs(:,:, nn))
!  if(Dyn%grid_tracer) call write_data(unit,Dyn%Grid%tr (:,:, nn))
!end do

!call close_file(unit)

end subroutine write_restart

!====================================================================

subroutine barotropic_dynamics_end (Dyn, previous, current)

type(dynamics_type), intent(inout)  :: Dyn
integer, intent(in) :: previous, current

if(.not.module_is_initialized) then
  call error_mesg('barotropic_dynamics','dynamics has not been initialized ', FATAL)
endif

call transforms_end()

call write_restart (Dyn, previous, current)

module_is_initialized = .false.

return
end subroutine barotropic_dynamics_end
!===================================================================================

end module barotropic_dynamics_mod


      FUNCTION bessj1(x)
      REAL bessj1,x
      REAL ax,xx,z
      DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
     *s1,s2,s3,s4,s5,s6,y
      SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
     *s5,s6
      DATA r1,r2,r3,r4,r5,r6/72362614232.d0,-7895059235.d0,
     *242396853.1d0,-2972611.439d0,15704.48260d0,-30.16036606d0/,s1,s2,
     *s3,s4,s5,s6/144725228442.d0,2300535178.d0,18583304.74d0,
     *99447.43394d0,376.9991397d0,1.d0/
      DATA p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4,
     *.2457520174d-5,-.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0,
     *-.2002690873d-3,.8449199096d-5,-.88228987d-6,.105787412d-6/
      if(abs(x).lt.8.)then
        y=x**2
        bessj1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+
     *y*(s4+y*(s5+y*s6)))))
      else
        ax=abs(x)
        z=8./ax
        y=z**2
        xx=ax-2.356194491
        bessj1=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
     *p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))*sign(1.,x)
      endif
      return
      END

      FUNCTION bessj0(x)
      REAL bessj0,x
      REAL ax,xx,z
      DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
     *s1,s2,s3,s4,s5,s6,y
      SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
     *s5,s6
      DATA p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4,
     *-.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1,
     *.1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/
      DATA r1,r2,r3,r4,r5,r6/57568490574.d0,-13362590354.d0,
     *651619640.7d0,-11214424.18d0,77392.33017d0,-184.9052456d0/,s1,s2,
     *s3,s4,s5,s6/57568490411.d0,1029532985.d0,9494680.718d0,
     *59272.64853d0,267.8532712d0,1.d0/
      if(abs(x).lt.8.)then
        y=x**2
        bessj0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y*
     *(s4+y*(s5+y*s6)))))
      else
        ax=abs(x)
        z=8./ax
        y=z**2
        xx=ax-.785398164
        bessj0=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
     *p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
      endif
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software =v1.9"217..


C SUBROUTINE INTERP.F
C
C SOURCE
C   BEVINGTON, PAGES 266-267.
C
C PURPOSE
C   INTERPOLATE BETWEEN DATA POINTS TO EVALUATE A FUNCTION
C
C USAGE
C   CALL INTERP (X, Y, NPTS, NTERMS, XIN, YOUT)
C
C DESCRIPTION OF PARAMETERS
C   X	   - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE
C   Y	   - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
C   NPTS   - NUMBER OF PAIRS OF DATA POINTS
C   NTERMS - NUMBER OF TERMS IN FITTING POLYNOMIAL
C   XIN    - INPUT VALUE OF X
C   YOUT   - INTERPOLATED VALUE OF Y
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   NONE
C
C COMMENTS
C   DIMENSION STATEMENT VALID FOR NTERMS UP TO 10
C   VALUE OF NTERMS MAY BE MODIFIED BY THE PROGRAM
C
	SUBROUTINE INTERP (X,Y,NPTS,NTERMS,XIN,YOUT)
	DOUBLE PRECISION DELTAX,DELTA,A,PROD,SUM
	DIMENSION X(1),Y(1)
	DIMENSION DELTA(10),A(10)
C
C SEARCH FOR APPROPRIATE VALUE OF X(1)
C
11	DO 19 I=1,NPTS
	IF (XIN-X(I)) 13,17,19
13	I1=I-NTERMS/2
	IF (I1) 15,15,21
15	I1=1
	GOTO 21
17	YOUT=Y(I)
18	GOTO 61
19	CONTINUE
	I1=NPTS-NTERMS+1
21	I2=I1+NTERMS-1
	IF (NPTS-I2) 23,31,31
23	I2=NPTS
	I1=I2-NTERMS+1
25	IF (I1) 26,26,31
26	I1=1
27	NTERMS=I2-I1+1
C
C EVALUATE DEVIATIONS DELTA
C
31	DENOM=X(I1+1)-X(I1)
	DELTAX=(XIN-X(I1))/DENOM
	DO 35 I=1,NTERMS
	IX=I1+I-1
35	DELTA(I)=(X(IX)-X(I1))/DENOM
C
C ACCUMULATE COEFFICIENTS A
C
40	A(1)=Y(I1)
41	DO 50 K=2,NTERMS
	PROD=1.
	SUM=0.
	IMAX=K-1
	IXMAX=I1+IMAX
	DO 49 I=1,IMAX
	J=K-I
	PROD=PROD*(DELTA(K)-DELTA(J))
49	SUM=SUM-A(J)/PROD
50	A(K)=SUM+Y(IXMAX)/PROD
C
C ACCUMULATE SUM OF EXPANSION
C
51	SUM=A(1)
	DO 57 J=2,NTERMS
	PROD=1.
	IMAX=J-1
	DO 56 I=1,IMAX
56	PROD=PROD*(DELTAX-DELTA(I))
57	SUM=SUM+A(J)*PROD
60	YOUT=SUM
61	RETURN
	END


      PROGRAM LA_SPTSVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_PTSVX
!  .. "IMPLICIT STATEMENT" ..
      IMPLICIT NONE
!  .. "Parameters" ..
      REAL(WP), PARAMETER :: ONE = 1.0_WP, THREE = 3.0_WP
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N, NRHS
      REAL(WP) ::  RCOND
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:), D(:), E(:), B(:,:), X(:,:), FERR(:), BERR(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SPTSVX Program Results.'
      N = 5; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE ( A(N), D(N), E(N-1), B(N,NRHS), X(N,NRHS), FERR(NRHS), BERR(NRHS) )

      OPEN(UNIT=21,FILE='ptsv.ma',STATUS='UNKNOWN')
      DO I=1,N
         READ(21,'(F3.0)') A(I);
      ENDDO;
      CLOSE(21)

      E = THREE; D(1) = 2*E(1)+ONE; D(2:N) = 2*E+ONE
      B(1,1) = D(1)+E(1); B(N,1) = E(N-1)+D(N)
      B(2:N-1,1) = 2*E + D(2:N-1)
      DO I = 2, NRHS; B(:,I) = B(:,1)*I; ENDDO
         WRITE(*,*) '  on entry:'
         WRITE (*,'(2HD:,8(1X,F9.2))') D
         WRITE (*,'(2HE:,8(1X,F9.2))') E
         WRITE(*,*) 'The RHS matrix B:'
         DO J = 1, N; WRITE (*,'(3(F9.5))') B(J,:);
         ENDDO

      CALL LA_PTSVX( D, E, B, X, FERR=FERR, BERR=BERR, RCOND=RCOND, INFO=INFO)

      WRITE(*,*) 'FERR on exit :'
      DO I = 1, N-1; WRITE (*,'(E13.5)') FERR(I);
      ENDDO
      WRITE(*,*)'BERR on exit :'
      DO I = 1, N-1; WRITE (*,'(E13.5)') BERR(I);
      ENDDO
      WRITE(*,*) 'RCOND =', RCOND
      WRITE(*,*) 'The matrix X on exit:'
      DO J = 1, N; WRITE (*,'(7(F9.5))') X(J,:);
      ENDDO
      WRITE(*,*)'INFO = ' ,INFO

      WRITE(*,*) '\noindent'
      WRITE(*,*) 'The solution of the system $ A\,X = B $ is:'
      WRITE(*,*) '$$ X = \left( \begin{array}{rrr}'
      DO I=1,N; WRITE(*,"(2(F9.5,' & '),F9.5,' \\')") X(I,:); ENDDO
      WRITE(*,*) '\end{array} \right). $$'

      END PROGRAM LA_SPTSVX_EXAMPLE


      SUBROUTINE CROSS(LX,X,LY,Y,LG,G)
!
!     CROSS COMPUTES THE CROSS PRODUCT BETWEEN TWO VECTORS.
!     REFERENCE: EAR MULTICHANNEL VOLUME, P. 27.
!
!     INPUTS ARE
!         LX=  LENGTH OF X SERIES
!         X=   X SERIES
!         LY=  LENGTH OF Y SERIES
!         Y= Y SERIES
!         LG=  NUMBER OF LAGS,FROM 0 TO LG-1,DESIRED IN CROSS PRODUCT
!     OUTPUT IS
!         G=   CROSS PRODUCT GIVEN BY (WHERE THE SUM IS OVER ALL I)
!
!
!              G(K) = SUM X(I+K)*Y(I)
!
!              WHERE VALUES OF X AND Y OUTSIDE OF THEIR RANGES ARE
!              TAKEN TO BE ZERO.
!
      DIMENSION X(*),Y(*),G(*)

      if(lg .gt. 0) then

         DO I=1,LG
c    1       call dotpr(x(i),1,y,1,g(i),min0(ly+i-1,lx)-i+1)
            CALL DOT(MIN0(LY+I-1,LX)-I+1,X(I),Y,G(I))
         enddo

      else if(lg .lt. 0) then

            lg2=-lg
            lg1=lg2+1
            do 2 i=1,lg1
c               call dotpr(x(i),1,y,1,g(i+lg2-1),min0(ly+i-1,lx)-i+1)
              call dot(min0(ly+i-1,lx)-i+1,x(i),y,g(i+lg2-1))
    2       continue
            do 3 i=1,lg2
               ii=lg2-i+1
c               call dotpr(y(i),1,x,1,g(ii),min0(lx+i-1,ly)-i+1)
              call dot(min0(lx+i-1,ly)-i+1,y(i),x,g(ii))
    3       continue

      endif

      RETURN
      END


 program test

   implicit none
   integer,parameter :: t = 10*9*8*7*6*5*4*3*2  !computed at compile time

   write(*,*) t  !write the value the console.

 end program test


PROGRAM mclqn

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       ==========================================================
!       Purpose: This program computes the Legendre polynomials
!                Qn(z) and Qn'(z) for a complex argument using
!                subroutine CLQN
!       Input :  x --- Real part of z
!                y --- Imaginary part of z
!                n --- Degree of Qn(z), n = 0,1,...
!       Output:  CQN(n) --- Qn(z)
!                CQD(n) --- Qn'(z)
!       Examples:

!       z = 0.5 + 0.5 i
!       n    Re[Qn(z)]     Im[Qn(z)]     Re[Qn'(z)]    Im[Qn'(z)]
!      -----------------------------------------------------------
!       0   .402359D+00   .553574D+00   .800000D+00   .400000D+00
!       1  -.107561D+01   .477967D+00   .602359D+00   .115357D+01
!       2  -.136636D+01  -.725018D+00  -.242682D+01   .183390D+01
!       3   .182619D+00  -.206146D+01  -.622944D+01  -.247151D+01
!       4   .298834D+01  -.110022D+01  -.114849D+01  -.125963D+02
!       5   .353361D+01   .334847D+01   .206656D+02  -.123735D+02

!       z = 3.0 + 2.0 i
!       n    Re[Qn(z)]     Im[Qn(z)]     Re[Qn'(z)]    Im[Qn'(z)]
!      -----------------------------------------------------------
!       0   .229073D+00  -.160875D+00  -.250000D-01   .750000D-01
!       1   .896860D-02  -.244805D-01   .407268D-02   .141247D-01
!       2  -.736230D-03  -.281865D-02   .190581D-02   .155860D-02
!       3  -.264727D-03  -.227023D-03   .391535D-03   .314880D-04
!       4  -.430648D-04  -.443187D-05   .527190D-04  -.305592D-04
!       5  -.481362D-05   .265297D-05   .395108D-05  -.839883D-05
!       ==========================================================

IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX*16 (c,z)
DIMENSION cqn(0:100),cqd(0:100)
WRITE(*,*)'  Please enter Nmax, x and y (z=x+iy)'
!        READ(*,*)N,X,Y
n=5
x=.5
y=.5
WRITE(*,30)x,y
WRITE(*,*)
CALL clqn(n,x,y,cqn,cqd)
WRITE(*,*)'  n    Re[Qn(z)]     Im[Qn(z)]     Re[Qn''(Z)]', '    Im[Qn''(Z)]'
WRITE(*,*)' ---------------------------------------------', '--------------'
DO  k=0,n
  WRITE(*,20)k,cqn(k),cqd(k)
END DO
20      FORMAT(1X,i3,4D14.6)
30      FORMAT(3X,'x =',f5.1,',  ','y =',f5.1)
END PROGRAM mclqn

SUBROUTINE clqn(n,x,y,cqn,cqd)

!       ==================================================
!       Purpose: Compute the Legendre functions Qn(z) and
!                their derivatives Qn'(z) for a complex
!                argument
!       Input :  x --- Real part of z
!                y --- Imaginary part of z
!                n --- Degree of Qn(z), n = 0,1,2,...
!       Output:  CQN(n) --- Qn(z)
!                CQD(n) --- Qn'(z)
!       ==================================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN OUT)         :: x
DOUBLE PRECISION, INTENT(IN OUT)         :: y
COMPLEX, INTENT(OUT)                     :: cqn(0:n)
COMPLEX, INTENT(OUT)                     :: cqd(0:n)
IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX*16 (c,z)

z=CMPLX(x,y)
IF (z == 1.0D0) THEN
  DO  k=0,n
    cqn(k)=(1.0D+300,0.0D0)
    cqd(k)=(1.0D+300,0.0D0)
  END DO
  RETURN
END IF
ls=1
IF (CDABS(z) > 1.0D0) ls=-1
cq0=0.5D0*CDLOG(ls*(1.0D0+z)/(1.0D0-z))
cq1=z*cq0-1.0D0
cqn(0)=cq0
cqn(1)=cq1
IF (CDABS(z) < 1.0001D0) THEN
  cqf0=cq0
  cqf1=cq1
  DO  k=2,n
    cqf2=((2.0D0*k-1.0D0)*z*cqf1-(k-1.0D0)*cqf0)/k
    cqn(k)=cqf2
    cqf0=cqf1
    cqf1=cqf2
  END DO
ELSE
  IF (CDABS(z) > 1.1D0) THEN
    km=40+n
  ELSE
    km=(40+n)*INT(-1.0-1.8*LOG(CDABS(z-1.0)))
  END IF
  cqf2=0.0D0
  cqf1=1.0D0
  DO  k=km,0,-1
    cqf0=((2*k+3.0D0)*z*cqf1-(k+2.0D0)*cqf2)/(k+1.0D0)
    IF (k <= n) cqn(k)=cqf0
    cqf2=cqf1
    cqf1=cqf0
  END DO
  DO  k=0,n
    cqn(k)=cqn(k)*cq0/cqf0
  END DO
END IF
cqd(0)=(cqn(1)-z*cqn(0))/(z*z-1.0D0)
DO  k=1,n
  cqd(k)=(k*z*cqn(k)-k*cqn(k-1))/(z*z-1.0D0)
END DO
RETURN
END SUBROUTINE clqn


*DECK DPCHBS
      SUBROUTINE DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF,
     +   NDIM, KORD, IERR)
C***BEGIN PROLOGUE  DPCHBS
C***PURPOSE  Piecewise Cubic Hermite to B-Spline converter.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      DOUBLE PRECISION (PCHBS-S, DPCHBS-D)
C***KEYWORDS  B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION,
C             PIECEWISE CUBIC INTERPOLATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Computing and Mathematics Research Division
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C *Usage:
C
C        INTEGER  N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR
C        PARAMETER  (INCFD = ...)
C        DOUBLE PRECISION  X(nmax), F(INCFD,nmax), D(INCFD,nmax),
C       *      T(2*nmax+4), BCOEF(2*nmax)
C
C        CALL DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF,
C       *             NDIM, KORD, IERR)
C
C *Arguments:
C
C     N:IN  is the number of data points, N.ge.2 .  (not checked)
C
C     X:IN  is the real array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.   (not checked)
C           nmax, the dimension of X, must be .ge.N.
C
C     F:IN  is the real array of dependent variable values.
C           F(1+(I-1)*INCFD) is the value corresponding to X(I).
C           nmax, the second dimension of F, must be .ge.N.
C
C     D:IN  is the real array of derivative values at the data points.
C           D(1+(I-1)*INCFD) is the value corresponding to X(I).
C           nmax, the second dimension of D, must be .ge.N.
C
C     INCFD:IN  is the increment between successive values in F and D.
C           This argument is provided primarily for 2-D applications.
C           It may have the value 1 for one-dimensional applications,
C           in which case F and D may be singly-subscripted arrays.
C
C     KNOTYP:IN  is a flag to control the knot sequence.
C           The knot sequence T is normally computed from X by putting
C           a double knot at each X and setting the end knot pairs
C           according to the value of KNOTYP:
C              KNOTYP = 0:  Quadruple knots at X(1) and X(N).  (default)
C              KNOTYP = 1:  Replicate lengths of extreme subintervals:
C                           T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1))  ;
C                           T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)).
C              KNOTYP = 2:  Periodic placement of boundary knots:
C                           T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1));
C                           T(M+4) = T(M+3) = X(N) + (X(2)-X(1))  .
C              Here M=NDIM=2*N.
C           If the input value of KNOTYP is negative, however, it is
C           assumed that NKNOTS and T were set in a previous call.
C           This option is provided for improved efficiency when used
C           in a parametric setting.
C
C     NKNOTS:INOUT  is the number of knots.
C           If KNOTYP.GE.0, then NKNOTS will be set to NDIM+4.
C           If KNOTYP.LT.0, then NKNOTS is an input variable, and an
C              error return will be taken if it is not equal to NDIM+4.
C
C     T:INOUT  is the array of 2*N+4 knots for the B-representation.
C           If KNOTYP.GE.0, T will be returned by DPCHBS with the
C              interior double knots equal to the X-values and the
C              boundary knots set as indicated above.
C           If KNOTYP.LT.0, it is assumed that T was set by a
C              previous call to DPCHBS.  (This routine does **not**
C              verify that T forms a legitimate knot sequence.)
C
C     BCOEF:OUT  is the array of 2*N B-spline coefficients.
C
C     NDIM:OUT  is the dimension of the B-spline space.  (Set to 2*N.)
C
C     KORD:OUT  is the order of the B-spline.  (Set to 4.)
C
C     IERR:OUT  is an error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -4  if KNOTYP.GT.2 .
C              IERR = -5  if KNOTYP.LT.0 and NKNOTS.NE.(2*N+4).
C
C *Description:
C     DPCHBS computes the B-spline representation of the PCH function
C     determined by N,X,F,D.  To be compatible with the rest of PCHIP,
C     DPCHBS includes INCFD, the increment between successive values of
C     the F- and D-arrays.
C
C     The output is the B-representation for the function:  NKNOTS, T,
C     BCOEF, NDIM, KORD.
C
C *Caution:
C     Since it is assumed that the input PCH function has been
C     computed by one of the other routines in the package PCHIP,
C     input arguments N, X, INCFD are **not** checked for validity.
C
C *Restrictions/assumptions:
C     1. N.GE.2 .  (not checked)
C     2. X(i).LT.X(i+1), i=1,...,N .  (not checked)
C     3. INCFD.GT.0 .  (not checked)
C     4. KNOTYP.LE.2 .  (error return if not)
C    *5. NKNOTS = NDIM+4 = 2*N+4 .  (error return if not)
C    *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N .  (not checked)
C
C       * Indicates this applies only if KNOTYP.LT.0 .
C
C *Portability:
C     Argument INCFD is used only to cause the compiler to generate
C     efficient code for the subscript expressions (1+(I-1)*INCFD) .
C     The normal usage, in which DPCHBS is called with one-dimensional
C     arrays F and D, is probably non-Fortran 77, in the strict sense,
C     but it works on all systems on which DPCHBS has been tested.
C
C *See Also:
C     PCHIC, PCHIM, or PCHSP can be used to determine an interpolating
C        PCH function from a set of data.
C     The B-spline routine DBVALU can be used to evaluate the
C        B-representation that is output by DPCHBS.
C        (See BSPDOC for more information.)
C
C***REFERENCES  F. N. Fritsch, "Representations for parametric cubic
C                 splines," Computer Aided Geometric Design 6 (1989),
C                 pp.79-82.
C***ROUTINES CALLED  DPCHKT, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   870701  DATE WRITTEN
C   900405  Converted Fortran to upper case.
C   900405  Removed requirement that X be dimensioned N+1.
C   900406  Modified to make PCHKT a subsidiary routine to simplify
C           usage.  In the process, added argument INCFD to be com-
C           patible with the rest of PCHIP.
C   900410  Converted prologue to SLATEC 4.0 format.
C   900410  Added calls to XERMSG and changed constant 3. to 3 to
C           reduce single/double differences.
C   900411  Added reference.
C   900430  Produced double precision version.
C   900501  Corrected declarations.
C   930317  Minor cosmetic changes.  (FNF)
C   930514  Corrected problems with dimensioning of arguments and
C           clarified DESCRIPTION.  (FNF)
C   930604  Removed  NKNOTS from DPCHKT call list.  (FNF)
C***END PROLOGUE  DPCHBS
C
C*Internal Notes:
C
C**End
C
C  Declare arguments.
C
      INTEGER  N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*)
C
C  Declare local variables.
C
      INTEGER  K, KK
      DOUBLE PRECISION  DOV3, HNEW, HOLD
      CHARACTER*8  LIBNAM, SUBNAM
C***FIRST EXECUTABLE STATEMENT  DPCHBS
C
C  Initialize.
C
      NDIM = 2*N
      KORD = 4
      IERR = 0
      LIBNAM = 'SLATEC'
      SUBNAM = 'DPCHBS'
C
C  Check argument validity.  Set up knot sequence if OK.
C
      IF ( KNOTYP.GT.2 )  THEN
         IERR = -1
         CALL XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1)
         RETURN
      ENDIF
      IF ( KNOTYP.LT.0 )  THEN
         IF ( NKNOTS.NE.NDIM+4 )  THEN
            IERR = -2
            CALL XERMSG (LIBNAM, SUBNAM,
     *                    'KNOTYP.LT.0 AND NKNOTS.NE.(2*N+4)', IERR, 1)
            RETURN
         ENDIF
      ELSE
C          Set up knot sequence.
         NKNOTS = NDIM + 4
         CALL DPCHKT (N, X, KNOTYP, T)
      ENDIF
C
C  Compute B-spline coefficients.
C
      HNEW = T(3) - T(1)
      DO 40  K = 1, N
         KK = 2*K
         HOLD = HNEW
C          The following requires mixed mode arithmetic.
         DOV3 = D(1,K)/3
         BCOEF(KK-1) = F(1,K) - HOLD*DOV3
C          The following assumes T(2*K+1) = X(K).
         HNEW = T(KK+3) - T(KK+1)
         BCOEF(KK) = F(1,K) + HNEW*DOV3
   40 CONTINUE
C
C  Terminate.
C
      RETURN
C------------- LAST LINE OF DPCHBS FOLLOWS -----------------------------
      END


program PSOclassicG

! Author: Mohammad Asif Zaman
! Fortran code (gfortran, G95)
! The fitness.f95 and timestamp.f95 files are expected to be in the same directory.

! gfortran -c PSOclassicG.f95
! gfortran PSOclassicG.f95 -o PSOclassicG.exe
! ./PSOclassicG.exe to run (in Cygwin or powershell terminal)

! Date: 13th Aug., 2012

! VTR = Value to reach. Required fitness function value for termination.
! NIR = Number of iterations required to obtain VTR.
! pbest = population best solution at each generation/iteration
! pbest_val = fitness value at pbset
! gbest = global best solution
! gbest_val = fitness value at gbest

! -> Mathematical parameters
!real(kind(1.0d0)) , parameter :: pi = 3.141592653589793
!complex, parameter :: j = (0,1)
!real(kind(1.0d0)), parameter :: eps = epsilon(eps)
! <- Mathematical parameters

! May 2, 2020
! version 1.2
!   - timestamp subroutine: date bug fixed
!   - added Makefile
!   - The make file works in both linux terminal and windows powershell as well
!   - The code works fine in both linux and windows

! -> File operation parameters
CHARACTER(len=18) :: str
character(len=29) :: command_Make
character(len=35) :: command_File
! <- File operation parameters

! -> PSO and fitness parameters
integer, parameter :: psize = 30, dimen = 30, max_iter = 5000, c1 = 2, c2 = 2
real(kind(1.0d0)), parameter :: VTR = 1e-6
integer :: iter = 1, overfly_counter = 0, NIR = 0, NFE = 0
logical :: overfly_flag = .false.
real(kind(1.0d0)) :: xmin(dimen), xmax(dimen), vmin(dimen), vmax(dimen)
real(kind(1.0d0)) :: x(psize, dimen) = 0, v(psize, dimen) = 0
real(kind(1.0d0)) :: pbest(psize, dimen), gbest(dimen)
real(kind(1.0d0)) :: pbest_val(psize) = 0
real(kind(1.0d0)) :: gbest_val
real(kind(1.0d0)) :: w
real(kind(1.0d0)) :: gbest_val_store(max_iter) = 0, x11_store(max_iter)
! <- PSO and fitness parameters

integer :: loop1, loop2, loopG

real(kind(1.0d0)) :: time_start, time_end
real(kind(1.0d0)) :: temp1, temp2

! The following loop runs the PSO. Every time this loop starts, a new PSO run is initiated with new seeds.
loopG = 0
! Do while (NIR == 0)    ! Turn this loop on if you want to run PSO multiple times till it satisfies VTR

						! until NIR reaches a finite value. If VTR is not achieved, this loop will continue.

	loopG = loopG + 1
	print *, loopG
	print *, NIR

	NIR = 0
	NFE = 0
	overfly_counter = 0

	call cpu_time(time_start)

	! -> Defining solution space
	! All dimensions are assigned same limit. But this can easily be changed by employing a loop
	xmin = -30
	xmax = 30

	vmin = 0.5 * xmin                          ! lower limit for velocity
	vmax = 0.5 * xmax                          ! higher limit for velocity
	! <- Defining solution space

	call random_seed
	call random_number(x)
	call random_number(v)

	! -> Intializaing particle position and velocities

	! The cost of the first particle is evaluated because it is needed as a stepping stool for evaluating gbest.
	x(1,:) = x(1,:) * (xmax - xmin) + xmin			! fixing the location of the first particle
	v(1,:) = v(1,:) * (vmax - vmin) + vmin
	pbest(1,:) = x(1,:)
	gbest = pbest(1,:)
	call fitness(dimen, pbest(1,:), pbest_val(1))		! evaluating the fitenss of the first particle
	NFE = NFE + 1
	gbest_val = pbest_val(1)

	! Composite threaded loop (15th Aug., 2012)
	! As the population is adjusted, the corresponding fitness parameters of the population is assigned simultaneously.

	do loop1 = 2, psize
		x(loop1,:) = x(loop1,:) * (xmax - xmin) + xmin
		v(loop1,:) = v(loop1,:) * (vmax - vmin) + vmin

		pbest(loop1,:) = x(loop1,:)

		call fitness(dimen, x(loop1,:), pbest_val(loop1))
		NFE = NFE + 1
		if ( pbest_val(loop1) < gbest_val ) then		! Geared for minimization problem
			gbest_val = pbest_val(loop1)
			gbest = x(loop1,:)
		end if

	end do

	! <- Intializaing particle position and velocities

	! Main iteration loop. Creating the generations.
	do iter = 1, max_iter

		w = 0.9 - (0.9 - 0.2) * iter /max_iter

		gbest_val_store(iter) = gbest_val
		x11_store(iter) = x(1,1)

		do loop1 = 1, psize
			overfly_flag = .false.
			do loop2 = 1, dimen
				call random_number(temp1)
				call random_number(temp2)
				v(loop1, loop2) = w*v(loop1,  loop2) + c1 * temp1 * (pbest(loop1,loop2) - x(loop1,loop2))
				v(loop1, loop2) = v(loop1, loop2) + c2* temp2 *(gbest(loop2) - x(loop1,loop2))

				if ( v(loop1, loop2) > vmax(loop2) ) then
					v(loop1, loop2) = vmax(loop2)
				end if

				if ( v(loop1, loop2) < vmin(loop2) ) then
					v(loop1, loop2) = vmin(loop2)
				end if

				x(loop1, loop2) = x(loop1, loop2) + v(loop1, loop2)

				if ( x(loop1, loop2) < xmin(loop2) .or. x(loop1, loop2) > xmax(loop2) ) then
					overfly_flag = .true.
					!print *, "fly"
					overfly_counter = overfly_counter + 1
				end if

			end do

			! Invisible boundary condition. Can be changed to reflecting or absorbing boundary conditions.

			if ( .not. overfly_flag ) then

				!print *, "No overfly"
				call fitness(dimen, x(loop1,:), temp1)
				if (NIR == 0) then
					NFE = NFE + 1
				end if

				! Composite IF statement that adjusts the pbset and gbest parameters (15th Aug., 2012)
				if ( temp1 < pbest_val(loop1) ) then
					pbest_val(loop1) = temp1
					pbest(loop1,:) = x(loop1,:)

					if ( pbest_val(loop1) < gbest_val ) then
						gbest_val = pbest_val(loop1)
						gbest = pbest(loop1,:)
						if ( NIR == 0 .and. gbest_val < VTR ) then
							NIR = iter
						end if
					end if

				end if

			end if

		end do  ! Ending loop over population

	end do  ! Ending main iteration loop

	call cpu_time(time_end)

	call timestamp(str)

	!do loop1 = 1, psize
	!print "(4f10.3)",  x(loop1,:), pbest_val(loop1)
	!print *,  x(loop1,:), pbest_val(loop1)

	!print "(1f10.3)", pbest_val(loop1)
	!end do

	!print "(2f10.5)",  x
	!print * , "Best"
	!print *, x(1,:)
	!print "(4f10.6)", gbest, gbest_val

	print *, "======================================================"
	print *, "Time stamp = ", str
	print *, "======================================================"

	print *, "======================================================"
	print *, "Algorithm parameters"
	print *, "--------------------------------------------------------------------------------------------"
	print *, "Problem dimension = ", dimen
	print *, "Dynamic range = ", xmin(1) , "to", xmax(1)
	print *, "Population size = ", psize
	print *, "Maximum allowed iterations = ", max_iter
	print *, "Defined value to reach (VTR) = ", VTR
	print *, "======================================================"

	print *,

	print *, "======================================================"
	print *, "Performance parameters"
	print *, "--------------------------------------------------------------------------------------------"
	print *, "Total CPU time = ", time_end - time_start, "seconds"
	print *, "Overfly counter = ", overfly_counter
	print *, "No. of iterations required to reach VTR (NIR) = ", NIR
	print *, "No. of function evaluations (NFE) = ", NFE
	print *, "Global best value achieved after NIR = ", gbest_val_store(NIR)
	print *, "Global best value achieved after max_iter = ", gbest_val
	print *,
	print *, "Global best solution ="
	print *,
	do loop1 = 1, dimen
		print *, gbest(loop1)
	end do
	print *,
	!call fitness(dimen, gbest, temp1)
	!print *, temp1
	print *, "======================================================"

!end do  ! Ending NIR loop if active.

! -> CSV File operation 17th Aug., 2012. (M -> 18th Aug., 2012)

command_Make = ('mkdir ' // 'Data_') // str

print *, "commandMake = ", command_Make

call system(command_Make)
command_File =   'Data_' // str // '/' // 'converg.csv' 	! the file name must be 11 characters, including . and extension
open  (20, file = command_File)
	do loop1 = 1, max_iter
		write (20,*) gbest_val_store(loop1), ",", x11_store(loop1)
	end do
close (20)

command_File =   'Data_' // str // '/' // 'final_x.txt' 	! the file name must be 11 characters, including . and extension
open  (30, file = command_File)
	do loop1 = 1, psize

		write (30,*) x(loop1,:), ","

	end do
close (30)

! <- File operation 17th Aug., 2012.

! -> Log file operation
command_File =   'Data_' // str // '/' // 'logfile.txt'
open  (11, file = command_File)

write (11,*) "======================================================"
write (11,*) "Time stamp = ", str
write (11,*) "======================================================"

write (11,*) "======================================================"
write (11,*) "Algorithm parameters"
write (11,*) "--------------------------------------------------------------------------------------------"
write (11,*) "Problem dimension = ", dimen
write (11,*) "Dynamic range = ", xmin(1) , "to", xmax(1)
write (11,*) "Population size = ", psize
write (11,*) "Maximum allowed iterations = ", max_iter
write (11,*) "Defined value to reach (VTR) = ", VTR
write (11,*) "======================================================"

write (11,*)

write (11,*) "======================================================"
write (11,*) "Performance parameters"
write (11,*) "---------------------------------------------------------------------------------------------"
write (11,*) "Total CPU time = ", time_end - time_start, "seconds"
write (11,*) "Overfly counter = ", overfly_counter
write (11,*) "No. of iterations required to reach VTR (NIR) = ", NIR
write (11,*) "No. of function evaluations (NFE) = ", NFE
write (11,*) "Global best value achieved after NIR = ", gbest_val_store(NIR)
write (11,*) "Global best value achieved after max_iter = ", gbest_val
write (11,*)
write (11,*) "Global best solution ="
write (11,*)
do loop1 = 1, dimen
	write (11,*) gbest(loop1)
end do
write (11,*)
write (11,*) "======================================================"

close(11)

! <- Log file operation

contains

	include 'fitness.f95'
	include 'timestamp.f95'

end program PSOclassicG


!We will create an array with ten integer numbers, and write a routine to sort the numbers.

PROGRAM Sort_numbers_within_an_array
  IMPLICIT NONE

  INTEGER, DIMENSION(1:10) :: a
  INTEGER, DIMENSION(1:1)  :: i,k
  INTEGER :: j,n

a = (/ 12, 5, 2, 4, 0, 9, 13, 5, 6, 10 /)

n=0

Do
i=MAXLOC(a(1:10-n)) !find location of maximum value
j=MAXVAL(a(1:10-n)) !Maximum value
k=MINLOC(a(1:10-n)) !find location of minimum value

a(i)=a(10-n)
a(10-n)=j

n=n+1

If (n==9) Exit
end do

Write (6,*) a

END PROGRAM Sort_numbers_within_an_array


	REAL FUNCTION CHISQSIZE(P1)
	IMPLICIT NONE
C
C    This function returns the sample size associated with P1 and the
C    other input parameters.  This formula should be used for studies that
C    are analyzed with an uncorrected chi-squared test.
C
C    Arguments
C
	REAL P1
C
C    Functions
C
	REAL ZCRVALUE
C
C    Locals
C
	REAL ZALPHA,ZBETA,P,Q
C
C    Common from main
C
	REAL ALPHA,BETA,P0,N,M,Q0,Q1
	COMMON/IPCOM/ALPHA,BETA,P0,N,M,Q0,Q1
C
C Code:
	ZALPHA=ZCRVALUE(ALPHA/2.)
	ZBETA=ZCRVALUE(BETA)
	P=(N*P1+M*N*P0)/(M*N+N)
        Q=1.-P
	Q1=1.-P1
	Q0=1.-P0
	CHISQSIZE=
     .	(
     .	(ZALPHA*SQRT((1.+1./M)*P*Q) + ZBETA*SQRT((P0*Q0)/M+(P1*Q1)))**2
     .     /
     .  (P0-P1)**2
     .	) - N
C
C    Done.
C
	RETURN
	END


MODULE matrices
	IMPLICIT NONE
	CONTAINS

	INTEGER FUNCTION plus_un(i,n)
		INTEGER, INTENT(IN) :: i, n
		IF(n>i)THEN
			plus_un=i+1
		ELSE
			plus_un=1
		END IF
	END FUNCTION plus_un

	INTEGER FUNCTION moins_un(i,n)
		INTEGER, INTENT(IN) :: i, n
		IF(i>1)THEN
			moins_un=i-1
		ELSE
			moins_un=n
		END IF
	END FUNCTION moins_un

	SUBROUTINE saisit_impair(n)
		INTEGER, INTENT(OUT)::n
		DO
			PRINT*, "Entrez l'ordre impair et positif n du carre magique"
			READ*, n
			IF(MODULO(n,2)==1 .AND. n>0)EXIT
			PRINT*, "Recommencez!"
		END DO
	END SUBROUTINE saisit_impair

	SUBROUTINE affiche(A)
		INTEGER, DIMENSION(:,:), INTENT(IN):: A
		INTEGER:: i, nl
		nl = SIZE(A,1)
		DO i=1, nl
			PRINT*, A(i,:)
		END DO
	END SUBROUTINE affiche
END MODULE matrices


! { dg-do compile }
! { dg-additional-options "-ffrontend-optimize" }
! PR 84270 - this used to be rejected.
! Test case by Michael Weinert

module fp_precision

   integer, parameter   :: fp = selected_real_kind(13)

end module fp_precision

      subroutine lhcal(nrot,orth,ngpts,vgauss,vr_0)

      use fp_precision  ! floating point precision

      implicit none

!--->    rotation matrices and rotations (input)
      integer,          intent(in)  :: nrot
!     real(kind=fp),    intent(in)  :: orth(3,3,nrot)  ! fine at all -O
      real(kind=fp),    intent(in)  :: orth(3,3,*)

!--->    gaussian integration points
      integer,          intent(in)  :: ngpts
      real(kind=fp),    intent(in)  :: vgauss(3,*)

!--->    output results
      real(kind=fp),    intent(out) :: vr_0(3)

      real(kind=fp)     :: v(3),vr(3)
      integer           :: n,nn

      vr_0 = 0
      do nn=1,ngpts
         v(:) = vgauss(:,nn)
!--->    apply rotations
         do n=2,nrot
            vr = matmul( orth(:,:,n), v )
            vr_0 = vr_0 + vr
         enddo
      enddo

      return
      end subroutine lhcal


! vim: set ft=fortran sw=4 ts=4:

program weather_stats

    ! parallel version, using coarrays

    use mod_array, only: denan, mean
    use mod_io, only: read_buoy
    use mod_parallel, only: tile_indices

    implicit none

    character(len=5), allocatable :: ids(:)
    character(len=20), allocatable :: time(:)
    real, allocatable  :: gather_max(:)[:], gather_mean(:)[:]
    real, allocatable :: wind_speed(:)
    real, allocatable :: max_wind(:), mean_wind(:)
    integer :: is, ie, indices(2)
    integer :: i

    ids = ['42001', '42002', '42003', '42020', '42035',&
        '42036', '42039', '42040', '42055']

    indices = tile_indices(size(ids))
    is = indices(1)
    ie = indices(2)

    allocate(gather_max(size(ids))[*], gather_mean(size(ids))[*])
    allocate(max_wind(is:ie), mean_wind(is:ie))

    do i = is, ie
        call read_buoy('data/buoy_' // ids(i) // '.csv', time, wind_speed)
        wind_speed = denan(wind_speed)
        max_wind(i) = maxval(wind_speed)
        mean_wind(i) = mean(wind_speed)
    end do

    gather_max(is:ie)[1] = max_wind
    gather_mean(is:ie)[1] = mean_wind

    sync all

    if (this_image() == 1) then
        print *, 'Maximum wind speed measured is ', maxval(gather_max),&
            'at station ', ids(maxloc(gather_max))
        print *, 'Highest mean wind speed is ', maxval(gather_mean),&
            'at station ', ids(maxloc(gather_mean))
        print *, 'Lowest mean wind speed is ', minval(gather_mean),&
            'at station ', ids(minloc(gather_mean))
    end if

end program weather_stats


program co_reduce_factorial
  !! author: Daniel Topa & Izaak Beekman
  !! category: regression
  !!
  !! [issue #172](https://github.com/sourceryinstitute/opencoarrays/issues/172)
  !! wherein co-reduce gets junk in the first image when binary
  !! operator's (pure function) arguments have `value` attribute
  !! instead of `intent(in)`

  implicit none
  integer :: value[ * ] !! Each image stores their image number here
  integer :: k
  value = this_image ( )
  call co_reduce ( value, result_image = 1, operator = myProd )
  !! value[k /= 1] undefined, value[ k == 1 ] should equal $n!$ where $n$ is `num_images()`
  if ( this_image ( ) == 1 ) then
     write ( * , '( "Number of images = ", g0 )' ) num_images ( )
     do k = 1, num_images ( )
        write ( * , '( 2( a, i0 ) )' ) 'value [ ', k, ' ] is ', value [ k ]
        write ( * , '(a)' ) 'since RESULT_IMAGE is present, value on other images is undefined by the standard'
     end do
     write ( * , '( "Product  value = ", g0 )' ) value  !! should print num_images() factorial
     write ( * , 100 )
     if ( value == factorial( num_images() ) ) then
        write ( * , '(a)' ) 'Test passed.'
     else
        write ( * , '(a, I0)') 'Answer should have been num_images()! = ', factorial( num_images() )
        error stop 'Wrong answer for n! using co_reduce'
     end if
  end if
100 format ( "Expected value = num_images()!", /, " 2! = 2, 3! = 6, 4! = 24, ..." )

contains

  pure function myProd ( a, b ) result ( rslt )
    !! Product function to be used in `co_reduce` reduction for
    !! computing factorials. When `value` attribute is changed to
    !! `intent(in)` tests pass, and expected behavior is observed.
    integer, value :: a, b
    !! multiply two inputs together.  If we change `value` to
    !! `intent(in)` the test passes and the issue goes away and
    !! according to C1276 of F2008:
    !!
    !! > C1276 The specification-part of a pure function subprogram
    !! > shall specify that all its nonpointer dummy data objects have
    !! > the INTENT (IN) or the VALUE attribute.
    !!
    !! Thanks to @LadaF for pointing this out.
    integer        :: rslt !! product of a*b
    rslt = a * b
  end function

  pure function factorial ( n ) result ( rslt )
    !! Compute $n!$
    integer, intent(in) :: n
    integer :: rslt
    integer :: i
    rslt = 1
    do i = 1, n
      rslt = rslt*i
   end do
 end function
end program