*> \brief \b SLANSF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLANSF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )
*
*       .. Scalar Arguments ..
*       CHARACTER          NORM, TRANSR, UPLO
*       INTEGER            N
*       ..
*       .. Array Arguments ..
*       REAL               A( 0: * ), WORK( 0: * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLANSF returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> real symmetric matrix A in RFP format.
*> \endverbatim
*>
*> \return SLANSF
*> \verbatim
*>
*>    SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*>             (
*>             ( norm1(A),         NORM = '1', 'O' or 'o'
*>             (
*>             ( normI(A),         NORM = 'I' or 'i'
*>             (
*>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
*>
*> where  norm1  denotes the  one norm of a matrix (maximum column sum),
*> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
*> normF  denotes the  Frobenius norm of a matrix (square root of sum of
*> squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NORM
*> \verbatim
*>          NORM is CHARACTER*1
*>          Specifies the value to be returned in SLANSF as described
*>          above.
*> \endverbatim
*>
*> \param[in] TRANSR
*> \verbatim
*>          TRANSR is CHARACTER*1
*>          Specifies whether the RFP format of A is normal or
*>          transposed format.
*>          = 'N':  RFP format is Normal;
*>          = 'T':  RFP format is Transpose.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>           On entry, UPLO specifies whether the RFP matrix A came from
*>           an upper or lower triangular matrix as follows:
*>           = 'U': RFP A came from an upper triangular matrix;
*>           = 'L': RFP A came from a lower triangular matrix.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A. N >= 0. When N = 0, SLANSF is
*>          set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension ( N*(N+1)/2 );
*>          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
*>          part of the symmetric matrix A stored in RFP format. See the
*>          "Notes" below for more details.
*>          Unchanged on exit.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK)),
*>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*>          WORK is not referenced.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup realOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  We first consider Rectangular Full Packed (RFP) Format when N is
*>  even. We give an example where N = 6.
*>
*>      AP is Upper             AP is Lower
*>
*>   00 01 02 03 04 05       00
*>      11 12 13 14 15       10 11
*>         22 23 24 25       20 21 22
*>            33 34 35       30 31 32 33
*>               44 45       40 41 42 43 44
*>                  55       50 51 52 53 54 55
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
*>  the transpose of the first three columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
*>  the transpose of the last three columns of AP lower.
*>  This covers the case N even and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>        03 04 05                33 43 53
*>        13 14 15                00 44 54
*>        23 24 25                10 11 55
*>        33 34 35                20 21 22
*>        00 44 45                30 31 32
*>        01 11 55                40 41 42
*>        02 12 22                50 51 52
*>
*>  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
*>  transpose of RFP A above. One therefore gets:
*>
*>
*>           RFP A                   RFP A
*>
*>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
*>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
*>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
*>
*>
*>  We then consider Rectangular Full Packed (RFP) Format when N is
*>  odd. We give an example where N = 5.
*>
*>     AP is Upper                 AP is Lower
*>
*>   00 01 02 03 04              00
*>      11 12 13 14              10 11
*>         22 23 24              20 21 22
*>            33 34              30 31 32 33
*>               44              40 41 42 43 44
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
*>  the transpose of the first two columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
*>  the transpose of the last two columns of AP lower.
*>  This covers the case N odd and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>        02 03 04                00 33 43
*>        12 13 14                10 11 44
*>        22 23 24                20 21 22
*>        00 33 34                30 31 32
*>        01 11 44                40 41 42
*>
*>  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
*>  transpose of RFP A above. One therefore gets:
*>
*>           RFP A                   RFP A
*>
*>     02 12 22 00 01             00 10 20 30 40 50
*>     03 13 23 33 11             33 11 21 31 41 51
*>     04 14 24 34 44             43 44 22 32 42 52
*> \endverbatim
*
*  =====================================================================
      REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      CHARACTER          NORM, TRANSR, UPLO
      INTEGER            N
*     ..
*     .. Array Arguments ..
      REAL               A( 0: * ), WORK( 0: * )
*     ..
*
*  =====================================================================
*
*     ..
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, IFM, ILU, NOE, N1, K, L, LDA
      REAL               SCALE, S, VALUE, AA, TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, SISNAN
      EXTERNAL           LSAME, SISNAN
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLASSQ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
*     ..
*     .. Executable Statements ..
*
      VALUE = ZERO
      IF( N.EQ.0 ) THEN
         SLANSF = ZERO
         RETURN
      ELSE IF( N.EQ.1 ) THEN
         SLANSF = ABS( A(0) )
         RETURN
      END IF
*
*     set noe = 1 if n is odd. if n is even set noe=0
*
      NOE = 1
      IF( MOD( N, 2 ).EQ.0 )
     $   NOE = 0
*
*     set ifm = 0 when form='T or 't' and 1 otherwise
*
      IFM = 1
      IF( LSAME( TRANSR, 'T' ) )
     $   IFM = 0
*
*     set ilu = 0 when uplo='U or 'u' and 1 otherwise
*
      ILU = 1
      IF( LSAME( UPLO, 'U' ) )
     $   ILU = 0
*
*     set lda = (n+1)/2 when ifm = 0
*     set lda = n when ifm = 1 and noe = 1
*     set lda = n+1 when ifm = 1 and noe = 0
*
      IF( IFM.EQ.1 ) THEN
         IF( NOE.EQ.1 ) THEN
            LDA = N
         ELSE
*           noe=0
            LDA = N + 1
         END IF
      ELSE
*        ifm=0
         LDA = ( N+1 ) / 2
      END IF
*
      IF( LSAME( NORM, 'M' ) ) THEN
*
*       Find max(abs(A(i,j))).
*
         K = ( N+1 ) / 2
         VALUE = ZERO
         IF( NOE.EQ.1 ) THEN
*           n is odd
            IF( IFM.EQ.1 ) THEN
*           A is n by k
               DO J = 0, K - 1
                  DO I = 0, N - 1
                     TEMP = ABS( A( I+J*LDA ) )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END DO
            ELSE
*              xpose case; A is k by n
               DO J = 0, N - 1
                  DO I = 0, K - 1
                     TEMP = ABS( A( I+J*LDA ) )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END DO
            END IF
         ELSE
*           n is even
            IF( IFM.EQ.1 ) THEN
*              A is n+1 by k
               DO J = 0, K - 1
                  DO I = 0, N
                     TEMP = ABS( A( I+J*LDA ) )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END DO
            ELSE
*              xpose case; A is k by n+1
               DO J = 0, N
                  DO I = 0, K - 1
                     TEMP = ABS( A( I+J*LDA ) )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END DO
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
     $         ( NORM.EQ.'1' ) ) THEN
*
*        Find normI(A) ( = norm1(A), since A is symmetric).
*
         IF( IFM.EQ.1 ) THEN
            K = N / 2
            IF( NOE.EQ.1 ) THEN
*              n is odd
               IF( ILU.EQ.0 ) THEN
                  DO I = 0, K - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K
                     S = ZERO
                     DO I = 0, K + J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(i,j+k)
                        S = S + AA
                        WORK( I ) = WORK( I ) + AA
                     END DO
                     AA = ABS( A( I+J*LDA ) )
*                    -> A(j+k,j+k)
                     WORK( J+K ) = S + AA
                     IF( I.EQ.K+K )
     $                  GO TO 10
                     I = I + 1
                     AA = ABS( A( I+J*LDA ) )
*                    -> A(j,j)
                     WORK( J ) = WORK( J ) + AA
                     S = ZERO
                     DO L = J + 1, K - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
   10             CONTINUE
                  VALUE = WORK( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               ELSE
*                 ilu = 1
                  K = K + 1
*                 k=(n+1)/2 for n odd and ilu=1
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = K - 1, 0, -1
                     S = ZERO
                     DO I = 0, J - 2
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(j+k,i+k)
                        S = S + AA
                        WORK( I+K ) = WORK( I+K ) + AA
                     END DO
                     IF( J.GT.0 ) THEN
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(j+k,j+k)
                        S = S + AA
                        WORK( I+K ) = WORK( I+K ) + S
*                       i=j
                        I = I + 1
                     END IF
                     AA = ABS( A( I+J*LDA ) )
*                    -> A(j,j)
                     WORK( J ) = AA
                     S = ZERO
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  VALUE = WORK( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END IF
            ELSE
*              n is even
               IF( ILU.EQ.0 ) THEN
                  DO I = 0, K - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K - 1
                     S = ZERO
                     DO I = 0, K + J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(i,j+k)
                        S = S + AA
                        WORK( I ) = WORK( I ) + AA
                     END DO
                     AA = ABS( A( I+J*LDA ) )
*                    -> A(j+k,j+k)
                     WORK( J+K ) = S + AA
                     I = I + 1
                     AA = ABS( A( I+J*LDA ) )
*                    -> A(j,j)
                     WORK( J ) = WORK( J ) + AA
                     S = ZERO
                     DO L = J + 1, K - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  VALUE = WORK( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               ELSE
*                 ilu = 1
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = K - 1, 0, -1
                     S = ZERO
                     DO I = 0, J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(j+k,i+k)
                        S = S + AA
                        WORK( I+K ) = WORK( I+K ) + AA
                     END DO
                     AA = ABS( A( I+J*LDA ) )
*                    -> A(j+k,j+k)
                     S = S + AA
                     WORK( I+K ) = WORK( I+K ) + S
*                    i=j
                     I = I + 1
                     AA = ABS( A( I+J*LDA ) )
*                    -> A(j,j)
                     WORK( J ) = AA
                     S = ZERO
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  VALUE = WORK( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END IF
            END IF
         ELSE
*           ifm=0
            K = N / 2
            IF( NOE.EQ.1 ) THEN
*              n is odd
               IF( ILU.EQ.0 ) THEN
                  N1 = K
*                 n/2
                  K = K + 1
*                 k is the row size and lda
                  DO I = N1, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, N1 - 1
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,n1+i)
                        WORK( I+N1 ) = WORK( I+N1 ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = S
                  END DO
*                 j=n1=k-1 is special
                  S = ABS( A( 0+J*LDA ) )
*                 A(k-1,k-1)
                  DO I = 1, K - 1
                     AA = ABS( A( I+J*LDA ) )
*                    A(k-1,i+n1)
                     WORK( I+N1 ) = WORK( I+N1 ) + AA
                     S = S + AA
                  END DO
                  WORK( J ) = WORK( J ) + S
                  DO J = K, N - 1
                     S = ZERO
                     DO I = 0, J - K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(i,j-k)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
*                    i=j-k
                     AA = ABS( A( I+J*LDA ) )
*                    A(j-k,j-k)
                     S = S + AA
                     WORK( J-K ) = WORK( J-K ) + S
                     I = I + 1
                     S = ABS( A( I+J*LDA ) )
*                    A(j,j)
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,l)
                        WORK( L ) = WORK( L ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  VALUE = WORK( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               ELSE
*                 ilu=1
                  K = K + 1
*                 k=(n+1)/2 for n odd and ilu=1
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K - 2
*                    process
                     S = ZERO
                     DO I = 0, J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     AA = ABS( A( I+J*LDA ) )
*                    i=j so process of A(j,j)
                     S = S + AA
                     WORK( J ) = S
*                    is initialised here
                     I = I + 1
*                    i=j process A(j+k,j+k)
                     AA = ABS( A( I+J*LDA ) )
                     S = AA
                     DO L = K + J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(l,k+j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( K+J ) = WORK( K+J ) + S
                  END DO
*                 j=k-1 is special :process col A(k-1,0:k-1)
                  S = ZERO
                  DO I = 0, K - 2
                     AA = ABS( A( I+J*LDA ) )
*                    A(k,i)
                     WORK( I ) = WORK( I ) + AA
                     S = S + AA
                  END DO
*                 i=k-1
                  AA = ABS( A( I+J*LDA ) )
*                 A(k-1,k-1)
                  S = S + AA
                  WORK( I ) = S
*                 done with col j=k+1
                  DO J = K, N - 1
*                    process col j of A = A(j,0:k-1)
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  VALUE = WORK( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END IF
            ELSE
*              n is even
               IF( ILU.EQ.0 ) THEN
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K - 1
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,i+k)
                        WORK( I+K ) = WORK( I+K ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = S
                  END DO
*                 j=k
                  AA = ABS( A( 0+J*LDA ) )
*                 A(k,k)
                  S = AA
                  DO I = 1, K - 1
                     AA = ABS( A( I+J*LDA ) )
*                    A(k,k+i)
                     WORK( I+K ) = WORK( I+K ) + AA
                     S = S + AA
                  END DO
                  WORK( J ) = WORK( J ) + S
                  DO J = K + 1, N - 1
                     S = ZERO
                     DO I = 0, J - 2 - K
                        AA = ABS( A( I+J*LDA ) )
*                       A(i,j-k-1)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
*                     i=j-1-k
                     AA = ABS( A( I+J*LDA ) )
*                    A(j-k-1,j-k-1)
                     S = S + AA
                     WORK( J-K-1 ) = WORK( J-K-1 ) + S
                     I = I + 1
                     AA = ABS( A( I+J*LDA ) )
*                    A(j,j)
                     S = AA
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,l)
                        WORK( L ) = WORK( L ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
*                 j=n
                  S = ZERO
                  DO I = 0, K - 2
                     AA = ABS( A( I+J*LDA ) )
*                    A(i,k-1)
                     WORK( I ) = WORK( I ) + AA
                     S = S + AA
                  END DO
*                 i=k-1
                  AA = ABS( A( I+J*LDA ) )
*                 A(k-1,k-1)
                  S = S + AA
                  WORK( I ) = WORK( I ) + S
                  VALUE = WORK ( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               ELSE
*                 ilu=1
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
*                 j=0 is special :process col A(k:n-1,k)
                  S = ABS( A( 0 ) )
*                 A(k,k)
                  DO I = 1, K - 1
                     AA = ABS( A( I ) )
*                    A(k+i,k)
                     WORK( I+K ) = WORK( I+K ) + AA
                     S = S + AA
                  END DO
                  WORK( K ) = WORK( K ) + S
                  DO J = 1, K - 1
*                    process
                     S = ZERO
                     DO I = 0, J - 2
                        AA = ABS( A( I+J*LDA ) )
*                       A(j-1,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     AA = ABS( A( I+J*LDA ) )
*                    i=j-1 so process of A(j-1,j-1)
                     S = S + AA
                     WORK( J-1 ) = S
*                    is initialised here
                     I = I + 1
*                    i=j process A(j+k,j+k)
                     AA = ABS( A( I+J*LDA ) )
                     S = AA
                     DO L = K + J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(l,k+j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( K+J ) = WORK( K+J ) + S
                  END DO
*                 j=k is special :process col A(k,0:k-1)
                  S = ZERO
                  DO I = 0, K - 2
                     AA = ABS( A( I+J*LDA ) )
*                    A(k,i)
                     WORK( I ) = WORK( I ) + AA
                     S = S + AA
                  END DO
*                 i=k-1
                  AA = ABS( A( I+J*LDA ) )
*                 A(k-1,k-1)
                  S = S + AA
                  WORK( I ) = S
*                 done with col j=k+1
                  DO J = K + 1, N
*                    process col j-1 of A = A(j-1,0:k-1)
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j-1,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     WORK( J-1 ) = WORK( J-1 ) + S
                  END DO
                  VALUE = WORK( 0 )
                  DO I = 1, N-1
                     TEMP = WORK( I )
                     IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) )
     $                    VALUE = TEMP
                  END DO
               END IF
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
*       Find normF(A).
*
         K = ( N+1 ) / 2
         SCALE = ZERO
         S = ONE
         IF( NOE.EQ.1 ) THEN
*           n is odd
            IF( IFM.EQ.1 ) THEN
*              A is normal
               IF( ILU.EQ.0 ) THEN
*                 A is upper
                  DO J = 0, K - 3
                     CALL SLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S )
*                    L at A(k,0)
                  END DO
                  DO J = 0, K - 1
                     CALL SLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S )
*                    trap U at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K-1, A( K ), LDA+1, SCALE, S )
*                 tri L at A(k,0)
                  CALL SLASSQ( K, A( K-1 ), LDA+1, SCALE, S )
*                 tri U at A(k-1,0)
               ELSE
*                 ilu=1 & A is lower
                  DO J = 0, K - 1
                     CALL SLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S )
*                    trap L at A(0,0)
                  END DO
                  DO J = 0, K - 2
                     CALL SLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S )
*                    U at A(0,1)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S )
*                 tri L at A(0,0)
                  CALL SLASSQ( K-1, A( 0+LDA ), LDA+1, SCALE, S )
*                 tri U at A(0,1)
               END IF
            ELSE
*              A is xpose
               IF( ILU.EQ.0 ) THEN
*                 A**T is upper
                  DO J = 1, K - 2
                     CALL SLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S )
*                    U at A(0,k)
                  END DO
                  DO J = 0, K - 2
                     CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                    k by k-1 rect. at A(0,0)
                  END DO
                  DO J = 0, K - 2
                     CALL SLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1,
     $                            SCALE, S )
*                    L at A(0,k-1)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K-1, A( 0+K*LDA ), LDA+1, SCALE, S )
*                 tri U at A(0,k)
                  CALL SLASSQ( K, A( 0+( K-1 )*LDA ), LDA+1, SCALE, S )
*                 tri L at A(0,k-1)
               ELSE
*                 A**T is lower
                  DO J = 1, K - 1
                     CALL SLASSQ( J, A( 0+J*LDA ), 1, SCALE, S )
*                    U at A(0,0)
                  END DO
                  DO J = K, N - 1
                     CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                    k by k-1 rect. at A(0,k)
                  END DO
                  DO J = 0, K - 3
                     CALL SLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S )
*                    L at A(1,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S )
*                 tri U at A(0,0)
                  CALL SLASSQ( K-1, A( 1 ), LDA+1, SCALE, S )
*                 tri L at A(1,0)
               END IF
            END IF
         ELSE
*           n is even
            IF( IFM.EQ.1 ) THEN
*              A is normal
               IF( ILU.EQ.0 ) THEN
*                 A is upper
                  DO J = 0, K - 2
                     CALL SLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S )
*                    L at A(k+1,0)
                  END DO
                  DO J = 0, K - 1
                     CALL SLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S )
*                    trap U at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K, A( K+1 ), LDA+1, SCALE, S )
*                 tri L at A(k+1,0)
                  CALL SLASSQ( K, A( K ), LDA+1, SCALE, S )
*                 tri U at A(k,0)
               ELSE
*                 ilu=1 & A is lower
                  DO J = 0, K - 1
                     CALL SLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S )
*                    trap L at A(1,0)
                  END DO
                  DO J = 1, K - 1
                     CALL SLASSQ( J, A( 0+J*LDA ), 1, SCALE, S )
*                    U at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K, A( 1 ), LDA+1, SCALE, S )
*                 tri L at A(1,0)
                  CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S )
*                 tri U at A(0,0)
               END IF
            ELSE
*              A is xpose
               IF( ILU.EQ.0 ) THEN
*                 A**T is upper
                  DO J = 1, K - 1
                     CALL SLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S )
*                    U at A(0,k+1)
                  END DO
                  DO J = 0, K - 1
                     CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                    k by k rect. at A(0,0)
                  END DO
                  DO J = 0, K - 2
                     CALL SLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE,
     $                            S )
*                    L at A(0,k)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K, A( 0+( K+1 )*LDA ), LDA+1, SCALE, S )
*                 tri U at A(0,k+1)
                  CALL SLASSQ( K, A( 0+K*LDA ), LDA+1, SCALE, S )
*                 tri L at A(0,k)
               ELSE
*                 A**T is lower
                  DO J = 1, K - 1
                     CALL SLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S )
*                    U at A(0,1)
                  END DO
                  DO J = K + 1, N
                     CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                    k by k rect. at A(0,k+1)
                  END DO
                  DO J = 0, K - 2
                     CALL SLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S )
*                    L at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  CALL SLASSQ( K, A( LDA ), LDA+1, SCALE, S )
*                 tri L at A(0,1)
                  CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S )
*                 tri U at A(0,0)
               END IF
            END IF
         END IF
         VALUE = SCALE*SQRT( S )
      END IF
*
      SLANSF = VALUE
      RETURN
*
*     End of SLANSF
*
      END


      subroutine vecpot (ax, ay, az, i, nlo, nhi)
c ----------------------------------------------------------------------
      use stel_kinds
      use bnvariables, only: indu, indv, guu, guv, gvv, djx, djy, djz,
     1    x, y, z, tanu, tanv
      implicit none
      integer, intent(in) :: i, nlo, nhi
      integer :: ip, istat
      real(rprec), intent(inout) :: ax, ay, az
      real(rprec), target, allocatable :: dx(:), dy(:), dz(:)
      real(rprec), pointer :: sq(:), sqs(:), du(:), dv(:)
      real(rprec) :: sqsum
c ----------------------------------------------------------------------
      ip = nhi - nlo + 1
      if (ip .le. 0) return

      allocate (dx(nlo:nhi), dy(nlo:nhi), dz(nlo:nhi), stat=istat)
      if (istat .ne. 0) stop 'Allocation error in BNORM routine vecpot'

      sq => dz
      du => dx
      dv => dy
      sqs => dy

      dx    = x(i) - x(nlo:nhi)
      dy    = y(i) - y(nlo:nhi)
      dz    = z(i) - z(nlo:nhi)
      sq    = 1._dp/sqrt(dx*dx + dy*dy + dz*dz)
      du    = tanu(indu(nlo:nhi) - indu(i))
      dv    = tanv(indv(nlo:nhi) - indv(i))
      sqs   = 1._dp/sqrt(guu(i)*du*du + 2._dp*guv(i)*du*dv
     1                 + gvv(i)*dv*dv)

      sqsum = sum(sqs)

      ax = ax + sum(djx(nlo:nhi)*sq) - djx(i)*sqsum
      ay = ay + sum(djy(nlo:nhi)*sq) - djy(i)*sqsum
      az = az + sum(djz(nlo:nhi)*sq) - djz(i)*sqsum

      deallocate (dx, dy, dz)

      end subroutine vecpot


!********************************************************************************
!* This file is part of:
!* BAFFLE (https://github.com/ATHannington/BAFFLE)
!* BAFFLE: BAsic Fortran FLuids Engine
!*
!* BAFFLE:
!* Copyright (C) 2017 Andrew Hannington (ath4@st-andrews.ac.uk)
!*
!* This software is a derivative of work by Bert Vandenbroucke
!* (bert.vandenbroucke@gmail.com)
!* Find more work by Bert Vandenbroucke at: (https://github.com/bwvdnbro)
!*
!* BAFFLE is a 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.
!*
!* BAFFLE 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 BAFFLE. If not, see
!* <http://www.gnu.org/licenses/>.
!********************************************************************************

!********************************************************************************
!* @file periodic_bounds_subroutine_3D.f90
!*
!* @Periodic boundary conditions subroutine in 3D: Fortran 90 version.
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!-------------------------------------------------------------------------------
!Compact subroutine for periodic boundary conditions. Reverses the direction of
!velocity and momentum
!-------------------------------------------------------------------------------
subroutine bounds

	use constants
	implicit none
		integer :: i,j,k,d
		Real*8 :: m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
			& grad_d_x,grad_d_y,grad_d_z, &
			& grad_ux_x,grad_uy_x,grad_uz_x, &
			& grad_ux_y,grad_uy_y,grad_uz_y, &
			& grad_ux_z,grad_uy_z,grad_uz_z, &
			& grad_p_x,grad_p_y,grad_p_z

!	Cells format: 	cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)

	d=1									!Counter to move over variables within a cell for two ghost cells
	i=1
	j=1
	k=1

!==============================================================================
!*****			X-Axis Face Ghost Cells:			  ******
!==============================================================================

!	Face normal to: -ve x-axis
	i=1
	j=1
	k=1
	Do while(k<=NcZ)
		j=1
		Do while(j<=NcY)

!	Set values of this face equal to those NcX-1 cell in x-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(NcX-1,j,k,mn)
			qx=+1.d0*cells(NcX-1,j,k,qxn)
			qy=+1.d0*cells(NcX-1,j,k,qyn)
			qz=+1.d0*cells(NcX-1,j,k,qzn)
			E = cells(NcX-1,j,k,En)
			rho = cells(NcX-1,j,k,rhon)
			ux = +1.d0*cells(NcX-1,j,k,uxn)
			uy = +1.d0*cells(NcX-1,j,k,uyn)
			uz = +1.d0*cells(NcX-1,j,k,uzn)
			p = cells(NcX-1,j,k,pn)
			V = cells(NcX-1,j,k,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients equal to those in NcX-1 cell in x-direction for periodic boundary:
			grad_d_x= cells(NcX-1,j,k,gdxn)
			grad_d_y=cells(NcX-1,j,k,gdyn)
			grad_d_z=cells(NcX-1,j,k,gdzn)
			grad_ux_x=cells(NcX-1,j,k,guxxn)
			grad_uy_x=cells(NcX-1,j,k,guyxn)
			grad_uz_x=cells(NcX-1,j,k,guzxn)
			grad_ux_y=cells(NcX-1,j,k,guxyn)
			grad_uy_y=cells(NcX-1,j,k,guyyn)
			grad_uz_y=cells(NcX-1,j,k,guzyn)
			grad_ux_z=cells(NcX-1,j,k,guxzn)
			grad_uy_z=cells(NcX-1,j,k,guyzn)
			grad_uz_z=cells(NcX-1,j,k,guzzn)
			grad_p_x=cells(NcX-1,j,k,gpxn)
			grad_p_y=cells(NcX-1,j,k,gpyn)
			grad_p_z=cells(NcX-1,j,k,gpzn)

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)

			j=j+1
		enddo
		k=k+1
	enddo

!	Face normal to: +ve x-axis
	i=NcX
	j=1
	k=1
	Do while(k<=NcZ)
		j=1
		Do while(j<=NcY)

!	Set values of this face equal to those +2 cell in x-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(2,j,k,mn)
			qx=+1.d0*cells(2,j,k,qxn)
			qy=+1.d0*cells(2,j,k,qyn)
			qz=+1.d0*cells(2,j,k,qzn)
			E = cells(2,j,k,En)
			rho = cells(2,j,k,rhon)
			ux = +1.d0*cells(2,j,k,uxn)
			uy = +1.d0*cells(2,j,k,uyn)
			uz = +1.d0*cells(2,j,k,uzn)
			p = cells(2,j,k,pn)
			V = cells(2,j,k,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients equal to those in +2 cell in x-direction for periodic boundary:

			grad_d_x= cells(2,j,k,gdxn)
			grad_d_y=cells(2,j,k,gdyn)
			grad_d_z=cells(2,j,k,gdzn)
			grad_ux_x=cells(2,j,k,guxxn)
			grad_uy_x=cells(2,j,k,guyxn)
			grad_uz_x=cells(2,j,k,guzxn)
			grad_ux_y=cells(2,j,k,guxyn)
			grad_uy_y=cells(2,j,k,guyyn)
			grad_uz_y=cells(2,j,k,guzyn)
			grad_ux_z=cells(2,j,k,guxzn)
			grad_uy_z=cells(2,j,k,guyzn)
			grad_uz_z=cells(2,j,k,guzzn)
			grad_p_x=cells(2,j,k,gpxn)
			grad_p_y=cells(2,j,k,gpyn)
			grad_p_z=cells(2,j,k,gpzn)

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)

			j=j+1
		enddo
		k=k+1
	enddo

!==============================================================================
!*****			y-Axis Face Ghost Cells:			  ******
!==============================================================================

!	Face normal to: -ve y-axis
	i=1
	j=1
	k=1
	Do while(k<=NcZ)
		i=1
		Do while(i<=NcX)

!	Set values of this face equal to those NcY-1 cell in y-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(i,NcY-1,k,mn)
			qx=+1.d0*cells(i,NcY-1,k,qxn)
			qy=+1.d0*cells(i,NcY-1,k,qyn)
			qz=+1.d0*cells(i,NcY-1,k,qzn)
			E = cells(i,NcY-1,k,En)
			rho = cells(i,NcY-1,k,rhon)
			ux = +1.d0*cells(i,NcY-1,k,uxn)
			uy = +1.d0*cells(i,NcY-1,k,uyn)
			uz = +1.d0*cells(i,NcY-1,k,uzn)
			p = cells(i,NcY-1,k,pn)
			V = cells(i,NcY-1,k,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients equal to those in NcY-1 cell in y-direction for periodic boundary:

			grad_d_x= cells(i,NcY-1,k,gdxn)
			grad_d_y=cells(i,NcY-1,k,gdyn)
			grad_d_z=cells(i,NcY-1,k,gdzn)
			grad_ux_x=cells(i,NcY-1,k,guxxn)
			grad_uy_x=cells(i,NcY-1,k,guyxn)
			grad_uz_x=cells(i,NcY-1,k,guzxn)
			grad_ux_y=cells(i,NcY-1,k,guxyn)
			grad_uy_y=cells(i,NcY-1,k,guyyn)
			grad_uz_y=cells(i,NcY-1,k,guzyn)
			grad_ux_z=cells(i,NcY-1,k,guxzn)
			grad_uy_z=cells(i,NcY-1,k,guyzn)
			grad_uz_z=cells(i,NcY-1,k,guzzn)
			grad_p_x=cells(i,NcY-1,k,gpxn)
			grad_p_y=cells(i,NcY-1,k,gpyn)
			grad_p_z=cells(i,NcY-1,k,gpzn)

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)
			i=i+1
		enddo
		k=k+1
	enddo

!	Face normal to: +ve y-axis
	i=1
	j=NcY
	k=1
	Do while(k<=NcZ)
		i=1
		Do while(i<=NcX)

!	Set values of this face equal to those +2 cell in y-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(i,2,k,mn)
			qx=+1.d0*cells(i,2,k,qxn)
			qy=+1.d0*cells(i,2,k,qyn)
			qz=+1.d0*cells(i,2,k,qzn)
			E = cells(i,2,k,En)
			rho = cells(i,2,k,rhon)
			ux = +1.d0*cells(i,2,k,uxn)
			uy = +1.d0*cells(i,2,k,uyn)
			uz = +1.d0*cells(i,2,k,uzn)
			p = cells(i,2,k,pn)
			V = cells(i,2,k,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients equal to those in +2 cell in y-direction for periodic boundary:

			grad_d_x= cells(i,2,k,gdxn)
			grad_d_y=cells(i,2,k,gdyn)
			grad_d_z=cells(i,2,k,gdzn)
			grad_ux_x=cells(i,2,k,guxxn)
			grad_uy_x=cells(i,2,k,guyxn)
			grad_uz_x=cells(i,2,k,guzxn)
			grad_ux_y=cells(i,2,k,guxyn)
			grad_uy_y=cells(i,2,k,guyyn)
			grad_uz_y=cells(i,2,k,guzyn)
			grad_ux_z=cells(i,2,k,guxzn)
			grad_uy_z=cells(i,2,k,guyzn)
			grad_uz_z=cells(i,2,k,guzzn)
			grad_p_x=cells(i,2,k,gpxn)
			grad_p_y=cells(i,2,k,gpyn)
			grad_p_z=cells(i,2,k,gpzn)

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)
			i=i+1
		enddo
		k=k+1
	enddo

!==============================================================================
!*****			z-Axis Face Ghost Cells:			  ******
!==============================================================================

!	Face normal to: -ve z-axis
	i=1
	j=1
	k=1
	Do while(j<=NcY)
		i=1
		Do while(i<=NcX)

!	Set values of this face equal to those NcZ-1 cell in z-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(i,j,NcZ-1,mn)
			qx=+1.d0*cells(i,j,NcZ-1,qxn)
			qy=+1.d0*cells(i,j,NcZ-1,qyn)
			qz=+1.d0*cells(i,j,NcZ-1,qzn)
			E = cells(i,j,NcZ-1,En)
			rho = cells(i,j,NcZ-1,rhon)
			ux = +1.d0*cells(i,j,NcZ-1,uxn)
			uy = +1.d0*cells(i,j,NcZ-1,uyn)
			uz = +1.d0*cells(i,j,NcZ-1,uzn)
			p = cells(i,j,NcZ-1,pn)
			V = cells(i,j,NcZ-1,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients equal to those in NcZ-1 cell in z-direction for periodic boundary:

			grad_d_x= cells(i,j,NcZ-1,gdxn)
			grad_d_y=cells(i,j,NcZ-1,gdyn)
			grad_d_z=cells(i,j,NcZ-1,gdzn)
			grad_ux_x=cells(i,j,NcZ-1,guxxn)
			grad_uy_x=cells(i,j,NcZ-1,guyxn)
			grad_uz_x=cells(i,j,NcZ-1,guzxn)
			grad_ux_y=cells(i,j,NcZ-1,guxyn)
			grad_uy_y=cells(i,j,NcZ-1,guyyn)
			grad_uz_y=cells(i,j,NcZ-1,guzyn)
			grad_ux_z=cells(i,j,NcZ-1,guxzn)
			grad_uy_z=cells(i,j,NcZ-1,guyzn)
			grad_uz_z=cells(i,j,NcZ-1,guzzn)
			grad_p_x=cells(i,j,NcZ-1,gpxn)
			grad_p_y=cells(i,j,NcZ-1,gpyn)
			grad_p_z=cells(i,j,NcZ-1,gpzn)

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)
			i=i+1
		enddo
		j=j+1
	enddo

!	Face normal to: +ve z-axis
	i=1
	j=1
	k=NcZ
	Do while(j<=NcY)
		i=1
		Do while(i<=NcX)

!	Set values of this face equal to those +2 cell in z-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(i,j,2,mn)
			qx=+1.d0*cells(i,j,2,qxn)
			qy=+1.d0*cells(i,j,2,qyn)
			qz=+1.d0*cells(i,j,2,qzn)
			E = cells(i,j,2,En)
			rho = cells(i,j,2,rhon)
			ux = +1.d0*cells(i,j,2,uxn)
			uy = +1.d0*cells(i,j,2,uyn)
			uz = +1.d0*cells(i,j,2,uzn)
			p = cells(i,j,2,pn)
			V = cells(i,j,2,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients equal to those in +2 cell in z-direction for periodic boundary:
			grad_d_x= cells(i,j,2,gdxn)
			grad_d_y=cells(i,j,2,gdyn)
			grad_d_z=cells(i,j,2,gdzn)
			grad_ux_x=cells(i,j,2,guxxn)
			grad_uy_x=cells(i,j,2,guyxn)
			grad_uz_x=cells(i,j,2,guzxn)
			grad_ux_y=cells(i,j,2,guxyn)
			grad_uy_y=cells(i,j,2,guyyn)
			grad_uz_y=cells(i,j,2,guzyn)
			grad_ux_z=cells(i,j,2,guxzn)
			grad_uy_z=cells(i,j,2,guyzn)
			grad_uz_z=cells(i,j,2,guzzn)
			grad_p_x=cells(i,j,2,gpxn)
			grad_p_y=cells(i,j,2,gpyn)
			grad_p_z=cells(i,j,2,gpzn)

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)

			i=i+1
		enddo
		j=j+1
	enddo

end subroutine bounds


!***********************************************************************
!                                                                      *
      SUBROUTINE IN(IORB, JP, P, Q, MTP)
!                                                                      *
!   This program computes the solution of an  inhomogeneous  pair of   *
!   radial Dirac equations in the tail region. A simple extension of   *
!   the method of  C Froese Fischer [C Froese, Can J Phys, 41 (1963)   *
!   1895]  is  used. The  equations  are treated as a boundary value   *
!   problem, with  the value of P(r) given at the inner boundary and   *
!   required to  be  sufficiently small  at the outer boundary.  The   *
!   location  of this second boundary is determined in the course of   *
!   the calculation. The same  finite  difference equations are used   *
!   as in the outward integration.                                     *
!                                                                      *
!   Arguments:                                                         *
!                                                                      *
!      IORB: (Input) Index of orbital                                  *
!      JP:   (Input) Tabulation point at which the outward             *
!            integration terminated                                    *
!      P,Q:  (Input and Output) arrays containing, respectively, the   *
!            large and small components of the solution                *
!      MTP:  (Output) Maximum tabulation point of functions P, Q       *
!                                                                      *
!   When  written  in  matrix form the system of linear equations iS   *
!   M*W = V, where  W  is a vector consisting of the elements Q(JP),   *
!   P(JP+1), Q(JP+1), ... . The matrix  M  is  of band type, with  5   *
!   elements  in each row.  M is  expressed as a product of two tri-   *
!   angular matrices L and  U (the L/U decomposition, carried out by   *
!   the Crout procedure), variable elements of L being stored in the   *
!   arrays TC, TD  and TE, and  variable elements of U in TH, TI and   *
!   TJ. The  solution vector W  is then obtained by solving two tri-   *
!   angular systems, L*Z = V AND U*W = Z.                              *
!                                                                      *
!   Call(s) to: [LIB92]: CONVRT.                                       *
!                                           Last update: 10 Dec 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:06:32   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param,  ONLY: DOUBLE
      USE parameter_def,    ONLY: NNNP
      USE def_C,            ONLY: accy
      USE grid_C,           ONLY: h, n, r, rpor
      USE int_C,            ONLY: TF, TG, XU, XV
      USE orb_C,            ONLY: nak
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE convrt_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: IORB
      INTEGER , INTENT(IN) :: JP
      INTEGER , INTENT(OUT) :: MTP
      REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP)
      REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, J, LCNUM, MTPP1
      REAL(DOUBLE), DIMENSION(NNNP) :: TH, TI, TJ, XR, XS
      REAL(DOUBLE) :: EPS, HHK, HHKF, CPJ, CMJ, CPJP1, CMJP1, TEI, TTHIS, TCI, &
         TDI, TLAST
      CHARACTER :: CNUM*5
!-----------------------------------------------
!
!   Global initializations
!
      EPS = 0.01D00*ACCY
      HHK = 0.5D00*H*DBLE(NAK(IORB))
!
!   Initialize counters
!
      I = 1
      J = JP
!
!   Other initializations
!
      HHKF = HHK*RPOR(J)
      CPJ = 1.0D00 + HHKF
      CMJ = 1.0D00 - HHKF
      HHKF = HHK*RPOR(J+1)
      CPJP1 = 1.0D00 + HHKF
      CMJP1 = 1.0D00 - HHKF
!
!   Compute required elements of first two rows of  L  and  U
!
      TH(I) = CPJ
      TEI = -TF(J)/TH(I)
      TI(I) = (-CPJP1) + TEI*TG(J+1)
      TJ(I) = CMJP1*TEI - TF(J+1)
!
!   First elements of solution vector Z
!
      XR(I) = (-XV(J)) + TG(J)*P(J)
      XS(I) = (-XU(J)) - CMJ*P(J) - TEI*XR(I)
!
      TTHIS = ABS(XS(I)/TI(I))
!
    1 CONTINUE
      I = I + 1
      J = J + 1
!
!   Failure if tables not long enough
!
      IF (J >= N) THEN
         CALL CONVRT (N, CNUM, LCNUM)
         WRITE (6, *) 'IN: maximum tabulation point exceeds'
         WRITE (6, *) ' dimensional limit (currently '//CNUM(1:LCNUM)//');'
         WRITE (6, *) ' radial wavefunction may indicate a'
         WRITE (6, *) ' continuum state.'
         STOP
      ENDIF
!
!   Compute required elements of remaining rows of  L  and  U
!
      CPJ = CPJP1
      CMJ = CMJP1
      HHKF = HHK*RPOR(J+1)
      CPJP1 = 1.0D00 + HHKF
      CMJP1 = 1.0D00 - HHKF
!
      TCI = -TG(J)/TI(I-1)
      TH(I) = CPJ - TCI*TJ(I-1)
      TDI = CMJ/TI(I-1)
      TEI = ((-TF(J))-TDI*TJ(I-1))/TH(I)
      TI(I) = (-CPJP1) + TEI*TG(J+1)
      TJ(I) = (-TF(J+1)) + CMJP1*TEI
!
!   Solution of  L*Z = V
!
      XR(I) = (-XV(J)) - TCI*XS(I-1)
      XS(I) = (-XU(J)) - TDI*XS(I-1) - TEI*XR(I)
!
!   Test for outer boundary
!
      TLAST = TTHIS
      TTHIS = ABS(XS(I)/TI(I))
      IF (TTHIS + TLAST <= EPS .OR. J .EQ. NNNP-1 ) THEN
         MTP = J
      ELSE
         GO TO 1
      ENDIF
!
!   Reset counter
!
      I = I - 1
!
!   Last two rows of solution of  U*W = Z ; evaluation of Q(J)
!
      Q(J) = 0.0D00
      P(J) = XS(I)/TI(I)
      Q(J-1) = (XR(I)+TG(J)*P(J))/TH(I)
!
!   Solution of  U*W = Z
!
    2 CONTINUE
      J = J - 1
      I = I - 1
!
      IF (I > 0) THEN
         P(J) = (XS(I)-TJ(I)*Q(J))/TI(I)
         Q(J-1) = (XR(I)+(1.0D00-HHK*RPOR(J))*Q(J)+TG(J)*P(J))/TH(I)
         GO TO 2
      ENDIF
!
!   Complete tables with zeroes
!
      MTPP1 = MTP + 1
      P(MTPP1:N) = 0.0D00
      Q(MTPP1:N) = 0.0D00
!
      RETURN
      END SUBROUTINE IN


module local_stage_vec

  USE OMP_LIB
  use Structure
  use Matrix_op
  use bar
  !use global_stage

  implicit none

  type :: local

    double precision, dimension(:,:,:,:), allocatable :: sigma
    double precision, dimension(:,:,:,:), allocatable :: d_Ep

  end type local

  type(local) :: L

  contains

  subroutine local_stage_vp_vec(I,Sop,sigma)

    type(Input), intent(inout) :: I
    !type(global), intent(inout) :: G
    type(Space_op), intent(inout) :: Sop
    double precision, dimension(:,:,:,:) :: sigma
    integer, dimension(4) :: siz
    double precision, dimension(Sop%comp,I%ngps,I%Nx,I%Tngpt) :: sigma_D,d_Ep,tau
    double precision, dimension(1,I%ngps,I%Nx,I%Tngpt) :: J2_sigma,iJ2_sigma,N,nlaw

    integer :: i1,j,k,l1
    double precision, dimension(1,I%ngps,I%Nx,I%Tngpt) :: f_K

    !integer :: ind
    !integer, dimension(1,I%Nx) :: v1,v2

    !!$OMP PARALLEL

    !PRINT *, 'Hello from process: ', OMP_GET_THREAD_NUM()

    siz = (/Sop%comp,I%ngps,I%Nx,I%Tngpt/)
    L%sigma      = sigma
    L%d_Ep = sigma
    !allocate(L%d_Ep( siz(1),siz(2),siz(3),siz(4) ))

    !$omp simd
    do i1=1,Sop%comp
      do j=1,I%ngps
        do k=1,I%Nx
          do l1=1,I%Tngpt
            sigma_D(i1,j,k,l1) = L%sigma(i1,j,k,l1) - L%sigma(i1,j,k,l1)/3
            tau(i1,j,k,l1) = sigma_D(i1,j,k,l1)

          end do
        end do
      end do
    end do
    !$omp end simd

    J2_sigma = reshape( sqrt(1.5*sum((tau)**2,1)), siz )

    !$omp simd
    do j=1,I%ngps
      do k=1,I%Nx
        do l1=1,I%Tngpt
          iJ2_sigma(1,j,k,l1) = 1/J2_sigma(1,j,k,l1)
        end do
      end do
    end do
    !$omp end simd

    where(J2_sigma == 0.D0) iJ2_sigma = 0.D0  !iJ2_sigma(J2_sigma==0) = 0;

    !$omp simd
    do i1=1,Sop%comp
      do j=1,I%ngps
        do k=1,I%Nx
          do l1=1,I%Tngpt
            N(i1,j,k,l1) = iJ2_sigma(1,j,k,l1)*tau(i1,j,k,l1)
          end do
        end do
      end do
    end do
    !$omp end simd

    !$omp simd
    do j=1,I%ngps
      do k=1,I%Nx
        do l1=1,I%Tngpt
          f_K(1,j,k,l1) = J2_sigma(1,j,k,l1)  - I%sigma_y
        end do
      end do
    end do
    !$omp end simd

    where(f_K<0.D0) f_K = 0.D0

    !$omp simd
    do j=1,I%ngps
      do k=1,I%Nx
        do l1=1,I%Tngpt
          nlaw(1,j,k,l1) = I%ks*(f_K(1,j,k,l1)**I%np)
        end do
      end do
    end do
    !$omp end simd

    !$omp simd
    do i1=1,Sop%comp
      do j=1,I%ngps
        do k=1,I%Nx
          do l1=1,I%Tngpt
            L%d_Ep(i1,j,k,l1)  = 3/2*(nlaw(1,j,k,l1)*N(i1,j,k,l1))
          end do
        end do
      end do
    end do
    !$omp end simd
    !stop

    !!$OMP END PARALLEL

  end subroutine local_stage_vp_vec

end module local_stage_vec


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_orthfact_2x2deflation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine deflates a 2x2 block in an orthogonal
!  upper-hessenberg matrix
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: eigenvectors, assumes Z already initialized
!                    .FALSE.: no eigenvectors
!
!  Q               REAL(8) array of dimension (2)
!                    array of generators for first sequence of rotations
!
!  D               REAL(8) arrays of dimension (2)
!                    array of generators for complex diagonal matrices
!
!  M               INTEGER
!                    leading dimension of Z
!
! OUTPUT VARIABLES:
!
!  Z               REAL(8) array of dimension (M,2)
!                    eigenvectors
!                    if VEC = .TRUE. updates eigenvectors in Z
!                    if VEC = .FALSE. unused
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_orthfact_2x2deflation(VEC,Q,D,M,Z)

  implicit none

  ! input variables
  logical, intent(in) :: VEC
  real(8), intent(inout) :: Q(2), D(2)
  integer, intent(in) :: M
  real(8), intent(inout) :: Z(M,2)

  ! compute variables
  real(8) :: nrm, row(2), temp(2,2)

  ! D scalar
  if (D(1).EQ.D(2)) then

    ! update Q
    Q = sign(1d0,D(1))*Q

    ! update D
    D = 1d0

  ! D not scalar
  else

    ! compute first row of Q*D
    row(1) = Q(1)*D(1)
    row(2) = -Q(2)*D(2)

    ! update D
    D(1) = -sign(1d0,row(1))
    D(2) = -D(1)

    ! update D
    Q(1) = 1d0
    Q(2) = 0d0

    ! subtract off +/-1
    row(1) = row(1) - D(1)

    ! construct eliminator
    call d_rot2_vec2gen(row(2),-row(1),temp(1,1),temp(2,1),nrm)

    ! update Z
    if (VEC) then
      temp(1,2) = -temp(2,1)
      temp(2,2) = temp(1,1)
      Z = matmul(Z,temp)
    end if

  end if

end subroutine d_orthfact_2x2deflation


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of visw in forward (tangent) mode:
!   variations   of useful results: visw
!   with respect to varying inputs: p t
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! 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.
!> @brief rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water
!> @param[in] p cell pressure [MPa]
!> @param[in] t temperature [degC]
!> @return visw  [Pa s]
!> @details
!> rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of  pure water,\n
!> given temperature (t, in C), and pressure (p,in Pa) at node(i,j,k)\n\n
!>
!>  Main source Zyvoloski1997: \n
!>
!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
!> of the models and methods for the FEHM application - a
!> finite-element heat- and mass-transfer code. United
!> States. doi:10.2172/565545. \n \n
!>
!> See Section 8.4.3. of Zyvoloski1997 for an explanation of the
!> "Rational function approximation" used in this subroutine. \n \n
!> The approximation uses the table of coefficients in Appendix 10 of
!> Zyvoloski1997.\n
!>
!> Alternative source (same text, more modern, without doi): \n
!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
!>
!> The table of coefficients from Zyvoloski1997 describes the physical
!> values found in Haar1984: \n
!>
!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
!> Thermodynamic and Transport Properties and Computer Programs for
!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
!> Corporation, Washington, 1984. \n \n
!>
!>    range of validity:\n
!>    - pressures   0.001 - 110 MPa,\n
!>    - temperature   15 - 360 degC\n
DOUBLE PRECISION FUNCTION g_VISW(p, g_p, t, g_t, visw)
  IMPLICIT NONE
! Temperature (degC)
  DOUBLE PRECISION, INTENT(IN) :: t
  DOUBLE PRECISION, INTENT(IN) :: g_t
! Pressure (MPa)
  DOUBLE PRECISION, INTENT(IN) :: p
  DOUBLE PRECISION, INTENT(IN) :: g_p
! Coefficients of numerator of rational function approximation
  DOUBLE PRECISION, PARAMETER :: y0=0.17409149d-02
  DOUBLE PRECISION, PARAMETER :: y1=0.18894882d-04
  DOUBLE PRECISION, PARAMETER :: y2=-0.66439332d-07
  DOUBLE PRECISION, PARAMETER :: y3=-0.23122388d-09
  DOUBLE PRECISION, PARAMETER :: y4=-0.31534914d-05
  DOUBLE PRECISION, PARAMETER :: y5=0.11120716d-07
  DOUBLE PRECISION, PARAMETER :: y6=-0.48576020d-10
  DOUBLE PRECISION, PARAMETER :: y7=0.28006861d-07
  DOUBLE PRECISION, PARAMETER :: y8=0.23225035d-09
  DOUBLE PRECISION, PARAMETER :: y9=0.47180171d-10
! Coefficients of denominator of rational function approximation
  DOUBLE PRECISION, PARAMETER :: z0=0.10000000d+01
  DOUBLE PRECISION, PARAMETER :: z1=0.10523153d-01
  DOUBLE PRECISION, PARAMETER :: z2=-0.22658391d-05
  DOUBLE PRECISION, PARAMETER :: z3=-0.31796607d-06
  DOUBLE PRECISION, PARAMETER :: z4=0.29869141d-01
  DOUBLE PRECISION, PARAMETER :: z5=0.21844248d-03
  DOUBLE PRECISION, PARAMETER :: z6=-0.87658855d-06
  DOUBLE PRECISION, PARAMETER :: z7=0.41690362d-03
  DOUBLE PRECISION, PARAMETER :: z8=-0.25147022d-05
  DOUBLE PRECISION, PARAMETER :: z9=0.22144660d-05
! Monomials of temperature and pressure
  DOUBLE PRECISION :: t2, t3
  DOUBLE PRECISION :: g_t2, g_t3
  DOUBLE PRECISION :: p2, p3, p4
  DOUBLE PRECISION :: g_p2, g_p3
  DOUBLE PRECISION :: tp, t2p, tp2
  DOUBLE PRECISION :: g_tp, g_t2p, g_tp2
! Numerator and denominator of rational function approximation
  DOUBLE PRECISION :: ta, tb
  DOUBLE PRECISION :: g_ta, g_tb
  DOUBLE PRECISION :: visw
! Compute monomials in pressure and temperature
  g_p2 = 2*p*g_p
  p2 = p*p
  g_p3 = p*g_p2 + p2*g_p
  p3 = p2*p
  p4 = p3*p
  g_t2 = 2*t*g_t
  t2 = t*t
  g_t3 = t*g_t2 + t2*g_t
  t3 = t2*t
  g_tp = t*g_p + p*g_t
  tp = p*t
  g_tp2 = p2*g_t + t*g_p2
  tp2 = t*p2
  g_t2p = p*g_t2 + t2*g_p
  t2p = t2*p
! Numerator of rational function approximation
  g_ta = y1*g_p + y2*g_p2 + y3*g_p3 + y4*g_t + y5*g_t2 + y6*&
&   g_t3 + y7*g_tp + y8*g_tp2 + y9*g_t2p
  ta = y0 + y1*p + y2*p2 + y3*p3 + y4*t + y5*t2 + y6*t3 + y7*tp + y8*tp2&
&   + y9*t2p
! Denominator of rational function approximation
  g_tb = z1*g_p + z2*g_p2 + z3*g_p3 + z4*g_t + z5*g_t2 + z6*&
&   g_t3 + z7*g_tp + z8*g_tp2 + z9*g_t2p
  tb = z0 + z1*p + z2*p2 + z3*p3 + z4*t + z5*t2 + z6*t3 + z7*tp + z8*tp2&
&   + z9*t2p
! Viscosity
  g_visw = (g_ta-ta*g_tb/tb)/tb
  visw = ta/tb
  RETURN
END FUNCTION g_VISW


C
C	$Id: mssrf2.f,v 1.5 2008-07-27 00:17:31 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      REAL FUNCTION MSSRF2 (XX,YY,M,N,X,Y,Z,IZ,ZP,SIGMA)
C
      INTEGER M,N,IZ
      REAL XX,YY,X(M),Y(N),Z(IZ,N),ZP(M,N,3),SIGMA
C
C ---------------------------------------------------------------------
C Note:  This routine comes from a proprietary package called FITPACK.
C It is used in the NCAR graphics package by permission of the author,
C Alan Cline.
C ---------------------------------------------------------------------
C
C                                            CODED BY ALAN KAYLOR CLINE
C                                         FROM FITPACK -- JUNE 22, 1986
C                                   A CURVE AND SURFACE FITTING PACKAGE
C                                 A PRODUCT OF PLEASANT VALLEY SOFTWARE
C                             8603 ALTUS COVE, AUSTIN, TEXAS 78759, USA
C
C ---------------------------------------------------------------------
C
C THIS FUNCTION INTERPOLATES A SURFACE AT A GIVEN COORDINATE
C PAIR USING A BI-SPLINE UNDER TENSION. THE SUBROUTINE MSSRF1
C SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY
C PARAMETERS.
C
C ON INPUT--
C
C   XX AND YY CONTAIN THE X- AND Y-COORDINATES OF THE POINT
C   TO BE MAPPED ONTO THE INTERPOLATING SURFACE.
C
C   M AND N CONTAIN THE NUMBER OF GRID LINES IN THE X- AND
C   Y-DIRECTIONS, RESPECTIVELY, OF THE RECTANGULAR GRID
C   WHICH SPECIFIED THE SURFACE.
C
C   X AND Y ARE ARRAYS CONTAINING THE X- AND Y-GRID VALUES,
C   RESPECTIVELY, EACH IN INCREASING ORDER.
C
C   Z IS A MATRIX CONTAINING THE M * N FUNCTIONAL VALUES
C   CORRESPONDING TO THE GRID VALUES (I. E. Z(I,J) IS THE
C   SURFACE VALUE AT THE POINT (X(I),Y(J)) FOR I = 1,...,M
C   AND J = 1,...,N).
C
C   IZ CONTAINS THE ROW DIMENSION OF THE ARRAY Z AS DECLARED
C   IN THE CALLING PROGRAM.
C
C   ZP IS AN ARRAY OF 3*M*N LOCATIONS STORED WITH THE
C   VARIOUS SURFACE DERIVATIVE INFORMATION DETERMINED BY
C   MSSRF1.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS M, N, X, Y, Z, IZ, ZP, AND SIGMA SHOULD BE
C INPUT UNALTERED FROM THE OUTPUT OF MSSRF1.
C
C ON OUTPUT--
C
C   MSSRF2 CONTAINS THE INTERPOLATED SURFACE VALUE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS FUNCTION REFERENCES PACKAGE MODULES MSNTVL AND
C MSSHCH.
C
C-----------------------------------------------------------
C
C INLINE ONE DIMENSIONAL CUBIC SPLINE INTERPOLATION
C
      HERMZ (F1,F2,FP1,FP2) = (F2*DEL1+F1*DEL2)/DELS-DEL1*
     *                        DEL2*(FP2*(DEL1+DELS)+
     *                              FP1*(DEL2+DELS))/
     *                        (6.*DELS)
C
C INLINE ONE DIMENSIONAL SPLINE UNDER TENSION INTERPOLATION
C
      HERMNZ (F1,F2,FP1,FP2,SIGMAP) = (F2*DEL1+F1*DEL2)/DELS
     *          +(FP2*DEL1*(SINHM1-SINHMS)
     *           +FP1*DEL2*(SINHM2-SINHMS)
     *          )/(SIGMAP*SIGMAP*DELS*(1.+SINHMS))
C
C DENORMALIZE TENSION FACTOR IN X AND Y DIRECTION
C
      SIGMAX = ABS(SIGMA)*REAL(M-1)/(X(M)-X(1))
      SIGMAY = ABS(SIGMA)*REAL(N-1)/(Y(N)-Y(1))
C
C DETERMINE Y INTERVAL
C
      JM1 = MSNTVL (YY,Y,N)
      J = JM1+1
C
C DETERMINE X INTERVAL
C
      IM1 = MSNTVL (XX,X,M)
      I = IM1+1
      DEL1 = YY-Y(JM1)
      DEL2 = Y(J)-YY
      DELS = Y(J)-Y(JM1)
      IF (SIGMAY .NE. 0.) GO TO 1
C
C PERFORM FOUR INTERPOLATIONS IN Y-DIRECTION
C
      ZIM1 = HERMZ(Z(I-1,J-1),Z(I-1,J),ZP(I-1,J-1,1),
     *                                  ZP(I-1,J,1))
      ZI = HERMZ(Z(I,J-1),Z(I,J),ZP(I,J-1,1),ZP(I,J,1))
      ZXXIM1 = HERMZ(ZP(I-1,J-1,2),ZP(I-1,J,2),
     *                ZP(I-1,J-1,3),ZP(I-1,J,3))
      ZXXI = HERMZ(ZP(I,J-1,2),ZP(I,J,2),
     *              ZP(I,J-1,3),ZP(I,J,3))
      GO TO 2
    1 CALL MSSHCH (SINHM1,DUMMY,SIGMAY*DEL1,-1)
      CALL MSSHCH (SINHM2,DUMMY,SIGMAY*DEL2,-1)
      CALL MSSHCH (SINHMS,DUMMY,SIGMAY*DELS,-1)
      ZIM1 = HERMNZ(Z(I-1,J-1),Z(I-1,J),ZP(I-1,J-1,1),
     *               ZP(I-1,J,1),SIGMAY)
      ZI = HERMNZ(Z(I,J-1),Z(I,J),ZP(I,J-1,1),ZP(I,J,1),
     *             SIGMAY)
      ZXXIM1 = HERMNZ(ZP(I-1,J-1,2),ZP(I-1,J,2),
     *                 ZP(I-1,J-1,3),ZP(I-1,J,3),SIGMAY)
      ZXXI = HERMNZ(ZP(I,J-1,2),ZP(I,J,2),
     *               ZP(I,J-1,3),ZP(I,J,3),SIGMAY)
C
C PERFORM FINAL INTERPOLATION IN X-DIRECTION
C
    2 DEL1 = XX-X(IM1)
      DEL2 = X(I)-XX
      DELS = X(I)-X(IM1)
      IF (SIGMAX .NE. 0.) GO TO 3
      MSSRF2 = HERMZ(ZIM1,ZI,ZXXIM1,ZXXI)
      RETURN
    3 CALL MSSHCH (SINHM1,DUMMY,SIGMAX*DEL1,-1)
      CALL MSSHCH (SINHM2,DUMMY,SIGMAX*DEL2,-1)
      CALL MSSHCH (SINHMS,DUMMY,SIGMAX*DELS,-1)
      MSSRF2 = HERMNZ(ZIM1,ZI,ZXXIM1,ZXXI,SIGMAX)
      RETURN
      END


!> Exponential RK stepper module for DIM=3
module pf_my_stepper
  use pf_mod_dtype
  use pf_mod_zndarray
  use pf_mod_erkstepper
  use pf_mod_fftpackage
  use pf_mod_solutions
  use phi_mod
  use pf_mod_zutils
  use pf_mod_fftops
  implicit none

  ! Define the derived stepper type
  type, extends(pf_erk_stepper_t) :: my_stepper_t
     integer ::     nx
     ! phi storage space
     complex(pfdp),  allocatable :: A_phi(:,:,:,:)          ! coefficients for A vector
     complex(pfdp),  allocatable :: b_phi(:,:,:,:)          ! coefficients for b vector
     complex(pfdp),  allocatable :: d_phi(:,:,:,:)          ! coefficients for d vector
     real(pfdp)                  :: dt_phi              ! dt used to store coefficients
     ! fft object and differentiaton matrices
     type(pf_fft_t), pointer :: fft_tool
     type(pf_fft_ops_t), pointer :: fft_ops
     complex(pfdp), allocatable :: tmp(:,:,:) ! temp space for feval
     complex(pfdp), pointer :: p_tmp(:,:,:)   ! a useful pointer
     !  Useful for making f_eval and f_comp generic
     class(pf_zndarray_t), pointer :: f_encap,rhs_encap,y_encap
     complex(pfdp),      pointer :: yvec(:,:,:), rhsvec(:,:,:), fvec(:,:,:)
   contains

     procedure :: f_eval       !  Computes the advection and diffusion terms
     procedure :: compA        !  applies phi functions for tableau matrix A(i,j)
     procedure :: compB        !  applied phi functions for tableau vector B(i)
     procedure :: compD        !  applies phi functions for tableau vector D(i)
     procedure :: initialize
     procedure :: destroy
     procedure, private :: initRKCoeff
     procedure, private :: mult_dphi
     procedure, private :: mult_bphi
     procedure, private :: mult_Aphi
     procedure, private :: initialize_tmp
  end type my_stepper_t

contains
  subroutine mult_Aphi(this,i,y,f)
    class(my_stepper_t), intent(inout) :: this
    integer, intent(in) :: i
    class(pf_encap_t), intent(in) :: y
    class(pf_encap_t), intent(in) :: f

    complex(pfdp),        pointer :: yvec(:,:,:), fvec(:,:,:)
    class(pf_zndarray_t), pointer :: y_encap,f_encap
    y_encap => cast_as_zndarray(y)
    call y_encap%get_array(yvec)
    f_encap => cast_as_zndarray(f)
    call f_encap%get_array(fvec)

    yvec=this%A_phi(:,:,:, i)*fvec
  end subroutine mult_Aphi

  subroutine mult_dphi(this,i,y,f)
    class(my_stepper_t), intent(inout) :: this
    integer, intent(in) :: i
    class(pf_encap_t), intent(in) :: y
    class(pf_encap_t), intent(in) :: f

    complex(pfdp),        pointer :: yvec(:,:,:), fvec(:,:,:)
    class(pf_zndarray_t), pointer :: y_encap,f_encap
    y_encap => cast_as_zndarray(y)
    call y_encap%get_array(yvec)
    f_encap => cast_as_zndarray(f)
    call f_encap%get_array(fvec)

    yvec=this%d_phi(:,:,:, i)*fvec
  end subroutine mult_dphi

  subroutine mult_bphi(this,i,y,f)
    class(my_stepper_t), intent(inout) :: this
    integer, intent(in) :: i
    class(pf_encap_t), intent(in) :: y
    class(pf_encap_t), intent(in) :: f

    complex(pfdp),        pointer :: yvec(:,:,:), fvec(:,:,:)
    class(pf_zndarray_t), pointer :: y_encap,f_encap
    y_encap => cast_as_zndarray(y)
    call y_encap%get_array(yvec)
    f_encap => cast_as_zndarray(f)
    call f_encap%get_array(fvec)

    yvec=this%b_phi(:,:,:, i)*fvec
  end subroutine mult_bphi

  subroutine initialize_tmp(this)
    class(my_stepper_t), intent(inout) :: this

    integer :: istat,nx
    nx=this%nx
    allocate(this%tmp(nx,nx,nx),STAT=istat)
    if (istat .ne. 0)  call pf_stop(__FILE__,__LINE__,'Allocate failed ',istat)

    ! allocate space for phi functions
    allocate(this%A_phi(nx,nx,nx,this%nnz_A),STAT=istat)
    if (istat .ne. 0)  call pf_stop(__FILE__,__LINE__,'Allocate failed ',istat)
    allocate(this%b_phi(nx,nx,nx, this%nstages),STAT=istat)
    if (istat .ne. 0)  call pf_stop(__FILE__,__LINE__,'Allocate failed ',istat)
    allocate(this%d_phi(nx,nx,nx, this%nstages),STAT=istat)
    if (istat .ne. 0)  call pf_stop(__FILE__,__LINE__,'Allocate failed ',istat)

  end subroutine initialize_tmp

  subroutine initRKCoeff(this, opL, dt)

    ! Arguments
    class(my_stepper_t), intent(inout) :: this
    complex(pfdp), intent(in) :: opL(:,:,:)
    real(pfdp), intent(in) :: dt

    ! Variables
    integer :: i, j, k, num_phi, A_ij
    complex(pfdp), allocatable :: phi(:,:,:,:)
    real(pfdp) :: c1, c2
    num_phi = size(this%A,2)
    allocate(phi(num_phi, this%nx, this%nx, this%nx))

    ! init A Tablaeu coefficients
    this%A_phi = (0.0_pfdp, 0.0_pfdp)
    do i = 1, this%nstages - 1
       do j = 1, i
          A_ij = this%AF(j,i)
          if(A_ij .ne. 0) then ! A(i,j) is nonzero
             do k = 1, num_phi
                c1 = this%A(1, k, j, i)
                c2 = this%A(2, k, j, i)
                if(c1 .ne. 0.0_pfdp) then ! A(i,j) contains \varphi_{k-1}(c2 opL)
                   call phi_zmatrix3d(dt*c2*opL, num_phi-1, phi)
                   this%A_phi(:,:,:, A_ij) = this%A_phi(:,:,:, A_ij)+dt*c1*phi(k,:, :,:)
                endif
             enddo
          endif
       enddo
    enddo

    ! init b vector coefficients
    this%b_phi = (0.0_pfdp, 0.0_pfdp)
    do i = 1, this%nstages
       do k = 1, num_phi
          c1 = this%b(1, k, i)
          c2 = this%b(2, k, i)
          if(c1 .ne. 0.0_pfdp) then ! b(i) contains \varphi_{k-1}(c2 opL)
             call phi_zmatrix3d(dt*c2*opL, num_phi - 1, phi)
             this%b_phi(:,:,:, i) = this%b_phi(:,:,:, i) + dt*c1*phi(k,:, :,:)
          endif
       enddo
    enddo

    ! init d vector coefficients
    do i = 1, this%nstages
       c1 = this%d(1, i)
       c2 = this%d(2, i)
       if(c1 .ne. 0.0_pfdp) then ! d(i) contains \exp(c2 opL)
          call phi_zmatrix3d(dt*c2*opL, num_phi-1, phi)
          this%d_phi(:,:,:, i) = c1*phi(1,:,:,:)
       endif
    enddo
    deallocate(phi)
  end subroutine initRKCoeff

  ! The rest of the stuff is dimension independent
  include 'stepper_include.f90'

end module pf_my_stepper


      SUBROUTINE scrunch(rin, zin, rbc, zbs, rbs, zbc,
     1   rmnaxis, zmnaxis, ftol, niter, nstep, mexp, mntot)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE Vname0
      USE Vname1
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: niter, nstep, mexp, mntot
      REAL(rprec) :: ftol
      REAL(rprec), DIMENSION(ntheta,nphi) :: rin, zin
      REAL(rprec), DIMENSION(mntot) :: rbc, zbs, rbs, zbc
      REAL(rprec), DIMENSION(*) ::  rmnaxis, zmnaxis
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: pexp = 4, qexp = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: irst=1, nplane, imodes, iter, modeno, mrho1
      REAL(rprec), ALLOCATABLE, DIMENSION(:,:) :: angle
      REAL(rprec), DIMENSION(2*mpol,nphi) :: result1
      REAL(rprec) :: too_large,
     1   gtrig, fsq, gmin, g11, gout, time_on, time_off
C-----------------------------------------------
c
c       PARAMETER VALUES TO BE SET IN NAME1.INC:
c
c       MU:   MAXIMUM NO. OF POLOIDAL MODES IN FIT
c       NU:   MAXIMUM NO. OF THETA (POLOIDAL) POINTS ALLOWED IN FIT
c       NV:   MAXIMUM NO. OF TOROIDAL PLANES IN FIT
c
!

!
!     CHECK THAT INPUT DIMENSIONS ARE CONSISTENT WITH NAME1 PARAMETERS
!
      deltf = 1
      IF (MOD(nphi,2).ne.0 .and. nphi.ne.1 .or. nphi.eq.0) THEN
         PRINT *, ' NPHI > 0 must be EVEN for non-symmetric systems'
         STOP
      ENDIF
      IF (ntheta > nu) THEN
         PRINT *, ' NTHETA input to SCRUNCH is too large'
         STOP
      ENDIF
      IF (nphi > nv) THEN
         PRINT *, ' NPHI input to SCRUNCH is too large'
         STOP
      ENDIF
      IF (mpol > mu) THEN
         PRINT *, ' MPOL input to SCRUNCH is too large'
         STOP
      ENDIF
      IF (nfp .le. 0) THEN
         PRINT *, ' NFP > 0 must be positive and exceed zero'
         STOP
      ENDIF

!
!     INITIALIZE FIXED m,n ARRAYS
!
      OPEN(unit=3, file='outcurve', status='unknown')
      twopi = 8*ATAN(one)
      CALL fixaray (pexp, qexp, mexp)

!
!     COMPUTE INITIAL GUESSES (MUST ORDER ANGLES MONOTONICALLY FOR
!     NON-STARLIKE DOMAINS)
!
      ALLOCATE (angle(ntheta, nphi))
      CALL inguess (rin, zin, angle)

      too_large = 1.E6_dp
      gtrig = 1.E-4_dp
      mrho1 = mrho+1

      ALLOCATE (xvec(n2), gvec(n2), xdot(n2), xstore(n2))
!
!     BEGIN MAIN INTERATION LOOP
!
      CALL second0(time_on)
      DO nplane = 1, nphi
!
!     INITIALIZE M = 0 and M = 1 MODE AMPLITUDES
!
!        STACKING OF XVEC ARRAY (FOR FIXED TOROIDAL PLANE)
!        XVEC(1)              : R0c             (Symmetric components)
!        XVEC(2,mrho1)        : Rhoc            (Symmetric components)
!        XVEC(1+mrho1)        : Z0c             (Asymmetric components)
!        XVEC(2+mrho1,2*mrho1): Rhos            (Asymmetric components)
!        XVEC(2*mrho1+1,n2)   : Theta angle
!
         xstore(:n2) = zero
         xdot(:n2) = zero
         xvec(:n2) = zero

         WRITE (3, 10) nplane
         WRITE (*, 10) nplane
 10      FORMAT(/'                  Fitting toroidal plane # ',i3)

         CALL amplitud (r0n(nplane), z0n(nplane), angle(1,nplane),
     1     xvec, xvec(1+mrho1), xvec(2:mrho1), xvec(2+mrho1:2*mrho1),
     2     xvec(2*mrho1+1:), rin(1,nplane), zin(1,nplane))

      WRITE (3, 20)
      WRITE (*, 20)
 20   FORMAT(/' ITERATIONS    RMS ERROR    FORCE GRADIENT    <M>',
     1        '    MAX m   DELT')

         imodes = mrho
         delt = deltf
         CALL restart(0)

         DO iter = 1, niter
            gvec(:n2) = zero

            CALL funct (xvec, xvec(1+mrho1), xvec(2:mrho1),
     1        xvec(2+mrho1:2*mrho1),xvec(2*mrho1+1:), gvec,
     2        gvec(1+mrho1), gvec(2:mrho1), gvec(2+mrho1:2*mrho1),
     3        gvec(2*mrho1+1:), fsq, rin(1,nplane), zin(1,nplane),
     4        imodes)

            SELECT CASE (iter)
            CASE DEFAULT
               gmin = MIN(gmin,gnorm)
               CALL evolve (g11)
!
!     RUDIMENTARY TIME STEP CONTROL
!
               IF (gnorm/gmin .gt. too_large) irst = 2
               IF (irst.eq.2 .or. gmin.eq.gnorm) THEN
                  CALL restart (irst)
                  IF (irst .eq. 4) THEN
                     gnorm=gmin
                     EXIT
                  END IF
               END IF

               IF (gnorm.lt.gtrig .and. imodes.lt.mrho) THEN
                  imodes = imodes + 1
                  CALL restart (irst)
                  irst = 2
                  delt = MIN(0.98_dp, delt/.975)
               ENDIF
               IF (MOD(iter,nstep).ne.0 .and. gnorm.gt.ftol**2) CYCLE
            CASE (2)
               g11 = gnorm
               CYCLE
            CASE (1)
               gmin = gnorm
               imodes = MIN(4,mrho)
            END SELECT

            gout = SQRT(gnorm)
            modeno = imodes
            IF (iter .eq. 1) modeno = mpol - 1
            IF (qexp .gt. zero) specw = specw**(one/qexp)
            PRINT 110, iter, fsq, gout, specw, modeno, delt
            WRITE (3, 110) iter, fsq, gout, specw, modeno, delt
            IF (gnorm.lt.ftol**2 .and. imodes.eq.mrho
     1         .or. fsq.lt.ftol) EXIT
         END DO

  110    FORMAT(i8,1p,2e16.3,0p,f10.2,i8,1p,e10.2)

!
!     STORE FINAL ANSWER FOR FINAL PHI-TRANSFORM OF RHOC, RHOS
!
         result1(1:2*mpol,nplane) = xvec(1:2*mpol)

      END DO
      CALL second0(time_off)
!
!     OUTPUT LOOP
!
      PRINT 330, mexp, pexp, qexp, time_off-time_on
      WRITE (3, 330) mexp, pexp, qexp, time_off-time_on
  330 FORMAT(/' ANGLE CONSTRAINTS WERE APPLIED',
     1   ' FOR POLAR DAMPING EXPONENT (PEXP) = ',i2,/,
     2   ' RM**2 + ZM**2 SPECTRUM COMPUTED WITH P = ',f8.2,
     3   ' AND Q = ',f8.2,/,' TIME: ',1p,e10.2,
     3   ' SEC.'/)
!
!     PERFORM PHI-FOURIER TRANSFORM
!
      CALL fftrans (result1(1,1:nphi), result1(1+mpol,1:nphi),
     1   result1(2:mpol,1:nphi), result1(mpol+2:2*mpol,1:nphi), rbc,
     1   zbs, rbs, zbc, rmnaxis, zmnaxis)

      DEALLOCATE (xvec, gvec, xdot, xstore, angle)

      END SUBROUTINE scrunch