      subroutine unit_hyd (tc, uh)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This subroutine computes variables related to the watershed hydrology:
!!    the time of concentration for the subbasins, lagged surface runoff,
!!    the coefficient for the peak runoff rate equation, and lateral flow travel
!!    time.

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~1
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_n(1,:)   |none          |Manning"s "n" value for the tributary channels
!!    ch_s(1,:)   |m/m           |average slope of tributary channels
!!    gdrain(:)   |hrs           |drain tile lag time: the amount of time
!!                               |between the transfer of water from the soil
!!                               |to the drain tile and the release of the
!!                               |water from the drain tile to the reach.
!!    hru_km(:)   |km2           |area of HRU in square kilometers
!!    lat_ttime(:)|days          |lateral flow travel time
!!    slsoil(:)   |m             |slope length for lateral subsurface flow
!!    slsubbsn(:) |m             |average slope length for subbasin
!!    tconc(:)     |hr           |time of concentration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    lat_ttime(:)|none          |Exponential of the lateral flow travel time
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    l           |none          |counter
!!    scmx        |mm/hr         |maximum soil hydraulic conductivity
!!    t_ch        |hr            |time for flow entering the farthest upstream
!!                               |channel to reach the subbasin outlet
!!    xx          |none          |variable to hold calculation result
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: Ttcoef

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      !use hru_module, only : itb
      use basin_module
      use time_module
      use hydrograph_module, only : sp_ob

      implicit none

      integer :: j              !none       |counter
      real :: ql                !           |
      real :: sumq              !           |
      real :: tb                !           |
      real :: tp                !           |
      integer :: int            !           |
      integer :: i              !none       |counter
      real :: xi                !           |
      real :: q                 !           |
      integer :: max            !           |
      integer :: itb            !           |
      integer :: istep          !none       |time step that corresponds to time%step for routing
      integer :: iday           !none       |current day in the unit hydrograph
      real :: t_inc             !hr         |time increment to sum the unit hyd
      real :: t_tot             !hr         |total time in the hydrograph

      real, intent (in)  :: tc
      real, intent (out), dimension(bsn_prm%day_lag_mx,time%step) :: uh

      !! compute unit hydrograph for computing hydrograph from direct runoff
      ql = 0.
      sumq = 0.
      uh = 0.
      tb = .5 + .6 * tc + bsn_prm%tb_adj    !baseflow time, hr
      if (tb > 48.) tb = 48.			    !maximum 48hrs
      tp = .375 * tb                        ! time to peak flow

      !! sum 20 points on the unit hydrograph to get sum for the time%step
	  itb = 20
      t_inc = tb / 20.
      t_tot = 0.
      istep = 1
      iday = 1

	  !! Triangular Unit Hydrograph
	  if (bsn_cc%uhyd == 0) then
        !! increment for number of points to estimate uh
	    do i = 1, itb
          t_tot = t_tot + t_inc
          if (t_tot > float(istep * time%step / 24)) then
            istep = istep + 1
          end if
          if (t_tot > float(iday * 24)) then
            iday = iday + 1
            t_tot = 0
          end if

 	      if (t_tot < tp) then
            !! rising limb of hydrograph
            q = t_tot / tp
          else
            !! falling limb of hydrograph
            q = (tb - t_tot) / (tb - tp)
          end if
          q = Max(0.,q)
          uh(iday,istep) = uh(iday,istep) + (q + ql) / 2.
          sumq = sumq + (q + ql) / 2.
          ql = q
        end do

	  ! Gamma Function Unit Hydrograph
	  else if (bsn_cc%uhyd == 1) then
        i = 1; q = 1.
		do while (q > 0.0001)
          t_tot = t_tot + t_inc
          if (t_tot > float(istep * time%step / 24)) then
            istep = istep + 1
          end if
          if (t_tot > float(iday * 24)) then
            iday = iday + 1
            t_tot = 0
          end if

          xi = float(i)
          q = (xi / tp) ** bsn_prm%uhalpha * exp((1. - xi / tp) * bsn_prm%uhalpha)
          q = Max(0.,q)
          uh(iday,istep) = (q + ql) / 2.
          ql = q
          sumq = sumq + uh(iday,istep)
	      i = i + 1
	      if (i > 3. * time%step) exit
        end do

	  end if

      do i = 1, iday
        do istep = 1, time%step
          uh(i,istep) = uh(i, istep) / sumq
        end do
      end do

      return
      end subroutine unit_hyd


       program pend
*
*      *** Demo program for DASPK ***
*
* Single Pendulum problem with sensitivity equation coupling
* run  for  0.0 <= t <= 1.0.
*
* x1' = x3                      x1(0) = 0.5
* x2' = x4                      x2(0) = -sqrt(p1^2 - x1^2)
* x3' = -x1*x5                  x3(0) = 0.0
* x4' = -x2*x5 + g              x4(0) = 0.0
* 0   = x1*x3 + x2*x4
*
*
       IMPLICIT DOUBLE PRECISION(A-H,O-Z), integer(i-n)
       EXTERNAL RES, i_res, h_res, j_res
       DIMENSION Y(10),RWORK(300),IWORK(100),YPRIME(10)
       DIMENSION INFO(30),RPAR(1),IPAR(20), senpar(1)
*
* Specify Error tolerances, length of iwork and rwork, NEQ and the
* interval of integeration.
*
       RTOL = 1.0d-6
       ATOL = 1.0d-6
       LRW = 300
       LIW = 100
       T = 0.0
       TOUT = 1.0
       neq = 5
*
* Initialize y, yprime, senpar
*
       call init(y,yprime,senpar)
*
* Initialize the INFO vector to 0.
*
       DO 10 I = 1,30
          INFO(I) = 0
  10   CONTINUE
*
* Get solution at intermediate steps.
*
       INFO(3)  = 1
*
* Finite difference approx. (FDA) of Jacobian. (1 = no,0 = yes)
*
       info(5) = 2
       print *, '   0 ------ finite difference '
       print *, '   2 ------ ADIFOR with SparcLinC option '
       print *, '   3 ------ ADIFOR with seed matrix option '
       print *, ' please input the Jacobian method: (0,2,3)'
       read(*,*)info(5)
C
C Here set INFO(14) = 1 to get the computed initial values.
       INFO(14) = 1
*
* Set x5 as a algebraic variable, does not do the error test on it.
*
       info(16) = 1
       NEQ = 5
       do i = 1, 4
          iwork(40+i) = 1
          iwork(40+5+i) = 0
       end do
       iwork(41) = 2
       iwork(42) = 2

       iwork(45) = -1
       iwork(50) = 1
       iwork(38) = 0
*
*
* Make the IC's consistent and relay this info. to DASSLSO.
*
c      call consistic(y,yprime)
      INFO(11) = 1
      PRINT *, 'initial condition options(3,4,5)'
      read(*,*) info(11)
      inso = 18
      info(inso+1) = 1
      print *, ' number of sensitivities? (0,1) '
      read(*,*) info(inso+1)
      Ny = neq
      neq = neq*(info(inso+1) + 1)
      print *, '    0: central differencing '
      print *, '    1: one-side forward differencing '
      print *, '    3: Adifor input'
      print *, ' method for computing sensitivity residuals:(0,1,3)'
      read (*,*) info(inso+2)
      info(inso+3) = 1          ! default perturbed factor
      info(inso+4) = 0          ! no sensitivity parameter in the RES
      info(inso+5) = 0          ! 0, full control 1. partial control
      info(inso+6) = 0          ! no derived information
      info(inso+7) = 1          ! simultaneous corrector(0), staggered(1)
      print *, '    0:  simultaneous corrector method '
      print *, '    1:  staggered corrector method'
      print *, ' Corrector method: (0, 1)'
      read(*,*) info(inso+7)

      print *, ' Initial values are:'
      do i = 1,neq
         print*, 'y(', i, ')=', y(i), ', yprime(i)= ',yprime(i)
      enddo
      print *, 'y(1)**2 + y(2)**2 - 1.0         = ',
     *     y(1)*y(1) + y(2)*y(2) - 1.0
      print *, 'y(1)*y(3)+y(2)*y(4)             = ',
     *     y(1)*y(3) + y(2)*y(4)
      print *, 'y(3)**2 + y(4)**2 - y(5) - y(2) = ',
     *     y(3)**2 + y(4)**2 - (y(1)*y(1)+y(2)*y(2))*y(5)-y(2)
      print *, 'input the end time TOUT:'
      read *, TOUT
*
 20   IF(T .LT. TOUT) THEN
*
         if (info(5) .eq. 2) then
            CALL DDASPK(
     *           RES,NEQ,T,Y,YPRIME,TOUT,INFO,RTOL,ATOL,IDID,RWORK,
     *           LRW,IWORK,LIW,RPAR,IPAR,i_res, psol,senpar, H_res)
         else
            CALL DDASPK(
     *           RES,NEQ,T,Y,YPRIME,TOUT,INFO,RTOL,ATOL,IDID,RWORK,
     *           LRW,IWORK,LIW,RPAR,IPAR,j_res, psol,senpar, H_res)
         end if

         if (info(11).ne.0)  then
            info(11) = 0
            write(*,99)t, y(1)*y(1) + y(2)*y(2) - 1.0,
     *        y(1)*y(3) + y(2)*y(4),
     *        y(3)**2 + y(4)**2 - (y(1)*y(1)+y(2)*y(2))*y(5)-y(2)
            pause
         end if

         write(20,99)t, y(1), y(2), y(6), y(7)
         write(21,99)t, y(1)*y(1) + y(2)*y(2) - 1.0,
     *        y(1)*y(3) + y(2)*y(4),
     *        y(3)**2 + y(4)**2 - (y(1)*y(1)+y(2)*y(2))*y(5)-y(2)
         if (idid.gt.0) GOTO 20
      ENDIF
 99   format(1x, 5e15.6)
      PRINT *
*
* Output IWORK and RWORK vector values
*
      PRINT*
      WRITE(*,*)'TOTAL # OF STEPS:',IWORK(11)
      PRINT*
      WRITE(*,*)'TOTAL # OF ERROR TEST FAILURES:',IWORK(14)
      PRINT*
      WRITE(*,*)'TOTAL # OF CONV. TEST FAILURES:',IWORK(15)
      PRINT*
      WRITE(*,*)'TOTAL # OF RES function evals:',IWORK(12)
*
      END
*------------------------------------------------------------------------*
      SUBROUTINE RES(T,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR, senpar)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER(I-N)
      DIMENSION Y(*), YPRIME(*), DELTA(*), RPAR(*), IPAR(*),senpar(*)
*
      DELTA(1) = YPRIME(1) - Y(3)
      DELTA(2) = YPRIME(2) - Y(4)
      DELTA(3) = YPRIME(3) + Y(1)*Y(5)
      DELTA(4) = YPRIME(4) + Y(2)*Y(5) + 1.0D0
      DELTA(5) = cj*(Y(1)*Y(3) + Y(2)*Y(4))
*     print *,' delta(5) =', delta(5)
*     delta(5) = y(3)*y(3) + y(4)*y(4) - y(5) - y(2)
*
      RETURN
      END
*------------------------------------------------------------------------*
*------------------------------------------------------------------------*
      SUBROUTINE CONSISTIC(Y,YPRIME)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION Y(*), YPRIME(*)
*
*     Set yprime to the value of the RHS, for consistency.
*
      YPRIME(1) = Y(3)
      YPRIME(2) = Y(4)
      YPRIME(3) = -Y(1)*Y(5)
      YPRIME(4) = -Y(2)*Y(5) - 1.0D0
*
      return
      end
*------------------------------------------------------------------------*
      SUBROUTINE INIT(Y,YPRIME,senpar)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER(I-N)
      DIMENSION Y(*), YPRIME(*), senPAR(*)
*
*     Set y, yprime, IPAR, RPAR to 0, initially.
*
      do i = 1,10
         y(i) = 0.0
         yprime(i) = 0.0
      enddo
*
*
*     Parameter values - placed somewhere in senPAR.
*
      senpar(1) = 1.0d0
*
*     Specify the initial values for the SP problem.
*
      Y(1) = 5.0D-1
      temp =  sqrt(senpar(1)**2 - y(1)**2)
      Y(2) = -temp
      y(3) = 10.0
      y(4) = 10.0
C
      y(5) = 10.0
      y(7) = -senpar(1)/temp
c     ... the state variables that satisfy the constraints.
c     y(3) = 11.82969400622030
c     y(4) = 6.829877018922193
*     y(5) = y(3)*y(3) + y(4)*y(4) - y(2)
*
*     Y(8) = 2.113537329186674
*     y(9) = -7.886251345948634
*
      return
      end
*------------------------------------------------------------------------*


Module charge_grid_module

  Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

  Use lattice_module, Only : lattice

  Implicit None

  Public :: charge_grid_calculate, charge_grid_find_range, charge_grid_forces

  Private

  Real( wp ), Parameter, Private :: pi = 3.141592653589793238462643383279502884197_wp

Contains

  Subroutine charge_grid_calculate( l, alpha, q, r, range_gauss, q_grid, error )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

    !$ Use omp_lib

    Use lattice_module, Only : lattice

    Implicit none

    Type( lattice )                    , Intent( In    ) :: l
    Real( wp ),                          Intent( In    ) :: alpha
    Real( wp ), Dimension( 1: ),         Intent( In    ) :: q
    Real( wp ), Dimension( 1:, 1: ),     Intent( In    ) :: r
    Integer   , Dimension( 1:3        ), Intent( In    ) :: range_gauss
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent(   Out ) :: q_grid
    Integer                            , Intent(   Out ) :: error

    Real( wp ), Parameter :: pi = 3.141592653589793238462643383279502884197_wp

    ! If set adjust the charge so it adds to zero. If we have zero charge there is
    ! gauranteed to be a solution of the linear equations, as the RHS vector
    ! has no component of the null space of the LHS matrix
    ! If we have to do this this really tells us that our representation of the charge density
    ! is not good enough, so print a warning
    Logical   , Parameter :: stabilise_q     = .True.

    Real( wp ), Parameter :: stabilise_q_tol = 1e-10_wp

    Real( wp ), Dimension( :, :, :, : ), Allocatable :: q_grid_red_hack

    Real( wp ), Dimension( 1:3 ) :: ri
    Real( wp ), Dimension( 1:3 ) :: fi
    Real( wp ), Dimension( 1:3 ) :: f_point
    Real( wp ), Dimension( 1:3 ) :: r_point
    Real( wp ), Dimension( 1:3 ) :: grid_vec

    Real( wp ) :: q_norm
    Real( wp ) :: qi_norm
    Real( wp ) :: q_val
    Real( wp ) :: q_tot, q_av, c, y, t

    Integer, Dimension( 1:3 ) :: n_grid
    Integer, Dimension( 1:3 ) :: i_atom_centre
    Integer, Dimension( 1:3 ) :: i_atom_grid
    Integer, Dimension( 1:3 ) :: i_point
    Integer, Dimension( 1:3 ) :: i_grid

    Integer :: n
    Integer :: n_th, iam
    Integer :: i1, i2, i3
    Integer :: i, i_th

    error = 0

    n = Size( q )
    n_grid = Ubound( q_grid ) + 1

    q_norm = ( ( ( alpha * alpha ) / pi ) ** 1.5_wp )

    ! What follows is a complete HACK to avoid gfortran stupidly putting
    ! arrays it is reducing on the stack and hence seg faulting once the
    ! array gets beyond a certain size - beyond belief, going to whinge about this one!
    !
    ! The proper fix is to //ise the loops over the grid points assoicated with a given
    ! atom. This is a bit complicated currently due to the Modulo meaning if we have
    ! a wide gaussian we can get a race condition. But we have to fix exactly this sort of
    ! thing when going to MPI, hence fix this properly then. At the moment
    ! just want correctness, hence simple HACK as grids really aren't that large

    n_th = 1
    ! Yes, omp_max_threads is a HACK as well ....
    !$ n_th = omp_get_max_threads()
    Allocate( q_grid_red_hack( Lbound( q_grid, Dim = 1 ):Ubound( q_grid, Dim = 1 ), &
         Lbound( q_grid, Dim = 2 ):Ubound( q_grid, Dim = 2 ), &
         Lbound( q_grid, Dim = 3 ):Ubound( q_grid, Dim = 3 ), 0:n_th - 1 ) )

    !$omp parallel default( none ) shared( n, l, alpha, r, q, q_norm, n_grid, q_grid, range_gauss, q_grid_red_hack, n_th ) &
    !$omp                          private( i, i1, i2, i3, qi_norm, ri, fi, i_atom_centre,   &
    !$omp                                   i_atom_grid, i_point, f_point, r_point, grid_vec, q_val, i_grid, iam, i_th )
    !$omp do collapse( 3 )
    Do i3 = 0, n_grid( 3 ) - 1
       Do i2 = 0, n_grid( 2 ) - 1
          Do i1 = 0, n_grid( 1 ) - 1
             q_grid( i1, i2, i3 ) = 0.0_wp
          End Do
       End Do
    End Do
    iam = 0
    !$ iam = omp_get_thread_num()
    Do i3 = 0, n_grid( 3 ) - 1
       Do i2 = 0, n_grid( 2 ) - 1
          Do i1 = 0, n_grid( 1 ) - 1
             q_grid_red_hack( i1, i2, i3, iam ) = 0.0_wp
          End Do
       End Do
    End Do
    ! No need to sync at this point as in the next loop nest we only write to the
    ! bit we have just initalised
    ! Loop over atoms
    !$omp do
    Do i = 1, n
       ! Loop over points associated with atoms
       ! Find point nearest to the atom, and call this the centre for the atom grid
       ! Assumes atom in fractional 0 < ri < 1
       ri = r( :, i )
       qi_norm = q_norm * q( i )
       Call l%to_fractional( ri, fi )
       i_atom_centre = Nint( fi * n_grid )
       Do i3 = - range_gauss( 3 ), range_gauss( 3 )
          Do i2 = - range_gauss( 2 ), range_gauss( 2 )
             Do i1 = - range_gauss( 1 ), range_gauss( 1 )
                i_atom_grid = [ i1, i2, i3 ]
                ! The indices of the point in space
                i_point = i_atom_centre + i_atom_grid
                ! Transform to fractional coordinates
                f_point = Real( i_point, wp ) / n_grid
                ! And fractional to real
                Call l%to_direct( f_point, r_point )
                ! Calculate the contribution to the total charge at the point
                ! R_POINT due to the charge distribution I
                grid_vec = r_point - ri
                q_val = qi_norm * Exp( - alpha * alpha * Dot_product( grid_vec, grid_vec ) )
                ! Reflect grid indices into reference Cell
                i_grid = Modulo( i_point, n_grid )
                ! And add in
                q_grid_red_hack( i_grid( 1 ), i_grid( 2 ), i_grid( 3 ), iam ) = &
                     q_grid_red_hack( i_grid( 1 ), i_grid( 2 ), i_grid( 3 ), iam ) + q_val
             End Do
          End Do
       End Do
    End Do
    !$omp end do
    ! Synced here so OK to add up
    ! Now do the reduction manually - not needed once hacky way is fixed
    Do i_th = 0, n_th - 1
       !$omp do collapse( 3 )
       Do i3 = 0, n_grid( 3 ) - 1
          Do i2 = 0, n_grid( 2 ) - 1
             Do i1 = 0, n_grid( 1 ) - 1
                q_grid( i1, i2, i3 ) = q_grid( i1, i2, i3 ) + q_grid_red_hack( i1, i2, i3, i_th )
             End Do
          End Do
       End Do
       !$omp end do
    End Do
    !$omp end parallel

    ! If required carefully make sure the charge on the grid adds to zero
    If( stabilise_q ) Then
       ! Use Kahan summation as adding lots of very small values
       q_tot = 0.0_wp
       c = 0.0_wp
       Do i3 = 0, n_grid( 3 ) - 1
          Do i2 = 0, n_grid( 2 ) - 1
             Do i1 = 0, n_grid( 1 ) - 1
                y = q_grid( i1, i2, i3 ) - c
                t = q_tot + y
                c = ( t - q_tot ) - y
                q_tot = t
             End Do
          End Do
       End Do
!!$       Write( *, * ) 'Total charge before stabilisation ', q_tot
       If( Abs( q_tot ) > stabilise_q_tol ) Then
!!$          Write( *, * ) 'WARNING: Sum of charge on grid greater than tolerance, sum = ', &
!!$               q_tot, ' tol = ', stabilise_q_tol
          error = -1
       End If
       q_av = q_tot / Size( q_grid )
       Do i3 = 0, n_grid( 3 ) - 1
          Do i2 = 0, n_grid( 2 ) - 1
             Do i1 = 0, n_grid( 1 ) - 1
                q_grid( i1, i2, i3 ) = q_grid( i1, i2, i3 ) - q_av
             End Do
          End Do
       End Do
       q_tot = 0.0_wp
       c = 0.0_wp
       Do i3 = 0, n_grid( 3 ) - 1
          Do i2 = 0, n_grid( 2 ) - 1
             Do i1 = 0, n_grid( 1 ) - 1
                y = q_grid( i1, i2, i3 ) - c
                t = q_tot + y
                c = ( t - q_tot ) - y
                q_tot = t
             End Do
          End Do
       End Do
!!$       Write( *, * ) 'Total charge after  stabilisation ', q_tot
       If( Abs( q_tot ) > stabilise_q_tol ) Then
          error = -2
       End If
    End If

  End Subroutine charge_grid_calculate

  Subroutine charge_grid_forces( l, alpha, q, r, range_gauss, q_grid, pot_grid, ei, f )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

    Use lattice_module, Only : lattice

    Implicit none

    Type( lattice )                    , Intent( In    ) :: l
    Real( wp ),                          Intent( In    ) :: alpha
    Real( wp ), Dimension( 1: ),         Intent( In    ) :: q
    Real( wp ), Dimension( 1:, 1: ),     Intent( In    ) :: r
    Integer   , Dimension( 1:3        ), Intent( In    ) :: range_gauss
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent( In    ) :: q_grid
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent( In    ) :: pot_grid
    Real( wp ), Dimension( 1: )        , Intent(   Out ) :: ei
    Real( wp ), Dimension( 1:, 1: )    , Intent(   Out ) :: f

    Real( wp ), Parameter :: pi = 3.141592653589793238462643383279502884197_wp

    Real( wp ), Dimension( 1:3, 1:3 ) :: stress

    Real( wp ), Dimension( 1:3 ) :: ri
    Real( wp ), Dimension( 1:3 ) :: fi
    Real( wp ), Dimension( 1:3 ) :: f_point
    Real( wp ), Dimension( 1:3 ) :: r_point
    Real( wp ), Dimension( 1:3 ) :: grid_vec

    Real( wp ) :: q_norm
    Real( wp ) :: qi_norm
    Real( wp ) :: g_val
    Real( wp ) :: dV
    Real( wp ) :: s

    Integer, Dimension( 1:3 ) :: n_grid
    Integer, Dimension( 1:3 ) :: i_atom_centre
    Integer, Dimension( 1:3 ) :: i_atom_grid
    Integer, Dimension( 1:3 ) :: i_point
    Integer, Dimension( 1:3 ) :: i_grid

    Integer :: n
    Integer :: i1, i2, i3
    Integer :: i, i_alpha, i_beta

    n      = Size( q )
    n_grid = Ubound( q_grid ) + 1
    dV     = l%get_volume() / Product( n_grid )

    q_norm = ( ( ( alpha * alpha ) / pi ) ** 1.5_wp )

    stress = 0.0_wp

    !$omp parallel default( none ) shared( n, l, alpha, r, q, q_norm, n_grid, q_grid, pot_grid, range_gauss, dV, ei, f, stress ) &
    !$omp                          private( i, i1, i2, i3, qi_norm, ri, fi, i_atom_centre,   &
    !$omp                                   i_atom_grid, i_point, f_point, r_point, grid_vec, g_val, i_grid, s )
    ! Loop over atoms
    ! Stress small array, size invariant, so reduction won't stack smash
    !$omp do reduction( +:stress )
    Do i = 1, n
       ! Loop over points associated with atoms
       ! Find point nearest to the atom, and call this the centre for the atom grid
       ! Assumes atom in fractional 0 < ri < 1
       ri = r( :, i )
       qi_norm = q_norm * q( i ) * dV
       Call l%to_fractional( ri, fi )
       i_atom_centre = Nint( fi * n_grid )
       !
       ei(    i ) = 0.0_wp
       f ( :, i ) = 0.0_wp
       Do i3 = - range_gauss( 3 ), range_gauss( 3 )
          Do i2 = - range_gauss( 2 ), range_gauss( 2 )
             Do i1 = - range_gauss( 1 ), range_gauss( 1 )
                i_atom_grid = [ i1, i2, i3 ]
                ! The indices of the point in space
                i_point = i_atom_centre + i_atom_grid
                ! Transform to fractional coordinates
                f_point = Real( i_point, wp ) / n_grid
                ! And fractional to real
                Call l%to_direct( f_point, r_point )
                ! Vector to the point of interest from the centre of the gaussin
                grid_vec = r_point - ri
                ! Gaussian at that point times normalisation times the volume element
                g_val = qi_norm * Exp( - alpha * alpha * Dot_product( grid_vec, grid_vec ) )
                ! Reflect grid indices into reference Cell
                i_grid = Modulo( i_point, n_grid )
                ! Include the potential term
                g_val = g_val * pot_grid( i_grid( 1 ), i_grid( 2 ), i_grid( 3 ) )
                ! Add into the per particle energy and the force
                ei(    i ) = ei(    i ) + 0.5_wp *                            g_val
                f ( :, i ) = f ( :, i ) - 2.0_wp * alpha * alpha * grid_vec * g_val
                ! Stress term - TOTALLY UNTESTED AND PROBABLY INCOMPLETE
                ! Need short range term due to differentiation of coulomb operator,
                ! and SIC term
                Do i_beta = 1, 3
                   Do i_alpha = i_beta, 3
                      s = - 2.0_wp * g_val * alpha * alpha * grid_vec( i_alpha ) * grid_vec( i_beta )
                      stress( i_alpha, i_beta ) = stress( i_alpha, i_beta ) + s
                   End Do
                End Do
             End Do
          End Do
       End Do
    End Do
    !$omp end do
    !$omp end parallel

    ! Stress - Untested!
    ! Symmetrize stress tensor
    Do i_beta = 1, 2
       Do i_alpha = i_beta + 1, 3
          stress( i_beta, i_alpha ) = stress( i_alpha, i_beta )
       End Do
    End Do

  End Subroutine charge_grid_forces

  Subroutine charge_grid_find_range( l, alpha, n_grid, range_gauss )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

    Use lattice_module, Only : lattice

    Implicit None

    Type( lattice )             , Intent( In    ) :: l
    Real( wp ),                   Intent( In    ) :: alpha
    Integer   , Dimension( 1:3 ), Intent( In    ) :: n_grid
    Integer   , Dimension( 1:3 ), Intent(   Out ) :: range_gauss

    Real( wp ), Dimension( 1:3 ) :: G
    Real( wp ), Dimension( 1:3 ) :: grid_vec

    Real( wp ) :: q_norm
    Real( wp ) :: q_val

    Integer, Dimension( 1:3 ) :: n_vec

    Integer :: i_dir

    n_vec = [ 1, 0, 0 ] ! Will use cshift to move onto next vector
    q_norm = ( ( ( alpha * alpha ) / pi ) ** 1.5_wp )
    Do i_dir = 1, 3
       Call l%get_dir_vec( n_vec, G )
       range_gauss( i_dir ) = 1
       Do
          grid_vec = ( range_gauss( i_dir ) * G ) / ( n_grid( i_dir ) )
          q_val = q_norm * Exp( - alpha * alpha * Dot_product( grid_vec, grid_vec ) )
          If( q_val < 1e-15_wp ) Exit
          range_gauss( i_dir ) = range_gauss( i_dir ) + 1
       End Do
       n_vec = Cshift( n_vec, -1 )
    End Do

  End Subroutine charge_grid_find_range

End Module charge_grid_module


module Initialize

  implicit none

contains

!****************************************************
  subroutine init_X_point(proc_X, y_loc_loc)

    use constants, only: nly_par, y_loc, z_loc, npe
    use grid,      only: r_variable, proc_id
    implicit none
    integer, intent(out) :: proc_X, y_loc_loc

    !!!proc_X=proc_id(r_variable,y_loc) + proc_id(z_loc)*NPE   !proc num that contains the X-point
    proc_X = proc_id(r_variable, y_loc, z_loc)
    y_loc_loc = y_loc - mod(proc_X, npe)*nly_par  !local j-index of the x-point

  end subroutine init_X_point

!****************************************************
  subroutine init_perturb(field)

    use constants
    use transforms, only: FFT2d_inv
    use forcing,    only: ran1
    use grid, only: xx, yy, zz
    use mp,   only: iproc

    implicit none

    real, intent(out), dimension(nlx, nly_par, nlz_par) :: field
    complex, dimension(nky, nkx_par, nlz_par) :: fieldk
    integer :: i, j, k, idum1, n

    fieldk=0.0
    field=0.0

    if(perturb_type=='none') then
    end if

    if(perturb_type=='gaus') then
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
                field(i,j,k) = exp(-(zz(k)*2*pi/lz)**2)*&
                     exp(-(yy(j)*2*pi/ly)**2)*&
                     exp(-(xx(i)*2*pi/lx)**2)
             end do
          end do
       end do
    end if

    if (perturb_type == 'allk') then
    !TTR
#   ifdef gasca2d
       do k = 1, nlz_par
          do i = 1, nkx_par
             do j = 1, nky
                fieldk(j,i,k) = (1.0,1.0) * cos(2*pi*zz(k)/Lz)
             end do
          end do
          if(mod(iproc,npe)==0) fieldk(1,1,k) = 0.0
          call FFT2d_inv(fieldk(:, :, k), field(:, :, k))
       end do
#   elif defined(gasca3d)
       do k = 1, nlz_par
       idum1 = -1*( mod(iproc,npe)+1 )
          do i = 1, nkx_par
             do j = 1, nky
                do n = 1, 16
                fieldk(j,i,k) = fieldk(j,i,k) + (ran1(idum1)+0.5d0 + (0.0,1.0)*(ran1(idum1)-0.5d0))*cos(2*n*pi*zz(k)/Lz+2*pi*ran1(idum1))
                end do
             end do
          end do
          if(mod(iproc, npe) == 0) fieldk(1, 1, k) = 0.0
       end do
       call FFT2d_inv(fieldk(:, :, :), field(:, :, :))
#   endif
    end if

    if (perturb_type == 'onmo') then
    !TTR
#   ifdef gasca2d
       do k = 1, nlz_par
          do i = 1, nkx_par
             do j = 1, nky
                field(i,j,k) = (1.0,1.0)*(2*pi*yy(j)/Ly)*(2*pi*xx(i)/Ly)*(20*pi*zz(k)/Ly)
             end do
          end do
          if(mod(iproc,npe)==0) fieldk(1,1,k) = 0.0
          call FFT2d_inv(fieldk(:, :, k), field(:, :, k))
       end do
#   elif defined(gasca3d)
       do k = 1, nlz_par
          do i = 1, nkx_par
             do j = 1, nky
                fieldk(1,1,10) =  (1.0,1.0)
             end do
          end do
          if(mod(iproc, npe) == 0) fieldk(1, 1, k) = 0.0
       end do
       call FFT2d_inv(fieldk(:, :, :), field(:, :, :))
#   endif
    end if

    if (perturb_type == 'onem') then
    !TTR
#   ifdef gasca2d
       do k = 1, nlz_par
          do i = 1, nkx_par
             do j = 1, nky
                fieldk(1,1,10) = (1.0,1.0)
             end do
          end do
          if(mod(iproc,npe)==0) fieldk(1,1,k) = 0.0
          call FFT2d_inv(fieldk(:, :, k), field(:, :, k))
       end do
#   elif defined(gasca3d)
       do k = 1, nlz_par
          do i = 1, nkx_par
             do j = 1, nky
                fieldk(1,1,10) =  (1.0,1.0)
             end do
          end do
          if(mod(iproc, npe) == 0) fieldk(1, 1, k) = 0.0
       end do
       call FFT2d_inv(fieldk(:, :, :), field(:, :, :))
#   endif
    end if

    if (perturb_type == 'cosi') then
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
                field(i,j,k) = cos(20*pi*xx(i)/Lx)*&
                cos(20*pi*yy(j)/Ly)*cos(4*pi*zz(k)/Lz)
               ! field(i,j,k) = cos(2*pi*yy(j)/Ly)*cos(2*pi*zz(k)/Lz)
             end do
          end do
       end do
    end if

    if (perturb_type == 'rand') then
    !TTR
#   ifdef gasca2d
       do k = 1, nlz_par
          idum1 = -1*( mod(iproc,npe)+1 )
          do i = 1, nkx_par
             do j = 1, nky
                fieldk(j,i,k) = -(ran1(idum1)-0.5d0 + (0.0,1.0)*(ran1(idum1)-0.5d0))*cos(2*pi*zz(k)/Lz)
             end do
          end do
          call FFT2d_inv(fieldk(:, :, k), field(:, :, k))
       end do
#   elif defined(gasca3d)
       do k = 1, nlz_par
          idum1 = -1*( mod(iproc,npe)+1 )
          do i = 1, nkx_par
             do j = 1, nky
                fieldk(j,i,k) = -(ran1(idum1)-0.5d0 + (0.0,1.0)*(ran1(idum1)-0.5d0))*cos(2*pi*zz(k)/Lz)
             end do
          end do
       end do
       call FFT2d_inv(fieldk(:, :, :), field(:, :, :))
#   endif
    end if

    !this was used to test the TVDRK3UW7 for the JCP paper:
    !              Apar_perturb(i,j,k)=perturb_A*cos(xx(i))*&
    !                   0.5*tanh(100*(zz(k)-0.0)-tanh(100*(zz(k)-0.5)))

    field = perturb_amp*field

  end subroutine init_perturb

!*****************************************
  subroutine equilibrium(Apar_eq,  Akpar_eq, uepar_eq, uekpar_eq, &
       &                 Apar_eq_double_prime, Akpar_eq_double_prime, phi_eq)

    use constants,  only: nlx, nly_par, nlz_par, nky, nkx_par, equilib_type, pi, &
         &                Lx, Ly, Lz, phi0, a0
    use grid,       only: xx, yy, zz, kperp, kx
    use transforms, only: FFT2d_direct, FFT2d_inv

    implicit none

    real,    intent(out), dimension(nlx, nly_par, nlz_par) :: Apar_eq, uepar_eq, Apar_eq_double_prime
    real,    intent(out), dimension(nlx, nly_par, nlz_par) :: phi_eq
    complex, intent(out), dimension(nky, nkx_par, nlz_par) :: AKpar_eq, ueKpar_eq,Akpar_eq_double_prime

    integer :: i, j, k

   !AVK 14/7/13 >
    apar_eq = 0.0
    Akpar_eq = 0.0
    uepar_eq = 0.0
    uekpar_eq = 0.0
    apar_eq_double_prime = 0.0
    akpar_eq_double_prime = 0.0
    phi_eq = 0.0

    !<

    if(equilib_type=='tear') then
       !    j0=2./(Leq*Sqrt(Pi))
       do k = 1, nlz_par
          do j = 1, NLy_par
             do i = 1, NLx
                !this is the original one
                !           Apar_eq(i,j)=A0/cosh(xx(i)*2*Pi/lx)**2*(-1.+tanh(XX(i)+Lx/2.)**2+tanh(-XX(i)+Lx/2.)**2)
                !Numata's modification
                Apar_eq(i,j,k) = -A0/cosh(xx(i))**2*&
                     1./(2.*tanh(Pi)**2-tanh(2*Pi))*(tanh(xx(i)-Pi)**2+Tanh(xx(i)+Pi)**2-Tanh(2*Pi)**2)
                phi_eq(i,j,k)=0.0

             end do
          end do
       end do
    end if

    if(equilib_type=='tsin') then
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
  !              Apar_eq(i,j,k)=-A0/4.*cos(2*pi/Lx*xx(i)*4)
                Apar_eq(i,j,k)=-A0*cos(2*pi/Lx*xx(i))
                phi_eq(i,j,k)=0.0
             end do
          end do
       end do
    end if

    if(equilib_type=='kh00') then
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
                Apar_eq(i,j,k)=0.0
                phi_eq(i,j,k)=-PHI0/cosh(xx(i))**2*&
                     1./(2.*tanh(Pi)**2-tanh(2*Pi))*(tanh(xx(i)-Pi)**2+Tanh(xx(i)+Pi)**2-Tanh(2*Pi)**2)
             end do
          end do
       end do
    end if

    if(equilib_type=='OT00') then
       !NFL, 20/03/13
       !Orszag-Tang equilib -- from Numata, JCP 10
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
!                Apar_eq(i,j,k)=cos(4*pi*xx(i)/Lx)+2.*cos(2*pi*yy(j)/ly)
!                phi_eq(i,j,k)=-2.0*(cos(2*pi*xx(i)/Lx)+cos(2*pi*yy(j)/ly))
                Apar_eq(i,j,k) = 0.5*cos(4*pi*xx(i)/Lx) + cos(2*pi*yy(j)/ly)
                phi_eq(i,j,k) = -cos(2*pi*xx(i)/Lx) - cos(2*pi*yy(j)/ly)
             end do
          end do
       end do
    end if

    if(equilib_type=='OTPD') then
       !NFL, 04/07/13
       !Orszag-Tang equilib -- from Paul Dellar, JCP 2013
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
                Apar_eq(i,j,k)=2.0*cos(2*pi*xx(i)/Lx) - cos(4*pi*yy(j)/ly)
                phi_eq(i,j,k)=2.0*cos(2*pi*xx(i)/Lx) - 2.0*sin(2*pi*yy(j)/ly)
             end do
          end do
       end do
    end if

    if(equilib_type=='OTBW') then
       !NFL, 04/07/13
       !Orszag-Tang equilib -- from Biskamp-Welter, PoF B 1989
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
                Apar_eq(i,j,k)=cos(4*pi*xx(i)/Lx + 2.3) + cos(2*pi*yy(j)/ly + 4.1)
                phi_eq(i,j,k)=cos(2*pi*xx(i)/Lx + 1.4) + cos(2*pi*yy(j)/ly + 0.5)
             end do
          end do
       end do
    end if

    if(equilib_type=='OT3D') then
       !NFL, 04/07/13
       !Orszag-Tang equilib -- from Biskamp-Welter, PoF B 1989
       !modulated by a z perturb
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
                Apar_eq(i,j,k)=(cos(4*pi*xx(i)/Lx + 2.3) + cos(2*pi*yy(j)/ly + 4.1))*cos(2*pi*zz(k)/lz)
                phi_eq(i,j,k)=(cos(2*pi*xx(i)/Lx + 1.4) + cos(2*pi*yy(j)/ly + 0.5))*sin(2*pi*zz(k)/lz)
             end do
          end do
       end do
    end if

    if(equilib_type=='OT01') then
       !NFL, 20/03/13
       do k=1,nlz_par
          do j=1,NLy_par
             do i=1,NLx
                Apar_eq(i,j,k)=(cos(4*pi*xx(i)/Lx)+2.*cos(2*pi*yy(j)/ly))*cos(2*pi*zz(k)/lz)
                phi_eq(i,j,k)=-2.0*(cos(2*pi*xx(i)/Lx)+cos(2*pi*yy(j)/ly))*cos(2*pi*zz(k)/lz)
             end do
          end do
       end do
    end if

    !AVK 14/07/13>
    if(equilib_type/='none') then
    !TTR
#   ifdef gasca2d
       do k=1, nlz_par
          call FFT2d_direct (Apar_eq(:, :, k), AKpar_eq(:, :, k))
          !     print*,'equilil',maxval(abs(Apar_eq(:,:,k))),maxval(abs(Akpar_eq(:,:,k)))
          do i = 1, nkx_par
             do j = 1, nky
                uekpar_eq(j, i, k) = -kperp(j, i)**2 * AKpar_eq(j, i, k)
                AKpar_eq_double_prime(j, i, k) = -kx(i)**2 * AKpar_eq(j, i, k)
             end do
          end do
          call FFT2d_inv (AKpar_eq_double_prime(:, :, k), Apar_eq_double_prime(:, :, k))
          call FFT2d_inv (uekpar_eq(:, :, k), uepar_eq(:, :, k))
       end do
#   elif defined(gasca3d)
       call FFT2d_direct (Apar_eq(:, :, :), AKpar_eq(:, :, :))
       do i = 1, nkx_par
          do j = 1, nky
             uekpar_eq(j, i, :) = -kperp(j, i)**2 * AKpar_eq(j, i, :)
             AKpar_eq_double_prime(j, i, :) = -kx(i)**2 * AKpar_eq(j, i, :)
          end do
       end do
       call FFT2d_inv (AKpar_eq_double_prime(:, :, :), Apar_eq_double_prime(:, :, :))
       call FFT2d_inv (uekpar_eq(:, :, :), uepar_eq(:, :, :))
#   endif
    end if

  end subroutine equilibrium

end module Initialize


**********************************************************************
C    SIMPLE HISTOGRAMMING PACKAGE --  SIMPLIFIED VERSION OF HBOOK
C    BY Michelangelo Mangano    NOVEMBER 1988
C    LAST REVISED NOVEMBER 9, 1988
c     (minor modifications by I Hinchliffe   1 May, 89)
C**********************************************************************
C
C Fills up to 100 histograms with up to 100 bins.
C Gives a data file (to be specified in the calling program by assigning
C a file name to unit 98) and a topdrawer file (to be specified in the
C calling program by assigning a file name to unit 99).
C
C INITIALIZATION:
C Call once INIHIST; this just resets a few counters and logicals
C Call MBOOK(N,'TITLE',DEL,XMIN,XMAX) for each histogram to be booked.
C N (an integer) is the label of the histogram;
C 'TITLE' is the name of the histogram (no more then 100 characters);
C DEL (real*8) is the bin size;
C XMIN (real*8) is the lower limit of the first bin;
C XMAX (real*8)is the upper limit of the last  bin
C Example:
C      call mbook(2,'pt distribution',1.,10.,70.)
C This call initializes histogram number 2, called 'pt distribution';
C The bin size will be 1. (possibly GeV, if that's what you want), the
C first bin being  10.<x<11. and the last one being 69.<x<70.
C
C FILLING:
C When it's time, call MFILL(N,X,Y); this will add Y (real*8) to the bin
C in which X (real*8) happens to be, within histogram N.
C
C PLAYING AROUND:
C At the end of the day you may want to sum, divide, cancel, etc.etc.
C various histograms (bin by bin). Then you call MOPERA(I,'O',J,K,X,Y).
C The 1-character string O can take the following values:
C +  : sums       X*(hist I) with Y*(hist J) and puts the result in hist K;
C -  : subtracts  X*(hist I) with Y*(hist J) and puts the result in hist K;
C *  : multiplies X*(hist I) with Y*(hist J) and puts the result in hist K;
C /  : divides    X*(hist I) with Y*(hist J) and puts the result in hist K;
C F  : multiplies hist I by the factor X, and puts the result in hist K;
C R  : takes the square root of  hist  I, and puts the result in hist K;if
C      the value at a given bin is less than or equal to 0., puts 0. in K
C S  : takes the square      of  hist  I, and puts the result in hist K;
C L  : takes the log_10 of  hist  I, and puts the result in hist K; if the
C      value at a given bin is less than or equal to 0., puts 0. in K
C M  : statistical analysis; if I contains the weights (let's say WGT),
C      J contains variable times weight (F*WGT) and K contains the
C      variable squared times the weight (F**2*WGT), then, after using 'M',
C      J will contain the average value of the variable <F> and K will
C      contain the sigma of the average: sigma=sqrt(<F**2>-<F>**2).
C      If WGT=1. for all the entries, then it is enough to put I=J, and
C      it is not necessary to book a hist with the weights.
C V  : estimates errors for vegas evaluation of differential distributions.
C      Fill I with the values of
C      the functions do integrate times the Vegas weight (fun*wgt); fill
C      J with fun**2*wgt; then K will contain an estimate of the error
C      of the integration. Putting X=1/(#of iterations) performs the
C      average over the iterations, and gives the right normalization to
C      the differential distribution, I, and to the errors, K. J stays the same.
C U  : same as V, but I also remains the same (i.e. only K is filled)
C
C FINAL ACCOUNTING:
C Now we can finalize our histograms; MFINAL(N) will calculate the integral
C of the histogram N, the mean value of the X variable and its RMS.
C If we now want to renormalize the hist's, we can call MNORM(N,X), which
C will normalize the integral to X  -- CAUTION: do not call MNORM before
C MFINAL, it will blow up.
C
C OUTPUT:
C To get a .dat file containing the values of the histograms, together with
C some information (like integral, mean values, etc.etc.) call MPRINT(N),
C for each hist N that you want in the .dat file. Before the call to MPRINT
C you want to open unit 98 and give it a name:
C     OPEN(UNIT=98,NAME='NAME.DAT',STATUS='NEW')
C If you want a topdrawer file with a plot of the hist values, call
C MTOP(N,M,'X','Y','SCALE'). The points of the plot will be taken from histogram
C N, the error bars from histogram M. 'SCALE', character*(*), determines
C the scale for y, logarithmic or linear (SCALE=LOG,LIN).
C If you do not want error bars, keep
C a histogram of zeros, or just call a hist that had not been booked.
C X will appear as a 'bottom title', and Y will appear as a 'left title'.
C The top title is by default the name of the histogram itself.
C A little box below the plot will contain some information on the plot
C itself. Before calling MTOP,
C     OPEN(UNIT=99,NAME='NAME.TOP',STATUS='NEW')
c Empty histograms are not put out by MTOP.
C--------------------------------------------------------------------------
      BLOCK DATA HISTOSET
      include 'histo.f'
      data book/nplot*'NO'/
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO',
c     & ' NO','NO',' NO','NO',' NO','NO',' NO','NO',' NO','NO'/
      END

      SUBROUTINE MBOOK(N,TIT,DEL,XMIN,XMAX)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      CHARACTER*(*) TIT
      include 'histo.f'
      NHIST=MAX(N,NHIST)
      TITLE(N)=TIT
      BOOK(N)='YES'
      HDEL(N)=DEL
      HMIN(N)=XMIN
      HMAX(N)=XMAX+1d-8
      NNBIN=INT((XMAX+1d-8-XMIN)/DEL)
      IF (NNBIN .GT. MAXNBIN) THEN
      WRITE(6,*) XMAX,XMIN,DEL,NNBIN,' BIN SIZE TOO LARGE'
      NNBIN=MAXNBIN
      DEL=(XMAX-XMIN)/NNBIN
      ENDIF
      NBIN(N)=NNBIN
      IENT(N)=0
      IUSCORE(N)=0
      IOSCORE(N)=0
      HAVG(N)=0.d0
      HINT(N)=0.d0
      DO 1 I=1,NBIN(N)
      XHIS(N,I)=HMIN(N)+HDEL(N)*(DFLOAT(I)-0.5d0)
      IHIS(N,I)=0
   1  HIST(N,I)=0.d0
      END

      SUBROUTINE MFILL(N,X,Y)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      include 'histo.f'
      I=INT((X-HMIN(N))/HDEL(N)+1)
      IF(I.GT.0.AND.I.LE.NBIN(N))  THEN
!$omp atomic
      IENT(N)=IENT(N)+1
!$omp atomic
      IHIS(N,I)=IHIS(N,I)+1
      Yadd=Y/hdel(n)
!$omp atomic
      HIST(N,I)=HIST(N,I)+Yadd
c     we are renormalising the weights by the bin width
      ELSEIF(I.LE.0) THEN
!$omp atomic
      IUSCORE(N)=IUSCORE(N)+1
      ELSEIF(I.GT.NBIN(N)) THEN
!$omp atomic
      IOSCORE(N)=IOSCORE(N)+1
      ENDIF
      END

      SUBROUTINE MOPERA(I,OPER,J,K,X,Y)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      CHARACTER OPER*1
      include 'histo.f'
      IF(NBIN(I).NE.NBIN(J).AND.(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.
     &'*'.OR.OPER.EQ.'/'.OR.OPER.EQ.'M')) GO TO 10
      DO L=1,NBIN(I)
      IF(OPER.EQ.'+') THEN
      HIST(K,L)=X*HIST(I,L) + Y*HIST(J,L)
      ELSEIF(OPER.EQ.'-') THEN
      HIST(K,L)=X*HIST(I,L) - Y*HIST(J,L)
      ELSEIF(OPER.EQ.'*') THEN
      HIST(K,L)=X*HIST(I,L) * Y*HIST(J,L)
      ELSEIF(OPER.EQ.'/') THEN
        IF(Y.EQ.0.d0.OR.HIST(J,L).EQ.0.d0) THEN
          HIST(K,L)=0.d0
          ELSE
          HIST(K,L)=X*HIST(I,L) / (Y*HIST(J,L))
        ENDIF
      ELSEIF(OPER.EQ.'F') THEN
      HIST(K,L)=X*HIST(I,L)
      ELSEIF(OPER.EQ.'R') THEN
        IF(HIST(I,L).GT.0.d0) THEN
        HIST(K,L)=X*SQRT(HIST(I,L))
        ELSE
        HIST(K,L)=0.d0
        ENDIF
      ELSEIF(OPER.EQ.'S') THEN
      HIST(K,L)=X*HIST(I,L)**2
      ELSEIF(OPER.EQ.'l') THEN
        IF(HIST(I,L).EQ.0.d0.OR.J.EQ.0) THEN
             HIST(K,L)=0.d0
             ELSE
             HIST(K,L)=X*LOG10(Y*HIST(I,L))
        ENDIF
      ELSEIF(OPER.EQ.'M') THEN
        IF(I.NE.J) XNORM=HIST(I,L)
        IF(I.EQ.J) XNORM=DFLOAT(IHIS(J,L))
        IF(XNORM.NE.0.d0) THEN
        XAVG=HIST(J,L)/XNORM
        HIST(K,L)=DSQRT(ABS(-XAVG**2+HIST(K,L)/XNORM)/DFLOAT(IHIS(I,L)))
        HIST(J,L)=XAVG
        ELSE
        HIST(K,L)=0.d0
        HIST(J,L)=0.d0
        ENDIF
      ELSEIF(OPER.EQ.'V') THEN
        XAVG=HIST(I,L)*X
        XSQAVG=HIST(J,L)*X
c--- need extra factor to account for renormalization by bin width
        XSQAVG=XSQAVG/hdel(i)
        XNORM=(IENT(I)+IUSCORE(I)+IOSCORE(I))*X
        IF(XNORM.NE.0.d0) THEN
        HIST(K,L)=DSQRT(X*ABS(XSQAVG-XAVG**2/XNORM))
        HIST(I,L)=XAVG
        ELSE
        HIST(K,L)=0.d0
        ENDIF
      ELSEIF(OPER.EQ.'U') THEN ! same as 'V', but write errors only
        XAVG=HIST(I,L)*X
        XSQAVG=HIST(J,L)*X
c--- need extra factor to account for renormalization by bin width
        XSQAVG=XSQAVG/hdel(i)
        XNORM=(IENT(I)+IUSCORE(I)+IOSCORE(I))*X
        IF(XNORM.NE.0.d0) THEN
        HIST(K,L)=DSQRT(X*ABS(XSQAVG-XAVG**2/XNORM))
c        HIST(I,L)=XAVG ! removed from 'V'
        ELSE
        HIST(K,L)=0.d0
        ENDIF
      ELSE
      WRITE(98,5) OPER
   5  FORMAT(' ****** OPERATION ="',A1,'" UNKNOWN ********'/)
      RETURN
      ENDIF
      END DO
      RETURN
  10  WRITE(98,20) I,J
  20  FORMAT(' ****** INCOMPATIBLE OPERATION HIST ',I3,' &',I3,
     &                                                   '*******'/)
      END

      SUBROUTINE MZERO(N)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      include 'histo.f'
      BOOK(N)='RES'
      IENT(N)=0
      IUSCORE(N)=0
      IOSCORE(N)=0
      HAVG(N)=0.d0
      HINT(N)=0.d0
      DO 1 I=1,NBIN(N)
      IHIS(N,I)=0
   1  HIST(N,I)=0.d0
      END

      SUBROUTINE MRESET(N)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      include 'histo.f'
      BOOK(N)='RES'
      END

      SUBROUTINE MFINAL(N)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      include 'histo.f'
      IF(BOOK(N).NE.'YES') RETURN
      AVG=0.d0
      XIN=0.d0
c      SIG=0.d0
      DO 1, J=1,NBIN(N)
      AVG=AVG+HIST(N,J)*XHIS(N,J)
   1  XIN=XIN+HIST(N,J)
      IF(XIN.EQ.0.d0) GO TO 10
      HAVG(N)=AVG/XIN
c      DO 2, J=1,NBIN(N)
c   2  SIG=HIST(N,J)*(XHIS(N,J)-HAVG(N))**2+SIG
c      IF(SIG.GE.0.)HSIG(N)=SQRT(SIG/XIN)
      HINT(N)=XIN*hdel(n)
      RETURN
  10  BOOK(N)=' NO'
      END

      SUBROUTINE MNORM(N,X)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      include 'histo.f'
      IF(BOOK(N).NE.'YES')RETURN
      DO 1, I=1,NBIN(N)
    1 HIST(N,I)=HIST(N,I)/HINT(N)*X
      HINT(N)=X
      END

      SUBROUTINE MPRINT(N,L)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      include 'histo.f'
      logical scaleplots
      double precision scalefac
      common/scaleplots/scalefac,scaleplots
c      DATA INI/0/
c      IF(INI.EQ.0) THEN
c      CALL IDATE(IMON,IDAY,IYEAR)
c      CALL TIME(CTIME)
c      INI=1
c      ENDIF
      IF(BOOK(N).NE.'YES') then
      write(98,21) n
      RETURN
      end if
c      WRITE(98,7) N,IYEAR,IMON,IDAY,CTIME(1:5)
      WRITE(98,8) N
      WRITE(98,*) TITLE(N)
      DO I=1,NBIN(N)
      if (scaleplots) then
      WRITE(98,10) XHIS(N,I),scalefac*HIST(N,I),HIST(L,I)
      else
      WRITE(98,10) XHIS(N,I),HIST(N,I),HIST(L,I)
      endif
      ENDDO
      WRITE(98,15) HAVG(N),HSIG(N),HINT(N)
      WRITE(98,20) IENT(N),IUSCORE(N),IOSCORE(N)
c    7 FORMAT(4X,'HIST = ',I3,'   19',I2,'-',I2,'-',I2,1X,A5/)
    8 FORMAT(4X,'HIST = ',I3)
   10 FORMAT(3(3x,G13.6))
   15 FORMAT(/' AVG =',E10.3,4X,' RMS =',E10.3,' INTEGRAL =',E10.3,/)
   20 FORMAT('ENTRIES=',I10,1X,'U`FLOW=',I10,1X,'O`FLOW=',I10,//)
   21 FORMAT(' HISTOGRAM ',I3,' IS EMPTY')
      END

      SUBROUTINE MTOP(N,M,BTIT,LTIT,SCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      CHARACTER*(*) LTIT,BTIT,SCALE
      include 'histo.f'
c--- added these variables to scale plots at intermediate steps
      logical scaleplots
      double precision scalefac
      common/scaleplots/scalefac,scaleplots
c      DATA INI/0/
c      IF(INI.EQ.0) THEN
c      CALL IDATE(IMON,IDAY,IYEAR)
c      CALL TIME(CTIME)
c      INI=1
c      ENDIF

      IF(BOOK(N).NE.'YES') RETURN
c      WRITE(99,100) TITLE(N),BTIT,LTIT,SCALE,HMIN(N),HMAX(N)
      WRITE(99,101) TITLE(N),TITLE(N),TITLE(N),SCALE,HMIN(N),HMAX(N)
c  100 FORMAT( /1x,
c     &' SET WINDOW Y 2.5 TO 7.'/,1X,
c     &' SET WINDOW X 2.5 TO 10.'/,1X,
c     &' SET FONT DUPLEX '/1X,
c     &' SET SYMBOL 5O SIZE 1.8'/,1X,
c     &' TITLE TOP ','"',A50,'"',/1X,
c     &' TITLE BOTTOM ','"',A50,'"',/1X,
c     &' TITLE LEFT ','"',A50,'"',/1X,
c     &' SET SCALE Y ',A5,/1X,
c     &' (SET TICKS TOP OFF)   '/1x,
c     &' SET LIMITS X ',F10.5,' ',F10.5,/1X,
c     &' SET ORDER X Y DY ')
  100 FORMAT( /1x,
     &' SET WINDOW Y 2.5 TO 7.'/,1X,
     &' SET WINDOW X 2.5 TO 10.'/,1X,
     &' SET SYMBOL 5O SIZE 1.8'/,1X,
     &' TITLE TOP ','"',A50,'"',/1X,
     &' TITLE BOTTOM ','"',A50,'"',/1X,
     &' TITLE LEFT ','"',A50,'"',/1X,
     &' SET SCALE Y ',A5,/1X,
     &' (SET TICKS TOP OFF)   '/1x,
     &' SET LIMITS X ',F10.5,' ',F10.5,/1X,
     &' SET ORDER X Y DY')
  101 FORMAT( /1x,
     &' SET WINDOW Y 2.5 TO 7.'/,1X,
     &' SET WINDOW X 2.5 TO 10.'/,1X,
     &' SET SYMBOL 5O SIZE 1.8'/,1X,
     &' TITLE TOP SIZE=3','"',A,/1X,
     &' TITLE BOTTOM ','"',A,'"',/1X,
     &' TITLE LEFT ','"dS/d',A,' [fb]"',/1X,
     &' CASE       ','" G"',/1X,
     &' SET SCALE Y ',A5,/1X,
     &' (SET TICKS TOP OFF)   '/1x,
     &' SET LIMITS X ',F10.5,' ',F10.5,/1X,
     &' SET ORDER X Y DY')
      DO 1 J=1,NBIN(N)
c      IF(HIST(N,J).EQ.0.) GO TO 1
      if (scaleplots) then
      WRITE(99,'(3X,G13.6,2(2X,G13.4))')
     & XHIS(N,J),scalefac*HIST(N,J),HIST(M,J)
      else
      WRITE(99,'(3X,G13.6,2(2X,G13.4))')
     &                            XHIS(N,J),HIST(N,J),HIST(M,J)
      endif
    1 CONTINUE
      WRITE(99,200)
  200 FORMAT('   PLOT')
      if (scaleplots) then
      WRITE(99,300) scalefac*HINT(N),scalefac*HAVG(N),scalefac*HSIG(N),
     & IENT(N),IUSCORE(N),IOSCORE(N)
      else
      WRITE(99,300) HINT(N),HAVG(N),HSIG(N),IENT(N),IUSCORE(N)
     &   ,IOSCORE(N)
      endif
c  300 FORMAT( /1x,
c     &' BOX 7. 0.75 SIZE 9. 1.5'/,1X,
c     &' SET WINDOW Y 0. TO 2.'/,1X,
c     &' SET TITLE SIZE -1.5'/1X,
c     &' SET FONT DUPLEX '/1X,
c     &' TITLE 2.8 1.2 "INTEGRAL =',E10.3,'   AVERAGE =',E10.3,
c     &             '   RMS =',E10.3,'"',/1X,
c     &' TITLE 2.8 0.8 "Entries =',I10,4x,'Underflow =',I10,4X
c     &                                 ,'Overflow =',I10,'"',/1X,
c     &' SET TITLE SIZE -2')
  300 FORMAT( /1x,
     &' BOX 7. 0.75 SIZE 9. 1.5'/,1X,
     &' SET WINDOW Y 0. TO 2.'/,1X,
     &' SET TITLE SIZE -1.5'/1X,
     &' TITLE 2.8 1.2 "INTGRL =',E12.5,'   AVGE =',E12.5,
     &             '   RMS =',E12.5,'"',/1X,
     &' TITLE 2.8 0.8 "Entries =',I9,2x,'U`flow =',I9,2X
     &                                 ,'O`flow =',I9,'"',/1X,
     &' SET TITLE SIZE -2')
      WRITE(99,400)
  400 FORMAT('   NEW PLOT')
      END

C*******************************************************************
C     END OF THE HISTOGRAMMING PACKAGE
C*******************************************************************

c--F  Add gnuplot output

      SUBROUTINE MGNUPLOT(N,M,BTIT,LTIT,SCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      CHARACTER*(*) LTIT,BTIT,SCALE
      include 'histo.f'
c--- added these variables to scale plots at intermediate steps
      logical scaleplots
      double precision scalefac
      common/scaleplots/scalefac,scaleplots

      istring=LEN_TRIM(TITLE(N))

      IF(BOOK(N).NE.'YES') RETURN
      WRITE(97,101) TITLE(N)(1:istring), TITLE(N)(1:istring),
     & TITLE(N)(1:istring), HMIN(N),HMAX(N)
  101 FORMAT( /1x,
     &' set title ','"',A,' distribution" font "Helvetica, 20"',/1X,
     &' set xlabel ','"',A,'" font "Helvetica, 20"',/1X,
     &' set ylabel ','"d{/Symbol s}/d',A,
     &' [fb]" font "Helvetica, 20"',/1X,
     &' set xrange [ ',F10.5,':',F10.5,']')
      if(SCALE .eq. 'log') then
         write(97,*) ' set logscale y'
      endif
      write(97,*) ' plot "-" with histeps'

      DO 1 J=1,NBIN(N)
      IF(HIST(N,J).EQ.0.) GO TO 1
      if (scaleplots) then
      WRITE(97,'(3(2X,G13.6))')
     & XHIS(N,J),scalefac*HIST(N,J),HIST(M,J)
      else
      WRITE(97,'(3X,G13.6,2(2X,G13.6))')
     &                            XHIS(N,J),HIST(N,J),HIST(M,J)
      endif
    1 CONTINUE
      WRITE(97,200)
  200 FORMAT(' e')
      END

c--F  Add root output

      SUBROUTINE MROOTPLOT(N,M,BTIT,LTIT)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      CHARACTER*(*) LTIT,BTIT
      CHARACTER*5 histoid
      include 'histo.f'
c--- added these variables to scale plots at intermediate steps
      logical scaleplots
      double precision scalefac
      common/scaleplots/scalefac,scaleplots

      istring=LEN_TRIM(TITLE(N))

      if (N.lt.10) then
         write(histoid, '(A2,I1,A2)') 'id', N, '  '
      elseif ((N.ge.10).and.(N.lt.100)) then
         write(histoid, '(A2,I2,A1)') 'id', N, ' '
      elseif (N.ge.100) then
         write(histoid, '(A2,I3)') 'id', N
      endif

      idlength=LEN_TRIM(histoid)

      IF(BOOK(N).NE.'YES') RETURN

      WRITE(96,131) histoid(1:idlength), TITLE(N)(1:istring), NBIN(N),
     & HMIN(N), HMAX(N)
 131  FORMAT ( /1X,
     & ' mcfmhisto -> cd();', /1X,
     & ' TH1F *hist = new TH1F( "', A, '", "', A, '", ',
     & I0, ', ', F10.5, ', ', F10.5, ');')

      WRITE(96, 132) histoid(1:idlength), TITLE(N)(1:istring),
     & histoid(1:idlength), TITLE(N)(1:istring)
 132  FORMAT ( /1X,
     & ' ', A, ' -> GetXaxis() -> SetTitle("', A, '");', /1X,
     & ' ', A, ' -> GetYaxis() -> SetTitle(" d#sigma/d', A,
     & ' [fb]");', /1X)

      WRITE (96,*) ' ', histoid(1:idlength), ' -> GetYaxis() -> ',
     & 'SetTitleOffset(1.2);'

      WRITE(96,*) ' ', histoid(1:idlength), ' -> SetStats(false);'

      DO 1 J=1,NBIN(N)
      IF(HIST(N,J).EQ.0.) GO TO 1
      if (scaleplots) then
      WRITE(96,'(3(2X,G13.6))')
     & XHIS(N,J),scalefac*HIST(N,J),HIST(M,J)
      else
C         write(96,*) ' ', histoid(1:idlength), ' -> Fill(',
C     &        XHIS(N,J), ', ', HIST(N,J), ');'
         write(96,*) '  int xbin = ', histoid(1:idlength),'->FindBin(',
     & XHIS(n,j),');'
         write(96,*) ' ', histoid(1:idlength), ' -> SetBinContent(',
     &       ' xbin', ', ', HIST(N,J), ');'
         write(96,*) ' ', histoid(1:idlength), ' -> SetBinError(',
     &       ' xbin', ', ', HIST(M,J), ');'
      endif
    1 CONTINUE

      WRITE (96, *) ' histos -> Add(hist); '
      WRITE (96, *) ''
      WRITE (96, *) ''

      END


c=======================================================================
c
c     subroutine QP
c
c     Quadratic solver
c
c     Minimization of function  f(x) = 1/2*x'*quamat*x + plin'*x
c
c            cinf(i) <= x(i) <= csup(i), i=1,nmat
c            (cmat(1,j),...,cmat(nmat,j))*x  = bvect(j) for j=1,nceg
c            (cmat(1,j),...,cmat(nmat,j))*x <= bvect(j)
c                                               for j=nceg+1,nceg+ncineg
c
c-----------------------------------------------------------------------
      SUBROUTINE qp ( nmat, quamat, plin, nceg, ncineg, cmat, bvect,
     &                cinf, csup, iwork, dwork,
     &                lagr, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            nmat   : size of the matrix                         integer
c            quamat : quadratic matrix (nmat*nmat)                double
c            plin   : linear part vector (nmat)                   double
c            nceg   : number of equality constraints             integer
c            ncineg : number of inequality constraints           integer
c            cmat   : matrix of constraints (nmat*(nceg+ncineg))  double
c            bvect  : vector of constraints (nceg+ncineg)         double
c            cinf   : inferior limit vector (nmat)                double
c            csup   : superior limit vector (nmat)                double
c
c     WORKSPACE
c            iwork  : (3*nmat + 2*ncineg + nceg + 1)             integer
c            dwork  : (nmat*nmat + 6*nmat + 2*ncineg)             double
c
c     OUTPUT
c            lagr   : Lagrange multipliers (nmat+ncineg+nceg)     double
c            wopt   : optimal vector (nmat)                       double
c            info   : diagnostic argument                        integer
c
c-------------------------------------------------------------------------------
c     USED FUNCTION
c
c     From rne/optim/ directory:
c     anfm01.f anfm03.f anfm05.f anrs01.f auxo01.f dimp03.f dnrm0.f optr03.f
c     pasr03.f zthz.f anfm02.f anfm04.f anfm06.f anrs02.f desr03.f dipvtf.f
c     optr01.f opvf03.f plcbas.f
c
c     From BLAS library:
c     daxpy.f dcopy.f ddot.f dnrm2.f dscal.f dswap.f idamax.f
c
c     From LAPACK library:
c     dlamch.f
c
c     From rne/calelm directory:
c     add.f ddif.f dmmul.f
c
c     PLCBAS Error Codes
c                   =   1 maximal number of iterations exceeded
c                   =  -1 no inferior bound supplied
c                   =  -2 degenerate point with indefinite cycle
c                   =  -3 may be there is a problem of bound. Too large
c                         gap between 2 successive iterations
c                   =  -4 incorrect data
c                   = -11 incompatibility of equality constraints
c                         detected when calling OPTR01.
c                   = -12 no admissible points OPTR01 with the given
c                         constraints
c                   = -13 degenerate point with indefinite cycle in
c                         OPTR01.
c                   = -14 maximal number of iterations for OPTR01
c                         reached without finding an admissible point
c                   = -15 cinf constraints no verified
c                   = -16 csup constraints no verified
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER nmat, nceg, ncineg, info, iter
      DOUBLE PRECISION quamat(nmat,*), wopt(*), plin(*), lagr(*),
     &                 cinf(*), csup(*), cmat(nmat,*), bvect(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER modo, imp, ira, iosort
      DOUBLE PRECISION fopt
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     modo = 1 : normal call
c     modo = 2 : as modo = 1,may be util when matrix is definite positive
c     modo = 3 : call with initial conditions (compatible with restrictions)
      modo = 1
c
c     parameters for output: no output here
      imp    = 6
      iosort = 6
c
c     ira = 0  : no bounds
c     ira = 1  : only lower bounds
c     ira = 2  : only upper bounds
c     ira = 3  : lower and upper bounds
      ira = 3
c
c     Number maximum of iterations
C     if ITER <= 0, number max=14*(nmat+nceg+ncineg)
      iter = 0
c
      CALL plcbas ( quamat, plin, cmat, bvect, cinf, csup, ira,
     &              nceg, ncineg, wopt, fopt, dwork, iwork, lagr, imp,
     &              iosort, nmat, modo, info, iter )
c------------------------------------------------------------------------
c    INPUTS
c
c     quamat    Matrix of dimension (N,N), the quadratic part.
c               By default only the triangular inferior part is supplied.
c
c     plin      Vector  N-dimensional of the linear part
c
c     cmat      Matrix of dimension (N,MI+MD). Contiene los coeficientes
c               de las restricciones  de igualdad y  desigualdad. Los de
c               igualdad se almacenan en las  MI primeras columnas de la
c               matriz  C  y los de desigualdad en las restantes.
c
c     bvect     Vector of dimension  MI+MD. Contiene los coeficientes de
c               los  terminos  independientes  de  las  restricciones de
c               igualdad y desigualdad.
c
c     cinf      Si  IRA= 0  o  2  esta  variable  no sera  utilizada. Si
c               IRA= 1  o  3,   CI  sera  un  vector  de  dimension  N
c               conteniendo las cotas inferiores de  X. Si  X(I) no esta
c               acotado  inferiormente, CI(I)  debera ser  menor  que la
c               raiz cuadrada negativa  de la constante real  mas grande
c               de la maquina.
c
c     csup      Si  IRA= 0  o  1  esta  variable no  sera  utilizada. Si
c               IRA= 2  o  3,  CS   sera  un  vector  de  dimension  N
c               conteniendo las cotas superiores de  X. Si  X(I) no esta
c               acotado  superiormente,  CS(I)  debera  ser  mayor  que
c               la raiz cuadrada de la constante real  mas grande  de la
c               maquina.
c
c     ira       Variable  que  indica  si  existen  restricciones  de
c               acotacion en el problema. Toma los valores:
c                  0  : No existen restricciones de acotacion.
c                  1  : Se  tienen  solo  restricciones  de  acotacion
c                       inferior.
c                  2  : Existen solo restricciones de acotacion superior
c                  3  : Se tienen ambos tipos de restriccion.
c
c     nceg      Numero de restricciones de igualdad del problema.
c
c     ncineg    Numero  de  restricciones  de desigualdad  del  problema
c
c        W      Vector de trabajo de dimension  N*N+6*N+2*MD
c
c        IV     Vector entero  de dimension  3*N+2*MD+MI+1.
c
c     IMP    Indicador del nivel de impresion de salida de resultados
c               Toma los valores:
c                  6  : Sin salida de resultados.
c                  7  : Escribe el motivo de finalizacion del proceso.
c                  8  : Se obtiene informacion referente  a la solucion:
c                       el numero de iteraciones; el  optimo  calculado,
c                       la norma del vector de Kuhn-Tucker, el numero de
c                       restricciones activas y cuales   son    (para
c                       identificar estas restricciones  se  sigue el
c                       siguiente convenio para los valores que se
c                       obtienen:
c
c                       [-N,-1]         : Restriciones de cota inferior
c                       [ 1,N ]         : Restricciones de cota superior
c                       [N+1,N+MI]      : Restricciones de igualdad
c                       [N+MI+1,N+MI+MD]: Restricciones de desigualdad)
c
c                       y los multiplicadores de  Lagrange  asociados  a
c                       ellas  (si IND=0);  el valor  del funcional  ;
c                       la norma del punto calculado (si  IND=-3).
c
c                  9  : Se obtiene  informacion referente  al desarrollo
c                       de las iteraciones:  el numero de  restricciones
c                       activas   y cuales  son  (para identificarlas se
c                       sigue el convenio anterior), la restriccion que
c                       se anade  o  se  elimina  del conjunto activo,
c                       el  tipo  de  direccion   de  descenso calculada
c                       y las iteraciones  con  punto degenerado.
c
c               > 10  : Ademas,  se  obtiene  el punto calculado en cada
c                       iteracion e informacion sobre el proceso llevado
c                       a cabo por OPTR01. (Ver valores posibles de  IMP
c                       en  OPTR01).
c
c        IO     Output chanel number.
c
c        N      Number of problem variables (N > 1).
c
c        MODO   Variable que indica el modo de comienzo del proceso con
c               los valores:
c                  1  : No se facilita un punto inicial,ni restricciones
c                       recomendadas como activas.
c                  2  : Igual que MODO = 1, pero la subrutina trabaja
c                       de forma diferente. Este caso debe utilizarse
c                       cuando hay valores de seguridad para las
c                       variables o las restricciones que son grandes y
c                       que previsiblemente no seran alcanzados.
c                       Tambien puede ser util este MODO cuando la
c                       forma cuadratica es definida positiva.
c                  3  : Se facilita un punto inicial. En este caso
c                       el punto ha de ser admisible para todas las
c                       restricciones.
c
c     OUTPUTS
c
c        X      Vector of dimension N, optimal vector,
c
c        F      Variable  que  contiene  el  valor  del funcional  en el
c               optimo si el proceso  ha finalizado sin problemas.
c
c      LAGR     Vector of double precision of dimension N+MI+MD si IRA es
c               mayor que cero y de dimension MI+MD si IRA=0.En las N
c               primeras componentes contiene los multiplicadores de
c               Lagrange asociados a las restricciones de cota (si IRA
c               es mayor que cero) y en las MI+MD ultimas componentes
c               contiene los multiplicadores asociados a las de igualdad
c               y desigualdad respectivamente.
c
c      INFO     Diagnostic argument
c-------------------------------------------------------------------------
c     error code
      IF (info .EQ. 1)   info =  1007
      IF (info .EQ. -12) info =  1001
      IF (info .EQ. -1)  info = -1002
      IF (info .EQ. -2)  info = -1003
      IF (info .EQ. -3)  info = -1004
      IF (info .EQ. -4)  info = -1005
      IF (info .EQ. -11) info = -1006
      IF (info .EQ. -13) info = -1003
      IF (info .EQ. -14) info =  1007
c
      RETURN
      END


!=============================================================================!
        subroutine cpenta2bc( n, nsys, nblk, mat, rhs, mult, fact, code )
!=============================================================================!
!
!  Solves a block pentadiagonal system of equations without pivoting.
!  Vectorized over the second index.
!
!  This version includes the Boundary Treatment, and complex math
!
!  WARNING: Since pivoting is not done, this algorithm could fail
!
!  input:
!    nsys       : number of systems to vectorize over
!    n          : number of rows in the systems
!    nblk       : dimension of the blocks in each row
!    code       : 0 = LU factorization only
!               : 1 = Forward and back solves given LU
!               : 2 = LU and solve
!
!  inout:
!    mat        : the block pentadiagonal matrix to be solved
!    rhs        : the right hand side
!
!  Revised:  8-6-96
!=============================================================================!
        implicit none

        integer n, nblk, nsys, code
        complex mat(n,nsys,nblk,nblk,5), rhs(n,nsys,nblk)
        complex mult(nsys), fact(nsys)

!.... useful constants

        real zero, one
        parameter (zero = 0.0, one = 1.0)

!.... local variables

        integer nc, i, j, l, m, p, q, r, s, t, iv

!=============================================================================!
!                       L U   F A C T O R I Z A T I O N
!=============================================================================!

        if (code .eq. 0 .or. code .eq. 2) then

!.... do the first row

        i = 1

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
                mat(i,iv,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,4) = mat(i,iv,l,q,4) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(i,iv,l,q,5) = mat(i,iv,l,q,5) + mult(iv) * mat(i,iv,nc,q,5)
                  mat(i,iv,l,q,1) = mat(i,iv,l,q,1) + mult(iv) * mat(i,iv,nc,q,1)
                  mat(i,iv,l,q,2) = mat(i,iv,l,q,2) + mult(iv) * mat(i,iv,nc,q,2)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do iv = 1, nsys
              fact(iv) = one / mat(i,iv,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(p,iv,m,nc,2) * fact(iv)
                mat(p,iv,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,2) = mat(p,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,3) = mat(p,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(p,iv,m,q,4) = mat(p,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,5)
                  mat(p,iv,m,q,5) = mat(p,iv,m,q,5) + mult(iv) * mat(i,iv,nc,q,1)
                  mat(p,iv,m,q,1) = mat(p,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,2)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(r,iv,m,nc,1) * fact(iv)
                mat(r,iv,m,nc,1) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,1) = mat(r,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,2) = mat(r,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(r,iv,m,q,3) = mat(r,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,5)
                  mat(r,iv,m,q,4) = mat(r,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,1)
                  mat(r,iv,m,q,5) = mat(r,iv,m,q,5) + mult(iv) * mat(i,iv,nc,q,2)
                end do
              end do

            end do

          end do        ! end of loop on nc

!.... do the second row

        i = 2

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
                mat(i,iv,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,4) = mat(i,iv,l,q,4) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(i,iv,l,q,5) = mat(i,iv,l,q,5) + mult(iv) * mat(i,iv,nc,q,5)
                  mat(i,iv,l,q,1) = mat(i,iv,l,q,1) + mult(iv) * mat(i,iv,nc,q,1)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do iv = 1, nsys
              fact(iv) = one / mat(i,iv,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(p,iv,m,nc,2) * fact(iv)
                mat(p,iv,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,2) = mat(p,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,3) = mat(p,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(p,iv,m,q,4) = mat(p,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,5)
                  mat(p,iv,m,q,5) = mat(p,iv,m,q,5) + mult(iv) * mat(i,iv,nc,q,1)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(r,iv,m,nc,1) * fact(iv)
                mat(r,iv,m,nc,1) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,1) = mat(r,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,2) = mat(r,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(r,iv,m,q,3) = mat(r,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,5)
                  mat(r,iv,m,q,4) = mat(r,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,1)
                end do
              end do

            end do

          end do        ! end of loop on nc

!.... do the interior rows

        do i = 3, n - 5

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
                mat(i,iv,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,4) = mat(i,iv,l,q,4) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(i,iv,l,q,5) = mat(i,iv,l,q,5) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do iv = 1, nsys
              fact(iv) = one / mat(i,iv,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(p,iv,m,nc,2) * fact(iv)
                mat(p,iv,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,2) = mat(p,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,3) = mat(p,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(p,iv,m,q,4) = mat(p,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(r,iv,m,nc,1) * fact(iv)
                mat(r,iv,m,nc,1) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,1) = mat(r,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,2) = mat(r,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(r,iv,m,q,3) = mat(r,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

            end do

          end do        ! end of loop on nc

        end do          ! end of loop on i

!.... do the (n-4)th row

        i = n - 4

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
                mat(i,iv,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,4) = mat(i,iv,l,q,4) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(i,iv,l,q,5) = mat(i,iv,l,q,5) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2
            s = i + 3
            t = i + 4

            do iv = 1, nsys
              fact(iv) = one / mat(i,iv,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(p,iv,m,nc,2) * fact(iv)
                mat(p,iv,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,2) = mat(p,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,3) = mat(p,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(p,iv,m,q,4) = mat(p,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(r,iv,m,nc,1) * fact(iv)
                mat(r,iv,m,nc,1) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,1) = mat(r,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,2) = mat(r,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(r,iv,m,q,3) = mat(r,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(s,iv,m,nc,5) * fact(iv)
                mat(s,iv,m,nc,5) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(s,iv,m,q,5) = mat(s,iv,m,q,5) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(s,iv,m,q,1) = mat(s,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(s,iv,m,q,2) = mat(s,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(t,iv,m,nc,4) * fact(iv)
                mat(t,iv,m,nc,4) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(t,iv,m,q,4) = mat(t,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(t,iv,m,q,5) = mat(t,iv,m,q,5) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(t,iv,m,q,1) = mat(t,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

            end do

          end do        ! end of loop on nc

!.... do the (n-3)rd row

        i = n - 3

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
                mat(i,iv,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,4) = mat(i,iv,l,q,4) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(i,iv,l,q,5) = mat(i,iv,l,q,5) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2
            s = i + 3

            do iv = 1, nsys
              fact(iv) = one / mat(i,iv,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(p,iv,m,nc,2) * fact(iv)
                mat(p,iv,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,2) = mat(p,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,3) = mat(p,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(p,iv,m,q,4) = mat(p,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(r,iv,m,nc,1) * fact(iv)
                mat(r,iv,m,nc,1) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,1) = mat(r,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,2) = mat(r,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(r,iv,m,q,3) = mat(r,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(s,iv,m,nc,5) * fact(iv)
                mat(s,iv,m,nc,5) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(s,iv,m,q,5) = mat(s,iv,m,q,5) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(s,iv,m,q,1) = mat(s,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(s,iv,m,q,2) = mat(s,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

            end do

          end do        ! end of loop on nc

!.... do the (n-2)nd row

        i = n - 2

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
                mat(i,iv,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,4) = mat(i,iv,l,q,4) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(i,iv,l,q,5) = mat(i,iv,l,q,5) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do iv = 1, nsys
              fact(iv) = one / mat(i,iv,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(p,iv,m,nc,2) * fact(iv)
                mat(p,iv,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,2) = mat(p,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,3) = mat(p,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(p,iv,m,q,4) = mat(p,iv,m,q,4) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

              do iv = 1, nsys
                mult(iv) = -mat(r,iv,m,nc,1) * fact(iv)
                mat(r,iv,m,nc,1) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,1) = mat(r,iv,m,q,1) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(r,iv,m,q,2) = mat(r,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,4)
                  mat(r,iv,m,q,3) = mat(r,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,5)
                end do
              end do

            end do

          end do        ! end of loop on nc

!.... do the next-to-the-last row

        i = n - 1

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
                mat(i,iv,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(i,iv,l,q,4) = mat(i,iv,l,q,4) + mult(iv) * mat(i,iv,nc,q,4)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1

            do iv = 1, nsys
              fact(iv) = one / mat(i,iv,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(p,iv,m,nc,2) * fact(iv)
                mat(p,iv,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,2) = mat(p,iv,m,q,2) + mult(iv) * mat(i,iv,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(p,iv,m,q,3) = mat(p,iv,m,q,3) + mult(iv) * mat(i,iv,nc,q,4)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... do the last row

        i = n

        do nc = 1, nblk - 1

          do m = nc, nblk - 1
            l = m + 1
            do iv = 1, nsys
              mult(iv) = -mat(i,iv,l,nc,3) / mat(i,iv,nc,nc,3)
              mat(i,iv,l,nc,3) = mult(iv)
            end do
            do q = nc + 1, nblk
              do iv = 1, nsys
                mat(i,iv,l,q,3) = mat(i,iv,l,q,3) + mult(iv) * mat(i,iv,nc,q,3)
              end do
            end do
          end do

        end do  ! end of loop on nc

        end if
!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!
        if (code.eq.1 .or. code.eq.2) then

!.... do the first row

        i = 1

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = mat(i,iv,l,nc,3)
                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(p,iv,m,nc,2)
                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(r,iv,m,nc,1)
                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

            end do

          end do        ! end of loop on nc

!.... do the second row

        i = 2

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = mat(i,iv,l,nc,3)
                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(p,iv,m,nc,2)
                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(r,iv,m,nc,1)
                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

            end do

          end do        ! end of loop on nc

!.... do the interior rows

        do i = 3, n - 5

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = mat(i,iv,l,nc,3)
                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(p,iv,m,nc,2)
                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(r,iv,m,nc,1)
                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

            end do

          end do        ! end of loop on nc

        end do          ! end of loop on i

!.... do the (n-4)th row

        i = n - 4

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = mat(i,iv,l,nc,3)
                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2
            s = i + 3
            t = i + 4

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(p,iv,m,nc,2)
                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(r,iv,m,nc,1)
                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(s,iv,m,nc,5)
                rhs(s,iv,m) = rhs(s,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(t,iv,m,nc,4)
                rhs(t,iv,m) = rhs(t,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

            end do

          end do        ! end of loop on nc

!.... do the (n-3)rd row

        i = n - 3

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = mat(i,iv,l,nc,3)
                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2
            s = i + 3

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(p,iv,m,nc,2)
                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(r,iv,m,nc,1)
                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(s,iv,m,nc,5)
                rhs(s,iv,m) = rhs(s,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

            end do

          end do        ! end of loop on nc

!.... do the (n-2)nd row

        i = n - 2

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = mat(i,iv,l,nc,3)
                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(p,iv,m,nc,2)
                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(r,iv,m,nc,1)
                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

            end do

          end do        ! end of loop on nc

!.... do the next-to-the-last row

        i = n - 1

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              do iv = 1, nsys
                mult(iv) = mat(i,iv,l,nc,3)
                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(p,iv,m,nc,2)
                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... do the last row

        i = n

        do nc = 1, nblk - 1

          do m = nc, nblk - 1
            l = m + 1
            do iv = 1, nsys
              mult(iv) = mat(i,iv,l,nc,3)
              rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
            end do
          end do

        end do  ! end of loop on nc

!=============================================================================!
!                   B A C K W A R D   S U B S T I T U T I O N
!=============================================================================!

!.... do the last row first

        i = n

        do m = nblk, 1, -1
          do q = m+1, nblk
            do iv = 1, nsys
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(i,iv,q) * mat(i,iv,m,q,3)
            end do
          end do
          do iv = 1, nsys
            rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,m,3)
          end do
        end do

!.... do the next-to-the-last row

        i = n - 1
        p = i + 1

        do m = nblk, 1, -1
          do q = m+1, nblk
            do iv = 1, nsys
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(i,iv,q) * mat(i,iv,m,q,3)
            end do
          end do
          do q = 1, nblk
            do iv = 1, nsys
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,q) * mat(i,iv,m,q,4)
            end do
          end do
          do iv = 1, nsys
            rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,m,3)
          end do
        end do

!.... now do the rest of the rows in reverse order

        do i = n - 2, 3, -1

          p = i + 1
          r = i + 2

          do m = nblk, 1, -1
            do q = m+1, nblk
              do iv = 1, nsys
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(i,iv,q) * mat(i,iv,m,q,3)
              end do
            end do
            do q = 1, nblk
              do iv = 1, nsys
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,q) * mat(i,iv,m,q,4)
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,q) * mat(i,iv,m,q,5)
              end do
            end do
            do iv = 1, nsys
              rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,m,3)
            end do
          end do

        end do

!.... Do the last two boundary rows

          i = 2
          p = i + 1
          r = i + 2
          s = i + 3

          do m = nblk, 1, -1
            do q = m+1, nblk
              do iv = 1, nsys
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(i,iv,q) * mat(i,iv,m,q,3)
              end do
            end do
            do q = 1, nblk
              do iv = 1, nsys
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,q) * mat(i,iv,m,q,4)
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,q) * mat(i,iv,m,q,5)
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,q) * mat(i,iv,m,q,1)
              end do
            end do
            do iv = 1, nsys
              rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,m,3)
            end do
          end do

          i = 1
          p = i + 1
          r = i + 2
          s = i + 3
          t = i + 4

          do m = nblk, 1, -1
            do q = m+1, nblk
              do iv = 1, nsys
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(i,iv,q) * mat(i,iv,m,q,3)
              end do
            end do
            do q = 1, nblk
              do iv = 1, nsys
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,q) * mat(i,iv,m,q,4)
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,q) * mat(i,iv,m,q,5)
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,q) * mat(i,iv,m,q,1)
                rhs(i,iv,m) = rhs(i,iv,m) - rhs(t,iv,q) * mat(i,iv,m,q,2)
              end do
            end do
            do iv = 1, nsys
              rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,m,3)
            end do
          end do

        end if
!=============================================================================!
        return
        end