*> \brief  SGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGEGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
*                         BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOBVL, JOBVR
*       INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
*      $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
*      $                   VR( LDVR, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> This routine is deprecated and has been replaced by routine SGGEV.
*>
*> SGEGV computes the eigenvalues and, optionally, the left and/or right
*> eigenvectors of a real matrix pair (A,B).
*> Given two square matrices A and B,
*> the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
*> eigenvalues lambda and corresponding (non-zero) eigenvectors x such
*> that
*>
*>    A*x = lambda*B*x.
*>
*> An alternate form is to find the eigenvalues mu and corresponding
*> eigenvectors y such that
*>
*>    mu*A*y = B*y.
*>
*> These two forms are equivalent with mu = 1/lambda and x = y if
*> neither lambda nor mu is zero.  In order to deal with the case that
*> lambda or mu is zero or small, two values alpha and beta are returned
*> for each eigenvalue, such that lambda = alpha/beta and
*> mu = beta/alpha.
*>
*> The vectors x and y in the above equations are right eigenvectors of
*> the matrix pair (A,B).  Vectors u and v satisfying
*>
*>    u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B
*>
*> are left eigenvectors of (A,B).
*>
*> Note: this routine performs "full balancing" on A and B
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBVL
*> \verbatim
*>          JOBVL is CHARACTER*1
*>          = 'N':  do not compute the left generalized eigenvectors;
*>          = 'V':  compute the left generalized eigenvectors (returned
*>                  in VL).
*> \endverbatim
*>
*> \param[in] JOBVR
*> \verbatim
*>          JOBVR is CHARACTER*1
*>          = 'N':  do not compute the right generalized eigenvectors;
*>          = 'V':  compute the right generalized eigenvectors (returned
*>                  in VR).
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrices A, B, VL, and VR.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA, N)
*>          On entry, the matrix A.
*>          If JOBVL = 'V' or JOBVR = 'V', then on exit A
*>          contains the real Schur form of A from the generalized Schur
*>          factorization of the pair (A,B) after balancing.
*>          If no eigenvectors were computed, then only the diagonal
*>          blocks from the Schur form will be correct.  See SGGHRD and
*>          SHGEQZ for details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB, N)
*>          On entry, the matrix B.
*>          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
*>          upper triangular matrix obtained from B in the generalized
*>          Schur factorization of the pair (A,B) after balancing.
*>          If no eigenvectors were computed, then only those elements of
*>          B corresponding to the diagonal blocks from the Schur form of
*>          A will be correct.  See SGGHRD and SHGEQZ for details.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] ALPHAR
*> \verbatim
*>          ALPHAR is REAL array, dimension (N)
*>          The real parts of each scalar alpha defining an eigenvalue of
*>          GNEP.
*> \endverbatim
*>
*> \param[out] ALPHAI
*> \verbatim
*>          ALPHAI is REAL array, dimension (N)
*>          The imaginary parts of each scalar alpha defining an
*>          eigenvalue of GNEP.  If ALPHAI(j) is zero, then the j-th
*>          eigenvalue is real; if positive, then the j-th and
*>          (j+1)-st eigenvalues are a complex conjugate pair, with
*>          ALPHAI(j+1) = -ALPHAI(j).
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*>          BETA is REAL array, dimension (N)
*>          The scalars beta that define the eigenvalues of GNEP.
*>
*>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
*>          beta = BETA(j) represent the j-th eigenvalue of the matrix
*>          pair (A,B), in one of the forms lambda = alpha/beta or
*>          mu = beta/alpha.  Since either lambda or mu may overflow,
*>          they should not, in general, be computed.
*> \endverbatim
*>
*> \param[out] VL
*> \verbatim
*>          VL is REAL array, dimension (LDVL,N)
*>          If JOBVL = 'V', the left eigenvectors u(j) are stored
*>          in the columns of VL, in the same order as their eigenvalues.
*>          If the j-th eigenvalue is real, then u(j) = VL(:,j).
*>          If the j-th and (j+1)-st eigenvalues form a complex conjugate
*>          pair, then
*>             u(j) = VL(:,j) + i*VL(:,j+1)
*>          and
*>            u(j+1) = VL(:,j) - i*VL(:,j+1).
*>
*>          Each eigenvector is scaled so that its largest component has
*>          abs(real part) + abs(imag. part) = 1, except for eigenvectors
*>          corresponding to an eigenvalue with alpha = beta = 0, which
*>          are set to zero.
*>          Not referenced if JOBVL = 'N'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*>          LDVL is INTEGER
*>          The leading dimension of the matrix VL. LDVL >= 1, and
*>          if JOBVL = 'V', LDVL >= N.
*> \endverbatim
*>
*> \param[out] VR
*> \verbatim
*>          VR is REAL array, dimension (LDVR,N)
*>          If JOBVR = 'V', the right eigenvectors x(j) are stored
*>          in the columns of VR, in the same order as their eigenvalues.
*>          If the j-th eigenvalue is real, then x(j) = VR(:,j).
*>          If the j-th and (j+1)-st eigenvalues form a complex conjugate
*>          pair, then
*>            x(j) = VR(:,j) + i*VR(:,j+1)
*>          and
*>            x(j+1) = VR(:,j) - i*VR(:,j+1).
*>
*>          Each eigenvector is scaled so that its largest component has
*>          abs(real part) + abs(imag. part) = 1, except for eigenvalues
*>          corresponding to an eigenvalue with alpha = beta = 0, which
*>          are set to zero.
*>          Not referenced if JOBVR = 'N'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*>          LDVR is INTEGER
*>          The leading dimension of the matrix VR. LDVR >= 1, and
*>          if JOBVR = 'V', LDVR >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL 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,8*N).
*>          For good performance, LWORK must generally be larger.
*>          To compute the optimal value of LWORK, call ILAENV to get
*>          blocksizes (for SGEQRF, SORMQR, and SORGQR.)  Then compute:
*>          NB  -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;
*>          The optimal LWORK is:
*>              2*N + MAX( 6*N, N*(NB+1) ).
*>
*>          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] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          = 1,...,N:
*>                The QZ iteration failed.  No eigenvectors have been
*>                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
*>                should be correct for j=INFO+1,...,N.
*>          > N:  errors that usually indicate LAPACK problems:
*>                =N+1: error return from SGGBAL
*>                =N+2: error return from SGEQRF
*>                =N+3: error return from SORMQR
*>                =N+4: error return from SORGQR
*>                =N+5: error return from SGGHRD
*>                =N+6: error return from SHGEQZ (other than failed
*>                                                iteration)
*>                =N+7: error return from STGEVC
*>                =N+8: error return from SGGBAK (computing VL)
*>                =N+9: error return from SGGBAK (computing VR)
*>                =N+10: error return from SLASCL (various calls)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realGEeigen
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Balancing
*>  ---------
*>
*>  This driver calls SGGBAL to both permute and scale rows and columns
*>  of A and B.  The permutations PL and PR are chosen so that PL*A*PR
*>  and PL*B*R will be upper triangular except for the diagonal blocks
*>  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
*>  possible.  The diagonal scaling matrices DL and DR are chosen so
*>  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
*>  one (except for the elements that start out zero.)
*>
*>  After the eigenvalues and eigenvectors of the balanced matrices
*>  have been computed, SGGBAK transforms the eigenvectors back to what
*>  they would have been (in perfect arithmetic) if they had not been
*>  balanced.
*>
*>  Contents of A and B on Exit
*>  -------- -- - --- - -- ----
*>
*>  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
*>  both), then on exit the arrays A and B will contain the real Schur
*>  form[*] of the "balanced" versions of A and B.  If no eigenvectors
*>  are computed, then only the diagonal blocks will be correct.
*>
*>  [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations",
*>      by Golub & van Loan, pub. by Johns Hopkins U. Press.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
     $                  BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
*
*  -- LAPACK driver routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          JOBVL, JOBVR
      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
     $                   VR( LDVR, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILIMIT, ILV, ILVL, ILVR, LQUERY
      CHARACTER          CHTEMP
      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
     $                   IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT,
     $                   LWKMIN, LWKOPT, NB, NB1, NB2, NB3
      REAL               ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
     $                   BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN,
     $                   SALFAI, SALFAR, SBETA, SCALE, TEMP
*     ..
*     .. Local Arrays ..
      LOGICAL            LDUMMA( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY,
     $                   SLASCL, SLASET, SORGQR, SORMQR, STGEVC, XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               SLAMCH, SLANGE
      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANGE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, MAX
*     ..
*     .. Executable Statements ..
*
*     Decode the input arguments
*
      IF( LSAME( JOBVL, 'N' ) ) THEN
         IJOBVL = 1
         ILVL = .FALSE.
      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
         IJOBVL = 2
         ILVL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVL = .FALSE.
      END IF
*
      IF( LSAME( JOBVR, 'N' ) ) THEN
         IJOBVR = 1
         ILVR = .FALSE.
      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
         IJOBVR = 2
         ILVR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVR = .FALSE.
      END IF
      ILV = ILVL .OR. ILVR
*
*     Test the input arguments
*
      LWKMIN = MAX( 8*N, 1 )
      LWKOPT = LWKMIN
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      INFO = 0
      IF( IJOBVL.LE.0 ) THEN
         INFO = -1
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
         INFO = -16
      END IF
*
      IF( INFO.EQ.0 ) THEN
         NB1 = ILAENV( 1, 'SGEQRF', ' ', N, N, -1, -1 )
         NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 )
         NB3 = ILAENV( 1, 'SORGQR', ' ', N, N, N, -1 )
         NB = MAX( NB1, NB2, NB3 )
         LOPT = 2*N + MAX( 6*N, N*(NB+1) )
         WORK( 1 ) = LOPT
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGEGV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Get machine constants
*
      EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
      SAFMIN = SLAMCH( 'S' )
      SAFMIN = SAFMIN + SAFMIN
      SAFMAX = ONE / SAFMIN
      ONEPLS = ONE + ( 4*EPS )
*
*     Scale A
*
      ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
      ANRM1 = ANRM
      ANRM2 = ONE
      IF( ANRM.LT.ONE ) THEN
         IF( SAFMAX*ANRM.LT.ONE ) THEN
            ANRM1 = SAFMIN
            ANRM2 = SAFMAX*ANRM
         END IF
      END IF
*
      IF( ANRM.GT.ZERO ) THEN
         CALL SLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 10
            RETURN
         END IF
      END IF
*
*     Scale B
*
      BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
      BNRM1 = BNRM
      BNRM2 = ONE
      IF( BNRM.LT.ONE ) THEN
         IF( SAFMAX*BNRM.LT.ONE ) THEN
            BNRM1 = SAFMIN
            BNRM2 = SAFMAX*BNRM
         END IF
      END IF
*
      IF( BNRM.GT.ZERO ) THEN
         CALL SLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 10
            RETURN
         END IF
      END IF
*
*     Permute the matrix to make it more nearly triangular
*     Workspace layout:  (8*N words -- "work" requires 6*N words)
*        left_permutation, right_permutation, work...
*
      ILEFT = 1
      IRIGHT = N + 1
      IWORK = IRIGHT + N
      CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
     $             WORK( IRIGHT ), WORK( IWORK ), IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 1
         GO TO 120
      END IF
*
*     Reduce B to triangular form, and initialize VL and/or VR
*     Workspace layout:  ("work..." must have at least N words)
*        left_permutation, right_permutation, tau, work...
*
      IROWS = IHI + 1 - ILO
      IF( ILV ) THEN
         ICOLS = N + 1 - ILO
      ELSE
         ICOLS = IROWS
      END IF
      ITAU = IWORK
      IWORK = ITAU + IROWS
      CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
     $             WORK( IWORK ), LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 )
     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 2
         GO TO 120
      END IF
*
      CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
     $             LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 )
     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 3
         GO TO 120
      END IF
*
      IF( ILVL ) THEN
         CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
         CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
     $                VL( ILO+1, ILO ), LDVL )
         CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
     $                WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
     $                IINFO )
         IF( IINFO.GE.0 )
     $      LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 4
            GO TO 120
         END IF
      END IF
*
      IF( ILVR )
     $   CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
*
*     Reduce to generalized Hessenberg form
*
      IF( ILV ) THEN
*
*        Eigenvectors requested -- work on whole matrix.
*
         CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
     $                LDVL, VR, LDVR, IINFO )
      ELSE
         CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
      END IF
      IF( IINFO.NE.0 ) THEN
         INFO = N + 5
         GO TO 120
      END IF
*
*     Perform QZ algorithm
*     Workspace layout:  ("work..." must have at least 1 word)
*        left_permutation, right_permutation, work...
*
      IWORK = ITAU
      IF( ILV ) THEN
         CHTEMP = 'S'
      ELSE
         CHTEMP = 'E'
      END IF
      CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
     $             ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
     $             WORK( IWORK ), LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 )
     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
            INFO = IINFO
         ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
            INFO = IINFO - N
         ELSE
            INFO = N + 6
         END IF
         GO TO 120
      END IF
*
      IF( ILV ) THEN
*
*        Compute Eigenvectors  (STGEVC requires 6*N words of workspace)
*
         IF( ILVL ) THEN
            IF( ILVR ) THEN
               CHTEMP = 'B'
            ELSE
               CHTEMP = 'L'
            END IF
         ELSE
            CHTEMP = 'R'
         END IF
*
         CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
     $                VR, LDVR, N, IN, WORK( IWORK ), IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 7
            GO TO 120
         END IF
*
*        Undo balancing on VL and VR, rescale
*
         IF( ILVL ) THEN
            CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
     $                   WORK( IRIGHT ), N, VL, LDVL, IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = N + 8
               GO TO 120
            END IF
            DO 50 JC = 1, N
               IF( ALPHAI( JC ).LT.ZERO )
     $            GO TO 50
               TEMP = ZERO
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 10 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
   10             CONTINUE
               ELSE
                  DO 20 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
     $                      ABS( VL( JR, JC+1 ) ) )
   20             CONTINUE
               END IF
               IF( TEMP.LT.SAFMIN )
     $            GO TO 50
               TEMP = ONE / TEMP
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 30 JR = 1, N
                     VL( JR, JC ) = VL( JR, JC )*TEMP
   30             CONTINUE
               ELSE
                  DO 40 JR = 1, N
                     VL( JR, JC ) = VL( JR, JC )*TEMP
                     VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
   40             CONTINUE
               END IF
   50       CONTINUE
         END IF
         IF( ILVR ) THEN
            CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
     $                   WORK( IRIGHT ), N, VR, LDVR, IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = N + 9
               GO TO 120
            END IF
            DO 100 JC = 1, N
               IF( ALPHAI( JC ).LT.ZERO )
     $            GO TO 100
               TEMP = ZERO
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 60 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
   60             CONTINUE
               ELSE
                  DO 70 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
     $                      ABS( VR( JR, JC+1 ) ) )
   70             CONTINUE
               END IF
               IF( TEMP.LT.SAFMIN )
     $            GO TO 100
               TEMP = ONE / TEMP
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 80 JR = 1, N
                     VR( JR, JC ) = VR( JR, JC )*TEMP
   80             CONTINUE
               ELSE
                  DO 90 JR = 1, N
                     VR( JR, JC ) = VR( JR, JC )*TEMP
                     VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
   90             CONTINUE
               END IF
  100       CONTINUE
         END IF
*
*        End of eigenvector calculation
*
      END IF
*
*     Undo scaling in alpha, beta
*
*     Note: this does not give the alpha and beta for the unscaled
*     problem.
*
*     Un-scaling is limited to avoid underflow in alpha and beta
*     if they are significant.
*
      DO 110 JC = 1, N
         ABSAR = ABS( ALPHAR( JC ) )
         ABSAI = ABS( ALPHAI( JC ) )
         ABSB = ABS( BETA( JC ) )
         SALFAR = ANRM*ALPHAR( JC )
         SALFAI = ANRM*ALPHAI( JC )
         SBETA = BNRM*BETA( JC )
         ILIMIT = .FALSE.
         SCALE = ONE
*
*        Check for significant underflow in ALPHAI
*
         IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
            ILIMIT = .TRUE.
            SCALE = ( ONEPLS*SAFMIN / ANRM1 ) /
     $              MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
*
         ELSE IF( SALFAI.EQ.ZERO ) THEN
*
*           If insignificant underflow in ALPHAI, then make the
*           conjugate eigenvalue real.
*
            IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
               ALPHAI( JC-1 ) = ZERO
            ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
               ALPHAI( JC+1 ) = ZERO
            END IF
         END IF
*
*        Check for significant underflow in ALPHAR
*
         IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
     $       MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
            ILIMIT = .TRUE.
            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) /
     $              MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
         END IF
*
*        Check for significant underflow in BETA
*
         IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
            ILIMIT = .TRUE.
            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) /
     $              MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
         END IF
*
*        Check for possible overflow when limiting scaling
*
         IF( ILIMIT ) THEN
            TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
     $             ABS( SBETA ) )
            IF( TEMP.GT.ONE )
     $         SCALE = SCALE / TEMP
            IF( SCALE.LT.ONE )
     $         ILIMIT = .FALSE.
         END IF
*
*        Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
*
         IF( ILIMIT ) THEN
            SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
            SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
            SBETA = ( SCALE*BETA( JC ) )*BNRM
         END IF
         ALPHAR( JC ) = SALFAR
         ALPHAI( JC ) = SALFAI
         BETA( JC ) = SBETA
  110 CONTINUE
*
  120 CONTINUE
      WORK( 1 ) = LWKOPT
*
      RETURN
*
*     End of SGEGV
*
      END


c
c     This file contains the Stokes direct kernel evaluators in two dimensions
c
c**********************************************************************
c
c     We take the following conventions for the Stokes kernels
c
c     For a source y and target x, let r_i = x_i-y_i
c     and let r = sqrt(r_1^2 + r_2^2)
c
c     The Stokeslet, G_{ij}, and its associated pressure tensor, P_j,
c     (without the 1/2pi scaling) are
c
c     G_{ij}(x,y) = (r_i r_j)/(2r^2) - delta_{ij}log(r)/(2)
c     P_j(x,y) = r_j/r^2
c
c     The (Type I) stresslet, T_{ijk}, and its associated pressure
c     tensor, PI_{jk}, (without the 1/2pi scaling) are
c
c     T_{ijk}(x,y) = -2 r_i r_j r_k/ r^4
c     PI_{jk} = - delta_{jk}/r^2 + 2 r_j r_k/r^4
c

      subroutine st2ddirectstokg(nd,sources,stoklet,ns,targ,nt,
     1     pot,pre,grad,thresh)
c
c     This subroutine evaluates the potential and gradient due
c     to a collection of Stokeslet and stresslet sources and adds
c     to existing quantities (see definitions at top of file).
c
c       pot(x) = pot(x) + sum_m G_{ij}(x,y^{(m)}) sigma^{(m)}_j
c
c       pre(x) = sum_m P_j(x,y^m) sigma^{(m)}_j
c
c       grad(x) = Grad[sum_m G_{ij}(x,y^m) sigma^{(m)}_j
c
c     where sigma^{(m)} is the Stokeslet charge, mu^{(m)} is the
c     stresslet charge, and nu^{(m)} is the stresslet orientation
c     (note that each of these is a 2 vector per source point y^{(m)}).
c     For x a source point, the self-interaction in the sum is omitted.
c
c
c-----------------------------------------------------------------------

c     INPUT:
c
c     nd in: integer
c        number of densities
c
c     nsource in: integer
c        number of sources
c
c     source  in: double precision (2,nsource)
c        source(k,j) is the kth component of the jth
c        source location
c
c     stoklet in: double precision (nd,2,nsource)
c        Stokeslet charge strengths (sigma vectors above)
c
c     ntarg   in: integer
c        number of targs
c
c     targ    in: double precision (2,ntarg)
c        targ(k,j) is the kth component of the jth
c        targ location
c
c     thresh in: double precision
c        threshold for updating potential,
c        potential at target won't be updated if
c        |t - s| <= thresh, where t is the target
c        location and, and s is the source location
c
c-----------------------------------------------------------------------
c
c   OUTPUT:
c
c     pot out: double precision(nd,2,ntarg)
c        velocity at the targets
c
c     pre out: double precision(nd,ntarg)
c        pressure at the targets
c
c     grad out: double precision(nd,2,2,ntarg)
c        gradient of velocity at the targets
c        gradtarg(l,i,j,k) is the ith component of the
c        gradient of the jth component of the velocity
c        for the lth density at the kth target
c
c------------------------------------------------------------------
      implicit none
cf2py intent(in) nd,sources,stoklet,ns
cf2py intent(in) targ,nt,thresh
cf2py intent(out) pot,pre,grad

      integer nd, ns, nt, istress
      real *8 sources(2,ns),targ(2,nt)
      real *8 stoklet(nd,2,ns)
      real *8 pot(nd,2,nt),pre(nd,nt),grad(nd,2,2,nt)
      real *8 thresh

c     local

      real *8 zdiff(2), d1, d2, d3, tempx1, tempx2, tempx3
      real *8 pl, pl2,pv, dmu(2), dnu(2), temp, r, r2, r3, r4, r5
      real *8 dmunu,rtmp
      real *8 threshsq

      integer i, j, idim, l

      threshsq = thresh**2

c     stokeslet contribution

      do i = 1,nt
         do j = 1,ns
            zdiff(1) = targ(1,i)-sources(1,j)
            zdiff(2) = targ(2,i)-sources(2,j)

            r2 = zdiff(1)**2 + zdiff(2)**2
            if (r2 .lt. threshsq) goto 10

            rtmp = zdiff(1)**2 - zdiff(2)**2
            r4 = r2*r2

            do idim = 1,nd

               pot(idim,1,i) = pot(idim,1,i)-
     1            stoklet(idim,1,j)*log(r2)/(4)
               pot(idim,2,i) = pot(idim,2,i)-
     1             stoklet(idim,2,j)*log(r2)/(4)

               pl = (zdiff(1)*stoklet(idim,1,j) +
     1              zdiff(2)*stoklet(idim,2,j))

               pl2 = zdiff(1)*stoklet(idim,2,j) +
     1               zdiff(2)*stoklet(idim,1,j)

               pot(idim,1,i) = pot(idim,1,i) + zdiff(1)*pl/r2/2
               pot(idim,2,i) = pot(idim,2,i) + zdiff(2)*pl/r2/2

               grad(idim,1,1,i) = grad(idim,1,1,i) - rtmp*pl/r4/2
               grad(idim,2,2,i) = grad(idim,2,2,i) + rtmp*pl/r4/2
               grad(idim,2,1,i) = grad(idim,2,1,i) +
     1           (pl2*rtmp -
     2             stoklet(idim,1,j)*4*zdiff(2)*zdiff(1)**2)/2/r4

               grad(idim,1,2,i) = grad(idim,1,2,i) -
     1           (pl2*rtmp +
     2             stoklet(idim,2,j)*4*zdiff(1)*zdiff(2)**2)/2/r4

               pre(idim,i) = pre(idim,i) + pl/r2

            enddo
 10         continue
         enddo
      enddo

      return
      end
c
c
c
c
c

      subroutine st2ddirectstokstrsg(nd,sources,ifstoklet,
     1     stoklet,
     1     istress, strslet, strsvec, ns,targ,nt,pot,pre,
     2     grad,thresh)
c
c     This subroutine evaluates the potential and gradient due
c     to a collection of Stokeslet and stresslet sources and adds
c     to existing quantities (see definitions at top of file).
c
c       pot(x) = pot(x) + sum_m G_{ij}(x,y^{(m)}) sigma^{(m)}_j
c
c       pre(x) = sum_m P_j(x,y^m) sigma^{(m)}_j
c
c       grad(x) = Grad[sum_m G_{ij}(x,y^m) sigma^{(m)}_j
c
c     where sigma^{(m)} is the Stokeslet charge, mu^{(m)} is the
c     stresslet charge, and nu^{(m)} is the stresslet orientation
c     (note that each of these is a 2 vector per source point y^{(m)}).
c     For x a source point, the self-interaction in the sum is omitted.
c
c
c-----------------------------------------------------------------------

c     INPUT:
c
c     nd in: integer
c        number of densities
c
c     nsource in: integer
c        number of sources
c
c     source  in: double precision (2,nsource)
c        source(k,j) is the kth component of the jth
c        source location
c
c     stoklet in: double precision (nd,2,nsource)
c        Stokeslet charge strengths (sigma vectors above)
c
c     istress in: integer
c        stresslet computation flag
c           istress = 1   =>  include standard stresslet
c                               (type I)
c
c           NOT YET IMPLEMENTED
c
c           ifstress = 2   =>  include symmetric stresslet
c                                   (type II)
c           ifstress = 3   =>  include rotlet
c           ifstress = 4   =>  include Stokes doublet
c                      otherwise do not include
c
c     strslet  in: double precision (nd,2,nsource)
c        stresslet strengths (mu vectors above)
c
c     strsvec  in: double precision (nd,2,nsource)
c        stresslet orientations (nu vectors above)
c
c     ntarg   in: integer
c        number of targs
c
c     targ    in: double precision (2,ntarg)
c        targ(k,j) is the kth component of the jth
c        targ location
c
c     thresh in: double precision
c        threshold for updating potential,
c        potential at target won't be updated if
c        |t - s| <= thresh, where t is the target
c        location and, and s is the source location
c
c-----------------------------------------------------------------------
c
c   OUTPUT:
c
c     pot out: double precision(nd,2,ntarg)
c        velocity at the targets
c
c     pre out: double precision(nd,ntarg)
c        pressure at the targets
c
c     grad out: double precision(nd,2,2,ntarg)
c        gradient of velocity at the targets
c        gradtarg(l,i,j,k) is the ith component of the
c        gradient of the jth component of the velocity
c        for the lth density at the kth target
c
c------------------------------------------------------------------
      implicit none
cf2py intent(in) nd,sources,stoklet,ns
cf2py intent(in) targ,nt,thresh
cf2py intent(out) pot,pre,grad

      integer nd, ns, nt, istress,ifstoklet
      real *8 sources(2,ns),targ(2,nt)
      real *8 stoklet(nd,2,ns),strslet(nd,2,ns),strsvec(nd,2,ns)
      real *8 pot(nd,2,nt),pre(nd,nt),grad(nd,2,2,nt)
      real *8 thresh

c     local

      real *8 zdiff(2), d1, d2, d3, tempx1, tempx2, tempx3
      real *8 pl, pl2,pv, dmu(2), dnu(2), temp, r, r2, r3, r4, r6
      real *8 dmunu,rtmp
      real *8 threshsq

      integer i, j, idim, l
      if(ifstoklet.eq.1) call st2ddirectstokg(nd,sources,stoklet,
     1     ns,targ,nt,pot,pre,grad,thresh)

      threshsq = thresh**2
      if(istress.ne.1) goto 100

c     stresslet contribution

      do i = 1,nt
         do j = 1,ns
            zdiff(1) = targ(1,i)-sources(1,j)
            zdiff(2) = targ(2,i)-sources(2,j)

            r2 = zdiff(1)**2 + zdiff(2)**2
            if (r2 .lt. threshsq) goto 10

            rtmp = zdiff(1)**2 - zdiff(2)**2
            r4 = r2*r2
            r6 = r4*r2

            do idim = 1,nd

               pl = (zdiff(1)*strslet(idim,1,j) +
     1              zdiff(2)*strslet(idim,2,j))

               pl2 = zdiff(1)*strsvec(idim,1,j) +
     1               zdiff(2)*strsvec(idim,2,j)

               pv = strslet(idim,1,j)*strsvec(idim,1,j) +
     1             strslet(idim,2,j)*strsvec(idim,2,j)

               pot(idim,1,i) = pot(idim,1,i) - 2*zdiff(1)*pl*pl2/r4
               pot(idim,2,i) = pot(idim,2,i) - 2*zdiff(2)*pl*pl2/r4

               grad(idim,1,1,i) = grad(idim,1,1,i) - 2*pl*pl2/r4 -
     1            2*zdiff(1)*strslet(idim,1,j)*pl2/r4 -
     2            2*zdiff(1)*strsvec(idim,1,j)*pl/r4 +
     3            8*zdiff(1)*zdiff(1)*pl*pl2/r6
               grad(idim,2,1,i) = grad(idim,2,1,i) -
     1            2*zdiff(1)*strslet(idim,2,j)*pl2/r4 -
     2            2*zdiff(1)*strsvec(idim,2,j)*pl/r4 +
     3            8*zdiff(1)*zdiff(2)*pl*pl2/r6
               grad(idim,1,2,i) = grad(idim,1,2,i) -
     1            2*zdiff(2)*strslet(idim,1,j)*pl2/r4 -
     2            2*zdiff(2)*strsvec(idim,1,j)*pl/r4 +
     3            8*zdiff(1)*zdiff(2)*pl*pl2/r6
               grad(idim,2,2,i) = grad(idim,2,2,i) - 2*pl*pl2/r4 -
     1            2*zdiff(2)*strslet(idim,2,j)*pl2/r4 -
     2            2*zdiff(2)*strsvec(idim,2,j)*pl/r4 +
     3            8*zdiff(2)*zdiff(2)*pl*pl2/r6

               pre(idim,i) = pre(idim,i) - 4*pl*pl2/r4 + 2*pv/r2

            enddo
 10         continue
         enddo
      enddo
 100  continue

      return
      end


*DECK CHU
      FUNCTION CHU (A, B, X)
C***BEGIN PROLOGUE  CHU
C***PURPOSE  Compute the logarithmic confluent hypergeometric function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C11
C***TYPE      SINGLE PRECISION (CHU-S, DCHU-D)
C***KEYWORDS  FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CHU computes the logarithmic confluent hypergeometric function,
C U(A,B,X).
C
C Input Parameters:
C       A   real
C       B   real
C       X   real and positive
C
C This routine is not valid when 1+A-B is close to zero if X is small.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU,
C                    XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  CHU
      EXTERNAL GAMMA
      SAVE PI, EPS
      DATA PI / 3.1415926535 8979324 E0 /
      DATA EPS / 0.0 /
C***FIRST EXECUTABLE STATEMENT  CHU
      IF (EPS.EQ.0.0) EPS = R1MACH(3)
C
      IF (X .EQ. 0.0) CALL XERMSG ('SLATEC', 'CHU',
     +   'X IS ZERO SO CHU IS INFINITE', 1, 2)
      IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'CHU',
     +   'X IS NEGATIVE, USE CCHU', 2, 2)
C
      IF (MAX(ABS(A),1.0)*MAX(ABS(1.0+A-B),1.0).LT.0.99*ABS(X))
     1  GO TO 120
C
C THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL
C APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE.
C
      IF (ABS(1.0+A-B) .LT. SQRT(EPS)) CALL XERMSG ('SLATEC', 'CHU',
     +   'ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO FOR SMALL X', 10, 2)
C
      AINTB = AINT(B+0.5)
      IF (B.LT.0.0) AINTB = AINT(B-0.5)
      BEPS = B - AINTB
      N = AINTB
C
      ALNX = LOG(X)
      XTOEPS = EXP(-BEPS*ALNX)
C
C EVALUATE THE FINITE SUM.     -----------------------------------------
C
      IF (N.GE.1) GO TO 40
C
C CONSIDER THE CASE B .LT. 1.0 FIRST.
C
      SUM = 1.0
      IF (N.EQ.0) GO TO 30
C
      T = 1.0
      M = -N
      DO 20 I=1,M
        XI1 = I - 1
        T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0))
        SUM = SUM + T
 20   CONTINUE
C
 30   SUM = POCH(1.0+A-B, -A) * SUM
      GO TO 70
C
C NOW CONSIDER THE CASE B .GE. 1.0.
C
 40   SUM = 0.0
      M = N - 2
      IF (M.LT.0) GO TO 70
      T = 1.0
      SUM = 1.0
      IF (M.EQ.0) GO TO 60
C
      DO 50 I=1,M
        XI = I
        T = T * (A-B+XI)*X/((1.0-B+XI)*XI)
        SUM = SUM + T
 50   CONTINUE
C
 60   SUM = GAMMA(B-1.0) * GAMR(A) * X**(1-N) * XTOEPS * SUM
C
C NOW EVALUATE THE INFINITE SUM.     -----------------------------------
C
 70   ISTRT = 0
      IF (N.LT.1) ISTRT = 1 - N
      XI = ISTRT
C
      FACTOR = (-1.0)**N * GAMR(1.0+A-B) * X**ISTRT
      IF (BEPS.NE.0.0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI)
C
      POCHAI = POCH (A, XI)
      GAMRI1 = GAMR (XI+1.0)
      GAMRNI = GAMR (AINTB+XI)
      B0 = FACTOR * POCH(A,XI-BEPS) * GAMRNI * GAMR(XI+1.0-BEPS)
C
      IF (ABS(XTOEPS-1.0).GT.0.5) GO TO 90
C
C X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING
C THE DIFFERENCES
C
      PCH1AI = POCH1 (A+XI, -BEPS)
      PCH1I = POCH1 (XI+1.0-BEPS, BEPS)
      C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * (
     1  -POCH1(B+XI, -BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I )
C
C XEPS1 = (1.0 - X**(-BEPS)) / BEPS
      XEPS1 = ALNX * EXPREL(-BEPS*ALNX)
C
      CHU = SUM + C0 + XEPS1*B0
      XN = N
      DO 80 I=1,1000
        XI = ISTRT + I
        XI1 = ISTRT + I - 1
        B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS))
        C0 = (A+XI1)*C0*X/((B+XI1)*XI) - ((A-1.0)*(XN+2.*XI-1.0)
     1    + XI*(XI-BEPS)) * B0/(XI*(B+XI1)*(A+XI1-BEPS))
        T = C0 + XEPS1*B0
        CHU = CHU + T
        IF (ABS(T).LT.EPS*ABS(CHU)) GO TO 130
 80   CONTINUE
      CALL XERMSG ('SLATEC', 'CHU',
     +   'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2)
C
C X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD
C FORMULATION IS STABLE.
C
 90   A0 = FACTOR * POCHAI * GAMR(B+XI) * GAMRI1 / BEPS
      B0 = XTOEPS*B0/BEPS
C
      CHU = SUM + A0 - B0
      DO 100 I=1,1000
        XI = ISTRT + I
        XI1 = ISTRT + I - 1
        A0 = (A+XI1)*A0*X/((B+XI1)*XI)
        B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS))
        T = A0 - B0
        CHU = CHU + T
        IF (ABS(T).LT.EPS*ABS(CHU)) GO TO 130
 100  CONTINUE
      CALL XERMSG ('SLATEC', 'CHU',
     +   'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2)
C
C USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION.
C
 120  CHU = X**(-A) * R9CHU(A, B, X)
C
 130  RETURN
      END


c
c-----------------------------------------------------------------------
c subroutine:  ffs
c fast fourier synthesis subroutine
c radix 8-4-2
c-----------------------------------------------------------------------
c
      subroutine ffs(b, nfft)
c
c this subroutine synthesizes the real vector b(k), where
c k=1,2,...,n. the initial fourier coefficients are placed in
c the b array of size n+2.  the dc term is in b(1) with
c b(2) equal to 0.
c the jth harmonic is stored as b(2*j+1) + i b(2*j+2).
c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0.
c the subroutine is called as ffs(b,n) where n=2**m and
c b is the n term real array discussed above.
c
      dimension b(2)
      common /con1/ pii, p7, p7two, c22, s22, pi2
c
c iw is a machine dependent write device number
c
      iw = i1mach(2)
c
      pii = 4.*atan(1.)
      pi8 = pii/8.
      p7 = 1./sqrt(2.)
      p7two = 2.*p7
      c22 = cos(pi8)
      s22 = sin(pi8)
      pi2 = 2.*pii
      n = 1
      do 10 i=1,15
        m = i
        n = n*2
        if (n.eq.nfft) go to 20
  10  continue
      write (iw,9999)
9999  format (30h nfft not a power of 2 for ffs)
      stop
  20  continue
      b(2) = b(nfft+1)
      do 30 i=1,nfft
        b(i) = b(i)/float(nfft)
  30  continue
      do 40 i=4,nfft,2
        b(i) = -b(i)
  40  continue
      n8pow = m/3
c
c reorder the input fourier coefficients
c
      call ord2(m, b)
      call ord1(m, b)
c
      if (n8pow.eq.0) go to 60
c
c perform the radix 8 iterations
c
      nn = n
      do 50 it=1,n8pow
        int = n/nn
        call r8syn(int, nn, b, b(int+1), b(2*int+1), b(3*int+1),
     *      b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1),
     *      b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1),
     *      b(6*int+1), b(7*int+1))
        nn = nn/8
  50  continue
c
c do a radix 2 or radix 4 iteration if one is required
c
  60  if (m-n8pow*3-1) 90, 80, 70
  70  int = n/4
      call r4syn(int, b(1), b(int+1), b(2*int+1), b(3*int+1))
      go to 90
  80  int = n/2
      call r2tr(int, b(1), b(int+1))
  90  return
      end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   wav :    Periodic waves in an a nonlinear parabolic PDE
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION R

       R= U(2)/(PAR(5)+U(2)) * U(1)/(1+U(1)+PAR(6)*U(1)*U(1))
       F(1)=-PAR(1)*( PAR(4)*R - (PAR(2)-U(1)) )
       F(2)=-PAR(1)*( PAR(4)*R - PAR(7)*(PAR(3)-U(2)) )

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       PAR(1) = 3.0
       PAR(2) = 145
       PAR(3) = 500.
       PAR(4) = 210
       PAR(5) = 3.4
       PAR(6) = 0.023
       PAR(7) = 0.2

       U(1) = 6.27662E+01
       U(2) = 8.88308E+01

       PAR(10) = 0.05
       PAR(15) = 1.0
       PAR(16) = 5.0

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


PROGRAM A_PLUS_B
    INTEGER :: A, B
    READ(*,*) A, B

    WRITE(*,"(I0)") A+B
    WRITE(*,"(I0)") A-B
    WRITE(*,"(I0)") A*B
    WRITE(*,"(I0)") A/B
    WRITE(*,"(I0)") MOD(A,B)
END PROGRAM


      program tutorial
        implicit none

        ! character (len = 20) :: f_name, l_name
        ! print *, 'What's your name? '
        ! read *, f_name, l_name
        ! print *, 'Hello ', trim(l_name), ', ', trim(f_name)

        real, parameter :: PI = 3.14159265
        character (len = 20) :: s
        integer, dimension(5) :: nums
        integer, dimension(5, 5) :: mat
        integer, dimension(:), allocatable :: vararray
        integer :: n
        logical :: y = .true.
        integer :: i, j

        nums = (/1, 1, 2, 3, 5/)
        write(s, '(i0)') 666
        print '(5i2, 2i4, "; best number: ", a)', nums, 8, 13, s
        print '(3i2)', (nums(n), n=3,5)
        print '(3i2)', nums(3:5)
        print '(4i2)', size(mat), rank(mat), shape(mat)

        allocate(vararray(1:5))
        vararray(1:3) = nums(3:5)
        print '(5i2)', vararray

        do i = 0, 4
          j = 5 * i
          mat(:, i + 1) = (/j, j+1, j+2, j+3, j+4/)
        enddo

        print '(/, 25i4)', mat(::2, ::2)
        print '(5i4)', transpose(mat)

        print 100,
     &    mat(:, 1) * mat(:, 1),
     &    mat(:, 1) + mat(:, 1)
100     format(/, 'x*x: ', 5i3, /, '2*x: ', 5i3)

      end program tutorial


       program ch
       real a(1:100,1:100)
       real b(1:100)
       integer n
       do 10 j = 1,n
cvd$    concur
        do 20 i = max(1+1,j),n
         do 30 k = 1,min(j-1,i-1)
          a(i,j) = a(i,j)-a(i,k)*a(j,k)
   30    continue
   20   continue
        a(j,j) = sqrt(a(j,j))
cvd$    concur
        do 40 i = j+1,n
         a(i,j) = a(i,j)/a(j,j)
   40   continue
   10  continue
       end


!=======================================================================!
! Copyright (c) Intel Corporation - All rights reserved.                !
! This file is part of the LIBXSMM library.                             !
!                                                                       !
! For information on the license, see the LICENSE file.                 !
! Further information: https://github.com/hfp/libxsmm/                  !
! SPDX-License-Identifier: BSD-3-Clause                                 !
!=======================================================================!
! Hans Pabst (Intel Corp.)
!=======================================================================!
      PROGRAM hello
        USE :: LIBXSMM, ONLY: LIBXSMM_BLASINT_KIND,                     &
     &                        LIBXSMM_MMFUNCTION => LIBXSMM_DMMFUNCTION,&
     &                        libxsmm_mmdispatch => libxsmm_dmmdispatch,&
     &                        libxsmm_mmcall => libxsmm_dmmcall
        IMPLICIT NONE
        INTEGER, PARAMETER :: T = KIND(0D0)
        INTEGER :: batchsize = 1000, i
        INTEGER(LIBXSMM_BLASINT_KIND) :: j, ki
        INTEGER(LIBXSMM_BLASINT_KIND) :: m = 13, n = 5, k = 7
        REAL(T), ALLOCATABLE :: a(:,:,:), b(:,:,:), c(:,:)
        TYPE(LIBXSMM_MMFUNCTION) :: xmm

        ALLOCATE(a(m,k,batchsize), b(k,n,batchsize), c(m,n))
        ! initialize input
        DO i = 1, batchsize
          DO ki = 1, k
            DO j = 1, m
              a(j,ki,i) = REAL(1, T) / REAL(MOD(i+j+ki, 25), T)
            END DO
            DO j = 1, n
              b(ki,j,i) = REAL(7, T) / REAL(MOD(i+j+ki, 75), T)
            END DO
          END DO
        END DO
        c(:,:) = REAL(0, T)
        ! generates and dispatches a matrix multiplication kernel
        CALL libxsmm_mmdispatch(xmm, m, n, k,                           &
     &    alpha=REAL(1, T), beta=REAL(1, T))
        ! kernel multiplies and accumulates matrices: C += Ai * Bi
        DO i = 1, batchsize
          CALL libxsmm_mmcall(xmm, a(:,:,i), b(:,:,i), c)
        END DO
        DEALLOCATE(a, b, c)
      END PROGRAM


! MIT License
!
! Copyright (c) 2018 Anders Steen Christensen
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module ffchl_module

    implicit none

contains

pure function cut_function(r, cut_start, cut_distance) result(f)

    implicit none

    ! Distance
    double precision, intent(in) :: r

    ! Lower limit of damping
    double precision, intent(in) :: cut_start

    ! Upper limit of damping
    double precision, intent(in) :: cut_distance

    ! Intermediate variables
    double precision :: x
    double precision :: rl
    double precision :: ru

    ! Damping function at distance r
    double precision :: f

    ru = cut_distance
    rl = cut_start * cut_distance

    if (r > ru) then

        f = 0.0d0

    else if (r < rl) then

        f = 1.0d0

    else

        x = (ru - r) / (ru - rl)
        f = (10.0d0 * x**3) - (15.0d0 * x**4) + (6.0d0 * x**5)

    endif

end function cut_function

pure function get_angular_norm2(t_width) result(ang_norm2)

    implicit none

    ! Theta-width
    double precision, intent(in) :: t_width

    ! The resulting angular norm (squared)
    double precision ang_norm2

    ! Integration limit - bigger than 100 should suffice.
    integer, parameter :: limit = 10000

    ! Pi at double precision.
    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)

    integer :: n

    ang_norm2 = 0.0d0

    do n = -limit, limit
        ang_norm2 = ang_norm2 + exp(-((t_width * n)**2)) &
            & * (2.0d0 - 2.0d0 * cos(n * pi))
    end do

    ang_norm2 = sqrt(ang_norm2 * pi) * 2.0d0

end function

function get_twobody_weights(x, neighbors, power, cut_start, cut_distance, dim1) result(ksi)

    implicit none

    double precision, dimension(:,:), intent(in) :: x
    integer, intent(in) :: neighbors
    double precision, intent(in) :: power
    double precision, intent(in) :: cut_start
    double precision, intent(in) :: cut_distance
    integer, intent(in) :: dim1

    double precision, dimension(dim1) :: ksi
    integer :: i

    ksi = 0.0d0

    do i = 2, neighbors

        ksi(i) = cut_function(x(1, i), cut_start, cut_distance) / x(1, i)**power

    enddo

end function get_twobody_weights

! Calculate the Fourier terms for the FCHL three-body expansion
function get_threebody_fourier(x, neighbors, order, power, cut_start, cut_distance, &
    & dim1, dim2, dim3) result(fourier)

    implicit none

    ! Input representation, dimension=(5,n).
    double precision, dimension(:,:), intent(in) :: x

    ! Number of neighboring atoms to iterate over.
    integer, intent(in) :: neighbors

    ! Fourier-expansion order.
    integer, intent(in) :: order

    ! Power law
    double precision, intent(in) :: power

    ! Lower limit of damping function
    double precision, intent(in) :: cut_start

    ! Upper limit of damping function
    double precision, intent(in) :: cut_distance

    ! Dimensions or the output array.
    integer, intent(in) :: dim1, dim2, dim3

    ! dim(1,:,:,:) are cos terms, dim(2,:,:,:) are sine terms.
    double precision, dimension(2,dim1,dim2,dim3) :: fourier

    ! Pi at double precision.
    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)

    ! Internal counters.
    integer :: j, k, m

    ! Indexes for the periodic-table distance matrix.
    integer :: pj, pk

    ! Angle between atoms for the three-body term.
    double precision :: theta

    ! Three-body weight
    double precision :: ksi3

    ! Temporary variables for cos and sine Fourier terms.
    double precision :: cos_m, sin_m

    fourier = 0.0d0

    do j = 2, neighbors
        do k = j+1, neighbors

            ksi3 = calc_ksi3(X(:,:), j, k, power, cut_start, cut_distance)
            theta = calc_angle(x(3:5, j), x(3:5, 1), x(3:5, k))

            pj =  int(x(2,k))
            pk =  int(x(2,j))

            do m = 1, order

                cos_m = (cos(m * theta) - cos((theta + pi) * m))*ksi3
                sin_m = (sin(m * theta) - sin((theta + pi) * m))*ksi3

                fourier(1, pj, m, j) = fourier(1, pj, m, j) + cos_m
                fourier(2, pj, m, j) = fourier(2, pj, m, j) + sin_m

                fourier(1, pk, m, k) = fourier(1, pk, m, k) + cos_m
                fourier(2, pk, m, k) = fourier(2, pk, m, k) + sin_m

            enddo

        enddo
    enddo

    return

end function get_threebody_fourier

pure function calc_angle(a, b, c) result(angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle
    double precision :: angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

    ! Clipping
    if (cos_angle > 1.0d0) cos_angle = 1.0d0
    if (cos_angle < -1.0d0) cos_angle = -1.0d0

    angle = acos(cos_angle)

end function calc_angle

pure function calc_cos_angle(a, b, c) result(cos_angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

end function calc_cos_angle

function calc_ksi3(X, j, k, power, cut_start, cut_distance) result(ksi3)

    implicit none

    double precision, dimension(:,:), intent(in) :: X

    integer, intent(in) :: j
    integer, intent(in) :: k
    double precision, intent(in) :: power
    double precision, intent(in) :: cut_start
    double precision, intent(in) :: cut_distance

    double precision :: cos_i, cos_j, cos_k
    double precision :: di, dj, dk

    double precision :: ksi3
    double precision :: cut

    cos_i = calc_cos_angle(x(3:5, k), x(3:5, 1), x(3:5, j))
    cos_j = calc_cos_angle(x(3:5, j), x(3:5, k), x(3:5, 1))
    cos_k = calc_cos_angle(x(3:5, 1), x(3:5, j), x(3:5, k))

    dk = x(1, j)
    dj = x(1, k)
    di = norm2(x(3:5, j) - x(3:5, k))

    cut = cut_function(dk, cut_start, cut_distance) * &
        & cut_function(dj, cut_start, cut_distance) * &
        & cut_function(di, cut_start, cut_distance)

    ksi3 = cut * (1.0d0 + 3.0d0 * cos_i*cos_j*cos_k) / (di * dj * dk)**power

end function calc_ksi3

pure function scalar(X1, X2, N1, N2, ksi1, ksi2, sin1, sin2, cos1, cos2, &
    & t_width, d_width, cut_distance, order, pd, ang_norm2, &
    & distance_scale, angular_scale, alchemy) result(aadist)

    implicit none

    double precision, dimension(:,:), intent(in) :: X1
    double precision, dimension(:,:), intent(in) :: X2

    integer, intent(in) :: N1
    integer, intent(in) :: N2

    double precision, dimension(:), intent(in) :: ksi1
    double precision, dimension(:), intent(in) :: ksi2

    double precision, dimension(:,:,:), intent(in) :: sin1
    double precision, dimension(:,:,:), intent(in) :: sin2
    double precision, dimension(:,:,:), intent(in) :: cos1
    double precision, dimension(:,:,:), intent(in) :: cos2

    double precision, intent(in) :: t_width
    double precision, intent(in) :: d_width
    double precision, intent(in) :: cut_distance
    integer, intent(in) :: order
    double precision, dimension(:,:), intent(in) :: pd
    double precision, intent(in) :: angular_scale
    double precision, intent(in) :: distance_scale

    double precision :: true_angular_scale
    double precision :: true_distance_scale

    double precision, intent(in):: ang_norm2

    double precision :: aadist

    logical, intent(in) :: alchemy

    ! We changed the convention for the scaling factors when the paper was under review
    ! so this is a quick fix
    true_angular_scale = angular_scale / sqrt(8.0d0)
    true_distance_scale = distance_scale / 16.0d0

    if (alchemy) then
        aadist = scalar_alchemy(X1, X2, N1, N2, ksi1, ksi2, sin1, sin2, cos1, cos2, &
            & t_width, d_width, order, pd, ang_norm2, &
            & true_distance_scale, true_angular_scale)
    else
        aadist = scalar_noalchemy(X1, X2, N1, N2, ksi1, ksi2, sin1, sin2, cos1, cos2, &
            & t_width, d_width, ang_norm2, &
            & true_distance_scale, true_angular_scale)
    endif

end function scalar

pure function scalar_noalchemy(X1, X2, N1, N2, ksi1, ksi2, sin1, sin2, cos1, cos2, &
    & t_width, d_width, ang_norm2, &
    & distance_scale, angular_scale) result(aadist)

    implicit none

    double precision, dimension(:,:), intent(in) :: X1
    double precision, dimension(:,:), intent(in) :: X2

    integer, intent(in) :: N1
    integer, intent(in) :: N2

    double precision, dimension(:), intent(in) :: ksi1
    double precision, dimension(:), intent(in) :: ksi2

    double precision, dimension(:,:,:), intent(in) :: sin1
    double precision, dimension(:,:,:), intent(in) :: sin2
    double precision, dimension(:,:,:), intent(in) :: cos1
    double precision, dimension(:,:,:), intent(in) :: cos2

    double precision, intent(in) :: t_width
    double precision, intent(in) :: d_width

    double precision, intent(in) :: angular_scale
    double precision, intent(in) :: distance_scale

    double precision :: aadist

    double precision :: d

    integer :: i, j, p
    double precision :: angular
    double precision :: maxgausdist2

    integer :: pmax1
    integer :: pmax2
    integer :: pmax

    double precision :: inv_width
    double precision :: r2

    double precision :: s

    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)

    double precision :: g1

    logical, allocatable, dimension(:) :: mask1
    logical, allocatable, dimension(:) :: mask2

    double precision, intent(in):: ang_norm2

    ! cached sine and cos terms
    double precision, allocatable, dimension(:,:) :: cos1c, cos2c, sin1c, sin2c

    if (int(x1(2,1)) /= int(x2(2,1))) then
        aadist = 0.0d0
        return
    endif

    pmax1 = int(maxval(x1(2,:n1)))
    pmax2 = int(maxval(x2(2,:n2)))

    pmax = min(pmax1,pmax2)

    allocate(mask1(pmax1))
    allocate(mask2(pmax2))
    mask1 = .true.
    mask2 = .true.

    do i = 1, n1
        mask1(int(x1(2,i))) = .false.
    enddo

    do i = 1, n2
        mask2(int(x2(2,i))) = .false.
    enddo

    allocate(cos1c(pmax,n1))
    allocate(cos2c(pmax,n2))
    allocate(sin1c(pmax,n1))
    allocate(sin2c(pmax,n2))

    cos1c = 0.0d0
    cos2c = 0.0d0
    sin1c = 0.0d0
    sin2c = 0.0d0

    p = 0

    do i = 1, pmax
        if (mask1(i)) cycle
        if (mask2(i)) cycle

        p = p + 1

        cos1c(p,:n1) = cos1(i,1,:n1)
        cos2c(p,:n2) = cos2(i,1,:n2)
        sin1c(p,:n1) = sin1(i,1,:n1)
        sin2c(p,:n2) = sin2(i,1,:n2)

    enddo

    pmax = p

    ! Pre-computed constants
    g1 = sqrt(2.0d0 * pi)/ang_norm2
    s = g1 * exp(-(t_width)**2 / 2.0d0)
    inv_width = -1.0d0 / (4.0d0 * d_width**2)
    maxgausdist2 = (8.0d0 * d_width)**2

    ! Initialize scalar product
    aadist = 1.0d0

    do i = 2, n1
        do j = 2, n2

            if (int(x1(2,i)) /= int(x2(2,j))) cycle

            r2 = (x2(1,j) - x1(1,i))**2
            if (r2 >= maxgausdist2) cycle

            d = exp(r2 * inv_width)

            angular = (sum(cos1c(:pmax,i) * cos2c(:pmax,j)) &
                   & + sum(sin1c(:pmax,i) * sin2c(:pmax,j))) * s

            aadist = aadist + d * (ksi1(i) * ksi2(j) * distance_scale &
                & + angular * angular_scale)

        end do
    end do

    deallocate(mask1)
    deallocate(mask2)
    deallocate(cos1c)
    deallocate(cos2c)
    deallocate(sin1c)
    deallocate(sin2c)

end function scalar_noalchemy

pure function scalar_alchemy(X1, X2, N1, N2, ksi1, ksi2, sin1, sin2, cos1, cos2, &
    & t_width, d_width, order, pd, ang_norm2, &
    & distance_scale, angular_scale) result(aadist)

    implicit none

    double precision, dimension(:,:), intent(in) :: X1
    double precision, dimension(:,:), intent(in) :: X2

    integer, intent(in) :: N1
    integer, intent(in) :: N2

    double precision, dimension(:), intent(in) :: ksi1
    double precision, dimension(:), intent(in) :: ksi2

    double precision, dimension(:,:,:), intent(in) :: sin1
    double precision, dimension(:,:,:), intent(in) :: sin2
    double precision, dimension(:,:,:), intent(in) :: cos1
    double precision, dimension(:,:,:), intent(in) :: cos2

    double precision, intent(in) :: t_width
    double precision, intent(in) :: d_width
    ! double precision, intent(in) :: cut_distance
    integer, intent(in) :: order
    double precision, dimension(:,:), intent(in) :: pd
    double precision, intent(in) :: angular_scale
    double precision, intent(in) :: distance_scale

    double precision :: aadist

    double precision :: d

    integer :: m_1, m_2

    integer :: i, m, p1, p2

    double precision :: angular
    double precision :: maxgausdist2

    integer :: pmax1
    integer :: pmax2

    double precision :: inv_width
    double precision :: r2

    double precision, dimension(order) :: s

    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)

    double precision :: g1
    double precision :: a0

    logical, allocatable, dimension(:) :: mask1
    logical, allocatable, dimension(:) :: mask2

    double precision :: temp, sin1_temp, cos1_temp
    double precision, intent(in):: ang_norm2

    pmax1 = int(maxval(x1(2,:n1)))
    pmax2 = int(maxval(x2(2,:n2)))

    allocate(mask1(pmax1))
    allocate(mask2(pmax2))
    mask1 = .true.
    mask2 = .true.

    do i = 1, n1
        mask1(int(x1(2,i))) = .false.
    enddo

    do i = 1, n2
        mask2(int(x2(2,i))) = .false.
    enddo

    a0 = 0.0d0
    g1 = sqrt(2.0d0 * pi)/ang_norm2

    do m = 1, order
        s(m) = g1 * exp(-(t_width * m)**2 / 2.0d0)
    enddo

    inv_width = -1.0d0 / (4.0d0 * d_width**2)

    maxgausdist2 = (8.0d0 * d_width)**2

    aadist = 1.0d0

    do m_1 = 2, N1

        ! if (X1(1, m_1) > cut_distance) exit

        do m_2 = 2, N2

            ! if (X2(1, m_2) > cut_distance) exit

            r2 = (X2(1,m_2) - X1(1,m_1))**2

            if (r2 < maxgausdist2) then

                d = exp(r2 * inv_width ) * pd(int(x1(2,m_1)), int(x2(2,m_2)))

                angular = a0 * a0

                do m = 1, order

                    temp = 0.0d0

                    do p1 = 1, pmax1
                        if (mask1(p1)) cycle
                        cos1_temp = cos1(p1,m,m_1)
                        sin1_temp = sin1(p1,m,m_1)

                        do p2 = 1, pmax2
                            if (mask2(p2)) cycle

                            temp = temp + (cos1_temp * cos2(p2,m,m_2) &
                                & + sin1_temp * sin2(p2,m,m_2)) * pd(p2,p1)

                        enddo
                    enddo

                    angular = angular + temp * s(m)

                enddo

                aadist = aadist + d * (ksi1(m_1) * ksi2(m_2) * distance_scale &
                    & + angular * angular_scale)

            end if
        end do
    end do

    aadist = aadist * pd(int(x1(2,1)), int(x2(2,1)))

    deallocate(mask1)
    deallocate(mask2)
end function scalar_alchemy

end module ffchl_module


      SUBROUTINE PDGESVD(JOBU,JOBVT,M,N,A,IA,JA,DESCA,S,U,IU,JU,DESCU,
     +                   VT,IVT,JVT,DESCVT,WORK,LWORK,INFO)
*
*  -- ScaLAPACK routine (version 1.7) --
*     Univ. of Tennessee, Oak Ridge National Laboratory
*     and Univ. of California Berkeley.
*     Jan 2006

*
*     .. Scalar Arguments ..
      CHARACTER JOBU,JOBVT
      INTEGER IA,INFO,IU,IVT,JA,JU,JVT,LWORK,M,N
*     ..
*     .. Array Arguments ..
      INTEGER DESCA(*),DESCU(*),DESCVT(*)
      DOUBLE PRECISION A(*),U(*),VT(*),WORK(*)
      DOUBLE PRECISION S(*)
*     ..
*
*  Purpose
*  =======
*
*  PDGESVD computes the singular value decomposition (SVD) of an
*  M-by-N matrix A, optionally computing the left and/or right
*  singular vectors. The SVD is written as
*
*       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 orthogonal matrix, and
*  V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
*  are the singular values of A and the columns of U and V are the
*  corresponding right and left singular vectors, respectively. The
*  singular values are returned in array S in decreasing order and
*  only the first min(M,N) columns of U and rows of VT = V**T are
*  computed.
*
*  Notes
*  =====
*  Each global data object is described by an associated description
*  vector. This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix, and
*  assume that its process grid has dimension r x c. LOCr( K ) denotes
*  the number of elements of K that a process would receive if K were
*  distributed over the r processes of its process column. Similarly,
*  LOCc( K ) denotes the number of elements of K that a process would
*  receive if K were distributed over the c processes of its process
*  row. The values of LOCr() and LOCc() may be determined via a call
*  to the ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*          MP = number of local rows in A and U
*          NQ = number of local columns in A and VT
*          SIZE = min( M, N )
*          SIZEQ = number of local columns in U
*          SIZEP = number of local rows in VT
*
*  JOBU    (global input) CHARACTER*1
*          Specifies options for computing U:
*          = 'V':  the first SIZE columns of U (the left singular
*                  vectors) are returned in the array U;
*          = 'N':  no columns of U (no left singular vectors) are
*                  computed.
*
*  JOBVT   (global input) CHARACTER*1
*          Specifies options for computing V**T:
*          = 'V':  the first SIZE rows of V**T (the right singular
*                  vectors) are returned in the array VT;
*          = 'N':  no rows of V**T (no right singular vectors) are
*                  computed.
*
*  M       (global input) INTEGER
*          The number of rows of the input matrix A.  M >= 0.
*
*  N       (global input) INTEGER
*          The number of columns of the input matrix A.  N >= 0.
*
*  A       (local input/workspace) block cyclic DOUBLE PRECISION
*          array,
*          global dimension (M, N), local dimension (MP, NQ)
*          On exit, the contents of A are destroyed.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global input) INTEGER array of dimension DLEN_
*          The array descriptor for the distributed matrix A.
*
*  S       (global output) DOUBLE PRECISION   array, dimension SIZE
*          The singular values of A, sorted so that S(i) >= S(i+1).
*
*  U       (local output) DOUBLE PRECISION   array, local dimension
*          (MP, SIZEQ), global dimension (M, SIZE)
*          if JOBU = 'V', U contains the first min(m,n) columns of U
*          if JOBU = 'N', U is not referenced.
*
*  IU      (global input) INTEGER
*          The row index in the global array U indicating the first
*          row of sub( U ).
*
*  JU      (global input) INTEGER
*          The column index in the global array U indicating the
*          first column of sub( U ).
*
*  DESCU   (global input) INTEGER array of dimension DLEN_
*          The array descriptor for the distributed matrix U.
*
*  VT      (local output) DOUBLE PRECISION   array, local dimension
*          (SIZEP, NQ), global dimension (SIZE, N).
*          If JOBVT = 'V', VT contains the first SIZE rows of
*          V**T. If JOBVT = 'N', VT is not referenced.
*
*  IVT     (global input) INTEGER
*          The row index in the global array VT indicating the first
*          row of sub( VT ).
*
*  JVT     (global input) INTEGER
*          The column index in the global array VT indicating the
*          first column of sub( VT ).
*
*  DESCVT   (global input) INTEGER array of dimension DLEN_
*          The array descriptor for the distributed matrix VT.
*
*  WORK    (local workspace/output) DOUBLE PRECISION   array, dimension
*          (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (local input) INTEGER
*          The dimension of the array WORK.
*
*          LWORK >= 1 + 6*SIZEB + MAX(WATOBD, WBDTOSVD),
*
*          where SIZEB = MAX(M,N), and WATOBD and WBDTOSVD refer,
*          respectively, to the workspace required to bidiagonalize
*          the matrix A and to go from the bidiagonal matrix to the
*          singular value decomposition U*S*VT.
*
*          For WATOBD, the following holds:
*
*          WATOBD = MAX(MAX(WPDLANGE,WPDGEBRD),
*                       MAX(WPDLARED2D,WP(pre)LARED1D)),
*
*          where WPDLANGE, WPDLARED1D, WPDLARED2D, WPDGEBRD are the
*          workspaces required respectively for the subprograms
*          PDLANGE, PDLARED1D, PDLARED2D, PDGEBRD. Using the
*          standard notation
*
*          MP = NUMROC( M, MB, MYROW, DESCA( CTXT_ ), NPROW),
*          NQ = NUMROC( N, NB, MYCOL, DESCA( LLD_ ), NPCOL),
*
*          the workspaces required for the above subprograms are
*
*          WPDLANGE = MP,
*          WPDLARED1D = NQ0,
*          WPDLARED2D = MP0,
*          WPDGEBRD = NB*(MP + NQ + 1) + NQ,
*
*          where NQ0 and MP0 refer, respectively, to the values obtained
*          at MYCOL = 0 and MYROW = 0. In general, the upper limit for
*          the workspace is given by a workspace required on
*          processor (0,0):
*
*          WATOBD <= NB*(MP0 + NQ0 + 1) + NQ0.
*
*          In case of a homogeneous process grid this upper limit can
*          be used as an estimate of the minimum workspace for every
*          processor.
*
*          For WBDTOSVD, the following holds:
*
*          WBDTOSVD = SIZE*(WANTU*NRU + WANTVT*NCVT) +
*                     MAX(WDBDSQR,
*                         MAX(WANTU*WPDORMBRQLN, WANTVT*WPDORMBRPRT)),
*
*          where
*
*                          1, if left(right) singular vectors are wanted
*          WANTU(WANTVT) =
*                          0, otherwise
*
*          and WDBDSQR, WPDORMBRQLN and WPDORMBRPRT refer respectively
*          to the workspace required for the subprograms DBDSQR,
*          PDORMBR(QLN), and PDORMBR(PRT), where QLN and PRT are the
*          values of the arguments VECT, SIDE, and TRANS in the call
*          to PDORMBR. NRU is equal to the local number of rows of
*          the matrix U when distributed 1-dimensional "column" of
*          processes. Analogously, NCVT is equal to the local number
*          of columns of the matrix VT when distributed across
*          1-dimensional "row" of processes. Calling the LAPACK
*          procedure DBDSQR requires
*
*          WDBDSQR = MAX(1, 4*SIZE )
*
*          on every processor. Finally,
*
*          WPDORMBRQLN = MAX( (NB*(NB-1))/2, (SIZEQ+MP)*NB)+NB*NB,
*          WPDORMBRPRT = MAX( (MB*(MB-1))/2, (SIZEP+NQ)*MB )+MB*MB,
*
*          If LWORK = -1, then LWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          size for the work array. The required workspace is returned
*          as the first element of WORK and no error message is issued
*          by PXERBLA.
*
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value

*          > 0:  if DBDSQR did not converge
*                If INFO = MIN(M,N) + 1, then PDGESVD has detected
*                heterogeneity by finding that eigenvalues were not
*                identical across the process grid. In this case, the
*                accuracy of the results from PDGESVD cannot be
*                guaranteed.
*
*  =====================================================================
*
*  The results of PDGEBRD, and therefore PDGESVD, may vary slightly
*  from run to run with the same input data. If repeatability is an
*  issue, call BLACS_SET with the appropriate option after defining
*  the process grid.
*
*  Alignment requirements
*  ======================
*
*  The routine PDGESVD inherits the same alignement requirement as
*  the routine PDGEBRD, namely:
*
*  The distributed submatrix sub( A ) must verify some alignment proper-
*  ties, namely the following expressions should be true:
*  ( MB_A.EQ.NB_A .AND. IROFFA.EQ.ICOFFA )
*          where NB = MB_A = NB_A,
*          IROFFA = MOD( IA-1, NB ), ICOFFA = MOD( JA-1, NB ),
*
*  =====================================================================
*
*
*     .. Parameters ..
      INTEGER BLOCK_CYCLIC_2D,DLEN_,DTYPE_,CTXT_,M_,N_,MB_,NB_,RSRC_,
     +        CSRC_,LLD_,ITHVAL
      PARAMETER (BLOCK_CYCLIC_2D=1,DLEN_=9,DTYPE_=1,CTXT_=2,M_=3,N_=4,
     +          MB_=5,NB_=6,RSRC_=7,CSRC_=8,LLD_=9,ITHVAL=10)
      DOUBLE PRECISION ZERO,ONE
      PARAMETER (ZERO= (0.0D+0),ONE= (1.0D+0))
*     ..
*     .. Local Scalars ..
      CHARACTER UPLO
      INTEGER CONTEXTC,CONTEXTR,I,INDD,INDD2,INDE,INDE2,INDTAUP,INDTAUQ,
     +        INDU,INDV,INDWORK,IOFFD,IOFFE,ISCALE,J,K,LDU,LDVT,LLWORK,
     +        LWMIN,MAXIM,MB,MP,MYPCOL,MYPCOLC,MYPCOLR,MYPROW,MYPROWC,
     +        MYPROWR,NB,NCVT,NPCOL,NPCOLC,NPCOLR,NPROCS,NPROW,NPROWC,
     +        NPROWR,NQ,NRU,SIZE,SIZEB,SIZEP,SIZEPOS,SIZEQ,WANTU,WANTVT,
     +        WATOBD,WBDTOSVD,WDBDSQR,WPDGEBRD,WPDLANGE,WPDORMBRPRT,
     +        WPDORMBRQLN
      DOUBLE PRECISION ANRM,BIGNUM,EPS,RMAX,RMIN,SAFMIN,SIGMA,SMLNUM
*     ..
*     .. Local Arrays ..
      INTEGER DESCTU(DLEN_),DESCTVT(DLEN_),IDUM1(3),IDUM2(3)
      DOUBLE PRECISION C(1,1)
*     ..
*     .. External Functions ..
      LOGICAL LSAME
      INTEGER NUMROC
      DOUBLE PRECISION PDLAMCH,PDLANGE
      EXTERNAL LSAME,NUMROC,PDLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL BLACS_GET,BLACS_GRIDEXIT,BLACS_GRIDINFO,BLACS_GRIDINIT,
     +         CHK1MAT,DBDSQR,DESCINIT,DGAMN2D,DGAMX2D,DSCAL,IGAMX2D,
     +         IGEBR2D,IGEBS2D,PCHK1MAT,PDGEBRD,PDGEMR2D,PDLARED1D,
     +         PDLARED2D,PDLASCL,PDLASET,PDORMBR,PXERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX,MIN,SQRT,DBLE
*     ..
*     .. Executable Statements ..
*     This is just to keep ftnchek happy
      IF (BLOCK_CYCLIC_2D*DTYPE_*LLD_*MB_*M_*NB_*N_.LT.0) RETURN
*
      CALL BLACS_GRIDINFO(DESCA(CTXT_),NPROW,NPCOL,MYPROW,MYPCOL)
      ISCALE = 0
      INFO = 0
*
      IF (NPROW.EQ.-1) THEN
          INFO = - (800+CTXT_)
      ELSE
*
          SIZE = MIN(M,N)
          SIZEB = MAX(M,N)
          NPROCS = NPROW*NPCOL
          IF (M.GE.N) THEN
              IOFFD = JA - 1
              IOFFE = IA - 1
              SIZEPOS = 1
          ELSE
              IOFFD = IA - 1
              IOFFE = JA - 1
              SIZEPOS = 3
          END IF
*
          IF (LSAME(JOBU,'V')) THEN
              WANTU = 1
          ELSE
              WANTU = 0
          END IF
          IF (LSAME(JOBVT,'V')) THEN
              WANTVT = 1
          ELSE
              WANTVT = 0
          END IF
*
          CALL CHK1MAT(M,3,N,4,IA,JA,DESCA,8,INFO)
          IF (WANTU.EQ.1) THEN
              CALL CHK1MAT(M,3,SIZE,SIZEPOS,IU,JU,DESCU,13,INFO)
          END IF
          IF (WANTVT.EQ.1) THEN
              CALL CHK1MAT(SIZE,SIZEPOS,N,4,IVT,JVT,DESCVT,17,INFO)
          END IF
          CALL IGAMX2D(DESCA(CTXT_),'A',' ',1,1,INFO,1,1,1,-1,-1,0)
*
          IF (INFO.EQ.0) THEN
*
*           Set up pointers into the WORK array.
*
              INDD = 2
              INDE = INDD + SIZEB + IOFFD
              INDD2 = INDE + SIZEB + IOFFE
              INDE2 = INDD2 + SIZEB + IOFFD
*
              INDTAUQ = INDE2 + SIZEB + IOFFE
              INDTAUP = INDTAUQ + SIZEB + JA - 1
              INDWORK = INDTAUP + SIZEB + IA - 1
              LLWORK = LWORK - INDWORK + 1
*
*           Initialize contexts for "column" and "row" process matrices.
*
              CALL BLACS_GET(DESCA(CTXT_),10,CONTEXTC)
              CALL BLACS_GRIDINIT(CONTEXTC,'R',NPROCS,1)
              CALL BLACS_GRIDINFO(CONTEXTC,NPROWC,NPCOLC,MYPROWC,
     +                            MYPCOLC)
              CALL BLACS_GET(DESCA(CTXT_),10,CONTEXTR)
              CALL BLACS_GRIDINIT(CONTEXTR,'R',1,NPROCS)
              CALL BLACS_GRIDINFO(CONTEXTR,NPROWR,NPCOLR,MYPROWR,
     +                            MYPCOLR)
*
*           Set local dimensions of matrices (this is for MB=NB=1).
*
              NRU = NUMROC(M,1,MYPROWC,0,NPROCS)
              NCVT = NUMROC(N,1,MYPCOLR,0,NPROCS)
              NB = DESCA(NB_)
              MB = DESCA(MB_)
              MP = NUMROC(M,MB,MYPROW,DESCA(RSRC_),NPROW)
              NQ = NUMROC(N,NB,MYPCOL,DESCA(CSRC_),NPCOL)
              IF (WANTVT.EQ.1) THEN
                  SIZEP = NUMROC(SIZE,DESCVT(MB_),MYPROW,DESCVT(RSRC_),
     +                    NPROW)
              ELSE
                  SIZEP = 0
              END IF
              IF (WANTU.EQ.1) THEN
                  SIZEQ = NUMROC(SIZE,DESCU(NB_),MYPCOL,DESCU(CSRC_),
     +                    NPCOL)
              ELSE
                  SIZEQ = 0
              END IF
*
*           Transmit MAX(NQ0, MP0).
*
              IF (MYPROW.EQ.0 .AND. MYPCOL.EQ.0) THEN
                  MAXIM = MAX(NQ,MP)
                  CALL IGEBS2D(DESCA(CTXT_),'All',' ',1,1,MAXIM,1)
              ELSE
                  CALL IGEBR2D(DESCA(CTXT_),'All',' ',1,1,MAXIM,1,0,0)
              END IF
*
              WPDLANGE = MP
              WPDGEBRD = NB* (MP+NQ+1) + NQ
              WATOBD = MAX(MAX(WPDLANGE,WPDGEBRD),MAXIM)
*
              WDBDSQR = MAX(1,4*SIZE)
              WPDORMBRQLN = MAX((NB* (NB-1))/2, (SIZEQ+MP)*NB) + NB*NB
              WPDORMBRPRT = MAX((MB* (MB-1))/2, (SIZEP+NQ)*MB) + MB*MB
              WBDTOSVD = SIZE* (WANTU*NRU+WANTVT*NCVT) +
     +                   MAX(WDBDSQR,MAX(WANTU*WPDORMBRQLN,
     +                   WANTVT*WPDORMBRPRT))
*
*           Finally, calculate required workspace.
*
              LWMIN = 1 + 6*SIZEB + MAX(WATOBD,WBDTOSVD)
              WORK(1) = DBLE(LWMIN)
*
              IF (WANTU.NE.1 .AND. .NOT. (LSAME(JOBU,'N'))) THEN
                  INFO = -1
              ELSE IF (WANTVT.NE.1 .AND. .NOT. (LSAME(JOBVT,'N'))) THEN
                  INFO = -2
              ELSE IF (LWORK.LT.LWMIN .AND. LWORK.NE.-1) THEN
                  INFO = -19
              END IF
*
          END IF
*
          IDUM1(1) = WANTU
          IDUM1(2) = WANTVT
          IF (LWORK.EQ.-1) THEN
              IDUM1(3) = -1
          ELSE
              IDUM1(3) = 1
          END IF
          IDUM2(1) = 1
          IDUM2(2) = 2
          IDUM2(3) = 19
          CALL PCHK1MAT(M,3,N,4,IA,JA,DESCA,8,3,IDUM1,IDUM2,INFO)
          IF (INFO.EQ.0) THEN
              IF (WANTU.EQ.1) THEN
                  CALL PCHK1MAT(M,3,SIZE,4,IU,JU,DESCU,13,0,IDUM1,IDUM2,
     +                          INFO)
              END IF
              IF (WANTVT.EQ.1) THEN
                  CALL PCHK1MAT(SIZE,3,N,4,IVT,JVT,DESCVT,17,0,IDUM1,
     +                          IDUM2,INFO)
              END IF
          END IF
*
      END IF
*
      IF (INFO.NE.0) THEN
          CALL PXERBLA(DESCA(CTXT_),'PDGESVD',-INFO)
          RETURN
      ELSE IF (LWORK.EQ.-1) THEN
          GO TO 40
      END IF
*
*     Quick return if possible.
*
      IF (M.LE.0 .OR. N.LE.0) GO TO 40
*
*     Get machine constants.
*
      SAFMIN = PDLAMCH(DESCA(CTXT_),'Safe minimum')
      EPS = PDLAMCH(DESCA(CTXT_),'Precision')
      SMLNUM = SAFMIN/EPS
      BIGNUM = ONE/SMLNUM
      RMIN = SQRT(SMLNUM)
      RMAX = MIN(SQRT(BIGNUM),ONE/SQRT(SQRT(SAFMIN)))
*
*     Scale matrix to allowable range, if necessary.
*
      ANRM = PDLANGE('1',M,N,A,IA,JA,DESCA,WORK(INDWORK))
      IF (ANRM.GT.ZERO .AND. ANRM.LT.RMIN) THEN
          ISCALE = 1
          SIGMA = RMIN/ANRM
      ELSE IF (ANRM.GT.RMAX) THEN
          ISCALE = 1
          SIGMA = RMAX/ANRM
      END IF
*
      IF (ISCALE.EQ.1) THEN
          CALL PDLASCL('G',ONE,SIGMA,M,N,A,IA,JA,DESCA,INFO)
      END IF
*
      CALL PDGEBRD(M,N,A,IA,JA,DESCA,WORK(INDD),WORK(INDE),
     +             WORK(INDTAUQ),WORK(INDTAUP),WORK(INDWORK),LLWORK,
     +             INFO)
*
*     Copy D and E to all processes.
*     Array D is in local array of dimension:
*     LOCc(JA+MIN(M,N)-1) if M >= N; LOCr(IA+MIN(M,N)-1) otherwise.
*     Array E is in local array of dimension
*     LOCr(IA+MIN(M,N)-1) if M >= N; LOCc(JA+MIN(M,N)-2) otherwise.
*
      IF (M.GE.N) THEN
*        Distribute D
          CALL PDLARED1D(N+IOFFD,IA,JA,DESCA,WORK(INDD),WORK(INDD2),
     +                   WORK(INDWORK),LLWORK)
*        Distribute E
          CALL PDLARED2D(M+IOFFE,IA,JA,DESCA,WORK(INDE),WORK(INDE2),
     +                   WORK(INDWORK),LLWORK)
      ELSE
*        Distribute D
          CALL PDLARED2D(M+IOFFD,IA,JA,DESCA,WORK(INDD),WORK(INDD2),
     +                   WORK(INDWORK),LLWORK)
*        Distribute E
          CALL PDLARED1D(N+IOFFE,IA,JA,DESCA,WORK(INDE),WORK(INDE2),
     +                   WORK(INDWORK),LLWORK)
      END IF
*
*     Prepare for calling PDBDSQR.
*
      IF (M.GE.N) THEN
          UPLO = 'U'
      ELSE
          UPLO = 'L'
      END IF
*
      INDU = INDWORK
      INDV = INDU + SIZE*NRU*WANTU
      INDWORK = INDV + SIZE*NCVT*WANTVT
*
      LDU = MAX(1,NRU)
      LDVT = MAX(1,SIZE)
*
      CALL DESCINIT(DESCTU,M,SIZE,1,1,0,0,CONTEXTC,LDU,INFO)
      CALL DESCINIT(DESCTVT,SIZE,N,1,1,0,0,CONTEXTR,LDVT,INFO)
*
      IF (WANTU.EQ.1) THEN
          CALL PDLASET('Full',M,SIZE,ZERO,ONE,WORK(INDU),1,1,DESCTU)
      ELSE
          NRU = 0
      END IF
*
      IF (WANTVT.EQ.1) THEN
          CALL PDLASET('Full',SIZE,N,ZERO,ONE,WORK(INDV),1,1,DESCTVT)
      ELSE
          NCVT = 0
      END IF
*
      CALL DBDSQR(UPLO,SIZE,NCVT,NRU,0,WORK(INDD2+IOFFD),
     +            WORK(INDE2+IOFFE),WORK(INDV),SIZE,WORK(INDU),LDU,C,1,
     +            WORK(INDWORK),INFO)
*
*     Redistribute elements of U and VT in the block-cyclic fashion.
*
      IF (WANTU.EQ.1) CALL PDGEMR2D(M,SIZE,WORK(INDU),1,1,DESCTU,U,IU,
     +                              JU,DESCU,DESCU(CTXT_))
*
      IF (WANTVT.EQ.1) CALL PDGEMR2D(SIZE,N,WORK(INDV),1,1,DESCTVT,VT,
     +                               IVT,JVT,DESCVT,DESCVT(CTXT_))
*
*     Set to ZERO "non-square" elements of the larger matrices U, VT.
*
      IF (M.GT.N .AND. WANTU.EQ.1) THEN
          CALL PDLASET('Full',M-SIZE,SIZE,ZERO,ZERO,U,IA+SIZE,JU,DESCU)
      ELSE IF (N.GT.M .AND. WANTVT.EQ.1) THEN
          CALL PDLASET('Full',SIZE,N-SIZE,ZERO,ZERO,VT,IVT,JVT+SIZE,
     +                 DESCVT)
      END IF
*
*     Multiply Householder rotations from bidiagonalized matrix.
*
      IF (WANTU.EQ.1) CALL PDORMBR('Q','L','N',M,SIZE,N,A,IA,JA,DESCA,
     +                             WORK(INDTAUQ),U,IU,JU,DESCU,
     +                             WORK(INDWORK),LLWORK,INFO)
*
      IF (WANTVT.EQ.1) CALL PDORMBR('P','R','T',SIZE,N,M,A,IA,JA,DESCA,
     +                              WORK(INDTAUP),VT,IVT,JVT,DESCVT,
     +                              WORK(INDWORK),LLWORK,INFO)
*
*     Copy singular values into output array S.
*
      DO 10 I = 1,SIZE
          S(I) = WORK(INDD2+IOFFD+I-1)
   10 CONTINUE
*
*     If matrix was scaled, then rescale singular values appropriately.
*
      IF (ISCALE.EQ.1) THEN
          CALL DSCAL(SIZE,ONE/SIGMA,S,1)
      END IF
*
*     Compare every ith eigenvalue, or all if there are only a few,
*     across the process grid to check for heterogeneity.
*
      IF (SIZE.LE.ITHVAL) THEN
          J = SIZE
          K = 1
      ELSE
          J = SIZE/ITHVAL
          K = ITHVAL
      END IF
*
      DO 20 I = 1,J
          WORK(I+INDE) = S((I-1)*K+1)
          WORK(I+INDD2) = S((I-1)*K+1)
   20 CONTINUE
*
      CALL DGAMN2D(DESCA(CTXT_),'a',' ',J,1,WORK(1+INDE),J,1,1,-1,-1,0)
      CALL DGAMX2D(DESCA(CTXT_),'a',' ',J,1,WORK(1+INDD2),J,1,1,-1,-1,0)
*
      DO 30 I = 1,J
          IF ((WORK(I+INDE)-WORK(I+INDD2)).NE.ZERO) THEN
              INFO = SIZE + 1
          END IF
   30 CONTINUE
*
   40 CONTINUE
*
      CALL BLACS_GRIDEXIT(CONTEXTC)
      CALL BLACS_GRIDEXIT(CONTEXTR)
*
*     End of PDGESVD
*
      RETURN
      END


      SUBROUTINE DPHYBRID(P0,HYA,HYB,PSFC,MLON,NLAT,KLEV,PHY,PMSG)

c NCL: phy = pres_hybrid_ccm (psfc,p0,hya,hyb)

c this routine interploates ccm2/3 hybrid coordinate data
c     to pressure coordinates.

c     formula for the pressure of a hybrid surface is;
c          phy(k) = hya(k)*p0 + hyb(k)*psfc

c     input
c          hya    - is the "a" or pressure hybrid coef
c          hyb    - is the "b" or sigma coeficient
c          p0     - is the base pressure in pascals [Pa]
c          psfc   - is the surface pressure in pascals [Pa]
c          mlon   - longitude dimension
c          nlat   - latitude  dimension
c          klev   - number of levels
c     output
c          phy    - pressure at hybrid levels [Pa]

      IMPLICIT NONE
      INTEGER MLON,NLAT,KLEV
      DOUBLE PRECISION P0,HYA(KLEV),HYB(KLEV),PSFC(MLON,NLAT),PMSG

      DOUBLE PRECISION PHY(MLON,NLAT,KLEV)

      INTEGER KL,NL,ML
c f77
      DO KL = 1,KLEV
          DO NL = 1,NLAT
              DO ML = 1,MLON
                 IF (PSFC(ML,NL).NE.PMSG) then
                     PHY(ML,NL,KL) = HYA(KL)*P0 + HYB(KL)*PSFC(ML,NL)
                 ELSE
                     PHY(ML,NL,KL) = PMSG
                 END IF
              END DO
          END DO
      END DO

c f90 do kl=1,klev
c f90    phy(:,:,kl) = hya(kl)*p0 + hyb(kl)*psfc(:,:)
c f90 end do

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DDPHYBRID(P0,HYA,HYB,PSFC,MLON,NLAT,KLEV,DPHY,PMSG)
      IMPLICIT NONE

c input
      INTEGER MLON,NLAT,KLEV
      DOUBLE PRECISION P0,HYA(KLEV),HYB(KLEV),PSFC(MLON,NLAT),PMSG
c output
      DOUBLE PRECISION DPHY(MLON,NLAT,KLEV-1)
C NCLEND

c NCL: dphy = dpres_hybrid_ccm (ps,p0,hyai,hybi)
c Note: dphy will have one less vertical level

c this routine interploates ccm2/3 hybrid coordinate data
c     to pressure coordinates. then it computes

c     formula for the pressure of a hybrid surface is;
c          phy(k) = hya(k)*p0 + hyb(k)*psfc

c     input
c          hya    - is the "a" or pressure hybrid coef
c          hyb    - is the "b" or sigma coeficient
c          p0     - is the base pressure in pascals [Pa]
c          psfc   - is the surface pressure in pascals [Pa]
c          mlon   - longitude dimension
c          nlat   - latitude  dimension
c          klev   - number of levels
c     output
c          dphy    - delta pressure [Pa; always positive]

c local
      INTEGER KL,NL,ML
      DOUBLE PRECISION PA,PB

      DO NL = 1,NLAT
          DO ML = 1,MLON
              DO KL = 1,KLEV - 1
                 IF (PSFC(ML,NL).NE.PMSG) then
                     PA = P0*HYA(KL)   + HYB(KL)*PSFC(ML,NL)
                     PB = P0*HYA(KL+1) + HYB(KL+1)*PSFC(ML,NL)
                     DPHY(ML,NL,KL) = ABS(PB-PA)
c c c       dphy(ml,nl,kl) = abs((hya(kl+1)-hya(kl))*p0
c c c*                     -     (hyb(kl+1)-hya(kl))*psfc(ml,nl))
                 ELSE
                     DPHY(ML,NL,KL) = PMSG
                 END IF
              END DO
          END DO
      END DO

      RETURN
      END


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 20 node
!!      hexahedral element  (Serendipity  interpolation)
module shape_hex20n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_hex20n(localcoord,func)
    real(kind=kreal) :: localcoord(3)
    real(kind=kreal) :: func(20)
    real(kind=kreal) RI,SI,TI,RP,SP,TP,RM,SM,TM
    RI=localcoord(1);  SI=localcoord(2);  TI=localcoord(3)
    RP=1.0+RI; SP=1.0+SI; TP=1.0+TI
    RM=1.0-RI; SM=1.0-SI; TM=1.0-TI
    func(1)=-0.125*RM*SM*TM*(2.0+RI+SI+TI)
    func(2)=-0.125*RP*SM*TM*(2.0-RI+SI+TI)
    func(3)=-0.125*RP*SP*TM*(2.0-RI-SI+TI)
    func(4)=-0.125*RM*SP*TM*(2.0+RI-SI+TI)
    func(5)=-0.125*RM*SM*TP*(2.0+RI+SI-TI)
    func(6)=-0.125*RP*SM*TP*(2.0-RI+SI-TI)
    func(7)=-0.125*RP*SP*TP*(2.0-RI-SI-TI)
    func(8)=-0.125*RM*SP*TP*(2.0+RI-SI-TI)
    func(9)=0.25*(1.0-RI**2)*SM*TM
    func(10)=0.25*RP*(1.0-SI**2)*TM
    func(11)=0.25*(1.0-RI**2)*SP*TM
    func(12)=0.25*RM*(1.0-SI**2)*TM
    func(13)=0.25*(1.0-RI**2)*SM*TP
    func(14)=0.25*RP*(1.0-SI**2)*TP
    func(15)=0.25*(1.0-RI**2)*SP*TP
    func(16)=0.25*RM*(1.0-SI**2)*TP
    func(17)=0.25*RM*SM*(1.0-TI**2)
    func(18)=0.25*RP*SM*(1.0-TI**2)
    func(19)=0.25*RP*SP*(1.0-TI**2)
    func(20)=0.25*RM*SP*(1.0-TI**2)
  end subroutine

  subroutine ShapeDeriv_hex20n(localcoord,func)
    real(kind=kreal) :: localcoord(3)
    real(kind=kreal) :: func(20,3)
    real(kind=kreal) RI,SI,TI,RP,SP,TP,RM,SM,TM
    RI=localcoord(1);  SI=localcoord(2);  TI=localcoord(3)
    RP=1.d0+RI; SP=1.d0+SI; TP=1.d0+TI
    RM=1.d0-RI; SM=1.d0-SI; TM=1.d0-TI
    !  FOR R-COORDINATE
    func(1,1)=-0.125*RM*SM*TM+0.125*SM*TM*(2.0+RI+SI+TI)
    func(2,1)=+0.125*RP*SM*TM-0.125*SM*TM*(2.0-RI+SI+TI)
    func(3,1)=+0.125*RP*SP*TM-0.125*SP*TM*(2.0-RI-SI+TI)
    func(4,1)=-0.125*RM*SP*TM+0.125*SP*TM*(2.0+RI-SI+TI)
    func(5,1)=-0.125*RM*SM*TP+0.125*SM*TP*(2.0+RI+SI-TI)
    func(6,1)=+0.125*RP*SM*TP-0.125*SM*TP*(2.0-RI+SI-TI)
    func(7,1)=+0.125*RP*SP*TP-0.125*SP*TP*(2.0-RI-SI-TI)
    func(8,1)=-0.125*RM*SP*TP+0.125*SP*TP*(2.0+RI-SI-TI)
    func(9,1 )=-0.50*RI*SM*TM
    func(10,1)=+0.25*(1.0-SI**2)*TM
    func(11,1)=-0.50*RI*SP*TM
    func(12,1)=-0.25*(1.0-SI**2)*TM
    func(13,1)=-0.50*RI*SM*TP
    func(14,1)=+0.25*(1.0-SI**2)*TP
    func(15,1)=-0.50*RI*SP*TP
    func(16,1)=-0.25*(1.0-SI**2)*TP
    func(17,1)=-0.25*SM*(1.0-TI**2)
    func(18,1)=+0.25*SM*(1.0-TI**2)
    func(19,1)=+0.25*SP*(1.0-TI**2)
    func(20,1)=-0.25*SP*(1.0-TI**2)
    !  FOR S-COORDINATE
    func(1,2)=-0.125*RM*SM*TM+0.125*RM*TM*(2.0+RI+SI+TI)
    func(2,2)=-0.125*RP*SM*TM+0.125*RP*TM*(2.0-RI+SI+TI)
    func(3,2)=+0.125*RP*SP*TM-0.125*RP*TM*(2.0-RI-SI+TI)
    func(4,2)=+0.125*RM*SP*TM-0.125*RM*TM*(2.0+RI-SI+TI)
    func(5,2)=-0.125*RM*SM*TP+0.125*RM*TP*(2.0+RI+SI-TI)
    func(6,2)=-0.125*RP*SM*TP+0.125*RP*TP*(2.0-RI+SI-TI)
    func(7,2)=+0.125*RP*SP*TP-0.125*RP*TP*(2.0-RI-SI-TI)
    func(8,2)=+0.125*RM*SP*TP-0.125*RM*TP*(2.0+RI-SI-TI)
    func(9,2)=-0.25*(1.0-RI**2)*TM
    func(10,2)=-0.50*RP*SI*TM
    func(11,2)=+0.25*(1.0-RI**2)*TM
    func(12,2)=-0.50*RM*SI*TM
    func(13,2)=-0.25*(1.0-RI**2)*TP
    func(14,2)=-0.50*RP*SI*TP
    func(15,2)=+0.25*(1.0-RI**2)*TP
    func(16,2)=-0.50*RM*SI*TP
    func(17,2)=-0.25*RM*(1.0-TI**2)
    func(18,2)=-0.25*RP*(1.0-TI**2)
    func(19,2)=+0.25*RP*(1.0-TI**2)
    func(20,2)=+0.25*RM*(1.0-TI**2)
    !  FOR T-COORDINATE
    func(1,3)=-0.125*RM*SM*TM+0.125*RM*SM*(2.0+RI+SI+TI)
    func(2,3)=-0.125*RP*SM*TM+0.125*RP*SM*(2.0-RI+SI+TI)
    func(3,3)=-0.125*RP*SP*TM+0.125*RP*SP*(2.0-RI-SI+TI)
    func(4,3)=-0.125*RM*SP*TM+0.125*RM*SP*(2.0+RI-SI+TI)
    func(5,3)=+0.125*RM*SM*TP-0.125*RM*SM*(2.0+RI+SI-TI)
    func(6,3)=+0.125*RP*SM*TP-0.125*RP*SM*(2.0-RI+SI-TI)
    func(7,3)=+0.125*RP*SP*TP-0.125*RP*SP*(2.0-RI-SI-TI)
    func(8,3)=+0.125*RM*SP*TP-0.125*RM*SP*(2.0+RI-SI-TI)
    func(9,3)=-0.25*(1.0-RI**2)*SM
    func(10,3)=-0.25*RP*(1.0-SI**2)
    func(11,3)=-0.25*(1.0-RI**2)*SP
    func(12,3)=-0.25*RM*(1.0-SI**2)
    func(13,3)=0.25*(1.0-RI**2)*SM
    func(14,3)=0.25*RP*(1.0-SI**2)
    func(15,3)=0.25*(1.0-RI**2)*SP
    func(16,3)=0.25*RM*(1.0-SI**2)
    func(17,3)=-0.5*RM*SM*TI
    func(18,3)=-0.5*RP*SM*TI
    func(19,3)=-0.5*RP*SP*TI
    func(20,3)=-0.5*RM*SP*TI
  end subroutine

end module


! ------------------------------------------------------------------ DK80eq2PDF
      FUNCTION DK80eq2PDF(pf,q,anz)

! The PDF corresponding to DK80 eq. 2, using analytic derivatives
! Dates: 06/24/14 - Written by D. Boore, DK80eq2

      REAL pf, q, sqrtpidiv2, qe, anz

      sqrtpidiv2 = sqrt(2.0*atan(1.0))

      qe = q**1.2     ! l. 2 below eq. 2 in DK(1980)

      e1 = exp(-0.5*pf**2)
      e2 = exp(-sqrtpidiv2*qe*pf)

      A = (1.0-e1)
      B = (1.0-e2)
      C = A/e1
      E = exp(-anz*B/C)

      dAda = pf * e1
      dBda = sqrtpidiv2*qe*e2
      dCda = pf/e1

      dEda = -anz*E*(C*dBda - B*dCda)/C**2

      DK80eq2PDF = A*dEda + E*dAda

      END
! ------------------------------------------------------------------ DK80eq2PDF