      SUBROUTINE MB03XZ( BALANC, JOB, JOBU, N, A, LDA, QG, LDQG, U1,
     $                   LDU1, U2, LDU2, WR, WI, ILO, SCALE, DWORK,
     $                   LDWORK, ZWORK, LZWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a Hamiltonian matrix,
C
C                   [  A   G  ]         H        H
C             H  =  [       H ],   G = G ,  Q = Q ,                  (1)
C                   [  Q  -A  ]
C
C     where A, G and Q are complex n-by-n matrices.
C
C     Due to the structure of H, if lambda is an eigenvalue, then
C     -conjugate(lambda) is also an eigenvalue. This does not mean that
C     purely imaginary eigenvalues are necessarily multiple. The routine
C     computes the eigenvalues of H using an embedding to a real skew-
C     Hamiltonian matrix He,
C
C                    [  Ae   Ge  ]            T            T
C             He  =  [         T ],   Ge = -Ge ,   Qe = -Qe ,        (2)
C                    [  Qe   Ae  ]
C
C     where Ae, Ge, and Qe are real 2*n-by-2*n matrices, defined by
C
C                    [   Im(A)   Re(A)  ]
C             Ae  =  [                  ],
C                    [  -Re(A)   Im(A)  ]
C
C                    [  triu(Im(G))     Re(G)     ]
C        triu(Ge) =  [                            ],
C                    [       0       triu(Im(G))  ]
C
C                    [  tril(Im(Q))       0       ]
C        tril(Qe) =  [                            ],
C                    [     -Re(Q)    tril(Im(Q))  ]
C
C     and triu and tril denote the upper and lower triangle,
C     respectively. Then, an orthogonal symplectic matrix Ue is used to
C     reduce He to the structured real Schur form
C
C           T          [  Se   De ]            T
C          Ue He Ue =  [        T ],   De = -De ,                    (3)
C                      [  0    Se ]
C
C     where Ue is a 4n-by-4n real symplectic matrix, and Se is upper
C     quasi-triangular (real Schur form).
C
C     Optionally, if JOB = 'S', or JOB = 'G', the matrix i*He is further
C     transformed to the structured complex Schur form
C
C           H            [  Sc  Gc ]           H
C          U (i*He) U =  [       H ],   Gc = Gc ,                    (4)
C                        [  0  -Sc ]
C
C     where U is a 4n-by-4n unitary symplectic matrix, and Sc is upper
C     triangular (Schur form).
C
C     The algorithm is backward stable and preserves the spectrum
C     structure in finite precision arithmetic.
C
C     Optionally, a symplectic balancing transformation to improve the
C     conditioning of eigenvalues is computed (see the SLICOT Library
C     routine MB04DZ). In this case, the matrix He in decompositions (3)
C     and (4) must be replaced by the balanced matrix.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     BALANC  CHARACTER*1
C             Indicates how H should be diagonally scaled and/or
C             permuted to reduce its norm.
C             = 'N': Do not diagonally scale or permute;
C             = 'P': Perform symplectic permutations to make the matrix
C                    closer to skew-Hamiltonian Schur form. Do not
C                    diagonally scale;
C             = 'S': Diagonally scale the matrix, i.e., replace A, G and
C                    Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where
C                    D is a diagonal matrix chosen to make the rows and
C                    columns of H more equal in norm. Do not permute;
C             = 'B': Both diagonally scale and permute A, G and Q.
C             Permuting does not change the norm of H, but scaling does.
C
C     JOB     CHARACTER*1
C             Indicates whether the user wishes to compute the full
C             decomposition (4) or the eigenvalues only, as follows:
C             = 'E': compute the eigenvalues only;
C             = 'S': compute the matrix Sc of (4);
C             = 'G': compute the matrices Sc and Gc of (4).
C
C     JOBU    CHARACTER*1
C             Indicates whether or not the user wishes to compute the
C             symplectic matrix Ue of (3), if JOB = 'E', or U of (4),
C             if JOB = 'S' or JOB = 'G', as follows:
C             = 'N': the matrix Ue or U is not computed;
C             = 'U': the matrix Ue or U is computed.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA,K)
C             where K = N, if JOB = 'E', and K = 2*N, if JOB <> 'E'.
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, if JOB = 'E', the leading N-by-N part of this
C             array is unchanged, if BALANC = 'N', or it contains the
C             balanced (permuted and/or scaled) matrix A, if
C             BALANC <> 'N'.
C             On exit, if JOB = 'S' or JOB = 'G', the leading 2*N-by-2*N
C             upper triangular part of this array contains the matrix Sc
C             (complex Schur form) of decomposition (4).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,K).
C
C     QG      (input/output) COMPLEX*16 array, dimension
C                            (LDQG,min(K+1,2*N))
C             On entry, the leading N-by-N+1 part of this array must
C             contain in columns 1:N the lower triangular part of the
C             matrix Q and in columns 2:N+1 the upper triangular part
C             of the matrix G.
C             On exit, if JOB <> 'G', the leading N-by-N+1 part of this
C             array is unchanged, if BALANC = 'N', or it contains the
C             balanced (permuted and/or scaled) parts of the matrices
C             Q and G (as above), if BALANC <> 'N'.
C             On exit, JOB = 'G', the leading 2*N-by-2*N upper
C             triangular part of this array contains the upper
C             triangular part of the matrix Gc in the decomposition (4).
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= max(1,K).
C
C     U1      (output) COMPLEX*16 array, dimension (LDU1,2*N)
C             On exit, if JOB = 'S' or JOB = 'G', and JOBU = 'U', the
C             leading 2*N-by-2*N part of this array contains the (1,1)
C             block of the unitary symplectic matrix U of the
C             decomposition (4).
C             If JOB = 'E' or JOBU = 'N', this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.  LDU1 >= 1.
C             LDU1 >= 2*N,    if JOBU = 'U'.
C
C     U2      (output) COMPLEX*16 array, dimension (LDU2,2*N)
C             On exit, if JOB = 'S' or JOB = 'G', and JOBU = 'U', the
C             leading 2*N-by-2*N part of this array contains the (1,2)
C             block of the unitary symplectic matrix U of the
C             decomposition (4).
C             If JOB = 'E' or JOBU = 'N', this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.  LDU2 >= 1.
C             LDU2 >= 2*N,    if JOBU = 'U'.
C
C     WR      (output) DOUBLE PRECISION array, dimension (2*N)
C     WI      (output) DOUBLE PRECISION array, dimension (2*N)
C             On exit, the leading 2*N elements of WR and WI contain the
C             real and imaginary parts, respectively, of the eigenvalues
C             of the Hamiltonian matrix H.
C
C     ILO     (output) INTEGER
C             ILO is an integer value determined when H was balanced.
C             The balanced A(I,J) = 0 if I > J and J = 1,...,ILO-1.
C             The balanced Q(I,J) = 0 if J = 1,...,ILO-1 or
C             I = 1,...,ILO-1.
C
C     SCALE   (output) DOUBLE PRECISION array, dimension (N)
C             On exit, if BALANC <> 'N', the leading N elements of this
C             array contain details of the permutation and/or scaling
C             factors applied when balancing H, see MB04DZ.
C             This array is not referenced if BALANC = 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK, and   DWORK(2)  returns the 1-norm of the
C             (scaled, if BALANC = 'S' or 'B') Hamiltonian matrix.
C             Moreover, the next locations of this array have the
C             following content:
C             - The leading 2*N-by-2*N upper Hessenberg part in the
C             locations 3:2+4*N*N contains the upper Hessenberg part of
C             the real Schur matrix Se in the decomposition (3);
C             - the leading 2*N-by-2*N upper triangular part in the
C             locations 3+4*N*N+2*N:2+8*N*N+2*N contains the upper
C             triangular part of the skew-symmetric matrix De in the
C             decomposition (3).
C             - If JOBU = 'U', the leading 2*N-by-2*N part in the
C             locations 3+8*N*N+2*N:2+12*N*N+2*N contains the (1,1)
C             block of the orthogonal symplectic matrix Ue of
C             decomposition (3).
C             - the leading 2*N-by-2*N part in the locations
C             3+12*N*N+2*N:2+16*N*N+2*N contains the (2,1) block of the
C             orthogonal symplectic matrix Ue.
C             On exit, if  INFO = -18,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= MAX( 12*N**2 + 4*N, 8*N**2 + 12*N ) + 2,
C                                    if JOB = 'E' and JOBU = 'N';
C             LDWORK >= MAX( 2, 12*N**2 + 4*N, 8*N**2 + 12*N ),
C                                    if JOB = 'S' or 'G' and JOBU = 'N';
C             LDWORK >= 20*N**2 + 12*N + 2,
C                                    if JOB = 'E' and JOBU = 'U';
C             LDWORK >= MAX( 2, 20*N**2 + 12*N ),
C                                    if JOB = 'S' or 'G' and JOBU = 'U'.
C             For good performance, LDWORK must generally be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0,  ZWORK(1)  returns the optimal
C             value of LZWORK.
C             On exit, if  INFO = -20,  ZWORK(1)  returns the minimum
C             value of LZWORK.
C
C     LZWORK  INTEGER
C             The dimension of the array ZWORK.
C             LZWORK >= 1,                  if JOB = 'E';
C             LZWORK >= MAX( 1, 12*N - 6 ), if JOB = 'S' and JOBU = 'N';
C             LZWORK >= MAX( 1, 12*N - 2 ), if JOB = 'G' or  JOBU = 'U'.
C
C             If LZWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             ZWORK array, returns this value as the first entry of
C             the ZWORK array, and no error message related to LZWORK
C             is issued by XERBLA.
C
C     BWORK   LOGICAL array, dimension (LBWORK)
C             LBWORK >= 0,     if JOB = 'E';
C             LBWORK >= 2*N-1, if JOB = 'S' or JOB = 'G'.
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              > 0:  if INFO = i, the QR algorithm failed to compute
C                    all the eigenvalues; elements i+1:2*N of WR and
C                    WI contain eigenvalues which have converged;
C              = 2*N+1:  the QR algorithm failed to compute the
C                    eigenvalues of a 2-by-2 real block.
C
C     METHOD
C
C     First, the extended matrix He in (2) is built. Then, the
C     structured real Schur form in (3) is computed, using the SLICOT
C     Library routine MB03XS. The eigenvalues of Se immediately give
C     the eigenvalues of H. Finally, if required, Se is further
C     transformed by using the complex QR algorithm to triangularize
C     its 2-by-2 blocks, and Ge and U are updated, to obtain (4).
C
C     REFERENCES
C
C     [1] Van Loan, C.F.
C         A symplectic method for approximating all the eigenvalues of
C         a Hamiltonian matrix.
C         Linear Algebra and its Applications, 61, pp. 233-251, 1984.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2011.
C
C     REVISIONS
C
C     V. Sima, Dec. 2011, Sep. 2012, Oct. 2012.
C
C     KEYWORDS
C
C     Schur form, eigenvalues, skew-Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
     $                     CONE  = ( 1.0D0, 0.0D0 ) )
C     .. Scalar Arguments ..
      CHARACTER          BALANC, JOB, JOBU
      INTEGER            ILO, INFO, LDA, LDQG, LDU1, LDU2, LDWORK,
     $                   LZWORK, N
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      DOUBLE PRECISION   DWORK( * ), SCALE( * ), WI( * ), WR( * )
      COMPLEX*16         A( LDA, * ), QG( LDQG, * ), U1( LDU1, * ),
     $                   U2( LDU2, * ), ZWORK( * )
C     .. Local Scalars ..
      LOGICAL            LQUERY, LSCAL, SCALEH, WANTG, WANTS, WANTU,
     $                   WANTUS
      INTEGER            I, I1, IA, IERR, IEV, IQG, IS, IU, IU1, IU2,
     $                   IUB, IW, IW1, IWRK, J, J1, J2, JM1, JP2, K,
     $                   MINDB, MINDW, MINZW, N2, NB, NC, NC1, NN, NN2,
     $                   OPTDW, OPTZW
      DOUBLE PRECISION   BIGNUM, CSCALE, EPS, HNR1, HNRM, NRMB, SMLNUM
      COMPLEX*16         TMP
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, MA02IZ
      EXTERNAL           DLAMCH, LSAME, MA02IZ
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLABAD, DLACPY, DLASCL, MB03XS, MB04DZ,
     $                   XERBLA, ZGEMM, ZGEQRF, ZLACPY, ZLAHQR, ZLASCL,
     $                   ZLASET
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, SQRT
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      NN    = N*N
      N2    = 2*N
      NN2   = N2*N2
      INFO  = 0
      LSCAL = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'S' ) .OR.
     $        LSAME( BALANC, 'B' )
      WANTG = LSAME( JOB,    'G' )
      WANTS = LSAME( JOB,    'S' ) .OR. WANTG
      WANTU = LSAME( JOBU,   'U' )
C
      WANTUS = WANTS .AND. WANTU
C
      IF ( WANTS ) THEN
         K = N2
      ELSE
         K = N
      END IF
C
      IF ( N.EQ.0 ) THEN
         MINDW = 2
      ELSE IF ( WANTU ) THEN
         MINDB = 4*NN2 + N2
         IF ( WANTS ) THEN
            MINDW = MAX( 2, 20*NN + 12*N )
         ELSE
            MINDW = 20*NN + 12*N + 2
         END IF
      ELSE
         MINDB = 2*NN2 + N2
         IF ( WANTS ) THEN
            MINDW = MAX( 2, 12*NN + 4*N, 8*NN + 12*N )
         ELSE
            MINDW = MAX( 12*NN + 4*N, 8*NN + 12*N ) + 2
         END IF
      END IF
      IF ( WANTG .OR. WANTU ) THEN
         MINZW = MAX( 1, 12*N - 2 )
      ELSE IF ( WANTS ) THEN
         MINZW = MAX( 1, 12*N - 6 )
      ELSE
         MINZW = 1
      END IF
      LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1
C
C     Test the scalar input parameters.
C
      IF ( .NOT.LSCAL .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB,  'E' ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 ) THEN
         INFO = -4
      ELSE IF (  LDA.LT.MAX( 1, K ) ) THEN
         INFO = -6
      ELSE IF ( LDQG.LT.MAX( 1, K ) ) THEN
         INFO = -8
      ELSE IF ( LDU1.LT.1 .OR. ( WANTUS .AND. LDU1.LT.N2 ) ) THEN
         INFO = -10
      ELSE IF ( LDU2.LT.1 .OR. ( WANTUS .AND. LDU2.LT.N2 ) ) THEN
         INFO = -12
      ELSE IF ( .NOT. LQUERY ) THEN
         IF ( LDWORK.LT.MINDW ) THEN
            DWORK( 1 ) = MINDW
            INFO = -18
         ELSE IF ( LZWORK.LT.MINZW ) THEN
            ZWORK( 1 ) = MINZW
            INFO = -20
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03XZ', -INFO )
         RETURN
      ELSE IF ( N.GT.0 ) THEN
C
C        Set the pointers for the inputs and outputs of MB03XS.
C
         IF ( WANTS ) THEN
            IA = 1
         ELSE
            IA = 3
         END IF
         IQG = IA + NN2
         IF ( WANTU ) THEN
            IU1  = IQG + NN2 + N2
            IU2  = IU1 + NN2
            IWRK = IU2 + NN2
         ELSE
            IU1  = IQG
            IU2  = IQG
            IWRK = IQG + NN2 + N2
         END IF
C
C        Compute optimal workspace.
C
         OPTZW = MINZW
         IF ( WANTS ) THEN
            CALL ZGEQRF( N2, N2, ZWORK, N2, ZWORK, ZWORK, -1, INFO )
            I  = INT( ZWORK( 1 ) )
            NB = MAX( I/N2, 2 )
         END IF
C
         IF ( LQUERY ) THEN
            CALL MB03XS( JOBU, N2, DWORK, N2, DWORK, N2, DWORK, N2,
     $                   DWORK, N2, WI, WR, DWORK, -1, INFO )
            OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) )
            DWORK( 1 ) = OPTDW
            ZWORK( 1 ) = OPTZW
            RETURN
         END IF
      END IF
C
C     Quick return if possible.
C
      ILO = 1
      IF ( N.EQ.0 ) THEN
         DWORK( 1 ) = TWO
         DWORK( 2 ) = ZERO
         ZWORK( 1 ) = CONE
         RETURN
      END IF
C
      EPS    = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Scale H if maximal element is outside range [SMLNUM,BIGNUM].
C
      HNRM = MA02IZ( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG,
     $               DWORK )
      SCALEH = .FALSE.
      IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN
         SCALEH = .TRUE.
         CSCALE = SMLNUM
      ELSE IF ( HNRM.GT.BIGNUM ) THEN
         SCALEH = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF ( SCALEH ) THEN
        CALL ZLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR )
        CALL ZLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG,
     $               IERR )
      END IF
C
C     Balance the matrix and compute the 1-norm.
C
      IF ( LSCAL ) THEN
         CALL MB04DZ( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR )
      ELSE
         ILO = 1
      END IF
C
C     Real workspace:    need  2*N.
C
      HNR1 = MA02IZ( 'Hamiltonian', '1-norm', N, A, LDA, QG, LDQG,
     $               DWORK )
C
C     Set up the embeddings of the matrix H.
C
C     Real workspace:    need  w1 =  8*N**2 + 2*N, if JOBU = 'N';
C                              w1 = 16*N**2 + 2*N, if JOBU = 'U'.
C
C     Build the embedding of A.
C
      IW = IA
      IS = IW + N2*N
      DO 30 J = 1, N
         IW1 = IW
         DO 10 I = 1, N
            DWORK( IW ) = DIMAG( A( I, J ) )
            IW = IW + 1
   10    CONTINUE
C
         DO 20 I = 1, N
            DWORK( IW ) = -DBLE( A( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
   20    CONTINUE
         CALL DCOPY( N, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IS = IS + N
   30 CONTINUE
C
C     Build the embedding of G and Q.
C
      IW = IQG
      DO 60 J = 1, N + 1
         DO 40 I = 1, N
            DWORK( IW ) = DIMAG( QG( I, J ) )
            IW = IW + 1
   40    CONTINUE
C
         IW = IW + J - 1
         IS = IW
         DO 50 I = J, N
            DWORK( IW ) = -DBLE( QG( I, J ) )
            DWORK( IS ) =  DWORK( IW )
            IW = IW + 1
            IS = IS + N2
   50    CONTINUE
   60 CONTINUE
C
      IW1 = IW
      I1  = IW
      DO 80 J = 2, N + 1
         IS = I1
         I1 = I1 + 1
         DO 70 I = 1, J - 1
            DWORK( IW ) = DBLE( QG( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N2
   70    CONTINUE
         IW = IW + N2 - J + 1
   80 CONTINUE
      CALL DLACPY( 'Full', N, N+1, DWORK( IQG ), N2, DWORK( IW1-N ),
     $             N2 )
C
C     Compute the eigenvalues and real skew-Hamiltonian Schur form of
C     the embedded skew-Hamiltonian matrix.
C
C     Real workspace:    need  w1 + w2, where
C                              w2 = max( 4*N**2 + 2*N,
C                                        10*N ),       if JOBU = 'N';
C                              w2 = 4*N**2 + 10*N,     if JOBU = 'U'.
C                        prefer larger.
C
      CALL MB03XS( JOBU, N2, DWORK( IA ), N2, DWORK( IQG ), N2,
     $             DWORK( IU1 ), N2, DWORK( IU2 ), N2, WI, WR,
     $             DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      IF ( INFO.NE.0 )
     $   RETURN
C
      OPTDW = MAX( MINDW, INT( DWORK(IWRK) ) + IWRK - 1 )
C
C     Return if further reduction is not required.
C
      IF ( .NOT.WANTS ) THEN
         IF ( SCALEH ) THEN
C
C           Undo scaling.
C
            CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N2, N2,
     $                   DWORK( IA ), N2, IERR )
            IF ( WANTG )
     $         CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, N2,
     $                      DWORK( IQG+N2 ), N2, IERR )
            CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WR, N2,
     $                   IERR )
            CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WI, N2,
     $                   IERR )
            HNR1 = HNR1 * HNRM / CSCALE
         END IF
         GO TO 190
      END IF
C
C     Convert the results to complex datatype. G starts now in the
C     first column of QG.
C     Only the upper triangular part of G is used below.
C
      IW = IA
      DO 100 J = 1, N2
         DO 90 I = 1, MIN( J+1, N2 )
            A( I, J ) = DCMPLX( ZERO, DWORK( IW ) )
            IW = IW + 1
   90    CONTINUE
         IW = IW + N2 - MIN( J+1, N2 )
  100 CONTINUE
C
      IF ( WANTG ) THEN
         IW = IQG + N2
         DO 120 J = 1, N2
            DO 110 I = 1, J - 1
               QG( I, J ) = DCMPLX( ZERO, DWORK( IW ) )
               IW = IW + 1
  110       CONTINUE
            QG( J, J ) = CZERO
            IW = IW + N2 - J + 1
  120    CONTINUE
      END IF
C
      IF ( WANTU ) THEN
C
C        Set the transformation matrix.
C
         IW = IU1
         DO 140 J = 1, N2
            DO 130 I = 1, N2
               U1( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  130       CONTINUE
  140    CONTINUE
C
         DO 160 J = 1, N2
            DO 150 I = 1, N2
               U2( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  150       CONTINUE
  160    CONTINUE
      END IF
C
C     Triangularize the 2-by-2 diagonal blocks in Se using the complex
C     version of the QR algorithm.
C
C     Set up pointers on the outputs of ZLAHQR.
C     A block algorithm is used for large N2.
C
      IEV  = 1
      IU   = 3
      IWRK = IU + 4*( N2 - 1 )
C
      J  = 1
      J2 = MIN( N2, NB )
C     WHILE( J.LT.N2 ) DO
  170 CONTINUE
      IF ( J.LT.N2 ) THEN
         NRMB = ABS( A( J, J ) ) + ABS( A( J+1, J+1 ) )
         IF ( ABS( A( J+1, J ) ).GT.NRMB*EPS ) THEN
C
C           Triangularization step.
C           Workspace:    need   8*N - 2 (complex).
C
            NC  = MAX( J2-J-1, 0 )
            NC1 = MAX( J2-J+1, 0 )
            JM1 = MAX( J-1, 1 )
            JP2 = MIN( J+2, N2 )
            CALL ZLASET( 'Full', 2, 2, CZERO, CONE, ZWORK( IU ), 2 )
            CALL ZLAHQR( .TRUE., .TRUE., 2, 1, 2, A( J, J ), LDA,
     $                   ZWORK( IEV ), 1, 2, ZWORK( IU ), 2, INFO )
            IF ( INFO.GT.0 ) THEN
               INFO = N2 + 1
               RETURN
            END IF
C
C           Update A.
C           Workspace:    need   12*N - 6.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', J-1, 2, 2,
     $                   CONE, A( 1, J ), LDA, ZWORK( IU ), 2, CZERO,
     $                   ZWORK( IWRK ), JM1 )
            CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, A( 1, J ),
     $                   LDA )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2, NC,
     $                   2, CONE, ZWORK( IU ), 2, A( J, JP2 ), LDA,
     $                   CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, A( J, JP2 ),
     $                   LDA )
C
            IF ( WANTG ) THEN
C
C              Update G.
C              Workspace:    need   12*N - 2.
C
               TMP          =  QG( J+1, J )
               QG( J+1, J ) = -QG( J, J+1 )
               CALL ZGEMM(  'No Transpose', 'No Transpose', J+1, 2, 2,
     $                      CONE, QG( 1, J ), LDQG, ZWORK( IU ), 2,
     $                      CZERO, ZWORK( IWRK ), J+1 )
               CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1,
     $                      QG( 1, J ), LDQG )
               CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                      NC1, 2, CONE, ZWORK( IU ), 2, QG( J, J ),
     $                      LDQG, CZERO, ZWORK( IWRK ), 2 )
               CALL ZLACPY( 'Full', 2, NC1, ZWORK( IWRK ), 2,
     $                      QG( J, J ), LDQG )
               QG( J+1, J ) = TMP
            END IF
C
            IF ( WANTU ) THEN
C
C              Update U.
C              Workspace:    need   12*N - 2.
C
               CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2,
     $                      CONE, U1( 1, J ), LDU1, ZWORK( IU ), 2,
     $                      CZERO, ZWORK( IWRK ), N2 )
               CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2,
     $                      U1( 1, J ), LDU1 )
               CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2,
     $                      CONE, U2( 1, J ), LDU2, ZWORK( IU ), 2,
     $                      CZERO, ZWORK( IWRK ), N2 )
               CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2,
     $                      U2( 1, J ), LDU2 )
            END IF
C
            BWORK( J ) = .TRUE.
            J  = J  + 2
            IU = IU + 4
         ELSE
            BWORK( J )  = .FALSE.
            A( J+1, J ) = CZERO
            J = J + 1
         END IF
C
         IF ( J.GE.J2 .AND. J.LT.N2 ) THEN
            J1 = J2 + 1
            J2 = MIN( N2, J1 + NB - 1 )
            NC = J2 - J1 + 1
C
C           Update the columns J1 to J2 of A and QG for previous
C           transformations.
C
            I   = 1
            IUB = 3
C           WHILE( I.LT.J ) DO
  180       CONTINUE
            IF ( I.LT.J ) THEN
               IF ( BWORK( I ) ) THEN
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IUB ), 2, A( I, J1 ),
     $                         LDA, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         A( I, J1 ), LDA )
C
                  IF ( WANTG ) THEN
                     CALL ZGEMM(  'Conjugate Transpose', 'No Transpose',
     $                            2, NC, 2, CONE, ZWORK( IUB ), 2,
     $                            QG( I, J1 ), LDQG, CZERO,
     $                            ZWORK( IWRK ), 2 )
                     CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                            QG( I, J1 ), LDQG )
                  END IF
C
                  IUB = IUB + 4
C
                  I = I + 2
               ELSE
                  I = I + 1
               END IF
               GO TO 180
            END IF
C           END WHILE 180
         END IF
         GO TO 170
      END IF
C     END WHILE 170
C
      IF ( SCALEH ) THEN
C
C        Undo scaling.
C
         CALL ZLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N2, N2, A, LDA,
     $                IERR )
         If ( WANTG )
     $      CALL ZLASCL( 'General', 0, 0, CSCALE, HNRM, N2, N2, QG(1,2),
     $                   LDQG, IERR )
         CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WR, N2,
     $                IERR )
         CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WI, N2,
     $                IERR )
         HNR1 = HNR1 * HNRM / CSCALE
      END IF
C
  190 CONTINUE
      DWORK( 1 ) = DBLE( OPTDW )
      DWORK( 2 ) = HNR1
      ZWORK( 1 ) = OPTZW
      RETURN
C *** Last line of MB03XZ ***
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vhsgs.f
c
c     this file contains code and documentation for subroutines
c     vhsgs and vhsgsi
c
c ... files which must be loaded with vhsgs.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvhsgs,lvhsgs,work,lwork,ierror)
c
c
c     subroutine vhsgs performs the vector spherical harmonic synthesis
c     of the arrays br, bi, cr, and ci and stores the result in the
c     arrays v and w.  the synthesis is performed on an equally spaced
c     longitude grid and a gaussian colatitude grid (measured from
c     the north pole). v(i,j) and w(i,j) are the colatitudinal and
c     east longitudinal components respectively, located at the i(th)
c     colatitude gaussian point (see nlat below) and longitude
c     phi(j) = (j-1)*2*pi/nlon.  the spectral respresentation of (v,w)
c     is given below at output parameters v,w.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 2  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 3  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 5  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 6  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 8  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c
c     nt     the number of syntheses.  in the program that calls vhsgs,
c            the arrays v,w,br,bi,cr, and ci can be three dimensional
c            in which case multiple syntheses will be performed.
c            the third index is the synthesis index which assumes the
c            values k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls vhags. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls vhsgs. jdvw must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            in the spectral representation of v(i,j) and w(i,j) given
c            below at the discription of output parameters v and w.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhsgs. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhsgs. ndab must be at
c            least nlat.
c
c     wvhsgs an array which must be initialized by subroutine vhsgsi.
c            once initialized, wvhsgs can be used repeatedly by vhsgs
c            as long as nlon and nlat remain unchanged.  wvhsgs must
c            not be altered between calls of vhsgs.
c
c     lvhsgs the dimension of the array wvhsgs as it appears in the
c            program that calls vhsgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsgs must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhsgs. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c
c                       (2*nt+1)*nlat*nlon
c
c            if ityp .gt. 2 then lwork must be at least
c
c                        (2*nt+1)*l2*nlon
c
c     **************************************************************
c
c     output parameters
c
c     v,w    two or three dimensional arrays (see input parameter nt)
c            in which the synthesis is stored. v is the colatitudinal
c            component and w is the east longitudinal component.
C*PL*ERROR* Comment line too long
c            v(i,j),w(i,j) contain the components at the guassian colatitude
c            point theta(i) and longitude phi(j) = (j-1)*2*pi/nlon.
c            the index ranges are defined above at the input parameter
c            ityp. v and w are computed from the formulas given below.
c
c
c     define
c
c     1.  theta is colatitude and phi is east longitude
c
c     2.  the normalized associated legendre funnctions
c
c         pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative
c                        of (x**2-1)**n with respect to x=cos(theta)
c
c     3.  vbar(m,n,theta) = the derivative of pbar(m,n,theta) with
c                           respect to theta divided by the square
c                           root of n(n+1).
c
c         vbar(m,n,theta) is more easily computed in the form
c
c         vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta)
c         -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1)))
c
c     4.  wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided
c                           by the square root of n(n+1).
c
c         wbar(m,n,theta) is more easily computed in the form
c
c         wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1))
c         *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta))
c         /(2*sqrt(n*(n+1)))
c
c
c    the colatitudnal dependence of the normalized surface vector
c                spherical harmonics are defined by
c
c     5.    bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta))
c
c     6.    cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta))
c
c
c    the coordinate to index mappings
c
C*PL*ERROR* Comment line too long
c     7.   theta(i) = i(th) gaussian grid point and phi(j) = (j-1)*2*pi/nlon
c
c
c     the maximum (plus one) longitudinal wave number
c
c     8.     mmax = min0(nlat,nlon/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    if we further define the output vector as
c
c     9.    h(i,j) = (v(i,j),w(i,j))
c
c    and the complex coefficients
c
c     10.   b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1))
c
c     11.   c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1))
c
c
c    then for i=1,...,nlat and  j=1,...,nlon
c
c        the expansion for real h(i,j) takes the form
c
c     h(i,j) = the sum from n=1 to n=nlat-1 of the real part of
c
c         .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i)))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c              b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j))
c             +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j))
c
c   *************************************************************
c
c   in terms of real variables this expansion takes the form
c
c             for i=1,...,nlat and  j=1,...,nlon
c
c     v(i,j) = the sum from n=1 to n=nlat-1 of
c
c               .5*br(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c       (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c    and for i=1,...,nlat and  j=1,...,nlon
c
c     w(i,j) = the sum from n=1 to n=nlat-1 of
c
c              -.5*cr(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c      -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c
c      br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are
c      assumed zero for m even.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lvhsgs
c            = 10 error in the specification of lwork
c
c
c     subroutine vhsgsi(nlat,nlon,wvhsgs,lvhsgs,dwork,ldwork,ierror)
c
c     subroutine vhsgsi initializes the array wvhsgs which can then be
c     used repeatedly by subroutine vhsgs until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lvhsgs the dimension of the array wvhsgs as it appears in the
c            program that calls vhsgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsgs must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
c
c     dwork a double precision work array that does not need to be saved
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls vhsgsi. ldwork must be at least
c
c                 (3*nlat*(nlat+3)+2)/2

c
c     **************************************************************
c
c     output parameters
c
c     wvhsgs an array which is initialized for use by subroutine vhsgs.
c            once initialized, wvhsgs can be used repeatedly by vhsgs
c            as long as nlat and nlon remain unchanged.  wvhsgs must not
c            be altered between calls of vhsgs.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lvhsgs
c            = 4  error in the specification of lwork
c
      SUBROUTINE DVHSGS(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,
     +                  MDAB,NDAB,WVHSGS,LVHSGS,WORK,LWORK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WVHSGS
      DOUBLE PRECISION WORK
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),WORK(1),
     +          WVHSGS(1)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IF (ITYP.LT.0 .OR. ITYP.GT.8) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ITYP.LE.2.AND.IDVW.LT.NLAT) .OR.
     +    (ITYP.GT.2.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      IF (LVHSGS.LT.LZIMN+LZIMN+NLON+15) RETURN
      IERROR = 10
      IDV = NLAT
      IF (ITYP.GT.2) IDV = IMID
      LNL = NT*IDV*NLON
      IF (LWORK.LT.LNL+LNL+IDV*NLON) RETURN
      IERROR = 0
      IST = 0
      IF (ITYP.LE.2) IST = IMID
c
c     set wvhsgs pointers
c
      LMN = NLAT* (NLAT+1)/2
      JW1 = 1
      JW2 = JW1 + IMID*LMN
      JW3 = JW2 + IMID*LMN
c
c     set work pointers
c
      IW1 = IST + 1
      IW2 = LNL + 1
      IW3 = IW2 + IST
      IW4 = IW2 + LNL

      CALL DVHSGS1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,BR,
     +             BI,CR,CI,IDV,WORK,WORK(IW1),WORK(IW2),WORK(IW3),
     +             WORK(IW4),IDZ,WVHSGS(JW1),WVHSGS(JW2),WVHSGS(JW3))
      RETURN
      END

      SUBROUTINE DVHSGS1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,
     +                  BR,BI,CR,CI,IDV,VE,VO,WE,WO,WORK,IDZ,VB,WB,
     +                  WRFFT)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION VE
      DOUBLE PRECISION VO
      DOUBLE PRECISION WE
      DOUBLE PRECISION WO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION WRFFT
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),
     +          VE(IDV,NLON,1),VO(IDV,NLON,1),WE(IDV,NLON,1),
     +          WO(IDV,NLON,1),WORK(1),WRFFT(1),VB(IMID,1),WB(IMID,1)

      NLP1 = NLAT + 1
      MLAT = MOD(NLAT,2)
      MLON = MOD(NLON,2)
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMM1 = IMID
      IF (MLAT.NE.0) IMM1 = IMID - 1
      DO 10 K = 1,NT
          DO 10 J = 1,NLON
              DO 10 I = 1,IDV
                  VE(I,J,K) = 0.D0
                  WE(I,J,K) = 0.D0
   10 CONTINUE
      NDO1 = NLAT
      NDO2 = NLAT
      IF (MLAT.NE.0) NDO1 = NLAT - 1
      IF (MLAT.EQ.0) NDO2 = NLAT - 1
   18 ITYPP = ITYP + 1
      GO TO (1,100,200,300,400,500,600,700,800) ITYPP
c
c     case ityp=0   no symmetries
c
c     case m = 0
c
    1 CONTINUE
      DO 15 K = 1,NT
          DO 15 NP1 = 2,NDO2,2
              DO 15 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
   15 CONTINUE
      DO 16 K = 1,NT
          DO 16 NP1 = 3,NDO1,2
              DO 16 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
   16 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 30 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 26
          DO 25 K = 1,NT
              DO 24 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 23 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
   23             CONTINUE
                  IF (MLAT.EQ.0) GO TO 24
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
   24         CONTINUE
   25     CONTINUE
   26     IF (MP2.GT.NDO2) GO TO 30
          DO 29 K = 1,NT
              DO 28 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 27 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
   27             CONTINUE
                  IF (MLAT.EQ.0) GO TO 28
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
   28         CONTINUE
   29     CONTINUE
   30 CONTINUE
      GO TO 950
c
c     case ityp=1   no symmetries,  cr and ci equal zero
c
c     case m = 0
c
  100 CONTINUE
      DO 115 K = 1,NT
          DO 115 NP1 = 2,NDO2,2
              DO 115 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  115 CONTINUE
      DO 116 K = 1,NT
          DO 116 NP1 = 3,NDO1,2
              DO 116 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  116 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 130 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 126
          DO 125 K = 1,NT
              DO 124 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 123 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  123             CONTINUE
                  IF (MLAT.EQ.0) GO TO 124
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
  124         CONTINUE
  125     CONTINUE
  126     IF (MP2.GT.NDO2) GO TO 130
          DO 129 K = 1,NT
              DO 128 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 127 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  127             CONTINUE
                  IF (MLAT.EQ.0) GO TO 128
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
  128         CONTINUE
  129     CONTINUE
  130 CONTINUE
      GO TO 950
c
c     case ityp=2   no symmetries,  br and bi are equal to zero
c
c     case m = 0
c
  200 DO 215 K = 1,NT
          DO 215 NP1 = 2,NDO2,2
              DO 215 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  215 CONTINUE
      DO 216 K = 1,NT
          DO 216 NP1 = 3,NDO1,2
              DO 216 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  216 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 230 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 226
          DO 225 K = 1,NT
              DO 224 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 223 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  223             CONTINUE
                  IF (MLAT.EQ.0) GO TO 224
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
  224         CONTINUE
  225     CONTINUE
  226     IF (MP2.GT.NDO2) GO TO 230
          DO 229 K = 1,NT
              DO 228 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 227 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  227             CONTINUE
                  IF (MLAT.EQ.0) GO TO 228
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
  228         CONTINUE
  229     CONTINUE
  230 CONTINUE
      GO TO 950
c
c     case ityp=3   v even,  w odd
c
c     case m = 0
c
  300 DO 315 K = 1,NT
          DO 315 NP1 = 2,NDO2,2
              DO 315 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  315 CONTINUE
      DO 316 K = 1,NT
          DO 316 NP1 = 3,NDO1,2
              DO 316 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  316 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 330 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 326
          DO 325 K = 1,NT
              DO 324 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 323 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  323             CONTINUE
                  IF (MLAT.EQ.0) GO TO 324
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
  324         CONTINUE
  325     CONTINUE
  326     IF (MP2.GT.NDO2) GO TO 330
          DO 329 K = 1,NT
              DO 328 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 327 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  327             CONTINUE
                  IF (MLAT.EQ.0) GO TO 328
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
  328         CONTINUE
  329     CONTINUE
  330 CONTINUE
      GO TO 950
c
c     case ityp=4   v even,  w odd, and both cr and ci equal zero
c
c     case m = 0
c
  400 DO 415 K = 1,NT
          DO 415 NP1 = 2,NDO2,2
              DO 415 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  415 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 430 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 430
          DO 429 K = 1,NT
              DO 428 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 427 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  427             CONTINUE
                  IF (MLAT.EQ.0) GO TO 428
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
  428         CONTINUE
  429     CONTINUE
  430 CONTINUE
      GO TO 950
c
c     case ityp=5   v even,  w odd,     br and bi equal zero
c
c     case m = 0
c
  500 DO 516 K = 1,NT
          DO 516 NP1 = 3,NDO1,2
              DO 516 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  516 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 530 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 530
          DO 525 K = 1,NT
              DO 524 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 523 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  523             CONTINUE
                  IF (MLAT.EQ.0) GO TO 524
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
  524         CONTINUE
  525     CONTINUE
  530 CONTINUE
      GO TO 950
c
c     case ityp=6   v odd  ,  w even
c
c     case m = 0
c
  600 DO 615 K = 1,NT
          DO 615 NP1 = 2,NDO2,2
              DO 615 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  615 CONTINUE
      DO 616 K = 1,NT
          DO 616 NP1 = 3,NDO1,2
              DO 616 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  616 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 630 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 626
          DO 625 K = 1,NT
              DO 624 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 623 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  623             CONTINUE
                  IF (MLAT.EQ.0) GO TO 624
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
  624         CONTINUE
  625     CONTINUE
  626     IF (MP2.GT.NDO2) GO TO 630
          DO 629 K = 1,NT
              DO 628 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 627 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  627             CONTINUE
                  IF (MLAT.EQ.0) GO TO 628
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
  628         CONTINUE
  629     CONTINUE
  630 CONTINUE
      GO TO 950
c
c     case ityp=7   v odd, w even   cr and ci equal zero
c
c     case m = 0
c
  700 DO 716 K = 1,NT
          DO 716 NP1 = 3,NDO1,2
              DO 716 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  716 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 730 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 730
          DO 725 K = 1,NT
              DO 724 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 723 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  723             CONTINUE
                  IF (MLAT.EQ.0) GO TO 724
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
  724         CONTINUE
  725     CONTINUE
  730 CONTINUE
      GO TO 950
c
c     case ityp=8   v odd,  w even   br and bi equal zero
c
c     case m = 0
c
  800 DO 815 K = 1,NT
          DO 815 NP1 = 2,NDO2,2
              DO 815 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  815 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 830 MP1 = 2,MMAX
          M = MP1 - 1
c     mb = m*(nlat-1)-(m*(m-1))/2
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 830
          DO 829 K = 1,NT
              DO 828 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 827 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  827             CONTINUE
                  IF (MLAT.EQ.0) GO TO 828
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
  828         CONTINUE
  829     CONTINUE
  830 CONTINUE
  950 CONTINUE
      DO 14 K = 1,NT
          CALL DHRFFTB(IDV,NLON,VE(1,1,K),IDV,WRFFT,WORK)
          CALL DHRFFTB(IDV,NLON,WE(1,1,K),IDV,WRFFT,WORK)
   14 CONTINUE
      IF (ITYP.GT.2) GO TO 12
      DO 60 K = 1,NT
          DO 60 J = 1,NLON
              DO 60 I = 1,IMM1
                  V(I,J,K) = .5D0* (VE(I,J,K)+VO(I,J,K))
                  W(I,J,K) = .5D0* (WE(I,J,K)+WO(I,J,K))
                  V(NLP1-I,J,K) = .5D0* (VE(I,J,K)-VO(I,J,K))
                  W(NLP1-I,J,K) = .5D0* (WE(I,J,K)-WO(I,J,K))
   60 CONTINUE
      GO TO 13
   12 DO 11 K = 1,NT
          DO 11 J = 1,NLON
              DO 11 I = 1,IMM1
                  V(I,J,K) = .5D0*VE(I,J,K)
                  W(I,J,K) = .5D0*WE(I,J,K)
   11 CONTINUE
   13 IF (MLAT.EQ.0) RETURN
      DO 65 K = 1,NT
          DO 65 J = 1,NLON
              V(IMID,J,K) = .5D0*VE(IMID,J,K)
              W(IMID,J,K) = .5D0*WE(IMID,J,K)
   65 CONTINUE
      RETURN
      END
      SUBROUTINE DVHSGSI(NLAT,NLON,WVHSGS,LVHSGS,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WVHSGS
c
c     subroutine vhsfsi computes the gaussian points theta, gauss
c     weights wts, and the components vb and wb of the vector
c     harmonics. all quantities are computed internally in double
c     precision but returned in single precision and are therfore
c     accurate to single precision.
c
c     set imid = (nlat+1)/2 and lmn=(nlat*(nlat+1))/2 then
c     wvhsgs must have 2*(imid*lmn+nlat)+nlon+15 locations
c
c     double precision array dwork must have
c       3*nlat*(nlat+1)+5*nlat+1 = nlat*(3*nlat+8)+1
c     locations which is determined by the size of dthet,
c     dwts, dwork, and dpbar in vhsgs1
c
      DIMENSION WVHSGS(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(*)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IMID = (NLAT+1)/2
      LMN = (NLAT* (NLAT+1))/2
      IF (LVHSGS.LT.2* (IMID*LMN)+NLON+15) RETURN
      IERROR = 4
      IF (LDWORK.LT. (NLAT*3* (NLAT+3)+2)/2) RETURN
      IERROR = 0
c
c     set saved work space pointers
c
      JW1 = 1
      JW2 = JW1 + IMID*LMN
      JW3 = JW2 + IMID*LMN
c
c     set unsaved work space pointers
c
      IW1 = 1
      IW2 = IW1 + NLAT
      IW3 = IW2 + NLAT
      IW4 = IW3 + 3*IMID*NLAT
c     iw2 = iw1+nlat+nlat
c     iw3 = iw2+nlat+nlat
c     iw4 = iw3+6*imid*nlat
      CALL DVHGSI1(NLAT,IMID,WVHSGS(JW1),WVHSGS(JW2),DWORK(IW1),
     +             DWORK(IW2),DWORK(IW3),DWORK(IW4))
      CALL DHRFFTI(NLON,WVHSGS(JW3))
      RETURN
      END
      SUBROUTINE DVHGSI1(NLAT,IMID,VB,WB,DTHET,DWTS,DPBAR,WORK)
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DIMENSION VB(IMID,*),WB(IMID,*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION ABEL,BBEL,CBEL,SSQR2,DCF
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DTHET(*),DWTS(*),DPBAR(IMID,NLAT,3),WORK(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DN,DM
c
c     compute gauss points and weights
c     use dpbar (length 3*nnlat*(nnlat+1)) as work space for gaqd
c
      LWK = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHET,DWTS,DPBAR,LWK,IERROR)
C*PT*WARNING* Constant already double-precision
c
c     compute associated legendre functions
c
c     compute m=n=0 legendre polynomials for all theta(i)
c
      SSQR2 = 1.D0/DSQRT(2.d0)
      DO 90 I = 1,IMID
          DPBAR(I,1,1) = SSQR2
          VB(I,1) = 0.D0
          WB(I,1) = 0.D0
   90 CONTINUE
c
c     main loop for remaining vb, and wb
c
      DO 100 N = 1,NLAT - 1
C*PT*WARNING* Already double-precision (DBLE)
          DN = DBLE(N)
          NM = MOD(N-2,3) + 1
          NZ = MOD(N-1,3) + 1
          NP = MOD(N,3) + 1
c
c     compute dpbar for m=0
c
          CALL DDNLFK(0,N,WORK)
          MN = INDX(0,N,NLAT)
          DO 105 I = 1,IMID
              CALL DDNLFT(0,N,DTHET(I),WORK,DPBAR(I,1,NP))
c      pbar(i,mn) = dpbar(i,1,np)
  105     CONTINUE
c
c     compute dpbar for m=1
c
          CALL DDNLFK(1,N,WORK)
          MN = INDX(1,N,NLAT)
          DO 106 I = 1,IMID
              CALL DDNLFT(1,N,DTHET(I),WORK,DPBAR(I,2,NP))
c      pbar(i,mn) = dpbar(i,2,np)
  106     CONTINUE
  104     CONTINUE
c
c     compute and store dpbar for m=2,n
c
          IF (N.LT.2) GO TO 108
          DO 107 M = 2,N
C*PT*WARNING* Already double-precision (DBLE)
              DM = DBLE(M)
              ABEL = DSQRT(((2*DN+1)* (DM+DN-2)* (DM+DN-3))/
     +               ((2*DN-3)* (DM+DN-1)* (DM+DN)))
              BBEL = DSQRT(((2*DN+1)* (DN-DM-1)* (DN-DM))/
     +               ((2*DN-3)* (DM+DN-1)* (DM+DN)))
              CBEL = DSQRT(((DN-DM+1)* (DN-DM+2))/ ((DM+DN-1)* (DM+DN)))
              ID = INDX(M,N,NLAT)
              IF (M.GE.N-1) GO TO 102
              DO 103 I = 1,IMID
                  DPBAR(I,M+1,NP) = ABEL*DPBAR(I,M-1,NM) +
     +                              BBEL*DPBAR(I,M+1,NM) -
     +                              CBEL*DPBAR(I,M-1,NP)
c      pbar(i,id) = dpbar(i,m+1,np)
  103         CONTINUE
              GO TO 107
  102         DO 101 I = 1,IMID
                  DPBAR(I,M+1,NP) = ABEL*DPBAR(I,M-1,NM) -
     +                              CBEL*DPBAR(I,M-1,NP)
c      pbar(i,id) = dpbar(i,m+1,np)
  101         CONTINUE
  107     CONTINUE
c
c     compute the derivative of the functions
c
  108     IX = INDX(0,N,NLAT)
          IY = INDX(N,N,NLAT)
          DO 125 I = 1,IMID
              VB(I,IX) = -DPBAR(I,2,NP)
              VB(I,IY) = DPBAR(I,N,NP)/DSQRT(2* (DN+1))
  125     CONTINUE
c
          IF (N.EQ.1) GO TO 131
          DCF = DSQRT(4*DN* (DN+1))
          DO 130 M = 1,N - 1
              DM = DBLE(M)
              IX = INDX(M,N,NLAT)
              ABEL = DSQRT((DN+DM)* (DN-DM+1))/DCF
              BBEL = DSQRT((DN-DM)* (DN+DM+1))/DCF
              DO 130 I = 1,IMID
                  VB(I,IX) = ABEL*DPBAR(I,M,NP) - BBEL*DPBAR(I,M+2,NP)
  130     CONTINUE
c
c     compute the vector harmonic w(theta) = m*pbar/cos(theta)
c
c     set wb=0 for m=0
c
  131     IX = INDX(0,N,NLAT)
          DO 220 I = 1,IMID
C*PT*WARNING* Constant already double-precision
              WB(I,IX) = 0.d0
  220     CONTINUE
c
c     compute wb for m=1,n
c
          DCF = DSQRT((DN+DN+1)/ (4*DN* (DN+1)* (DN+DN-1)))
          DO 230 M = 1,N
              DM = DBLE(M)
              IX = INDX(M,N,NLAT)
              ABEL = DCF*DSQRT((DN+DM)* (DN+DM-1))
              BBEL = DCF*DSQRT((DN-DM)* (DN-DM-1))
              IF (M.GE.N-1) GO TO 231
              DO 229 I = 1,IMID
                  WB(I,IX) = ABEL*DPBAR(I,M,NZ) + BBEL*DPBAR(I,M+2,NZ)
  229         CONTINUE
              GO TO 230
  231         DO 228 I = 1,IMID
                  WB(I,IX) = ABEL*DPBAR(I,M,NZ)
  228         CONTINUE
  230     CONTINUE
  100 CONTINUE
      RETURN
      END


      SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
     $                   LDQ, Z, LDZ, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  CGGHRD reduces a pair of complex matrices (A,B) to generalized upper
*  Hessenberg form using unitary transformations, where A is a
*  general matrix and B is upper triangular.  The form of the generalized
*  eigenvalue problem is
*     A*x = lambda*B*x,
*  and B is typically made upper triangular by computing its QR
*  factorization and moving the unitary matrix Q to the left side
*  of the equation.
*
*  This subroutine simultaneously reduces A to a Hessenberg matrix H:
*     Q**H*A*Z = H
*  and transforms B to another upper triangular matrix T:
*     Q**H*B*Z = T
*  in order to reduce the problem to its standard form
*     H*y = lambda*T*y
*  where y = Z**H*x.
*
*  The unitary matrices Q and Z are determined as products of Givens
*  rotations.  They may either be formed explicitly, or they may be
*  postmultiplied into input matrices Q1 and Z1, so that
*       Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
*       Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
*  If Q1 is the unitary matrix from the QR factorization of B in the
*  original equation A*x = lambda*B*x, then CGGHRD reduces the original
*  problem to generalized Hessenberg form.
*
*  Arguments
*  =========
*
*  COMPQ   (input) CHARACTER*1
*          = 'N': do not compute Q;
*          = 'I': Q is initialized to the unit matrix, and the
*                 unitary matrix Q is returned;
*          = 'V': Q must contain a unitary matrix Q1 on entry,
*                 and the product Q1*Q is returned.
*
*  COMPZ   (input) CHARACTER*1
*          = 'N': do not compute Q;
*          = 'I': Q is initialized to the unit matrix, and the
*                 unitary matrix Q is returned;
*          = 'V': Q must contain a unitary matrix Q1 on entry,
*                 and the product Q1*Q is returned.
*
*  N       (input) INTEGER
*          The order of the matrices A and B.  N >= 0.
*
*  ILO     (input) INTEGER
*  IHI     (input) INTEGER
*          ILO and IHI mark the rows and columns of A which are to be
*          reduced.  It is assumed that A is already upper triangular
*          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
*          normally set by a previous call to CGGBAL; otherwise they
*          should be set to 1 and N respectively.
*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
*  A       (input/output) COMPLEX array, dimension (LDA, N)
*          On entry, the N-by-N general matrix to be reduced.
*          On exit, the upper triangle and the first subdiagonal of A
*          are overwritten with the upper Hessenberg matrix H, and the
*          rest is set to zero.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  B       (input/output) COMPLEX array, dimension (LDB, N)
*          On entry, the N-by-N upper triangular matrix B.
*          On exit, the upper triangular matrix T = Q**H B Z.  The
*          elements below the diagonal are set to zero.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  Q       (input/output) COMPLEX array, dimension (LDQ, N)
*          On entry, if COMPQ = 'V', the unitary matrix Q1, typically
*          from the QR factorization of B.
*          On exit, if COMPQ='I', the unitary matrix Q, and if
*          COMPQ = 'V', the product Q1*Q.
*          Not referenced if COMPQ='N'.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.
*          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
*
*  Z       (input/output) COMPLEX array, dimension (LDZ, N)
*          On entry, if COMPZ = 'V', the unitary matrix Z1.
*          On exit, if COMPZ='I', the unitary matrix Z, and if
*          COMPZ = 'V', the product Z1*Z.
*          Not referenced if COMPZ='N'.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.
*          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  This routine reduces A to Hessenberg and B to triangular form by
*  an unblocked reduction, as described in _Matrix_Computations_,
*  by Golub and van Loan (Johns Hopkins Press).
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            CONE, CZERO
      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
     $                   CZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILQ, ILZ
      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
      REAL               C
      COMPLEX            CTEMP, S
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLARTG, CLASET, CROT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
*     ..
*     .. Executable Statements ..
*
*     Decode COMPQ
*
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
*
*     Decode COMPZ
*
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF( ICOMPQ.LE.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -4
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -11
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGGHRD', -INFO )
         RETURN
      END IF
*
*     Initialize Q and Z if desired.
*
      IF( ICOMPQ.EQ.3 )
     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 )
     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
*     Quick return if possible
*
      IF( N.LE.1 )
     $   RETURN
*
*     Zero out lower triangle of B
*
      DO 20 JCOL = 1, N - 1
         DO 10 JROW = JCOL + 1, N
            B( JROW, JCOL ) = CZERO
   10    CONTINUE
   20 CONTINUE
*
*     Reduce A and B
*
      DO 40 JCOL = ILO, IHI - 2
*
         DO 30 JROW = IHI, JCOL + 2, -1
*
*           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
*
            CTEMP = A( JROW-1, JCOL )
            CALL CLARTG( CTEMP, A( JROW, JCOL ), C, S,
     $                   A( JROW-1, JCOL ) )
            A( JROW, JCOL ) = CZERO
            CALL CROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
     $                 A( JROW, JCOL+1 ), LDA, C, S )
            CALL CROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
     $                 B( JROW, JROW-1 ), LDB, C, S )
            IF( ILQ )
     $         CALL CROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C,
     $                    CONJG( S ) )
*
*           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
*
            CTEMP = B( JROW, JROW )
            CALL CLARTG( CTEMP, B( JROW, JROW-1 ), C, S,
     $                   B( JROW, JROW ) )
            B( JROW, JROW-1 ) = CZERO
            CALL CROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
            CALL CROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
     $                 S )
            IF( ILZ )
     $         CALL CROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
   30    CONTINUE
   40 CONTINUE
*
      RETURN
*
*     End of CGGHRD
*
      END


program ray_trace
    use pnm
    use scene

    implicit none

    integer, parameter :: height=512, width=512
    real, dimension(width,height,3) :: image
    integer, dimension(width,height,3) :: int_image
    real,parameter :: aspect_ratio = width/height
    ! View_plane properties
    real,parameter :: view_len = width / tan(fov/2)/2
    real, dimension(3) :: hor,top_pixel
    ! ray tracing variables
    real, dimension(3) :: ray, pixel, subpixel
    real :: colour(3), tmp_colour(3)

    integer :: i,j,ii,jj,naa=4

    ! Set up the ray tracer geometry
    ! view_len = ubound(image, 1) / tan(fov/2.0) / 2.0;

    call cross(hor, cam_direction, ver)
    call normalize( ver )
    call normalize( hor )

    ! Establish view-plane location
    top_pixel = cam_position + cam_direction*view_len + ver*height/2 -hor*width/2;

    ! Now, to do the tracing
    do i = 1,ubound(image,2)
        do j = 1,ubound(image,1)
            colour = 0
            pixel = top_pixel + hor*aspect_ratio*j - ver*i
            do ii = 1,naa
                do jj = 1,naa
                    subpixel = pixel + hor*aspect_ratio*jj/naa - ver*ii/naa
                    ray = subpixel - cam_position
                    call trace(tmp_colour, ray, cam_position)
                    colour = colour + tmp_colour
                end do
            end do
            image(j,i,:) = colour/naa**2
        end do
    end do

    int_image = nint(image*255)
    int_image = min(int_image, 255)
    call write_ppm('./traced.ppm', int_image)

contains
    subroutine cross(tmp, x,y)
        real, dimension(3), intent(in) :: x,y
        real, dimension(3), intent(out) :: tmp

        tmp(1) = x(2)*y(3)-x(3)*y(2)
        tmp(2) = x(3)*y(1)-x(1)*y(3)
        tmp(3) = x(1)*y(2)-x(2)*y(1)
    end subroutine

    subroutine normalize(x)
        real, intent(inout) :: x(:)

        x = x / sqrt(dot_product(x,x))
    end subroutine

    subroutine trace(colour, ray, origin)
        real, dimension(3), intent(in) :: ray,origin
        real, intent(out) :: colour(3)
        real, dimension(3) :: normal, intersection, shadow_ray, tmp, diffuse
        real :: ray_norm(3), specular(3)
        real :: raylen, diffuse_coeff, spec_coeff
        integer :: i, sphere, tmp_int

        call intersect_spheres(ray, origin, raylen, normal, sphere)

        if (raylen == 0) then
            colour = 0
        else
            diffuse = 0
            specular = 0
            intersection = ray*raylen + origin
            call normalize(normal)
            ray_norm = ray
            call normalize(ray_norm)

            do i = 1,ubound(lights, 2)
                shadow_ray = lights(1:3,i) - intersection
                call intersect_spheres(shadow_ray, intersection, raylen, tmp, tmp_int)
                if (raylen == 0) then
                    call normalize(shadow_ray)
                    diffuse_coeff = dot_product(normal, shadow_ray)
                    if (diffuse_coeff >0) then
                        tmp = mats(1:3,sphere_mats(sphere))*diffuse_coeff
                        tmp = tmp*lights(4:6,i)
                        diffuse = diffuse + tmp
                    end if
                    shadow_ray = shadow_ray - normal*2*diffuse_coeff
                    raylen = dot_product(shadow_ray, ray_norm)
                    spec_coeff = raylen**mats(7,sphere_mats(sphere))
                    if (spec_coeff>0) then
                        tmp = mats(4:6,sphere_mats(sphere))*spec_coeff
                        tmp = tmp * lights(4:6,i)
                        specular = specular + tmp
                    end if
                end if
            end do
            colour = ambient* mats(1:3,sphere_mats(sphere)) + diffuse+specular
        end if
    end subroutine

    subroutine intersect_spheres(ray, origin, raylen, normal, sphere)
        real, intent(in) :: ray(3), origin(3)
        real, intent(out) :: raylen, normal(3)
        integer, intent(out) :: sphere
        integer :: k
        real :: m = 10000,tmp, tmp_normal(3)

        raylen = 0

        do k = 1,ubound(spheres,2)
            call intersect_sphere(ray, origin, spheres(:,k), tmp, tmp_normal)
            if (tmp > 0.0000001) then
                if (tmp < raylen .or. raylen==0) then
                    raylen = tmp
                    sphere = k
                    normal = tmp_normal
                end if
            end if
        end do
    end subroutine

    subroutine intersect_sphere(ray, origin, sphere, raylen, normal)
        real, intent(in) :: ray(3), origin(3), sphere(4)
        real, intent(out) :: normal(3), raylen

        real :: line(3), a, b, c, roots(2)
        integer :: numroots
        line = sphere(1:3) - origin;
        a = dot_product(ray,ray)
        b = dot_product(ray,line)
        c = dot_product(line, line)

        call quadroots(a,-2*b, c - sphere(4)**2, numroots, roots)
        select case (numroots)
            case (0)
                raylen = 0
                normal = 0
            case (1)
                call ray_epsilon_check(roots(1), ray, line, raylen, normal)
            case (2)
                if (roots(1)<roots(2)) then
                    call ray_epsilon_check(roots(1), ray, line, raylen, normal)
                else
                    call ray_epsilon_check(roots(2), ray, line, raylen, normal)
                end if
        end select
    end subroutine

    subroutine quadroots(a, b, c, numroots, roots)
        real, intent(in) :: a,b,c
        real, intent(out) :: roots(2)
        integer, intent(out) :: numroots

        real :: t

        if (a==0) then
            roots(1) = -c/b
            roots(2) = 0
            numroots = 1
        else
            t = b**2 - 4*a*c
            if (t>0) then
                roots(1) = (-b+sqrt(t)) / (2*a)
                roots(2) = (-b-sqrt(t)) / (2*a)
                numroots = 2
            else
                roots = 0
                numroots = 0
            end if
        end if
    end subroutine

    subroutine ray_epsilon_check(root, ray, line, raylen, normal)
        real, intent(in) :: root, ray(3), line(3)
        real, intent(out) :: raylen, normal(3)

        if (root > 0.0000001) then
            raylen = root
            normal = ray*root-line
        else
            raylen=0
            normal=0
        end if
    end subroutine

end program ray_trace


SUBROUTINE mocouq(psi,dsbar,theta,dq1,dq2,dq3)
!
! This subroutine forms the derivatives of a Mohr-Coulomb potential
! function with respect to the three invariants (psi in degrees).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::psi,dsbar,theta
 REAL(iwp),INTENT(OUT)::dq1,dq2,dq3
 REAL(iwp)::psir,snth,snps,sq3,c1,csth,cs3th,tn3th,tnth,zero=0.0_iwp,     &
   pt49=0.49_iwp,pt5=0.5_iwp,one=1.0_iwp,d3=3.0_iwp,d4=4.0_iwp,           &
   d180=180.0_iwp
 psir=psi*d4*ATAN(one)/d180
 snth=SIN(theta)
 snps=SIN(psir)
 sq3=SQRT(d3)
 dq1=snps
 if(ABS(snth).GT.pt49)THEN
   c1=one
   IF(snth.LT.zero)c1=-one
   dq2=(sq3*pt5-c1*snps*pt5/sq3)*sq3*pt5/dsbar
   dq3=zero
 ELSE
   csth=COS(theta)
   cs3th=COS(d3*theta)
   tn3th=TAN(d3*theta)
   tnth=snth/csth
   dq2=sq3*csth/dsbar*((one+tnth*tn3th)+snps*(tn3th-tnth)/sq3)*pt5
   dq3=pt5*d3*(sq3*snth+snps*csth)/(cs3th*dsbar*dsbar)
 END IF
RETURN
END SUBROUTINE mocouq


      subroutine small_strain_von_Mises_elastoPlasticity
     *              (epsp,xi,eps,stre,cc,matdata,err)

      implicit none

      integer          err,
     *                 i, j

      double precision epsp(*), xi, eps(*), stre(*), cc(6,*),
     *                 matData(*),
     *                 Dg, nstrialD, nsD, Phitrial, treps,
     *                 mu, K, sY, H,
     *                 fact1, fact2, fact3,
     *                 r0, r1d2, r1, r2, r3, r1d3, r2d3, sq2d3

      data r0, r1d2, r1, r2, r3 / 0.d0, 0.5d0, 1.d0, 2.d0, 3.d0 /

      r1d3 = r1 / r3
      r2d3 = r1d3 + r1d3

      sq2d3 = sqrt(r2d3)

      K  = matData(1)
      mu = matData(2)
      sY = matData(3)
      H  = matData(4)

      !write(*,*) K, mu, sY, H

      if (abs(epsp(1)+epsp(2)+epsp(3)).gt.1.d-10)
     *  write(*,'(9x,a/)')'WARNING! tr(epsp) <> 0 !'

c...  update for deviatoric stress and internal variables

      !write(*,'(6(1x,g12.5))') (epsp(i),i=1,6)
      !write(*,'(6(1x,g12.5))') (eps(i),i=1,6)

      fact1 = mu + mu
      treps = eps(1) + eps(2) + eps(3)
      fact2 = r1d3 * treps

      do i=1, 3
        stre(i)   = fact1 * (eps(i)  -epsp(i)  - fact2)
        stre(3+i) = fact1 * (eps(3+i)-epsp(3+i))
      enddo

      nstrialD = r0
      do i=1, 3
        nstrialD = nstrialD + stre(i)  *stre(i)
     *                 + r2 * stre(3+i)*stre(3+i)
      enddo
      nstrialD = sqrt(nstrialD)

      Phitrial = nstrialD - sq2d3 * (sY + xi*H)

      if (Phitrial.gt.r0) then

        !write(*,*) Phitrial

        Dg = Phitrial / (r2d3 * H + fact1)

        !write(*,*) 'Dg = ', Dg

        nsD   = nstrialD - fact1 * Dg
        fact3 = nsD / nstrialD         ! beta
        do i=1, 6
          stre(i) = fact3 * stre(i)
        enddo

        fact2 = Dg / nsD
        do i=1, 6
          epsp(i) = epsp(i) + fact2 * stre(i)
        enddo

        xi = xi + sq2d3 * Dg

        fact2 = fact1 * fact3   ! 2 mu beta

      else

        fact2 = fact1

      endif

c...  computation of consistent tantgent tensor

      fact3 = K - r1d3 * fact2
      do i=1, 3
        do j=1, 3
          cc(i,j)     = fact3
          cc(3+i,j)   = r0
          cc(i,3+j)   = r0
          cc(3+i,3+j) = r0
        enddo
        cc(i,i)     = cc(i,i) + fact2
        cc(3+i,3+i) = fact2 * r1d2
      enddo

      if (Phitrial.gt.r0) then

        fact3 = (fact1/(r1+H/(mu+fact1)) - fact1+fact2) / (nsD*nsD) ! 2 mu gam
        do i=1, 6
          do j=1, 6
            cc(i,j) = cc(i,j) - fact3 * stre(i) * stre(j)
          enddo
        enddo

      endif

c...  volumetric stress

      fact3 = K * treps
      do i=1, 3
        stre(i) = stre(i) + fact3
      enddo

      return

      end


      SUBROUTINE pinvs(ie1,ie2,je1,jsf,jc1,k,c,nci,ncj,nck,s,nsi,nsj)
      INTEGER ie1,ie2,jc1,je1,jsf,k,nci,ncj,nck,nsi,nsj,NMAX
      REAL c(nci,ncj,nck),s(nsi,nsj)
      PARAMETER (NMAX=10)
      INTEGER i,icoff,id,ipiv,irow,j,jcoff,je2,jp,jpiv,js1,indxr(NMAX)
      REAL big,dum,piv,pivinv,pscl(NMAX)
      je2=je1+ie2-ie1
      js1=je2+1
      do 12 i=ie1,ie2
        big=0.
        do 11 j=je1,je2
          if(abs(s(i,j)).gt.big) big=abs(s(i,j))
11      continue
        if(big.eq.0.) pause 'singular matrix, row all 0 in pinvs'
        pscl(i)=1./big
        indxr(i)=0
12    continue
      do 18 id=ie1,ie2
        piv=0.
        do 14 i=ie1,ie2
          if(indxr(i).eq.0) then
            big=0.
            do 13 j=je1,je2
              if(abs(s(i,j)).gt.big) then
                jp=j
                big=abs(s(i,j))
              endif
13          continue
            if(big*pscl(i).gt.piv) then
              ipiv=i
              jpiv=jp
              piv=big*pscl(i)
            endif
          endif
14      continue
        if(s(ipiv,jpiv).eq.0.) pause 'singular matrix in pinvs'
        indxr(ipiv)=jpiv
        pivinv=1./s(ipiv,jpiv)
        do 15 j=je1,jsf
          s(ipiv,j)=s(ipiv,j)*pivinv
15      continue
        s(ipiv,jpiv)=1.
        do 17 i=ie1,ie2
          if(indxr(i).ne.jpiv) then
            if(s(i,jpiv).ne.0.) then
              dum=s(i,jpiv)
              do 16 j=je1,jsf
                s(i,j)=s(i,j)-dum*s(ipiv,j)
16            continue
              s(i,jpiv)=0.
            endif
          endif
17      continue
18    continue
      jcoff=jc1-js1
      icoff=ie1-je1
      do 21 i=ie1,ie2
        irow=indxr(i)+icoff
        do 19 j=js1,jsf
          c(irow,j+jcoff,k)=s(i,j)
19      continue
21    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/pinvs.for