! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program barot_obs_random

use    types_mod, only : r8
use   random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian

! this routine used to call a special NAG subroutine but we have a
! replacement one in the system now.

! Places a given number of observations randomly uniformly on the sphere
! Used to test barotropic model ability to deal with increasingly sparse
! observations. Also tacks on the observational variance.

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

integer :: num_obs
real(r8), parameter :: variance = (1e6)**2_r8
real(r8) :: x, y, z, lon, length, lat
integer :: i
type(random_seq_type) :: s

call init_random_sequence(s)

write(*, *) 'input the number of observations'
read(*, *) num_obs

write(*, *) num_obs
do i = 1, num_obs
! Compute a random point in a volume and then compute direction to surface
11 x = random_gaussian(0.0_r8, 1.0_r8)
   y = random_gaussian(0.0_r8, 1.0_r8)
   z = random_gaussian(0.0_r8, 1.0_r8)
! Begin by computing longitude in degrees
   lon = atan2(y, x) * 360.0 / (2.0 * 3.14159) + 180.0
   if(lon < 0.0 .or. lon > 360.0) then
      write(*, *) 'longitude out of bound'
      stop
   endif
   length = sqrt(x**2 + y**2)
   lat = atan2(z, length) * 360.0 / (2.0 * 3.14159)
   if(lat < -90.0 .or. lat > 90.0) then
      write(*, *) 'latitude out of bound'
      stop
   endif
! For barotropic model, don't want to go too close to poles for now
   if(lat < -83 .or. lat > 83) goto 11

!----------------------------------------------------------
! Option for doing NH only
!   if(lat < 0 .or. lat > 85) goto 11
!----------------------------------------------------------
! Option for doing extended WH only
!    if(lon > 60 .and. lon < 160) goto 11
!----------------------------------------------------------
! Option for doing NA only
     if(lon < 180 .or. lon > 300 .or. lat > 80 .or. lat < 20) goto 11
!----------------------------------------------------------
   write(*, *) lon, lat, variance
end do

end program barot_obs_random

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


*DECK CFFTB1
      SUBROUTINE CFFTB1 (N, C, CH, WA, IFAC)
C***BEGIN PROLOGUE  CFFTB1
C***PURPOSE  Compute the unnormalized inverse of CFFTF1.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A2
C***TYPE      COMPLEX (RFFTB1-S, CFFTB1-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine CFFTB1 computes the backward complex discrete Fourier
C  transform (the Fourier synthesis).  Equivalently, CFFTB1 computes
C  a complex periodic sequence from its Fourier coefficients.
C  The transform is defined below at output parameter C.
C
C  A call of CFFTF1 followed by a call of CFFTB1 will multiply the
C  sequence by N.
C
C  The arrays WA and IFAC which are used by subroutine CFFTB1 must be
C  initialized by calling subroutine CFFTI1 (N, WA, IFAC).
C
C  Input Parameters
C
C  N       the length of the complex sequence C.  The method is
C          more efficient when N is the product of small primes.
C
C  C       a complex array of length N which contains the sequence
C
C  CH      a real work array of length at least 2*N
C
C  WA      a real work array which must be dimensioned at least 2*N.
C
C  IFAC    an integer work array which must be dimensioned at least 15.
C
C          The WA and IFAC arrays must be initialized by calling
C          subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC
C          arrays must be used for each different value of N.  This
C          initialization does not have to be repeated so long as N
C          remains unchanged.  Thus subsequent transforms can be
C          obtained faster than the first.  The same WA and IFAC arrays
C          can be used by CFFTF1 and CFFTB1.
C
C  Output Parameters
C
C  C       For J=1,...,N
C
C              C(J)=the sum from K=1,...,N of
C
C                 C(K)*EXP(I*(J-1)*(K-1)*2*PI/N)
C
C                         where I=SQRT(-1)
C
C  NOTE:   WA and IFAC contain initialization calculations which must
C          not be destroyed between calls of subroutine CFFTF1 or CFFTB1
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  PASSB, PASSB2, PASSB3, PASSB4, PASSB5
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from subsidiary to user-callable.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CFFTB1
      DIMENSION CH(*), C(*), WA(*), IFAC(*)
C***FIRST EXECUTABLE STATEMENT  CFFTB1
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL PASSB2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL PASSB2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END


! =============================================================================
!                               Parcel diagnostics
! =============================================================================
module parcel_diagnostics
    use constants, only : zero, one, f12
    use merge_sort
    use parameters, only : extent, lower, vcell, vmin, nx, nz
    use parcel_container, only : parcels, n_parcels
    use parcel_ellipse
    use omp_lib
    use timer, only : start_timer, stop_timer
    implicit none

    integer :: parcel_stats_timer

    ! peref : potential energy reference
    ! pe    : potential energy
    ! ke    : kinetic energy
    double precision :: peref, pe, ke

    integer :: n_small

    ! avg_lam : mean aspect ratio over all parcels
    ! avg_vol : mean volume over all parcels
    ! std_lam : standard deviation of aspect ratio
    ! std_vol : standard deviation of volume
    double precision :: avg_lam, avg_vol
    double precision :: std_lam, std_vol

    ! rms vorticity
    double precision :: rms_zeta

    ! min and max buoyancy
    double precision :: bmin, bmax

    ! min and max vorticity
    double precision :: vormin, vormax

#ifdef ENABLE_DIAGNOSE
    ! buoyancy weighted first and second moments
    double precision :: xb_bar, x2b_bar
    double precision :: zb_bar, z2b_bar
    double precision :: xzb_bar

    ! vorticity weighted first and second moments
    double precision :: xv_bar, x2v_bar
    double precision :: zv_bar, z2v_bar
    double precision :: xzv_bar
#endif

    contains

        ! Compute the reference potential energy
        subroutine init_parcel_diagnostics
            integer          :: ii(n_parcels), n
            double precision :: b(n_parcels)
            double precision :: gam, zmean

            call start_timer(parcel_stats_timer)

            b = parcels%buoyancy(1:n_parcels)

            ! sort buoyancy in ascending order
            call msort(b, ii)

            gam = f12 / extent(1)
            zmean = gam * parcels%volume(ii(1))

            peref = - b(1) * parcels%volume(ii(1)) * zmean
            do n = 2, n_parcels
                zmean = zmean + gam * (parcels%volume(ii(n-1)) + parcels%volume(ii(n)))

                peref = peref &
                      - b(n) * parcels%volume(ii(n)) * zmean
            enddo

            call stop_timer(parcel_stats_timer)
        end subroutine init_parcel_diagnostics

        ! Calculate all parcel related diagnostics
        subroutine calculate_parcel_diagnostics(velocity)
            double precision :: velocity(:, :)
            integer          :: n
            double precision :: b, z, vel(2), vol, zmin
            double precision :: eval, lam, B22, lsum, l2sum, vsum, v2sum

            call start_timer(parcel_stats_timer)

            ! reset
            ke = zero
            pe = zero

            ! find extrema outside OpenMP loop, we can integrate it later;
            ! this way the result is reproducible
            bmin = minval(parcels%buoyancy(1:n_parcels))
            bmax = maxval(parcels%buoyancy(1:n_parcels))
            vormin = minval(parcels%vorticity(1:n_parcels))
            vormax = maxval(parcels%vorticity(1:n_parcels))

            lsum = zero
            l2sum = zero
            vsum = zero
            v2sum = zero

            rms_zeta = zero

            n_small = zero

            zmin = lower(2)

            avg_lam = zero
            avg_vol = zero
            std_lam = zero
            std_vol = zero

            !$omp parallel default(shared)
            !$omp do private(n, vel, vol, b, z, eval, lam, B22) &
            !$omp& reduction(+: ke, pe, lsum, l2sum, vsum, v2sum, n_small, rms_zeta)
            do n = 1, n_parcels

                vel = velocity(:, n)
                vol = parcels%volume(n)
                b   = parcels%buoyancy(n)
                z   = parcels%position(2, n) - zmin

                ! kinetic energy
                ke = ke + (vel(1) ** 2 + vel(2) ** 2) * vol

                ! potential energy
                pe = pe - b * z * vol

                B22 = get_B22(parcels%B(1, n), parcels%B(2, n), vol)
                eval = get_eigenvalue(parcels%B(1, n), parcels%B(2, n), B22)
                lam = get_aspect_ratio(eval, vol)

                lsum = lsum + lam
                l2sum = l2sum + lam ** 2

                vsum = vsum + vol
                v2sum = v2sum + vol ** 2

                if (vol <= vmin) then
                    n_small = n_small + 1
                endif

                rms_zeta = rms_zeta + vol * parcels%vorticity(n) ** 2

            enddo
            !$omp end do
            !$omp end parallel

            ke = f12 * ke
            pe = pe - peref

            avg_lam = lsum / dble(n_parcels)
            std_lam = dsqrt(abs(l2sum / dble(n_parcels) - avg_lam ** 2))

            rms_zeta = dsqrt(rms_zeta / vsum)

            avg_vol = vsum / dble(n_parcels)
            std_vol = dsqrt(abs(v2sum / dble(n_parcels) - avg_vol ** 2))

#ifdef ENABLE_DIAGNOSE
            call straka_diagnostics
#endif

            call stop_timer(parcel_stats_timer)

        end subroutine calculate_parcel_diagnostics

#ifdef ENABLE_DIAGNOSE
        ! Straka density current test case diagnostics
        subroutine straka_diagnostics
            integer          :: n
            double precision :: xbv, x2bv, zbv, z2bv, xzbv
            double precision :: xvv, x2vv, zvv, z2vv, xzvv
            double precision :: bvsum, vvsum, bv, vv

            ! reset
            xb_bar = zero
            zb_bar = zero
            x2b_bar = zero
            z2b_bar = zero
            xzb_bar = zero

            xv_bar = zero
            zv_bar = zero
            x2v_bar = zero
            z2v_bar = zero
            xzv_bar = zero

            xbv = zero
            x2bv = zero
            zbv = zero
            z2bv = zero
            xzbv = zero
            xvv = zero
            x2vv = zero
            zvv = zero
            z2vv = zero
            xzvv = zero

            bvsum = zero
            vvsum = zero
            bv = zero
            vv = zero

            !$omp parallel default(shared)
            !$omp do private(n, bv, vv) &
            !$omp& reduction(+: vvsum, bvsum, xbv, zbv, x2bv, z2bv, xzbv, xvv, zvv, x2vv, z2vv, xzvv)
            do n = 1, n_parcels
                ! we only use the upper half in horizontal direction
                if (parcels%position(1, n) >= 0) then
                    bv = parcels%buoyancy(n) * parcels%volume(n)
                    bvsum = bvsum + bv
                    xbv = xbv + bv * parcels%position(1, n)
                    zbv = zbv + bv * parcels%position(2, n)

                    x2bv = x2bv + bv * parcels%position(1, n) ** 2
                    z2bv = z2bv + bv * parcels%position(2, n) ** 2
                    xzbv = xzbv + bv * parcels%position(1, n) * parcels%position(2, n)

                    vv = parcels%vorticity(n) * parcels%volume(n)
                    vvsum = vvsum + vv
                    xvv = xvv + vv * parcels%position(1, n)
                    zvv = zvv + vv * parcels%position(2, n)

                    x2vv = x2vv + vv * parcels%position(1, n) ** 2
                    z2vv = z2vv + vv * parcels%position(2, n) ** 2
                    xzvv = xzvv + vv * parcels%position(1, n) * parcels%position(2, n)
                endif
            enddo
            !$omp end do
            !$omp end parallel

            ! we do not need to divide by the number of of involved
            ! parcels since whe divide by the sums "bvsum" or "vvsum"
            ! what should also be averages (i.e. divided by the number of
            ! involved parcels)

            ! make sure we do not divide by zero
            if (dabs(bvsum) < epsilon(zero)) then
                bvsum = epsilon(zero)
            else
                bvsum = one / bvsum
            endif

            if (dabs(vvsum) < epsilon(zero)) then
                vvsum = epsilon(zero)
            else
                vvsum = one / vvsum
            endif

            xb_bar = xbv * bvsum
            zb_bar = zbv * bvsum

            x2b_bar = x2bv * bvsum
            z2b_bar = z2bv * bvsum

            xzb_bar = xzbv * bvsum - xb_bar * zb_bar

            xv_bar = xvv * vvsum
            zv_bar = zvv * vvsum

            x2v_bar = x2vv * vvsum
            z2v_bar = z2vv * vvsum

            xzv_bar = xzvv * vvsum - xv_bar * zv_bar
        end subroutine straka_diagnostics
#endif
end module parcel_diagnostics


	REAL FUNCTION SURVFUNC1(M2)
C
C  Functions
	IMPLICIT NONE
C
	REAL ZCRVALUE
C
C    Arguments
C
	REAL M2
C
C    Data passed in common to functions.
C
	REAL ALPHA,BETA,M1,A,F,N,M,ZALPHA,ZBETA
	COMMON /SURVCOM1/ ALPHA,BETA,M1,A,F,N,M
	COMMON /SURVCOM2/ ZALPHA, ZBETA
C
C    Locals
C
	REAL PA,GF,P,R,MM
C
C Code:
C
	MM=(M1+M2)/2.
	PA=(1.-EXP(-LOG(2.)*A/MM))/(LOG(2.)*A/MM)
	GF=EXP(-LOG(2.)*F/MM)
	P=1.-PA*GF
	ZALPHA=ZCRVALUE(ALPHA/2.)
	ZBETA=ZCRVALUE(BETA)
	R=M2/M1
	SURVFUNC1= ( (ZALPHA+ZBETA)**2 * ((1.+1./M)/P)/(LOG(R))**2 )-N
	RETURN
	END


*DECK DLI
      DOUBLE PRECISION FUNCTION DLI (X)
C***BEGIN PROLOGUE  DLI
C***PURPOSE  Compute the logarithmic integral.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      DOUBLE PRECISION (ALI-S, DLI-D)
C***KEYWORDS  FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DLI(X) calculates the double precision logarithmic integral
C for double precision argument X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DEI, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DLI
      DOUBLE PRECISION X, DEI
C***FIRST EXECUTABLE STATEMENT  DLI
      IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DLI',
     +   'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2)
      IF (X .EQ. 1.D0) CALL XERMSG ('SLATEC', 'DLI',
     +   'LOG INTEGRAL UNDEFINED FOR X = 0', 2, 2)
C
      DLI = DEI (LOG(X))
C
      RETURN
      END


c----------------------------------------------------------------------c
c                          S P A R S K I T                             c
c----------------------------------------------------------------------c
c          BASIC MATRIX-VECTOR OPERATIONS - MATVEC MODULE              c
c         Matrix-vector Mulitiplications and Triang. Solves            c
c----------------------------------------------------------------------c
c contents: (as of Nov 18, 1991)                                       c
c----------                                                            c
c 1) Matrix-vector products:                                           c
c---------------------------                                           c
c amux  : A times a vector. Compressed Sparse Row (CSR) format.        c
c amuxms: A times a vector. Modified Compress Sparse Row format.       c
c atmux : Transp(A) times a vector. CSR format.                        c
c atmuxr: Transp(A) times a vector. CSR format. A rectangular.         c
c amuxe : A times a vector. Ellpack/Itpack (ELL) format.               c
c amuxd : A times a vector. Diagonal (DIA) format.                     c
c amuxj : A times a vector. Jagged Diagonal (JAD) format.              c
c vbrmv : Sparse matrix-full vector product, in VBR format             c
c                                                                      c
c 2) Triangular system solutions:                                      c
c-------------------------------                                       c
c lsol  : Unit Lower Triang. solve. Compressed Sparse Row (CSR) format.c
c ldsol : Lower Triang. solve.  Modified Sparse Row (MSR) format.      c
c lsolc : Unit Lower Triang. solve. Comp. Sparse Column (CSC) format.  c
c ldsolc: Lower Triang. solve. Modified Sparse Column (MSC) format.    c
c ldsoll: Lower Triang. solve with level scheduling. MSR format.       c
c usol  : Unit Upper Triang. solve. Compressed Sparse Row (CSR) format.c
c udsol : Upper Triang. solve.  Modified Sparse Row (MSR) format.      c
c usolc : Unit Upper Triang. solve. Comp. Sparse Column (CSC) format.  c
c udsolc: Upper Triang. solve.  Modified Sparse Column (MSC) format.   c
c----------------------------------------------------------------------c
c 1)     M A T R I X    B Y    V E C T O R     P R O D U C T S         c
c----------------------------------------------------------------------c
      subroutine amux (n, x, y, a,ja,ia)
      real*8  x(*), y(*), a(*)
      integer n, ja(*), ia(*)
c-----------------------------------------------------------------------
c         A times a vector
c-----------------------------------------------------------------------
c multiplies a matrix by a vector using the dot product form
c Matrix A is stored in compressed sparse row storage.
c
c on entry:
c----------
c n     = row dimension of A
c x     = real array of length equal to the column dimension of
c         the A matrix.
c a, ja,
c    ia = input matrix in compressed sparse row format.
c
c on return:
c-----------
c y     = real array of length n, containing the product y=Ax
c
c-----------------------------------------------------------------------
c local variables
c
      real*8 t
      integer i, k
c-----------------------------------------------------------------------
      do 100 i = 1,n
c
c     compute the inner product of row i with vector x
c
         t = 0.0d0
         do 99 k=ia(i), ia(i+1)-1
            t = t + a(k)*x(ja(k))
 99      continue
c
c     store result in y(i)
c
         y(i) = t
 100  continue
c
      return
c---------end-of-amux---------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine amuxms (n, x, y, a,ja)
      real*8  x(*), y(*), a(*)
      integer n, ja(*)
c-----------------------------------------------------------------------
c         A times a vector in MSR format
c-----------------------------------------------------------------------
c multiplies a matrix by a vector using the dot product form
c Matrix A is stored in Modified Sparse Row storage.
c
c on entry:
c----------
c n     = row dimension of A
c x     = real array of length equal to the column dimension of
c         the A matrix.
c a, ja,= input matrix in modified compressed sparse row format.
c
c on return:
c-----------
c y     = real array of length n, containing the product y=Ax
c
c-----------------------------------------------------------------------
c local variables
c
      integer i, k
c-----------------------------------------------------------------------
        do 10 i=1, n
        y(i) = a(i)*x(i)
 10     continue
      do 100 i = 1,n
c
c     compute the inner product of row i with vector x
c
         do 99 k=ja(i), ja(i+1)-1
            y(i) = y(i) + a(k) *x(ja(k))
 99      continue
 100  continue
c
      return
c---------end-of-amuxm--------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine atmux (n, x, y, a, ja, ia)
      real*8 x(*), y(*), a(*)
      integer n, ia(*), ja(*)
c-----------------------------------------------------------------------
c         transp( A ) times a vector
c-----------------------------------------------------------------------
c multiplies the transpose of a matrix by a vector when the original
c matrix is stored in compressed sparse row storage. Can also be
c viewed as the product of a matrix by a vector when the original
c matrix is stored in the compressed sparse column format.
c-----------------------------------------------------------------------
c
c on entry:
c----------
c n     = row dimension of A
c x     = real array of length equal to the column dimension of
c         the A matrix.
c a, ja,
c    ia = input matrix in compressed sparse row format.
c
c on return:
c-----------
c y     = real array of length n, containing the product y=transp(A)*x
c
c-----------------------------------------------------------------------
c     local variables
c
      integer i, k
c-----------------------------------------------------------------------
c
c     zero out output vector
c
      do 1 i=1,n
         y(i) = 0.0
 1    continue
c
c loop over the rows
c
      do 100 i = 1,n
         do 99 k=ia(i), ia(i+1)-1
            y(ja(k)) = y(ja(k)) + x(i)*a(k)
 99      continue
 100  continue
c
      return
c-------------end-of-atmux----------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine atmuxr (m, n, x, y, a, ja, ia)
      real*8 x(*), y(*), a(*)
      integer m, n, ia(*), ja(*)
c-----------------------------------------------------------------------
c         transp( A ) times a vector, A can be rectangular
c-----------------------------------------------------------------------
c See also atmux.  The essential difference is how the solution vector
c is initially zeroed.  If using this to multiply rectangular CSC
c matrices by a vector, m number of rows, n is number of columns.
c-----------------------------------------------------------------------
c
c on entry:
c----------
c m     = column dimension of A
c n     = row dimension of A
c x     = real array of length equal to the column dimension of
c         the A matrix.
c a, ja,
c    ia = input matrix in compressed sparse row format.
c
c on return:
c-----------
c y     = real array of length n, containing the product y=transp(A)*x
c
c-----------------------------------------------------------------------
c     local variables
c
      integer i, k
c-----------------------------------------------------------------------
c
c     zero out output vector
c
      do 1 i=1,m
         y(i) = 0.0
 1    continue
c
c loop over the rows
c
      do 100 i = 1,n
         do 99 k=ia(i), ia(i+1)-1
            y(ja(k)) = y(ja(k)) + x(i)*a(k)
 99      continue
 100  continue
c
      return
c-------------end-of-atmuxr---------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine amuxe (n,x,y,na,ncol,a,ja)
      real*8 x(n), y(n), a(na,*)
      integer  n, na, ncol, ja(na,*)
c-----------------------------------------------------------------------
c        A times a vector in Ellpack Itpack format (ELL)
c-----------------------------------------------------------------------
c multiplies a matrix by a vector when the original matrix is stored
c in the ellpack-itpack sparse format.
c-----------------------------------------------------------------------
c
c on entry:
c----------
c n     = row dimension of A
c x     = real array of length equal to the column dimension of
c         the A matrix.
c na    = integer. The first dimension of arrays a and ja
c         as declared by the calling program.
c ncol  = integer. The number of active columns in array a.
c         (i.e., the number of generalized diagonals in matrix.)
c a, ja = the real and integer arrays of the itpack format
c         (a(i,k),k=1,ncol contains the elements of row i in matrix
c          ja(i,k),k=1,ncol contains their column numbers)
c
c on return:
c-----------
c y     = real array of length n, containing the product y=y=A*x
c
c-----------------------------------------------------------------------
c local variables
c
      integer i, j
c-----------------------------------------------------------------------
      do 1 i=1, n
         y(i) = 0.0
 1    continue
      do 10 j=1,ncol
         do 25 i = 1,n
            y(i) = y(i)+a(i,j)*x(ja(i,j))
 25      continue
 10   continue
c
      return
c--------end-of-amuxe---------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff)
      integer n, ndiag, idiag, ioff(idiag)
      real*8 x(n), y(n), diag(ndiag,idiag)
c-----------------------------------------------------------------------
c        A times a vector in Diagonal storage format (DIA)
c-----------------------------------------------------------------------
c multiplies a matrix by a vector when the original matrix is stored
c in the diagonal storage format.
c-----------------------------------------------------------------------
c
c on entry:
c----------
c n     = row dimension of A
c x     = real array of length equal to the column dimension of
c         the A matrix.
c ndiag  = integer. The first dimension of array adiag as declared in
c         the calling program.
c idiag  = integer. The number of diagonals in the matrix.
c diag   = real array containing the diagonals stored of A.
c idiag  = number of diagonals in matrix.
c diag   = real array of size (ndiag x idiag) containing the diagonals
c
c ioff   = integer array of length idiag, containing the offsets of the
c   	   diagonals of the matrix:
c          diag(i,k) contains the element a(i,i+ioff(k)) of the matrix.
c
c on return:
c-----------
c y     = real array of length n, containing the product y=A*x
c
c-----------------------------------------------------------------------
c local variables
c
      integer j, k, io, i1, i2
c-----------------------------------------------------------------------
      do 1 j=1, n
         y(j) = 0.0d0
 1    continue
      do 10 j=1, idiag
         io = ioff(j)
         i1 = max0(1,1-io)
         i2 = min0(n,n-io)
         do 9 k=i1, i2
            y(k) = y(k)+diag(k,j)*x(k+io)
 9       continue
 10   continue
c
      return
c----------end-of-amuxd-------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine amuxj (n, x, y, jdiag, a, ja, ia)
      integer n, jdiag, ja(*), ia(*)
      real*8 x(n), y(n), a(*)
c-----------------------------------------------------------------------
c        A times a vector in Jagged-Diagonal storage format (JAD)
c-----------------------------------------------------------------------
c multiplies a matrix by a vector when the original matrix is stored
c in the jagged diagonal storage format.
c-----------------------------------------------------------------------
c
c on entry:
c----------
c n      = row dimension of A
c x      = real array of length equal to the column dimension of
c         the A matrix.
c jdiag  = integer. The number of jadded-diagonals in the data-structure.
c a      = real array containing the jadded diagonals of A stored
c          in succession (in decreasing lengths)
c j      = integer array containing the colum indices of the
c          corresponding elements in a.
c ia     = integer array containing the lengths of the  jagged diagonals
c
c on return:
c-----------
c y      = real array of length n, containing the product y=A*x
c
c Note:
c-------
c Permutation related to the JAD format is not performed.
c this can be done by:
c     call permvec (n,y,y,iperm)
c after the call to amuxj, where iperm is the permutation produced
c by csrjad.
c-----------------------------------------------------------------------
c local variables
c
      integer i, ii, k1, len, j
c-----------------------------------------------------------------------
      do 1 i=1, n
         y(i) = 0.0d0
 1    continue
      do 70 ii=1, jdiag
         k1 = ia(ii)-1
         len = ia(ii+1)-k1-1
         do 60 j=1,len
            y(j)= y(j)+a(k1+j)*x(ja(k1+j))
 60      continue
 70   continue
c
      return
c----------end-of-amuxj-------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine vbrmv(nr, nc, ia, ja, ka, a, kvstr, kvstc, x, b)
c-----------------------------------------------------------------------
      integer nr, nc, ia(nr+1), ja(*), ka(*), kvstr(nr+1), kvstc(*)
      real*8  a(*), x(*), b(*)
c-----------------------------------------------------------------------
c     Sparse matrix-full vector product, in VBR format.
c-----------------------------------------------------------------------
c     On entry:
c--------------
c     nr, nc  = number of block rows and columns in matrix A
c     ia,ja,ka,a,kvstr,kvstc = matrix A in variable block row format
c     x       = multiplier vector in full format
c
c     On return:
c---------------
c     b = product of matrix A times vector x in full format
c
c     Algorithm:
c---------------
c     Perform multiplication by traversing a in order.
c
c-----------------------------------------------------------------------
c-----local variables
      integer n, i, j, ii, jj, k, istart, istop
      real*8  xjj
c---------------------------------
      n = kvstc(nc+1)-1
      do i = 1, n
         b(i) = 0.d0
      enddo
c---------------------------------
      k = 1
      do i = 1, nr
         istart = kvstr(i)
         istop  = kvstr(i+1)-1
         do j = ia(i), ia(i+1)-1
            do jj = kvstc(ja(j)), kvstc(ja(j)+1)-1
               xjj = x(jj)
               do ii = istart, istop
                  b(ii) = b(ii) + xjj*a(k)
                  k = k + 1
               enddo
            enddo
         enddo
      enddo
c---------------------------------
      return
      end
c-----------------------------------------------------------------------
c----------------------end-of-vbrmv-------------------------------------
c-----------------------------------------------------------------------
c----------------------------------------------------------------------c
c 2)     T R I A N G U L A R    S Y S T E M    S O L U T I O N S       c
c----------------------------------------------------------------------c
      subroutine lsol (n,x,y,al,jal,ial)
      integer n, jal(*),ial(n+1)
      real*8  x(n), y(n), al(*)
c-----------------------------------------------------------------------
c   solves    L x = y ; L = lower unit triang. /  CSR format
c-----------------------------------------------------------------------
c solves a unit lower triangular system by standard (sequential )
c forward elimination - matrix stored in CSR format.
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real array containg the right side.
c
c al,
c jal,
c ial,    = Lower triangular matrix stored in compressed sparse row
c          format.
c
c On return:
c-----------
c	x  = The solution of  L x  = y.
c--------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8  t
c-----------------------------------------------------------------------
      x(1) = y(1)
      do 150 k = 2, n
         t = y(k)
         do 100 j = ial(k), ial(k+1)-1
            t = t-al(j)*x(jal(j))
 100     continue
         x(k) = t
 150  continue
c
      return
c----------end-of-lsol--------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine ldsol (n,x,y,al,jal)
      integer n, jal(*)
      real*8 x(n), y(n), al(*)
c-----------------------------------------------------------------------
c     Solves L x = y    L = triangular. MSR format
c-----------------------------------------------------------------------
c solves a (non-unit) lower triangular system by standard (sequential)
c forward elimination - matrix stored in MSR format
c with diagonal elements already inverted (otherwise do inversion,
c al(1:n) = 1.0/al(1:n),  before calling ldsol).
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real array containg the right hand side.
c
c al,
c jal,   = Lower triangular matrix stored in Modified Sparse Row
c          format.
c
c On return:
c-----------
c	x = The solution of  L x = y .
c--------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8 t
c-----------------------------------------------------------------------
      x(1) = y(1)*al(1)
      do 150 k = 2, n
         t = y(k)
         do 100 j = jal(k), jal(k+1)-1
            t = t - al(j)*x(jal(j))
 100     continue
         x(k) = al(k)*t
 150  continue
      return
c----------end-of-ldsol-------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine lsolc (n,x,y,al,jal,ial)
      integer n, jal(*),ial(*)
      real*8  x(n), y(n), al(*)
c-----------------------------------------------------------------------
c       SOLVES     L x = y ;    where L = unit lower trang. CSC format
c-----------------------------------------------------------------------
c solves a unit lower triangular system by standard (sequential )
c forward elimination - matrix stored in CSC format.
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real*8 array containg the right side.
c
c al,
c jal,
c ial,    = Lower triangular matrix stored in compressed sparse column
c          format.
c
c On return:
c-----------
c	x  = The solution of  L x  = y.
c-----------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8 t
c-----------------------------------------------------------------------
      do 140 k=1,n
         x(k) = y(k)
 140  continue
      do 150 k = 1, n-1
         t = x(k)
         do 100 j = ial(k), ial(k+1)-1
            x(jal(j)) = x(jal(j)) - t*al(j)
 100     continue
 150  continue
c
      return
c----------end-of-lsolc-------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine ldsolc (n,x,y,al,jal)
      integer n, jal(*)
      real*8 x(n), y(n), al(*)
c-----------------------------------------------------------------------
c    Solves     L x = y ;    L = nonunit Low. Triang. MSC format
c-----------------------------------------------------------------------
c solves a (non-unit) lower triangular system by standard (sequential)
c forward elimination - matrix stored in Modified Sparse Column format
c with diagonal elements already inverted (otherwise do inversion,
c al(1:n) = 1.0/al(1:n),  before calling ldsol).
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real array containg the right hand side.
c
c al,
c jal,
c ial,    = Lower triangular matrix stored in Modified Sparse Column
c           format.
c
c On return:
c-----------
c	x = The solution of  L x = y .
c--------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8 t
c-----------------------------------------------------------------------
      do 140 k=1,n
         x(k) = y(k)
 140  continue
      do 150 k = 1, n
         x(k) = x(k)*al(k)
         t = x(k)
         do 100 j = jal(k), jal(k+1)-1
            x(jal(j)) = x(jal(j)) - t*al(j)
 100     continue
 150  continue
c
      return
c----------end-of-lsolc------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev)
      integer n, nlev, jal(*), ilev(nlev+1), lev(n)
      real*8 x(n), y(n), al(*)
c-----------------------------------------------------------------------
c    Solves L x = y    L = triangular. Uses LEVEL SCHEDULING/MSR format
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real array containg the right hand side.
c
c al,
c jal,   = Lower triangular matrix stored in Modified Sparse Row
c          format.
c nlev   = number of levels in matrix
c lev    = integer array of length n, containing the permutation
c          that defines the levels in the level scheduling ordering.
c ilev   = pointer to beginning of levels in lev.
c          the numbers lev(i) to lev(i+1)-1 contain the row numbers
c          that belong to level number i, in the level shcheduling
c          ordering.
c
c On return:
c-----------
c	x = The solution of  L x = y .
c--------------------------------------------------------------------
      integer ii, jrow, i
      real*8 t
c
c     outer loop goes through the levels. (SEQUENTIAL loop)
c
      do 150 ii=1, nlev
c
c     next loop executes within the same level. PARALLEL loop
c
         do 100 i=ilev(ii), ilev(ii+1)-1
            jrow = lev(i)
c
c compute inner product of row jrow with x
c
            t = y(jrow)
            do 130 k=jal(jrow), jal(jrow+1)-1
               t = t - al(k)*x(jal(k))
 130        continue
            x(jrow) = t*al(jrow)
 100     continue
 150  continue
      return
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine usol (n,x,y,au,jau,iau)
      integer n, jau(*),iau(n+1)
      real*8  x(n), y(n), au(*)
c-----------------------------------------------------------------------
c             Solves   U x = y    U = unit upper triangular.
c-----------------------------------------------------------------------
c solves a unit upper triangular system by standard (sequential )
c backward elimination - matrix stored in CSR format.
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real array containg the right side.
c
c au,
c jau,
c iau,    = Lower triangular matrix stored in compressed sparse row
c          format.
c
c On return:
c-----------
c	x = The solution of  U x = y .
c--------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8  t
c-----------------------------------------------------------------------
      x(n) = y(n)
      do 150 k = n-1,1,-1
         t = y(k)
         do 100 j = iau(k), iau(k+1)-1
            t = t - au(j)*x(jau(j))
 100     continue
         x(k) = t
 150  continue
c
      return
c----------end-of-usol--------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine udsol (n,x,y,au,jau)
      integer n, jau(*)
      real*8  x(n), y(n),au(*)
c-----------------------------------------------------------------------
c             Solves   U x = y  ;   U = upper triangular in MSR format
c-----------------------------------------------------------------------
c solves a non-unit upper triangular matrix by standard (sequential )
c backward elimination - matrix stored in MSR format.
c with diagonal elements already inverted (otherwise do inversion,
c au(1:n) = 1.0/au(1:n),  before calling).
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real array containg the right side.
c
c au,
c jau,    = Lower triangular matrix stored in modified sparse row
c          format.
c
c On return:
c-----------
c	x = The solution of  U x = y .
c--------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8 t
c-----------------------------------------------------------------------
      x(n) = y(n)*au(n)
      do 150 k = n-1,1,-1
         t = y(k)
         do 100 j = jau(k), jau(k+1)-1
            t = t - au(j)*x(jau(j))
 100     continue
         x(k) = au(k)*t
 150  continue
c
      return
c----------end-of-udsol-------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine usolc (n,x,y,au,jau,iau)
      real*8  x(*), y(*), au(*)
      integer n, jau(*),iau(*)
c-----------------------------------------------------------------------
c       SOUVES     U x = y ;    where U = unit upper trang. CSC format
c-----------------------------------------------------------------------
c solves a unit upper triangular system by standard (sequential )
c forward elimination - matrix stored in CSC format.
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real*8 array containg the right side.
c
c au,
c jau,
c iau,    = Uower triangular matrix stored in compressed sparse column
c          format.
c
c On return:
c-----------
c	x  = The solution of  U x  = y.
c-----------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8 t
c-----------------------------------------------------------------------
      do 140 k=1,n
         x(k) = y(k)
 140  continue
      do 150 k = n,1,-1
         t = x(k)
         do 100 j = iau(k), iau(k+1)-1
            x(jau(j)) = x(jau(j)) - t*au(j)
 100     continue
 150  continue
c
      return
c----------end-of-usolc-------------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine udsolc (n,x,y,au,jau)
      integer n, jau(*)
      real*8 x(n), y(n), au(*)
c-----------------------------------------------------------------------
c    Solves     U x = y ;    U = nonunit Up. Triang. MSC format
c-----------------------------------------------------------------------
c solves a (non-unit) upper triangular system by standard (sequential)
c forward elimination - matrix stored in Modified Sparse Column format
c with diagonal elements already inverted (otherwise do inversion,
c auuuul(1:n) = 1.0/au(1:n),  before calling ldsol).
c-----------------------------------------------------------------------
c
c On entry:
c----------
c n      = integer. dimension of problem.
c y      = real*8 array containg the right hand side.
c
c au,
c jau,   = Upper triangular matrix stored in Modified Sparse Column
c          format.
c
c On return:
c-----------
c	x = The solution of  U x = y .
c--------------------------------------------------------------------
c local variables
c
      integer k, j
      real*8 t
c-----------------------------------------------------------------------
      do 140 k=1,n
         x(k) = y(k)
 140  continue
      do 150 k = n,1,-1
         x(k) = x(k)*au(k)
         t = x(k)
         do 100 j = jau(k), jau(k+1)-1
            x(jau(j)) = x(jau(j)) - t*au(j)
 100     continue
 150  continue
c
      return
c----------end-of-udsolc------------------------------------------------
c-----------------------------------------------------------------------
      end


      SUBROUTINE foo(N,C)
      INTEGER N
      REAL*8  C(N,N)
      REAL*8  X(-1:4,-1:6), B(-1:4,-1:6)

      INTEGER I,J,K

C     Loop #0
      DO 10,I=1,N
         DO 20,J=I,N
            C(I,J) = 1.0D0
 20      CONTINUE
 10   CONTINUE

C     Loop #1
      DO 30,I=0,4
         DO 40,J=0,6
            X(I,J) = 2 * X(I-1,J)
            B(I,J) = B(I,J-1) + X(I,J)
 40      CONTINUE
 30   CONTINUE

C     Loop #2
      DO 50,I=1,N
         DO 60,J=1,N
            DO 70,K=1,N
               C(I,J) = C(I,J)+1.0D0
 70         CONTINUE
 60      CONTINUE
 50   CONTINUE

C     Loop #3
      DO 80,I=1,3
         DO 90,J=1,3
            C(4*J-2*I+3,I+J) = 1.0D0
 90      CONTINUE
 80   CONTINUE

      END


	SUBROUTINE CSMTHN  ( nsmoth, npts, xpt, ypt, iret )
C************************************************************************
C* CSMTHN								*
C*									*
C* This subroutine applies a 3-point smoothing to the buffered contour	*
C* line.  The smoothing is performed NSMOTH times.			*
C*									*
C* CSMTHN  ( NSMOTH, NPTS, XPT, YPT, IRET )				*
C*									*
C* Input parameters:							*
C*	NSMOTH		INTEGER		Number of smoothing passes	*
C*	NPTS		INTEGER		Number of points		*
C*									*
C* Input and output parameters:						*
C*	XPT (NPTS)	REAL		X grid points			*
C*	YPT (NPTS)	REAL		Y grid points			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/NMC	11/91	From old CSMOTH				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'CONTUR.CMN'
C*
	REAL		xpt (*), ypt (*)
C------------------------------------------------------------------------
	iret = 0
C
C*	Check that there are at least two points.
C
	IF  ( npts .lt. 2 )  RETURN
C
C*	Loop through the points NSMOTH times.
C
	DO  ii = 1, nsmoth
	  xim1 = xpt (1)
	  yim1 = ypt (1)
	  DO  i = 2, npts - 1
	    xi = xpt (i)
	    yi = ypt (i)
	    xpt (i) = ( xim1 + xpt (i+1) + xi + xi ) / 4.
	    ypt (i) = ( yim1 + ypt (i+1) + yi + yi ) / 4.
	    xim1 = xi
	    yim1 = yi
	  END DO
	END DO
C*
	RETURN
	END


!==============================================================================!
  subroutine Surf_Mod_Smooth(surf, phi, phi_e)
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Surf_Type), target :: surf
  type(Var_Type),  target :: phi
  real                    :: phi_e
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type), pointer :: grid
  type(Vert_Type), pointer :: vert(:)
  type(Elem_Type), pointer :: elem(:)
  type(Side_Type), pointer :: side(:)
  integer                  :: it_smooth, s, v, e, c
  integer                  :: n_verts_in_buffers
  integer,         pointer :: nv, ne, ns
  real                     :: xc, yc, zc
  real                     :: nx, ny, nz, phi_m, dx, dy, dz, dm
  real                     :: phi_v
!==============================================================================!

  ! Take aliases
  nv   => surf % n_verts
  ne   => surf % n_elems
  ns   => surf % n_sides
  vert => surf % vert
  elem => surf % elem
  side => surf % side
  grid => surf % pnt_grid

  !---------------------------------------------------------!
  !   Count number of neighbouring elements for each node   !
  !---------------------------------------------------------!
  vert(1:nv) % nne = 0
  do e = 1, ne
    vert(elem(e) % i) % nne = vert(elem(e) % i) % nne + 1
    vert(elem(e) % j) % nne = vert(elem(e) % j) % nne + 1
    vert(elem(e) % k) % nne = vert(elem(e) % k) % nne + 1
  end do

  call Surf_Mod_Find_Boundaries(surf)

  !---------------------------------------------------------------!
  !   Initialize sums of x, y and z coordinates for each vertex   !
  !---------------------------------------------------------------!
  vert(1:nv) % sumx = 0.0
  vert(1:nv) % sumy = 0.0
  vert(1:nv) % sumz = 0.0

  !-------------------------------------!
  !   Go through smoothing iterations   !
  !-------------------------------------!
  do it_smooth = 1, 3

    ! Compute sums of all coordinates for nodes
    do s = 1, ns
      vert(side(s) % c) % sumx =  &
      vert(side(s) % c) % sumx + vert(side(s) % d) % x_n
      vert(side(s) % c) % sumy =  &
      vert(side(s) % c) % sumy + vert(side(s) % d) % y_n
      vert(side(s) % c) % sumz =  &
      vert(side(s) % c) % sumz + vert(side(s) % d) % z_n

      vert(side(s) % d) % sumx =  &
      vert(side(s) % d) % sumx + vert(side(s) % c) % x_n
      vert(side(s) % d) % sumy =  &
      vert(side(s) % d) % sumy + vert(side(s) % c) % y_n
      vert(side(s) % d) % sumz =  &
      vert(side(s) % d) % sumz + vert(side(s) % c) % z_n
    end do

    ! Move the vertices to their new positions
    do v = 1, nv

      ! This is how I check if vertex is on a boundary.  Maybe there
      ! is a more spothisticated way to do it, but this works so far
      if( .not. vert(v) % boundary ) then
        vert(v) % x_n = vert(v) % sumx / vert(v) % nne
        vert(v) % y_n = vert(v) % sumy / vert(v) % nne
        vert(v) % z_n = vert(v) % sumz / vert(v) % nne
        call Surf_Mod_Find_Nearest_Cell(surf, v, n_verts_in_buffers)
        call Surf_Mod_Find_Nearest_Node(surf, v)
      end if

    end do

    ! Re-initalize the sums
    vert(1:nv) % sumx = 0.0
    vert(1:nv) % sumy = 0.0
    vert(1:nv) % sumz = 0.0

    ! Correct vertex position
    do v = 1, nv

      ! This is how I check if vertex is on a boundary.  Maybe there
      ! is a more spothisticated way to do it, but this works so far
      if( .not. vert(v) % boundary ) then

        c = vert(v) % cell

        ! Cell coordinates
        xc = grid % xc(c)
        yc = grid % yc(c)
        zc = grid % zc(c)

        ! Surface normal
        phi_m = sqrt(phi % x(c)**2 + phi % y(c)**2 + phi % z(c)**2)
        nx = phi % x(c) / phi_m
        ny = phi % y(c) / phi_m
        nz = phi % z(c) / phi_m

        ! Value at current vertex position
        dx = vert(v) % x_n - xc
        dy = vert(v) % y_n - yc
        dz = vert(v) % z_n - zc
        phi_v = phi % n(c) + dx * phi % x(c)  &
                           + dy * phi % y(c)  &
                           + dz * phi % z(c)

        dm = (phi_e - phi_v) / (phi % x(c)*nx + phi % y(c)*ny + phi % z(c)*nz)

        dx = dm * nx
        dy = dm * ny
        dz = dm * nz

        ! Move vertex in the surface normal direction
        vert(v) % x_n = vert(v) % x_n + dx
        vert(v) % y_n = vert(v) % y_n + dy
        vert(v) % z_n = vert(v) % z_n + dz

        dx = vert(v) % x_n - xc
        dy = vert(v) % y_n - yc
        dz = vert(v) % z_n - zc
        phi_v = phi % n(c) + dx * phi % x(c)  &
                           + dy * phi % y(c)  &
                           + dz * phi % z(c)

        call Surf_Mod_Find_Nearest_Cell(surf, v, n_verts_in_buffers)
        call Surf_Mod_Find_Nearest_Node(surf, v)

      end if  ! if vertex is on a boundary

    end do

  end do  ! smoothing iterations

  end subroutine


PROGRAM test_quadf
!
!  Purpose:
!    Program to test function quadf.
!
IMPLICIT NONE

! Data dictionary: declare variable types & definitions
REAL :: quadf                   ! Declare function
REAL :: a, b, c, x              ! Declare local variables

! Get input data.
WRITE (*,*) 'Enter quadratic coefficients a, b, and c: '
READ  (*,*) a, b, c
WRITE (*,*) 'Enter location at which to evaluate equation: '
READ  (*,*) x

! Write out result.
WRITE (*,100) ' quadf(', x, ') = ', quadf(x,a,b,c)
100 FORMAT (A,F10.4,A,F12.4)

END PROGRAM test_quadf


module blas_s2
  use blas_kinds, only : ik, sp
  implicit none
  private :: ik, sp

  interface
    subroutine sgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: trans
      integer(ik) :: m
      integer(ik) :: n
      integer(ik) :: kl
      integer(ik) :: ku
      real(sp) :: alpha
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: beta
      real(sp) :: y(*)
      integer(ik) :: incy
    end subroutine sgbmv
  end interface
  interface
    subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: trans
      integer(ik) :: m
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: beta
      real(sp) :: y(*)
      integer(ik) :: incy
    end subroutine sgemv
  end interface
  interface
    subroutine sger(m, n, alpha, x, incx, y, incy, a, lda)
      import :: ik, sp
      integer(ik) :: lda
      integer(ik) :: m
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: y(*)
      integer(ik) :: incy
      real(sp) :: a(lda, *)
    end subroutine sger
  end interface
  interface
    subroutine ssbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      integer(ik) :: k
      real(sp) :: alpha
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: beta
      real(sp) :: y(*)
      integer(ik) :: incy
    end subroutine ssbmv
  end interface
  interface
    subroutine sspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
      import :: ik, sp
      character(len=1) :: uplo
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: ap(*)
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: beta
      real(sp) :: y(*)
      integer(ik) :: incy
    end subroutine sspmv
  end interface
  interface
    subroutine sspr2(uplo, n, alpha, x, incx, y, incy, ap)
      import :: ik, sp
      character(len=1) :: uplo
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: y(*)
      integer(ik) :: incy
      real(sp) :: ap(*)
    end subroutine sspr2
  end interface
  interface
    subroutine sspr(uplo, n, alpha, x, incx, ap)
      import :: ik, sp
      character(len=1) :: uplo
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: ap(*)
    end subroutine sspr
  end interface
  interface
    subroutine ssymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: beta
      real(sp) :: y(*)
      integer(ik) :: incy
    end subroutine ssymv
  end interface
  interface
    subroutine ssyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: y(*)
      integer(ik) :: incy
      real(sp) :: a(lda, *)
    end subroutine ssyr2
  end interface
  interface
    subroutine ssyr(uplo, n, alpha, x, incx, a, lda)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: x(*)
      integer(ik) :: incx
      real(sp) :: a(lda, *)
    end subroutine ssyr
  end interface
  interface
    subroutine stbmv(uplo, trans, diag, n, k, a, lda, x, incx)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      integer(ik) :: k
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
    end subroutine stbmv
  end interface
  interface
    subroutine stbsv(uplo, trans, diag, n, k, a, lda, x, incx)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      integer(ik) :: k
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
    end subroutine stbsv
  end interface
  interface
    subroutine stpmv(uplo, trans, diag, n, ap, x, incx)
      import :: ik, sp
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(sp) :: ap(*)
      real(sp) :: x(*)
      integer(ik) :: incx
    end subroutine stpmv
  end interface
  interface
    subroutine stpsv(uplo, trans, diag, n, ap, x, incx)
      import :: ik, sp
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(sp) :: ap(*)
      real(sp) :: x(*)
      integer(ik) :: incx
    end subroutine stpsv
  end interface
  interface
    subroutine strmv(uplo, trans, diag, n, a, lda, x, incx)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
    end subroutine strmv
  end interface
  interface
    subroutine strsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, sp
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      character(len=1) :: transa
      character(len=1) :: diag
      integer(ik) :: m
      integer(ik) :: n
      real(sp) :: alpha
      real(sp) :: a(lda, *)
      real(sp) :: b(ldb, *)
    end subroutine strsm
  end interface
  interface
    subroutine strsv(uplo, trans, diag, n, a, lda, x, incx)
      import :: ik, sp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(sp) :: a(lda, *)
      real(sp) :: x(*)
      integer(ik) :: incx
    end subroutine strsv
  end interface

end module blas_s2


MODULE FluidFieldsUtilitiesModule

  USE KindModule, ONLY: &
    DP
  USE ProgramHeaderModule, ONLY: &
    nDOFX

  IMPLICIT NONE
  PRIVATE

CONTAINS

  PURE REAL(DP) FUNCTION CellAverage( uF, VJ )

    REAL(DP), DIMENSION(1:nDOFX), INTENT(in) :: uF, VJ

!!$    CellAverage &
!!$      = DOT_PRODUCT( WeightsF, uF * VJ ) &
!!$        / DOT_PRODUCT( WeightsF, VJ )

    RETURN
  END FUNCTION CellAverage

END MODULE FluidFieldsUtilitiesModule


C-------------------------------------------------------------------------
C-
C       --
C-   INSTITUT  DE RECHERCHE EN INFORMATIQUE DE TOULOUSE (I.R.I.T.)      --
C-       LABORATOIRE D'INFORMATIQUE et MATHEMATIQUE APPLIQUEE
C-                DE L'E.N.S.E.E.I.H.T.
C               --
C-
C-                   P.Amestoy, M. Dayde
CC      --
C-------------------------------------------------------------------------
************************************************************************
C Esclave associe au calcul du produit matrice-vecteur dynamique
C --------------------------------------------------------------
      program esclav
      implicit none
* -------------------
* static parameters
* -------------------
      integer NMAX
      parameter (NMAX=20000)
      double precision one, zero
      parameter ( one = 1.0D0, zero = 0.0D0)
* --------------------------
* matrix-vector related data
*     a matrix m*n
*     x vector of size n
*     y vector of size m
* --------------------------
      DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: a
      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE   :: x, y
      integer n,m,i,j
      logical fini
* --------------
* pvm variables
* --------------
      integer my_id, info, IERR

      include 'fpvm3.h'
*
* ----------------------------------
* variables used for message passing
* ----------------------------------
* no_slave Logical number of slave
*          It is received and then send back to the master
*          The master need it to know
*          which part of the solution is computed
* bufidS buffer for sending data
* bufidR buffer for receiving data
* type = 0 to reveive data broadcasted by the master
*      = 1 to reveive local data from the master
*      = 2 to send results to the master
      integer no_slave, p_id, bufidS, bufidR,type
*
*
* ---------------------------
* Enroll this program in PVM_3
* Get the tid of the master's task id
* ---------------------------
      call pvmfmytid(my_id)
      call pvmfparent(p_id)
      if (p_id.le.0) stop
*
* ------------------------
* Receive broadcasted data
* ------------------------
*
* ------------------------------------------------------------
* Receive size of the block of row followed by sub-matrix
* ------------------------------------------------------------
      type = 1
      call pvmfrecv(p_id, type, bufidR)
      call pvmfunpack(INTEGER4, no_slave, 1, 1, info)
      call pvmfunpack(INTEGER4, m, 1, 1, info)
      call pvmfunpack(INTEGER4, n, 1, 1, info)
      call pvmfunpack(BYTE1, fini, 1, 1, info)
        write(6,*) ' slave: ',no_slave,' tid: ',my_id, ' m= ',m
        ALLOCATE( A(m,n), y(m), stat=IERR)
        IF (IERR .GT. 0 ) THEN
          WRITE(6,*) " Error in memory allocation of size ",m*n+n
          GOTO 1000  ! quit PVM and return
        ENDIF

      do i=1,n
        call pvmfunpack(REAL8, a(1,i), m, 1, info)
      enddo

      write(6,*) ' slave: ',my_id, ' end reception submatrix'
C       Allocate all Matrices and vectors of size n
        ALLOCATE( x(n), stat=IERR)
*
      fini = .false.
      DO WHILE(.not.fini)

      write(6,*) ' slave: ',my_id,' starts receiving'

      type = 0
      call pvmfrecv(p_id, type, bufidR)
      call pvmfunpack(INTEGER4, n, 1, 1, info)

        write(6,*) ' slave: ',my_id, ' n= ',n

        IF (IERR .GT. 0 ) THEN
          WRITE(6,*) " Error in memory allocation of size ", n,
     &               " reduce value of N =", n
          GOTO 1000  ! quit PVM and return
        ENDIF

      call pvmfunpack(REAL8   , x, n, 1, info)

* ---------------------------
* compute his part of work
* --------------------------

      write(6,*) ' slave: ', my_id,' starts computation '

      do i=1,m
       y(i) = zero
       do j=1,n
        y(i) = y(i) + a(i,j)*x(j)
       enddo
      enddo
*
* --------------------------------------
* send back task_id and results to master
* --------------------------------------

      write(6,*) ' slave: ', no_slave, ' tid: ',my_id,
     *           ' sends results '

      call pvmfinitsend(PVMDATADEFAULT, bufidS)
      call pvmfpack(INTEGER4, no_slave, 1, 1, info)
      call pvmfpack(REAL8, y, m, 1, info)
      type = 2
      call pvmfsend(p_id, type, info)

      ENDDO

*
* ------------------------
* leave Pvm before exiting
* ------------------------

 1000 write(6,*) ' slave: ', my_id, ' leaves PVM '
*     -- free memory associated to a and y
      IF (ALLOCATED(a)) DEALLOCATE(a)
      IF (ALLOCATED(y)) DEALLOCATE(y)

      IF (ALLOCATED(x)) DEALLOCATE(x)
      call pvmfexit(info)
*
      stop
      end


*> \brief \b CLAPTM
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CLAPTM( UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B,
*                          LDB )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            LDB, LDX, N, NRHS
*       REAL               ALPHA, BETA
*       ..
*       .. Array Arguments ..
*       REAL               D( * )
*       COMPLEX            B( LDB, * ), E( * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CLAPTM multiplies an N by NRHS matrix X by a Hermitian tridiagonal
*> matrix A and stores the result in a matrix B.  The operation has the
*> form
*>
*>    B := alpha * A * X + beta * B
*>
*> where alpha may be either 1. or -1. and beta may be 0., 1., or -1.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER
*>          Specifies whether the superdiagonal or the subdiagonal of the
*>          tridiagonal matrix A is stored.
*>          = 'U':  Upper, E is the superdiagonal of A.
*>          = 'L':  Lower, E is the subdiagonal of A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrices X and B.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is REAL
*>          The scalar alpha.  ALPHA must be 1. or -1.; otherwise,
*>          it is assumed to be 0.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The n diagonal elements of the tridiagonal matrix A.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is COMPLEX array, dimension (N-1)
*>          The (n-1) subdiagonal or superdiagonal elements of A.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is COMPLEX array, dimension (LDX,NRHS)
*>          The N by NRHS matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(N,1).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is REAL
*>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
*>          it is assumed to be 1.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB,NRHS)
*>          On entry, the N by NRHS matrix B.
*>          On exit, B is overwritten by the matrix expression
*>          B := alpha * A * X + beta * B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(N,1).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_lin
*
*  =====================================================================
      SUBROUTINE CLAPTM( UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B,
     $                   LDB )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDB, LDX, N, NRHS
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      REAL               D( * )
      COMPLEX            B( LDB, * ), E( * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG
*     ..
*     .. Executable Statements ..
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( BETA.EQ.ZERO ) THEN
         DO 20 J = 1, NRHS
            DO 10 I = 1, N
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE IF( BETA.EQ.-ONE ) THEN
         DO 40 J = 1, NRHS
            DO 30 I = 1, N
               B( I, J ) = -B( I, J )
   30       CONTINUE
   40    CONTINUE
      END IF
*
      IF( ALPHA.EQ.ONE ) THEN
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           Compute B := B + A*X, where E is the superdiagonal of A.
*
            DO 60 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
     $                        E( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) + CONJG( E( N-1 ) )*
     $                        X( N-1, J ) + D( N )*X( N, J )
                  DO 50 I = 2, N - 1
                     B( I, J ) = B( I, J ) + CONJG( E( I-1 ) )*
     $                           X( I-1, J ) + D( I )*X( I, J ) +
     $                           E( I )*X( I+1, J )
   50             CONTINUE
               END IF
   60       CONTINUE
         ELSE
*
*           Compute B := B + A*X, where E is the subdiagonal of A.
*
            DO 80 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
     $                        CONJG( E( 1 ) )*X( 2, J )
                  B( N, J ) = B( N, J ) + E( N-1 )*X( N-1, J ) +
     $                        D( N )*X( N, J )
                  DO 70 I = 2, N - 1
                     B( I, J ) = B( I, J ) + E( I-1 )*X( I-1, J ) +
     $                           D( I )*X( I, J ) +
     $                           CONJG( E( I ) )*X( I+1, J )
   70             CONTINUE
               END IF
   80       CONTINUE
         END IF
      ELSE IF( ALPHA.EQ.-ONE ) THEN
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           Compute B := B - A*X, where E is the superdiagonal of A.
*
            DO 100 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
     $                        E( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) - CONJG( E( N-1 ) )*
     $                        X( N-1, J ) - D( N )*X( N, J )
                  DO 90 I = 2, N - 1
                     B( I, J ) = B( I, J ) - CONJG( E( I-1 ) )*
     $                           X( I-1, J ) - D( I )*X( I, J ) -
     $                           E( I )*X( I+1, J )
   90             CONTINUE
               END IF
  100       CONTINUE
         ELSE
*
*           Compute B := B - A*X, where E is the subdiagonal of A.
*
            DO 120 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
     $                        CONJG( E( 1 ) )*X( 2, J )
                  B( N, J ) = B( N, J ) - E( N-1 )*X( N-1, J ) -
     $                        D( N )*X( N, J )
                  DO 110 I = 2, N - 1
                     B( I, J ) = B( I, J ) - E( I-1 )*X( I-1, J ) -
     $                           D( I )*X( I, J ) -
     $                           CONJG( E( I ) )*X( I+1, J )
  110             CONTINUE
               END IF
  120       CONTINUE
         END IF
      END IF
      RETURN
*
*     End of CLAPTM
*
      END


!======================================================================!
  SUBROUTINE Resid(N, NB, NONZ, A, Acol,Arow,Ab,x,r1)
!----------------------------------------------------------------------!
!   Calculates residuals.                                              !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  USE par_mod
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  INTEGER  :: N, NB, NONZ

  REAL     :: A(NONZ),Ab(-NB:-1)
  INTEGER  :: Acol(N+1)
  INTEGER  :: Arow(NONZ)
  REAL     :: x(-NB:N), r1(N)             !  [A]{x}={r1}
!-------------------------------[Locals]-------------------------------!
  INTEGER  :: i,j,k,sub
!--------------------------------[CVS]---------------------------------!
!  $Id: Resid.f90,v 1.8 2008/12/10 14:52:43 IUS\mhadziabdic Exp $
!  $Source: /home/IUS/mhadziabdic/.CVSROOT/T-Rex/Process/Resid.f90,v $
!======================================================================!

!+++++++++++++++++++++++++!
!     r = b - Ax          !
!     => Parallelized     !
!+++++++++++++++++++++++++!

  do i=1,N
    do j=Acol(i),Acol(i+1)-1
      k = Arow(j)
      r1(i) = r1(i) - A(j) * x(k)
    end do
  end do
!      call exchange(x)
  do sub=1,Npro
    if(NBBe(sub)  <=  NBBs(sub)) then
      do k=NBBs(sub),NBBe(sub),-1
        i=BufInd(k)
        r1(i) = r1(i) - Ab(k)*x(k)
      end do
    end if
  end do

  END SUBROUTINE Resid


      PROGRAM xcovsrt
C     driver for routine covsrt
      INTEGER MA,MFIT
      PARAMETER(MA=10,MFIT=5)
      INTEGER i,j,ia(MA)
      REAL covar(MA,MA)
      do 12 i=1,MA
        do 11 j=1,MA
          covar(i,j)=0.0
          if (i.le.MFIT .and. j.le.MFIT) then
            covar(i,j)=i+j-1
          endif
11      continue
12    continue
      write(*,'(//2x,a)') 'Original matrix'
      do 13 i=1,MA
        write(*,'(1x,10f4.1)') (covar(i,j),j=1,MA)
13    continue
      write(*,*) ' press RETURN to continue...'
      read(*,*)
      write(*,'(/2x,a)') 'Test #1 - Full Fitting'
      do 14 i=1,MA
        ia(i)=1
14    continue
      call covsrt(covar,MA,MA,ia,MA)
      do 15 i=1,MA
        write(*,'(1x,10f4.1)') (covar(i,j),j=1,MA)
15    continue
      write(*,*) ' press RETURN to continue...'
      read(*,*)
      write(*,'(/2x,a)') 'Test #2 - Spread'
      do 17 i=1,MA
        do 16 j=1,MA
          covar(i,j)=0.0
          if (i.le.MFIT .and. j.le.MFIT) then
            covar(i,j)=i+j-1
          endif
16      continue
17    continue
      do 18 i=1,MA,2
        ia(i)=0
18    continue
      call covsrt(covar,MA,MA,ia,MFIT)
      do 19 i=1,MA
        write(*,'(1x,10f4.1)') (covar(i,j),j=1,MA)
19    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xcovsrt.for