***********************************************************************
* This file contains for the calculation of weights for the monitor
* function as well as normalising routines.
***********************************************************************

***********************************************************************
* Explaination of the method:
*
* The dynamic approach of the grid adaption method tries to find
* a PHI:Omega->Omega that way, that:
*
*    det grad(PHI(x)) = f(PHI(x))
*
* for a given monitor function f:Omega->Omega. f has to fulfill the
* compatibility equation:
*
*    int_Omega ( 1/f(z) ) dz = |Omega|
*
* Our method here requires an arbitrary monitor function with values
* f(z) in (0,1]. Therefore we have to scale the monitor function
* according to the compatibility equation.
***********************************************************************

***********************************************************************
* Normalize monitor function to Int(1/f)= Domain measure
*
* Wrapper-function.
*
* In:
*  NVT    - Number of vertices
*  LONE   - Handle to: array [1..NVT] of dobule
*           Mean area around each vertex
*  DMSR   - Total measure of the domain
*  LMON   - Handle to monitor function
*
* Out:
*  Normalised monitor function.
***********************************************************************

      SUBROUTINE  XNORM(LONE,NVT,DMSR,LMON)

      IMPLICIT NONE
      INCLUDE 'cmem.inc'

      DOUBLE PRECISION DMSR
      INTEGER LONE,LMON,NVT

      CALL NORM(DWORK(L(LONE)),NVT,DMSR,DWORK(L(LMON)))

      END

***********************************************************************
* Normalize monitor function to Int(1/f)= Domain measure
*
* This routine performs a quick-and-dirty inexact integration using
* the mean area around each vertex.
*
* In:
*  NVT    - Number of vertices
*  DONE   - array [1..NVT] of dobule
*           Mean area around each vertex
*  DMSR   - Total measure of the domain
*  DMON   - array [1..NVT] of double
*           Monitor function
*
* Out:
*  DMON   - Normalised monitor function.
***********************************************************************
* Assume an arbitrary function g:Omega->R. The aim is to
* obtain a monitor function f:Omega->R that way, that
*
*    int_Omega 1/f = |Omega|
*
* holds. The approach is to scale g by a constant:    f = c * g
* Let {x} in Omega be the sei of points where our monitor function g
* is given, and let Area(x) be the mean area around each x. Then
* the compatibility equation can be approximated as:
*
*    |Omega| = int_Omega 1/f = sum_x ( 1/f(x) * Area(x) )
*                            = sum_x ( Area(x) / f(x) )
*                            = sum_x ( Area(x) / (c*g(x)) )
*                            = 1/c * sum_x ( Area(x) / g(x) )
*
* i.e.:   c = sum_x ( Area(x) / g(x) )  /  |Omega|
*
* That formula is implemented below...
***********************************************************************

      SUBROUTINE NORM(DONE,NVT,DMSR,DMON)

      IMPLICIT NONE

      INCLUDE 'cout.inc'

      DOUBLE PRECISION DMON,DONE,DMSR
      INTEGER NVT
      DIMENSION DMON(NVT),DONE(NVT)
      DOUBLE PRECISION DSUM
      INTEGER IVT

      IF (MT.GE.3) THEN
        WRITE (MTERM,FMT='(A,F10.6)')
     *         'Normalizing monitor function to ',DMSR
      END IF

C The old monitor function is g=DMON.
C build:    DSUM = sum_x ( Area(x) / g(x) )

      DSUM=0D0
      DO IVT=1,NVT
        DSUM=DSUM+DONE(IVT)/DMON(IVT)
      END DO

C build:    c = DSUM / |Omega|

      DSUM=DSUM/DMSR

C scale g(x) to obtain the actual monitor function f:
C    f(x) = c*g(x)
C Overwrite the old monitor function.

      DO IVT=1,NVT
        DMON(IVT)=DMON(IVT)*DSUM
      END DO
!      DSUM=0D0
!      DO 30 IVT=1,NVT
!30    DSUM=DSUM+DONE(IVT)/DMON(IVT)

      END

***********************************************************************
* Normalize monitor function to Int(f)= Domain measure
*
* This routine performs a quick-and-dirty inexact integration using
* the mean area around each vertex.
*
* In:
*  NVT    - Number of vertices
*  DONE   - array [1..NVT] of dobule
*           Mean area around each vertex
*  DMSR   - Total measure of the domain
*  DMON   - array [1..NVT] of double
*           Monitor function
*
* Out:
*  DMON   - Normalised monitor function.
*
* Remark:
*    DONE = DMON is allowed.
***********************************************************************
* Assume an arbitrary function g:Omega->R. The aim is to
* obtain a monitor function f:Omega->R that way, that
*
*    int_Omega f = |Omega|
*
* holds. The approach is to scale g by a constant:    f = c * g
* Let {x} in Omega be the set of points where our monitor function g
* is given, and let Area(x) be the mean area around each x. Then
* the compatibility equation can be approximated as:
*
*    |Omega| = int_Omega f   = sum_x ( f(x) * Area(x) )
*                            = sum_x ( (c*g(x)) * Area(x) )
*                            = c * sum_x ( g(x) * Area(x) )
*
* i.e.:   c = |Omega| / sum_x ( Area(x) * g(x) )
*
* That formula is implemented below...
***********************************************************************

      SUBROUTINE NORMIF(DONE,NVT,DMSR,DMON)

      IMPLICIT NONE

      INCLUDE 'cout.inc'

      DOUBLE PRECISION DMON,DONE,DMSR
      INTEGER NVT
      DIMENSION DMON(NVT),DONE(NVT)
      DOUBLE PRECISION DSUM
      INTEGER IVT

C The old monitor function is g=DMON.
C build:    DSUM = sum_x ( Area(x) * g(x) )

      DSUM=0D0
      DO IVT=1,NVT
        DSUM = DSUM + DONE(IVT)*DMON(IVT)
      END DO

C build:    c = |Omega| / DSUM

      DSUM=DMSR / DSUM

C scale g(x) to obtain the actual monitor function f:
C    f(x) = c*g(x)
C Overwrite the old monitor function.

      DO IVT=1,NVT
        DMON(IVT)=DMON(IVT)*DSUM
      END DO

      END

**********************************************************************
* Normalise monitor function
*
* Normally the scaled monitor function is calculated around
* each node by FMON_i/AREA_i with AREA_i the average area of the
* elements around node i. For the calculation of the grid deformation
* the monitor function is only needed up to a constant, which is
* unappropriate for visualisation and/or error calculation.
* This function scales the monitor function such that the mean
* value is 1D0 (and every entry is positive).
* (For this purpose the normalising routines of the Neumann filter
*  are used)
*
* In:
*  DMON   - array [1..NVT] of double
*           Given scaled monitor function
*  NVT    - Number of vertices
*
* Out:
*  DMONNM - array [1..NVT] of double
*           Normalised scaled monitor function
*
* DMONNM=DMON is allowed.
**********************************************************************

      SUBROUTINE NRMMON (DMON,NVT,DMONNM)

      IMPLICIT NONE

      INTEGER NVT
      DOUBLE PRECISION DMON(NVT),DMONNM(NVT)

C local variables

      INTEGER I
      DOUBLE PRECISION MEAN,DCLIMV

C Calculate the current mean value

      MEAN = DCLIMV (DMON,NVT)

C Divide all vector entries by the calculated meanvalue to get an
C all positive vector with mean value 1d0

      DO I=1,NVT
        DMONNM(I)=DMON(I)/MEAN
      END DO

      END

************************************************************************
* Calculate the weight of a monitor function
*
* This is the maximum ratio between the cell size and the corresponding
* function that determines the grid deformation. THe value is reduced
* by 1 to make it 0-based
*
* Remember: DMON(I) = F(I) / AREA(I)
* With F(I)    = function determining the grid deformation in node I,
*      AREA(I) = mean cell size around node I
* and:
*  if DMON(I) > 1   =>   D(I) > AREA(I)   =>   ratio = DMON(I)
*  if DMON(I) < 1   =>   D(I) < AREA(I)   =>   ratio = 1/DMON(I)
*
* Example:
*  DMON(I)=100
*    => Ratio = 100 because Mean cell size is 100 times to large
*  DMON(I)=0.1
*    => Ratio = 1 / 0.1 = 10 because Mean cell size is 10 times to small
*
* In:
*  NVT     - Number of vertices
*  DMON    - array [1..NVT] of double
*            Monitor function to analyse
*
* Out:
*  WEIGHT  - The weight of the monitor function = ratio, >= 1
*  INODE   - The number of the node with the above weight
************************************************************************

      SUBROUTINE MONWGH (DMON,NVT,WEIGHT,INODE)

      IMPLICIT NONE

      INTEGER NVT, INODE
      DOUBLE PRECISION DMON(NVT),WEIGHT

      INTEGER I

      DOUBLE PRECISION CWGH

      WEIGHT=0D0
      INODE=0

      DO I=1,NVT

C What is the current weight?

        CWGH=DMON(I)
        IF (CWGH.LT.1D0) CWGH=1D0/CWGH

        IF ( CWGH.GT.WEIGHT ) THEN
          WEIGHT = CWGH
          INODE=I
        END IF
      END DO

      END

************************************************************************
* Calculate the cell ratio from the monitor function
*
* Calculates with the help of the current monitor function
* 1.) the ratio between the smallest and largest cell or
* 2.) the largest monitor function weight
*
* In:
*  NVT     - Number of vertices
*  DMON    - array [1..NVT] of double
*            Monitor function to analyse
*  IMTH    - type of return value:
*            =0: return the ratio between largest and smallest cell
*                in RAT, calculated with the help of the monitor
*                function
*            =1: return largest f_i/area_i (or area_i/f_i if
*                f_i/area_i < 1)
*
* Out:
*  RAT     - ratio
*  INDEMN  - The number of the node with the minimum weight
*  INDEMX  - The number of the node with the maximmum weight
************************************************************************

      SUBROUTINE MONCRT (DMON,NVT,IMTH,RAT,INDEMN,INDEMX)

      IMPLICIT NONE

      INTEGER NVT, INDEMN, INDEMX, IMTH
      DOUBLE PRECISION DMON(NVT),RAT

      INTEGER I

      DOUBLE PRECISION MN,MX

      RAT = 0D0
      INDEMN = 1
      INDEMX = 1
      MN = DMON(1)
      MX = DMON(1)

C Determine minimum and maximum weight = cell-ratio

      DO I=1,NVT
        IF ( DMON(I).LT.MN ) THEN
          MN = DMON(I)
          INDEMN = I
        END IF
        IF ( DMON(I).GT.MX ) THEN
          MX = DMON(I)
          INDEMX = I
        END IF
      END DO

      IF (IMTH.EQ.0) THEN

C calculate the ratio

        RAT = MX / MN

      ELSE

C Calculate the largest monitor function value; invert it
C if it is < 1 to obtain a value > 1!

        IF (MX.LT.1D0) MX=1/MX
        IF (MN.LT.1D0) MX=1/MN

        RAT = MAX (MN,MX)

      END IF

      END

************************************************************************
* Monitor function rescaling
*
* Rescales the monitor function. Every entry DMON(I) is taken up to
* a power of PW.
*
* In:
*  NVT     - Number of vertices
*  DMON    - array [1..NVT] of double
*            Monitor function to analyse
*  PW      - Power that should be applied to each entry
*
* Out:
*  DMON    - Rescaled monitor function
*
* The monitor function is rescaled during this process such that the
* minimum value is 1D0!
************************************************************************

      SUBROUTINE MONRSC (DMON,NVT,PW)

      IMPLICIT NONE

      INTEGER NVT
      DOUBLE PRECISION DMON(NVT),PW

      INTEGER I

      DO I=1,NVT
        DMON(I) = DMON(I) ** PW
      END DO

      END

**********************************************************************
* Normalize monitor function to Int(f)= Domain measure
*
* This routine performs exact integration to normalize the monitor
* function. It scales f by multiplication of a constant to enforce
*     int_Omega f = |Omega|
*
* In:
*  TRIA   - array [1..SZTRIA] of integer
*           Triangulation structure
*  DMON   - array [1..NVT] of double
*           Monitor function
*  DMSR   - Total measure of the domain
*  NEQ    - number of elements in DMON
*  ELE    - Element that should be used for the interpretation of
*           DMON as FE-function. Must be a conforming element.
*  ICUB   - Number of cubature formula that should be used
*           for integration
*
* Out:
*  DMON   - Normalised monitor function.
**********************************************************************

      SUBROUTINE NRMM2(TRIA,DMON,DMSR,NEQ,ELE,ICUB)

      IMPLICIT NONE

      INCLUDE 'cerr.inc'
      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'stria.inc'

      INCLUDE 'ccub.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

C     parameters:

      INTEGER TRIA(SZTRIA),NEQ,ICUB
      DOUBLE PRECISION DMON(NEQ),DMSR

C     local variables:

      INTEGER IELTYP,IDFL,I,IG,JP,IEL1,IVE,NVE
      DOUBLE PRECISION DJF(2,2),OM,DINTF,XI1,XI2
      DOUBLE PRECISION DCOORD(2,4)
      INTEGER KDFG(NNBAS),KDFL(NNBAS)
      INTEGER KVERT, KMID

C     externals

      EXTERNAL ELE
      INTEGER NDFL
      EXTERNAL NDFL

      IER = 0

C     The formula is as follows. Let g:=c*f denote the scaled monitor
C     function f. Then:
C       int_Omega g = int_Omega c*f = c*int_Omega f = |Omega|
C     So,
C       c = |Omega| / int_Omega f
C
C     At first we have to build int_Omega f.
C
C     Resolve some handles for quicker access:

      KVERT = L(TRIA(OLVERT))
      KMID = L(TRIA(OLMID))
      NVE = TRIA(ONVE)

C     We need only function values for the integration:

      DO  I = 1,NNDER
        BDER(I)=.FALSE.
      ENDDO
      BDER(1)=.TRUE.

C     Get the element type as well as number of local degrees of
C     freedom:

      IELTYP=-1
      CALL ELE(0D0,0D0,IELTYP)
      IDFL=NDFL(IELTYP)

C     initialise cubature formula

      CALL CB2Q(ICUB)
      IF (IER.NE.0) GOTO 99999

C     Prepare conforming element for cubature. Save the current cubature
C     formula into the COMMON block variable ICUBP - either for now or
C     for later use. Perform a dummy call to the element in the conforming
C     case.
C     This is done for saving arithmetic operations in later calls.

      ICUBP=ICUB

      CALL ELE(0D0,0D0,-2)

C     Loop about the elements, calculate the integral into DINTF

      DINTF = 0D0

      DO IEL1 = 1,TRIA(ONEL)

C       Calculate the local and global DOF's on our current element.
C       We later have to loop about them...

        CALL NDFGL(IEL1,1,IELTYP,KWORK(KVERT),KWORK(KMID), KDFG,KDFL)
        IF (IER.LT.0) GOTO 99999

C Store the coordinates of the corners of the current element in
C the COMMON block variables DX/DY (necessary for the element)
C as well as in the DCOORD array for the coordinate transformation.

        DO IVE = 1, NVE
          JP=KWORK(KVERT + (IEL1-1)*NNVE+(IVE-1))
          KVE(IVE)=JP
          CALL NDE2XY (JP,TRIA,DCOORD (1,IVE),DCOORD (2,IVE))
          DX(IVE)=DCOORD (1,IVE)
          DY(IVE)=DCOORD (2,IVE)
        END DO

C Initialise auxiliary Jacobian factors DJF for transformation

        CALL QINIJF (DCOORD,DJF)

c Loop over all cubature points

        DO ICUBP = 1, NCUBP

c Cubature point on the reference element

          XI1=DXI(ICUBP,1)
          XI2=DXI(ICUBP,2)

C         Calculate Jacobian matrix of transformation and its
C         determinant. This is necessary for the element routine ELE
C         to properly calculate derivatives. The result is directly
C         written into the element COMMON block variables DJAC and DETJ.

          CALL QTRDET (DCOORD,DJF,DJAC,DETJ,XI1,XI2)

C         Evaluate the basis functions in the cubature point

          CALL ELE(XI1,XI2,-3)
          IF (IER.LT.0) GOTO 99999

C         Calculate the weighting factor for the current cubature point
C         with the help of the Jacobian determinant

          OM = DOMEGA(ICUBP)*DETJ

C         Add the values of the basis function to the integral

          DO I=1,IDFL
            IG=KDFG(I)
            DINTF = DINTF + OM * DMON(IG)*DBAS(KDFL(I),1)
          END DO

        END DO

      END DO

C     DINTF now contains the integral. Using c=|Omega|/DINTF,
C     scale the monitor function appropriately.

      IF (DINTF.NE.0D0) THEN

        DINTF = DMSR/DINTF
        DO I=1,NEQ
          DMON(I) = DMON(I)*DINTF
        END DO

      END IF

C     ... or do nothing if an error occurred

99999 CONTINUE

      END

**********************************************************************
* Normalize monitor function to Int(1/f)= Domain measure
*
* This routine performs exact integration to normalize the monitor
* function. It scales f by multiplication of a constant to enforce
*     int_Omega 1/f = |Omega|
*
* In:
*  TRIA   - array [1..SZTRIA] of integer
*           Triangulation structure
*  DMON   - array [1..NVT] of double
*           Monitor function
*  DMSR   - Total measure of the domain
*  NEQ    - number of elements in DMON
*  ELE    - Element that should be used for the interpretation of
*           DMON as FE-function. Must be a conforming element.
*  ICUB   - Number of cubature formula that should be used
*           for integration
*
* Out:
*  DMON   - Normalised monitor function.
**********************************************************************

      SUBROUTINE NRMM2R(TRIA,DMON,DMSR,NEQ,ELE,ICUB)
      IMPLICIT NONE

      INCLUDE 'cerr.inc'
      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'stria.inc'

      INCLUDE 'ccub.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

C     parameters:

      INTEGER TRIA(SZTRIA),NEQ,ICUB
      DOUBLE PRECISION DMON(NEQ),DMSR

C     local variables:

      INTEGER IELTYP,IDFL,I,IG,JP,IEL1,IVE,NVE
      DOUBLE PRECISION DJF(2,2),OM,DINTF,XI1,XI2,DF
      DOUBLE PRECISION DCOORD(2,4)
      INTEGER KDFG(NNBAS),KDFL(NNBAS)
      INTEGER KVERT, KMID

C     externals

      EXTERNAL ELE
      INTEGER NDFL
      EXTERNAL NDFL

C     A first idea for this routine is the following:
C     1.) Transform f -> 1/f
C     2.) Use NRMM2 to normalize 1/f
C     3.) Transform f -> 1/f for obtaining the result
C     This strategy is possible, but slightly wrong! The reason is, that
C     1/f is not a bilinear function, and so normalizing 1/f would
C     not mean for f that int(1/f)=|Omega|.
C
C     Instead we use a different normalization strategy. We use the
C     same integration routine as stated above, but with a slightly
C     different summing in the coefficients of the integral to
C     properly resolve 1/f.

      IER = 0

C     The formula is as follows. Let g:=c*f denote the scaled monitor
C     function f. Then:
C       int_Omega g = int_Omega c*f = c*int_Omega f = |Omega|
C     So,
C       c = |Omega| / int_Omega f
C
C     At first we have to build int_Omega f.
C
C     Resolve some handles for quicker access:

      KVERT = L(TRIA(OLVERT))
      KMID = L(TRIA(OLMID))
      NVE = TRIA(ONVE)

C     We need only function values for the integration:

      DO  I = 1,NNDER
        BDER(I)=.FALSE.
      ENDDO
      BDER(1)=.TRUE.

C     Get the element type as well as number of local degrees of
C     freedom:

      IELTYP=-1
      CALL ELE(0D0,0D0,IELTYP)
      IDFL=NDFL(IELTYP)

C     initialise cubature formula

      CALL CB2Q(ICUB)
      IF (IER.NE.0) GOTO 99999

C     Prepare conforming element for cubature. Save the current cubature
C     formula into the COMMON block variable ICUBP - either for now or
C     for later use. Perform a dummy call to the element in the conforming
C     case.
C     This is done for saving arithmetic operations in later calls.

      ICUBP=ICUB

      CALL ELE(0D0,0D0,-2)

C     Loop about the elements, calculate the integral into DINTF

      DINTF = 0D0

      DO IEL1 = 1,TRIA(ONEL)

C       Calculate the local and global DOF's on our current element.
C       We later have to loop about them...

        CALL NDFGLX(TRIA,IEL1,1,IELTYP,KWORK(KVERT),KWORK(KMID),
     *              KDFG,KDFL)
        IF (IER.LT.0) GOTO 99999

C Store the coordinates of the corners of the current element in
C the COMMON block variables DX/DY (necessary for the element)
C as well as in the DCOORD array for the coordinate transformation.

        DO IVE = 1, NVE
          JP=KWORK(KVERT + (IEL1-1)*NNVE+(IVE-1))
          KVE(IVE)=JP
          CALL NDE2XY (JP,TRIA,DCOORD (1,IVE),DCOORD (2,IVE))
          DX(IVE)=DCOORD (1,IVE)
          DY(IVE)=DCOORD (2,IVE)
        END DO

C Initialise auxiliary Jacobian factors DJF for transformation

        CALL QINIJF (DCOORD,DJF)

c Loop over all cubature points

        DO ICUBP = 1, NCUBP

c Cubature point on the reference element

          XI1=DXI(ICUBP,1)
          XI2=DXI(ICUBP,2)

C         Calculate Jacobian matrix of transformation and its
C         determinant. This is necessary for the element routine ELE
C         to properly calculate derivatives. The result is directly
C         written into the element COMMON block variables DJAC and DETJ.

          CALL QTRDET (DCOORD,DJF,DJAC,DETJ,XI1,XI2)

C         Evaluate the basis functions in the cubature point

          CALL ELE(XI1,XI2,-3)
          IF (IER.LT.0) GOTO 99999

C         Add the values of the basis function to calculate the value
C         of the function in the current cubature point.

          DF = 0D0
          DO I=1,IDFL
            IG=KDFG(I)
            DF = DF + DMON(IG)*DBAS(KDFL(I),1)
          END DO

C         Calculate the weighting factor for the current cubature point
C         with the help of the Jacobian determinant

          OM = DOMEGA(ICUBP)*DETJ

C         Now add 1/DF * cubature weight to the integral. This properly
C         calculates int(1/f):

          DINTF = DINTF + OM/DF

        END DO

      END DO

C     DINTF now contains the integral. Using c=DINTF/|Omega|,
C     scale the monitor function appropriately:
C
C        int(1/(c*DMON)) = |Omega|
C     => c = 1/|Omega| * int(1/DMON) = DINTF/|Omega|

      IF (DMSR.NE.0D0) THEN

        DINTF = DINTF/DMSR
        DO I=1,NEQ
          DMON(I) = DMON(I)*DINTF
        END DO

      END IF

C     ... or do nothing if an error occurred

99999 CONTINUE

      END

************************************************************************
* Calculate quality measure
*
* This routine calculates the quality measure of a deformed grid.
* The quality measure is defined by:
*
*      Q := ||q-1||_l2
*
* with q(x) = f(x)/a(x), f(.)=monitor function, a(.)=element area
* distribution on deformed mesh.
*
* In:
*   TRIA    - array [1..SZTRIA] of integer
*             Triangulation structure of the deformed grid
*   DMON    - array [1..NVT] of double
*             monitor function; must correspond to TRIA
*   DSIZE   - array [1..NVT] of double
*             current area distribution around each vertex
*   DMSR    - Measure of the domain
*
* Out:
*   QMSR    - Quality measure
************************************************************************

      SUBROUTINE GAQMSR (NVT,DMON,DSIZE,DMSR,QMSR)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'

      INCLUDE 'stria.inc'

      INTEGER NVT
      DOUBLE PRECISION DMON(NVT),DSIZE(NVT),DMSR,QMSR

C local variables

      INTEGER LTMP,KTMP,KSIZE,I

C Make a copy of DMON and DSIZE for normalizing

      CALL ZNEW (2*NVT,-1,LTMP,'DTMP  ')
      CALL LCP1 (DMON,DWORK(L(LTMP)),NVT)
      CALL LCP1 (DSIZE,DWORK(L(LTMP)+NVT),NVT)

C Normalize monitor function and area distribution such that
C         Int(f) = Int(a) ( = |Omega| )
C This way if f~a, then q(x)~1, so Q=0.

      CALL NORMIF(DSIZE,NVT,DMSR,DWORK(L(LTMP)))
      CALL NORMIF(DSIZE,NVT,DMSR,DWORK(L(LTMP)+NVT))

C Build q(x)-1:

      KTMP = L(LTMP)
      KSIZE = L(LTMP)+NVT

      DO I=0,NVT-1
        DWORK(KTMP+I) = DWORK(KTMP+I)/DWORK(KSIZE+I) - 1D0
      END DO

C Build the l2-norm of the vector

      CALL LL21(DWORK(KTMP),NVT,QMSR)
      QMSR = QMSR / SQRT(DBLE(NVT))

C Release memory, finish

      CALL ZDISP (0,LTMP,'DTMP  ')

      END


      MODULE UTILITIES
          USE CONFIG

          IMPLICIT NONE
          PRIVATE
          PUBLIC :: STDERR, TOSTR, DEG2RAD

          REAL, PARAMETER :: PI     = 4._DP * ATAN(1._DP)
          REAL, PARAMETER :: DEG180 = 180._DP
          REAL, PARAMETER :: D_TO_R = PI / DEG180
      CONTAINS
          SUBROUTINE STDERR(MESSAGE)
              USE ISO_FORTRAN_ENV, ONLY : ERROR_UNIT
              CHARACTER(LEN=*) :: MESSAGE

              WRITE(ERROR_UNIT, '(A)') MESSAGE
          END SUBROUTINE STDERR

          PURE FUNCTION TOSTR(K) RESULT(STR)
              INTEGER, INTENT(IN) :: K
              CHARACTER(LEN=20) :: STR

              WRITE(STR, *) K
              STR = ADJUSTL(STR)
          END FUNCTION TOSTR

          PURE FUNCTION DEG2RAD(D) RESULT(R)
              REAL(DP), INTENT(IN) :: D
              REAL(DP) :: R

              R = D * D_TO_R
          END FUNCTION DEG2RAD
      END MODULE UTILITIES


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   phs :    A Hopf bifurcation leading to a homoclinic orbit
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

       F(1)=-PAR(1)*U(1) - U(2)
       F(2)= U(1) * (1 - U(1))

      END SUBROUTINE FUNC

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

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

       PAR(1)=-1.0

       U(1)=0.0
       U(2)=0.0

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


*DECK COMHES
      SUBROUTINE COMHES (NM, N, LOW, IGH, AR, AI, INT)
C***BEGIN PROLOGUE  COMHES
C***PURPOSE  Reduce a complex general matrix to complex upper Hessenberg
C            form using stabilized elementary similarity
C            transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B2
C***TYPE      COMPLEX (ELMHES-S, COMHES-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure COMHES,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     Given a COMPLEX GENERAL matrix, this subroutine
C     reduces a submatrix situated in rows and columns
C     LOW through IGH to upper Hessenberg form by
C     stabilized elementary similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, AR and AI, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  CBAL.  If  CBAL  has not been used,
C          set LOW=1 and IGH equal to the order of the matrix, N.
C
C        AR and AI contain the real and imaginary parts, respectively,
C          of the complex input matrix.  AR and AI are two-dimensional
C          REAL arrays, dimensioned AR(NM,N) and AI(NM,N).
C
C     On OUTPUT
C
C        AR and AI contain the real and imaginary parts, respectively,
C          of the upper Hessenberg matrix.  The multipliers which
C          were used in the reduction are stored in the remaining
C          triangles under the Hessenberg matrix.
C
C        INT contains information on the rows and columns
C          interchanged in the reduction.  Only elements LOW through
C          IGH are used.  INT is a one-dimensional INTEGER array,
C          dimensioned INT(IGH).
C
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  CDIV
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  COMHES
C
      INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
      REAL AR(NM,*),AI(NM,*)
      REAL XR,XI,YR,YI
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  COMHES
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         MM1 = M - 1
         XR = 0.0E0
         XI = 0.0E0
         I = M
C
         DO 100 J = M, IGH
            IF (ABS(AR(J,MM1)) + ABS(AI(J,MM1))
     1         .LE. ABS(XR) + ABS(XI)) GO TO 100
            XR = AR(J,MM1)
            XI = AI(J,MM1)
            I = J
  100    CONTINUE
C
         INT(M) = I
         IF (I .EQ. M) GO TO 130
C     .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI ..........
         DO 110 J = MM1, N
            YR = AR(I,J)
            AR(I,J) = AR(M,J)
            AR(M,J) = YR
            YI = AI(I,J)
            AI(I,J) = AI(M,J)
            AI(M,J) = YI
  110    CONTINUE
C
         DO 120 J = 1, IGH
            YR = AR(J,I)
            AR(J,I) = AR(J,M)
            AR(J,M) = YR
            YI = AI(J,I)
            AI(J,I) = AI(J,M)
            AI(J,M) = YI
  120    CONTINUE
C     .......... END INTERCHANGE ..........
  130    IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 180
         MP1 = M + 1
C
         DO 160 I = MP1, IGH
            YR = AR(I,MM1)
            YI = AI(I,MM1)
            IF (YR .EQ. 0.0E0 .AND. YI .EQ. 0.0E0) GO TO 160
            CALL CDIV(YR,YI,XR,XI,YR,YI)
            AR(I,MM1) = YR
            AI(I,MM1) = YI
C
            DO 140 J = M, N
               AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J)
               AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J)
  140       CONTINUE
C
            DO 150 J = 1, IGH
               AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I)
               AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I)
  150       CONTINUE
C
  160    CONTINUE
C
  180 CONTINUE
C
  200 RETURN
      END


module myLib

    use iso_c_binding

    implicit none

    integer, parameter :: dp = selected_real_kind(15, 307)

contains

    real(kind=dp)  function binomial(n,k) result(coefficient) &
        bind (C, name="myLib_binomial")

        implicit none

        integer, intent(in) :: n, k
        integer :: numerator, i

        if (k == 0) then
            coefficient = 1
        else
            coefficient = 1.0D0
            do i = 1, k
                numerator = n + 1 -i
                coefficient = coefficient * real(numerator)/real(i)
            end do
        end if

    end function binomial

end module myLib


program test
  character(len=10), dimension(5) :: array
  character(len=10) :: message
  character, dimension(10) :: charArray
  integer :: a(3, 3)
  integer :: i, j, k=0

  do i = 1, 3
    do j = 1, 3
      a(i, j) = k
      k = k + 1
    end do
  end do
  write(*, '(3i3)') ((a(i, j), j = 1, 3), i = 1, 3)

end program test


program test

  use iso_fortran_env

  ! Import solvers
  use linear_algebra, only: solve
  use direct_linear_solve, only: tdma

  ! Import physics
  use linear_transport, only: exact1, assemble_system
  use nonlinear_transport, only: exact2, exact3, exact4, assemble_residual_jacobian

  implicit none

  type(event_type) :: event[*]

  ! Problem setup
  logical, parameter :: sparse = .true.
  integer, parameter :: sizes(7) = [10-1, 50-1, 100-1, 500-1, 1000-1, 5000-1, 10000-1]
  !integer, parameter :: sizes(5) = [10-1, 20-1, 30-1, 40-1, 50-1]

  ! Solve the linear transport
  call solve_linear_transport(sparse, sizes, exact1)

  ! Solve all three nonlinear transport cases
  call solve_nonlinear_transport(sparse, sizes, 1, exact2)
  call solve_nonlinear_transport(sparse, sizes, 2, exact3)
  call solve_nonlinear_transport(sparse, sizes, 3, exact4)

contains

  !===================================================================!
  ! Setup of nonlinear transport equation
  !===================================================================!

  subroutine solve_nonlinear_transport(sparse, sizes, case, exact)

    interface
       pure real(8) function exact(x)
         real(8), intent(in) ::  x
       end function exact
    end interface

    ! Problem setup
    logical, intent(in) :: sparse
    integer, intent(in) :: sizes(:)
    integer, intent(in) :: case

    real(8), parameter :: tau_r = 1.0d-16
    real(8), parameter :: tau_a = 1.0d-13
    integer, parameter :: max_it = 100

    ! Matrices and vectors
    real(8), allocatable, dimension(:,:) :: A
    real(8), allocatable, dimension(:)   :: phi, Q, R

    integer :: i, j
    real(8) :: xi, rmse, walltime, time_start, time_end

    integer :: npts
    character(len=100) :: filename
    character(len=100) :: strnpts
    character(len=100) :: strcase

    ! Open file
    write(strcase,*) int(case)
    open(12, file='nonlinear_summary' // '-case-' // trim(adjustl(strcase))//'.dat')
    write(12, *) "npts ", "h ", "rmse ", "wall_time"

    do j = 1, size(sizes)

       npts = sizes(j)

       ! Create filename and open
       write(strnpts,*) int(npts+1)
       filename = 'nonlinear-solution' // '-npts-' // trim(adjustl(strnpts)) // "-case-"// trim(adjustl(strcase)) //'.dat'
       open(11, file=filename)
       write(11, *) "x ", "phihat ", "phi"

       call cpu_time(time_start)

       allocate(R(npts))
       allocate(A(npts, npts))

       ! Initial solution
       allocate(phi(npts))
       do i = 1, npts
          xi = dble(i)/dble(npts+1)
          phi(i) = exact(xi)
       end do

       ! Set the source term
       allocate(Q(npts))
       if (case.eq.1) then
          Q = 0.0d0
       else if (case.eq.2) then
          Q = 0.1d0
       else
          do i = 1, npts
             xi = dble(i)/dble(npts+1)
             Q(i) = 0.1d0*xi
          end do
       end if

       ! Solve the nonlinear system
       call newton(sparse, tau_r, tau_a, max_it, npts, phi, Q, A, R)
       call cpu_time(time_end)
       walltime = time_end - time_start

       ! Compare solution to exact and write output
       rmse = 0.0d0
       do i = 1, npts
          xi = dble(i)/dble(npts+1)
          write(11, *) xi, phi(i), exact(xi)
          rmse = rmse + (exact(xi)-phi(i))**2.0d0
       end do
       rmse = sqrt(rmse/dble(npts))
       write(12, *) npts+1, 1.0d0/dble(npts+1), rmse, walltime

       close(11)

       deallocate(R,A,phi,Q)

    end do

    close(12)

  end subroutine solve_nonlinear_transport

  !===================================================================!
  ! Newton method for solving nonlinear system that features quadratic
  ! convergence
  !===================================================================!

  subroutine newton(sparse, tau_r, tau_a, max_it, npts, phi, Q, jac, res )

    logical, intent(in)    :: sparse
    real(8), intent(in)    :: tau_r, tau_a
    integer, intent(in)    :: max_it
    integer, intent(in)    :: npts
    real(8), intent(inout) :: phi(:)
    real(8), intent(in)    :: Q(:)
    real(8), intent(inout) :: res(:)
    real(8), intent(inout) :: jac(:,:)

    ! local variables
    real(8) :: r0
    real(8) :: s(size(res))
    integer :: iter

    call assemble_residual_jacobian(sparse, npts, phi, Q, jac, res)

    ! Initial residual
    r0 = norm2(res)

    iter = 0
    do while (norm2(res) > tau_r*r0 + tau_a .and. iter .le. max_it)

       ! Increment the iteration count
       iter = iter + 1

       ! Residual and jacobian
       call assemble_residual_jacobian(sparse, npts, phi, Q, jac, res)

       ! Solve the linear system based on matrix storage format
       if (sparse .eqv. .true.) then
          call tdma(jac, res, s)
       else
          s = solve(jac, res)
       end if

       ! Apply the update
       phi = phi + s

       ! print newton solve details
       print *, iter, norm2(res)

    end do

  end subroutine newton

  !===================================================================!
  ! Setup of linear transport equation
  !===================================================================!

  subroutine solve_linear_transport(sparse, sizes, exact)

    interface
       pure real(8) function exact(x)
         real(8), intent(in) ::  x
       end function exact
    end interface

    ! Problem setup
    logical, intent(in) :: sparse
    integer, intent(in) :: sizes(:)

    ! Matrices and vectors
    real(8), allocatable, dimension(:,:) :: A
    real(8), allocatable, dimension(:)   :: phi, b

    real(8) :: xi, rmse, walltime, time_start, time_end

    ! Physics parameters
    integer :: i, j
    integer :: npts

    ! Filename
    character(len=100) :: filename
    character(len=100) :: strnpts

    ! Open file
    open(12, file='linear_summary.dat')
    write(12, *) "npts ", "h ", "rmse ", "wall_time"

    do j = 1, size(sizes)

       npts = sizes(j)

       ! Create filename and open
       write(strnpts,*) int(npts+1)
       filename = 'linear-solution' // '-npts-' // trim(adjustl(strnpts)) // '.dat'
       open(11, file=filename)
       write(11, *) "x ", "phihat ", "phi"

       call cpu_time(time_start)

       if (sparse .eqv. .true.) then
          allocate(A(npts, 3))
       else
          allocate(A(npts, npts))
       end if
       allocate(b(npts), phi(npts))
       call assemble_system(0.0d0, 1.0d0, npts, A, b, sparse)

       ! Solve the system
       if (sparse .eqv. .true.) then
          call tdma(A, b, phi)
       else
          phi = solve(A, b)
       end if

       call cpu_time(time_end)
       walltime = time_end - time_start

       ! Write output
       rmse = 0.0d0
       do i = 1, npts
          xi = dble(i)/dble(npts+1)
          write(11, *) xi, phi(i), exact(xi)
          rmse = rmse + (exact(xi)-phi(i))**2.0d0
       end do
       rmse = sqrt(rmse/dble(npts))
       write(12, *) npts+1, 1.0d0/dble(npts+1), rmse, walltime

       ! Free resources
       close(11)
       deallocate(A, phi, b)

    end do

    close(12)

  end subroutine solve_linear_transport

end program


	PROGRAM SECEME
C
C	CALCULATES AVERAGE VALUE OF 1/SQRT(ES) FOR SECONDARY
C	EMISSION FROM COPPER, SEAH, SURFACE SCIENCE 17,132-160,(1969)
C
	DELE = .05
	VAL1 = 0.
	VAL2 = 0.
	DO N = 1,1000
	ES = .05*N
	FSR = 1 + (N.AND.1)
	Y = ES/(ES +.35)/(ES + 4.5)**1.6
	VAL1 = VAL1 + DELE*FSR*Y
	VAL2 = VAL2 + DELE*FSR*Y/SQRT(ES)
	ENDDO
	PRINT*,'VAL1,VAL2,AVR SQRT(ES)',VAL1,VAL2,VAL1/VAL2
	STOP
	END


      SUBROUTINE MB03KE( TRANA, TRANB, ISGN, K, M, N, PREC, SMIN, S, A,
     $                   B, C, SCALE, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve small periodic Sylvester-like equations (PSLE)
C
C      op(A(i))*X( i ) + isgn*X(i+1)*op(B(i)) = -scale*C(i), S(i) =  1,
C      op(A(i))*X(i+1) + isgn*X( i )*op(B(i)) = -scale*C(i), S(i) = -1.
C
C     i = 1, ..., K, where op(A) means A or A**T, for the K-periodic
C     matrix sequence X(i) = X(i+K), where A, B and C are K-periodic
C     matrix sequences and A and B are in periodic real Schur form. The
C     matrices A(i) are M-by-M and B(i) are N-by-N, with 1 <= M, N <= 2.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   LOGICAL
C             Specifies the form of op(A) to be used, as follows:
C             = .FALSE.:  op(A) = A,
C             = .TRUE. :  op(A) = A**T.
C
C     TRANB   LOGICAL
C             Specifies the form of op(B) to be used, as follows:
C             = .FALSE.:  op(B) = B,
C             = .TRUE. :  op(B) = B**T.
C
C     ISGN    INTEGER
C             Specifies which sign variant of the equations to solve.
C             ISGN = 1 or ISGN = -1.
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The period of the periodic matrix sequences A, B, C and X.
C             K >= 2. (For K = 1, a standard Sylvester equation is
C             obtained.)
C
C     M       (input) INTEGER
C             The order of the matrices A(i) and the number of rows of
C             the matrices C(i) and X(i), i = 1, ..., K.  1 <= M <= 2.
C
C     N       (input) INTEGER
C             The order of the matrices B(i) and the number of columns
C             of the matrices C(i) and X(i), i = 1, ..., K.
C             1 <= N <= 2.
C
C     PREC    (input) DOUBLE PRECISION
C             The relative machine precision. See the LAPACK Library
C             routine DLAMCH.
C
C     SMIN    (input) DOUBLE PRECISION
C             The machine safe minimum divided by PREC.
C
C     S       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures (exponents) of the factors in the K-periodic
C             matrix sequences for A and B. Each entry in S must be
C             either 1 or -1. Notice that it is assumed that the same
C             exponents are tied to both A and B on reduction to the
C             periodic Schur form.
C
C     A       (input) DOUBLE PRECISION array, dimension (M*M*K)
C             On entry, this array must contain the M-by-M matrices
C             A(i), for i = 1, ..., K, stored with the leading dimension
C             M. Matrix A(i) is stored starting at position M*M*(i-1)+1.
C
C     B       (input) DOUBLE PRECISION array, dimension (N*N*K)
C             On entry, this array must contain the N-by-N matrices
C             B(i), for i = 1, ..., K, stored with the leading dimension
C             N. Matrix B(i) is stored starting at position N*N*(i-1)+1.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (M*N*K)
C             On entry, this array must contain the M-by-N matrices
C             C(i), for i = 1, ..., K, stored with the leading dimension
C             M. Matrix C(i) is stored starting at position M*N*(i-1)+1.
C             On exit, the matrices C(i) are overwritten by the solution
C             sequence X(i).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             avoid overflow in X.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             On exit, if INFO = -21, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= (4*K-3) * (M*N)**2 + K * M*N.
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -21, then LDWORK is too small; appropriate
C                   value for LDWORK is returned in DWORK(1); the other
C                   arguments are not tested, for efficiency;
C             = 1:  the solution would overflow with scale = 1, so
C                   SCALE was set less than 1. This is a warning, not
C                   an error.
C
C     METHOD
C
C     A version of the algorithm described in [1] is used. The routine
C     uses a sparse Kronecker product representation Z of the PSLE and
C     solves for X(i) from an associated linear system Z*x = c using
C     structured (overlapping) variants of QR factorization and backward
C     substitution.
C
C     REFERENCES
C
C     [1] Granat, R., Kagstrom, B. and Kressner, D.
C         Computing periodic deflating subspaces associated with a
C         specified set of eigenvalues.
C         BIT Numerical Mathematics, vol. 47, 763-791, 2007.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Mar. 2010, an essentially new version of the PEP routine
C     PEP_DGESY2, by R. Granat, Umea University, Sweden, Apr. 2008.
C
C     REVISIONS
C
C     V. Sima, Apr. 2010, Oct. 2010, Aug. 2011.
C
C     KEYWORDS
C
C     Orthogonal transformation, periodic QZ algorithm, periodic
C     Sylvester-like equations, QZ algorithm.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
C     ..
C     .. Scalar Arguments ..
      LOGICAL            TRANA, TRANB
      INTEGER            INFO, ISGN, K, LDWORK, M, N
      DOUBLE PRECISION   PREC, SCALE, SMIN
C     ..
C     .. Array Arguments ..
      INTEGER            S( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), DWORK( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            DOSCAL, LQUERY
      INTEGER            CB, I, IA1, IA3, IB1, IB3, IC1, II, IM1, IXA,
     $                   IXB, IXC, IZ, J, KM2, KM3, KMN, L, LDW, LEN,
     $                   MINWRK, MM, MN, MN6, MN7, NN, ZC, ZD, ZI, ZI2,
     $                   ZIS
      DOUBLE PRECISION   AC, AD, BETA, BIGNUM, DMIN, ELEM, SCALOC, SGN,
     $                   SPIV, TAU, TEMP
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, MOD
C     ..
C     .. Executable Statements ..
C
C     Decode the input parameters.
C     For efficiency reasons, the parameters are not checked.
C
      INFO   = 0
      LQUERY = LDWORK.EQ.-1
C
      MN  = M*N
      KMN = K*MN
C
      MINWRK = ( 4*K - 3 ) * MN**2 + KMN
      IF( .NOT. LQUERY .AND. LDWORK.LT.MINWRK )
     $   INFO = -21
C
C     Quick return if possible.
C
      DWORK( 1 ) = DBLE( MINWRK )
      IF( LQUERY ) THEN
         RETURN
      ELSE IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03KE', -INFO )
         RETURN
      END IF
C
C     Find the overflow threshold.
C
      BIGNUM = PREC / SMIN
C
C     --- Use QR-factorizations and backward substitution ---
C
C     This variant does not utilize the sparsity structure of the
C     individual blocks of the matrix Z - storage of each block Z_i,i
C     is compatible with the BLAS. Numerics is stable since excessive
C     pivot growth is avoided.
C
      MM  = M*M
      NN  = N*N
      SGN = DBLE( ISGN )
      LDW = 3*MN
      IF( M.EQ.2 .AND. N.EQ.2 ) THEN
         MN6 = LDW + LDW
         MN7 = MN6 + LDW
         KM2 = KMN + KMN
         KM3 = KM2 + KMN
      END IF
C
C     Divide workspace for superdiagonal + diagonal + subdiagonal blocks
C     and right-most block column stored in a "block-packed" format. For
C     simplicity, an additional block Z_{0,1} appears in the first block
C     column in Z.
C
      ZD = 1
      ZC = ZD + LDW*MN*( K - 1 )
C
C     Also give workspace for right hand side in CB.
C
      CB = ZC + MN*KMN
C
C     Fill the Z part of the workspace with zeros.
C
      DO 10 J = 1, CB - 1
         DWORK( J ) = ZERO
   10 CONTINUE
C
C     Build matrix Z in ZD and ZC.
C
      IXA = 1
      IXB = 1
      IXC = 1
      IM1 = K
      ZI  = ZD + MN
C
      DO 20 I = 1, K - 1
C
C        Build Z_{i,i}, i = 1,...,K-1.
C
         IF( S( IM1 ).EQ.-1 ) THEN
C
            IA1 = ( IM1 - 1 )*MM + 1
            DWORK( ZI ) = A( IA1 )
            IF( M.EQ.2 ) THEN
               IA3 = IA1 + 2
               IF( .NOT. TRANA ) THEN
                  DWORK( ZI + 1   )  = A( IA1 + 1 )
                  DWORK( ZI + LDW )  = A( IA3     )
               ELSE
                  DWORK( ZI + 1   )  = A( IA3     )
                  DWORK( ZI + LDW )  = A( IA1 + 1 )
               END IF
               DWORK( ZI + LDW + 1 ) = A( IA3 + 1 )
            END IF
            IF( N.EQ.2 ) THEN
               ZI2 = ZI + ( LDW + 1 )*M
               DWORK( ZI2 ) = DWORK( ZI )
               IF( M.EQ.2 ) THEN
                  DWORK( ZI2 + 1 )       = DWORK( ZI + 1 )
                  DWORK( ZI2 + LDW     ) = DWORK( ZI + LDW     )
                  DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 )
               END IF
            END IF
C
         ELSE
C
            IB1 = ( IM1 - 1 )*NN + 1
            DWORK( ZI ) = SGN*B( IB1 )
            IF( .NOT. TRANB ) THEN
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB3 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB1 + 1 )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6 )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB3 )
                  DWORK( ZI + LDW     ) = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            ELSE
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB1 + 1 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB3     )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6 )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW     ) = SGN*B( IB3     )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            END IF
C
         END IF
C
C        Build Z_{i+1,i}, i = 1,...,K-1.
C
         ZI = ZI + MN
         IF( S( I ).EQ.1 ) THEN
C
            IA1 = IXA
            DWORK( ZI ) = A( IA1 )
            IF( M.EQ.2 ) THEN
               IA3 = IA1 + 2
               IF( .NOT. TRANA ) THEN
                  DWORK( ZI + 1   )  = A( IA1 + 1 )
                  DWORK( ZI + LDW )  = A( IA3     )
               ELSE
                  DWORK( ZI + 1   )  = A( IA3     )
                  DWORK( ZI + LDW )  = A( IA1 + 1 )
               END IF
               DWORK( ZI + LDW + 1 ) = A( IA3 + 1 )
            END IF
            IF( N.EQ.2 ) THEN
               ZI2 = ZI + ( LDW + 1 )*M
               DWORK( ZI2 ) = DWORK( ZI )
               IF( M.EQ.2 ) THEN
                  DWORK( ZI2 + 1 )       = DWORK( ZI + 1 )
                  DWORK( ZI2 + LDW     ) = DWORK( ZI + LDW     )
                  DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 )
               END IF
            END IF
C
         ELSE
C
            IB1 = IXB
            DWORK( ZI ) = SGN*B( IB1 )
            IF( .NOT. TRANB ) THEN
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB3 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB1 + 1 )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6     )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB3 )
                  DWORK( ZI + LDW     ) = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            ELSE
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB1 + 1 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB3     )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6     )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW     ) = SGN*B( IB3     )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            END IF
         END IF
C
         IXA = IXA + MM
         IXB = IXB + NN
         IM1 = I
         ZI  = ZI + MN*( LDW - 1 )
   20 CONTINUE
C
C     Build Z_{K,K}.
C
      IXA = IXA - MM
      IXB = IXB - NN
      ZI  = ZC + KMN - MN
      IF( S( K - 1 ).EQ.-1 ) THEN
C
         IA1 = IXA
         DWORK( ZI ) = A( IA1 )
         IF( M.EQ.2 ) THEN
            IA3 = IA1 + 2
            IF( .NOT. TRANA ) THEN
               DWORK( ZI + 1   )  = A( IA1 + 1 )
               DWORK( ZI + KMN )  = A( IA3     )
            ELSE
               DWORK( ZI + 1   )  = A( IA3     )
               DWORK( ZI + KMN )  = A( IA1 + 1 )
            END IF
            DWORK( ZI + KMN + 1 ) = A( IA3 + 1 )
         END IF
         IF( N.EQ.2 ) THEN
            ZI2 = ZI + ( KMN + 1 )*M
            DWORK( ZI2 ) = DWORK( ZI )
            IF( M.EQ.2 ) THEN
               DWORK( ZI2 + 1 )       = DWORK( ZI + 1 )
               DWORK( ZI2 + KMN     ) = DWORK( ZI + KMN     )
               DWORK( ZI2 + KMN + 1 ) = DWORK( ZI + KMN + 1 )
            END IF
         END IF
C
      ELSE
C
         IB1 = IXB
         DWORK( ZI ) = SGN*B( IB1 )
         IF( .NOT. TRANB ) THEN
            IF( M.EQ.2 ) THEN
               DWORK( ZI + KMN + 1 ) = DWORK( ZI )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 2 )       = SGN*B( IB3 )
                  DWORK( ZI + KMN + 3 ) = DWORK( ZI  + 2 )
                  DWORK( ZI + KM2     ) = SGN*B( IB1 + 1 )
                  DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZI + KM3 + 1 ) = DWORK( ZI  + KM2     )
                  DWORK( ZI + KM3 + 3 ) = DWORK( ZI  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZI + 1 )       = SGN*B( IB3 )
               DWORK( ZI + KMN     ) = SGN*B( IB1 + 1 )
               DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         ELSE
            IF( M.EQ.2 ) THEN
               DWORK( ZI + KMN + 1 ) = DWORK( ZI )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 2 )       = SGN*B( IB1 + 1 )
                  DWORK( ZI + KMN + 3 ) = DWORK( ZI  + 2 )
                  DWORK( ZI + KM2     ) = SGN*B( IB3     )
                  DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZI + KM3 + 1 ) = DWORK( ZI  + KM2     )
                  DWORK( ZI + KM3 + 3 ) = DWORK( ZI  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZI + 1 )       = SGN*B( IB1 + 1 )
               DWORK( ZI + KMN     ) = SGN*B( IB3     )
               DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         END IF
      END IF
C
C     Build Z_{1,K}.
C
      IF( S( K ).EQ.1 ) THEN
C
         IA1 = IA1 + MM
         DWORK( ZC ) = A( IA1 )
         IF( M.EQ.2 ) THEN
            IA3 = IA1 + 2
            IF( .NOT. TRANA ) THEN
               DWORK( ZC + 1   )  = A( IA1 + 1 )
               DWORK( ZC + KMN )  = A( IA3     )
            ELSE
               DWORK( ZC + 1   )  = A( IA3     )
               DWORK( ZC + KMN )  = A( IA1 + 1 )
            END IF
            DWORK( ZC + KMN + 1 ) = A( IA3 + 1 )
         END IF
         IF( N.EQ.2 ) THEN
            ZI2 = ZC + ( KMN + 1 )*M
            DWORK( ZI2 ) = DWORK( ZC )
            IF( M.EQ.2 ) THEN
               DWORK( ZI2 + 1 )       = DWORK( ZC + 1 )
               DWORK( ZI2 + KMN     ) = DWORK( ZC + KMN     )
               DWORK( ZI2 + KMN + 1 ) = DWORK( ZC + KMN + 1 )
            END IF
         END IF
C
      ELSE
C
         IB1 = IB1 + NN
         DWORK( ZC ) = SGN*B( IB1 )
         IF( .NOT. TRANB ) THEN
            IF( M.EQ.2 ) THEN
               DWORK( ZC + KMN + 1 ) = DWORK( ZC )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZC + 2 )       = SGN*B( IB3 )
                  DWORK( ZC + KMN + 3 ) = DWORK( ZC  + 2 )
                  DWORK( ZC + KM2     ) = SGN*B( IB1 + 1 )
                  DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZC + KM3 + 1 ) = DWORK( ZC  + KM2     )
                  DWORK( ZC + KM3 + 3 ) = DWORK( ZC  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZC + 1 )       = SGN*B( IB3 )
               DWORK( ZC + KMN     ) = SGN*B( IB1 + 1 )
               DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         ELSE
            IF( M.EQ.2 ) THEN
               DWORK( ZC + KMN + 1 ) = DWORK( ZC )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZC + 2 )       = SGN*B( IB1 + 1 )
                  DWORK( ZC + KMN + 3 ) = DWORK( ZC  + 2 )
                  DWORK( ZC + KM2     ) = SGN*B( IB3     )
                  DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZC + KM3 + 1 ) = DWORK( ZC  + KM2     )
                  DWORK( ZC + KM3 + 3 ) = DWORK( ZC  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZC + 1 )       = SGN*B( IB1 + 1 )
               DWORK( ZC + KMN     ) = SGN*B( IB3     )
               DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         END IF
      END IF
C
C     Prepare right hand side in CB.
C
      ZI = CB + MN
      DO 30 L = 1, K - 1
         IC1 = IXC
         DWORK( ZI ) = -C( IC1 )
         IF( M.EQ.1 ) THEN
            IF( N.EQ.2 )
     $         DWORK( ZI + 1 ) = -C( IC1 + 1 )
         ELSE
            DWORK( ZI + 1 )    = -C( IC1 + 1 )
            IF( N.EQ.2 ) THEN
               DWORK( ZI + 2 ) = -C( IC1 + 2 )
               DWORK( ZI + 3 ) = -C( IC1 + 3 )
            END IF
         END IF
         IXC = IXC + MN
         ZI  = ZI  + MN
   30 CONTINUE
C
      ZI  = CB
      IC1 = IXC
      DWORK( ZI ) = -C( IC1 )
      IF( M.EQ.1 ) THEN
         IF( N.EQ.2 )
     $      DWORK( ZI + 1 ) = -C( IC1 + 1 )
      ELSE
         DWORK( ZI + 1 )    = -C( IC1 + 1 )
         IF( N.EQ.2 ) THEN
            DWORK( ZI + 2 ) = -C( IC1 + 2 )
            DWORK( ZI + 3 ) = -C( IC1 + 3 )
         END IF
      END IF
C
C     Solve the Kronecker product system for X_i, i = 1,...,K
C     using overlapping (structured) QR-factorization and
C     backward substitution.
C
C     Step 1: Reduce the system to triangular form via overlapping
C             QR-factorizations.
C
C             The method here is based on successively formed
C             Householder reflections which are applied one by one
C             to the matrix Z and the right hand side c. The size
C             of each reflection is chosen as the number of elements
C             in each column from the last non-zero element up to
C             the diagonal.
C
C             Notation:
C             L   = current position of the column to work with;
C             I   = corresponding block column in Z;
C             II  = corresponding row and column position in Z-block;
C             LEN = length of the current Householder reflection.
C
      I   = 1
      II  = 0
      ZIS = ZD + MN
      ZI2 = ZD + MN*LDW
C
C     Treat Z_{K,K} separately from [Z_{i,i}',Z_{i+1,i}']' (see below).
C     DMIN is the minimum modulus of the final diagonal values.
C
      DMIN = BIGNUM
C
      DO 50 L = 1, KMN - MN
         II  = II   + 1
         ZI  = ZIS  + 2*MN
         LEN = 2*MN - II + 1
C
C        REPEAT
   40    CONTINUE
         ZI = ZI - 1
         ELEM = DWORK( ZI )
         IF( ELEM.EQ.ZERO ) THEN
            LEN = LEN - 1
            GO TO 40
         END IF
C        UNTIL ELEM.NE.ZERO.
C
         IF( LEN.GT.1 ) THEN
C
C           Generate Householder reflection to zero out the current
C           column. The new main diagonal value is stored temporarily
C           in BETA.
C
            ZI = ZI - LEN + 1
            CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU )
            BETA = DWORK( ZI )
            DWORK( ZI ) = ONE
C
C           Apply reflection to Z and c: first to the rest of the
C           corresponding rows and columns of [Z_{i,i}',Z_{i+1,i}']'
C           of size LEN-by-(MN-II) ...
C
            CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU,
     $                   DWORK( ZI + LDW ), LDW, DWORK )
C
C           ... then to the corresponding part of
C           [Z_{i,i+1}',Z_{i+1,i+1}']' of size LEN-by-MN ...
C
            IF( I.LT.K - 1 )
     $         CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU,
     $                      DWORK( ZI2 ), LDW, DWORK )
C
C           ... next to the corresponding part of
C           [Z_{i,K}',Z_{i+1,K}']' of size LEN-by-MN ...
C
            CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU,
     $                   DWORK( ZC + L - 1 ), KMN, DWORK )
C
C           ... and finally to c(L:L+LEN-1).
C
            CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU,
     $                   DWORK( CB + L - 1 ), KMN, DWORK )
C
C           Store the new diagonal value.
C
            DWORK( ZI ) = BETA
            DMIN = MIN( DMIN, ABS( BETA ) )
         END IF
C
         ZIS = ZIS + LDW
         ZI2 = ZI2 + 1
         IF( MOD( L, MN ).EQ.0 ) THEN
            I   =  I + 1
            II  =  0
            ZI2 = ZD + I*MN*LDW
         END IF
   50 CONTINUE
C
      II = 0
      ZI = ZC + KMN - MN
C
C     Z_{K,K} is treated separately.
C
      DO 60 L = KMN - MN + 1, KMN
         II  = II + 1
         LEN = MN - II + 1
         IF( LEN.GT.1 ) THEN
C
C           Generate Householder reflection.
C
            CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU )
            BETA = DWORK( ZI )
            DWORK( ZI ) = ONE
C
C           Apply reflection to Z and c: first to Z_{i,i} ...
C
            CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU,
     $                   DWORK( ZI + KMN ), KMN, DWORK )
C
C           ... and finally to c(L:L+LEN-1).
C
            CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU,
     $                   DWORK( CB + L - 1 ), KMN, DWORK )
C
C           Store the new diagonal value.
C
            DWORK( ZI ) = BETA
            DMIN = MIN( DMIN, ABS( BETA ) )
         END IF
         ZI = ZI + KMN + 1
C
   60 CONTINUE
C
C     Step 2: Use backward substitution on the computed triangular
C             system.
C
C             Here, we take the possible irregularities above the
C             diagonal of the resulting R-factor into account by
C             checking the number of elements from the main diagonal
C             to the last non-zero element above the diagonal that
C             resides in the current column.
C             Pivots less than SPIV = MAX( PREC*DMIN, SMIN ) are set
C             to SPIV.
C
      SCALE  = ONE
      DOSCAL = .FALSE.
      DMIN   = MAX( DMIN, SMIN )
      SPIV   = MAX( PREC*DMIN, SMIN )
C
C     Check for scaling.
C
      I  = IDAMAX( KMN, DWORK( CB ), 1 )
      AC = ABS( DWORK( CB + I - 1 ) )
      IF( TWO*SMIN*AC.GT.DMIN ) THEN
         TEMP = ( ONE / TWO ) / AC
         CALL DSCAL( KMN, TEMP, DWORK( CB ), 1 )
         SCALE = SCALE*TEMP
      END IF
C
      ZI = CB - 1
C
      DO 70 I = KMN, KMN - MN + 1, -1
C
         AD = ABS( DWORK( ZI ) )
         AC = ABS( DWORK( CB + I - 1 ) )
         IF( AD.LT.SPIV ) THEN
            AD = SPIV
            DWORK( ZI ) = SPIV
         END IF
         SCALOC = ONE
         IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN
            IF( AC.GT.BIGNUM*AD ) THEN
               INFO   = 1
               SCALOC = BIGNUM*AD / AC
               DOSCAL = .TRUE.
               SCALE  = SCALE * SCALOC
            END IF
         END IF
         TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI )
         IF( DOSCAL ) THEN
            DOSCAL = .FALSE.
            CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 )
         END IF
         DWORK( CB + I - 1 ) = TEMP
C
         CALL DAXPY( I - 1, -TEMP, DWORK( ZI - I + 1 ), 1, DWORK( CB ),
     $               1 )
C
         ZI = ZI - KMN - 1
   70 CONTINUE
C
      ZIS = ZC - LDW
      ZI  = ZIS + 2*MN - 1
      IZ  = 0
C
      DO 90 I = KMN - MN, 1, -1
         AD = ABS( DWORK( ZI ) )
         AC = ABS( DWORK( CB + I - 1 ) )
         IF( AD.LT.SPIV ) THEN
            AD = SPIV
            DWORK( ZI ) = SPIV
         END IF
         SCALOC = ONE
         IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN
            IF( AC.GT.BIGNUM*AD ) THEN
               INFO   = 1
               SCALOC = BIGNUM*AD / AC
               DOSCAL = .TRUE.
               SCALE  = SCALE * SCALOC
            END IF
         END IF
         TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI )
         IF( DOSCAL ) THEN
            DOSCAL = .FALSE.
            CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 )
         END IF
         DWORK( CB + I - 1 ) = TEMP
         LEN = MN + MOD( I - 1, MN ) + 1
         ZI2 = ZIS
   80    CONTINUE
         IF( DWORK( ZI2 ).EQ.ZERO ) THEN
            LEN = LEN - 1
            ZI2 = ZI2 + 1
            GO TO 80
         END IF
C
         J = MAX( 1, I - LEN + 1 )
         CALL DAXPY( I - J, -TEMP, DWORK( ZI - I + J ), 1,
     $               DWORK( CB + J - 1 ), 1 )
C
         IF( MN.GT.1 ) THEN
            IF( MOD( I, MN ).EQ.1 ) THEN
               IZ = 1 - MN
            ELSE
               IZ = 1
            END IF
         END IF
         ZI  = ZI  - LDW - IZ
         ZIS = ZIS - LDW
   90 CONTINUE
C
C     Reshape the solution into C.
C
      IC1 = 1
      ZI  = CB
C
      DO 100 L = 1, K
         C( IC1 ) = DWORK( ZI )
         IF( M.EQ.1 ) THEN
            IF( N.EQ.2 )
     $         C( IC1 + 1 ) = DWORK( ZI + 1 )
         ELSE
            C( IC1 + 1 ) = DWORK( ZI + 1 )
            IF( N.EQ.2 ) THEN
               C( IC1 + 2 ) = DWORK( ZI + 2 )
               C( IC1 + 3 ) = DWORK( ZI + 3 )
            END IF
         END IF
         IC1 = IC1 + MN
         ZI  = ZI  + MN
  100 CONTINUE
C
C     Store the minimal workspace on output.
C
      DWORK( 1 ) = DBLE( MINWRK )
      RETURN
C
C *** Last line of MB03KE ***
      END


      function appdiskpot(s,z)

      include 'commonblocks'

c  The potential is obtained by integrating the density of a sech**2
c  disk up vertically, ignoring radial potential gradients.  In the
c  resulting expression the cylindrical r is then replaced with
c  spherical radius, to make the potential zero at infinity (otherwise
c  the harmonics series do not have a simple asymptotic form at
c  infinity).
      r=sqrt(s*s+z*z)
c  erfc radial truncation factor
      t=sqrt(0.5d0)*(r-outdisk)/drtrunc
      if (t.lt.-4.0) then
         eerfc=1.
      elseif(t.gt.4.0) then
         appdiskpot=0.
         return
      else
         eerfc=0.5*erfc(t)
      endif

      f=diskconst*exp(-r/rdisk)
      zz=abs(z/zdisk)
      appdiskpot=-4*pi*f*zdisk**2*(zz+log(0.5*(1+exp(-2*zz))))*eerfc

      return
      end


C-----------------------------------------------------------------------
      SUBROUTINE SPGRADY(I,M,ENN1,EON,EONTOP,Q,QDY,QDYTOP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPGRADY     COMPUTE Y-GRADIENT IN SPECTRAL SPACE
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: COMPUTES THE HORIZONTAL VECTOR Y-GRADIENT OF A SCALAR FIELD
C           IN SPECTRAL SPACE.
C           SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY.
C           IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER,
C           EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS,
C           THEN THE MERIDIONAL GRADIENT OF Q(L,N) IS COMPUTED AS
C           EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1).
C           EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN.
C           ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0
C           IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN.
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL SPGRADY(I,M,ENN1,EON,EONTOP,Q,QDY,QDYTOP)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     ENN1     - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
C     EON      - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A
C     EONTOP   - REAL (M+1) EPSILON/N*A OVER TOP
C     Q        - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD
C
C   OUTPUT ARGUMENT LIST:
C     QDY      - REAL ((M+1)*((I+1)*M+2)) MERID GRADIENT (TIMES COSLAT)
C     QDYTOP   - REAL (2*(M+1)) MERID GRADIENT (TIMES COSLAT) OVER TOP
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      REAL ENN1((M+1)*((I+1)*M+2)/2)
      REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
      REAL Q((M+1)*((I+1)*M+2))
      REAL QDY((M+1)*((I+1)*M+2))
      REAL QDYTOP(2*(M+1))
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TAKE MERIDIONAL GRADIENT
      K=1
      QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)
      QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)
      DO K=2,(M+1)*((I+1)*M+2)/2-1
        QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)-EON(K)*ENN1(K-1)*Q(2*K-3)
        QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)-EON(K)*ENN1(K-1)*Q(2*K-2)
      ENDDO
      K=(M+1)*((I+1)*M+2)/2
      QDY(2*K-1)=-EON(K)*ENN1(K-1)*Q(2*K-3)
      QDY(2*K)=-EON(K)*ENN1(K-1)*Q(2*K-2)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TAKE MERIDIONAL GRADIENT OVER TOP
      DO L=0,M
        K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1
        QDYTOP(2*L+1)=-EONTOP(L+1)*ENN1(K)*Q(2*K-1)
        QDYTOP(2*L+2)=-EONTOP(L+1)*ENN1(K)*Q(2*K)
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


      REAL FUNCTION VALKH(HFFDG)
C
C CHANGE RECORD
C
      USE GLOBAL
      IF(HFFDG.LE.0.02)THEN
        VALKH=HFFDG*HFFDG
        RETURN
      ENDIF
      IF(HFFDG.GE.10.)THEN
        VALKH=HFFDG
        RETURN
      ENDIF
      DO NTAB=2,1001
        FTMPM1=FUNKH(NTAB-1)
        FTMP  =FUNKH(NTAB  )
        IF(FTMPM1.LE.HFFDG.AND.HFFDG.LT.FTMP)THEN
          VALKH=RKHTAB(NTAB)
     &        -(RKHTAB(NTAB)-RKHTAB(NTAB-1))*(FTMP-HFFDG)/(FTMP-FTMPM1)
          RETURN
        ENDIF
      ENDDO
      IF(NTAB.EQ.1001)THEN
        WRITE(6,600) RKHTAB(1001)
        WRITE(8,600) RKHTAB(1001)
        STOP
      ENDIF
C
C **  INITIALIZE WAVE DISPERSION RELATION TABLE
C           DRDF=(RKH(M+1)-RKH(M))/(FRKH(M+1)-FRKH(M))
C           GOTO 200
C  200 CONTINUE
C
  600 FORMAT(' WAVE DISPERSION TABLE OUT OF BOUNDS KH = ',E12.4)
      RETURN
      END


      subroutine evol_betagd(n_Lamx,n_beta,np1_Lamx,np1_beta,x,Nx,eta,ht
     &,mus,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 eta
      real*8 ht
      real*8 mus
      real*8 myzero
      real*8 n_Lamx(Nx)
      real*8 n_beta(Nx)
      real*8 np1_Lamx(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_beta(i) - 0.2D1 / (eta * ht + 0.2D1) * ht * ((-0.1D1 * n_
     #beta(i) + np1_beta(i)) / ht - 0.5000000000000000D0 * mus * np1_Lam
     #x(i) + 0.5000000000000000D0 * eta * np1_beta(i) - 0.50000000000000
     #00D0 * mus * n_Lamx(i) + 0.5000000000000000D0 * eta * n_beta(i))
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_beta(i) - 0.2D1 / (eta * ht + 0.2D1) * ht * ((-0.1D1 * n_
     #beta(i) + np1_beta(i)) / ht - 0.5000000000000000D0 * mus * np1_Lam
     #x(i) + 0.5000000000000000D0 * eta * np1_beta(i) - 0.50000000000000
     #00D0 * mus * n_Lamx(i) + 0.5000000000000000D0 * eta * n_beta(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      END


program problem74
  implicit none
  integer, parameter :: factorials(0:9) = (/ 1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880 /)
  integer            :: i,answer

  answer=0
  do i=1,1000000
     if (predicate(i)) answer=answer+1
  end do

  print *, answer

contains

  pure function step(n)
    implicit none
    integer*16, intent(in) :: n
    integer*16             :: temp,step

    temp=n
    step=0
    do while(temp>0)
       step=step+factorials(mod(temp,10))
       temp=temp/10
    end do

  end function step

  pure function predicate(n)
    implicit none
    integer, intent(in)      :: n
    integer                  :: i
    integer, parameter       :: m=60
    integer*16, dimension(m) :: trajectory
    logical                  :: predicate

    trajectory(1)=int(n,16)
    do i=2,m
       trajectory(i)=step(trajectory(i-1))
    end do

    predicate=all(trajectory(1:m-1) /= trajectory(m))

  end function predicate

end program problem74


!----------------- BEGIN CL68_NUMRCL_INT -----------------------------
      function cl68_numrcl_int( an_in, xi_in, zup)
! Numerical integration of eq. 6.8 in Cartwright and Longuet-Higgins
! Dates: 06/09/95 - Written by D.M. Boore, and tested using CHK_INT.
!                   I also plotted the integrand for typical values
!                   of an, xi, and found that it decays strongly to zero
!                   by a value of 5 for the variable.  I use 10 as an upper
!                   limit, which should be much more than enough.  The
!                   integration routines are such, however, that I could
!                   probably use a much larger m=number with little extra
!                   time.
!        12/19/95 - Added zup to exact_numrcl
!        12/28/95 - Name changed from exact_numrcl to cl68_numrcl
!        01/03/96 - Name changed from cl68_numrcl to cl68_numrcl_int
!        03/13/99 - On the advice of R. Herrmann, substituted qromb for
!                   qmidpnt.  Numerical tests indicate that both give the
!                   same answers, but qromb evaluates the function at the
!                   endpoints (zlow and zup), whereas qmidpnt does not (and
!                   is appropriate for an improper integral for which
!                   the integrand cannot be evaluated right at the endpoints;
!                   this is not the case here).
!        01/27/02 - Reset zup so that the integrand is not equal to 0.0
!                   (except the last point).  I did this because I was being
!                   plagued with small differences in the pk_rms factor for
!                   some values of D, M, and zup.  After a bunch of testing,
!                   using embedded write statements and the program chk_int,
!                   I'm pretty sure that the problem is related to the attempt
!                   to numerically integrate the function when it has been set
!                   to 0.0 by the compiler (because of underflow).  The
!                   integrand decreases rapidly, so that zup=10 is generally
!                   much larger than needed.  Note that I also eliminated the
!                   "glitch" in pk_rms by setting eps in qromb to 1.0e-8, but I
!                   think the current fix is better.

      external cl68_integrand

      common /clint/ xi, an

      an = an_in
      xi = xi_in
      zlow = 0.0 ! where is zup? It is read in as a parameter in the input file.

! Reset zup if need be:
      zup_step = 0.1
      do while (cl68_integrand(zup) .eq. 0.0)
        zup = zup - zup_step
      end do
      zup = zup + zup_step

      call qromb(cl68_integrand,zlow,zup,result)

      cl68_numrcl_int = result/sqrt(2.0)

      return
      end
!----------------- END CL68_NUMRCL_INT -----------------------------


      real*8 function sqdist(x1,y1,z1,x2,y2,z2,ind,MAXROT,rotmat)
!-----------------------------------------------------------------------
!
!    Squared Anisotropic Distance Calculation Given Matrix Indicator
!    ***************************************************************
!
! This routine calculates the anisotropic distance between two points
!  given the coordinates of each point and a definition of the
!  anisotropy.
!
!
! INPUT VARIABLES:
!
!   x1,y1,z1         Coordinates of first point
!   x2,y2,z2         Coordinates of second point
!   ind              The rotation matrix to use
!   MAXROT           The maximum number of rotation matrices dimensioned
!   rotmat           The rotation matrices
!
!
!
! OUTPUT VARIABLES:
!
!   sqdist           The squared distance accounting for the anisotropy
!                      and the rotation of coordinates (if any).
!
!
! NO EXTERNAL REFERENCES
!
!
!-----------------------------------------------------------------------
      real*8 rotmat(MAXROT,3,3),cont,dx,dy,dz
!
! Compute component distance vectors and the squared distance:
!
      dx = dble(x1 - x2)
      dy = dble(y1 - y2)
      dz = dble(z1 - z2)
      sqdist = 0.0
      do i=1,3
            cont   = rotmat(ind,i,1) * dx &
                   + rotmat(ind,i,2) * dy &
                   + rotmat(ind,i,3) * dz
            sqdist = sqdist + cont * cont
      end do
      return
      end


      SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve an N-by-N pole placement problem for the simple cases
C     N = 1 or N = 2: given the N-by-N matrix A and N-by-M matrix B,
C     construct an M-by-N matrix F such that A + B*F has prescribed
C     eigenvalues. These eigenvalues are specified by their sum S and
C     product P (if N = 2). The resulting F has minimum Frobenius norm.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A and also the number of rows of
C             the matrix B and the number of columns of the matrix F.
C             N is either 1, if a single real eigenvalue is prescribed
C             or 2, if a complex conjugate pair or a set of two real
C             eigenvalues are prescribed.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B and also the number
C             of rows of the matrix F.  M >= 1.
C
C     S       (input) DOUBLE PRECISION
C             The sum of the prescribed eigenvalues if N = 2 or the
C             value of prescribed eigenvalue if N = 1.
C
C     P       (input) DOUBLE PRECISION
C             The product of the prescribed eigenvalues if N = 2.
C             Not referenced if N = 1.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N,N)
C             On entry, this array must contain the N-by-N state
C             dynamics matrix whose eigenvalues have to be moved to
C             prescribed locations.
C             On exit, this array contains no useful information.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (N,M)
C             On entry, this array must contain the N-by-M input/state
C             matrix B.
C             On exit, this array contains no useful information.
C
C     F       (output) DOUBLE PRECISION array, dimension (M,N)
C             The state feedback matrix F which assigns one pole or two
C             poles of the closed-loop matrix A + B*F.
C             If N = 2 and the pair (A,B) is not controllable
C             (INFO = 1), then F(1,1) and F(1,2) contain the elements of
C             an orthogonal rotation which can be used to remove the
C             uncontrollable part of the pair (A,B).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The absolute tolerance level below which the elements of A
C             and B are considered zero (used for controllability test).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (M)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if uncontrollability of the pair (A,B) is detected.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine SB01BY.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C     May  2003, A. Varga, German Aerospace Center.
C
C     KEYWORDS
C
C     Eigenvalue, eigenvalue assignment, feedback control, pole
C     placement, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  FOUR, ONE, THREE, ZERO
      PARAMETER         ( FOUR = 4.0D0,  ONE = 1.0D0, THREE = 3.0D0,
     $                    ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, M, N
      DOUBLE PRECISION  P, S, TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(N,*), B(N,*), DWORK(*), F(M,*)
C     .. Local Scalars ..
      INTEGER           IR, J
      DOUBLE PRECISION  ABSR, B1, B2, B21, C, C0, C1, C11, C12, C21,
     $                  C22, C3, C4, CS, CU, CV, DC0, DC2, DC3, DIFFR,
     $                  R, RN, S12, S21, SIG, SN, SU, SV, TAU1, TAU2,
     $                  WI, WI1, WR, WR1, X, Y, Z
C     .. External Functions ..
      DOUBLE PRECISION  DLAMC3, DLAMCH
      EXTERNAL          DLAMC3, DLAMCH
C     .. External Subroutines ..
      EXTERNAL          DLANV2, DLARFG, DLASET, DLASV2, DLATZM, DROT
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MIN
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked.
C
      INFO = 0
      IF( N.EQ.1 ) THEN
C
C        The case N = 1.
C
         IF( M.GT.1 )
     $      CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 )
         B1 = B(1,1)
         IF( ABS( B1 ).LE.TOL ) THEN
C
C           The pair (A,B) is uncontrollable.
C
            INFO = 1
            RETURN
         END IF
C
         F(1,1) = ( S - A(1,1) )/B1
         IF( M.GT.1 ) THEN
            CALL DLASET( 'Full', M-1, 1, ZERO, ZERO, F(2,1), M )
            CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1),
     $                   M, DWORK )
         END IF
         RETURN
      END IF
C
C     In the sequel N = 2.
C
C     Compute the singular value decomposition of B in the form
C
C                    ( V  0 )                ( B1 0  )
C     B = U*( G1 0 )*(      )*H2*H1 ,   G1 = (       ),
C                    ( 0  I )                ( 0  B2 )
C
C               ( CU   SU )          ( CV   SV )
C     where U = (         )  and V = (         )  are orthogonal
C               (-SU   CU )          (-SV   CV )
C
C     rotations and H1 and H2 are elementary Householder reflectors.
C     ABS(B1) and ABS(B2) are the singular values of matrix B,
C     with ABS(B1) >= ABS(B2).
C
C     Reduce first B to the lower bidiagonal form  ( B1  0  ... 0 ).
C                                                  ( B21 B2 ... 0 )
      IF( M.EQ.1 ) THEN
C
C        Initialization for the case M = 1; no reduction required.
C
         B1  = B(1,1)
         B21 = B(2,1)
         B2  = ZERO
      ELSE
C
C        Postmultiply B with elementary Householder reflectors H1
C        and H2.
C
         CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 )
         CALL DLATZM( 'Right', N-1, M, B(1,2), N, TAU1, B(2,1), B(2,2),
     $                N, DWORK )
         B1  = B(1,1)
         B21 = B(2,1)
         IF( M.GT.2 )
     $      CALL DLARFG( M-1, B(2,2), B(2,3), N, TAU2 )
         B2  = B(2,2)
      END IF
C
C     Reduce B to a diagonal form by premultiplying and postmultiplying
C     it with orthogonal rotations U and V, respectively, and order the
C     diagonal elements to have decreasing magnitudes.
C     Note: B2 has been set to zero if M = 1. Thus in the following
C     computations the case M = 1 need not to be distinguished.
C     Note also that LAPACK routine DLASV2 assumes an upper triangular
C     matrix, so the results should be adapted.
C
      CALL DLASV2( B1, B21, B2, X, Y, SU, CU, SV, CV )
      SU = -SU
      B1 =  Y
      B2 =  X
C
C     Compute  A1 = U'*A*U.
C
      CALL DROT( 2, A(2,1), 2, A(1,1), 2, CU, SU )
      CALL DROT( 2, A(1,2), 1, A(1,1), 1, CU, SU )
C
C     Compute the rank of B and check the controllability of the
C     pair (A,B).
C
      IR = 0
      IF( ABS( B2 ).GT.TOL ) IR = IR + 1
      IF( ABS( B1 ).GT.TOL ) IR = IR + 1
      IF( IR.EQ.0 .OR. ( IR.EQ.1 .AND. ABS( A(2,1) ).LE.TOL ) ) THEN
         F(1,1) =  CU
         F(1,2) = -SU
C
C        The pair (A,B) is uncontrollable.
C
         INFO = 1
         RETURN
      END IF
C
C     Compute F1 which assigns N poles for the reduced pair (A1,G1).
C
      X = DLAMC3( B1, B2 )
      IF( X.EQ.B1 ) THEN
C
C        Rank one G1.
C
         F(1,1) = ( S - ( A(1,1) + A(2,2) ) )/B1
         F(1,2) = -( A(2,2)*( A(2,2) - S ) + A(2,1)*A(1,2) + P )/
     $             A(2,1)/B1
         IF( M.GT.1 ) THEN
            F(2,1) = ZERO
            F(2,2) = ZERO
         END IF
      ELSE
C
C        Rank two G1.
C
         Z = ( S - ( A(1,1) + A(2,2) ) )/( B1*B1 + B2*B2 )
         F(1,1) = B1*Z
         F(2,2) = B2*Z
C
C        Compute an approximation for the minimum norm parameter
C        selection.
C
         X = A(1,1) + B1*F(1,1)
         C = X*( S - X ) - P
         IF( C.GE.ZERO ) THEN
            SIG =  ONE
         ELSE
            SIG = -ONE
         END IF
         S12 = B1/B2
         S21 = B2/B1
         C11 = ZERO
         C12 = ONE
         C21 = SIG*S12*C
         C22 = A(1,2) - SIG*S12*A(2,1)
         CALL DLANV2( C11, C12, C21, C22, WR, WI, WR1, WI1, CS, SN )
         IF( ABS( WR - A(1,2) ).GT.ABS( WR1 - A(1,2) ) ) THEN
            R = WR1
         ELSE
            R = WR
         END IF
C
C        Perform Newton iteration to solve the equation for minimum.
C
         C0 = -C*C
         C1 =  C*A(2,1)
         C4 =  S21*S21
         C3 = -C4*A(1,2)
         DC0 = C1
         DC2 = THREE*C3
         DC3 = FOUR*C4
C
         DO 10 J = 1, 10
            X  = C0 + R*( C1 + R*R*( C3 + R*C4 ) )
            Y  = DC0 + R*R*( DC2 + R*DC3 )
            IF( Y.EQ.ZERO ) GO TO 20
            RN = R - X/Y
            ABSR  = ABS( R )
            DIFFR = ABS( R - RN )
            Z = DLAMC3( ABSR, DIFFR )
            IF( Z.EQ.ABSR )
     $         GO TO 20
            R = RN
   10    CONTINUE
C
   20    CONTINUE
         IF( R.EQ.ZERO ) R = DLAMCH( 'Epsilon' )
         F(1,2) = (  R  - A(1,2) )/B1
         F(2,1) = ( C/R - A(2,1) )/B2
      END IF
C
C     Back-transform F1. Compute first F1*U'.
C
      CALL DROT( MIN( M, 2 ), F(1,1), 1, F(1,2), 1, CU, SU )
      IF( M.EQ.1 )
     $   RETURN
C
C     Compute V'*F1.
C
      CALL DROT( 2, F(2,1), M, F(1,1), M, CV, SV )
C
C               ( F1 )
C     Form  F = (    ) .
C               ( 0  )
C
      IF( M.GT.N )
     $   CALL DLASET( 'Full', M-N, N, ZERO, ZERO, F(N+1,1), M )
C
C     Compute H1*H2*F.
C
      IF( M.GT.2 )
     $   CALL DLATZM( 'Left', M-1, N, B(2,3), N, TAU2, F(2,1), F(3,1),
     $                M, DWORK )
      CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), M,
     $             DWORK )
C
      RETURN
C *** Last line of SB01BY ***
      END


c
c    ************************  DET *******************************
c
c              calculate the determinant of matrix A(3,3)
c     *************************************************************
       real*8 function det(a11,a12,a13,a21,a22,a23,a31,a32,a33)
       implicit none
       real*8 a11,a12,a13,a21,a22,a23,a31,a32,a33
       det=a11*(a22*a33-a23*a32)+a12*(a23*a31-a21*a33)+
     1     a13*(a21*a32-a22*a31)
       return
      end


	SUBROUTINE DP_TERM  ( datmin, datmax, res, logscl, iofset,
     +			      nbits, iret )
C************************************************************************
C* DP_TERM								*
C* 									*
C* This subroutine computes the terms required by the data-packing	*
C* subroutines.  The scale factor, offset, and number of bits are 	*
C* computed from the minimum, maximum and resolution for each data	*
C* item.  These terms are computed for a single item in this subroutine.*
C* Therefore, this subroutine must be called for each data item to be 	*
C* packed.								*
C*									*
C* The resolution must be an integral power of 10.  If not, the next	*
C* smaller resolution will be used.  For example: RES = .5 will use a	*
C* resolution of .1 .  LOGSCL is the base 10 logarithm of the value to	*
C* be used in scaling data.  NBITS must be less than 32.		*
C* 									*
C* DP_TERM  ( DATMIN, DATMAX, RES, LOGSCL, IOFSET, NBITS, IRET )	*
C* 									*
C* Input parameters:							*
C*	DATMIN		REAL		Minimum data value		*
C*	DATMAX		REAL		Maximum data value		*
C*	RES		REAL		Resolution to be retained	*
C* 									*
C* Output parameters:							*
C*	LOGSCL		INTEGER		Log10 of scaling factor		*
C*	IOFSET		INTEGER		Data offset			*
C*	NBITS		INTEGER		Number of bits			*
C*	IRET		INTEGER		Return code			*
C*	 				   0 = normal return		*
C*					  -5 = DATMAX less than DATMIN	*
C*					  -6 = invalid resolution	*
C**									*
C* Log:									*
C* G. Chatters/RDS	 4/84						*
C* M. desJardins/GSFC	 3/86						*
C* M. desJardins/GSFC	 3/87						*
C* M. desJardins/GSFC	10/89	Allow packing of single value		*
C* S. Jacobs/NCEP	 5/01	Fixed error code: changed -2 to -5	*
C************************************************************************
C------------------------------------------------------------------------
	rmax   = 2. ** 31
	logscl = 0
	iofset = 0
	nbits  = 32
C
C*	For invalid range, set return code, allow for storing full value.
C
	IF  ( datmax .lt. datmin )  THEN
	    iret = -5
C
C*	    Return error for "infinite" resolution ( res = 0 ) or
C*	    negative resolution.
C
	  ELSE IF  ( res .le. 0. )  THEN
	    iret = -6
C
C*	    General case.  Formula for packing is:
C*	    IPACK = NINT ( DATA / SCALE ) - IOFSET.
C*	    Where SCALE = 10.**LOGSCL.
C*
C*  	    First compute log of scale factor, then take power of 10
C*	    to get scale factor for later internal computation. Log of
C*	    scale factor is log10 of resolution truncated to next
C*	    smaller integer value.
C
	  ELSE
	    logscl = INT ( ALOG10 ( res ) )
	    IF ( ALOG10 ( res ) .lt. 0.0  .and.
     *	         ALOG10 ( res ) .ne. REAL ( INT ( ALOG10 ( res ) ) ) )
     *	         logscl = logscl - 1
C
	    scale = 10.**logscl
C
C*	    Check to see that scale is not too small to do computations.
C*	    If it is, treat same as for RES = 0.0
C
	   IF ( ABS ( datmin / scale ) .gt. ( rmax )  .or.
     *	        ABS ( datmax / scale ) .gt. ( rmax )  .or.
     *	        ABS ( ( datmax - datmin ) / scale ) .gt. ( rmax)) THEN
	      iret = -6
C
C*	      The offset is the scaled value of DATMIN, which is then
C*	      truncated to next smaller integer.  Thus, the smallest packed
C*	      data field will be zero.  IF tests are necessary so that
C*	      truncation is done in right direction for negative values.
C
	   ELSE
	      iofset = INT ( datmin / scale )
	      IF ( datmin .lt. 0.0 .and.
     *	       datmin / scale .NE. REAL ( INT ( datmin / scale ) ) )
     *	       iofset = INT ( datmin / scale ) - 1
C
C*	      NBITS is the same as the number of bits required to store
C*	      DATMAX after it has scale and offset applied.  We have to be
C*	      sure that this value is rounded up properly.
C
	      maxval = INT ( datmax / scale ) - iofset
	      IF ( datmax .gt. 0.0  .and.
     *	       datmax / scale .NE. REAL ( INT ( datmax / scale ) ) )
     *	       maxval = INT ( datmax / scale ) - iofset + 1
C
C*	      Add 1 so that the largest possible value ( all bits on ) can
C*	      be used as a missing data flag.
C
	      maxval = maxval + 1
C
C*	      Count number of bits required to store MAXVAL.
C
	      nbits = 0
	      DO WHILE ( maxval .NE. 0 )
	         maxval = ISHFT ( maxval, -1 )
	         nbits  = nbits + 1
	      END DO
	      iret = 0
	   END IF
	END IF
C*
	RETURN
	END


      subroutine sphere_compute_error_fort(mx,my,mbc,meqn,
     &      dx,dy,xlower,ylower,t, q,error,xp,yp,zp)
      implicit none

      integer mx,my,mbc,meqn
      double precision dx, dy, xlower, ylower, t
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision error(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer i,j
      double precision gaussian_sum

      include 'fclaw2d_metric_terms.i'

c     # Assume a single field variable only
      do j = 1,my
         do i = 1,mx
            error(i,j,1) = q(i,j,1) -
     &            gaussian_sum(xp(i,j),yp(i,j),zp(i,j))
         enddo
      enddo
      end