!*==zblat1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022

!> \brief \b ZBLAT1
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       PROGRAM ZBLAT1
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    Test program for the COMPLEX*16 Level 1 BLAS.
!>
!>    Based upon the original BLAS test routine together with:
!>    F06GAF Example Program Text
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date April 2012
!
!> \ingroup complex16_blas_testing
!
!  =====================================================================
      PROGRAM ZBLAT1
      IMPLICIT NONE
!*--ZBLAT142
!
!  -- Reference BLAS test routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     April 2012
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      DOUBLE PRECISION sfac
      INTEGER ic
!     .. External Subroutines ..
      EXTERNAL CHECK1 , CHECK2 , HEADER
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA sfac/9.765625D-4/
!     .. Executable Statements ..
      WRITE (NOUT,99001)
!
99001 FORMAT (' Complex BLAS Test Program Results',/1X)
      DO ic = 1 , 10
         ICAse = ic
         CALL HEADER
!
!        Initialize PASS, INCX, INCY, and MODE for a new case.
!        The value 9999 for INCX, INCY or MODE will appear in the
!        detailed  output, if any, for cases that do not involve
!        these parameters.
!
         PASs = .TRUE.
         INCx = 9999
         INCy = 9999
         MODe = 9999
         IF ( ICAse<=5 ) THEN
            CALL CHECK2(sfac)
         ELSEIF ( ICAse>=6 ) THEN
            CALL CHECK1(sfac)
         ENDIF
!        -- Print
         IF ( PASs ) WRITE (NOUT,99002)
99002    FORMAT ('                                    ----- PASS -----')
      ENDDO
      STOP
      END PROGRAM ZBLAT1
!*==header.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE HEADER
      IMPLICIT NONE
!*--HEADER97
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Arrays ..
      CHARACTER*6 l(10)
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA l(1)/'ZDOTC '/
      DATA l(2)/'ZDOTU '/
      DATA l(3)/'ZAXPY '/
      DATA l(4)/'ZCOPY '/
      DATA l(5)/'ZSWAP '/
      DATA l(6)/'DZNRM2'/
      DATA l(7)/'DZASUM'/
      DATA l(8)/'ZSCAL '/
      DATA l(9)/'ZDSCAL'/
      DATA l(10)/'IZAMAX'/
!     .. Executable Statements ..
      WRITE (NOUT,99001) ICAse , l(ICAse)
!
99001 FORMAT (/' Test of subprogram number',I3,12X,A6)
      RETURN
      END SUBROUTINE HEADER
!*==check1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK1(Sfac)
      IMPLICIT NONE
!*--CHECK1128
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      COMPLEX*16 ca
      DOUBLE PRECISION sa
      INTEGER i , ix , j , len , np1
!     .. Local Arrays ..
      COMPLEX*16 ctrue5(8,5,2) , ctrue6(8,5,2) , cv(8,5,2) , cvr(8) ,   &
     &           cx(8) , cxr(15) , mwpcs(5) , mwpct(5)
      DOUBLE PRECISION strue2(5) , strue4(5)
      INTEGER itrue3(5) , itruec(5)
!     .. External Functions ..
      DOUBLE PRECISION DZASUM , DZNRM2
      INTEGER IZAMAX
      EXTERNAL DZASUM , DZNRM2 , IZAMAX
!     .. External Subroutines ..
      EXTERNAL ZSCAL , ZDSCAL , CTEST , ITEST1 , STEST1
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA sa , ca/0.3D0 , (0.4D0,-0.7D0)/
      DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1D0,0.1D0) , (1.0D0,2.0D0) ,    &
     &      (1.0D0,2.0D0) , (1.0D0,2.0D0) , (1.0D0,2.0D0) ,             &
     &      (1.0D0,2.0D0) , (1.0D0,2.0D0) , (1.0D0,2.0D0) ,             &
     &      (0.3D0,-0.4D0) , (3.0D0,4.0D0) , (3.0D0,4.0D0) ,            &
     &      (3.0D0,4.0D0) , (3.0D0,4.0D0) , (3.0D0,4.0D0) ,             &
     &      (3.0D0,4.0D0) , (3.0D0,4.0D0) , (0.1D0,-0.3D0) ,            &
     &      (0.5D0,-0.1D0) , (5.0D0,6.0D0) , (5.0D0,6.0D0) ,            &
     &      (5.0D0,6.0D0) , (5.0D0,6.0D0) , (5.0D0,6.0D0) ,             &
     &      (5.0D0,6.0D0) , (0.1D0,0.1D0) , (-0.6D0,0.1D0) ,            &
     &      (0.1D0,-0.3D0) , (7.0D0,8.0D0) , (7.0D0,8.0D0) ,            &
     &      (7.0D0,8.0D0) , (7.0D0,8.0D0) , (7.0D0,8.0D0) ,             &
     &      (0.3D0,0.1D0) , (0.5D0,0.0D0) , (0.0D0,0.5D0) ,             &
     &      (0.0D0,0.2D0) , (2.0D0,3.0D0) , (2.0D0,3.0D0) ,             &
     &      (2.0D0,3.0D0) , (2.0D0,3.0D0)/
      DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1D0,0.1D0) , (4.0D0,5.0D0) ,    &
     &      (4.0D0,5.0D0) , (4.0D0,5.0D0) , (4.0D0,5.0D0) ,             &
     &      (4.0D0,5.0D0) , (4.0D0,5.0D0) , (4.0D0,5.0D0) ,             &
     &      (0.3D0,-0.4D0) , (6.0D0,7.0D0) , (6.0D0,7.0D0) ,            &
     &      (6.0D0,7.0D0) , (6.0D0,7.0D0) , (6.0D0,7.0D0) ,             &
     &      (6.0D0,7.0D0) , (6.0D0,7.0D0) , (0.1D0,-0.3D0) ,            &
     &      (8.0D0,9.0D0) , (0.5D0,-0.1D0) , (2.0D0,5.0D0) ,            &
     &      (2.0D0,5.0D0) , (2.0D0,5.0D0) , (2.0D0,5.0D0) ,             &
     &      (2.0D0,5.0D0) , (0.1D0,0.1D0) , (3.0D0,6.0D0) ,             &
     &      (-0.6D0,0.1D0) , (4.0D0,7.0D0) , (0.1D0,-0.3D0) ,           &
     &      (7.0D0,2.0D0) , (7.0D0,2.0D0) , (7.0D0,2.0D0) ,             &
     &      (0.3D0,0.1D0) , (5.0D0,8.0D0) , (0.5D0,0.0D0) ,             &
     &      (6.0D0,9.0D0) , (0.0D0,0.5D0) , (8.0D0,3.0D0) ,             &
     &      (0.0D0,0.2D0) , (9.0D0,4.0D0)/
      DATA cvr/(8.0D0,8.0D0) , (-7.0D0,-7.0D0) , (9.0D0,9.0D0) ,        &
     &     (5.0D0,5.0D0) , (9.0D0,9.0D0) , (8.0D0,8.0D0) , (7.0D0,7.0D0)&
     &     , (7.0D0,7.0D0)/
      DATA strue2/0.0D0 , 0.5D0 , 0.6D0 , 0.7D0 , 0.8D0/
      DATA strue4/0.0D0 , 0.7D0 , 1.0D0 , 1.3D0 , 1.6D0/
      DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1D0,0.1D0) , (1.0D0,2.0D0) ,&
     &      (1.0D0,2.0D0) , (1.0D0,2.0D0) , (1.0D0,2.0D0) ,             &
     &      (1.0D0,2.0D0) , (1.0D0,2.0D0) , (1.0D0,2.0D0) ,             &
     &      (-0.16D0,-0.37D0) , (3.0D0,4.0D0) , (3.0D0,4.0D0) ,         &
     &      (3.0D0,4.0D0) , (3.0D0,4.0D0) , (3.0D0,4.0D0) ,             &
     &      (3.0D0,4.0D0) , (3.0D0,4.0D0) , (-0.17D0,-0.19D0) ,         &
     &      (0.13D0,-0.39D0) , (5.0D0,6.0D0) , (5.0D0,6.0D0) ,          &
     &      (5.0D0,6.0D0) , (5.0D0,6.0D0) , (5.0D0,6.0D0) ,             &
     &      (5.0D0,6.0D0) , (0.11D0,-0.03D0) , (-0.17D0,0.46D0) ,       &
     &      (-0.17D0,-0.19D0) , (7.0D0,8.0D0) , (7.0D0,8.0D0) ,         &
     &      (7.0D0,8.0D0) , (7.0D0,8.0D0) , (7.0D0,8.0D0) ,             &
     &      (0.19D0,-0.17D0) , (0.20D0,-0.35D0) , (0.35D0,0.20D0) ,     &
     &      (0.14D0,0.08D0) , (2.0D0,3.0D0) , (2.0D0,3.0D0) ,           &
     &      (2.0D0,3.0D0) , (2.0D0,3.0D0)/
      DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1D0,0.1D0) , (4.0D0,5.0D0) ,&
     &      (4.0D0,5.0D0) , (4.0D0,5.0D0) , (4.0D0,5.0D0) ,             &
     &      (4.0D0,5.0D0) , (4.0D0,5.0D0) , (4.0D0,5.0D0) ,             &
     &      (-0.16D0,-0.37D0) , (6.0D0,7.0D0) , (6.0D0,7.0D0) ,         &
     &      (6.0D0,7.0D0) , (6.0D0,7.0D0) , (6.0D0,7.0D0) ,             &
     &      (6.0D0,7.0D0) , (6.0D0,7.0D0) , (-0.17D0,-0.19D0) ,         &
     &      (8.0D0,9.0D0) , (0.13D0,-0.39D0) , (2.0D0,5.0D0) ,          &
     &      (2.0D0,5.0D0) , (2.0D0,5.0D0) , (2.0D0,5.0D0) ,             &
     &      (2.0D0,5.0D0) , (0.11D0,-0.03D0) , (3.0D0,6.0D0) ,          &
     &      (-0.17D0,0.46D0) , (4.0D0,7.0D0) , (-0.17D0,-0.19D0) ,      &
     &      (7.0D0,2.0D0) , (7.0D0,2.0D0) , (7.0D0,2.0D0) ,             &
     &      (0.19D0,-0.17D0) , (5.0D0,8.0D0) , (0.20D0,-0.35D0) ,       &
     &      (6.0D0,9.0D0) , (0.35D0,0.20D0) , (8.0D0,3.0D0) ,           &
     &      (0.14D0,0.08D0) , (9.0D0,4.0D0)/
      DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1D0,0.1D0) , (1.0D0,2.0D0) ,&
     &      (1.0D0,2.0D0) , (1.0D0,2.0D0) , (1.0D0,2.0D0) ,             &
     &      (1.0D0,2.0D0) , (1.0D0,2.0D0) , (1.0D0,2.0D0) ,             &
     &      (0.09D0,-0.12D0) , (3.0D0,4.0D0) , (3.0D0,4.0D0) ,          &
     &      (3.0D0,4.0D0) , (3.0D0,4.0D0) , (3.0D0,4.0D0) ,             &
     &      (3.0D0,4.0D0) , (3.0D0,4.0D0) , (0.03D0,-0.09D0) ,          &
     &      (0.15D0,-0.03D0) , (5.0D0,6.0D0) , (5.0D0,6.0D0) ,          &
     &      (5.0D0,6.0D0) , (5.0D0,6.0D0) , (5.0D0,6.0D0) ,             &
     &      (5.0D0,6.0D0) , (0.03D0,0.03D0) , (-0.18D0,0.03D0) ,        &
     &      (0.03D0,-0.09D0) , (7.0D0,8.0D0) , (7.0D0,8.0D0) ,          &
     &      (7.0D0,8.0D0) , (7.0D0,8.0D0) , (7.0D0,8.0D0) ,             &
     &      (0.09D0,0.03D0) , (0.15D0,0.00D0) , (0.00D0,0.15D0) ,       &
     &      (0.00D0,0.06D0) , (2.0D0,3.0D0) , (2.0D0,3.0D0) ,           &
     &      (2.0D0,3.0D0) , (2.0D0,3.0D0)/
      DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1D0,0.1D0) , (4.0D0,5.0D0) ,&
     &      (4.0D0,5.0D0) , (4.0D0,5.0D0) , (4.0D0,5.0D0) ,             &
     &      (4.0D0,5.0D0) , (4.0D0,5.0D0) , (4.0D0,5.0D0) ,             &
     &      (0.09D0,-0.12D0) , (6.0D0,7.0D0) , (6.0D0,7.0D0) ,          &
     &      (6.0D0,7.0D0) , (6.0D0,7.0D0) , (6.0D0,7.0D0) ,             &
     &      (6.0D0,7.0D0) , (6.0D0,7.0D0) , (0.03D0,-0.09D0) ,          &
     &      (8.0D0,9.0D0) , (0.15D0,-0.03D0) , (2.0D0,5.0D0) ,          &
     &      (2.0D0,5.0D0) , (2.0D0,5.0D0) , (2.0D0,5.0D0) ,             &
     &      (2.0D0,5.0D0) , (0.03D0,0.03D0) , (3.0D0,6.0D0) ,           &
     &      (-0.18D0,0.03D0) , (4.0D0,7.0D0) , (0.03D0,-0.09D0) ,       &
     &      (7.0D0,2.0D0) , (7.0D0,2.0D0) , (7.0D0,2.0D0) ,             &
     &      (0.09D0,0.03D0) , (5.0D0,8.0D0) , (0.15D0,0.00D0) ,         &
     &      (6.0D0,9.0D0) , (0.00D0,0.15D0) , (8.0D0,3.0D0) ,           &
     &      (0.00D0,0.06D0) , (9.0D0,4.0D0)/
      DATA itrue3/0 , 1 , 2 , 2 , 2/
      DATA itruec/0 , 1 , 1 , 1 , 1/
!     .. Executable Statements ..
      DO INCx = 1 , 2
         DO np1 = 1 , 5
            N = np1 - 1
            len = 2*MAX(N,1)
!           .. Set vector arguments ..
            DO i = 1 , len
               cx(i) = cv(i,np1,INCx)
            ENDDO
            IF ( ICAse==6 ) THEN
!              .. DZNRM2 ..
               CALL STEST1(DZNRM2(N,cx,INCx),strue2(np1),strue2(np1),   &
     &                     Sfac)
            ELSEIF ( ICAse==7 ) THEN
!              .. DZASUM ..
               CALL STEST1(DZASUM(N,cx,INCx),strue4(np1),strue4(np1),   &
     &                     Sfac)
            ELSEIF ( ICAse==8 ) THEN
!              .. ZSCAL ..
               CALL ZSCAL(N,ca,cx,INCx)
               CALL CTEST(len,cx,ctrue5(1,np1,INCx),ctrue5(1,np1,INCx), &
     &                    Sfac)
            ELSEIF ( ICAse==9 ) THEN
!              .. ZDSCAL ..
               CALL ZDSCAL(N,sa,cx,INCx)
               CALL CTEST(len,cx,ctrue6(1,np1,INCx),ctrue6(1,np1,INCx), &
     &                    Sfac)
            ELSEIF ( ICAse==10 ) THEN
!              .. IZAMAX ..
               CALL ITEST1(IZAMAX(N,cx,INCx),itrue3(np1))
               DO i = 1 , len
                  cx(i) = (42.0D0,43.0D0)
               ENDDO
               CALL ITEST1(IZAMAX(N,cx,INCx),itruec(np1))
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
               STOP
            ENDIF
!
         ENDDO
         IF ( ICAse==10 ) THEN
            N = 8
            ix = 1
            DO i = 1 , N
               cxr(ix) = cvr(i)
               ix = ix + INCx
            ENDDO
            CALL ITEST1(IZAMAX(N,cxr,INCx),3)
         ENDIF
      ENDDO
!
      INCx = 1
      IF ( ICAse==8 ) THEN
!        ZSCAL
!        Add a test for alpha equal to zero.
         ca = (0.0D0,0.0D0)
         DO i = 1 , 5
            mwpct(i) = (0.0D0,0.0D0)
            mwpcs(i) = (1.0D0,1.0D0)
         ENDDO
         CALL ZSCAL(5,ca,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
      ELSEIF ( ICAse==9 ) THEN
!        ZDSCAL
!        Add a test for alpha equal to zero.
         sa = 0.0D0
         DO i = 1 , 5
            mwpct(i) = (0.0D0,0.0D0)
            mwpcs(i) = (1.0D0,1.0D0)
         ENDDO
         CALL ZDSCAL(5,sa,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
!        Add a test for alpha equal to one.
         sa = 1.0D0
         DO i = 1 , 5
            mwpct(i) = cx(i)
            mwpcs(i) = cx(i)
         ENDDO
         CALL ZDSCAL(5,sa,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
!        Add a test for alpha equal to minus one.
         sa = -1.0D0
         DO i = 1 , 5
            mwpct(i) = -cx(i)
            mwpcs(i) = -cx(i)
         ENDDO
         CALL ZDSCAL(5,sa,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
      ENDIF
      END SUBROUTINE CHECK1
!*==check2.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK2(Sfac)
      IMPLICIT NONE
!*--CHECK2342
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      COMPLEX*16 ca
      INTEGER i , j , ki , kn , ksize , lenx , leny , lincx , lincy ,   &
     &        mx , my
!     .. Local Arrays ..
      COMPLEX*16 cdot(1) , csize1(4) , csize2(7,2) , csize3(14) ,       &
     &           ct10x(7,4,4) , ct10y(7,4,4) , ct6(4,4) , ct7(4,4) ,    &
     &           ct8(7,4,4) , cty0(1) , cx(7) , cx0(1) , cx1(7) ,       &
     &           cy(7) , cy0(1) , cy1(7)
      INTEGER incxs(4) , incys(4) , lens(4,2) , ns(4)
!     .. External Functions ..
      COMPLEX*16 ZDOTC , ZDOTU
      EXTERNAL ZDOTC , ZDOTU
!     .. External Subroutines ..
      EXTERNAL ZAXPY , ZCOPY , ZSWAP , CTEST
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MIN
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA ca/(0.4D0,-0.7D0)/
      DATA incxs/1 , 2 , -2 , -1/
      DATA incys/1 , -2 , 1 , -2/
      DATA lens/1 , 1 , 2 , 4 , 1 , 1 , 3 , 7/
      DATA ns/0 , 1 , 2 , 4/
      DATA cx1/(0.7D0,-0.8D0) , (-0.4D0,-0.7D0) , (-0.1D0,-0.9D0) ,     &
     &     (0.2D0,-0.8D0) , (-0.9D0,-0.4D0) , (0.1D0,0.4D0) ,           &
     &     (-0.6D0,0.6D0)/
      DATA cy1/(0.6D0,-0.6D0) , (-0.9D0,0.5D0) , (0.7D0,-0.6D0) ,       &
     &     (0.1D0,-0.5D0) , (-0.1D0,-0.2D0) , (-0.5D0,-0.3D0) ,         &
     &     (0.8D0,-0.7D0)/
      DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,  &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.32D0,-1.41D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.32D0,-1.41D0) , (-1.55D0,0.5D0) , (0.0D0,0.0D0) ,        &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.32D0,-1.41D0) , (-1.55D0,0.5D0) ,        &
     &      (0.03D0,-0.89D0) , (-0.38D0,-0.96D0) , (0.0D0,0.0D0) ,      &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0)/
      DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,  &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.32D0,-1.41D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (-0.07D0,-0.89D0) , (-0.9D0,0.5D0) , (0.42D0,-1.41D0) ,     &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.78D0,0.06D0) , (-0.9D0,0.5D0) ,          &
     &      (0.06D0,-0.13D0) , (0.1D0,-0.5D0) , (-0.77D0,-0.49D0) ,     &
     &      (-0.5D0,-0.3D0) , (0.52D0,-1.51D0)/
      DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,  &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.32D0,-1.41D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (-0.07D0,-0.89D0) , (-1.18D0,-0.31D0) , (0.0D0,0.0D0) ,     &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.78D0,0.06D0) , (-1.54D0,0.97D0) ,        &
     &      (0.03D0,-0.89D0) , (-0.18D0,-1.31D0) , (0.0D0,0.0D0) ,      &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0)/
      DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,  &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.32D0,-1.41D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.32D0,-1.41D0) , (-0.9D0,0.5D0) , (0.05D0,-0.6D0) ,       &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.32D0,-1.41D0) , (-0.9D0,0.5D0) ,         &
     &      (0.05D0,-0.6D0) , (0.1D0,-0.5D0) , (-0.77D0,-0.49D0) ,      &
     &      (-0.5D0,-0.3D0) , (0.32D0,-1.16D0)/
      DATA ct7/(0.0D0,0.0D0) , (-0.06D0,-0.90D0) , (0.65D0,-0.47D0) ,   &
     &     (-0.34D0,-1.22D0) , (0.0D0,0.0D0) , (-0.06D0,-0.90D0) ,      &
     &     (-0.59D0,-1.46D0) , (-1.04D0,-0.04D0) , (0.0D0,0.0D0) ,      &
     &     (-0.06D0,-0.90D0) , (-0.83D0,0.59D0) , (0.07D0,-0.37D0) ,    &
     &     (0.0D0,0.0D0) , (-0.06D0,-0.90D0) , (-0.76D0,-1.15D0) ,      &
     &     (-1.33D0,-1.82D0)/
      DATA ct6/(0.0D0,0.0D0) , (0.90D0,0.06D0) , (0.91D0,-0.77D0) ,     &
     &     (1.80D0,-0.10D0) , (0.0D0,0.0D0) , (0.90D0,0.06D0) ,         &
     &     (1.45D0,0.74D0) , (0.20D0,0.90D0) , (0.0D0,0.0D0) ,          &
     &     (0.90D0,0.06D0) , (-0.55D0,0.23D0) , (0.83D0,-0.39D0) ,      &
     &     (0.0D0,0.0D0) , (0.90D0,0.06D0) , (1.04D0,0.79D0) ,          &
     &     (1.95D0,1.22D0)/
      DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7D0,-0.8D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.6D0,-0.6D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.6D0,-0.6D0) , (-0.9D0,0.5D0) , (0.0D0,0.0D0) ,           &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.6D0,-0.6D0) , (-0.9D0,0.5D0) ,           &
     &      (0.7D0,-0.6D0) , (0.1D0,-0.5D0) , (0.0D0,0.0D0) ,           &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0)/
      DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7D0,-0.8D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.6D0,-0.6D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.7D0,-0.6D0) , (-0.4D0,-0.7D0) , (0.6D0,-0.6D0) ,         &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.8D0,-0.7D0) , (-0.4D0,-0.7D0) ,          &
     &      (-0.1D0,-0.2D0) , (0.2D0,-0.8D0) , (0.7D0,-0.6D0) ,         &
     &      (0.1D0,0.4D0) , (0.6D0,-0.6D0)/
      DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7D0,-0.8D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.6D0,-0.6D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (-0.9D0,0.5D0) , (-0.4D0,-0.7D0) , (0.6D0,-0.6D0) ,         &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.1D0,-0.5D0) , (-0.4D0,-0.7D0) ,          &
     &      (0.7D0,-0.6D0) , (0.2D0,-0.8D0) , (-0.9D0,0.5D0) ,          &
     &      (0.1D0,0.4D0) , (0.6D0,-0.6D0)/
      DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7D0,-0.8D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.6D0,-0.6D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.6D0,-0.6D0) , (0.7D0,-0.6D0) , (0.0D0,0.0D0) ,           &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.6D0,-0.6D0) , (0.7D0,-0.6D0) ,           &
     &      (-0.1D0,-0.2D0) , (0.8D0,-0.7D0) , (0.0D0,0.0D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0)/
      DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.7D0,-0.8D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.7D0,-0.8D0) , (-0.4D0,-0.7D0) , (0.0D0,0.0D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.7D0,-0.8D0) , (-0.4D0,-0.7D0) ,          &
     &      (-0.1D0,-0.9D0) , (0.2D0,-0.8D0) , (0.0D0,0.0D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0)/
      DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.7D0,-0.8D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (-0.1D0,-0.9D0) , (-0.9D0,0.5D0) , (0.7D0,-0.8D0) ,         &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (-0.6D0,0.6D0) , (-0.9D0,0.5D0) ,           &
     &      (-0.9D0,-0.4D0) , (0.1D0,-0.5D0) , (-0.1D0,-0.9D0) ,        &
     &      (-0.5D0,-0.3D0) , (0.7D0,-0.8D0)/
      DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.7D0,-0.8D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (-0.1D0,-0.9D0) , (0.7D0,-0.8D0) , (0.0D0,0.0D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (-0.6D0,0.6D0) , (-0.9D0,-0.4D0) ,          &
     &      (-0.1D0,-0.9D0) , (0.7D0,-0.8D0) , (0.0D0,0.0D0) ,          &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0)/
      DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6D0,-0.6D0) , (0.0D0,0.0D0) ,&
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.7D0,-0.8D0) ,            &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.7D0,-0.8D0) , (-0.9D0,0.5D0) , (-0.4D0,-0.7D0) ,         &
     &      (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,             &
     &      (0.0D0,0.0D0) , (0.7D0,-0.8D0) , (-0.9D0,0.5D0) ,           &
     &      (-0.4D0,-0.7D0) , (0.1D0,-0.5D0) , (-0.1D0,-0.9D0) ,        &
     &      (-0.5D0,-0.3D0) , (0.2D0,-0.8D0)/
      DATA csize1/(0.0D0,0.0D0) , (0.9D0,0.9D0) , (1.63D0,1.73D0) ,     &
     &     (2.90D0,2.78D0)/
      DATA csize3/(0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,       &
     &     (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0)&
     &     , (1.17D0,1.17D0) , (1.17D0,1.17D0) , (1.17D0,1.17D0) ,      &
     &     (1.17D0,1.17D0) , (1.17D0,1.17D0) , (1.17D0,1.17D0) ,        &
     &     (1.17D0,1.17D0)/
      DATA csize2/(0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) ,       &
     &     (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0) , (0.0D0,0.0D0)&
     &     , (1.54D0,1.54D0) , (1.54D0,1.54D0) , (1.54D0,1.54D0) ,      &
     &     (1.54D0,1.54D0) , (1.54D0,1.54D0) , (1.54D0,1.54D0) ,        &
     &     (1.54D0,1.54D0)/
!     .. Executable Statements ..
      DO ki = 1 , 4
         INCx = incxs(ki)
         INCy = incys(ki)
         mx = ABS(INCx)
         my = ABS(INCy)
!
         DO kn = 1 , 4
            N = ns(kn)
            ksize = MIN(2,kn)
            lenx = lens(kn,mx)
            leny = lens(kn,my)
!           .. initialize all argument arrays ..
            DO i = 1 , 7
               cx(i) = cx1(i)
               cy(i) = cy1(i)
            ENDDO
            IF ( ICAse==1 ) THEN
!              .. ZDOTC ..
               cdot(1) = ZDOTC(N,cx,INCx,cy,INCy)
               CALL CTEST(1,cdot,ct6(kn,ki),csize1(kn),Sfac)
            ELSEIF ( ICAse==2 ) THEN
!              .. ZDOTU ..
               cdot(1) = ZDOTU(N,cx,INCx,cy,INCy)
               CALL CTEST(1,cdot,ct7(kn,ki),csize1(kn),Sfac)
            ELSEIF ( ICAse==3 ) THEN
!              .. ZAXPY ..
               CALL ZAXPY(N,ca,cx,INCx,cy,INCy)
               CALL CTEST(leny,cy,ct8(1,kn,ki),csize2(1,ksize),Sfac)
            ELSEIF ( ICAse==4 ) THEN
!              .. ZCOPY ..
               CALL ZCOPY(N,cx,INCx,cy,INCy)
               CALL CTEST(leny,cy,ct10y(1,kn,ki),csize3,1.0D0)
               IF ( ki==1 ) THEN
                  cx0(1) = (42.0D0,43.0D0)
                  cy0(1) = (44.0D0,45.0D0)
                  IF ( N==0 ) THEN
                     cty0(1) = cy0(1)
                  ELSE
                     cty0(1) = cx0(1)
                  ENDIF
                  lincx = INCx
                  INCx = 0
                  lincy = INCy
                  INCy = 0
                  CALL ZCOPY(N,cx0,INCx,cy0,INCy)
                  CALL CTEST(1,cy0,cty0,csize3,1.0D0)
                  INCx = lincx
                  INCy = lincy
               ENDIF
            ELSEIF ( ICAse==5 ) THEN
!              .. ZSWAP ..
               CALL ZSWAP(N,cx,INCx,cy,INCy)
               CALL CTEST(lenx,cx,ct10x(1,kn,ki),csize3,1.0D0)
               CALL CTEST(leny,cy,ct10y(1,kn,ki),csize3,1.0D0)
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
               STOP
            ENDIF
!
         ENDDO
      ENDDO
      END SUBROUTINE CHECK2
!*==stest.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST(Len,Scomp,Strue,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST592
!     ********************************* STEST **************************
!
!     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
!     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
!     NEGLIGIBLE.
!
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      DOUBLE PRECISION ZERO
      PARAMETER (NOUT=6,ZERO=0.0D0)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
      INTEGER Len
!     .. Array Arguments ..
      DOUBLE PRECISION Scomp(Len) , Ssize(Len) , Strue(Len)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      DOUBLE PRECISION sd
      INTEGER i
!     .. External Functions ..
      DOUBLE PRECISION SDIFF
      EXTERNAL SDIFF
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Executable Statements ..
!
      DO i = 1 , Len
         sd = Scomp(i) - Strue(i)
         IF ( ABS(Sfac*sd)>ABS(Ssize(i))*EPSILON(ZERO) ) THEN
!
!                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
!
            IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
               PASs = .FALSE.
               WRITE (NOUT,99001)
!
99001          FORMAT ('                                       FAIL')
               WRITE (NOUT,99002)
99002          FORMAT (/                                                &
     &          ' CASE  N INCX INCY MODE  I                            '&
     &          ,                                                       &
     &        ' COMP(I)                             TRUE(I)  DIFFERENCE'&
     &        ,'     SIZE(I)',/1X)
            ENDIF
            WRITE (NOUT,99003) ICAse , N , INCx , INCy , MODe , i ,     &
     &                         Scomp(i) , Strue(i) , sd , Ssize(i)
99003       FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4)
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE STEST
!*==stest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST1(Scomp1,Strue1,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST1654
!     ************************* STEST1 *****************************
!
!     THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
!     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
!     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
!
!     C.L. LAWSON, JPL, 1978 DEC 6
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Scomp1 , Sfac , Strue1
!     .. Array Arguments ..
      DOUBLE PRECISION Ssize(*)
!     .. Local Arrays ..
      DOUBLE PRECISION scomp(1) , strue(1)
!     .. External Subroutines ..
      EXTERNAL STEST
!     .. Executable Statements ..
!
      scomp(1) = Scomp1
      strue(1) = Strue1
      CALL STEST(1,scomp,strue,Ssize,Sfac)
!
      END SUBROUTINE STEST1
!*==sdiff.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      DOUBLE PRECISION FUNCTION SDIFF(Sa,Sb)
      IMPLICIT NONE
!*--SDIFF681
!     ********************************* SDIFF **************************
!     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sa , Sb
!     .. Executable Statements ..
      SDIFF = Sa - Sb
      END FUNCTION SDIFF
!*==ctest.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CTEST(Len,Ccomp,Ctrue,Csize,Sfac)
      IMPLICIT NONE
!*--CTEST693
!     **************************** CTEST *****************************
!
!     C.L. LAWSON, JPL, 1978 DEC 6
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
      INTEGER Len
!     .. Array Arguments ..
      COMPLEX*16 Ccomp(Len) , Csize(Len) , Ctrue(Len)
!     .. Local Scalars ..
      INTEGER i
!     .. Local Arrays ..
      DOUBLE PRECISION scomp(20) , ssize(20) , strue(20)
!     .. External Subroutines ..
      EXTERNAL STEST
!     .. Intrinsic Functions ..
      INTRINSIC DIMAG , DBLE
!     .. Executable Statements ..
      DO i = 1 , Len
         scomp(2*i-1) = DBLE(Ccomp(i))
         scomp(2*i) = DIMAG(Ccomp(i))
         strue(2*i-1) = DBLE(Ctrue(i))
         strue(2*i) = DIMAG(Ctrue(i))
         ssize(2*i-1) = DBLE(Csize(i))
         ssize(2*i) = DIMAG(Csize(i))
      ENDDO
!
      CALL STEST(2*Len,scomp,strue,ssize,Sfac)
      END SUBROUTINE CTEST
!*==itest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE ITEST1(Icomp,Itrue)
      IMPLICIT NONE
!*--ITEST1726
!     ********************************* ITEST1 *************************
!
!     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
!     EQUALITY.
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      INTEGER Icomp , Itrue
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      INTEGER id
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Executable Statements ..
      IF ( Icomp/=Itrue ) THEN
!
!                            HERE ICOMP IS NOT EQUAL TO ITRUE.
!
         IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
            PASs = .FALSE.
            WRITE (NOUT,99001)
!
99001       FORMAT ('                                       FAIL')
            WRITE (NOUT,99002)
99002       FORMAT (/                                                   &
     &          ' CASE  N INCX INCY MODE                               '&
     &          ,                                                       &
     &        ' COMP                                TRUE     DIFFERENCE'&
     &        ,/1X)
         ENDIF
         id = Icomp - Itrue
         WRITE (NOUT,99003) ICAse , N , INCx , INCy , MODe , Icomp ,    &
     &                      Itrue , id
99003    FORMAT (1X,I4,I3,3I5,2I36,I12)
      ENDIF
      RETURN
      END SUBROUTINE ITEST1


SUBROUTINE ZPPSVX_F95(A, B, X, UPLO, AF, FACT, EQUED, S, FERR, BERR, RCOND, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: PPSVX_F77 => LA_PPSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO, FACT
   CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(INOUT) :: A(:), B(:,:)
   COMPLEX(WP), INTENT(OUT) :: X(:,:)
   REAL(WP), INTENT(INOUT), OPTIONAL, TARGET :: S(:)
   COMPLEX(WP), INTENT(INOUT), OPTIONAL, TARGET :: AF(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_PPSVX computes the solution to a linear system of equations
! A*X = B, where A is real symmetric or complex Hermitian and, in either
! case, positive definite, and where X and B are rectangular matrices or
! vectors. A is stored in packed format.
!     LA_PPSVX can also optionally equilibrate the system if A is poorly
! scaled, estimate the condition number of (the equilibrated) A, and
! compute error bounds.
!
! =========
!
!       SUBROUTINE LA_PPSVX( AP, B, X, UPLO=uplo, AFP=afp, &
!                  FACT=fact, EQUED=equed, S=s, FERR=ferr, &
!                  BERR=berr, RCOND=rcond, INFO=info )
!           <type>(<wp>), INTENT(INOUT) :: AP(:), <rhs>
!           <type>(<wp>), INTENT(OUT) :: <sol>
!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!           <type>(<wp>), INTENT(INOUT), OPTIONAL :: AFP(:)
!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT
!           CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED
!           REAL(<wp>), INTENT(INOUT), OPTIONAL :: S(:)
!           REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>
!           REAL(<wp>), INTENT(OUT), OPTIONAL :: RCOND
!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!           <type> ::= REAL | COMPLEX
!           <wp>   ::= KIND(1.0) | KIND(1.0D0)
!           <rhs>  ::= B(:,:) | B(:)
!           <sol>  ::= X(:,:) | X(:)
!           <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! AP      (input/output) REAL or COMPLEX square array, shape (:) with
!         size(AP) = n*(n + 1)=2, where n is a rank of the matrix A.
!         On entry, the upper or lower triangle of matrix A, or its
!         equilibration, in packed storage. The elements are stored
! 	  columnwise as follows:
! 	  if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j<=n;
! 	  if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for 1<=j<=i<=n.
!         On exit, if FACT = 'E', then the equilibrated version of A is
! 	  stored in AP; otherwise, AP is unchanged.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = n or shape (:) with size(B) = n.
!         On entry, the matrix B.
!         On exit, the scaled version of B if the system has been
!         equilibrated; otherwise, B is unchanged.
! X       (output) REAL or COMPLEX array, shape (:,:) with size(X,1)=n
!         and size(X,2) = size(B,2), or shape (:) with size(X) = n.
!         The solution matrix X .
! UPLO    Optional (input) CHARACTER(LEN=1).
!           = 'U': Upper triangle of A is stored;
!           = 'L': Lower triangle of A is stored.
!         Default value: 'U'.
! AFP     Optional (input or output) REAL or COMPLEX array, shape (:)
!         with the same size as AP.
!         If FACT = 'F' then AFP is an input argument that contains the
! 	  factor U or L from the Cholesky factorization of (the
! 	  equilibrated) A, in the same storage format as A, returned by
! 	  a previous call to LA_PPSVX.
!         If FACT 6= 'F' then AFP is an output argument that contains the
!         factor U or L from the Cholesky factorization of (the
!   	  equilibrated) A in the same storage format as A.
! FACT    Optional (input) CHARACTER(LEN=1).
!         Specifies whether the factored form of the matrix A is supplied
! 	  on entry, and, if not, whether A should be equilibrated before
! 	  it is factored.
!           = 'N': The matrix A will be copied to AFP and factored
! 	         (no equilibration).
!           = 'E': The matrix A will be equilibrated, then copied to AFP
! 	         and factored.
!           = 'F': AFP contains the factored form of (the equilibrated) A.
!         Default value: 'N'.
! EQUED   Optional (input or output) CHARACTER(LEN=1).
!         Specifies the form of equilibration that was done.
!         EQUED is an input argument if FACT = 'F', otherwise it is an
!         output argument:
!           = 'N': No equilibration (always true if FACT = 'N').
!           = 'Y': Equilibration, i.e., A has been premultiplied and
!                postmultiplied by diag(S).
!         Default value: 'N'.
! S       Optional (input or output) REAL array, shape (:) with size(S)
!         = size(A,1).
!         The scaling factors for A.
!         S is an input argument if FACT = 'F' and EQUED = 'Y'.
!         S is an output argument if FACT = 'E' and EQUED = 'Y'.
! FERR    Optional (output) REAL array of shape (:), with size(FERR) =
!         size(X,2), or REAL scalar.
!         The estimated forward error bound for each solution vector X(j)
! 	  (the j-th column of the solution matrix X). If XTRUE is the
! 	  true solution corresponding to X(j) , FERR(j) is an estimated
! 	  upper bound for the magnitude of the largest element in
! 	  (X(j)-XTRUE) divided by the magnitude of the largest element
! 	  in X(j). The estimate is as reliable as the estimate for RCOND,
! 	  and is almost always a slight overestimate of the true error.
! BERR    Optional (output) REAL array of shape (:), with size(BERR) =
!         size(X,2), or REAL scalar.
!         The componentwise relative backward error of each solution
! 	  vector X(j) (i.e., the smallest relative change in any element
! 	  of A or B that makes X(j) an exact solution).
! RCOND   Optional (output) REAL
!         The estimate of the reciprocal condition number of (the
! 	  equilibrated) A. If RCOND is less than the machine precision,
! 	  the matrix is singular to working precision. This condition is
!         indicated by a return code of INFO > 0.
! INFO    Optional (output) INTEGER
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, and i is
!             <= n: the leading minor of order i of (the equilibrated) A
! 	        is not positive definite, so the factorization could
! 		not be completed and the solution and error bounds
! 		could not be computed. RCOND= 0 is returned.
!             = n+1: U or L is nonsingular, but RCOND is less than
! 	        machine precision, so the matrix is singular to
! 		working precision. Nevertheless, the solution and
! 		error bounds are computed because the computed solution
! 		can be more accurate than the value of RCOND would
! 		suggest.
!         If INFO is not present and an error occurs, then the program is
! 	  terminated with an error message.
!-----------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_PPSVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT, LUPLO, LEQUED
   INTEGER :: LINFO, NRHS, N, NN, ISTAT, ISTAT1, SAF, SS, SFERR, SBERR
   REAL(WP) :: LRCOND, MVS
   COMPLEX(WP) :: WW
!  .. LOCAL POINTERS ..
   REAL(WP),  POINTER :: RWORK(:), LS(:), LFERR(:), LBERR(:)
   COMPLEX(WP),  POINTER :: WORK(:), LAF( :)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE, MINVAL, TINY, REAL, INT, AIMAG
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; NN = SIZE(A, 1); NRHS = SIZE(B, 2)
   WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW)
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(EQUED) .AND. LSAME(LFACT,'F') )THEN; LEQUED = EQUED
   ELSE; LEQUED='N'; END IF
   IF( PRESENT(AF) )THEN; SAF = SIZE(AF); ELSE; SAF = N*(N+1)/2; END IF
   IF( ( PRESENT(S) ) )THEN; SS = SIZE(S); ELSE; SS = N; END IF
   IF( PRESENT(S) .AND. LSAME(LFACT,'F') .AND. LSAME(LEQUED,'Y') ) THEN
       MVS = MINVAL(S); ELSE; MVS = TINY(1.0_WP); ENDIF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
   IF(PRESENT(UPLO))THEN; LUPLO = UPLO; ELSE; LUPLO='U'; END IF
!  .. TEST THE ARGUMENTS
   IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -2
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -3
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
   ELSE IF( SAF /= N*(N+1)/2 ) THEN; LINFO = -5
   ELSE IF( ( .NOT. ( LSAME(LFACT,'F') .OR. LSAME(LFACT,'N') .OR. &
                    LSAME(LFACT,'E') ) ) .OR. &
      ( LSAME(LFACT,'F') .AND. .NOT.PRESENT(AF) ) )THEN; LINFO = -6
   ELSE IF( .NOT.LSAME(LEQUED,'N') .AND. .NOT.LSAME(LEQUED,'Y') )THEN; LINFO = -7
   ELSE IF( SS /= N .OR. LSAME(LFACT,'F') .AND. LSAME(LEQUED,'Y') &
      .AND. MVS  <= 0.0_WP )THEN; LINFO = -8
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -9
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -10
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(AF) ) THEN; ALLOCATE( LAF(N*(N+1)/2), STAT=ISTAT )
      ELSE; LAF => AF; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(S) )THEN; ALLOCATE( LS(N), STAT=ISTAT )
         ELSE; LS => S; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 ) ALLOCATE(WORK(2*N), RWORK(N), STAT=ISTAT )
      IF( ISTAT == 0 )THEN
         CALL PPSVX_F77( LFACT, LUPLO, N, NRHS, A, LAF, LEQUED, LS, &
                  B, N, X, N, LRCOND, LFERR, LBERR, WORK, RWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(S) ) DEALLOCATE( LS, STAT=ISTAT1 )
      IF( .NOT.PRESENT(AF) ) DEALLOCATE( LAF, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      IF( PRESENT(EQUED) .AND. .NOT.LSAME(LFACT,'F') ) EQUED=LEQUED
      DEALLOCATE( WORK, RWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE ZPPSVX_F95


C
      SUBROUTINE HESSEN(A,IDIM1,M,IDIM2,B)
      IMPLICIT NONE
      INTEGER IDIM1,IDIM2,M,LC,N,N1,N2,NI,J,K
      REAL A,B,DIV
      DIMENSION A(IDIM1,IDIM2)
      DIMENSION B(M)
      DOUBLE PRECISION SUM
      IF (M-2 < 0) GOTO 30
      IF (M-2 == 0) GOTO 30
      IF (M-2 > 0) GOTO 32
   32 DO 40 LC=3,M
      N=M-LC+3
      N1=N-1
      N2=N-2
      NI=N1
      DIV=ABS(A(N,N-1))
      DO 2 J=1,N2
      IF(ABS(A(N,J))-DIV < 0) GOTO 2
      IF(ABS(A(N,J))-DIV == 0) GOTO 2
      IF(ABS(A(N,J))-DIV > 0) GOTO 1
    1 NI=J
      DIV=ABS(A(N,J))
    2 CONTINUE
      IF(DIV < 0) GOTO 3
      IF(DIV == 0) GOTO 40
      IF(DIV > 0) GOTO 3
    3 IF(NI-N1 < 0) GOTO 4
      IF(NI-N1 == 0) GOTO 7
      IF(NI-N1 > 0) GOTO 4
    4 DO 5 J=1,N
      DIV=A(J,NI)
      A(J,NI)=A(J,N1)
    5 A(J,N1)=DIV
      DO 6 J=1,M
      DIV=A(NI,J)
      A(NI,J)=A(N1,J)
    6 A(N1,J)=DIV
    7 DO 26 K=1,N1
   26 B(K)=A(N,K)/A(N,N-1)
      DO 45 J=1,M
      SUM=0.0
      IF(J-N1 < 0) GOTO 46
      IF(J-N1 == 0) GOTO 43
      IF(J-N1 > 0) GOTO 43
   46 IF(B(J) < 0) GOTO 41
      IF(B(J) == 0) GOTO 43
      IF(B(J) > 0) GOTO 41
   41 A(N,J)=0.0
      DO 42 K=1,N1
      A(K,J)=A(K,J)-A(K,N1)*B(J)
   42 SUM=SUM+A(K,J)*B(K)
      GO TO 45
   43 DO 44 K=1,N1
   44 SUM=SUM+A(K,J)*B(K)
   45 A(N1,J)=REAL(SUM)
   40 CONTINUE
   30 RETURN
      END


C Copyright (c) 2007-2017 National Technology & Engineering Solutions of
C Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C=======================================================================
*DECK,CNTR
      SUBROUTINE CNTR (ITYPE,XX,YY,ZZ,XCNTR,YCNTR,ZCNTR)
C
C     ******************************************************************
C
C     SUBROUTINE TO FIND THE CENTER COORDINATES OF AN ELEMENT
C
C     Called by ELTON3, LDCENB, SRCH2D, SRCH3D
C
C     ******************************************************************
C
      DIMENSION XX(*), YY(*), ZZ(*)
C
C     ******************************************************************
C
C     SELECT ELEMENT TYPE
C
      GO TO (100, 110, 120, 130, 140, 150, 160, 170, 180, 190,
     &    200, 210, 150), ITYPE
C
C     3-NODE TRIANGLE
C
  100 CONTINUE
      XCNTR=(XX(1)+XX(2)+XX(3))/3.
      YCNTR=(YY(1)+YY(2)+YY(3))/3.
      ZCNTR=0.
      RETURN
C
C     6-NODE TRIANGLE
C
  110 CONTINUE
      XCNTR=-(XX(1)+XX(2)+XX(3))/9.+4.*(XX(4)+XX(5)+XX(6))/9.
      YCNTR=-(YY(1)+YY(2)+YY(3))/9.+4.*(YY(4)+YY(5)+YY(6))/9.
      ZCNTR=0.
      RETURN
C
C     4-NODE QUADRILATERAL
C
  120 CONTINUE
      XCNTR=(XX(1)+XX(2)+XX(3)+XX(4))/4.
      YCNTR=(YY(1)+YY(2)+YY(3)+YY(4))/4.
      ZCNTR=0.
      RETURN
C
C     8-NODE QUADRILATERAL
C
  130 CONTINUE
      XCNTR=-(XX(1)+XX(2)+XX(3)+XX(4))/4.+(XX(5)+XX(6)+XX(7)+XX(8))/2.
      YCNTR=-(YY(1)+YY(2)+YY(3)+YY(4))/4.+(YY(5)+YY(6)+YY(7)+YY(8))/2.
      ZCNTR=0.
      RETURN
C
C     9-NODE QUADRILATERAL
C
  140 CONTINUE
      XCNTR=XX(9)
      YCNTR=YY(9)
      ZCNTR=0.
      RETURN
C
C     4-NODE TETRAHEDRON OR SHELL
C
  150 CONTINUE
      XCNTR=(XX(1)+XX(2)+XX(3)+XX(4))/4.
      YCNTR=(YY(1)+YY(2)+YY(3)+YY(4))/4.
      ZCNTR=(ZZ(1)+ZZ(2)+ZZ(3)+ZZ(4))/4.
      RETURN
C
C     10-NODE TETRAHEDRON
C
  160 CONTINUE
      XCNTR=-(XX(1)+XX(2)+XX(3)+XX(4))/8.+(XX(5)+XX(6)+XX(7)+XX(8)+
     1XX(9)+XX(10))/4.
      YCNTR=-(YY(1)+YY(2)+YY(3)+YY(4))/8.+(YY(5)+YY(6)+YY(7)+YY(8)+
     1YY(9)+YY(10))/4.
      ZCNTR=-(ZZ(1)+ZZ(2)+ZZ(3)+ZZ(4))/8.+(ZZ(5)+ZZ(6)+ZZ(7)+ZZ(8)+
     1ZZ(9)+ZZ(10))/4.
      RETURN
C
C     6-NODE PRISM
C
  170 CONTINUE
      XCNTR=(XX(1)+XX(2)+XX(3)+XX(4)+XX(5)+XX(6))/6.
      YCNTR=(YY(1)+YY(2)+YY(3)+YY(4)+YY(5)+YY(6))/6.
      ZCNTR=(ZZ(1)+ZZ(2)+ZZ(3)+ZZ(4)+ZZ(5)+ZZ(6))/6.
      RETURN
C
C     15-NODE PRISM
C
  180 CONTINUE
      XCNTR=-2.*(XX(1)+XX(2)+XX(3)+XX(4)+XX(5)+XX(6))/9.+
     12.*(XX(7)+XX(8)+XX(9)+XX(13)+XX(14)+XX(15))/9.+
     2(XX(10)+XX(11)+XX(12))/3.
      YCNTR=-2.*(YY(1)+YY(2)+YY(3)+YY(4)+YY(5)+YY(6))/9.+
     12.*(YY(7)+YY(8)+YY(9)+YY(13)+YY(14)+YY(15))/9.+
     2(YY(10)+YY(11)+YY(12))/3.
      ZCNTR=-2.*(ZZ(1)+ZZ(2)+ZZ(3)+ZZ(4)+ZZ(5)+ZZ(6))/9.+
     12.*(ZZ(7)+ZZ(8)+ZZ(9)+ZZ(13)+ZZ(14)+ZZ(15))/9.+
     2(ZZ(10)+ZZ(11)+ZZ(12))/3.
      RETURN
C
C     8-NODE HEX
C
  190 CONTINUE
      XCNTR=(XX(1)+XX(2)+XX(3)+XX(4)+XX(5)+XX(6)+XX(7)+XX(8))/8.
      YCNTR=(YY(1)+YY(2)+YY(3)+YY(4)+YY(5)+YY(6)+YY(7)+YY(8))/8.
      ZCNTR=(ZZ(1)+ZZ(2)+ZZ(3)+ZZ(4)+ZZ(5)+ZZ(6)+ZZ(7)+ZZ(8))/8.
      RETURN
C
C     20-NODE HEX
C
  200 CONTINUE
      XCNTR=-(XX(1)+XX(2)+XX(3)+XX(4)+XX(5)+XX(6)+XX(7)+XX(8))/4.+
     1(XX(9)+XX(10)+XX(11)+XX(12)+XX(13)+XX(14)+XX(15)+XX(16)+XX(17)+
     2XX(18)+XX(19)+XX(20))/4.
      YCNTR=-(YY(1)+YY(2)+YY(3)+YY(4)+YY(5)+YY(6)+YY(7)+YY(8))/4.+
     1(YY(9)+YY(10)+YY(11)+YY(12)+YY(13)+YY(14)+YY(15)+YY(16)+YY(17)+
     2YY(18)+YY(19)+YY(20))/4.
      ZCNTR=-(ZZ(1)+ZZ(2)+ZZ(3)+ZZ(4)+ZZ(5)+ZZ(6)+ZZ(7)+ZZ(8))/4.+
     1(ZZ(9)+ZZ(10)+ZZ(11)+ZZ(12)+ZZ(13)+ZZ(14)+ZZ(15)+ZZ(16)+ZZ(17)+
     2ZZ(18)+ZZ(19)+ZZ(20))/4.
      RETURN
C
C     27-NODE HEX
C
  210 CONTINUE
      XCNTR=XX(27)
      YCNTR=YY(27)
      ZCNTR=ZZ(27)
      RETURN
C
      END


! { dg-do compile }
!
! PR fortran/46328
!
! Contributed by Damian Rouson
!
module foo_module
  type ,abstract :: foo
  contains
    procedure(t_interface) ,deferred :: t
    procedure(assign_interface) ,deferred :: assign
    procedure(multiply_interface) ,deferred :: multiply
    generic :: operator(*) => multiply
    generic :: assignment(=) => assign
  end type
  abstract interface
    function t_interface(this)
      import :: foo
      class(foo) :: this
      class(foo), allocatable ::t_interface
    end function
    function multiply_interface(lhs,rhs)
      import :: foo
      class(foo), allocatable :: multiply_interface
      class(foo), intent(in) :: lhs
      real, intent(in) :: rhs
    end function
    subroutine assign_interface(lhs,rhs)
      import :: foo
      class(foo), intent(in) :: rhs
      class(foo), intent(inout) :: lhs
    end subroutine
  end interface
contains
  subroutine bar(x,dt)
    class(foo) :: x
    real, intent(in) :: dt
    x = x%t()*dt
  end subroutine
end module


!FFLAGS:-O3
!This is the testcase of bug #552
!This testcase is extracted from 454.calculix@spec2006
      subroutine e_c3d(co,s,mattyp)
      implicit none
      integer mattyp,j,k,l,i,m,n

      real*8 co(3,*),s(60,60),w(3,3),anisox(3,3,3,3),vo(3,3),weight

      if(mattyp.eq.1) then
         do j=1,2
            do k=1,2
               do i=1,2
                  s(1,j)=s(1,j) + weight
                  do m=1,2
                     do n=1,2
                        s(1,j)=s(1,j)
     &                       +anisox(m,k,n,i)
     &                       *w(k,i)*vo(1,m)*vo(j,n)
     &                       *weight
                     enddo
                  enddo
               enddo
            enddo
         enddo
      endif
      return
      end


************************************************************************
*
*     Function DDOT           Called by: DGQTST, DHUMIT, DLIVMU, DLSVMN,
*                                        DSLVMU, FACINV
*
*     form the dot product of DX and DY
*
*     based on linpack routine (j dongarra,3/11/78) that uses unrolled
*     loops for increments equal to one. Modified for the special case
*     of contiguous DX and DY (INCX=INCY=1).
*
************************************************************************
      DOUBLE PRECISION FUNCTION DDOT(N,DX,DY)
*
*     function arguments
*
      INTEGER*4 N
      DOUBLE PRECISION DX(*),DY(*)
*
*     local vars
*
      INTEGER*4 I,M
*
*     code for both increments equal to 1; clean-up loop so remaining
*     vector length is a multiple of 5.
*
      DDOT = 0.D0
      IF (N.LE.0) RETURN
      M = MOD(N,5)
      IF (M.NE.0) THEN
         DO 10 I = 1,M
            DDOT = DDOT + DX(I)*DY(I)
 10      CONTINUE
         IF (N .LT. 5) RETURN
      ENDIF

      DO 20 I = M+1,N,5
         DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1)
     &        + DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
   20 CONTINUE

      RETURN
      END


      subroutine compute_u(n_ipsi,n_rpsi,Nx,mass,res)
      implicit none
      integer i
      integer Nx
      real*8 mass
      real*8 n_ipsi(Nx)
      real*8 n_rpsi(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = mass * (n_rpsi(i) ** 2 + n_ipsi(i) ** 2)
      res(i)=qb
      end do
      END


      SUBROUTINE EBLTM3 (X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ,
     1                   XFRMT)

      REAL   X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ,
     1       XFRMT (4,4), WKA(4,4), WKB(4,4), WKC(4,4)

C shift so that fixed point is at origin
      CALL ETR3  (-X0,-Y0,-Z0, WKA)
C scale
      CALL ESC3  ( FX, FY, FZ, WKB)
      CALL ECOM3 (WKB, WKA, WKC)
C rotations
      CALL EROX  (PHIX, WKA)
      CALL ECOM3 (WKA, WKC, WKB)
      CALL EROY  (PHIY, WKA)
      CALL ECOM3 (WKA, WKB, WKC)
      CALL EROZ  (PHIZ, WKA)
      CALL ECOM3 (WKA, WKC, WKB)
C do specified shift and undo fixed-point shift
      CALL ETR3  (X0+DX, Y0+DY, Z0+DZ, WKA)
      CALL ECOM3 (WKA, WKB, XFRMT)

      END


      subroutine scaleup_boundary(nub, nvb)
      use neswrite
!      use meshes, only: md, nd
      use normal_info, only: u0, v0, rb_ws, zb_ws, vb_ws
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer :: nub, nvb
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: zero = 0, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: m, n, mn, n1, i, nuvb, iflag
      integer :: ku, kv, k, nmax, mmax
      real(rprec) :: cosnv, sinnv, alub, alvb, twopi, rtemp, ztemp
      real(rprec) :: rtemps,ztempc
      real(rprec) :: cosmu, sinmu, theta, zeta, cosmn1, sinmn1, dnorm,
     1   b1, c1, r1, re, ae, error, Map_v, sep_tol
      real(rprec), allocatable, dimension(:) :: rbn, zbn
C-----------------------------------------------
      external Map_v
!
!     Attempts to scale up boundary by a uniform distance coil_separation
!     On entry, rmnc_b, zmns_b contain the boundary coefficients
!     On exit,  they contain the scaled up boundary coefficients
!
      nuvb = nub * nvb
      twopi = 8*atan(one)
      alub = twopi/nub
      alvb = twopi/nvb                    !!Note: ixn has nfp factored out already...

      allocate (rmnc_ws(nuvb), zmns_ws(nuvb), rmns_ws(nuvb),
     1          zmnc_ws(nuvb), ixm_ws(nuvb), ixn_ws(nuvb), stat=iflag)
      if (iflag .ne. 0)stop 'Allocation error in bnorm scaleup_boundary'

      allocate (rbn(nuvb), zbn(nuvb), stat=iflag)
      if (iflag .ne. 0)stop 'Allocation error in bnorm scaleup_boundary'

      re = 10*epsilon(re)
      ae = re
      i = 0

      do ku = 1, nub
        u0 = alub*(ku - 1)
        do kv = 1, nvb
          i = i + 1
          v0 = alvb*(kv - 1)                                            !!Np*(Real toroidal angle)
          b1 = v0 - twopi/6
          c1 = v0 + twopi/6
          r1 = v0
!         Map v0 at plasma boundary to vb_ws at winding surface
          call fzero(Map_v, b1, c1, r1, re, ae, iflag)
          error = abs(Map_v (b1))
          if (iflag .gt. 2) print *,'  i = ', i,' iflag = ', iflag,
     1    ' v0 = ', v0,' vb_ws = ', vb_ws, ' v1 = ', b1,
     2    ' Error mapping to Winding Surface in BNORM code ', error

          rbn(i) = rb_ws
          zbn(i) = zb_ws
        end do
      end do

!
!     FFT new surface (use NESCOIL convention, mu + nv)
!
      mmax = min(md, (nub-1)/2)
      nmax = min(nd, abs(nvb-1)/2)
      mnmax_ws = 0
      rmnc_ws = zero;  zmns_ws = zero
      sep_tol = 1.e-3_dp*coil_separation

      mloop: do m = 0, mmax
         nloop: do n = -nmax, nmax
            if (m.eq.0 .and. n.gt.0) cycle nloop
            dnorm = one/nuvb
            if (m.ne.0 .or. n.ne.0) dnorm = 2*dnorm
            i = 0
            rtemp = zero;  ztemp = zero
            do ku = 1, nub
               theta= alub*(ku-1)
               cosmu = cos(m*theta)*dnorm
               sinmu = sin(m*theta)*dnorm
               do kv = 1, nvb
                  i = i + 1
                  zeta = alvb*(kv-1)
                  cosnv = cos(n*zeta)
                  sinnv = sin(n*zeta)
                  cosmn1 = cosmu*cosnv - sinmu*sinnv          !cos(mu+nv) NESCOIL CONVENTION
                  sinmn1 = sinmu*cosnv + cosmu*sinnv          !sin(mu+nv)
                  rtemp  = rtemp  + rbn(i) * cosmn1
                  ztemp  = ztemp  + zbn(i) * sinmn1
                  rtemps = rtemps + rbn(i) * sinmn1
                  ztempc = ztempc + zbn(i) * cosmn1
               end do
            end do
            if (abs(rtemp).lt.sep_tol .and. abs(ztemp).lt.sep_tol)
     1      cycle nloop
            mnmax_ws = mnmax_ws+1
            rmnc_ws(mnmax_ws) = rtemp
            zmns_ws(mnmax_ws) = ztemp
            rmns_ws(mnmax_ws) = rtemps
            zmnc_ws(mnmax_ws) = ztempc
            ixm_ws(mnmax_ws) = m
            ixn_ws(mnmax_ws) = n
         end do nloop
      end do mloop

      deallocate (rbn, zbn)

      end subroutine scaleup_boundary


!!$*****************************************************************************
!!$*****************************************************************************
!!$*****************************************************************************
!!$ fort_rebin.f90: utility function to rebin synthetic spectrum to data spectrum
!!$ for the petitRADTRANS radiative transfer package.
!!$
!!$ Copyright 2016-2018, Paul Molliere
!!$ Maintained by Paul Molliere, molliere@strw.leidenunivl.nl
!!$ Status: under development
!!$*****************************************************************************
!!$*****************************************************************************
!!$*****************************************************************************

subroutine rebin_spectrum(nu_synth,flux_synth,nu_obs, &
     reb_synth_flux,len_obs,len_synth)

  implicit none
  ! I/O
  integer, intent(in) :: len_obs, len_synth
  double precision, intent(in) :: nu_obs(len_obs)
  double precision, intent(in) :: nu_synth(len_synth),flux_synth(len_synth)
  double precision, intent(out) :: reb_synth_flux(len_obs)
  ! internal
  double precision :: nu_obs_bin_bords(len_obs+1)
  integer :: i_nu, i_nu_synth
  double precision :: nu1, nu2, y_ax, del_nu, ddel_nu, slope, add_fl, min_flux, max_flux

  reb_synth_flux = 0d0

  ! Check stuff...
  if (len_obs < 2) then
     STOP 'rebin.f90 ERROR: Coarse wavelength grid needs at least two wavelength points!'
  end if

  ! Get intp bin bords
  nu_obs_bin_bords(1) = nu_obs(1)-(nu_obs(2)-nu_obs(1))/2d0
  do i_nu = 2, len_obs
     nu_obs_bin_bords(i_nu) = nu_obs(i_nu)-(nu_obs(i_nu)-nu_obs(i_nu-1))/2d0
  end do
  nu_obs_bin_bords(len_obs+1) = nu_obs(len_obs)+(nu_obs(len_obs)-nu_obs(len_obs-1))/2d0

  if ((nu_synth(1) >= nu_obs_bin_bords(1)) .OR. (nu_synth(len_synth) <= nu_obs_bin_bords(len_obs+1))) then
     STOP 'rebin.f90 ERROR: Fine wavelength grid needs to extend at least half'// &
          ' a bin width further than coarse grid (on both sides)!'
  end if

  ! Start interpolation
  i_nu_synth = 1

  do i_nu = 1, len_obs

     do while (nu_synth(i_nu_synth) < nu_obs_bin_bords(i_nu))
        i_nu_synth = i_nu_synth+1
     end do

     del_nu = 0d0

     do while (nu_synth(i_nu_synth) < nu_obs_bin_bords(i_nu+1))

        nu1 = max(nu_synth(i_nu_synth-1),nu_obs_bin_bords(i_nu))
        nu2 = min(nu_synth(i_nu_synth),nu_obs_bin_bords(i_nu+1))
        ddel_nu = nu2-nu1
        slope = (flux_synth(i_nu_synth)-flux_synth(i_nu_synth-1))/ &
             (nu_synth(i_nu_synth)-nu_synth(i_nu_synth-1))
        y_ax = flux_synth(i_nu_synth-1)

        min_flux = min(flux_synth(i_nu_synth),flux_synth(i_nu_synth-1))
        max_flux = max(flux_synth(i_nu_synth),flux_synth(i_nu_synth-1))

        ! y+b*(x-a) , int from x1 .. x2
        ! y*(x2-x1)-b*a*(x2-x1)+b/2d0*(x2**2d0-x1**2d0)
        add_fl = (y_ax-slope*nu_synth(i_nu_synth-1))*(nu2-nu1) + &
             slope*(nu2-nu1)*(nu2+nu1)/2d0

        reb_synth_flux(i_nu) = reb_synth_flux(i_nu) + add_fl

        del_nu = del_nu + ddel_nu

        i_nu_synth = i_nu_synth + 1

     end do

     nu1 = max(nu_synth(i_nu_synth-1),nu_obs_bin_bords(i_nu))
     nu2 = min(nu_synth(i_nu_synth),nu_obs_bin_bords(i_nu+1))
     ddel_nu = nu2-nu1
     slope = (flux_synth(i_nu_synth)-flux_synth(i_nu_synth-1))/ &
          (nu_synth(i_nu_synth)-nu_synth(i_nu_synth-1))
     y_ax = flux_synth(i_nu_synth-1)

     min_flux = min(flux_synth(i_nu_synth),flux_synth(i_nu_synth-1))
     max_flux = max(flux_synth(i_nu_synth),flux_synth(i_nu_synth-1))

     ! y+b*(x-a) , int from x1 .. x2
     ! y*(x2-x1)-b*a*(x2-x1)+b/2d0*(x2**2d0-x1**2d0)
     add_fl = (y_ax-slope*nu_synth(i_nu_synth-1))*(nu2-nu1) + &
          slope*(nu2**2d0-nu1**2d0)/2d0

     reb_synth_flux(i_nu) = reb_synth_flux(i_nu) + add_fl

     del_nu = del_nu + ddel_nu

     reb_synth_flux(i_nu) = reb_synth_flux(i_nu)/del_nu

  end do

end subroutine rebin_spectrum


!---------------------------------------------------------------------
!
!
!     In this file (numerators.f)
!     you should place all numerator functions
!
!
!---------------------------------------------------------------------
!
      subroutine test(q,amp)
!
!-------------------------------
!
!     "Test" numerator
!
!-------------------------------
!
      implicit none
      complex*16 q(0:3)
      complex*16 amp
      integer rango
      common/rango/rango
      amp  = 2.d0+(4.d0+q(0)*2.22333d0-q(1)*30.666d0+q(2)*1.55d0
     &       +q(3)*3.6541122d0)**rango

!      amp= (2.d0+(4.d0+q(0)*2.22333d0-q(1)*30.666d0+q(2)*1.55d0
!     &            +q(3)*3.6541122d0)**2
!     &     )*(q(0)**2-q(1)**2-q(2)**2-q(3)**2+7.d0)*
!     &     (q(0)*1.12333d0-q(1)*10.666d0+q(2)*5.55d0
!     &            -q(3)*2.6541122d0)
      end subroutine test


      subroutine runCY_00i1i2i3i4i5(k,l,i1,i2,i3,i4,i5,
     . Xtwiddle,Gtwiddle,Shat7,N0)
      implicit none
C---  Expression for extension of Eq. 5.60c
C---  Calculates C00i1i2i3i4i5, requires C00li1i2i3i4
C---  Small terms of order Xtwiddle(0,k)*Ciiiiii,Xtwiddle(0,0)*Ciiiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,i1,i2,i3,i4,i5,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7(np,z6max,-2:0)

      if ( (i1.eq.l).or.(i2.eq.l).or.(i3.eq.l).or.(i4.eq.l).or.(i5.eq.l)
     ..or. (i1.eq.0).or.(i2.eq.0).or.(i3.eq.0).or.(i4.eq.0).or.(i5.eq.0)
     .    ) then
      return
      endif

      do ep=-2,0
      Cv(czziiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     .(-2d0*Gtwiddle(k,i1)*Cv(czziiiii(z5(l,i2,i3,i4,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i2)*Cv(czziiiii(z5(l,i1,i3,i4,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i3)*Cv(czziiiii(z5(l,i1,i2,i4,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i4)*Cv(czziiiii(z5(l,i1,i2,i3,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i5)*Cv(czziiiii(z5(l,i1,i2,i3,i4))+N0,ep)
     . +Gtwiddle(k,1)*Shat7(1,z6(l,i1,i2,i3,i4,i5),ep)
     . +Gtwiddle(k,2)*Shat7(2,z6(l,i1,i2,i3,i4,i5),ep)
     . +Xtwiddle(k,0)*Cv(ciiiiii(z6(l,i1,i2,i3,i4,i5))+N0,ep)
     . -Xtwiddle(0,0)*Cv(ciiiiiii(z7(k,l,i1,i2,i3,i4,i5))+N0,ep))
     . /(2d0*Gtwiddle(k,l))

      enddo

      return
      end


      SUBROUTINE PULAY(F,P,N,FPPF,FOCK,EMAT,LFOCK,NFOCK,MSIZE,START,PL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION F(*), P(*), FPPF(*), FOCK(*)
      LOGICAL START
**************************************************************************
*
*   PULAY USES DR. PETER PULAY'S METHOD FOR CONVERGENCE.
*         A MATHEMATICAL DESCRIPTION CAN BE FOUND IN
*         "P. PULAY, CHEM. PHYS. LETT., 73  393, (1980)."
*
* ARGUMENTS:-
*          ON INPUT F      = FOCK MATRIX, PACKED, LOWER HALF TRIANGLE.
*                   P      = DENSITY MATRIX, PACKED, LOWER HALF TRIANGLE.
*                   N      = NUMBER OF ORBITALS.
*                   FPPF   = WORKSTORE OF SIZE MSIZE, CONTENTS WILL BE
*                            OVERWRITTEN.
*                   FOCK   =      "       "              "         "
*                   EMAT   = WORKSTORE OF AT LEAST 15**2 ELEMENTS.
*                   START  = LOGICAL, = TRUE TO START PULAY.
*                   PL     = UNDEFINED ELEMENT.
*       ON OUTPUT   F      = "BEST" FOCK MATRIX, = LINEAR COMBINATION
*                            OF KNOWN FOCK MATRICES.
*                   START  = FALSE
*                   PL     = MEASURE OF NON-SELF-CONSISTENCY
*                          = [F*P] = F*P - P*F.
*
**************************************************************************
      COMMON /KEYWRD/ KEYWRD
      DIMENSION EMAT(20,20), EVEC(1000), COEFFS(20)
      CHARACTER*80 KEYWRD
      LOGICAL FIRST, DEBUG
      DATA FIRST/.TRUE./
      IF(FIRST) THEN
          FIRST=.FALSE.
          MAXLIM=6
          DEBUG=(INDEX(KEYWRD,'DEBUGPULAY') .NE.0)
      ENDIF
      IF(START) THEN
          LINEAR=(N*(N+1))/2
          MFOCK=MSIZE/LINEAR
          IF(MFOCK.GT.MAXLIM)MFOCK=MAXLIM
          IF(DEBUG)
     +    WRITE(6,'('' MAXIMUM SIZE:'',I5)')MFOCK
          NFOCK=1
          LFOCK=1
          START=.FALSE.
      ELSE
          IF(NFOCK.LT.MFOCK)      NFOCK=NFOCK+1
          IF(LFOCK.NE.MFOCK)THEN
              LFOCK=LFOCK+1
              ELSE
              LFOCK=1
          ENDIF
      ENDIF
      LBASE=(LFOCK-1)*LINEAR
*
*   FIRST, STORE FOCK MATRIX FOR FUTURE REFERENCE.
*
      DO 9 I=1,LINEAR
   9     FOCK((I-1)*MFOCK+LFOCK)=F(I)
*
*   NOW FORM /FOCK*DENSITY-DENSITY*FOCK/, AND STORE THIS IN FPPF
*
      CALL MAMULT(P,F,FPPF(LBASE+1),N,0.D0)
      CALL MAMULT(F,P,FPPF(LBASE+1),N,-1.D0)
*
*   FPPF NOW CONTAINS THE RESULT OF FP - PF.
*
      NFOCK1=NFOCK+1
      DO 10 I=1,NFOCK
          EMAT(NFOCK1,I)=-1.D0
          EMAT(I,NFOCK1)=-1.D0
          EMAT(LFOCK,I)=DOT(FPPF((I-1)*LINEAR+1),FPPF(LBASE+1),LINEAR)
  10      EMAT(I,LFOCK)=EMAT(LFOCK,I)
      PL=EMAT(LFOCK,LFOCK)/LINEAR
      EMAT(NFOCK1,NFOCK1)=0.D0
      CONST=1.D0/EMAT(LFOCK,LFOCK)
C#     + *1.D4
      DO 14 I=1,NFOCK
      DO 14 J=1,NFOCK
  14  EMAT(I,J)=EMAT(I,J)*CONST
      IF(DEBUG) THEN
          WRITE(6,'('' EMAT'')')
          DO 66 I=1,NFOCK1
  66      WRITE(6,'(6E13.6)')(EMAT(J,I),J=1,NFOCK1)
      ENDIF
      L=0
      DO 20 I=1,NFOCK1
          DO 20 J=1,NFOCK1
              L=L+1
  20          EVEC(L)=EMAT(I,J)
      CONST=1.D0/CONST
      DO 15 I=1,NFOCK
      DO 15 J=1,NFOCK
  15  EMAT(I,J)=EMAT(I,J)*CONST
*********************************************************************
*   THE MATRIX EMAT SHOULD HAVE FORM
*
*      |<E(1)*E(1)>  <E(1)*E(2)> ...   -1.0|
*      |<E(2)*E(1)>  <E(2)*E(2)> ...   -1.0|
*      |<E(3)*E(1)>  <E(3)*E(2)> ...   -1.0|
*      |<E(4)*E(1)>  <E(4)*E(2)> ...   -1.0|
*      |     .            .      ...     . |
*      |   -1.0         -1.0     ...    0. |
*
*   WHERE <E(I)*E(J)> IS THE SCALAR PRODUCT OF [F*P] FOR ITERATION I
*   TIMES [F*P] FOR ITERATION J.
*
*********************************************************************
      CALL OSINV(EVEC,NFOCK1,D)
C#      WRITE(6,'(''   D:'',E16.5)')D
      IF(ABS(D).LT.1.D-6)THEN
          START=.TRUE.
          RETURN
      ENDIF
      IF(NFOCK.LT.2) RETURN
      IL=NFOCK*NFOCK1
      DO 29 I=1,NFOCK
  29  COEFFS(I)=-EVEC(I+IL)
      IF(DEBUG) THEN
          WRITE(6,'('' EVEC'')')
          WRITE(6,'(6F12.6)')(COEFFS(I),I=1,NFOCK)
          WRITE(6,'(''    LAGRANGIAN MULTIPLIER (ERROR) =''
     +             ,F13.6)')EVEC(NFOCK1*NFOCK1)
      ENDIF
      DO 30 I=1,LINEAR
          SUM=0
          L=0
          II=(I-1)*MFOCK
          DO 40 J=1,NFOCK
  40          SUM=SUM+COEFFS(J)*FOCK(J+II)
  30      F(I)=SUM
C#      WRITE(6,'('' AFTER RE-INVERSION '')')
C#      CALL OSINV(EVEC,NFOCK1,D)
C#      DO 87 I=1,NFOCK1
C#      IL=(I-1)*NFOCK1+1
C#      IU=IL+NFOCK1-1
C#  87  WRITE(6,'(6E10.3)')(EVEC(J),J=IL,IU)
      RETURN
      END


*=======================================================================
        SUBROUTINE ORTHNRM(N,LIM,ORTHO,KPASS,NNCV,SCRA1,
     :                     BASIS,RESTART)
*=======================================================================
*
*       It orthogonalizes the new NNCV basis vectors starting from the
*       kpass+1, to the previous vectors of the basis and to themselves.
*       A Gram-Schmidt method is followed after which the residuals
*       should be orthogonal to the BASIS. Because of machine arithmetic
*       errors this orthogonality may be lost, and a reorthogonalization
*       procedure is adopted whenever orthogonality loss is above a
*       ORTHO. If after some reorthogonalizations the procedure does not
*       converge to orthogonality, the basis is collapsed to the
*       current eigenvector approximations.
*
*       Subroutines called:
*       DAXPY, DDOT, DSCAL
*-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION(A-H,O-Z)
        DIMENSION BASIS(N*LIM)
        DIMENSION SCRA1(N)
        LOGICAL RESTART
*-----------------------------------------------------------------------
*   on entry
*   --------
*   N           The order of the matrix A
*   LIM         The limit on the size of the expanding Basis
*   ORTHO       The orthogonality threshold
*   KPASS       The number of basis vectors already in Basis
*   NNCV        The number of new vectors in the basis
*   SCRA1       Scratch vector of size N
*   BASIS       the expanding basis having kpass vectors
*
*   on exit
*   -------
*   BASIS       the new basis orthonormalized
*   RESTART     Logical, if true the algoritm will collapse BASIS.
*-----------------------------------------------------------------------
*
* ORTHOGONALIZATION
*
        RESTART=.false.
        ICUR=KPASS*N+1
*
*       .. do iv=1,nncv
        IV = 1
 30     CONTINUE

           DPREV=1.D+7
 5         DCUR=0.D0
           IBSTART=1
           DO 10 I=1,KPASS+IV-1
              SCRA1(I)=DDOT(N,BASIS(IBSTART),1,BASIS(ICUR),1)
              DCUR=MAX(DCUR,ABS(SCRA1(I)))
              IBSTART=IBSTART+N
 10        CONTINUE
           IBSTART=1
           DO 20 I=1,KPASS+IV-1
              CALL DAXPY(N,-SCRA1(I),BASIS(IBSTART),1,BASIS(ICUR),1)
              IBSTART=IBSTART+N
 20        CONTINUE

           IF (DCUR.GE.ORTHO) THEN
              IF (DCUR.GT.DPREV) THEN
                 RESTART=.true.
*                ..Adjust the number of added vectors.
                 NNCV=IV-1
                 RETURN
              ELSE
                 DPREV=DCUR
                 GOTO 5
              ENDIF
           ENDIF
*
* NORMALIZATION
*
           SCRA1(1)=DDOT(N,BASIS(ICUR),1,BASIS(ICUR),1)
           SCRA1(1)=SQRT(SCRA1(1))
           IF (SCRA1(1).LT.1D-14) THEN
              CALL DCOPY(N,BASIS( N*(NNCV-1)+1),1,BASIS(ICUR),1)
              NNCV=NNCV-1
           ELSE
              CALL DSCAL(N,1/SCRA1(1),BASIS(ICUR),1)
              ICUR=ICUR+N
              IV = IV +1
           ENDIF
        IF (IV.LE.NNCV) GOTO 30

        RETURN
        END