      SUBROUTINE ITERATE
     &           (NNW,     NGP,    NW_IPAR,
     &            CRD,     PHI,    PHN,
     &            A0,      A1,     B,
     &            ALPHA,   MAX_IT, TOL,     X)
C ---------------------------------------------------------------------------
C     Iteratively solves the following system of equations:
C
C     A0 * X (:, 1) + A1 * X (:, 2) = B
C                     Tr * X (:, 2) = D * X (:, 1)
C
C     where A0 and A1 are the Boundary Integral Equations.
C     and Tr and D are the Spline matrices.
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
      INCLUDE 'net_params.inc'
      INCLUDE 'usr_params.inc'
      INCLUDE 'chk_params.inc'
C
      INTEGER(KIND=IK) NNW
      INTEGER(KIND=IK) NGP
      INTEGER(KIND=IK) NW_IPAR (N_IP, *)
      REAL   (KIND=RK) CRD (4, *)
      REAL   (KIND=RK) PHI (2, *)
      REAL   (KIND=RK) PHN (2, *)
      REAL   (KIND=RK) A0 (NGP, NGP)
      REAL   (KIND=RK) A1 (NGP, NGP)
      REAL   (KIND=RK) B (NGP)
      REAL   (KIND=RK) ALPHA (*)
      INTEGER(KIND=IK) MAX_IT
      REAL   (KIND=RK) TOL (*)
      REAL   (KIND=RK) X (NGP, 2)
C
      LOGICAL(KIND=LK) CONVERGED
      INTEGER(KIND=IK) COUNTER
      REAL   (KIND=RK) RES (2)
      DATA             RES /2*0.0D0/
      REAL   (KIND=RK) Y (NGP, 2)
C
      WRITE (USR_O, *) '=== ITERATE =='
C
      IF (CHK_EQNS) CALL CHECK_EQNS (NGP, A0, A1, X, B)
C
      CONVERGED = .FALSE.
      COUNTER   = 0
C     A0 <- Inverse (A0)
      CALL INVERT (NGP, A0)
C
      DO WHILE (.NOT. CONVERGED .AND. COUNTER. LT. MAX_IT)
C         Y (:, 1) <- X (:, 2)
          CALL DCOPY (NGP, X (1, 2), 1, Y, 1)
C         Y (:, 2) <- B
C         Y (:, 2) <- Y (:, 2) - A1 * Y (:, 1)
C         Y (:, 1) <- INVERSE (A0) * Y (:, 2)
          CALL SOLVE_AX_B (NGP, A0, A1, Y, B)
C         X (:, 1) <- (1 - alpha) * Y (:, 1) + alpha * X (:, 1)
          CALL RESIDUAL (NGP, 1, ALPHA, Y, X, RES)
          CALL SET_TANGENT (NNW, NW_IPAR, CRD,
     &                      PHI, PHN, X (1, 1), X (1, 2))
          CALL DERIVATIVES (1, 1, NNW, NW_IPAR, X (1, 1), X (1, 2))
C         CHECK CONVERGENCE
          CONVERGED = RES (1) .LT. TOL (1) .AND. RES (2) .LT. TOL (2)
          COUNTER   = COUNTER + 1
          WRITE (USR_O, 1101) RES, COUNTER
      END DO
C
      IF (.NOT. CONVERGED) THEN
         CALL ERROR ('ITERATE', 'No convergence')
      END IF
      WRITE (USR_O, 1001) RES, COUNTER
C
      RETURN
 1001 FORMAT (1X,'ITR:',2E9.1,' USING ', I4,' ITERATIONS')
 1101 FORMAT (1X,'RES:',2E9.1,' ITERATION ', I4)
      END
      SUBROUTINE SOLVE_AX_B (N, A0_INV, A1, X, B)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      INTEGER(KIND=IK) N
      REAL   (KIND=RK) A0_INV (N, N)
      REAL   (KIND=RK) A1 (N, N)
      REAL   (KIND=RK) X (N, 2)
      REAL   (KIND=RK) B (N)
C     X (:, 2) <- B
      CALL DCOPY (N, B, 1, X (1, 2), 1)
C     X (:, 2)  <- X (:, 2) - A1 * X (:, 1)
      CALL DGEMV
     &   ('N', N, N, -1.0D0, A1,     N, X (1, 1), 1, 1.0D0, X (1, 2), 1)
C     X (:, 1) <- INVERSE (A0) * X (:, 2)
      CALL DGEMV
     &   ('N', N, N,  1.0D0, A0_INV, N, X (1, 2), 1, 0.0D0, X (1, 1), 1)
C
      RETURN
      END
      SUBROUTINE INVERT (N, A)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      INTEGER(KIND=IK) N
      REAL   (KIND=RK) A (N, N)
C
      INTEGER(KIND=IK) INFO
      INTEGER(KIND=IK) IPIV (N)
      CHARACTER*48     MSG
      REAL   (KIND=RK) W (3 * N)
C
      CALL DGETRF (N, N, A, N, IPIV, INFO)
      IF (INFO .NE. 0) THEN
         IF (INFO .LT. 0) WRITE (MSG, 201) 'DGETRF', INFO
         IF (INFO .GT. 0) WRITE (MSG, 211) 'DGETRF', INFO
         CALL ERROR ('INVERT', MSG)
      END IF
C
      CALL DGETRI (N, A, N, IPIV, W, 3 * N, INFO)
      IF (INFO .NE. 0) THEN
         IF (INFO .LT. 0) WRITE (MSG, 201) 'DGETRI', INFO
         IF (INFO .GT. 0) WRITE (MSG, 211) 'DGETRI', INFO
         CALL ERROR ('INVERT', MSG)
      END IF
C
      RETURN
  201 FORMAT (1X,A,': ARGUMENT',I2,' IS INCORRECT')
  211 FORMAT (1X,A,': MATRIX BECAME SINGULAR AT ROW',I4)
      END
      SUBROUTINE RESIDUAL (N, K, ALPHA, Y, X, RES)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      INTEGER(KIND=IK) N
      INTEGER(KIND=IK) K
      REAL   (KIND=RK) ALPHA (K)
      REAL   (KIND=RK) Y (N, K)
      REAL   (KIND=RK) X (N, K)
      REAL   (KIND=RK) RES (K)
C
      INTEGER(KIND=IK) I
      INTEGER(KIND=IK) J
      REAL   (KIND=RK) DX
C
      DO J = 1, K
         RES (J) = 0.0D0
         DO I = 1, N
            DX = X (I, J) - Y (I, J)
            RES (J) = MAX (RES (J), ABS (DX))
            X (I, J) = (1.0D0 - ALPHA (J)) * Y (I, J)
     &               +          ALPHA (J)  * X (I, J)
         END DO
      END DO
C
      RETURN
      END
      SUBROUTINE CHECK_EQNS (NGP, A0, A1, X, B)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      INTEGER(KIND=IK) NGP
      REAL   (KIND=RK) A0 (NGP, *)
      REAL   (KIND=RK) A1 (NGP, *)
      REAL   (KIND=RK) X (NGP, *)
      REAL   (KIND=RK) B (*)
C
      INTEGER(KIND=IK) I, J
      REAL   (KIND=RK) S
C
      WRITE (*, *) '=== CHECK EQNS ==='
      DO I = 1, NGP
         S = 0.0D0
         DO J = 1, NGP
            S = S + A0 (I, J) * X (J, 1) + A1 (I, J) * X (J, 2)
         END DO
         WRITE (*, '(1X,I3,'':'',E10.1)') I, S - B (I)
      END DO
      WRITE (*, *) '=== CHECK EQNS ==='
C
      RETURN
      END


! Subroutine getomi finds poles and weights for representing epsInv.
! Written by J. Kas, 2006
      SUBROUTINE getomi(wgrid, epsInv, NPts, NPoles, omi, gi, Deltai,
     &     eps0)
      IMPLICIT NONE
!     Input variables
!     wGrid(NPts)  - grid of omega
!     epsInv(NPts) - loss function
!     NPoles       - Number of poles to represent epsInv

!     Output
!     omi          - omega position of poles
!     gi           - pole strengths
!     Deltai       - energry region about omi where
      INTEGER NPoles, NPts
      DOUBLE PRECISION wGrid(NPts), epsInv(NPts), omi(NPoles),
     &     gi(NPoles), Deltai(NPoles), eps0

!     Local variables
      INTEGER maxPts, MaxPoles, iMax, i1, i2
      PARAMETER (maxPts = 50000)
      DOUBLE PRECISION M0, M0i, M1i, MM1i, M1Old, M1New, omNew, omOld,
     $     pi, Tmp1(maxPts), Tmp2(maxPts), IntGrl, a, b, c, frac, egap
      PARAMETER (pi = 3.14159 26535 89793 23846 26433d0)
      EXTERNAL IntGrl
!     Find zeroth moment
!      frac = (1.d0-0.01d0)
      frac = 0.999d0
      M0 = 0.5d0*epsInv(1)*wGrid(1)
      DO i1 = 2, NPts
         M0 = M0 + 0.5d0*(epsInv(i1)+epsInv(i1-1))*
     &        (wGrid(i1)-wGrid(i1-1))
         Tmp1(i1) = epsInv(i1)/wGrid(i1)
         Tmp2(i1) = epsInv(i1)*wGrid(i1)
      END DO
!     Find gap energy
!      DO i1 = 1, NPts

!     Now find energy regions such that the integral of epsinv in each region is
!     equal.
      omOld = 0.d0
      omNew = 0.d0
      M1Old = 0.d0
      M1New = 0.d0
      ! Save the first 10 poles for low energies.
      DO i1 = 1, NPoles
         M0i = 0.5d0*epsInv(1)*wGrid(1)
         M1New = 0.5d0*epsInv(1)*wGrid(1)**2
         DO i2 = 2, NPts
            IF(M0i.ge.(DBLE(i1)*frac*M0/DBLE(NPoles))) THEN
               omOld = omNew
               omNew = wGrid(i2-1)
               IF(i2.eq.1) THEN
                  M0i = 0.d0
               ELSEIF(i2.eq.2) THEN
                  M0i = 0.5d0*epsInv(1)*wGrid(1)
               ELSE
                  M0i = M0i - 0.5d0*(epsInv(i2-1)+ epsInv(i2-2))*
     $              (wGrid(i2-1)-wGrid(i2-2))
               END IF
               GOTO 5
            ELSE
               M0i = M0i + 0.5d0*(epsInv(i2)+epsInv(i2-1))*
     $              (wGrid(i2)-wGrid(i2-1))
               M1New = M1New + 0.5d0*(epsInv(i2)*wGrid(i2)+ epsInv(i2-1)
     $              *wGrid(i2-1))*(wGrid(i2)-wGrid(i2-1))
            END IF
         END DO
 5       CONTINUE

!        The region has been found up to the wGrid accuracy. Now interpolate
!        to find omi
         IF(i2.eq.2) THEN
            a = epsInv(i2-1)/omNew
         ELSE
            a = (epsInv(i2-1) - epsInv(i2-2))/(omNew - wGrid(i2-2))
            b = epsInv(i2-2)
         END IF
         a = MAX(a, 1.d-6)
         c = 2.d0/a*(M0i - frac*M0*(DBLE(i1)/DBLE(NPoles)))

         omNew = wGrid(i2-2) - b/a + SQRT((b/a)**2 - c)
         IF((omNew.lt.wGrid(i2-2)).or.(omNew.gt.wGrid(i2-1))) THEN
            omNew = wGrid(i2-2) - b/a - SQRT((b/a)**2 - c)
         END IF

         IF(.FALSE.) THEN
            omOld = DBLE(i1-1)*500.d0/DBLE(NPoles)
            omNew = DBLE(i1)*500.d0/DBLE(NPoles)
         END IF
!        Now set omi and g s.t. the inverse and first moments are preserved for
!        this region.
         MM1i = 0.d0
         M1i  = 0.d0
         IF(omOld.eq.0.d0) THEN
            MM1i = 0.5d0*epsInv(1)
            M1i  = 0.5d0*epsInv(1)*wGrid(1)**2
            omOld = wGrid(1)
         END IF
         MM1i = MM1i + IntGrl(omOld, omNew, wGrid, Tmp1, NPts)
         M1i  = M1i + IntGrl(omOld, omNew, wGrid, Tmp2, NPts)
         gi(i1)  = 2.d0/pi*MM1i
         omi(i1) = SQRT(M1i/MM1i)
         Deltai(i1) = omNew-omOld
         M1Old  = M1New
         !PRINT '(a27,i6,20f20.10)', 'i1, omi, omOld, omNew, a, b', i1,
         !&    omi(i1), omOld, omNew, a, b
      END DO

!     Shift and scale the poles to set inverse moment to 1-1/eps0, without changing
!     first moment. (eps0 is input by user)
      CALL getdom(gi,omi,NPoles,eps0)

      RETURN
      END
      subroutine terp (x, y, n, m, x0, y0)
      implicit double precision (a-h, o-z)

      dimension x(n), y(n)

c     Find out between which x points x0 lies
      i = locat (x0, n, x)
      k = min( max(i-m/2,1) , n-m )
      call polint( x(k), y(k), m+1, x0, y0, dy)

      return
      end

      subroutine polint( xa, ya, n, x, y, dy)
c     draws a polynimial P(x) of order (n-1) through n points.
c     returns y = P(x) and dy - estimate of the error
c     adapted  from numerical recipies in fortran by Press et al.

      implicit double precision (a-h,o-z)
      integer n, nmax
      parameter (nmax=4)
      dimension xa(nmax), ya(nmax), c(nmax), d (nmax)

      ns = 1
      dif = abs (x-xa(1))
      do 10 i=1,n
         dift = abs(x-xa(i))
         if (dift.lt.dif) then
            ns = i
            dif = dift
         endif
         c(i) = ya(i)
         d(i) = ya(i)
  10  continue
      y = ya(ns)
      ns = ns-1
      do 30 m=1,n-1
         do 20 i=1,n-m
            ho = xa(i)-x
            hp = xa(i+m)-x
            w = c(i+1) - d(i)
            den = ho-hp
            if (den.eq.0) pause 'failure in polint'
            den = w/den
            d(i) = hp*den
            c(i) = ho*den
  20     continue
         if (2*ns .lt. n-m) then
            dy = c(ns+1)
         else
            dy = d(ns)
            ns = ns-1
         endif
         y = y + dy
  30  continue

      return
      end

      function locat (x, n, xx)
      integer  u, m, n
      double precision x, xx(n)

c     Binary search for index of grid point immediately below x.
c     Array xx required to be monotonic increasing.
c     Returns
c     0            x <  xx(1)
c     1            x =  xx(1)
c     i            x =  xx(i)
c     n            x >= xx(n)

      locat = 0
      u = n+1

   10 if (u-locat .gt. 1)  then
         m = (u + locat) / 2
         if (x .lt. xx(m))  then
            u = m
         else
            locat = m
         endif
         goto 10
      endif

      return
      end

      DOUBLE PRECISION FUNCTION IntGrl(a, b, x, y, n)
      INTEGER n, i, iStart, iLast
      DOUBLE PRECISION x(n), y(n), dx, a, b, aEnd, bEnd,
     &     ya, yb

      iStart = -1
      iLast = -1
      IntGrl = 0.d0
      dx = x(2) - x(1)

      DO i = 1, n
         IF(x(i).ge.a.and.x(i).lt.b) THEN
            iStart = i
            goto 5
         ELSE
            iStart = -1
         END IF
      END DO
 5    CONTINUE

      DO i = n, 1, -1
         IF(x(i).le.b.and.x(i).gt.a) THEN
            iLast = i
            goto 10
         ELSE
            iLast = -1
         END IF
      END DO
 10   CONTINUE

      IF (iStart.lt.0.and.iLast.lt.0) THEN
         CALL terp(x, y, n, 1, a, ya)
         CALL terp(x, y, n, 1, b, yb)
         IntGrl = IntGrl + 0.5d0*(yb+ya)*(b-a)
      ELSE
         DO i = iStart, iLast-1
            dx=x(i+1)-x(i)
            IntGrl = IntGrl + 0.5d0*(y(i)+y(i+1))*dx
         END DO

         CALL terp(x, y, n, 1, a, ya)
         CALL terp(x, y, n, 1, b, yb)

         IntGrl = IntGrl + 0.5d0*(ya+y(iStart))*(x(iStart) - a)
         IntGrl = IntGrl + 0.5d0*(yb+y(iLast))*(b-x(iLast))
      END IF
      RETURN
      END
      SUBROUTINE rdloss(Uloss,Dat,NPts)
      IMPLICIT NONE
c     Variables passed
      INTEGER Uloss, NPts
      DOUBLE PRECISION Dat(50000,2)

c     local variables
      INTEGER nterp,n,i
      DOUBLE PRECISION dum
      CHARACTER(1) comment, ch
      CHARACTER(200) Line
      comment='#*!c'
      nterp=1
      n=0

c     Read data into Dat
 200  DO i=1,50000
c     Read past comments
         CALL rdcmt(Uloss,comment)
         READ(Uloss,*,end=250) Dat(i,1), Dat(i,2)
         n=i
      END DO
 250  CONTINUE
      NPts=n

300   CLOSE(Uloss)
      RETURN
      END
      SUBROUTINE rdcmt(iUnt,Cmt)
      INTEGER iUnt, i1
      CHARACTER(300) line
      CHARACTER(4) Cmt
      CHARACTER TmpCmt(4), ch
      LOGICAL CmtLin

      CmtLin = .true.
      DO i1 = 1, 4
         TmpCmt(i1) = Cmt(i1:i1)
      END DO
 5    CONTINUE
      READ(iUnt,*,END=10) ch
      DO i1 = 1, 4
         IF(ch.eq.TmpCmt(i1)) goto 5
      END DO

      BACKSPACE(iUnt)

 10   CONTINUE

      RETURN
      END
! Written by J. Kas, 2006
! eps2exc takes loss function from loss.dat and gives poles and weights
! corresponding to the many pole model detailed in
! Phys. Rev. B 76, 195116 (2007).
! First, regions are chosen
      PROGRAM eps2exc
      DOUBLE PRECISION Dat(50000,2), g(10000), gamma, omi(10000),
     &     Delta(10000),eps0, sumrl, xNElec, csumrl
      INTEGER i,i1,ios1,ios2,imax, NPoles,NPts,NFile
      CHARACTER*80 infl, outfl, comment
      CHARACTER ch
      EXTERNAL IntGrl
      NPts = 1000
      infl='loss.dat'
      outfl='exc.dat'
      PRINT*, '# Enter number of poles:'
      READ*, NPoles
      ! This input can be used to correct the sumrules
      !PRINT*, '# Enter eps^-1 sumrule and N_el:'
      !READ*, sumrl, xNElec
      sumrl = 1.d0
      xNElec = 1.d0
      PRINT*, 'Is this a metal? (y/n)'
      READ*, ch
      IF(ch.EQ.'y'.OR.ch.EQ.'Y') THEN
         eps0 = -1.d0
      ELSE
         PRINT*, 'Would you like to set the dielectric constant? (y/n)'
         READ*, ch
         IF(ch.EQ.'n'.OR.ch.EQ.'N') THEN
            eps0 = -2.d0
         ELSE

            ! This input can be used to correct the dielectric constant,
            ! which is related to the inverse moment.
            ! Use eps0 = -2 to ignore this correction.
            PRINT*, '# Enter dielectric constant: '
            READ*, eps0
         END IF
      END IF
      PRINT*, eps0
      gamma = 0.01
      csumrl= xNElec/sumrl

      OPEN(unit=12,file=infl,status='old')
      OPEN(unit=13,file=outfl,status='replace')
      CALL rdloss(12,Dat,NPts)

      DO i1 = 1, NPts
         Dat(i1,2) = Dat(i1,2)*csumrl
      END DO
      ! getomi finds poles and weights
      CALL getomi(Dat(1,1), Dat(1,2), NPts, NPoles, omi, g, Delta, eps0)
      WRITE(13,'(A33,I4,A6)') '# Loss function represented with ',
     $     NPoles, ' poles'
      WRITE(13,'(A23,f8.4)') '# Dielectric constant: ', eps0
      DO i = 1, NPoles
         WRITE(13,'(4f20.10)'), omi(i), omi(i)*gamma, g(i), Delta(i)
      END DO

      END
! This will change the pole representation of the loss function without
! changing the f-sum rules. Written by J. Kas 2006
      SUBROUTINE getdom(gi,omi,NPoles,eps0)
      IMPLICIT NONE

!     Input/output
      INTEGER NPoles
      DOUBLE PRECISION gi(NPoles), omi(NPoles), eps0

!     Local
      INTEGER i1, i2, MxIter
      DOUBLE PRECISION MM1, tol, dom, dom1, dom2, sumg1, sumg2
      PARAMETER(MxIter = 10000, tol = 1.d-6)
      IF(eps0.lt.-1.5d0) RETURN
      IF(eps0.lt.0.d0) THEN
         MM1 = 1.d0
      ELSE
         MM1   = 1.d0 - 1.d0/eps0
      END IF
      dom1  = -omi(1)*0.999d0
      dom2  = omi(1)*0.999d0
!     Bracket dom between dom1 and dom2
      DO i1 = 1, MxIter
         sumg1 = 0.d0
         sumg2 = 0.d0
         DO i2 = 1, NPoles
            sumg1 = sumg1 + gi(i2)*(omi(i2)/(omi(i2)-dom1))**2
            sumg2 = sumg2 + gi(i2)*(omi(i2)/(omi(i2)-dom2))**2
         END DO
         IF((sumg1.lt.MM1).and.(sumg2.gt.MM1)) GOTO 5
         !IF(sumg1.gt.MM1) dom1 = dom1*2.d0
         !IF(sumg2.lt.MM1) dom2 = dom2/2.d0
         PRINT*, 'Error in getdom.f.'
         PRINT*, 'sumg1, sumg2', sumg1, sumg2, MM1, dom1, dom2
         STOP
      END DO
 5    CONTINUE                  ! dom bracketed

      dom = 0.5d0*(dom1+dom2)
      DO i1 = 1, MxIter
         sumg1 = 0.d0
         DO i2 = 1, NPoles
            sumg1 = sumg1 + gi(i2)*(omi(i2)/(omi(i2)-dom))**2
         END DO
         IF(abs((sumg1-MM1)/MM1).lt.tol) GOTO 10
         IF((sumg1-MM1).gt.0.d0) THEN
            dom2 = dom
         ELSE
            dom1 = dom
         END IF
         dom = 0.5d0*(dom1+dom2)
      END DO
 10   CONTINUE

      DO i1 = 1, NPoles
         gi(i1)  = gi(i1)*(omi(i1)/(omi(i1)-dom))**2
         omi(i1) = omi(i1)-dom
      END DO
      RETURN
      END


C
C**************************  MASS_ADV ************************************
C
C  post-calculate the mass advected in and out after the
C  advective router (VOLFIN)
C
C***********************************************************************
C
      SUBROUTINE MASS_ADV(NFACE,DELTATADV,PLIST,VN,
     1           PRECL,PRECR,MASSOUTADV,MASSINADV,
     2           MASSOUTTOTADV,MASSINTOTADV)
C
      IMPLICIT NONE
      INTEGER  I
      INTEGER  NFACE,PLIST(2,*)
      REAL*8   VN(*),DELTATADV
      REAL*8   PRECL(*),PRECR(*)
      REAL*8   MASSOUTADV,MASSINADV
      REAL*8   MASSOUTTOTADV,MASSINTOTADV
      REAL*8   MASSINLOC,MASSOUTLOC
C
C  CARLOTTA POST COMPUTATION OF MASSBALANCE
c      SFMASSOUT=0.0d0
c      SFEV=0.0d0
c      SFIN=0.0d0
      MASSINLOC=0.0d0
      MASSOUTLOC=0.0d0
      DO I=1,NFACE
         IF(PLIST(2,I).EQ.0)THEN
           IF(VN(I).GE.0.0d0)THEN
CC QUI É SU TUTTO BOUNDARY
              MASSOUTADV=MASSOUTADV+VN(I)*PRECL(I)*DELTATADV
              MASSOUTLOC=MASSOUTLOC+VN(I)*PRECL(I)*DELTATADV
c           ELSE
c             SFEV=SFEV+VN(I)*PRECL(I)*
c     1                 DELTATADV
c           END IF
           ELSE
              MASSINADV=MASSINADV+VN(I)*PRECR(I)*DELTATADV
              MASSINLOC=MASSINLOC+VN(I)*PRECR(I)*DELTATADV
           END IF
         END IF
      END DO
C Condition bidouille, mais sinon il y a un
C problème d'écriture dans les fichiers de sortie
C     IF (MASSOUTLOC.LE.1.0D-99) THEN
C     MASSOUTLOC=0.0d0
C     END IF
C     IF (MASSINLOC.LE.1.0D-99) THEN
C     MASSINLOC=0.0d0
C     END IF
C
c      SFMASSOUTTOT=SFMASSOUTTOT+SFMASSOUT
      MASSOUTTOTADV=MASSOUTTOTADV+MASSOUTLOC
c      SFEVTOT=SFEVTOT+SFEV
      MASSINTOTADV=MASSINTOTADV+MASSINLOC
cc  CARLOTTA Queste sono di Dirichlet
c         DO I=1,NFACE
c            IF(Faces_FaceType(I).EQ.0)THEN
c              IF(VN(I).GT.0.0d0)THEN
cc qui sto guardando Seepage face
c                C=C+VN(I)*precl(i)*deltatadv
c              END IF
c           END IF
c         END DO
C
      RETURN
      END


module mod_gaussseidel_standard
#include <messenger.h>
    use mod_kinds,              only: rk, ik
    use mod_constants,          only: ONE, ZERO
    use DNAD_D
!    use mod_inv,                only: inv

    implicit none

contains

    !> Solution routine
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/24/2016
    !!
    !!
    !!
    !--------------------------------------------------------------
    subroutine gaussseidel_standard(A,x,b)
        real(rk), intent(in)           :: A(:,:)
        real(rk), intent(inout)        :: x(:)
        real(rk), intent(in)           :: b(:)

        real(rk), allocatable, dimension(:)     :: r, diff, xold, err
        real(rk), dimension(size(x))            :: D

        integer(ik) :: iparent, ierr, iblk, ielem, i, irow, icol
        real(rk)    :: res, tol

        tol = 1.e-13_rk

        !
        ! Initialize D blocks
        !
        do irow = 1,size(A,1)
            D(irow) = ONE/A(irow,irow)
        end do

        xold = x
        x    = ZERO
        xold = ZERO

        res = 1._rk
        do while (res > tol)

            !
            ! form b - Ax, except for diagonal
            !
            r = b
            do irow = 1,size(A,1)
                do icol = 1,size(A,2)

                    !
                    ! Don't multiply diagonal
                    !
                    if ( irow /= icol ) then
                        r(irow) = r(irow) - A(irow,icol) * x(icol)
                    end if

                end do

                !
                ! Multiply by inverse block diagonal
                !
                x(irow) = D(irow) * r(irow)
            end do

            !
            ! Compute residual
            !
            err = b - matmul(A,x)
            res = norm2(err)

            xold = x    ! store old solution

        end do ! res > self%tol

    end subroutine gaussseidel_standard

    !> Solution routine
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/9/2018
    !!
    !!
    !--------------------------------------------------------------
    subroutine gaussseidel_autodiff(A,x,b)
        type(AD_D), intent(in)      :: A(:,:)
        type(AD_D), intent(inout)   :: x(:)
        type(AD_D), intent(in)      :: b(:)

        type(AD_D), allocatable, dimension(:)     :: r, diff, xold, err
        type(AD_D), dimension(size(x))            :: D
        type(AD_D)  :: res, res1

        integer(ik) :: iparent, ierr, iblk, ielem, i, irow, icol, iiter
        real(rk)    :: tol, oreduction

        tol = 1.e-11_rk

        !
        ! Initialize D blocks
        !
        do irow = 1,size(A,1)
            D(irow) = ONE/A(irow,irow)
        end do

        ! Initialize derivatives
        x = b
        x = ZERO

        xold = x
        x    = ZERO
        xold = ZERO

        res = b(1)
        res = 1._rk
        iiter = 1
        do while (res > tol)

            !
            ! form b - Ax, except for diagonal
            !
            r = b
            do irow = 1,size(A,1)
                do icol = 1,size(A,2)

                    !
                    ! Don't multiply diagonal
                    !
                    if ( irow /= icol ) then
                        r(irow) = r(irow) - A(irow,icol) * x(icol)
                    end if

                end do

                !
                ! Multiply by inverse block diagonal
                !
                x(irow) = D(irow) * r(irow)
            end do

            !
            ! Compute residual
            !
            err = b - matmul(A,x)
            res = norm2(err)
            if (iiter == 1) res1 = res

            print*, res%x_ad_
            if (log10(res/res1) < -8.) exit

            xold = x    ! store old solution

            iiter = iiter + 1
        end do ! res > self%tol

    end subroutine gaussseidel_autodiff

end module mod_gaussseidel_standard


c     # ------------------------------------------------------------
c     # Prescribes velocity fields for the unit square ([0.1]x[0,1]).
c     #
c     # Assumes all components are given in coordinates relative to
c     # the standard basis (1,0) and (0,1).
c     # ------------------------------------------------------------

c      subroutine square_velocity_components(x,y,u,vcart,flag)
c      implicit none
c
c      double precision x, y, u(2), vcart(3)
c      double precision uderivs(4)
c
c      double precision s
c
c      call velocity_derivs(x,y,u,uderivs)
c
c      end

      subroutine square_velocity_derivs(x,y,t,u,vcart,derivs,flag)
      implicit none

      double precision x, y, t, u(2), vcart(3)
      double precision derivs(4)
      integer flag

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      double precision velocity(2)
      common /velocity_comm/ velocity

      double precision s, u1x, u1y, u2x, u2y

c     # uderivs(1) = u1x
c     # uderivs(2) = u1y
c     # uderivs(3) = u2x
c     # uderivs(4) = u2y

      u1x = 0
      u1y = 0
      u2x = 0
      u2y = 0

c     # Basis map is the unit
      flag = 1

c     # Set non-zeros derivs only
      s = sqrt(2.d0)
      if (example .eq. 0) then
         u(1) = velocity(1)
         u(2) = velocity(2)
      elseif (example .eq. 1) then
c        # No sonic points, i.e. velocity field > 0
         u(1) = s*(cos(pi*x)**2 + 0.5d0)
         u(2) = s*(sin(pi*y)**2 + 0.5d0)
         u1x = -2*pi*s*cos(pi*x)*sin(pi*x)
         u2y =  2*pi*s*sin(pi*y)*cos(pi*y)
      elseif (example .eq. 2) then
c        # Velocity field crosses 0
         u(1) = s*(cos(pi*x)**2 - 0.5d0)
         u(2) = s*(sin(pi*y)**2 - 0.5d0)
         u1x = -2*pi*s*cos(pi*x)*sin(pi*x)
         u2y =  2*pi*s*sin(pi*y)*cos(pi*y)
      else
         write(6,'(A,A)') 'square_velocity : ',
     &              'No valid example provided'
         stop
      endif

      vcart(1) = u(1)
      vcart(2) = u(2)
      vcart(3) = 0

      derivs(1) = u1x
      derivs(2) = u1y
      derivs(3) = u2x
      derivs(4) = u2y

      end

c     # ----------------------------------------------------------------
c     #                       Public interface
c     # ----------------------------------------------------------------

c     # ---------------------------------------------
c     # Called from setaux
c     #
c     #    -- used to compute velocity at faces
c     # ---------------------------------------------
      subroutine velocity_components_cart(x,y,t,vcart)
      implicit none

      double precision x,y,t, u(2), vcart(3), derivs(4)
      integer flag

      call square_velocity_derivs(x,y,t, u,vcart,derivs,flag)

c      if (flag .eq. 0) then
cc         # Velocity components are given in spherical components
cc         # and must be converted to Cartesian
c          call map_covariant_basis(x, y, t1,t2)
c
c          do k = 1,3
c              vcart(k) = u(1)*t1(k) + u(2)*t2(k)
c          enddo
c      endif

      end

c     # ------------------------------------------------------------
c     # Called from map_divergence
c     #
c     #    -- Needed to define ODE system to get exact solution
c     # ------------------------------------------------------------
      subroutine velocity_derivs(x,y,t, u, vcart, derivs, flag)
      implicit none

      double precision x,y,t, u(2), vcart(3), derivs(4)
      integer flag

      call square_velocity_derivs(x,y,t, u,vcart,derivs,flag)

c     # Not needed for Cartesian grid
c      if (flag .eq. 1) then
cc         # Velocity components are given in Cartesian components
cc         # Derivatives are automatically given in terms of basis.
c          call map_covariant_basis(x, y, t1,t2)
c          t1n2 = map_dot(t1,t1)
c          t2n2 = map_dot(t2,t2)
c          u(1) = map_dot(vcart,t1)/t1n2
c          u(2) = map_dot(vcart,t2)/t2n2
c      endif

      end

c     # ------------------------------------------------------------
c     # Called from qexact
c     #
c     #  -- components relative to basis are needed.
c     # ------------------------------------------------------------
      subroutine velocity_components(x,y,t,u)
      implicit none

      double precision x,y,t, u(2), vcart(3), derivs(4)
      integer flag

      call velocity_derivs(x,y,t, u,vcart,derivs,flag)

      end

cc     # ------------------------------------------------------------
cc     # Center : u = u1*tau1 + u2*tau2   (div u might not be zero)
cc     # ------------------------------------------------------------
c      subroutine velocity_componet(x,y,t,vcart)
c      implicit none
c
c      double precision x,y,vel(3)
c
c
c      double precision u(2), derivs(4)
c
c      integer k
c
cc     # Velocity components are given in Cartesian components
c      call square_velocity_derivs(x,y,t,u)
c
c
cc     # Velocities are all given in terms of Cartesian components
c      do k = 1,2
c        vel(k) = u(k)
c      enddo
c      vel(3) = 0
c
c      end


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

program testieee19
use ieee_arithmetic
real*8 a, ral, rsa, rone
real*8 aa1(1040), aa2(1040), aa3(1040), aa4(1040)
logical ll1(1040), ll2(1040), le1(1040), le2(1040)
logical luflow!, cg_support_underflow_control
logical lfsav(5), lfset(5)

lfset = .false.
call ieee_get_halting_mode(ieee_all, lfsav)
call ieee_set_halting_mode(ieee_all, lfset)

call ieee_get_underflow_mode(luflow)
call ieee_set_underflow_mode(.true.)

rone = 1.0d0
rlogb = 0.0d0
a = rone
do j = 1, 1040
  ral = ieee_logb(a)
  aa1(j) = ral
  aa2(j) = rlogb
  i = int(ieee_rint(ral))
  rsa = ieee_scalb(rone,i)
  aa3(j) = rsa
  aa4(j) = a
  a = a * 0.5d0
  rlogb = rlogb - 1.0d0
end do

do j = 1, 1040
  ll1(j) = aa1(j) .eq. aa2(j)
  ll2(j) = aa3(j) .eq. aa4(j)
end do

le1 = .true.
le2 = .true.

call check(ll1, le1, 1040)
call check(ll2, le2, 1040)

! We need to stop putting conditions in tests
!
! if (cg_support_underflow_control(a)) then

call ieee_set_underflow_mode(.false.)

rone = 1.0d0
rlogb = 0.0d0
a = rone
do j = 1, 1040
  ral = ieee_logb(a)
  i = int(ieee_rint(ral))
  rsa = ieee_scalb(rone,i)
  aa3(j) = rsa
  aa4(j) = a
  a = a * 0.5d0
  rlogb = rlogb - 1.0d0
end do

do j = 1, 1040
  ll2(j) = aa3(j) .eq. aa4(j)
end do

le2 = .true.

call check(ll2, le2, 1040)
! end if

call ieee_set_underflow_mode(luflow)
call ieee_set_halting_mode(ieee_all, lfsav)
end

! This function uses a "bug" in our oldcg implementation of exp
!logical function cg_support_underflow_control(a)
!use ieee_arithmetic
!real*8 a, b
!b = ieee_value(a,ieee_negative_inf)
!cg_support_underflow_control = ieee_is_normal(exp(b))
!return
!end


! { dg-do compile }
! Tests the fix for PR33566, in which the first variable array ref
! to v1 would cause an incompatible ranks error and the second an ICE.
!
! Contributed by Mikael Morin <mikael.morin@tele2.fr>
!
      program test_vec

      implicit none

      integer :: i
      real    :: x

      type vec3
        real, dimension(3) :: coords
      end type vec3

      type(vec3),parameter :: v1 = vec3((/ 1.0, 2.0, 3.0 /))
      type(vec3)           :: v2

      v2 = vec3((/ 1.0, 2.0, 3.0 /))

      x = v1%coords(1)

      do i=1,3
        x = v1%coords(i)  ! used to fail
        x = v2%coords(i)
      end do

      i = 2

      v2 = vec3 (v1%coords ((/i+1, i, i-1/))) ! also broken

      end program test_vec


      SUBROUTINE COMPAREFLOATINGNUMBERS(FIRSTVALUE,SECONDVALUE,
     &                                    STATUS)
*
*       +---------------------------------------------------+
*       | Copyright (c) FORMAT Int '03. All rights reserved |
*       +---------------------------------------------------+
*       | Subroutine :  COMPAREFLOATINGNUMBERS              |
*       | Description:  Compare for floating equality       |
*       | Revision   :  November 2003                       |
*       +---------------------------------------------------+
*
*------------------------
*  Implicit definition  *
*------------------------
*
        IMPLICIT INTEGER (A-Z)
*
*------------------
*  Indirect data  *
*------------------
*
        DOUBLE PRECISION FIRSTVALUE,SECONDVALUE
*
*---------------
*  Local data  *
*---------------
*
        DOUBLE PRECISION DIFF,RATIO,ETOL
*       DATA ETOL /0.000001D0/
        DATA ETOL /0.0000000001D0/
*
*----------------------------------
*             STATUS              *
*----------------------------------
*                                 *
*  -1 = Firstvalue < Secondvalue  *
*   0 = Firstvalue = Secondvalue  *
*   1 = Firstvalue > Secondvalue  *
*------------------------------------
*
*-----------------------------
*  Test if values are equal  *
*-----------------------------
*
        IF(FIRSTVALUE.EQ.SECONDVALUE) THEN
          STATUS=0
          RETURN
        END IF
*--------------------------------
*  Test if first value is zero  *
*--------------------------------
*
        IF(FIRSTVALUE.EQ.0D0) THEN
          IF(DABS(SECONDVALUE).LT.ETOL) THEN
            STATUS=0
          ELSE IF(SECONDVALUE.LT.0D0) THEN
            STATUS=1
          ELSE
            STATUS=-1
          END IF
          RETURN
        END IF
*
*---------------------------------
*  Test if second value is zero  *
*---------------------------------
*
        IF(SECONDVALUE.EQ.0D0) THEN
          IF(DABS(FIRSTVALUE).LT.ETOL) THEN
            STATUS=0
          ELSE IF(FIRSTVALUE.LT.0D0) THEN
            STATUS=-1
          ELSE
            STATUS=1
          END IF
          RETURN
        END IF
*
*---------------------------
*  Perform magnitude test  *
*---------------------------
*
        DIFF=DABS(FIRSTVALUE-SECONDVALUE)
        IF(DIFF.LE.DABS(FIRSTVALUE)) THEN
          RATIO=DIFF/DABS(SECONDVALUE)
          IF(RATIO.LT.ETOL) THEN
            STATUS=0
            RETURN
          END IF
        END IF
*
*---------------------------
*  Magnitude test failure  *
*---------------------------
*
        IF(FIRSTVALUE.LT.SECONDVALUE) THEN
          STATUS=-1
        ELSE
          STATUS=1
        END IF
        RETURN
*
        END


*     MC01SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 10 )
*     .. Local Scalars ..
      INTEGER          BETA, DP, I, INFO, S, T
*     .. Local Arrays ..
      DOUBLE PRECISION MANT(DPMAX+1), P(DPMAX+1)
      INTEGER          E(DPMAX+1), IWORK(DPMAX+1)
C     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH
*     .. External Subroutines ..
      EXTERNAL         MC01SD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Compute the coefficients of the scaled polynomial Q(x).
         CALL MC01SD( DP, P, S, T, MANT, E, IWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            BETA = DLAMCH( 'Base' )
            WRITE ( NOUT, FMT = 99995 ) BETA, S, T
            WRITE ( NOUT,FMT = 99997 )
            DO 20 I = 0, DP
               WRITE ( NOUT, FMT = 99996 ) I, P(I+1)
   20       CONTINUE
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01SD = ',I2)
99997 FORMAT (/' The coefficients of the scaled polynomial Q(x) = s*P(',
     $       'tx) are ',//' power of x     coefficient ')
99996 FORMAT (2X,I5,9X,F9.4)
99995 FORMAT (' The base of the machine (BETA) = ',I2,//' The scaling ',
     $       'factors are s = BETA**(',I3,') and t = BETA**(',I3,')')
99994 FORMAT (/' DP is out of range.',/' DP =',I5)
      END


c-----------------------------------------------------------------------
c http://www.netlib.org/bihar/
c-----------------------------------------------------------------------
      subroutine drffti (n,wsave)
      integer n
c wsave is a work array which should be dimensioned at least 2*n+15
      real*8 wsave(*)
c
      if (n .eq. 1) return
c
      call drfti1 (n,wsave(n+1),wsave(2*n+1))
c
      return
      end
c
c-----------------------------------------------------------------------
      subroutine drfti1 (n,wa,ifac)
      integer n
      real*8 wa(n), ifac(15)
c
      real*8 TPI
      parameter (TPI = 6.2831853071 7958647692 5286766559 00577d0)
c
      integer i, ib, ido, ii, ip, ipm, is, j, k1, l1, l2, ld,
     &  nf, nfm1, nl, nq, nr, ntry
      integer ntryh(4)
      real*8 arg, argh, argld, fi
c
      data ntryh /4, 2, 3, 5/
c
      nl = n
      nf = 0
      j = 0
c
  101 j = j+1
      if (j.le.4) ntry = ntryh(j)
      if (j.gt.4) ntry = ntry + 2
  104 nq = nl/ntry
      nr = nl-ntry*nq
      if (nr.ne.0) go to 101
c
  105 nf = nf+1
      ifac(nf+2) = ntry
      nl = nq
      if (ntry .ne. 2) go to 107
      if (nf .eq. 1) go to 107
      do 106 i=2,nf
         ib = nf-i+2
         ifac(ib+2) = ifac(ib+1)
  106 continue
      ifac(3) = 2
  107 if (nl .ne. 1) go to 104
      ifac(1) = n
      ifac(2) = nf
c
      argh = TPI/dble(n)
      is = 0
      nfm1 = nf-1
      l1 = 1
      if (nfm1 .eq. 0) return
      do 110 k1=1,nfm1
         ip = ifac(k1+2)
         ld = 0
         l2 = l1*ip
         ido = n/l2
         ipm = ip-1
         do 109 j=1,ipm
            ld = ld+l1
            i = is
            argld = dble(ld)*argh
            fi = 0.d0
            do 108 ii=3,ido,2
               i = i+2
               fi = fi+1.d0
               arg = fi*argld
               wa(i-1) = dcos(arg)
               wa(i) = dsin(arg)
  108       continue
            is = is+ido
  109    continue
c
         l1 = l2
  110 continue
c
      return
      end
c


C NCLFORTSTART
      SUBROUTINE DINT2P(PPIN,XXIN,P,X,NPIN,PPOUT,XXOUT,NPOUT,LINLOG,
     +     XMSG,IER)
      IMPLICIT NONE

c routine to interpolate from one set of pressure levels
c .   to another set  using linear or ln(p) interpolation
c
c NCL: xout = int2p (pin,xin,pout,linlog)
c
c This code was originally written for a specific purpose.
c .   Several features were added for incorporation into NCL's
c .   function suite including linear extrapolation.
c
c nomenclature:
c
c .   ppin   - input pressure levels. The pin can be
c .            be in ascending or descending order
c .   xxin   - data at corresponding input pressure levels
c .   npin   - number of input pressure levels >= 2
c .   ppout  - output pressure levels (input by user)
c .            same (ascending or descending) order as pin
c .   xxout  - data at corresponding output pressure levels
c .   npout  - number of output pressure levels
c .   linlog - if abs(linlog)=1 use linear interp in pressure
c .            if abs(linlog) anything but =1 linear interp in
c .                ln(pressure)
c .            If the value is negative then the routine will
c .            extrapolate. Be wary of results in this case.
c .   xmsg   - missing data code. if none, set to some number
c .            which will not be encountered (e.g., 1.e+36)
c .   ier    - error code

c                                                ! input types
      INTEGER NPIN,NPOUT,LINLOG,IER
      DOUBLE PRECISION PPIN(NPIN),XXIN(NPIN),PPOUT(NPOUT),XMSG
C                                                ! output
      DOUBLE PRECISION XXOUT(NPOUT)
C NCLEND

c local
      INTEGER J1,NP,NL,NIN,NLMAX,NPLVL,NLSAVE,NP1,NO1,N1,N2,LOGLIN,
     +        NLSTRT
      DOUBLE PRECISION SLOPE,PA,PB,PC

C automatic arrays
      DOUBLE PRECISION PIN(NPIN),XIN(NPIN),P(NPIN),X(NPIN)
      DOUBLE PRECISION POUT(NPOUT),XOUT(NPOUT)

      LOGLIN = ABS(LINLOG)

c error check: enough points: pressures consistency?

      IER = 0
      IF (NPOUT.GT.0) THEN
          DO NP = 1,NPOUT
              XXOUT(NP) = XMSG
          END DO
      END IF

      IF (NPIN.LT.2 .OR. NPOUT.LT.1) IER = IER + 1

C C C IF (NPOUT.GT.1) THEN
C C C     IF ((PPIN(1).GT.PPIN(2).AND.PPOUT(1).LT.PPOUT(2)) .OR.
C C C+        (PPIN(1).LT.PPIN(2).AND.PPOUT(1).GT.PPOUT(2))) THEN
C C C         IER = IER + 10
C              PRINT *,'INT2P: ppout is in different order than ppin'
C              PRINT *,'       Must both be monotonic {in/de}creasing'
C C C     END IF
C C C END IF

      IF (IER.NE.0) THEN
C          PRINT *,'INT2P: error exit: ier=',IER
          RETURN
      END IF

c should input arrays be reordered: want p(1) > p(2) > p(3) etc
c so that it will match order for which code was originally designed
c copy to local arrays

      NP1 = 0
      NO1 = 0
      IF (PPIN(1).LT.PPIN(2)) THEN
          NP1 = NPIN + 1
          NO1 = NPOUT + 1
      END IF

      DO NP = 1,NPIN
          PIN(NP) = PPIN(ABS(NP1-NP))
          XIN(NP) = XXIN(ABS(NP1-NP))
      END DO

      DO NP = 1,NPOUT
          POUT(NP) = PPOUT(ABS(NO1-NP))
      END DO
c
c eliminate levels with missing data. This can easily
c .   happen with observational data.
c
      NL = 0
      DO NP = 1,NPIN
          IF (XIN(NP).NE.XMSG .AND. PIN(NP).NE.XMSG) THEN
              NL = NL + 1
              P(NL) = PIN(NP)
              X(NL) = XIN(NP)
          END IF
      END DO
      NLMAX = NL
C                                                ! all missing data
      IF (NLMAX.LT.2) THEN
          IER = IER + 1000
C          PRINT *,'INT2P: ier=',IER
          RETURN
      END IF

c ===============> pressure in decreasing order <================
c perform the interpolation  [pin(1)>pin(2)>...>pin(npin)]
c                                                      ( p ,x)
c ------------------------- p(nl+1), x(nl+1)   example (200,5)
c .
c ------------------------- pout(np), xout(np)         (250,?)
c .
c ------------------------- p(nl)  , x(nl)             (300,10)

c exact p-level matches
      NLSTRT = 1
      NLSAVE = 1
      DO NP = 1,NPOUT
          XOUT(NP) = XMSG
          DO NL = NLSTRT,NLMAX
              IF (POUT(NP).EQ.P(NL)) THEN
                  XOUT(NP) = X(NL)
                  NLSAVE = NL + 1
                  GO TO 10
              END IF
          END DO
   10     NLSTRT = NLSAVE
      END DO

      IF (LOGLIN.EQ.1) THEN
          DO NP = 1,NPOUT
              DO NL = 1,NLMAX - 1
                  IF (POUT(NP).LT.P(NL) .AND. POUT(NP).GT.P(NL+1)) THEN
                      SLOPE = (X(NL)-X(NL+1))/ (P(NL)-P(NL+1))
                      XOUT(NP) = X(NL+1) + SLOPE* (POUT(NP)-P(NL+1))
                  END IF
              END DO
          END DO
      ELSE
          DO NP = 1,NPOUT
              DO NL = 1,NLMAX - 1
                  IF (POUT(NP).LT.P(NL) .AND. POUT(NP).GT.P(NL+1)) THEN
                      PA = DLOG(P(NL))
                      PB = DLOG(POUT(NP))
c special case: In case someome inadvertently enter p=0.
                      if (p(nl+1).gt.0.d0) then
                          PC = DLOG(P(NL+1))
                      else
                          PC = DLOG(1.d-4)
                      end if

                      SLOPE = (X(NL)-X(NL+1))/ (PA-PC)
                      XOUT(NP) = X(NL+1) + SLOPE* (PB-PC)
                  END IF
              END DO
          END DO
      END IF

c extrapolate?
c . use the 'last' valid slope for extrapolating

      IF (LINLOG.LT.0) THEN
          DO NP = 1,NPOUT
              DO NL = 1,NLMAX
                  IF (POUT(NP).GT.P(1)) THEN
                      IF (LOGLIN.EQ.1) THEN
                          SLOPE = (X(2)-X(1))/ (P(2)-P(1))
                          XOUT(NP) = X(1) + SLOPE* (POUT(NP)-P(1))
                      ELSE
                          PA = DLOG(P(2))
                          PB = DLOG(POUT(NP))
                          PC = DLOG(P(1))
                          SLOPE = (X(2)-X(1))/ (PA-PC)
                          XOUT(NP) = X(1) + SLOPE* (PB-PC)
                      END IF
                  ELSE IF (POUT(NP).LT.P(NLMAX)) THEN
                      N1 = NLMAX
                      N2 = NLMAX - 1
                      IF (LOGLIN.EQ.1) THEN
                          SLOPE = (X(N1)-X(N2))/ (P(N1)-P(N2))
                          XOUT(NP) = X(N1) + SLOPE* (POUT(NP)-P(N1))
                      ELSE
                          PA = DLOG(P(N1))
                          PB = DLOG(POUT(NP))
                          PC = DLOG(P(N2))
                          SLOPE = (X(N1)-X(N2))/ (PA-PC)
                          XOUT(NP) = X(N1) + SLOPE* (PB-PC)
                      END IF
                  END IF
              END DO
          END DO
      END IF

c place results in the return array;
c .   reverse to original order

      DO NP = 1,NPOUT
          XXOUT(NP) = XOUT(ABS(NO1-NP))
      END DO

      RETURN
      END


        subroutine idz_qmatmat(ifadjoint,m,n,a,krank,l,b,work)
c
c       applies to a bunch of vectors collected together as a matrix
c       the Q matrix (or its adjoint) which the routine idzp_qrpiv
c       or idzr_qrpiv has stored in a triangle of the matrix
c       it produces (stored, incidentally, as data
c       for applying a bunch of Householder reflections).
c       Use the routine idz_qmatvec to apply the Q matrix
c       (or its adjoint)
c       to a single vector, if you'd rather not provide a work array.
c
c       input:
c       ifadjoint -- set to 0 for applying Q;
c                    set to 1 for applying the adjoint of Q
c       m -- first dimension of both a and b
c       n -- second dimension of a
c       a -- data describing the qr decomposition of a matrix,
c            as produced by idzp_qrpiv or idzr_qrpiv
c       krank -- numerical rank
c       l -- second dimension of b
c       b -- matrix to which Q (or its adjoint) is to be applied
c
c       output:
c       b -- matrix to which Q (or its adjoint) has been applied
c
c       work:
c       work -- must be at least krank real*8 elements long
c
        implicit none
        save
        integer l,m,n,krank,j,k,ifrescal,mm,ifadjoint
        real*8 work(krank)
        complex*16 a(m,n),b(m,l)
c
c
        if(ifadjoint .eq. 0) then
c
c
c         Handle the first iteration, j = 1,
c         calculating all scals (ifrescal = 1).
c
          ifrescal = 1
c
          j = 1
c
          do k = krank,1,-1
            if(k .lt. m) then
              mm = m-k+1
              call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                          work(k),b(k,j))
            endif
          enddo ! k
c
c
          if(l .gt. 1) then
c
c           Handle the other iterations, j > 1,
c           using the scals just computed (ifrescal = 0).
c
            ifrescal = 0
c
            do j = 2,l
c
              do k = krank,1,-1
                if(k .lt. m) then
                  mm = m-k+1
                  call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                              work(k),b(k,j))
                endif
              enddo ! k
c
            enddo ! j
c
          endif ! j .gt. 1
c
c
        endif ! ifadjoint .eq. 0
c
c
        if(ifadjoint .eq. 1) then
c
c
c         Handle the first iteration, j = 1,
c         calculating all scals (ifrescal = 1).
c
          ifrescal = 1
c
          j = 1
c
          do k = 1,krank
            if(k .lt. m) then
              mm = m-k+1
              call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                          work(k),b(k,j))
            endif
          enddo ! k
c
c
          if(l .gt. 1) then
c
c           Handle the other iterations, j > 1,
c           using the scals just computed (ifrescal = 0).
c
            ifrescal = 0
c
            do j = 2,l
c
              do k = 1,krank
                if(k .lt. m) then
                  mm = m-k+1
                  call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                              work(k),b(k,j))
                endif
              enddo ! k
c
            enddo ! j
c
          endif ! j .gt. 1
c
c
        endif ! ifadjoint .eq. 1
c
c
        return
        end
c
c
c
c


function fitness(vector)
    use numz
    use global_test
    use map_stuff
    implicit none
    real(b8) fitness
    integer, dimension(:),target ::  vector
    integer isize,i,tot
    test_vect=>vector
    isize=size(vector)
    tot=0
! our function compares the color of every state
! to those to which it shares a boarder
! map(i)%list is the list of boarding states for state i
    do i=1,isize
        my_color=vector(i)
        tot=tot+ltest(map(i)%list)
    enddo
    fitness=(100.0_b8-tot)/100.0_b8
end function

! function used by the fitness function
! compares the color of a list of states
! to "mycolor" adds 1 for each match
recursive function ltest(list) result (connect)
        use list_stuff
        use global_test
        type(llist),pointer :: list
        integer connect,tmp
        if(.not. associated(list))then
            connect=0
        else
            if(test_vect(list%index)  == my_color)then
                connect=1+ltest(list%next)
            else
                connect=ltest(list%next)
            endif
        endif
end function ltest


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_GRAD_XY

    USE MR_KINDS

    USE MR_DEF_ACTIVITY

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_GRAD_XY_UV , MR_CALC_GRAD_XY_SS
    PUBLIC :: MR_CALC_REDC_GRAD_XY_UV , MR_CALC_REDC_GRAD_XY_SS
    PUBLIC :: MR_CALC_BY_INTERP_GRAD_XY_SS

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_GRAD_XY_UV( NI , NJ , UU , VV , GRAD_XY_UV )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ,1:2) :: UU
    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ,1:2) :: VV

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2,1:2) :: GRAD_XY_UV

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM

  ! U DIRECTION
    DO DIM = 1 , 2

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
            GRAD_XY_UV( I , J ,DIM,1) = UU( I , J ,DIM) - UU(I-1, J ,DIM)
          ELSE
            GRAD_XY_UV( I , J ,DIM,1) = 0.0
          END IF
        END DO
      END DO

    END DO

  ! V DIRECTION
    DO DIM = 1 , 2

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
            GRAD_XY_UV( I , J ,DIM,2) = VV( I , J ,DIM) - VV( I ,J-1,DIM)
          ELSE
            GRAD_XY_UV( I , J ,DIM,2) = 0.0
          END IF
        END DO
      END DO

    END DO

  END SUBROUTINE MR_CALC_GRAD_XY_UV

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_REDC_GRAD_XY_UV( NI , NJ , UU , VV , REDC_GRAD_XY_UV )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ,1:2) :: UU
    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ,1:2) :: VV

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: REDC_GRAD_XY_UV

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2,1:2) :: GRAD_XY_UV

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM

    CALL MR_CALC_GRAD_XY_UV( NI , NJ , UU , VV , GRAD_XY_UV )

    DO DIM = 1 , 2

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          REDC_GRAD_XY_UV( I , J ,DIM) = GRAD_XY_UV( I , J ,DIM,1) + GRAD_XY_UV( I , J ,DIM,2)
        END DO
      END DO

    END DO

  END SUBROUTINE MR_CALC_REDC_GRAD_XY_UV

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_GRAD_XY_SS( NI , NJ , SU , SV , GRAD_XY_SS )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ) :: SU
    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ) :: SV

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: GRAD_XY_SS

    INTEGER(IJID_KIND) :: I , J

  ! U DIRECTION
    DO J = 1 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
          GRAD_XY_SS( I , J ,1) = SU( I , J ) - SU(I-1, J )
        ELSE
          GRAD_XY_SS( I , J ,1) = 0.0
        END IF
      END DO
    END DO

  ! V DIRECTION
    DO J = 1 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
          GRAD_XY_SS( I , J ,2) = SV( I , J ) - SV( I ,J-1)
        ELSE
          GRAD_XY_SS( I , J ,2) = 0.0
        END IF
      END DO
    END DO

  END SUBROUTINE MR_CALC_GRAD_XY_SS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_REDC_GRAD_XY_SS( NI , NJ , SU , SV , REDC_GRAD_XY_SS )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ) :: SU
    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ) :: SV

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ) :: REDC_GRAD_XY_SS

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: GRAD_XY_SS

    INTEGER(IJID_KIND) :: I , J

    CALL MR_CALC_GRAD_XY_SS( NI , NJ , SU , SV , GRAD_XY_SS )

    DO J = 1 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        REDC_GRAD_XY_SS( I , J ) = GRAD_XY_SS( I , J ,1) + GRAD_XY_SS( I , J ,2)
      END DO
    END DO

  END SUBROUTINE MR_CALC_REDC_GRAD_XY_SS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_BY_INTERP_GRAD_XY_SS( NI , NJ , SS , GRAD_XY_SS )

    USE MR_MOD_INTERP_XY

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ) :: SS

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: GRAD_XY_SS

    REAL   (FDRD_KIND) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ) :: SU
    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ) :: SV

    CALL MR_INTERP_XY_SS_U ( NI , NJ , SS , SU )
    CALL MR_INTERP_XY_SS_V ( NI , NJ , SS , SV )

    CALL MR_CALC_GRAD_XY_SS( NI , NJ , SU , SV , GRAD_XY_SS )

  END SUBROUTINE MR_CALC_BY_INTERP_GRAD_XY_SS

  END MODULE MR_MOD_CALC_GRAD_XY


c     =====================================================
      subroutine qinit(meqn,mbc,mx,my,mz,xlower,ylower,zlower,
     &     dx,dy,dz,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c     # Sample scalar equation with linear data to test
c     # that second order method stays exact.
c
      implicit double precision (a-h,o-z)
      dimension q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc,1-mbc:mz+mbc)
      dimension aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc,1-mbc:mz+mbc)

c     # set concentration profile
c     ---------------------------
      do 20 k=1,mz
         zk = zlower + (k-0.5d0)*dz
         do 20 j=1,my
            yj = ylower + (j-0.5d0)*dy
            do 20 i=1,mx
               xi = xlower + (i-0.5d0)*dx
               q(1,i,j,k) = qtrue(xi,yj,zk,0.d0)
   20    continue

      return
      end


!> \file exponential_cov.f90
!! Set of tools to build exponential covariance matrices.
!! By now, this toolbox support only the uniformly spaced grid: fixed discretization step.
!!  \author Innocent Souopgui
!!  \date 12/2013
!!  \version 1.0
!<

!> Procedures to build exponential covariance matrices
!!
!<
module exponential_cov
  use general_constant
  use general_tools
  use debug_tools

implicit none

  private
  public exp_cov_param, se_cov_matrix, load_ecp

  !> Derived type for 1D exponential covariance matrix parameters
  type exp_cov_param
    integer:: n !< Number of grid point
    integer:: k !< Number of significant eigenvalues/singular values to be kept
    real(dp):: dx !< discretization step
    real(dp):: s !< smoothing parameter of the covariance function (standard deviation at a single point)
    real(dp):: l !< decorrelation length
  end type exp_cov_param

  !> Computes a square exponential covariance matrix
  interface se_cov_matrix
    module procedure se_cov_matrix_scalar
    module procedure se_cov_matrix_type
  end interface se_cov_matrix

contains

  !> \brief Loads the parameters of an exponential covariance matrix from namelist file
  !! \param[in] ecp data structure containing the exponential covariance matrix parameters
  !! \param[in] fName name of the namelist file
  !! \param[in] dName name associated with physical space dimension where the covariance matrix will be applied.
  !! \param[in] n size of the covariance matrix (number of columns/rows)
  !! \param[in] delta discretization step
  !!
  !! \details The namelist is supposed to holds
  !! - the dimension name to make the difference with other covariance parameters in the namelist file
  !! - the number of significant singular values
  !! - the smoothing parameter
  !! - and the decorrelation length
  !! By default, dName picks values in ["X", "Y", "Z"], but can be anything meaningful to the program writer
  !<
  subroutine load_ecp(ecp, fName, dName, n, delta)
    INTEGER, PARAMETER:: fid = 68
    type(exp_cov_param), intent(out) :: ecp
    CHARACTER(len=*), INTENT(IN) :: fName, dName
    INTEGER, INTENT(IN) :: n
    REAL(cp), INTENT(IN) :: delta
    !local var
    CHARACTER(len=ip_snl) :: dimName, ala_dimName
    INTEGER :: nsv
    REAL(cp):: smoothing, decorrelation
    namelist/NAM_EXPONENTIAL_COV_PARAM/&
      dimName,&
      nsv,&
      smoothing,&
      decorrelation

    open(fid,file=fName,form='FORMATTED',status='OLD')
    dimName = "{#}@"
    ala_dimName = trim(dName)
    call uppercase(ala_dimName)
    call debug(ala_dimName, "In load_ecp, looking for dimName = ", tag=dALLWAYS)
    do while(dimName.ne.ala_dimName)
      read(fid, NAM_EXPONENTIAL_COV_PARAM)!reading the block
      call uppercase(dimName)
      call debug(dimName, "  found dimName = ", tag=dALLWAYS)
    end do
    close(fid)

    ecp = exp_cov_param(n, nsv, delta, smoothing, decorrelation)
  end subroutine load_ecp

  !> @brief Computes the square exponential covariance matrix for a 1D uniform grid, using exp_cov_param derived type
  !! @param [in, out] C square matrix of covariance
  !! @param [in] xcp covariance parameters in the x dimension
  !!
  !! @see se_cov_matrix_scalar
  !>
  subroutine se_cov_matrix_type(C, xcp)
    real(dp), dimension(:,:), intent(in out) :: C
    type(exp_cov_param), intent(in) :: xcp

    call se_cov_matrix_scalar(C, xcp%dx, xcp%s, xcp%l)
  end subroutine se_cov_matrix_type

  !> @brief Computes the square exponential covariance matrix for a 1D uniform grid, using scalar parameters
  !! @param [in, out] C square matrix of covariance
  !! @param [in] dx discretization step
  !! @param [in] s smoothing parameter of the covariance function (standard deviation)
  !! @param [in] lx correlation length
  !!
  !! The covariance betwen the grid points i and j is given by
  !! \f$ C(i,j) = s^2\exp(\frac{-(i\Delta_x-j\Delta_x)^2}{2l_x^2}) \f$
  !>
  subroutine se_cov_matrix_scalar(C, dx, s, lx)
    real(dp), dimension(:,:), intent(in out) :: C
    real(dp), intent(in) :: dx, s, lx
    !local variables
    real(dp) :: x, s2, lx2
    integer :: ii, jj

    s2 = s*s
    lx2 = lx*lx

    !compute the upper triangular part
    do jj=2, size(C,2)
      do ii=1, jj-1
        x = (ii-jj)*dx
        C(ii, jj) = s2*exp(-x*x/(2*lx2))
      end do
    end do

    !The diagonal element are all identical
    do jj=1,size(C,2)
      C(jj, jj) = s2
    end do

    !computes the lower triangular part by symmetry
    do jj = 1, size(C,2)
      do ii = jj+1, size(C,1)
        C(ii, jj) = C(jj, ii)
      end do
    end do

    !I strongly believe that the next (commented line) was not necessary
    !C = dx*C
  end subroutine se_cov_matrix_scalar

  !> @brief Covariance function using exponential of the square
  !! @param [in] x1, x2 points between which the covariance is evaluated
  !! @param [in] s smoothing parameter of the covariance function
  !! @param [in] lx decorrelation length
  !!
  !<
  function se_cov_function(x1, x2, s, lx)result(f)
    real(dp), intent(in) :: x1, x2, s, lx
    !local variables
    real(dp) :: f, x

    x = x1-x2
    f = s*s*exp(-x*x/(2*lx*lx))
  end function se_cov_function

  !> @brief Covariance function using exponential of absolute value
  !! @param [in] x1, x2 points between which the covariance is evaluated
  !! @param [in] s smoothing parameter of the covariance function; this is the varaince
  !! @param [in] lx decorrelation length
  !!
  !<
  function ae_cov_function(x1, x2, s, lx)result(f)
    real(dp), intent(in) :: x1, x2, s, lx
    real(dp) :: f

    f = s*s*exp(-abs(x1-x2)/lx);
  end function ae_cov_function
end module exponential_cov


!------------------------------------------------------------------------------
! MODULE: image_manipulation
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @description:
!> Collection of image manipulating routines.
!------------------------------------------------------------------------------
MODULE image_manipulation

USE ISO_FORTRAN_ENV
USE global_std

IMPLICIT NONE

INTERFACE downscale
    MODULE PROCEDURE downscale_ik2
    MODULE PROCEDURE downscale_ik4
END INTERFACE downscale

CONTAINS

!------------------------------------------------------------------------------
! SUBROUTINE: downscale_ik2
!------------------------------------------------------------------------------
!> @author Johannes Gebert, gebert@hlrs.de, HLRS/NUM
!
!> @brief
!> Reduce the resolution of a given image by a given integer factor.
!
!> @param[in] in_array Input array
!> @param[in] scale_factor Factor of high resolution voxels to get a mean ave.
!> @param[out] out_array Output array
!------------------------------------------------------------------------------
SUBROUTINE downscale_ik2(in_array, scale_factor, out_array)

    INTEGER(KIND=INT16), DIMENSION(:,:,:), INTENT(OUT) :: out_array
    INTEGER(KIND=INT16), DIMENSION(:,:,:), INTENT(IN) :: in_array
    INTEGER(KIND=ik), DIMENSION(3), INTENT(IN) :: scale_factor

    INTEGER(KIND=ik) :: ii, jj, kk, ll, mm, nn
    REAL(KIND=rk) :: scale_volume

    scale_volume = REAL(PRODUCT(scale_factor), KIND=rk)

    nn = 1_ik
    DO kk=1, SIZE(in_array, DIM=3), scale_factor(3)

        mm = 1_ik
        DO jj=1, SIZE(in_array, DIM=2), scale_factor(2)

            ll = 1_ik
            DO ii=1, SIZE(in_array, DIM=1), scale_factor(1)
                out_array(ll, mm, nn) = INT(SUM(REAL(in_array(&
                    ii:ii+scale_factor(1)-1_ik, &
                    jj:jj+scale_factor(2)-1_ik, &
                    kk:kk+scale_factor(3)-1_ik), KIND=rk)) / scale_volume, KIND=INT16)
                ll = ll + 1_ik
            END DO

            mm = mm + 1_ik
        END DO

        nn = nn + 1_ik
    END DO
END SUBROUTINE downscale_ik2

!------------------------------------------------------------------------------
! SUBROUTINE: downscale_ik4
!------------------------------------------------------------------------------
!> @author Johannes Gebert, gebert@hlrs.de, HLRS/NUM
!
!> @brief
!> Reduce the resolution of a given image by a given integer factor.
!
!> @param[in] in_array Input array
!> @param[in] scale_factor Factor of high resolution voxels to get a mean ave.
!> @param[out] out_array Output array
!------------------------------------------------------------------------------
SUBROUTINE downscale_ik4(in_array, scale_factor, out_array)

    INTEGER(KIND=INT32), DIMENSION(:,:,:), INTENT(OUT) :: out_array
    INTEGER(KIND=INT32), DIMENSION(:,:,:), INTENT(IN) :: in_array
    INTEGER(KIND=ik), DIMENSION(3), INTENT(IN) :: scale_factor

    INTEGER(KIND=ik) :: ii, jj, kk, ll, mm, nn
    REAL(KIND=rk) :: scale_volume

    scale_volume = REAL(PRODUCT(scale_factor), KIND=rk)

    nn = 1_ik
    DO kk=1, SIZE(in_array, DIM=3), scale_factor(3)

        mm = 1_ik
        DO jj=1, SIZE(in_array, DIM=2), scale_factor(2)

            ll = 1_ik
            DO ii=1, SIZE(in_array, DIM=1), scale_factor(1)
                out_array(ll, mm, nn) = SUM(in_array(&
                    ii:ii+scale_factor(1)-1_ik, &
                    jj:jj+scale_factor(2)-1_ik, &
                    kk:kk+scale_factor(3)-1_ik)) / scale_volume
                ll = ll + 1_ik
            END DO

            mm = mm + 1_ik
        END DO

        nn = nn + 1_ik
    END DO
END SUBROUTINE downscale_ik4

END MODULE image_manipulation


      DOUBLE PRECISION FUNCTION PHO_DFMASS(Xmin,Xmax,Pref2,Pvirt2,Imode)
C**********************************************************************
C
C     sampling of Mx diffractive mass distribution within
C              limits XMIN, XMAX
C
C     input:    XMIN,XMAX     mass limitations (GeV)
C               PREF2         original particle mass/ reference mass
C                             (squared, GeV**2)
C               PVIRT2        particle virtuality
C               IMODE         M**2 mass distribution
C                             1      1/(M**2+Q**2)
C                             2      1/(M**2+Q**2)**alpha
C                            -1      1/(M**2-Mref**2+Q**2)
C                            -2      1/(M**2-Mref**2+Q**2)**alpha
C
C     output:   diffractive mass (GeV)
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION ddelta , DT_RNDM , EPS , pm2 , Pref2 , Pvirt2 ,
     &                 xi , xma2 , Xmax , xmax2 , Xmin , xmin2
      INTEGER Imode
      SAVE

      PARAMETER (EPS=1.D-10)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  some constants
      INCLUDE 'inc/pocons'

      IF ( (Xmin.GE.Xmax) .OR. (Xmin.LE.0.3D0) ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A,3E12.4)')
     &         'PHO_DFMASS:ERROR: ' , 'invalid mass limits' , Xmin ,
     &        Xmax , Pref2
         CALL PHO_PREVNT(-1)
         PHO_DFMASS = 0.135D0
         RETURN
      END IF

      IF ( Imode.GT.0 ) THEN
         pm2 = -Pvirt2
      ELSE
         pm2 = Pref2 - Pvirt2
      END IF

C  critical pomeron
      IF ( ABS(Imode).EQ.1 ) THEN
         xmin2 = LOG(Xmin**2-pm2)
         xmax2 = LOG(Xmax**2-pm2)
         xi = (xmax2-xmin2)*DT_RNDM(pm2) + xmin2
         xma2 = EXP(xi) + pm2

C  supercritical pomeron
      ELSE IF ( ABS(Imode).EQ.2 ) THEN
         ddelta = 1.D0 - PARmdl(48)
         xmin2 = (Xmin**2-pm2)**ddelta
         xmax2 = (Xmax**2-pm2)**ddelta
         xi = (xmax2-xmin2)*DT_RNDM(pm2) + xmin2
         xma2 = xi**(1.D0/ddelta) + pm2
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(/,1X,A,I3)')
     &         'PHO_DFMASS:ERROR: unsupported mode' , Imode
         CALL PHO_ABORT
      END IF

      PHO_DFMASS = SQRT(xma2)
C  debug output
      IF ( IDEb(43).GE.15 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,4E12.3)')
     &         'PHO_DFMASS:Mmin,Mmax,Mref,Mass' , Xmin , Xmax , Pref2 ,
     &        SQRT(xma2)
      END IF

      END FUNCTION


      subroutine resbact

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine models bacteria in reservoirs

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name             |units       |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    inum1            |none        |reservoir number
!!    inum2            |none        |inflow hydrograph storage location number
!!    res_bactlp(:)    |# cfu/100ml |less persistent bacteria stored in
!!                                  |reservoir
!!    res_bactp(:)     |# cfu/100ml |persistent bacteria stored in reservoir
!!    reswtr           |m^3 H2O     |initial reservoir volume
!!    thbact           |none        |temperature adjustment factor for bacteria
!!                                  |die-off/growth
!!    tmpav(:)         |deg C       |average air temperature on current day
!!    varoute(2,:)     |m^3 H2O     |water flowing into reservoir on day
!!    varoute(18,:)    |# cfu/100ml |persistent bacteria
!!    varoute(19,:)    |# cfu/100ml |less persistent bacteria
!!    wdlpres          |1/day       |Die-off factor for less persistent bacteria
!!                                  |in reservoirs
!!    wdpres           |1/day       |Die-off factor for persistent bacteria in
!!                                  |reservoirs
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    res_bactlp(:)|# cfu/100ml  |less persistent bacteria in reservoir/outflow
!!                               |at end of day
!!    res_bactp(:) |# cfu/100ml  |persistent bacteria in reservoir/outflow at
!!                               |end of day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    jres        |none          |reservoir number
!!    netwtr      |m^3 H2O       |net amount of water in reservoir during
!!                               |time step
!!    totbactlp   |10^4 cfu      |mass less persistent bacteria
!!    totbactp    |10^4 cfu      |mass persistent bacteria
!!    wtmp        |deg C         |temperature of water in reach
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp, Max
!!    SWAT: Theta

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

      use parm
      implicit none

      integer :: jres
      real*8 :: totbactp, totbactlp, netwtr
      real*8 :: wtmp

      jres = 0
      jres = inum1

      !! calculate temperature in stream
      !! Stefan and Preudhomme. 1993.  Stream temperature estimation
      !! from air temperature.  Water Res. Bull. p. 27-45
      !! SWAT manual equation 2.3.13
      wtmp = 0.
      wtmp = 5.0 + 0.75 * tmpav(jres)
      if (wtmp <= 0.) wtmp = 0.1

!! daily mass balance
      !! total bacteria mass in reservoir
      totbactp = 0.
      totbactlp = 0.
      totbactp = varoute(18,inum2) * varoute(2,inum2)
     &                                        + res_bactp(jres) * reswtr
      totbactlp = varoute(19,inum2) * varoute(2,inum2)
     &                                       + res_bactlp(jres) * reswtr

      !! compute bacteria die-off
      totbactp = totbactp * Exp(-Theta(wdpres,thbact,wtmp))
      totbactp = Max(0., totbactp)
      totbactlp = totbactlp * Exp(-Theta(wdlpres,thbact,wtmp))
      totbactlp = Max(0., totbactlp)

      !! new concentration
      netwtr = 0.
      netwtr = varoute(2,inum2) + reswtr
      if (netwtr >= 1.) then
        res_bactp(jres) = totbactp / netwtr
        res_bactlp(jres) = totbactlp / netwtr
      else
        res_bactp(jres) = 0.
        res_bactlp(jres) = 0.
      end if

      return
      end


C***********************************************************************
C     TODO: rewrite
      subroutine interp(model,modlog,y,m,ncol,ntrk,ttrkk,tprewd,mtrk,
     &           xtrk,xout)
C=======================================================================
C
C     This subroutine interpolates a certain related measure with the EB
C     DB or ONe, according to input data, considering all the cases of
C     interpolation and extrapolation needed.
C
C     Created by ER Cojocaru (10/2012)
C
C-------------------------------------------------------------------
C     Input parameters:
C       model: DA,DB (0) or ONe (1)
C       QUESTION: what does it mean?
C       modlog: hay que usar log de la medida (1 - teff) o no (0) (DA/DB)
C       y: cooling time
C       m: mass of the WD
C       ncol: number of sequences(columns) available
C       ntrk: number de rows for sequence
C       ttrkk: known cooling times in the sequence
C       mtrk: known masses in the sequence
C       xtrk: values of the measure of interest known in sequence
C-------------------------------------------------------------------
C     Output parameters:
C       xout: measure of interest
C=======================================================================
      implicit real (a-h,m,o-z)

C     ---   Declaration de variables   ---
      integer ncol,ii,jj,k,ns,j1,j2,case1,case2,model,modlog
C     TIME
      real y,y1,y2,y3,y4,ym1,ym2
C     MASS
      real m,m1,m2
C     Measure of interest
      real x1,x2,x3,x4,xm1,xm2,xout

      real deltf,den,s,b,t

C     ---   Dimensions   ---
      integer ntrk(ncol)
      real mtrk(ncol),ttrkk(ncol,*)
      real tprewd(ncol),xtrk(ncol,*)

C     ---  Interpolating measure from tcool and mwd  ---

C     ---   Mass less than minimum   ---
      if (m .lt. mtrk(1)) then
        jj=1
        m1=mtrk(jj)
C       --- Checking if the time is less than the minimum---
        if(y.lt.ttrkk(jj,1)) then
C         making linear extrapolation in log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,2)/xtrk(jj,1))/deltf
              b=log10(xtrk(jj,2))-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm1=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=(xtrk(jj,2)-xtrk(jj,1))/deltf
              b=xtrk(jj,2)-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm1=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,2)-ttrkk(jj,1)
            s=(xtrk(jj,2)-xtrk(jj,1))/deltf
            b=xtrk(jj,2)-s*ttrkk(jj,2)
            xm1=s*y+b
          end if
          goto 20
        endif
C       --- Checking if the time is greater than maximum ---
        ns=ntrk(jj)
        if(y.gt.ttrkk(jj,ns)) then
C         making linear extrapolation in log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,ns)/xtrk(jj,ns-1))/deltf
              b=log10(xtrk(jj,ns))-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm1=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
              b=xtrk(jj,ns)-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm1=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,ns)-ttrkk(jj,ns-1)
            s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
            b=xtrk(jj,ns)-s*ttrkk(jj,ns)
            xm1=s*y+b
          end if
          goto 20
        endif
        do k=1,ns-1
          ii=k
C         ---   Interpolation of the tiempo   ---
          if (y .ge. ttrkk(jj,ii) .and. y .lt. ttrkk(jj,ii+1)) then
            y1=ttrkk(jj,ii)
            y2=ttrkk(jj,ii+1)
            x1=xtrk(jj,ii)
            x2=xtrk(jj,ii+1)
            deltf=(y-y1)/(y2-y1)
            xm1=x1+deltf*(x2-x1)
            goto 20
          end if
        end do
20      CONTINUE
        jj=2
        m2=mtrk(jj)
C       --- Checking if the time is less than minimum---
        if(y.lt.ttrkk(jj,1)) then
C         hacemos un extrapolacion lineal en log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,2)/xtrk(jj,1))/deltf
              b=log10(xtrk(jj,2))-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm2=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=(xtrk(jj,2)-xtrk(jj,1))/deltf
              b=xtrk(jj,2)-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm2=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,2)-ttrkk(jj,1)
            s=(xtrk(jj,2)-xtrk(jj,1))/deltf
            b=xtrk(jj,2)-s*ttrkk(jj,2)
            xm2=s*y+b
          end if
          goto 30
        endif
C       --- Checking if the time is greater than maximum---
        ns=ntrk(jj)
        if(y.gt.ttrkk(jj,ns)) then
C         making linear extrapolation in log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,ns)/xtrk(jj,ns-1))/deltf
              b=log10(xtrk(jj,ns))-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm2=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
              b=xtrk(jj,ns)-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm2=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,ns)-ttrkk(jj,ns-1)
            s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
            b=xtrk(jj,ns)-s*ttrkk(jj,ns)
            xm2=s*y+b
          end if
          goto 30
        endif
        do k=1,ntrk(jj)-1
          ii=k
C         ---   Interpolation of the time   ---
          if (y .ge. ttrkk(jj,ii) .and. y .lt. ttrkk(jj,ii+1)) then
            y1=ttrkk(jj,ii)
            y2=ttrkk(jj,ii+1)
            x1=xtrk(jj,ii)
            x2=xtrk(jj,ii+1)
            deltf=(y-y1)/(y2-y1)
            xm2=x1+deltf*(x2-x1)
            goto 30
          end if
        end do
30      CONTINUE
        s=(xm2-xm1)/(m2-m1)
        t=xm2-s*m2
        xout=s*m+t
        goto 100
      end if

C     ---   Mass greater than maximum---
      if (m .ge. mtrk(ncol)) then
        jj=ncol-1
        m1=mtrk(jj)
C       --- Checking if time is less than minimum---
        if(y.lt.ttrkk(jj,1)) then
C         making linear extrapolation in log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,2)/xtrk(jj,1))/deltf
              b=log10(xtrk(jj,2))-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm1=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=(xtrk(jj,2)-xtrk(jj,1))/deltf
              b=xtrk(jj,2)-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm1=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,2)-ttrkk(jj,1)
            s=(xtrk(jj,2)-xtrk(jj,1))/deltf
            b=xtrk(jj,2)-s*ttrkk(jj,2)
            xm1=s*y+b
          end if
          goto 200
        endif
C       --- Checking if time is greater than maximum---
        ns=ntrk(jj)
        if(y.gt.ttrkk(jj,ns)) then
C         making linear extrapolation in log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,ns)/xtrk(jj,ns-1))/deltf
              b=log10(xtrk(jj,ns))-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm1=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
              b=xtrk(jj,ns)-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm1=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,ns)-ttrkk(jj,ns-1)
            s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
            b=xtrk(jj,ns)-s*ttrkk(jj,ns)
            xm1=s*y+b
          end if
          goto 200
        endif
        do k=1,ns-1
          ii=k
C         ---   Interpolation of time   ---
          if (y .ge. ttrkk(jj,ii) .and. y .lt. ttrkk(jj,ii+1)) then
            y1=ttrkk(jj,ii)
            y2=ttrkk(jj,ii+1)
            x1=xtrk(jj,ii)
            x2=xtrk(jj,ii+1)
            deltf=(y-y1)/(y2-y1)
            xm1=x1+deltf*(x2-x1)
            goto 200
          end if
        end do
200     CONTINUE
        jj=ncol
        m2=mtrk(jj)
C       --- Checking if time is less than minimum ---
        if(y.lt.ttrkk(jj,1)) then
C       making linear extrapolation in log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,2)/xtrk(jj,1))/deltf
              b=log10(xtrk(jj,2))-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm2=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,2)+tprewd(jj))/(ttrkk(jj,1)+
     &              tprewd(jj)))
              s=(xtrk(jj,2)-xtrk(jj,1))/deltf
              b=xtrk(jj,2)-s*log10(ttrkk(jj,2)+tprewd(jj))
              xm2=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,2)-ttrkk(jj,1)
            s=(xtrk(jj,2)-xtrk(jj,1))/deltf
            b=xtrk(jj,2)-s*ttrkk(jj,2)
            xm2=s*y+b
          end if
          goto 300
        endif
C       --- Checking if time is greater than maximum ---
        ns=ntrk(jj)
        if(y.gt.ttrkk(jj,ns)) then
C         making linear extrapolation in log-log
          if(model.eq.0) then
            if(modlog.eq.1) then
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=log10(xtrk(jj,ns)/xtrk(jj,ns-1))/deltf
              b=log10(xtrk(jj,ns))-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm2=10.0**(s*log10(y+tprewd(jj))+b)
            else
              deltf=log10((ttrkk(jj,ns)+tprewd(jj))/(ttrkk(jj,ns-1)+
     &              tprewd(jj)))
              s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
              b=xtrk(jj,ns)-s*log10(ttrkk(jj,ns)+tprewd(jj))
              xm2=s*log10(y+tprewd(jj))+b
            endif
          else
            deltf=ttrkk(jj,ns)-ttrkk(jj,ns-1)
            s=(xtrk(jj,ns)-xtrk(jj,ns-1))/deltf
            b=xtrk(jj,ns)-s*ttrkk(jj,ns)
            xm2=s*y+b
          end if
          goto 300
        endif
        do k=1,ntrk(jj)-1
          ii=k
C         ---  Interpolation of time   ---
          if (y .ge. ttrkk(jj,ii) .and. y .lt. ttrkk(jj,ii+1)) then
            y1=ttrkk(jj,ii)
            y2=ttrkk(jj,ii+1)
            x1=xtrk(jj,ii)
            x2=xtrk(jj,ii+1)
            deltf=(y-y1)/(y2-y1)
            xm2=x1+deltf*(x2-x1)
            goto 300
          end if
        end do
300     CONTINUE
        s=(xm2-xm1)/(m2-m1)
        t=xm2-s*m2
        xout=s*m+t
        goto 100
      end if

C     ---   Search for masses of interpolation ---
      do 3 k=1,ncol-1
        j1=k
        if (m .ge. mtrk(k) .and. m .lt. mtrk(k+1)) then
          goto 4
        end if
3     continue
4     j2=j1+1

C     ---   Search for the times of interpolation (1)   ---
C     ---   Times less than minimum  ---
      if (y. lt. ttrkk(j1,1)) then
C       making linear extrapolation in log-log
        if(model.eq.0) then
          if(modlog.eq.1) then
            deltf=log10((ttrkk(j1,2)+tprewd(j1))/(ttrkk(j1,1)+
     &            tprewd(j1)))
            s=log10(xtrk(j1,2)/xtrk(j1,1))/deltf
            b=log10(xtrk(j1,2))-s*log10(ttrkk(j1,2)+tprewd(j1))
            x1=10.0**(s*log10(y+tprewd(j1))+b)
          else
            deltf=log10((ttrkk(j1,2)+tprewd(j1))/(ttrkk(j1,1)+
     &            tprewd(j1)))
            s=(xtrk(j1,2)-xtrk(j1,1))/deltf
            b=xtrk(j1,2)-s*log10(ttrkk(j1,2)+tprewd(j1))
            x1=s*log10(y+tprewd(j1))+b
          end if
        else
          deltf=ttrkk(j1,2)-ttrkk(j1,1)
          s=(xtrk(j1,2)-xtrk(j1,1))/deltf
          b=xtrk(j1,2)-s*ttrkk(j1,2)
          x1=s*y+b
        end if
        case1=1
        goto 6
      end if

C     ---   Times greater than maximum ---
      if(y .ge. ttrkk(j1,ntrk(j1))) then
        ns=ntrk(j1)
C       making linear extrapolation in log-log
        if(model.eq.0) then
          if(modlog.eq.1) then
            deltf=log10((ttrkk(j1,ns)+tprewd(j1))/(ttrkk(j1,ns-1)+
     &            tprewd(j1)))
            s=log10(xtrk(j1,ns)/xtrk(j1,ns-1))/deltf
            b=log10(xtrk(j1,ns))-s*log10(ttrkk(j1,ns)+tprewd(j1))
            x1=10.0**(s*log10(y+tprewd(j1))+b)
          else
            deltf=log10((ttrkk(j1,ns)+tprewd(j1))/(ttrkk(j1,ns-1)+
     &            tprewd(j1)))
            s=(xtrk(j1,ns)-xtrk(j1,ns-1))/deltf
            b=xtrk(j1,ns)-s*log10(ttrkk(j1,ns)+tprewd(j1))
            x1=s*log10(y+tprewd(j1))+b
          end if
        else
          deltf=ttrkk(j1,ns)-ttrkk(j1,ns-1)
          s=(xtrk(j1,ns)-xtrk(j1,ns-1))/deltf
          b=xtrk(j1,ns)-s*ttrkk(j1,ns)
          x1=s*y+b
        end if
        case1=1
        goto 6
      end if

C     ---   Times between the minimum and maximum ---
      do 5 k=1,ntrk(j1)-1
        if (y .ge. ttrkk(j1,k) .and. y .lt. ttrkk(j1,k+1)) then
          y1=ttrkk(j1,k  )
          y2=ttrkk(j1,k+1)
          x1=xtrk(j1,k  )
          x2=xtrk(j1,k+1)
          case1=0
          goto 6
        end if
5     continue

C     ---   Search for interpolation times (2)   ---
C     ---   Times less than minimum---
6     if (y. lt. ttrkk(j2,1)) then
C       making linear extrapolation in log-log
        if(model.eq.0) then
          if(modlog.eq.1) then
            deltf=log10((ttrkk(j2,2)+tprewd(j2))/(ttrkk(j2,1)+
     &            tprewd(j2)))
            s=log10(xtrk(j2,2)/xtrk(j2,1))/deltf
            b=log10(xtrk(j2,2))-s*log10(ttrkk(j2,2)+tprewd(j2))
            x3=10.0**(s*log10(y+tprewd(j2))+b)
          else
            deltf=log10((ttrkk(j2,2)+tprewd(j2))/(ttrkk(j2,1)+
     &            tprewd(j2)))
            s=(xtrk(j2,2)-xtrk(j2,1))/deltf
            b=xtrk(j2,2)-s*log10(ttrkk(j2,2)+tprewd(j2))
            x3=s*log10(y+tprewd(j2))+b
          end if
        else
          deltf=ttrkk(j2,2)-ttrkk(j2,1)
            s=(xtrk(j2,2)-xtrk(j2,1))/deltf
            b=xtrk(j2,2)-s*ttrkk(j2,2)
            x3=s*y+b
        end if
        case2=1
        goto 8
      endif

C     ---   Times greater than maximum   ---
      if(y .ge. ttrkk(j2,ntrk(j2))) then
        ns=ntrk(j2)
C       making linear extrapolation in log-log
        if(model.eq.0) then
          if(modlog.eq.1) then
            deltf=log10((ttrkk(j2,ns)+tprewd(j2))/(ttrkk(j2,ns-1)+
     &            tprewd(j2)))
            s=log10(xtrk(j2,ns)/xtrk(j2,ns-1))/deltf
            b=log10(xtrk(j2,ns))-s*log10(ttrkk(j2,ns)+tprewd(j2))
            x3=10.0**(s*log10(y+tprewd(j2))+b)
          else
            deltf=log10((ttrkk(j2,ns)+tprewd(j2))/(ttrkk(j2,ns-1)+
     &            tprewd(j2)))
            s=(xtrk(j2,ns)-xtrk(j2,ns-1))/deltf
            b=xtrk(j2,ns)-s*log10(ttrkk(j2,ns)+tprewd(j2))
            x3=s*log10(y+tprewd(j2))+b
          endif
        else
          deltf=ttrkk(j2,ns)-ttrkk(j2,ns-1)
          s=(xtrk(j2,ns)-xtrk(j2,ns-1))/deltf
          b=xtrk(j2,ns)-s*ttrkk(j2,ns)
          x3=s*y+b
        end if
        case2=1
        goto 8
      end if

C     ---   Times between the minimum and maximum ---
      do 7 k=1,ntrk(j2)-1
        if (y .ge. ttrkk(j2,k) .and. y .lt. ttrkk(j2,k+1)) then
          y3=ttrkk(j2,k  )
          y4=ttrkk(j2,k+1)
          x3=xtrk(j2,k  )
          x4=xtrk(j2,k+1)
          case2=0
          goto 8
        end if
7     continue

C     ---   Bilinear interpolation ---
8     m1=mtrk(j1)
      m2=mtrk(j2)
      den=(m-m1)/(m2-m1)
      if(case1.eq.0.AND.case2.eq.0) then
        ym1=y1+(y3-y1)*den
        ym2=y2+(y4-y2)*den
        xm1=x1+(x3-x1)*den
        xm2=x2+(x4-x2)*den
        xout=xm1+(y-ym1)/(ym2-ym1)*(xm2-xm1)
      elseif(case1.eq.0.AND.case2.eq.1) then
        xm1=x1+(x2-x1)*(y-y1)/(y2-y1)
        xout=xm1+(x3-xm1)*den
      elseif(case1.eq.1.AND.case2.eq.0) then
        xm2=x3+(x4-x3)*(y-y3)/(y4-y3)
        xout=x1+(xm2-x1)*den
      else
        xout=x1+(x3-x1)*den
      end if
100   continue

      if(isNaN(xout)) then
        write(*,*) "Error interp(tcool,mass,model,log):",y,m,model,
     &             modlog
        stop
      end if

      return
      end
C***********************************************************************


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine objective_stress_dx(nodeset,istartset,iendset,ialset,
     &  nk,idesvarc,iobject,dgdx,ndesi,nobject,stn,dstn,objectset,g0)
!
!     calculates derivative of the sum of the square of the
!     von Mises stress of a node set w.r.t. the coordinates of the mesh
!
      implicit none
!
      character*81 objectset(3,*)
!
      integer nk,istartset(*),iendset(*),ialset(*),nodeset,
     &  idesvarc,iobject,j,k,ndesi,nobject,idesvar
!
      real*8 dgdx(ndesi,nobject),stn(6,*),dstn(6,*),g0(nobject),
     &  rho,xstress,svm,dsvmdx,p
!
      idesvar=idesvarc+1
!
!     reading rho and the mean stress for the Kreisselmeier-Steinhauser
!     function
!
      read(objectset(2,iobject)(41:60),'(f20.0)') rho
      read(objectset(2,iobject)(61:80),'(f20.0)') xstress
!
!     check for the existence of a set, else take the complete mesh
!
      if(nodeset.eq.0) then
         do j=1,nk
            p=-(stn(1,j)+stn(2,j)+stn(3,j))/3.d0
            svm=dsqrt(1.5d0*
     &        ((stn(1,j)+p)**2+(stn(2,j)+p)**2+(stn(3,j)+p)**2+
     &         2.d0*(stn(4,j)**2+stn(5,j)**2+stn(6,j)**2)))
            dsvmdx=
     &           (2.d0*stn(1,j)-stn(2,j)-stn(3,j))*dstn(1,j)+
     &           (2.d0*stn(2,j)-stn(1,j)-stn(3,j))*dstn(2,j)+
     &           (2.d0*stn(3,j)-stn(1,j)-stn(2,j))*dstn(3,j)+
     &           6.d0*(stn(4,j)*dstn(4,j)+stn(5,j)*dstn(5,j)+
     &                 stn(6,j))
            dgdx(idesvar,iobject)=dgdx(idesvar,iobject)+
     &           dexp(rho*svm/xstress)*dsvmdx
         enddo
         dgdx(idesvar,iobject)=dgdx(idesvar,iobject)*
     &         dexp(-rho*g0(iobject))/xstress
      else
         do j=istartset(nodeset),iendset(nodeset)
            if(ialset(j).gt.0) then
               k=ialset(j)
               p=-(stn(1,k)+stn(2,k)+stn(3,k))/3.d0
               svm=dsqrt(1.5d0*
     &              ((stn(1,k)+p)**2+(stn(2,k)+p)**2+(stn(3,k)+p)**2+
     &              2.d0*(stn(4,k)**2+stn(5,k)**2+stn(6,k)**2)))
               dsvmdx=
     &              (2.d0*stn(1,k)-stn(2,k)-stn(3,k))*dstn(1,k)+
     &              (2.d0*stn(2,k)-stn(1,k)-stn(3,k))*dstn(2,k)+
     &              (2.d0*stn(3,k)-stn(1,k)-stn(2,k))*dstn(3,k)+
     &              6.d0*(stn(4,k)*dstn(4,k)+stn(5,k)*dstn(5,k)+
     &              stn(6,k))
               dgdx(idesvar,iobject)=dgdx(idesvar,iobject)+
     &              dexp(rho*svm/xstress)*dsvmdx
            else
               k=ialset(j-2)
               do
                  k=k-ialset(j)
                  if(k.ge.ialset(j-1)) exit
                  p=-(stn(1,k)+stn(2,k)+stn(3,k))/3.d0
                  svm=dsqrt(1.5d0*
     &                 ((stn(1,k)+p)**2+(stn(2,k)+p)**2+(stn(3,k)+p)**2+
     &                 2.d0*(stn(4,k)**2+stn(5,k)**2+stn(6,k)**2)))
                  dsvmdx=
     &                 (2.d0*stn(1,k)-stn(2,k)-stn(3,k))*dstn(1,k)+
     &                 (2.d0*stn(2,k)-stn(1,k)-stn(3,k))*dstn(2,k)+
     &                 (2.d0*stn(3,k)-stn(1,k)-stn(2,k))*dstn(3,k)+
     &                 6.d0*(stn(4,k)*dstn(4,k)+stn(5,k)*dstn(5,k)+
     &                 stn(6,k))
                  dgdx(idesvar,iobject)=dgdx(idesvar,iobject)+
     &                 dexp(rho*svm/xstress)*dsvmdx
               enddo
            endif
         enddo
         dgdx(idesvar,iobject)=dgdx(idesvar,iobject)*
     &         dexp(-rho*g0(iobject))/xstress
      endif
!
      return
      end