!@sum ODEEP contains routines used for Qflux mixed layer with deep diff.
!@auth G. Schmidt/G. Russell
!@ver  1.0
      MODULE ODEEP_COM
!@sum  ODEEP_COM defines the variables for deep diffusing Qflux model
!@auth Gavin Schmidt/Gary Russell
!@ver  1.0
      USE MODEL_COM, only : im,jm
      IMPLICIT NONE
      SAVE

!@param LMOM number of layers for deep ocean diffusion
c      INTEGER, PARAMETER :: LMOM = 9    ! good for 1000m
      INTEGER, PARAMETER :: LMOM = 12    ! good for 5015m
!@var TG3M Monthly accumulation of temperatures at base of mixed layer
      REAL*8, DIMENSION(IM,JM,12) :: TG3M
!@var RTGO Temperature anomaly in thermocline
      REAL*8, DIMENSION(LMOM,IM,JM) :: RTGO
!@var STG3 accumulated temperature at base of mixed layer
      REAL*8, DIMENSION(IM,JM) :: STG3
!@var DTG3 accumulated temperature diff. from initial monthly values
      REAL*8, DIMENSION(IM,JM) :: DTG3
!@var EDO ocean vertical diffusion (m^2/s)
      REAL*8, DIMENSION(IM,JM) :: EDO
!@var DZ thermocline layer thickness (m)
      REAL*8, DIMENSION(LMOM) :: DZ
!@var DZO,BYDZO distance between centres in thermocline layer (m)
      REAL*8, DIMENSION(LMOM-1) :: DZO,BYDZO

      END MODULE ODEEP_COM

      SUBROUTINE init_ODEEP(iniOCEAN)
!@sum  init_ODEEP initialise deep ocean arrays
!@auth G. Schmidt
!@ver  1.0
      USE FILEMANAGER, only : openunit,closeunit
      USE MODEL_COM, only : im,jm
      USE ODEEP_COM, only : tg3m,stg3,dtg3,rtgo,dz,dzo,bydzo,edo,lmom
      USE STATIC_OCEAN, only : tocean
      IMPLICIT NONE
      LOGICAL, INTENT(IN) :: iniOCEAN
      INTEGER :: iu_tg3m,iu_EDDY,L
      CHARACTER*80 TITLE

!@param FAC ratio of adjacent deep ocean layers
C**** NOTE: For LMOM is 9 this value gives a total depth of 1000m
C**** For any different number of layers, the effective depth is given
C**** by the equation Z=10*(1-x^(LMOM-1))/(1-x).
C**** In particular, for LMOM=12, the total depth is 5015m
      REAL*8, PARAMETER :: FAC=1.705357255658901d0

C**** READ IN EDDY DIFFUSIVITY AT BASE OF MIXED LAYER
      CALL openunit("EDDY",iu_EDDY,.TRUE.,.TRUE.)
      CALL READT (iu_EDDY,0,EDO,IM*JM,EDO,1)
      call closeunit(iu_EDDY)

C**** DEFINE THE VERTICAL LAYERING EVERYWHERE EXCEPT LAYER 1 THICKNESS
      DZ(2)=10.
      DZO(1)=0.5*DZ(2)          ! 10./SQRT(FAC)
      BYDZO(1)=1./DZO(1)
      DO L=2,LMOM-1
        DZ(L+1)=DZ(L)*FAC
        DZO(L)=0.5*(DZ(L+1)+DZ(L)) !DZO(L-1)*FAC
        BYDZO(L)=1./DZO(L)
      END DO

C**** read in initial conditions and climatology for the temperatures at
C**** base of mixed layer, initialise deep arrays for start of run
      if (iniOCEAN) then
        stg3=0. ; dtg3=0. ; rtgo=0.

        call openunit("TG3M",iu_tg3m,.true.,.true.)
        READ(iu_tg3m) TITLE,TG3M
        WRITE(6,*) "Read from TG3M",TITLE
        call closeunit (iu_tg3m)

      end if
      return
C****
      end subroutine init_odeep

      SUBROUTINE io_ocean(kunit,iaction,ioerr)
!@sum  io_ocean reads and writes ocean arrays to file
!@auth Gavin Schmidt
!@ver  1.0
      USE MODEL_COM, only : ioread,iowrite,irsficno,lhead
      USE STATIC_OCEAN
      USE ODEEP_COM
      IMPLICIT NONE

      INTEGER kunit   !@var kunit unit number of read/write
      INTEGER iaction !@var iaction flag for reading or writing to file
!@var IOERR 1 (or -1) if there is (or is not) an error in i/o
      INTEGER, INTENT(INOUT) :: IOERR
!@var HEADER Character string label for individual records
      CHARACTER*80 :: HEADER, MODULE_HEADER = "OCNDEEP01"

      WRITE(MODULE_HEADER(lhead+1:80),'(a45,i2,a)') 'R8 To(3,ijm)'//
     *     ', dim(ijm): MixLD,Stg3,dtg3,rtgo(',lmom,',ijm),'//
     *     'tg3m(12,ijm)'

      SELECT CASE (IACTION)
      CASE (:IOWRITE)            ! output to standard restart file
        WRITE (kunit,err=10) MODULE_HEADER,TOCEAN,Z1O,STG3,DTG3,RTGO,
     *     TG3M
      CASE (IOREAD:)            ! input from restart file
        SELECT CASE (IACTION)
        CASE (IRSFICNO)         ! no ocean initial conditions
C**** Note this is for reading in a full rsf file, but from a qflux run
C**** We do not check HEADER here because it will be wrong. The other
C**** data MUST be initialised by setting iniOCEAN=.TRUE. in init_ODEEP.
          READ (kunit) HEADER,TOCEAN,Z1O
        CASE DEFAULT            ! restart file
          READ (kunit,err=10) HEADER,TOCEAN,Z1O,STG3,DTG3,RTGO,TG3M
          IF (HEADER(1:LHEAD).NE.MODULE_HEADER(1:LHEAD)) THEN
            PRINT*,"Discrepancy in module version ",HEADER,MODULE_HEADER
            GO TO 10
          END IF
        END SELECT
      END SELECT

      RETURN
 10   IOERR=1
      RETURN
C****
      END SUBROUTINE io_ocean

      SUBROUTINE io_ocdiag(kunit,it,iaction,ioerr)
!@sum  io_ocdiag reads and writes ocean diagnostic arrays to file
!@auth Gavin Schmidt
!@ver  1.0
      USE MODEL_COM, only : ioread,iowrite,irsfic,irerun,iowrite_single
     *     ,ioread_single,lhead,im,jm
      USE ODEEP_COM
      IMPLICIT NONE

      INTEGER kunit   !@var kunit unit number of read/write
      INTEGER iaction !@var iaction flag for reading or writing to file
!@var IOERR 1 (or -1) if there is (or is not) an error in i/o
      INTEGER, INTENT(INOUT) :: IOERR
!@var HEADER Character string label for individual records
      CHARACTER*80 :: HEADER, MODULE_HEADER = "OCDIAGDEEP01"
!@var it input/ouput value of hour
      INTEGER, INTENT(INOUT) :: it
!@var RTGO4 dummy variable for reading in single precision
      REAL*4 RTGO4(LMOM,IM,JM)
      INTEGER I,J

C**** no output required for rsf files. Only acc files
      write(MODULE_HEADER(lhead+1:80),'(a,i2,a)')
     *     'R4 RTGO(',lmom,'im,jm)'

      SELECT CASE (IACTION)
      CASE (IOWRITE_SINGLE)     ! output to acc file
        WRITE (kunit,err=10) MODULE_HEADER,REAL(RTGO,KIND=4)
      CASE (IOREAD:)            ! input from restart file
        SELECT CASE (IACTION)
        CASE (ioread_single)    ! read in from acc file
          READ (kunit,err=10) HEADER,RTGO4
C**** sum RTGO over input files
          RTGO=RTGO+RTGO4
          IF (HEADER(1:LHEAD).NE.MODULE_HEADER(1:LHEAD)) THEN
            PRINT*,"Discrepancy in module version ",HEADER
     *           ,MODULE_HEADER
            GO TO 10
          END IF
        END SELECT
      END SELECT

      RETURN
 10   IOERR=1
      RETURN
C****
      END SUBROUTINE io_ocdiag

      SUBROUTINE reset_odiag(isum)
!@sum reset_odiag zeros out ocean diagnostics if needed
!@auth G. Schmidt
!@ver  1.0
      USE ODEEP_COM, only : rtgo
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: isum

C**** there is a confusion of definition for rtgo
C****   i) for the model run, it is the actual temperature anomaly
C****  ii) for post-processing, it is the accumulatated anomaly
C**** Thus it is only initiallised here for case ii).
      if (isum.eq.1) rtgo=0

      return
      end subroutine reset_odiag

      SUBROUTINE conserv_OCE(OCEANE)
!@sum  conserv_OCE calculates zonal ocean energy for Qflux ocean
!@auth Gavin Schmidt
!@ver  1.0
      USE CONSTANT, only : shw,rhows
      USE MODEL_COM, only : im,jm,fim,focean
      USE GEOM, only : imaxj
      USE STATIC_OCEAN, only : tocean,z1o,z12o
      USE ODEEP_COM, only : dz,rtgo,lmom
      IMPLICIT NONE
!@var OCEANE zonal ocean energy (J/M^2)
      REAL*8, DIMENSION(JM) :: OCEANE
      INTEGER I,J,L

      OCEANE=0
      DO J=1,JM
        DO I=1,IMAXJ(J)
          IF (FOCEAN(I,J).gt.0) THEN
            OCEANE(J)=OCEANE(J)+(TOCEAN(1,I,J)*Z1O(I,J)
     *           +TOCEAN(2,I,J)*(Z12O(I,J)-Z1O(I,J)))*SHW*RHOWS
            DO L=2,LMOM
              OCEANE(J)=OCEANE(J)+(RTGO(L,I,J)*DZ(L)*SHW*RHOWS)
            END DO
          END IF
        END DO
      END DO
      OCEANE(1) =FIM*OCEANE(1)
      OCEANE(JM)=FIM*OCEANE(JM)
C****
      END SUBROUTINE conserv_OCE

      SUBROUTINE ODIFS
!@sum  ODFIS calculates heat diffusion at the base of the mixed layer
!@+    compares that to the control run's temperature, calls odffus,
!@+    and reduces the upper ocean temperatures by the amount of heat
!@+    that is diffused into the thermocline
!@auth Gary Russell/G. Schmidt
!@ver  1.0
!@calls ODFFUS
      USE FILEMANAGER
      USE CONSTANT, only : sday
      USE MODEL_COM, only : im,jm,focean,jmon,jday,jdate,itocean
     *     ,itoice
      USE GEOM, only : imaxj
      USE ODEEP_COM, only : tg3m,rtgo,stg3,dtg3,edo,dz,dzo,bydzo,lmom
      USE SEAICE_COM, only : rsi
      USE DAGCOM, only : aj,j_ftherm
      USE FLUXES, only : gtemp
      USE STATIC_OCEAN, only : z12o,tocean
      IMPLICIT NONE
      REAL*8, PARAMETER :: PERDAY=1./365d0
!@param ALPHA degree of implicitness (1 fully implicit,0 fully explicit)
      REAL*8, PARAMETER :: ALPHA=.5d0
      REAL*8 :: ADTG3
      INTEGER I,J,L
C****
C**** ACCUMULATE OCEAN TEMPERATURE AT MAXIMUM MIXED LAYER
C****
      DO J=1,JM
        DO I=1,IMAXJ(J)
          STG3(I,J)=STG3(I,J)+TOCEAN(3,I,J)
        END DO
      END DO
C****
C**** AT THE END OF EACH MONTH, UPDATE THE OCEAN TEMPERATURE
C**** DIFFERENCE AND REPLACE THE MONTHLY SUMMED TEMPERATURE
C****
      IF(JDATE.EQ.1) THEN
      DO J=1,JM
        DO I=1,IMAXJ(J)
          DTG3(I,J)=DTG3(I,J)+(STG3(I,J)-TG3M(I,J,JMON))
          TG3M(I,J,JMON)=STG3(I,J)
          STG3(I,J)=0.
        END DO
      END DO
      END IF
C****
C**** DIFFUSE THE OCEAN TEMPERATURE DIFFERENCE OF THE UPPER LAYERS
C**** INTO THE THERMOCLINE AND REDUCE THE UPPER TEMPERATURES BY THE
C**** HEAT THAT IS DIFFUSED DOWNWARD
C****
      DO J=1,JM
        DO I=1,IMAXJ(J)
          IF(FOCEAN(I,J).GT.0.) THEN

            ADTG3=DTG3(I,J)*PERDAY
            RTGO(1,I,J)=ADTG3
C**** Set first layer thickness
            DZ(1)=Z12O(I,J)

            CALL ODFFUS (SDAY,ALPHA,EDO(I,J),DZ,BYDZO,RTGO(1,I,J),LMOM)

            DO L=1,3
              TOCEAN(L,I,J)=TOCEAN(L,I,J)+(RTGO(1,I,J)-ADTG3)
            END DO
            AJ(J,J_FTHERM,ITOCEAN)=AJ(J,J_FTHERM,ITOCEAN)-(RTGO(1,I,J)
     *           -ADTG3)*Z12O(I,J)*FOCEAN(I,J)*(1.-RSI(I,J))
            AJ(J,J_FTHERM,ITOICE )=AJ(J,J_FTHERM,ITOICE )-(RTGO(1,I,J)
     *           -ADTG3)*Z12O(I,J)*FOCEAN(I,J)*RSI(I,J)
            GTEMP(1:2,1,I,J) = TOCEAN(1:2,I,J)
          END IF
        END DO
      END DO

      RETURN
      END SUBROUTINE ODIFS

      SUBROUTINE ODFFUS (DT,ALPHA,ED,DZ,BYDZO,R,LMIJ)
!@sum  ODFFUS calculates the vertical mixing of a tracer
!@auth Gavin Schmidt/Gary Russell
!@ver  1.0
!@calls TRIDIAG
      IMPLICIT NONE
!@var LMIJ IS THE NUMBER OF VERTICAL LAYERS
      INTEGER, INTENT(IN) :: LMIJ
!@var ED diffusion coefficient between adjacent layers (m**2/s)
!@var ALPHA determines the time scheme (0 explicit,1 fully implicit)
!@var DT time step (s)
      REAL*8, INTENT(IN) :: ED,ALPHA,DT
!@var DZ the depth of the layers (m)
!@var BYDZO is the inverse of depth between layer centers (1/m)
      REAL*8, INTENT(IN) :: DZ(LMIJ),BYDZO(LMIJ-1)
!@var R tracer concentration
      REAL*8, INTENT(INOUT) :: R(LMIJ)

      REAL*8 AM(LMIJ),BM(LMIJ),CM(LMIJ),DM(LMIJ)
      INTEGER L
C**** SET UP TRIDIAGONAL MATRIX ENTRIES AND RIGHT HAND SIDE
      AM(1)=0
      BM(1)=DZ(1)+ALPHA*DT*ED*BYDZO(1)
      CM(1)=     -ALPHA*DT*ED*BYDZO(1)
      DM(1)=DZ(1)*R(1)-(1.-ALPHA)*DT*ED*(R(1)-R(2))*BYDZO(1)

      DO L=2,LMIJ-1
        AM(L)=     -ALPHA*DT* ED*BYDZO(L-1)
        BM(L)=DZ(L)+ALPHA*DT*(ED*BYDZO(L-1)+ED*BYDZO(L))
        CM(L)=     -ALPHA*DT*               ED*BYDZO(L)
        DM(L)=DZ(L)*R(L)+(1.-ALPHA)*DT*(ED*(R(L-1)-R(L))*BYDZO(L-1)
     *                                 -ED*(R(L)-R(L+1))*BYDZO(L))
      END DO

      AM(LMIJ)=        -ALPHA*DT*ED*BYDZO(LMIJ-1)
      BM(LMIJ)=DZ(LMIJ)+ALPHA*DT*ED*BYDZO(LMIJ-1)
      CM(LMIJ)=0.
      DM(LMIJ)=DZ(LMIJ)*R(LMIJ)+(1.-ALPHA)*DT*ED*
     *         (R(LMIJ-1)-R(LMIJ))*BYDZO(LMIJ-1)

      CALL TRIDIAG(AM,BM,CM,DM,R,LMIJ)

      RETURN
      END SUBROUTINE ODFFUS

      SUBROUTINE CHECKO(SUBR)
!@sum  CHECKO Checks whether deep ocean values are reasonable
!@auth Original Development Team
!@ver  1.0
      USE MODEL_COM, only : im,jm
      USE ODEEP_COM, only : lmom,stg3,dtg3,tg3m,rtgo
      USE STATIC_OCEAN, only : tocean
      IMPLICIT NONE

!@var SUBR identifies where CHECK was called from
      CHARACTER*6, INTENT(IN) :: SUBR
      LOGICAL QCHECKO
      INTEGER I,J

C**** Check for NaN/INF in ocean data
      CALL CHECK3(TOCEAN,3 ,IM,JM,SUBR,'toc')
      CALL CHECK3(DTG3  ,IM,JM, 1,SUBR,'dtg3')
      CALL CHECK3(TG3M  ,12,IM,JM,SUBR,'tg3m')
      CALL CHECK3(STG3  ,IM,JM,1 ,SUBR,'stg3')
      CALL CHECK3(RTGO,LMOM,IM,JM,SUBR,'rtgo')

      QCHECKO = .FALSE.
C**** Check for reasonable values for ocean variables
      DO J=1,JM
        DO I=1,IM
          IF (TOCEAN(1,I,J).lt.-2. .or. TOCEAN(1,I,J).gt.50.) THEN
            WRITE(6,*) 'After ',SUBR,': I,J,TOCEAN=',I,J,TOCEAN(1:3,I,J)
            QCHECKO = .TRUE.
          END IF
       END DO
      END DO
      IF (QCHECKO)
     *     call stop_model("CHECKO: Ocean variables out of bounds",255)

      END SUBROUTINE CHECKO

      SUBROUTINE diag_OCEAN
!@sum  diag_OCEAN prints out diagnostics for ocean
!@auth Gavin Schmidt
!@ver  1.0
      USE MODEL_COM, only : jm,lrunid,xlabel,idacc
      USE GEOM, only : imaxj,lat_dg
      USE ODEEP_COM, only : lmom,rtgo,dz
      USE DAGCOM, only : acc_period,qdiag,zoc
      IMPLICIT NONE
      CHARACTER LNAME*50,SNAME*30,UNITS*50
      INTEGER I,J,L
      REAL*8 ATGO(JM,LMOM),SCALED,ONES(JM)

C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED
      IF(QDIAG) call open_jl(trim(acc_period)//'.o'//XLABEL(1:LRUNID),
     *  jm,lmom,0,lat_dg)
      LNAME="Zonally averaged deep ocean temperature anomaly"
      SNAME="tgo_deep_anom"
      UNITS="DEGREES C"
C**** calculate zonal average
      DO L=1,LMOM
        DO J=1,JM
          ATGO(J,L)=0.
          DO I=1,IMAXJ(J)
            ATGO(J,L)=ATGO(J,L)+RTGO(L,I,J)
          END DO
        END DO
      END DO
C**** depths are calculated from base of the mixed layer
      ZOC(1)=0.
      DO L=2,LMOM
        ZOC(L)=ZOC(L-1)+DZ(L)
      END DO
      SCALED=1./IDACC(12)
      ONES(1:JM)=1.
C**** Print out a depth/latitude plot of the deep ocean temp anomaly
      CALL JLMAP(LNAME,SNAME,UNITS,1,ZOC,ATGO,SCALED,ONES,ONES,LMOM,2,1)
C****
      if(qdiag) call close_jl

      RETURN
      END SUBROUTINE diag_OCEAN


subroutine test_covariance()
  !! Tests the covariance subroutine, cov.f90.
  use statistics

  real, allocatable :: a(:)
  real, allocatable :: b(:)
  real, allocatable :: c(:)

  allocate(a(6))
  allocate(b(6))
  allocate(c(6))
  a = (/0, 1, 2, 3, 4, 5/)
  b = (/0, 10, 20, 30, 40, 50/)
  c = covariance(a,b)

end subroutine test_covariance


*> \brief \b DLAGSY
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, K, LDA, N
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       DOUBLE PRECISION   A( LDA, * ), D( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLAGSY generates a real symmetric matrix A, by pre- and post-
*> multiplying a real diagonal matrix D with a random orthogonal matrix:
*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
*> orthogonal transformations.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>          The number of nonzero subdiagonals within the band of A.
*>          0 <= K <= N-1.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The diagonal elements of the diagonal matrix D.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          The generated n by n symmetric matrix A (the full matrix is
*>          stored).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= N.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry, the seed of the random number generator; the array
*>          elements must be between 0 and 4095, and ISEED(4) must be
*>          odd.
*>          On exit, the seed is updated.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_matgen
*
*  =====================================================================
      SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   A( LDA, * ), D( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   ALPHA, TAU, WA, WB, WN
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DGEMV, DGER, DLARNV, DSCAL, DSYMV,
     $                   DSYR2, XERBLA
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DDOT, DNRM2
      EXTERNAL           DDOT, DNRM2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SIGN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'DLAGSY', -INFO )
         RETURN
      END IF
*
*     initialize lower triangle of A to diagonal matrix
*
      DO 20 J = 1, N
         DO 10 I = J + 1, N
            A( I, J ) = ZERO
   10    CONTINUE
   20 CONTINUE
      DO 30 I = 1, N
         A( I, I ) = D( I )
   30 CONTINUE
*
*     Generate lower triangle of symmetric matrix
*
      DO 40 I = N - 1, 1, -1
*
*        generate random reflection
*
         CALL DLARNV( 3, ISEED, N-I+1, WORK )
         WN = DNRM2( N-I+1, WORK, 1 )
         WA = SIGN( WN, WORK( 1 ) )
         IF( WN.EQ.ZERO ) THEN
            TAU = ZERO
         ELSE
            WB = WORK( 1 ) + WA
            CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
            WORK( 1 ) = ONE
            TAU = WB / WA
         END IF
*
*        apply random reflection to A(i:n,i:n) from the left
*        and the right
*
*        compute  y := tau * A * u
*
         CALL DSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
     $               WORK( N+1 ), 1 )
*
*        compute  v := y - 1/2 * tau * ( y, u ) * u
*
         ALPHA = -HALF*TAU*DDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 )
         CALL DAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
*
*        apply the transformation as a rank-2 update to A(i:n,i:n)
*
         CALL DSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
     $               A( I, I ), LDA )
   40 CONTINUE
*
*     Reduce number of subdiagonals to K
*
      DO 60 I = 1, N - 1 - K
*
*        generate reflection to annihilate A(k+i+1:n,i)
*
         WN = DNRM2( N-K-I+1, A( K+I, I ), 1 )
         WA = SIGN( WN, A( K+I, I ) )
         IF( WN.EQ.ZERO ) THEN
            TAU = ZERO
         ELSE
            WB = A( K+I, I ) + WA
            CALL DSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
            A( K+I, I ) = ONE
            TAU = WB / WA
         END IF
*
*        apply reflection to A(k+i:n,i+1:k+i-1) from the left
*
         CALL DGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA,
     $               A( K+I, I ), 1, ZERO, WORK, 1 )
         CALL DGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
     $              A( K+I, I+1 ), LDA )
*
*        apply reflection to A(k+i:n,k+i:n) from the left and the right
*
*        compute  y := tau * A * u
*
         CALL DSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
     $               A( K+I, I ), 1, ZERO, WORK, 1 )
*
*        compute  v := y - 1/2 * tau * ( y, u ) * u
*
         ALPHA = -HALF*TAU*DDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 )
         CALL DAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
*
*        apply symmetric rank-2 update to A(k+i:n,k+i:n)
*
         CALL DSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
     $               A( K+I, K+I ), LDA )
*
         A( K+I, I ) = -WA
         DO 50 J = K + I + 1, N
            A( J, I ) = ZERO
   50    CONTINUE
   60 CONTINUE
*
*     Store full symmetric matrix
*
      DO 80 J = 1, N
         DO 70 I = J + 1, N
            A( J, I ) = A( I, J )
   70    CONTINUE
   80 CONTINUE
      RETURN
*
*     End of DLAGSY
*
      END


      SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B,
     $                   LDB, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute one of the matrix products
C
C        B = alpha*op( H ) * A, or B = alpha*A * op( H ),
C
C     where alpha is a scalar, A and B are m-by-n matrices, H is an
C     upper Hessenberg matrix, and op( H ) is one of
C
C        op( H ) = H   or   op( H ) = H',  the transpose of H.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether the Hessenberg matrix H appears on the
C             left or right in the matrix product as follows:
C             = 'L':  B = alpha*op( H ) * A;
C             = 'R':  B = alpha*A * op( H ).
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( H ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( H ) = H;
C             = 'T':  op( H ) = H';
C             = 'C':  op( H ) = H'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices A and B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices A and B.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then H is not
C             referenced and A need not be set before entry.
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,k)
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C             On entry with SIDE = 'L', the leading M-by-M upper
C             Hessenberg part of this array must contain the upper
C             Hessenberg matrix H.
C             On entry with SIDE = 'R', the leading N-by-N upper
C             Hessenberg part of this array must contain the upper
C             Hessenberg matrix H.
C             The elements below the subdiagonal are not referenced,
C             except possibly for those in the first column, which
C             could be overwritten, but are restored on exit.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,k),
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading M-by-N part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,N)
C             The leading M-by-N part of this array contains the
C             computed product.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,M).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The required matrix product is computed in two steps. In the first
C     step, the upper triangle of H is used; in the second step, the
C     contribution of the subdiagonal is added. A fast BLAS 3 DTRMM
C     operation is used in the first step.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, January 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS
      INTEGER           INFO, LDA, LDB, LDH, M, N
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), H(LDH,*)
C     .. Local Scalars ..
      LOGICAL           LSIDE, LTRANS
      INTEGER           I, J
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DLACPY, DLASET, DSWAP, DTRMM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LSIDE  = LSAME( SIDE,  'L' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LSIDE  ).AND.( .NOT.LSAME( SIDE,  'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR.
     $                  ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01UD', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF ( MIN( M, N ).EQ.0 )
     $   RETURN
C
      IF( ALPHA.EQ.ZERO ) THEN
C
C        Set B to zero and return.
C
         CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB )
         RETURN
      END IF
C
C     Copy A in B and compute one of the matrix products
C       B = alpha*op( triu( H ) ) * A, or
C       B = alpha*A * op( triu( H ) ),
C     involving the upper triangle of H.
C
      CALL DLACPY( 'Full', M, N, A, LDA, B, LDB )
      CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H,
     $            LDH, B, LDB )
C
C     Add the contribution of the subdiagonal of H.
C     If SIDE = 'L', the subdiagonal of H is swapped with the
C     corresponding elements in the first column of H, and the
C     calculations are organized for column operations.
C
      IF( LSIDE ) THEN
         IF( M.GT.2 )
     $      CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
         IF( LTRANS ) THEN
            DO 20 J = 1, N
               DO 10 I = 1, M - 1
                  B( I, J ) = B( I, J ) + ALPHA*H( I+1, 1 )*A( I+1, J )
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40 J = 1, N
               DO 30 I = 2, M
                  B( I, J ) = B( I, J ) + ALPHA*H( I, 1 )*A( I-1, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         IF( M.GT.2 )
     $      CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
      ELSE
C
         IF( LTRANS ) THEN
            DO 50 J = 1, N - 1
               IF ( H( J+1, J ).NE.ZERO )
     $            CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J ), 1,
     $                        B( 1, J+1 ), 1 )
   50       CONTINUE
         ELSE
            DO 60 J = 1, N - 1
               IF ( H( J+1, J ).NE.ZERO )
     $            CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J+1 ), 1,
     $                        B( 1, J ), 1 )
   60       CONTINUE
         END IF
      END IF
C
      RETURN
C *** Last line of MB01UD ***
      END


! ##################################################################################################################################

      MODULE LAPACK_LIN_EQN_DPB

      USE PENTIUM_II_KIND, ONLY          :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                   :  ERR, F04, F06, WRT_LOG
      USE SCONTR, ONLY                   :  BLNK_SUB_NAM
      USE TIMDAT, ONLY                   :  HOUR, MINUTE, SEC,
     &                                      SFRAC, TSEC
      USE SUBR_BEGEND_LEVELS, ONLY       :  LAPACK_BEGEND
      USE LAPACK_BLAS_AUX

      character(1*byte), parameter      :: cr13_dpb = char(13)

      INTEGER(LONG), PARAMETER, PRIVATE :: SUBR_BEGEND = LAPACK_BEGEND

! This is the set of LAPACK routines for solving equations

!                             Ax = B

! where matrix A is a dbl prec symmetric banded matrix.
! Matrix A is decomposed into an upper triangular matrix U such that:

!                         A = U(transp)*U

! This module contains:

!     DPBEQU to equilize A by scaling using diagonals of A

!     DPBTRF to do the factorization of A by calling

!         DPBTF2 if A is unblocked to do factorization of A, or

!         DPOTF2 if A is blocked   to do factorization of A

!     DPBCON to calculate the condition number of A, given it's triangular factors

!     DPBTRS to get the solution for x given the triangular factors of A

! In addition, files in module LAPACK_BLAS_AUX are also used

      CONTAINS

! ##################################################################################################################################
! 001 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBEQU'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
      REAL(DOUBLE)   AMAX, SCOND
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   AB( LDAB, * ), S( * )
*     ..
*
*  Purpose
*  =======
*
*  DPBEQU computes row and column scalings intended to equilibrate a
*  symmetric positive definite band matrix A and reduce its condition
*  number (with respect to the two-norm).  S contains the scale factors,
*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
*  choice of S puts the condition number of B within a factor N of the
*  smallest possible condition number over all possible diagonal
*  scalings.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangular of A is stored;
*          = 'L':  Lower triangular of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  AB      (input) REAL(DOUBLE) array, dimension (LDAB,N)
*          The upper or lower triangle of the symmetric band matrix A,
*          stored in the first KD+1 rows of the array.  The j-th column
*          of A is stored in the j-th column of the array AB as follows:
*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*
*  LDAB     (input) INTEGER
*          The leading dimension of the array A.  LDAB >= KD+1.
*
*  S       (output) REAL(DOUBLE) array, dimension (N)
*          If INFO = 0, S contains the scale factors for A.
*
*  SCOND   (output) REAL(DOUBLE)
*          If INFO = 0, S contains the ratio of the smallest S(i) to
*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
*          large nor too small, it is not worth scaling by S.
*
*  AMAX    (output) REAL(DOUBLE)
*          Absolute value of largest matrix element.  If AMAX is very
*          close to overflow or very close to underflow, the matrix
*          should be scaled.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, J
      REAL(DOUBLE)   SMIN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N < 0 ) THEN
         INFO = -2
      ELSE IF( KD < 0 ) THEN
         INFO = -3
      ELSE IF( LDAB < KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO /= 0 ) THEN
         CALL XERBLA( 'DPBEQU', -INFO )
         go to 9000          ! My line
      END IF
*
*     Quick return if possible
*
      IF( N == 0 ) THEN
         SCOND = ONE
         AMAX = ZERO
         go to 9000          ! My line
      END IF
*
      IF( UPPER ) THEN
         J = KD + 1
      ELSE
         J = 1
      END IF
*
*     Initialize SMIN and AMAX.
*
      S( 1 ) = AB( J, 1 )
      SMIN = S( 1 )
      AMAX = S( 1 )
*
*     Find the minimum and maximum diagonal elements.
*
      DO 10 I = 2, N
         S( I ) = AB( J, I )
         SMIN = MIN( SMIN, S( I ) )
         AMAX = MAX( AMAX, S( I ) )
   10 CONTINUE
*
      IF( SMIN <= ZERO ) THEN
*
*        Find the first non-positive diagonal element and return.
*
         DO 20 I = 1, N
            IF( S( I ) <= ZERO ) THEN
               INFO = I
               go to 9000          ! My line
            END IF
   20    CONTINUE
      ELSE
*
*        Set the scale factors to the reciprocals
*        of the diagonal elements.
*
         DO 30 I = 1, N
            S( I ) = ONE / SQRT( S( I ) )
   30    CONTINUE
*
*        Compute SCOND = min(S(I)) / max(S(I))
*
         SCOND = SQRT( SMIN ) / SQRT( AMAX )
      END IF
      go to 9000          ! My line
*
*     End of DPBEQU
*
! **********************************************************************************************************************************
 9000 continue
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE DPBEQU

! ##################################################################################################################################
! 002 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBTRF'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   AB( LDAB, * )
*     ..
*
*  Purpose
*  =======
*
*  DPBTRF computes the Cholesky factorization of a real symmetric
*  positive definite band matrix A.
*
*  The factorization has the form
*     A = U**T * U,  if UPLO = 'U', or
*     A = L  * L**T,  if UPLO = 'L',
*  where U is an upper triangular matrix and L is lower triangular.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  AB      (input/output) REAL(DOUBLE) array, dimension (LDAB,N)
*          On entry, the upper or lower triangle of the symmetric band
*          matrix A, stored in the first KD+1 rows of the array.  The
*          j-th column of A is stored in the j-th column of the array AB
*          as follows:
*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*
*          On exit, if INFO = 0, the triangular factor U or L from the
*          Cholesky factorization A = U**T*U or A = L*L**T of the band
*          matrix A, in the same storage format as A.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the leading minor of order i is not
*                positive definite, and the factorization could not be
*                completed.
*
*  iblock  (local) INTEGER
*          Block number that the calling program (DPBTRF) is working on
*
*  numblk  (local) INTEGER
*          Total number of diagonal blocks that the calling program
*          (DPBTRF) has to work on
*
*  Further Details
*  ===============
*
*  The band storage scheme is illustrated by the following example, when
*  N = 6, KD = 2, and UPLO = 'U':
*
*  On entry:                       On exit:
*
*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*
*  Similarly, if UPLO = 'L' the format of A is as follows:
*
*  On entry:                       On exit:
*
*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
*
*  Array elements marked * are not used by the routine.
*
*  Contributed by
*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
*
*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            NBMAX, LDWORK
      PARAMETER          ( NBMAX = 32, LDWORK = NBMAX+1 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I2, I3, IB, II, J, JJ, NB, iblock
     &                 , numblk
*     ..
*     .. Local Arrays ..
      REAL(DOUBLE)   WORK( LDWORK, NBMAX )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME

      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     ..
*     .. Executable Statements ..
*
! **********************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************
*     Test the input parameters.
*
      INFO = 0
      IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
     $    ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -1
      ELSE IF( N < 0 ) THEN
         INFO = -2
      ELSE IF( KD < 0 ) THEN
         INFO = -3
      ELSE IF( LDAB < KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO /= 0 ) THEN
         CALL XERBLA( 'DPBTRF', -INFO )
         go to 9000          ! My line
      END IF
*
*     Quick return if possible
*
      IF( N == 0 )
     &   go to 9000          ! My line
*
*     Determine the block size for this environment
*
      NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 )
*
*     The block size must not exceed the semi-bandwidth KD, and must not
*     exceed the limit set by the size of the local array WORK.
*
      NB = MIN( NB, NBMAX )
*
      IF( NB <= 1 .OR. NB > KD ) THEN
*
*        Use unblocked code
*
         CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
      ELSE
*
*        Use blocked code
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           Compute the Cholesky factorization of a symmetric band
*           matrix, given the upper triangle of the matrix in band
*           storage.
*
*           Zero the upper triangle of the work array.
*
            DO 20 J = 1, NB
               DO 10 I = 1, J - 1
                  WORK( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
*
*           Process the band matrix one diagonal block at a time.
*
            numblk = int(n/nb) + 1
            iblock = 0
            WRITE (*,*)
            DO 70 I = 1, N, NB
               iblock = iblock + 1
               IB = MIN( NB, N-I+1 )
*
*              Factorize the diagonal block
*
               write(sc1,12345,advance='no') iblock,numblk,ib,cr13_dpb
               CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
               IF( II /= 0 ) THEN
                  INFO = I + II - 1
                  GO TO 150
               END IF
               IF( I+IB <= N ) THEN
*
*                 Update the relevant part of the trailing submatrix.
*                 If A11 denotes the diagonal block which has just been
*                 factorized, then we need to update the remaining
*                 blocks in the diagram:
*
*                    A11   A12   A13
*                          A22   A23
*                                A33
*
*                 The numbers of rows and columns in the partitioning
*                 are IB, I2, I3 respectively. The blocks A12, A22 and
*                 A23 are empty if IB = KD. The upper triangle of A13
*                 lies outside the band.
*
                  I2 = MIN( KD-IB, N-I-IB+1 )
                  I3 = MIN( IB, N-I-KD+1 )
*
                  IF( I2 > 0 ) THEN
*
*                    Update A12
*
                     CALL DTRSM( 'Left', 'Upper', 'Transpose',
     $                           'Non-unit', IB, I2, ONE, AB( KD+1, I ),
     $                           LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
*
*                    Update A22
*
                     CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
     $                           AB( KD+1-IB, I+IB ), LDAB-1, ONE,
     $                           AB( KD+1, I+IB ), LDAB-1 )
                  END IF
*
                  IF( I3 > 0 ) THEN
*
*                    Copy the lower triangle of A13 into the work array.
*
                     DO 40 JJ = 1, I3
                        DO 30 II = JJ, IB
                           WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
   30                   CONTINUE
   40                CONTINUE
*
*                    Update A13 (in the work array).
*
                     CALL DTRSM( 'Left', 'Upper', 'Transpose',
     $                           'Non-unit', IB, I3, ONE, AB( KD+1, I ),
     $                           LDAB-1, WORK, LDWORK )
*
*                    Update A23
*
                     IF( I2 > 0 )
     $                  CALL DGEMM( 'Transpose', 'No Transpose', I2, I3,
     $                              IB, -ONE, AB( KD+1-IB, I+IB ),
     $                              LDAB-1, WORK, LDWORK, ONE,
     $                              AB( 1+IB, I+KD ), LDAB-1 )
*
*                    Update A33
*
                     CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
     $                           WORK, LDWORK, ONE, AB( KD+1, I+KD ),
     $                           LDAB-1 )
*
*                    Copy the lower triangle of A13 back into place.
*
                     DO 60 JJ = 1, I3
                        DO 50 II = JJ, IB
                           AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
   50                   CONTINUE
   60                CONTINUE
                  END IF
               END IF
   70       CONTINUE
         ELSE
*
*           Compute the Cholesky factorization of a symmetric band
*           matrix, given the lower triangle of the matrix in band
*           storage.
*
*           Zero the lower triangle of the work array.
*
            DO 90 J = 1, NB
               DO 80 I = J + 1, NB
                  WORK( I, J ) = ZERO
   80          CONTINUE
   90       CONTINUE
*
*           Process the band matrix one diagonal block at a time.
*
            numblk = int(n/nb) + 1
            iblock = 0
            WRITE (*,*)
            DO 140 I = 1, N, NB
               iblock = iblock + 1
               IB = MIN( NB, N-I+1 )
*
*              Factorize the diagonal block
*
               write(sc1,12345,advance='no') iblock,numblk,ib,cr13_dpb
               CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
               IF( II /= 0 ) THEN
                  INFO = I + II - 1
                  GO TO 150
               END IF
               IF( I+IB <= N ) THEN
*
*                 Update the relevant part of the trailing submatrix.
*                 If A11 denotes the diagonal block which has just been
*                 factorized, then we need to update the remaining
*                 blocks in the diagram:
*
*                    A11
*                    A21   A22
*                    A31   A32   A33
*
*                 The numbers of rows and columns in the partitioning
*                 are IB, I2, I3 respectively. The blocks A21, A22 and
*                 A32 are empty if IB = KD. The lower triangle of A31
*                 lies outside the band.
*
                  I2 = MIN( KD-IB, N-I-IB+1 )
                  I3 = MIN( IB, N-I-KD+1 )
*
                  IF( I2 > 0 ) THEN
*
*                    Update A21
*
                     CALL DTRSM( 'Right', 'Lower', 'Transpose',
     $                           'Non-unit', I2, IB, ONE, AB( 1, I ),
     $                           LDAB-1, AB( 1+IB, I ), LDAB-1 )
*
*                    Update A22
*
                     CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
     $                           AB( 1+IB, I ), LDAB-1, ONE,
     $                           AB( 1, I+IB ), LDAB-1 )
                  END IF
*
                  IF( I3 > 0 ) THEN
*
*                    Copy the upper triangle of A31 into the work array.
*
                     DO 110 JJ = 1, IB
                        DO 100 II = 1, MIN( JJ, I3 )
                           WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
  100                   CONTINUE
  110                CONTINUE
*
*                    Update A31 (in the work array).
*
                     CALL DTRSM( 'Right', 'Lower', 'Transpose',
     $                           'Non-unit', I3, IB, ONE, AB( 1, I ),
     $                           LDAB-1, WORK, LDWORK )
*
*                    Update A32
*
                     IF( I2 > 0 )
     $                  CALL DGEMM( 'No transpose', 'Transpose', I3, I2,
     $                              IB, -ONE, WORK, LDWORK,
     $                              AB( 1+IB, I ), LDAB-1, ONE,
     $                              AB( 1+KD-IB, I+IB ), LDAB-1 )
*
*                    Update A33
*
                     CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
     $                           WORK, LDWORK, ONE, AB( 1, I+KD ),
     $                           LDAB-1 )
*
*                    Copy the upper triangle of A31 back into place.
*
                     DO 130 JJ = 1, IB
                        DO 120 II = 1, MIN( JJ, I3 )
                           AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
  120                   CONTINUE
  130                CONTINUE
                  END IF
               END IF
  140       CONTINUE
         END IF
      END IF
      go to 9000          ! My line
*
  150 CONTINUE
      go to 9000          ! My line
*
12345 format(5X,'Block ',i8,' of ',i8,'. Factoring rows 1 thru: ',i8,a)

*     End of DPBTRF
*
! **********************************************************************************************************************************
 9000 continue            ! My lines
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE DPBTRF

! ##################################################################################################################################
! 003 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBTF2'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   AB( LDAB, * )
*     ..
*
*  Purpose
*  =======
*
*  DPBTF2 computes the Cholesky factorization of a real symmetric
*  positive definite band matrix A.
*
*  The factorization has the form
*     A = U' * U ,  if UPLO = 'U', or
*     A = L  * L',  if UPLO = 'L',
*  where U is an upper triangular matrix, U' is the transpose of U, and
*  L is lower triangular.
*
*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          symmetric matrix A is stored:
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of super-diagonals of the matrix A if UPLO = 'U',
*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
*
*  AB      (input/output) REAL(DOUBLE) array, dimension (LDAB,N)
*          On entry, the upper or lower triangle of the symmetric band
*          matrix A, stored in the first KD+1 rows of the array.  The
*          j-th column of A is stored in the j-th column of the array AB
*          as follows:
*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*
*          On exit, if INFO = 0, the triangular factor U or L from the
*          Cholesky factorization A = U'*U or A = L*L' of the band
*          matrix A, in the same storage format as A.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, the leading minor of order k is not
*               positive definite, and the factorization could not be
*               completed.
*
*  Further Details
*  ===============
*
*  The band storage scheme is illustrated by the following example, when
*  N = 6, KD = 2, and UPLO = 'U':
*
*  On entry:                       On exit:
*
*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*
*  Similarly, if UPLO = 'L' the format of A is as follows:
*
*  On entry:                       On exit:
*
*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
*
*  Array elements marked * are not used by the routine.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            i,J, KLD, KN
      REAL(DOUBLE)   AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N < 0 ) THEN
         INFO = -2
      ELSE IF( KD < 0 ) THEN
         INFO = -3
      ELSE IF( LDAB < KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO /= 0 ) THEN
         CALL XERBLA( 'DPBTF2', -INFO )
         go to 9000          ! My line
      END IF
*
*     Quick return if possible
*
      IF( N == 0 )
     &   go to 9000          ! My line
*
      KLD = MAX( 1, LDAB-1 )
*
      IF( UPPER ) THEN
*
*        Compute the Cholesky factorization A = U'*U.
*
         WRITE(SC1,*)
         DO 10 J = 1, N
            write(sc1,12345,advance='no') j,n,cr13_dpb
*
*           Compute U(J,J) and test for non-positive-definiteness.
*
            AJJ = AB( KD+1, J )
            IF( AJJ <= ZERO ) THEN
               GO TO 30
            ENDIF
            AJJ = SQRT( AJJ )
            AB( KD+1, J ) = AJJ
*
*           Compute elements J+1:J+KN of row J and update the
*           trailing submatrix within the band.
*
            KN = MIN( KD, N-J )
            IF( KN > 0 ) THEN
               CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
               CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
     $                    AB( KD+1, J+1 ), KLD )
            END IF
   10    CONTINUE
      ELSE
*
*        Compute the Cholesky factorization A = L*L'.
*
         WRITE(SC1,*)
         DO 20 J = 1, N
            write(sc1,12345,advance='no') j,n,cr13_dpb
*
*           Compute L(J,J) and test for non-positive-definiteness.
*
            AJJ = AB( 1, J )
            IF( AJJ <= ZERO )
     $         GO TO 30
            AJJ = SQRT( AJJ )
            AB( 1, J ) = AJJ
*
*           Compute elements J+1:J+KN of column J and update the
*           trailing submatrix within the band.
*
            KN = MIN( KD, N-J )
            IF( KN > 0 ) THEN
               CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
               CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1,
     $                    AB( 1, J+1 ), KLD )
            END IF
   20    CONTINUE
      END IF
      go to 9000             ! My line
*
   30 CONTINUE
      INFO = J
      go to 9000          ! My line
*
12345 format(5x,'DPBTF2: Unblocked code. Factoring row ',i8,' of ',i8,a)

*     End of DPBTF2
*
! **********************************************************************************************************************************
 9000 continue            ! My lines
      IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE DPBTF2

! ##################################################################################################################################
! 004 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPOTF2'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DPOTF2 computes the Cholesky factorization of a real symmetric
*  positive definite matrix A.
*
*  The factorization has the form
*     A = U' * U ,  if UPLO = 'U', or
*     A = L  * L',  if UPLO = 'L',
*  where U is an upper triangular matrix and L is lower triangular.
*
*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          symmetric matrix A is stored.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) REAL(DOUBLE) array, dimension (LDA,N)
*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
*          n by n upper triangular part of A contains the upper
*          triangular part of the matrix A, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading n by n lower triangular part of A contains the lower
*          triangular part of the matrix A, and the strictly upper
*          triangular part of A is not referenced.
*
*          On exit, if INFO = 0, the factor U or L from the Cholesky
*          factorization A = U'*U  or A = L*L'.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, the leading minor of order k is not
*               positive definite, and the factorization could not be
*               completed.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J
      REAL(DOUBLE)   AJJ,dda
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
*     ..
*     .. Executable Statements ..
*
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N < 0 ) THEN
         INFO = -2
      ELSE IF( LDA < MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO /= 0 ) THEN
         CALL XERBLA( 'DPOTF2', -INFO )
         go to 9000          ! My line
      END IF
*
*     Quick return if possible
*
      IF( N == 0 )
     &   go to 9000          ! My line
*
      IF( UPPER ) THEN
*
*        Compute the Cholesky factorization A = U'*U.
*
         DO 10 J = 1, N
*
*           Compute U(J,J) and test for non-positive-definiteness.
*
            AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
            IF( AJJ <= ZERO ) THEN
               AJJ = ONE
               A( J, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            A( J, J ) = AJJ
*
*           Compute elements J+1:N of row J.
*
            IF( J < N ) THEN
               CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
     $                     LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
               CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
            END IF
   10    CONTINUE
      ELSE
*
*        Compute the Cholesky factorization A = L*L'.
*
         DO 20 J = 1, N
*
*           Compute L(J,J) and test for non-positive-definiteness.
*
            AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ),
     $            LDA )
            IF( AJJ <= ZERO ) THEN
               A( J, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            A( J, J ) = AJJ
*
*           Compute elements J+1:N of column J.
*
            IF( J < N ) THEN
               CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
     $                     LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
               CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
      GO TO 40
*
   30 CONTINUE
      INFO = J
*
   40 CONTINUE
*
*     End of DPOTF2
*
! **********************************************************************************************************************************
 9000 continue            ! My lines
      IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE DPOTF2

! ##################################################################################################################################
! 005 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK,
     $                   IWORK, INFO, itmax, dtbsv_msg )

!                             I added itmax, dtbsv_msg

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBCON'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      character*1        dtbsv_msg
      INTEGER            INFO, KD, LDAB, N
      REAL(DOUBLE)   ANORM, RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL(DOUBLE)   AB( LDAB, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DPBCON estimates the reciprocal of the condition number (in the
*  1-norm) of a real symmetric positive definite band matrix using the
*  Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
*
*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangular factor stored in AB;
*          = 'L':  Lower triangular factor stored in AB.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  AB      (input) REAL(DOUBLE) array, dimension (LDAB,N)
*          The triangular factor U or L from the Cholesky factorization
*          A = U**T*U or A = L*L**T of the band matrix A, stored in the
*          first KD+1 rows of the array.  The j-th column of U or L is
*          stored in the j-th column of the array AB as follows:
*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  ANORM   (input) REAL(DOUBLE)
*          The 1-norm (or infinity-norm) of the symmetric band matrix A.
*
*  RCOND   (output) REAL(DOUBLE)
*          The reciprocal of the condition number of the matrix A,
*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
*          estimate of the 1-norm of inv(A) computed in this routine.
*
*  WORK    (workspace) REAL(DOUBLE) array, dimension (3*N)
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
!  dtbsv_msg (input) CHARACTER
!           = 'Y', have subr DTBSV print Fwd, Back pass messages

*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      CHARACTER          NORMIN
      CHARACTER*48       MODNAM
      INTEGER            IX, KASE
      integer            iter_num, itmax
      REAL(DOUBLE)   AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME

      REAL(DOUBLE)       DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N < 0 ) THEN
         INFO = -2
      ELSE IF( KD < 0 ) THEN
         INFO = -3
      ELSE IF( LDAB < KD+1 ) THEN
         INFO = -5
      ELSE IF( ANORM < ZERO ) THEN
         INFO = -6
      END IF
      IF( INFO /= 0 ) THEN
         CALL XERBLA( 'DPBCON', -INFO )
         go to 9000          ! My line
      END IF
*
*     Quick return if possible
*
      RCOND = ZERO
      IF( N == 0 ) THEN
         RCOND = ONE
         go to 9000          ! My line
      ELSE IF( ANORM == ZERO ) THEN
         go to 9000          ! My line
      END IF
*
      SMLNUM = DLAMCH( 'Safe minimum' )
*
*     Estimate the 1-norm of the inverse.
*
      KASE = 0
      iter_num = 0
      NORMIN = 'N'
   10 CONTINUE
      iter_num = iter_num + 1
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, itmax )! my ITMAX
      IF( KASE /= 0 ) THEN
         IF( UPPER ) THEN
*
*           Multiply by inv(U').
*
            CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
     $                   KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
     $                   INFO, iter_num, dtbsv_msg )
            NORMIN = 'Y'
*
*           Multiply by inv(U).
*
            CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
     $                   KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
     $                   INFO, iter_num, dtbsv_msg )
         ELSE
*
*           Multiply by inv(L).
*
            CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
     $                   KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
     $                   INFO, iter_num, dtbsv_msg )
            NORMIN = 'Y'
*
*           Multiply by inv(L').
*
            CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
     $                   KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
     $                   INFO, iter_num, dtbsv_msg )
         END IF
*
*        Multiply by 1/SCALE if doing so will not cause overflow.
*
         SCALE = SCALEL*SCALEU
         IF( SCALE /= ONE ) THEN
            IX = IDAMAX( N, WORK, 1 )
            IF( SCALE < ABS( WORK( IX ) )*SMLNUM .OR. SCALE == ZERO )
     $         GO TO 20
            CALL DRSCL( N, SCALE, WORK, 1 )
         END IF
         GO TO 10
      END IF
*
*     Compute the estimate of the reciprocal condition number.
*
      IF( AINVNM /= ZERO )
     $   RCOND = ( ONE / AINVNM ) / ANORM
*
   20 CONTINUE
*
      go to 9000          ! My line
*
*     End of DPBCON
*
! **********************************************************************************************************************************
 9000 continue            ! My lines
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE DPBCON

! ##################################################################################################################################
! 006 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO,
     &                   dtbsv_msg )     ! my addition

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBTRS'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      character*1        dtbsv_msg
      INTEGER            INFO, KD, LDAB, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   AB( LDAB, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DPBTRS solves a system of linear equations A*X = B with a symmetric
*  positive definite band matrix A using the Cholesky factorization
*  A = U**T*U or A = L*L**T computed by DPBTRF.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangular factor stored in AB;
*          = 'L':  Lower triangular factor stored in AB.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  AB      (input) REAL(DOUBLE) array, dimension (LDAB,N)
*          The triangular factor U or L from the Cholesky factorization
*          A = U**T*U or A = L*L**T of the band matrix A, stored in the
*          first KD+1 rows of the array.  The j-th column of U or L is
*          stored in the j-th column of the array AB as follows:
*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  B       (input/output) REAL(DOUBLE) array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
!  dtbsv_msg (input) CHARACTER
!           = 'Y', have subr DTBSV print Fwd, Back pass messages

*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N < 0 ) THEN
         INFO = -2
      ELSE IF( KD < 0 ) THEN
         INFO = -3
      ELSE IF( NRHS < 0 ) THEN
         INFO = -4
      ELSE IF( LDAB < KD+1 ) THEN
         INFO = -6
      ELSE IF( LDB < MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO /= 0 ) THEN
         CALL XERBLA( 'DPBTRS', -INFO )
         go to 9000          ! My line
      END IF
*
*     Quick return if possible
*
      IF( N == 0 .OR. NRHS == 0 )
     &   go to 9000          ! My line
*
      IF( UPPER ) THEN
*
*        Solve A*X = B where A = U'*U.
*
         DO 10 J = 1, NRHS
            write(f06,*) 'In DPBTRS calling DTBSV with j = ',j
*
*           Solve U'*X = B, overwriting B with X.
*
            CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB,
     $                  LDAB, B( 1, J ), 1, dtbsv_msg )
*
*           Solve U*X = B, overwriting B with X.
*
            CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
     $                  LDAB, B( 1, J ), 1, dtbsv_msg )
   10    CONTINUE
      ELSE
*
*        Solve A*X = B where A = L*L'.
*
         DO 20 J = 1, NRHS
*
*           Solve L*X = B, overwriting B with X.
*
            CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
     $                  LDAB, B( 1, J ), 1, dtbsv_msg )
*
*           Solve L'*X = B, overwriting B with X.
*
            CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB,
     $                  LDAB, B( 1, J ), 1, dtbsv_msg )
   20    CONTINUE
      END IF
*
      go to 9000          ! My line
*
*     End of DPBTRS
*
! **********************************************************************************************************************************
 9000 continue            ! My lines
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
98711 FORMAT(' ido = ',I3,', ipntr(1) = ',I8,', ipntr(2) = ',I8)

98712 FORMAT(' I, AB,  B      = ',I8,2(1ES15.6))

      END SUBROUTINE DPBTRS

! ##################################################################################################################################
! 007 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DPTTRF_MYSTRAN( N, D, E, INFO )

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPTTRF'

!  This is my mod of LAPACK subr DPTTRF. I have changed the statements:

!      IF( D( I ).LE.ZERO ) THEN
!  to
!      IF( D( I ).EQ.ZERO ) THEN

!  in order to allow the subr to get the LDL decomp when diag elements
!  are neqative. I need this in LINK4 for subr EST_NUMBER_OF_EIGENS
!  which needs a count of the number of diag terms < 0 in order to
!  estimate the number of eigens less than a specified value.

*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   D( * ), E( * )
*     ..
*
*  Purpose
*  =======
*
*  DPTTRF computes the L*D*L' factorization of a real symmetric
*  positive definite tridiagonal matrix A.  The factorization may also
*  be regarded as having the form A = U'*D*U.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the n diagonal elements of the tridiagonal matrix
*          A.  On exit, the n diagonal elements of the diagonal matrix
*          D from the L*D*L' factorization of A.
*
*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, the (n-1) subdiagonal elements of the tridiagonal
*          matrix A.  On exit, the (n-1) subdiagonal elements of the
*          unit bidiagonal factor L from the L*D*L' factorization of A.
*          E can also be regarded as the superdiagonal of the unit
*          bidiagonal factor U from the U'*D*U factorization of A.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, the leading minor of order k is not
*               positive definite; if k < N, the factorization could not
*               be completed, while if k = N, the factorization was
*               completed, but D(N) <= 0.
**
*     .. Parameters ..
      REAL(DOUBLE)   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I4
      REAL(DOUBLE)   EI
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DPTTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Compute the L*D*L' (or U'*D*U) factorization of A.
*
      I4 = MOD( N-1, 4 )
      DO 10 I = 1, I4
         IF( D( I ).EQ.ZERO ) THEN
            INFO = I
            GO TO 30
         END IF
         EI = E( I )
         E( I ) = EI / D( I )
         D( I+1 ) = D( I+1 ) - E( I )*EI
   10 CONTINUE
*
      DO 20 I = I4 + 1, N - 4, 4
*
*        Drop out of the loop if d(i) <= 0: the matrix is not positive
*        definite.
*
         IF( D( I ).EQ.ZERO ) THEN
            INFO = I
            GO TO 30
         END IF
*
*        Solve for e(i) and d(i+1).
*
         EI = E( I )
         E( I ) = EI / D( I )
         D( I+1 ) = D( I+1 ) - E( I )*EI
*
         IF( D( I ).EQ.ZERO ) THEN
            INFO = I + 1
            GO TO 30
         END IF
*
*        Solve for e(i+1) and d(i+2).
*
         EI = E( I+1 )
         E( I+1 ) = EI / D( I+1 )
         D( I+2 ) = D( I+2 ) - E( I+1 )*EI
*
         IF( D( I ).EQ.ZERO ) THEN
            INFO = I + 2
            GO TO 30
         END IF
*
*        Solve for e(i+2) and d(i+3).
*
         EI = E( I+2 )
         E( I+2 ) = EI / D( I+2 )
         D( I+3 ) = D( I+3 ) - E( I+2 )*EI
*
         IF( D( I ).EQ.ZERO ) THEN
            INFO = I + 3
            GO TO 30
         END IF
*
*        Solve for e(i+3) and d(i+4).
*
         EI = E( I+3 )
         E( I+3 ) = EI / D( I+3 )
         D( I+4 ) = D( I+4 ) - E( I+3 )*EI
   20 CONTINUE
*
*     Check d(n) for positive definiteness.
*
      IF( D( N ).LE.ZERO )
     $   INFO = N
*
   30 CONTINUE
      RETURN
*
*     End of DPTTRF
*
! **********************************************************************************************************************************
 9000 continue            ! My lines
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE DPTTRF_MYSTRAN

! #################################################################################################################################
! 008 LAPACK_LINEAR_EQN_DPB

      SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSYTF2'
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DSYTF2 computes the factorization of a real symmetric matrix A using
*  the Bunch-Kaufman diagonal pivoting method:
*
*     A = U*D*U'  or  A = L*D*L'
*
*  where U (or L) is a product of permutation and unit upper (lower)
*  triangular matrices, U' is the transpose of U, and D is symmetric and
*  block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*
*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          symmetric matrix A is stored:
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
*          n-by-n upper triangular part of A contains the upper
*          triangular part of the matrix A, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading n-by-n lower triangular part of A contains the lower
*          triangular part of the matrix A, and the strictly upper
*          triangular part of A is not referenced.
*
*          On exit, the block diagonal matrix D and the multipliers used
*          to obtain the factor U or L (see below for further details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (output) INTEGER array, dimension (N)
*          Details of the interchanges and the block structure of D.
*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*          interchanged and D(k,k) is a 1-by-1 diagonal block.
*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
*               has been completed, but the block diagonal matrix D is
*               exactly singular, and division by zero will occur if it
*               is used to solve a system of equations.
*
*  Further Details
*  ===============
*
*  09-29-06 - patch from
*    Bobby Cheng, MathWorks
*
*    Replace l.204 and l.372
*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*    by
*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
*  01-01-96 - Based on modifications by
*    J. Lewis, Boeing Computer Services Company
*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*  1-96 - Based on modifications by J. Lewis, Boeing Computer Services
*         Company
*
*  If UPLO = 'U', then A = U*D*U', where
*     U = P(n)*U(n)* ... *P(k)U(k)* ...,
*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
*             (   I    v    0   )   k-s
*     U(k) =  (   0    I    0   )   s
*             (   0    0    I   )   n-k
*                k-s   s   n-k
*
*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*  and A(k,k), and v overwrites A(1:k-2,k-1:k).
*
*  If UPLO = 'L', then A = L*D*L', where
*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
*             (   I    0     0   )  k-1
*     L(k) =  (   0    I     0   )  s
*             (   0    v     I   )  n-k-s+1
*                k-1   s  n-k-s+1
*
*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   EIGHT, SEVTEN
      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
     $                   ROWMAX, T, WK, WKM1, WKP1
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME

*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTF2', -INFO )
         RETURN
      END IF
*
*     Initialize ALPHA for use in choosing pivot block size.
*
      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
      IF( UPPER ) THEN
*
*        Factorize A as U*D*U' using the upper triangle of A
*
*        K is the main loop index, decreasing from N to 1 in steps of
*        1 or 2
*
         K = N
   10    CONTINUE
*
*        If K < 1, exit from loop
*
         IF( K.LT.1 )
     $      GO TO 70
         KSTEP = 1
*
*        Determine rows and columns to be interchanged and whether
*        a 1-by-1 or 2-by-2 pivot block will be used
*
         ABSAKK = ABS( A( K, K ) )
*
*        IMAX is the row-index of the largest off-diagonal element in
*        column K, and COLMAX is its absolute value
*
         IF( K.GT.1 ) THEN
            IMAX = IDAMAX( K-1, A( 1, K ), 1 )
            COLMAX = ABS( A( IMAX, K ) )
         ELSE
            COLMAX = ZERO
         END IF
*
         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
*           Column K is zero or contains a NaN: set INFO and continue
*
            IF( INFO.EQ.0 )
     $         INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
*              no interchange, use 1-by-1 pivot block
*
               KP = K
            ELSE
*
*              JMAX is the column-index of the largest off-diagonal
*              element in row IMAX, and ROWMAX is its absolute value
*
               JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
               ROWMAX = ABS( A( IMAX, JMAX ) )
               IF( IMAX.GT.1 ) THEN
                  JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
               END IF
*
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
*                 no interchange, use 1-by-1 pivot block
*
                  KP = K
               ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
*                 interchange rows and columns K and IMAX, use 1-by-1
*                 pivot block
*
                  KP = IMAX
               ELSE
*
*                 interchange rows and columns K-1 and IMAX, use 2-by-2
*                 pivot block
*
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
*
            KK = K - KSTEP + 1
            IF( KP.NE.KK ) THEN
*
*              Interchange rows and columns KK and KP in the leading
*              submatrix A(1:k,1:k)
*
               CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
               CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
     $                     LDA )
               T = A( KK, KK )
               A( KK, KK ) = A( KP, KP )
               A( KP, KP ) = T
               IF( KSTEP.EQ.2 ) THEN
                  T = A( K-1, K )
                  A( K-1, K ) = A( KP, K )
                  A( KP, K ) = T
               END IF
            END IF
*
*           Update the leading submatrix
*
            IF( KSTEP.EQ.1 ) THEN
*
*              1-by-1 pivot block D(k): column k now holds
*
*              W(k) = U(k)*D(k)
*
*              where U(k) is the k-th column of U
*
*              Perform a rank-1 update of A(1:k-1,1:k-1) as
*
*              A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
*
               R1 = ONE / A( K, K )
               CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
*
*              Store U(k) in column k
*
               CALL DSCAL( K-1, R1, A( 1, K ), 1 )
            ELSE
*
*              2-by-2 pivot block D(k): columns k and k-1 now hold
*
*              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
*              where U(k) and U(k-1) are the k-th and (k-1)-th columns
*              of U
*
*              Perform a rank-2 update of A(1:k-2,1:k-2) as
*
*              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
*                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
*
               IF( K.GT.2 ) THEN
*
                  D12 = A( K-1, K )
                  D22 = A( K-1, K-1 ) / D12
                  D11 = A( K, K ) / D12
                  T = ONE / ( D11*D22-ONE )
                  D12 = T / D12
*
                  DO 30 J = K - 2, 1, -1
                     WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
                     WK = D12*( D22*A( J, K )-A( J, K-1 ) )
                     DO 20 I = J, 1, -1
                        A( I, J ) = A( I, J ) - A( I, K )*WK -
     $                              A( I, K-1 )*WKM1
   20                CONTINUE
                     A( J, K ) = WK
                     A( J, K-1 ) = WKM1
   30             CONTINUE
*
               END IF
*
            END IF
         END IF
*
*        Store details of the interchanges in IPIV
*
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K-1 ) = -KP
         END IF
*
*        Decrease K and return to the start of the main loop
*
         K = K - KSTEP
         GO TO 10
*
      ELSE
*
*        Factorize A as L*D*L' using the lower triangle of A
*
*        K is the main loop index, increasing from 1 to N in steps of
*        1 or 2
*
         K = 1
   40    CONTINUE
*
*        If K > N, exit from loop
*
         IF( K.GT.N )
     $      GO TO 70
         KSTEP = 1
*
*        Determine rows and columns to be interchanged and whether
*        a 1-by-1 or 2-by-2 pivot block will be used
*
         ABSAKK = ABS( A( K, K ) )
*
*        IMAX is the row-index of the largest off-diagonal element in
*        column K, and COLMAX is its absolute value
*
         IF( K.LT.N ) THEN
            IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
            COLMAX = ABS( A( IMAX, K ) )
         ELSE
            COLMAX = ZERO
         END IF
*
         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
*           Column K is zero or contains a NaN: set INFO and continue
*
            IF( INFO.EQ.0 )
     $         INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
*              no interchange, use 1-by-1 pivot block
*
               KP = K
            ELSE
*
*              JMAX is the column-index of the largest off-diagonal
*              element in row IMAX, and ROWMAX is its absolute value
*
               JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
               ROWMAX = ABS( A( IMAX, JMAX ) )
               IF( IMAX.LT.N ) THEN
                  JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
               END IF
*
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
*                 no interchange, use 1-by-1 pivot block
*
                  KP = K
               ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
*                 interchange rows and columns K and IMAX, use 1-by-1
*                 pivot block
*
                  KP = IMAX
               ELSE
*
*                 interchange rows and columns K+1 and IMAX, use 2-by-2
*                 pivot block
*
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
*
            KK = K + KSTEP - 1
            IF( KP.NE.KK ) THEN
*
*              Interchange rows and columns KK and KP in the trailing
*              submatrix A(k:n,k:n)
*
               IF( KP.LT.N )
     $            CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
               CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
     $                     LDA )
               T = A( KK, KK )
               A( KK, KK ) = A( KP, KP )
               A( KP, KP ) = T
               IF( KSTEP.EQ.2 ) THEN
                  T = A( K+1, K )
                  A( K+1, K ) = A( KP, K )
                  A( KP, K ) = T
               END IF
            END IF
*
*           Update the trailing submatrix
*
            IF( KSTEP.EQ.1 ) THEN
*
*              1-by-1 pivot block D(k): column k now holds
*
*              W(k) = L(k)*D(k)
*
*              where L(k) is the k-th column of L
*
               IF( K.LT.N ) THEN
*
*                 Perform a rank-1 update of A(k+1:n,k+1:n) as
*
*                 A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
*
                  D11 = ONE / A( K, K )
                  CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
     $                       A( K+1, K+1 ), LDA )
*
*                 Store L(k) in column K
*
                  CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
               END IF
            ELSE
*
*              2-by-2 pivot block D(k)
*
               IF( K.LT.N-1 ) THEN
*
*                 Perform a rank-2 update of A(k+2:n,k+2:n) as
*
*                 A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
*
*                 where L(k) and L(k+1) are the k-th and (k+1)-th
*                 columns of L
*
                  D21 = A( K+1, K )
                  D11 = A( K+1, K+1 ) / D21
                  D22 = A( K, K ) / D21
                  T = ONE / ( D11*D22-ONE )
                  D21 = T / D21
*
                  DO 60 J = K + 2, N
*
                     WK = D21*( D11*A( J, K )-A( J, K+1 ) )
                     WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
*
                     DO 50 I = J, N
                        A( I, J ) = A( I, J ) - A( I, K )*WK -
     $                              A( I, K+1 )*WKP1
   50                CONTINUE
*
                     A( J, K ) = WK
                     A( J, K+1 ) = WKP1
*
   60             CONTINUE
               END IF
            END IF
         END IF
*
*        Store details of the interchanges in IPIV
*
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K+1 ) = -KP
         END IF
*
*        Increase K and return to the start of the main loop
*
         K = K + KSTEP
         GO TO 40
*
      END IF
*
   70 CONTINUE
*
      RETURN
*
*     End of DSYTF2
*
! **********************************************************************************************************************************
 9000 continue            ! My lines
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE DSYTF2

      END MODULE LAPACK_LIN_EQN_DPB