      SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X either the reduced generalized continuous-time
C     Lyapunov equation
C
C         T            T
C        A  * X * E + E  * X * A  =  SCALE * Y                       (1)
C
C     or
C
C                 T            T
C        A * X * E  + E * X * A   =  SCALE * Y                       (2)
C
C     where the right hand side Y is symmetric. A, E, Y, and the
C     solution X are N-by-N matrices. The pencil A - lambda * E must be
C     in generalized Schur form (A upper quasitriangular, E upper
C     triangular). SCALE is an output scale factor, set to avoid
C     overflow in X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANS   CHARACTER*1
C             Specifies whether the transposed equation is to be solved
C             or not:
C             = 'N':  Solve equation (1);
C             = 'T':  Solve equation (2).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N upper Hessenberg part of this array
C             must contain the quasitriangular matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             The leading N-by-N upper triangular part of this array
C             must contain the matrix E.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, the leading N-by-N part of this array must
C             contain the right hand side matrix Y of the equation. Only
C             the upper triangular part of this matrix need be given.
C             On exit, the leading N-by-N part of this array contains
C             the solution matrix X of the equation.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= MAX(1,N).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor set to avoid overflow in X.
C             (0 < SCALE <= 1)
C
C     Error indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  equation is (almost) singular to working precision;
C                   perturbed values were used to solve the equation
C                   (but the matrices A and E are unchanged).
C
C     METHOD
C
C     The solution X of (1) or (2) is computed via block back
C     substitution or block forward substitution, respectively. (See
C     [1] and [2] for details.)
C
C     REFERENCES
C
C     [1] Bartels, R.H., Stewart, G.W.
C         Solution of the equation A X + X B = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Penzl, T.
C         Numerical solution of generalized Lyapunov equations.
C         Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
C
C     NUMERICAL ASPECTS
C
C     8/3 * N**3 flops are required by the routine. Note that we count a
C     single floating point arithmetic operation as one flop.
C
C     The algorithm is backward stable if the eigenvalues of the pencil
C     A - lambda * E are real. Otherwise, linear systems of order at
C     most 4 are involved into the computation. These systems are solved
C     by Gauss elimination with complete pivoting. The loss of stability
C     of the Gauss elimination with complete pivoting is rarely
C     encountered in practice.
C
C     CONTRIBUTOR
C
C     T. Penzl, Technical University Chemnitz, Germany, Aug. 1998.
C
C     REVISIONS
C
C     Sep. 1998 (V. Sima).
C     Dec. 1998 (V. Sima).
C
C     KEYWORDS
C
C     Lyapunov equation
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  MONE, ONE, ZERO
      PARAMETER         ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANS
      DOUBLE PRECISION  SCALE
      INTEGER           INFO, LDA, LDE, LDX, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), X(LDX,*)
C     .. Local Scalars ..
      INTEGER           DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL
      DOUBLE PRECISION  AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22,
     $                  EK11, EK12, EK22, EL11, EL12, EL22, SCALE1
      LOGICAL           NOTRNS
C     .. Local Arrays ..
      DOUBLE PRECISION  MAT(4,4), RHS(4), TM(2,2)
      INTEGER           PIV1(4), PIV2(4)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU,
     $                  MB02UV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Decode input parameters.
C
      NOTRNS = LSAME( TRANS, 'N' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN
         INFO = -1
      ELSEIF ( N .LT. 0 ) THEN
         INFO = -2
      ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN
         INFO = -4
      ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN
         INFO = -6
      ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN
         INFO = -8
      ELSE
         INFO = 0
      END IF
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'SG03AY', -INFO )
         RETURN
      END IF
C
      SCALE = ONE
C
C     Quick return if possible.
C
      IF ( N .EQ. 0 ) RETURN
C
      IF ( NOTRNS ) THEN
C
C        Solve equation (1).
C
C        Outer Loop. Compute block row X(KL:KH,:). KB denotes the number
C        of rows in this block row.
C
         KL = 0
         KB = 1
C        WHILE ( KL+KB .LE. N ) DO
   20    IF ( KL+KB .LE. N ) THEN
            KL = KL + KB
            IF ( KL .EQ. N ) THEN
               KB = 1
            ELSE
               IF ( A(KL+1,KL) .NE. ZERO ) THEN
                  KB = 2
               ELSE
                  KB = 1
               END IF
            END IF
            KH = KL + KB - 1
C
C           Copy elements of solution already known by symmetry.
C
C              X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)'
C
            IF ( KL .GT. 1 ) THEN
               DO 40 I = KL, KH
                  CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX )
   40          CONTINUE
            END IF
C
C           Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the
C           number of columns in this block.
C
            LL = KL - 1
            LB = 1
C           WHILE ( LL+LB .LE. N ) DO
   60       IF  ( LL+LB .LE. N ) THEN
               LL = LL + LB
               IF ( LL .EQ. N ) THEN
                  LB = 1
               ELSE
                  IF ( A(LL+1,LL) .NE. ZERO ) THEN
                     LB = 2
                  ELSE
                     LB = 1
                  END IF
               END IF
               LH = LL + LB - 1
C
C              Update right hand sides (I).
C
C                 X(KL:LH,LL:LH) = X(KL:LH,LL:LH) -
C                    A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH))
C
C                 X(KL:LH,LL:LH) = X(KL:LH,LL:LH) -
C                    E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH))
C
               IF ( LL .GT. 1 ) THEN
                  CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX,
     $                        E(1,LL), LDE, ZERO, TM, 2 )
                  CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL),
     $                        LDA, TM, 2, ONE, X(KL,LL), LDX )
                  CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX,
     $                        A(1,LL), LDA, ZERO, TM, 2 )
                  CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, MONE, E(KL,KH),
     $                        LDE, TM, 2, ONE, X(KH,LL), LDX )
                  IF ( KB .EQ. 2 ) CALL DAXPY( LB, -E(KL,KL), TM, 2,
     $                                         X(KL,LL), LDX )
               END IF
C
C              Solve small Sylvester equations of order at most (2,2).
C
               IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN
C
                  DIMMAT = 1
C
                  MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL)
C
                  RHS(1) = X(KL,LL)
C
               ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN
C
                  DIMMAT = 2
C
                  AK11 = A(KL,KL)
                  AK12 = A(KL,KH)
                  AK21 = A(KH,KL)
                  AK22 = A(KH,KH)
C
                  AL11 = A(LL,LL)
C
                  EK11 = E(KL,KL)
                  EK12 = E(KL,KH)
                  EK22 = E(KH,KH)
C
                  EL11 = E(LL,LL)
C
                  MAT(1,1) = EL11*AK11 + AL11*EK11
                  MAT(1,2) = EL11*AK21
                  MAT(2,1) = EL11*AK12 + AL11*EK12
                  MAT(2,2) = EL11*AK22 + AL11*EK22
C
                  RHS(1) = X(KL,LL)
                  RHS(2) = X(KH,LL)
C
               ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN
C
                  DIMMAT = 2
C
                  AK11 = A(KL,KL)
C
                  AL11 = A(LL,LL)
                  AL12 = A(LL,LH)
                  AL21 = A(LH,LL)
                  AL22 = A(LH,LH)
C
                  EK11 = E(KL,KL)
C
                  EL11 = E(LL,LL)
                  EL12 = E(LL,LH)
                  EL22 = E(LH,LH)
C
                  MAT(1,1) = EL11*AK11 + AL11*EK11
                  MAT(1,2) = AL21*EK11
                  MAT(2,1) = EL12*AK11 + AL12*EK11
                  MAT(2,2) = EL22*AK11 + AL22*EK11
C
                  RHS(1) = X(KL,LL)
                  RHS(2) = X(KL,LH)
C
               ELSE
C
                  DIMMAT = 4
C
                  AK11 = A(KL,KL)
                  AK12 = A(KL,KH)
                  AK21 = A(KH,KL)
                  AK22 = A(KH,KH)
C
                  AL11 = A(LL,LL)
                  AL12 = A(LL,LH)
                  AL21 = A(LH,LL)
                  AL22 = A(LH,LH)
C
                  EK11 = E(KL,KL)
                  EK12 = E(KL,KH)
                  EK22 = E(KH,KH)
C
                  EL11 = E(LL,LL)
                  EL12 = E(LL,LH)
                  EL22 = E(LH,LH)
C
                  MAT(1,1) = EL11*AK11 + AL11*EK11
                  MAT(1,2) = EL11*AK21
                  MAT(1,3) = AL21*EK11
                  MAT(1,4) = ZERO
C
                  MAT(2,1) = EL11*AK12 + AL11*EK12
                  MAT(2,2) = EL11*AK22 + AL11*EK22
                  MAT(2,3) = AL21*EK12
                  MAT(2,4) = AL21*EK22
C
                  MAT(3,1) = EL12*AK11 + AL12*EK11
                  MAT(3,2) = EL12*AK21
                  MAT(3,3) = EL22*AK11 + AL22*EK11
                  MAT(3,4) = EL22*AK21
C
                  MAT(4,1) = EL12*AK12 + AL12*EK12
                  MAT(4,2) = EL12*AK22 + AL12*EK22
                  MAT(4,3) = EL22*AK12 + AL22*EK12
                  MAT(4,4) = EL22*AK22 + AL22*EK22
C
                  RHS(1) = X(KL,LL)
                  IF ( KL .EQ. LL ) THEN
                     RHS(2) = X(KL,KH)
                  ELSE
                     RHS(2) = X(KH,LL)
                  END IF
                  RHS(3) = X(KL,LH)
                  RHS(4) = X(KH,LH)
C
               END IF
C
               CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 )
               IF ( INFO1 .NE. 0 )
     $            INFO = 1
               CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 )
C
C              Scaling.
C
               IF ( SCALE1 .NE. ONE ) THEN
                  DO 80 I = 1, N
                     CALL DSCAL( N, SCALE1, X(1,I), 1 )
   80             CONTINUE
                  SCALE = SCALE*SCALE1
               END IF
C
               IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN
                  X(KL,LL) = RHS(1)
               ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN
                  X(KL,LL) = RHS(1)
                  X(KH,LL) = RHS(2)
               ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN
                  X(KL,LL) = RHS(1)
                  X(KL,LH) = RHS(2)
               ELSE
                  X(KL,LL) = RHS(1)
                  X(KH,LL) = RHS(2)
                  X(KL,LH) = RHS(3)
                  X(KH,LH) = RHS(4)
               END IF
C
C              Update right hand sides (II).
C
C                 X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) -
C                    A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH))
C
C                 X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) -
C                    E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH))
C
               IF ( KL .LT. LL ) THEN
                  IF ( LB .EQ. 2 )
     $               CALL DGEMV( 'N', KB, 2, ONE, X(KL,LL), LDX,
     $                           E(LL,LH), 1, ZERO, TM(1,2), 1 )
                  CALL DCOPY( KB, X(KL,LL), 1, TM, 1 )
                  CALL DSCAL( KB, E(LL,LL), TM, 1 )
                  CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1),
     $                        LDA, TM, 2, ONE, X(KH+1,LL), LDX )
                  CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX,
     $                        A(LL,LL), LDA, ZERO, TM, 2 )
                  CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, E(KL,KH+1),
     $                        LDE, TM, 2, ONE, X(KH+1,LL), LDX )
               END IF
C
            GOTO 60
            END IF
C           END WHILE 60
C
         GOTO 20
         END IF
C        END WHILE 20
C
      ELSE
C
C        Solve equation (2).
C
C        Outer Loop. Compute block column X(:,LL:LH). LB denotes the
C        number of columns in this block column.
C
         LL = N + 1
C        WHILE ( LL .GT. 1 ) DO
  100    IF ( LL .GT. 1 ) THEN
            LH = LL - 1
            IF ( LH .EQ. 1 ) THEN
               LB = 1
            ELSE
               IF ( A(LL-1,LL-2) .NE. ZERO ) THEN
                  LB = 2
               ELSE
                  LB = 1
               END IF
            END IF
            LL = LL - LB
C
C           Copy elements of solution already known by symmetry.
C
C              X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)'
C
            IF ( LH .LT. N ) THEN
               DO 120 I = LL, LH
                  CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 )
  120          CONTINUE
            END IF
C
C           Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the
C           number of rows in this block.
C
            KL = LH + 1
C           WHILE ( KL .GT. 1 ) DO
  140       IF ( KL .GT. 1 ) THEN
               KH = KL - 1
               IF ( KH .EQ. 1 ) THEN
                  KB = 1
               ELSE
                  IF ( A(KL-1,KL-2) .NE. ZERO ) THEN
                     KB = 2
                  ELSE
                     KB = 1
                  END IF
               END IF
               KL = KL - KB
C
C              Update right hand sides (I).
C
C                 X(KL:KH,KL:LH) = X(KL:KH,KL:LH) -
C                    (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)'
C
C                 X(KL:KH,KL:LH) = X(KL:KH,KL:LH) -
C                    (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)'
C
               IF ( KH .LT. N ) THEN
                  CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1),
     $                        LDA, X(KH+1,LL), LDX, ZERO, TM, 2 )
                  CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, MONE, TM, 2,
     $                        E(KL,LL), LDE, ONE, X(KL,KL), LDX )
                  IF ( LB .EQ. 2 ) CALL DAXPY( KB, -E(LH,LH), TM(1,2),
     $                                         1, X(KL,LH), 1 )
                  CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1),
     $                        LDE, X(KH+1,LL), LDX, ZERO, TM, 2 )
                  CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2,
     $                        A(KL,LL), LDA, ONE, X(KL,KL), LDX )
               END IF
C
C              Solve small Sylvester equations of order at most (2,2).
C
               IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN
C
                  DIMMAT = 1
C
                  MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL)
C
                  RHS(1) = X(KL,LL)
C
               ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN
C
                  DIMMAT = 2
C
                  AK11 = A(KL,KL)
                  AK12 = A(KL,KH)
                  AK21 = A(KH,KL)
                  AK22 = A(KH,KH)
C
                  AL11 = A(LL,LL)
C
                  EK11 = E(KL,KL)
                  EK12 = E(KL,KH)
                  EK22 = E(KH,KH)
C
                  EL11 = E(LL,LL)
C
                  MAT(1,1) = EL11*AK11 + AL11*EK11
                  MAT(1,2) = EL11*AK12 + AL11*EK12
                  MAT(2,1) = EL11*AK21
                  MAT(2,2) = EL11*AK22 + AL11*EK22
C
                  RHS(1) = X(KL,LL)
                  RHS(2) = X(KH,LL)
C
               ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN
C
                  DIMMAT = 2
C
                  AK11 = A(KL,KL)
C
                  AL11 = A(LL,LL)
                  AL12 = A(LL,LH)
                  AL21 = A(LH,LL)
                  AL22 = A(LH,LH)
C
                  EK11 = E(KL,KL)
C
                  EL11 = E(LL,LL)
                  EL12 = E(LL,LH)
                  EL22 = E(LH,LH)
C
                  MAT(1,1) = EL11*AK11 + AL11*EK11
                  MAT(1,2) = EL12*AK11 + AL12*EK11
                  MAT(2,1) = AL21*EK11
                  MAT(2,2) = EL22*AK11 + AL22*EK11
C
                  RHS(1) = X(KL,LL)
                  RHS(2) = X(KL,LH)
C
               ELSE
C
                  DIMMAT = 4
C
                  AK11 = A(KL,KL)
                  AK12 = A(KL,KH)
                  AK21 = A(KH,KL)
                  AK22 = A(KH,KH)
C
                  AL11 = A(LL,LL)
                  AL12 = A(LL,LH)
                  AL21 = A(LH,LL)
                  AL22 = A(LH,LH)
C
                  EK11 = E(KL,KL)
                  EK12 = E(KL,KH)
                  EK22 = E(KH,KH)
C
                  EL11 = E(LL,LL)
                  EL12 = E(LL,LH)
                  EL22 = E(LH,LH)
C
                  MAT(1,1) = EL11*AK11 + AL11*EK11
                  MAT(1,2) = EL11*AK12 + AL11*EK12
                  MAT(1,3) = EL12*AK11 + AL12*EK11
                  MAT(1,4) = EL12*AK12 + AL12*EK12
C
                  MAT(2,1) = EL11*AK21
                  MAT(2,2) = EL11*AK22 + AL11*EK22
                  MAT(2,3) = EL12*AK21
                  MAT(2,4) = EL12*AK22 + AL12*EK22
C
                  MAT(3,1) = AL21*EK11
                  MAT(3,2) = AL21*EK12
                  MAT(3,3) = EL22*AK11 + AL22*EK11
                  MAT(3,4) = EL22*AK12 + AL22*EK12
C
                  MAT(4,1) = ZERO
                  MAT(4,2) = AL21*EK22
                  MAT(4,3) = EL22*AK21
                  MAT(4,4) = EL22*AK22 + AL22*EK22
C
                  RHS(1) = X(KL,LL)
                  IF ( KL .EQ. LL ) THEN
                     RHS(2) = X(KL,KH)
                  ELSE
                     RHS(2) = X(KH,LL)
                  END IF
                  RHS(3) = X(KL,LH)
                  RHS(4) = X(KH,LH)
C
               END IF
C
               CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 )
               IF ( INFO1 .NE. 0 )
     $            INFO = 1
               CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 )
C
C              Scaling.
C
               IF ( SCALE1 .NE. ONE ) THEN
                  DO 160 I = 1, N
                     CALL DSCAL( N, SCALE1, X(1,I), 1 )
  160             CONTINUE
                  SCALE = SCALE*SCALE1
               END IF
C
               IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN
                  X(KL,LL) = RHS(1)
               ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN
                  X(KL,LL) = RHS(1)
                  X(KH,LL) = RHS(2)
               ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN
                  X(KL,LL) = RHS(1)
                  X(KL,LH) = RHS(2)
               ELSE
                  X(KL,LL) = RHS(1)
                  X(KH,LL) = RHS(2)
                  X(KL,LH) = RHS(3)
                  X(KH,LH) = RHS(4)
               END IF
C
C              Update right hand sides (II).
C
C                 X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) -
C                    (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)'
C
C                 X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) -
C                    (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)'
C
               IF ( KL .LT. LL ) THEN
                  CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA,
     $                        X(KL,LL), LDX, ZERO, TM, 2 )
                  CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2,
     $                        E(KL,LL), LDE, ONE, X(KL,KL), LDX )
                  CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL),
     $                        LDE, ZERO, TM, 2 )
                  IF ( KB .EQ. 2 ) THEN
                     CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 )
                     CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 )
                  END IF
                  CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2,
     $                        A(KL,LL), LDA, ONE, X(KL,KL), LDX )
               END IF
C
            GOTO 140
            END IF
C           END WHILE 140
C
         GOTO 100
         END IF
C        END WHILE 100
C
      END IF
C
      RETURN
C *** Last line of SG03AY ***
      END


#include "Definitions.INC"

module jfunctmod
contains

function ffunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: ffunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     ffunct=xval + (fac-1)*(xval+scalingdistance+smoothness/2d0)
  else if (xval.ge.scalingdistance+smoothness) then
     ffunct=xval + (fac-1)*(xval-scalingdistance-smoothness/2d0)
  else if (abs(xval).le.scalingdistance) then
     ffunct=xval
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     ffunct = xval + (fac-1) * smoothness * fscaled(xx)
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     ffunct = xval - (fac-1) * smoothness * fscaled(xx)
  else
     print *, "OOGABLAH0"; stop
  endif
end function ffunct

function jfunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: jfunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     jfunct=fac
  else if (xval.ge.scalingdistance+smoothness) then
     jfunct=fac
  else if (abs(xval).le.scalingdistance) then
     jfunct=1d0
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     jfunct = 1d0 + (fac-1d0) * jscaled(xx)
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     jfunct = 1d0 + (fac-1d0) * jscaled(xx)
  else
     print *, "OOGABLAHd"; stop
  endif
end function jfunct

function djfunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: djfunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     djfunct=0
  else if (xval.ge.scalingdistance+smoothness) then
     djfunct=0
  else if (abs(xval).le.scalingdistance) then
     djfunct=0
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     djfunct = (fac-1d0) * djscaled(xx) / smoothness
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     djfunct = (1d0-fac) * djscaled(xx) / smoothness
  else
     print *, "OOGABLAHd"; stop
  endif
end function djfunct

function ddjfunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: ddjfunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     ddjfunct=0
  else if (xval.ge.scalingdistance+smoothness) then
     ddjfunct=0
  else if (abs(xval).le.scalingdistance) then
     ddjfunct=0
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     ddjfunct = (fac-1d0) * ddjscaled(xx) / smoothness**2
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     ddjfunct = (fac-1d0) * ddjscaled(xx) / smoothness**2
  else
     print *, "OOGABLAHd"; stop
  endif
end function ddjfunct

!! f happens to go from 0 to 1/2 on (0,1)

function fscaled(xval)
  implicit none
  real*8 :: fscaled,xval,pixval
  real*8, parameter :: pi = 3.14159265358979323844d0 !!TEMP

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  fscaled = (-1d0)/12d0/pi * sin(pixval)**3 - 1d0/2d0/pi * sin(pixval) + xval/2d0
end function fscaled

function jscaled(xval)
  implicit none
  real*8 :: jscaled,xval,pixval
  real*8, parameter :: pi = 3.14159265358979323844d0 !!TEMP

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  jscaled = 1d0/4d0 * cos(pixval)**3 - 3d0/4d0 * cos(pixval) + 0.5d0
end function jscaled

function djscaled(xval)
  implicit none
  real*8 :: djscaled,xval,pixval
  real*8, parameter :: pi = 3.14159265358979323844d0 !!TEMP

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  djscaled = 0.75d0 * pi * sin(pixval)**3

end function djscaled

function ddjscaled(xval)
  implicit none
  real*8 :: ddjscaled,xval,pixval
  real*8, parameter :: pi = 3.14159265358979323844d0 !!TEMP

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  ddjscaled = 9d0/4d0*pi**2 * sin(pixval)**2 * cos(pixval)
end function ddjscaled

end module jfunctmod

module ivopotmod
  implicit none
  integer :: numocc=(-1)
  DATATYPE, allocatable :: ivopot(:),ivo_occupied(:,:)
end module ivopotmod

module initspfsmod
contains

subroutine init_spfs(inspfs,numloaded,numfrozen,frozenreduced)
  use myparams
  use pmpimod
  use pfileptrmod
  use ivopotmod
  use utilmod     !! IN PARENT DIRECTORY
  use lanblockmod !! IN PARENT DIRECTORY
  use tinvsubmod
  implicit none
  DATATYPE,intent(inout) :: inspfs(totpoints,numspf)
  integer, intent(in) :: numloaded,numfrozen
  DATATYPE,intent(in) :: frozenreduced(totpoints)
  DATATYPE,allocatable :: lanspfs(:,:),density(:)
  DATAECS,allocatable :: energies(:)
  integer :: ibig,iorder,ispf,ppfac,ii,jj,kk,olist(numspf),flag
  integer :: null1,null2,null3,null4,null10(10),numcompute

  if (ivoflag.ne.0) then
     if (numloaded.le.0) then
        OFLWR "error, for ivo must load orbitals",numloaded; CFLST
     endif
     numcompute = numspf + max(0,num_skip_orbs) - numloaded
  else
     numcompute = numspf + num_skip_orbs
  endif

  if (numcompute.lt.0) then
     OFLWR "error numcompute lt 0 ", numloaded,numspf; CFLST
  endif
  if (numcompute.eq.0) then
     OFLWR "numcompute eq 0 RETURN"; CFL
     return
  endif
  if (numspf-numloaded.le.0) then
     OFLWR "numget eq 0 return", numspf-numloaded; CFL
     return
  endif

  if (ivoflag.ne.0) then
     kk=0
  else
     if (num_skip_orbs.lt.0) then
        kk=numloaded+num_skip_orbs
     else
        kk=numloaded
     endif
  endif

  ii=1
  do while (ii.le.numspf-numloaded)
     kk=kk+1
     flag=0
     do jj=1,num_skip_orbs
        if (orb_skip(jj).eq.kk) then
           flag=1
           exit
        endif
     enddo
     if (flag.eq.0) then
        olist(ii)=kk
        ii=ii+1
     endif
  enddo

  if (kk.gt.numcompute) then
     OFLWR "FSFFD EEEEE 555",kk,numspf,num_skip_orbs; CFLST
  endif

  if (ivoflag.ne.0) then
     OFLWR "getting IVO pot.  occupations are "
     WRFL loadedocc(1:numloaded); CFL

     allocate(ivopot(totpoints), density(totpoints),ivo_occupied(totpoints,numloaded))
     ivopot(:)=0d0; density(:)=0d0; ivo_occupied=0d0

     numocc=numloaded
     ivo_occupied(:,:)=inspfs(:,1:numloaded)
     do ispf=1,numloaded

        call gramschmidt(totpoints,ispf-1,totpoints,ivo_occupied(:,:),ivo_occupied(:,ispf),orbparflag)

        density(:)=density(:)+ivo_occupied(:,ispf)*CONJUGATE(ivo_occupied(:,ispf))*loadedocc(ispf)
     enddo
     call op_tinv(density,ivopot,1,1,null1,null2,null3,null4,null10)
     deallocate(density)

     if (numfrozen.gt.0) then
        ivopot(:)=ivopot(:)+frozenreduced(:)
     endif
  endif

  allocate(lanspfs(totpoints,numcompute),energies(numcompute))
  lanspfs=0; energies=0

  ibig=totpoints
  ppfac=1
  if (orbparflag) then
     ppfac=nprocs
  endif
  iorder=min(ibig*ppfac,orblanorder)

  OFLWR "CALL BLOCK LAN FOR ORBS, ",numcompute," VECTORS"; CFL

  call blocklanczos0(min(3,numspf),numcompute,ibig,ibig,iorder,ibig*ppfac,lanspfs,ibig,&
       energies,1,0,orblancheckmod,orblanthresh,mult_bigspf,orbparflag,orbtargetflag,orbtarget)

  if (ivoflag.ne.0) then
     deallocate(ivopot,ivo_occupied)
  endif

  OFLWR "BL CALLED. ENERGIES: ";CFL
  do ispf=1,numcompute
     OFLWR ispf,energies(ispf); CFL
  enddo
  OFLWR;  CFL

  do ispf=1,numspf-numloaded
     inspfs(:,ispf+numloaded)=lanspfs(:,olist(ispf))
  enddo

  deallocate(lanspfs,energies)

contains

  subroutine ivo_project(inbigspf,outbigspf)
    use myparams
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    integer :: ii
    outbigspf(:)=0d0
    do ii=1,numocc
       outbigspf(:)=outbigspf(:) + ivo_occupied(:,ii) * ivodot(ivo_occupied(:,ii),inbigspf(:),totpoints)
    enddo
  end subroutine ivo_project

  function ivodot(inbra,inket,size)
    use myparams
    use mpisubmod   !! IN PARENT DIRECTORY
    implicit none
    integer,intent(in) :: size
    DATATYPE,intent(in) :: inbra(size),inket(size)
    DATATYPE :: ivodot,csum
    csum=DOT_PRODUCT(inbra,inket)
    if (orbparflag) then
       call mympireduceone(csum)
    endif
    ivodot=csum
  end function ivodot

  subroutine mult_bigspf_ivo(inbigspf,outbigspf)
    use myparams
    use orbprojectmod !! IN PARENT DIRECTORY
    use orbmultsubmod !! IN PARENT DIRECTORY
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    DATATYPE :: tempspf(totpoints),inwork(totpoints),inwork2(totpoints),&
         workspf(totpoints)   !! AUTOMATIC

    tempspf=0; inwork=0; inwork2=0; workspf=0

    call ivo_project(inbigspf,outbigspf)
    call project_onfrozen(inbigspf,workspf)
    outbigspf=outbigspf+workspf

    inwork2(:)=inbigspf(:)-outbigspf(:)

    outbigspf(:)=outbigspf(:) * (1d2)

    call mult_ke(inwork2(:),inwork(:),1,"booga",2)

    call mult_pot(1,inwork2(:),tempspf(:))

    inwork(:) = inwork(:) + tempspf(:) + ivopot(:)*inwork2(:)

    call ivo_project(inwork,inwork2)
    call project_onfrozen(inwork,workspf)
    inwork2=inwork2+workspf

    outbigspf(:) = outbigspf(:) + inwork(:) - inwork2(:)

  end subroutine mult_bigspf_ivo

  subroutine mult_bigspf0(inbigspf,outbigspf)
    use myparams
    use orbmultsubmod !! IN PARENT DIRECTORY
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    DATATYPE :: tempspf(totpoints)   !! AUTOMATIC

    tempspf=0
    call mult_ke(inbigspf(:),outbigspf(:),1,"booga",2)
    call mult_pot(1,inbigspf(:),tempspf(:))
    outbigspf(:)=outbigspf(:)+tempspf(:)

  end subroutine mult_bigspf0

  subroutine mult_bigspf(inbigspf,outbigspf)
    use myparams
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    if (ivoflag.eq.0) then
       call mult_bigspf0(inbigspf,outbigspf)
    else
       call mult_bigspf_ivo(inbigspf,outbigspf)
    endif
  end subroutine mult_bigspf

end subroutine init_spfs

end module initspfsmod

subroutine init_project(inspfs,spfsloaded,pot,halfniumpot,rkemod,proderivmod,skipflag,&
     bondpoints,bondweights,elecweights,elecradii,numelec,&
     numfrozen, infrozens, frozenkediag, frozenpotdiag, frozenreduced, notusedreduced)
  use myparams
  use pmpimod
  use pfileptrmod
  use myprojectmod
  use jfunctmod
  use initspfsmod
  use gettwoemod
  implicit none
  integer, intent(in) :: skipflag,numelec
  integer,intent(inout) :: spfsloaded
  DATATYPE,intent(inout) :: inspfs(totpoints, numspf)
  DATATYPE,intent(out) :: pot(totpoints),proderivmod(numr,numr),rkemod(numr,numr),&
       bondpoints(numr),bondweights(numr), elecweights(totpoints,3),elecradii(totpoints),&
       halfniumpot(totpoints)
  integer,intent(in) :: numfrozen
  DATATYPE,intent(in) :: infrozens(totpoints,numfrozen)
  DATATYPE,intent(out) :: frozenkediag, frozenpotdiag, &
       frozenreduced(totpoints)
  DATATYPE :: notusedreduced(totpoints)
#ifndef REALGO
  real*8,allocatable :: temppot(:)
#endif
  real*8 :: rsum,pi
  character (len=2) :: th(4)
  integer ::  i,   j,ii,jj,k,l,idim,ilow(3),ihigh(3)

!! smooth exterior scaling
  DATATYPE,allocatable :: scalefunction(:,:), djacobian(:,:), ddjacobian(:,:)

  pi=4d0*atan(1d0)

#ifndef REALGO
  allocate(temppot(totpoints))
  temppot=0
#endif
  allocate(scalefunction(totpoints,3), djacobian(totpoints,3), ddjacobian(totpoints,3))
  scalefunction=0; djacobian=0; ddjacobian=0

  rkemod(:,:)=0d0; proderivmod(:,:)=0d0; bondpoints(:)=1d0; bondweights(:)=1d0

  elecweights(:,:)=1d0
  elecweights(:,1:griddim)=(1d0/spacing)    !! griddim=3

  do idim=1,griddim

     call sineDVR(kevect(idim)%rmat(:),fdvect(idim)%rmat(:), sinepoints(idim)%mat(:,:),gridpoints(idim),spacing)

     kevect(idim)%cmat(:)=kevect(idim)%rmat(:)
     fdvect(idim)%cmat(:)=fdvect(idim)%rmat(:)

     ii=0
     do i=1,nbox(idim)
        do j=1,numpoints(idim)
           ii=ii+1
           jj=0
           do k=1,nbox(idim)
              do l=1,numpoints(idim)
                 jj=jj+1
                 ketot(idim)%mat(l,k,j,i)=kevect(idim)%rmat(ii-jj)
                 fdtot(idim)%mat(l,k,j,i)=fdvect(idim)%rmat(ii-jj)
                 ketot(idim)%tam(l,j,k,i)=kevect(idim)%rmat(ii-jj)
                 fdtot(idim)%tam(l,j,k,i)=fdvect(idim)%rmat(ii-jj)
              enddo
           enddo
        enddo
     enddo
  enddo

  th=(/ "st", "nd", "rd", "th" /)

!!$  if (skipflag.gt.1) then
!!$     return
!!$  endif

  call get_dipoles()

  if (scalingflag.ne.0) then

     if (debugflag.eq.54321) then
        OFLWR "#Testing scaling..."; CFL
        if (myrank.eq.1) then
           open(76333,file="Contour.Dat",status="unknown")
           do i=-100,100
              rsum=i/100d0*spacing*gridpoints(1)/2d0
              write(76333,'(100F12.5)') rsum, ffunct(rsum), jfunct(rsum), djfunct(rsum), ddjfunct(rsum)
           enddo
           close(76333)
        endif
        call mpibarrier()
        OFLWR "#Done testing scaling"; CFLST
     endif

     OFLWR "Getting scaling..."; CFL

     do idim=1,3
        do i=1,totpoints
           scalefunction(i,idim)=ffunct(real(dipoles(i,idim),8))
           jacobian(i,idim)=jfunct(real(dipoles(i,idim),8))
           djacobian(i,idim)=djfunct(real(dipoles(i,idim),8))
           ddjacobian(i,idim)=ddjfunct(real(dipoles(i,idim),8))
        enddo
     enddo

     invjacobian(:,:)=1d0/jacobian(:,:)

     invsqrtjacobian(:,:)=sqrt(invjacobian(:,:))

     invsqrtscaleweights(:) = sqrt(invjacobian(:,1)) * sqrt(invjacobian(:,2)) *  sqrt(invjacobian(:,3))

     scaleweights13(:) = (jacobian(:,1))**(1d0/3d0) * (jacobian(:,2))**(1d0/3d0) * (jacobian(:,3))**(1d0/3d0)
     invscaleweights13(:) = 1d0/scaleweights13(:)

     scaleweights16(:)=sqrt(scaleweights13(:))
     invscaleweights16(:)=sqrt(invscaleweights13(:))

!!     scaleweights13(:) = 1d0
!!     invscaleweights13(:) = 1d0

     scalediag(:)=0d0
     do jj=1,3
        scalediag(:)=scalediag(:) + 3d0/8d0 * invjacobian(:,jj)**4 * djacobian(:,jj)**2 &
             - 1d0/4d0 * invjacobian(:,jj)**3 * ddjacobian(:,jj)
     enddo

     elecweights(:,:)=elecweights(:,:)*jacobian(:,:)

!!$     elecweights(:)=elecweights(:)*jacobian(:,1)*jacobian(:,2)*jacobian(:,3)

     dipoles(:,:)=scalefunction(:,:)
     OFLWR "    ....Ok got scaling."; CFL
  endif

  elecradii(:)=sqrt( dipoles(:,1)**2 + dipoles(:,2)**2 + dipoles(:,3)**2)

  call get_twoe_new(pot)

  if (numfrozen.gt.0) then
     call call_frozen_matels_core(infrozens,numfrozen,frozenkediag,frozenpotdiag,frozenreduced)
  endif

  if (debugflag .eq. 4040) then
     pot(:) = 0.35d0 * elecradii(:)**2 * ( &
          exp((-0.13d0)*(dipoles(:,1)**2+dipoles(:,2)**2+(dipoles(:,3)-2d0)**2)) + &
          exp((-0.13d0)*(dipoles(:,1)**2+dipoles(:,2)**2+(dipoles(:,3)+2d0)**2)) )
     threed_two(:,:,:)=0d0
  else if (debugflag .eq. 4242) then
     pot(:) = 7.5d0 * elecradii(:)**2 * exp((-1)*elecradii(:))
     threed_two(:,:,:)=0d0
  else if (debugflag.eq.4343) then
     pot(:) = 4.5d0 * elecradii(:)**2
     threed_two(:,:,:)=0d0
  endif

#ifndef REALGO
  if (capflag.gt.0) then
     temppot(:)=0d0
     do i=1,capflag
        if (capmode.eq.1) then
           temppot(:)=temppot(:) + capstrength(i)*( real(elecradii(:),8)/capstart(i) )**cappower(i)
        else
           temppot(:)=temppot(:) + capstrength(i)*( max(0d0,real(elecradii(:),8)-capstart(i)) )**cappower(i)
        endif
     enddo
     temppot(:)= min(maxcap,max(mincap,temppot(:)))
     halfniumpot(:)=pot(:)*(sumcharge-numelec+1)/sumcharge + (0d0,-1d0) * temppot(:)
     pot(:)=pot(:) + (0d0,-1d0) * temppot(:)
  else
#endif
     halfniumpot(:)=pot(:)/sumcharge
#ifndef REALGO
  endif
#endif

  ilow(1:3)=1
  ihigh(1:3)=gridpoints(1:3)

  if (orbparflag) then
     ilow(orbparlevel:3)=(boxrank(orbparlevel:3)-1)*numpoints(orbparlevel:3)+1
     ihigh(orbparlevel:3)=boxrank(orbparlevel:3)*numpoints(orbparlevel:3)
  endif

  if (maskflag.ne.0) then
     do jj=1,3
        maskfunction(jj)%rmat(:)=1d0
        do ii=1,masknumpoints

           rsum=( 1d0 + cos(pi*ii/(masknumpoints+1)) ) / 2d0

           i=masknumpoints+1-ii

           if (i.ge.ilow(jj).and.i.le.ihigh(jj)) then
              maskfunction(jj)%rmat(i+1-ilow(jj)) = maskfunction(jj)%rmat(i+1-ilow(jj)) * rsum
           endif

           i=gridpoints(jj)-masknumpoints+ii

           if (i.ge.ilow(jj).and.i.le.ihigh(jj)) then
              maskfunction(jj)%rmat(i+1-ilow(jj)) = maskfunction(jj)%rmat(i+1-ilow(jj)) * rsum
           endif
        enddo
     enddo
  endif

  if (spfsloaded.lt.numspf) then
     call init_spfs(inspfs(:,:),spfsloaded,numfrozen,frozenreduced)
  endif

  spfsloaded=numspf   !! for mcscf... really just for BO curve to skip eigen

  if (debugflag.eq.90210) then
     OFLWR "TEMPSTOP init_project debugflag 90210"; CFLST
  endif

#ifndef REALGO
  deallocate(temppot)
#endif
  deallocate(scalefunction, djacobian, ddjacobian)

contains

  subroutine get_dipoles()
    use myparams
    use myprojectmod
    implicit none
    integer :: jj,ii,kk
    ii=1;  kk=totpoints
    do jj=1,griddim
       kk=kk/numpoints(jj)
       call get_one_dipole(dipoles(:,jj),jj,qbox(jj),ii,kk)
       ii=ii*numpoints(jj)
    enddo
  end subroutine get_dipoles

  subroutine get_one_dipole(out,idim,whichbox,nnn,mmm)
    use myparams
    use myprojectmod
    implicit none
    integer,intent(in) :: mmm,idim,nnn,whichbox
    DATATYPE,intent(out) :: out(nnn,numpoints(idim),mmm)
    integer :: jj,ii

    do jj=1,mmm
       do ii=1,numpoints(idim)
          out(:,ii,jj)=sinepoints(idim)%mat(ii,whichbox)
       enddo
    enddo
  end subroutine get_one_dipole

end subroutine init_project

!! fixed nuclei only for now

subroutine nucdipvalue(notused,dipoles)
  use myparams
  implicit none
  DATATYPE,intent(in) :: notused(1)
  DATATYPE,intent(out) :: dipoles(3)
  integer :: i
  dipoles(:)=0d0 * notused(1)   !! avoid warn unused
  do i=1,numcenters
     dipoles(:)=dipoles(:) + nuccharges(i) * centershift(:,i)/2d0 * spacing
  enddo
end subroutine nucdipvalue


      PROGRAM xdftint
C     driver for routine dftint
      REAL a,b,c,cans,cosint,d,sans,sinint,w
      COMMON /parms/ c,d
      EXTERNAL coscxd
      write(*,'(2x,a,t10,a,t37,a,t44,a,t70,a)') 'Omega',
     * 'Integral cosine*test func','Err','Integral sine*test func','Err'
3     write(*,*) 'INPUT C,D: '
      read(*,*) c,d
1     write(*,*) 'INPUT A,B: '
      read(*,*) a,b
      if (a.eq.b) goto 3
2     write(*,*) 'INPUT W: '
      read(*,*,END=999) w
      if (w.lt.0.) goto 1
      call dftint(coscxd,a,b,w,cosint,sinint)
      call getans(w,a,b,cans,sans)
      write(*,100) w,cans,cosint-cans,sans,sinint-sans
100   format(1p5e15.6)
      goto 2
999   write(*,*) 'NORMAL COMPLETION'
      STOP
      END
      REAL FUNCTION coscxd(x)
      REAL c,d,x
      COMMON /parms/ c,d
      coscxd=cos(c*x+d)
      return
      END
      SUBROUTINE getans(w,a,b,cans,sans)
      REAL a,b,c,cans,ci,d,sans,si,w,x
      COMMON /parms/ c,d
      ci(x)=sin((w-c)*x-d)/(2.*(w-c))+sin((w+c)*x+d)/(2.*(w+c))
      si(x)=-cos((w-c)*x-d)/(2.*(w-c))-cos((w+c)*x+d)/(2.*(w+c))
      cans=ci(b)-ci(a)
      sans=si(b)-si(a)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xdftint.for


module gc_terms
    implicit none
    save
    real, allocatable :: bCurvature_R(:,:), &
        bCurvature_phi(:,:), bCurvature_z(:,:), &
        bGradient_R(:,:), bGradient_phi(:,:), &
        bGradient_z(:,:), bDotGradB(:,:)

contains
    subroutine bCurvature ()
        use eqdsk
        use dlg
        use constants
        implicit none

        integer :: j
        real, dimension(nw,nh) :: bR_B, bPhi_B, bz_B, &
            bDotGradB_R, bDotGradB_phi, bDotGradB_z, &
            bR_B_dR, bR_B_dz, bPhi_B_dR, bPhi_B_dz, &
            bz_B_dR, bz_B_dz, r2D, omega, &
            gradB_R, gradB_z

        do j=1,nh
            r2D(:,j)    = r
        end do

        omega   = q * bMag / mi

        bR_B    = bR / bMag
        bPhi_B  = bPhi / bMag
        bz_B    = bz / bMag

        bR_B_dR = dlg_pDeriv ( bR_B, 1, rStep )
        bR_B_dz = dlg_pDeriv ( bR_B, 2, zStep )

        bPhi_B_dR   = dlg_pDeriv ( bPhi_B, 1, rStep )
        bPhi_B_dz   = dlg_pDeriv ( bPhi_B, 2, zStep )

        bz_B_dR = dlg_pDeriv ( bz_B, 1, rStep )
        bz_B_dz = dlg_pDeriv ( bz_B, 2, zStep )

        bDotGradB_R = bR_B * bR_B_dR + bz_B * bR_B_dz - bPhi_B**2 / r2D
        bDotGradB_phi   = bPhi_B * bR_B / r2D + bR_B * bPhi_B_dR &
            + bz_B * bPhi_B_dz
        bDotGradB_z = bR_B * bz_B_dR + bz_B * bz_B_dz

        allocate ( bCurvature_R(nw,nh), bCurvature_phi(nw,nh), bCurvature_z(nw,nh) )

        bCurvature_R = ( bPhi_B * bDotGradB_z - bz_B * bDotGradB_phi ) / omega
        bCurvature_phi   = -1.0 * ( bR_B * bDotGradB_z - bz_B * bDotGradB_R ) &
            / omega
        bCurvature_z = ( bR_B * bDotGradB_phi - bPhi_B * bDotGradB_R ) / omega

        ! Also in here is the b.Grad b for calculating vPar

        gradB_R = dlg_pDeriv ( bMag, 1, rStep )
        gradB_z = dlg_pDeriv ( bMag, 2, zStep )

        allocate ( bDotGradB(nw,nh) )

        bDotGradB   = bR_B * gradB_R + bz_B * gradB_z

    end subroutine bCurvature

    subroutine bGradient ()
        use eqdsk
        use dlg
        use constants
        !use dislin
        implicit none
        real, dimension(nw,nh) :: bR_B, bPhi_B, bz_B, &
            lnB_dR, lnB_dz, lnB, omega

        !!   Plot variables
        !
        !integer :: nLevs, i
        !real, allocatable :: levels(:)
        !real :: levStep

        omega   = q * bMag / mi
        lnB = log ( bMag )
        lnB_dR  = dlg_pDeriv ( lnB, 1, rStep )
        lnB_dz  = dlg_pDeriv ( lnB, 2, zStep )

        bR_B    = bR / bMag
        bPhi_B  = bPhi / bMag
        bz_B    = bz / bMag

        allocate ( bGradient_R(nw,nh), bGradient_phi(nw,nh), &
            bGradient_z(nw,nh) )

        bGradient_R = bPhi_B * lnB_dz / ( 2.0 * omega )
        bGradient_phi   = -1.0 * ( bR_B * lnB_dz - bz_B * lnB_dR ) &
            / ( 2.0 * omega )
        bGradient_z = -1.0 * bPhi_B * lnB_dR / ( 2.0 * omega )

        !!call setFil ( 'eqdsk.eps' )
        !!call setPag ( 'DA4P' )
        !call scrMod ( 'REVERS' )
        !call metaFl ( 'XWIN' )
        !call disIni ()
        !call graf ( 0.0, 3.0, 0.0, 0.5, -2.0, 2.0, -2.0, 0.5 )
        !call noClip ()
        !call color ('BLUE')
        !
        !nLevs   = 101
        !levStep    = maxVal ( abs ( bz ) ) / ( nLevs / 2 )
        !allocate ( levels(nLevs) )
        !levels = (/ (i*levStep,i=-nLevs/2,nLevs/2) /)
        !write (*,*) levels
        !do i=0,nLevs-1
        !    call contur ( r, nw, z, nh, bz, levels(i) )
        !end do
        !call endGrf ()
        !read (*,*)

    end subroutine bGradient

end module gc_terms


! The Computer Language Benchmarks Game
! http://benchmarksgame.alioth.debian.org/
!
! contributed by Andrei Jirnyi
!   Closely based on C codes by Bartlett/Bonzini/Mellor
! compilation: ifort -O2 -xHost -ipo pidigits2.f90 -lgmp

module gmp_mod
  ! declaring the GMP functions...
  use iso_c_binding
  type, bind(C) :: mpz_t
     private
     integer :: mp_alloc
     integer :: mp_size
     type(c_ptr) :: mp_d  ! a pointer
  end type mpz_t

  interface
!!      int mpz_cmp (mpz_t op1, mpz_t op2)
     integer(c_int) function  mpz_cmp(op1, op2) bind(C,name='__gmpz_cmp')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
     end function mpz_cmp
!!   void mpz_init (mpz_t integer)
     subroutine mpz_init(op) bind(C,name='__gmpz_init')
       import
       type(mpz_t), intent(inout) :: op
     end subroutine mpz_init
!!   void mpz_init_set_ui (mpz_t rop, unsigned long int op)
     subroutine mpz_init_set_ui(op, N) bind(C,name='__gmpz_init_set_ui')
       import
       type(mpz_t), intent(inout) :: op
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_init_set_ui
!!   void mpz_set (mpz_t rop, mpz_t op1)
     subroutine mpz_set(op1, op2) bind(C,name='__gmpz_set')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
     end subroutine mpz_set
!!      unsigned long int mpz_get_ui (mpz_t op)
     integer function  mpz_get_ui(op1) bind(C,name='__gmpz_get_ui')
       import
       type(mpz_t), intent(inout) :: op1
     end function mpz_get_ui
!!   void mpz_add (mpz_t rop, mpz_t op1, mpz_t op2)
     subroutine mpz_add(op1, op2, op3) bind(C,name='__gmpz_add')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       type(mpz_t), intent(inout) :: op3
     end subroutine mpz_add
!!   void mpz_mul_2exp (mpz_t rop, mpz_t op1, unsigned long int op2)
     subroutine mpz_mul_2exp(op1, op2, N) bind(C,name='__gmpz_mul_2exp')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_mul_2exp
!!   void mpz_fdiv_qr (mpz_t q, mpz_t r, mpz_t n, mpz_t d)
     subroutine mpz_fdiv_qr(op1, op2, op3, op4) bind(C,name='__gmpz_fdiv_qr')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       type(mpz_t), intent(inout) :: op3
       type(mpz_t), intent(inout) :: op4
     end subroutine mpz_fdiv_qr
!!   void mpz_mul_ui (mpz_t rop, mpz_t op1, unsigned long int op2)
     subroutine mpz_mul_ui(op1, op2, N) bind(C,name='__gmpz_mul_ui')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_mul_ui
!!   void mpz_submul_ui (mpz_t rop, mpz_t op1, unsigned long int op2)
     subroutine mpz_submul_ui(op1, op2, N) bind(C,name='__gmpz_submul_ui')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_submul_ui
!!   void mpz_addmul_ui (mpz_t rop, mpz_t op1, unsigned long int op2)
     subroutine mpz_addmul_ui(op1, op2, N) bind(C,name='__gmpz_addmul_ui')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_addmul_ui
  end interface
end module gmp_mod

program pidigits
  use iso_c_binding
  use gmp_mod
  implicit none

  integer(c_long) :: d, k=0, i=0, n=10000
  type(mpz_t) :: numer, accum, denom, tmp1, tmp2
  character(len=25) :: strout
  integer(8) :: intout=0

  character(len=10)  :: argv

  call getarg(1, argv)
  read(argv, *) n

  call mpz_init(tmp1);
  call mpz_init(tmp2);
  call mpz_init_set_ui(numer, 1);
  call mpz_init_set_ui(accum, 0);
  call mpz_init_set_ui(denom, 1);

  do
     do
        k = k+1
        call next_term(k)
        d = extract_digit()
        if(d /= -1) exit
     end do
     i = i+1
     intout = intout*10+d
     if(mod(i,10)==0) then
        write(strout,'(i10)') i
        write(*,'(i10.10,a,a)') intout,achar(9)//':',trim(adjustl(strout))
        intout=0
     end if
     if(i >= n) exit
     call eliminate_digit(d)
  end do

contains

!! Uses only one bigint division instead of two when checking a produced digit's validity.

!!  integer function extract_digit()
!!    if (mpz_cmp(numer, accum) > 0) then
!!       extract_digit = -1
!!       return
!!    end if

    call mpz_set(tmp1,accum)
    call mpz_addmul_ui(tmp1,numer,3)
    call mpz_fdiv_qr(tmp1, tmp2, tmp1, denom);
    call mpz_add(tmp2, tmp2, numer);

    if (mpz_cmp(tmp2, denom) >= 0) then
       extract_digit = -1
       return
    end if

    extract_digit = mpz_get_ui(tmp1);
    return
  end function extract_digit

  subroutine next_term(k)
    integer(c_long) k
    integer(c_long) y2
    y2 = k*2+1

    call mpz_addmul_ui(accum, numer, 2);
    call mpz_mul_ui(accum, accum, y2);
    call mpz_mul_ui(numer, numer, k);
    call mpz_mul_ui(denom, denom, y2);

  end subroutine next_term

  subroutine eliminate_digit(d)
    integer(c_long) d
    call mpz_submul_ui(accum, denom, d);
    call mpz_mul_ui(accum, accum, 10);
    call mpz_mul_ui(numer, numer, 10);
  end subroutine eliminate_digit

end program pidigits


	FUNCTION PS_BVFQ  ( datain, nparm, clev, ivcord )
C************************************************************************
C* PS_BVFQ								*
C*									*
C* This function computes the Brunt-Vaisala Frequency.			*
C*									*
C* REAL PS_BVFQ  ( DATAIN, NPARM, CLEV, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	PS_BVFQ		REAL		Brunt-Vaisala Frequency		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 7/90						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		datain (*)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
C*	Get Brunt-Vaisala Frequency squared.
C
	bvfqsq = PS_BVSQ  ( datain, nparm, clev, ivcord )
C
C*	The Brunt-Vaisala Frequency is the square root of this number.
C
	IF  ( ERMISS ( bvfqsq ) )  THEN
	    PS_BVFQ = RMISSD
	  ELSE
	    PS_BVFQ = SQRT ( bvfqsq )
	END IF
C*
	RETURN
	END


      program callfit3pbnd

      implicit double precision (a-h,o-z), integer(i-n)
      parameter (mamax=100, mg=1, mdw=mamax+mg, n=3, k=mamax+mg)
      parameter (lin=10, lout=11)
      dimension rate(mamax), temp(mamax)
      dimension w(mdw,n+1), ws(2*n+k+(mg+2)*(n+7)), x(n), ip(mg+2*n+2)

c     Purpose: calling program to test fit3pbnd subroutine

c     The input.dat_orig file has rate data for the rxn h + o2 = oh + o
c     from Miller (1997). T has units of Kelvin and k has units of
c     L/mol-s. The rate parameters should be A = 6.71e8 L/mol-s,
c     n = 0.55, Ea = 11.86 kcal/mol. Source: NIST kinetic database.

c     The input.dat file has data which give a negative activation energy
c     when fit with the original unbounded fit3p.f subroutine.
c     fit3p.f results (unbounded):  A=6.71e8,  n=2.000, Ea=-3.97
c     fit3pbnd.f results (bounded): A=1.25e12, n=1.153, Ea=0.0

c     open files for i/o
      open(lin, status='unknown', file='input.dat')
      open(lout, status='unknown', file='output.dat')

c     read input data (column 1 is T, column 2 is k)
      i = 1
 5    if (i.le.mamax) then ! only read first mamax points
         read(lin, *, end=15) temp(i), rate(i) ! break when eof reached
         i = i+1
         goto 5
      endif
 15   ma = i-1

c     calculate A, n, Tarr
      call fit3pbnd(ma, temp, rate, afactor, an, tarr,
     >              w, ws, x, ip, mg, mdw, n, mode)

c     check if solution was found
      if (mode.gt.0) then
         write(lout,*) 'No solution found in fit3pbnd: mode =', mode
         stop
      endif

c     convert Arrhenius temperautre to activation energy
      r  = 1.987d-3 ! kcal/mol-K
      ea = tarr*r   ! kcal/mol

c     print output and check goodness of fit
      write(lout,'(A, e13.5e3)') ' A [L/mol-s] = ', afactor
      write(lout,'(A, f12.4)')  ' n = ', an
      write(lout,'(A, f12.3)') ' Ea [kcal/mol] = ', ea
      write(lout,*)

      write(lout,'(A)') ' Temp     k           kfit'
      do i=1,ma
         t     = temp(i)
         rk    = rate(i)
         rkfit = afactor * t**an * exp(-tarr/t)

         write(lout,'(f7.1, e12.3, e12.3)') t, rk, rkfit
      end do

c     close files for i/o
      close(lin)
      close(lout)

      stop
      end
c
c
c
c
      subroutine fit3pbnd(ma, temp, ak,  afactor, an, tarr,
     >                    w, ws, x, ip, mg, mdw, n, mode)

      implicit double precision (a-h,o-z), integer(i-n)
      dimension ak(*), temp(*), w(mdw,*), ws(*), x(*), ip(*), prgopt(1)

c     Purpose: Fit Arrhenius parameters (A, n, Tarr) given data
c              for the rate constant at various temperatures.
c
c              Calls the DLSEI subroutine from the SLATEC library to solve
c              the constrained linear least-squares problem. The Arrhenius
c              temperature (Ea/R) is constrained to be non-negative. DLSEI.f
c              was downloaded from www.netlib.org on 8 March 04.
c
c     Inputs:  ma   = the number of data points for k and T
c              temp = a vector of temperatures
c              ak   = a vector of rate constants
c              w    = least-squares matrix and constraints
c              ws   = real workspace for LSEI
c              x    = solution vector x=[ln(A),n,Tarr]'
c              ip   = integer workspace for LSEI
c              mg   = number of inequality constraints
c              mdw  = first dimension of w (should be >= ma+me+mg)
c              n    = number of parameters in fitting
c
c     Outputs: afactor = the pre-exponential factor, A [same units as k]
c              an      = the temperature exponent, n
c              tarr    = Arrhenius temperature [same units as temp]
c              mode    = value returned by LSEI indicating if sol'n was found
c
c     Paul Yelvington, 8 March 04

c     construct the w matrix

c     equations to be solved in a least-squares sense
      do i=1,ma
         w(i,1) = 1.0d0
         w(i,2) = log(temp(i))
         w(i,3) = -1.0d0/temp(i)
         w(i,4) = log(ak(i))
      enddo

c     inequaility constraint (Tarr>=0)
      w(ma+1,1) = 0
      w(ma+1,2) = 0
      w(ma+1,3) = 1
      w(ma+1,4) = 0

c     parameters for LSEI
      me        = 0   ! number of equality constraints (equals 0)
      prgopt(1) = 1   ! use default parameters for LSEI

c     call LSEI to solve the constrained lls problem
      call dlsei(w, mdw, me, ma, mg, n, prgopt, x, rnorme,
     >           rnorml, mode, ws, ip)

c     calculate fitted Arrhenius parameters
      afactor = exp(x(1))
      an      = x(2)
      tarr    = x(3)

      return
      end


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Matrix-vector multiplication for sparse matrices (RCS format).
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nnz number of nonzero elements
!> @param[in] As sparse matrix
!> @param[in] Jsp pointer for sparsity pattern
!> @param[in] Isp pointer for sparsity pattern
!> @param[in] n  row of the matrix
!> @param[in] m  column of the matrix
!> @param[in] vet_in input vector for the multiplication As*vet_in
!> @param[in] error control parameter (dummy)
!> @param[out] vet_out result of the multiplication As*vet_in

        subroutine MATMUL_SPARSE(As, nnz, Jsp, Isp, vet_out, n, vet_in, m, error)

        implicit none

        integer*4 :: nnz, i, j, n, m, error
        integer*4 :: Jsp(nnz), Isp(0:n)

        real*8 :: As(nnz), vet_in(m), vet_out(n)

        vet_out = 0.d0

        do i = 1, n
           do j = Isp(i-1) + 1, Isp(i)
              vet_out(i) = vet_out(i) + As(j)*vet_in(Jsp(j))
           enddo
        enddo

        return
        end subroutine MATMUL_SPARSE


program test_mat
implicit none

real*4, allocatable:: A(:,:)
integer:: N,ii,jj

write(*,*) "give me the maximum number of rows for the square matrix"
read(*,*) N

do ii = 2,N
	allocate(A(1:ii,1:ii))
	call random_number(A)
	do jj = 1,ii
		write(*,*) A(jj,1:ii)
	end do
	write(*,*) ""
	deallocate(A)
end do

end program test_mat