      SUBROUTINE SPFIT (M,X,Y,SIG,NMAX,SEEKN,COMTRN,CHBBAS,P,NFIT,
     * SIGFAC, W)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SPFIT  Krogh  Changes to use M77CON
c>> 1990-08-13 SPFIT  CLL Fixed to assure NFIT .ge. 0 in OK cases.
C>> 1987-12-09 SPFIT  Lawson  Initial code.
C     Least squares polynomial fit to discrete data.
C     Uses either the Monomial or the Chebyshev basis.
C     ------------------------------------------------------------------
C     M  [integer, in]  No. of data points.
C
C     (X(I),I=1,M)  [float, in]  Abcissas of data.
C
C     (Y(I),I=1,M)  [float, in]  Ordinates of data.
C
C     (SIG(I),I=1,M)  [float, in]  Standard deviations of data Y().
C          If SIG(1) .lt. 0., the subr will funcrtion as though all
C          SIG(I) ate equal to abs(SIG(1)).
C          In this latter case SIG() can be dimensioned 1 rather than M.
C
C     NMAX [integer, in]  Specifies the highest degree polynomial to be
c          considered.
C
C     SEEKN  [logical, in]  If .true. this subr will determine the
c           optimal degree NFIT in the range [0, NMAX] for fitting the
c           given data and compute that fit.
C           If .false. this subr will do the fit with NFIT = NMAX
C           unless this produces a near-singular problem, in which case
C           NFIT will be reduced.
C
C     COMTRN  [logical, in]  If .true. this subr will compute
c           transformation parameters, P(1) and P(2), so that the
c           transformed abcissa variable ranges from -1.0 to +1.0.
C           If .false., will use P(1) and P(2) as given on entry.
C
C     CHBBAS  [logical, in]  If .true. this subr will use the Chebyshev
c           basis.  If .false., will use the Monomial basis.
C
C     (P(J),J=1,NMAX+3)  [float, inout]  P(1) and P(2) define a
c            transformation of the abcissa variable as follows:
C
C                     S = ( X - P(1) ) / P(2)
C
C           (P(I+3),I=0,...,NMAX) are polynomial coefficients computed
C           by this subr.  P(I+3) is the coeff of S**I, if the Monomial
C           bases is used and of the I-th degree Chebyshev polynomial if
C           the Chebyshev basis is used.
C           If this subr sets NFIT < NMAX then it will also set the
c           coefficients P(I+3) for I = NFIT+1, ..., NMAX to zero.
C
C     NFIT [integer, out]  On a successful return NFIT will be the
c           degree of the fitted polynomial.  It will be set as
c           described above in the specification of SEEKN.
c           If input values are inconsistent, NFIT will be set to -1
c           to indicate an error condition, and no fit will be done.
C
C     SIGFAC [float,out]  Factor by which the given SIG() values should
C           be multiplied to improve consistency with the fit, i.e.,
c           SIGFAC*SIG(i) is the a posteriori estimate of the standard
c           deviation of the error in Y(i).  In particular,
c           if all SIG(i) = 1.0, then SIGFAC is an estimate
c           of the standard deviation of the data error.
c           Let SUMSQ = the sum from 1 to M of
c               ((Residual at ith point)/SIG(i))**2
c           Then SIGFAC = sqrt(SUMSQ / max(M-NFIT-1, 1)).
C
C     W() [float, work]  Working space. Must be dimensioned at least
C           (NMAX+3)*(NMAX+3).  W() will be used in this subr as a
c           2-dim array: W(NDIM+3,NDIM+3).
C     ------------------------------------------------------------------
C     C.L.LAWSON, JPL, 1969 DEC 10
C     C.L.L., JPL, 1970 JAN 12      Calling sequence changed.
C     C.L.L., JPL, 1982 Aug 24:
c          To improve portability we are replacing use of
c          subrs BHSLR1 and BHSLR2 by SROTG and SROT.
C          This uses Givens rotations instead of Householder
c          transformations.  Accuracy should be the same.
c          Execution time will be greater.  Storage required
c          for the work array W() will be less.
c          Name changed from PFIT to LSPOL2.
c     C.L.Lawson, JPL, 1984 March 6.  Adapted to Fortran 77.
c          See type declaration for W(,).
C          Counting on the Fortran 77 rule that a DO-loop will
c          be skipped if the values of the control parameters
c          imply no iterations.
c          Name changed from LSPOL2 to [S/D]PFIT,
C     1984 APR 18 Using 'Modified Givens' rather than standard
C          Givens to reduce execution time. Requires one more
C          column in W().
c     1990-08-10 CLL. In cases of the Y() values lying randomly around
c     zero with no polynomial trend, and SEEKN = .true., the preferred
c     fit according to our degree determination test may be with no
c     coefficients at all.
c     In this case the subr formerly set NSOLVE = 0 and NFIT = -1.
c     Setting NFIT = -1 is a bad choice on two counts.  It indicates an
c     error, whereas this is not an error condition.  Also it may be
c     incompatible with subsequent programs that expect a valid
c     polynomial degree for use in polynomial evaluation.
c     Changed to set NFIT = max(NSOLVE-1, 0) so we can still set
c     NSOLVE = 0 in this case but NFIT will not be set less than 0.
c     Having NSOLVE = 0 causes all polynomial coefficients to be set to
c     zero on return.
c     ------------------------------------------------------------------
c--S replaces "?": ?PFIT, ?ERV1, ?ERM1, ?ROTMG, ?ROTM
c     Both versions use IERM1, IERV1
c     Generic intrinsic functions referenced: SQRT, MAX, MIN, ABS
c     ------------------------------------------------------------------
c           The dimensions of X(), Y(), and SIG() must be at least M.
C
      external IERM1, IERV1, SERV1, SERM1, R1MACH, SROTMG, SROTM
      logical          SEEKN,  COMTRN,  CHBBAS
      integer I, II, IDATA, IDIM, IRANK, IROW, J, LIMIT, LROW, M
      integer N, NFIT, NMAX, NP1, NP2, NP3, NSOLVE
      real             R1MACH
      real             CMIN, DENOM, FAC, HALF
      real             ONE, P(NMAX+3), PARAM(5)
      real             S, S2, SIG(*), SIGFAC, SIGMA, SIZE
      real             T, TEMP, TEN, TENEPS, TWO
      real             W(NMAX+3,NMAX+3), X(*), XMAX, XMIN, Y(*), ZERO
      parameter(ZERO = 0.E0, HALF = .5E0, ONE = 1.E0, TWO = 2.E0)
      parameter(TEN = 10.E0, FAC = 1.01E0 )
C     ------------------------------------------------------------------
C
C     N = NMAX = MAX DEGREE TO BE CONSIDERED.
C     NP1 = N+1 = NO. OF COEFFS IN A POLY OF DEGREE N
C     NP2 = N+2 = COL INDEX FOR y DATA AND ROW INDEX FOR RESIDUAL NORM.
C     NP3 = N+3.  Col NP3 holds the scale factors for the modified
c           Givens method.  Row NP3 is used for the entry of additional
c           data after the first NP2 data points have been entered.
C     Total array space used used in W() is NP3 rows by NP3 cols.
C
      N = NMAX
      NP1=N+1
      NP2=NP1+1
      NP3 = NP2+1
      IF (N.LT.0 .OR. M.LE.0 .OR. SIG(1).EQ.ZERO) THEN
        CALL IERM1('SPFIT',1,0,
     *    'No fit done. Require NMAX .ge. 0, M > 0, and SIG(1) .ne. 0.',
     *    'NMAX',N,',')
        CALL IERV1('M',M,',')
        CALL SERV1('SIG(1)',SIG(1),'.')
        NFIT = -1
        RETURN
      END IF
C
c     R1MACH(4) is the smallest no. that can be added to 1.0
c     and will give a no. larger than 1.0 in storage.
c
      TENEPS = TEN * R1MACH(4)
      IDIM = NP3
      SIGMA=ABS(SIG(1))
C     ------------------------------------------------------------------
C                                       COMPUTE P(1),P(2) IF REQUESTED
C
C     CHANGE OF INDEPENDENT VARIABLE IS GIVEN BY  S=(X-P(1))/P(2)
C                                             OR  X=P(1) + P(2)*S
C
      IF (COMTRN) THEN
        XMIN = X(1)
        XMAX = XMIN
        DO 30 I=2,M
        XMIN = MIN(XMIN,X(I))
   30   XMAX = MAX(XMAX,X(I))
        P(1) = (XMAX+XMIN)*HALF
        P(2) = (XMAX-XMIN)*HALF
        IF (P(2) .EQ. ZERO) P(2)=ONE
      ELSE
        IF (P(2) .EQ. ZERO) THEN
          CALL SERM1('SPFIT',2,0,
     *      'No fit done. With COMTRN = .FALSE. require P(2) .ne. 0.',
     *      'P(2)',P(2),'.')
          NFIT = -1
          RETURN
        END IF
      END IF
C
C     ------------------------------------------------------------------
C
C                               ACCUMULATION LOOP BEGINS HERE
C          IDATA COUNTS THE TOTAL NO. OF DATA POINTS ACCUMULATED.
C          LROW is the index of the row of W(,) in which the
c          new row of data will be placed.
C
      DO 150 IDATA = 1, M
        LROW = MIN( IDATA, NP3 )
        S=(X(IDATA)-P(1))/P(2)
        IF ( SIG(1) .GT. ZERO ) THEN
          SIGMA = SIG(IDATA)
          IF (SIGMA .LE. ZERO) THEN
            CALL SERM1('SPFIT',3,0,
     *        'No fit done. With SIG(1) > 0. require all SIG(I) > 0.',
     *        'SIG(1)',SIG(1),',')
            CALL IERV1('I',IDATA,',')
            CALL SERV1('SIG(I)',SIGMA,'.')
            NFIT = -1
            RETURN
          END IF
        END IF
        W(LROW,1) = ONE/SIGMA
        W(LROW,NP2) = Y(IDATA)/SIGMA
        W(LROW,NP3) = ONE
        IF (N .GT. 0) THEN
          IF (CHBBAS) THEN
C                                      Chebyshev basis
            W(LROW,2) = S / SIGMA
            S2 = TWO * S
            DO 120 J = 3,NP1
  120       W(LROW,J) = S2 * W(LROW,J-1) - W(LROW,J-2)
          ELSE
C                                      Monomial basis
            DO 100 J = 2,NP1
  100       W(LROW,J) = S * W(LROW,J-1)
          END IF
        END IF
C
C                  Accumulate new data row into triangular array.
c
         DO 145 IROW = 1,LROW-1
          CALL SROTMG(W(IROW,NP3),W(LROW,NP3),W(IROW,IROW),
     *                W(LROW,IROW),PARAM)
            IF(IROW .LT. NP2) CALL SROTM(NP2-IROW, W(IROW,IROW+1),
     *         IDIM, W(LROW,IROW+1), IDIM, PARAM)
  145    CONTINUE
  150 CONTINUE
C                                       END OF ACCUMULATION LOOP
C     ------------------------------------------------------------------
C
C     Replace Modified Givens weights by their square roots.
C
      DO 155 I = 1, MIN(NP2,M)
        W(I,NP3) = SQRT(W(I,NP3))
  155 CONTINUE
C
C     ------------------------------------------------------------------
C
C          Set IRANK = no. of leading diagonal elements of
c          the triangular matrix that are not extremely small
c          relative to the other elements in the same column.
c
         IRANK = MIN(NP1, M)
C                    Fortran 77 skips this loop if IRANK .le. 1.
         DO 240 J = 2,IRANK
            SIZE = ZERO
            DO 136 II = 1, J-1
               SIZE = MAX( SIZE, ABS(W(II,J)*W(II,NP3)) )
  136       CONTINUE
C
            IF( ABS(W(J,J)*W(J,NP3))  .LT. TENEPS * SIZE ) THEN
               IRANK = J-1
               GO TO 260
            END IF
  240    CONTINUE
  260 CONTINUE
C     ------------------------------------------------------------------
C
C         TEMPORARILY COPY RT-SIDE VECTOR INTO P()
C
      DO 160 I = 1,IRANK
  160 P(I+2) = W(I,NP2)
C     ------------------------------------------------------------------
C
C          Now we deal with 3 possible cases.
C          We must determine NSOLVE and SIGFAC for each of these cases.
c          NSOLVE is the no. of coefficients that will be computed.
c          We initially set NSOLVE = IRANK, but NSOLVE may be
c          reset to a smaller value in Case 3 below.
c     1. SEEKN = .false. and IRANK = NMAX+1
C             This is the simple case.
c     2. SEEKN = .false. and IRANK .lt. NMAX+1
C             Requires extra work to compute SIGFAC.
c     3. SEEKN = .true.
c             This requires more work to determine NSOLVE and SIGFAC.
C
      NSOLVE = IRANK
      IF( .NOT. SEEKN .AND. IRANK .EQ. NP1 ) THEN
C
C                                  Here for Case 1.
c
         TEMP = M - NP1
         IF( TEMP .EQ. ZERO ) THEN
           SIGFAC = ZERO
         ELSE
c                                      Here M .gt. NP1.
           SIGFAC = ABS(W(NP2,NP2)*W(NP2,NP3)) / SQRT( TEMP )
         END IF
         GO TO 235
      END IF
C     ------------------------------------------------------------------
C
C                       Here for Cases 2 and 3.
c
C                      Set SIZE = max abs value of elts in col NP2.
C     SIZE is used to scale quantities to avoid possible
c     trouble due to overflow or underflow.
C
      SIZE = ZERO
      DO 215 I = 1,MIN(NP2,M)
        W(I,NP2) = ABS(W(I,NP2)*W(I,NP3))
         SIZE = MAX( SIZE, W(I,NP2) )
  215 CONTINUE
c                        SIZE will be zero if and only if all of
c                        the given Y() data is zero.
c
      IF( SIZE .EQ. ZERO) THEN
         SIGFAC = ZERO
         NSOLVE = 1
         GO TO 235
      END IF
C     ------------------------------------------------------------------
C
c     Col NP2 now contains data from which sums of squares of
c     residuals can be computed for various possible settings
c     of NSOLVE.  We will set LIMIT = the largest row index to
c     be used in Col NP2 in analyzing residual norms.
c     In the usual case of M .ge. NP2, we set LIMIT = NP2.
c     Otherwise, when M .le. NP1, we set LIMIT = M+1 and set
c     W(LIMIT,NP2) = 0.  This reflects the fact that there is the
c     possibility of reducing the residual norm to zero by
c     exact interpolation when M .le. NP1.  The subr will do this
c     unless it must set NSOLVE smaller than M due to IRANK being
c     less than M.
C          Transform col NP2 so the (i+1)-st elt is
c          Sum(i) divided by SIZE**2, where Sum(i)
c          is the sum of squares of weighted residuals that
c          would be obtained if only the first i coefficients
c          were computed.
c
      IF( M .GE. NP2 ) THEN
         LIMIT = NP2
      ELSE
         LIMIT = M + 1
         W(LIMIT,NP2) = ZERO
      END IF
C
      W(LIMIT,NP2) = (W(LIMIT,NP2)/SIZE)**2
      DO 220 I = LIMIT-1, 1, -1
         W(I,NP2) = ( W(I,NP2)/SIZE )**2 + W(I+1,NP2)
  220 CONTINUE
c     ------------------------------------------------------------------
c
c     >     Do Case 3 if SEEKN is true, and Case 2 if SEEKN is false.
c
      IF( SEEKN ) THEN
c     >     Divide each W(i,NP2) by the no. of degrees of
c     >     freedom which is M - (i-1).
c     >     Then set CMIN = smallest of these quotients.
c     >     Then set NSOLVE.
c
         DENOM = M
         W(1,NP2) = W(1,NP2) / DENOM
         CMIN = W(1,NP2)
         DO 222 I = 2, IRANK + 1
            DENOM = MAX( DENOM-1, ONE)
            W(I,NP2) = W(I,NP2) / DENOM
            CMIN = MIN( CMIN, W(I,NP2) )
  222    CONTINUE
c
         TEMP = FAC * CMIN
         DO 230 I=1, IRANK+1
            IF(W(I,NP2) .LE. TEMP) THEN
               NSOLVE = I-1
               GO TO 232
            END IF
  230    CONTINUE
  232    CONTINUE
      ELSE
         DENOM = MAX(M-NSOLVE, 1)
         W(NSOLVE+1,NP2) = W(NSOLVE+1,NP2) / DENOM
      END IF
c
      SIGFAC = SIZE * SQRT( W(NSOLVE+1, NP2) )
C     ------------------------------------------------------------------
C
C                       Solve for NSOLVE coefficients.
C
  235 CONTINUE
      DO 290 I=NSOLVE,1,-1
         T = P(I+2)
c               Fortran 77 will skip this loop when I .EQ. NSOLVE.
         DO 270 J = I+1,NSOLVE
            T = T - W(I,J) * P(J+2)
  270    CONTINUE
         P(I+2) = T / W(I,I)
  290 CONTINUE
C     ------------------------------------------------------------------
C
C          Set missing high order coeffs to zero.
c
C         Counting on Fortran 77 skipping following loop if
c         NSOLVE .GE. NP1.
C
      DO 300 I = NSOLVE+1, NP1
  300 P(I+2) = ZERO
      NFIT = max(NSOLVE - 1, 0)
      RETURN
      END


      PROGRAM xeigsrt
C     driver for routine eigsrt
      INTEGER NP
      PARAMETER(NP=10)
      INTEGER i,j,nrot
      REAL d(NP),v(NP,NP),c(NP,NP)
      DATA c /5.0,4.3,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,-4.0,
     *     4.3,5.1,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,
     *     3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,
     *     2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,
     *     1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,
     *     0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,
     *     -1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,
     *     -2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,
     *     -3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,
     *     -4.0,-3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0/
      call jacobi(c,NP,NP,d,v,nrot)
      write(*,*) 'Unsorted Eigenvectors:'
      do 11 i=1,NP
        write(*,'(/1x,a,i3,a,f12.6)') 'Eigenvalue',i,' =',d(i)
        write(*,*) 'Eigenvector:'
        write(*,'(10x,5f12.6)') (v(j,i),j=1,NP)
11    continue
      write(*,'(//,1x,a,//)') '****** sorting ******'
      call eigsrt(d,v,NP,NP)
      write(*,*) 'Sorted Eigenvectors:'
      do 12 i=1,NP
        write(*,'(/1x,a,i3,a,f12.6)') 'Eigenvalue',i,' =',d(i)
        write(*,*) 'Eigenvector:'
        write(*,'(10x,5f12.6)') (v(j,i),j=1,NP)
12    continue
      END

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


!solve eq x=cos(x)
program xcosx
    implicit none
    real x1,x2,eps
    integer it,itmax
    x1=0
    eps=1e-7
    itmax=10000000
    do it =1,itmax
        x2=cos(x1)
        if(abs(x2-x1)<eps) exit
        x1=x2
    enddo

    if (it > itmax) then
        print *,'No Convergence!'
    else
        print *,"X=",x2,cos(x2)-x2,it
    endif

end program xcosx


*> \brief \b SGET24
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
*                          H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS,
*                          LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT,
*                          RESULT, WORK, LWORK, IWORK, BWORK, INFO )
*
*       .. Scalar Arguments ..
*       LOGICAL            COMP
*       INTEGER            INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT
*       REAL               RCDEIN, RCDVIN, THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            BWORK( * )
*       INTEGER            ISEED( 4 ), ISLCT( * ), IWORK( * )
*       REAL               A( LDA, * ), H( LDA, * ), HT( LDA, * ),
*      $                   RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
*      $                   WI( * ), WIT( * ), WITMP( * ), WORK( * ),
*      $                   WR( * ), WRT( * ), WRTMP( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    SGET24 checks the nonsymmetric eigenvalue (Schur form) problem
*>    expert driver SGEESX.
*>
*>    If COMP = .FALSE., the first 13 of the following tests will be
*>    be performed on the input matrix A, and also tests 14 and 15
*>    if LWORK is sufficiently large.
*>    If COMP = .TRUE., all 17 test will be performed.
*>
*>    (1)     0 if T is in Schur form, 1/ulp otherwise
*>           (no sorting of eigenvalues)
*>
*>    (2)     | A - VS T VS' | / ( n |A| ulp )
*>
*>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
*>      form  (no sorting of eigenvalues).
*>
*>    (3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*>
*>    (4)     0     if WR+sqrt(-1)*WI are eigenvalues of T
*>            1/ulp otherwise
*>            (no sorting of eigenvalues)
*>
*>    (5)     0     if T(with VS) = T(without VS),
*>            1/ulp otherwise
*>            (no sorting of eigenvalues)
*>
*>    (6)     0     if eigenvalues(with VS) = eigenvalues(without VS),
*>            1/ulp otherwise
*>            (no sorting of eigenvalues)
*>
*>    (7)     0 if T is in Schur form, 1/ulp otherwise
*>            (with sorting of eigenvalues)
*>
*>    (8)     | A - VS T VS' | / ( n |A| ulp )
*>
*>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
*>      form  (with sorting of eigenvalues).
*>
*>    (9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*>
*>    (10)    0     if WR+sqrt(-1)*WI are eigenvalues of T
*>            1/ulp otherwise
*>            If workspace sufficient, also compare WR, WI with and
*>            without reciprocal condition numbers
*>            (with sorting of eigenvalues)
*>
*>    (11)    0     if T(with VS) = T(without VS),
*>            1/ulp otherwise
*>            If workspace sufficient, also compare T with and without
*>            reciprocal condition numbers
*>            (with sorting of eigenvalues)
*>
*>    (12)    0     if eigenvalues(with VS) = eigenvalues(without VS),
*>            1/ulp otherwise
*>            If workspace sufficient, also compare VS with and without
*>            reciprocal condition numbers
*>            (with sorting of eigenvalues)
*>
*>    (13)    if sorting worked and SDIM is the number of
*>            eigenvalues which were SELECTed
*>            If workspace sufficient, also compare SDIM with and
*>            without reciprocal condition numbers
*>
*>    (14)    if RCONDE the same no matter if VS and/or RCONDV computed
*>
*>    (15)    if RCONDV the same no matter if VS and/or RCONDE computed
*>
*>    (16)  |RCONDE - RCDEIN| / cond(RCONDE)
*>
*>       RCONDE is the reciprocal average eigenvalue condition number
*>       computed by SGEESX and RCDEIN (the precomputed true value)
*>       is supplied as input.  cond(RCONDE) is the condition number
*>       of RCONDE, and takes errors in computing RCONDE into account,
*>       so that the resulting quantity should be O(ULP). cond(RCONDE)
*>       is essentially given by norm(A)/RCONDV.
*>
*>    (17)  |RCONDV - RCDVIN| / cond(RCONDV)
*>
*>       RCONDV is the reciprocal right invariant subspace condition
*>       number computed by SGEESX and RCDVIN (the precomputed true
*>       value) is supplied as input. cond(RCONDV) is the condition
*>       number of RCONDV, and takes errors in computing RCONDV into
*>       account, so that the resulting quantity should be O(ULP).
*>       cond(RCONDV) is essentially given by norm(A)/RCONDE.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] COMP
*> \verbatim
*>          COMP is LOGICAL
*>          COMP describes which input tests to perform:
*>            = .FALSE. if the computed condition numbers are not to
*>                      be tested against RCDVIN and RCDEIN
*>            = .TRUE.  if they are to be compared
*> \endverbatim
*>
*> \param[in] JTYPE
*> \verbatim
*>          JTYPE is INTEGER
*>          Type of input matrix. Used to label output if error occurs.
*> \endverbatim
*>
*> \param[in] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          If COMP = .FALSE., the random number generator seed
*>          used to produce matrix.
*>          If COMP = .TRUE., ISEED(1) = the number of the example.
*>          Used to label output if error occurs.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is REAL
*>          A test will count as "failed" if the "error", computed as
*>          described above, exceeds THRESH.  Note that the error
*>          is scaled to be O(1), so THRESH should be a reasonably
*>          small multiple of 1, e.g., 10 or 100.  In particular,
*>          it should not depend on the precision (single vs. double)
*>          or the size of the matrix.  It must be at least zero.
*> \endverbatim
*>
*> \param[in] NOUNIT
*> \verbatim
*>          NOUNIT is INTEGER
*>          The FORTRAN unit number for printing out error messages
*>          (e.g., if a routine returns INFO not equal to 0.)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The dimension of A. N must be at least 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA, N)
*>          Used to hold the matrix whose eigenvalues are to be
*>          computed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A, and H. LDA must be at
*>          least 1 and at least N.
*> \endverbatim
*>
*> \param[out] H
*> \verbatim
*>          H is REAL array, dimension (LDA, N)
*>          Another copy of the test matrix A, modified by SGEESX.
*> \endverbatim
*>
*> \param[out] HT
*> \verbatim
*>          HT is REAL array, dimension (LDA, N)
*>          Yet another copy of the test matrix A, modified by SGEESX.
*> \endverbatim
*>
*> \param[out] WR
*> \verbatim
*>          WR is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] WI
*> \verbatim
*>          WI is REAL array, dimension (N)
*>
*>          The real and imaginary parts of the eigenvalues of A.
*>          On exit, WR + WI*i are the eigenvalues of the matrix in A.
*> \endverbatim
*>
*> \param[out] WRT
*> \verbatim
*>          WRT is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] WIT
*> \verbatim
*>          WIT is REAL array, dimension (N)
*>
*>          Like WR, WI, these arrays contain the eigenvalues of A,
*>          but those computed when SGEESX only computes a partial
*>          eigendecomposition, i.e. not Schur vectors
*> \endverbatim
*>
*> \param[out] WRTMP
*> \verbatim
*>          WRTMP is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] WITMP
*> \verbatim
*>          WITMP is REAL array, dimension (N)
*>
*>          Like WR, WI, these arrays contain the eigenvalues of A,
*>          but sorted by increasing real part.
*> \endverbatim
*>
*> \param[out] VS
*> \verbatim
*>          VS is REAL array, dimension (LDVS, N)
*>          VS holds the computed Schur vectors.
*> \endverbatim
*>
*> \param[in] LDVS
*> \verbatim
*>          LDVS is INTEGER
*>          Leading dimension of VS. Must be at least max(1, N).
*> \endverbatim
*>
*> \param[out] VS1
*> \verbatim
*>          VS1 is REAL array, dimension (LDVS, N)
*>          VS1 holds another copy of the computed Schur vectors.
*> \endverbatim
*>
*> \param[in] RCDEIN
*> \verbatim
*>          RCDEIN is REAL
*>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
*>          condition number for the average of selected eigenvalues.
*> \endverbatim
*>
*> \param[in] RCDVIN
*> \verbatim
*>          RCDVIN is REAL
*>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
*>          condition number for the selected right invariant subspace.
*> \endverbatim
*>
*> \param[in] NSLCT
*> \verbatim
*>          NSLCT is INTEGER
*>          When COMP = .TRUE. the number of selected eigenvalues
*>          corresponding to the precomputed values RCDEIN and RCDVIN.
*> \endverbatim
*>
*> \param[in] ISLCT
*> \verbatim
*>          ISLCT is INTEGER array, dimension (NSLCT)
*>          When COMP = .TRUE. ISLCT selects the eigenvalues of the
*>          input matrix corresponding to the precomputed values RCDEIN
*>          and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
*>          eigenvalue with the J-th largest real part is selected.
*>          Not referenced if COMP = .FALSE.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL array, dimension (17)
*>          The values computed by the 17 tests described above.
*>          The values are currently limited to 1/ulp, to avoid
*>          overflow.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The number of entries in WORK to be passed to SGEESX. This
*>          must be at least 3*N, and N+N**2 if tests 14--16 are to
*>          be performed.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (N*N)
*> \endverbatim
*>
*> \param[out] BWORK
*> \verbatim
*>          BWORK is LOGICAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          If 0,  successful exit.
*>          If <0, input parameter -INFO had an incorrect value.
*>          If >0, SGEESX returned an error code, the absolute
*>                 value of which is returned.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
     $                   H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS,
     $                   LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT,
     $                   RESULT, WORK, LWORK, IWORK, BWORK, INFO )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      LOGICAL            COMP
      INTEGER            INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT
      REAL               RCDEIN, RCDVIN, THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            ISEED( 4 ), ISLCT( * ), IWORK( * )
      REAL               A( LDA, * ), H( LDA, * ), HT( LDA, * ),
     $                   RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
     $                   WI( * ), WIT( * ), WITMP( * ), WORK( * ),
     $                   WR( * ), WRT( * ), WRTMP( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
      REAL               EPSIN
      PARAMETER          ( EPSIN = 5.9605E-8 )
*     ..
*     .. Local Scalars ..
      CHARACTER          SORT
      INTEGER            I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, LIWORK,
     $                   RSUB, SDIM, SDIM1
      REAL               ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
     $                   SMLNUM, TMP, TOL, TOLIN, ULP, ULPINV, V, VIMIN,
     $                   VRMIN, WNORM
*     ..
*     .. Local Arrays ..
      INTEGER            IPNT( 20 )
*     ..
*     .. Arrays in Common ..
      LOGICAL            SELVAL( 20 )
      REAL               SELWI( 20 ), SELWR( 20 )
*     ..
*     .. Scalars in Common ..
      INTEGER            SELDIM, SELOPT
*     ..
*     .. Common blocks ..
      COMMON             / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
*     ..
*     .. External Functions ..
      LOGICAL            SSLECT
      REAL               SLAMCH, SLANGE
      EXTERNAL           SSLECT, SLAMCH, SLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SGEESX, SGEMM, SLACPY, SORT01, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL, SIGN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Check for errors
*
      INFO = 0
      IF( THRESH.LT.ZERO ) THEN
         INFO = -3
      ELSE IF( NOUNIT.LE.0 ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
         INFO = -8
      ELSE IF( LDVS.LT.1 .OR. LDVS.LT.N ) THEN
         INFO = -18
      ELSE IF( LWORK.LT.3*N ) THEN
         INFO = -26
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGET24', -INFO )
         RETURN
      END IF
*
*     Quick return if nothing to do
*
      DO 10 I = 1, 17
         RESULT( I ) = -ONE
   10 CONTINUE
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Important constants
*
      SMLNUM = SLAMCH( 'Safe minimum' )
      ULP = SLAMCH( 'Precision' )
      ULPINV = ONE / ULP
*
*     Perform tests (1)-(13)
*
      SELOPT = 0
      LIWORK = N*N
      DO 120 ISORT = 0, 1
         IF( ISORT.EQ.0 ) THEN
            SORT = 'N'
            RSUB = 0
         ELSE
            SORT = 'S'
            RSUB = 6
         END IF
*
*        Compute Schur form and Schur vectors, and test them
*
         CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
         CALL SGEESX( 'V', SORT, SSLECT, 'N', N, H, LDA, SDIM, WR, WI,
     $                VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
     $                LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 1+RSUB ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX1', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX1', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            RETURN
         END IF
         IF( ISORT.EQ.0 ) THEN
            CALL SCOPY( N, WR, 1, WRTMP, 1 )
            CALL SCOPY( N, WI, 1, WITMP, 1 )
         END IF
*
*        Do Test (1) or Test (7)
*
         RESULT( 1+RSUB ) = ZERO
         DO 30 J = 1, N - 2
            DO 20 I = J + 2, N
               IF( H( I, J ).NE.ZERO )
     $            RESULT( 1+RSUB ) = ULPINV
   20       CONTINUE
   30    CONTINUE
         DO 40 I = 1, N - 2
            IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.ZERO )
     $         RESULT( 1+RSUB ) = ULPINV
   40    CONTINUE
         DO 50 I = 1, N - 1
            IF( H( I+1, I ).NE.ZERO ) THEN
               IF( H( I, I ).NE.H( I+1, I+1 ) .OR. H( I, I+1 ).EQ.
     $             ZERO .OR. SIGN( ONE, H( I+1, I ) ).EQ.
     $             SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB ) = ULPINV
            END IF
   50    CONTINUE
*
*        Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP)
*
*        Copy A to VS1, used as workspace
*
         CALL SLACPY( ' ', N, N, A, LDA, VS1, LDVS )
*
*        Compute Q*H and store in HT.
*
         CALL SGEMM( 'No transpose', 'No transpose', N, N, N, ONE, VS,
     $               LDVS, H, LDA, ZERO, HT, LDA )
*
*        Compute A - Q*H*Q'
*
         CALL SGEMM( 'No transpose', 'Transpose', N, N, N, -ONE, HT,
     $               LDA, VS, LDVS, ONE, VS1, LDVS )
*
         ANORM = MAX( SLANGE( '1', N, N, A, LDA, WORK ), SMLNUM )
         WNORM = SLANGE( '1', N, N, VS1, LDVS, WORK )
*
         IF( ANORM.GT.WNORM ) THEN
            RESULT( 2+RSUB ) = ( WNORM / ANORM ) / ( N*ULP )
         ELSE
            IF( ANORM.LT.ONE ) THEN
               RESULT( 2+RSUB ) = ( MIN( WNORM, N*ANORM ) / ANORM ) /
     $                            ( N*ULP )
            ELSE
               RESULT( 2+RSUB ) = MIN( WNORM / ANORM, REAL( N ) ) /
     $                            ( N*ULP )
            END IF
         END IF
*
*        Test (3) or (9):  Compute norm( I - Q'*Q ) / ( N * ULP )
*
         CALL SORT01( 'Columns', N, N, VS, LDVS, WORK, LWORK,
     $                RESULT( 3+RSUB ) )
*
*        Do Test (4) or Test (10)
*
         RESULT( 4+RSUB ) = ZERO
         DO 60 I = 1, N
            IF( H( I, I ).NE.WR( I ) )
     $         RESULT( 4+RSUB ) = ULPINV
   60    CONTINUE
         IF( N.GT.1 ) THEN
            IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
     $         RESULT( 4+RSUB ) = ULPINV
            IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
     $         RESULT( 4+RSUB ) = ULPINV
         END IF
         DO 70 I = 1, N - 1
            IF( H( I+1, I ).NE.ZERO ) THEN
               TMP = SQRT( ABS( H( I+1, I ) ) )*
     $               SQRT( ABS( H( I, I+1 ) ) )
               RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
     $                            ABS( WI( I )-TMP ) /
     $                            MAX( ULP*TMP, SMLNUM ) )
               RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
     $                            ABS( WI( I+1 )+TMP ) /
     $                            MAX( ULP*TMP, SMLNUM ) )
            ELSE IF( I.GT.1 ) THEN
               IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.ZERO .AND.
     $             WI( I ).NE.ZERO )RESULT( 4+RSUB ) = ULPINV
            END IF
   70    CONTINUE
*
*        Do Test (5) or Test (11)
*
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'N', SORT, SSLECT, 'N', N, HT, LDA, SDIM, WRT,
     $                WIT, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
     $                LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 5+RSUB ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX2', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX2', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 250
         END IF
*
         RESULT( 5+RSUB ) = ZERO
         DO 90 J = 1, N
            DO 80 I = 1, N
               IF( H( I, J ).NE.HT( I, J ) )
     $            RESULT( 5+RSUB ) = ULPINV
   80       CONTINUE
   90    CONTINUE
*
*        Do Test (6) or Test (12)
*
         RESULT( 6+RSUB ) = ZERO
         DO 100 I = 1, N
            IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
     $         RESULT( 6+RSUB ) = ULPINV
  100    CONTINUE
*
*        Do Test (13)
*
         IF( ISORT.EQ.1 ) THEN
            RESULT( 13 ) = ZERO
            KNTEIG = 0
            DO 110 I = 1, N
               IF( SSLECT( WR( I ), WI( I ) ) .OR.
     $             SSLECT( WR( I ), -WI( I ) ) )KNTEIG = KNTEIG + 1
               IF( I.LT.N ) THEN
                  IF( ( SSLECT( WR( I+1 ), WI( I+1 ) ) .OR.
     $                SSLECT( WR( I+1 ), -WI( I+1 ) ) ) .AND.
     $                ( .NOT.( SSLECT( WR( I ),
     $                WI( I ) ) .OR. SSLECT( WR( I ),
     $                -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )RESULT( 13 )
     $                = ULPINV
               END IF
  110       CONTINUE
            IF( SDIM.NE.KNTEIG )
     $         RESULT( 13 ) = ULPINV
         END IF
*
  120 CONTINUE
*
*     If there is enough workspace, perform tests (14) and (15)
*     as well as (10) through (13)
*
      IF( LWORK.GE.N+( N*N ) / 2 ) THEN
*
*        Compute both RCONDE and RCONDV with VS
*
         SORT = 'S'
         RESULT( 14 ) = ZERO
         RESULT( 15 ) = ZERO
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'V', SORT, SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
     $                WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
     $                IWORK, LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 14 ) = ULPINV
            RESULT( 15 ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX3', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX3', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 250
         END IF
*
*        Perform tests (10), (11), (12), and (13)
*
         DO 140 I = 1, N
            IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
     $         RESULT( 10 ) = ULPINV
            DO 130 J = 1, N
               IF( H( I, J ).NE.HT( I, J ) )
     $            RESULT( 11 ) = ULPINV
               IF( VS( I, J ).NE.VS1( I, J ) )
     $            RESULT( 12 ) = ULPINV
  130       CONTINUE
  140    CONTINUE
         IF( SDIM.NE.SDIM1 )
     $      RESULT( 13 ) = ULPINV
*
*        Compute both RCONDE and RCONDV without VS, and compare
*
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'N', SORT, SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
     $                WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
     $                IWORK, LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 14 ) = ULPINV
            RESULT( 15 ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX4', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX4', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 250
         END IF
*
*        Perform tests (14) and (15)
*
         IF( RCNDE1.NE.RCONDE )
     $      RESULT( 14 ) = ULPINV
         IF( RCNDV1.NE.RCONDV )
     $      RESULT( 15 ) = ULPINV
*
*        Perform tests (10), (11), (12), and (13)
*
         DO 160 I = 1, N
            IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
     $         RESULT( 10 ) = ULPINV
            DO 150 J = 1, N
               IF( H( I, J ).NE.HT( I, J ) )
     $            RESULT( 11 ) = ULPINV
               IF( VS( I, J ).NE.VS1( I, J ) )
     $            RESULT( 12 ) = ULPINV
  150       CONTINUE
  160    CONTINUE
         IF( SDIM.NE.SDIM1 )
     $      RESULT( 13 ) = ULPINV
*
*        Compute RCONDE with VS, and compare
*
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'V', SORT, SSLECT, 'E', N, HT, LDA, SDIM1, WRT,
     $                WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
     $                IWORK, LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 14 ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX5', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX5', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 250
         END IF
*
*        Perform test (14)
*
         IF( RCNDE1.NE.RCONDE )
     $      RESULT( 14 ) = ULPINV
*
*        Perform tests (10), (11), (12), and (13)
*
         DO 180 I = 1, N
            IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
     $         RESULT( 10 ) = ULPINV
            DO 170 J = 1, N
               IF( H( I, J ).NE.HT( I, J ) )
     $            RESULT( 11 ) = ULPINV
               IF( VS( I, J ).NE.VS1( I, J ) )
     $            RESULT( 12 ) = ULPINV
  170       CONTINUE
  180    CONTINUE
         IF( SDIM.NE.SDIM1 )
     $      RESULT( 13 ) = ULPINV
*
*        Compute RCONDE without VS, and compare
*
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'N', SORT, SSLECT, 'E', N, HT, LDA, SDIM1, WRT,
     $                WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
     $                IWORK, LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 14 ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX6', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX6', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 250
         END IF
*
*        Perform test (14)
*
         IF( RCNDE1.NE.RCONDE )
     $      RESULT( 14 ) = ULPINV
*
*        Perform tests (10), (11), (12), and (13)
*
         DO 200 I = 1, N
            IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
     $         RESULT( 10 ) = ULPINV
            DO 190 J = 1, N
               IF( H( I, J ).NE.HT( I, J ) )
     $            RESULT( 11 ) = ULPINV
               IF( VS( I, J ).NE.VS1( I, J ) )
     $            RESULT( 12 ) = ULPINV
  190       CONTINUE
  200    CONTINUE
         IF( SDIM.NE.SDIM1 )
     $      RESULT( 13 ) = ULPINV
*
*        Compute RCONDV with VS, and compare
*
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'V', SORT, SSLECT, 'V', N, HT, LDA, SDIM1, WRT,
     $                WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
     $                IWORK, LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 15 ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX7', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX7', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 250
         END IF
*
*        Perform test (15)
*
         IF( RCNDV1.NE.RCONDV )
     $      RESULT( 15 ) = ULPINV
*
*        Perform tests (10), (11), (12), and (13)
*
         DO 220 I = 1, N
            IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
     $         RESULT( 10 ) = ULPINV
            DO 210 J = 1, N
               IF( H( I, J ).NE.HT( I, J ) )
     $            RESULT( 11 ) = ULPINV
               IF( VS( I, J ).NE.VS1( I, J ) )
     $            RESULT( 12 ) = ULPINV
  210       CONTINUE
  220    CONTINUE
         IF( SDIM.NE.SDIM1 )
     $      RESULT( 13 ) = ULPINV
*
*        Compute RCONDV without VS, and compare
*
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'N', SORT, SSLECT, 'V', N, HT, LDA, SDIM1, WRT,
     $                WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
     $                IWORK, LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 15 ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'SGEESX8', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'SGEESX8', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 250
         END IF
*
*        Perform test (15)
*
         IF( RCNDV1.NE.RCONDV )
     $      RESULT( 15 ) = ULPINV
*
*        Perform tests (10), (11), (12), and (13)
*
         DO 240 I = 1, N
            IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
     $         RESULT( 10 ) = ULPINV
            DO 230 J = 1, N
               IF( H( I, J ).NE.HT( I, J ) )
     $            RESULT( 11 ) = ULPINV
               IF( VS( I, J ).NE.VS1( I, J ) )
     $            RESULT( 12 ) = ULPINV
  230       CONTINUE
  240    CONTINUE
         IF( SDIM.NE.SDIM1 )
     $      RESULT( 13 ) = ULPINV
*
      END IF
*
  250 CONTINUE
*
*     If there are precomputed reciprocal condition numbers, compare
*     computed values with them.
*
      IF( COMP ) THEN
*
*        First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that
*        the logical function SSLECT selects the eigenvalues specified
*        by NSLCT and ISLCT.
*
         SELDIM = N
         SELOPT = 1
         EPS = MAX( ULP, EPSIN )
         DO 260 I = 1, N
            IPNT( I ) = I
            SELVAL( I ) = .FALSE.
            SELWR( I ) = WRTMP( I )
            SELWI( I ) = WITMP( I )
  260    CONTINUE
         DO 280 I = 1, N - 1
            KMIN = I
            VRMIN = WRTMP( I )
            VIMIN = WITMP( I )
            DO 270 J = I + 1, N
               IF( WRTMP( J ).LT.VRMIN ) THEN
                  KMIN = J
                  VRMIN = WRTMP( J )
                  VIMIN = WITMP( J )
               END IF
  270       CONTINUE
            WRTMP( KMIN ) = WRTMP( I )
            WITMP( KMIN ) = WITMP( I )
            WRTMP( I ) = VRMIN
            WITMP( I ) = VIMIN
            ITMP = IPNT( I )
            IPNT( I ) = IPNT( KMIN )
            IPNT( KMIN ) = ITMP
  280    CONTINUE
         DO 290 I = 1, NSLCT
            SELVAL( IPNT( ISLCT( I ) ) ) = .TRUE.
  290    CONTINUE
*
*        Compute condition numbers
*
         CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL SGEESX( 'N', 'S', SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
     $                WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
     $                IWORK, LIWORK, BWORK, IINFO )
         IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
            RESULT( 16 ) = ULPINV
            RESULT( 17 ) = ULPINV
            WRITE( NOUNIT, FMT = 9999 )'SGEESX9', IINFO, N, ISEED( 1 )
            INFO = ABS( IINFO )
            GO TO 300
         END IF
*
*        Compare condition number for average of selected eigenvalues
*        taking its condition number into account
*
         ANORM = SLANGE( '1', N, N, A, LDA, WORK )
         V = MAX( REAL( N )*EPS*ANORM, SMLNUM )
         IF( ANORM.EQ.ZERO )
     $      V = ONE
         IF( V.GT.RCONDV ) THEN
            TOL = ONE
         ELSE
            TOL = V / RCONDV
         END IF
         IF( V.GT.RCDVIN ) THEN
            TOLIN = ONE
         ELSE
            TOLIN = V / RCDVIN
         END IF
         TOL = MAX( TOL, SMLNUM / EPS )
         TOLIN = MAX( TOLIN, SMLNUM / EPS )
         IF( EPS*( RCDEIN-TOLIN ).GT.RCONDE+TOL ) THEN
            RESULT( 16 ) = ULPINV
         ELSE IF( RCDEIN-TOLIN.GT.RCONDE+TOL ) THEN
            RESULT( 16 ) = ( RCDEIN-TOLIN ) / ( RCONDE+TOL )
         ELSE IF( RCDEIN+TOLIN.LT.EPS*( RCONDE-TOL ) ) THEN
            RESULT( 16 ) = ULPINV
         ELSE IF( RCDEIN+TOLIN.LT.RCONDE-TOL ) THEN
            RESULT( 16 ) = ( RCONDE-TOL ) / ( RCDEIN+TOLIN )
         ELSE
            RESULT( 16 ) = ONE
         END IF
*
*        Compare condition numbers for right invariant subspace
*        taking its condition number into account
*
         IF( V.GT.RCONDV*RCONDE ) THEN
            TOL = RCONDV
         ELSE
            TOL = V / RCONDE
         END IF
         IF( V.GT.RCDVIN*RCDEIN ) THEN
            TOLIN = RCDVIN
         ELSE
            TOLIN = V / RCDEIN
         END IF
         TOL = MAX( TOL, SMLNUM / EPS )
         TOLIN = MAX( TOLIN, SMLNUM / EPS )
         IF( EPS*( RCDVIN-TOLIN ).GT.RCONDV+TOL ) THEN
            RESULT( 17 ) = ULPINV
         ELSE IF( RCDVIN-TOLIN.GT.RCONDV+TOL ) THEN
            RESULT( 17 ) = ( RCDVIN-TOLIN ) / ( RCONDV+TOL )
         ELSE IF( RCDVIN+TOLIN.LT.EPS*( RCONDV-TOL ) ) THEN
            RESULT( 17 ) = ULPINV
         ELSE IF( RCDVIN+TOLIN.LT.RCONDV-TOL ) THEN
            RESULT( 17 ) = ( RCONDV-TOL ) / ( RCDVIN+TOLIN )
         ELSE
            RESULT( 17 ) = ONE
         END IF
*
  300    CONTINUE
*
      END IF
*
 9999 FORMAT( ' SGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
     $      I6, ', INPUT EXAMPLE NUMBER = ', I4 )
 9998 FORMAT( ' SGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
     $      I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
      RETURN
*
*     End of SGET24
*
      END


program ej2

  !Programa que resuelve ecuaciones de segundo grado. Soporta raices complejas
  complex x_1, x_2, aux
  real a, b, c, disc

  print *, "Sea la ecuación con la forma ax² + bx + c = 0"
  print *, "Porfavor ingresa los valores de los coeficientes a, b y c"
  read *, a, b, c

  disc = b**2 - (4*a*c)

  if (disc < 0) then
    disc = - sqrt(abs(disc))
    aux = cmplx(0, disc)

  end if

  x_1 = (-b + aux)/(2*a)
  x_2 = (-b - aux)/(2*a)

  print *, "Las raices son: x = {", x_1, ", ", x_2, "}"

end program ej2


program kidou_ex2_7c
  !天体と軌道の力学(p.56)[例2.7c]

  implicit none
  integer::n
  real(8)::pi,e,l,u

  pi=4.0d0*atan(1.0d0)

  ![例2.7a]冥王星の離心近点離角uをニュートン・ラプソン法で求める。
  write(*,*)"冥王星"
  e=0.249d0 !離心率（文献値）
  l=(12.14d0/180)*pi !平均近点離角をラジアン表記へ変更

  u=l
  n=0
  write(*,*) n,(u/pi)*180d0

  do n=1,9
     u=u-((u-e*sin(u)-l)/(1-e*cos(u)))
     write(*,*) n,(u/pi)*180d0
  end do

  ![例2.7b]ハレー彗星の離心近点離角uをニュートン・ラプソン法で求める。
  write(*,*)" ハレー彗星"
  e=0.967d0 !離心率（文献値）
  l=(10d0/180)*pi !平均近点離角をラジアン表記へ変更

  u=l
  n=0
  write(*,*) n,(u/pi)*180d0

  do n=1,20
     u=u-((u-e*sin(u)-l)/(1-e*cos(u)))
     write(*,*) n,(u/pi)*180d0
  end do

end program kidou_ex2_7c


MODULE MODULE_MATH

CONTAINS

  SUBROUTINE NORMALIZE_VECT (a)

    DOUBLE PRECISION,DIMENSION(3),INTENT(INOUT)::a
    DOUBLE PRECISION::norm

    norm=sqrt(dot_product(a,a))
    a=a/norm

  END SUBROUTINE NORMALIZE_VECT

  SUBROUTINE PRODUCT_VECT(a,b,normal)

    DOUBLE PRECISION,DIMENSION(3),INTENT(IN)::a,b
    DOUBLE PRECISION,DIMENSION(3),INTENT(OUT)::normal

    normal(1)=a(2)*b(3)-a(3)*b(2)
    normal(2)=-a(1)*b(3)+a(3)*b(1)
    normal(3)=a(1)*b(2)-a(2)*b(1)

  END SUBROUTINE PRODUCT_VECT

  SUBROUTINE ROTANDTRANS_RMSD(center_orig,U,center_ref,coors,dim_coors,new_coors)

    IMPLICIT NONE

    INTEGER,INTENT(IN)::dim_coors
    DOUBLE PRECISION,DIMENSION(3),INTENT(IN)::center_orig,center_ref
    DOUBLE PRECISION,DIMENSION(3,3),INTENT(IN)::U
    DOUBLE PRECISION,DIMENSION(dim_coors,3),INTENT(IN)::coors

    DOUBLE PRECISION,DIMENSION(dim_coors,3),INTENT(OUT)::new_coors

    INTEGER::ii

    DO ii=1,dim_coors
       new_coors(ii,:)=matmul(transpose(U(:,:)),coors(ii,:)-center_orig)+center_ref
    END DO

  END SUBROUTINE ROTANDTRANS_RMSD

END MODULE MODULE_MATH


!!
!! Simple Fortran 90 module with program constants
!! You could have delcared pi directly in the program units that
!! need pi. However the purpose of modules is to make pieces of the
!! code reusable and easier to maintain.
!!
!! 100212, lb
!!
MODULE fourthconst

  use precise, only : defaultp
  IMPLICIT NONE

  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

  ! This defines the number pi. The key word parameter makes sure,
  ! the number pi is not overridden when the program is executed
  REAL(WP), PARAMETER :: one=1.0
  REAL(WP), PARAMETER :: four=4.0
  REAL(WP), PARAMETER :: pi=Four*ATAN(one)  ! using a function to define the
                                     ! parameter value is a Fortran 2003
                                     ! extension supported by g95 but
                                     !  not all other compilers
  !real(wp), parameter :: pi=3.141592653589793 ! this is an alternative form

END MODULE fourthconst


!    File:    FibonacciModule.f90
!    Author:  Marvin Smith
!    Date:    4/25/2015
!
!    Purpose: Contains some Fibonacci utilities written in Fortran.
!
!    Fibonacci Module
MODULE FibonacciModule

!  Define Everything As Public
PUBLIC

!  List of Procedures in the Fibonacci Module
CONTAINS

!   Recursive Fibonacci Function
RECURSIVE FUNCTION Fibonacci (n) result (fnum)
     integer, intent(in) :: n
     integer :: fnum

    !  Handle Exit Conditions
    if (n<2) then
        fnum = n

    !  Handle Normal Conditions
    else
        fnum = Fibonacci(n-1) + Fibonacci(n-2)

    endif
end function Fibonacci

!   Find the Max Fibonacci Number given Max Value
FUNCTION Find_Max_Fibonacci (max_value) result (Fmax)
    integer, intent(in) :: max_value
    integer :: Fmax, I, val

!  Start iterating
I = 2
Fmax = I
do

    !  Compute the Fibonacci Number
    val = Fibonacci(I)

    !  Check if we are at the max number
    if ( val >= max_value ) then
        EXIT
    endif

    !  Increment the Counter
    Fmax = I
    I = I + 1

END DO
END FUNCTION

!   End of the Module
END MODULE FibonacciModule


************************************************************************
*
*   SBFCT -- SYMMETRIC BANDED MATRIX FACTORIZATION.
*   SBSLV -- SYMMETRIC BANDED MATRIX SOLVE.
*
*   THESE ROUTINES SOLVE LINEAR SYSTEMS A*X=B FOR THE VECTOR X WHEN A
*   IS A SYMMETRIC BANDED MATRIX.  THE ROUTINE SBFCT COMPUTES THE
*   LOWER CHOLESKI FACTOR OF THE COEFFICIENT MATRIX A.  IT IS ASSUMED
*   THAT GAUSSIAN ELIMINATION APPLIED TO A IS STABLE WITHOUT PIVOTING.
*   THE LOWER TRIANGULAR PART OF THE MATRIX A IS STORED BY COLUMN
*   AND THE ELEMENTS OF THE LOWER FACTOR OVERWRITE THOSE OF A IN THE
*   STANDARD MANNER.  SUBSEQUENT CALLS TO THE ROUTINE SBSLV SOLVE THE
*   SYSTEM, CARRYING OUT THE FORWARD AND BACKWARD SUBSTITUTIONS.
*
*   ARGUMENT  DESCRIPTION
*   --------  -----------
*    NEQNS    THE NUMBER OF EQATIONS.
*
*    BANDW    THE BANDWIDTH OF THE MATRIX.  THE BANDWIDTH IS DEFINED
*             TO BE THE MAX { |I-J| : AIJ .NE. 0 }.
*
*    A        ARRAY CONTAINING EITHER THE LOWER TRIANGULAR ELEMENTS OF
*             THE COEFFICIENT MATRIX A OR THE ELEMENTS OF ITS LOWER
*             CHOLESKI FACTOR.  THE ELEMENTS ARE STORED BY COLUMN SO
*             THAT AIJ, I.GE.J, IS STORED IN A(I-J,J).
*
*    B        ON INPUT THE ARRAY CONTAINS THE ELEMENTS OF THE RHS
*             VECTOR AND IS OVERWRITTEN WITH THE SOLUTION VECTOR.
*
************************************************************************
      subroutine sbfct(neqn,bandw,a)

      integer neqn,bandw,i,j,k
      double precision a(0:bandw,neqn)

      do 10 j=1,neqn
      do 11 k=1,min(bandw,j-1)
      do 11 i=0,min(bandw-k,neqn-j)
   11 a(i,j) = a(i,j) - a(k,j-k)*a(k+i,j-k)
      a(0,j) = 1./sqrt(a(0,j))
      do 10 i=1,min(bandw,neqn-j)
   10 a(i,j) = a(0,j)*a(i,j)

      return
      end
      subroutine sbslv(neqn,bandw,a,b)

      integer neqn,bandw,i,j
      double precision a(0:bandw,neqn),b(neqn)

      do 10 j=1,neqn
      b(j) = a(0,j)*b(j)
      do 10 i=1,min(bandw,neqn-j)
   10 b(j+i) = b(j+i) - b(j)*a(i,j)

      do 20 j=neqn,1,-1
      do 21 i=1,min(bandw,neqn-j)
   21 b(j) = b(j) - a(i,j)*b(j+i)
   20 b(j) = a(0,j)*b(j)

      return
      end


program reduce

  ! example of OpenMP reduction.  Here we pick some widely-varying
  ! numbers to sum to demonstrate that roundoff can come into play
  ! with threads
  !
  ! M. Zingale (2013-04-14)

  implicit none

  integer :: i

  double precision :: sum

  sum = 0.0d0

!$omp parallel do private (i) reduction(+:sum)
  do i = 1, 10000

     sum = sum + exp((mod(dble(i), 5.0d0) - 2*mod(dble(i),7.0d0)))

  end do
!$omp end parallel do

  print *, sum

end program reduce


function kron(A,B) result(C)
!
!   Copyright 2017, Viktor Reshiak, All rights reserved.
!
!
!   Purpose
!   =======
!   Kronecker product of two matrices
!
!
!   IN
!   ==
!   1) na1 - first  dimension of array A
!   2) na2 - second dimension of array A
!   3) A   - array
!   4) nb1 - first  dimension of array B
!   5) nb2 - second dimension of array B
!   6) B   - array
!
!
!   INOUT
!   =====
!   1) C  - resulting matrix
!
!
	implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments
    real(kind=8), intent(in), dimension(:,:) :: A
    real(kind=8), intent(in), dimension(:,:) :: B

    real(kind=8), dimension(size(A,1)*size(B,1),size(A,2)*size(B,2))    :: C

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    integer(kind=4) :: i, j
    integer(kind=4), dimension(2) :: sh_A, sh_B

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    sh_A = shape(A)
    sh_B = shape(B)

    do i = 1,sh_A(1)
        do j = 1,sh_A(2)
            C((i-1)*sh_B(1)+1:i*sh_B(1),(j-1)*sh_B(2)+1:j*sh_B(2)) = A(i,j) * B
        enddo
    enddo

end function kron

! function kron(na1,na2,A,nb1,nb2,B) result(C)
! !
! !   Copyright 2017, Viktor Reshiak, All rights reserved.
! !
! !
! !   Purpose
! !   =======
! !   Kronecker product of two matrices
! !
! !
! !   IN
! !   ==
! !   1) na1 - first  dimension of array A
! !   2) na2 - second dimension of array A
! !   3) A   - array
! !   4) nb1 - first  dimension of array B
! !   5) nb2 - second dimension of array B
! !   6) B   - array
! !
! !
! !   INOUT
! !   =====
! !   1) C  - resulting matrix
! !
! !
!     implicit none

!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     ! dummy arguments

!     integer(kind=4), intent(in)                             :: na1, na2, nb1, nb2
!        real(kind=8), intent(in), dimension(na1,na2)         :: A
!        real(kind=8), intent(in), dimension(nb1,nb2)         :: B

!        real(kind=8), dimension(na1*nb1,na2*nb2)             :: C

!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     integer(kind=4) :: i, j

!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     do i = 1,na1
!         do j = 1,na2
!             C((i-1)*nb1+1:i*nb1,(j-1)*nb2+1:j*nb2) = A(i,j) * B
!         enddo
!     enddo

! end function kron


program basic
  use arrayfire
  implicit none

  real, dimension(3,3) :: a
  real, dimension(:,:), allocatable :: b
  type(array) M1, M2, tmp

  a(1,:) = [1, 0, 0]
  a(2,:) = [0, 3, 0]
  a(3,:) = [0, 0, 2]

  ! Copy data from host to device
  M1 = a
  write(*,*) "Showing the matrix after mem copy from host (M1)"
  call print(M1)

  ! Generate a uniformly random, single precision matrix
  M2 = randu(3,3, ty=f32)
  write(*,*) "Showing a randomly generated matrix (M2)"
  call print(M2)

  ! Transpose of matrix
  tmp = transpose(M2)
  call print(tmp, "Transpose of M2") ! Displays array after printing message

  ! Element wise addition
  tmp = M1 + M2
  call print(tmp, "M1 + M2")

  ! element wise subtraction
  call print(-M2, "-M2")

  ! Trignometric functions
  write(*,*) "Displaying sin(M2)**2 + cos(M2)**2"
  call print(sin(M2)**2.0 + cos(M2)**2.0)

  ! Multiplication of matrices
  ! Matrix multiply
  write(*, *) "Matrix multiply: matmul(M1, M2)"
  call print(matmul(M1, M2))

  ! Element wise multiplication
  write(*, *) "Element wise multiplication: M1 * M2"
  call print(M1 * M2)

  ! minimum value
  tmp = min(M2)
  call print(tmp, "min(M2)")

  ! Get back to host
  b = tmp
  write(*,*) "Showing min(M2) data back on host "
  write(*,*) b(:,:)

end program basic


!Subroutine to find the inverse of a square matrix
!Author : Louisda16th a.k.a Ashwith J. Rego
!Reference : Algorithm has been well explained in:
!http://math.uww.edu/~mcfarlat/inverse.htm
!http://www.tutor.ms.unimelb.edu.au/matrix/matrix_inverse.html

SUBROUTINE InvertMatrix(matrix, inverse, n, errorflag)
	IMPLICIT NONE
	!Declarations
	INTEGER, INTENT(IN)  :: n
	INTEGER, INTENT(OUT) :: errorflag  !Return error status. -1 for error, 0 for normal
	REAL(8), INTENT(IN)	:: matrix(n,n)  !Input matrix
	REAL(8), INTENT(OUT)	:: inverse(n,n) !Inverted matrix

	LOGICAL :: FLAG = .TRUE.
	INTEGER :: i, j, k
	REAL(8) :: m
	REAL(8), DIMENSION(n,2*n) :: augmatrix !augmented matrix

	!Augment input matrix with an identity matrix
	DO i = 1, n
		DO j = 1, 2*n
			IF (j <= n ) THEN
				augmatrix(i,j) = matrix(i,j)
			ELSE IF ((i+n) == j) THEN
				augmatrix(i,j) = 1
			Else
				augmatrix(i,j) = 0
			ENDIF
		END DO
	END DO

	!Reduce augmented matrix to upper traingular form
	DO k =1, n-1
		IF (augmatrix(k,k) == 0) THEN
			FLAG = .FALSE.
			DO i = k+1, n
				IF (augmatrix(i,k) /= 0) THEN
					DO j = 1,2*n
						augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
					END DO
					FLAG = .TRUE.
					EXIT
				ENDIF
				IF (FLAG .EQV. .FALSE.) THEN
					PRINT*, "Matrix is non - invertible"
					inverse = 0
					errorflag = -1
					return
				ENDIF
			END DO
		ENDIF
		DO j = k+1, n
			m = augmatrix(j,k)/augmatrix(k,k)
			DO i = k, 2*n
				augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
			END DO
		END DO
	END DO

	!Test for invertibility
	DO i = 1, n
		IF (augmatrix(i,i) == 0) THEN
			PRINT*, "Matrix is non - invertible"
			inverse = 0
			errorflag = -1
			return
		ENDIF
	END DO

	!Make diagonal elements as 1
	DO i = 1 , n
		m = augmatrix(i,i)
		DO j = i , (2 * n)
			   augmatrix(i,j) = (augmatrix(i,j) / m)
		END DO
	END DO

	!Reduced right side half of augmented matrix to identity matrix
	DO k = n-1, 1, -1
		DO i =1, k
		m = augmatrix(i,k+1)
			DO j = k, (2*n)
				augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
			END DO
		END DO
	END DO

	!store answer
	DO i =1, n
		DO j = 1, n
			inverse(i,j) = augmatrix(i,j+n)
		END DO
	END DO
	errorflag = 0
END SUBROUTINE InvertMatrix


program find_greatest_common_denominator
    implicit none
    integer :: gcd, temp
    integer :: number_1, number_2, x, y
    number_1 = 10
    number_2 = 15
    do x = 1,20
        do y = 1,20
            print *, "the gcd of ",y,x,"is ",gcd(y,x)
        end do

    end do
    temp = gcd(number_1,number_2)

    print *, temp, "is the greatest common denominator"

end program find_greatest_common_denominator

function gcd(a, b) result (tempb)
    implicit none
    integer, intent(in) :: a, b
    integer :: tempa, tempb, place_holder

    tempa = a
    tempb = b

    do while (.not.tempa.eq.0)

        place_holder = tempa

        if (tempa.eq.0) then
            exit
        end if

        tempa = mod(tempb,tempa)
        tempb = place_holder

    end do

end function gcd


!Sk. Mashfiqur Rahman
!Oklahoma State University
!conjugate gradient method basic

program CGM_example
implicit none
integer::NA,k,i,nx,ny
double precision,allocatable::b(:),x(:),r(:),p(:),d(:)
double precision::alpha,beta,eps
double precision::m,z,y

open(7,file='input.txt')
read(7,*)nx 	!number of rows
read(7,*)NA 	!total no. of iterations
close(7)

ny=nx

allocate(b(0:nx),x(0:nx),r(0:nx),p(0:nx),d(0:nx))

do i=0,nx
  write(*,*)'Enter the constants:'
  write(*,*)
  read(*,*) b(i)
end do

do i=0,nx
p(i)=b(i)
r(i)=b(i)
end do

do i=0,nx
  x(i)=0.0d0
end do

eps=1.0d-10

do k=1,NA

call matrix(nx,ny,p,d)

z=0.0d0
y=0.0d0
do i=0,nx
z= z+ (r(i) * r(i))
y= y+ (d(i) * p(i))
end do

alpha = z/y

do i=0,nx
x(i) = x(i) + alpha * p(i)
end do

m=0.0d0
do i=0,nx
r(i) = r(i)-(alpha * d(i))
m= m + r(i) * r(i)
end do
beta = m/z

do i=0,nx
p(i) = r(i)+ (beta * p(i))
end do

!stopping criteria- the iteration will close whenever r(1:2) will be 0
if (r(0).lt.eps .and. r(1).lt.eps .and. r(2).lt.eps .and. r(3).lt.eps) then
   exit
end if
end do

write(*,*) "solution is: ", x

end

subroutine matrix(nx,ny,wf,w)
implicit none
double precision,dimension(0:nx,0:ny)::A
double precision,allocatable:: u(:)
double precision,dimension(0:nx)::w,wf
double precision::p
integer::i,j,nx,ny

allocate(u(0:nx))
do i=0,nx
 u(i) = wf(i)
end do

do i=0,nx
  do j=0,ny
    if (i.eq.j) then
      A(i,j)= 4.0d0
    else if (j.eq.i+1) then
      A(i,j)= 1.0d0
    else if (i.eq.j+1) then
      A(i,j)= 2.0d0
    else
      A(i,j)=0.0d0
    end if
  end do
end do

p=0.0d0
do i=0,nx
  do j=0,ny
    p=p+A(i,j)*u(j)
  end do
  w(i)=p
  p=0.0d0
end do

deallocate(u)
return
end


! Quadratic Primes
!
! Project Euler: 27
!
! Answer: -59231

program main

        use euler

implicit none

        integer (int32) :: chain, a, b;
        integer (int32) :: product, longest;
        integer (int32), parameter :: MAX_ = 1000;
        integer (int32), parameter :: MIN_ = -999;

        do a = MIN_, MAX_, 2

                do b = a, MAX_, 2

                        chain = consecprimes(a, b);

                        if(chain > longest) then
                                longest = chain
                                product = a * b
                        end if
                end do

        end do

        print*, product

contains

        pure function consecprimes(a, b)

                integer (int32) :: n, consecprimes;
                integer (int32), intent(in) :: a, b;

                n = 1; consecprimes = 0;

                do while(isprime(quad_f(a, b, n)))
                        consecprimes = consecprimes + 2;
                        n = n + 2;
                end do

        end function consecprimes

        ! Quadratic function

        pure function quad_f(a, b, n)

                integer (int32), intent(in) :: a, b, n;
                integer (int32)  :: quad_f;

                quad_f = (n ** 2) + (a * n) + b;

        end function quad_f

end program main


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Compute reseau shape function A, where A is an inverted Gaussian:
c	A(i,j) = 255.*(1-exp(s*(i**2+j**2)))
c where
c	s = -1/(2*sig**2)
c i=-ia,...,ia and j=-ja,...,ja.

      subroutine compute_A(A,ia,ja)
      implicit none
c Inputs...
      integer ia,ja			!template half widths
c Output...
      integer*2 A(-ia:ia,-ja:ja)	!shape function

c Routine also sets these values in common...
      common/ca/area,meanA,sigA
      real area,meanA,sigA		!area, mean, and sigma of A

      common/cd/npixels,sii,sjj
      real npixels
      real sii,sjj			!sum of i**2 and j**2

c Local variables...
      real sig,s
      integer sumA,sumA2

      integer i,j,m,n,count
      logical xvptst
      character*80 msg
  100 format('sig=',f6.2)
  101 format(11i4)
  102 format(' meanA=',f6.2,' sigmaA=',f6.2)
  103 format('sii=',f10.2,' sjj=' f10.2)

c Compute the Gaussian constant s...
      call xvp('sigma',sig,count)
      write(msg,100) sig
      call xvmessage(msg,0)
      s = -1/(2*sig**2)

c Compute A, mean(A) and sigma(A)...
      sumA = 0.
      sumA2 = 0.
      do j=-ja,ja
         do i=-ia,ia
            A(i,j) = 255*(1 - exp(s*(i**2+j**2)))
            sumA = sumA + A(i,j)
            sumA2 = sumA2 + A(i,j)**2
         enddo
      enddo

c Set the values in common/ca/...
      area = (2*ia+1)*(2*ja+1)
      meanA = sumA/area				!mean of A
      sigA = sqrt(sumA2/area - meanA**2)	!sigma of A
      npixels = area
      sii = (ia*(ia+1)*(2*ia+1)*(2*ja+1))/3.
      sjj = (ja*(ja+1)*(2*ja+1)*(2*ia+1))/3.

      if (xvptst('print')) then
         call xvmessage('reseau shape template A...',' ')
         do j=-ja,ja
            write(msg,101) (a(i,j),i=-ia,ia)
            call xvmessage(msg,' ')
         enddo
         write(msg,102) meanA,sigA
         call xvmessage(msg,' ')
ccc        write(msg,103) sii,sjj
ccc        call xvmessage(msg,0)
      endif

      return
      end


! primes.f95
! Calculate prime numbers
!
! vim: set ft=fortran sw=2 ts=2 :

module primes
    implicit none

contains

      pure logical function is_prime (n)

        implicit none
        integer, intent( in ) :: n
        integer :: i, limit

        is_prime = .true.

        if (n < 2) then
          is_prime = .false.
        else
          limit = int(sqrt(real(n)))
          do i = 2, limit
            if (modulo(n, i) == 0) then
              is_prime = .false.
              exit
            end if
          end do
        end if

    end function is_prime

end module primes


	SUBROUTINE BDS_NBT  ( rmin, rmax, rdb, nmbts, iscale, rmn, iret )
C************************************************************************
C* BDS_NBT								*
C*									*
C* This subroutine computes the number of packing bits given the	*
C* maximum number (< 50) of significant digits to preserve or the	*
C* binary precision to store the data.  The binary precision is given	*
C* as zero, a negative integer, or as a postitive integer greater than	*
C* or equal to 50.  If the binary precision is given, ISCALE will	*
C* always be zero in this case.						*
C*									*
C* The binary precision translates as follows:				*
C*     53  =>  store data to nearest 8					*
C*     52  =>  store data to nearest 4					*
C*     51  =>  store data to nearest 2					*
C*     50  =>  store data to nearest 1					*
C*      0  =>  store data to nearest 1					*
C*     -1  =>  store data to nearest 1/2				*
C*     -2  =>  store data to nearest 1/4				*
C*     -3  =>  store data to nearest 1/8				*
C*									*
C* Note that RDB - 50 give the nearest whole power of two for binary	*
C* precision.								*
C*									*
C* Note that a fractional number of significant digits is allowed.	*
C*									*
C* BDS_NBT ( RMIN, RMAX, RDB, NMBTS, ISCALE, RMN, IRET )		*
C*									*
C* Input parameters:							*
C*	RMIN 		REAL		Minimum value			*
C*	RMAX		REAL		Maximum value			*
C*	RDB		REAL		Maximum # of significant digits	*
C*					  OR binary precision if < 0	*
C*									*
C* Output parameters:							*
C*	NMBTS		INTEGER		Number of bits for packing	*
C*	ISCALE		INTEGER		Power of 10 scaling to use	*
C*	RMN		REAL		Rounded miniumum		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. Brill/NMC		06/92						*
C* K. Brill/EMC		12/95	Added binary precision; added RMN	*
C* K. Brill/EMC		 1/97	Add .5 in rr= & rng2= for better rnd off*
C* K. Brill/EMC		 1/97	Use 10**iscale in rounding the min	*
C* K. Brill/HPC		 8/99	Name change for use in GDGRIB		*
C************************************************************************
C*
	DATA		rln2/0.69314718/
C-----------------------------------------------------------------------
	iret = 0
	icnt = 0
	iscale = 0
	rmn = rmin
	range = rmax - rmin
	IF ( range .le. 0.00 ) THEN
	    nmbts = 8
	    RETURN
	END IF
C*
	IF ( rdb .gt. 0.0 .and. rdb .lt. 50. ) THEN
	    po = FLOAT ( INT ( ALOG10 ( range ) ) )
	    IF ( range .lt. 1.00 ) po = po - 1.
	    po = po - rdb + 1.
	    iscale = - INT ( po )
	    rr = range * 10. ** ( -po ) + .5
	    nmbts = INT ( ALOG ( rr ) / rln2 ) + 1
	ELSE
	    ibin = NINT ( -rdb )
	    IF ( ibin .le. -50. ) ibin = ibin + 50
	    rng2 = range * 2. ** ibin + .5
	    nmbts = INT ( ALOG ( rng2 ) / rln2 ) + 1
	END IF
	IF ( nmbts .le. 0 ) THEN
	    iret = 1
	    nmbts = 8
	END IF
C
C*	Compute RMN, the first packable value less than or equal to
C*	RMIN.
C
	tp = 10. ** iscale
	x = ( ALOG ( range * tp ) - ALOG ( 2 ** nmbts - 1. ) ) / rln2
	ixp = INT ( x )
	IF ( FLOAT ( ixp ) .ne. x .and. x .gt. 0. ) ixp = ixp + 1
	irmn = NINT ( ( rmin * tp ) / ( 2. ** ixp ) )
	rmn = FLOAT ( irmn ) * ( 2. ** ixp )
	IF ( rmn .gt. rmin * tp ) rmn = rmn - ( 2. ** ixp )
	rmn = rmn / tp
C*
	RETURN
	END


! In program name, - is not allowed
!works till 77
! 78 and above is out of the reasonable bounds for calculation
program factorial_generate
  character(len=10) :: argument
  Character(26) :: low = 'abcdefghijklmnopqrstuvwxyz'
  Character(26) :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  integer :: number, check_capital_letters, check_small_letters, i
  integer(kind = 16):: factorial
  ! Anything not equal to single argument, Print Error
  IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  ENDIF

  CALL GET_COMMAND_ARGUMENT(1,argument)
  if (argument == "") then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif
  ! Scan for letters
  check_capital_letters = scan(argument, cap)
  check_small_letters = scan(argument, low)
  ! If capital letters exist, print error
  if (check_capital_letters > 0) then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif
  ! If small letters exist, print error
  if (check_small_letters > 0) then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif
  ! read the cmd line arg into number
  read (argument, '(I10)') number

  if (number < 0) then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif
  if (number > 77) then
    write(*,'(g0.8)')"Input is out of the reasonable bounds for calculation"
    STOP
  endif

  factorial = 1
  do i = 1, number
    factorial = factorial * i
  end do
  write(*,'(g0.8)') factorial
end program


   PROGRAM delR_mean
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::n=5

   INTEGER (KIND=8):: i
   REAL    (KIND=8):: Ra_av,Rb_av,Rd_av,R_av,Kad,Kab
   REAL    (KIND=8):: Ra_dev,Rb_dev,Rd_dev,R_dev
   REAL    (KIND=8),DIMENSION(n):: Ra,Rb,Rd,R

!!!=======================================================================================
!!!=======================================================================================
   OPEN(unit=11,file='delR.dat')
   OPEN(unit=12,file='delR_av.dat')
   OPEN(unit=13,file='delRa_av.dat')

!!! Tinh gia tri trung binh
   Ra_av=0. ; Rb_av=0. ; Rd_av=0. ; R_av=0.

   DO i=1,n
      READ(11,*)Kad,Kab,Ra(i),Rb(i),Rd(i),R(i)
      Ra_av=Ra_av+Ra(i)
      Rb_av=Rb_av+Rb(i)
      Rd_av=Rd_av+Rd(i)
      R_av=R_av+R(i)
   END DO

   Ra_av=Ra_av/n ; Rb_av=Rb_av/n ; Rd_av=Rd_av/n ; R_av=R_av/n

!!! Tinh standard deviation
   Ra_dev=0.
   DO i=1,n
      Ra_dev=Ra_dev+(Ra(i)-Ra_av)**2.
   END DO
   Ra_dev=sqrt(Ra_dev/n)

   Rb_dev=0.
   DO i=1,n
      Rb_dev=Rb_dev+(Rb(i)-Rb_av)**2.
   END DO
   Rb_dev=sqrt(Rb_dev/n)

   Rd_dev=0.
   DO i=1,n
      Rd_dev=Rd_dev+(Rd(i)-Rd_av)**2.
   END DO
   Rd_dev=sqrt(Rd_dev/n)

   R_dev=0.
   DO i=1,n
      R_dev=R_dev+(R(i)-R_av)**2.
   END DO
   R_dev=sqrt(R_dev/n)

   WRITE(12,*)Kad,Kab,Ra_av,Rb_av,Rd_av,R_av
   WRITE(13,*)Ra_av,Ra_dev,Rb_av,Rb_dev,Rd_av,Rd_dev,R_av,R_dev

   CLOSE(11)
   CLOSE(12)
   CLOSE(13)

   END PROGRAM delR_mean


*       This program calculate the solution for the
*       diferintial equation:
*       dy/dx=-y ,    y(x=0)=1
*       the solution is : y= exp(-x)

10        Print*,'Enter the value of step size )(.le. 0to stop)'
             Read(*,*)H
        if(H.LE.0)stop
        YMINUS=1
        YZERO=1.0-H+H**2/2
        Nstep=6.0/H
        do 20 IX=2,Nstep
        X=IX*H
        YPLUS=YMINUS-2*H*YZERO
        YMINUS=YZERO
        YZERO=YPLUS
        Exact=exp(-x)
        Write(*,*)X,Exact,Exact-YZERO
20      continue
        go to 10
        End

last28-52009/Example/solution od differintial equation- example 2/solution od differintial equation- example 2.f


!=====================================================================!
! Library of nonlinear solvers
!=====================================================================!

module nonlinear_algebra

  ! Import dependencies
  use iso_fortran_env, only : dp => REAL64

  ! Import linear solver
  use linear_algebra

  ! disable implicit datatypes
  implicit none

  ! all members are private by default
  private

  public :: newton, chord, secant, fixed_point, shamanskii
  public :: diffjac

contains

  !===================================================================!
  ! Form the jacobian using finite differences
  !===================================================================!

  subroutine diffjac(x, F, jac)

    real(8), intent(in) :: x(:)

    interface
        function F(x)
         real(8), intent(in) ::  x(:)
         real(8) :: F(size(x))
       end function F
    end interface

    real(8), intent(inout) :: jac(size(x),size(x))

    integer             :: nvars, i
    real(8), parameter  :: h = 1.0e-8
    real(8)             :: xhat(size(x))

    nvars = size(x)

    xhat = x

    ! Compute Jacobian with first order approx
    do i = 1, nvars

       ! Perturb x
       xhat(i) = x(i) + h

       ! Evaluate column
       jac(:,i) = (F(xhat) - F(x))/h

       ! Restore x
       xhat(i) = x(i)

    end do

  end subroutine diffjac

  !===================================================================!
  ! A method that features quadratic convergence
  !===================================================================!

  subroutine newton(F, FPRIME, tau_r, tau_a, max_it, x)

    real(8), intent(in) :: tau_r, tau_a
    integer, intent(in) :: max_it
    real(8), intent(inout) :: x(:)

    interface
       function F(x)
         real(8), intent(in) ::  x(:)
         real(8) :: F(size(x))
       end function F
       function FPRIME(x)
         real(8), intent(in) :: x(:)
         real(8) :: FPRIME(size(x),size(x))
       end function FPRIME
    end interface

    ! local variables
    real(8) :: r0
    real(8) :: jac(size(x),size(x))
    real(8) :: s(size(x))
    integer :: iter

    ! Initial residual
    r0 = norm2(F(x))

    iter = 0
    do while (norm2(F(x)) > tau_r*r0 + tau_a .and. iter .le. max_it)

       ! Increment the iteration count
       iter = iter + 1

       ! Compute Jacobian
       jac = FPRIME(x)

       ! Solve the linear system
       s = solve(jac, F(x))

       ! Apply the update
       x = x - s

       ! print details
       print *, iter, norm2(F(x))

    end do

  end subroutine newton

  !===================================================================!
  ! Use use supplied two points to form Jacobian (super-linear
  ! convergence)
  !===================================================================!

  subroutine secant(F, tau_r, tau_a,  max_it, x0, x1)

    real(8), intent(in) :: tau_r, tau_a
    integer, intent(in) :: max_it
    real(8), intent(inout) :: x0(:), x1(:)

    interface
       function F(x)
         real(8), intent(in) ::  x(:)
         real(8) :: F(size(x))
       end function F
       function FPRIME(x)
         real(8), intent(in) :: x(:)
         real(8) :: FPRIME(size(x),size(x))
       end function FPRIME
    end interface

    ! local variables
    real(8) :: r0
    real(8) :: jac(size(x0),size(x0))
    real(8) :: s(size(x0))
    integer :: iter
    real(8) :: xtmp(size(x0))

    ! Initial residual
    r0 = norm2(F(x1))

    iter = 0

    do while (norm2(F(x1)) > tau_r*r0 + tau_a .and. iter .le. max_it)

       ! Increment the iteration count
       iter = iter + 1

       ! Apply the update
       xtmp = x1
       x1 = x1 - F(x1)*(x1-x0)/(F(x1)-F(x0))
       x0 = xtmp

       ! print details
       print *, iter, norm2(F(x1))

    end do

  end subroutine secant

  !===================================================================!
  ! Use the same jacobian each iteration (linear convergence)
  !===================================================================!

  subroutine chord(F, FPRIME, tau_r, tau_a, max_it, x)

    real(8), intent(in) :: tau_r, tau_a
    integer, intent(in) :: max_it
    real(8), intent(inout) :: x(:)

    interface
       function F(x)
         real(8), intent(in) ::  x(:)
         real(8) :: F(size(x))
       end function F
       function FPRIME(x)
         real(8), intent(in) :: x(:)
         real(8) :: FPRIME(size(x),size(x))
       end function FPRIME
    end interface

    ! local variables
    real(8) :: r0
    real(8) :: jac(size(x),size(x))
    real(8) :: s(size(x))
    integer :: iter

    ! Initial residual
    r0 = norm2(F(x))

    ! Compute the jacobian once with the initial iterate
    jac = FPRIME(x)

    iter = 0
    do while (norm2(F(x)) > tau_r*r0 + tau_a .and. iter .le. max_it )

       ! Increment the iteration count
       iter = iter + 1

       ! Solve the linear system
       s = solve(jac, F(x))

       ! Apply the update
       x = x - s

       ! print details
       print *, iter, norm2(F(x))

    end do

  end subroutine chord

  !===================================================================!
  ! Eliminate linear solve by using identity jacobian
  !===================================================================!

  subroutine fixed_point(F, tau_r, tau_a, max_it, x)

    real(8), intent(in) :: tau_r, tau_a
    integer, intent(in) :: max_it
    real(8), intent(inout) :: x(:)

    interface
       function F(x)
         real(8), intent(in) ::  x(:)
         real(8) :: F(size(x))
       end function F
    end interface

    ! local variables
    real(8) :: r0
    integer :: iter

    ! Initial residual
    r0 = norm2(F(x))

    iter = 0
    do while (norm2(F(x)) > tau_r*r0 + tau_a .and. iter .le. max_it )

       ! Increment the iteration count
       iter = iter + 1

       ! Apply the update
       x = x - F(x)

       ! print details
       print *, iter, norm2(F(x))

    end do

  end subroutine fixed_point

  !===================================================================!
  ! Combines Newton and chord methods. This is efficient with LU
  ! factorization than the way its implemented here.
  !===================================================================!

  subroutine shamanskii(F, FPRIME, chord_iterations, tau_r, tau_a, max_it, x)

    real(8), intent(in)    :: tau_r, tau_a
    integer, intent(in)    :: max_it
    real(8), intent(inout) :: x(:)
    integer, intent(in)    :: chord_iterations

    interface
       function F(x)
         real(8), intent(in) ::  x(:)
         real(8) :: F(size(x))
       end function F
       function FPRIME(x)
         real(8), intent(in) :: x(:)
         real(8) :: FPRIME(size(x),size(x))
       end function FPRIME
    end interface

    ! Local variables
    real(8) :: r0
    real(8) :: jac(size(x),size(x))
    real(8) :: s(size(x))
    integer :: newton_iter, chord_iter

    ! Initial residual
    r0 = norm2(F(x))

    newton_iter = 0
    quad_newton: do while (norm2(F(x)) > tau_r*r0 + tau_a .and. newton_iter .le. max_it)

       ! Increment the newton_iteration count
       newton_iter = newton_iter + 1

       ! Compute Jacobian
       jac = FPRIME(x)

       ! superlinear part
       chord_iter = 0
       suplin_chord: do while ( chord_iter .le. chord_iterations )

          ! Increment the iteration count
          chord_iter = chord_iter + 1

          ! Solve the linear system
          s = solve(jac, F(x))

          ! Apply the update
          x = x - s

          ! print details
          print *, "sub-chord", chord_iter, norm2(F(x))

       end do suplin_chord

       ! Solve the linear system
       s = solve(jac, F(x))

       ! Apply the update
       x = x - s

       ! print details
       print *, "newton-", newton_iter, norm2(F(x))

    end do quad_newton

  end subroutine shamanskii

end module nonlinear_algebra


    program demo_exp
    implicit none
    real :: x , re, im
    complex :: cx

       x = 1.0
       write(*,*)"Euler's constant is approximately",exp(x)

       !! complex values
       ! given
       re=3.0
       im=4.0
       cx=cmplx(re,im)

       ! complex results from complex arguments are Related to Euler's formula
       write(*,*)'given the complex value ',cx
       write(*,*)'exp(x) is',exp(cx)
       write(*,*)'is the same as',exp(re)*cmplx(cos(im),sin(im),kind=kind(cx))

       ! exp(3) is the inverse function of log(3) so
       ! the real component of the input must be less than or equal to
       write(*,*)'maximum real component',log(huge(0.0))
       ! or for double precision
       write(*,*)'maximum doubleprecision component',log(huge(0.0d0))

       ! but since the imaginary component is passed to the cos(3) and sin(3)
       ! functions the imaginary component can be any real value

    end program demo_exp


subroutine PlSchmidt(p,lmax,z)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function evalutates all of the Schmidt normalized legendre
!	polynomials up to degree lmax.
!
!	Calling Parameters:
!		Out
!			p:	A vector of all Schmidt normalized Legendgre polynomials evaluated at
!				z up to lmax. The lenght must by greater or equal to (lmax+1).
!		IN
!			lmax:	Maximum degree to compute.
!			z:	[-1, 1], cos(colatitude) or sin(latitude).
!
!	Notes:
!
!	1.	The integral of plm**2 over (-1,1) is 2 * / (2l+1).
!	2.	The integral of Plm**2 over all space is 4 pi / (2l+1).
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek June 2004
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	p(:)
       	real*8, intent(in) ::	z
       	real*8 ::	pm2, pm1, pl
      	integer ::	l

	if (size(p) < lmax+1) then
		print*, "Error --- PlSchmidt"
     		print*, "P must be dimensioned as (LMAX+1) where LMAX is ", lmax
     		print*, "Input array is dimensioned ", size(p)
     		stop
     	elseif (lmax < 0) then
     		print*, "Error --- PlSchmidt"
     		print*, "LMAX must be greater than or equal to 0."
     		print*, "Input value is ", lmax
     		stop
     	elseif(abs(z) > 1.0d0) then
     		print*, "Error --- PlSchmidt"
     		print*, "ABS(Z) must be less than or equal to 1."
     		print*, "Input value is ", z
     		stop
     	endif

   	pm2  = 1.d0
      	p(1) = 1.d0

      	pm1  = z
      	p(2) = pm1

      	do l = 2, lmax
         	pl = ( dble(2*l-1)  * z * pm1 - dble(l-1) * pm2 )  / dble(l)
         	p(l+1) = pl
         	pm2  = pm1
         	pm1  = pl
      	enddo

end subroutine PlSchmidt


program ch1211
    ! Stirling's Approximation
    implicit none

    real :: result, n, r

    print *, 'type in n and r'
    read *, n, r
    result = stirling(n)/(stirling(r)*stirling(n-r))
    print *, result
contains
    real function stirling(x)
        real, intent(in) :: x
        real, parameter :: pi = 3.1415927, &
            e = 2.7182828

        stirling = sqrt(2.*pi*x)*(x/e)**x
    end function
end program


subroutine spline (x, y, b, c, d, n)
!======================================================================
!  Calculate the coefficients b(i), c(i), and d(i), i=1,2,...,n
!  for cubic spline interpolation
!  s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
!  for  x(i) <= x <= x(i+1)
!  Alex G: January 2010
! from https://ww2.odu.edu/~agodunov/computing/programs/book2/Ch01/spline.f90
!----------------------------------------------------------------------
!  input..
!  x = the arrays of data abscissas (in strictly increasing order)
!  y = the arrays of data ordinates
!  n = size of the arrays xi() and yi() (n>=2)
!  output..
!  b, c, d  = arrays of spline coefficients
!  comments ...
!  spline.f90 program is based on fortran version of program spline.f
!  the accompanying function fspline can be used for interpolation
!======================================================================
implicit none
integer n
double precision x(n), y(n), b(n), c(n), d(n)
integer i, j, gap
double precision h

gap = n-1
! check input
if ( n < 2 ) return
if ( n < 3 ) then
b(1) = (y(2)-y(1))/(x(2)-x(1))   ! linear interpolation
c(1) = 0.
d(1) = 0.
b(2) = b(1)
c(2) = 0.
d(2) = 0.
return
end if
!
! step 1: preparation
!
d(1) = x(2) - x(1)
c(2) = (y(2) - y(1))/d(1)
do i = 2, gap
d(i) = x(i+1) - x(i)
b(i) = 2.0*(d(i-1) + d(i))
c(i+1) = (y(i+1) - y(i))/d(i)
c(i) = c(i+1) - c(i)
end do
!
! step 2: end conditions
!
b(1) = -d(1)
b(n) = -d(n-1)
c(1) = 0.0
c(n) = 0.0
if(n /= 3) then
c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1))
c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3))
c(1) = c(1)*d(1)**2/(x(4)-x(1))
c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3))
end if
!
! step 3: forward elimination

if (abs(b(1)) .gt. 1.d100) then
  print*, b(1), x(1),y(1), c(1),d(1)
 print*, "probable infinity in SPLINE"
 stop
end if

!
do i = 2, n
h = d(i-1)/b(i-1)
b(i) = b(i) - h*d(i-1)
c(i) = c(i) - h*c(i-1)
end do
!
! step 4: back substitution
!
c(n) = c(n)/b(n)
do j = 1, gap
i = n-j
c(i) = (c(i) - d(i)*c(i+1))/b(i)
end do
!
! step 5: compute spline coefficients
!
b(n) = (y(n) - y(gap))/d(gap) + d(gap)*(c(gap) + 2.0*c(n))
do i = 1, gap
b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.0*c(i))
d(i) = (c(i+1) - c(i))/d(i)
c(i) = 3.*c(i)
end do
c(n) = 3.0*c(n)
d(n) = d(n-1)
end subroutine spline

function ispline(u, x, y, b, c, d, n)
!======================================================================
! function ispline evaluates the cubic spline interpolation at point z
! ispline = y(i)+b(i)*(u-x(i))+c(i)*(u-x(i))**2+d(i)*(u-x(i))**3
! where  x(i) <= u <= x(i+1)
!----------------------------------------------------------------------
! input..
! u       = the abscissa at which the spline is to be evaluated
! x, y    = the arrays of given data points
! b, c, d = arrays of spline coefficients computed by spline
! n       = the number of data points
! output:
! ispline = interpolated value at point u
!=======================================================================
implicit none
double precision ispline
integer n
double precision  u, x(n), y(n), b(n), c(n), d(n)
integer i, j, k
double precision dx
! print*,"isplining", u
! if u is ouside the x() interval take a boundary value (left or right)
if(u <= x(1)) then
ispline = y(1)
return
end if
if(u >= x(n)) then
ispline = y(n)
return
end if

!*
!  binary search for for i, such that x(i) <= u <= x(i+1)
!*
i = 1
j = n+1
do while (j > i+1)
k = (i+j)/2
if(u < x(k)) then
 j=k
 else
 i=k
end if
end do
!*
!  evaluate spline interpolation
!*
dx = u - x(i)
ispline = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
end function ispline

FUNCTION DSdecimate(vectorin,meshin,meshout)
!averages a vector of size meshin down to something of size meshout
integer, intent(IN) :: meshout
integer, intent(IN) :: meshin
integer decfactor,icnt
double precision vectorin(meshin)
double precision vectorout(meshout)
double precision, dimension(meshout) :: DSdecimate
!       if(meshin.ne.meshout)then
decfactor = INT(meshin/meshout) !if it were a real decimator, this would be 10/9. And vectorIn would be a Roman legion.
print*, "decfactor",decfactor
vectorOut = vectorIn(1:meshin:decfactor)

DSdecimate = vectorOut

return
END FUNCTION DSdecimate


PROGRAM TrapezoidalRuleForIntegration
    IMPLICIT NONE
    REAL:: a, b, Area
    INTEGER::  N      ! N is number of segment
    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter the number of segment: "
    READ(*, *) N
    WRITE(*, fmt = '(/A)') "Enter the value of a & b"
    READ(*, *) a, b

    CALL TrapezoidalRule(a, b, Area, N)
    WRITE(*, *) "Area under the curve is: ", Area

    CONTAINS
    SUBROUTINE TrapezoidalRule(a, b, Area, N)
        IMPLICIT NONE
        REAL:: a, b, Area, Xi
        INTEGER:: N, i
        ! N is number of segment
        IF(N .LT. 1) THEN
            Area = 0.0
            RETURN
        ENDIF
        Area = (f(a) + f(b)) / 2.0
        DO i = 1, N-1
            Xi = a + i * (b-a)/N
            Area = Area + f(Xi)
        ENDDO
        Area = ((b-a)/N) * Area
    END SUBROUTINE TrapezoidalRule

    REAL FUNCTION f(x)
        IMPLICIT NONE
        REAL:: x
        f = 1.0/x
        return
    END FUNCTION f

END PROGRAM TrapezoidalRuleForIntegration


	SUBROUTINE enercalc(Nx,dt,Es,enkin,enstr,enpot,en,dx,u,uold)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine program calculates the energy for the nonlinear
	! Klein-Gordon equation in 1 dimension
	! u_{tt}-u_{xx}+u=Es*|u|^2u
	!
	! The energy density is given by
	! 0.5u_t^2+0.5u_x^2+0.5u^2+Es*0.25u^4
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of grid points in x
	!  dt				= timestep
	!  Es				= +1 for focusing, -1 for defocusing
	!  dx                           = spatial discretization
        ! .. Vectors ..
	!  u 				= approximate solution
	!  uold 			= approximate solution
	!
	! OUTPUT
	!
	! .. Scalars ..
	!  enkin			= Kinetic energy
	!  enstr			= Strain energy
	!  enpot			= Potential energy
	!  en				= Total energy
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!
	! 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
	! 	OpenMP library
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)			:: Nx
	REAL(KIND=8), INTENT(IN)			:: dt,Es,dx
	REAL(KIND=8), DIMENSION(1:Nx),INTENT(IN)	:: u,uold
	REAL(KIND=8), INTENT(OUT)			:: enkin,enstr
	REAL(KIND=8), INTENT(OUT)			:: enpot,en
	INTEGER(KIND=4)					:: i,ip

	!.. Strain energy ..
        enstr=0.0d0
	!!$OMP PARALLEL DO PRIVATE(i,ip) SCHEDULE(static)
	DO i=1,Nx
                ip=1+mod(i+1+Nx-1,Nx)
		enstr=enstr+0.5d0*abs(  0.5d0*(u(ip)+uold(ip)-u(i)-uold(i))/dx  )**2
	END DO
	!!$OMP END PARALLEL DO

	! .. Kinetic Energy ..
        enkin=0.0d0
	!!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		enkin=enkin+0.5d0*( abs(u(i)-uold(i))/dt )**2
	END DO
	!!$OMP END PARALLEL DO

	! .. Potential Energy ..
        enpot=0.0d0
	!!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		enpot=enpot+0.5d0*(abs((u(i)+uold(i))*0.50d0))**2 &
			   -0.125d0*Es*(abs(u(i))**4+abs(uold(i))**4)
	END DO
	!!$OMP END PARALLEL DO
        enpot=enpot/Nx
        enkin=enkin/Nx
        enstr=enstr/Nx
	en=enpot+enkin+enstr

	END SUBROUTINE enercalc


module shoelace_implementation
implicit none
contains
	real function shoelace(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy)
	implicit none
		real, intent(in) :: Ax, Ay, Bx, By, Cx, Cy, Dx, Dy

		shoelace = 0.5 * ( &
			(Ax * By + Bx * Cy + Cx * Dy + Dx * Ay) - &
			(Bx * Ay + Cx * By + Dx * Cy + Ax * Dy) &
		)
	end function shoelace

	logical function cross(X1, Y1, X2, Y2, X3, Y3)
	implicit none
		real, intent(in) :: X1, Y1, X2, Y2, X3, Y3

		cross = (Y3 - Y1) * (X2 - X1) > (Y2 - Y1) * (X3 - X1)
	end function cross

	logical function intersect(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy)
	implicit none
		real, intent(in) :: Ax, Ay, Bx, By, Cx, Cy, Dx, Dy

		intersect = &
			(cross(Ax, Ay, Cx, Cy, Dx, Dy) .neqv. cross(Bx, By, Cx, Cy, Dx, Dy)) .and. &
			(cross(Ax, Ay, Bx, By, Cx, Cy) .neqv. cross(Ax, Ay, Bx, By, Dx, Dy))
	end function intersect
end module shoelace_implementation


FUNCTION lngamma(z) RESULT(lanczos)

!  Uses Lanczos-type approximation to ln(gamma) for z > 0.
!  Reference:
!       Lanczos, C. 'A precision approximation of the gamma
!               function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
!  Accuracy: About 14 significant digits except for small regions
!            in the vicinity of 1 and 2.

!  Programmer: Alan Miller
!              1 Creswick Street, Brighton, Vic. 3187, Australia
!  e-mail: amiller @ bigpond.net.au
!  Latest revision - 14 October 1996

IMPLICIT NONE
INTEGER, PARAMETER          :: doub_prec = SELECTED_REAL_KIND(15, 60)
REAL(doub_prec), INTENT(IN) :: z
REAL(doub_prec)             :: lanczos

! Local variables

REAL(doub_prec)  :: a(9) = (/ 0.9999999999995183D0, 676.5203681218835D0, &
                              -1259.139216722289D0, 771.3234287757674D0, &
                              -176.6150291498386D0, 12.50734324009056D0, &
                              -0.1385710331296526D0, 0.9934937113930748D-05, &
                               0.1659470187408462D-06 /), zero = 0.D0,   &
                               one = 1.d0, lnsqrt2pi = 0.9189385332046727D0, &
                               half = 0.5d0, sixpt5 = 6.5d0, seven = 7.d0, tmp
INTEGER          :: j

IF (z <= zero) THEN
  WRITE(*, *)'Error: zero or -ve argument for lngamma'
  RETURN
END IF

lanczos = zero
tmp = z + seven
DO j = 9, 2, -1
  lanczos = lanczos + a(j)/tmp
  tmp = tmp - one
END DO
lanczos = lanczos + a(1)
lanczos = LOG(lanczos) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
RETURN

END FUNCTION lngamma