      SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS,
     $                   ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX,
     $                   Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK,
     $                   IWORK, NOUT, INFO )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
     $                   NSIZES, NTYPES
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
      INTEGER            ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * )
      DOUBLE PRECISION   A( LDA, * ), BD( * ), BE( * ), PT( LDPT, * ),
     $                   Q( LDQ, * ), S1( * ), S2( * ), U( LDPT, * ),
     $                   VT( LDPT, * ), WORK( * ), X( LDX, * ),
     $                   Y( LDX, * ), Z( LDX, * )
*     ..
*
*  Purpose
*  =======
*
*  DCHKBD checks the singular value decomposition (SVD) routines.
*
*  DGEBRD reduces a real general m by n matrix A to upper or lower
*  bidiagonal form B by an orthogonal transformation:  Q' * A * P = B
*  (or A = Q * B * P').  The matrix B is upper bidiagonal if m >= n
*  and lower bidiagonal if m < n.
*
*  DORGBR generates the orthogonal matrices Q and P' from DGEBRD.
*  Note that Q and P are not necessarily square.
*
*  DBDSQR computes the singular value decomposition of the bidiagonal
*  matrix B as B = U S V'.  It is called three times to compute
*     1)  B = U S1 V', where S1 is the diagonal matrix of singular
*         values and the columns of the matrices U and V are the left
*         and right singular vectors, respectively, of B.
*     2)  Same as 1), but the singular values are stored in S2 and the
*         singular vectors are not computed.
*     3)  A = (UQ) S (P'V'), the SVD of the original matrix A.
*  In addition, DBDSQR has an option to apply the left orthogonal matrix
*  U to a matrix X, useful in least squares applications.
*
*  DBDSDC computes the singular value decomposition of the bidiagonal
*  matrix B as B = U S V' using divide-and-conquer. It is called twice
*  to compute
*     1) B = U S1 V', where S1 is the diagonal matrix of singular
*         values and the columns of the matrices U and V are the left
*         and right singular vectors, respectively, of B.
*     2) Same as 1), but the singular values are stored in S2 and the
*         singular vectors are not computed.
*
*  For each pair of matrix dimensions (M,N) and each selected matrix
*  type, an M by N matrix A and an M by NRHS matrix X are generated.
*  The problem dimensions are as follows
*     A:          M x N
*     Q:          M x min(M,N) (but M x M if NRHS > 0)
*     P:          min(M,N) x N
*     B:          min(M,N) x min(M,N)
*     U, V:       min(M,N) x min(M,N)
*     S1, S2      diagonal, order min(M,N)
*     X:          M x NRHS
*
*  For each generated matrix, 14 tests are performed:
*
*  Test DGEBRD and DORGBR
*
*  (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
*
*  (2)   | I - Q' Q | / ( M ulp )
*
*  (3)   | I - PT PT' | / ( N ulp )
*
*  Test DBDSQR on bidiagonal matrix B
*
*  (4)   | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
*
*  (5)   | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X
*                                                   and   Z = U' Y.
*  (6)   | I - U' U | / ( min(M,N) ulp )
*
*  (7)   | I - VT VT' | / ( min(M,N) ulp )
*
*  (8)   S1 contains min(M,N) nonnegative values in decreasing order.
*        (Return 0 if true, 1/ULP if false.)
*
*  (9)   | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
*                                    computing U and V.
*
*  (10)  0 if the true singular values of B are within THRESH of
*        those in S1.  2*THRESH if they are not.  (Tested using
*        DSVDCH)
*
*  Test DBDSQR on matrix A
*
*  (11)  | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp )
*
*  (12)  | X - (QU) Z | / ( |X| max(M,k) ulp )
*
*  (13)  | I - (QU)'(QU) | / ( M ulp )
*
*  (14)  | I - (VT PT) (PT'VT') | / ( N ulp )
*
*  Test DBDSDC on bidiagonal matrix B
*
*  (15)  | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
*
*  (16)  | I - U' U | / ( min(M,N) ulp )
*
*  (17)  | I - VT VT' | / ( min(M,N) ulp )
*
*  (18)  S1 contains min(M,N) nonnegative values in decreasing order.
*        (Return 0 if true, 1/ULP if false.)
*
*  (19)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
*                                    computing U and V.
*  The possible matrix types are
*
*  (1)  The zero matrix.
*  (2)  The identity matrix.
*
*  (3)  A diagonal matrix with evenly spaced entries
*       1, ..., ULP  and random signs.
*       (ULP = (first number larger than 1) - 1 )
*  (4)  A diagonal matrix with geometrically spaced entries
*       1, ..., ULP  and random signs.
*  (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
*       and random signs.
*
*  (6)  Same as (3), but multiplied by SQRT( overflow threshold )
*  (7)  Same as (3), but multiplied by SQRT( underflow threshold )
*
*  (8)  A matrix of the form  U D V, where U and V are orthogonal and
*       D has evenly spaced entries 1, ..., ULP with random signs
*       on the diagonal.
*
*  (9)  A matrix of the form  U D V, where U and V are orthogonal and
*       D has geometrically spaced entries 1, ..., ULP with random
*       signs on the diagonal.
*
*  (10) A matrix of the form  U D V, where U and V are orthogonal and
*       D has "clustered" entries 1, ULP,..., ULP with random
*       signs on the diagonal.
*
*  (11) Same as (8), but multiplied by SQRT( overflow threshold )
*  (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
*  (13) Rectangular matrix with random entries chosen from (-1,1).
*  (14) Same as (13), but multiplied by SQRT( overflow threshold )
*  (15) Same as (13), but multiplied by SQRT( underflow threshold )
*
*  Special case:
*  (16) A bidiagonal matrix with random entries chosen from a
*       logarithmic distribution on [ulp^2,ulp^(-2)]  (I.e., each
*       entry is  e^x, where x is chosen uniformly on
*       [ 2 log(ulp), -2 log(ulp) ] .)  For *this* type:
*       (a) DGEBRD is not called to reduce it to bidiagonal form.
*       (b) the bidiagonal is  min(M,N) x min(M,N); if M<N, the
*           matrix will be lower bidiagonal, otherwise upper.
*       (c) only tests 5--8 and 14 are performed.
*
*  A subset of the full set of matrix types may be selected through
*  the logical array DOTYPE.
*
*  Arguments
*  ==========
*
*  NSIZES  (input) INTEGER
*          The number of values of M and N contained in the vectors
*          MVAL and NVAL.  The matrix sizes are used in pairs (M,N).
*
*  MVAL    (input) INTEGER array, dimension (NM)
*          The values of the matrix row dimension M.
*
*  NVAL    (input) INTEGER array, dimension (NM)
*          The values of the matrix column dimension N.
*
*  NTYPES  (input) INTEGER
*          The number of elements in DOTYPE.   If it is zero, DCHKBD
*          does nothing.  It must be at least zero.  If it is MAXTYP+1
*          and NSIZES is 1, then an additional type, MAXTYP+1 is
*          defined, which is to use whatever matrices are in A and B.
*          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
*          DOTYPE(MAXTYP+1) is .TRUE. .
*
*  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
*          If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
*          of type j will be generated.  If NTYPES is smaller than the
*          maximum number of types defined (PARAMETER MAXTYP), then
*          types NTYPES+1 through MAXTYP will not be generated.  If
*          NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
*          DOTYPE(NTYPES) will be ignored.
*
*  NRHS    (input) INTEGER
*          The number of columns in the "right-hand side" matrices X, Y,
*          and Z, used in testing DBDSQR.  If NRHS = 0, then the
*          operations on the right-hand side will not be tested.
*          NRHS must be at least 0.
*
*  ISEED   (input/output) INTEGER array, dimension (4)
*          On entry ISEED specifies the seed of the random number
*          generator. The array elements should be between 0 and 4095;
*          if not they will be reduced mod 4096.  Also, ISEED(4) must
*          be odd.  The values of ISEED are changed on exit, and can be
*          used in the next call to DCHKBD to continue the same random
*          number sequence.
*
*  THRESH  (input) DOUBLE PRECISION
*          The threshold value for the test ratios.  A result is
*          included in the output file if RESULT >= THRESH.  To have
*          every test ratio printed, use THRESH = 0.  Note that the
*          expected value of the test ratios is O(1), so THRESH should
*          be a reasonably small multiple of 1, e.g., 10 or 100.
*
*  A       (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX)
*          where NMAX is the maximum value of N in NVAL.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,MMAX),
*          where MMAX is the maximum value of M in MVAL.
*
*  BD      (workspace) DOUBLE PRECISION array, dimension
*                      (max(min(MVAL(j),NVAL(j))))
*
*  BE      (workspace) DOUBLE PRECISION array, dimension
*                      (max(min(MVAL(j),NVAL(j))))
*
*  S1      (workspace) DOUBLE PRECISION array, dimension
*                      (max(min(MVAL(j),NVAL(j))))
*
*  S2      (workspace) DOUBLE PRECISION array, dimension
*                      (max(min(MVAL(j),NVAL(j))))
*
*  X       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
*
*  LDX     (input) INTEGER
*          The leading dimension of the arrays X, Y, and Z.
*          LDX >= max(1,MMAX)
*
*  Y       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
*
*  Z       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
*
*  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX)
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.  LDQ >= max(1,MMAX).
*
*  PT      (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX)
*
*  LDPT    (input) INTEGER
*          The leading dimension of the arrays PT, U, and V.
*          LDPT >= max(1, max(min(MVAL(j),NVAL(j)))).
*
*  U       (workspace) DOUBLE PRECISION array, dimension
*                      (LDPT,max(min(MVAL(j),NVAL(j))))
*
*  V       (workspace) DOUBLE PRECISION array, dimension
*                      (LDPT,max(min(MVAL(j),NVAL(j))))
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The number of entries in WORK.  This must be at least
*          3(M+N) and  M(M + max(M,N,k) + 1) + N*min(M,N)  for all
*          pairs  (M,N)=(MM(j),NN(j))
*
*  IWORK   (workspace) INTEGER array, dimension at least 8*min(M,N)
*
*  NOUT    (input) INTEGER
*          The FORTRAN unit number for printing out error messages
*          (e.g., if a routine returns IINFO not equal to 0.)
*
*  INFO    (output) INTEGER
*          If 0, then everything ran OK.
*           -1: NSIZES < 0
*           -2: Some MM(j) < 0
*           -3: Some NN(j) < 0
*           -4: NTYPES < 0
*           -6: NRHS  < 0
*           -8: THRESH < 0
*          -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
*          -17: LDB < 1 or LDB < MMAX.
*          -21: LDQ < 1 or LDQ < MMAX.
*          -23: LDPT< 1 or LDPT< MNMAX.
*          -27: LWORK too small.
*          If  DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR,
*              returns an error code, the
*              absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
*     Some Local Variables and Parameters:
*     ---- ----- --------- --- ----------
*
*     ZERO, ONE       Real 0 and 1.
*     MAXTYP          The number of types defined.
*     NTEST           The number of tests performed, or which can
*                     be performed so far, for the current matrix.
*     MMAX            Largest value in NN.
*     NMAX            Largest value in NN.
*     MNMIN           min(MM(j), NN(j)) (the dimension of the bidiagonal
*                     matrix.)
*     MNMAX           The maximum value of MNMIN for j=1,...,NSIZES.
*     NFAIL           The number of tests which have exceeded THRESH
*     COND, IMODE     Values to be passed to the matrix generators.
*     ANORM           Norm of A; passed to matrix generators.
*
*     OVFL, UNFL      Overflow and underflow thresholds.
*     RTOVFL, RTUNFL  Square roots of the previous 2 values.
*     ULP, ULPINV     Finest relative precision and its inverse.
*
*             The following four arrays decode JTYPE:
*     KTYPE(j)        The general type (1-10) for type "j".
*     KMODE(j)        The MODE value to be passed to the matrix
*                     generator for type "j".
*     KMAGN(j)        The order of magnitude ( O(1),
*                     O(overflow^(1/2) ), O(underflow^(1/2) )
*
* ======================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, HALF
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                   HALF = 0.5D0 )
      INTEGER            MAXTYP
      PARAMETER          ( MAXTYP = 16 )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADMM, BADNN, BIDIAG
      CHARACTER          UPLO
      CHARACTER*3        PATH
      INTEGER            I, IINFO, IMODE, ITYPE, J, JCOL, JSIZE, JTYPE,
     $                   LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, MQ,
     $                   MTYPES, N, NFAIL, NMAX, NTEST
      DOUBLE PRECISION   AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
     $                   TEMP1, TEMP2, ULP, ULPINV, UNFL
*     ..
*     .. Local Arrays ..
      INTEGER            IDUM( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
     $                   KMODE( MAXTYP ), KTYPE( MAXTYP )
      DOUBLE PRECISION   DUM( 1 ), DUMMA( 1 ), RESULT( 19 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLARND
      EXTERNAL           DLAMCH, DLARND
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALASUM, DBDSDC, DBDSQR, DBDT01, DBDT02, DBDT03,
     $                   DCOPY, DGEBRD, DGEMM, DLABAD, DLACPY, DLAHD2,
     $                   DLASET, DLATMR, DLATMS, DORGBR, DORT01, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, EXP, INT, LOG, MAX, MIN, SQRT
*     ..
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*6        SRNAMT
      INTEGER            INFOT, NUNIT
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, NUNIT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Data statements ..
      DATA               KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 /
      DATA               KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
      DATA               KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
     $                   0, 0, 0 /
*     ..
*     .. Executable Statements ..
*
*     Check for errors
*
      INFO = 0
*
      BADMM = .FALSE.
      BADNN = .FALSE.
      MMAX = 1
      NMAX = 1
      MNMAX = 1
      MINWRK = 1
      DO 10 J = 1, NSIZES
         MMAX = MAX( MMAX, MVAL( J ) )
         IF( MVAL( J ).LT.0 )
     $      BADMM = .TRUE.
         NMAX = MAX( NMAX, NVAL( J ) )
         IF( NVAL( J ).LT.0 )
     $      BADNN = .TRUE.
         MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
         MINWRK = MAX( MINWRK, 3*( MVAL( J )+NVAL( J ) ),
     $            MVAL( J )*( MVAL( J )+MAX( MVAL( J ), NVAL( J ),
     $            NRHS )+1 )+NVAL( J )*MIN( NVAL( J ), MVAL( J ) ) )
   10 CONTINUE
*
*     Check for errors
*
      IF( NSIZES.LT.0 ) THEN
         INFO = -1
      ELSE IF( BADMM ) THEN
         INFO = -2
      ELSE IF( BADNN ) THEN
         INFO = -3
      ELSE IF( NTYPES.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MMAX ) THEN
         INFO = -11
      ELSE IF( LDX.LT.MMAX ) THEN
         INFO = -17
      ELSE IF( LDQ.LT.MMAX ) THEN
         INFO = -21
      ELSE IF( LDPT.LT.MNMAX ) THEN
         INFO = -23
      ELSE IF( MINWRK.GT.LWORK ) THEN
         INFO = -27
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DCHKBD', -INFO )
         RETURN
      END IF
*
*     Initialize constants
*
      PATH( 1: 1 ) = 'Double precision'
      PATH( 2: 3 ) = 'BD'
      NFAIL = 0
      NTEST = 0
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = DLAMCH( 'Overflow' )
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      ULPINV = ONE / ULP
      LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
      RTUNFL = SQRT( UNFL )
      RTOVFL = SQRT( OVFL )
      INFOT = 0
*
*     Loop over sizes, types
*
      DO 200 JSIZE = 1, NSIZES
         M = MVAL( JSIZE )
         N = NVAL( JSIZE )
         MNMIN = MIN( M, N )
         AMNINV = ONE / MAX( M, N, 1 )
*
         IF( NSIZES.NE.1 ) THEN
            MTYPES = MIN( MAXTYP, NTYPES )
         ELSE
            MTYPES = MIN( MAXTYP+1, NTYPES )
         END IF
*
         DO 190 JTYPE = 1, MTYPES
            IF( .NOT.DOTYPE( JTYPE ) )
     $         GO TO 190
*
            DO 20 J = 1, 4
               IOLDSD( J ) = ISEED( J )
   20       CONTINUE
*
            DO 30 J = 1, 14
               RESULT( J ) = -ONE
   30       CONTINUE
*
            UPLO = ' '
*
*           Compute "A"
*
*           Control parameters:
*
*           KMAGN  KMODE        KTYPE
*       =1  O(1)   clustered 1  zero
*       =2  large  clustered 2  identity
*       =3  small  exponential  (none)
*       =4         arithmetic   diagonal, (w/ eigenvalues)
*       =5         random       symmetric, w/ eigenvalues
*       =6                      nonsymmetric, w/ singular values
*       =7                      random diagonal
*       =8                      random symmetric
*       =9                      random nonsymmetric
*       =10                     random bidiagonal (log. distrib.)
*
            IF( MTYPES.GT.MAXTYP )
     $         GO TO 100
*
            ITYPE = KTYPE( JTYPE )
            IMODE = KMODE( JTYPE )
*
*           Compute norm
*
            GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
   40       CONTINUE
            ANORM = ONE
            GO TO 70
*
   50       CONTINUE
            ANORM = ( RTOVFL*ULP )*AMNINV
            GO TO 70
*
   60       CONTINUE
            ANORM = RTUNFL*MAX( M, N )*ULPINV
            GO TO 70
*
   70       CONTINUE
*
            CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
            IINFO = 0
            COND = ULPINV
*
            BIDIAG = .FALSE.
            IF( ITYPE.EQ.1 ) THEN
*
*              Zero matrix
*
               IINFO = 0
*
            ELSE IF( ITYPE.EQ.2 ) THEN
*
*              Identity
*
               DO 80 JCOL = 1, MNMIN
                  A( JCOL, JCOL ) = ANORM
   80          CONTINUE
*
            ELSE IF( ITYPE.EQ.4 ) THEN
*
*              Diagonal Matrix, [Eigen]values Specified
*
               CALL DLATMS( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, IMODE,
     $                      COND, ANORM, 0, 0, 'N', A, LDA,
     $                      WORK( MNMIN+1 ), IINFO )
*
            ELSE IF( ITYPE.EQ.5 ) THEN
*
*              Symmetric, eigenvalues specified
*
               CALL DLATMS( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, IMODE,
     $                      COND, ANORM, M, N, 'N', A, LDA,
     $                      WORK( MNMIN+1 ), IINFO )
*
            ELSE IF( ITYPE.EQ.6 ) THEN
*
*              Nonsymmetric, singular values specified
*
               CALL DLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
     $                      ANORM, M, N, 'N', A, LDA, WORK( MNMIN+1 ),
     $                      IINFO )
*
            ELSE IF( ITYPE.EQ.7 ) THEN
*
*              Diagonal, random entries
*
               CALL DLATMR( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, 6, ONE,
     $                      ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
     $                      WORK( 2*MNMIN+1 ), 1, ONE, 'N', IWORK, 0, 0,
     $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
            ELSE IF( ITYPE.EQ.8 ) THEN
*
*              Symmetric, random entries
*
               CALL DLATMR( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, 6, ONE,
     $                      ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
     $                      WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
     $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
            ELSE IF( ITYPE.EQ.9 ) THEN
*
*              Nonsymmetric, random entries
*
               CALL DLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
     $                      'T', 'N', WORK( MNMIN+1 ), 1, ONE,
     $                      WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
     $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
            ELSE IF( ITYPE.EQ.10 ) THEN
*
*              Bidiagonal, random entries
*
               TEMP1 = -TWO*LOG( ULP )
               DO 90 J = 1, MNMIN
                  BD( J ) = EXP( TEMP1*DLARND( 2, ISEED ) )
                  IF( J.LT.MNMIN )
     $               BE( J ) = EXP( TEMP1*DLARND( 2, ISEED ) )
   90          CONTINUE
*
               IINFO = 0
               BIDIAG = .TRUE.
               IF( M.GE.N ) THEN
                  UPLO = 'U'
               ELSE
                  UPLO = 'L'
               END IF
            ELSE
               IINFO = 1
            END IF
*
            IF( IINFO.EQ.0 ) THEN
*
*              Generate Right-Hand Side
*
               IF( BIDIAG ) THEN
                  CALL DLATMR( MNMIN, NRHS, 'S', ISEED, 'N', WORK, 6,
     $                         ONE, ONE, 'T', 'N', WORK( MNMIN+1 ), 1,
     $                         ONE, WORK( 2*MNMIN+1 ), 1, ONE, 'N',
     $                         IWORK, MNMIN, NRHS, ZERO, ONE, 'NO', Y,
     $                         LDX, IWORK, IINFO )
               ELSE
                  CALL DLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE,
     $                         ONE, 'T', 'N', WORK( M+1 ), 1, ONE,
     $                         WORK( 2*M+1 ), 1, ONE, 'N', IWORK, M,
     $                         NRHS, ZERO, ONE, 'NO', X, LDX, IWORK,
     $                         IINFO )
               END IF
            END IF
*
*           Error Exit
*
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUT, FMT = 9998 )'Generator', IINFO, M, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               RETURN
            END IF
*
  100       CONTINUE
*
*           Call DGEBRD and DORGBR to compute B, Q, and P, do tests.
*
            IF( .NOT.BIDIAG ) THEN
*
*              Compute transformations to reduce A to bidiagonal form:
*              B := Q' * A * P.
*
               CALL DLACPY( ' ', M, N, A, LDA, Q, LDQ )
               CALL DGEBRD( M, N, Q, LDQ, BD, BE, WORK, WORK( MNMIN+1 ),
     $                      WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
*              Check error code from DGEBRD.
*
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUT, FMT = 9998 )'DGEBRD', IINFO, M, N,
     $               JTYPE, IOLDSD
                  INFO = ABS( IINFO )
                  RETURN
               END IF
*
               CALL DLACPY( ' ', M, N, Q, LDQ, PT, LDPT )
               IF( M.GE.N ) THEN
                  UPLO = 'U'
               ELSE
                  UPLO = 'L'
               END IF
*
*              Generate Q
*
               MQ = M
               IF( NRHS.LE.0 )
     $            MQ = MNMIN
               CALL DORGBR( 'Q', M, MQ, N, Q, LDQ, WORK,
     $                      WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
*              Check error code from DORGBR.
*
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUT, FMT = 9998 )'DORGBR(Q)', IINFO, M, N,
     $               JTYPE, IOLDSD
                  INFO = ABS( IINFO )
                  RETURN
               END IF
*
*              Generate P'
*
               CALL DORGBR( 'P', MNMIN, N, M, PT, LDPT, WORK( MNMIN+1 ),
     $                      WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
*              Check error code from DORGBR.
*
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUT, FMT = 9998 )'DORGBR(P)', IINFO, M, N,
     $               JTYPE, IOLDSD
                  INFO = ABS( IINFO )
                  RETURN
               END IF
*
*              Apply Q' to an M by NRHS matrix X:  Y := Q' * X.
*
               CALL DGEMM( 'Transpose', 'No transpose', M, NRHS, M, ONE,
     $                     Q, LDQ, X, LDX, ZERO, Y, LDX )
*
*              Test 1:  Check the decomposition A := Q * B * PT
*                   2:  Check the orthogonality of Q
*                   3:  Check the orthogonality of PT
*
               CALL DBDT01( M, N, 1, A, LDA, Q, LDQ, BD, BE, PT, LDPT,
     $                      WORK, RESULT( 1 ) )
               CALL DORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
     $                      RESULT( 2 ) )
               CALL DORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
     $                      RESULT( 3 ) )
            END IF
*
*           Use DBDSQR to form the SVD of the bidiagonal matrix B:
*           B := U * S1 * VT, and compute Z = U' * Y.
*
            CALL DCOPY( MNMIN, BD, 1, S1, 1 )
            IF( MNMIN.GT.0 )
     $         CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
            CALL DLACPY( ' ', M, NRHS, Y, LDX, Z, LDX )
            CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
            CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
*
            CALL DBDSQR( UPLO, MNMIN, MNMIN, MNMIN, NRHS, S1, WORK, VT,
     $                   LDPT, U, LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
*
*           Check error code from DBDSQR.
*
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUT, FMT = 9998 )'DBDSQR(vects)', IINFO, M, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 ) THEN
                  RETURN
               ELSE
                  RESULT( 4 ) = ULPINV
                  GO TO 170
               END IF
            END IF
*
*           Use DBDSQR to compute only the singular values of the
*           bidiagonal matrix B;  U, VT, and Z should not be modified.
*
            CALL DCOPY( MNMIN, BD, 1, S2, 1 )
            IF( MNMIN.GT.0 )
     $         CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
            CALL DBDSQR( UPLO, MNMIN, 0, 0, 0, S2, WORK, VT, LDPT, U,
     $                   LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
*
*           Check error code from DBDSQR.
*
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUT, FMT = 9998 )'DBDSQR(values)', IINFO, M, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 ) THEN
                  RETURN
               ELSE
                  RESULT( 9 ) = ULPINV
                  GO TO 170
               END IF
            END IF
*
*           Test 4:  Check the decomposition B := U * S1 * VT
*                5:  Check the computation Z := U' * Y
*                6:  Check the orthogonality of U
*                7:  Check the orthogonality of VT
*
            CALL DBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
     $                   WORK, RESULT( 4 ) )
            CALL DBDT02( MNMIN, NRHS, Y, LDX, Z, LDX, U, LDPT, WORK,
     $                   RESULT( 5 ) )
            CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
     $                   RESULT( 6 ) )
            CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
     $                   RESULT( 7 ) )
*
*           Test 8:  Check that the singular values are sorted in
*                    non-increasing order and are non-negative
*
            RESULT( 8 ) = ZERO
            DO 110 I = 1, MNMIN - 1
               IF( S1( I ).LT.S1( I+1 ) )
     $            RESULT( 8 ) = ULPINV
               IF( S1( I ).LT.ZERO )
     $            RESULT( 8 ) = ULPINV
  110       CONTINUE
            IF( MNMIN.GE.1 ) THEN
               IF( S1( MNMIN ).LT.ZERO )
     $            RESULT( 8 ) = ULPINV
            END IF
*
*           Test 9:  Compare DBDSQR with and without singular vectors
*
            TEMP2 = ZERO
*
            DO 120 J = 1, MNMIN
               TEMP1 = ABS( S1( J )-S2( J ) ) /
     $                 MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
     $                 ULP*MAX( ABS( S1( J ) ), ABS( S2( J ) ) ) )
               TEMP2 = MAX( TEMP1, TEMP2 )
  120       CONTINUE
*
            RESULT( 9 ) = TEMP2
*
*           Test 10:  Sturm sequence test of singular values
*                     Go up by factors of two until it succeeds
*
            TEMP1 = THRESH*( HALF-ULP )
*
            DO 130 J = 0, LOG2UI
*               CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO )
               IF( IINFO.EQ.0 )
     $            GO TO 140
               TEMP1 = TEMP1*TWO
  130       CONTINUE
*
  140       CONTINUE
            RESULT( 10 ) = TEMP1
*
*           Use DBDSQR to form the decomposition A := (QU) S (VT PT)
*           from the bidiagonal form A := Q B PT.
*
            IF( .NOT.BIDIAG ) THEN
               CALL DCOPY( MNMIN, BD, 1, S2, 1 )
               IF( MNMIN.GT.0 )
     $            CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
               CALL DBDSQR( UPLO, MNMIN, N, M, NRHS, S2, WORK, PT, LDPT,
     $                      Q, LDQ, Y, LDX, WORK( MNMIN+1 ), IINFO )
*
*              Test 11:  Check the decomposition A := Q*U * S2 * VT*PT
*                   12:  Check the computation Z := U' * Q' * X
*                   13:  Check the orthogonality of Q*U
*                   14:  Check the orthogonality of VT*PT
*
               CALL DBDT01( M, N, 0, A, LDA, Q, LDQ, S2, DUMMA, PT,
     $                      LDPT, WORK, RESULT( 11 ) )
               CALL DBDT02( M, NRHS, X, LDX, Y, LDX, Q, LDQ, WORK,
     $                      RESULT( 12 ) )
               CALL DORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
     $                      RESULT( 13 ) )
               CALL DORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
     $                      RESULT( 14 ) )
            END IF
*
*           Use DBDSDC to form the SVD of the bidiagonal matrix B:
*           B := U * S1 * VT
*
            CALL DCOPY( MNMIN, BD, 1, S1, 1 )
            IF( MNMIN.GT.0 )
     $         CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
            CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
            CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
*
            CALL DBDSDC( UPLO, 'I', MNMIN, S1, WORK, U, LDPT, VT, LDPT,
     $                   DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
*
*           Check error code from DBDSDC.
*
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUT, FMT = 9998 )'DBDSDC(vects)', IINFO, M, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 ) THEN
                  RETURN
               ELSE
                  RESULT( 15 ) = ULPINV
                  GO TO 170
               END IF
            END IF
*
*           Use DBDSDC to compute only the singular values of the
*           bidiagonal matrix B;  U and VT should not be modified.
*
            CALL DCOPY( MNMIN, BD, 1, S2, 1 )
            IF( MNMIN.GT.0 )
     $         CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
            CALL DBDSDC( UPLO, 'N', MNMIN, S2, WORK, DUM, 1, DUM, 1,
     $                   DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
*
*           Check error code from DBDSDC.
*
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUT, FMT = 9998 )'DBDSDC(values)', IINFO, M, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 ) THEN
                  RETURN
               ELSE
                  RESULT( 18 ) = ULPINV
                  GO TO 170
               END IF
            END IF
*
*           Test 15:  Check the decomposition B := U * S1 * VT
*                16:  Check the orthogonality of U
*                17:  Check the orthogonality of VT
*
            CALL DBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
     $                   WORK, RESULT( 15 ) )
            CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
     $                   RESULT( 16 ) )
            CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
     $                   RESULT( 17 ) )
*
*           Test 18:  Check that the singular values are sorted in
*                     non-increasing order and are non-negative
*
            RESULT( 18 ) = ZERO
            DO 150 I = 1, MNMIN - 1
               IF( S1( I ).LT.S1( I+1 ) )
     $            RESULT( 18 ) = ULPINV
               IF( S1( I ).LT.ZERO )
     $            RESULT( 18 ) = ULPINV
  150       CONTINUE
            IF( MNMIN.GE.1 ) THEN
               IF( S1( MNMIN ).LT.ZERO )
     $            RESULT( 18 ) = ULPINV
            END IF
*
*           Test 19:  Compare DBDSQR with and without singular vectors
*
            TEMP2 = ZERO
*
            DO 160 J = 1, MNMIN
               TEMP1 = ABS( S1( J )-S2( J ) ) /
     $                 MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
     $                 ULP*MAX( ABS( S1( 1 ) ), ABS( S2( 1 ) ) ) )
               TEMP2 = MAX( TEMP1, TEMP2 )
  160       CONTINUE
*
            RESULT( 19 ) = TEMP2
*
*           End of Loop -- Check for RESULT(j) > THRESH
*
  170       CONTINUE
            DO 180 J = 1, 19
               IF( RESULT( J ).GE.THRESH ) THEN
                  IF( NFAIL.EQ.0 )
     $               CALL DLAHD2( NOUT, PATH )
                  WRITE( NOUT, FMT = 9999 )M, N, JTYPE, IOLDSD, J,
     $               RESULT( J )
                  NFAIL = NFAIL + 1
               END IF
  180       CONTINUE
            IF( .NOT.BIDIAG ) THEN
               NTEST = NTEST + 19
            ELSE
               NTEST = NTEST + 5
            END IF
*
  190    CONTINUE
  200 CONTINUE
*
*     Summary
*
      CALL ALASUM( PATH, NOUT, NFAIL, NTEST, 0 )
*
      RETURN
*
*     End of DCHKBD
*
 9999 FORMAT( ' M=', I5, ', N=', I5, ', type ', I2, ', seed=',
     $      4( I4, ',' ), ' test(', I2, ')=', G11.4 )
 9998 FORMAT( ' DCHKBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
     $      I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
     $      I5, ')' )
*
      END


module constants
   implicit none

   public:: me, c, eps0, el

   real,parameter:: c = 2.99792458e8
   real,parameter:: me = 9.10938356e-31
   real,parameter:: eps0 = 8.85418782e-12
   real,parameter:: el = 1.60217662e-19
   real,parameter:: pi = acos(-1.0)
end module constants


      real function gcum(x)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c Evaluate the standard normal cdf given a normal deviate x.  gcum is
c the area under a unit normal curve to the left of x.  The results are
c accurate only to about 5 decimal places.
c
c
c-----------------------------------------------------------------------
      z = x
      if(z.lt.0.) z = -z
      t    = 1./(1.+ 0.2316419*z)
      gcum = t*(0.31938153   + t*(-0.356563782 + t*(1.781477937 +
     +       t*(-1.821255978 + t*1.330274429))))
      e2   = 0.
c
c  6 standard deviations out gets treated as infinity:
c
      if(z.le.6.) e2 = exp(-z*z/2.)*0.3989422803
      gcum = 1.0- e2 * gcum
      if(x.ge.0.) return
      gcum = 1.0 - gcum
      return
      end


      SUBROUTINE MB02WD( FORM, F, N, IPAR, LIPAR, DPAR, LDPAR, ITMAX,
     $                   A, LDA, B, INCB, X, INCX, TOL, DWORK, LDWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve the system of linear equations Ax = b, with A symmetric,
C     positive definite, or, in the implicit form, f(A, x) = b, where
C     y = f(A, x) is a symmetric positive definite linear mapping
C     from x to y, using the conjugate gradient (CG) algorithm without
C     preconditioning.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FORM     CHARACTER*1
C              Specifies the form of the system of equations, as
C              follows:
C              = 'U' :  Ax = b, the upper triagular part of A is used;
C              = 'L' :  Ax = b, the lower triagular part of A is used;
C              = 'F' :  the implicit, function form, f(A, x) = b.
C
C     Function Parameters
C
C     F       EXTERNAL
C             If FORM = 'F', then F is a subroutine which calculates the
C             value of f(A, x), for given A and x.
C             If FORM <> 'F', then F is not called.
C
C             F must have the following interface:
C
C             SUBROUTINE F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, X,
C            $              INCX, DWORK, LDWORK, INFO )
C
C             where
C
C             N       (input) INTEGER
C                     The dimension of the vector x.  N >= 0.
C
C             IPAR    (input) INTEGER array, dimension (LIPAR)
C                     The integer parameters describing the structure of
C                     the matrix A.
C
C             LIPAR   (input) INTEGER
C                     The length of the array IPAR.  LIPAR >= 0.
C
C             DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C                     The real parameters needed for solving the
C                     problem.
C
C             LDPAR   (input) INTEGER
C                     The length of the array DPAR.  LDPAR >= 0.
C
C             A       (input) DOUBLE PRECISION array, dimension
C                     (LDA, NC), where NC is the number of columns.
C                     The leading NR-by-NC part of this array must
C                     contain the (compressed) representation of the
C                     matrix A, where NR is the number of rows of A
C                     (function of IPAR entries).
C
C             LDA     (input) INTEGER
C                     The leading dimension of the array A.
C                     LDA >= MAX(1,NR).
C
C             X       (input/output) DOUBLE PRECISION array, dimension
C                     (1+(N-1)*INCX)
C                     On entry, this incremented array must contain the
C                     vector x.
C                     On exit, this incremented array contains the value
C                     of the function f, y = f(A, x).
C
C             INCX    (input) INTEGER
C                     The increment for the elements of X.  INCX > 0.
C
C             DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C                     The workspace array for subroutine F.
C
C             LDWORK  (input) INTEGER
C                     The size of the array DWORK (as large as needed
C                     in the subroutine F).
C
C             INFO    INTEGER
C                     Error indicator, set to a negative value if an
C                     input scalar argument is erroneous, and to
C                     positive values for other possible errors in the
C                     subroutine F. The LAPACK Library routine XERBLA
C                     should be used in conjunction with negative INFO.
C                     INFO must be zero if the subroutine finished
C                     successfully.
C
C             Parameters marked with "(input)" must not be changed.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the vector x.  N >= 0.
C             If FORM = 'U' or FORM = 'L', N is also the number of rows
C             and columns of the matrix A.
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             If FORM = 'F', the integer parameters describing the
C             structure of the matrix A.
C             This parameter is ignored if FORM = 'U' or FORM = 'L'.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 0.
C
C     DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C             If FORM = 'F', the real parameters needed for solving
C             the problem.
C             This parameter is ignored if FORM = 'U' or FORM = 'L'.
C
C     LDPAR   (input) INTEGER
C             The length of the array DPAR.  LDPAR >= 0.
C
C     ITMAX   (input) INTEGER
C             The maximal number of iterations to do.  ITMAX >= 0.
C
C     A       (input) DOUBLE PRECISION array,
C                     dimension (LDA, NC), if FORM = 'F',
C                     dimension (LDA, N),  otherwise.
C             If FORM = 'F', the leading NR-by-NC part of this array
C             must contain the (compressed) representation of the
C             matrix A, where NR and NC are the number of rows and
C             columns, respectively, of the matrix A. The array A is
C             not referenced by this routine itself, except in the
C             calls to the routine F.
C             If FORM <> 'F', the leading N-by-N part of this array
C             must contain the matrix A, assumed to be symmetric;
C             only the triangular part specified by FORM is referenced.
C
C     LDA     (input) INTEGER
C             The leading dimension of array A.
C             LDA >= MAX(1,NR), if FORM = 'F';
C             LDA >= MAX(1,N),  if FORM = 'U' or FORM = 'L'.
C
C     B       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCB)
C             The incremented vector b.
C
C     INCB    (input) INTEGER
C             The increment for the elements of B.  INCB > 0.
C
C     X       (input/output) DOUBLE PRECISION array, dimension
C             (1+(N-1)*INCX)
C             On entry, this incremented array must contain an initial
C             approximation of the solution. If an approximation is not
C             known, setting all elements of x to zero is recommended.
C             On exit, this incremented array contains the computed
C             solution x of the system of linear equations.
C
C     INCX    (input) INTEGER
C             The increment for the elements of X.  INCX > 0.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If TOL > 0, absolute tolerance for the iterative process.
C             The algorithm will stop if || Ax - b ||_2 <= TOL. Since
C             it is advisable to use a relative tolerance, say TOLER,
C             TOL should be chosen as TOLER*|| b ||_2.
C             If TOL <= 0, a default relative tolerance,
C             TOLDEF = N*EPS*|| b ||_2,  is used, where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the number of
C             iterations performed and DWORK(2) returns the remaining
C             residual, || Ax - b ||_2.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(2,3*N + DWORK(F)),  if FORM = 'F',
C                       where DWORK(F) is the workspace needed by F;
C             LDWORK >= MAX(2,3*N),       if FORM = 'U' or FORM = 'L'.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  the algorithm finished after ITMAX > 0 iterations,
C                   without achieving the desired precision TOL;
C             = 2:  ITMAX is zero; in this case, DWORK(2) is not set.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, then F returned with INFO = i.
C
C     METHOD
C
C     The following CG iteration is used for solving Ax = b:
C
C     Start: q(0) = r(0) = Ax - b
C
C                   < q(k),  r(k) >
C     ALPHA(k) = - ----------------
C                   < q(k), Aq(k) >
C     x(k+1)   = x(k) - ALPHA(k) * q(k)
C     r(k+1)   = r(k) - ALPHA(k) * Aq(k)
C                 < r(k+1), r(k+1) >
C     BETA(k)  = --------------------
C                 < r(k)  , r(k)   >
C     q(k+1)   = r(k+1) + BETA(k) * q(k)
C
C     where <.,.> denotes the scalar product.
C
C     REFERENCES
C
C     [1] Golub, G.H. and van Loan, C.F.
C         Matrix Computations. Third Edition.
C         M. D. Johns Hopkins University Press, Baltimore, pp. 520-528,
C         1996.
C
C     [2] Luenberger, G.
C         Introduction to Linear and Nonlinear Programming.
C         Addison-Wesley, Reading, MA, p.187, York, 1973.
C
C     NUMERICAL ASPECTS
C
C     Since the residuals are orthogonal in the scalar product
C     <x, y> = y'Ax, the algorithm is theoretically finite. But rounding
C     errors cause a loss of orthogonality, so a finite termination
C     cannot be guaranteed. However, one can prove [2] that
C
C        || x-x_k ||_A := sqrt( (x-x_k)' * A * (x-x_k) )
C
C                                             sqrt( kappa_2(A) ) - 1
C                      <=  2 || x-x_0 ||_A * ------------------------ ,
C                                             sqrt( kappa_2(A) ) + 1
C
C     where kappa_2 is the condition number.
C
C     The approximate number of floating point operations is
C        (k*(N**2 + 15*N) + N**2 + 3*N)/2, if FORM <> 'F',
C        k*(f + 7*N) + f,                  if FORM =  'F',
C     where k is the number of CG iterations performed, and f is the
C     number of floating point operations required by the subroutine F.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Oct. 2000, during a stay at University of Twente, NL.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001,
C     March, 2002.
C
C     KEYWORDS
C
C     Conjugate gradients, convergence, linear system of equations,
C     matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FORM
      INTEGER           INCB, INCX, INFO, ITMAX, IWARN, LDA, LDPAR,
     $                  LDWORK, LIPAR, N
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(*), DPAR(*), DWORK(*), X(*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      DOUBLE PRECISION  ALPHA, BETA, RES, RESOLD, TOLDEF
      INTEGER           AQ, DWLEFT, K, R
      LOGICAL           MAT
C     .. External Functions ..
      DOUBLE PRECISION  DDOT, DLAMCH, DNRM2
      LOGICAL           LSAME
      EXTERNAL          DDOT, DLAMCH, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DSCAL, DSYMV, F, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     ..
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MAT = LSAME( FORM, 'U' ) .OR. LSAME( FORM, 'L' )
C
C     Check the scalar input parameters.
C
      IWARN = 0
      INFO  = 0
      IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN
         INFO = -1
      ELSEIF ( N.LT.0 ) THEN
         INFO = -3
      ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN
         INFO = -5
      ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN
         INFO = -7
      ELSEIF ( ITMAX.LT.0 ) THEN
         INFO = -8
      ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.N ) ) THEN
         INFO = -10
      ELSEIF ( INCB.LE.0 ) THEN
         INFO = -12
      ELSEIF ( INCX.LE.0 ) THEN
         INFO = -14
      ELSEIF ( LDWORK.LT.MAX( 2, 3*N ) ) THEN
         INFO = -17
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02WD', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ZERO
         DWORK(2) = ZERO
         RETURN
      ENDIF
C
      IF ( ITMAX.EQ.0 ) THEN
         DWORK(1) = ZERO
         IWARN = 2
         RETURN
      ENDIF
C
C     Set default tolerance, if needed.
C
      TOLDEF = TOL
      IF ( TOLDEF.LE.ZERO )
     $   TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )*DNRM2( N, B, INCB )
C
C     Initialize local variables.
C
      K = 0
C
C     Vector q is stored in DWORK(1), A*q or f(A, q) in DWORK(AQ),
C     and r in DWORK(R). The workspace for F starts in DWORK(DWLEFT).
C
      AQ     = N + 1
      R      = N + AQ
      DWLEFT = N + R
C
C     Prepare the first iteration, initialize r and q.
C
      IF ( MAT ) THEN
         CALL DCOPY( N, B, INCB, DWORK(R), 1 )
         CALL DSYMV( FORM, N, ONE, A, LDA, X, INCX, -ONE, DWORK(R), 1 )
      ELSE
         CALL DCOPY( N, X, INCX, DWORK(R), 1 )
         CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(R), 1,
     $           DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO )
         IF ( INFO.NE.0 )
     $      RETURN
         CALL DAXPY( N, -ONE, B, INCB, DWORK(R), 1 )
      ENDIF
      CALL DCOPY( N, DWORK(R), 1, DWORK, 1 )
C
      RES = DNRM2( N, DWORK(R), 1 )
C
C     Do nothing if x is already the solution.
C
      IF ( RES.LE.TOLDEF ) GOTO 20
C
C     Begin of the iteration loop.
C
C     WHILE ( RES.GT.TOLDEF .AND. K.LE.ITMAX ) DO
   10 CONTINUE
C
C        Calculate A*q or f(A, q).
C
         IF ( MAT ) THEN
            CALL DSYMV( FORM, N, ONE, A, LDA, DWORK, 1, ZERO, DWORK(AQ),
     $                  1 )
         ELSE
            CALL DCOPY( N, DWORK, 1, DWORK(AQ), 1 )
            CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(AQ), 1,
     $              DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO )
            IF ( INFO.NE.0 )
     $         RETURN
         ENDIF
C
C        Calculate ALPHA(k).
C
         ALPHA = DDOT( N, DWORK, 1, DWORK(R),  1 ) /
     $           DDOT( N, DWORK, 1, DWORK(AQ), 1 )
C
C        x(k+1) = x(k) - ALPHA(k)*q(k).
C
         CALL DAXPY( N, -ALPHA, DWORK, 1, X, INCX )
C
C        r(k+1) = r(k) - ALPHA(k)*(A*q(k)).
C
         CALL DAXPY( N, -ALPHA, DWORK(AQ), 1, DWORK(R), 1 )
C
C        Save RES and calculate a new RES.
C
         RESOLD = RES
         RES = DNRM2( N, DWORK(R), 1 )
C
C        Exit if tolerance is reached.
C
         IF ( RES.LE.TOLDEF ) GOTO 20
C
C        Calculate BETA(k).
C
         BETA = ( RES/RESOLD )**2
C
C        q(k+1) = r(k+1) + BETA(k)*q(k).
C
         CALL DSCAL( N, BETA, DWORK, 1 )
         CALL DAXPY( N, ONE,  DWORK(R), 1, DWORK, 1 )
C
C        End of the iteration loop.
C
         K = K + 1
         IF ( K.LT.ITMAX ) GOTO 10
C     END WHILE 10
C
C     Tolerance was not reached!
C
      IWARN = 1
C
   20 CONTINUE
C
      DWORK(1) = K
      DWORK(2) = RES
C
C *** Last line of MB02WD ***
      END


      SUBROUTINE TTEST(DATA1,N1,DATA2,N2,T,PROB)
      DIMENSION DATA1(N1),DATA2(N2)
      CALL AVEVAR(DATA1,N1,AVE1,VAR1)
      CALL AVEVAR(DATA2,N2,AVE2,VAR2)
      DF=N1+N2-2
      VAR=((N1-1)*VAR1+(N2-1)*VAR2)/DF
      T=(AVE1-AVE2)/SQRT(VAR*(1./N1+1./N2))
      PROB=BETAI(0.5*DF,0.5,DF/(DF+T**2))
      RETURN
      END


! ----------------------------------------------------------------------
! SUBROUTINE: R3
! ----------------------------------------------------------------------
! Purpose:
!    Calculate rotation matrix about the z-axis (towards earth centre)
!    for given radians PSI
! ----------------------------------------------------------------------
! Author :	John Donovan, Geoscience Australia
! Created:	26 March 2020
! ----------------------------------------------------------------------
*
*         (  + cos(PSI)   + sin(PSI)     0  )
*         (                                 )
*         (  - sin(PSI)   + cos(PSI)     0  )
*         (                                 )
*         (       0            0         1  )
*

      SUBROUTINE R3 ( PSI, R )
      IMPLICIT NONE

      DOUBLE PRECISION PSI, R(3,3)

      DOUBLE PRECISION S, C, A11, A12, A13, A21, A22, A23

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      S = SIN(PSI)
      C = COS(PSI)

      A11 =   C
      A12 =   S
      A13 =   0.0d0
      A21 = - S
      A22 =   C
      A23 =   0.0d0

      R(1,1) = A11
      R(1,2) = A12
      R(1,3) = A13
      R(2,1) = A21
      R(2,2) = A22
      R(2,3) = A23

      END


module HeatingMod
 implicit none
 private
 public :: crheat

 real, parameter :: sece = 35

contains

 function crheat_f1(x) result(f1)
  real :: x,f1
  f1=.9971*(1-(1-x**.2663)**1.3163)
 end function

 function crheat_f2(e) result(f2)
  real :: e,f2
  f2=2*e-13.6
 end function

 function crheat_f3(x) result(f3)
  real :: x,logx,f3
  logx=log10(x)
  f3=-.265*(-2.37+logx)*(4.69+logx)*(15.62+7.21*logx+logx**2)
 end function

 function crheat(x)
  real :: crheat,x,xe
  xe=x
  if(x.lt.5.e-5) xe=5.e-5
  if(x.gt.1) xe=1
  crheat=crheat_f1(xe)+1./(crheat_f2(sece)/crheat_f3(xe)+1./(1-crheat_f1(xe)))
  crheat=crheat*sece
 end function

end module

!program test
!use heatingMod
!real xe

!10 read*, xe
!   if(xe.eq.0) stop
!   print*, crheat(xe)
!   goto 10

!end program


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This test computes a 3D FFT using 2DECOMP&FFT and P3DFFT separately,
! crosschecks the result and compares the performance of the libraries.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program p3dfft_test

  use p3dfft
  use decomp_2d
  use decomp_2d_fft
  use MPI

  implicit none

  integer, parameter :: wp=KIND(0.0d0)
  integer, parameter :: nx=128, ny=128, nz=128
  ! use 0*0 for auto-tuning, particularly good for large core count
  integer, parameter :: p_row=0, p_col=0
  integer, parameter :: ntest = 10

  real(wp), dimension(:,:,:), allocatable :: BEG,FIN
  complex(wp), dimension(:,:,:), allocatable :: AEND,AEND2

  real(wp) :: cdiff, ccdiff
  double precision :: rtime1, rtime2
  integer :: ierr, ndims(2), nsize, proc_id
  integer :: dims(2), dummy_coords(2)
  logical :: dummy_periods(2)
  integer :: istart(3), iend(3), isize(3)
  integer :: fstart(3), fend(3), fsize(3)
  integer :: i, m, x, y, z, imin

  call MPI_INIT (ierr)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 2DECOMP&FFT
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call decomp_2d_init(nx,ny,nz,p_row,p_col)
  call MPI_CART_GET(DECOMP_2D_COMM_CART_X, 2, &
       dims, dummy_periods, dummy_coords, ierr)

  if (nrank == 0) then
     print *,' '
     print *,'----------------------------------------------'
     print *,'2DECOMP&FFT result'
  endif

  call decomp_2d_fft_init

  allocate (BEG(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
  allocate (FIN(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
  call decomp_2d_fft_get_size(istart,iend,isize)
  allocate(AEND(istart(1):iend(1),istart(2):iend(2),istart(3):iend(3)))
  allocate(AEND2(istart(1):iend(1),istart(2):iend(2),istart(3):iend(3)))

  do z=xstart(3),xend(3)
     do y=xstart(2),xend(2)
        do x=xstart(1),xend(1)
           BEG(x,y,z) = real(x,wp)/real(nx,wp)*real(y,wp) &
                /real(ny,wp)*real(z,wp)/real(nz,wp)
           FIN(x,y,z) = BEG(x,y,z) ! keep a copy
        end do
     end do
  end do

  rtime1 = 0.0D0
  do m = 1, ntest

     BEG = FIN ! Note if OVERWRITE flag used BEG may be overwritten.
     ! So here restore exact input from the copy.

     call MPI_Barrier(MPI_COMM_WORLD,ierr)
     rtime1 = rtime1 - MPI_WTIME()
     call decomp_2d_fft_3d(BEG,AEND)
     rtime1 = rtime1 + MPI_WTIME()

     ! keep a copy of the result for comparison with P3DFFT
     if (m==1) AEND2=AEND

     if (nrank==0 .AND. m==1) then
        imin = min(isize(1),min(isize(2),isize(3)))
        write(*,*) 'Result of forward transform:'
        write(*,*) (AEND(i,i,i),i=1,min(10,imin))
     end if

     AEND = AEND / real(nx,wp) / real(ny,wp) / real(nz,wp)

     call MPI_Barrier(MPI_COMM_WORLD,ierr)
     rtime1 = rtime1 - MPI_WTIME()
     call decomp_2d_fft_3d(AEND,BEG)
     rtime1 = rtime1 + MPI_WTIME()

  end do

  cdiff = 0.0_wp
  ccdiff = 0.0_wp
  do z=xstart(3),xend(3)
     do y=xstart(2),xend(2)
        do x=xstart(1),xend(1)
           if (cdiff < abs(BEG(x,y,z)-FIN(x,y,z))) then
              cdiff = abs(BEG(x,y,z)-FIN(x,y,z))
           end if
        end do
     end do
  end do
  call MPI_Reduce(cdiff,ccdiff,1,real_type,MPI_MAX,0, &
       MPI_COMM_WORLD,ierr)
  if (nrank == 0) then
     write(*,*) 'after backward transform'
     write (*,*) ' max diff =',ccdiff
  end if

  cdiff = 0.0_wp
  ccdiff = 0.0_wp
  do z=xstart(3),xend(3)
     do y=xstart(2),xend(2)
        do x=xstart(1),xend(1)
           cdiff = cdiff + (BEG(x,y,z)-FIN(x,y,z))**2
        end do
     end do
  end do
  call MPI_Reduce(cdiff,ccdiff,1,real_type,MPI_SUM,0, &
       MPI_COMM_WORLD,ierr)
  ccdiff = sqrt(ccdiff/real(nx,wp)/real(ny,wp)/real(nz,wp))
  if (nrank == 0) then
     write (*,*) 'aver diff =',ccdiff
  end if

  call MPI_Reduce(rtime1,rtime2,1,MPI_REAL8,MPI_MAX,0, &
       MPI_COMM_WORLD,ierr)
  if (nrank==0) then
     write(*,*)'cpu time per forward+backward transforms', &
          rtime2/dble(ntest)
  end if

  ! save some information for P3DFFT
  proc_id = nrank
  ndims(1) = dims(1)
  ndims(2) = dims(2)

  call decomp_2d_fft_finalize
  call decomp_2d_finalize

  deallocate(BEG, FIN, AEND)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! P3DFFT
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call MPI_COMM_SIZE(MPI_COMM_WORLD,nsize,ierr)
  call MPI_COMM_RANK(MPI_COMM_WORLD,proc_id,ierr)

  if (ndims(1)*ndims(2) /= nsize) then
     call MPI_ABORT(MPI_COMM_WORLD,-1,ierr)
  end if

  if (proc_id == 0) then
     print *,' '
     print *,'----------------------------------------------'
     print *,'P3DFFT result'
  endif

  call p3dfft_setup(ndims,nx,ny,nz,.true.)
  call p3dfft_get_dims(istart,iend,isize,1)
  call p3dfft_get_dims(fstart,fend,fsize,2)

  allocate (BEG(istart(1):iend(1),istart(2):iend(2),istart(3):iend(3)))
  allocate (AEND(fstart(1):fend(1),fstart(2):fend(2),fstart(3):fend(3)))
  allocate (FIN(istart(1):iend(1),istart(2):iend(2),istart(3):iend(3)))

  do z=istart(3),iend(3)
     do y=istart(2),iend(2)
        do x=istart(1),iend(1)
           BEG(x,y,z) = real(x,wp)/real(nx,wp)*real(y,wp) &
                /real(ny,wp)*real(z,wp)/real(nz,wp)
        end do
     end do
  end do
  !
  ! transform from physical space to wavenumber space
  ! (XgYiZj to XiYjZg)
  ! then transform back to physical space
  ! (XiYjZg to XgYiZj)
  !
  rtime1 = 0.0D0
  do m=1, ntest

     call MPI_Barrier(MPI_COMM_WORLD,ierr)

     ! Forward transform
     rtime1 = rtime1 - MPI_wtime()
     ! The third parameter introduce in version 2.5.1 of P3DFFT
     ! API not compatible with earlier versions
     call p3dfft_ftran_r2c(BEG,AEND,'fft')
     rtime1 = rtime1 + MPI_wtime()

     ! check against 2DECOMP&FFT
     if (m==1) then
        cdiff = 0.0_wp
        do z=fstart(3),fend(3)
           do y=fstart(2),fend(2)
              do x=fstart(1),fend(1)
                 cdiff = cdiff + &
                      (real(AEND(x,y,z),wp)-real(AEND2(x,y,z),wp))**2 &
                      +(aimag(AEND(x,y,z))-aimag(AEND2(x,y,z)))**2
              end do
           end do
        end do
        call MPI_Reduce(cdiff,ccdiff,1,mpireal,MPI_SUM,0, &
             MPI_COMM_WORLD,ierr)
        ccdiff = sqrt(ccdiff/real(nx/2+1,wp)/real(ny,wp)/real(nz,wp))
        if (proc_id==0) then
           write(*,*) ' '
           write(*,*) '==== Crosscheck (2DECOMP&FFT vs. P3DFFT) ===='
           write(*,*) 'aver diff = ', ccdiff
           write(*,*) ' '
        end if
     end if

     if (proc_id==0 .AND. m==1) then
        imin = min(fsize(1),min(fsize(2),fsize(3)))
        write(*,*) 'Result of forward transform:'
        write(*,*) (AEND(i,i,i),i=1,min(10,imin))
     end if

     AEND = AEND / real(nx,wp) / real(ny,wp) / real(nz,wp)

     call MPI_Barrier(MPI_COMM_WORLD,ierr)

     ! Backward transform
     rtime1 = rtime1 - MPI_wtime()
     call p3dfft_btran_c2r(AEND,FIN,'tff')
     rtime1 = rtime1 + MPI_wtime()

  end do

  cdiff = 0.0_wp
  ccdiff = 0.0_wp
  do z=istart(3),iend(3)
     do y=istart(2),iend(2)
        do x=istart(1),iend(1)
           if (cdiff < abs(BEG(x,y,z)-FIN(x,y,z))) then
              cdiff = abs(BEG(x,y,z)-FIN(x,y,z))
           end if
        end do
     end do
  end do
  call MPI_Reduce(cdiff,ccdiff,1,mpireal,MPI_MAX,0, &
       MPI_COMM_WORLD,ierr)
  if (proc_id == 0) then
     write(*,*) 'after backward transform'
     write (*,*) ' max diff =',ccdiff
  end if

  cdiff = 0.0_wp
  ccdiff = 0.0_wp
  do z=istart(3),iend(3)
     do y=istart(2),iend(2)
        do x=istart(1),iend(1)
           cdiff = cdiff + (BEG(x,y,z)-FIN(x,y,z))**2
        end do
     end do
  end do
  call MPI_Reduce(cdiff,ccdiff,1,mpireal,MPI_SUM,0, &
       MPI_COMM_WORLD,ierr)
  ccdiff = sqrt(ccdiff/real(nx,wp)/real(ny,wp)/real(nz,wp))
  if (proc_id == 0) then
     write (*,*) 'aver diff =',ccdiff
  end if

  call MPI_Reduce(rtime1,rtime2,1,mpi_real8,MPI_MAX,0, &
       MPI_COMM_WORLD,ierr)

  if (proc_id == 0) then
     write(*,*)'cpu time per forward+backward transforms', &
          rtime2/dble(ntest)
  end if

  call p3dfft_clean
  deallocate(BEG, FIN, AEND, AEND2)

  call MPI_FINALIZE (ierr)

end program p3dfft_test


! Check that parameters are correct intercepted.
! Constants with comma separations are commonly
! used, for instance Pi = 3._dp
subroutine foo_single(x)
  implicit none
  integer, parameter :: rp = selected_real_kind(6)
  real(rp), intent(inout) :: x
  dimension x(3)
  real(rp), parameter :: three = 3._rp
  x(1) = x(1) + x(2) + x(3) * three
  return
end subroutine

subroutine foo_double(x)
  implicit none
  integer, parameter :: rp = selected_real_kind(15)
  real(rp), intent(inout) :: x
  dimension x(3)
  real(rp), parameter :: three = 3._rp
  x(1) = x(1) + x(2) + x(3) * three
  return
end subroutine


module date_mod
implicit none
interface operator (+)
   module procedure add
end interface
interface operator (>)
   module procedure greater
end interface
type :: ym
   integer :: year,month
end type ym
contains
!
elemental function str(date) result(text)
type(ym), intent(in) :: date
character (len=7) :: text
write (text,"(i4.4,'-',i2.2)") date%year,date%month
end function str
!
elemental function add(date,n) result(new_date)
type(ym), intent(in) :: date
integer , intent(in) :: n
type(ym)             :: new_date
new_date = int_to_ym(int(date) + n)
end function add
!
elemental function int(date) result(idate)
type(ym), intent(in) :: date
integer              :: idate
idate = date%year*12 + date%month
end function int
!
elemental function int_to_ym(idate) result(date)
integer, intent(in) :: idate
type(ym)            :: date
date%year  = idate/12
date%month = idate - date%year*12
if (date%month == 0) then
   date%month = 12
   date%year = date%year - 1
end if
end function int_to_ym
!
elemental function greater(date_1,date_2) result(tf)
type(ym), intent(in) :: date_1,date_2
logical              :: tf
tf = int(date_1) > int(date_2)
end function greater
end module date_mod

program xdate
use date_mod, only: ym, str, operator(+), operator(>)
implicit none
type(ym), allocatable :: dates(:)
dates = [ym(2021,11),ym(2021,12),ym(2022,1)] ! set array of type(ym)
write (*,"(a10,':',*(1x,a))") "dates",str(dates)
write (*,"(a10,':',*(i8))") "months",dates%month
write (*,"(a10,':',*(1x,a))") "dates+1",str(dates+1) ! user-defined + operator
write (*,*) "dates > dates(2)",dates > dates(2)      ! user-defined > operator
! output:
!     dates: 2021-11 2021-12 2022-01
!    months:      11      12       1
!   dates+1: 2021-12 2022-01 2022-02
! dates > dates(2) F F T
end program xdate


MODULE circle_class
!
!   This module implements a circle class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/29/06    S. J. Chapman        Original code
!
USE shape_class                  ! USE parent class
IMPLICIT NONE

! Type definition
TYPE,PUBLIC,EXTENDS(shape) :: circle

   ! Additional instance variables.
   REAL :: r = 0               ! Radius

CONTAINS

   ! Bound procedures
   PROCEDURE,PUBLIC :: initialize => initialize_sub
   PROCEDURE,PUBLIC :: area => get_area_fn
   PROCEDURE,PUBLIC :: perimeter => get_perimeter_fn
   PROCEDURE,PUBLIC :: to_string => to_string_fn

END TYPE circle

! Declare constant PI
REAL,PARAMETER :: PI = 3.141593

! Restrict access to the actual procedure names
PRIVATE :: initialize_sub, get_area_fn, get_perimeter_fn
PRIVATE :: to_string_fn

! Now add methods
CONTAINS

   SUBROUTINE initialize_sub(this,r)
   !
   ! Initialize the circle object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(circle) :: this               ! Circle object
   REAL,INTENT(IN) :: r                ! Radius

   ! Initialize the circle
   this%r = r

   END SUBROUTINE initialize_sub

   REAL FUNCTION get_area_fn(this)
   !
   ! Return the area of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(circle) :: this             ! Circle object

   ! Calculate area
   get_area_fn = PI * this%r**2

   END FUNCTION get_area_fn

   REAL FUNCTION get_perimeter_fn(this)
   !
   ! Return the perimeter of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(circle) :: this             ! Circle object

   ! Calculate perimeter
   get_perimeter_fn = 2.0 * PI * this%r

   END FUNCTION get_perimeter_fn

   CHARACTER(len=50) FUNCTION to_string_fn(this)
   !
   ! Return the a character description of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(circle) :: this             ! Circle object

   ! Return description
   WRITE (to_string_fn,'(A,F6.2)') 'Circle of radius ', &
      this%r

   END FUNCTION to_string_fn

END MODULE circle_class


program diff_and_diss
use constants
implicit none
integer, parameter :: dp = selected_real_kind(15,307)
! program to calculate ratediff and ratediss
real (dp) :: deltag,eta,ratediff,ratediss,temp,k
! read eta (in Pa*s=pascal*second) deltag (of reaction) and temperature (in K)
read(*,*) eta,deltag,temp
if(deltag>0) then
   ratediff=8*boltz*temp/3/eta*avog*1d3
else
   ratediff=boltz*temp/planck*exp(deltag/r/temp)*ratm*temp
endif
k=exp(-deltag/r/temp)/ratm/temp
ratediss=ratediff*k
! rate
print*, ratediff
print*, ratediss

end program diff_and_diss