! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_C3

USE Precision_Model, ONLY: stnd

Implicit NONE

PRIVATE

PUBLIC :: Rule_C3a

CONTAINS
      SUBROUTINE Rule_C3a(VER,INFOLD,VOLUME,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_C3a
!***DATE WRITTEN   970430   (YYMMDD)
!***REVISION DATE  990528   (YYMMDD)  (F conversion)
!***REVISION DATE  990604   (YYMMDD)  (divisions removed)
!***REVISION DATE  010919   (YYMMDD)  (subdivision information changed)
!***AUTHOR
!          Erwin Goor & Ronald Cools
!***PURPOSE  To compute basic integration rule values and
!            corresponding error estimates.
!***DESCRIPTION Rule_C3a computes basic integration rule values
!            for a vector of integrands over a cube.
!            Rule_C3a also computes estimates for the errors by
!            using several null rule approximations.
!   ON ENTRY
!
!   VER    Real array of dimension (3,4).
!          The coordinates of the vertices of the cube.
!          vertex i -> ( ver(1,i),ver(2,i),ver(3,i) )
!   NUMFUN Integer.
!          Number of components of the vector integrand.
!   Integrand Externally declared subroutine for computing
!            all components of the integrand at the given
!            evaluation point.
!            It must have parameters (X)
!            Input parameters:
!              X(1)   The x-coordinate of the evaluation point.
!              X(2)   The y-coordinate of the evaluation point.
!              X(3)   The z-coordinate of the evaluation point.
!
!   ON RETURN
!
!   BASVAL Real array of dimension NUMFUN.
!          The values for the basic rule for each component
!          of the integrand.
!   RGNERR Real array of dimension NUMFUN.
!          The error estimates for each component of the integrand.
!   NUM    Integer
!          The number of function evaluations used.
!   INFOLD(4) contains useful information for future subdivisions.
!          This is a 2 digit number.
!          The least significant digit contains info for 2-division.
!          The most significant digit contains info for 2/4/8-division.
!
!***REFERENCES Terje O. Espelid,
!              On the construction of good fully symmetric integration rules
!              SIAM J. NUMER. ANAL., Vol 24, No 4, August 1987.
!***ROUTINES CALLED
!                   OrbC3_Sum,Integrand
!***END PROLOGUE Rule_C3a
!
!   Parameters
!
!   ORBITS Integer
!          The number of orbits of the cubature formula and null rules
!   CRIVAL Real
!          The decision to choose the optimistic part of the error
!          estimator is based on CRIVAL
!   FACMED Real
!          FACMED is the safety coefficient used in the non-optimistic
!          part of the error estimator. FACMED is related to CRIVAL
!          and FACOPT.
!   FACOPT Real
!          FACOPT is the safety coefficient used in the optimistic part
!          of the error estimator.
!   K      Integer array of dimension (0:4) that contains the structure
!          parameters. K(I) = number of orbits of type I.
!   TYPE0  Real array of dimension (K(0)).
!          Contains the first homogeneous coordinate of the generators
!          of type 0
!   TYPE1  Real array of dimension (K(1)).
!          Contains the first homogeneous coordinate of the generators
!          of type 1
!   TYPE2  Real array of dimension (K(2)).
!          Contains the first homogeneous coordinate of the generators
!          of type 2
!   TYPE3  Real array of dimension (K(3)).
!          Contains the first homogeneous coordinate of the generators
!          of type 3
!   TYPE4  Real array of dimension (2,K(4)).
!          Contains the first two homogeneous coordinates of
!          the generators of type 4.
!   WEIGHT Real array of dimension (8,ORBITS).
!          The weights of the cubature formula and the null rules.
!          WEIGHT(1,1) ,..., WEIGHT(1,ORBITS) are the weights of the
!                cubature formula
!          WEIGHT(I,1) ,..., WEIGHT(I,ORBITS) for I > 1, are the weights
!                of the null rules
!
!
!   Global variables.
!
      INTEGER, INTENT(IN)  :: NUMFUN
      INTEGER, INTENT(OUT) ::  NUM
      INTEGER, DIMENSION(:), INTENT(IN OUT) :: INFOLD
      REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
      REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
      REAL(kind=stnd), INTENT(IN) :: VOLUME

      INTERFACE
         FUNCTION Integrand(NUMFUN,X) RESULT(Value)
            USE Precision_Model
            INTEGER, INTENT(IN) :: NUMFUN
            REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
            REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
         END FUNCTION Integrand
      END INTERFACE
!
!   Constants
!
  INTEGER, PARAMETER ::   ORBITS = 8
  REAL(kind=stnd), PARAMETER:: HALF=0.5_stnd,                      &
                               TRES=50*EPSILON(HALF),              &
                               EIGHT=8.0_stnd,                     &
                               CRIVAL=0.5_stnd,                    &
                               FACMED=16.0_stnd,                   &
                               FACOPT=FACMED/CRIVAL,               &
                               CUTOFF=0.0001_stnd,                 &
                               BOUND1=0.55_stnd,                   &
                               BOUND2=0.1_stnd
  REAL(kind=stnd),DIMENSION(0:2),PARAMETER ::                      &
                            DFC = (/-1.888242615950863158_stnd,    &
                                     1.0_stnd,                     &
                                    -0.055878692024568421_stnd/)
!
!  Cubature formula of degree 11 with 89 points
!
          INTEGER, DIMENSION(0:4), PARAMETER ::                    &
                      K = (/1,2,1,2,2/)    ! Rule structure parameters
!
!  Information for the generators
!
     INTEGER :: I
     REAL(kind=stnd), DIMENSION(1:2), PARAMETER ::                 &
             TYPE1 = (/ 0.18052075573249470822058794973169_stnd,   &
                        0.76366700531389881917491285487593_stnd/)
     REAL(kind=stnd), DIMENSION(1:1), PARAMETER ::                 &
             TYPE2 = (/ 0.78830647250493547382701809890320_stnd/)
     REAL(kind=stnd), DIMENSION(1:2), PARAMETER ::                 &
             TYPE3 = (/ 0.52144095618907883093466563244662_stnd,   &
                        0.82617221731829521680258049987187_stnd/)
     REAL(kind=stnd), DIMENSION(1:2,1:2), PARAMETER ::             &
              TYPE4 = RESHAPE( SOURCE= (/                          &
                         0.97242481190902569341735290339642_stnd,  &
                         0.42110799536126494561573004212340_stnd,  &
                         0.46744847718063717386066856549398_stnd,  &
                         0.95930890177116312068682678508629_stnd/),&
                        SHAPE=(/2,2/), ORDER=(/2,1/) )
!
!  Weights of the cubature formula
!
     REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
          W1 = (/                                                  &
                       -3.8953757160532611282600158759761_stnd,    &
                       0.81856660649734492124488620848997_stnd,    &
                       0.21531990811243713389570303707084_stnd,    &
                       0.13294125786605972133694036186057_stnd,    &
                       0.20860736817139167236507600668966_stnd,    &
                       0.58773830247770211247176280672459E-1_stnd, &
                       0.14162520571796920029532663140195E-1_stnd, &
                       0.67408810538559624656933076917621E-1_stnd /)
!
!  Weights of the null rule of degree 7
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::           &
           W2 = (/                                                 &
                      -4.09716713830698487528731726354974_stnd,    &
                       0.74677969141515975595448607337805_stnd,    &
                      -0.46417363966526945568711797402935E-1_stnd, &
                       0.17727896857214604523364317327611E-1_stnd, &
                      -0.52470267108342327292624832196503E-1_stnd, &
                       0.11664449246716569286439872549707E-1_stnd, &
                      -0.53791657604525012052256857235844E-2_stnd, &
                       0.57418721863532854861331639295054E-2_stnd /)
!
!  Weights of null rule of degree 5
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::           &
           W3 = (/                                                 &
                      -0.38418257346076321180942534161643E-1_stnd, &
                      -0.13809393819461658172313782493931_stnd,    &
                      -0.36966067391537395134033779422780_stnd,    &
                      -0.84000216250042784132468820210803_stnd,    &
                       0.98945444020489415899976989198423_stnd,    &
                      -0.41711084444475038186621253136889_stnd,    &
                       0.16359771673332304281428383670012_stnd,    &
                       0.19416157968042709878528265453063_stnd /)
!
!  Weights of first null rule of degree 5
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::           &
           W4 = (/                                                 &
                      -0.14339024357997965865651041863131_stnd,    &
                      -0.66574999845489902738481549374176_stnd,    &
                       1.41839687939449181019382815244241_stnd,    &
                      -0.38081150117982085429476186080312E-1_stnd, &
                       0.34239475207312939941374219725925_stnd,    &
                      -0.23914717080898300739086398648709_stnd,    &
                       0.17286429544022414400537142491791_stnd,    &
                      -0.37042670755501427522315796603400_stnd/)
!
!  Weights of second null rule of degree 5
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::           &
           W5 = (/                                                 &
                       0.22799738734760429615753528373102E-2_stnd, &
                       0.11905590372687096358500385350270E-1_stnd, &
                       0.33061061773693696525589383114487_stnd,    &
                      -0.85087326218125136673746262977113_stnd,    &
                      -0.36662650042420411259687111438947_stnd,    &
                       0.67323896068825610599714357264483_stnd,    &
                      -0.21824874793205523689197441637244_stnd,    &
                       0.45575717466252940526695071801422_stnd/)
!
!  Weights of null rule of degree 3
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::           &
           W6 = (/                                                 &
                       0.90256803909235587533523794574584E-1_stnd, &
                       0.48637869392568312594620915328833_stnd,    &
                       0.22605864607138151215790621639873_stnd,    &
                      -0.39733053275758221554551132969977_stnd,    &
                      -0.70260525791346956325766210839408_stnd,    &
                      -0.99463956560911321939850485360746_stnd,    &
                       0.40396337255003509831702095024785_stnd,    &
                       0.17858013317413262800119803474017_stnd/)
!
!   Weights of null rule of degree 3
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::           &
           W7 = (/                                                 &
                      -0.14921225605249988383647637370117_stnd,    &
                      -0.85591937094309731035699238944552_stnd,    &
                      -0.19099496525254529541694749463933_stnd,    &
                       0.19040522291618896750255618030982_stnd,    &
                      -0.27115051668249444743700654045145_stnd,    &
                      -0.35979905900549990374887346342547_stnd,    &
                      -0.30255473948150702142743236951006_stnd,    &
                       0.68561441463717546800811910057288_stnd/)
!
!   Weights of null rule of degree 1
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::           &
           W8 = (/                                                 &
                      -0.08621714823499486708026259436068_stnd,    &
                      -0.50649036609789532778219912403455_stnd,    &
                      -0.32380295374003822370848233043689_stnd,    &
                      -0.20985459608863301976909856362672_stnd,    &
                      -0.32887361592661612467795805597359_stnd,    &
                       0.21614962128074085470205806229955_stnd,    &
                       0.73079630784536188048918935662702_stnd,    &
                      -0.37712863378314543994499210520609_stnd/)
!
     REAL(kind=stnd), DIMENSION(1:8,1:ORBITS), PARAMETER ::        &
          WEIGHT =  RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7,W8/), &
                          SHAPE=(/8,ORBITS/), ORDER=(/2,1/) )
!
!   Local variables.
!
      INTEGER :: J,NR,P,REGTYPE,NUMBER
      INTEGER, DIMENSION(1:3) :: DIFFINDEX
      REAL(kind=stnd):: NOISE,DEG7,DEG5,DEG3,DEG1,R3,R2,R1,R,      &
                Z1,Z2
      REAL(kind=stnd), DIMENSION(NUMFUN,7) :: NullRule
      REAL(kind=stnd), DIMENSION(NUMFUN) :: SUMVAL
      REAL(kind=stnd), DIMENSION(1:3) :: DIFF
      REAL(kind=stnd), DIMENSION(3,24) :: X
!
!***FIRST EXECUTABLE STATEMENT Rule_C3a
!

!  The number of points used by the cubature formula is
!     NUM    = 1*K(0) + 6*K(1) + 12*K(2) + 8*K(3) +24*K(4) = 89
          NUM = 89
!
!  Initialise BASVAL and NullRule
!
          BASVAL = 0
          NullRule = 0
!
!  Compute contributions from orbits with 1, 6, 12, 8 and 24  points
!
          P = 1
          DO REGTYPE = 0,4
                DO NR = 1,K(REGTYPE)
                      SELECT CASE (REGTYPE)
                      CASE (0) !       Generator ( 0, 0, 0 )
                              NUMBER = 1
                              X(:,1) = (VER(:,2) + VER(:,3))*HALF +                 &
                                             ( VER(:,4) - VER(:,1) )*HALF
                      CASE (1) !       Generator ( z1 , 0, 0 )
                              Z1 = TYPE1(NR)*HALF
                              NUMBER = 6
                              X(:,1) = -VER(:,1)*(z1+HALF) + VER(:,2)*HALF +        &
                                   VER(:,3)*HALF + VER(:,4)*(Z1+HALF)
                              X(:,2) = VER(:,1)*(z1-HALF) + VER(:,2)*HALF +         &
                                   VER(:,3)*HALF + VER(:,4)*(-Z1+HALF)
                              X(:,3) = -VER(:,1)*(z1+HALF) + VER(:,2)*HALF +        &
                                   VER(:,4)*HALF + VER(:,3)*(Z1+HALF)
                              X(:,4) = VER(:,1)*(z1-HALF) + VER(:,2)*HALF +         &
                                   VER(:,4)*HALF + VER(:,3)*(-Z1+HALF)
                              X(:,5) = -VER(:,1)*(z1+HALF) + VER(:,4)*HALF +        &
                                   VER(:,3)*HALF + VER(:,2)*(Z1+HALF)
                              X(:,6) = VER(:,1)*(z1-HALF) + VER(:,4)*HALF +         &
                                   VER(:,3)*HALF + VER(:,2)*(-Z1+HALF)
                      CASE (2) !       Generator ( z1 , z1, 0 )
                              Z1 = TYPE2(NR)*HALF
                              NUMBER = 12
                              X(:,1) = -VER(:,1)*(2*z1+HALF) + VER(:,4)*HALF +      &
                                   (VER(:,2) + VER(:,3))*(Z1+HALF)
                              X(:,2) = VER(:,1)*(2*z1-HALF) + VER(:,4)*HALF +       &
                                   (VER(:,2) + VER(:,3))*(-Z1+HALF)
                              X(:,3) = -VER(:,1)*(HALF) + VER(:,4)*HALF +           &
                                   VER(:,2)*(-z1+HALF) + VER(:,3)*(z1+HALF)
                              X(:,4) = -VER(:,1)*(HALF) + VER(:,4)*HALF +           &
                                   VER(:,3)*(-z1+HALF) + VER(:,2)*(z1+HALF)
                              X(:,5) = -VER(:,1)*(2*z1+HALF) + VER(:,3)*HALF +      &
                                   (VER(:,2) + VER(:,4))*(Z1+HALF)
                              X(:,6) = VER(:,1)*(2*z1-HALF) + VER(:,3)*HALF +       &
                                   (VER(:,2) + VER(:,4))*(-Z1+HALF)
                              X(:,7) = -VER(:,1)*(HALF) + VER(:,3)*HALF +           &
                                   VER(:,2)*(-z1+HALF) + VER(:,4)*(z1+HALF)
                              X(:,8) = -VER(:,1)*(HALF) + VER(:,3)*HALF +           &
                                   VER(:,4)*(-z1+HALF) + VER(:,2)*(z1+HALF)
                              X(:,9) = -VER(:,1)*(2*z1+HALF) + VER(:,2)*HALF +      &
                                   (VER(:,4) + VER(:,3))*(Z1+HALF)
                              X(:,10) = VER(:,1)*(2*z1-HALF) + VER(:,2)*HALF +      &
                                    (VER(:,4) + VER(:,3))*(-Z1+HALF)
                              X(:,11) = -VER(:,1)*(HALF) + VER(:,2)*HALF +          &
                                    VER(:,4)*(-z1+HALF) + VER(:,3)*(z1+HALF)
                              X(:,12) = -VER(:,1)*(HALF) + VER(:,2)*HALF +          &
                                    VER(:,3)*(-z1+HALF) + VER(:,4)*(z1+HALF)
                      CASE (3) !       Generator ( z1 , z1, z1 )
                              Z1 = TYPE3(NR)*HALF
                              NUMBER = 8
                              X(:,1) = -VER(:,1)*(3*z1 + HALF) + VER(:,2)*(HALF + z1) + &
                                   VER(:,3)*(HALF + z1) + VER(:,4)*(HALF + z1)
                              X(:,2) = -VER(:,1)*(z1 + HALF) + VER(:,2)*(HALF - z1) +   &
                                   VER(:,3)*(HALF + z1) + VER(:,4)*(HALF + z1)
                              X(:,3) = -VER(:,1)*(z1 + HALF) + VER(:,2)*(HALF + z1) +   &
                                   VER(:,3)*(HALF - z1) + VER(:,4)*(HALF + z1)
                              X(:,4) = -VER(:,1)*(z1 + HALF) + VER(:,2)*(HALF + z1) +   &
                                   VER(:,3)*(HALF + z1) + VER(:,4)*(HALF - z1)
                              X(:,5) = -VER(:,1)*(-z1 + HALF) + VER(:,2)*(HALF - z1) +  &
                                   VER(:,3)*(HALF - z1) + VER(:,4)*(HALF + z1)
                              X(:,6) = -VER(:,1)*(-z1 + HALF) + VER(:,2)*(HALF - z1) +  &
                                   VER(:,3)*(HALF + z1) + VER(:,4)*(HALF - z1)
                              X(:,7) = -VER(:,1)*(-z1 + HALF) + VER(:,2)*(HALF + z1) +  &
                                   VER(:,3)*(HALF - z1) + VER(:,4)*(HALF - z1)
                              X(:,8) = VER(:,1)*(3*z1 - HALF) + VER(:,2)*(HALF - z1) +  &
                                   VER(:,3)*(HALF - z1) + VER(:,4)*(HALF - z1)
                      CASE (4) !       Generator ( z1 , z1, z2 )
                                                Z1 = TYPE4(1,NR)*HALF
                              Z2 = TYPE4(2,NR)*HALF
                              NUMBER = 24
                              X(:,1) = -VER(:,1)*(2*z1+z2+HALF) + VER(:,4)*(HALF + z2) +   &
                                   VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF + z1)
                              X(:,2) = -VER(:,1)*(2*z1-z2+HALF) + VER(:,4)*(HALF - z2) +   &
                                   VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF + z1)
                              X(:,3) = -VER(:,1)*(z2+HALF) + VER(:,4)*(HALF + z2) +        &
                                   VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF + z1)
                              X(:,4) = -VER(:,1)*(z2+HALF) + VER(:,4)*(HALF + z2) +        &
                                   VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF - z1)
                              X(:,5) = -VER(:,1)*(-2*z1+z2+HALF) + VER(:,4)*(HALF + z2) +  &
                                   VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF - z1)
                              X(:,6) = -VER(:,1)*(-z2+HALF) + VER(:,4)*(HALF - z2) +       &
                                   VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF - z1)
                              X(:,7) = -VER(:,1)*(-z2+HALF) + VER(:,4)*(HALF - z2) +       &
                                   VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF + z1)
                              X(:,8) = -VER(:,1)*(-2*z1-z2+HALF) + VER(:,4)*(HALF - z2) +  &
                                   VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF - z1)
                              X(:,9) = -VER(:,1)*(2*z1+z2+HALF) + VER(:,2)*(HALF + z2) +   &
                                   VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF + z1)
                              X(:,10) = -VER(:,1)*(2*z1-z2+HALF) + VER(:,2)*(HALF - z2) +  &
                                    VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF + z1)
                              X(:,11) = -VER(:,1)*(z2+HALF) + VER(:,2)*(HALF + z2) +       &
                                    VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF + z1)
                              X(:,12) = -VER(:,1)*(z2+HALF) + VER(:,2)*(HALF + z2) +       &
                                    VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF - z1)
                              X(:,13) = -VER(:,1)*(-2*z1+z2+HALF) + VER(:,2)*(HALF + z2) + &
                                    VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF - z1)
                              X(:,14) = -VER(:,1)*(-z2+HALF) + VER(:,2)*(HALF - z2) +      &
                                    VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF - z1)
                              X(:,15) = -VER(:,1)*(-z2+HALF) + VER(:,2)*(HALF - z2) +      &
                                    VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF + z1)
                              X(:,16) = -VER(:,1)*(-2*z1-z2+HALF) + VER(:,2)*(HALF - z2) + &
                                    VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF - z1)
                              X(:,17) = -VER(:,1)*(2*z1+z2+HALF) + VER(:,3)*(HALF + z2) +  &
                                    VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF + z1)
                              X(:,18) = -VER(:,1)*(2*z1-z2+HALF) + VER(:,3)*(HALF - z2) +  &
                                    VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF + z1)
                              X(:,19) = -VER(:,1)*(z2+HALF) + VER(:,3)*(HALF + z2) +       &
                                    VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF + z1)
                              X(:,20) = -VER(:,1)*(z2+HALF) + VER(:,3)*(HALF + z2) +       &
                                    VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF - z1)
                              X(:,21) = -VER(:,1)*(-2*z1+z2+HALF) + VER(:,3)*(HALF + z2) + &
                                    VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF - z1)
                              X(:,22) = -VER(:,1)*(-z2+HALF) + VER(:,3)*(HALF - z2) +      &
                                    VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF - z1)
                              X(:,23) = -VER(:,1)*(-z2+HALF) + VER(:,3)*(HALF - z2) +      &
                                    VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF + z1)
                              X(:,24) = -VER(:,1)*(-2*z1-z2+HALF) + VER(:,3)*(HALF - z2) + &
                                    VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF - z1)
                      END SELECT
                      SUMVAL = Integrand(NUMFUN,X(:,1))
                      SELECT CASE (REGTYPE)
                      CASE (0)
                           DIFF(2) = SUMVAL(1)*DFC(0)
                           DIFF(1) = DIFF(2)
                           DIFF(3) = DIFF(2)
                      CASE (1)
                           DIFF(3) = DIFF(3) + SUMVAL(1)*DFC(NR)
                      END SELECT
                      DO J = 2,NUMBER
                           RGNERR = Integrand(NUMFUN,X(:,J))
                           IF ( REGTYPE == 1 ) THEN
                                IF ( J <= 2 ) THEN
                                     DIFF(3) = DIFF(3) + RGNERR(1)*DFC(NR)
                                ELSE IF ( (J == 3) .OR. (J == 4) ) THEN
                                     DIFF(2) = DIFF(2) + RGNERR(1)*DFC(NR)
                                ELSE
                                     DIFF(1) = DIFF(1) + RGNERR(1)*DFC(NR)
                                END IF
                           END IF
                           SUMVAL(1:NUMFUN) = SUMVAL(1:NUMFUN) + RGNERR(1:NUMFUN)
                      END DO
                                  DO J = 1,NUMFUN
                         BASVAL(J) = BASVAL(J) + WEIGHT(1,P)*SUMVAL(J)
                         DO I = 1,7
                           NullRule(J,I) = NullRule(J,I) + WEIGHT(I+1,P)*SUMVAL(J)
                         END DO
                                  END DO
                      P = P + 1
                END DO
          END DO
!
!  Decide on future subdivision direction
!
          DIFF = ABS(DIFF)
          ! Sort the fourth differences
          DIFFINDEX = (/ 1,2,3 /)
          DO I = 1,2
               DO J = 1,(3-I)
                    IF ( DIFF(J+1) > DIFF(J) ) THEN
                         R = DIFF(J)  ! dummy
                         DIFF(J) = DIFF(J+1)
                         DIFF(J+1) = R
                         P = DIFFINDEX(J)  ! dummy
                         DIFFINDEX(J) = DIFFINDEX(J+1)
                         DIFFINDEX(J+1) = P
                    END IF
               END DO
          END DO
          if ( diff(1) < cutoff ) then   ! recommend uniform division
             !!  infold(4) = 0
             infold(4) = 90+diffindex(1)
          else
             if ( diff(2) > bound1*diff(1) ) then
                if ( diff(3) > bound2*diff(2) ) then
                   ! recommend uniform division
                   !! infold(4) = 0
                   infold(4) = 90+diffindex(1)
                else
                   ! recommend division in 4
                   select case (diffindex(3))
                   case(1)
                          infold(4) = -3
                   case(2)
                          infold(4) = -1
                   case(3)
                          infold(4) = -2
                   end select
                   infold(4) = 10*infold(4) - diffindex(1)
                end if
             else
                ! recommend division in 2
                infold(4) = diffindex(1)
             end if
          end if
!
!  Compute error estimates
!
          DO J = 1,NUMFUN
                NOISE = ABS(BASVAL(J))*TRES
                DEG7 = ABS( NullRule(J,1) )
                IF (DEG7 <= NOISE) THEN
                      RGNERR(J) = NOISE
                ELSE
                         DEG5 = SQRT(NullRule(J,2)**2+NullRule(J,3)**2)
                      DEG3 = SQRT(NullRule(J,4)**2+NullRule(J,5)**2)
                      DEG1 = SQRT(NullRule(J,6)**2+NullRule(J,7)**2)
                      IF (DEG5 /= 0) THEN
                                      R1 = DEG7/DEG5
                      ELSE
                                      R1 = 1
                      END IF
                      IF (DEG3 /= 0) THEN
                                      R2 = DEG5/DEG3
                      ELSE
                                      R2 = 1
                      END IF
                      IF (DEG1 /= 0) THEN
                                      R3 = DEG3/DEG1
                      ELSE
                                      R3 = 1
                      END IF
                      R = MAX(R1,R2,R3)
                      IF (R >= 1) THEN
                           INFOLD(5) = 0
                           RGNERR(J) = FACMED*DEG7
                      ELSE IF (R >= CRIVAL) THEN
                           INFOLD(5) = 0
                           RGNERR(J) = FACMED*R*DEG7
                      ELSE
                           INFOLD(5) = 1
                           RGNERR(J) = FACOPT*(R**2)*DEG7
                      END IF
                      RGNERR(J) = MAX(NOISE,RGNERR(J))
                END IF
                RGNERR(J) = VOLUME*RGNERR(J)/EIGHT
                BASVAL(J) = VOLUME*BASVAL(J)/EIGHT
          END DO
          RETURN
          END SUBROUTINE Rule_C3a

END Module CubatureRule_C3


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine sim2bc                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.5
!  Written by Gordon A. Fenton, TUNS, Jul 16, 1999
!  Latest Update: Sep 9, 2002
!
!  PURPOSE  simulates soil property fields for MRBEAR2D
!
!  DESCRIPTION
!  This routine simulates up to 5 soil property fields (cohesion, friction
!  angle, dilation angle, elastic modulus, and Poisson's ratio), which are
!  possibly intercorrelated. Individual fields are generated as standard
!  Gaussian random fields using the 2-D Local Average Subdivision (LAS)
!  algorithm. These fields are then combined to produce correlated standard
!  Gaussian fields using the Covariance Matrix Decomposition approach.
!  Finally the individual fields are transformed so that they have the
!  desired marginal distributions. These transformations are as follows;
!
!	P(x,y) = mean + sd*G(x,y)		if normally distributed
!
!	P(x,y) = exp{ log-mean + log-sd*G(x,y) }if lognormally distributed
!
!	P(x,y) = a + 0.5*(b-a)*[ 1 + tanh((m + s*G(x,y))/2*pi) ]
!						if bounded
!
!  where P(x,y) is the desired random field (one of the soil properties),
!  G(x,y) is one of the standard correlated Gaussian fields, and (mean,sd)
!  and (a,b,m,s) are parameters of the distributions.
!
!  If the property is deterministic, the entire field is simply set to the
!  mean.
!
!  ARGUMENTS
!
!   istat	unit number connected to a file to which the input data is to
!		echoed if echo is true. (input)
!
!   iterm	unit number connected to the screen. If verbos is true, then
!		error and warning messages are also sent to the screen. (input)
!
!  verbos	logical flag which is true if error, warning, and progress
!		messages are allowed to be sent to the screen. (input)
!
!    kxfld	real array of size at least (nxe x nye) which on output
!		will contain the (optionally random) cohesion field.
!		(output)
!
!  kyfld	real array of size at least (nxe x nye) which on output
!		will contain the (optionally random) friction angle or
!		tan(friction angle) field. (output)
!
!  psifld	real array of size at least (nxe x nye) which on output
!		will contain the (optionally random) dilation angle
!		field. (output)
!
!    efld	real array of size at least (nxe x nye) which on output
!		will contain the (optionally random) elastic modulus
!		field. (output)
!
!    vfld	real array of size at least (nxe x nye) which on output
!		will contain the (optionally random) Poisson's ratio
!		field. (output)
!
!    nrfx	integer giving the number of cells in the x-direction in the
!		random fields kxfld, ..., vfld. This is normally equal to nxe,
!		but if nxe is not an integer of the form nxe = k1*(2**m),
!		where m is a non-negative integer, and k1 is a positive
!		integer with k1*k2 < MXK (see chknxe) then nrfx is the next
!		larger possible integer that does satisfy this requirement
!		of LAS2G. (input)
!
!    nrfy	integer giving the number of cells in the y-direction in the
!		random fields above. This is normally equal to nye, but if
!		nye is not an integer of the form nye = k2*(2**m), where m is
!		a non-negative integer, and k2 is a positive integer with
!		k1*k2 < MXK (see chknxe) then nrfy is the next larger
!		possible integer that does satisfy this requirement of LAS2G.
!		(input)
!
!	c	real vector of length at least 7 containing the parameters of
!		the soil cohesion. Notably,
!		   c(1) = mean cohesion,
!		   c(2) = cohesion standard deviation,
!		   c(3) = cohesion distribution type;
!			  = 0.0 if cohesion is deterministic (at mean value)
!			  = 1.0 if cohesion is normally distributed
!			  = 2.0 if cohesion is lognormally distributed (logn)
!			  = 3.0 if cohesion is bounded
!		   c(4) = lower bound (bounded), or mean of log-cohesion (logn)
!		   c(5) = upper bound (bounded), or sd of log-cohesion (logn)
!		   c(6) = m parameter (if bounded)
!		   c(7) = s parameter (if bounded)
!		If c is bounded, then c(1) and c(2) are ignored and the
!		parameters c(4) through c(7) completely describe the
!		distribution. (input)
!
!     phi	real vector of length at least 7 containing the parameters of
!		soil friction angle. See `c' for what the various elements of
!		phi contain. (input)
!
!     psi	real vector of length at least 7 containing the parameters of
!		soil dilation angle. See `c' for what the various elements of
!		psi contain. (input)
!
!	e	real vector of length at least 7 containing the parameters of
!		soil elastic modulus. See `c' for what the various elements of
!		e contain. (input)
!
!	v	real vector of length at least 7 containing the parameters of
!		soil Poisson ratio. See `c' for what the various elements of
!		v contain. (input)
!
!	R	real array of size at least 5 x 5 which is assumed to
!		contain the correlation matrix between the 5 (possibly)
!		random soil properties.  Indexing into R is as follows;
!		  1 = cohesion
!		  2 = friction angle
!		  3 = dilation angle
!		  4 = elastic modulus
!		  5 = Poisson's ratio
!		(input)
!
!   lxfld	logical flag which is true if more than one soil property
!		are cross-correlated. That is, if all soil properties are
!		independent, then lxfld is false. (input)
!
!     thx	real value giving the x-direction scale of fluctuation
!		(or, at least, this is a parameter of the variance function).
!		(input)
!
!     thy	real value giving the y-direction scale of fluctuation
!		(or, at least, this is another parameter of the variance
!		function). (input)
!
!     nxe	integer giving the number of elements describing the soil
!		mass in the x-direction (horizontally). (input)
!
!     nye	integer giving the number of elements describing the soil
!		mass in the y-direction (vertically). (input)
!
!      dx	real value giving the physical size of an element in the
!		x-direction. (input)
!
!      dy	real value giving the physical size of an element in the
!		y-direction. (input)
!
!  dmpfld	logical flag which is true if a random field is to be
!		plotted to *.fld. (input)
!
!    nfld	integer giving the realization number of the random field
!		which is to be plotted to *.fld. (input)
!
!    jfld	integer denoting which random field is to be plotted;
!		 = 1 for the cohesion (c) field,
!		 = 2 for the friction angle (phi) field,
!		 = 3 for the dilation angle (psi) field,
!		 = 4 for the elastic modulus (psi) field,
!		 = 5 for the poisson ratio (psi) field.
!		(input)
!
!    ifld	unit number connected to the file to which the random field
!		plot is to be written in the event that dmpfld is true.
!		(input)
!
!     job	character string containing the main title of the run.
!		(input)
!
!    sub1	character string, which on output will contain the first
!		subtitle for this run. (output)
!
!    sub2	character string, which on output will contain the second
!		subtitle for this run. (output)
!
!  varfnc	character string containing the name of the variance
!		function controlling the random fields. Possible variance
!		functions are
!		`dlavx2' - 2-D exponentially decaying (Markov) model
!			   requires X- and Y-direction scales of fluctuation
!		`dlafr2' - 2-D isotropic fractional Gaussian noise model
!			   requires (H,delta) as parameters. In this case,
!			   thx is H, and delta is the minimum element
!			   dimension.
!		`dlsep2' - 2-D separable (1D x 1D) Markov model
!			   requires X- and Y-direction scales of fluctuation
!		`dlsfr2' - 2-D separable fractional Gaussian noise model
!			   requires (H_x,H_y,delta) as parameters. In this
!			   case, thx is H_x, thy is H_y, and delta is the
!			   minimum element dimension.
!		`dlspx2' - 2-D separable Gaussian decaying model
!			   requires X- and Y-direction scales of fluctuation
!		(input)
!
!   kseed	integer giving the seed to be used to initialize the
!		pseudo-random number generator. Subsequent runs using
!		the same seed will result in the same sequence of random
!		numbers. (input)
!
!   debug	logical flag which is true if debug information is to be
!		sent to the *.stt file. (input)
!
!  REVISION HISTORY:
!  1.01	added dx and dy to argument list (Jul 27/99)
!  1.02	now properly treat lognormal distributions (Jul 29/99)
!  1.1	defined `twopi'! (Apr 27/00)
!  1.2	added lvarfn parameter to common /dparam/ for las2g (May 5/00)
!  1.21	revised documentation above (Jan 31/01)
!  1.3	eliminated lvarfn (LAS2G now looks after this internally) (Apr 26/01)
!  1.4	now make RF's possibly larger than nxe x nye (Jul 30/02)
!  1.5	added error output if covariance function name unknown (Sep 9/02)
!-------------------------------------------------------------------------
      subroutine sim2bc1(istat,iterm,verbos,kxfld,kyfld,efld,  &
                        nrfx,nrfy,kx,ky,e,R,lxfld,thx,thy,dx,dy,    &
                        dmpfld,nfld,jfld,ifld,job,sub1,sub2,              &
                        varfnc,kseed,debug)

      real kxfld(nrfx,*), kyfld(nrfx,*), efld(nrfx,*)
      real kx(*), ky(*), e(*), R(3,*), thx, thy
      integer nfld, ifld, nrfx, nrfy
      character*(*) job, sub1, sub2, varfnc
      logical verbos, dmpfld, debug, liid, shofld, lxfld
      real*8 dvar, dpb, dthx, dthy, dthz, ddx, ddy
      real*8 dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2
      real*8 dmin1, dble
      save XL, YL, ienter, liid
      external dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2
      common/dparam/ dvar, dpb, dthx, dthy, dthz
      data zero/0.0/, half/0.5/, one/1.0/, onept5/1.5/, twopt5/2.5/
      data twopi/6.2831853071795864769d0/
      data ienter/0/

   1  format(a,a)

!-------------------------------------- initialize -------------------------
!					compute required field size (once)
      ienter = ienter + 1
      if( ienter .eq. 1 ) then
         liid   = ((thx .eq. zero) .and. (thy .eq. zero))
         XL     = float(nrfx)*dx
         YL     = float(nrfy)*dy

         if( debug ) write(istat,1)'SIM2BC: setting field parameters...'

         if( .not. liid ) then
!						set variance fnc parameters
            dvar   = 1.d0
            dthx   = thx
            dthy   = thy

            if( varfnc .eq. 'dlafr2' .or. varfnc .eq. 'dlsfr2' ) then
               dpb = dx
               if( dy .lt. dx ) dpb = dy
            endif
!						initialize LAS2G
            if( varfnc .eq. 'dlavx2' ) then
               call las2g(kxfld,nrfx,nrfy,XL,YL,dlavx2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlsep2' ) then
               call las2g(kxfld,nrfx,nrfy,XL,YL,dlsep2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlspx2' ) then
               call las2g(kxfld,nrfx,nrfy,XL,YL,dlspx2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlafr2' ) then
               call las2g(kxfld,nrfx,nrfy,XL,YL,dlafr2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlsfr2' ) then
               call las2g(kxfld,nrfx,nrfy,XL,YL,dlsfr2,kseed,-1,istat)
            else
               if( verbos ) then
                  write(iterm,1)                                          &
                  '*** Error: unknown variance function name: ', varfnc
               endif
               write(istat,1)                                             &
			      '*** Error: unknown variance function name: ', varfnc
               stop
            endif
         endif
      endif
!					are we going to plot anything?
      shofld = dmpfld .and. (nfld .eq. ienter)

!					now produce 3 standard normal fields
!					for kx...
      if( kx(3) .lt. half ) then			! kx is deterministic
         do 10 j = 1, nrfy
         do 10 i = 1, nrfx
            kxfld(i,j) = zero			! we'll add mean back on later
  10     continue
      elseif( liid ) then			! white noise field
         do 20 j = 1, nrfy
         do 20 i = 1, nrfx
            kxfld(i,j) = gausv(one)
  20     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(kxfld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(kxfld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(kxfld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(kxfld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(kxfld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					for ky...
      if( ky(3) .lt. half ) then		! ky is deterministic
         do 30 j = 1, nrfy
         do 30 i = 1, nrfx
            kyfld(i,j) = zero			! we'll add mean back on later
  30     continue
      elseif( liid ) then			! white noise field
         do 40 j = 1, nrfy
         do 40 i = 1, nrfx
            kyfld(i,j) = gausv(one)
  40     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(kyfld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(kyfld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(kyfld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(kyfld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(kyfld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					for elastic modulus...
      if( e(3) .lt. half ) then		! modulus is deterministic
         do 70 j = 1, nrfy
         do 70 i = 1, nrfx
            efld(i,j) = zero			! we'll add mean back on later
  70     continue
      elseif( liid ) then			! white noise field
         do 80 j = 1, nrfy
         do 80 i = 1, nrfx
            efld(i,j) = gausv(one)
  80     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					combine for correlated fields...
      if( lxfld ) then
         do 110 j = 1, nrfy
         do 110 i = 1, nrfx
            efld(i,j) = R(1,3)*kxfld(i,j)   + R(2,3)*kyfld(i,j)        &
                       + R(3,3)*efld(i,j)
            kyfld(i,j) = R(1,2)*kxfld(i,j)   + R(2,2)*kyfld(i,j)
 110     continue
      endif
!					plot the random field?
      if( shofld ) then
         if( jfld .eq. 1 ) then
	    call pltfld( job,sub1,sub2,kxfld,nrfx,nrfx,nrfy,XL,YL,            &
     		     '(Underlying) kx Field',ifld )
         elseif( jfld .eq. 2 ) then
	    call pltfld( job,sub1,sub2,kyfld,nrfx,nrfx,nrfy,XL,YL,          &
     		     '(Underlying) ky Field',ifld )
         elseif( jfld .eq. 3 ) then
	    call pltfld( job,sub1,sub2,efld,nrfx,nrfx,nrfy,XL,YL,          &
     		     '(Underlying) Elastic Modulus Field',ifld )
         endif
      endif
!					convert to final fields
!					for kx...
      if( kx(3) .lt. half ) then				! deterministic
         do 120 j = 1, nrfy
         do 120 i = 1, nrfx
            kxfld(i,j) = kx(1)
 120     continue
      elseif( kx(3) .lt. onept5 ) then			! normal
         do 130 j = 1, nrfy
         do 130 i = 1, nrfx
            kxfld(i,j) = kx(1) + kx(2)*kxfld(i,j)
 130     continue
      elseif( kx(3) .lt. twopt5 ) then			! lognormal
         do 140 j = 1, nrfy
         do 140 i = 1, nrfx
            kxfld(i,j) = exp( kx(4) + kx(5)*kxfld(i,j) )
 140     continue
      else						! bounded
         do 150 j = 1, nrfy
         do 150 i = 1, nrfx
            kxfld(i,j) = kx(4) + half*(kx(5)-kx(4))                           &
               *( one + tanh((kx(6)+kx(7)*kxfld(i,j))/twopi) )
 150     continue
      endif
!					for ky...
      if( ky(3) .lt. half ) then			! deterministic
         do 160 j = 1, nrfy
         do 160 i = 1, nrfx
            kyfld(i,j) = ky(1)
 160     continue
      elseif( ky(3) .lt. onept5 ) then			! normal
         do 170 j = 1, nrfy
         do 170 i = 1, nrfx
            kyfld(i,j) = ky(1) + ky(2)*kyfld(i,j)
 170     continue
      elseif( ky(3) .lt. twopt5 ) then			! lognormal
         do 180 j = 1, nrfy
         do 180 i = 1, nrfx
            kyfld(i,j) = exp( ky(4) + ky(5)*kyfld(i,j) )
 180     continue
      else						! bounded
         do 190 j = 1, nrfy
         do 190 i = 1, nrfx
            kyfld(i,j) = ky(4) + half*(ky(5)-ky(4))                   &
                     *( one + tanh((ky(6)+ky(7)*kyfld(i,j))/twopi) )
 190     continue
      endif
!					for elastic modulus...
      if( e(3) .lt. half ) then				! deterministic
         do 240 j = 1, nrfy
         do 240 i = 1, nrfx
            efld(i,j) = e(1)
 240     continue
      elseif( e(3) .lt. onept5 ) then			! normal
         do 250 j = 1, nrfy
         do 250 i = 1, nrfx
            efld(i,j) = e(1) + e(2)*efld(i,j)
 250     continue
      elseif( e(3) .lt. twopt5 ) then			! lognormal
         do 260 j = 1, nrfy
         do 260 i = 1, nrfx
            efld(i,j) = exp( e(4) + e(5)*efld(i,j) )
 260     continue
      else						! bounded
         do 270 j = 1, nrfy
         do 270 i = 1, nrfx
            efld(i,j) = e(4) + half*(e(5)-e(4))                           &
                     *( one + tanh((e(6)+e(7)*efld(i,j))/twopi) )
 270     continue
      endif
      return
      end


SUBROUTINE LUDCMP(A,N,NP,INDX,D)

  ! CHANGE RECORD

  IMPLICIT NONE

  INTEGER :: N,NP,INDX(N),I,J,K,IMAX
  REAL :: A(NP,NP),TINY,D,AAMAX,DUM,SUM

  PARAMETER (TINY=1.0E-20)
  REAL,ALLOCATABLE,DIMENSION(:) :: VV

  ALLOCATE(VV(N))
  !
  D=1.
  DO 12 I=1,N
    AAMAX=0.
    DO 11 J=1,N
      IF( ABS(A(I,J)) > AAMAX) AAMAX=ABS(A(I,J))
     11   CONTINUE
    IF( AAMAX == 0. ) PAUSE 'SINGULAR MATRIX.'
    VV(I)=1./AAMAX
     12 CONTINUE
  DO 19 J=1,N
    IF( J > 1 )THEN
      DO 14 I=1,J-1
        SUM=A(I,J)
        IF( I > 1 )THEN
          DO 13 K=1,I-1
            SUM=SUM-A(I,K)*A(K,J)
     13         CONTINUE
          A(I,J)=SUM
        ENDIF
     14     CONTINUE
    ENDIF
    AAMAX=0.
    DO 16 I=J,N
      SUM=A(I,J)
      IF( J > 1 )THEN
        DO 15 K=1,J-1
          SUM=SUM-A(I,K)*A(K,J)
     15       CONTINUE
        A(I,J)=SUM
      ENDIF
      DUM=VV(I)*ABS(SUM)
      IF( DUM >= AAMAX )THEN
        IMAX=I
        AAMAX=DUM
      ENDIF
     16   CONTINUE
    IF( J /= IMAX )THEN
      DO 17 K=1,N
        DUM=A(IMAX,K)
        A(IMAX,K)=A(J,K)
        A(J,K)=DUM
     17     CONTINUE
      D=-D
      VV(IMAX)=VV(J)
    ENDIF
    INDX(J)=IMAX
    IF( J /= N )THEN
      IF( A(J,J) == 0. )A(J,J)=TINY
      DUM=1./A(J,J)
      DO 18 I=J+1,N
        A(I,J)=A(I,J)*DUM
     18     CONTINUE
    ENDIF
     19 CONTINUE
  IF( A(N,N) == 0. )A(N,N)=TINY
  DEALLOCATE(VV)
  RETURN
END


module mod_param
use mod_types
implicit none
public
!
! parameters
!
real(rp), parameter :: pi = acos(-1._rp)
real(rp), parameter :: small = epsilon(pi)*10**(precision(pi)/2)
character(len=100), parameter :: datadir = 'data/'
real(rp), parameter, dimension(2,3) :: rkcoeff = reshape((/ 32._rp/60._rp,  0._rp        , &
                                                            25._rp/60._rp, -17._rp/60._rp, &
                                                            45._rp/60._rp, -25._rp/60._rp/), shape(rkcoeff))
real(rp), parameter, dimension(3)   :: rkcoeff12 = rkcoeff(1,:)+rkcoeff(2,:)
!
! variables to be determined from the input file 'dns.in'
!
integer :: itot,jtot,ktot,imax,jmax
real(rp) :: lx,ly,lz,dx,dy,dz,dxi,dyi,dzi,gr
real(rp) :: cfl,dtmin
real(rp) :: uref,lref,rey,visc
!
character(len=100) :: inivel
logical :: is_wallturb
!
integer :: nstep
real(rp) :: time_max,tw_max
logical, dimension(3) :: stop_type
logical :: restart,is_overwrite_save
integer :: icheck,iout0d,iout1d,iout2d,iout3d,isave
!
integer, dimension(2) :: dims
integer :: nthreadsmax
!
character(len=1), dimension(0:1,3,3) ::  cbcvel
real(rp)         , dimension(0:1,3,3) :: bcvel
character(len=1), dimension(0:1,3)   ::  cbcpre
real(rp)         , dimension(0:1,3)   ::   bcpre
!
real(rp), dimension(3) :: bforce
logical , dimension(3) :: is_forced
real(rp), dimension(3) :: velf
!
integer , dimension(3) :: ng
integer , dimension(3) :: n
real(rp), dimension(3) :: l
real(rp), dimension(3) :: dl
real(rp), dimension(3) :: dli
!
contains
  subroutine read_input(myid)
  use mpi
  implicit none
  integer, intent(in) :: myid
  integer :: iunit,ierr
    open(newunit=iunit,file='dns.in',status='old',action='read',iostat=ierr)
      if( ierr.eq.0 ) then
        read(iunit,*) itot,jtot,ktot
        read(iunit,*) lx,ly,lz
        read(iunit,*) gr
        read(iunit,*) cfl,dtmin
        read(iunit,*) uref,lref,rey
        read(iunit,*) inivel
        read(iunit,*) is_wallturb
        read(iunit,*) nstep, time_max,tw_max
        read(iunit,*) stop_type(1),stop_type(2),stop_type(3)
        read(iunit,*) restart,is_overwrite_save
        read(iunit,*) icheck,iout0d,iout1d,iout2d,iout3d,isave
        read(iunit,*) cbcvel(0,1,1),cbcvel(1,1,1),cbcvel(0,2,1),cbcvel(1,2,1),cbcvel(0,3,1),cbcvel(1,3,1)
        read(iunit,*) cbcvel(0,1,2),cbcvel(1,1,2),cbcvel(0,2,2),cbcvel(1,2,2),cbcvel(0,3,2),cbcvel(1,3,2)
        read(iunit,*) cbcvel(0,1,3),cbcvel(1,1,3),cbcvel(0,2,3),cbcvel(1,2,3),cbcvel(0,3,3),cbcvel(1,3,3)
        read(iunit,*) cbcpre(0,1  ),cbcpre(1,1  ),cbcpre(0,2  ),cbcpre(1,2  ),cbcpre(0,3  ),cbcpre(1,3  )
        read(iunit,*)  bcvel(0,1,1), bcvel(1,1,1), bcvel(0,2,1), bcvel(1,2,1), bcvel(0,3,1), bcvel(1,3,1)
        read(iunit,*)  bcvel(0,1,2), bcvel(1,1,2), bcvel(0,2,2), bcvel(1,2,2), bcvel(0,3,2), bcvel(1,3,2)
        read(iunit,*)  bcvel(0,1,3), bcvel(1,1,3), bcvel(0,2,3), bcvel(1,2,3), bcvel(0,3,3), bcvel(1,3,3)
        read(iunit,*)  bcpre(0,1  ), bcpre(1,1  ), bcpre(0,2  ), bcpre(1,2  ), bcpre(0,3  ), bcpre(1,3  )
        read(iunit,*)  bforce(1),bforce(2),bforce(3)
        read(iunit,*)  is_forced(1),is_forced(2),is_forced(3)
        read(iunit,*)  velf(1),velf(2),velf(3)
        read(iunit,*) dims(1),dims(2)
        read(iunit,*) nthreadsmax
      else
        if(myid.eq.0) print*, 'Error reading the input file'
        if(myid.eq.0) print*, 'Aborting...'
        call MPI_FINALIZE(ierr)
        error stop
      endif
    close(iunit)
    dx = lx/(1.*itot)
    dy = ly/(1.*jtot)
    dz = lz/(1.*ktot)
    dxi = dx**(-1)
    dyi = dy**(-1)
    dzi = dz**(-1)
    imax = itot/dims(1)
    jmax = jtot/dims(2)
    !
    visc = uref*lref/rey
    ng  = (/itot,jtot,ktot/)
    n   = (/imax,jmax,ktot/)
    l   = (/lx,ly,lz/)
    dl  = (/dx,dy,dz/)
    dli = (/dxi,dyi,dzi/)
  return
  end subroutine read_input
end module mod_param


!**********************************************************************!
SUBROUTINE SEDZLJ_MAIN
  USE GLOBAL
  IMPLICIT NONE
  REAL(4) SECNDS
  DOUBLE PRECISION,DIMENSION(LCM)::WVEL,CLEFT,CRIGHT,GRADSED,SEDAVG,CRNUM
  INTEGER::L,K,NS
  DOUBLE PRECISION::AA11,AA12,AA21,AA22,BB11,BB22,DETI
  ! PT: real values are written in DOUBLE PRECISION. 7/16/08
!**********************************************************************!
!
! **  SUBROUTINE CALSED CALCULATES COHESIVE SEDIMENT SETTLING,
! **  DEPOSITION AND RESUSPENSION According to SEDZLJ MODEL
!
!  REVISION DATE :  May 24, 2006
!  Craig Jones and Scott James

!**********************************************************************!
!
  IF(IS_TIMING)THEN
        T1TMP=SECNDS(SECNDS_ZERO)
  ENDIF
!Calculates the shear stresses from the velocity output of the hydraulic model.
  CALL SEDZLJ_SHEAR

  IF(ISSLOPE/=0)THEN
    CALL SEDZLJ_SLOPE
  ELSE
    FORALL(L=2:LA)SH_SCALE(L)=1.0
  ENDIF
!
!Calculating the morphology before sediment transport of each time step.
  IF(IMORPH_SEDZLJ==1)FORALL(L=2:LA)HBED(L,1:KB)=0.01*(TSED(1:KB,L)/BULKDENS(1:KB,L))
!TSED-sediment layer's thickness. HBED-Bed height. BULKDENS-Density of sediment and water in layer.
!
!Setting the sediment concentration in the current.  SEDS is a saved version of SED (the sediment
!concentration).  SEDS and SED could be used to calculate the difference between the two time
!steps.  If SED = SEDS + SEDF (the flux) then mass is conserved.
  SEDS(2:LA,1:KC,1:NSCM)=SED(2:LA,1:KC,1:NSCM)

!calling bed load calculation.  BEDLOADJ subroutine provides CBL, the sediment concentration
!load.
  IF(NCALC_BL==1.AND.N>=ISEDTIME) CALL BEDLOADJ
  !Calls the sedflume transport. NOTE: ISEDTIME is the time difference between when sediment
  !transport begins versus the beginning of hydraulic transport.
  IF(NSEDFLUME==1.AND.N>=ISEDTIME) THEN
!**********************************************************************!
!   SEDZLJ Sediment Transport only
!
!WSETA - temporary settling velocity.  The division of DWS by 100.0 probably has to do with unit conversion.
!going from cm/s to m/s.
     FORALL(K=0:KS,L=2:LA)WSETA(L,K,1:NSCM)=DWS(1:NSCM)/100.0
     SEDF(2:LA,0:KS,1:NSCM)=0.0
     !if(minval(SEDF) < 0.0) then
        !print *, 'Negative SEDF 0'
        !pause
     !endif
     SSGI(1:NSCM)=1.0/(1.0E6*SSG(1:NSCM))
!----------------------------------------------------------------------!
!
! **  HORIZONTAL LOOPS
!These loops account for sediment diffusion between the water layers.
!PT: added if loops to make code run faster when KC = 1 and KC = 2
     KCNOT1LOOP: IF(KC .NE. 1) THEN
        DO NS=1,NSCM
           FORALL(L=2:LA) !K=KC
              WVEL(L)=DELT*HPI(L)*DZIC(KC)
              CLEFT(L)=1.0+WSETA(L,KC-1,NS)*WVEL(L)
              CRIGHT(L)=MAX(SED(L,KC,NS),0.0)
              SED(L,KC,NS)=CRIGHT(L)/CLEFT(L)
              SEDF(L,KC-1,NS)=-WSETA(L,KC-1,NS)*SED(L,KC,NS)
           ENDFORALL
!PT: added if loop to allow code to run faster for KC = 2 case.
           KCNOT2LOOP: IF(KC .NE. 2) THEN
              DO K=KC-1,2,-1
                 FORALL(L=2:LA)
                    WVEL(L)=DELT*HPI(L)*DZIC(K)
                    CLEFT(L)=1.0+WSETA(L,K-1,NS)*WVEL(L)
                    CRIGHT(L)=MAX(SED(L,K,NS),0.0)-SEDF(L,K,NS)*WVEL(L)
                    SED(L,K,NS)=CRIGHT(L)/CLEFT(L)
                    SEDF(L,K-1,NS)=-WSETA(L,K-1,NS)*SED(L,K,NS)
                 ENDFORALL
              ENDDO
           ENDIF KCNOT2LOOP
        ENDDO
     ENDIF KCNOT1LOOP

     !if(minval(SEDF) < 0.0) then
        !print *, 'Negative SEDF 1'
        !pause
     !endif

!
!   Call Bedload subroutines here
!
     DO L=2,LA
!  **   Calculate total flux from bed and determine if
!       there is enough sediment to erode from SEDZLJ
        IF(ISCDRY(L).EQ.0)THEN !Only Call for wet cells (CRAIG JONES)
          CALL SEDZLJ(L)
        ENDIF
!  **   Update the bed thickness based on the flux and calculate
!       the flux into the water column.
!
        QSBDTOP(L)=SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM))
        DO NS=1,NSCM
           QWBDTOP(L)=QWBDTOP(L)+SSGI(NS)*(VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.0)+VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.0))
        ENDDO
     ENDDO
!
!---------- ------------------------------------------------------------!
!
! **  ANTI-DIFFUSION OF COHESIVE SEDIMENT  KC.GT.3

     DO NS=1,NSCM
        IF(KC .GT. 3) THEN
           IF(ISTOPT(6)==1) THEN
              DO K=1,KC-1
                 FORALL(L=2:LA)
                    CRNUM(L)=1.0+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1)
                    GRADSED(L)=(SED(L,K+1,NS)-SED(L,K,NS))/(DZC(K+1)+DZC(K))
                    SEDAVG(L)=0.5*(SED(L,K+1,NS)+SED(L,K,NS)+1.0E-16)
                    WSETA(L,K,NS)=-CRNUM(L)*DZC(K+1)*WSETA(L,K,NS)*GRADSED(L)/SEDAVG(L)
                 ENDFORALL
              ENDDO
!
!     TVAR1S=LOWER DIAGONAL
              TVAR1S(2:LA,1)=0.0
              DO K=2,KC
                 TVAR1S(2:LA,K)=MIN(WSETA(2:LA,K-1,NS),0.0)
              ENDDO
!
!     TVAR1N=UPPER DIAGONAL
              TVAR1N(2:LA,KC)=0.0
              DO K=1,KC-1
                 TVAR1N(2:LA,K)=-MAX(WSETA(2:LA,K,NS),0.0)
              ENDDO
!     TVAR1W=MAIN DIAGONAL
              TVAR1W(2:LA,1)=DELTI*DZC(1)*HP(2:LA)-MIN(WSETA(2:LA,1,NS),0.0)
              DO K=2,KC-1
                 TVAR1W(2:LA,K)=DELTI*DZC(KC)*HP(2:LA)+MAX(WSETA(2:LA,K-1,NS),0.0)-MIN(WSETA(2:LA,K,NS),0.0)
              ENDDO
              TVAR1W(2:LA,KC)=DELTI*DZC(KC)*HP(2:LA)+MAX(WSETA(2:LA,KC-1,NS),0.0)
!     TVAR1E=RIGHT HAND SIDE
              DO K=1,KC
                 TVAR1E(2:LA,K)=DELTI*DZC(KC)*HP(2:LA)*SED(2:LA,K,NS)
              ENDDO
!
!     TVAR3S=BET,TVAR2N=U,TVAR2S=GAM ARE WORKING ARRAYS
              TVAR3S(2:LA)=TVAR1W(2:LA,1)
              TVAR2N(2:LA,1)=TVAR1E(2:LA,1)/TVAR3S(2:LA)
              DO K=2,KC
                 TVAR2S(2:LA,K)=TVAR1N(2:LA,K-1)/TVAR3S(2:LA)
                 TVAR3S(2:LA)=TVAR1W(2:LA,K)-TVAR1S(2:LA,K)*TVAR2S(2:LA,K)
                 TVAR2N(2:LA,K)=(TVAR1E(2:LA,K)-TVAR1S(2:LA,K)*TVAR2N(2:LA,K-1))/TVAR3S(2:LA)
              ENDDO
              DO K=KC-1,1,-1
                 TVAR2N(2:LA,K)=TVAR2N(2:LA,K)-TVAR2S(2:LA,K+1)*TVAR2N(2:LA,K+1)
              ENDDO
              SED(2:LA,K,NS)=TVAR2N(2:LA,K)
           ENDIF
!
!----------------------------------------------------------------------!
!
! **  FINAL FLUX KC.GT.3 for SEDZLJ. Note: KS=KC-1
!
           SEDF(2:LA,KS,NS)=DELTI*DZC(KC)*HP(2:LA)*(SED(2:LA,KC,NS)-SEDS(2:LA,KC,NS))
           !if(minval(SEDF) < 0.0) then
              !print *, 'Negative SEDF 2'
              !pause
           !endif
           DO K=KS-1,1,-1
              SEDF(2:LA,K,NS)=DELTI*DZC(K+1)*HP(2:LA)*(SED(2:LA,K+1,NS)-SEDS(2:LA,K+1,NS))+SEDF(2:LA,K+1,NS)
           ENDDO
           !if(minval(SEDF) < 0.0) then
              !print *, 'Negative SEDF 3'
              !pause
           !endif
        ENDIF
!                *************************************                 !
        IF(KC .EQ. 3) THEN
! **  ANTI-DIFFUSION OF COHESIVE SEDIMENT  KC.EQ.3
!
           IF(ISTOPT(6).EQ.1) THEN

              DO K=1,2
                 CRNUM=1.+DELT*WSETA(2:LA,K,NS)*HPI(2:LA)*DZIC(K+1)
                 GRADSED=(SED(2:LA,K+1,NS)-SED(2:LA,K,NS))/(DZC(K+1)+DZC(K))
                 SEDAVG=0.5*(SED(2:LA,K+1,NS)-SED(2:LA,K,NS)+1.E-16)
                 WSETA(2:LA,K,NS)=-CRNUM*DZC(K+1)*WSETA(2:LA,K,NS)*GRADSED/SEDAVG
              ENDDO
!
!     TVAR1S=LOWER DIAGONAL
              TVAR1S(2:LA,1)=0
              DO K=2,KC
                 TVAR1S(2:LA,K)=MIN(WSETA(2:LA,K-1,NS),0.)
              ENDDO
!     TVAR1N=UPPER DIAGONAL
              TVAR1N(2:LA,KC)=0
              DO K=1,KS
                 TVAR1N(2:LA,K)=-MAX(WSETA(2:LA,K,NS),0.)
              ENDDO
!     TVAR1W=MAIN DIAGONAL
              TVAR1W(2:LA,1)=DELTI*DZC(1)*HP(2:LA)-MIN(WSETA(2:LA,1,NS),0.)
              TVAR1W(2:LA,KC)=DELTI*DZC(KC)*HP(2:LA)+MAX(WSETA(2:LA,KC-1,NS),0.)
              DO K=2,KS
                 TVAR1W(2:LA,K)=DELTI*DZC(KC)*HP(2:LA)+MAX(WSETA(2:LA,K-1,NS),0.)-MIN(WSETA(2:LA,K,NS),0.)
              ENDDO
!     TVAR1E=RIGHT HAND SIDE
              DO K=1,KC
                 TVAR1E(2:LA,K)=DELTI*DZC(KC)*HP(2:LA)*SED(2:LA,K,NS)
              ENDDO
!
!     TVAR3S=BET,TVAR2N=U,TVAR2S=GAM ARE WORKING ARRAYS
              TVAR3S(2:LA)=TVAR1W(2:LA,1)
              TVAR2N(2:LA,1)=TVAR1E(2:LA,1)/TVAR3S(2:LA)
              DO K=2,KC
                 TVAR2S(2:LA,K)=TVAR1N(2:LA,K-1)/TVAR3S(2:LA)
                 TVAR3S(2:LA)=TVAR1W(2:LA,K)-TVAR1S(2:LA,K)*TVAR2S(2:LA,K)
                 TVAR2N(2:LA,K)=(TVAR1E(2:LA,K)-TVAR1S(2:LA,K)*TVAR2N(2:LA,K-1))/TVAR3S(2:LA)
              ENDDO
              DO K=KS,1,-1
                 TVAR2N(2:LA,K)=TVAR2N(2:LA,K)-TVAR2S(2:LA,K+1)*TVAR2N(2:LA,K+1)
              ENDDO
              DO K=1,KC
                 SED(2:LA,K,NS)=TVAR2N(2:LA,K)
              ENDDO
           ENDIF
!
!----------------------------------------------------------------------C
!
! **  FINAL FLUX KC=3
!
           SEDF(2:LA,KC-1,NS)=DELTI*DZC(KC)*HP(2:LA)*(SED(2:LA,KC,NS)-SEDS(2:LA,KC,NS))
           !if(minval(SEDF) < 0.0) then
              !print *, 'Negative SEDF 4'
              !pause
           !endif
           SEDF(2:LA,1,NS)=DELTI*DZC(KC-1)*HP(2:LA)*(SED(2:LA,KC-1,NS)-SEDS(2:LA,KC-1,NS))+SEDF(2:LA,KC-1,NS)
           !if(minval(SEDF) < 0.0) then
              !print *, 'Negative SEDF 5'
              !pause
           !endif
        ENDIF
 !                *************************************                 !
 !end of if loop (KC .EQ. 3).
 !starting if KC .EQ. 2 loop.
        IF(KC .EQ. 2) THEN

! **  ANTI-DIFFUSION OF COHESIVE SEDIMENT  KC.EQ.2
!
           IF(ISTOPT(6).EQ.1) THEN
              DO L=2,LA
                 DO K=1,1
                    CRNUM=1.+DELT*WSETA(L,1,NS)*HPI(L)*DZIC(KC)
                    GRADSED=(SED(L,KC,NS)-SED(L,1,NS))/(DZC(KC)+DZC(1))
                    SEDAVG=0.5*(SED(L,KC,NS)+SED(L,1,NS)+1.E-16)
                    ! WSETA(L,K,NS)=-CRNUM*DZC(KC)*WSETA(L,K,NS)*GRADSED/SEDAVG
                 ENDDO
              ENDDO
!
              DO L=2,LA
                 AA11=DELTI*DZC(1)*HP(L)-MIN(WSETA(L,1,NS),0.)
                 AA12=-MAX(WSETA(L,1,NS),0.)
                 AA21=MIN(WSETA(L,1,NS),0.)
                 AA22=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,1,NS),0.)
                 BB11=DELTI*DZC(1)*HP(L)*SED(L,1,NS)
                 BB22=DELTI*DZC(KC)*HP(L)*SED(L,KC,NS)
                 DETI=1./(AA11*AA22-AA12*AA21)
                 SED(L,1,NS)=DETI*( BB11*AA22-BB22*AA12 )
                 SED(L,KC,NS)=DETI*( AA11*BB22-AA21*BB11 )
              ENDDO
           ENDIF
!
!----------------------------------------------------------------------C
!
! **  FINAL FLUX KC=2
!
           DO L=2,LA
              SEDF(L,1,NS)=DELTI*DZC(KC)*HP(L)*(SED(L,KC,NS)-SEDS(L,KC,NS))
           ENDDO
           !if(minval(SEDF) < 0.0) then
              !print *, 'Negative SEDF 6'
              !pause
           !endif
        ENDIF
!                *************************************                 !
!end of if loop (KC .EQ. 2).
     ENDDO !end do of NS=1,NSCM loop
!PT: the rest of the IF loop is NSEDFLUME == 2 for toxic.  Not concerning sedimentary only.
  ELSEIF(NSEDFLUME==2) THEN
!**********************************************************************!
!   SEDZLJ Sediment and Contaminant Transport model
!
     DO NS=1,NSCM
        FORALL(L=2:LA,K=0:KS)WSETA(L,K,NS)=DWS(NS)/100.
!----------------------------------------------------------------------!
!
! **  HORIZONTAL LOOPS
!
        K=KC
        SEDF(2:LA,K,NS)=0.0
        WVEL(2:LA)=DELT*HPI(2:LA)*DZIC(K)
        CLEFT(2:LA)=1.0+WSETA(2:LA,K-1,NS)*WVEL(2:LA)
        CRIGHT(2:LA)=MAX(SED(2:LA,K,NS),0.0)
        SED(2:LA,K,NS)=CRIGHT(2:LA)/CLEFT(2:LA)
        SEDF(2:LA,K-1,NS)=-WSETA(2:LA,K-1,NS)*SED(2:LA,K,NS)
        !if(minval(SEDF) < 0.0) then
           !print *, 'Negative SEDF 7'
           !pause
        !endif

        DO K=KC-1,2,-1
           WVEL(2:LA)=DELT*HPI(2:LA)*DZIC(K)
           CLEFT(2:LA)=1.0+WSETA(2:LA,K-1,NS)*WVEL(2:LA)
           CRIGHT(2:LA)=MAX(SED(2:LA,K,NS),0.0)-SEDF(2:LA,K,NS)*WVEL(2:LA)
           SED(2:LA,K,NS)=CRIGHT(2:LA)/CLEFT(2:LA)
           SEDF(2:LA,K-1,NS)=-WSETA(2:LA,K-1,NS)*SED(2:LA,K,NS)
           !if(minval(SEDF) < 0.0) then
              !print *, 'Negative SEDF 8'
              !pause
           !endif
        ENDDO
     ENDDO
!
!   Call Bedload subroutines here
!
     DO L=2,LA
!  **   Calculate total flux from bed and determine if
!       there is enough sediment to erode from SEDZLJ
!			CALL CHEMBEDFLX(L)
!  **   Update the bed thickness based on the flux and calculate
!       the flux into the water column.
!
        QSBDTOP(L)=SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM))
        QWBDTOP(L)=VDRBED(L,KBT(L))*SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM), &
                   SEDF(L,0,1:NSCM)>0.0)+SUM(SSGI(1:NSCM)*VDRDEPO(1:NSCM)* &
                   SEDF(L,0,1:NSCM),SEDF(L,0,1:NSCM)<0.0)
        !DO NS=1,NSCM
        !QWBDTOP(L)=QWBDTOP(L)+SSGI(1:NSCM)*(VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.0)+VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.0))
        !ENDDO
     ENDDO

!-----------------------------------------------------------------------!
!---------- ------------------------------------------------------------!
! The stuff below is for SEDTOX only.
!
! **  ANTI-DIFFUSION OF COHESIVE SEDIMENT  KC.GT.3
!
     DO NS=1,NSCM
        IF(ISTOPT(6)==1) THEN
           DO K=1,KC-1
              FORALL(L=2:LA)
                 CRNUM(L)=1.0+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1)
                 GRADSED(L)=(SED(L,K+1,NS)-SED(L,K,NS))/(DZC(K+1)+DZC(K))
                 SEDAVG(L)=0.5*(SED(L,K+1,NS)+SED(L,K,NS)+1.0E-16)
                 WSETA(L,K,NS)=-CRNUM(L)*DZC(K+1)*WSETA(L,K,NS)*GRADSED(L)/SEDAVG(L)
              ENDFORALL
           ENDDO
!
!     TVAR1S=LOWER DIAGONAL
           TVAR1S(2:LA,1)=0.0
!	   TVAR1S(2:LA,K)=MIN(WSETA(2:LA,K-1,NS),0.0)
           DO K=2,KC
              TVAR1S(2:LA,K)=MIN(WSETA(2:LA,K-1,NS),0.0)
           ENDDO
!     TVAR1N=UPPER DIAGONAL
           TVAR1N(2:LA,KC)=0.0
           DO K=1,KC-1
              TVAR1N(2:LA,K)=-MAX(WSETA(2:LA,K,NS),0.0)
           ENDDO
!     TVAR1W=MAIN DIAGONAL
           TVAR1W(2:LA,1)=DELTI*DZC(1)*HP(2:LA)-MIN(WSETA(2:LA,1,NS),0.0)
           DO K=2,KC-1
              TVAR1W(2:LA,K)=DELTI*DZC(KC)*HP(2:LA)+MAX(WSETA(2:LA,K-1,NS),0.0)-MIN(WSETA(2:LA,K,NS),0.0)
           ENDDO
           TVAR1W(2:LA,KC)=DELTI*DZC(KC)*HP(2:LA)+MAX(WSETA(2:LA,KC-1,NS),0.0)
!     TVAR1E=RIGHT HAND SIDE
           DO K=1,KC
              TVAR1E(2:LA,K)=DELTI*DZC(KC)*HP(2:LA)*SED(2:LA,K,NS)
           ENDDO
!
!     TVAR3S=BET,TVAR2N=U,TVAR2S=GAM ARE WORKING ARRAYS
           TVAR3S(2:LA)=TVAR1W(2:LA,1)
           TVAR2N(2:LA,1)=TVAR1E(2:LA,1)/TVAR3S(2:LA)
           DO K=2,KC
              TVAR2S(2:LA,K)=TVAR1N(2:LA,K-1)/TVAR3S(2:LA)
              TVAR3S(2:LA)=TVAR1W(2:LA,K)-TVAR1S(2:LA,K)*TVAR2S(2:LA,K)
              TVAR2N(2:LA,K)=(TVAR1E(2:LA,K)-TVAR1S(2:LA,K)*TVAR2N(2:LA,K-1))/TVAR3S(2:LA)
           ENDDO
           DO K=KC-1,1,-1
              TVAR2N(2:LA,K)=TVAR2N(2:LA,K)-TVAR2S(2:LA,K+1)*TVAR2N(2:LA,K+1)
           ENDDO
           FORALL(L=2:LA,K=1:KC)SED(L,K,NS)=TVAR2N(L,K)
        ENDIF
!
!----------------------------------------------------------------------!
!
! **  FINAL FLUX KC.GT.3  for SEDZLJ Note: KS=KC-1
!
        SEDF(2:LA,KS,NS)=DELTI*DZC(KC)*HP(2:LA)*(SED(2:LA,KC,NS)-SEDS(2:LA,KC,NS))
        !if(minval(SEDF) < 0.0) then
           !print *, 'Negative SEDF 9'
           !pause
        !endif
        DO K=KS-1,1,-1
           SEDF(2:LA,K,NS)=DELTI*DZC(K+1)*HP(2:LA)*(SED(2:LA,K+1,NS)-SEDS(2:LA,K+1,NS))+SEDF(2:LA,K+1,NS)
        ENDDO
        !if(minval(SEDF) < 0.0) then
           !print *, 'Negative SEDF 10'
           !pause
        !endif
     ENDDO
  ENDIF

!-------------------------------end of sedtox and sed if loop: IF(NSEDFLUME==1.AND.N>=ISEDTIME) ----!

!This is for the changing the hydraulic boundary condition/morphology due to sediment transport.
  IF(IMORPH_SEDZLJ==1)CALL MORPHJ

  RETURN
END SUBROUTINE SEDZLJ_MAIN


C++---------------------------------------------------------------------
C Set of routines to determine automatic center of galaxy
C and automatic sky level for Fitelli and other programs
C Contains: AUTO_CENTER and AUTO_SKY
C------------------------------------------------------------------------
C  Subroutine AUTO_CENTER :
C Assumes that the center of the galaxy is close to the center of the image
C
C------------------------------------------------------------------------
	SUBROUTINE AUTO_CENTER(IMAGE,NX,NY,IDIM,OX,OY)

	REAL*4 IMAGE(IDIM,*),OX,OY,VALMAX,SUMX,SUMY,SUMI
	INTEGER*4 IXMIN,IXMAX,IYMIN,IYMAX,IOX,IOY

C First determines working window:
        IXMIN=NX/4
        IXMAX=3*NX/4
        IYMIN=NY/4
        IYMAX=3*NY/4

C Scan window to look for maximum:
        IOX=IXMIN
        IOY=IYMIN
        VALMAX=IMAGE(IOX,IOY)
	DO IY=IYMIN,IYMAX
	 DO IX=IXMIN,IXMAX
           IF(IMAGE(IX,IY).GT.VALMAX)THEN
             VALMAX=IMAGE(IX,IY)
             IOX=IX
             IOY=IY
           ENDIF
	 END DO
	END DO

C More acurate determination with barycenter:
        SUMX=0.
        SUMY=0.
        SUMI=0.
        DO IY=IOY-1,IOY+1
         DO IX=IOX-1,IOX+1
            SUMX = SUMX + FLOAT(IX)*IMAGE(IX,IY)
            SUMY = SUMY + FLOAT(IY)*IMAGE(IX,IY)
            SUMI = SUMI + IMAGE(IX,IY)
	 END DO
	END DO
C
        IF(SUMI.EQ.0.)THEN
           OX=IOX
           OY=IOY
        ELSE
           OX = SUMX/SUMI
           OY = SUMY/SUMI
        ENDIF

        RETURN
        END
C------------------------------------------------------------------------
C  Subroutine AUTO_SKY :
C  Works out the sky level and the noise of a CCD image
C
C Calculates the sky level of the image in 4 edge zones :
C
C Zone 1 : bottom left
C          I=NX/30+1,NX/6+1	J=NY/30+1,NY/6+1
C Zone 2 : bottom right
C          I=NX-NX/6,NX-NX/30	J=NY/30+1,NY/6+1
C Zone 3 : top left
C          I=NX/30+1,NX/6+1	J=NY-NY/6,NY-NY/30
C Zone 4 : top right
C          I=NX-NX/6,NX-NX/30	J=NY-NY/6,NY-NY/30
C
C INPUT :
C IMAGE(NX,NY)  REAL*4   declared as (IDIM,*)
C
C OUTPUT :
C SKY, SIGMA
C
C JLP
C Version 04-11-93
C------------------------------------------------------------------------
	SUBROUTINE AUTO_SKY(IMAGE,NX,NY,IDIM,SKY,SIGMA)

	REAL*4 IMAGE(IDIM,*),SKY,SIGMA,STATUS
	REAL*8 SUM(4),SUMSQ(4)
	REAL*4 SIG(4),XMEAN(4),VALMIN(4),VALMAX(4),COEF(4)
	REAL*4 XNUMB(4)
	INTEGER*4 IMIN(4),IMAX(4),JMIN(4),JMAX(4)

C Setting up the boundaries of the 4 areas:
        IF(NX.LT.6) THEN
          I1=0
          I2=1
        ELSE
	  I1=NX/30
	  I2=NX/6
        ENDIF

	IMIN(1)=I1+1
	IMIN(2)=NX-I2+1
	IMIN(3)=I1+1
	IMIN(4)=NX-I2+1

	IMAX(1)=I2
	IMAX(2)=NX-I1
	IMAX(3)=I2
	IMAX(4)=NX-I1

        IF(NY.LT.6) THEN
          J1=0
          J2=1
        ELSE
	  J1=NY/30
	  J2=NY/6
        ENDIF

	  JMIN(1)=J1+1
	  JMIN(2)=J1+1
	  JMIN(3)=NY-J2+1
	  JMIN(4)=NY-J2+1

	  JMAX(1)=J2
	  JMAX(2)=J2
	  JMAX(3)=NY-J1
	  JMAX(4)=NY-J1

C First loop on the four areas to determine mean and standard deviation :

	DO KK=1,4

	SUM(KK)=0.
	SUMSQ(KK)=0.
	XNUMB(KK)=0.

	DO J=JMIN(KK),JMAX(KK)
	 DO I=IMIN(KK),IMAX(KK)
	  SUM(KK)=IMAGE(I,J)+SUM(KK)
	  SUMSQ(KK)=IMAGE(I,J)*IMAGE(I,J)+SUMSQ(KK)
	  XNUMB(KK)=XNUMB(KK)+1.
	 END DO
	END DO

        IF(XNUMB(KK).NE.0) THEN
	  XMEAN(KK)=SUM(KK)/XNUMB(KK)
	  WORK=(SUMSQ(KK)/XNUMB(KK))-(XMEAN(KK)*XMEAN(KK))
	  SIG(KK)=SQRT(WORK)
	  VALMIN(KK)=XMEAN(KK)-2.*SIG(KK)
	  VALMAX(KK)=XMEAN(KK)+2.*SIG(KK)
        ELSE
          WRITE(6,76)
76        FORMAT('AUTO_SKY: Unable to compute the sky level',/,
     1    ' Empty area, because image is too small')
          SKY=0.
          SIGMA=0.
          RETURN
        ENDIF

	END DO

C	WRITE(6,*) ' FIRST LOOP'
C	WRITE(6,75) (XMEAN(K),K=1,4),(SIG(K),K=1,4)

C Second loop on the four zones to discard the points over 2-sigma
	DO KK=1,4
	SUM(KK)=0.
	SUMSQ(KK)=0.
	XNUMB(KK)=0

	DO J=JMIN(KK),JMAX(KK)
	DO I=IMIN(KK),IMAX(KK)
	WORK=IMAGE(I,J)
	  IF(WORK.GT.VALMIN(KK).AND.WORK.LT.VALMAX(KK))THEN
	    XNUMB(KK)=XNUMB(KK)+1.
	    SUM(KK)=WORK+SUM(KK)
	    SUMSQ(KK)=WORK*WORK+SUMSQ(KK)
	  ENDIF
	END DO
	END DO

	END DO

C Test if bad area:
        ISTATUS=0
        DO KK=1,4
	  IF(XNUMB(KK).NE.0.)THEN
	    XMEAN(KK)=SUM(KK)/XNUMB(KK)
	    COEF(KK)=1.
	    WORK=(SUMSQ(KK)/XNUMB(KK))-(XMEAN(KK)*XMEAN(KK))
	    SIG(KK)=SQRT(WORK)
          ELSE
            COEF(KK)=0.
            ISTATUS=ISTATUS+1
	  ENDIF
        END DO

	WRITE(6,74) IMIN(1),IMIN(2),IMAX(1),IMAX(2),
     1        JMIN(1),JMIN(3),JMAX(1),JMAX(3)
74      FORMAT(' AUTO_SKY/X1,2,3,4',4(1X,I5),'  Y1,2,3,4',4(1X,I5))
C
	WRITE(6,75) (XMEAN(K),K=1,4),(SIG(K),K=1,4)
75	FORMAT(' 3-sigma mean in bottom left (X12Y12) bottom right',
	1	' (X34Y12) top left (X12Y34)',/,' & top right (X34Y34):',
	1	4(1PG11.4,1X),/,' Corresponding sigma: ',
	1	4(1PG11.4,1X))

C Initialize SKY and SIGMA, first (since it exists at least one good value):
	DO I=1,4
	 IF(COEF(I).NE.0.OR.ISTATUS.EQ.4)THEN
	   SKY=XMEAN(I)
	   SIGMA=SIG(I)
	 ENDIF
	END DO

C Then finds the minima:
	DO I=1,4
	 IF(COEF(I).NE.0.OR.ISTATUS.EQ.4)THEN
	   SKY=AMIN1(XMEAN(I),SKY)
	   SIGMA=AMIN1(SIG(I),SIGMA)
	 ENDIF
	END DO

C If status=4, no good points on second loop, so I keep first loop values:
        IF(ISTATUS.EQ.4) THEN
	  WRITE(6,77) SKY,SIGMA
77	  FORMAT('AUTO_SKY/ Sky level : ',1PG11.4,' sigma : ',
     1           1PG11.4,' (one loop)')
        ELSE
	  WRITE(6,78) SKY,SIGMA
78	  FORMAT('AUTO_SKY/ Sky level : ',1PG11.4,' sigma : ',
     1           1PG11.4)
        ENDIF

	RETURN
	END


*> \brief  DSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSTEVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
*                          M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOBZ, RANGE
*       INTEGER            IL, INFO, IU, LDZ, M, N
*       DOUBLE PRECISION   ABSTOL, VL, VU
*       ..
*       .. Array Arguments ..
*       INTEGER            IFAIL( * ), IWORK( * )
*       DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DSTEVX computes selected eigenvalues and, optionally, eigenvectors
*> of a real symmetric tridiagonal matrix A.  Eigenvalues and
*> eigenvectors can be selected by specifying either a range of values
*> or a range of indices for the desired eigenvalues.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBZ
*> \verbatim
*>          JOBZ is CHARACTER*1
*>          = 'N':  Compute eigenvalues only;
*>          = 'V':  Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*>          RANGE is CHARACTER*1
*>          = 'A': all eigenvalues will be found.
*>          = 'V': all eigenvalues in the half-open interval (VL,VU]
*>                 will be found.
*>          = 'I': the IL-th through IU-th eigenvalues will be found.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          On entry, the n diagonal elements of the tridiagonal matrix
*>          A.
*>          On exit, D may be multiplied by a constant factor chosen
*>          to avoid over/underflow in computing the eigenvalues.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*>          E is DOUBLE PRECISION array, dimension (max(1,N-1))
*>          On entry, the (n-1) subdiagonal elements of the tridiagonal
*>          matrix A in elements 1 to N-1 of E.
*>          On exit, E may be multiplied by a constant factor chosen
*>          to avoid over/underflow in computing the eigenvalues.
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*>          VL is DOUBLE PRECISION
*>          If RANGE='V', the lower bound of the interval to
*>          be searched for eigenvalues. VL < VU.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*>          VU is DOUBLE PRECISION
*>          If RANGE='V', the upper bound of the interval to
*>          be searched for eigenvalues. VL < VU.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*>          IL is INTEGER
*>          If RANGE='I', the index of the
*>          smallest eigenvalue to be returned.
*>          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*>          IU is INTEGER
*>          If RANGE='I', the index of the
*>          largest eigenvalue to be returned.
*>          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*>          ABSTOL is DOUBLE PRECISION
*>          The absolute error tolerance for the eigenvalues.
*>          An approximate eigenvalue is accepted as converged
*>          when it is determined to lie in an interval [a,b]
*>          of width less than or equal to
*>
*>                  ABSTOL + EPS *   max( |a|,|b| ) ,
*>
*>          where EPS is the machine precision.  If ABSTOL is less
*>          than or equal to zero, then  EPS*|T|  will be used in
*>          its place, where |T| is the 1-norm of the tridiagonal
*>          matrix.
*>
*>          Eigenvalues will be computed most accurately when ABSTOL is
*>          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*>          If this routine returns with INFO>0, indicating that some
*>          eigenvectors did not converge, try setting ABSTOL to
*>          2*DLAMCH('S').
*>
*>          See "Computing Small Singular Values of Bidiagonal Matrices
*>          with Guaranteed High Relative Accuracy," by Demmel and
*>          Kahan, LAPACK Working Note #3.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*>          M is INTEGER
*>          The total number of eigenvalues found.  0 <= M <= N.
*>          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*>          W is DOUBLE PRECISION array, dimension (N)
*>          The first M elements contain the selected eigenvalues in
*>          ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*>          Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
*>          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
*>          contain the orthonormal eigenvectors of the matrix A
*>          corresponding to the selected eigenvalues, with the i-th
*>          column of Z holding the eigenvector associated with W(i).
*>          If an eigenvector fails to converge (INFO > 0), then that
*>          column of Z contains the latest approximation to the
*>          eigenvector, and the index of the eigenvector is returned
*>          in IFAIL.  If JOBZ = 'N', then Z is not referenced.
*>          Note: the user must ensure that at least max(1,M) columns are
*>          supplied in the array Z; if RANGE = 'V', the exact value of M
*>          is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*>          LDZ is INTEGER
*>          The leading dimension of the array Z.  LDZ >= 1, and if
*>          JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*>          IFAIL is INTEGER array, dimension (N)
*>          If JOBZ = 'V', then if INFO = 0, the first M elements of
*>          IFAIL are zero.  If INFO > 0, then IFAIL contains the
*>          indices of the eigenvectors that failed to converge.
*>          If JOBZ = 'N', then IFAIL is not referenced.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, then i eigenvectors failed to converge.
*>                Their indices are stored in array IFAIL.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup doubleOTHEReigen
*
*  =====================================================================
      SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
     $                   M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
*
*  -- LAPACK driver routine (version 3.6.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE
      INTEGER            IL, INFO, IU, LDZ, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, TEST, VALEIG, WANTZ
      CHARACTER          ORDER
      INTEGER            I, IMAX, INDIBL, INDISP, INDIWO, INDWRK,
     $                   ISCALE, ITMP1, J, JJ, NSPLIT
      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
     $                   TMP1, TNRM, VLL, VUU
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, DLAMCH, DLANST
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF,
     $                   DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
*
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE
         IF( VALEIG ) THEN
            IF( N.GT.0 .AND. VU.LE.VL )
     $         INFO = -7
         ELSE IF( INDEIG ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -8
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -9
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
     $      INFO = -14
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEVX', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      M = 0
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = D( 1 )
         ELSE
            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
               M = 1
               W( 1 ) = D( 1 )
            END IF
         END IF
         IF( WANTZ )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
*
*     Get machine constants.
*
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
*     Scale matrix to allowable range, if necessary.
*
      ISCALE = 0
      IF( VALEIG ) THEN
         VLL = VL
         VUU = VU
      ELSE
         VLL = ZERO
         VUU = ZERO
      END IF
      TNRM = DLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / TNRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( N, SIGMA, D, 1 )
         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
         IF( VALEIG ) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         END IF
      END IF
*
*     If all eigenvalues are desired and ABSTOL is less than zero, then
*     call DSTERF or SSTEQR.  If this fails for some eigenvalue, then
*     try DSTEBZ.
*
      TEST = .FALSE.
      IF( INDEIG ) THEN
         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
            TEST = .TRUE.
         END IF
      END IF
      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
         CALL DCOPY( N, D, 1, W, 1 )
         CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
         INDWRK = N + 1
         IF( .NOT.WANTZ ) THEN
            CALL DSTERF( N, W, WORK, INFO )
         ELSE
            CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
            IF( INFO.EQ.0 ) THEN
               DO 10 I = 1, N
                  IFAIL( I ) = 0
   10          CONTINUE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 20
         END IF
         INFO = 0
      END IF
*
*     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
*
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDWRK = 1
      INDIBL = 1
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
     $             NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ),
     $             WORK( INDWRK ), IWORK( INDIWO ), INFO )
*
      IF( WANTZ ) THEN
         CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
     $                Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL,
     $                INFO )
      END IF
*
*     If matrix was scaled, then rescale eigenvalues appropriately.
*
   20 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
*
*     If eigenvalues are not in order, then sort them, along with
*     eigenvectors.
*
      IF( WANTZ ) THEN
         DO 40 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 30 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   30       CONTINUE
*
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( INDIBL+I-1 )
               W( I ) = W( J )
               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
               W( J ) = TMP1
               IWORK( INDIBL+J-1 ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
               IF( INFO.NE.0 ) THEN
                  ITMP1 = IFAIL( I )
                  IFAIL( I ) = IFAIL( J )
                  IFAIL( J ) = ITMP1
               END IF
            END IF
   40    CONTINUE
      END IF
*
      RETURN
*
*     End of DSTEVX
*
      END


!-----------------------------------------------------------------------
!
! Header with QFunctions
!
      include 't502-operator-f.h'
!-----------------------------------------------------------------------
      program test

      include 'ceed/fortran.h'

      integer ceed,err,i,j
      integer stridesu(3)
      integer erestrictx,erestrictu,erestrictui
      integer bx,bu
      integer qf_setup,qf_mass
      integer op_setup,op_mass
      integer qdata,x,u,v
      integer nelem,p,q
      parameter(nelem=15)
      parameter(p=5)
      parameter(q=8)
      integer nx,nu
      parameter(nx=nelem+1)
      parameter(nu=nelem*(p-1)+1)
      integer indx(nelem*2)
      integer indu(nelem*p)
      real*8 arrx(nx)
      integer*8 voffset,xoffset

      real*8 hu(nu*2),hv(nu*2)
      real*8 total1,total2

      character arg*32

      external setup,mass

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do i=0,nx-1
        arrx(i+1)=i/(nx-1.d0)
      enddo
      do i=0,nelem-1
        indx(2*i+1)=i
        indx(2*i+2)=i+1
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,2,1,1,nx,ceed_mem_host,&
     & ceed_use_pointer,indx,erestrictx,err)

      do i=0,nelem-1
        do j=0,p-1
          indu(p*i+j+1)=2*(i*(p-1)+j)
        enddo
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,p,2,1,2*nu,ceed_mem_host,&
     & ceed_use_pointer,indu,erestrictu,err)
      stridesu=[1,q,q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,1,q*nelem,stridesu,&
     & erestrictui,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bx,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,2,p,q,ceed_gauss,bu,err)

      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t502-operator.h:setup'//char(0),qf_setup,err)
      call ceedqfunctionaddinput(qf_setup,'weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddinput(qf_setup,'dx',1,ceed_eval_grad,err)
      call ceedqfunctionaddoutput(qf_setup,'rho',1,ceed_eval_none,err)

      call ceedqfunctioncreateinterior(ceed,1,mass,&
     &SOURCE_DIR&
     &//'t502-operator.h:mass'//char(0),qf_mass,err)
      call ceedqfunctionaddinput(qf_mass,'rho',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_mass,'u',2,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_mass,'v',2,ceed_eval_interp,err)

      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup,err)
      call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_mass,err)

      call ceedvectorcreate(ceed,nx,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)
      call ceedvectorcreate(ceed,nelem*q,qdata,err)

      call ceedoperatorsetfield(op_setup,'weight',ceed_elemrestriction_none,&
     & bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup,'dx',erestrictx,bx,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup,'rho',erestrictui,&
     & ceed_basis_collocated,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'rho',erestrictui,&
     & ceed_basis_collocated,qdata,err)
      call ceedoperatorsetfield(op_mass,'u',erestrictu,bu,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'v',erestrictu,bu,&
     & ceed_vector_active,err)

      call ceedoperatorapply(op_setup,x,qdata,ceed_request_immediate,err)

      call ceedvectorcreate(ceed,2*nu,u,err)
      call ceedvectorgetarraywrite(u,ceed_mem_host,hu,voffset,err)
      do i=1,nu
        hu(voffset+2*i-1)=1.
        hu(voffset+2*i)=2.
      enddo
      call ceedvectorrestorearray(u,hu,voffset,err)
      call ceedvectorcreate(ceed,2*nu,v,err)
      call ceedoperatorapply(op_mass,u,v,ceed_request_immediate,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,hv,voffset,err)
      total1=0.
      total2=0.
      do i=1,nu
        total1=total1+hv(voffset+2*i-1)
        total2=total2+hv(voffset+2*i)
      enddo
      if (abs(total1-1.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total1,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      if (abs(total2-2.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total2,' != True Area: 2.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(v,hv,voffset,err)

      call ceedvectordestroy(qdata,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedoperatordestroy(op_mass,err)
      call ceedoperatordestroy(op_setup,err)
      call ceedqfunctiondestroy(qf_mass,err)
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


c
c program remnoise
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter(npix=20000)
      integer*4 ounit,def,count_tol,status
      integer*4 count_factor
      real*4 buf1(npix),buf2(npix),buf3(npix),obuf(npix)
      real*4 sdev(npix)
      real*4 border(8)
      character*32 format
      logical roundoff

c set constants
      w=.7072        ! weight for a corner pixel.
      nreset=0       ! # pixels changed

c parameters
      call xvparm('TOL',tol_fixed,count_tol,def,1)
      call xvparm('FACTOR',factor,count_factor,def,1)
      call xvpcnt('INP',nids)

c open input 1
      call xvunit(inunit,'INP',1,status,' ')
      call xvopen(inunit,status,'U_FORMAT','REAL',' ')
      call xvget(inunit,status,'NL',nl,'NS',ns,'FORMAT',format,' ')
      roundoff=.false.
      if(format.eq.'BYTE')roundoff=.true.
      if(format.eq.'HALF')roundoff=.true.
      if(format.eq.'FULL')roundoff=.true.
      if(roundoff)write(*,*)'Integer roundoff correction applied'
      if(ns.gt.npix)then
        write(*,*)'Max number of pixels/line=',npix
        call abend
      endif

c open input 2
      if(nids.gt.1)then
        call xvunit(inunit2,'INP',2,status,' ')
        call xvopen(inunit2,status,'U_FORMAT','REAL',' ')
        bigsig=0.0
        do j=1,nl
          call xvread(inunit2,sdev,status,'LINE',j,' ')
          do i=1,ns
            if(sdev(i).gt.bigsig)bigsig=sdev(i)
          enddo
        enddo
        write(*,*)'largest standard deviation is',bigsig
        scale=ntab/bigsig
      endif

c open output
      call xvunit(ounit,'OUT',1,status,' ')
      call xvopen(ounit,status,'U_FORMAT','REAL','OP','WRITE',' ')

c line loop
      do j=1,nl

c       read picture data
        if(j.eq.1)then
          call xvread(inunit,buf2(2),status,'LINE',1,' ')
          buf2(1)=buf2(2)
          buf2(ns+2)=buf2(ns+1)
          call xvread(inunit,buf3(2),status,'LINE',2,' ')
          buf3(1)=buf3(2)
          buf3(ns+2)=buf3(ns+1)
          call mve(7,ns+2,buf2,buf1,1,1)
        else if(j.eq.nl)then
          call mve(7,ns+2,buf2,buf1,1,1)
          call mve(7,ns+2,buf3,buf2,1,1)
        else
          call mve(7,ns+2,buf2,buf1,1,1)
          call mve(7,ns+2,buf3,buf2,1,1)
          call xvread(inunit,buf3(2),status,'LINE',j+1,' ')
          buf3(1)=buf3(2)
          buf3(ns+2)=buf3(ns+1)
        endif

c       read standard deviation data
        if(nids.gt.1)call xvread(inunit2,sdev(2),status,'LINE',j,' ')

c       pixel loop
        do i=2,ns+1

c         interpolate medians around 3 by 3 box border.
c         border(8) border(1) border(5)
c         border(3)           border(4)
c         border(7) border(2) border(6)
          sum=0.0
          sumr=0.0
          call median(buf1(i-1),w,buf1(i),1.,buf1(i+1),w,sum,sumr
     +     ,border(1))
          call median(buf3(i-1),w,buf3(i),1.,buf3(i+1),w,sum,sumr
     +     ,border(2))
          call median(buf1(i-1),w,buf2(i-1),1.,buf3(i-1),w,sum,sumr
     +     ,border(3))
          call median(buf1(i+1),w,buf2(i+1),1.,buf3(i+1),w,sum,sumr
     +     ,border(4))
          call median(buf1(i),1.,buf1(i+1),w,buf2(i+1),1.,sum,sumr
     +     ,border(5))
          call median(buf2(i+1),1.,buf3(i+1),w,buf3(i),1.,sum,sumr
     +     ,border(6))
          call median(buf3(i),1.,buf3(i-1),w,buf2(i-1),1.,sum,sumr
     +     ,border(7))
          call median(buf2(i-1),1.,buf1(i-1),w,buf1(i),1.,sum,sumr
     +     ,border(8))
          surface=sum/sumr
          dif=abs(buf2(i)-surface)

c         compute tol
          if(nids.eq.1)then
            tol=factor*((abs(border(8)-border(6))+
     +                   abs(border(5)-border(7))+
     +                   abs(border(3)-border(4))+
     +                   abs(border(1)-border(2)))/4.0 )+
     +          tol_fixed
          else
            tol=factor*sdev(i) + tol_fixed
          endif

c         determine if pixel is changed.
          if(dif.gt.tol)then
            obuf(i)=surface
            nreset=nreset+1
          else
            obuf(i)=buf2(i)
          endif

c         roundoff for integer output
          if(roundoff)obuf(i)=float(nint(obuf(i)))

        enddo
        call xvwrit(ounit,obuf(2),status,' ')
      enddo

c statistics
      write(*,*)nreset,' pixels reset'

      return
      end

c************************************************************************
      subroutine median(a,wa,b,wb,c,wc,sum,sumr,med)
c given 3 numbers a,b,c and weights wa,wb,wc
c return sum=sum+median(a,b,c) and sumr=sumr+corresponding weight.
      real*4 med
      if((b.ge.a).and.(b.le.c))then
        med=b
        sum=sum+b*wb
        sumr=sumr+wb
      else if((b.le.a).and.(b.ge.c))then
        med=b
        sum=sum+b*wb
        sumr=sumr+wb
      else if((a.ge.b).and.(a.le.c))then
        med=a
        sum=sum+a*wa
        sumr=sumr+wa
      else if((a.le.b).and.(a.ge.c))then
        med=a
        sum=sum+a*wa
        sumr=sumr+wa
      else if((c.ge.a).and.(c.le.b))then
        med=c
        sum=sum+c*wc
        sumr=sumr+wc
      else if((c.le.a).and.(c.ge.b))then
        med=c
        sum=sum+c*wc
        sumr=sumr+wc
      else
        write(*,*)'MEDIAN: should not be here'
      endif
      return
      end