! A piecewise linear regression model.
MODULE PLRM
  USE ISO_FORTRAN_ENV, ONLY: REAL64
  IMPLICIT NONE
  ! Value used for rectification, default is 0.
  REAL(KIND=REAL64), PARAMETER :: DISCONTINUITY = 0.0_REAL64
  REAL(KIND=REAL64), PARAMETER :: SMALL_SLOPE = 0.01_REAL64
  ! Value for bias base (in terms of standard deviation for unit
  !  variance data), default value is 2.
  REAL(KIND=REAL64), PARAMETER :: BIAS_MIN_PERC = 1.0_REAL64
  REAL(KIND=REAL64), PARAMETER :: BIAS_MAX_PERC = 50.0_REAL64
  REAL(KIND=REAL64), PARAMETER :: BIAS_STDEVS = 2.0_REAL64
  ! MDI = Model dimension -- input
  ! MDS = Model dimension -- states (internal)
  ! MNS = Model number -- states (internal)
  ! MDO = Model dimension -- output
  INTEGER :: MDI, MDS, MNS, MDO
  ! Model parameters, for evaluation.
  REAL(KIND=REAL64), DIMENSION(:,:),   ALLOCATABLE :: INPUT_PARAMS
  REAL(KIND=REAL64), DIMENSION(:),     ALLOCATABLE :: INPUT_BIAS
  REAL(KIND=REAL64), DIMENSION(:,:,:), ALLOCATABLE :: INTERNAL_PARAMS
  REAL(KIND=REAL64), DIMENSION(:,:),   ALLOCATABLE :: INTERNAL_BIAS
  REAL(KIND=REAL64), DIMENSION(:,:),   ALLOCATABLE :: OUTPUT_PARAMS
  REAL(KIND=REAL64), DIMENSION(:),     ALLOCATABLE :: OUTPUT_BIAS

  PUBLIC :: NEW_MODEL, INIT_MODEL, MINIMIZE_MSE, EVALUATE_ONE
  PRIVATE :: DROP_INTERNAL_NODES, SWAP_PARAMS, SSE_GRADIENT

CONTAINS

  ! Allocate storage for a new model given paramters:
  !   DI -- Dimension of input vector.
  !   DS -- Dimension of internal vectors spaces.
  !   NS -- Number of sequential internal vector spaces.
  !   DO -- Dimension of output vector.
  SUBROUTINE NEW_MODEL(DI, DS, NS, DO)
    INTEGER, INTENT(IN) :: DI, DS, NS, DO
    ! Store the integer sizes related to this model.
    MDI = DI
    MDS = DS
    MNS = NS
    MDO = DO
    ! Deallocate any of the internal arrays if they have already been allocated.
    IF (ALLOCATED(INPUT_PARAMS))    DEALLOCATE(INPUT_PARAMS)
    IF (ALLOCATED(INPUT_BIAS))      DEALLOCATE(INPUT_BIAS)
    IF (ALLOCATED(INTERNAL_PARAMS)) DEALLOCATE(INTERNAL_PARAMS)
    IF (ALLOCATED(INTERNAL_BIAS))   DEALLOCATE(INTERNAL_BIAS)
    IF (ALLOCATED(OUTPUT_PARAMS))   DEALLOCATE(OUTPUT_PARAMS)
    IF (ALLOCATED(OUTPUT_BIAS))     DEALLOCATE(OUTPUT_BIAS)
    ! Allocate space for all model parameters.
    ALLOCATE( &
         INPUT_PARAMS(DI,DS), &
         INPUT_BIAS(DS), &
         INTERNAL_PARAMS(DS, DS, NS-1), &
         INTERNAL_BIAS(DS, NS-1), &
         OUTPUT_PARAMS(DS, DO), &
         OUTPUT_BIAS(DO) &
         )
  END SUBROUTINE NEW_MODEL

  ! Initialize the weights for a model, optionally provide a random seed.
  SUBROUTINE INIT_MODEL(INPUTS, OUTPUTS, SEED)
    REAL(KIND=REAL64), DIMENSION(:,:), INTENT(IN), OPTIONAL :: INPUTS, OUTPUTS
    INTEGER, INTENT(IN), OPTIONAL :: SEED
    ! Storage for data-related statistics for high quality initialization.
    REAL(KIND=REAL64), DIMENSION(:),   ALLOCATABLE :: VALUES
    REAL(KIND=REAL64), DIMENSION(:,:), ALLOCATABLE :: INTERNAL_VALUES, OUTPUT_VALUES
    !  Storage for seeding the random number generator (for repeatability).
    INTEGER, DIMENSION(:), ALLOCATABLE :: SEED_ARRAY
    ! Dimension and layer iterates, number of points, scalar used to
    !  regularly space bias values, and selected percentile.
    !  (all only relevant if INPUTS is provided).
    INTEGER :: D, L, I
    REAL(KIND=REAL64) :: N, S, P, MEAN, STDEV
    ! Set a random seed, if one was provided (otherwise leave default).
    IF (PRESENT(SEED)) THEN
       CALL RANDOM_SEED(SIZE=I)
       ALLOCATE(SEED_ARRAY(I))
       SEED_ARRAY(:) = SEED
       CALL RANDOM_SEED(PUT=SEED_ARRAY(:))
    END IF
    !
    ! TODO:
    !  - compute the scale and range of inputs, use that to
    !    adjust the input layer
    !  - compute the scale and range of each intermediate layer and
    !    adjust all initial parameters accordingly
    !  - study output surface of model, make sure it looks like a
    !    random valued surface with * variance and zero mean.
    !
    ! Generate random unit-length vectors (no scaling biases) for
    !  all initial parameters in the input, internal, and output.
    CALL RANDOM_UNIT_VECTORS(INPUT_PARAMS(:,:))
    DO I = 1, MNS-1
       CALL RANDOM_UNIT_VECTORS(INTERNAL_PARAMS(:,:,I))
    END DO
    CALL RANDOM_UNIT_VECTORS(OUTPUT_PARAMS(:,:))
    ! Generate random biases for inputs and internal layers, zero
    !  bias for the output layer (first two will be rescaled).
    CALL RANDOM_NUMBER(INPUT_BIAS(:))
    CALL RANDOM_NUMBER(INTERNAL_BIAS(:,:))
    OUTPUT_BIAS(:) = 0.0_REAL64
    ! Get the scalar for adjusting internal bias values.
    S = (1.0_REAL64 / REAL(MDI,REAL64))
    ! Adjust parameters based on sample input data.
    IF (PRESENT(INPUTS)) THEN
       ! Allocate storage for intermediate arrays.
       ALLOCATE( INTERNAL_VALUES(1:SIZE(INPUTS,2),1:MDS), &
            OUTPUT_VALUES(1:SIZE(INPUTS,2),1:MDO), &
            VALUES(1:SIZE(INPUTS,2)) )
       ! Get the number of points.
       N = REAL(SIZE(INPUTS,2), REAL64)
       ! Compute first layer of internal values.
       INTERNAL_VALUES(:,:) = MATMUL(TRANSPOSE(INPUTS(:,:)), INPUT_PARAMS(:,:))
       DO L = 1, MNS
          ! Adjust magnitude of vectors to make dimension values unit variance.
          DO D = 1, MDS
             MEAN = SUM(INTERNAL_VALUES(:,D) / N)
             STDEV = SQRT(MAX(EPSILON(STDEV), SUM((INTERNAL_VALUES(:,D) - MEAN)**2 / N)))
             IF (L .EQ. 1) THEN
                INPUT_PARAMS(:,D) = INPUT_PARAMS(:,D) / STDEV
                ! Select a percentile of the values to use as the bias shift.
                P = BIAS_MAX_PERC - INPUT_BIAS(D)**S * (BIAS_MAX_PERC - BIAS_MIN_PERC)
                S = (1.0_REAL64 / REAL(MDS,REAL64))
             ELSE
                I = L-1
                INTERNAL_PARAMS(:,D,I) = INTERNAL_PARAMS(:,D,I) / STDEV
                ! Select a percentile of the values to use as the bias shift.
                P = BIAS_MAX_PERC - INTERNAL_BIAS(D,I)**S * (BIAS_MAX_PERC - BIAS_MIN_PERC)
             END IF
             ! Adjust current values based on updated scaling of input vector.
             INTERNAL_VALUES(:,D) = INTERNAL_VALUES(:,D) / STDEV
             ! Extract the "P"th percentil value from the values.
             I = INT(P * N / 100.0)
             VALUES(:) = INTERNAL_VALUES(:,D)
             CALL SELECT_R64(VALUES(:), I)
             ! Compute the values for this dimension of this layer based on the bias.
             IF (L .EQ. 1) THEN
                INPUT_BIAS(D) = - (VALUES(I) + DISCONTINUITY)
                MEAN = INPUT_BIAS(D)
             ELSE
                I = L-1
                INTERNAL_BIAS(D,I) = - (VALUES(I) + DISCONTINUITY)
                MEAN = INTERNAL_BIAS(D,I)
             END IF
             INTERNAL_VALUES(:,D) = INTERNAL_VALUES(:,D) + MEAN
             ! Evaluate tranformation function based on biases.
             WHERE (INTERNAL_VALUES(:,D) .LT. DISCONTINUITY)
                INTERNAL_VALUES(:,D) = INTERNAL_VALUES(:,D) * SMALL_SLOPE
             END WHERE
          END DO
          ! Compute the internal values for the next layer.
          IF (L .LT. MNS) THEN
             INTERNAL_VALUES(:,:) = MATMUL(INTERNAL_VALUES(:,:), INTERNAL_PARAMS(:,:,L))
          END IF
       END DO
       ! Compute the outputs from the last layer.
       OUTPUT_VALUES(:,:) = MATMUL(INTERNAL_VALUES(:,:), OUTPUT_PARAMS(:,:))
       ! Adjust magnitude of vectors to make dimension values unit variance.
       DO D = 1, MDO
          ! Make this component of the output have unit variance.
          MEAN = SUM(OUTPUT_VALUES(:,D) / N)
          STDEV = SQRT(MAX(EPSILON(STDEV), SUM((OUTPUT_VALUES(:,D) - MEAN)**2 / N)))
          OUTPUT_PARAMS(:,D) = OUTPUTS(:,D) / STDEV
          OUTPUT_VALUES(:,D) = OUTPUT_VALUES(:,D) / STDEV
          ! If outputs are provided.
          IF (PRESENT(OUTPUTS)) THEN
             ! Compute the variance of the output, make results match that.
             MEAN = SUM(OUTPUTS(:,D) / N)
             STDEV = SQRT(MAX(EPSILON(STDEV), SUM((OUTPUTS(:,D) - MEAN)**2 / N)))
             OUTPUT_PARAMS(:,D) = OUTPUT_PARAMS(:,D) * STDEV
             OUTPUT_VALUES(:,D) = OUTPUT_VALUES(:,D) * STDEV
             ! Set the bias value to make the output mean match.
             OUTPUT_BIAS(D) = MEAN - SUM(OUTPUT_VALUES(:,D) / N, DIM=1)
          ELSE
             ! Make this component of output have zero mean.
             OUTPUT_BIAS(D) = SUM(OUTPUT_VALUES(:,D) / N)
          END IF
       END DO
       ! Deallocate memory for temporary arrays.
       DEALLOCATE( INTERNAL_VALUES, OUTPUT_VALUES, VALUES )
    ELSE
       ! Set input biases so that the surface produced by the rectified linear
       !  functions produce well spaced simplices (not too many near origin).
       INPUT_BIAS(:) = 2.0_REAL64 * INPUT_BIAS(:) ** S
       ! Internal biases will depend on vector direction, they will
       !  need to be in this range, but this will disable many.
       INTERNAL_BIAS(:,:) = 2.0_REAL64 * (INTERNAL_BIAS(:,:) * 2.0_REAL64 - 1.0_REAL64)
    END IF

  CONTAINS

    ! Generate randomly distributed vectors on the N-sphere.
    SUBROUTINE RANDOM_UNIT_VECTORS(COLUMN_VECTORS)
      REAL(KIND=REAL64), INTENT(OUT), DIMENSION(:,:) :: COLUMN_VECTORS
      INTEGER :: I
      ! Generate random numbers in the range [0,1].
      CALL RANDOM_NUMBER(COLUMN_VECTORS(:,:))
      ! Map those random numbers to the range [-1,1].
      COLUMN_VECTORS(:,:) = 2.0_REAL64 * COLUMN_VECTORS(:,:) - 1.0_REAL64
      ! Compute the inverse hyperbolic tangent of all values.
      COLUMN_VECTORS(:,:) = ATANH(COLUMN_VECTORS(:,:))
      ! Normalize all vectors to have unit length.
      DO I = 1, SIZE(COLUMN_VECTORS,2)
         COLUMN_VECTORS(:,I) = COLUMN_VECTORS(:,I) / NORM2(COLUMN_VECTORS(:,I))
      END DO
    END SUBROUTINE RANDOM_UNIT_VECTORS

    ! Swap subroutine for exchanging pairs of values.
    SUBROUTINE SWAP_R64(V1, V2)
      REAL(KIND=REAL64), INTENT(INOUT) :: V1, V2
      ! Local temp
      REAL(KIND=REAL64) :: TEMP
      TEMP = V1
      V1 = V2
      V2 = TEMP
    END SUBROUTINE SWAP_R64

    ! ------------------------------------------------------------------
    !                       FastSelect method
    !
    ! Given VALUES list of numbers, rearrange the elements of VALUES
    ! such that the element at index K has rank K (holds its same
    ! location as if all of VALUES were sorted).
    !
    ! This algorithm uses the same conceptual approach as Floyd-Rivest,
    ! but instead of standard-deviation based selection of bounds for
    ! recursion, a rank-based method is used to pick the subset of
    ! values that is searched. This simplifies the code and improves
    ! interpretability, while achieving the same tunable performance.
    !
    ! Arguments:
    !
    !   VALUES   --  A 1D array of real numbers.
    !   K        --  A positive integer for the rank index about which
    !                VALUES should be rearranged.
    ! Optional:
    !
    !   DIVISOR  --  A positive integer >= 2 that represents the
    !                division factor used for large VALUES arrays.
    !   MAX_SIZE --  An integer >= DIVISOR that represents the largest
    !                sized VALUES for which the worst-case pivot value
    !                selection is tolerable. A worst-case pivot causes
    !                O( SIZE(VALUES)^2 ) runtime. This value should be
    !                determined heuristically based on compute hardware.
    !
    ! Output:
    !
    !   The elements of the array VALUES are rearranged such that the
    !   element at position VALUES(K) is in the same location it would
    !   be if all of VALUES were in sorted order. Also known as,
    !   VALUES(K) has rank K.
    !
    RECURSIVE SUBROUTINE SELECT_R64(VALUES, K, DIVISOR, MAX_SIZE)
      ! Arguments
      REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:) :: VALUES
      INTEGER,           INTENT(IN)                  :: K
      INTEGER,           INTENT(IN),    OPTIONAL     :: DIVISOR, MAX_SIZE
      ! Locals
      INTEGER :: LEFT, RIGHT, L, R, MS, D
      REAL(KIND=REAL64) :: P
      ! Initialize the divisor (for making subsets).
      IF (PRESENT(DIVISOR)) THEN ; D = DIVISOR
      ELSE IF (SIZE(VALUES) .GE. 2**23) THEN ; D = 2**5
      ELSE IF (SIZE(VALUES) .GE. 2**20) THEN ; D = 2**3
      ELSE                                   ; D = 2**2
      END IF
      ! Initialize the max size (before subsets are created).
      IF (PRESENT(MAX_SIZE)) THEN ; MS = MAX_SIZE
      ELSE                        ; MS = 2**10
      END IF
      ! Initialize LEFT and RIGHT to be the entire array.
      LEFT = 1
      RIGHT = SIZE(VALUES)
      ! Loop until done finding the K-th element.
      DO WHILE (LEFT .LT. RIGHT)
         ! Use SELECT recursively to improve the quality of the
         ! selected pivot value for large arrays.
         IF (RIGHT - LEFT .GT. MS) THEN
            ! Compute how many elements should be left and right of K
            ! to maintain the same percentile in a subset.
            L = K - K / D
            R = L + (SIZE(VALUES) / D)
            ! Perform fast select on an array a fraction of the size about K.
            CALL SELECT_R64(VALUES(L:R), K - L + 1, DIVISOR, MAX_SIZE)
         END IF
         ! Pick a partition element at position K.
         P = VALUES(K)
         L = LEFT
         R = RIGHT
         ! Move the partition element to the front of the list.
         CALL SWAP_R64(VALUES(LEFT), VALUES(K))
         ! Pre-swap the left and right elements (temporarily putting a
         ! larger element on the left) before starting the partition loop.
         IF (VALUES(RIGHT) .GT. P) THEN
            CALL SWAP_R64(VALUES(LEFT), VALUES(RIGHT))
         END IF
         ! Now partition the elements about the pivot value "P".
         DO WHILE (L .LT. R)
            CALL SWAP_R64(VALUES(L), VALUES(R))
            L = L + 1
            R = R - 1
            DO WHILE (VALUES(L) .LT. P) ; L = L + 1 ; END DO
            DO WHILE (VALUES(R) .GT. P) ; R = R - 1 ; END DO
         END DO
         ! Place the pivot element back into its appropriate place.
         IF (VALUES(LEFT) .EQ. P) THEN
            CALL SWAP_R64(VALUES(LEFT), VALUES(R))
         ELSE
            R = R + 1
            CALL SWAP_R64(VALUES(R), VALUES(RIGHT))
         END IF
         ! adjust left and right towards the boundaries of the subset
         ! containing the (k - left + 1)th smallest element
         IF (R .LE. K) LEFT = R + 1
         IF (K .LE. R) RIGHT = R - 1
      END DO
    END SUBROUTINE SELECT_R64
    ! ------------------------------------------------------------------

  END SUBROUTINE INIT_MODEL

  ! Swap the parameters of nodes at indices N1 and N2 in internal layer L.
  SUBROUTINE SWAP_PARAMS(L, N1, N2)
    INTEGER, INTENT(IN) :: L, N1, N2
    INTEGER :: I
    REAL(KIND=REAL64) :: TEMP_VAL
    ! Swap the input parameters.
    IF (L .EQ. 1) THEN
       DO I = 1, MDI
          TEMP_VAL = INPUT_PARAMS(I,N1)
          INPUT_PARAMS(I,N1) = INPUT_PARAMS(I,N2)
          INPUT_PARAMS(I,N2) = TEMP_VAL
       END DO
       INPUT_BIAS(N1) = INPUT_BIAS(N2)
       INPUT_BIAS(N2) = TEMP_VAL
    ELSE
       DO I = 1, MDS
          TEMP_VAL = INTERNAL_PARAMS(I,N1,L-1)
          INTERNAL_PARAMS(I,N1,L-1) = INTERNAL_PARAMS(I,N2,L-1)
          INTERNAL_PARAMS(I,N2,L-1) = TEMP_VAL
       END DO
       TEMP_VAL = INTERNAL_BIAS(N1,L-1)
       INTERNAL_BIAS(N1,L-1) = INTERNAL_BIAS(N2,L-1)
       INTERNAL_BIAS(N2,L-1) = TEMP_VAL
    END IF
    ! Swap the output parameters.
    IF (L .EQ. MNS-1) THEN
       DO I = 1, MDO
          TEMP_VAL = OUTPUT_PARAMS(N1,I)
          OUTPUT_PARAMS(N1,I) = OUTPUT_PARAMS(N2,I)
          OUTPUT_PARAMS(N2,I) = TEMP_VAL
       END DO
    ELSE
       DO I = 1, MDS
          TEMP_VAL = INTERNAL_PARAMS(N1,I,L)
          INTERNAL_PARAMS(N1,I,L) = INTERNAL_PARAMS(N2,I,L)
          INTERNAL_PARAMS(N2,I,L) = TEMP_VAL
       END DO
    END IF
  END SUBROUTINE SWAP_PARAMS

  ! Randomly disable N internal nodes at each internal layer by
  ! "swapping" their parameters to the back of the layer.
  SUBROUTINE DROP_INTERNAL_NODES(N)
    INTEGER, INTENT(IN) :: N
    INTEGER :: L, I, D, M
    REAL :: R
    ! Cycle over all internal layers.
    LAYERS : DO L = 1, MNS-1
       ! Compute the number of nodes that can be sampled from.
       M = MDS - N
       ! Cycle over all nodes that need to be dropped.
       DROPPED_NODES : DO I = MDS, MDS-N+1
          ! Pick a random node to drop.
          CALL RANDOM_NUMBER(R)
          D = 1 + INT(R * M)
          ! Swap the node that will be dropped to the end of the
          !  "droppable" nodes range.
          IF (D .NE. M) CALL SWAP_PARAMS(L, D, M)
          ! Swap the dropped node into the "dropped" range (end of layer).
          IF (M .NE. I) CALL SWAP_PARAMS(L, M, I)
          ! Exit if there are no more new nodes to swap in.
          IF (M .EQ. 1) EXIT DROPPED_NODES
          ! Reduce the number of droppable nodes
          M = M - 1
       END DO DROPPED_NODES
    END DO LAYERS
  END SUBROUTINE DROP_INTERNAL_NODES

  ! Evaluate the piecewise linear regression model, do not store any
  !  of the intermediate states (used
  SUBROUTINE EVALUATE_ONE(INPUT, OUTPUT)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:) :: INPUT
    ! Record of values after the last transformation.
    REAL(KIND=REAL64), INTENT(OUT), DIMENSION(:) :: OUTPUT
    ! Internal values.
    REAL(KIND=REAL64), DIMENSION(MDS) :: INTERNAL_VALUES
    ! Compute the number of nodes (to know where "bias" value is).
    INTEGER :: I, IP1
    ! Compute the input layer.
    INTERNAL_VALUES(:) = INPUT_BIAS(:) + MATMUL(INPUT(:), INPUT_PARAMS(:,:))
    WHERE (INTERNAL_VALUES(:) .LT. DISCONTINUITY)
       INTERNAL_VALUES(:) = INTERNAL_VALUES(:) * SMALL_SLOPE
    END WHERE
    ! Compute the next set of internal values with a rectified activation.
    DO I = 1, MNS-1
       IP1 = I+1
       INTERNAL_VALUES(:) = INTERNAL_BIAS(:,I) + &
            MATMUL(INTERNAL_VALUES(:), INTERNAL_PARAMS(:,:,I))
       WHERE (INTERNAL_VALUES(:) .LT. DISCONTINUITY)
          INTERNAL_VALUES(:) = INTERNAL_VALUES(:) * SMALL_SLOPE
       END WHERE
    END DO
    ! Compute the output.
    OUTPUT(:) = OUTPUT_BIAS(:) + &
         MATMUL(INTERNAL_VALUES(:), OUTPUT_PARAMS(:,:))
  END SUBROUTINE EVALUATE_ONE

  ! Evaluate the piecewise linear regression model, do not store any
  !  of the intermediate states (used
  SUBROUTINE EVALUATE(INPUTS, OUTPUTS)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: INPUTS
    REAL(KIND=REAL64), INTENT(OUT), DIMENSION(:,:) :: OUTPUTS
    ! Internal values.
    REAL(KIND=REAL64), DIMENSION(SIZE(INPUTS,2),MDS) :: INTERNAL_VALUES
    ! Compute the number of nodes (to know where "bias" value is).
    INTEGER :: D, L
    ! Compute the input transformation.
    CALL DGEMM('T', 'N', SIZE(INPUTS,2), MDS, MDI, 1.0_REAL64, &
         INPUTS(:,:), SIZE(INPUTS,1), &
         INPUT_PARAMS(:,:), SIZE(INPUT_PARAMS,1), &
         0.0_REAL64, INTERNAL_VALUES(:,:), SIZE(INTERNAL_VALUES,1))
    DO D = 1, MDS
       INTERNAL_VALUES(:,D) = INPUT_BIAS(D) + INTERNAL_VALUES(:,D)
    END DO
    WHERE (INTERNAL_VALUES(:,:) .LT. DISCONTINUITY)
       INTERNAL_VALUES(:,:) = INTERNAL_VALUES(:,:) * SMALL_SLOPE
    END WHERE
    ! Compute the next set of internal values with a rectified activation.
    DO L = 1, MNS-1
       CALL DGEMM('N', 'N', SIZE(INPUTS,2), MDS, MDS, 1.0_REAL64, &
            INTERNAL_VALUES(:,:), SIZE(INTERNAL_VALUES,1), &
            INTERNAL_PARAMS(:,:,L), SIZE(INTERNAL_PARAMS,1), &
            0.0_REAL64, INTERNAL_VALUES(:,:), SIZE(INTERNAL_VALUES,1))
       DO D = 1, MDS
          INTERNAL_VALUES(:,D) =  INTERNAL_BIAS(D,L) + INTERNAL_VALUES(:,D)
       END DO
       WHERE (INTERNAL_VALUES(:,:) .LT. DISCONTINUITY)
          INTERNAL_VALUES(:,:) = INTERNAL_VALUES(:,:) * SMALL_SLOPE
       END WHERE
    END DO
    ! Compute the output.
    CALL DGEMM('T', 'T', MDO, SIZE(INPUTS,2), MDS, 1.0_REAL64, &
         OUTPUT_PARAMS(:,:), SIZE(OUTPUT_PARAMS,1), &
         INTERNAL_VALUES(:,:), SIZE(INTERNAL_VALUES,1), &
         0.0_REAL64, OUTPUTS(:,:), SIZE(OUTPUTS,1))
    DO D = 1, MDO
       OUTPUTS(:,D) = OUTPUT_BIAS(D) + OUTPUTS(:,D)
    END DO
  END SUBROUTINE EVALUATE

  ! Compute the gradient of the sum of squared error of this regression
  ! model with respect to its parameters given input and output pairs.
  SUBROUTINE SSE_GRADIENT(INPUTS, OUTPUTS, SUM_SQUARED_ERROR, &
       INPUT_PARAMS_GRADIENT, INPUT_BIAS_GRADIENT, &
       INTERNAL_PARAMS_GRADIENT, INTERNAL_BIAS_GRADIENT, &
       OUTPUT_PARAMS_GRADIENT, OUTPUT_BIAS_GRADIENT)
    ! Data values stored with contiguous points: shape = (MDI,N)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: INPUTS
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: OUTPUTS
    ! Sum (over all data) squared error (summed over dimensions).
    REAL(KIND=REAL64), INTENT(INOUT) :: SUM_SQUARED_ERROR
    ! Model parameter gradients.
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:,:)   :: INPUT_PARAMS_GRADIENT
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:)     :: INPUT_BIAS_GRADIENT
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:,:,:) :: INTERNAL_PARAMS_GRADIENT
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:,:)   :: INTERNAL_BIAS_GRADIENT
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:,:)   :: OUTPUT_PARAMS_GRADIENT
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:)     :: OUTPUT_BIAS_GRADIENT
    ! Internal values and lists of which ones are nonzero.
    REAL(KIND=REAL64), DIMENSION(SIZE(INPUTS,2),MDO)     :: OUTPUT_GRADIENT
    REAL(KIND=REAL64), DIMENSION(SIZE(INPUTS,2),MDS,MNS) :: INTERNAL_VALUES
    LOGICAL, DIMENSION(SIZE(INPUTS,2),MDS) :: UNDER_SPLITS
    ! Number of points.
    REAL(KIND=REAL64) :: N
    INTEGER :: D
    ! Evaluate the model at all data points, store outputs in "OUTPUT_GRADIENT"
    CALL EVALUATE_BATCH()
    ! Compute the new gradient.
    DO D = 1, MDO
       OUTPUT_GRADIENT(:,D) = OUTPUT_GRADIENT(:,D) - OUTPUTS(D,:)
    END DO
    ! Get the number of points.
    N = REAL(SIZE(INPUTS,2), REAL64)
    ! Compute the current sum squared error.
    SUM_SQUARED_ERROR = SUM_SQUARED_ERROR + SUM(OUTPUT_GRADIENT(:,:)**2)
    ! Compute the gradient of parameters with respect to the output gradient.
    CALL GRADIENT_BATCH()

  CONTAINS

    ! Evaluate the piecewise linear regression model.
    SUBROUTINE EVALUATE_BATCH()
      ! D   - dimension index
      ! L   - layer index
      ! LP1 - layer index "plus 1" -> "P1"
      INTEGER :: D, L, LP1
      EXTERNAL :: DGEMM
      ! Compute the input transformation.
      CALL DGEMM('T', 'N', SIZE(INPUTS,2), MDS, MDI, 1.0_REAL64, &
           INPUTS(:,:), SIZE(INPUTS,1), &
           INPUT_PARAMS(:,:), SIZE(INPUT_PARAMS,1), &
           0.0_REAL64, INTERNAL_VALUES(:,:,1), SIZE(INTERNAL_VALUES,1))
      DO D = 1, MDS
         INTERNAL_VALUES(:,D,1) = INPUT_BIAS(D) + INTERNAL_VALUES(:,D,1)
      END DO
      WHERE (INTERNAL_VALUES(:,:,1) .LT. DISCONTINUITY)
         INTERNAL_VALUES(:,:,1) = INTERNAL_VALUES(:,:,1) * SMALL_SLOPE
      END WHERE
      ! Compute the next set of internal values with a rectified activation.
      DO L = 1, MNS-1
         LP1 = L+1
         CALL DGEMM('N', 'N', SIZE(INPUTS,2), MDS, MDS, 1.0_REAL64, &
              INTERNAL_VALUES(:,:,L), SIZE(INTERNAL_VALUES,1), &
              INTERNAL_PARAMS(:,:,L), SIZE(INTERNAL_PARAMS,1), &
              0.0_REAL64, INTERNAL_VALUES(:,:,LP1), SIZE(INTERNAL_VALUES,1))
         DO D = 1, MDS
            INTERNAL_VALUES(:,D,LP1) =  INTERNAL_BIAS(D,L) + INTERNAL_VALUES(:,D,LP1)
         END DO
         WHERE (INTERNAL_VALUES(:,:,LP1) .LT. DISCONTINUITY)
            INTERNAL_VALUES(:,:,LP1) = INTERNAL_VALUES(:,:,LP1) * SMALL_SLOPE
         END WHERE
      END DO
      ! Compute the output.
      CALL DGEMM('N', 'N', SIZE(INPUTS,2), MDO, MDS, 1.0_REAL64, &
           INTERNAL_VALUES(:,:,L), SIZE(INTERNAL_VALUES,1), &
           OUTPUT_PARAMS(:,:), SIZE(OUTPUT_PARAMS,1), &
           0.0_REAL64, OUTPUT_GRADIENT(:,:), SIZE(OUTPUT_GRADIENT,1))
      DO D = 1, MDO
         OUTPUT_GRADIENT(:,D) = OUTPUT_BIAS(D) + OUTPUT_GRADIENT(:,D)
      END DO
    END SUBROUTINE EVALUATE_BATCH

    SUBROUTINE GRADIENT_BATCH()
      ! L   - layer index
      ! LP1 - layer index "plus 1" -> "P1"
      INTEGER :: L, LP1
      EXTERNAL :: DGEMM
      ! Compute the average output gradient.
      OUTPUT_BIAS_GRADIENT(:) = SUM(OUTPUT_GRADIENT(:,:), 1) / N &
           + OUTPUT_BIAS_GRADIENT(:)
      ! Compute output parameter gradients.
      CALL DGEMM('T', 'N', MDS, MDO, SIZE(INPUTS,2), 1.0_REAL64 / N, &
           INTERNAL_VALUES(:,:,MNS), SIZE(INTERNAL_VALUES,1), &
           OUTPUT_GRADIENT(:,:), SIZE(OUTPUT_GRADIENT,1), &
           1.0_REAL64, OUTPUT_PARAMS_GRADIENT(:,:), SIZE(OUTPUT_PARAMS_GRADIENT,1))
      ! Compute the gradient for the last internal vector space values.
      UNDER_SPLITS(:,:) = INTERNAL_VALUES(:,:,MNS) .LT. DISCONTINUITY
      CALL DGEMM('N', 'T', SIZE(INPUTS,2), MDS, MDO, 1.0_REAL64, &
           OUTPUT_GRADIENT(:,:), SIZE(OUTPUT_GRADIENT,1), &
           OUTPUT_PARAMS(:,:), SIZE(OUTPUT_PARAMS,1), &
           0.0_REAL64, INTERNAL_VALUES(:,:,MNS), SIZE(INTERNAL_VALUES,1))
      WHERE (UNDER_SPLITS(:,:))
         INTERNAL_VALUES(:,:,MNS) = INTERNAL_VALUES(:,:,MNS) * SMALL_SLOPE
      END WHERE
      ! Cycle over all internal layers.
      INTERNAL_REPRESENTATIONS : DO L = MNS-1, 1, -1
         LP1 = L+1
         ! Compute the bias gradient.
         INTERNAL_BIAS_GRADIENT(:,L) = SUM(INTERNAL_VALUES(:,:,LP1), 1) / N &
              + INTERNAL_BIAS_GRADIENT(:,L)
         ! Compute the gradient with respect to each output and all inputs.
         CALL DGEMM('T', 'N', MDS, MDS, SIZE(INPUTS,2), 1.0_REAL64 / N, &
              INTERNAL_VALUES(:,:,L), SIZE(INTERNAL_VALUES,1), &
              INTERNAL_VALUES(:,:,LP1), SIZE(INTERNAL_VALUES,1), &
              1.0_REAL64, INTERNAL_PARAMS_GRADIENT(:,:,L), SIZE(INTERNAL_PARAMS_GRADIENT,1))
         ! Propogate the gradient to the immediately preceding layer.
         UNDER_SPLITS(:,:) = INTERNAL_VALUES(:,:,L) .LT. DISCONTINUITY
         CALL DGEMM('N', 'T', SIZE(INPUTS,2), MDS, MDS, 1.0_REAL64, &
              INTERNAL_VALUES(:,:,LP1), SIZE(INTERNAL_VALUES,1), &
              INTERNAL_PARAMS(:,:,L), SIZE(INTERNAL_PARAMS,1), &
              0.0_REAL64, INTERNAL_VALUES(:,:,L), SIZE(INTERNAL_VALUES,1))
         WHERE (UNDER_SPLITS(:,:))
            INTERNAL_VALUES(:,:,L) = INTERNAL_VALUES(:,:,L) * SMALL_SLOPE
         END WHERE
      END DO INTERNAL_REPRESENTATIONS
      ! Compute the input parameter bias values.
      INPUT_BIAS_GRADIENT(:) = SUM(INTERNAL_VALUES(:,:,1), 1) / N &
           + INPUT_BIAS_GRADIENT(:)
      ! Compute the gradient of all input parameters.
      !   [the INPUTS are transposed already, shape = (MDI,N)]
      CALL DGEMM('N', 'N', MDI, MDS, SIZE(INPUTS,2), 1.0_REAL64 / N, &
           INPUTS(:,:), SIZE(INPUTS,1), &
           INTERNAL_VALUES(:,:,1), SIZE(INTERNAL_VALUES,1), &
           1.0_REAL64, INPUT_PARAMS_GRADIENT(:,:), SIZE(INPUT_PARAMS_GRADIENT,1))
    END SUBROUTINE GRADIENT_BATCH

  END SUBROUTINE SSE_GRADIENT

  ! Fit input / output pairs by minimizing mean squared error.
  SUBROUTINE MINIMIZE_MSE(X, Y, STEPS, BATCH_SIZE, NUM_THREADS, &
       DROPOUT, MEAN_SQUARED_ERROR)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: X
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: Y
    INTEGER,           INTENT(IN), OPTIONAL :: STEPS, BATCH_SIZE, NUM_THREADS
    REAL,              INTENT(IN), OPTIONAL :: DROPOUT
    REAL(KIND=REAL64), INTENT(OUT) :: MEAN_SQUARED_ERROR
    !  gradient step arrays, 4 copies of internal model (total of 5).
    REAL(KIND=REAL64), DIMENSION(MDI,MDS)       :: P1_GRAD, P1_MEAN, P1_SQ_MEAN, BEST_P1
    REAL(KIND=REAL64), DIMENSION(MDS)           :: B1_GRAD, B1_MEAN, B1_SQ_MEAN, BEST_B1
    REAL(KIND=REAL64), DIMENSION(MDS,MDS,MNS-1) :: P2_GRAD, P2_MEAN, P2_SQ_MEAN, BEST_P2
    REAL(KIND=REAL64), DIMENSION(MDS,MNS-1)     :: B2_GRAD, B2_MEAN, B2_SQ_MEAN, BEST_B2
    REAL(KIND=REAL64), DIMENSION(MDS,MDO)       :: P3_GRAD, P3_MEAN, P3_SQ_MEAN, BEST_P3
    REAL(KIND=REAL64), DIMENSION(MDO)           :: B3_GRAD, B3_MEAN, B3_SQ_MEAN, BEST_B3
    !  local integers
    INTEGER :: BS, I, L, NX, NT, S, BATCH_START, BATCH_END, TO_DROP, STEPS_WITH_DROPOUT
    REAL(KIND=REAL64) :: RNX, BATCHES, STEP_FACTOR, PREV_MSE, BEST_MSE, SCALAR
    ! Function that is defined by OpenMP.
    INTERFACE
       FUNCTION OMP_GET_MAX_THREADS()
         INTEGER :: OMP_GET_MAX_THREADS
       END FUNCTION OMP_GET_MAX_THREADS
    END INTERFACE
    ! Initial step factor (for computing parameter updates).
    STEP_FACTOR = 0.001
    PREV_MSE = HUGE(PREV_MSE)
    BEST_MSE = HUGE(BEST_MSE)
    ! Number of points.
    NX = SIZE(X,2)
    RNX = REAL(NX, REAL64)
    ! Set the number of steps.
    IF (PRESENT(STEPS)) THEN
       S = STEPS
    ELSE
       S = 100
    END IF
    ! Set the number of threads.
    IF (PRESENT(NUM_THREADS)) THEN
       NT = NUM_THREADS
    ELSE
       NT = OMP_GET_MAX_THREADS()
    END IF
    ! Set the batch size.
    IF (PRESENT(BATCH_SIZE)) THEN
       BS = MIN(BATCH_SIZE, NX)
    ELSE
       BS = (NX + NT - 1) / NT
    END IF
    ! Set the dropout rate and number of training steps with dropout.
    IF (PRESENT(DROPOUT)) THEN
       IF ((DROPOUT .GT. 0.0) .AND. (MDS .GT. 1) .AND. (S .GT. 1)) THEN
          TO_DROP = MAX(1,INT(DROPOUT * REAL(MDS)))
          STEPS_WITH_DROPOUT = MAX(1, 1 + S/2)
          MDS = MDS - TO_DROP
       ELSE
          TO_DROP = 0
          STEPS_WITH_DROPOUT = 0
       END IF
    ELSE
       TO_DROP = 0
       STEPS_WITH_DROPOUT = 0
    END IF
    ! Set the average step sizes.
    P1_MEAN(:,:)   = 0.0_REAL64
    B1_MEAN(:)     = 0.0_REAL64
    P2_MEAN(:,:,:) = 0.0_REAL64
    B2_MEAN(:,:)   = 0.0_REAL64
    P3_MEAN(:,:)   = 0.0_REAL64
    B3_MEAN(:)     = 0.0_REAL64
    ! Set the average step size magnitudes.
    P1_SQ_MEAN(:,:)   = 0.0_REAL64
    B1_SQ_MEAN(:)     = 0.0_REAL64
    P2_SQ_MEAN(:,:,:) = 0.0_REAL64
    B2_SQ_MEAN(:,:)   = 0.0_REAL64
    P3_SQ_MEAN(:,:)   = 0.0_REAL64
    B3_SQ_MEAN(:)     = 0.0_REAL64
    ! Iterate, taking steps with the average gradient over all data.
    fit_loop : DO I = 1, S
       ! Do dropout if that is requested (by swapping nodes to back of layer).
       IF (I .LT. STEPS_WITH_DROPOUT) THEN
          CALL DROP_INTERNAL_NODES(TO_DROP)
       ELSE IF (I .EQ. STEPS_WITH_DROPOUT) THEN
          MDS = SIZE(INTERNAL_PARAMS,1)
       END IF
       ! Compute the average gradient over all points.
       MEAN_SQUARED_ERROR = 0.0_REAL64
       ! Set gradients to zero initially.
       P1_GRAD(:,:)   = 0.0_REAL64
       B1_GRAD(:)     = 0.0_REAL64
       P2_GRAD(:,:,:) = 0.0_REAL64
       B2_GRAD(:,:)   = 0.0_REAL64
       P3_GRAD(:,:)   = 0.0_REAL64
       B3_GRAD(:)     = 0.0_REAL64
       ! Count the number of batches.
       BATCHES = 0.0_REAL64
       !$OMP PARALLEL DO NUM_THREADS(NT) PRIVATE(BATCH_END) &
       !$OMP&  REDUCTION(+: BATCHES, MEAN_SQUARED_ERROR, &
       !$OMP&  P1_GRAD, B1_GRAD, P2_GRAD, B2_GRAD, P3_GRAD, B3_GRAD)
       DO BATCH_START = 1, NX, BS
          BATCHES = BATCHES + 1.0_REAL64
          BATCH_END = MIN(NX, BATCH_START+BS-1)
          ! Compute the gradient from all data.
          CALL SSE_GRADIENT(X(:,BATCH_START:BATCH_END), &
               Y(:,BATCH_START:BATCH_END), MEAN_SQUARED_ERROR, &
               P1_GRAD, B1_GRAD, P2_GRAD, B2_GRAD, P3_GRAD, B3_GRAD)
       END DO
       !$OMP END PARALLEL DO
       ! Convert the sum of squared errors into the mean squared error.
       MEAN_SQUARED_ERROR = MEAN_SQUARED_ERROR / RNX
       ! Update the saved "best" model based on error (only when dropout is disabled).
       IF ((I .GE. STEPS_WITH_DROPOUT) .AND. &
            (MEAN_SQUARED_ERROR .LT. BEST_MSE)) THEN
          BEST_MSE = MEAN_SQUARED_ERROR
          BEST_P1 = INPUT_PARAMS
          BEST_B1 = INPUT_BIAS
          BEST_P2 = INTERNAL_PARAMS
          BEST_B2 = INTERNAL_BIAS
          BEST_P3 = OUTPUT_PARAMS
          BEST_B3 = OUTPUT_BIAS
       END IF
       ! Update the step factor based on model improvement.
       IF (MEAN_SQUARED_ERROR .LT. PREV_MSE) THEN
          STEP_FACTOR = STEP_FACTOR * 1.01_REAL64
       ELSE
          STEP_FACTOR = STEP_FACTOR / 1.01_REAL64
       END IF
       PREV_MSE = MEAN_SQUARED_ERROR
       ! Convert the average gradients.
       P1_GRAD = P1_GRAD / BATCHES
       B1_GRAD = B1_GRAD / BATCHES
       P2_GRAD = P2_GRAD / BATCHES
       B2_GRAD = B2_GRAD / BATCHES
       P3_GRAD = P3_GRAD / BATCHES
       B3_GRAD = B3_GRAD / BATCHES
       ! Update the steps for all different parameters.
       CALL COMPUTE_STEP(SIZE(P1_GRAD), P1_GRAD, P1_MEAN, P1_SQ_MEAN)
       CALL COMPUTE_STEP(SIZE(B1_GRAD), B1_GRAD, B1_MEAN, B1_SQ_MEAN)
       CALL COMPUTE_STEP(SIZE(P2_GRAD), P2_GRAD, P2_MEAN, P2_SQ_MEAN)
       CALL COMPUTE_STEP(SIZE(B2_GRAD), B2_GRAD, B2_MEAN, B2_SQ_MEAN)
       CALL COMPUTE_STEP(SIZE(P3_GRAD), P3_GRAD, P3_MEAN, P3_SQ_MEAN)
       CALL COMPUTE_STEP(SIZE(B3_GRAD), B3_GRAD, B3_MEAN, B3_SQ_MEAN)
       ! Shrink the gradient to take smaller steps, and take
       !  the gradient step based on the average gradient.
       INPUT_PARAMS    = INPUT_PARAMS    - P1_GRAD
       INPUT_BIAS      = INPUT_BIAS      - B1_GRAD
       INTERNAL_PARAMS = INTERNAL_PARAMS - P2_GRAD
       INTERNAL_BIAS   = INTERNAL_BIAS   - B2_GRAD
       OUTPUT_PARAMS   = OUTPUT_PARAMS   - P3_GRAD
       OUTPUT_BIAS     = OUTPUT_BIAS     - B3_GRAD
       ! Enforce maxnorm of internal parameters.
       DO L = 1, MNS-1
          SCALAR = MAXVAL(INTERNAL_PARAMS(:,:,L))
          IF (SCALAR .GT. MDS) THEN
             SCALAR = REAL(MDS,REAL64) / SCALAR
             INTERNAL_PARAMS(:,:,L) = INTERNAL_PARAMS(:,:,L) * SCALAR
          END IF
       END DO
    END DO fit_loop
    ! Restore the best model seen so far (if a reasonable number of steps were taken).
    IF (S .GT. 10) THEN
       MEAN_SQUARED_ERROR = BEST_MSE
       INPUT_PARAMS = BEST_P1
       INPUT_BIAS = BEST_B1
       INTERNAL_PARAMS = BEST_P2
       INTERNAL_BIAS = BEST_B2
       OUTPUT_PARAMS = BEST_P3
       OUTPUT_BIAS = BEST_B3
    END IF
  CONTAINS

    ! Compute the current step factor as the running average step,
    ! inversely scaled by the average magnitude of the step.
    SUBROUTINE COMPUTE_STEP(N, CURR_STEP, STEP_MEAN, STEP_SQ_MEAN)
      INTEGER, INTENT(IN) :: N
      REAL(KIND=REAL64), DIMENSION(1:N), INTENT(INOUT) :: CURR_STEP
      REAL(KIND=REAL64), DIMENSION(1:N), INTENT(INOUT) :: STEP_MEAN
      REAL(KIND=REAL64), DIMENSION(1:N), INTENT(INOUT) :: STEP_SQ_MEAN
      STEP_MEAN = 0.1 * CURR_STEP + 0.9 * STEP_MEAN
      STEP_SQ_MEAN = 0.01 * CURR_STEP**2 + 0.99 * STEP_SQ_MEAN
      WHERE (STEP_SQ_MEAN .EQ. 0.0)
         STEP_SQ_MEAN = EPSILON(STEP_SQ_MEAN(1))
      END WHERE
      ! Start scaling by step magnitude once enough data is collected.
      IF (I .GT. 10) THEN
         CURR_STEP = STEP_FACTOR * STEP_MEAN / SQRT(STEP_SQ_MEAN)
      ! Otherwise, use a scaled-down gradient descent step.
      ELSE
         CURR_STEP = 0.01 * STEP_MEAN
      END IF
    END SUBROUTINE COMPUTE_STEP

  END SUBROUTINE MINIMIZE_MSE

END MODULE PLRM


      subroutine tdmp(x,y,n,a,b,c,d,kode)
C...subroutine     tdmp      01/09/73
C...subroutine     tdmp      01/09/78
      dimension x(n),y(n),a(n),b(n),c(n),d(n)
      if (n.le.2) go to 7
      dy2=y(2)-y(1)
      c(2)=x(2)-x(1)
      if (c(2).le.0.) goto 7
      dy=dy2
      do 1 i=3,n
      dy1=dy2
      dy2=y(i)-y(i-1)
      c(i)=x(i)-x(i-1)
      if (c(i).le.0.) goto  7
      a(i-1)=c(i)
      a2=a(i-1)
      c2=c(i-1)
      b(i-1)=2.*(c2+a2)
   1  d(i-1)=3.*(a2*dy1/c2+c2*dy2/a2)
      a(1)=0.
      c(n)=0.
      if(kode+1) 5,3,2
   2  if (kode-1) 4,6,7
    3 b(1)=1.
      b(n)=1.
      c(1)=0.
      a(n)=0.
      return
   4  d(1)=0.
      d(n)=0.
   5  b(1)=2.
      b(n)=2.
      c(1)=1.
      a(n)=1.
      d(1)=3.*dy/c(2)-(c(2)*d(1))/2.
      d(n)=3.*dy2/a(n-1)-(a(n-1)*d(n))/2.
      return
   6  a(1)=-1.
      c(1)=0.
      d(1)=0.
      b(1)=1.
      a(n)=c(2)
      c(n)=a(n-1)
      b(n)=2.*(c(2)+a(n-1))
      d(n)=3.*((a(n)/c(n))*dy2+(c(n)/a(n))*dy)
   7  return
      end


c
c
c=========================================================
      subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)
c=========================================================
c
c     # Set initial conditions for q.
c     # Pulse in pressure, zero velocity
c
c
      implicit none

      integer, intent(in) :: meqn, mbc, mx, maux
      double precision, intent(in) :: xlower, dx, aux
      double precision, intent(out) :: q
      dimension q(meqn, 1-mbc:mx+mbc)
      dimension aux(maux, 1-mbc:mx+mbc)

      common /cqinit/ betal, betar, freql, freqr
      double precision betal, betar, freql, freqr

      integer i
      double precision xcell
c
c
      do 150 i=1,mx
         xcell = xlower + (i-0.5d0)*dx

c     # wave packet with left-going and right-going wave packets:
         q(1,i) = dexp(-betar*(xcell-3.0d0)**2) * dsin(freqr*xcell)
     .            + dexp(-betal*(xcell+2.5d0)**2) * dsin(freql*xcell)
         q(2,i) = 0.d0
         go to 150

 150  continue
c
      return
      end


      subroutine eos_cs(rho,cs)
!-----------------------------------------------------------------------
! Reads and interpolates the equation of state tables to give
! temperatures, opacities etc
! Updated to fortran 90 PJC 22/05/2008
! Extended to opacities DHF 01/09/2009
!-----------------------------------------------------------------------

      use eosdata

      implicit none

      integer :: i,j
      real :: mT,mT1,mT2,cT,cT1,cT2,T1,T2
      real :: mmu,mmu1,mmu2,cmu,cmu1,cmu2,mu1,mu2
      real :: mkap,mkap1,mkap2,ckap,ckap1,ckap2,kap1,kap2
      real :: mkbar,mkbar1,mkbar2,ckbar,ckbar1,ckbar2,kbar1,kbar2
      real :: rho, cs

! gammamuT columns:
! 1) gamma
! 2) mu
! 3) T
! 4) Opacity
! 5) Mass Weighted Opacity (Stamatellos et al 2007)
	gammamuT = 0.0

! Find the relevant records in the table...
! ... for rho
         if (rho < 1.0e-24) rho = 1.0e-24
         i = 1
         do
            if ((eostable(i,1,1) >= rho).or.(i == nrhopoints)) exit
            i = i + 1
         enddo

! ... and for internal energy
         if (cs < cstab(1,1)) cs = cstab(1,1)
         j = 1
         do
            if ((cstab(i-1,j) >= cs).or.(j==nUpoints)) exit
            j = j + 1
         enddo

	IF(j==1) j = j+1

! Interpolate over the j value at i-1
         mT1 = (eostable(i-1,j-1,2) - eostable(i-1,j,2))/ &
              (cstab(i-1,j-1) - cstab(i-1,j))
         cT1 = eostable(i-1,j,2) - mT1*cstab(i-1,j)
         T1 = mT1*cs + cT1

         mmu1 = (eostable(i-1,j-1,4) - eostable(i-1,j,4))/ &
              (cstab(i-1,j-1) - cstab(i-1,j))
         cmu1 = eostable(i-1,j,4) - mmu1*cstab(i-1,j)
         mu1 = mmu1*cs + cmu1

	 mkap1 = (eostable(i-1,j-1,6) - eostable(i-1,j,6))/ &
              (cstab(i-1,j-1) - cstab(i-1,j))
	 ckap1 = eostable(i-1,j,6) - mkap1*cstab(i-1,j)
	 kap1 = mkap1*cs + ckap1

	 mkbar1 = (eostable(i-1,j-1,5) - eostable(i-1,j,5))/ &
              (cstab(i-1,j-1) - cstab(i-1,j))
	ckbar1 = eostable(i-1,j,5) - mkbar1*cstab(i-1,j)
	kbar1 = mkbar1*cs + ckbar1

! Then interpolate over the j value at i
! Update j value as necessary
         j = 1
         do
            if ((cstab(i,j) >= cs).or.(j==nUpoints)) exit
            j = j + 1
         enddo

	IF(j==1) j = j+1

         mT2 = (eostable(i,j-1,2) - eostable(i,j,2))/ &
              (cstab(i,j-1) - cstab(i,j))
         cT2 = eostable(i,j,2) - mT2*cstab(i,j)
         T2 = mT2*cs + cT2

         mmu2 = (eostable(i,j-1,4) - eostable(i,j,4))/ &
              (cstab(i,j-1) - cstab(i,j))
         cmu2 = eostable(i,j,4) - mmu2*cstab(i,j)
         mu2 = mmu2*cs + cmu2

         mkap2 = (eostable(i,j-1,6) - eostable(i,j,6))/ &
              (cstab(i,j-1) - cstab(i,j))
         ckap2 = eostable(i,j,6) - mkap2*cstab(i,j)
         kap2 = mkap2*cs + ckap2

	 mkbar2 = (eostable(i,j-1,5) - eostable(i,j,5))/ &
              (cstab(i,j-1) - cstab(i,j))
         ckbar2 = eostable(i,j,5) - mkbar2*cstab(i,j)
         kbar2 = mkbar2*cs + ckbar2

! Finally interpolate over i at the fractional j value
         mT = (T2 - T1) / (eostable(i,1,1)-eostable(i-1,1,1))
         cT = T2 - mT*eostable(i,1,1)
         gammamuT(3) = mT*rho + cT

         mmu = (mu2 - mu1) / (eostable(i,1,1)-eostable(i-1,1,1))
         cmu = mu2 - mmu*eostable(i,1,1)
         gammamuT(2) = mmu*rho + cmu

	mkap = (kap2 - kap1) / (eostable(i,1,1)-eostable(i-1,1,1))
         ckap = kap2 - mkap*eostable(i,1,1)
         gammamuT(4) = mkap*rho + ckap

	mkbar = (kbar2 - kbar1) / (eostable(i,1,1)-eostable(i-1,1,1))
         ckbar = kbar2 - mkbar*eostable(i,1,1)
         gammamuT(5) = mkbar*rho + ckbar

! Evaluate the gamma value from gamma = 1 + k/(mH*mu*cv), with cv = U/T

         gammamuT(1) = cs*cs*gammamuT(2)*mH/(Boltzmannk*gammamuT(3))

      end subroutine eos_cs


  subroutine berry_curvarture
     !> Calculate Berry curvature
     !
     !> ref : Physical Review B 74, 195118(2006)
     !
     !> eqn (34)
     !
     !> Sep. 22 2015 by Quansheng Wu @ ETHZ
     !
     ! Copyright (c) 2010 QuanSheng Wu. All rights reserved.

     use wmpi
     use para
     implicit none

     integer :: iR
     integer :: ik

     integer :: m, n, i, j

     integer :: ierr

     real(dp) :: kdotr
     real(dp) :: k(3)

     !> R points coordinates (3, nrpts)
     real(dp), allocatable :: crvec(:, :)

     !> k points slice
     real(dp), allocatable :: kslice(:, :)
     real(dp), allocatable :: kslice_shape(:, :)

     ! eigen value of H
	  real(dp), allocatable :: W(:)
     complex(dp), allocatable :: Hamk_bulk(:, :)
     complex(dp), allocatable :: Amat(:, :)
     complex(dp), allocatable :: UU(:, :)
     complex(dp), allocatable :: UU_dag(:, :)

     !> velocities
     complex(dp), allocatable :: vx(:, :)
     complex(dp), allocatable :: vy(:, :)
     complex(dp), allocatable :: vz(:, :)
     complex(dp), allocatable :: DHDk(:, :, :)
     complex(dp), allocatable :: DHDkdag(:, :, :)

     !> Berry curvature  (3, bands, k)
     complex(dp), allocatable :: Omega(:, :)
     complex(dp), allocatable :: Omega_mpi(:, :)

     allocate( kslice(3, Nk1*Nk2))
     allocate( kslice_shape(3, Nk1*Nk2))
     allocate( W       (Num_wann))
     allocate( crvec    (3, nrpts))
     allocate( Omega    (3, Nk1*Nk2))
     allocate( Omega_mpi(3, Nk1*Nk2))
     allocate( vx      (Num_wann, Num_wann))
     allocate( vy      (Num_wann, Num_wann))
     allocate( vz      (Num_wann, Num_wann))
     allocate( Hamk_bulk(Num_wann, Num_wann))
     allocate( Amat(Num_wann, Num_wann))
     allocate( UU(Num_wann, Num_wann))
     allocate( UU_dag(Num_wann, Num_wann))
     allocate( DHDk    (Num_wann, Num_wann, 3))
     allocate( DHDkdag (Num_wann, Num_wann, 3))
     kslice=0d0
     kslice_shape=0d0
     crvec= 0d0
     omega= 0d0
     omega_mpi= 0d0
     vx=0d0
     vy=0d0
     vz=0d0
     Hamk_bulk=0d0
     Amat= 0d0
     UU_dag=0d0
     UU= 0d0
     DHDk= 0d0
     DHDkdag= 0d0

     ik =0
     do i= 1, nk1
        do j= 1, nk2
           ik =ik +1
           kslice(:, ik)= K3D_start+ K3D_vec1*(i-1)/dble(nk1-1)  &
                     + K3D_vec2*(j-1)/dble(nk2-1)
           kslice_shape(:, ik)= kslice(1, ik)* Kua+ kslice(2, ik)* Kub+ kslice(3, ik)* Kuc
        enddo
     enddo

     !> get R coordinates
     do iR=1, Nrpts
        crvec(:, iR)= Rua*irvec(1,iR) + Rub*irvec(2,iR) + Ruc*irvec(3,iR)
     enddo

     do ik= 1+ cpuid, Nk1*Nk2, num_cpu
        if (cpuid==0) write(stdout, *)'Berry curvature ik, nk1*nk2 ', ik, Nk1*Nk2

        !> diagonalize hamiltonian
        k= kslice(:, ik)

        ! calculation bulk hamiltonian
        UU= 0d0
        call ham_bulk_old(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
        UU=Hamk_bulk
        call eigensystem_c( 'V', 'U', Num_wann, UU, W)
       !call zhpevx_pack(hamk_bulk,Num_wann, W, UU)

        UU_dag= conjg(transpose(UU))

        vx= 0d0
        vy= 0d0
        vz= 0d0
        do iR= 1, Nrpts
           kdotr= k(1)*irvec(1,iR) + k(2)*irvec(2,iR) + k(3)*irvec(3,iR)
           vx= vx+ zi*crvec(1, iR)*HmnR(:,:,iR)*Exp(pi2zi*kdotr)/ndegen(iR)
           vy= vy+ zi*crvec(2, iR)*HmnR(:,:,iR)*Exp(pi2zi*kdotr)/ndegen(iR)
           vz= vz+ zi*crvec(3, iR)*HmnR(:,:,iR)*Exp(pi2zi*kdotr)/ndegen(iR)
        enddo ! iR

        !> unitility rotate velocity
        call mat_mul(Num_wann, vx, UU, Amat)
        call mat_mul(Num_wann, UU_dag, Amat, vx)
        call mat_mul(Num_wann, vy, UU, Amat)
        call mat_mul(Num_wann, UU_dag, Amat, vy)
        call mat_mul(Num_wann, vz, UU, Amat)
        call mat_mul(Num_wann, UU_dag, Amat, vz)

        DHDk= 0d0
        DHDkdag= 0d0
        do m= 1, Num_wann
           do n= 1, Num_wann
             !if (W(n) > 0d0 .and. W(m)<0d0) then
              if (n> Numoccupied .and. m<= Numoccupied) then  ! "=" a bug reported by Linlin Wang
                 DHDk(n, m, 1)= zi*vx(n, m)/(W(m)-W(n))
                 DHDk(n, m, 2)= zi*vy(n, m)/(W(m)-W(n))
                 DHDk(n, m, 3)= zi*vz(n, m)/(W(m)-W(n))
              else
                 DHDk(n, m, 1)= 0d0
                 DHDk(n, m, 2)= 0d0
                 DHDk(n, m, 3)= 0d0
              endif
           enddo ! m
        enddo ! n

        do m= 1, Num_wann
           do n= 1, Num_wann
             !if (W(m) > 0d0 .and. W(n)< 0d0) then
              if (m>Numoccupied .and. n<=Numoccupied) then  ! "=" a bug reported by Linlin Wang
                 DHDkdag(n, m, 1)= zi*vx(n, m)/(W(m)-W(n))
                 DHDkdag(n, m, 2)= zi*vy(n, m)/(W(m)-W(n))
                 DHDkdag(n, m, 3)= zi*vz(n, m)/(W(m)-W(n))
              else
                 DHDkdag(n, m, 1)= 0d0
                 DHDkdag(n, m, 2)= 0d0
                 DHDkdag(n, m, 3)= 0d0
              endif
           enddo ! m
        enddo ! n

        !> rotate DHDk and DHDkdag to diagonal basis
        do i=1, 3
           call mat_mul(Num_wann, DHDk(:, :, i), UU_dag, Amat)
           call mat_mul(Num_wann, UU, Amat, DHDk(:, :, i))
           call mat_mul(Num_wann, DHDkdag(:, :, i), UU_dag, Amat)
           call mat_mul(Num_wann, UU, Amat, DHDkdag(:, :, i))
        enddo

        call mat_mul(Num_wann, DHDk(:, :, 1), DHDkdag(:, :, 2), vz)
        call mat_mul(Num_wann, DHDk(:, :, 2), DHDkdag(:, :, 3), vx)
        call mat_mul(Num_wann, DHDk(:, :, 3), DHDkdag(:, :, 1), vy)

        call Im_trace(Num_wann, vx, Omega(1, ik))
        call Im_trace(Num_wann, vy, Omega(2, ik))
        call Im_trace(Num_wann, vz, Omega(3, ik))

     enddo ! ik

     Omega_mpi= 0d0
#if defined (MPI)
     call mpi_allreduce(Omega,Omega_mpi,size(Omega_mpi),&
                       mpi_dc,mpi_sum,mpi_cmw,ierr)
#else
     Omega_mpi= Omega
#endif

     !> output the Berry curvature to file
     outfileindex= outfileindex+ 1
     if (cpuid==0) then
        open(unit=outfileindex, file='Berrycurvature.dat')
        write(outfileindex, '(20a18)')'# kx (1/A)', 'ky (1/A)', 'kz (1/A)', &
           'real(Omega_x)', 'imag(omega_x)', &
           'real(Omega_y)', 'imag(omega_y)', &
           'real(Omega_z)', 'imag(omega_z)'
        ik= 0
        do i= 1, nk1
           do j= 1, nk2
              ik= ik+ 1
              write(outfileindex, '(20f18.10)')kslice_shape(:, ik), Omega_mpi(:, ik)
           enddo
           write(outfileindex, *) ' '
        enddo

        close(outfileindex)

     endif

     !> generate gnuplot script to plot the Berry curvature
     outfileindex= outfileindex+ 1
     if (cpuid==0) then

        open(unit=outfileindex, file='Berrycurvature.gnu')
        write(outfileindex, '(a)')"set encoding iso_8859_1"
        write(outfileindex, '(a)')'#set terminal  pngcairo  truecolor enhanced size 1920, 1680 font ",40"'
        write(outfileindex, '(a)')'set terminal  png       truecolor enhanced size 1920, 1680 font ",40"'
        write(outfileindex, '(a)')"set output 'Berrycurvature.png'"
        write(outfileindex, '(a)')'if (!exists("MP_LEFT"))   MP_LEFT = .12'
        write(outfileindex, '(a)')'if (!exists("MP_RIGHT"))  MP_RIGHT = .92'
        write(outfileindex, '(a)')'if (!exists("MP_BOTTOM")) MP_BOTTOM = .12'
        write(outfileindex, '(a)')'if (!exists("MP_TOP"))    MP_TOP = .88'
        write(outfileindex, '(a)')'if (!exists("MP_GAP"))    MP_GAP = 0.08'
        write(outfileindex, '(a)')'set multiplot layout 2,3 rowsfirst title "\{ Berry Curvature\}" \'
        write(outfileindex, '(a)')"              margins screen MP_LEFT, MP_RIGHT, MP_BOTTOM, MP_TOP spacing screen MP_GAP"
        write(outfileindex, '(a)')" "
        write(outfileindex, '(a)')"set palette rgbformulae 33,13,10"
        write(outfileindex, '(a)')"unset ztics"
        write(outfileindex, '(a)')"unset key"
        write(outfileindex, '(a)')"set pm3d"
        write(outfileindex, '(a)')"set view map"
        write(outfileindex, '(a)')"set border lw 3"
        write(outfileindex, '(a)')"set xlabel 'k (1/{\305})'"
        write(outfileindex, '(a)')"set ylabel 'k (1/{\305})'"
        write(outfileindex, '(a)')"unset colorbox"
        write(outfileindex, '(a)')"unset xtics"
        write(outfileindex, '(a)')"unset xlabel"
        write(outfileindex, '(a)')"set xrange [] noextend"
        write(outfileindex, '(a)')"set yrange [] noextend"
        write(outfileindex, '(a)')"set ytics 0.5 nomirror scale 0.5"
        write(outfileindex, '(a)')"set pm3d interpolate 2,2"
        write(outfileindex, '(a)')"set title 'Omega_x real'"
        write(outfileindex, '(a)')"splot 'Berrycurvature.dat' u 1:2:4 w pm3d"
        write(outfileindex, '(a)')"unset ylabel"
        write(outfileindex, '(a)')"unset ytics"
        write(outfileindex, '(a)')"set title 'Omega_y real'"
        write(outfileindex, '(a)')"splot 'Berrycurvature.dat' u 1:2:6 w pm3d"
        write(outfileindex, '(a)')"set title 'Omega_z real'"
        write(outfileindex, '(a)')"set colorbox"
        write(outfileindex, '(a)')"splot 'Berrycurvature.dat' u 1:2:8 w pm3d"

        write(outfileindex, '(a)')"set xtics 0.5 nomirror scale 0.5"
        write(outfileindex, '(a)')"set ytics nomirror scale 0.5"
        write(outfileindex, '(a)')"set ylabel 'k (1/{\305})'"
        write(outfileindex, '(a)')"set xlabel 'k (1/{\305})'"
        write(outfileindex, '(a)')"unset colorbox"
        write(outfileindex, '(a)')"set title 'Omega_x imag'"
        write(outfileindex, '(a)')"splot 'Berrycurvature.dat' u 1:2:5 w pm3d"
        write(outfileindex, '(a)')"unset ylabel"
        write(outfileindex, '(a)')"unset ytics"
        write(outfileindex, '(a)')"set title 'Omega_y imag'"
        write(outfileindex, '(a)')"splot 'Berrycurvature.dat' u 1:2:7 w pm3d"
        write(outfileindex, '(a)')"set title 'Omega_z imag'"
        write(outfileindex, '(a)')"set colorbox"
        write(outfileindex, '(a)')"splot 'Berrycurvature.dat' u 1:2:9 w pm3d"
        close(outfileindex)
     endif

     return

  end subroutine berry_curvarture

  subroutine Fourier_R_to_k(k, ham)
     !> Fourier transform the Hamiltonian from R space to k space
     use para, only: irvec, HmnR, Nrpts, ndegen, pi, zi, Num_wann, dp
     implicit none

     real(dp), intent(in) :: k(3)
     complex(dp), intent(out) :: ham(Num_wann, Num_wann)
     integer :: iR
    !real(dp) :: R(3)
     real(dp) :: kdotr

     ham= 0d0
     do iR= 1, Nrpts
       !R= Rua*irvec(1,iR) + Rub*irvec(2,iR) + Ruc*irvec(3,iR)
        kdotr= k(1)*irvec(1,iR) + k(2)*irvec(2,iR) + k(3)*irvec(3,iR)
        Ham= Ham+ HmnR(:,:,iR)*Exp(2d0*pi*zi*kdotr)/ndegen(iR)
     enddo

     return
  end subroutine Fourier_R_to_k

  subroutine Im_trace(ndim, A, tr)
     !> Calculate trace only with the imaginary part of a matrix A with dimension ndim
     use para, only : dp
     implicit none
     integer :: ndim
     complex(dp), intent(out) :: tr
     complex(dp), intent(in) :: A(ndim, ndim)

     integer :: i

     tr = 0d0
     do i=1, ndim
        tr= tr+ aimag(A(i, i))
     enddo

     return
  end subroutine Im_trace

  subroutine trace(ndim, A, tr)
     !> Calculate trace of a matrix A with dimension ndim
     use para, only : dp
     use para, only : dp
     implicit none
     integer :: ndim
     complex(dp), intent(out) :: tr
     complex(dp), intent(in) :: A(ndim, ndim)

     integer :: i

     tr = 0d0
     do i=1, ndim
        tr= tr+ (A(i, i))
     enddo

     return
  end subroutine trace


!##############################################################################
!# ****************************************************************************
!# <name> stdoperators </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains some routines to assemble basic matrices that are
!# frequently used in most Finite Element based programs.
!#
!# The following routines can be found in this module:
!#
!# 1.) stdop_assembleLaplaceMatrix
!#     -> Assembles a standard Laplace matrix
!#
!# 2.) stdop_assembleSimpleMatrix
!#     -> Assembles simple standard matrices like a mass matrix.
!#
!# </purpose>
!##############################################################################

module stdoperators

!$ use omp_lib
  use fsystem
  use genoutput
  use linearsystemscalar
  use scalarpde
  use derivatives
  use spatialdiscretisation
  use bilinearformevaluation
  use perfconfig

  implicit none

  private

  public :: stdop_assembleLaplaceMatrix
  public :: stdop_assembleSimpleMatrix

contains

  ! ***************************************************************************

!<subroutine>

  subroutine stdop_assembleLaplaceMatrix (rmatrix,bclear,dalpha, &
      rcubatureInfo, rperfconfig)

!<description>
  ! This routine assembles a Laplace matrix into rmatrix.
!</description>

!<input>
  ! OPTIONAL: If set to TRUE (standard), the content of rmatrix is set to 0.0
  ! before assembling the matrix.
  logical, intent(in), optional :: bclear

  ! OPTIONAL: Constant coefficient in front of the matrix, which is multiplied
  ! to all entries. If not specified, 1.0 is assumed.
  real(DP), intent(in), optional :: dalpha

  ! OPTIONAL: A scalar cubature information structure that specifies the cubature
  ! formula(s) to use. If not specified, default settings are used.
  type(t_scalarCubatureInfo), intent(in), optional, target :: rcubatureInfo

  ! OPTIONAL: local performance configuration. If not given, the
  ! global performance configuration is used.
  type(t_perfconfig), intent(in), target, optional :: rperfconfig
!</input>

!<inputoutput>
  ! Matrix structure where to save the entries of the Laplace matrix to.
  ! The structure of the matrix (KCOL, KLD,...) as well as the discretisation
  ! structure must already be given.
  ! If the array for the matrix content does not exist, a new array is created.
  ! If the array exist, the new entries of the Laplace operator overwrite
  ! the old entries (if bclear=true) or are added to the old entries
  ! (if bclear=false).
  type(t_matrixScalar), intent(inout) :: rmatrix
!</inputoutput>

!</subroutine>

    ! local variables
    real(DP) :: dalpha1
    logical :: bclear1
    type(t_spatialDiscretisation), pointer :: p_rdiscr => null()
    type(t_scalarCubatureInfo), target :: rtempCubatureInfo
    type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

    ! A bilinear and linear form describing the analytic problem to solve
    type(t_bilinearForm) :: rform

    bclear1 = .true.
    dalpha1 = 1.0_DP
    if (present(bclear)) bclear1=bclear
    if (present(dalpha)) dalpha1=dalpha

    ! Now try to get a pointer to the spatial discretisation - either from the trial
    ! or the test space. We just need to know whether we are in 1D, 2D or 3D.
    p_rdiscr => rmatrix%p_rspatialDiscrTrial

    if(.not. associated(p_rdiscr)) then
      call output_line('Matrix does not have a discretisation!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'stdop_assembleLaplaceMatrix')
      call sys_halt()
    end if

    ! Now we can set up the bilinearform.
    select case(p_rdiscr%ndimension)
    case (1)
      rform%itermCount = 1
      rform%Idescriptors(1,1) = DER_DERIV1D_X
      rform%Idescriptors(2,1) = DER_DERIV1D_X

    case (2)
      rform%itermCount = 2
      rform%Idescriptors(1,1) = DER_DERIV2D_X
      rform%Idescriptors(2,1) = DER_DERIV2D_X
      rform%Idescriptors(1,2) = DER_DERIV2D_Y
      rform%Idescriptors(2,2) = DER_DERIV2D_Y

    case (3)
      rform%itermCount = 3
      rform%Idescriptors(1,1) = DER_DERIV3D_X
      rform%Idescriptors(2,1) = DER_DERIV3D_X
      rform%Idescriptors(1,2) = DER_DERIV3D_Y
      rform%Idescriptors(2,2) = DER_DERIV3D_Y
      rform%Idescriptors(1,3) = DER_DERIV3D_Z
      rform%Idescriptors(2,3) = DER_DERIV3D_Z

    end select

    ! In the standard case, we have constant coefficients:
    rform%ballCoeffConstant = .true.
    rform%Dcoefficients(1:rform%itermCount)  = dalpha1

    ! If we do not have it, create a cubature info structure that
    ! defines how to do the assembly.
    if (.not. present(rcubatureInfo)) then
      call spdiscr_createDefCubStructure(rmatrix%p_rspatialDiscrTrial,&
          rtempCubatureInfo,CUB_GEN_DEPR_BILFORM)
      p_rcubatureInfo => rtempCubatureInfo
    else
      p_rcubatureInfo => rcubatureInfo
    end if

    ! Now we can build the matrix entries.
    call bilf_buildMatrixScalar (rform,bclear1,rmatrix,&
        p_rcubatureInfo,rperfconfig=rperfconfig)

    ! Release the assembly structure if necessary.
    if (.not. present(rcubatureInfo)) then
      call spdiscr_releaseCubStructure(rtempCubatureInfo)
    end if

  end subroutine stdop_assembleLaplaceMatrix

  ! ***************************************************************************

!<subroutine>

  subroutine stdop_assembleSimpleMatrix (rmatrix,cderivTrial,cderivTest,dalpha,&
      bclear,rcubatureInfo,rperfconfig)

!<description>
  ! This routine assembles a simple Finite element matrix into rmatrix.
  ! "Simple" means here, that a matrix entry consists of exactly one
  ! trial/test function pair and a constant coefficient:
  !   <tex> $$ a_ij = int_{\Omega} \alpha * \psi^j_k * \phi^i_l $$ </tex>
  ! With $k,l$ being derivative quantifiers.
  ! This allows to assemble mass matrices or similar matrices
  ! directly. (A mass matrix for example can be assembled using
  ! cderivTrial = cderivTest = DER_FUNC.)
!</description>

!<input>
  ! A derivative quantifier for the trial function. One of the DER_XXXX constants,
  ! e.g. DER_DERIV_X for X- or DER_DERIV_Y for Y-derivative.
  integer, intent(in) :: cderivTrial

  ! A derivative quantifier for the test function. One of the DER_XXXX constants,
  ! e.g. DER_DERIV_X for X- or DER_DERIV_Y for Y-derivative.
  integer, intent(in) :: cderivTest

  ! Constant coefficient in front of the matrix, which is multiplied
  ! to all entries. If not specified, a value of 1.0 is assumed.
  real(DP), intent(in), optional :: dalpha

  ! OPTIONAL: If set to TRUE (standard), the content of rmatrix is set to 0.0
  ! before assembling the matrix.
  logical, intent(in), optional :: bclear

  ! OPTIONAL: A scalar cubature information structure that specifies the cubature
  ! formula(s) to use. If not specified, default settings are used.
  type(t_scalarCubatureInfo), intent(in), optional, target :: rcubatureInfo

  ! OPTIONAL: local performance configuration. If not given, the
  ! global performance configuration is used.
  type(t_perfconfig), intent(in), target, optional :: rperfconfig
!</input>

!<inputoutput>
  ! Matrix structure where to save the entries of the Laplace matrix to.
  ! The structure of the matrix (KCOL, KLD,...) as well as the discretisation
  ! structure must already be given.
  ! If the array for the matrix content does not exist, a new array is created.
  ! If the array exist, the new entries of the Laplace operator overwrite
  ! the old entries (if bclear=true) or are added to the old entries
  ! (if bclear=false).
  type(t_matrixScalar), intent(inout) :: rmatrix
!</inputoutput>

!</subroutine>

    ! local variables
    real(DP) :: dalpha1
    logical :: bclear1
    type(t_scalarCubatureInfo), target :: rtempCubatureInfo
    type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

    ! A bilinear and linear form describing the analytic problem to solve
    type(t_bilinearForm) :: rform

    bclear1 = .true.
    dalpha1 = 1.0_DP
    if (present(bclear)) bclear1=bclear
    if (present(dalpha)) dalpha1=dalpha

    ! Set up bilinear form for generating the mass matrix
    rform%itermCount = 1
    rform%Idescriptors(1,1) = cderivTrial
    rform%Idescriptors(2,1) = cderivTest

    ! We have constant coefficients:
    rform%ballCoeffConstant = .true.
    rform%Dcoefficients(1)  = dalpha1

    ! If we do not have it, create a cubature info structure that
    ! defines how to do the assembly.
    if (.not. present(rcubatureInfo)) then
      call spdiscr_createDefCubStructure(rmatrix%p_rspatialDiscrTrial,&
          rtempCubatureInfo,CUB_GEN_DEPR_BILFORM)
      p_rcubatureInfo => rtempCubatureInfo
    else
      p_rcubatureInfo => rcubatureInfo
    end if

    ! Now we can build the matrix entries.
    call bilf_buildMatrixScalar (rform,bclear1,rmatrix,&
        p_rcubatureInfo,rperfconfig=rperfconfig)

    ! Release the assembly structure if necessary.
    if (.not. present(rcubatureInfo)) then
      call spdiscr_releaseCubStructure(rtempCubatureInfo)
    end if

  end subroutine stdop_assembleSimpleMatrix

end module stdoperators


      SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W,
     $                   VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK,
     $                   BWORK, INFO )
*
*  -- LAPACK driver routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          JOBVS, SENSE, SORT
      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
      REAL               RCONDE, RCONDV
*     ..
*     .. Array Arguments ..
      LOGICAL            BWORK( * )
      REAL               RWORK( * )
      COMPLEX            A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
*     ..
*     .. Function Arguments ..
      LOGICAL            SELECT
      EXTERNAL           SELECT
*     ..
*
*  Purpose
*  =======
*
*  CGEESX computes for an N-by-N complex nonsymmetric matrix A, the
*  eigenvalues, the Schur form T, and, optionally, the matrix of Schur
*  vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).
*
*  Optionally, it also orders the eigenvalues on the diagonal of the
*  Schur form so that selected eigenvalues are at the top left;
*  computes a reciprocal condition number for the average of the
*  selected eigenvalues (RCONDE); and computes a reciprocal condition
*  number for the right invariant subspace corresponding to the
*  selected eigenvalues (RCONDV).  The leading columns of Z form an
*  orthonormal basis for this invariant subspace.
*
*  For further explanation of the reciprocal condition numbers RCONDE
*  and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
*  these quantities are called s and sep respectively).
*
*  A complex matrix is in Schur form if it is upper triangular.
*
*  Arguments
*  =========
*
*  JOBVS   (input) CHARACTER*1
*          = 'N': Schur vectors are not computed;
*          = 'V': Schur vectors are computed.
*
*  SORT    (input) CHARACTER*1
*          Specifies whether or not to order the eigenvalues on the
*          diagonal of the Schur form.
*          = 'N': Eigenvalues are not ordered;
*          = 'S': Eigenvalues are ordered (see SELECT).
*
*  SELECT  (input) LOGICAL FUNCTION of one COMPLEX argument
*          SELECT must be declared EXTERNAL in the calling subroutine.
*          If SORT = 'S', SELECT is used to select eigenvalues to order
*          to the top left of the Schur form.
*          If SORT = 'N', SELECT is not referenced.
*          An eigenvalue W(j) is selected if SELECT(W(j)) is true.
*
*  SENSE   (input) CHARACTER*1
*          Determines which reciprocal condition numbers are computed.
*          = 'N': None are computed;
*          = 'E': Computed for average of selected eigenvalues only;
*          = 'V': Computed for selected right invariant subspace only;
*          = 'B': Computed for both.
*          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
*
*  N       (input) INTEGER
*          The order of the matrix A. N >= 0.
*
*  A       (input/output) COMPLEX array, dimension (LDA, N)
*          On entry, the N-by-N matrix A.
*          On exit, A is overwritten by its Schur form T.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  SDIM    (output) INTEGER
*          If SORT = 'N', SDIM = 0.
*          If SORT = 'S', SDIM = number of eigenvalues for which
*                         SELECT is true.
*
*  W       (output) COMPLEX array, dimension (N)
*          W contains the computed eigenvalues, in the same order
*          that they appear on the diagonal of the output Schur form T.
*
*  VS      (output) COMPLEX array, dimension (LDVS,N)
*          If JOBVS = 'V', VS contains the unitary matrix Z of Schur
*          vectors.
*          If JOBVS = 'N', VS is not referenced.
*
*  LDVS    (input) INTEGER
*          The leading dimension of the array VS.  LDVS >= 1, and if
*          JOBVS = 'V', LDVS >= N.
*
*  RCONDE  (output) REAL
*          If SENSE = 'E' or 'B', RCONDE contains the reciprocal
*          condition number for the average of the selected eigenvalues.
*          Not referenced if SENSE = 'N' or 'V'.
*
*  RCONDV  (output) REAL
*          If SENSE = 'V' or 'B', RCONDV contains the reciprocal
*          condition number for the selected right invariant subspace.
*          Not referenced if SENSE = 'N' or 'E'.
*
*  WORK    (workspace/output) COMPLEX array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,2*N).
*          Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),
*          where SDIM is the number of selected eigenvalues computed by
*          this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2.
*          For good performance, LWORK must generally be larger.
*
*  RWORK   (workspace) REAL array, dimension (N)
*
*  BWORK   (workspace) LOGICAL array, dimension (N)
*          Not referenced if SORT = 'N'.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value.
*          > 0: if INFO = i, and i is
*             <= N: the QR algorithm failed to compute all the
*                   eigenvalues; elements 1:ILO-1 and i+1:N of W
*                   contain those eigenvalues which have converged; if
*                   JOBVS = 'V', VS contains the transformation which
*                   reduces A to its partially converged Schur form.
*             = N+1: the eigenvalues could not be reordered because some
*                   eigenvalues were too close to separate (the problem
*                   is very ill-conditioned);
*             = N+2: after reordering, roundoff changed values of some
*                   complex eigenvalues so that leading eigenvalues in
*                   the Schur form no longer satisfy SELECT=.TRUE.  This
*                   could also be caused by underflow due to scaling.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            SCALEA, WANTSB, WANTSE, WANTSN, WANTST,
     $                   WANTSV, WANTVS
      INTEGER            HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
     $                   ITAU, IWRK, K, MAXB, MAXWRK, MINWRK
      REAL               ANRM, BIGNUM, CSCALE, EPS, SMLNUM
*     ..
*     .. Local Arrays ..
      REAL               DUM( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           CCOPY, CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY,
     $                   CLASCL, CTRSEN, CUNGHR, SLABAD, SLASCL, XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               CLANGE, SLAMCH
      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      WANTVS = LSAME( JOBVS, 'V' )
      WANTST = LSAME( SORT, 'S' )
      WANTSN = LSAME( SENSE, 'N' )
      WANTSE = LSAME( SENSE, 'E' )
      WANTSV = LSAME( SENSE, 'V' )
      WANTSB = LSAME( SENSE, 'B' )
      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
     $         ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
         INFO = -11
      END IF
*
*     Compute workspace
*      (Note: Comments in the code beginning "Workspace:" describe the
*       minimal amount of real workspace needed at that point in the
*       code, as well as the preferred amount for good performance.
*       CWorkspace refers to complex workspace, and RWorkspace to real
*       workspace. NB refers to the optimal block size for the
*       immediately following subroutine, as returned by ILAENV.
*       HSWORK refers to the workspace preferred by CHSEQR, as
*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
*       the worst case.
*       If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
*       depends on SDIM, which is computed by the routine CTRSEN later
*       in the code.)
*
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 ) ) THEN
         MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 )
         MINWRK = MAX( 1, 2*N )
         IF( .NOT.WANTVS ) THEN
            MAXB = MAX( ILAENV( 8, 'CHSEQR', 'SN', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'CHSEQR', 'SN', N, 1,
     $          N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, HSWORK, 1 )
         ELSE
            MAXWRK = MAX( MAXWRK, N+( N-1 )*
     $               ILAENV( 1, 'CUNGHR', ' ', N, 1, N, -1 ) )
            MAXB = MAX( ILAENV( 8, 'CHSEQR', 'SV', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'CHSEQR', 'SV', N, 1,
     $          N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, HSWORK, 1 )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
      IF( LWORK.LT.MINWRK ) THEN
         INFO = -15
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGEESX', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         SDIM = 0
         RETURN
      END IF
*
*     Get machine constants
*
      EPS = SLAMCH( 'P' )
      SMLNUM = SLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL SLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = CLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA )
     $   CALL CLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
*
*     Permute the matrix to make it more nearly triangular
*     (CWorkspace: none)
*     (RWorkspace: need N)
*
      IBAL = 1
      CALL CGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
*
*     Reduce to upper Hessenberg form
*     (CWorkspace: need 2*N, prefer N+N*NB)
*     (RWorkspace: none)
*
      ITAU = 1
      IWRK = N + ITAU
      CALL CGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
     $             LWORK-IWRK+1, IERR )
*
      IF( WANTVS ) THEN
*
*        Copy Householder vectors to VS
*
         CALL CLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
*        Generate unitary matrix in VS
*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
*        (RWorkspace: none)
*
         CALL CUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
     $                LWORK-IWRK+1, IERR )
      END IF
*
      SDIM = 0
*
*     Perform QR iteration, accumulating Schur vectors in VS if desired
*     (CWorkspace: need 1, prefer HSWORK (see comments) )
*     (RWorkspace: none)
*
      IWRK = ITAU
      CALL CHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS,
     $             WORK( IWRK ), LWORK-IWRK+1, IEVAL )
      IF( IEVAL.GT.0 )
     $   INFO = IEVAL
*
*     Sort eigenvalues if desired
*
      IF( WANTST .AND. INFO.EQ.0 ) THEN
         IF( SCALEA )
     $      CALL CLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR )
         DO 10 I = 1, N
            BWORK( I ) = SELECT( W( I ) )
   10    CONTINUE
*
*        Reorder eigenvalues, transform Schur vectors, and compute
*        reciprocal condition numbers
*        (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM)
*                     otherwise, need none )
*        (RWorkspace: none)
*
         CALL CTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM,
     $                RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
     $                ICOND )
         IF( .NOT.WANTSN )
     $      MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
         IF( ICOND.EQ.-14 ) THEN
*
*           Not enough complex workspace
*
            INFO = -15
         END IF
      END IF
*
      IF( WANTVS ) THEN
*
*        Undo balancing
*        (CWorkspace: none)
*        (RWorkspace: need N)
*
         CALL CGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS,
     $                IERR )
      END IF
*
      IF( SCALEA ) THEN
*
*        Undo scaling for the Schur form of A
*
         CALL CLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
         CALL CCOPY( N, A, LDA+1, W, 1 )
         IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
            DUM( 1 ) = RCONDV
            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
            RCONDV = DUM( 1 )
         END IF
      END IF
*
      WORK( 1 ) = MAXWRK
      RETURN
*
*     End of CGEESX
*
      END


      SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
     $                            EIGCNT, LCNT, RCNT, INFO )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          JOBT
      INTEGER            EIGCNT, INFO, LCNT, N, RCNT
      REAL               PIVMIN, VL, VU
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
*     ..
*
*  Purpose
*  =======
*
*  Find the number of eigenvalues of the symmetric tridiagonal matrix T
*  that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
*  if JOBT = 'L'.
*
*  Arguments
*  =========
*
*  JOBT    (input) CHARACTER*1
*          = 'T':  Compute Sturm count for matrix T.
*          = 'L':  Compute Sturm count for matrix L D L^T.
*
*  N       (input) INTEGER
*          The order of the matrix. N > 0.
*
*  VL      (input) DOUBLE PRECISION
*  VU      (input) DOUBLE PRECISION
*          The lower and upper bounds for the eigenvalues.
*
*  D       (input) DOUBLE PRECISION array, dimension (N)
*          JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
*          JOBT = 'L': The N diagonal elements of the diagonal matrix D.
*
*  E       (input) DOUBLE PRECISION array, dimension (N)
*          JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
*          JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
*
*  PIVMIN  (input) DOUBLE PRECISION
*          The minimum pivot in the Sturm sequence for T.
*
*  EIGCNT  (output) INTEGER
*          The number of eigenvalues of the symmetric tridiagonal matrix T
*          that are in the interval (VL,VU]
*
*  LCNT    (output) INTEGER
*  RCNT    (output) INTEGER
*          The left and right negcounts of the interval.
*
*  INFO    (output) INTEGER
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Beresford Parlett, University of California, Berkeley, USA
*     Jim Demmel, University of California, Berkeley, USA
*     Inderjit Dhillon, University of Texas, Austin, USA
*     Osni Marques, LBNL/NERSC, USA
*     Christof Voemel, University of California, Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      LOGICAL            MATT
      REAL               LPIVOT, RPIVOT, SL, SU, TMP, TMP2

*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      LCNT = 0
      RCNT = 0
      EIGCNT = 0
      MATT = LSAME( JOBT, 'T' )

      IF (MATT) THEN
*        Sturm sequence count on T
         LPIVOT = D( 1 ) - VL
         RPIVOT = D( 1 ) - VU
         IF( LPIVOT.LE.ZERO ) THEN
            LCNT = LCNT + 1
         ENDIF
         IF( RPIVOT.LE.ZERO ) THEN
            RCNT = RCNT + 1
         ENDIF
         DO 10 I = 1, N-1
            TMP = E(I)**2
            LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
            RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
            IF( LPIVOT.LE.ZERO ) THEN
               LCNT = LCNT + 1
            ENDIF
            IF( RPIVOT.LE.ZERO ) THEN
               RCNT = RCNT + 1
            ENDIF
 10      CONTINUE
      ELSE
*        Sturm sequence count on L D L^T
         SL = -VL
         SU = -VU
         DO 20 I = 1, N - 1
            LPIVOT = D( I ) + SL
            RPIVOT = D( I ) + SU
            IF( LPIVOT.LE.ZERO ) THEN
               LCNT = LCNT + 1
            ENDIF
            IF( RPIVOT.LE.ZERO ) THEN
               RCNT = RCNT + 1
            ENDIF
            TMP = E(I) * D(I) * E(I)
*
            TMP2 = TMP / LPIVOT
            IF( TMP2.EQ.ZERO ) THEN
               SL =  TMP - VL
            ELSE
               SL = SL*TMP2 - VL
            END IF
*
            TMP2 = TMP / RPIVOT
            IF( TMP2.EQ.ZERO ) THEN
               SU =  TMP - VU
            ELSE
               SU = SU*TMP2 - VU
            END IF
 20      CONTINUE
         LPIVOT = D( N ) + SL
         RPIVOT = D( N ) + SU
         IF( LPIVOT.LE.ZERO ) THEN
            LCNT = LCNT + 1
         ENDIF
         IF( RPIVOT.LE.ZERO ) THEN
            RCNT = RCNT + 1
         ENDIF
      ENDIF
      EIGCNT = RCNT - LCNT

      RETURN
*
*     end of SLARRC
*
      END


      program getfreqs

      parameter(pi=3.1415926535)
      common /potconstants/ apot(20,0:20000), fr(20,0:20000),
     +     dr, nr, lmax, potcor
      common/legendre/ plcon(0:40)
      common /gparameters/  a, b, c, v0, q, psi00,
     +                      psiout, rho1, sigbulge2,
     +                      rmdisk, rdisk, zdisk, outdisk, drtrunc,
     +                      potcor1

      real adens(20,0:20000),potmaj(0:20000),
     +     potmajtot(0:20000),potup(0:20000),surden(0:20000),
     +     potmin(0:20000),vcmaj(0:20000),vctot(0:20000),vertfreq(0:20000),vcbulge(0:20000),
     +     vertfreqbulge(0:20000),psi2(0:20000)

c  constants for legendre polynomials
      do l=0,40
         plcon(l) = sqrt((2*l+1)/(4.0*pi))
      enddo

      open(14,file='dbh.dat',status='old')
      read(14,*)
      read(14,'(2x,7g15.5,i6,i4)') psi00,v0,q,a,b,c,dr,nr,lmax
      read(14,*)
      read(14,'(2x,3g15.5)') psiout,rho1,sigbulge
      read(14,*)
      read(14,'(2x,5g15.5)') rmdisk, rdisk, zdisk, outdisk, drtrunc
      read(14,'(2x,3i5)') idiskflag, ibulgeflag, ihaloflag
      read(14,*)
      write(0,'(x,''Harmonics up to l='',i4)') lmax
c
c READ HARMONICS IN FILE FILE INTO APOT ARRAY
c THESE CAN THEN BE USED BY POT(R,Z) TO GIVE THE CORRESPONDING FUNCTION
c
      do ir=0,nr
         read(14,*) rr,(adens(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)
      read(14,*)
c
c READ IN HARMONICS OF THE TOTAL POTENTIAL, TABULATE POT ON MAJ & MIN AXES
c
      do ir=0,nr
         read(14,*) rr,(apot(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)
      read(14,*)

c      write(*,*) 'Start of total potential harmonics:'
c      do ir=0,5
c         write(*,*) ir*dr,(apot(l/2+1,ir),l=0,lmax,2)
c      enddo

      open(15,file='freqdbh.dat',status='unknown')
      do ir=0,nr
         r=ir*dr
         potmajtot(ir)=pot(r,0.)
         potmin(ir)=pot(0.,r)
      enddo
c
c READ IN HARMONICS OF RADIAL FORCE, TABULATE ROTATION CURVE
c
      do ir=0,nr
         read(14,*) rr,(apot(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)
      read(14,*)

c      write(*,*) 'Start of total radial force harmonics:'
c      do ir=0,5
c         write(*,*) ir*dr,(apot(l/2+1,ir),l=0,lmax,2)
c      enddo

      do ir=0,nr
         r=ir*dr
         vctot(ir)=sqrt(max(0.,r*pot(r,0.)))
      enddo
c
c READ IN HARMONICS OF 2ND DERIVATIVE OF PSI, TABULATE IN PSI2
c
      do ir=0,nr
         read(14,*) rr,(apot(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)

c      write(*,*) 'Start of total potential 2nd deriv harmonics:'
c      do ir=0,5
c         write(*,*) ir*dr,(apot(l/2+1,ir),l=0,lmax,2)
c      enddo

      do ir=0,nr
         r=ir*dr
         psi2(ir)=pot(r,0.)
      enddo
c
c READ IN SURFACE DENSITY OF THE DISK, TABULATE
c
      do ir=0,nr
         read(14,'(2g16.8)') rr,surden(ir)
         enddo
      close(14)

      drsave=dr
      nrsave=nr
c
c NOW REPEAT FOR HALO-ONLY HARMONICS FILE
c

      open(14,file='h.dat',status='old')
      read(14,*)
      read(14,'(2x,7g15.5,i6,i4)') psi00,v0,q,a,b,c,drsave,nrsave,lmax
      read(14,*)
      read(14,'(2x,3g15.5)') psiout,rho1,sigbulge
      read(14,*)
      read(14,'(2x,5g15.5)') rmdisk, rdisk, zdisk, outdisk, drtrunc
      read(14,'(2x,3i5)') idiskflag, ibulgeflag, ihaloflag
      read(14,*)
      write(0,'(x,''Harmonics up to l='',i4)') lmax
      if (nr.ne.nrsave .or. dr.ne.drsave) then
         write(0,*) 'radial bins do not match.'
         stop
      endif

      idiskflag=0

c
c READ HALO POTENTIAL, TABULATE IT ON MAJOR & INCLINED AXES
c

      do ir=0,nr
         read(14,*) rr,(adens(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)
      read(14,*)

      do ir=0,nr
         read(14,*) rr,(apot(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)
      read(14,*)

c      write(*,*) 'Start of halo potential harmonics:'
c      do ir=0,5
c         write(*,*) ir*dr,(apot(l/2+1,ir),l=0,lmax,2)
c      enddo

      do ir=0,nr
         r=ir*dr
         potmaj(ir)=pot(r,0.)
         potup(ir)=pot(r*cos(0.05),r*sin(0.05))
      enddo

c
c READ HALO RADIAL FORCE, TABULATE ITS ROTATION CURVE AND VERT FREQ
c
      do ir=0,nr
         read(14,*) rr,(apot(l/2+1,ir),l=0,lmax,2)
      enddo

c      write(*,*) 'Start of halo radial force harmonics:'
c      do ir=0,5
c         write(*,*) ir*dr,(apot(l/2+1,ir),l=0,lmax,2)
c      enddo

      do ir=0,nr
         r=ir*dr
         if (ir.eq.0) then
            vcmaj(ir)=0
         else
            vcmaj(ir)=sqrt(max(0.,r*pot(r,0.)))
         endif
         if (ir.eq.0) then
            vertfreq(ir)=0
         else
            vertfreq(ir)=sqrt(max(0.,vcmaj(ir)**2+2.*(potup(ir)-potmaj(ir))/0.05**2))/r
         endif
      enddo

      close(14)

c REPEAT FOR BULGE

      open(14,file='b.dat',status='old')
      read(14,*)
      read(14,'(2x,7g15.5,i6,i4)') psi00,v0,q,a,b,c,drsave,nrsave,lmax
      read(14,*)
      read(14,'(2x,3g15.5)') psiout,rho1,sigbulge
      read(14,*)
      read(14,'(2x,5g15.5)') rmdisk, rdisk, zdisk, outdisk, drtrunc
      read(14,'(2x,3i5)') idiskflag, ibulgeflag, ihaloflag
      read(14,*)
      write(0,'(x,''Harmonics up to l='',i4)') lmax
      if (nr.ne.nrsave .or. dr.ne.drsave) then
         write(0,*) 'radial bins do not match.'
         stop
      endif

      idiskflag=0
c
c READ BULGE POTENTIAL, TABULATE
c
      do ir=0,nr
         read(14,*) rr,(adens(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)
      read(14,*)
      do ir=0,nr
         read(14,*) rr,(apot(l/2+1,ir),l=0,lmax,2)
      enddo
      read(14,*)
      read(14,*)

c      write(*,*) 'Start of bulge potential harmonics:'
c      do ir=0,5
c         write(*,*) ir*dr,(apot(l/2+1,ir),l=0,lmax,2)
c      enddo

      do ir=0,nr
         r=ir*dr
         potmaj(ir)=pot(r,0.)
         potup(ir)=pot(r*cos(0.05),r*sin(0.05))
      enddo
C
C READ BULGE RADIAL FORCE, MAKE ROT CURVE AND VERT FREQS.
C

      do ir=0,nr
         read(14,*) rr,(apot(l/2+1,ir),l=0,lmax,2)
      enddo

c      write(*,*) 'Start of bulge radial force harmonics:'
c      do ir=0,5
c         write(*,*) ir*dr,(apot(l/2+1,ir),l=0,lmax,2)
c      enddo

      do ir=0,nr
         r=ir*dr
         if (ir.eq.0) then
            vcbulge(ir)=0
         else
            vcbulge(ir)=sqrt(max(0.,r*pot(r,0.)))
         endif
         if (ir.eq.0) then
            vertfreqbulge(ir)=0
         else
            vertfreqbulge(ir)=sqrt(vcbulge(ir)**2+2.*(potup(ir)-potmaj(ir))/0.05**2)/r
         endif
      enddo

      close(14)

      write(15,'(''#'',16(3x,a10,3x))') 'RADIUS','OMEGA_H','NU_H',
     :     'SIGMA_D','VC_TOT','VC_B','NU_B','PSIMAJ_TOT','PSI'''''
      write(15,'(''#'')')

      ir=0
      write(15,'(9g16.8)') 0.,vcmaj(1)/dr,(4*vertfreq(1)-vertfreq(2))/3.,
     +     surden(ir),
     +     vctot(ir),vcbulge(ir),(4*vertfreqbulge(1)-vertfreqbulge(2))/3.,
     +     potmajtot(ir),
     +     psi2(ir)

      do ir=1,nr
         r=ir*dr
         write(15,'(9g16.8)') r,vcmaj(ir)/r,vertfreq(ir),surden(ir),
     +           vctot(ir),vcbulge(ir),vertfreqbulge(ir),potmajtot(ir),
     +           psi2(ir)
         enddo
 99   close(15)
      end


MODULE reservoir_module
  IMPLICIT NONE
  INTEGER, PRIVATE, PARAMETER :: n = 32   !! number of points in the polygon
  DOUBLE COMPLEX, PRIVATE, DIMENSION(n) :: z, fe, dz    !! internal arrays
  DOUBLE PRECISION, PRIVATE, DIMENSION(2) :: xll,xur    !! corners of a box containing reservoir

CONTAINS
  LOGICAL FUNCTION point_in_poly(x0,y0)
    IMPLICIT NONE

    REAL(kind=8) :: x0,y0

    DOUBLE COMPLEX :: z0, trapsum
    REAL(kind=8) :: tol
    INTEGER :: i

    DOUBLE PRECISION :: pi

    pi = 4.d0*ATAN(1.d0)

    !! First, do simple check

    IF (x0 < xll(1) .OR. x0 > xur(1)) THEN
       point_in_poly = .FALSE.
       RETURN
    ENDIF

    IF (y0 < xll(2) .OR. y0 > xur(2)) THEN
       point_in_poly = .FALSE.
       RETURN
    ENDIF

    z0 = CMPLX(x0,y0,kind=8)

    !!n = 32

    DO i = 1,n
       !! z(i) = CMPLX(x(i),y(i),kind=8)
       fe(i) = 1.d0/(z(i) - z0)
!!       IF (i .GT. 1) THEN
!!          dz(i-1) = z(i) - z(i-1)
!!       ENDIF
    ENDDO
100 FORMAT(I3, 4E24.16)

    !! Use trapezoidal rule to compute winding number
    trapsum = CMPLX(0.d0,0.d0,kind=8)
    DO i = 1,n-1
       trapsum = trapsum + (fe(i) + fe(i+1))*dz(i)/2.d0
    ENDDO
    trapsum = trapsum/(2*pi*CMPLX(0,1.d0,kind=8))

    tol = 0.25d0
    IF (ABS(trapsum) .LT. tol) THEN
       point_in_poly = .FALSE.
    ELSE
       point_in_poly = .TRUE.
    ENDIF

  END FUNCTION point_in_poly

  SUBROUTINE set_reservoir_path()
    IMPLICIT NONE

    DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: wpath
    DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: wpath1d

    INTEGER :: i

    ALLOCATE(wpath(2,n))

    !! wpath1d automatically allocated
    wpath1d = (/-111.5329602010579d0,43.90768251711403d0,  &
         -111.5425694320295d0,  43.91291520283087d0,  &
         -111.5265517148000d0,  43.92985173935236d0,     &
         -111.4838301614854d0,  43.93342747699161d0,  &
         -111.4526923402719d0,  43.92275343741503d0,  &
         -111.4229733394132d0,  43.92102950267466d0,  &
         -111.3888345969115d0,  43.94256354582464d0,  &
         -111.3547747442403d0,  43.96012412188881d0,  &
         -111.3290981366292d0,  43.94067321304157d0,  &
         -111.3055308323582d0,  43.92361145688078d0,   &
         -111.2787647823537d0,  43.93643579897589d0,   &
         -111.2483464534973d0,  43.94374241316081d0,   &
         -111.2512048905199d0,  43.93181718339741d0,   &
         -111.3004354725815d0,  43.91434621684393d0,   &
         -111.3310923535663d0,  43.92063116805807d0,   &
         -111.3574777595737d0,  43.93748955926343d0,   &
         -111.3734430072187d0,  43.92390465892466d0,   &
         -111.3830291449872d0,  43.91639601995375d0,   &
         -111.4070584125505d0,  43.91053159674234d0,   &
         -111.4273298964650d0,  43.90372138216379d0,    &
         -111.4497771036826d0,  43.90847035302123d0,   &
         -111.4470054376565d0,  43.89319391079540d0,    &
         -111.4340292718339d0,  43.88128609194279d0,   &
         -111.4328310870467d0,  43.87453080137639d0,   &
         -111.4525518180650d0,  43.87284083784596d0,    &
         -111.4655146366021d0,  43.88648791247213d0,   &
         -111.4742548002720d0,  43.89924049270922d0,    &
         -111.4743486255008d0,  43.91523470848247d0,   &
         -111.4878354873365d0,  43.92113549058154d0,   &
         -111.5039146384135d0,  43.91948128966648d0,   &
         -111.5182133156775d0,  43.91450172601051d0,   &
         -111.5329602010579d0,  43.90768251711403d0/)   !! Last line repeats first line

    wpath = RESHAPE(wpath1d,(/2,n/))

    DO i = 1,n
       z(i) = CMPLX(wpath(1,i),wpath(2,i),kind=8)
       IF (i .GT. 1) THEN
          dz(i-1) = z(i) - z(i-1)
       ENDIF
    END DO
    xll(1) = -111.6d0
    xur(1) = -111.2d0
    xll(2) = 43.8d0
    xur(2) = 44.0d0

    DEALLOCATE(wpath)

  END SUBROUTINE set_reservoir_path

end MODULE reservoir_module


C
C $Id: bcsubd.f,v 1.4 2008-07-27 00:17:29 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE BCSUBD(BX,BY,SX,SY,TX,TY)
C
C  Do a midpoint subdivision of the input Bezier curve whose control
C  points are in BX and BY to create two Bezier curves whose control
C  points are in SX, SY and TX, TY.
C
      DIMENSION BX(4),BY(4),SX(4),SY(4),TX(4),TY(4)
C
      SX(1) = BX(1)
      SY(1) = BY(1)
      SX(2) = .5*(BX(1)+BX(2))
      SY(2) = .5*(BY(1)+BY(2))
      TMPX  = .5*(BX(2)+BX(3))
      TMPY  = .5*(BY(2)+BY(3))
      SX(3) = .5*(SX(2)+TMPX)
      SY(3) = .5*(SY(2)+TMPY)
      TX(4) = BX(4)
      TY(4) = BY(4)
      TX(3) = .5*(BX(3)+BX(4))
      TY(3) = .5*(BY(3)+BY(4))
      TX(2) = .5*(TMPX+TX(3))
      TY(2) = .5*(TMPY+TY(3))
      SX(4) = .5*(SX(3)+TX(2))
      SY(4) = .5*(SY(3)+TY(2))
      TX(1) = SX(4)
      TY(1) = SY(4)
C
      RETURN
      END


!! ------------------------------------------------------------------------- !!
!>
!! TDAC: Tsunami Data Assimilation Code
!!
!! @author
!!   Takuto Maeda
!!
!! @see
!!   Maeda  et al. (2015) GRL doi:10.1002/2015GL065588
!!   Gusman et al. (2016) GRL doi:10.1002/2016GL068368
!<
!! --
program tdac

  use m_params
  use m_llw2d
  use m_matrix

  implicit none
  character(256) :: title_da  = "da"   !< output file title
  character(256) :: title_syn = "syn"  !< output file title for synthetic data

  !! control parameters for optimum interpolations: See document
  real(DP), parameter :: RHO = 1.     !< Ratio between obs and bg error
  real(DP), parameter :: RR  = 20000. !< Cutoff distance of error covariance (m)

  !! model sizes
  integer, parameter :: NN = 3*Nx*Ny
  integer, parameter :: NTMAX = 3000  !< #time step

  !! visualization
  integer, parameter :: ntdec = 10 !< decimation factor for visualization

  !! Model vector for data assimilation
  !!   m*(        1:  Nx*Ny): tsunami height eta(nx,ny)
  !!   m*(  Nx*Ny+1:2*Nx*Ny): vertically integrated velocity Mx(nx,ny)
  !!   m*(2*Nx*Ny+1:3*Nx*Ny): vertically integrated velocity Mx(nx,ny)
  real(DP), allocatable :: mf(:)  !< model vector: forecasted
  real(DP), allocatable :: ma(:)  !< model vector: data-assimilated
  real(DP), allocatable :: mt(:)  !< model vector: true wavefield (observation)

  real(DP), allocatable :: ww(:,:)         !< weight matrix
  real(DP), allocatable :: yt(:)           !< observed tsunami height
  real(DP), allocatable :: yf(:)           !< forecasted tsunami height
  real(DP), allocatable :: d_obs(:)        !< Forecast-observation residual
  integer,  allocatable :: ist(:), jst(:)  !< station location in digital grids
  integer  :: it
  !! ----

  !!
  !! memory allocation
  !!
  allocate( mf(NN), ma(NN), mt(NN) )
  allocate( ww(NN,No) )
  allocate( yt(No), yf(No) )
  allocate( d_obs(No) )
  allocate( ist(No), jst(No))

  mf = 0.0
  mt = 0.0
  ma = 0.0

  !!
  !! Set up tsunami model
  !!
  call llw2d__setup() ! obtain initial tsunami height
  call llw2d__initheight(mt(1:nx*ny))
  call llw2d__set_stations(ist, jst)

  !!
  !! Calculate weight matrix used in the data assimilation
  !!
  call set_weight()

  !!
  !! Time-marching of tsunami wavefiled & data assimilation
  !!
  do it=1, NTMAX

    if( mod(it-1, ntdec) == 0 ) then
      write(STDERR,* ) "timestep = ", it
    end if

    !!
    !! save tsunami wavefield snapshot for visualization
    !!   note that m*(1:Nx*Ny) corresponds to the tsunami height
    !!
    ! assimilation
    if ( mod(it-1, ntdec) == 0 ) then
      call llw2d__output_snap(ma(1:nx*ny), (it-1)/ntdec, title_da)
      call llw2d__output_snap(mt(1:nx*ny), (it-1)/ntdec, title_syn)
    endif

    !! Retrieve "observation" data from synthetic true wavefield
    !!   This part is specialized for synthetic test.
    !!   This example code calculates synthetic data parallel to
    !!   the data assimilation and use it as "observed" data.
    !!   This part can be substituted by real observation data.

    call tsunami_update( mt, mt )  !! integrate true synthetic wavefield

    call get_obs( mt, yt )             !! generate observed data

    !!
    !! Forecast-Assimilate
    !!

    !! tsunami forecast
    call tsunami_update( ma, mf ) !< ma-->mf forecasting

    !! Retrieve forecasted tsunami waveform data at stations
    call get_obs( mf, yf )

    !! Residual
    d_obs(:) = yt(:) - yf(:)

    !! Assimilation
    ma = mf + matmul( ww, d_obs )

  end do

contains

  !! ----------------------------------------------------------------------- !!
  !>
  !! Weight matrix based on the Optimum Interpolation method
  !<
  !! --
  subroutine set_weight

    real(DP), allocatable :: mu_bgo(:,:)
    real(DP), allocatable :: mu_boo(:,:)
    real(DP) :: mat(No,No)
    integer  :: ii, jj, i, j, ig
    real(DP) :: dist

    allocate( mu_bgo(nn,no))
    allocate( mu_boo(no,no ))
    mu_bgo(:,:) = 0.0
    mu_boo(:,:) = 0.0

    !! Estimate background error between numerical grid and station
    do ig=1, Nx*Ny
      do i=1, No

        !!
        !! Background error depend on spatial distance
        !!

        !! Gaussian correlation function
        ii = mod( ig, Nx )
        jj = (ig - ii)/Nx + 1
        call get_distance(ist(i), jst(i), ii, jj, dist)
        mu_bgo(ig,i) = exp( - (dist/RR)**2 )
      end do
    end do

    !! Estimate background error between stations
    do j=1, No
      do i = 1, No
        !! Gaussian correlation function
        call get_distance( ist(i), jst(i), ist(j), jst(j), dist )
        mu_boo(i,j) = exp( - (dist/RR)**2 )
      end do
    end do

    !! Calculate inverse matrix for obtaining weight matrix
    do j=1, No
      do i=1, No
        mat(i,j) = mu_boo(i,j)
        if(i==j) mat(i,j) = mat(i,j) + rho**2
      end do
    end do

    !! invert weight vector
    do ig=1, 3*nx*ny
      call matrix__gs(no, mat, mu_bgo(ig,:), ww(ig,:))
    end do

    deallocate( mu_bgo, mu_boo )

  end subroutine set_weight
  !! ----------------------------------------------------------------------- !!

  !! ----------------------------------------------------------------------- !!
  !>
  !! grid-to-grid distance
  !<
  !! --
  subroutine get_distance( i0, j0, i1, j1, dist )

    integer, intent(in) :: i0, j0, i1, j1
    real(DP), intent(out) :: dist

    dist = sqrt( ( (i0-i1)*dx )**2 + ( (j0-j1)*dy )**2  )

  end subroutine get_distance
  !! ----------------------------------------------------------------------- !!

  !! ----------------------------------------------------------------------- !!
  !>
  !! Return waveform data at stations from given model parameter matrix
  !<
  !! --
  subroutine get_obs( mm, obs )
    real(DP), intent(in) :: mm(NN)
    real(DP), intent(out) :: obs(No)
    integer :: i, ii, jj, iptr

    do i=1,No
      ii = ist(i)
      jj = jst(i)
      iptr = (jj-1) * Nx + ii
      obs(i) = mm( iptr )
    end do

  end subroutine get_obs
  !! ----------------------------------------------------------------------- !!

  !! ----------------------------------------------------------------------- !!
  !>
  !! Integrate linear long-wave equation for updating tsunami model
  !<
  !! --
  subroutine tsunami_update( xa, xf )

    real(DP), target, intent(inout) :: xa(nn)  !< input: assimilated
    real(DP), target, intent(inout) :: xf(nn)  !< output: forecasted

    real(DP), pointer :: eta_a(:)
    real(DP), pointer :: mm_a(:)
    real(DP), pointer :: nn_a(:)
    real(DP), pointer :: eta_f(:)
    real(DP), pointer :: mm_f(:)
    real(DP), pointer :: nn_f(:)
    integer :: nn = nx*ny

    eta_a => xa(1:nn)
    mm_a  => xa(nn+1:2*nn)
    nn_a  => xa(2*nn+1:3*nn)
    eta_f => xf(1:nn)
    mm_f  => xf(nn+1:2*nn)
    nn_f  => xf(2*nn+1:3*nn)

    !! Parts of model vector are aliased to tsunami heiht and velocities
    call llw2d__timestep( eta_a, mm_a, nn_a, eta_f, mm_f, nn_f )

  end subroutine tsunami_update
  !! ----------------------------------------------------------------------- !!

end program tdac
!! ------------------------------------------------------------------------- !!