      SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA,
     $                   A, LDA, B, LDB, C, LDC, MC, NC, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To perform the following matrix operation
C
C        C = alpha*kron( op(A), op(B) ) + beta*C,
C
C     where alpha and beta are real scalars, op(M) is either matrix M or
C     its transpose, M', and kron( X, Y ) denotes the Kronecker product
C     of the matrices X and Y.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used as follows:
C             = 'N':  op(A) = A;
C             = 'T':  op(A) = A';
C             = 'C':  op(A) = A'.
C
C     TRANB   CHARACTER*1
C             Specifies the form of op(B) to be used as follows:
C             = 'N':  op(B) = B;
C             = 'T':  op(B) = B';
C             = 'C':  op(B) = B'.
C
C     Input/Output Parameters
C
C     MA      (input) INTEGER
C             The number of rows of the matrix op(A).  MA >= 0.
C
C     NA      (input) INTEGER
C             The number of columns of the matrix op(A).  NA >= 0.
C
C     MB      (input) INTEGER
C             The number of rows of the matrix op(B).  MB >= 0.
C
C     NB      (input) INTEGER
C             The number of columns of the matrix op(B).  NB >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then A and B need not
C             be set before entry.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then C need not be
C             set before entry.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,ka),
C             where ka is NA when TRANA = 'N', and is MA otherwise.
C             If TRANA = 'N', the leading MA-by-NA part of this array
C             must contain the matrix A; otherwise, the leading NA-by-MA
C             part of this array must contain the matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= max(1,MA), if TRANA = 'N';
C             LDA >= max(1,NA), if TRANA = 'T' or 'C'.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,kb)
C             where kb is NB when TRANB = 'N', and is MB otherwise.
C             If TRANB = 'N', the leading MB-by-NB part of this array
C             must contain the matrix B; otherwise, the leading NB-by-MB
C             part of this array must contain the matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= max(1,MB), if TRANB = 'N';
C             LDB >= max(1,NB), if TRANB = 'T' or 'C'.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,NC)
C             On entry, if beta is nonzero, the leading MC-by-NC part of
C             this array must contain the given matric C, where
C             MC = MA*MB and NC = NA*NB.
C             On exit, the leading MC-by-NC part of this array contains
C             the computed matrix expression
C             C = alpha*kron( op(A), op(B) ) + beta*C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= max(1,MC).
C
C     MC      (output) INTEGER
C             The number of rows of the matrix C.  MC = MA*MB.
C
C     NC      (output) INTEGER
C             The number of columns of the matrix C.  NC = NA*NB.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The Kronecker product of the matrices op(A) and op(B) is computed
C     column by column.
C
C     FURTHER COMMENTS
C
C     The multiplications by zero elements in A are avoided, if the
C     matrix A is considered to be sparse, i.e., if
C     (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes
C     NB+1 passes through the matrix A, and MA*NA passes through the
C     matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or
C     op(B) = B', it could be more efficient to transpose A and/or B
C     before calling this routine, and use the 'N' values for TRANA
C     and/or TRANB.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, February 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
      DOUBLE PRECISION  SPARST
      PARAMETER         ( SPARST = 0.8D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANA, TRANB
      INTEGER           INFO, LDA, LDB, LDC, MA, MB, MC, NA, NB, NC
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*)
C     .. Local Scalars ..
      LOGICAL           SPARSE, TRANSA, TRANSB
      INTEGER           I, IC, J, JC, K, L, LC, NZ
      DOUBLE PRECISION  AIJ
C     .. Local Arrays ..
      DOUBLE PRECISION  DUM(1)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLASET, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      TRANSA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' )
      TRANSB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' )
      MC     = MA*MB
      INFO   = 0
      IF( .NOT.( TRANSA .OR. LSAME( TRANA, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( TRANSB .OR. LSAME( TRANB, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( MA.LT.0 ) THEN
         INFO = -3
      ELSE IF( NA.LT.0 ) THEN
         INFO = -4
      ELSE IF( MB.LT.0 ) THEN
         INFO = -5
      ELSE IF( NB.LT.0 ) THEN
         INFO = -6
      ELSE IF( ( TRANSA .AND. LDA.LT.NA ) .OR. LDA.LT.1 .OR.
     $    ( .NOT.TRANSA .AND. LDA.LT.MA ) ) THEN
         INFO = -10
      ELSE IF( ( TRANSB .AND. LDB.LT.NB ) .OR. LDB.LT.1 .OR.
     $    ( .NOT.TRANSB .AND. LDB.LT.MB ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.MAX( 1, MC ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01VD', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      NC = NA*NB
      IF ( MC.EQ.0 .OR. NC.EQ.0 )
     $   RETURN
C
      IF ( ALPHA.EQ.ZERO ) THEN
         IF ( BETA.EQ.ZERO ) THEN
            CALL DLASET( 'Full', MC, NC, ZERO, ZERO, C, LDC )
         ELSE IF ( BETA.NE.ONE ) THEN
C
            DO 10 J = 1, NC
               CALL DSCAL( MC, BETA, C(1,J), 1 )
   10       CONTINUE
C
         END IF
         RETURN
      END IF
C
      DUM(1) = ZERO
      JC = 1
      NZ = 0
C
C     Compute the Kronecker product of the matrices op(A) and op(B),
C        C = alpha*kron( op(A), op(B) ) + beta*C.
C     First, check if A is sparse. Here, A is considered as being sparse
C     if (number of zeros in A)/(MA*NA) >= SPARST.
C
      DO 30 J = 1, NA
C
         DO 20 I = 1, MA
            IF ( TRANSA ) THEN
               IF ( A(J,I).EQ.ZERO )
     $            NZ = NZ + 1
            ELSE
               IF ( A(I,J).EQ.ZERO )
     $            NZ = NZ + 1
            END IF
   20    CONTINUE
C
   30 CONTINUE
C
      SPARSE = DBLE( NZ )/DBLE( MA*NA ).GE.SPARST
C
      IF ( .NOT.TRANSA .AND. .NOT.TRANSB ) THEN
C
C        Case op(A) = A and op(B) = B.
C
         IF ( BETA.EQ.ZERO ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha = 1, A sparse.
C
                  DO 80 J = 1, NA
C
                     DO 70 K = 1, NB
                        IC = 1
C
                        DO 60 I = 1, MA
                           AIJ = A(I,J)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE IF ( AIJ.EQ.ONE ) THEN
                              CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 50 L = 1, MB
                                 C(LC,JC) = AIJ*B(L,K)
                                 LC = LC + 1
   50                         CONTINUE
C
                           END IF
                           IC = IC + MB
   60                   CONTINUE
C
                        JC = JC + 1
   70                CONTINUE
C
   80             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha = 1, A not sparse.
C
                  DO 120 J = 1, NA
C
                     DO 110 K = 1, NB
                        IC = 1
C
                        DO 100 I = 1, MA
                           AIJ = A(I,J)
                           LC = IC
C
                           DO 90 L = 1, MB
                              C(LC,JC) = AIJ*B(L,K)
                              LC = LC + 1
   90                      CONTINUE
C
                           IC = IC + MB
  100                   CONTINUE
C
                        JC = JC + 1
  110                CONTINUE
C
  120             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha <> 1, A sparse.
C
                  DO 160 J = 1, NA
C
                     DO 150 K = 1, NB
                        IC = 1
C
                        DO 140 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 130 L = 1, MB
                                 C(LC,JC) = AIJ*B(L,K)
                                 LC = LC + 1
  130                         CONTINUE
C
                           END IF
                           IC = IC + MB
  140                   CONTINUE
C
                        JC = JC + 1
  150                CONTINUE
C
  160             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha <> 1, A not sparse.
C
                  DO 200 J = 1, NA
C
                     DO 190 K = 1, NB
                        IC = 1
C
                        DO 180 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           LC = IC
C
                           DO 170 L = 1, MB
                              C(LC,JC) = AIJ*B(L,K)
                              LC = LC + 1
  170                      CONTINUE
C
                           IC = IC + MB
  180                   CONTINUE
C
                        JC = JC + 1
  190                CONTINUE
C
  200             CONTINUE
C
               END IF
            END IF
         ELSE IF ( BETA.EQ.ONE ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha = 1, A sparse.
C
                  DO 240 J = 1, NA
C
                     DO 230 K = 1, NB
                        IC = 1
C
                        DO 220 I = 1, MA
                           AIJ = A(I,J)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 210 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  210                         CONTINUE
C
                           END IF
                           IC = IC + MB
  220                   CONTINUE
C
                        JC = JC + 1
  230                CONTINUE
C
  240             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha = 1, A not sparse.
C
                  DO 280 J = 1, NA
C
                     DO 270 K = 1, NB
                        IC = 1
C
                        DO 260 I = 1, MA
                           AIJ = A(I,J)
                           LC = IC
C
                           DO 250 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  250                      CONTINUE
C
                           IC = IC + MB
  260                   CONTINUE
C
                        JC = JC + 1
  270                CONTINUE
C
  280             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha <> 1, A sparse.
C
                  DO 320 J = 1, NA
C
                     DO 310 K = 1, NB
                        IC = 1
C
                        DO 300 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 290 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  290                         CONTINUE
C
                           END IF
                           IC = IC + MB
  300                   CONTINUE
C
                        JC = JC + 1
  310                CONTINUE
C
  320             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha <> 1, A not sparse.
C
                  DO 360 J = 1, NA
C
                     DO 350 K = 1, NB
                        IC = 1
C
                        DO 340 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           LC = IC
C
                           DO 330 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  330                      CONTINUE
C
                           IC = IC + MB
  340                   CONTINUE
C
                        JC = JC + 1
  350                CONTINUE
C
  360             CONTINUE
C
               END IF
            END IF
         ELSE
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha = 1, A sparse.
C
                  DO 400 J = 1, NA
C
                     DO 390 K = 1, NB
                        IC = 1
C
                        DO 380 I = 1, MA
                           AIJ = A(I,J)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 370 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  370                         CONTINUE
C
                           END IF
                           IC = IC + MB
  380                   CONTINUE
C
                        JC = JC + 1
  390                CONTINUE
C
  400             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha = 1, A not sparse.
C
                  DO 440 J = 1, NA
C
                     DO 430 K = 1, NB
                        IC = 1
C
                        DO 420 I = 1, MA
                           AIJ = A(I,J)
                           LC = IC
C
                           DO 410 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  410                      CONTINUE
C
                           IC = IC + MB
  420                   CONTINUE
C
                        JC = JC + 1
  430                CONTINUE
C
  440             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha <> 1, A sparse.
C
                  DO 480 J = 1, NA
C
                     DO 470 K = 1, NB
                        IC = 1
C
                        DO 460 I = 1, MA
                           AIJ = ALPHA*A(I,J)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 450 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  450                         CONTINUE
C
                           END IF
                           IC = IC + MB
  460                   CONTINUE
C
                        JC = JC + 1
  470                CONTINUE
C
  480             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha <> 1, A not sparse.
C
                  DO 520 J = 1, NA
C
                     DO 510 K = 1, NB
                        IC = 1
C
                        DO 500 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           LC = IC
C
                           DO 490 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  490                      CONTINUE
C
                           IC = IC + MB
  500                   CONTINUE
C
                        JC = JC + 1
  510                CONTINUE
C
  520             CONTINUE
C
               END IF
            END IF
         END IF
      ELSE IF ( TRANSA .AND. .NOT.TRANSB ) THEN
C
C        Case op(A) = A' and op(B) = B.
C
         IF ( BETA.EQ.ZERO ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha = 1, A sparse.
C
                  DO 560 J = 1, NA
C
                     DO 550 K = 1, NB
                        IC = 1
C
                        DO 540 I = 1, MA
                           AIJ = A(J,I)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE IF ( AIJ.EQ.ONE ) THEN
                              CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 530 L = 1, MB
                                 C(LC,JC) = AIJ*B(L,K)
                                 LC = LC + 1
  530                         CONTINUE
C
                           END IF
                           IC = IC + MB
  540                   CONTINUE
C
                        JC = JC + 1
  550                CONTINUE
C
  560             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha = 1, A not sparse.
C
                  DO 600 J = 1, NA
C
                     DO 590 K = 1, NB
                        IC = 1
C
                        DO 580 I = 1, MA
                           AIJ = A(J,I)
                           LC = IC
C
                           DO 570 L = 1, MB
                              C(LC,JC) = AIJ*B(L,K)
                              LC = LC + 1
  570                      CONTINUE
C
                           IC = IC + MB
  580                   CONTINUE
C
                        JC = JC + 1
  590                CONTINUE
C
  600             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha <> 1, A sparse.
C
                  DO 640 J = 1, NA
C
                     DO 630 K = 1, NB
                        IC = 1
C
                        DO 620 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 610 L = 1, MB
                                 C(LC,JC) = AIJ*B(L,K)
                                 LC = LC + 1
  610                         CONTINUE
C
                           END IF
                           IC = IC + MB
  620                   CONTINUE
C
                        JC = JC + 1
  630                CONTINUE
C
  640             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha <> 1, A not sparse.
C
                  DO 680 J = 1, NA
C
                     DO 670 K = 1, NB
                        IC = 1
C
                        DO 660 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           LC = IC
C
                           DO 650 L = 1, MB
                              C(LC,JC) = AIJ*B(L,K)
                              LC = LC + 1
  650                      CONTINUE
C
                           IC = IC + MB
  660                   CONTINUE
C
                        JC = JC + 1
  670                CONTINUE
C
  680             CONTINUE
C
               END IF
            END IF
         ELSE IF ( BETA.EQ.ONE ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha = 1, A sparse.
C
                  DO 720 J = 1, NA
C
                     DO 710 K = 1, NB
                        IC = 1
C
                        DO 700 I = 1, MA
                           AIJ = A(J,I)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 690 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  690                         CONTINUE
C
                           END IF
                           IC = IC + MB
  700                   CONTINUE
C
                        JC = JC + 1
  710                CONTINUE
C
  720             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha = 1, A not sparse.
C
                  DO 760 J = 1, NA
C
                     DO 750 K = 1, NB
                        IC = 1
C
                        DO 740 I = 1, MA
                           AIJ = A(J,I)
                           LC = IC
C
                           DO 730 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  730                      CONTINUE
C
                           IC = IC + MB
  740                   CONTINUE
C
                        JC = JC + 1
  750                CONTINUE
C
  760             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha <> 1, A sparse.
C
                  DO 800 J = 1, NA
C
                     DO 790 K = 1, NB
                        IC = 1
C
                        DO 780 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 770 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  770                         CONTINUE
C
                           END IF
                           IC = IC + MB
  780                   CONTINUE
C
                        JC = JC + 1
  790                CONTINUE
C
  800             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha <> 1, A not sparse.
C
                  DO 840 J = 1, NA
C
                     DO 830 K = 1, NB
                        IC = 1
C
                        DO 820 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           LC = IC
C
                           DO 810 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  810                      CONTINUE
C
                           IC = IC + MB
  820                   CONTINUE
C
                        JC = JC + 1
  830                CONTINUE
C
  840             CONTINUE
C
               END IF
            END IF
         ELSE
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha = 1, A sparse.
C
                  DO 880 J = 1, NA
C
                     DO 870 K = 1, NB
                        IC = 1
C
                        DO 860 I = 1, MA
                           AIJ = A(J,I)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 850 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  850                         CONTINUE
C
                           END IF
                           IC = IC + MB
  860                   CONTINUE
C
                        JC = JC + 1
  870                CONTINUE
C
  880             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha = 1, A not sparse.
C
                  DO 920 J = 1, NA
C
                     DO 910 K = 1, NB
                        IC = 1
C
                        DO 900 I = 1, MA
                           AIJ = A(J,I)
                           LC = IC
C
                           DO 890 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  890                      CONTINUE
C
                           IC = IC + MB
  900                   CONTINUE
C
                        JC = JC + 1
  910                CONTINUE
C
  920             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha <> 1, A sparse.
C
                  DO 960 J = 1, NA
C
                     DO 950 K = 1, NB
                        IC = 1
C
                        DO 940 I = 1, MA
                           AIJ = ALPHA*A(J,I)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 930 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                                 LC = LC + 1
  930                         CONTINUE
C
                           END IF
                           IC = IC + MB
  940                   CONTINUE
C
                        JC = JC + 1
  950                CONTINUE
C
  960             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha <> 1, A not sparse.
C
                  DO 1000 J = 1, NA
C
                     DO 990 K = 1, NB
                        IC = 1
C
                        DO 980 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           LC = IC
C
                           DO 970 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K)
                              LC = LC + 1
  970                      CONTINUE
C
                           IC = IC + MB
  980                   CONTINUE
C
                        JC = JC + 1
  990                CONTINUE
C
 1000             CONTINUE
C
               END IF
            END IF
         END IF
      ELSE IF ( TRANSB .AND. .NOT.TRANSA ) THEN
C
C        Case op(A) = A and op(B) = B'.
C
         IF ( BETA.EQ.ZERO ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha = 1, A sparse.
C
                  DO 1080 J = 1, NA
C
                     DO 1070 K = 1, NB
                        IC = 1
C
                        DO 1060 I = 1, MA
                           AIJ = A(I,J)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE IF ( AIJ.EQ.ONE ) THEN
                              CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1050 L = 1, MB
                                 C(LC,JC) = AIJ*B(K,L)
                                 LC = LC + 1
 1050                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1060                   CONTINUE
C
                        JC = JC + 1
 1070                CONTINUE
C
 1080             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha = 1, A not sparse.
C
                  DO 1120 J = 1, NA
C
                     DO 1110 K = 1, NB
                        IC = 1
C
                        DO 1100 I = 1, MA
                           AIJ = A(I,J)
                           LC = IC
C
                           DO 1090 L = 1, MB
                              C(LC,JC) = AIJ*B(K,L)
                              LC = LC + 1
 1090                      CONTINUE
C
                           IC = IC + MB
 1100                   CONTINUE
C
                        JC = JC + 1
 1110                CONTINUE
C
 1120             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha <> 1, A sparse.
C
                  DO 1160 J = 1, NA
C
                     DO 1150 K = 1, NB
                        IC = 1
C
                        DO 1140 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1130 L = 1, MB
                                 C(LC,JC) = AIJ*B(K,L)
                                 LC = LC + 1
 1130                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1140                   CONTINUE
C
                        JC = JC + 1
 1150                CONTINUE
C
 1160             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha <> 1, A not sparse.
C
                  DO 1200 J = 1, NA
C
                     DO 1190 K = 1, NB
                        IC = 1
C
                        DO 1180 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           LC = IC
C
                           DO 1170 L = 1, MB
                              C(LC,JC) = AIJ*B(K,L)
                              LC = LC + 1
 1170                      CONTINUE
C
                           IC = IC + MB
 1180                   CONTINUE
C
                        JC = JC + 1
 1190                CONTINUE
C
 1200             CONTINUE
C
               END IF
            END IF
         ELSE IF ( BETA.EQ.ONE ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha = 1, A sparse.
C
                  DO 1240 J = 1, NA
C
                     DO 1230 K = 1, NB
                        IC = 1
C
                        DO 1220 I = 1, MA
                           AIJ = A(I,J)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 1210 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1210                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1220                   CONTINUE
C
                        JC = JC + 1
 1230                CONTINUE
C
 1240             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha = 1, A not sparse.
C
                  DO 1280 J = 1, NA
C
                     DO 1270 K = 1, NB
                        IC = 1
C
                        DO 1260 I = 1, MA
                           AIJ = A(I,J)
                           LC = IC
C
                           DO 1250 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1250                      CONTINUE
C
                           IC = IC + MB
 1260                   CONTINUE
C
                        JC = JC + 1
 1270                CONTINUE
C
 1280             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha <> 1, A sparse.
C
                  DO 1320 J = 1, NA
C
                     DO 1310 K = 1, NB
                        IC = 1
C
                        DO 1300 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 1290 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1290                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1300                   CONTINUE
C
                        JC = JC + 1
 1310                CONTINUE
C
 1320             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha <> 1, A not sparse.
C
                  DO 1360 J = 1, NA
C
                     DO 1350 K = 1, NB
                        IC = 1
C
                        DO 1340 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           LC = IC
C
                           DO 1330 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1330                      CONTINUE
C
                           IC = IC + MB
 1340                   CONTINUE
C
                        JC = JC + 1
 1350                CONTINUE
C
 1360             CONTINUE
C
               END IF
            END IF
         ELSE
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha = 1, A sparse.
C
                  DO 1400 J = 1, NA
C
                     DO 1390 K = 1, NB
                        IC = 1
C
                        DO 1380 I = 1, MA
                           AIJ = A(I,J)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1370 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1370                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1380                   CONTINUE
C
                        JC = JC + 1
 1390                CONTINUE
C
 1400             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha = 1, A not sparse.
C
                  DO 1440 J = 1, NA
C
                     DO 1430 K = 1, NB
                        IC = 1
C
                        DO 1420 I = 1, MA
                           AIJ = A(I,J)
                           LC = IC
C
                           DO 1410 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1410                      CONTINUE
C
                           IC = IC + MB
 1420                   CONTINUE
C
                        JC = JC + 1
 1430                CONTINUE
C
 1440             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha <> 1, A sparse.
C
                  DO 1480 J = 1, NA
C
                     DO 1470 K = 1, NB
                        IC = 1
C
                        DO 1460 I = 1, MA
                           AIJ = ALPHA*A(I,J)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1450 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1450                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1460                   CONTINUE
C
                        JC = JC + 1
 1470                CONTINUE
C
 1480             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha <> 1, A not sparse.
C
                  DO 1520 J = 1, NA
C
                     DO 1510 K = 1, NB
                        IC = 1
C
                        DO 1500 I = 1, MA
                           AIJ = ALPHA*A(I,J)
                           LC = IC
C
                           DO 1490 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1490                      CONTINUE
C
                           IC = IC + MB
 1500                   CONTINUE
C
                        JC = JC + 1
 1510                CONTINUE
C
 1520             CONTINUE
C
               END IF
            END IF
         END IF
      ELSE
C
C        Case op(A) = A' and op(B) = B'.
C
         IF ( BETA.EQ.ZERO ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha = 1, A sparse.
C
                  DO 1580 J = 1, NA
C
                     DO 1570 K = 1, NB
                        IC = 1
C
                        DO 1560 I = 1, MA
                           AIJ = A(J,I)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE IF ( AIJ.EQ.ONE ) THEN
                              CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1550 L = 1, MB
                                 C(LC,JC) = AIJ*B(K,L)
                                 LC = LC + 1
 1550                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1560                   CONTINUE
C
                        JC = JC + 1
 1570                CONTINUE
C
 1580             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha = 1, A not sparse.
C
                  DO 1620 J = 1, NA
C
                     DO 1610 K = 1, NB
                        IC = 1
C
                        DO 1600 I = 1, MA
                           AIJ = A(J,I)
                           LC = IC
C
                           DO 1590 L = 1, MB
                              C(LC,JC) = AIJ*B(K,L)
                              LC = LC + 1
 1590                      CONTINUE
C
                           IC = IC + MB
 1600                   CONTINUE
C
                        JC = JC + 1
 1610                CONTINUE
C
 1620             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 0, alpha <> 1, A sparse.
C
                  DO 1660 J = 1, NA
C
                     DO 1650 K = 1, NB
                        IC = 1
C
                        DO 1640 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1630 L = 1, MB
                                 C(LC,JC) = AIJ*B(K,L)
                                 LC = LC + 1
 1630                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1640                   CONTINUE
C
                        JC = JC + 1
 1650                CONTINUE
C
 1660             CONTINUE
C
               ELSE
C
C                 Case beta = 0, alpha <> 1, A not sparse.
C
                  DO 1700 J = 1, NA
C
                     DO 1690 K = 1, NB
                        IC = 1
C
                        DO 1680 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           LC = IC
C
                           DO 1670 L = 1, MB
                              C(LC,JC) = AIJ*B(K,L)
                              LC = LC + 1
 1670                      CONTINUE
C
                           IC = IC + MB
 1680                   CONTINUE
C
                        JC = JC + 1
 1690                CONTINUE
C
 1700             CONTINUE
C
               END IF
            END IF
         ELSE IF ( BETA.EQ.ONE ) THEN
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha = 1, A sparse.
C
                  DO 1740 J = 1, NA
C
                     DO 1730 K = 1, NB
                        IC = 1
C
                        DO 1720 I = 1, MA
                           AIJ = A(J,I)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 1710 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1710                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1720                   CONTINUE
C
                        JC = JC + 1
 1730                CONTINUE
C
 1740             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha = 1, A not sparse.
C
                  DO 1780 J = 1, NA
C
                     DO 1770 K = 1, NB
                        IC = 1
C
                        DO 1760 I = 1, MA
                           AIJ = A(J,I)
                           LC = IC
C
                           DO 1750 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1750                      CONTINUE
C
                           IC = IC + MB
 1760                   CONTINUE
C
                        JC = JC + 1
 1770                CONTINUE
C
 1780             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta = 1, alpha <> 1, A sparse.
C
                  DO 1820 J = 1, NA
C
                     DO 1810 K = 1, NB
                        IC = 1
C
                        DO 1800 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           IF ( AIJ.NE.ZERO ) THEN
                              LC = IC
C
                              DO 1790 L = 1, MB
                                 C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1790                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1800                   CONTINUE
C
                        JC = JC + 1
 1810                CONTINUE
C
 1820             CONTINUE
C
               ELSE
C
C                 Case beta = 1, alpha <> 1, A not sparse.
C
                  DO 1860 J = 1, NA
C
                     DO 1850 K = 1, NB
                        IC = 1
C
                        DO 1840 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           LC = IC
C
                           DO 1830 L = 1, MB
                              C(LC,JC) = C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1830                      CONTINUE
C
                           IC = IC + MB
 1840                   CONTINUE
C
                        JC = JC + 1
 1850                CONTINUE
C
 1860             CONTINUE
C
               END IF
            END IF
         ELSE
            IF ( ALPHA.EQ.ONE ) THEN
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha = 1, A sparse.
C
                  DO 1900 J = 1, NA
C
                     DO 1890 K = 1, NB
                        IC = 1
C
                        DO 1880 I = 1, MA
                           AIJ = A(J,I)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1870 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1870                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1880                   CONTINUE
C
                        JC = JC + 1
 1890                CONTINUE
C
 1900             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha = 1, A not sparse.
C
                  DO 1940 J = 1, NA
C
                     DO 1930 K = 1, NB
                        IC = 1
C
                        DO 1920 I = 1, MA
                           AIJ = A(J,I)
                           LC = IC
C
                           DO 1910 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1910                      CONTINUE
C
                           IC = IC + MB
 1920                   CONTINUE
C
                        JC = JC + 1
 1930                CONTINUE
C
 1940             CONTINUE
C
               END IF
            ELSE
               IF ( SPARSE ) THEN
C
C                 Case beta <> 0 or 1, alpha <> 1, A sparse.
C
                  DO 1980 J = 1, NA
C
                     DO 1970 K = 1, NB
                        IC = 1
C
                        DO 1960 I = 1, MA
                           AIJ = ALPHA*A(J,I)
C
                           IF ( AIJ.EQ.ZERO ) THEN
                              CALL DSCAL( MB, BETA, C(IC,JC), 1 )
                           ELSE
                              LC = IC
C
                              DO 1950 L = 1, MB
                                 C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                                 LC = LC + 1
 1950                         CONTINUE
C
                           END IF
                           IC = IC + MB
 1960                   CONTINUE
C
                        JC = JC + 1
 1970                CONTINUE
C
 1980             CONTINUE
C
               ELSE
C
C                 Case beta <> 0 or 1, alpha <> 1, A not sparse.
C
                  DO 2020 J = 1, NA
C
                     DO 2010 K = 1, NB
                        IC = 1
C
                        DO 2000 I = 1, MA
                           AIJ = ALPHA*A(J,I)
                           LC = IC
C
                           DO 1990 L = 1, MB
                              C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L)
                              LC = LC + 1
 1990                      CONTINUE
C
                           IC = IC + MB
 2000                   CONTINUE
C
                        JC = JC + 1
 2010                CONTINUE
C
 2020             CONTINUE
C
               END IF
            END IF
         END IF
      END IF
      RETURN
C *** Last line of MB01VD ***
      END


module grains

  implicit none

contains

  ! Using double precision return type instead of int to avoid overflow in int
  double precision function square(n)
    integer :: n
    square = -1.d0
    if (n>=1 .and. n<=64) then
      square = 2.d0**(n-1)
    end if
  end function

  double precision function total()
    integer :: i
    total=0.d0
    do i=1,64
      total = total +square(i)
    end do
  end function

end module


!--------------------------------------------------------------------------------
!
!       GEOFRACTAL version 1.0
!
!--------------------------------------------------------------------------------
!
! GEOFRACTAL v1.0 computes the geometrical cross section of randomly orientated
! fractal dust aggregates based on a statistical distribution model of monomer
! particles developed in Tazaki (in prep.).
!
! If you wish to publish a paper that contains results obtained by this code,
! please acknowledge this code and cite relevant papers.
!
!
! Disclaimer:
! I reject all responsibility for the use of this code. Although it has been
! tested, the code may still contain a bug. I am not responsible for any damages
! caused by the use of the code. If you find a bug, please let me know.
!
!                                                   Ryo Tazaki (2021/Jan/1)
!                                                   email: r.tazaki -at- uva.nl
!
!--------------------------------------------------------------------------------
! INPUT PARAMETERS
!--------------------------------------------------------------------------------
!
! Df            : fractal dimension
! PN            : number of monomers
! k0            : fractal prefactor defined by PN = k0*(Rg/R0)^Df
!
! iqapp         : Select a method for solving radial and angular integration
!                 when computing the mean overlapping efficiency.
!                --------------------------------------------------------
!                          |    radial  (x)        |  angular (u)        |
!                ---------------------------------------------------------
!                iqapp = 1 |   numerical           |  numerical          |
!                iqapp = 3 |   numerical  ( D<=2 ) |  analytical         |
!                          |   analytical ( D> 2 ) |                     |
!                --------------------------------------------------------
!
! iqcon         : Switch to specify the numerical factor A.
!                 iqcon  = 1 : A = 1
!                 iqcon  = 2 : A is chosen to connect two regimes.
!
! iqcor         : Switch to specify a cut-off model of the correlation function
!                 iqcon  = 1 : The Gaussian cut-off function
!                 iqcon  = 2 : The exponential cut-off function
!                 iqcon  = 3 : The fractal dimension cut-off function
!
! Prefered set of options is iqcor=3, iqapp=3 and iqcon=2.
! Note that iqcor=1 is also possible, but avoid using iqcor=2.
!
!--------------------------------------------------------------------------------
! OUTPUT PARAMETER
!--------------------------------------------------------------------------------
!
! G  : The geocross section of the aggregate normalized by a factor PN*pi*R0^2.
!      Thus, "G" is non-dimensional quantity.
!
!--------------------------------------------------------------------------------

!module types
!implicit none
!integer, parameter      :: dp = selected_real_kind(P=15)
!end module types
!
!module const
!use types
!implicit none
!real(kind=dp),parameter :: pi = 3.1415926535897932384_dp
!end module const

subroutine geofrac(iqapp,iqcon,iqcor,PN,k0,df,G)
use types
implicit none
integer                 :: iqapp,iqcon,iqcor
real(kind=dp)           :: PN,k0,df,GS,G
real(kind=dp)           :: pnth,gth,sigmath,A,sigma
logical,parameter::debug=.false.

!--------------------------------------------------------------------------------
! some checks
!--------------------------------------------------------------------------------
if(PN .le. 0.9999_dp) then
        print *, 'number of monomers =',PN
        print *, 'error: The number of monomers should be larger than 1.'
        print *, 'stop'
        stop
endif
if(df .lt. 0.9999_dp .or. df .gt. 3.00001) then
        print *, 'fractal dimension df =',df
        print *, 'error: Fractal dimension df should be 1<=df<=3.'
        print *, 'stop'
        stop
endif
if(iqcon .ne. 1 .and. iqcon .ne. 2) then
        print *, 'error: iqcon should be either 1 or 2.'
        print *, 'stop'
        stop
endif
if(iqcor .ne. 1 .and. iqcor .ne. 2 .and. iqcor .ne. 3) then
        print *, 'error: iqcor should be either 1, 2, or 3.'
        print *, 'stop'
        stop
endif
if(iqapp .ne. 1 .and. iqapp .ne. 2 .and. iqapp .ne. 3) then
        print *, 'error: iqapp should be either 1 or 3.'
        print *, 'stop'
        stop
endif
if(iqapp .eq. 2 .and. (debug .eqv. .false.)) then
        print *, 'error: iqapp = 2 is only allowed for a debug mode.'
        print *, 'stop'
        stop
endif

!--------------------------------------------------------------------------------
! start calculations
!--------------------------------------------------------------------------------
A = 1.0_dp
if(iqcon .eq. 2) then
        PNTH = 11.0_dp*df-8.5_dp
        PNTH = min(PNTH,8.0_dp)
        if(PN .lt. PNTH) then
                G=GS(PN)
                return
        endif
        call mean_overlap_efficiency(iqapp,iqcor,k0,df,PNTH,sigmath)
        A = (1.0_dp+(PNTH-1.0_dp)*sigmath)*GS(PNTH)
endif
call mean_overlap_efficiency(iqapp,iqcor,k0,df,PN,sigma)
G = A / (1.0_dp + (PN-1.0_dp)*sigma)

return
end subroutine geofrac

!--------------------------------------------------------------------------------
!
! Minato et al. (2006)'s fitting formula for N < 16
!
!--------------------------------------------------------------------------------
function GS(PN)
use types
implicit none
real(kind=dp)::GS,PN
        GS = 12.5_dp*PN**(-0.315_dp)*exp(-2.53_dp/PN**0.0920_dp)
return
end function GS

!--------------------------------------------------------------------------------
!
! This subroutine calculations the mean overlapping efficiency: sigma
! (In Tazaki in prep., this quantity corresponds to \tilde{sigma} )
!
! For iqcor=1 [Gaussian cut-off model]
!
!               xmin       /ln(xmax)
! sigma  = --------------  |   dlnx frad(x)*S(rho),
!          16*Gamma(df/2)  /ln(xmin)
!
!       xmin = df*(k0/PN)^(2/df); a=(df-2)/2; rho = sqrt(x/xmin)
!
! For iqcor=2 [Exponential cut-off model]
!
!              xmin^2      /ln(xmax)
! sigma  = --------------  |   dlnx frad(x)*S(rho),
!           16*Gamma(df)   /ln(xmin)
!
!       xmin = 2*sqrt(df(df+1)/2)*(k0/PN)^(1.0/df); a=df-2; rho = x/xmin
!
! For iqcor=3 [Fractal dimension cut-off model]
!
!          xmin^{2/df} /ln(xmax)
! sigma  = ----------  |  dlnx frad(x)*S(rho),
!             16      /ln(xmin)
!
!       xmin = 2^(df-1)*k0/PN; a=(df-2)/df; rho = (x/xmin)^(1/df)
!
! where df is fractal dimension, R0 is the monomer radius, Rg is
! the radius of gyration, frad(x) is the radial integrand function,
! and S(rho) is the angular integral function.
!
! frad(x)dlnx = x^{a}*exp(-x) dlnx = x^{a-1}exp(-x) dx
!
!           16*rho^2  / (1/rho)
! S(rho)  = --------  |  du fang(rho,u),
!              pi     /0
!
! fang(rho,u) = [Arcsin{sqrt(1-rho^2u^2)} - rho*u*sqrt{1-rho^2u^2}]*u/sqrt(1-u^2)
!
! Note that the angular integral function S(rho) ≈1 when rho >> 1.
!
!--------------------------------------------------------------------------------
subroutine mean_overlap_efficiency(iqapp,iqcor,k0,df,PN,sigma)
use types; use const
implicit none
integer,parameter       :: nx = 1000
real(kind=dp),parameter :: xmax = 25.0_dp
integer                 :: i,iqapp,iqcor
real(kind=dp)           :: xmin,dlnx,stmp,k0,df,PN,sigma,frad
real(kind=dp)           :: factor,aicgm,gammq
real(kind=dp),allocatable::x(:),sang(:)

if(iqcor .eq. 1) then                           ! Gaussian
        aicgm  = 0.5_dp*(df-2.0_dp)
        xmin   = df * (k0/PN) ** (2.0/df)
        factor = xmin/16.0_dp/gamma(0.5_dp*df)
elseif(iqcor .eq. 2) then                       ! Exponential
        aicgm  = df - 2.0_dp
        xmin   = 2.0_dp * sqrt(0.5_dp*df*(df+1.0_dp))*(k0/PN)**(1.0/df)
        factor = xmin*xmin/16.0_dp/gamma(df)
elseif(iqcor .eq. 3) then                       ! Fractal dimension
        aicgm  = (df - 2.0_dp) / df
        xmin   = 2.0_dp**(df-1.0_dp) * k0 / PN
        factor = xmin ** (2.0_dp/df) / 16.0_dp
endif

if(df .gt. 2.0_dp .and. iqapp .eq. 3) then
        sigma  = factor*gamma(aicgm)*gammq(aicgm,xmin)
else
        dlnx = log(xmax/xmin)/real(nx-1,kind=dp)
        allocate(x(1:nx),sang(1:nx))
        do i=1,nx
                x(i) = exp(log(xmin)+real(i-1,kind=dp)*dlnx)
                if(iqapp .eq. 1) then
                        call angular_integration(iqcor,x(i),xmin,df,stmp)
                        sang(i) = stmp
                else
                        sang(i) = 1.0_dp
                endif
        enddo
        sigma = 0.0_dp
        do i=1,nx-1
        sigma = sigma + 0.5_dp * (frad(aicgm,x(i))*sang(i)+&
                frad(aicgm,x(i+1))*sang(i+1))
        enddo
        sigma = sigma * dlnx * factor
        deallocate(x,sang)
endif
return
end subroutine mean_overlap_efficiency

!--------------------------------------------------------------------------------
! The radial integrand function in ln(x) space
!--------------------------------------------------------------------------------
function frad(aicgm,x)
use types
implicit none
real(kind=dp)::aicgm,x,frad
        frad = x ** aicgm * exp(-x)
return
end function frad

!--------------------------------------------------------------------------------
! This subroutine computes the angular integral function S(rho)
!--------------------------------------------------------------------------------
subroutine angular_integration(iqcor,x,xmin,df,sang)
use types; use const
implicit none
integer            :: i,j,iqcor
integer,parameter  :: nmax_u = 500
real(kind=dp)      :: x,xmin,df,rho,umin,umax,du,fang,sang
real(kind=dp)      :: u(1:nmax_u)

if(iqcor .eq. 1) then
        rho = sqrt(x/xmin)
elseif(iqcor .eq. 2) then
        rho = x/xmin
elseif(iqcor .eq. 3) then
        rho = (x/xmin) ** (1.0_dp/df)
endif

sang = 0.0_dp
umin = 0.0_dp
umax = 1.0_dp / rho
du   = (umax - umin) / real(nmax_u-1,kind=dp)
do j=1,nmax_u
        u(j) = umin + du * real(j-1,kind=dp)
enddo
do j=1,nmax_u-1
        sang = sang + 0.5_dp*(fang(rho,u(j))+fang(rho,u(j+1)))*du
enddo
sang = 16.0_dp * rho * rho * sang / pi
return
end subroutine angular_integration

!--------------------------------------------------------------------------------
!
! This function returns the integrand of the angular integral.
!  fang (rho,u) =  [ Arcsin(sqrt(1-rho^2u^2)) - &
!               rho*u*sqrt(1-rho^2u^2)] * u / sqrt(1-u^2)
!
!--------------------------------------------------------------------------------
function fang(rho,u)
use types
implicit none
real(kind=dp)::rho,u,fang

if(abs(1.0_dp-rho*u) .le. 1.0e-10_dp) then
        fang = 0.0_dp
else
        fang = (asin(sqrt(1.0_dp-rho*rho*u*u))-&
                rho*u*sqrt(1.0_dp-rho*rho*u*u))*u/sqrt(1.0_dp-u*u)
endif

return
end function fang

!--------------------------------------------------------------------------------
!
! Following subroutines (gammq, gser, gcf, gammln) compute
! the incomplete Gamma function Q(a,x)
!
!             1     /infinity
! Q(a,x) = -------- | x^{a-1} exp(-x) dx
!          Gamma(a) /x
!
! where a>0. The definition of Q(a,x) obeys the definition in
!
! "Numerical Recipes in Fortran 77"
! Press, W. H., Teukolsky, S. A., Vetterling, W. T., et al.1992,
! Cambridge: University Press, |c1992, 2nd ed
!
! Following subroutines are taken from Numerical Recippes in Fortran 77
!
!--------------------------------------------------------------------------------
!
! History (R.T.)
!
! The original subroutine was slightly modified so that the old F77 grammers
! are rewritten by modern grammers.
!
! Convergence accuracy eps is changed from 3e-7 to 3e-14.
!
!--------------------------------------------------------------------------------
function gammq(a,x)
use types
real(kind=dp) a,gammq,x
real(kind=dp) gammcf,gamser,gln
if(x.lt.0..or.a.le.0.) then
      write(*,*) 'error'
      stop
endif
if(x.lt.a+1.)then
        call gser(gamser,a,x,gln)
        gammq=1.-gamser
else
        call gcf(gammcf,a,x,gln)
        gammq=gammcf
endif
return
end function gammq

subroutine gser(gamser,a,x,gln)
use types
integer itmax
real(kind=dp) a,gamser,gln,x,eps
parameter (itmax=100,eps=3.e-14)
integer n
real(kind=dp) ap,del,sum,gammln
gln=gammln(a)
if(x.le.0.)then
        if(x.lt.0.) then
                write(*,*) "error"
                stop
        endif
        gamser=0.
        return
endif
ap=a
sum=1./a
del=sum
do n=1,itmax
        ap=ap+1.
        del=del*x/ap
        sum=sum+del
        if(abs(del).lt.abs(sum)*eps) exit
        if(n .eq. itmax) then
                print *, 'a too large, itmax too small in gser'
                stop
        endif
enddo
gamser=sum*exp(-x+a*log(x)-gln)
return
end subroutine gser
subroutine gcf(gammcf,a,x,gln)
use types
integer itmax
real(kind=dp) a,gammcf,gln,x,eps,fpmin
parameter (itmax=100,eps=3.e-14,fpmin=1.e-30)
integer i
real(kind=dp) an,b,c,d,del,h,gammln
gln=gammln(a)
b=x+1.-a
c=1./fpmin
d=1./b
h=d
do i=1,itmax
        an=-i*(i-a)
        b=b+2.
        d=an*d+b
        if(abs(d).lt.fpmin)d=fpmin
        c=b+an/c
        if(abs(c).lt.fpmin)c=fpmin
        d=1./d
        del=d*c
        h=h*del
        if(abs(del-1.).lt.eps) exit
        if(n .eq. itmax) then
                print *, 'a too large, itmax too small in gcf'
                stop
        endif
enddo
gammcf=exp(-x+a*log(x)-gln)*h
return
end subroutine gcf
function gammln(xx)
use types
real(kind=dp) gammln,xx
integer j
real(kind=dp) ser,stp,tmp,x,y,cof(6)
save cof,stp
data cof,stp/76.18009172947146d0,-86.50532032941677d0,&
        24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,&
        -.5395239384953d-5,2.5066282746310005d0/
x=xx
y=x
tmp=x+5.5d0
tmp=(x+0.5d0)*log(tmp)-tmp
ser=1.000000000190015d0
do j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
enddo
gammln=tmp+log(stp*ser/x)
return
end function gammln


subroutine sum(v,n,SU)
    implicit none ;
    integer*4 i,n
    double precision,dimension(n):: v
    double precision:: SU
SU=0.0d0;
   do i=1,n
 SU=SU+v(i);
    enddo ;
   return;
end subroutine


program main
  implicit none
  integer, parameter :: n = 5
  real :: a(n, n), norm, work(n)
  integer :: i, j
  real :: slange
  do j = 1, n
     do i = 1, n
        a(i, j) = min(i, j)
     end do
  end do
  print *, "Matrix A: ", n, n
  do j = 1, n
     print *, a(1:n, j)
  end do

  norm = slange('M', n, n, a, n)
  print *, "element of largest absolute value =", norm
  norm = slange('1', n, n, a, n)
  print *, "one norm =", norm
  norm = slange('I', n, n, a, n, work)
  print *, "infinity norm =", norm
  norm = slange('F', n, n, a, n)
  print *, "Frobenius norm =", norm
end program main


      INTEGER FUNCTION IFOLD(F,A,N)	!"Catamorphism"...
       INTEGER F	!We're working only with integers.
       EXTERNAL F	!This is a function, not an array.
       INTEGER A(*)	!An 1-D array, of unspecified size.
       INTEGER N	!The number of elements.
       INTEGER I	!A stepper.
        IFOLD = 0		!A default value.
        IF (N.LE.0) RETURN	!Dodge silly invocations.
        IFOLD = A(1)		!The function is to have two arguments.
        IF (N.EQ.1) RETURN	!So, if there is only one element, silly.
        DO I = 2,N		!Otherwise, stutter along the array.
          IFOLD = F(IFOLD,A(I))		!Applying the function.
        END DO			!On to the next element.
      END FUNCTION IFOLD!Thus, F(A(1),A(2)), or F(F(A(1),A(2)),A(3)), or F(F(F(A(1),A(2)),A(3)),A(4)), etc.

      INTEGER FUNCTION IADD(I,J)
       INTEGER I,J
        IADD = I + J
      END FUNCTION IADD

      INTEGER FUNCTION IMUL(I,J)
       INTEGER I,J
        IMUL = I*J
      END FUNCTION IMUL

      INTEGER FUNCTION IDIV(I,J)
       INTEGER I,J
        IDIV = I/J
      END FUNCTION IDIV

      INTEGER FUNCTION IVID(I,J)
       INTEGER I,J
        IVID = J/I
      END FUNCTION IVID

      PROGRAM POKE
      INTEGER ENUFF
      PARAMETER (ENUFF = 6)
      INTEGER A(ENUFF)
      PARAMETER (A = (/1,2,3,4,5,6/))
      INTEGER MSG
      EXTERNAL IADD,IMUL,IDIV,IVID	!Warn that these are the names of functions.

      MSG = 6	!Standard output.
      WRITE (MSG,1) ENUFF,A
    1 FORMAT ('To apply a function in the "catamorphic" style ',
     1 "to the ",I0," values ",/,(20I3))

      WRITE (MSG,*) "Iadd",IFOLD(IADD,A,ENUFF)
      WRITE (MSG,*) "Imul",IFOLD(IMUL,A,ENUFF)
      WRITE (MSG,*) "Idiv",IFOLD(IDIV,A,ENUFF)
      WRITE (MSG,*) "Ivid",IFOLD(IVID,A,ENUFF)
      END PROGRAM POKE


    Program zppcon_example

!     ZPPCON Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zlanhp, zppcon, zpptrf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: anorm, rcond
      Integer :: i, info, j, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:), work(:)
      Real (Kind=dp), Allocatable :: rwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'ZPPCON Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap(n*(n+1)/2), work(2*n), rwork(n))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

!     Compute norm of A
      anorm = zlanhp('1-norm', uplo, n, ap, rwork)

!     Factorize A
      Call zpptrf(uplo, n, ap, info)

      Write (nout, *)
      If (info==0) Then

!       Estimate condition number

        Call zppcon(uplo, n, ap, anorm, rcond, work, rwork, info)

        If (rcond>=epsilon(1.0E0_dp)) Then
          Write (nout, 100) 'Estimate of condition number =', 1.0_dp/rcond
        Else
          Write (nout, *) 'A is singular to working precision'
        End If
      Else
        Write (nout, *) 'A is not positive definite'
      End If

100   Format (1X, A, 1P, E10.2)
    End Program


    Program zgglse_example

!     ZGGLSE Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_interfaces, Only: zgglse
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: rnorm
      Integer :: i, info, lda, ldb, lwork, m, n, p
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), c(:), d(:), work(:), &
        x(:)
!     .. Executable Statements ..
      Write (nout, *) 'ZGGLSE Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, p
      lda = m
      ldb = p
      lwork = p + n + nb*(m+n)
      Allocate (a(lda,n), b(ldb,n), c(m), d(p), work(lwork), x(n))

!     Read A, B, C and D from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *)(b(i,1:n), i=1, p)
      Read (nin, *) c(1:m)
      Read (nin, *) d(1:p)

!     Solve the equality-constrained least squares problem

!     minimize ||c - A*x|| (in the 2-norm) subject to B*x = D

      Call zgglse(m, n, p, a, lda, b, ldb, c, d, x, work, lwork, info)

!     Print least squares solution

      Write (nout, *) 'Constrained least squares solution'
      Write (nout, 100) x(1:n)

!     Compute the square root of the residual sum of squares

      rnorm = dznrm2(m-n+p, c(n-p+1), 1)
      Write (nout, *)
      Write (nout, *) 'Square root of the residual sum of squares'
      Write (nout, 110) rnorm

100   Format (4(' (',F7.4,',',F7.4,')',:))
110   Format (1X, 1P, E10.2)
    End Program


!*==zgesvdx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGESVDX computes the singular value decomposition (SVD) for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGESVDX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!     SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU,
!    $                    IL, IU, NS, S, U, LDU, VT, LDVT, WORK,
!    $                    LWORK, RWORK, IWORK, INFO )
!
!
!     .. Scalar Arguments ..
!      CHARACTER          JOBU, JOBVT, RANGE
!      INTEGER            IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS
!      DOUBLE PRECISION   VL, VU
!     ..
!     .. Array Arguments ..
!      INTEGER            IWORK( * )
!      DOUBLE PRECISION   S( * ), RWORK( * )
!      COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
!     $                   WORK( * )
!     ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>  ZGESVDX computes the singular value decomposition (SVD) of a complex
!>  M-by-N matrix A, optionally computing the left and/or right singular
!>  vectors. The SVD is written
!>
!>      A = U * SIGMA * transpose(V)
!>
!>  where SIGMA is an M-by-N matrix which is zero except for its
!>  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
!>  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA
!>  are the singular values of A; they are real and non-negative, and
!>  are returned in descending order.  The first min(m,n) columns of
!>  U and V are the left and right singular vectors of A.
!>
!>  ZGESVDX uses an eigenvalue problem for obtaining the SVD, which
!>  allows for the computation of a subset of singular values and
!>  vectors. See DBDSVDX for details.
!>
!>  Note that the routine returns V**T, not V.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBU
!> \verbatim
!>          JOBU is CHARACTER*1
!>          Specifies options for computing all or part of the matrix U:
!>          = 'V':  the first min(m,n) columns of U (the left singular
!>                  vectors) or as specified by RANGE are returned in
!>                  the array U;
!>          = 'N':  no columns of U (no left singular vectors) are
!>                  computed.
!> \endverbatim
!>
!> \param[in] JOBVT
!> \verbatim
!>          JOBVT is CHARACTER*1
!>           Specifies options for computing all or part of the matrix
!>           V**T:
!>           = 'V':  the first min(m,n) rows of V**T (the right singular
!>                   vectors) or as specified by RANGE are returned in
!>                   the array VT;
!>           = 'N':  no rows of V**T (no right singular vectors) are
!>                   computed.
!> \endverbatim
!>
!> \param[in] RANGE
!> \verbatim
!>          RANGE is CHARACTER*1
!>          = 'A': all singular values will be found.
!>          = 'V': all singular values in the half-open interval (VL,VU]
!>                 will be found.
!>          = 'I': the IL-th through IU-th singular values will be found.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the input matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the input matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the contents of A are destroyed.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in] VL
!> \verbatim
!>          VL is DOUBLE PRECISION
!>          If RANGE='V', the lower bound of the interval to
!>          be searched for singular values. VU > VL.
!>          Not referenced if RANGE = 'A' or 'I'.
!> \endverbatim
!>
!> \param[in] VU
!> \verbatim
!>          VU is DOUBLE PRECISION
!>          If RANGE='V', the upper bound of the interval to
!>          be searched for singular values. VU > VL.
!>          Not referenced if RANGE = 'A' or 'I'.
!> \endverbatim
!>
!> \param[in] IL
!> \verbatim
!>          IL is INTEGER
!>          If RANGE='I', the index of the
!>          smallest singular value to be returned.
!>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!> \endverbatim
!>
!> \param[in] IU
!> \verbatim
!>          IU is INTEGER
!>          If RANGE='I', the index of the
!>          largest singular value to be returned.
!>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!> \endverbatim
!>
!> \param[out] NS
!> \verbatim
!>          NS is INTEGER
!>          The total number of singular values found,
!>          0 <= NS <= min(M,N).
!>          If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is DOUBLE PRECISION array, dimension (min(M,N))
!>          The singular values of A, sorted so that S(i) >= S(i+1).
!> \endverbatim
!>
!> \param[out] U
!> \verbatim
!>          U is COMPLEX*16 array, dimension (LDU,UCOL)
!>          If JOBU = 'V', U contains columns of U (the left singular
!>          vectors, stored columnwise) as specified by RANGE; if
!>          JOBU = 'N', U is not referenced.
!>          Note: The user must ensure that UCOL >= NS; if RANGE = 'V',
!>          the exact value of NS is not known in advance and an upper
!>          bound must be used.
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= 1; if
!>          JOBU = 'V', LDU >= M.
!> \endverbatim
!>
!> \param[out] VT
!> \verbatim
!>          VT is COMPLEX*16 array, dimension (LDVT,N)
!>          If JOBVT = 'V', VT contains the rows of V**T (the right singular
!>          vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N',
!>          VT is not referenced.
!>          Note: The user must ensure that LDVT >= NS; if RANGE = 'V',
!>          the exact value of NS is not known in advance and an upper
!>          bound must be used.
!> \endverbatim
!>
!> \param[in] LDVT
!> \verbatim
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= 1; if
!>          JOBVT = 'V', LDVT >= NS (see above).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see
!>          comments inside the code):
!>             - PATH 1  (M much larger than N)
!>             - PATH 1t (N much larger than M)
!>          LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths.
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
!>          LRWORK >= MIN(M,N)*(MIN(M,N)*2+15*MIN(M,N)).
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (12*MIN(M,N))
!>          If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0,
!>          then IWORK contains the indices of the eigenvectors that failed
!>          to converge in DBDSVDX/DSTEVX.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>     INFO is INTEGER
!>           = 0:  successful exit
!>           < 0:  if INFO = -i, the i-th argument had an illegal value
!>           > 0:  if INFO = i, then i eigenvectors failed to converge
!>                 in DBDSVDX/DSTEVX.
!>                 if INFO = N*2 + 1, an internal error occurred in
!>                 DBDSVDX
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup complex16GEsing
!
!  =====================================================================
      SUBROUTINE ZGESVDX(Jobu,Jobvt,Range,M,N,A,Lda,Vl,Vu,Il,Iu,Ns,S,U, &
     &                   Ldu,Vt,Ldvt,Work,Lwork,Rwork,Iwork,Info)
      IMPLICIT NONE
!*--ZGESVDX273
!
!  -- LAPACK driver routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobu , Jobvt , Range
      INTEGER Il , Info , Iu , Lda , Ldu , Ldvt , Lwork , M , N , Ns
      DOUBLE PRECISION Vl , Vu
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      DOUBLE PRECISION S(*) , Rwork(*)
      COMPLEX*16 A(Lda,*) , U(Ldu,*) , Vt(Ldvt,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16 CZERO
      PARAMETER (CZERO=(0.0D0,0.0D0))
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      CHARACTER jobz , rngtgk
      LOGICAL alls , inds , lquery , vals , wantu , wantvt
      INTEGER i , id , ie , ierr , ilqf , iltgk , iqrf , iscl , itau ,  &
     &        itaup , itauq , itemp , itempr , itgkz , iutgk , j , k ,  &
     &        maxwrk , minmn , minwrk , mnthr
      DOUBLE PRECISION abstol , anrm , bignum , eps , smlnum
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL ZGEBRD , ZGELQF , ZGEQRF , ZLASCL , ZLASET , ZLACPY ,    &
     &         ZUNMLQ , ZUNMBR , ZUNMQR , DBDSVDX , DLASCL , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , ZLANGE
      EXTERNAL LSAME , ILAENV , DLAMCH , ZLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      Ns = 0
      Info = 0
      abstol = 2*DLAMCH('S')
      lquery = (Lwork==-1)
      minmn = MIN(M,N)

      wantu = LSAME(Jobu,'V')
      wantvt = LSAME(Jobvt,'V')
      IF ( wantu .OR. wantvt ) THEN
         jobz = 'V'
      ELSE
         jobz = 'N'
      ENDIF
      alls = LSAME(Range,'A')
      vals = LSAME(Range,'V')
      inds = LSAME(Range,'I')
!
      Info = 0
      IF ( .NOT.LSAME(Jobu,'V') .AND. .NOT.LSAME(Jobu,'N') ) THEN
         Info = -1
      ELSEIF ( .NOT.LSAME(Jobvt,'V') .AND. .NOT.LSAME(Jobvt,'N') ) THEN
         Info = -2
      ELSEIF ( .NOT.(alls .OR. vals .OR. inds) ) THEN
         Info = -3
      ELSEIF ( M<0 ) THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( M>Lda ) THEN
         Info = -7
      ELSEIF ( minmn>0 ) THEN
         IF ( vals ) THEN
            IF ( Vl<ZERO ) THEN
               Info = -8
            ELSEIF ( Vu<=Vl ) THEN
               Info = -9
            ENDIF
         ELSEIF ( inds ) THEN
            IF ( Il<1 .OR. Il>MAX(1,minmn) ) THEN
               Info = -10
            ELSEIF ( Iu<MIN(minmn,Il) .OR. Iu>minmn ) THEN
               Info = -11
            ENDIF
         ENDIF
         IF ( Info==0 ) THEN
            IF ( wantu .AND. Ldu<M ) THEN
               Info = -15
            ELSEIF ( wantvt ) THEN
               IF ( inds ) THEN
                  IF ( Ldvt<Iu-Il+1 ) Info = -17
               ELSEIF ( Ldvt<minmn ) THEN
                  Info = -17
               ENDIF
            ENDIF
         ENDIF
      ENDIF
!
!     Compute workspace
!     (Note: Comments in the code beginning "Workspace:" describe the
!     minimal amount of workspace needed at that point in the code,
!     as well as the preferred amount for good performance.
!     NB refers to the optimal block size for the immediately
!     following subroutine, as returned by ILAENV.)
!
      IF ( Info==0 ) THEN
         minwrk = 1
         maxwrk = 1
         IF ( minmn>0 ) THEN
            IF ( M>=N ) THEN
               mnthr = ILAENV(6,'ZGESVD',Jobu//Jobvt,M,N,0,0)
               IF ( M>=mnthr ) THEN
!
!                 Path 1 (M much larger than N)
!
                  minwrk = N*(N+5)
                  maxwrk = N + N*ILAENV(1,'ZGEQRF',' ',M,N,-1,-1)
                  maxwrk = MAX(maxwrk,                                  &
     &                     N*N+2*N+2*N*ILAENV(1,'ZGEBRD',' ',N,N,-1,-1))
                  IF ( wantu .OR. wantvt )                              &
     &                 maxwrk = MAX(maxwrk,N*N+2*N+N*ILAENV(1,'ZUNMQR', &
     &                 'LN',N,N,N,-1))
               ELSE
!
!                 Path 2 (M at least N, but not much larger)
!
                  minwrk = 3*N + M
                  maxwrk = 2*N + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1,-1)
                  IF ( wantu .OR. wantvt )                              &
     &                 maxwrk = MAX(maxwrk,2*N+N*ILAENV(1,'ZUNMQR','LN',&
     &                 N,N,N,-1))
               ENDIF
            ELSE
               mnthr = ILAENV(6,'ZGESVD',Jobu//Jobvt,M,N,0,0)
               IF ( N>=mnthr ) THEN
!
!                 Path 1t (N much larger than M)
!
                  minwrk = M*(M+5)
                  maxwrk = M + M*ILAENV(1,'ZGELQF',' ',M,N,-1,-1)
                  maxwrk = MAX(maxwrk,                                  &
     &                     M*M+2*M+2*M*ILAENV(1,'ZGEBRD',' ',M,M,-1,-1))
                  IF ( wantu .OR. wantvt )                              &
     &                 maxwrk = MAX(maxwrk,M*M+2*M+M*ILAENV(1,'ZUNMQR', &
     &                 'LN',M,M,M,-1))
               ELSE
!
!                 Path 2t (N greater than M, but not much larger)
!
!
                  minwrk = 3*M + N
                  maxwrk = 2*M + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1,-1)
                  IF ( wantu .OR. wantvt )                              &
     &                 maxwrk = MAX(maxwrk,2*M+M*ILAENV(1,'ZUNMQR','LN',&
     &                 M,M,M,-1))
               ENDIF
            ENDIF
         ENDIF
         maxwrk = MAX(maxwrk,minwrk)
         Work(1) = DCMPLX(DBLE(maxwrk),ZERO)
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -19
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGESVDX',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Set singular values indices accord to RANGE='A'.
!
      IF ( alls ) THEN
         rngtgk = 'I'
         iltgk = 1
         iutgk = MIN(M,N)
      ELSEIF ( inds ) THEN
         rngtgk = 'I'
         iltgk = Il
         iutgk = Iu
      ELSE
         rngtgk = 'V'
         iltgk = 0
         iutgk = 0
      ENDIF
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = SQRT(DLAMCH('S'))/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = ZLANGE('M',M,N,A,Lda,dum)
      iscl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         iscl = 1
         CALL ZLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,Info)
      ELSEIF ( anrm>bignum ) THEN
         iscl = 1
         CALL ZLASCL('G',0,0,anrm,bignum,M,N,A,Lda,Info)
      ENDIF
!
      IF ( M>=N ) THEN
!
!        A has at least as many rows as columns. If A has sufficiently
!        more rows than columns, first reduce A using the QR
!        decomposition.
!
         IF ( M>=mnthr ) THEN
!
!           Path 1 (M much larger than N):
!           A = Q * R = Q * ( QB * B * PB**T )
!                     = Q * ( QB * ( UB * S * VB**T ) * PB**T )
!           U = Q * QB * UB; V**T = VB**T * PB**T
!
!           Compute A=Q*R
!           (Workspace: need 2*N, prefer N+N*NB)
!
            itau = 1
            itemp = itau + N
            CALL ZGEQRF(M,N,A,Lda,Work(itau),Work(itemp),Lwork-itemp+1, &
     &                  Info)
!
!           Copy R into WORK and bidiagonalize it:
!           (Workspace: need N*N+3*N, prefer N*N+N+2*N*NB)
!
            iqrf = itemp
            itauq = itemp + N*N
            itaup = itauq + N
            itemp = itaup + N
            id = 1
            ie = id + N
            itgkz = ie + N
            CALL ZLACPY('U',N,N,A,Lda,Work(iqrf),N)
            CALL ZLASET('L',N-1,N-1,CZERO,CZERO,Work(iqrf+1),N)
            CALL ZGEBRD(N,N,Work(iqrf),N,Rwork(id),Rwork(ie),Work(itauq)&
     &                  ,Work(itaup),Work(itemp),Lwork-itemp+1,Info)
            itempr = itgkz + N*(N*2+1)
!
!           Solve eigenvalue problem TGK*Z=Z*S.
!           (Workspace: need 2*N*N+14*N)
!
            CALL DBDSVDX('U',jobz,rngtgk,N,Rwork(id),Rwork(ie),Vl,Vu,   &
     &                   iltgk,iutgk,Ns,S,Rwork(itgkz),N*2,Rwork(itempr)&
     &                   ,Iwork,Info)
!
!           If needed, compute left singular vectors.
!
            IF ( wantu ) THEN
               k = itgkz
               DO i = 1 , Ns
                  DO j = 1 , N
                     U(j,i) = DCMPLX(Rwork(k),ZERO)
                     k = k + 1
                  ENDDO
                  k = k + N
               ENDDO
               CALL ZLASET('A',M-N,Ns,CZERO,CZERO,U(N+1,1),Ldu)
!
!              Call ZUNMBR to compute QB*UB.
!              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
!
               CALL ZUNMBR('Q','L','N',N,Ns,N,Work(iqrf),N,Work(itauq), &
     &                     U,Ldu,Work(itemp),Lwork-itemp+1,Info)
!
!              Call ZUNMQR to compute Q*(QB*UB).
!              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
!
               CALL ZUNMQR('L','N',M,Ns,N,A,Lda,Work(itau),U,Ldu,       &
     &                     Work(itemp),Lwork-itemp+1,Info)
            ENDIF
!
!           If needed, compute right singular vectors.
!
            IF ( wantvt ) THEN
               k = itgkz + N
               DO i = 1 , Ns
                  DO j = 1 , N
                     Vt(i,j) = DCMPLX(Rwork(k),ZERO)
                     k = k + 1
                  ENDDO
                  k = k + N
               ENDDO
!
!              Call ZUNMBR to compute VB**T * PB**T
!              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
!
               CALL ZUNMBR('P','R','C',Ns,N,N,Work(iqrf),N,Work(itaup), &
     &                     Vt,Ldvt,Work(itemp),Lwork-itemp+1,Info)
            ENDIF
         ELSE
!
!           Path 2 (M at least N, but not much larger)
!           Reduce A to bidiagonal form without QR decomposition
!           A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
!           U = QB * UB; V**T = VB**T * PB**T
!
!           Bidiagonalize A
!           (Workspace: need 2*N+M, prefer 2*N+(M+N)*NB)
!
            itauq = 1
            itaup = itauq + N
            itemp = itaup + N
            id = 1
            ie = id + N
            itgkz = ie + N
            CALL ZGEBRD(M,N,A,Lda,Rwork(id),Rwork(ie),Work(itauq),      &
     &                  Work(itaup),Work(itemp),Lwork-itemp+1,Info)
            itempr = itgkz + N*(N*2+1)
!
!           Solve eigenvalue problem TGK*Z=Z*S.
!           (Workspace: need 2*N*N+14*N)
!
            CALL DBDSVDX('U',jobz,rngtgk,N,Rwork(id),Rwork(ie),Vl,Vu,   &
     &                   iltgk,iutgk,Ns,S,Rwork(itgkz),N*2,Rwork(itempr)&
     &                   ,Iwork,Info)
!
!           If needed, compute left singular vectors.
!
            IF ( wantu ) THEN
               k = itgkz
               DO i = 1 , Ns
                  DO j = 1 , N
                     U(j,i) = DCMPLX(Rwork(k),ZERO)
                     k = k + 1
                  ENDDO
                  k = k + N
               ENDDO
               CALL ZLASET('A',M-N,Ns,CZERO,CZERO,U(N+1,1),Ldu)
!
!              Call ZUNMBR to compute QB*UB.
!              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
!
               CALL ZUNMBR('Q','L','N',M,Ns,N,A,Lda,Work(itauq),U,Ldu,  &
     &                     Work(itemp),Lwork-itemp+1,ierr)
            ENDIF
!
!           If needed, compute right singular vectors.
!
            IF ( wantvt ) THEN
               k = itgkz + N
               DO i = 1 , Ns
                  DO j = 1 , N
                     Vt(i,j) = DCMPLX(Rwork(k),ZERO)
                     k = k + 1
                  ENDDO
                  k = k + N
               ENDDO
!
!              Call ZUNMBR to compute VB**T * PB**T
!              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
!
               CALL ZUNMBR('P','R','C',Ns,N,N,A,Lda,Work(itaup),Vt,Ldvt,&
     &                     Work(itemp),Lwork-itemp+1,ierr)
            ENDIF
         ENDIF
!
!        A has more columns than rows. If A has sufficiently more
!        columns than rows, first reduce A using the LQ decomposition.
!
      ELSEIF ( N>=mnthr ) THEN
!
!           Path 1t (N much larger than M):
!           A = L * Q = ( QB * B * PB**T ) * Q
!                     = ( QB * ( UB * S * VB**T ) * PB**T ) * Q
!           U = QB * UB ; V**T = VB**T * PB**T * Q
!
!           Compute A=L*Q
!           (Workspace: need 2*M, prefer M+M*NB)
!
         itau = 1
         itemp = itau + M
         CALL ZGELQF(M,N,A,Lda,Work(itau),Work(itemp),Lwork-itemp+1,    &
     &               Info)

!           Copy L into WORK and bidiagonalize it:
!           (Workspace in WORK( ITEMP ): need M*M+3*M, prefer M*M+M+2*M*NB)
!
         ilqf = itemp
         itauq = ilqf + M*M
         itaup = itauq + M
         itemp = itaup + M
         id = 1
         ie = id + M
         itgkz = ie + M
         CALL ZLACPY('L',M,M,A,Lda,Work(ilqf),M)
         CALL ZLASET('U',M-1,M-1,CZERO,CZERO,Work(ilqf+M),M)
         CALL ZGEBRD(M,M,Work(ilqf),M,Rwork(id),Rwork(ie),Work(itauq),  &
     &               Work(itaup),Work(itemp),Lwork-itemp+1,Info)
         itempr = itgkz + M*(M*2+1)
!
!           Solve eigenvalue problem TGK*Z=Z*S.
!           (Workspace: need 2*M*M+14*M)
!
         CALL DBDSVDX('U',jobz,rngtgk,M,Rwork(id),Rwork(ie),Vl,Vu,iltgk,&
     &                iutgk,Ns,S,Rwork(itgkz),M*2,Rwork(itempr),Iwork,  &
     &                Info)
!
!           If needed, compute left singular vectors.
!
         IF ( wantu ) THEN
            k = itgkz
            DO i = 1 , Ns
               DO j = 1 , M
                  U(j,i) = DCMPLX(Rwork(k),ZERO)
                  k = k + 1
               ENDDO
               k = k + M
            ENDDO
!
!              Call ZUNMBR to compute QB*UB.
!              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
!
            CALL ZUNMBR('Q','L','N',M,Ns,M,Work(ilqf),M,Work(itauq),U,  &
     &                  Ldu,Work(itemp),Lwork-itemp+1,Info)
         ENDIF
!
!           If needed, compute right singular vectors.
!
         IF ( wantvt ) THEN
            k = itgkz + M
            DO i = 1 , Ns
               DO j = 1 , M
                  Vt(i,j) = DCMPLX(Rwork(k),ZERO)
                  k = k + 1
               ENDDO
               k = k + M
            ENDDO
            CALL ZLASET('A',Ns,N-M,CZERO,CZERO,Vt(1,M+1),Ldvt)
!
!              Call ZUNMBR to compute (VB**T)*(PB**T)
!              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
!
            CALL ZUNMBR('P','R','C',Ns,M,M,Work(ilqf),M,Work(itaup),Vt, &
     &                  Ldvt,Work(itemp),Lwork-itemp+1,Info)
!
!              Call ZUNMLQ to compute ((VB**T)*(PB**T))*Q.
!              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
!
            CALL ZUNMLQ('R','N',Ns,N,M,A,Lda,Work(itau),Vt,Ldvt,        &
     &                  Work(itemp),Lwork-itemp+1,Info)
         ENDIF
      ELSE
!
!           Path 2t (N greater than M, but not much larger)
!           Reduce to bidiagonal form without LQ decomposition
!           A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
!           U = QB * UB; V**T = VB**T * PB**T
!
!           Bidiagonalize A
!           (Workspace: need 2*M+N, prefer 2*M+(M+N)*NB)
!
         itauq = 1
         itaup = itauq + M
         itemp = itaup + M
         id = 1
         ie = id + M
         itgkz = ie + M
         CALL ZGEBRD(M,N,A,Lda,Rwork(id),Rwork(ie),Work(itauq),         &
     &               Work(itaup),Work(itemp),Lwork-itemp+1,Info)
         itempr = itgkz + M*(M*2+1)
!
!           Solve eigenvalue problem TGK*Z=Z*S.
!           (Workspace: need 2*M*M+14*M)
!
         CALL DBDSVDX('L',jobz,rngtgk,M,Rwork(id),Rwork(ie),Vl,Vu,iltgk,&
     &                iutgk,Ns,S,Rwork(itgkz),M*2,Rwork(itempr),Iwork,  &
     &                Info)
!
!           If needed, compute left singular vectors.
!
         IF ( wantu ) THEN
            k = itgkz
            DO i = 1 , Ns
               DO j = 1 , M
                  U(j,i) = DCMPLX(Rwork(k),ZERO)
                  k = k + 1
               ENDDO
               k = k + M
            ENDDO
!
!              Call ZUNMBR to compute QB*UB.
!              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
!
            CALL ZUNMBR('Q','L','N',M,Ns,N,A,Lda,Work(itauq),U,Ldu,     &
     &                  Work(itemp),Lwork-itemp+1,Info)
         ENDIF
!
!           If needed, compute right singular vectors.
!
         IF ( wantvt ) THEN
            k = itgkz + M
            DO i = 1 , Ns
               DO j = 1 , M
                  Vt(i,j) = DCMPLX(Rwork(k),ZERO)
                  k = k + 1
               ENDDO
               k = k + M
            ENDDO
            CALL ZLASET('A',Ns,N-M,CZERO,CZERO,Vt(1,M+1),Ldvt)
!
!              Call ZUNMBR to compute VB**T * PB**T
!              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
!
            CALL ZUNMBR('P','R','C',Ns,N,M,A,Lda,Work(itaup),Vt,Ldvt,   &
     &                  Work(itemp),Lwork-itemp+1,Info)
         ENDIF
      ENDIF
!
!     Undo scaling if necessary
!
      IF ( iscl==1 ) THEN
         IF ( anrm>bignum ) CALL DLASCL('G',0,0,bignum,anrm,minmn,1,S,  &
     &                                  minmn,Info)
         IF ( anrm<smlnum ) CALL DLASCL('G',0,0,smlnum,anrm,minmn,1,S,  &
     &                                  minmn,Info)
      ENDIF
!
!     Return optimal workspace in WORK(1)
!
      Work(1) = DCMPLX(DBLE(maxwrk),ZERO)
!
!
!     End of ZGESVDX
!
      END SUBROUTINE ZGESVDX


module integration

  use pde
  use global_module

  implicit none

  real(kind=8), dimension(Neq,Nx) :: U_new ! Working variable

  contains

  ! ========================================================================

  subroutine forward_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Update solution using the forward Euler integrator - INTERNAL CELLS only
    ! (I am using 4 ghost cells per side. This is useful for further generalizations
    !  to higher order methods)
    do i = 5, Nx-4

      ! Choose one of these fluxes
      call compute_fluxes_HLL(U, i, F_W, F_E)
      ! call compute_fluxes_Rusanov(U, i, F_W, F_E)

      ! Advect remaining stuff
      U_new(:,i) = U(:,i) - dt/dx*(F_E - F_W)  ! No source term

      ! Check that the solution did not diverge
      do eqID = 1, Neq
        if (isnan(U_new(eqID,i))) then
          print*, 'Solution diverged, try with a smaller time step! Aborting.'
          print*, 'Solution that diverged: ', U_new(:,i)
          print*, 'in cell i = ', i
          stop
        end if
      end do

    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,5:Nx-4) = U_new(:,5:Nx-4)

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_HLL(U, i, F_W, F_E)

    ! Computes HLL numerical fluxes for the cell "i"
    ! 'F_W' and 'F_E' are the complete fluxes at the cell interfaces, to be then
    ! added in the time-discretized PDE.
    ! The variables 'F_L' and 'F_R' are temporary variables used for the
    ! fluxes at the left and right of an interface.

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(in)  :: U
    real(kind=8), dimension(Neq),    intent(out) :: F_W, F_E
    integer, intent(in) :: i

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_im3, U_im2, U_im1, U_i, U_ip1, U_ip2, U_ip3
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R

    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_min, ws_max ! wave speeds

    ! ---- West interface -----

    U_L = U(:,i-1)
    U_R = U(:,i)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_W = F_L
    else if (ws_max .lt. 0.0) then
      F_W = F_R
    else
      F_W = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! ---- East interface -----

    U_L = U(:,i)
    U_R = U(:,i+1)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_E = F_L
    else if (ws_max .lt. 0.0) then
      F_E = F_R
    else
      F_E = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_Rusanov(U, i, F_W, F_E)

    ! Computes HLL numerical fluxes for the cell "i"
    ! 'F_W' and 'F_E' are the complete fluxes at the cell interfaces, to be then
    ! added in the time-discretized PDE.
    ! The variables 'F_L' and 'F_R' are temporary variables used for the
    ! fluxes at the left and right of an interface.

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(in)  :: U
    real(kind=8), dimension(Neq),    intent(out) :: F_W, F_E
    integer, intent(in) :: i

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R
    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_min, ws_max ! wave speeds

    ! ---- West interface -----

    U_L = U(:,i-1)
    U_R = U(:,i)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    ! West interface
    F_W    = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! ---- East interface -----

    U_L = U(:,i)
    U_R = U(:,i+1)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    ! West interface
    F_E    = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

  end subroutine

end module