SUBROUTINE ZSCQR( M, N, A, LDA, R, LDR, WORK, WORK2, INFO )
      
      IMPLICIT NONE
      
      INTEGER            M, N, LDA, LDR
      COMPLEX*16         A( LDA, * ), R( LDR, N ), WORK( N, * )
      DOUBLE PRECISION   WORK2( * ) 
      COMPLEX*16         ZONE, ZZERO
      PARAMETER          ( ZONE=(1.0D+0,0.0D+0), ZZERO=(0.0D+0,0.0D+0) )
      LOGICAL            FLAG2
      INTEGER            COUNT, INFO, I, J

      COUNT = 0

 10   COUNT = COUNT + 1

      CALL ZRQRCQR( M, N, A, LDA, WORK(1,1), WORK(1,N+1),
     $     WORK(1,2*N+1), WORK2, FLAG2, INFO )

      IF (INFO .EQ. -1) THEN
         INFO = COUNT
         RETURN
      ENDIF

      IF (COUNT .EQ. 1) THEN

         DO I = 1, N
            CALL ZCOPY(I,WORK(1,N+I),1,R(1,I),1)
            DO J = I+1, N
               R(J, I) = ZZERO
            ENDDO
         ENDDO
         
      ELSE

         CALL ZTRMM('L','U','N','N',N,N,ZONE,WORK(1,N+1),N,R,LDR)

      ENDIF
      
      IF (FLAG2 .EQV. .FALSE.) GO TO 10

      RETURN

      END SUBROUTINE ZSCQR
*
      SUBROUTINE ZSCQRH( COUNT, M, N, A, LDA, R, LDR, WORK, WORK2,
     $                   INFO )
      
      IMPLICIT NONE
      
      INTEGER            COUNT, M, N, LDA, LDR
      COMPLEX*16         A( LDA, * ), R( 5, LDR, N ), WORK( N, * )
      DOUBLE PRECISION   WORK2( * )
      COMPLEX*16         ZZERO
      PARAMETER          ( ZZERO=(0.0D+0,0.0D+0) )
      LOGICAL            FLAG2
      INTEGER            INFO, I, J

      COUNT = 0

 10   COUNT = COUNT + 1

      IF (COUNT .EQ. 6) THEN
         INFO = COUNT
         RETURN
      ENDIF
         
      CALL ZRQRCQR( M, N, A, LDA, WORK(1,1), WORK(1,N+1),
     $     WORK(1,2*N+1), WORK2, FLAG2, INFO )

      IF (INFO .EQ. -1) RETURN

      DO I = 1, N
         CALL ZCOPY(I,WORK(1,N+I),1,R(COUNT,1,I),1)
         DO J = I+1, N
            R(COUNT, J, I) = ZZERO
         ENDDO
      ENDDO
         
      IF (FLAG2 .EQV. .FALSE.) GO TO 10

      RETURN

      END SUBROUTINE ZSCQRH
*
      SUBROUTINE ZRQRCQR( M, N, Q, LDQ, WORK, WORK2, WORK3, 
     $                    WORK4, FLAG2, INFO )
*     
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      INTEGER            M, N, LDQ, INFO
      LOGICAL            FLAG2
*     ..
*     .. Array Arguments ..
      COMPLEX*16         Q( LDQ, * ), WORK( N, N ), WORK2( N, N ),
     $                   WORK3( * )
      DOUBLE PRECISION   WORK4( * )
*
*  =====================================================================
*
*     .. parameters ..
      DOUBLE PRECISION   DTWO, DONE, DZERO
      PARAMETER          ( DTWO=2.0D+0, DONE=1.0D+0, DZERO=0.0D+0 )
      COMPLEX*16         ZONE, ZZERO
      PARAMETER          ( ZONE=(1.0D+0,0.0D+0), ZZERO=(0.0D+0,0.0D+0) )
*     ..
*     .. local scalars ..
      INTEGER            IINFO, K, I, J, I0
      DOUBLE PRECISION   SHIFT, EPS, DLAMCH, TMP, OF, DZNRM2
      COMPLEX*16         ZDOTC
*     ..
*     .. external functions ..
      EXTERNAL           ZHERK, ZPOTRF, DLAMCH, DZNRM2, ZDOTC
*     ..
*     .. Executable Statements ..
*
      EPS = DLAMCH( 'Precision' )
      OF = DLAMCH( 'O' )
*
      CALL ZHERK('U','C',N,M,DONE,Q,LDQ,DZERO,WORK,N)

      DO K = 1, N
         IF (DBLE(WORK(K,K)) .GT. OF .OR.
     $        DBLE(WORK(K,K)) .EQ. DZERO) THEN
            GO TO 10
         ENDIF
      END DO
*         
      SHIFT = DZERO
      I0 = 0
*     
      DO K = 1, 2*N

         DO I = 1, N
            CALL ZCOPY(I,WORK(1,I),1,WORK2(1,I),1)
         ENDDO

         IF (SHIFT .NE. DZERO) THEN
            DO I = 1, N
               WORK2(I,I) = WORK2(I,I) + SHIFT
            ENDDO
         ENDIF

         CALL ZPOTRF('U',N,WORK2,N,IINFO)
         
         IF (IINFO .EQ. 0) THEN
            IF (SHIFT .EQ. DZERO) THEN
               CALL ZTRCON('I','U','N',N,WORK2,N,TMP,WORK3,
     $              WORK4(N+1),IINFO)
               IF (SQRT(SQRT(SQRT(EPS))) .GT. TMP) THEN
                  FLAG2 = .FALSE.
               ELSE
                  FLAG2 = .TRUE.
               END IF
            ELSE
               FLAG2 = .FALSE.
            END IF
*     
            CALL ZTRSM('R','U','N','N',M,N,ZONE,WORK2,N,Q,LDQ)

            INFO = 0
            RETURN
*
         ELSE

            IF (I0 .EQ. IINFO) THEN
               SHIFT = DTWO*SHIFT
            ELSE
               I0 = IINFO
               TMP=SHIFT-DBLE(WORK2(IINFO,IINFO))
               IF (TMP .NE. SHIFT) THEN
                  SHIFT=TMP
               ELSE
                  IF (SHIFT .EQ. DZERO) THEN
                     TMP = DZERO
                     DO I=1,N
                        TMP = MAX(TMP,DBLE(WORK(I,I)))
                     ENDDO
                     SHIFT=EPS*TMP
                  ELSE
                     SHIFT=(DONE+EPS)*SHIFT
                  ENDIF
               ENDIF
            ENDIF
            
            WRITE (*,*) 'S',I0,SHIFT

         ENDIF
         
      ENDDO
*     
      INFO = -1
      RETURN

 10   DO K = 1, N
         WORK4(K) = DZNRM2( M, Q( 1, K ), 1 )
         CALL ZDSCAL( M, DONE/WORK4(K), Q( 1, K ), 1 )
      END DO
      
      CALL ZHERK('U','C',N,M,DONE,Q,LDQ,DZERO,WORK,N)
*     
      SHIFT = DZERO
      I0 = 0
*     
      DO K = 1, 2*N
         
         DO I = 1, N
            CALL ZCOPY(I,WORK(1,I),1,WORK2(1,I),1)
         ENDDO
         
         IF (SHIFT .NE. DZERO) THEN
            DO I = 1, N
               WORK2(I,I) = WORK2(I,I) + SHIFT
            ENDDO
         ENDIF
         
         CALL ZPOTRF('U',N,WORK2,N,IINFO)
         
         IF (IINFO .EQ. 0) THEN
            IF (SHIFT .EQ. DZERO) THEN
               CALL ZTRCON('I','U','N',N,WORK2,N,TMP,WORK3,
     $              WORK4(N+1),IINFO)
               IF (SQRT(SQRT(SQRT(EPS))) .GT. TMP) THEN
                  FLAG2 = .FALSE.
               ELSE
                  FLAG2 = .TRUE.
               END IF
            ELSE
               FLAG2 = .FALSE.
            END IF
*     
            CALL ZTRSM('R','U','N','N',M,N,ZONE,WORK2,N,Q,LDQ)

            DO I = 1, N
               CALL ZDSCAL( I, WORK4(I), WORK2( 1, I ), 1 )
            END DO
      
            INFO = 0
            RETURN
*
         ELSE

            IF (I0 .EQ. IINFO) THEN
               SHIFT = DTWO*SHIFT
            ELSE
               I0 = IINFO
               TMP=SHIFT-DBLE(WORK2(IINFO,IINFO))
               IF (TMP .NE. SHIFT) THEN
                  SHIFT=TMP
               ELSE
                  IF (SHIFT .EQ. DZERO) THEN
                     SHIFT=EPS
                  ELSE
                     SHIFT=(DONE+EPS)*SHIFT
                  ENDIF
               ENDIF
            ENDIF
            
            WRITE (*,*) 'S',I0,SHIFT

         ENDIF
            
      ENDDO
*     
      INFO = -1
      RETURN
*
      END SUBROUTINE ZRQRCQR