matrix.f

CLM集合卡曼滤波数据同化算法

!*******************************************************

      subroutine TRISRT(n,d,e,m,rtmu,S,dx,ex,x)
      implicit none
      integer n, m
      real d(n), e(n-1), S(n,n), dx(n), ex(n-1), x(n)

      integer i,j,k,info
      real theta, ak, bk, coef, pi, rtmu

      pi = 4.0*atan(1.0)

      do j=1, n
         do i=j, n
            S(i,j) = 0.0
         enddo
      enddo

      do k=1, m

         theta = k*pi/(2.0*m+1.0)
         ak = 2.0/(2.0*m+1.0)* ( sin(theta))**2
         bk = ( cos(theta) )**2
         coef = ak*rtmu

         do i=1, n-1
            dx(i) = 1.0 + bk*d(i)
            ex(i) = bk*e(i)
         enddo
         dx(n) = 1.0 + bk*d(n)

!*     SPTTRF computes the factorization of a real symmetric positive
!*     definite tridiagonal matrix A.

         call SPTTRF(n,dx,ex,info)

         do j=1, n

            do i=1, n
               x(i) = 0.0
            enddo

            x(j) = d(j)*coef
            if ( j .GT. 1) x(j-1) = coef*e(j-1)
            if ( j .LT. n) x(j+1) = e(j)*coef

!*     SPTTRS solves a system of linear equations A * X = B with a
!*     symmetric positive definite tridiagonal matrix A using the
!*     factorization A = L*D*L**T or A = U**T*D*U computed by SPTTRF.
!*     (The two forms are equivalent if A is real.)

!*            call SPTTRS(n, neq, dx, ex, x, n, info)
            call TRISPE(n, dx, ex, x, j)

!*     We will replace this by our own program that takes
!*     advantage of the zeros in x, and the symmetric of 
!*     solution matrix.
            
            do i=j, n
               S(i,j) = S(i,j) + x(i)
            enddo

         enddo
      enddo

      return
      end

!***********************************************************
      subroutine TRISPE(n, d, e, x, j)
      implicit none
      integer n, j
      real d(n), e(n-1), x(n)
      integer i

      if ( j .GT. 1) x(j) = x(j)-e(j-1)*x(j-1)
      if ( j .LT. n) x(j+1) = x(j+1) - e(j)*x(j)
      do i = j+2, n
         x(i) = -e(i-1)*x(i-1)
      enddo
      
      x(n) = x(n)/d(n)
      do i=n-1, j, -1
         x(i) = x(i)/d(i) - e(i)*x(i+1)
      enddo
      
      return
      end
!******************************************************************
!*     This program requires 2n^3 flops.

!*     SSYTRD reduces a real symmetric matrix A to real symmetric
!*     tridiagonal form T by an orthogonal similarity transformation:
!*     Q**T * A * Q = T, where Q is is represented as a product of 
!*     elementary reflectors.
!*
!*     It takes: 4/3 n^3 operations.
!*
!*     If UPLO = 'L', the matrix Q is represented as a product of elementary
!*     reflectors
!*
!*     Q = H(1) H(2) . . . H(n-1).
!*
!*     Each H(i) has the form
!*
!*     H(i) = I - tau * v * v'
!*
!*     where tau is a real scalar, and v is a real vector with
!*     v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
!*     and tau in TAU(i).
!*
!*     The contents of A on exit are illustrated by the following examples
!*     with n = 5:
!*
!*     if UPLO = 'U':                       if UPLO = 'L':
!*
!*     (  d   e   v2  v3  v4 )              (  d                  )
!*     (      d   e   v3  v4 )              (  e   d              )
!*     (          d   e   v4 )              (  v1  e   d          )
!*     (              d   e  )              (  v1  v2  e   d      )
!*     (                  d  )              (  v1  v2  v3  e   d  )
!*
!*     where d and e denote diagonal and off-diagonal elements of T, and vi
!*     denotes an element of the vector defining H(i).

      subroutine APPLIQ(n,A,tau,S,v,w)
      implicit none
      integer n
      real A(n,n), tau(n-1), S(n,n), v(n), w(n)
      integer i, j, k
      real vtw

      do k= n-2, 1, -1
!         print*, k

!     Redefine the vector v, as sqrt(tau)*v, H = I - v*v'

         v(k+1) = sqrt(tau(k))
         do i=k+2, n
            v(i) = A(i,k)*v(k+1)
         enddo

!     Calculate the lower left corner, dimension is: (n-k) x k
!     Total operations:  4 (n-k) k

         do j=1, k
            w(j) = 0.0
            do i=k+1, n
               w(j) = w(j) + v(i)*S(i,j)
            enddo
         enddo

         do j=1, k
            do i=k+1, n
               S(i,j) = S(i,j) - v(i)*w(j)
            enddo
         enddo

!     Calculate the lower right trailing block, only the lower
!     triangular part, domension (n-k) x (n-k)
!     Total operations: 4 (n-k)^2

!     Operations:  2 (n-k)^2
         do i=k+1, n
            w(i) = 0.0
            do j=k+1, i
               w(i) = w(i) + S(i,j)*v(j)
            enddo
            do j=i+1, n
               w(i) = w(i) + S(j,i)*v(j)
            enddo
         enddo

         vtw = 0.0
         do i=k+1, n
            vtw = vtw + v(i)*w(i)
         enddo
         
         vtw = 0.5*vtw
         do i=k+1,n
            w(i) = w(i) - vtw*v(i)
         enddo

!     Operations: 4/2 (n-k)^2 = 2(n-k)^2

         do j= k+1, n
            do i=j, n
               S(i,j) = S(i,j) - w(i)*v(j)-v(i)*w(j)
            enddo
         enddo
               
      enddo
      return
      end
!**************************************************

      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
     $                 N4 )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
*     ..
*
*  Purpose
*  =======
*
*  ILAENV is called from the LAPACK routines to choose problem-dependent
*  parameters for the local environment.  See ISPEC for a description of
*  the parameters.
*
*  This version provides a set of parameters which should give good,
*  but not optimal, performance on many of the currently available
*  computers.  Users are encouraged to modify this subroutine to set
*  the tuning parameters for their particular machine using the option
*  and problem size information in the arguments.
*
*  This routine will not function correctly if it is converted to all
*  lower case.  Converting it to all upper case is allowed.
*
*  Arguments
*  =========
*
*  ISPEC   (input) INTEGER
*          Specifies the parameter to be returned as the value of
*          ILAENV.
*          = 1: the optimal blocksize; if this value is 1, an unblocked
*               algorithm will give the best performance.
*          = 2: the minimum block size for which the block routine
*               should be used; if the usable block size is less than
*               this value, an unblocked routine should be used.
*          = 3: the crossover point (in a block routine, for N less
*               than this value, an unblocked routine should be used)
*          = 4: the number of shifts, used in the nonsymmetric
*               eigenvalue routines
*          = 5: the minimum column dimension for blocking to be used;
*               rectangular blocks must have dimension at least k by m,
*               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
*          = 6: the crossover point for the SVD (when reducing an m by n
*               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
*               this value, a QR factorization is used first to reduce
*               the matrix to a triangular form.)
*          = 7: the number of processors
*          = 8: the crossover point for the multishift QR and QZ methods
*               for nonsymmetric eigenvalue problems.
*          = 9: maximum size of the subproblems at the bottom of the
*               computation tree in the divide-and-conquer algorithm
*               (used by xGELSD and xGESDD)
*          =10: ieee NaN arithmetic can be trusted not to trap
*          =11: infinity arithmetic can be trusted not to trap
*
*  NAME    (input) CHARACTER*(*)
*          The name of the calling subroutine, in either upper case or
*          lower case.
*
*  OPTS    (input) CHARACTER*(*)
*          The character options to the subroutine NAME, concatenated
*          into a single character string.  For example, UPLO = 'U',
*          TRANS = 'T', and DIAG = 'N' for a triangular routine would
*          be specified as OPTS = 'UTN'.
*
*  N1      (input) INTEGER
*  N2      (input) INTEGER
*  N3      (input) INTEGER
*  N4      (input) INTEGER
*          Problem dimensions for the subroutine NAME; these may not all
*          be required.
*
* (ILAENV) (output) INTEGER
*          >= 0: the value of the parameter specified by ISPEC
*          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  The following conventions have been used when calling ILAENV from the
*  LAPACK routines:
*  1)  OPTS is a concatenation of all of the character options to
*      subroutine NAME, in the same order that they appear in the
*      argument list for NAME, even if they are not used in determining
*      the value of the parameter specified by ISPEC.
*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
*      that they appear in the argument list for NAME.  N1 is used
*      first, N2 second, and so on, and unused problem dimensions are
*      passed a value of -1.
*  3)  The parameter value returned by ILAENV is checked for validity in
*      the calling subroutine.  For example, ILAENV is used to retrieve
*      the optimal blocksize for STRTRI as follows:
*
*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
*      IF( NB.LE.1 ) NB = MAX( 1, N )
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            CNAME, SNAME
      CHARACTER*1        C1
      CHARACTER*2        C2, C4
      CHARACTER*3        C3
      CHARACTER*6        SUBNAM
      INTEGER            I, IC, IZ, NB, NBMIN, NX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
*     ..
*     .. External Functions ..
      INTEGER            IEEECK
      EXTERNAL           IEEECK
*     ..
*     .. Executable Statements ..
*
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000,
     $        1100 ) ISPEC
*
*     Invalid value for ISPEC
*
      ILAENV = -1
      RETURN
*
  100 CONTINUE
*
*     Convert NAME to upper case if the first character is lower case.
*
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
*
*        ASCII character set
*
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 10 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   10       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
*
*        EBCDIC character set
*
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $       ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1:1 ) = CHAR( IC+64 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $             ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $             ( IC.GE.162 .AND. IC.LE.169 ) )
     $            SUBNAM( I:I ) = CHAR( IC+64 )
   20       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
*
*        Prime machines:  ASCII+128
*
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   30       CONTINUE
         END IF
      END IF
*
      C1 = SUBNAM( 1:1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )
     $   RETURN
      C2 = SUBNAM( 2:3 )
      C3 = SUBNAM( 4:6 )
      C4 = C3( 2:3 )
*
      GO TO ( 110, 200, 300 ) ISPEC
*
  110 CONTINUE
*
*     ISPEC = 1:  block size
*
*     In these examples, separate code is provided for setting NB for
*     real and complex.  We assume that NB will take the same value in
*     single or double precision.
*
      NB = 1
*
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF