c-----------------------------------------------------------------------
        function crvdist(npts, bsx, bsy, s1, s2,
     &                   nknot, xknot, yknot, korder, ncoef)
c-----------------------------------------------------------------------
        implicit real (a-h,o-z)
        dimension bsx(ncoef), bsy(ncoef)
        dimension xknot(nknot), yknot(nknot)
        dimension ystart(1)

        external derivs, RKQCR
c-----------------------------------------------------------------------
        crvdist = 0.0
        eps = 1.0e-10

        if (s1 .eq. s2) then
           crvdist = 0.0
           return
        end if

        ystart(1) = crvdist
        call ODEINTR(ystart, 1, s1, s2, eps, (s2-s1)*0.5, eps, nok,
     &               nbad, derivs, RKQCR)
        crvdist = ystart(1)

c       numquad = korder * 10
c       ds = (s2 - s1) / real(numquad)
c
c       x1 = BSDER( 0, s1, korder, xknot, ncoef, bsx )
c       y1 = BSDER( 0, s1, korder, yknot, ncoef, bsy )
c
c       do i = 1, numquad
c         sint = s1 + (i * ds)
c         x2 = BSDER( 0, sint, korder, xknot, ncoef, bsx )
c         y2 = BSDER( 0, sint, korder, yknot, ncoef, bsy )
c         crvdist = crvdist + sqrt( (x2 - x1)**2 + (y2 - y1)**2 )
c         x1 = x2
c         y1 = y2
c       end do

        return
        end

c-----------------------------------------------------------------------
        subroutine derivs(nl, arcl, sl, darcl)
c-----------------------------------------------------------------------
        parameter (mpts=1024)
        dimension s(mpts), t(mpts,2)
        parameter (kmax = 8)
        dimension xknot(kmax+mpts), yknot(kmax+mpts)
        common /bspline/  npts, t, darc, s1, s2, s, nknot, xknot, yknot,
     &                    korder, ncoef

        external bsder
c-----------------------------------------------------------------------
        dxds = BSDER( 1, sl, korder, xknot, ncoef, t(1,1) )
        dyds = BSDER( 1, sl, korder, yknot, ncoef, t(1,2) )

        darcl = sqrt( dxds**2 + dyds**2 )

        return
        end

c-----------------------------------------------------------------------
        function crvarc(npts, s, bsx, bsy, nknot, xknot, yknot,
     &                  korder, ncoef, arcl)
c-----------------------------------------------------------------------
        implicit real (a-h,o-z)
        dimension s(npts), bsx(ncoef), bsy(ncoef), arcl(npts)
        dimension xknot(nknot), yknot(nknot)
c-----------------------------------------------------------------------
        numquad = korder * 10
        crvarc = 0.0
        arcl(1) = 0.0

        do i = 2, npts
          arcl(i) = arcl(i-1)
          s1 = s(i-1)
          s2 = s(i)
          ds = (s2 - s1) / real(numquad)

          arcl(i) = arcl(i-1) + crvdist(npts, bsx, bsy, s1, s2,
     &              nknot, xknot, yknot, korder, ncoef)

c         x1 = BSDER( 0, s1, korder, xknot, ncoef, bsx )
c         y1 = BSDER( 0, s1, korder, yknot, ncoef, bsy )
c         do iquad = 1, numquad
c           sint = s1 + real(iquad)*ds
c           x2 = BSDER( 0, sint, korder, xknot, ncoef, bsx )
c           y2 = BSDER( 0, sint, korder, yknot, ncoef, bsy )
c           arcl(i) = arcl(i) + sqrt( (x2 - x1)**2 + (y2 - y1)**2 )
c           x1 = x2
c           y1 = y2
c         end do

        end do

        crvarc = arcl(npts)

        return
        end

c---------------------------------------------------------------------
        function gets()
c---------------------------------------------------------------------
        implicit real (a-h,o-z)

        parameter (mpts=1024)
        dimension s(mpts), t(mpts,2)
        parameter (kmax = 8)
        dimension xknot(kmax+mpts), yknot(kmax+mpts)
        common /bspline/ npts, t, darc, s1, s2, s, nknot, xknot, yknot,
     &                   korder, ncoef

        external rtsec, func
c---------------------------------------------------------------------

        gets = rtsec(func,s1,s2,1.0e-10)

        return
        end

c---------------------------------------------------------------------
        function func(sint)
c---------------------------------------------------------------------
        implicit real (a-h,o-z)

        parameter (mpts=1024)
        dimension s(mpts), t(mpts,2)
        parameter (kmax = 8)
        dimension xknot(kmax+mpts), yknot(kmax+mpts)
        common /bspline/ npts, t, darc, s1, s2, s, nknot, xknot, yknot,
     &                   korder, ncoef

        external crvdist
c---------------------------------------------------------------------

        func = darc - crvdist(npts, t(1,1), t(1,2), s1, sint,
     &                        nknot, xknot, yknot, korder, ncoef)

        return
        end


! 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 :: RECTIFY_AT = 0.0_REAL64
  ! Value for bias base (in terms of standard deviation for unit
  !  variance data), default value is 2.
  REAL(KIND=REAL64), PARAMETER :: BIAS_VALUE = 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

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(DATA, SEED)
    REAL(KIND=REAL64), DIMENSION(:,:), INTENT(IN), OPTIONAL :: DATA
    INTEGER, INTENT(IN), OPTIONAL :: SEED
    INTEGER :: I
    ! Storage for data-related statistics for high quality initialization.
    REAL(KIND=REAL64), DIMENSION(:),   ALLOCATABLE :: SCALE, RANGE
    REAL(KIND=REAL64), DIMENSION(:,:), ALLOCATABLE :: DATA_VALUES
    !  Storage for seeding the random number generator (for repeatability).
    INTEGER, DIMENSION(:), ALLOCATABLE :: SEED_ARRAY
    ! 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
    ! Set input biases so that the surface produced by the rectified linear
    !  functions produce well spaced simplices (not too many near origin).
    INPUT_BIAS(:) = BIAS_VALUE * INPUT_BIAS(:) ** (1.0_REAL64 / REAL(MDS,REAL64))
    ! Internal biases will depend on vector direction, they will
    !  need to be in this range, but this will disable many.
    INTERNAL_BIAS(:,:) = BIAS_VALUE * INTERNAL_BIAS(:,:) * 2.0_REAL64 - BIAS_VALUE

  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

  END SUBROUTINE INIT_MODEL

  ! 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 and lists of which ones are nonzero.
    REAL(KIND=REAL64), DIMENSION(MDS) :: INTERNAL_VALUES
    INTEGER, DIMENSION(MDS) :: NONZEROS
    ! Compute the number of nodes (to know where "bias" value is).
    INTEGER :: I, IP1, J, K
    ! Compute the input layer.
    INTERNAL_VALUES(:) = MAX(RECTIFY_AT, INPUT_BIAS(:) + &
         MATMUL(INPUT(:), INPUT_PARAMS(:,:)))
    ! Store the number of nonzero values and their locations.
    K = 0
    DO J = 1, MDS
       IF (INTERNAL_VALUES(J) .NE. 0.0_REAL64) THEN
          K = K + 1
          NONZEROS(K) = J
       END IF
    END DO
    ! Compute the next set of internal values with a rectified activation.
    DO I = 1, MNS-1
       IP1 = I+1
       INTERNAL_VALUES(:) = MAX(RECTIFY_AT, INTERNAL_BIAS(:,I) + &
            MATMUL(INTERNAL_VALUES(NONZEROS(1:K)), &
            INTERNAL_PARAMS(NONZEROS(1:K),:,I)))
       ! Store the number of nonzero values and their locations.
       K = 0
       DO J = 1, MDS
          IF (INTERNAL_VALUES(J) .NE. 0.0_REAL64) THEN
             K = K + 1
             NONZEROS(K) = J
          END IF
       END DO
    END DO
    ! Compute the output.
    OUTPUT(:) = OUTPUT_BIAS(:) + &
         MATMUL(INTERNAL_VALUES(NONZEROS(1:K)), &
         OUTPUT_PARAMS(NONZEROS(1:K),:))
  END SUBROUTINE EVALUATE_ONE

  ! 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
    ! Number of points.
    REAL(KIND=REAL64) :: N

    ! Evaluate the model at all data points, store outputs in "OUTPUT_GRADIENT"
    CALL EVALUATE_BATCH()
    ! Compute the new gradient.
    OUTPUT_GRADIENT(:,:) = OUTPUT_GRADIENT(:,:) - TRANSPOSE(OUTPUTS(:,:))
    ! 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
      ! Compute the input transformation.
      INTERNAL_VALUES(:,:,1) = MATMUL(TRANSPOSE(INPUTS(:,:)), INPUT_PARAMS(:,:))
      DO D = 1, MDS
         INTERNAL_VALUES(:,D,1) = MAX(RECTIFY_AT, &
              INPUT_BIAS(D) + INTERNAL_VALUES(:,D,1))
      END DO
      ! Compute the next set of internal values with a rectified activation.
      DO L = 1, MNS-1
         LP1 = L+1
         INTERNAL_VALUES(:,:,LP1) = MATMUL(INTERNAL_VALUES(:,:,L), INTERNAL_PARAMS(:,:,L))
         DO D = 1, MDS
            INTERNAL_VALUES(:,D,LP1) = MAX(RECTIFY_AT, &
                 INTERNAL_BIAS(D,L) + INTERNAL_VALUES(:,D,LP1))
         END DO
      END DO
      ! Compute the output.
      OUTPUT_GRADIENT(:,:) = MATMUL(INTERNAL_VALUES(:,:,MNS), OUTPUT_PARAMS(:,:))
      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
      ! Compute the average output gradient.
      OUTPUT_BIAS_GRADIENT(:) = SUM(OUTPUT_GRADIENT(:,:), 1) / N &
           + OUTPUT_BIAS_GRADIENT(:)
      ! Compute output parameter gradients.
      OUTPUT_PARAMS_GRADIENT(:,:) = MATMUL( &
           TRANSPOSE(INTERNAL_VALUES(:,:,MNS)), OUTPUT_GRADIENT(:,:)) / N &
           + OUTPUT_PARAMS_GRADIENT(:,:)
      ! Compute the gradient for the last internal vector space values.
      WHERE ( INTERNAL_VALUES(:,:,MNS) .GT. RECTIFY_AT )
         INTERNAL_VALUES(:,:,MNS) = MATMUL( &
              OUTPUT_GRADIENT(:,:), TRANSPOSE(OUTPUT_PARAMS(:,:)))
      ELSEWHERE
         INTERNAL_VALUES(:,:,MNS) = 0.0_REAL64
      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.
         INTERNAL_PARAMS_GRADIENT(:,:,L) = MATMUL( &
              TRANSPOSE(INTERNAL_VALUES(:,:,L)), INTERNAL_VALUES(:,:,LP1)) / N &
              + INTERNAL_PARAMS_GRADIENT(:,:,L)
         ! Propogate the gradient to the immediately preceding layer.
         WHERE (INTERNAL_VALUES(:,:,L) .GT. RECTIFY_AT )
            INTERNAL_VALUES(:,:,L) = MATMUL( &
                 INTERNAL_VALUES(:,:,LP1), TRANSPOSE(INTERNAL_PARAMS(:,:,L)))
         ELSEWHERE
            INTERNAL_VALUES(:,:,L) = 0.0_REAL64
         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)]
      INPUT_PARAMS_GRADIENT(:,:) = MATMUL( &
           INPUTS(:,:), INTERNAL_VALUES(:,:,1)) / N &
           + INPUT_PARAMS_GRADIENT(:,:)
    END SUBROUTINE GRADIENT_BATCH

  END SUBROUTINE SSE_GRADIENT

  ! Fit input / output pairs by minimizing mean squared error.
  SUBROUTINE MINIMIZE_MSE(X, Y, STEPS, MAX_BATCH_SIZE, MEAN_SQUARED_ERROR)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: X
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: Y
    INTEGER, INTENT(IN), OPTIONAL :: STEPS, MAX_BATCH_SIZE
    REAL(KIND=REAL64), INTENT(OUT) :: MEAN_SQUARED_ERROR
    ! Local variables.
    REAL(KIND=REAL64), PARAMETER :: STEP_FACTOR = 0.01_REAL64
    !  gradient step arrays
    REAL(KIND=REAL64), DIMENSION(MDI,MDS)       :: INPUT_PARAMS_GRADIENT_STEP
    REAL(KIND=REAL64), DIMENSION(MDS)           :: INPUT_BIAS_GRADIENT_STEP
    REAL(KIND=REAL64), DIMENSION(MDS,MDS,MNS-1) :: INTERNAL_PARAMS_GRADIENT_STEP
    REAL(KIND=REAL64), DIMENSION(MDS,MNS-1)     :: INTERNAL_BIAS_GRADIENT_STEP
    REAL(KIND=REAL64), DIMENSION(MDS,MDO)       :: OUTPUT_PARAMS_GRADIENT_STEP
    REAL(KIND=REAL64), DIMENSION(MDO)           :: OUTPUT_BIAS_GRADIENT_STEP
    ! Internal values and lists of which ones are nonzero.
    REAL(KIND=REAL64), DIMENSION(SIZE(X,2),MDS,MNS) :: INTERNAL_VALUES
    INTEGER, DIMENSION(SIZE(X,2),MDS,MNS) :: NONZEROS
    INTEGER, DIMENSION(SIZE(X,2),MNS) :: NUM_NONZERO
    !  storage for the gradient of the error function
    REAL(KIND=REAL64), DIMENSION(SIZE(X,2),MDO) :: OUTPUT_GRADIENT
    !  local integers
    INTEGER :: B, I, S, BATCH_END, BATCHES, BATCH_SIZE
    ! Set the number of steps.
    IF (PRESENT(STEPS)) THEN ; S = STEPS
    ELSE                     ; S = 1000
    END IF
    ! Set the batch size.
    IF (PRESENT(MAX_BATCH_SIZE)) THEN
       BATCH_SIZE = MIN(MAX_BATCH_SIZE, SIZE(X,2))
    ELSE
       BATCH_SIZE = (SIZE(X,2) + 3) / 4
    END IF
    ! Iterate, taking steps with the average gradient over all data.
    DO I = 1, S
       ! Compute the average gradient over all points.
       MEAN_SQUARED_ERROR = 0.0_REAL64
       ! Set gradients to zero initially.
       INPUT_PARAMS_GRADIENT_STEP = 0.0_REAL64
       INPUT_BIAS_GRADIENT_STEP   = 0.0_REAL64
       INTERNAL_PARAMS_GRADIENT_STEP = 0.0_REAL64
       INTERNAL_BIAS_GRADIENT_STEP   = 0.0_REAL64
       OUTPUT_PARAMS_GRADIENT_STEP = 0.0_REAL64
       OUTPUT_BIAS_GRADIENT_STEP   = 0.0_REAL64

       BATCHES = 0
       !$OMP PARALLEL DO PRIVATE(BATCH_END) REDUCTION(+: BATCHES, &
       !$OMP&  MEAN_SQUARED_ERROR, &
       !$OMP&  INPUT_PARAMS_GRADIENT_STEP, INPUT_BIAS_GRADIENT_STEP, &
       !$OMP&  INTERNAL_PARAMS_GRADIENT_STEP, INTERNAL_BIAS_GRADIENT_STEP, &
       !$OMP&  OUTPUT_PARAMS_GRADIENT_STEP, OUTPUT_BIAS_GRADIENT_STEP)
       DO B = 1, SIZE(X,2), BATCH_SIZE
          BATCHES = BATCHES + 1
          BATCH_END = MIN(SIZE(X,2), B+BATCH_SIZE-1)
          ! Compute the gradient from all data.
          CALL SSE_GRADIENT(X(:,B:BATCH_END), Y(:,B:BATCH_END), &
               MEAN_SQUARED_ERROR, &
               INPUT_PARAMS_GRADIENT_STEP, INPUT_BIAS_GRADIENT_STEP, &
               INTERNAL_PARAMS_GRADIENT_STEP, INTERNAL_BIAS_GRADIENT_STEP, &
               OUTPUT_PARAMS_GRADIENT_STEP, OUTPUT_BIAS_GRADIENT_STEP)
       END DO
       !$OMP END PARALLEL DO

       ! Convert the sum of squared errors into the mean squared error.
       MEAN_SQUARED_ERROR = MEAN_SQUARED_ERROR / REAL(SIZE(X,2), REAL64)
       ! Shrink the gradient to take smaller steps, and take
       !  the gradient step based on the average gradient.
       INPUT_PARAMS    = INPUT_PARAMS    - STEP_FACTOR * INPUT_PARAMS_GRADIENT_STEP    / REAL(BATCHES,REAL64)
       INPUT_BIAS      = INPUT_BIAS      - STEP_FACTOR * INPUT_BIAS_GRADIENT_STEP      / REAL(BATCHES,REAL64)
       INTERNAL_PARAMS = INTERNAL_PARAMS - STEP_FACTOR * INTERNAL_PARAMS_GRADIENT_STEP / REAL(BATCHES,REAL64)
       INTERNAL_BIAS   = INTERNAL_BIAS   - STEP_FACTOR * INTERNAL_BIAS_GRADIENT_STEP   / REAL(BATCHES,REAL64)
       OUTPUT_PARAMS   = OUTPUT_PARAMS   - STEP_FACTOR * OUTPUT_PARAMS_GRADIENT_STEP   / REAL(BATCHES,REAL64)
       OUTPUT_BIAS     = OUTPUT_BIAS     - STEP_FACTOR * OUTPUT_BIAS_GRADIENT_STEP     / REAL(BATCHES,REAL64)
    END DO
  END SUBROUTINE MINIMIZE_MSE

END MODULE PLRM


C----------------------------------------------------------------
C Set of subroutines used by KING1, HUBBLE and SHELL
C Contains : BROADEN, STORE_GRAPH,
C PROJECT_ABEL0, PROJECT_ABEL, PROJECT_ABEL1, PROJECT_ABEL3,
C SPLINELOGFIT, SPLINEFIT, and EXTRAPOL_2,
C SPLINELOG_INTER, and SPLINE_INTER.
C IDIM=6000
C_________________________________________________________________

	SUBROUTINE BROADEN(RAD1,SS,NPTS,SIGMA)
C_________________________________________________________________
C   Broadens the surface brightness using the Hankel transform of
C a gaussian Point Spread Function
C (From SAUL CAGANOFF's program.)
C
C  Version of October 8th 1986. Corrected from a previous bad normalization
C
C Input :
C   RAD1 : real*8 array with the radii
C   SS : real*8 array with the surface brightness
C   NPTS : number of points (remains unchanged)
C   SIGMA : sigma of the point response function
C
C Output :
C   SS : real*8 array with the broadened surface brightness
C---------------------------------------------------------------------
	PARAMETER (IDIM=6000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 S(IDIM),SS(IDIM),Y(IDIM),RAD1(IDIM),ERR(IDIM)
	REAL*8 WEIGHT(IDIM)
	PI=3.14159265358979323846
	PI1=DSQRT(2.D0*PI)
	SIGMA2=SIGMA*SIGMA

C Doesn't bother broadening if SIGMA=0.
	IF (SIGMA.LE.0.0D0)THEN
	PRINT *,' SIGMA EQUALS 0. : MODEL NOT BROADENED'
	RETURN
	ENDIF

C________________________________________________________________
	PRINT *,' BROADENING THE DENSITY...'

	DO J=1,NPTS
	X1=RAD1(J)

	DO 200 I=1,NPTS
	X2=RAD1(I)
	WTEST=(DABS(X1-X2))/(10.D0*SIGMA)
C Limit at 10. sigma
	IF(WTEST.GT.1.D0)THEN
	Y(I)=0.D0
	WEIGHT(I)=0.D0
	GO TO 200
	ENDIF
	Z=X1*X2/SIGMA2
C IF Z .LT. 10 uses a modified Bessel function I0. (This function can't be
C used outside of this range)
C Y(I)=[BESSI0(Z)*DEXP[{X1**2+X2**2}/-2.D0*SIGMA2]
	IF(Z.LT.10.0D0) THEN
	     IFAIL=0
	     BESSI0=S18AEF(Z,IFAIL)
	     WORK=(X1*X1+X2*X2)/(-2.0D0*SIGMA2)
	     Y(I)=BESSI0*DEXP(WORK)
	ELSE
C Else uses the assymptotic form (wich is very close to a normal gaussian
C for large values of X1, X2.
C Y(I)=[SIGMA*Y(I)/SQRT(2*PI*X1*X2)] * DEXP[{(X2-X1)**2}/-2.D0*SIGMA**2]
	    WORK=(X2-X1)*(X2-X1)/(-2.0D0*SIGMA2)
	    Y(I)=(SIGMA*DEXP(WORK))/(PI1*DSQRT(X2*X1))
	END IF
	WEIGHT(I)=X2*Y(I)
	Y(I)=X2*Y(I)*SS(I)
C
200	CONTINUE

C Then calculates the integral with NAG/D01GAF and puts the result in S(J)
	IFAIL=0
	CALL D01GAF(RAD1,Y,NPTS,S(J),ERR(J),IFAIL)
C Normalization by integrating WEIGHT(RAD1) :
	IFAIL=0
	CALL D01GAF(RAD1,WEIGHT,NPTS,WEIGHT1,ERR1,IFAIL)
C Division by WEIGHT1 of the result :
	S(J)=S(J)/WEIGHT1
C
	END DO

	DO I=1,NPTS
	SS(I)=S(I)
	END DO

	PRINT *,' PROFILE BROADENED'
	RETURN
	END

C**********************************************************************
	SUBROUTINE STORE_GRAPH(XPLOT1,YPLOT1,NSTART1,NEND1,
	1	XPLOT2,YPLOT2,NSTART2,NEND2,KCURVE)
C---------------------------------------------------------------------
C  Version of Aug 29th 1986
C
C Input :
C   XPLOT,YPLOT : real*4 X and Y arrays
C   NSTART,NEND : indices to start and to end the display
C   KCURVE : number of curves (here 1 or 2)
C
C---------------------------------------------------------------------
	PARAMETER (IDIM=6000)
	REAL*4 XPLOT1(IDIM),YPLOT1(IDIM),XPLOT2(IDIM)
	REAL*4 YPLOT2(IDIM)
	REAL*8 WORK1,WORK2
	CHARACTER*30 NAME
10	FORMAT(A)

500	PRINT *,'NAME OF THE OUTPUT FILE ?'
	READ(5,10) NAME
	OPEN(1,FILE=NAME,STATUS='NEW',ERR=500)

	NPTS1=NEND1-NSTART1+1
	WRITE(1,*)NPTS1
	DO J=NSTART1,NEND1
	WORK1=XPLOT1(J)
	WORK2=YPLOT1(J)
	WRITE(1,*)WORK1,WORK2
	END DO

	IF(KCURVE.EQ.2)THEN
	NPTS2=NEND2-NSTART2+1
	WRITE(1,*)NPTS2
	DO J=NSTART2,NEND2
	WORK1=XPLOT2(J)
	WORK2=YPLOT2(J)
	WRITE(1,*)WORK1,WORK2
	END DO
	ENDIF

	CLOSE(1)
	RETURN
	END
C******************************************************************
	SUBROUTINE PROJECT_ABEL0(R,RHO,S,NPTS)
C_________________________________________________________________
C  Projects the density through the Abel integral to get the surface brightness
C (From SAUL CAGANOFF's program.)
C  Version of June 1986
C
C Input :
C   R : real*8 array with the radii
C   RHO : real*8 array with the density
C   NPTS : number of points (remains unchanged)
C
C Output :
C   S : real*8 array with the surface brightness
C---------------------------------------------------------------------
	PARAMETER (IDIM=6000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 R(IDIM),RHO(IDIM),S(IDIM),ERR(IDIM),Y(IDIM),
	1	X(IDIM)
	DO J=1,NPTS-1
C         JJ=NPTS-J-1
C	WRITE (6,1) JJ
C	FORMAT('+',' Projecting the density now...',I6)
C
	DO I=J+1,NPTS
	II=I-J
	X(II)=R(I)
	Y(II)=RHO(I)*R(I)/SQRT(R(I)*R(I)-R(J)*R(J))
	END DO

C Calculates the integral with NAG/D01GAF
         IFAIL=0
	NPOINT=NPTS-J
	CALL D01GAF(X,Y,NPOINT,S(J),ERR(J),IFAIL)
C	ERR(J)=ERR(J)/S(J)
	S(J)=2.0D0*S(J)
C
	END DO
	RETURN
	END

C--------------------------------------------------------------
	SUBROUTINE PROJECT_ABEL(RAD1,RHO,S,NPTS)
C_________________________________________________________________
C  Projects the density through the Abel integral to get
C  the surface brightness
C  Version of Sept 15th 1986. Modified from PROJECT_ABEL0
C
C Input :
C   RAD1 : real*8 array with the radii
C   RHO : real*8 array with the density
C   NPTS : number of points (reduced by 4 in output)
C
C Output :
C   S : real*8 array with the surface brightness
C   NPTS : Initial NPTS minus 4
C---------------------------------------------------------------------
	PARAMETER (IDIM=6000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RAD1(IDIM),RHO(IDIM),S(IDIM),ERR(IDIM),Y(IDIM)
	REAL*8 X(IDIM)
C
	DO J=1,NPTS-1
C
	   DO I=J+1,NPTS
	   II=I+1-J
	   X(II)=RAD1(I)
	   Y(II)=RHO(I)*RAD1(I)
	1	/DSQRT(RAD1(I)*RAD1(I)-RAD1(J)*RAD1(J))
	   END DO

C For I=J the integral would be undefined, so we take
C an approximation (linear interpolation of Y(1) and Y(2)
C (We take only half of this value since we multiply by
C 2 later this integral (axial symmetry)).
	   X(1)=RAD1(J)
	   Y(1)=Y(2)-0.5D0*Y(3)

C Calculates the integral (NAG/D01GAF requires at least 4 points)
	   IFAIL=0
	   IWORK=NPTS+1-J
	   IF(IWORK.GT.4)THEN
	   CALL D01GAF(X,Y,IWORK,S(J),ERR(J),IFAIL)
C	   ERR(J)=ERR(J)/S(J)
	   S(J)=2.0D0*S(J)
	   ELSE
	   S(J)=0.
	   ENDIF
C
	END DO

	NPTS=NPTS-4
	RETURN
	END
C*******************************************************************
	SUBROUTINE PROJECT_ABEL1(R,RHO,S,NPTS)
C_________________________________________________________________
C  Projects the density through the Abel integral to get the surface brightness
C  With King'quadrature (1966)
C  Version of Oct 6th 1986 : doesn't work because I don't know what t2 is ...
C
C Input :
C   R : real*8 array with the radii
C   RHO : real*8 array with the density
C   NPTS : number of points (remains unchanged)
C
C Output :
C   S : real*8 array with the surface brightness
C---------------------------------------------------------------------
	PARAMETER (IDIM=6000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 R(IDIM),RHO(IDIM),S(IDIM),ERR(IDIM),
	1	TT(IDIM),Y(IDIM),XC(20)
C
	DO J=1,NPTS-1
	X1=R(J)
	X12=X1*X1

	DO I=J+1,NPTS
	X2=R(I)
	X22=X2*X2
	II=I-J
	WORK=1.D0+X22
	TT(II)=(X22-X12)/WORK
	Y(II)=RHO(I)*(WORK**1.5)*DSQRT(WORK/(X22-X12))
	Y(II)=Y(II)/DSQRT(TT(II))
	END DO

C Calculates the integral for I > J (NAG/D01GAF)
	IFAIL=0
	NPOINT=NPTS-J
	CALL D01GAF(TT,Y,NPOINT,S(J),ERR(J),IFAIL)
	PRINT *,' J, S(J):',J,S(J)
C	ERR(J)=ERR(J)/S(J)

C And for the singularity in I=J, uses a quadrature formula : (King 1966)
C
C  / t1          -1/2             1/2
C  |    Phi(t) t     dt = 4/15 t1    [(5-(t1/t2)Phi0 + ((3t1-5t2)/2(t1-t2))Phi1
C  / 0
C                                        + {t1**2/(t2(t1-t2))}Phi2 ]

C But is there a constraint for t2 ???
C	FF0=IM(0)
C	FF1=IM(TT1)
C	FF2=IM(TT2)

	YY0=0.26666666667D0*DSQRT(TT1)*(FF0*(5.D0-(TT1/TT2)
	1	+FF1*(1.5D0*TT1-2.5D0*TT2)/(TT1-TT2))
	1	+FF2*TT1*TT1/(TT2*(TT1-TT2)))
	PRINT *,' YY0:',YY0

C Then add this value to the previous integral calculated for I > J
	S(J)=(YY0+2.0D0*S(J))/(1.D0+X12)

C
	END DO
	RETURN
	END
C--------------------------------------------------------------
	SUBROUTINE PROJECT_ABEL3(RAD1,RHO,S,NPTS)
C--------------------------------------------------------------
C  Projects the density through the Abel integral to get
C  the surface brightness
C
C  Version of Oct 6th 1986, with spline fit and better sampling.
C
C Input :
C   RAD1 : real*8 array with the radii
C   RHO : real*8 array with the density
C   NPTS : number of points (reduced by 4 in output)
C
C Output :
C   S : real*8 array with the surface brightness
C   NPTS : (Initial NPTS) - 4
C---------------------------------------------------------------------
	PARAMETER (IDIM=6000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RAD1(IDIM),RHO(IDIM),S(IDIM),ERR(IDIM),Y(IDIM)
	REAL*8 X(IDIM)
	REAL*8 K(IDIM),SPLINE(IDIM),SOL(5)
	NPOINTS=NPTS
	NUMBJ=NPOINTS-4
	DELTAJ=(RAD1(NPTS)-RAD1(J))/FLOAT(NPOINTS)

	CALL SPLINEFIT(RAD1,PHI,NPTS,SPLINE,NCAP7,K)
C
	PRINT *,'NPTS,NPOINTS,NUMBJ,DELTAJ',NPTS,NPOINTS,NUMBJ,DELTAJ

	DO J=1,NUMBJ
	RADJ=RAD1(1)+DELTAJ*FLOAT(I-1)
	NUMBI=(NPOINTS-J)*10
	DELTAI=(RAD1(NPTS)-RAD1(J))/FLOAT(NUMBI+1)
	PRINT *,' J,RADJ,NUMBI,DELTAI',J,RADJ,NUMBI,DELTAI
	   DO I=1,NUMBI
	   RADI=RADJ+DELTAI*FLOAT(I)
C (For I=J the integral is undefined)
	   LEFT=0
	   IFAIL=1
C NAG/E02BCF
	   CALL E02BCF(NCAP7,K,SPLINE,XX1,LEFT,SOL,IFAIL)
	   IF(IFAIL.NE.0)PRINT 44,IFAIL
44	FORMAT(' WARNING :  IN E02BCF  IFAIL=',I3)
	   RHOWORK=SOL(1)
	   Y(I)=RHOWORK*RADI
	1	/DSQRT(RADI*RADI-RADJ*RADJ)
	   END DO

C Calculates the integral (NAG/D01GAF requires at least 4 points)
	   IF(IWORK.GT.4)THEN
	   IFAIL=1
	   CALL D01GAF(X,Y,IWORK,S(J),ERR(J),IFAIL)
	   IF(IFAIL.NE.0)PRINT 47,IFAIL
47	FORMAT(' WARNING :  IN D01GAF  IFAIL=',I3)
C	   ERR(J)=ERR(J)/S(J)
	   S(J)=2.0D0*S(J)
	   ELSE
	   S(J)=0.
	   ENDIF
C
	END DO

	NPTS=NPTS-4
	RETURN
	END
C*******************************************************************
	SUBROUTINE SPLINELOGFIT(RAD,SS,NPTS,SPLINE,NCAP7,K)
C
C   Fits a spline to the surface density of the calculated
C   profile as a function of LOG10(r/rcore).
C
	PARAMETER (IDIM=6000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 SPLINE(IDIM),K(IDIM),RAD(IDIM),SS(IDIM)
	REAL*8 LOGSS(IDIM),LOGRAD(IDIM),W(IDIM)
	REAL*8 WORK1(IDIM),WORK2(4,IDIM)

C Transformation in Log10/Log10 :
	DO I=1,NPTS
	IF(SS(I).GT.0.D0)THEN
	LOGSS(I)=DLOG10(SS(I))
	ELSE
	NPTS=I-1
	PRINT 200
200	FORMAT(' WARNING : NEGATIVE VALUES IN Y')
	GO TO 100
	ENDIF
	IF(RAD(I).GT.0.)THEN
	LOGRAD(I)=DLOG10(RAD(I))
	ELSE
	NPTS=I-1
	PRINT 201
201	FORMAT(' WARNING : NEGATIVE VALUES IN X')
	GO TO 100
	ENDIF
	END DO

100	PRINT *,' Calling NAG/E02BAF :  NPTS =',NPTS
C
      DO I=1,NPTS
         W(I)=1.0D0                    	! define the weights.
      END DO
C
C     Define the knots to lie on every fifth point.
C
      N=5           ! knots at every fifth data point.
      J=5           ! E02BAF wants the (I-4)th knot in K(I).
      DO I=5,NPTS-1
           IF(MOD(I,N).EQ.0) THEN
              K(J)=LOGRAD(I)
              J=J+1
           END IF
      END DO
C
C   NCAP7 : Number of intervals of the spline fit +7
C
      NCAP7=J+3
      IFAIL=1
C
C Generates the array SPLINE of the spline function
C
	CALL E02BAF (NPTS,NCAP7,LOGRAD,LOGSS,W,K,WORK1,WORK2,
	1	SPLINE,RMS,IFAIL)
	IF(IFAIL.NE.0)PRINT 44,IFAIL
44	FORMAT(' WARNING :  IN NAG/E02BAF  IFAIL=',I3)
	RMS=SQRT(RMS)/FLOAT(NPTS-1)
	WRITE (6,99) RMS
99	FORMAT(' RMS FOR SPLINE FIT = ',E12.5)
	RETURN
	END
C*******************************************************************
	SUBROUTINE SPLINEFIT(RAD,SS,NPTS,SPLINE,NCAP7,K)
C
C   Fits a spline to the surface density of the calculated
C   profile
C
	PARAMETER (IDIM=6000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 SPLINE(IDIM),K(IDIM),RAD(IDIM),SS(IDIM)
	REAL*8 WORK1(IDIM),WORK2(4,IDIM),W(IDIM)

C Defines the weights :
	DO I=1,NPTS-1
	W(I)=1.0D0
	END DO
C
C     Define the knots to lie on every fifth point.
C
      N=5           ! knots at every fifth data point.
      J=5           ! E02BAF wants the (I-4)th knot in K(I).
	DO I=5,NPTS-2
           IF(MOD(I,N).EQ.0) THEN
	   K(J)=RAD(I)
	   J=J+1
           END IF
	END DO
C
C   NCAP7 : Number of intervals of the spline fit +7
C
      NCAP7=J+3
      NPTS=NPTS-1
      IFAIL=1
C
C Generates the array SPLINE of the spline function
C
	CALL E02BAF (NPTS,NCAP7,RAD,SS,W,K,WORK1,WORK2,
	1	SPLINE,RMS,IFAIL)
	IF(IFAIL.NE.0)PRINT 44,IFAIL
44	FORMAT(' WARNING :  IN NAG/E02BAF  IFAIL=',I3)
	RMS=SQRT(RMS)/FLOAT(NPTS-1)
	WRITE (6,99) RMS
99	FORMAT(' RMS FOR SPLINE FIT = ',E12.5)
	RETURN
	END
C-----------------------------------------------------------------
C SUBROUTINE EXTRAPOL_2 : For second order extrapolation
C Version : October 4th 1986
C
C Resolution of the system
C
C  [ X1**2  X1  1 ]  [ COEF1 ]     [ Y1 ]
C  [ X2**2  X2  1 ]  [ COEF2 ]  =  [ Y2 ]
C  [ X3**2  X3  1 ]  [ COEF3 ]     [ Y3 ]
C
C [ I.E    COEF1*(X**2) + COEF2*X + COEF3 = Y ]
C-----------------------------------------------------------------
	SUBROUTINE EXTRAPOL_2(X1,X2,X3,Y1,Y2,Y3,COEF1,COEF2,COEF3)

	X12=X1-X2
	X23=X2-X3

	XX12=X1*X1-X2*X2
	XX23=X2*X2-X3*X3

	Y12=Y1-Y2
	Y23=Y2-Y3

	COEF1=(Y12*X23-Y23*X12)/(XX12*X23-XX23*X12)
	COEF2=(Y23-COEF1*XX23)/X23
	COEF3=Y3-COEF2*X3-COEF1*X3*X3

	RETURN
	END
C---------------------------------------------------------------------------
C Function PROJABEL
C---------------------------------------------------------------------------
	FUNCTION PROJABEL(RADIUS,RADSHELL,SIGMA,ANGLE)
	IMPLICIT REAL*8(A-H,O-Z)
	DIMENSION W(4000),IW(502)
	REAL*4 PROJSHELL,RADIUS,RADSHELL,SIGMA,ANGLE
	COMMON/BLKA/Y,RS,SIG,ANG
	EXTERNAL ALFUNC
	Y=RADIUS
	RS=RADSHELL
	SIG=SIGMA
        ANG=ANGLE
C Absolute and relative accuracy :
        EPSABS=0.0001
        EPSREL=0.001
C sizes of the work areas W(real) and IW(integer)
        LW=4000
        LIW=502
C Lower and upper values for the integration
        XLOW=DMAX1(Y,(RS-8.0D0*SIG))
        XHIGH=DMAX1(RS,Y)+8.0D0*SIG
C Rather sophisticated integration routine NAG/D01AKF :
        IFAIL=1
        CALL D01AKF(ALFUNC,XLOW,XHIGH,EPSABS,EPSREL,AL,ABSERR,W,LW,
	1	IW,LIW,IFAIL)
	AL=AL/SIG
        IF(IFAIL.NE.0) THEN
          PRINT *,' WARNING : FAILURE IN NAG/D01AKF,  IFAIL =',IFAIL
        END IF
        PROJSHELL=AL
	RETURN
	END
C---------------------------------------------------------------------------
C Function ALFUNC
C Called by D0AKF
C Generates the value to be integrated at the point X
C---------------------------------------------------------------------------
	DOUBLE PRECISION FUNCTION ALFUNC(X)
	IMPLICIT REAL*8(A-H,O-Z)
	COMMON/BLKA/Y,RS,SIG,ANG
	Z1=((X-RS)*(X-RS)/(2.0D0*SIG*SIG))
	Z3=DEXP(-Z1)
	Z4=DACOS(Y/X)
	IF(ABS(Z4).LT.ANG) THEN
	 Z5=1.0
	ELSE
	 Z5=0.0
	END IF
	Z2=DSQRT(X*X-Y*Y)
	ALFUN=(X*Z3*Z5)/Z2
	RETURN
	END
C*******************************************************************
	SUBROUTINE SPLINELOG_INTER(RAD,SS,NPTS,SPLINE,NCAP7,K)
C
C   Determines a cubic-spline interpolant to a given set of data
C   after transforming it into Log10/Log10
C
C   Uses NAG routine E01BAF.
C   In input the array X must be in increasing order.
C   CALL E01BAF(M,X,Y,K,C,LCK,WRK,LWRK,IFAIL)
C   From it you can get the value at x calling :
C   CALL E02BBF(M+4,K,C,XVALUE,SVALUE) Output in SVALUE)
C   or the value and its first three derivatives in the array SDIF (dim=4),
C   CALL E02BCF(M+4,K,C,XVALUE,LEFT,SDIF,IFAIL)
C   or the integral of S(x) over the full range (from the first to the last
C   knot) in SINT (real*8) :
C   CALL E02BDF(M+4,K,C,SINT,IFAIL)
C
	PARAMETER (IDIM=10000)
	PARAMETER (IDIM1=61000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 SPLINE(IDIM),K(IDIM),SS(IDIM),WORK1(IDIM1)
	REAL*8 LOGSS(IDIM),LOGRAD(IDIM),RAD(IDIM)

C Transformation in Log10/Log10 :
	DO I=1,NPTS
	IF(SS(I).GT.0.D0)THEN
	LOGSS(I)=DLOG10(SS(I))
	ELSE
	NPTS=I-1
	PRINT 200
200	FORMAT(' WARNING : NEGATIVE VALUES IN Y')
	GO TO 100
	ENDIF
	IF(RAD(I).GT.0.)THEN
	LOGRAD(I)=DLOG10(RAD(I))
	ELSE
	NPTS=I-1
	PRINT 201
201	FORMAT(' WARNING : NEGATIVE VALUES IN X')
	GO TO 100
	ENDIF
	END DO

100	PRINT *,' Calling NAG/E01BAF :  NPTS =',NPTS
C
C Generates the array SPLINE of the spline function
C K array of the knots (dimension : NCAP7=NPTS+4)
	NCAP7=NPTS+4
	IFAIL=1
	CALL E01BAF(NPTS,LOGRAD,LOGSS,K,SPLINE,IDIM,WORK1,
	1	IDIM1,IFAIL)
	IF(IFAIL.NE.0)PRINT 45,IFAIL
45	FORMAT(' ****** WARNING **** IN NAG/E01BAF  IFAIL=',I3)
	RETURN
	END
C*******************************************************************
	SUBROUTINE SPLINE_INTER(RAD,SS,NPTS,SPLINE,NCAP7,K)
C
C   Determines a cubic-spline interpolating to a given set of data
C
C   Uses NAG routine E01BAF.
C   In input the array X must be in increasing order.
C   CALL E01BAF(M,X,Y,K,C,LCK,WRK,LWRK,IFAIL)
C   From it you can get the value at x calling :
C   CALL E02BBF(M+4,K,C,XVALUE,SVALUE) Output in SVALUE)
C   or the value and its first three derivatives in the array SDIF (dim=4),
C   CALL E02BCF(M+4,K,C,XVALUE,LEFT,SDIF,IFAIL)
C   or the integral of S(x) over the full range (from the first to the last
C   knot) in SINT (real*8) :
C   CALL E02BDF(M+4,K,C,SINT,IFAIL)
C
	PARAMETER (IDIM=10000)
	PARAMETER (IDIM1=61000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 SPLINE(IDIM),K(IDIM),WORK1(IDIM1)
	REAL*8 SS(IDIM),RAD(IDIM)
C
C Generates the array SPLINE of the spline function
C K array of the knots (dimension : NCAP7=NPTS+4)
	NCAP7=NPTS+4
	IFAIL=1
	CALL E01BAF(NPTS,RAD,SS,K,SPLINE,IDIM,WORK1,
	1	IDIM1,IFAIL)
	IF(IFAIL.NE.0)PRINT 45,IFAIL
45	FORMAT(' ****** WARNING **** IN NAG/E01BAF  IFAIL=',I3)
	RETURN
	END


module correlation_mod

implicit none

real*8 :: h

private :: h

contains

function correlation(y1,y2,x1,x2,hc_optional)

real*8 :: correlation
real*8, intent(in) :: y1(:),y2(:),x1(:),x2(:)
real*8, optional, intent(in) :: hc_optional
integer :: i,j,k,n,m,max_samples
integer :: start_1,start_2,end_1,end_2,n_xbase
integer :: idx1,idx2
real*8 :: hc
real*8 :: mean1,mean2,lx,ly1,ly2,xmin,xmax
real*8 :: num,den1,den2,w1,w2,den
real*8 :: dx(max(size(x1,1),size(x2,1))-1)
real*8 :: median1,median2,iqr1,iqr2,temp1,temp2
real*8 :: xbase(3*(size(x1,1)+size(x2,1)))
logical :: valid1,valid2
real*8 :: a1,a2,b1,b2
real*8 :: xmid,delta_x
real*8 :: data_for_integration(3*(size(x1,1)+size(x2,1)),6)

hc=0.4d0
if(present(hc_optional)) hc=hc_optional

n=size(y1,1)
m=size(y2,1)

! find valid domain for both series, discard any data more than one point
! outside range of other data series
xmin=max(x1(1),x2(1))
xmax=min(x1(n),x2(m))
if (xmin.eq.x1(1)) then
  start_1=1
  do start_2=2,m
    if (x2(start_2).gt.xmin) exit
  enddo
  start_2=start_2-1
else
  start_2=1
  do start_1=2,n
    if (x1(start_1).gt.xmin) exit
  enddo
  start_1=start_1-1
endif
if (xmax.eq.x1(n)) then
  end_1=n
  do end_2=m-1,1,-1
    if (x2(end_2).lt.xmax) exit
  enddo
  end_2=end_2+1
else
  end_2=m
  do end_1=n-1,1,-1
    if (x1(end_1).lt.xmax) exit
  enddo
  end_1=end_1+1
endif

! find median and interquartile range of data spacing
dx(1:end_1-start_1)=x1(start_1+1:end_1)-x1(start_1:end_1-1)
call merge_sort(dx(1:end_1-start_1))
if (mod(end_1-start_1,2).eq.1) then ! odd number of points
  median1=dx((end_1-start_1)/2+1)
  i=floor((end_1-start_1)/4d0)
  if (mod(end_1-start_1,4).eq.1) then
    temp1=(dx(i)+3*dx(i+1))/4
    temp2=(3*dx(3*i+1)+dx(3*i+2))/4
  else
    temp1=(3*dx(i+1)+dx(i+2))/4
    temp2=(dx(3*i+2)+3*dx(3*i+3))/4
  endif
else
  median1=(dx((end_1-start_1)/2)+dx((end_1-start_1)/2+1))/2
  temp1=(dx((end_1-start_1)/4)+dx((end_1-start_1)/4+1))/2
  temp2=(dx(3*(end_1-start_1)/4+1)+dx(3*(end_1-start_1)/4+2))/2
endif
iqr1=temp2-temp1

dx(1:end_2-start_2)=x2(start_2+1:end_2)-x2(start_2:end_2-1)
call merge_sort(dx(1:end_2-start_2))
if (mod(end_2-start_2,2).eq.1) then ! odd number of points
  median2=dx((end_2-start_2)/2+1)
  i=floor((end_2-start_2)/4d0)
  if (mod(end_2-start_2,4).eq.1) then
    temp1=(dx(i)+3*dx(i+1))/4
    temp2=(3*dx(3*i+1)+dx(3*i+2))/4
  else
    temp1=(3*dx(i+1)+dx(i+2))/4
    temp2=(dx(3*i+2)+3*dx(3*i+3))/4
  endif
else
  median2=(dx((end_2-start_2)/2)+dx((end_2-start_2)/2+1))/2
  temp1=(dx((end_2-start_2)/4)+dx((end_2-start_2)/4+1))/2
  temp2=(dx(3*(end_2-start_2)/4+1)+dx(3*(end_2-start_2)/4+2))/2
endif
iqr2=temp2-temp1

! set interval around points
h=hc*max(median1,median2,iqr1,iqr2)

! construct points where kernel starts, midpoint, stops
j=1
do i=start_1,end_1
  if (x1(i)-h.gt.x1(start_1)) then
    xbase(j)=x1(i)-h
    j=j+1
  endif
  xbase(j)=x1(i)
  j=j+1
  if (x1(i)+h.lt.x1(end_1)) then
    xbase(j)=x1(i)+h
    j=j+1
  endif
enddo
do i=start_2,end_2
  if (x2(i)-h.gt.x2(start_2)) then
    xbase(j)=x2(i)-h
    j=j+1
  endif
  xbase(j)=x2(i)
  j=j+1
  if (x2(i)+h.lt.x2(end_2)) then
    xbase(j)=x2(i)+h
    j=j+1
  endif
enddo
n_xbase=j-1
call merge_sort(xbase(1:n_xbase))
! remove duplicates
i=2
do
  if (xbase(i).eq.xbase(i-1)) then
    xbase(i:n_xbase-1)=xbase(i+1:n_xbase)
    n_xbase=n_xbase-1
  else
    i=i+1
  endif
  if (i.gt.n_xbase) exit
enddo

! generate points of valid data for integration
idx1=2
idx2=2
j=1
do i=2,n_xbase
  if (xbase(i).le.max(x1(start_1),x2(start_2))) cycle
  if (xbase(i).gt.min(x1(end_1),x2(end_2))) cycle
  ! find both series have a data point within valid interval
  valid1=.false.
  valid2=.false.
  idx1=max(1,idx1-1)
  idx2=max(1,idx2-1)
  do k=idx1,n
    if (abs(x1(k)-(xbase(i-1)+xbase(i))/2d0).le.h) then
      valid1=.true.
      idx1=max(1,k-1)
      exit
    endif
  enddo
  do k=idx2,m
    if (abs(x2(k)-(xbase(i-1)+xbase(i))/2d0).le.h) then
      valid2=.true.
      idx2=max(1,k-1)
      exit
    endif
  enddo
  if (valid1.and.valid2) then
    data_for_integration(j,1:2)=xbase(i-1:i)
    ! linear interpolate
    do k=max(1,idx1-1),n-1
      if (x1(k).ge.xbase(i-1)) exit
    enddo
    k=max(1,k-1)
    data_for_integration(j,3)=y1(k)+(y1(k+1)-y1(k))*(xbase(i-1)-x1(k))/(x1(k+1)-x1(k))
    do k=max(1,idx1-1),n-1
      if (x1(k).ge.xbase(i)) exit
    enddo
    k=max(1,k-1)
    data_for_integration(j,4)=(y1(k)+(y1(k+1)-y1(k))*(xbase(i)-x1(k))/(x1(k+1)-x1(k))-data_for_integration(j,3))/(data_for_integration(j,2)-data_for_integration(j,1))
    do k=max(1,idx2-1),m-1
      if (x2(k).ge.xbase(i-1)) exit
    enddo
    k=max(1,k-1)
    data_for_integration(j,5)=y2(k)+(y2(k+1)-y2(k))*(xbase(i-1)-x2(k))/(x2(k+1)-x2(k))
    do k=max(1,idx2-1),m-1
      if (x2(k).ge.xbase(i)) exit
    enddo
    k=max(1,k-1)
    data_for_integration(j,6)=(y2(k)+(y2(k+1)-y2(k))*(xbase(i)-x2(k))/(x2(k+1)-x2(k))-data_for_integration(j,5))/(data_for_integration(j,2)-data_for_integration(j,1))
    j=j+1
  endif
enddo

j=j-1

! calculate means by integration
mean1=0d0
mean2=0d0
num=0d0
do i=1,j
  delta_x=data_for_integration(i,2)-data_for_integration(i,1)
  a1=data_for_integration(i,3)
  b1=data_for_integration(i,4)
  mean1=mean1+delta_x*(a1+delta_x*b1/2d0)
  a2=data_for_integration(i,5)
  b2=data_for_integration(i,6)
  mean2=mean2+delta_x*(a2+delta_x*b2/2d0)
  num=num+delta_x
enddo
mean1=mean1/num
mean2=mean2/num

! calculate correlation by integration
data_for_integration(1:j,3)=data_for_integration(1:j,3)-mean1
data_for_integration(1:j,5)=data_for_integration(1:j,5)-mean2
num=0d0
den1=0d0
den2=0d0
do i=1,j
  delta_x=data_for_integration(i,2)-data_for_integration(i,1)
  a1=data_for_integration(i,3)
  b1=data_for_integration(i,4)
  a2=data_for_integration(i,5)
  b2=data_for_integration(i,6)
  num=num+delta_x*(a1*a2+delta_x*(b1*a2/2d0+b2*a1/2d0+delta_x*b1*b2/3d0))
  den1=den1+delta_x*(a1**2+delta_x*(b1*a1+delta_x*b1**2/3d0))
  den2=den2+delta_x*(a2**2+delta_x*(b2*a2+delta_x*b2**2/3d0))
enddo

correlation=num/sqrt(den1*den2)

end function

function merge_arrays(b,c)

real*8, intent(in) :: b(:),c(:)
real*8 :: merge_arrays(size(b,1)+size(c,1))
integer :: i,j,k,n,m

n=size(b,1)
m=size(c,1)

i=1
j=1
do k=1,n+m
  if (i.gt.n) then
    merge_arrays(k:n+m)=c(j:m)
    exit
  elseif (j.gt.m) then
    merge_arrays(k:n+m)=b(i:n)
    exit
  endif
  if (b(i).lt.c(j)) then
    merge_arrays(k)=b(i)
    i=i+1
  else
    merge_arrays(k)=c(j)
    j=j+1
  endif
enddo

end function

subroutine merge_sort(a)

real*8, intent(inout) :: a(:)
integer :: i,m,n

n=size(a,1)

m=1
do
  i=1
  do
    a(i:min(i+2*m-1,n))=merge_arrays(a(i:min(i+m-1,n)),a(i+m:min(i+2*m-1,n)))
    if (i.ge.n-m) exit
    i=i+2*m
  enddo
  if (m.ge.n) exit
  m=m*2
enddo

end subroutine

end module


************************************************************************
************************************************************************
      subroutine rands(ar,cr1,cr2,var)
*
* generates a random number between 0 and 1 by selecting digits 5 to 13
*  in a square r of a number that is square-rooted over and over;
*					(from Bohdan)
*
*  input:
*      ar       = a seed number
*      cr1, cr2 = auxillary seed numbers
*
*  output:
*      ar       = a modified seed number
*      var      = a random variable with a uniform probability distri
*                    in the range 0 to 1
*
* called in:
*           setstar
*
* use of subroutines:
*           none
*
* use of functions:
*           none
*					October 31, 1991; J. Wambsganss
*
      implicit none
      integer ia13,ib13,ia39,ib39
      double precision cr1,cr2,ar,br,f13,f26,al,bl,var,a13,b13,a13m,b13m
     &  ,a39,b39,r1,r2
*
      cr1   = cr1+1
      cr2   = cr2+1
      if(cr1.gt.1019)then
	 cr1 = 1.0d0
      endif
      if(cr2.gt.1056)then
	 cr2 = 1.0d0
      endif
      ar    = dsqrt(ar+cr1*cr2*1.765321d-5)
      br    = ar+dsqrt(1.1d0+0.1/ar)
      f13   = 2.0d0**13
      f26   = 2.0d0**26
*
      al    = dsqrt(ar)
      bl    = dsqrt(br)
      a13   = al*f13
      b13   = bl*f13
      ia13  = idint(a13)
      ib13  = idint(b13)
      a13m  = a13-ia13
      b13m  = b13-ib13
      a39   = a13m*f26
      b39   = b13m*f26
      ia39  = idint(a39)
      ib39  = idint(b39)
      r1    = ia39/f26
      r2    = ib39/f26
*
      var   = r1+r2/f26
      ar    = r2+r1/f26
*
      return
      end


C***********************************************************************
C*
C*	Copyright 1996, University Corporation for Atmospheric Research.
C*
C*	colorbardraw.f
C*
C*	Utility for drawing the image colorbar.
C*
C*	History:
C*
C*	06/97	COMET	Original copy
C*	10/97	COMET	Get image common block items from function calls
C*	 3/98	COMET	Draw color bar only if num levels > 0
C*	 3/04	Unidata	Updated call to im_cbar for GEMPAK 5.7
C*
C************************************************************************
	SUBROUTINE colorbardraw  ( cbar )
C*
C*	This subroutine calls the routine that draws the colorbar.
C*	It prepares data values in some cases, specifically for
C*	satellite imagery. (Radar data levels are calculated when the
C*	header is read, since those values are part of the image
C*	product.)

C
	INCLUDE		'GEMPRM.PRM'
C*
	character	cbar*(*)
	CHARACTER	cmbunt*8, cmcalb*8, cmblev*8
	INTEGER		idcols(256)
	REAL		PR_TMKC
	INTEGER		GETIMGCOMINT
C------------------------------------------------------------------------
C
C*	For sat images, create the data level labels.
C
	imradf = GETIMGCOMINT ( 'imradf' )
	immxpx = GETIMGCOMINT ( 'immxpx' )
	immnpx = GETIMGCOMINT ( 'immnpx' )
	imtype = GETIMGCOMINT ( 'imtype' )
	imbank = GETIMGCOMINT ( 'imbank' )
	imndlv = GETIMGCOMINT ( 'imndlv' )
	CALL GETIMGCOMSTR ( 'cmcalb', 0, cmcalb )
	CALL GETIMGCOMSTR ( 'cmbunt', 0, cmbunt )

	IF ( imradf .eq. 0 ) THEN
	    imndlv = MIN ( 256, immxpx - immnpx + 1 )
	    CALL SETIMGCOMINT ( 'imndlv', imndlv )
C
C*	    For IR images calibrated to brightness, create Deg C levels
C
	    IF ( cmcalb .eq. 'BRIT' .and.
     +		(imtype .eq. 8 .or. imtype .eq. 128) ) THEN
	        cmbunt = 'DEG C'
		CALL SETIMGCOMSTR ( 'cmbunt', i, cmbunt )
		DO i = 1, imndlv
		    IF ( i .eq. 1 .or. i .eq. imndlv ) THEN
			CALL IM_BTOT ( 1, i-1+immnpx, temp, ier )
			temp = PR_TMKC ( temp )
		        CALL ST_RLCH ( temp, 1, cmblev, ier)
		    ELSE
		    	cmblev = ' '
		    END IF
		    CALL SETIMGCOMSTR ( 'cmblev', i, cmblev )
		END DO
		DO temp = -100., 50., 10.
		    CALL IM_TTOB ( 1, PR_TMCK ( temp ), brit, ier )
                    ibrit = NINT ( brit ) - immnpx
		    IF ( ibrit .gt. 0 ) THEN
     		        CALL ST_INCH ( INT (temp), cmblev, ier )
		    	CALL SETIMGCOMSTR ( 'cmblev', ibrit, cmblev )
 		    END IF
		END DO
	    ELSE IF (cmcalb .eq. 'PROD' ) THEN
	        imndlv = 256
	        CALL SETIMGCOMINT ( 'imndlv', imndlv )
C
C*	    For anything else, create labels in native units
C
	    ELSE
C
C*		GINI calbar values done in IM library
C
	        IF (cmcalb .ne. 'GINI' ) THEN
	           cmbunt = cmcalb
		   CALL SETIMGCOMSTR ( 'cmbunt', i, cmbunt )
	           ratio = (immxpx - immnpx)/255.
		   DO i = 1, imndlv
		      level = nint( (i-1) * ratio) + immnpx
		      IF ( (mod ( i-1,16) .eq. 0) .or. (i .eq. 1) .or.
     +			 (i .eq. imndlv) ) THEN
		    	 CALL ST_INCH ( level, cmblev, ier )
		      ELSE
		         cmblev = ' '
		      END IF
		      CALL SETIMGCOMSTR ( 'cmblev', i, cmblev )
		   END DO
		ENDIF
	    END IF
	END IF
C
C*	Create data level numbers for color bar
C
	CALL GQCLRS ( imbank, ncolr, ier )
	ratio = FLOAT (ncolr - 1) / (imndlv - 1)
	DO ic = 1, imndlv
	    idcols (ic) = (ic - 1) * ratio + .5
	END DO
C
C*	Draw color bar
C
 	if ( imndlv .gt. 0 ) CALL IM_CBAR ( cbar, ier )
C
	RETURN
	END


      SUBROUTINE MA01BZ( BASE, K, S, A, INCA, ALPHA, BETA, SCAL )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the general product of K complex scalars trying to
C     avoid over- and underflow.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     BASE    (input)  DOUBLE PRECISION
C             Machine base.
C
C     K       (input)  INTEGER
C             The number of scalars.  K >= 1.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     A       (input)  COMPLEX*16 array, dimension (K)
C             Vector of complex scalars.
C
C     INCA    (input)  INTEGER
C             Increment for the array A. INCA <> 0.
C
C     ALPHA   (output)  COMPLEX*16
C             ALPHA is a complex scalar with ABS(ALPHA) = 0, or
C             1.0 <= ABS(ALPHA) < BASE, such that
C
C                ALPHA / BETA * BASE**(SCAL)
C
C             is the general product of the scalars in the array A.
C
C     BETA    (output)  COMPLEX*16
C             BETA is either 0.0 or 1.0.
C             See also the description of ALPHA.
C
C     SCAL    (output)  INTEGER
C             Scaling factor exponent, see ALPHA.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Aug. 2009, SLICOT Library version of the routine ZLAPR1.
C
C     KEYWORDS
C
C     Computer arithmetic, overflow, underflow.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      COMPLEX*16        CONE, CZERO
      PARAMETER         ( CONE  = ( 1.0D+0, 0.0D+0 ),
     $                    CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      INTEGER           INCA, K, SCAL
      DOUBLE PRECISION  BASE
      COMPLEX*16        ALPHA, BETA
C     .. Array Arguments ..
      INTEGER           S(*)
      COMPLEX*16        A(*)
C     .. Local Scalars ..
      INTEGER           I, INDA
      COMPLEX*16        CBASE
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DCMPLX
C
C     .. Executable Statements ..
C
      CBASE = DCMPLX( BASE, ZERO )
      ALPHA = CONE
      BETA  = CONE
      SCAL = 0
      INDA = 1
C
      DO 40  I = 1, K
         IF ( S(I).EQ.1 ) THEN
            ALPHA = ALPHA * A(INDA)
         ELSE
            IF ( A(INDA).EQ.CZERO ) THEN
               BETA = CZERO
            ELSE
               ALPHA = ALPHA / A(INDA)
            END IF
         END IF
         IF ( ABS( ALPHA ).EQ.ZERO ) THEN
            ALPHA = CZERO
            SCAL  = 0
            IF ( ABS( BETA ).EQ.ZERO )
     $         RETURN
         ELSE
C           WHILE ( ABS( ALPHA ).LT.ONE )  DO
   10       CONTINUE
               IF ( ABS( ALPHA ).GE.ONE )
     $            GO TO 20
               ALPHA = ALPHA*CBASE
               SCAL  = SCAL - 1
            GO TO 10
C           END WHILE 10
C
C           WHILE ( ABS( ALPHA ).GE.BASE ) DO
   20       CONTINUE
               IF ( ABS( ALPHA ).LT.BASE )
     $            GO TO 30
               ALPHA = ALPHA / CBASE
               SCAL  = SCAL + 1
            GO TO 20
C           END WHILE 20
   30       CONTINUE
         END IF
         INDA = INDA + INCA
   40 CONTINUE
C
      RETURN
C *** Last line of MA01BZ ***
      END


#include "macros.h"
#include "mt19937_64.f90"
module vfield
    use numbers
    use openmpi
    use io
    use parameters
    use fieldio
    use fftw
    use diffops
    use symmops

    logical     :: seed_init = .false.
    integer(i8) :: seed

    contains

!==============================================================================

    subroutine vfield_inprod(vfieldk1, vfieldk2, res, allreduce)
        ! res = <vfieldk1, vfieldk2>, returns only the real part
        ! of the result
        complex(dpc), intent(in) :: vfieldk1(:, :, :, :)
        complex(dpc), intent(in) :: vfieldk2(:, :, :, :)
        real(dp), intent(out) :: res
        logical, intent(in) :: allreduce
        real(dp)          :: res1
        complex(dpc)      :: dummy
        _indices
        integer(i4) :: n

        res1 = 0
        do n=1,3
            _loop_spec_begin
                dummy = conjg(vfieldk1(ix,iy,iz,n)) * vfieldk2(ix,iy,iz,n)
                ! correct for double counting
                if (iy == 1) dummy = dummy * 0.5_dp
                res1 = res1 + dummy%re
            _loop_spec_end
        end do

        if (.not. allreduce) then
            call MPI_REDUCE(res1, res, 1, MPI_REAL8, MPI_SUM, 0, &
            MPI_COMM_WORLD, mpi_err)
        else
            call MPI_ALLREDUCE(res1, res, 1, MPI_REAL8, MPI_SUM, &
            MPI_COMM_WORLD, mpi_err)
        end if

    end subroutine vfield_inprod

!==============================================================================

    subroutine vfield_enstrophy(vfieldk, res, allreduce)

        complex(dpc), intent(in) :: vfieldk(:, :, :, :)
        real(dp), intent(out) :: res
        logical, intent(in) :: allreduce
        real(dp)          :: res1
        complex(dpc)      :: dummy
        _indices
        integer(i4) :: n

        res1 = 0
        do n=1,3
            _loop_spec_begin
                dummy = laplacian(ix,iy,iz) * &
                            conjg(vfieldk(ix,iy,iz,n)) * vfieldk(ix,iy,iz,n)
                ! correct for double counting
                if (iy == 1) dummy = dummy * 0.5_dp
                res1 = res1 + dummy%re
            _loop_spec_end
        end do

        if (.not. allreduce) then
            call MPI_REDUCE(res1, res, 1, MPI_REAL8, MPI_SUM, 0, &
            MPI_COMM_WORLD, mpi_err)
        else
            call MPI_ALLREDUCE(res1, res, 1, MPI_REAL8, MPI_SUM, &
            MPI_COMM_WORLD, mpi_err)
        end if

    end subroutine vfield_enstrophy

!==============================================================================

    subroutine vfield_norm2(vfieldk, res, allreduce)
        complex(dpc), intent(in) :: vfieldk(:, :, :, :)
        logical, intent(in) :: allreduce
        real(dp), intent(out) :: res

        call vfield_inprod(vfieldk, vfieldk, res, allreduce)

    end subroutine vfield_norm2

!==============================================================================

    subroutine vfield_norm(vfieldk, res, allreduce)
        complex(dpc), intent(in) :: vfieldk(:, :, :, :)
        logical, intent(in) :: allreduce
        real(dp), intent(out) :: res

        call vfield_norm2(vfieldk, res, allreduce)
        res = sqrt(res)

    end subroutine vfield_norm

!==============================================================================

    subroutine vfield_random(vfieldk, symmetric)
        use mt19937_64
        complex(dpc), intent(out) :: vfieldk(:, :, :, :)
        logical, intent(in) :: symmetric
        real(dp) :: random_vfieldxx(nyy, nzz_perproc, nxx, 3)

        _indices
        _indicess

        integer(i4) :: un, istat, n
        real(dp)    :: dummy, e_tot

        ! If the parameters.in contains a seed number, use it
        if (random_seed /= -1) then
            seed = random_seed
        else if (my_id==0) then
            ! otherwise read from entropy
            open(newunit=un, file="/dev/urandom", access="stream", &
                 form="unformatted", action="read", status="old", iostat=istat)
            if (istat == 0) then
               read(un) seed
               close(un)
               seed_init = .false.
            else
                write(out,*) "m_runs: /dev/urandom not found, stopping."
                flush(out)
                error stop
            end if
        end if

        ! Broadcast the seed
        call MPI_BCAST(seed,1,MPI_INTEGER8,0,MPI_COMM_WORLD,mpi_err)

        ! initialize the seed
        if (.not. seed_init) then
            call init_genrand64(seed)
            seed_init = .true.
        end if

        ! bring the processors to their own places in the random sequence
        do n = 1,my_id*nyy*nzz_perproc*nxx*3
            dummy = genrand64_real1()
        end do

        ! fill the arrays with [-1, 1]
        do n=1,3;
            _loop_phys_begin
                random_vfieldxx(iyy,izz,ixx,n) = (2 * genrand64_real1() - 1)
            _loop_phys_end
        end do;

        call fftw_vx2k(random_vfieldxx, vfieldk)

        ! scale the arrays with e^{-sk^2}
        do n=1,3;
            _loop_spec_begin
                vfieldk(ix,iy,iz,n) = vfieldk(ix,iy,iz,n) &
                                   * exp(-random_smooth * laplacian(ix,iy,iz))
            _loop_spec_end
        end do;

        call vfield_pressure(vfieldk)
        call vfield_galinv(vfieldk)

        if (symmetric) call symmopps_project_all(vfieldk,vfieldk)
        ! Normalize to a specific energy
        call vfield_norm2(vfieldk, e_tot, .true.)
        vfieldk(:,:,:,1:3) = sqrt(random_energy * ekin_lam / e_tot) * vfieldk(:,:,:,1:3)

        call vfield_solvediv(vfieldk)

        ! once more, doesn't hurt
        call vfield_pressure(vfieldk)
        call vfield_galinv(vfieldk)
        if (symmetric) call symmopps_project_all(vfieldk,vfieldk)
        call vfield_solvediv(vfieldk)

    end subroutine vfield_random

!==============================================================================

    subroutine vfield_laminar(vfieldk)
        complex(dpc), intent(out) :: vfieldk(:, :, :, :)

        vfieldk(:,:,:,1:3) = 0
        if (ix_zero /= -1 .and. iy_force /= -1) then
            if (tilting) then
                if (forcing == 1) then
                    vfieldk(ix_zero,iy_force,1,1)%im = -cos(tilt_angle * PI / 180.0_dp) * 0.5_dp
                    vfieldk(ix_zero,iy_force,1,3)%im = -sin(tilt_angle * PI / 180.0_dp) * 0.5_dp
                elseif (forcing == 2) then
                    vfieldk(ix_zero,iy_force,1,1)%re = cos(tilt_angle * PI / 180.0_dp) * 0.5_dp
                    vfieldk(ix_zero,iy_force,1,3)%re = sin(tilt_angle * PI / 180.0_dp) * 0.5_dp
                endif
            else
                if (forcing == 1) then
                    vfieldk(ix_zero,iy_force,1,1)%im = -0.5_dp
                elseif (forcing == 2) then
                    vfieldk(ix_zero,iy_force,1,1)%re = 0.5_dp
                endif
            end if
        endif
    end subroutine vfield_laminar

!==============================================================================

    subroutine vfield_shapiro(t, vfieldk)
        real(dp), intent(in) :: t
        complex(dpc), intent(out) :: vfieldk(:, :, :, :)
        real(dp) :: shapiro_vfieldxx(nyy, nzz_perproc, nxx, 3)
        real(dp) :: decay
        _indicess

        decay = exp(-shapiro_lambda**2 * t / Re)

        _loop_phys_begin
            shapiro_vfieldxx(iyy,izz,ixx,1) = -(decay / (shapiro_alpha**2 + shapiro_beta**2)) * &
                (shapiro_lambda * shapiro_beta * &
                    dcos(shapiro_alpha * vfield_coordinatexx(iyy,izz,ixx,1)) * &
                    dsin(shapiro_beta * vfield_coordinatexx(iyy,izz,ixx,2)) * &
                    dsin(shapiro_gamma * vfield_coordinatexx(iyy,izz,ixx,3)) &
                 + shapiro_gamma * shapiro_alpha * &
                    dsin(shapiro_alpha * vfield_coordinatexx(iyy,izz,ixx,1)) * &
                    dcos(shapiro_beta * vfield_coordinatexx(iyy,izz,ixx,2)) * &
                    dcos(shapiro_gamma * vfield_coordinatexx(iyy,izz,ixx,3)) &
                )

            shapiro_vfieldxx(iyy,izz,ixx,2) = (decay / (shapiro_alpha**2 + shapiro_beta**2)) * &
                (shapiro_lambda * shapiro_alpha * &
                    dsin(shapiro_alpha * vfield_coordinatexx(iyy,izz,ixx,1)) * &
                    dcos(shapiro_beta * vfield_coordinatexx(iyy,izz,ixx,2)) * &
                    dsin(shapiro_gamma * vfield_coordinatexx(iyy,izz,ixx,3)) &
                    - shapiro_gamma * shapiro_beta * &
                    dcos(shapiro_alpha * vfield_coordinatexx(iyy,izz,ixx,1)) * &
                    dsin(shapiro_beta * vfield_coordinatexx(iyy,izz,ixx,2)) * &
                    dcos(shapiro_gamma * vfield_coordinatexx(iyy,izz,ixx,3)) &
                )

            shapiro_vfieldxx(iyy,izz,ixx,3) = decay * &
                    dcos(shapiro_alpha * vfield_coordinatexx(iyy,izz,ixx,1)) * &
                    dcos(shapiro_beta * vfield_coordinatexx(iyy,izz,ixx,2)) * &
                    dsin(shapiro_gamma * vfield_coordinatexx(iyy,izz,ixx,3))

        _loop_phys_end

        call fftw_vx2k(shapiro_vfieldxx, vfieldk)

    end subroutine vfield_shapiro

!==============================================================================

    subroutine vfield_pressure(vfieldk)
        ! Apply pressure solver on vfieldk(:,:,:,1:3)
        complex(dpc), intent(inout) :: vfieldk(:, :, :, :)
        _indices
        integer(i4)  :: d
        complex(dpc) :: dpressure

        _loop_spec_begin
            dpressure = 0
            do d=1,3
                dpressure = dpressure + vfieldk(ix,iy,iz,d) * &
                                        vfield_coordinatek(ix,iy,iz,d) * &
                                        inverse_laplacian(ix,iy,iz)
            end do

            do d=1,3
                vfieldk(ix,iy,iz,d) = vfieldk(ix,iy,iz,d) - dpressure * &
                                                vfield_coordinatek(ix,iy,iz,d)
            end do
        _loop_spec_end

    end subroutine vfield_pressure

!==============================================================================

    subroutine vfield_galinv(vfieldk)
        ! Set (0,0,0)-mode to 0 (Galilean invariance)
        complex(dpc), intent(inout) :: vfieldk(:, :, :, :)

        ! index ix_zero has the zero mode in x
        if(ix_zero /= -1) vfieldk(ix_zero,1,1,1:3) = 0
    end subroutine vfield_galinv

!==============================================================================

    subroutine vfield_solvediv(vfieldk)
        complex(dpc), intent(inout) :: vfieldk(:, :, :, :)

        _indices

        ! uses
        !   u k_x + v k_y + w k_z = 0
        ! to solve for one velocity component in terms of the other two

        if (nx - 1 >= ny_half .and. nx - 1 >= nz - 1) then
            _loop_spec_begin
                if (ix_zero /= -1 .and. ix==ix_zero) cycle
                vfieldk(ix,iy,iz,1) = -(vfieldk(ix,iy,iz,2)*ky(iy) &
                                            + vfieldk(ix,iy,iz,3)*kz(iz)) / kx(ix)
            _loop_spec_end
        elseif (ny_half >= nx - 1 .and. ny_half >= nz - 1) then
            _loop_spec_begin
                if (iy==1) cycle
                vfieldk(ix,iy,iz,2) = -(vfieldk(ix,iy,iz,1)*kx(ix) &
                                            + vfieldk(ix,iy,iz,3)*kz(iz)) / ky(iy)
            _loop_spec_end
        else
            _loop_spec_begin
                if (iz==1) cycle
                vfieldk(ix,iy,iz,3) = -(vfieldk(ix,iy,iz,1)*kx(ix) &
                                                + vfieldk(ix,iy,iz,2)*ky(iy)) / kz(iz)
            _loop_spec_end
        end if

    end subroutine vfield_solvediv

!==============================================================================

    subroutine vfield_truncate(k_c, vfieldk)
        ! low-pass filter setting fluctuations with spatial frequencies higher
        ! than k_c to 0
        real(dp), intent(in) :: k_c
        complex(dpc), intent(inout) :: vfieldk(:, :, :, :)

        real(dp) :: normk

        _indices

        _loop_spec_begin

            normk = sqrt(kx(ix) ** 2 + ky(iy) ** 2 + kz(iz) ** 2)

            if (normk > k_c) then

                vfieldk(ix, iy, iz, 1:3) = 0

            end if

        _loop_spec_end

    end subroutine vfield_truncate

!==============================================================================
    real(dp) function vfield_coordinatek(ix,iy,iz,d)
        integer(i4), intent(in) :: ix, iy, iz, d
        select case (d)
            case(1)
                vfield_coordinatek = kx(ix)
            case(2)
                vfield_coordinatek = ky(iy)
            case(3)
                vfield_coordinatek = kz(iz)
        end select
    end function vfield_coordinatek

!==============================================================================

    real(dp) function vfield_coordinatexx(iyy,izz,ixx,d)
        integer(i4), intent(in) :: ixx, iyy, izz, d

        select case (d)
            case(1)
                vfield_coordinatexx = dx * (ixx - 1)
            case(2)
                vfield_coordinatexx = dy * (iyy - 1)
            case(3)
                vfield_coordinatexx = dz * (nzz_perproc * my_id + izz - 1)
        end select
    end function vfield_coordinatexx

!==============================================================================

end module vfield