      FUNCTION fmin (ax, bx, f, tol)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec) ax, bx, f, tol
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec),PARAMETER :: zero = 0,one = 1, two = 2,
     1   three = 3, five = 5, p5 = 0.5_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      REAL(rprec):: a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,
     1   u,v,w,fu,fv,fw,fx,x,fmin
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL f
C-----------------------------------------------
c
c  c is the squared inverse of the golden ratio
c
      c = p5*(three - SQRT(five))
c
c  eps is approximately the square root of the relative machine
c  precision.
c
      eps = one
      eps = eps/two
      tol1 = one + eps
 1003 CONTINUE
      IF (tol1 .le. one) GOTO 1002
      eps = eps/two
      tol1 = one + eps
      IF (tol1 .le. one) GOTO 1002
      eps = eps/two
      tol1 = one + eps
      IF (tol1 .le. one) GOTO 1002
      eps = eps/two
      tol1 = one + eps
      IF (tol1 .le. one) GOTO 1002
      eps = eps/two
      tol1 = one + eps
      GOTO 1003
 1002 CONTINUE
      eps = SQRT(eps)
c
c  initialization
c
      a = ax
      b = bx
      v = a + c*(b - a)
      w = v
      x = v
      e = zero
      fx = f(x)
      fv = fx
      fw = fx
c
c  main loop starts here
c
   20 CONTINUE
      xm = p5*(a + b)
      tol1 = eps*ABS(x) + tol/three
      tol2 = two*tol1
c
c  check STOPping criterion
c
      IF (ABS(x - xm) .le. tol2 - p5*(b - a)) GOTO 90
c
c is golden-section necessary
c
      IF (ABS(e) .le. tol1) GOTO 40
c
c  fit parabola
c
      r = (x - w)*(fx - fv)
      q = (x - v)*(fx - fw)
      p = (x - v)*q - (x - w)*r
      q = two*(q - r)
      IF (q .gt. zero) p = -p
      q = ABS(q)
      r = e
      e = d
c
c  is parabola acceptable
c
      IF (ABS(p) .ge. ABS(p5*q*r)) GOTO 40
      IF (p .le. q*(a - x)) GOTO 40
      IF (p .ge. q*(b - x)) GOTO 40
c
c  a parabolic interpolation step
c
      IF( q.ne.zero )d = p/q
      u = x + d
c
c  f must not be evaluated too CLOSE to ax or bx
c
      IF (u - a < tol2) d = SIGN(tol1,xm - x)
      IF (b - u < tol2) d = SIGN(tol1,xm - x)
      GOTO 50
c
c  a golden-section step
c
   40 CONTINUE
      IF (x .ge. xm) THEN
         e = a - x
      ELSE
         e = b - x
      END IF
      d = c*e
c
c  f must not be evaluated too CLOSE to x
c
   50 CONTINUE
      IF (ABS(d) .ge. tol1) THEN
         u = x + d
      ELSE
         u = x + SIGN(tol1,d)
      END IF
      fu = f(u)
c
c  update  a, b, v, w, and x
c
      IF (fu .gt. fx) GOTO 60
      IF (u .ge. x) THEN
         a = x
      ELSE
         b = x
      END IF
      v = w
      fv = fw
      w = x
      fw = fx
      x = u
      fx = fu
      GOTO 20
   60 CONTINUE
      IF (u .lt. x) THEN
         a = u
      ELSE
         b = u
      END IF
      IF (fu .le. fw) GOTO 70
      IF (w .eq. x) GOTO 70
      IF (fu .le. fv) GOTO 80
      IF (v .eq. x) GOTO 80
      IF (v .eq. w) GOTO 80
      GOTO 20
   70 CONTINUE
      v = w
      fv = fw
      w = u
      fw = fu
      GOTO 20
   80 CONTINUE
      v = u
      fv = fu
      GOTO 20
c
c  END of main loop
c
   90 CONTINUE
      fmin = x

      END FUNCTION fmin


      SUBROUTINE SETEXP(S,DS1,SMAX,NN)
C........................................................
C     Sets geometrically stretched array S:
C
C       S(i+1) - S(i)  =  r * [S(i) - S(i-1)]
C
C       S     (output)  array to be set
C       DS1   (input)   first S increment:  S(2) - S(1)
C       SMAX  (input)   final S value:      S(NN)
C       NN    (input)   number of points
C........................................................
      REAL S(NN)
C
      SIGMA = SMAX/DS1
      NEX = NN-1
      RNEX = FLOAT(NEX)
      RNI = 1.0/RNEX
C
C---- solve quadratic for initial geometric ratio guess
      AAA = RNEX*(RNEX-1.0)*(RNEX-2.0) / 6.0
      BBB = RNEX*(RNEX-1.0) / 2.0
      CCC = RNEX - SIGMA
C
      DISC = BBB**2 - 4.0*AAA*CCC
      DISC = MAX( 0.0 , DISC )
C
      IF(NEX.LE.1) THEN
       STOP 'SETEXP: Cannot fill array.  N too small.'
      ELSE IF(NEX.EQ.2) THEN
       RATIO = -CCC/BBB  +  1.0
      ELSE
       RATIO = (-BBB + SQRT(DISC))/(2.0*AAA)  +  1.0
      ENDIF
C
      IF(RATIO.EQ.1.0) GO TO 11
C
C---- Newton iteration for actual geometric ratio
      DO 1 ITER=1, 100
        SIGMAN = (RATIO**NEX - 1.0) / (RATIO - 1.0)
        RES = SIGMAN**RNI - SIGMA**RNI
        DRESDR = RNI*SIGMAN**RNI
     &         * (RNEX*RATIO**(NEX-1) - SIGMAN) / (RATIO**NEX - 1.0)
C
        DRATIO = -RES/DRESDR
        RATIO = RATIO + DRATIO
C
        IF(ABS(DRATIO) .LT. 1.0E-5) GO TO 11
C
    1 CONTINUE
      WRITE(*,*) 'SETEXP: Convergence failed.  Continuing anyway ...'
C
C---- set up stretched array using converged geometric ratio
   11 S(1) = 0.0
      DS = DS1
      DO 2 N=2, NN
        S(N) = S(N-1) + DS
        DS = DS*RATIO
    2 CONTINUE
C
      RETURN
      END

      FUNCTION ATANC(Y,X,THOLD)
      IMPLICIT REAL (A-H,M,O-Z)
C---------------------------------------------------------------
C     ATAN2 function with branch cut checking.
C
C     Increments position angle of point X,Y from some previous
C     value THOLD due to a change in position, ensuring that the
C     position change does not cross the ATAN2 branch cut
C     (which is in the -x direction).  For example:
C
C       ATANC( -1.0 , -1.0 , 0.75*pi )  returns  1.25*pi , whereas
C       ATAN2( -1.0 , -1.0 )            returns  -.75*pi .
C
C     Typically, ATANC is used to fill an array of angles:
C
C        THETA(1) = ATAN2( Y(1) , X(1) )
C        DO i=2, N
C          THETA(i) = ATANC( Y(i) , X(i) , THETA(i-1) )
C        END DO
C
C     This will prevent the angle array THETA(i) from jumping by
C     +/- 2 pi when the path X(i),Y(i) crosses the negative x axis.
C
C     Input:
C       X,Y     point position coordinates
C       THOLD   position angle of nearby point
C
C     Output:
C       ATANC   position angle of X,Y
C---------------------------------------------------------------
      DATA  PI /3.1415926535897932384/
      DATA TPI /6.2831853071795864769/
C
C---- set new position angle, ignoring branch cut in ATAN2 function for now
      THNEW = ATAN2( Y , X )
      DTHET = THNEW - THOLD
C
C---- angle change cannot exceed +/- pi, so get rid of any multiples of 2 pi
      DTCORR = DTHET - TPI*INT( (DTHET + SIGN(PI,DTHET))/TPI )
C
C---- set correct new angle
      ATANC = THOLD + DTCORR
C
      RETURN
      END ! ATANC


subroutine add(a, b, c)
real, intent(in) :: a, b
real, intent(out) :: c
c = a + b
end subroutine


!===============================================================================
program test_sphere_sample
!===============================================================================
!  Ensure the sphere_sample subroutine works as expected

   use spherical_geometry

   implicit none

   real(8),allocatable, dimension(:) :: lat,lon
   integer :: n  ! Number of points
   integer :: i
   real(8) :: d  ! Distance between points

   d = 15._8

   call sphere_sample(d,lon,lat,n)

   do i=1,n
      write(*,'(i4.4,x,2f6.1)') i,lon(i),lat(i)
   enddo

end program test_sphere_sample
!-------------------------------------------------------------------------------


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of SPREAD
module m1
  logical, parameter :: test_empty = size(spread(1, 1, 0)) == 0
  logical, parameter :: test_stov = all(spread(1, 1, 2) == [1, 1])
  logical, parameter :: test_vtom1 = all(spread([1, 2], 1, 3) == reshape([1, 1, 1, 2, 2, 2], [3, 2]))
  logical, parameter :: test_vtom2 = all(spread([1, 2], 2, 3) == reshape([1, 2, 1, 2, 1, 2], [2, 3]))
  logical, parameter :: test_vtom3 = all(spread([1, 2], 2, 3) == reshape([1, 2, 1, 2, 1, 2], [2, 3]))
  logical, parameter :: test_log1 = all(all(spread([.false., .true.], 1, 2), dim=2) .eqv. [.false., .false.])
  logical, parameter :: test_log2 = all(all(spread([.false., .true.], 2, 2), dim=2) .eqv. [.false., .true.])
  logical, parameter :: test_log3 = all(any(spread([.false., .true.], 1, 2), dim=2) .eqv. [.true., .true.])
  logical, parameter :: test_log4 = all(any(spread([.false., .true.], 2, 2), dim=2) .eqv. [.false., .true.])
end module


      subroutine setprob()
      implicit none

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

      double precision uvel, vvel, revs_per_s
      common /comm_velocity/ uvel, vvel, revs_per_s

      integer example
      common /comex/ example

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

      open(10,file='setprob.data')
      read(10,*) example
      read(10,*) uvel
      read(10,*) vvel
      read(10,*) revs_per_s

      end


! random_permutation.f90 --
!     Provide routines for permuting arrays
!
!     Derived from a posting on comp.lang.fortran by Bart Vanderwoestyne
!
!     $Id: random_permutation.f90,v 1.1 2012/12/23 10:18:12 arjenmarkus Exp $
!
module random_permutations

    implicit none

    interface randomly_permute
        module procedure randomly_permute_int
    end interface

contains

! fill_random_permutation --
!     Fill an array with randomly permuted integers from 1 to N
!
! Arguments:
!     array         Array to be filled
!
! Result:
!     The array is filled with integers 1 to N in random order.
!     It can be used to permute arrays of arbitrary type like:
!
!     call fill_random_permutation( order )
!     data = data(order)
!
subroutine fill_random_permutation( array )
    integer, dimension(:), intent(out) :: array

    integer                            :: i

    array = (/ (i, i=1,size(array)) /)

    call randomly_permute( array )
end subroutine fill_random_permutation

! randomly_permute_int --
!     Randomly permute an array of integers
!
! Arguments:
!     array         Array to be permuted
!
! Result:
!     Randomly permuted content
!
! Note:
!     The algorithm is derived from the book by Donald Knuth:
!     Adaptation of Knuth Volume 2, Algorithm 3.4.2P.
!
subroutine randomly_permute_int( array )
    integer, dimension(:), intent(inout) :: array

    integer                :: i, j, k
    integer                :: temp
    real(kind=kind(1.0d0)) :: u

    do j=size(array),2,-1

        call random_number(u)
        k = floor(j*u) + 1

        !
        ! Exchange array(k) and array(j)
        !
        temp     = array(k)
        array(k) = array(j)
        array(j) = temp

    end do

endsubroutine randomly_permute_int

endmodule random_permutations


!!## MODULE: FUNCTION  IsApprox
MODULE FUN_IsApprox

!!### PURPOSE
!! Compare two floats in an approximate sense.

!!### USAGE
!
!     TorF = IsApprox( A , B [,tol] [,reltol] )
!
!! where <TorF> is the <.TRUE.> or <.FALSE.> return value, and
!! <A> and <B> are two reals.

!!### DETAILS
!! Optional arguments, <tol> and <reltol> provide
!! absolute and relative tolerances, with <tol> overriding
!! <reltol> if (for some reason) both are present.
!!
!! The actual check is if
!
!                  ABS(A-B)<=tol
!
!! If <tol> is not present then we calculate it via the formula
!
!                  avg=(A+B)/2
!                  tol=reltol*avg
!
!! If <reltol> is not present then we use
!
!                  reltol=SQRT(EPSILON(avg))
!

!!#### NOTES
!! You may not mix kinds.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!### HISTORY
! 1.[waw] Author   = William A. Wieselquist
!         Modified = 105.2006
!         Contact  = william.wieselquist AT gmail.com

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!### INTERFACES
INTERFACE IsApprox
 MODULE PROCEDURE IsApprox_A0_Rsp
 MODULE PROCEDURE IsApprox_A0_Rdp
 MODULE PROCEDURE IsApprox_A1_Rsp
 MODULE PROCEDURE IsApprox_A1_Rdp
 MODULE PROCEDURE IsApprox_A2_Rsp
 MODULE PROCEDURE IsApprox_A2_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: IsApprox

!!## MODULE PROCEDURES
CONTAINS

PURE FUNCTION IsApprox_A0_Rsp(A,B,tol,reltol) RESULT(IsApprox)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_IsApprox_A0.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IsApprox_A0.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IsApprox_A0_Rdp(A,B,tol,reltol) RESULT(IsApprox)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_IsApprox_A0.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IsApprox_A0.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IsApprox_A1_Rsp(A,B,tol,reltol) RESULT(IsApprox)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_IsApprox_A1.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IsApprox_A1.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IsApprox_A1_Rdp(A,B,tol,reltol) RESULT(IsApprox)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_IsApprox_A1.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IsApprox_A1.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IsApprox_A2_Rsp(A,B,tol,reltol) RESULT(IsApprox)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_IsApprox_A2.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IsApprox_A2.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IsApprox_A2_Rdp(A,B,tol,reltol) RESULT(IsApprox)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_IsApprox_A2.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IsApprox_A2.f90.bdy"
!!--end--
END FUNCTION

END MODULE


MODULE HTURB_MOD

!   A random walk model is used to simulate turbulent particle motion in the
!   horizontal direction (x- and y- directions).
!
! Created by:             Elizabeth North
! Modified by:            Zachary Schlag
! Created on:             2003
! Last Modified on:       18 Aug 2008

IMPLICIT NONE
PUBLIC

CONTAINS

!       ***************** Horizontal Turbulence (RWM) *********************
!     ***********************************************************************
!    ** Random Walk Model (Visser 1997 MEPS 158:275-281) for simulating     **
!    ** turbulent diffusion, applied in the horizontal direction            **
!    **    z(t+1)= z + R[2/r K(z)dt]**0.5                                   **
!    **    where z = particle vertical location at time t                   **
!    **      K  = horizontal diffusivity (KM from QUODDY)                   **
!    **      dt = time step of RWM (deltat)                                 **
!    **      R  = random process with mean = 0 and standard deviation = r.  **
!    **                                                                     **
!    ** Programmed by EW North February 2003 UMCES HPL enorth@hpl.umces.edu **
!    *************************************************************************

  SUBROUTINE HTurb(TurbHx,TurbHy)
    USE PARAM_MOD, ONLY: ConstantHTurb,idt
    USE NORM_MOD,  ONLY: norm
    IMPLICIT NONE

    DOUBLE PRECISION, INTENT(OUT) :: TurbHx,TurbHy

    DOUBLE PRECISION :: devX,devY,r
    DOUBLE PRECISION :: KM

    r=1.0             ! standard deviation of the random deviate
    KM=ConstantHTurb  ! constant horizontal diffusivity

    devX=norm()       ! the random deviate in the X direction
    devY=norm()       ! the random deviate in the Y direction

    !Apply random walk model to calculate horizontal turbulent
    !  particle displacement
    TurbHx= devX*(DBLE(2.0)/r * KM *idt)**0.5
    TurbHy= devY*(DBLE(2.0)/r * KM *idt)**0.5

  END SUBROUTINE HTurb

END MODULE HTURB_MOD


      subroutine res_pest (jres)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes the lake hydrologic pesticide balance.

      use reservoir_data_module
      use reservoir_module
      use res_pesticide_module
      use hydrograph_module, only : res, ob, ht2
      use constituent_mass_module
      use pesticide_data_module
      use water_body_module

      implicit none

      real :: tpest1                !mg pst        |amount of pesticide in water
      real :: tpest2                !mg pst        |amount of pesticide in benthic sediment
      real :: kd                    !(mg/kg)/(mg/L) |koc * carbon
      real :: fd1                   !              |frac of soluble pesticide in water column
      real :: fd2                   !              |frac of sorbed pesticide in water column
      real :: fp1                   !              |frac of soluble pesticide in benthic column
      real :: fp2                   !              |frac of sorbed pesticide in benthic column
      real :: depth                 !              |average depth of reservoir
      real :: bedvol                !m^3           |volume of river bed sediment
      real :: solpesto              !mg pst        |soluble pesticide transported out of reservoir
      real :: sorpesto              !mg pst        |sorbed pesticide transported out of reservoir
      real :: sedmass_watervol      !kg/L or t/m3  |sediment mass divided by water volume in water and benthic
      real :: pest_init             !mg            |amount of pesticide before decay
      real :: pest_end              !mg            |amount of pesticide after decay
      integer :: jres               !none          |reservoir number
      integer :: ipst               !none          |counter
      integer :: icmd               !none          |
      integer :: jpst               !none          |counter
      integer :: jsed               !none          |counter
      integer :: idb                !none          |

      if (res(jres)%flo > 1.) then

      do ipst = 1, cs_db%num_pests
        icmd = res_ob(jres)%ob
        idb = ob(icmd)%props
        jpst = cs_db%pest_num(ipst)
        jsed = res_dat(idb)%sed
        respst_d(jres)%pest(ipst)%tot_in = obcs(icmd)%hin%pest(ipst)
        tpest1 = obcs(icmd)%hin%pest(ipst) + res_water(jres)%pest(ipst)
        bedvol = 1000. * res_wat_d(jres)%area_ha * pestdb(jpst)%ben_act_dep + .01
        tpest2 = res_benthic(jres)%pest(ipst) * bedvol

        !! calculate average depth of reservoir
        depth = res(jres)%flo / (res_wat_d(jres)%area_ha * 10000.)
        !! sor conc/sol conc = Koc * frac_oc = Kd -> (sor mass/mass sed) / (sol mass/mass water) = Kd
        !! -> sor mass/sol mass = Kd * (kg sed)/(L water) --> sol mass/tot mass = 1 / (1 + Kd * (kg sed)/(L water))
        !! water column --> kg sed/L water = t/m3 = t / (m3 - (t * m3/t)) --> sedvol = sed/particle density(2.65)
        sedmass_watervol = (res(jres)%sed) / (res(jres)%flo - (res(jres)%sed / 2.65))
        kd = pestdb(jpst)%koc * res_sed(jsed)%carbon / 100.
        fd1 = 1. / (1. + kd * sedmass_watervol)
        fd1 = amin1 (1., fd1)
        fp1 = 1. - fd1
        !! assume; fraction organic = 1%;\; por=0.8; density=2.6 t/m^3
        !! benthic layer --> kg sed/L water = t/m3 = bd (t sed/m3 total) / por --> por*total gives volume of water
        sedmass_watervol = res_sed(jsed)%bd / (1. - res_sed(jsed)%bd / 2.65)
        fd2 = 1. / (1. + kd * sedmass_watervol)
        fd2 = amin1 (1., fd2)
        fp2 = 1. - fd2

        fd2 = 1. / (.8 + .026 * kd)
        fd2 = amin1 (1., fd2)
        fp2 = 1. - fd2

        !! determine pesticide lost through reactions in water layer
        pest_init = tpest1
        if (pest_init > 1.e-12) then
          pest_end = tpest1 * pestcp(jpst)%decay_a
          tpest1 = pest_end
          respst_d(jres)%pest(ipst)%react = pest_init - pest_end
        end if

        !! determine pesticide lost through volatilization
        volatpst = pestdb(jpst)%aq_volat * fd1 * tpest1 / depth
        if (volatpst > tpest1) then
          volatpst = tpest1
          tpest1 = 0.
        else
          tpest1 = tpest1 - volatpst
        end if
        respst_d(jres)%pest(ipst)%volat = volatpst

        !! determine amount of pesticide settling to sediment layer
        setlpst = pestdb(jpst)%aq_settle * fp1 * tpest1 / depth
        if (setlpst > tpest1) then
          setlpst = tpest1
          tpest1 = 0.
          tpest2 = tpest2 + setlpst
        else
          tpest1 = tpest1 - setlpst
          tpest2 = tpest2 + setlpst
        end if
        respst_d(jres)%pest(ipst)%settle = setlpst

        !! determine pesticide resuspended into lake water
        resuspst = pestdb(jpst)%aq_resus * tpest2 / pestdb(jpst)%ben_act_dep
        if (resuspst > tpest2) then
          resuspst = tpest2
          tpest2 = 0.
          tpest1 = tpest1 + resuspst
        else
          tpest2 = tpest2 - resuspst
          tpest1 = tpest1 + resuspst
        end if
        respst_d(jres)%pest(ipst)%resus = resuspst

        !! determine pesticide diffusing from sediment to water
        difus = res_ob(jres)%aq_mix(ipst) *                                 &
              (fd2 * tpest2 / pestdb(jpst)%ben_act_dep - fd1 * tpest1 / depth)
        if (difus > 0.) then
          if (difus > tpest2) then
            difus = tpest2
            tpest2 = 0.
          else
            tpest2 = tpest2 - Abs(difus)
          end if
          tpest1 = tpest1 + Abs(difus)
        else
          if (Abs(difus) > tpest1) then
            difus = -tpest1
            tpest1 = 0.
          else
            tpest1 = tpest1 - Abs(difus)
          end if
          tpest2 = tpest2 + Abs(difus)
        end if
        respst_d(jres)%pest(ipst)%difus = difus

        !! determine pesticide lost from sediment by reactions
        pest_init = tpest2
        if (pest_init > 1.e-12) then
          pest_end = tpest2 * pestcp(jpst)%decay_b
          tpest2 = pest_end
          respst_d(jres)%pest(ipst)%react_bot = pest_init - pest_end
        end if

        !! determine pesticide lost from sediment by burial
        bury = pestdb(jpst)%ben_bury * tpest2 / pestdb(jpst)%ben_act_dep
        if (bury > tpest2) then
          bury = tpest2
          tpest2 = 0.
        else
          tpest2 = tpest2 - bury
        end if
        respst_d(jres)%pest(ipst)%bury = bury

        !! calculate soluble pesticide transported out of reservoir
        solpesto = ht2%flo * fd1 * tpest1 / res(jres)%flo
        if (solpesto > tpest1) then
          solpesto = tpest1
          tpest1 = 0.
        else
          tpest1 = tpest1 - solpesto
        end if

        !! calculate sorbed pesticide transported out of reservoir
        sorpesto = ht2%flo * fp1 * tpest1 / res(jres)%flo
        if (sorpesto > tpest1) then
          sorpesto = tpest1
          tpest1 = 0.
        else
          tpest1 = tpest1 - sorpesto
        end if
        respst_d(jres)%pest(ipst)%sol_out = solpesto
        respst_d(jres)%pest(ipst)%sor_out = sorpesto

        !! update concentration of pesticide in lake water and sediment
        if (tpest1 < 1.e-10) tpest1 = 0.0
        if (tpest2 < 1.e-10) tpest2 = 0.0
        res_water(jres)%pest(ipst) = tpest1 / res(jres)%flo
        res_benthic(jres)%pest(ipst) = tpest2 / bedvol

      end do
      end if

      return
      end subroutine res_pest


                    subroutine eqtoecl(rh, rm, rs, isign, dd, dm, ds,
     +                                elon, elat)
*
*     converts the J2000 equatorial coordinates to the ecliptic
*     coordinates 'elon' and 'elat' at J2000 in degrees. The J2000
*     value of the obliquity 'epcilon' is adopted.
*
      implicit real * 8 (a - h, o - z)
      implicit integer (i - n)
*
      data pi /3.14159265359d0/
*
      data epcd, epcm, epcs /23.0d0, 26.0d0, 21.448d0/
      data small /1.0d-15/
*
      rad = pi / 180.0d0
      epcilon = epcd + epcm / 60.0d0 + epcs / 3600.0d0
*
      ra = rad * 15.0d0 * (rh + rm / 60.0d0 + rs / 3600.0d0)
      dc = isign * rad * (dd + dm / 60.0d0 + ds / 3600.0d0)
*
      ep = rad * epcilon
*
      cose = cos(ep)
      sine = sin(ep)
      cosr = cos(ra)
      sinr = sin(ra)
      cosd = cos(dc)
      sind = sin(dc)
*
      sinb = - sine * cosd * sinr + cose * sind
*
      beta = asin(sinb)
*
      cosb = cos(beta)
*
      if (abs(cosb) .le. small) then
        elam = 0.0d0
      else
        cosl = cosd * cosr / cosb
        sinl = (cose * cosd * sinr + sine * sind) / cosb
        elam = atan2(sinl, cosl)
      endif
*
      elon = elam / rad
      elat = beta / rad
*
      if (elon .lt. 0.0d0) then
        elon = elon + 360.0d0
      endif
*
      return
      end


program problem38
  use euler
  implicit none
  integer               :: i,j,k,answer=-1
  integer, dimension(9) :: products,lengths

  do i=2,9
     j=1
     do while (.true.)
        forall (k=1:i)
           products(k)=k*j
           lengths(k)=number_length(int8(products(k)))
        end forall
        k=sum(lengths(1:i))
        if (k>9) exit
        if (k==9) then
           if (pandigital(products,i)) then
              answer=max(answer,to_number(products,i))
           end if
        end if
        j=j+1
     end do
  end do

  print *, answer

contains
  pure function to_number(ns,i)
    implicit none
    integer, dimension(9), intent(in) :: ns
    integer,intent(in)                :: i
    integer                           :: to_number,j

    to_number=0
    do j=1,i
       to_number=(to_number*10**(number_length(int8(ns(j)))))+ns(j)
    end do

  end function to_number

  pure function pandigital(ns,i)
    implicit none
    integer, dimension(9), intent(in) :: ns
    integer, intent(in)               :: i
    integer, dimension(10)            :: found
    integer                           :: j,product,index
    logical pandigital

    pandigital=.true.

    forall (j=1:10) found(j)=0

    do j=1,i
       product=ns(j)
       do while (product>0)
          index=mod(product,10)+1 ! turn modulus into index
          if (found(index)>0) then
             pandigital=.false.
             go to 1
          end if
          found(index)=1
          product=product/10
       end do
    end do

    if ((found(0+1) /= 0) .or. (sum(found(2:10)) /= 9)) then
       pandigital=.false.
    end if

1 end function pandigital

end program problem38


C$Procedure      XPOSEG ( Transpose a matrix, general )

      SUBROUTINE XPOSEG ( MATRIX, NROW, NCOL, XPOSEM )

C$ Abstract
C
C     Transpose a matrix of arbitrary size (the matrix
C     need not be square).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C
C$ Declarations

      DOUBLE PRECISION   MATRIX ( 0:* )
      INTEGER            NROW
      INTEGER            NCOL
      DOUBLE PRECISION   XPOSEM ( 0:* )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MATRIX     I   Matrix to be transposed.
C     NROW       I   Number of rows of input matrix M1.
C     NCOL       I   Number of columns of input matrix M1.
C     XPOSEM     O   Transposed matrix.
C
C$ Detailed_Input
C
C     MATRIX     Matrix to be transposed.
C
C     NROW       Number of rows of input matrix M1.
C
C     NCOL       Number of columns of input matrix M1.
C
C$ Detailed_Output
C
C     XPOSEM     O   Transposed matrix.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error Free.
C
C     1) If either NROW or NCOL is less than or equal to zero, no action
C        is taken. The routine simply returns.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine transposes the input matrix MATRIX and writes the
C     result to the matrix XPOSEM.  This algorithm is performed in
C     such a way that the transpose can be performed in place.  That
C     is, MATRIX and XPOSEM can use the same storage area in memory.
C
C     NOTE:  The matrices MATRIX and XPOSEM are declared
C            one-dimensional for computational purposes only.  The
C            calling program should declare them as MATRIX(NROW,NCOL)
C            and XPOSEM(NCOL,NROW).
C
C            This routine works on the assumption that the input and
C            output matrices are defined as described above.  More
C            specifically it assuses that the elements of the matrix
C            to be transformed is stored in contiguous memory locations
C            as shown here.  On output these elements will be
C            rearranged in consecutive memory locations as shown.
C
C               MATRIX              XPOSEM
C
C                m_11                m_11
C                m_21                m_12
C                m_31                m_13
C                 .                   .
C                 .                   .
C                 .                  m_1ncol
C                m_nrow1             m_21
C                m_12                m_22
C                m_22                m_23
C                m_32                 .
C                 .                   .
C                 .                  m_2ncol
C                 .                   .
C                m_nrow2
C                 .                   .
C
C                 .                   .
C
C                 .                   .
C                m_1ncol
C                m_2ncol             m_nrow1
C                m_3ncol             m_nrow2
C                 .                  m_nrow3
C                 .                   .
C                 .                   .
C                m_nrowncol          m_nrowncol
C
C
C     For those familiar with permutations, this algorithm relies
C     upon the fact that the transposition of a matrix, which has
C     been stored as a string, is simply the action of a
C     permutation applied to that string.  Since any permutation
C     can be decomposed as a product of disjoint cycles, it is
C     possible to transpose the matrix with only one additional
C     storage register.  However, once a cycle has been computed
C     it is necessary to find the next entry in the string that
C     has not been moved by the permutation.  For this reason the
C     algorithm is slower than would be necessary if the numbers
C     of rows and columns were known in advance.
C
C$ Examples
C
C     This routine is primarily useful when attempting to transpose
C     large matrices, where inplace transposition is important.  For
C     example suppose you have the following declarations
C
C         DOUBLE PRECISION      MATRIX ( 1003, 800  )
C
C     If the transpose of the matrix is needed, it may not be
C     possible to fit a second matrix requiring the same storage
C     into memory.  Instead declare XPOSEM as below and use
C     an equivalence so that the same area of memory is allocated.
C
C         DOUBLE PRECISION      XPOSEM (  800, 1003 )
C         EQUIVALENCE         ( MATRIX (1,1), XPOSEM(1,1) )
C
C     To obtain the transpose simply execute
C
C         CALL XPOSEG ( MATRIX, 1003, 800, XPOSEM )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.3, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.2.2, 4-MAY-1993 (HAN)
C
C        The example listed arguments in the call to XPOSEG incorrectly.
C        The number of rows was listed as the number of columns, and
C        the number of columns was listed as the number of rows.
C
C-    SPICELIB Version 1.2.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.2.0,  6-AUG-1990 (WLT)
C
C        The original version of the routine had a bug.  It worked
C        in place, but the fixed points (1,1) and (n,m) were not
C        moved so that the routine did not work if input and output
C        matrices were different.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     transpose a matrix general
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0,  6-AUG-1990 (WLT)
C
C        The original version of the routine had a bug.  It worked
C        in place, but the fixed points (1,1) and (n,m) were not
C        moved so that the routine did not work if input and output
C        matrices were different.
C
C-    Beta Version 1.1.0, 17-FEB-1989 (WLT) (NJB)
C
C        Example section of header upgraded.  Declarations of unused
C        variables I, J, and COUNT were removed.  Case of negative
C        matrix dimensions now is handled.
C
C-&

C
C     Local Variables
C
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION SOURCE

      INTEGER          DEST
      INTEGER          MOVED
      INTEGER          START

      INTEGER          K
      INTEGER          NMOVES
      INTEGER          R
      INTEGER          M
      INTEGER          N

C
C     Take care of dumb cases first.
C
      IF (( NROW .LE. 0 ) .OR. ( NCOL .LE. 0 )) THEN
         RETURN
      END IF

      N      = NROW
      M      = NCOL

C
C     Set up the upper bound for the number of objects to be moved and
C     initialize the counters.
C
      NMOVES = N*M - 2
      MOVED  = 0
      START  = 1

C
C     Until MOVED is equal to NMOVES, there is some matrix element that
C     has not been moved to its proper location in the transpose matrix.
C
      DO WHILE (MOVED .LT. NMOVES)
         SOURCE  = MATRIX(START)
         K       = START / N
         R       = START - N*K
         DEST    = R*M   + K

C
C        Perform this cycle of the permutation.  We will be done when
C        the destination of the next element is equal to the starting
C        position of the first element to be moved in this cycle.
C
         DO WHILE (DEST .NE. START)
            TEMP         = MATRIX(DEST)
            XPOSEM(DEST) = SOURCE
            SOURCE       = TEMP

            MOVED        = MOVED + 1
            K            = DEST  / N
            R            = DEST  - K*N
            DEST         = M*R   + K

         END DO

         XPOSEM(DEST) = SOURCE
         DEST         = 0
         MOVED        = MOVED + 1

C
C        Find the next element of the matrix that has not already been
C        moved by the transposition operation.
C
         IF (MOVED .LT. NMOVES) THEN

            DO WHILE (DEST .NE. START)
               START = START + 1
               K     = START / N
               R     = START - K*N
               DEST  = R*M   + K

               DO WHILE ( DEST .GT. START)
                  K     = DEST / N
                  R     = DEST - K*N
                  DEST  = M*R  + K
               END DO

            END DO

         END IF

      END DO

C
C     Just in case this isn't an in-place transpose, move the last
C     element of MATRIX to XPOSEM
C
      XPOSEM(0)     = MATRIX(0    )
      XPOSEM(N*M-1) = MATRIX(N*M-1)

      RETURN
      END


module Mod_sldup_calculateAU
  use typre
  implicit none

  contains

  subroutine getAU_U(nd,gradp,divstr,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: gradp(nd),divstr(nd)
      real(rp),             intent(inout) :: AU(nd)

      !A(U)
      AU = - gradp - divstr

  end subroutine

  subroutine getAU_U_dyn(nd,densi,accel,gradp,divstr,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: gradp(nd),divstr(nd),accel(nd),densi
      real(rp),             intent(inout) :: AU(nd)

      !A(U)
      AU = densi*accel - gradp - divstr

  end subroutine

  subroutine getAU_P(nd,mu,lam,J,b,gpress,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: mu,lam,J,b(nd,nd)
      real(rp),             intent(in)    :: gpress(1)
      real(rp),             intent(inout) :: AU
      real(rp)                            :: b_ii

      call trace(nd,b,b_ii)
      !A(U):
      AU = (J/lam)*gpress(1)-(mu/lam)*((b_ii/nd)-1.0_rp)
      AU = AU - log(J)

  end subroutine

  subroutine getAU_P_OSGS(nd,mu,lam,J,b,gpress,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: mu,lam,J,b(nd,nd)
      real(rp),             intent(in)    :: gpress(1)
      real(rp),             intent(inout) :: AU
      real(rp)                            :: b_ii

      call trace(nd,b,b_ii)
      !A(U):
      AU = -(mu/lam)*((b_ii/nd)-1.0_rp)
      AU = AU - log(J)

  end subroutine

  end module


      DOUBLE PRECISION FUNCTION ANOMLY(IND,ANGLE,ECC,IERPNT,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE COMPUTES MEAN ANOMALY GIVEN TRUE ANOMALY AND VIS-VERSA.
C
C  VAR    DIM TYPE  I/O  DESCRIPTION
C  ---    --- ----  ---  -----------
C
C  IND     1  I*4    I   INDICATOR ON ANGLE TYPE.
C                        =ZERO OR POSITIVE. MEAN ANOMALY INPUT, TRUE
C                         ANOMALY OUTPUT.
C                        =NEGATIVE. TRUE ANOMALY INPUT, MEAN OUTPUT.
C
C  ANGLE   1  R*8    I   ANGLE TO BE CONVERTED. MEAN OR TRUE ANOMALY,
C                        DEPENDING ON VALUE OF IND INPUT. RADIANS.
C
C  ECC     1  R*8    I   ECCENTRICITY. MUST BE LESS THAN 1.D0
C
C  IERPNT  1  I*4    I   FORTRAN UNIT FOR ERROR MESSAGE. USED WHEN AN
C                        INVALID ECC HAS BEEN INPUT OR WHEN ITERATION
C                        LOOP IN TRUE ANOMALY SOLUTION FAILS TO
C                        CONVERGE.
C                        =0 MEANS NO ERROR MESSAGE IS TO BE GIVEN.
C
C  IERR    1  I*4    O   ERROR RETURN FLAG.
C                        =0, NO ERROR.  =1, ERROR.
C
C***********************************************************************
C
C  TAKEN FROM 580'S MAESTRO PROGRAM. MODS BY C PETRUZZO 9/81.
C
C***********************************************************************
C
      REAL*8 PI/  3.141592653589793D0    /
      REAL*8 TWOPI/  6.283185307179586D0    /
      REAL*8 MEAN
C
C
C  EQUATIONS ARE FROM THE ORBITAL FLIGHT HANDBOOK(MARTIN CO., 1963.)
C  VOL I, PAGE III-21, EQN 2-7 AND
C  PAGE III-23, EQNS 2-57 AND 2-59.
C
      IERR=0
      IF(ECC.LT.0.D0.OR.ECC.GE.1.D0) IERR=1
      IF(IERR.EQ.0) GO TO 1515
      ANOMLY=0.D0
      IF(IERPNT.NE.0) WRITE(IERPNT,1500) IND,ANGLE,ECC,ANOMLY
 1500 FORMAT('0ANOMLY. BIG ERROR. ECCENTRICITY NOT FOR AN ELLIPSE.'/,
     1  '  IND,ANGLE,ECC=',I3,2G20.10,' ANOMLY OUT=',F8.2)
      GO TO 9000
C
 1515 CONTINUE
      TEMP=DABS(ANGLE)
      ANG1=DMOD(TEMP,TWOPI)
      DIF2PI=TEMP-ANG1
C
      IF(IND.LT.0) GO TO 1000
C
C
C  GET TRUE ANONALY FROM MEAN ANOMALY BY WAY OF ECCENTRIC ANOMALY.
      MEAN=ANG1
C  FIND ECANOM THE SATISFIES    MEAN=ECANOM-ECC*DSIN(ECANOM)
      ECANOM=MEAN
      DO 8 I=1,50
      ERROR=MEAN-ECANOM+ECC*DSIN(ECANOM)
      IF(DABS(ERROR).LE.1.D-12) GO TO 50
      TEMP=ECC*DCOS(ECANOM)
      HELPER=.01D0 * TEMP**3
      IF(TEMP.GT.0.99D0 .OR. I.GT.10) HELPER=0.D0
      DERIV=1.D0-TEMP+HELPER
      DEL=ERROR/DERIV
      IF(DEL.GT.2.D0) DEL=2.D0
      ECANOM=ECANOM+DEL
    8 CONTINUE
      IERR=1
      IF(IERPNT.NE.0) WRITE(IERPNT,1100) MEAN,ECANOM
 1100 FORMAT('0ANOMLY. ERROR. ECANOM LOOP NOT CONVERGED. MEAN,ECANOM=',
     1   2G20.10)
   50 CONTINUE
      Y=DSQRT(1.D0-ECC*ECC) * DSIN(ECANOM)
      X=DCOS(ECANOM) - ECC
      TRUANM=DMOD(DATAN2(Y,X)+TWOPI,TWOPI)
      ANG2=TRUANM
      GO TO 2000
C
C
 1000 CONTINUE
C  GET MEAN ANOMALY FROM TRUE ANOMALY BY WAY OF ECCENTRIC ANOMALY.
      TRUANM=ANG1
      COSTRU=DCOS(TRUANM)
      ECANOM=DARCOS( (ECC+COSTRU)/(1.D0+ECC*COSTRU) )
C  ECANOM IS BETWEEN 0.D0 AND PI. TRUE ANOMALY IS BETWEEN 0.D0 AND TWOPI
C  PUT ECANOM ON THE PROPER SIDE OF PI.
      IF(TRUANM.GT.PI) ECANOM=TWOPI-ECANOM
      MEAN = ECANOM - ECC*DSIN(ECANOM)
      ANG2=MEAN
C
C
 2000 CONTINUE
      ANG2=ANG2+DIF2PI
      IF(ANGLE.LT.0.D0) ANG2=-ANG2
      ANOMLY=ANG2
 9000 RETURN
      END


module m_ffhash
  implicit none
#define FFH_KEY_TYPE character(len=20)
#define FFH_KEY_IS_STRING
#define FFH_VAL_TYPE integer
#define FFH_CUSTOM_HASH_FUNCTION
#include "ffhash_inc.f90"

  ! djb2 hash function
  pure integer function hash_function(key) result(hash)
    character(len=*), intent(in) :: key
    integer                      :: n

    hash = 5381
    do n = 1, len(key)
       ! hash * 33 + c
       hash = (shiftl(hash, 5) + hash) + iachar(key(n:n))
    end do
  end function hash_function
end module m_ffhash

program test
  use m_ffhash

  implicit none

  type(ffh_t) :: h
  integer     :: day, month, year

  call h%ustore_value("day", 20)
  call h%ustore_value("month", 2)
  call h%ustore_value("year", 2020)

  call h%uget_value("day", day)
  call h%uget_value("month", month)
  call h%uget_value("year", year)

  if (all([day, month, year] == [20, 2, 2020])) then
     print *, [day, month, year]
     print *, h%get_index(["day  ", "month", "year "])
     print *, "PASSED"
  else
     error stop "FAILED"
  end if

  call h%reset()
end program test


      subroutine scheme_f77(up, u, um, x, y, t, nx, ny, Cx2, Cy2,
     &                      dt2, t_old)
      integer nx, ny
      real*8 up(0:nx, 0:ny), u(0:nx, 0:ny), um(0:nx, 0:ny)
      real*8 x(0:nx), y(0:ny)
      real*8 Cx2, Cy2, dt2, t, t_old
Cf2py intent(in, out) up
      real*8 f
      external f

      do j = 1, ny-1
         do i = 1, nx-1
            up(i,j) = - um(i,j) + 2*u(i,j) +
     &          Cx2*(u(i-1,j) - 2*u(i,j) + u(i+1,j)) +
     &          Cy2*(u(i,j-1) - 2*u(i,j) + u(i,j+1)) +
     &          dt2*f(x(i),y(j),t_old)
         end do
      end do
      return
      end

      subroutine ic_f77(u, um, x, y, nx, ny, Cx2, Cy2, dt)
      integer nx, ny
      real*8 u(0:nx, 0:ny), um(0:nx, 0:ny)
      real*8 x(0:nx), y(0:ny)
      real*8 Cx2, Cy2, dt, dt2
Cf2py intent(in, out) u, um
      real*8 f, ic
      external f, ic

      dt2 = dt*dt
      do j = 0, ny
         do i = 0, nx
            u(i,j) = ic(x(i),y(j))
         end do
      end do
      do j = 1, ny-1
         do i = 1, nx-1
            um(i,j) = u(i,j) +
     &          0.5*Cx2*(u(i-1,j) - 2*u(i,j) + u(i+1,j)) +
     &          0.5*Cy2*(u(i,j-1) - 2*u(i,j) + u(i,j+1)) +
     &          dt2*f(x(i),y(j),0.0D0)
         end do
      end do
C     boundary values:
      call bc_f77(um, x, y, nx, ny, dt)
      return
      end

      subroutine bc_f77(up, x, y, nx, ny, t)
      integer nx, ny
      real*8 up(0:nx, 0:ny)
      real*8 x(0:nx), y(0:ny)
      real*8 t
Cf2py intent(in, out) up
      real*8 bc
      external bc

      i = 0
      do j = 0, ny
         up(i,j) = bc(x(i),y(j),t)
      end do
      j = 0
      do i = 0, nx
         up(i,j) = bc(x(i),y(j),t)
      end do
      i = nx
      do j = 0, ny
         up(i,j) = bc(x(i),y(j),t)
      end do
      j = ny
      do i = 0, nx
         up(i,j) = bc(x(i),y(j),t)
      end do
      return
      end

      real*8 function f(x, y, t)
C     independent variables:
      real*8 x
      real*8 y
      real*8 t

      f = 0.0

      return
      end

      real*8 function bc(x, y, t)
C     independent variables:
      real*8 x
      real*8 y
      real*8 t

      bc = 0.0

      return
      end

      real*8 function ic(x, y)
C     independent variables:
      real*8 x
      real*8 y

C     parameters:
      real*8 Lx
      real*8 Ly
      Lx = 10
      Ly = 10

      ic = exp(-(x-Lx/2.0)**2/2.0 -(y-Ly/2.0)**2/2.0)

      return
      end

      real*8 function pow(x, a)
      real*8 x
C     the power a is usually a number (single precision),
C     note: it cannot be int
      real*4 a
      pow = x**a
      return
      end


MODULE ClassMatrizA

   ! Modulo que implementa a classe coeficientes

   IMPLICIT  NONE

   PRIVATE

   ! Os stencils da matriz A
   TYPE, PRIVATE :: stencil
      INTEGER,          DIMENSION(:), ALLOCATABLE :: p ! As posicoes do stencil     -1, +1, +Nx, -Nx,  0, +2Nx,  -2, etc...
      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: c ! Os coeficientes do stencil aw, ae,  an,  as, ap,  ann, aww, etc...
   END TYPE stencil

   TYPE, PUBLIC :: MatrizA

      ! Atritubos Externos serao atualizados por outra rotina
      ! Atributos Internos serao atualizados na classe

      !---------Atributos Externos-----------------------
      INTEGER :: Nx, Ny
      DOUBLE PRECISION :: hx, hy, ht, Re
      !--------------------------------------------------

      !--------Atributos Internos------------------------
      ! Para o problema estudado sao 9 stencils na matriz para U, V e P
      TYPE( stencil ), DIMENSION(9) :: s       ! Os stencils da matriz A
      INTEGER, DIMENSION(:), ALLOCATABLE :: v  ! Cada volume V vai utilizar um stencils s
      !--------------------------------------------------

      CONTAINS

         ! Metodos da Classe
         procedure :: init                ! Metodo que inicia a classe

         !--------------------------------------------------------------------------
         ! Obs: este metodo cria um vetor do mesmo tamanho que a matriz
         ! se estiver utilizando muita memoria pode-se calcular o stencil
         ! utilizado pelo volume utilizando o metodo calcula_stencil. Desta
         ! forma cada vez que o volume e considerado seu stencil e calculado
         ! em tempo real, ou seja, sera trocado memoria por processamento.
         procedure :: atribui_stencils    ! Metodo que ira atribuir a cada volume
                                          ! os stencils, utiliza mais memoria mas calcula os
                                          ! stencils uma unica vez

         procedure :: calcula_stencil     ! Metodo que calcula o stencil utilizado pelo volume
                                          ! em tempo real, nao utiliza memoria extra mas calcula
                                          ! os stencils toda vez que o volume for considerado
         !-----------------------------------------------------------------------------

         procedure :: stencils_u  ! Metodo que calcula os stencils para U
         procedure :: stencils_v  ! Metodo que calcula os stencils para V
         procedure :: stencils_p  ! Metodo que calcula os stencils para P

   END TYPE MatrizA

   CONTAINS

      SUBROUTINE init(self, Nx, Ny, hx, hy, ht, Re)

         !------------ Metodo que inicia as variaveis gerais da malha ---------------------

         CLASS( MatrizA ), INTENT(INOUT) :: self

         INTEGER         , INTENT(IN)      :: Nx, Ny
         DOUBLE PRECISION, INTENT(IN)      :: hx, hy, ht, Re

         ! Atualiando os atributos da classe
         self % Nx = Nx
         self % Ny = Ny
         self % hx = hx
         self % hy = hy
         self % Re = Re
         self % ht = ht

      END SUBROUTINE init

      SUBROUTINE atribui_stencils( self )

         CLASS (MatrizA), INTENT(INOUT) :: self

         INTEGER :: p, Nx, Ny

         ! Apenas para ficar mais clean o codigo abaixo
         Nx = self % Nx
         Ny = self % Ny

         ! Reservando o vetor de stencils
         ALLOCATE( self % v( Nx * Ny ) )

         ! Atribuindo o stencil central para todos os volumes,
         ! desta forma so sera necessario corrigir os contornos
         self % v(:) = 5

         ! Posicao do stencil, sao nove posicoes
         ! 1 = SW (South West)
         ! 2 = S  (South)
         ! 3 = SE (South East)
         ! 4 = W  (West)
         ! 5 = C  (Central)
         ! 6 = E  (East)
         ! 7 = NW (North West)
         ! 8 = N  (North)
         ! 9 = NE (North East)

         ! Canto SOUTH WEST recebe stencil 1
         p = 1
         self % v(p) = 1

         ! Contorno SOUTH recebe stencil 2
         DO p = 2, Nx - 1
            self % v(p) = 2
         END DO

         ! Canto SOUTH EAST  recebe stencil 3
         p = Nx
         self % v(p) = 3

         ! Contorno WEST recebe stencil 4
         DO p = 1 + Nx, Nx *( Ny - 2 ) + 1, Nx
            self % v(p) = 4
         END DO

         ! Volumes no CENTRO recebem stencil 5, mas ja foram considerados

         ! Contorno EAST recebe stencil 6
         DO p = 2 * Nx, Nx * (Ny - 1), Nx
            self % v(p) = 6
         END DO

         ! Canto NORTH WEST recebe stencil 7
         p = Nx *( Ny - 1 ) + 1
         self % v(p) = 7

         ! Contorno NORTH recebe stencil 8
         DO p = Nx *( Ny - 1 ) + 2, Nx * Ny - 1
            self % v(p) = 8
         END DO

         ! Canto NORTH EAST recebe stencil 9
         p = Nx * Ny
         self % v(p) = 9

      END SUBROUTINE atribui_stencils

      INTEGER FUNCTION calcula_stencil( self, volume )

         CLASS (MatrizA), INTENT(INOUT) :: self

         INTEGER, INTENT(IN) :: volume
         INTEGER             :: i, j, Nx, Ny
         INTEGER             :: s1, s2, s3, s4, s5, s6, s7, s8, s9

         j = (volume-1)/(self % Nx) + 1
         i = volume - (j-1)*(self % Nx)

         s2 = 1/j
         s4 = 1/i
         s6 = i/(self % Nx)
         s8 = j/(self % Ny)
         s1 = (s2 + s4)/2
         s3 = (s2 + s6)/2
         s5 = (5 - (s2 + s4 + s6 + s8))/5
         s7 = (s4 + s8)/2
         s9 = (s6 + s8)/2
         calcula_stencil = ABS( 2*s2 + 4*s4 + 6*s6 + 8*s8 - (7*s1 + 11*s3 + 19*s7 + 23*s9) + 5*s5 )

      END FUNCTION calcula_stencil

! STENCILS U ------------------------------------------------------------------------------------------------------------------------------------------

      SUBROUTINE stencils_u( self, alfa2 )

         CLASS (MatrizA), INTENT(INOUT) :: self

         INTEGER :: Nx, Ny
         DOUBLE PRECISION :: Re, ht, hx, hy
         DOUBLE PRECISION, INTENT(IN) :: alfa2

         ! Apenas para ficar mais clean o codigo abaixo
         hx = self % hx
         hy = self % hy
         ht = self % ht
         Re = self % Re
         Nx = self % Nx

         ! Sao nove stencils
         ! 1 = SW (South West)
         ! 2 = S  (South)
         ! 3 = SE (South East)
         ! 4 = W  (West)
         ! 5 = C  (Central)
         ! 6 = E  (East)
         ! 7 = NW (North West)
         ! 8 = N  (North)
         ! 9 = NE (North East)

         !------- 1 = SW (South West) -------
         IF ( .NOT. ALLOCATED( self % s(1) % c ) )    ALLOCATE( self % s(1) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(1) % p ) )    ALLOCATE( self % s(1) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(1) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 5.0d0 * ht/(Re*hy**2)
         self % s(1) % p(1) = 0

         ! ae
         self % s(1) % c(2) = ht/(Re*hx**2)
         self % s(1) % p(2) = 1

         ! an
         self % s(1) % c(3) = 2.0d0 * ht/(Re*hy**2)
         self % s(1) % p(3) = Nx

         !ann
         self % s(1) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hy**2))
         self % s(1) % p(4) = 2*Nx
         !------- 1 = SW (South West) -------

         !------- 2 = S (South) -------
         IF ( .NOT. ALLOCATED( self % s(2) % c ) )    ALLOCATE( self % s(2) % c(5) )
         IF ( .NOT. ALLOCATED( self % s(2) % p ) )    ALLOCATE( self % s(2) % p(5) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(2) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 5.0d0 * ht/(Re*hy**2)
         self % s(2) % p(1) = 0

         ! aw
         self % s(2) % c(2) = ht/(Re*hx**2)
         self % s(2) % p(2) = -1

         ! ae
         self % s(2) % c(3) = ht/(Re*hx**2)
         self % s(2) % p(3) = 1

         ! an
         self % s(2) % c(4) = 2.0d0 * ht/(Re*hy**2)
         self % s(2) % p(4) = Nx

         ! ann
         self % s(2) % c(5) = -(1.0d0/5.0d0)*(ht/(Re*hy**2))
         self % s(2) % p(5) = 2*Nx
         !------- 2 = S (South) -------

         !------- 3 = SE (South East) -------
         IF ( .NOT. ALLOCATED( self % s(3) % c ) )    ALLOCATE( self % s(3) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(3) % p ) )    ALLOCATE( self % s(3) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(3) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 5.0d0 * ht/(Re*hy**2)
         self % s(3) % p(1) = 0

         ! aw
         self % s(3) % c(2) = ht/(Re*hx**2)
         self % s(3) % p(2) = -1

         ! an
         self % s(3) % c(3) = 2.0d0 * ht/(Re*hy**2)
         self % s(3) % p(3) = Nx

         ! ann
         self % s(3) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hy**2))
         self % s(3) % p(4) = 2*Nx
         !------- 3 = SE (South East) -------

         !------- 4 = W (West) -------
         IF ( .NOT. ALLOCATED( self % s(4) % c ) )    ALLOCATE( self % s(4) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(4) % p ) )    ALLOCATE( self % s(4) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(4) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 2.0d0 * ht/(Re*hy**2)
         self % s(4) % p(1) = 0

         ! ae
         self % s(4) % c(2) = ht/(Re*hx**2)
         self % s(4) % p(2) = 1

         ! as
         self % s(4) % c(3) = ht/(Re*hy**2)
         self % s(4) % p(3) = -Nx

         ! an
         self % s(4) % c(4) = ht/(Re*hy**2)
         self % s(4) % p(4) = Nx
         !------- 4 = W (West) -------

         !------- 5 = C (Central) -------
         IF ( .NOT. ALLOCATED( self % s(5) % c ) )    ALLOCATE( self % s(5) % c(5) )
         IF ( .NOT. ALLOCATED( self % s(5) % p ) )    ALLOCATE( self % s(5) % p(5) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(5) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 2.0d0 * ht/(Re*hy**2)
         self % s(5) % p(1) = 0

         ! aw
         self % s(5) % c(2) = ht/(Re*hx**2)
         self % s(5) % p(2) = -1

         ! ae
         self % s(5) % c(3) = ht/(Re*hx**2)
         self % s(5) % p(3) = 1

         ! as
         self % s(5) % c(4) = ht/(Re*hy**2)
         self % s(5) % p(4) = -Nx

         ! an
         self % s(5) % c(5) = ht/(Re*hy**2)
         self % s(5) % p(5) = Nx
         !------- 5 = C (Central) -------

         !------- 6 = E (East) -------
         IF ( .NOT. ALLOCATED( self % s(6) % c ) )    ALLOCATE( self % s(6) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(6) % p ) )    ALLOCATE( self % s(6) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(6) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 2.0d0 * ht/(Re*hy**2)
         self % s(6) % p(1) = 0

         ! aw
         self % s(6) % c(2) = ht/(Re*hx**2)
         self % s(6) % p(2) = -1

         ! as
         self % s(6) % c(3) = ht/(Re*hy**2)
         self % s(6) % p(3) = -Nx

         ! an
         self % s(6) % c(4) = ht/(Re*hy**2)
         self % s(6) % p(4) = Nx
         !------- 6 = E (East) -------

         !------- 7 = NW (North West) -------
         IF ( .NOT. ALLOCATED( self % s(7) % c ) )    ALLOCATE( self % s(7) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(7) % p ) )    ALLOCATE( self % s(7) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(7) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 5.0d0 * ht/(Re*hy**2)
         self % s(7) % p(1) = 0

         ! ae
         self % s(7) % c(2) = ht/(Re*hx**2)
         self % s(7) % p(2) = 1

         ! as
         self % s(7) % c(3) = 2.0d0 * ht/(Re*hy**2)
         self % s(7) % p(3) = -Nx

         ! ass
         self % s(7) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hy**2))
         self % s(7) % p(4) = -2*Nx
         !------- 7 = NW (North West) -------

         !------- 8 = N (North) -------
         IF ( .NOT. ALLOCATED( self % s(8) % c ) )    ALLOCATE( self % s(8) % c(5) )
         IF ( .NOT. ALLOCATED( self % s(8) % p ) )    ALLOCATE( self % s(8) % p(5) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(8) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 5.0d0 * ht/(Re*hy**2)
         self % s(8) % p(1) = 0

         ! aw
         self % s(8) % c(2) =  ht/(Re*hx**2)
         self % s(8) % p(2) = -1

         ! ae
         self % s(8) % c(3) = ht/(Re*hx**2)
         self % s(8) % p(3) = 1

         ! as
         self % s(8) % c(4) = 2.0d0 * ht/(Re*hy**2)
         self % s(8) % p(4) = -Nx

         ! ass
         self % s(8) % c(5) = -(1.0d0/5.0d0)*(ht/(Re*hy**2))
         self % s(8) % p(5) = -2*Nx
         !------- 8 = N (North) -------

         !------- 9 = NE (North East) -------
         IF ( .NOT. ALLOCATED( self % s(9) % c ) )    ALLOCATE( self % s(9) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(9) % p ) )    ALLOCATE( self % s(9) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(9) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 5.0d0 * ht/(Re*hy**2)
         self % s(9) % p(1) = 0

         ! aw
         self % s(9) % c(2) =  ht/(Re*hx**2)
         self % s(9) % p(2) = -1

         ! as
         self % s(9) % c(3) = 2.0d0 * ht/(Re*hy**2)
         self % s(9) % p(3) = -Nx

         ! ass
         self % s(9) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hy**2))
         self % s(9) % p(4) = -2*Nx
         !------- 9 = NE (North East) -------

      END SUBROUTINE stencils_u

! STENCILS V ------------------------------------------------------------------------------------------------------------------------------------------

      SUBROUTINE stencils_v( self, alfa2 )

         CLASS (MatrizA), INTENT(INOUT) :: self

         INTEGER :: Nx, Ny
         DOUBLE PRECISION :: Re, ht, hx, hy
         DOUBLE PRECISION, INTENT(IN) :: alfa2

         ! Apenas para ficar mais clean o codigo abaixo
         hx = self % hx
         hy = self % hy
         ht = self % ht
         Re = self % Re
         Nx = self % Nx

         ! Sao nove stencils
         ! 1 = SW (South West)
         ! 2 = S  (South)
         ! 3 = SE (South East)
         ! 4 = W  (West)
         ! 5 = C  (Central)
         ! 6 = E  (East)
         ! 7 = NW (North West)
         ! 8 = N  (North)
         ! 9 = NE (North East)

         !------- 1 = SW (South West) -------
         IF ( .NOT. ALLOCATED( self % s(1) % c ) )    ALLOCATE( self % s(1) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(1) % p ) )    ALLOCATE( self % s(1) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(1) % c(1) = alfa2 + 5.0d0*(ht/(Re*hx**2)) + 2.0d0 * ht/(Re*hy**2)
         self % s(1) % p(1) = 0

         ! ae
         self % s(1) % c(2) = 2.0d0 * ht/(Re*hx**2)
         self % s(1) % p(2) = 1

         ! an
         self % s(1) % c(3) = ht/(Re*hy**2)
         self % s(1) % p(3) = Nx

         !aee
         self % s(1) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hx**2))
         self % s(1) % p(4) = 2
         !------- 1 = SW (South West) -------

         !------- 2 = S (South) -------
         IF ( .NOT. ALLOCATED( self % s(2) % c ) )    ALLOCATE( self % s(2) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(2) % p ) )    ALLOCATE( self % s(2) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(2) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 2.0d0 * ht/(Re*hy**2)
         self % s(2) % p(1) = 0

         ! aw
         self % s(2) % c(2) = ht/(Re*hx**2)
         self % s(2) % p(2) = -1

         ! ae
         self % s(2) % c(3) = ht/(Re*hx**2)
         self % s(2) % p(3) = 1

         ! an
         self % s(2) % c(4) = ht/(Re*hy**2)
         self % s(2) % p(4) = Nx

         !------- 2 = S (South) -------

         !------- 3 = SE (South East) -------
         IF ( .NOT. ALLOCATED( self % s(3) % c ) )    ALLOCATE( self % s(3) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(3) % p ) )    ALLOCATE( self % s(3) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(3) % c(1) = alfa2 + 5.0d0*(ht/(Re*hx**2)) + 2.0d0 * ht/(Re*hy**2)
         self % s(3) % p(1) = 0

         ! aw
         self % s(3) % c(2) = 2.0d0 * ht/(Re*hx**2)
         self % s(3) % p(2) = -1

         ! an
         self % s(3) % c(3) = ht/(Re*hy**2)
         self % s(3) % p(3) = Nx

         ! aww
         self % s(3) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hx**2))
         self % s(3) % p(4) = -2
         !------- 3 = SE (South East) -------

         !------- 4 = W (West) -------
         IF ( .NOT. ALLOCATED( self % s(4) % c ) )    ALLOCATE( self % s(4) % c(5) )
         IF ( .NOT. ALLOCATED( self % s(4) % p ) )    ALLOCATE( self % s(4) % p(5) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(4) % c(1) = alfa2 + 5.0d0*(ht/(Re*hx**2)) + 2.0d0 * ht/(Re*hy**2)
         self % s(4) % p(1) = 0

         ! ae
         self % s(4) % c(2) = 2.0d0 * ht/(Re*hx**2)
         self % s(4) % p(2) = 1

         ! as
         self % s(4) % c(3) = ht/(Re*hy**2)
         self % s(4) % p(3) = -Nx

         ! an
         self % s(4) % c(4) = ht/(Re*hy**2)
         self % s(4) % p(4) = Nx

         ! aee
         self % s(4) % c(5) = -(1.0d0/5.0d0)*(ht/(Re*hx**2))
         self % s(4) % p(5) = 2
         !------- 4 = W (West) -------

         !------- 5 = C (Central) -------
         IF ( .NOT. ALLOCATED( self % s(5) % c ) )    ALLOCATE( self % s(5) % c(5) )
         IF ( .NOT. ALLOCATED( self % s(5) % p ) )    ALLOCATE( self % s(5) % p(5) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(5) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 2.0d0 * ht/(Re*hy**2)
         self % s(5) % p(1) = 0

         ! aw
         self % s(5) % c(2) = ht/(Re*hx**2)
         self % s(5) % p(2) = -1

         ! ae
         self % s(5) % c(3) = ht/(Re*hx**2)
         self % s(5) % p(3) = 1

         ! as
         self % s(5) % c(4) = ht/(Re*hy**2)
         self % s(5) % p(4) = -Nx

         ! an
         self % s(5) % c(5) = ht/(Re*hy**2)
         self % s(5) % p(5) = Nx
         !------- 5 = C (Central) -------

         !------- 6 = E (East) -------
         IF ( .NOT. ALLOCATED( self % s(6) % c ) )    ALLOCATE( self % s(6) % c(5) )
         IF ( .NOT. ALLOCATED( self % s(6) % p ) )    ALLOCATE( self % s(6) % p(5) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(6) % c(1) = alfa2 + 5.0d0*(ht/(Re*hx**2)) + 2.0d0 * ht/(Re*hy**2)
         self % s(6) % p(1) = 0

         ! aw
         self % s(6) % c(2) = 2.0d0 * ht/(Re*hx**2)
         self % s(6) % p(2) = -1

         ! as
         self % s(6) % c(3) = ht/(Re*hy**2)
         self % s(6) % p(3) = -Nx

         ! an
         self % s(6) % c(4) = ht/(Re*hy**2)
         self % s(6) % p(4) = Nx

         ! aww
         self % s(6) % c(5) = -(1.0d0/5.0d0)*(ht/(Re*hx**2))
         self % s(6) % p(5) = -2
         !------- 6 = E (East) -------

         !------- 7 = NW (North West) -------
         IF ( .NOT. ALLOCATED( self % s(7) % c ) )    ALLOCATE( self % s(7) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(7) % p ) )    ALLOCATE( self % s(7) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(7) % c(1) = alfa2 + 5.0d0*(ht/(Re*hx**2)) + 2.0d0 * ht/(Re*hy**2)
         self % s(7) % p(1) = 0

         ! ae
         self % s(7) % c(2) =  2.0d0 * ht/(Re*hx**2)
         self % s(7) % p(2) = 1

         ! as
         self % s(7) % c(3) =  ht/(Re*hy**2)
         self % s(7) % p(3) = -Nx

         ! aee
         self % s(7) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hx**2))
         self % s(7) % p(4) = 2
         !------- 7 = NW (North West) -------

         !------- 8 = N (North) -------
         IF ( .NOT. ALLOCATED( self % s(8) % c ) )    ALLOCATE( self % s(8) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(8) % p ) )    ALLOCATE( self % s(8) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(8) % c(1) = alfa2 + 2.0d0 * ht/(Re*hx**2) + 2.0d0 * ht/(Re*hy**2)
         self % s(8) % p(1) = 0

         ! aw
         self % s(8) % c(2) = ht/(Re*hx**2)
         self % s(8) % p(2) = -1

         ! ae
         self % s(8) % c(3) =  ht/(Re*hx**2)
         self % s(8) % p(3) = 1

         ! as
         self % s(8) % c(4) =  ht/(Re*hy**2)
         self % s(8) % p(4) = -Nx

         !------- 8 = N (North) -------

         !------- 9 = NE (North East) -------
         IF ( .NOT. ALLOCATED( self % s(9) % c ) )    ALLOCATE( self % s(9) % c(4) )
         IF ( .NOT. ALLOCATED( self % s(9) % p ) )    ALLOCATE( self % s(9) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(9) % c(1) =  alfa2 + 5.0d0*(ht/(Re*hx**2)) + 2.0d0 * ht/(Re*hy**2)
         self % s(9) % p(1) = 0

         ! aw
         self % s(9) % c(2) = 2.0d0 * ht/(Re*hx**2)
         self % s(9) % p(2) = -1

         ! as
         self % s(9) % c(3) = ht/(Re*hy**2)
         self % s(9) % p(3) = -Nx

         ! aww
         self % s(9) % c(4) = -(1.0d0/5.0d0)*(ht/(Re*hx**2))
         self % s(9) % p(4) = -2
         !------- 9 = NE (North East) -------

      END SUBROUTINE stencils_v

! STENCILS P ------------------------------------------------------------------------------------------------------------------------------------------

      SUBROUTINE stencils_p( self )

         CLASS (MatrizA), INTENT(INOUT) :: self

         INTEGER :: Nx, Ny
         DOUBLE PRECISION :: hx, hy

         ! Apenas para ficar mais clean o codigo abaixo
         hx = self % hx
         hy = self % hy
         Nx = self % Nx

         ! Sao nove stencils
         ! 1 = SW (South West)
         ! 2 = S  (South)
         ! 3 = SE (South East)
         ! 4 = W  (West)
         ! 5 = C  (Central)
         ! 6 = E  (East)
         ! 7 = NW (North West)
         ! 8 = N  (North)
         ! 9 = NE (North East)

         !------- 1 = SW (South West) -------
         ALLOCATE( self % s(1) % c(3) )
         ALLOCATE( self % s(1) % p(3) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(1) % c(1) = 1.0d0/(hx**2) + 1.0d0/(hy**2)
         self % s(1) % p(1) = 0

         ! ae
         self % s(1) % c(2) = 1.0d0/(hx**2)
         self % s(1) % p(2) = 1

         ! an
         self % s(1) % c(3) = 1.0d0/(hy**2)
         self % s(1) % p(3) = Nx

         !------- 1 = SW (South West) -------

         !------- 2 = S (South) -------
         ALLOCATE( self % s(2) % c(4) )
         ALLOCATE( self % s(2) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(2) % c(1) = 2.0d0/(hx**2) + 1.0d0/(hy**2)
         self % s(2) % p(1) = 0

         ! aw
         self % s(2) % c(2) = 1.0d0/(hx**2)
         self % s(2) % p(2) = -1

         ! ae
         self % s(2) % c(3) =  1.0d0/(hx**2)
         self % s(2) % p(3) = 1

         ! an
         self % s(2) % c(4) = 1.0d0/(hy**2)
         self % s(2) % p(4) = Nx

         !------- 2 = S (South) -------

         !------- 3 = SE (South East) -------
         ALLOCATE( self % s(3) % c(3) )
         ALLOCATE( self % s(3) % p(3) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(3) % c(1) = 1.0d0/(hx**2) + 1.0d0/(hy**2)
         self % s(3) % p(1) = 0

         ! aw
         self % s(3) % c(2) = 1.0d0/(hx**2)
         self % s(3) % p(2) = -1

         ! an
         self % s(3) % c(3) =  1.0d0/(hy**2)
         self % s(3) % p(3) = Nx
         !------- 3 = SE (South East) -------

         !------- 4 = W (West) -------
         ALLOCATE( self % s(4) % c(4) )
         ALLOCATE( self % s(4) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(4) % c(1) = 1.0d0/(hx**2) + 2.0d0/(hy**2)
         self % s(4) % p(1) = 0

         ! ae
         self % s(4) % c(2) = 1.0d0/(hx**2)
         self % s(4) % p(2) = 1

         ! as
         self % s(4) % c(3) = 1.0d0/(hy**2)
         self % s(4) % p(3) = -Nx

         ! an
         self % s(4) % c(4) = 1.0d0/(hy**2)
         self % s(4) % p(4) = Nx
         !------- 4 = W (West) -------

         !------- 5 = C (Central) -------
         ALLOCATE( self % s(5) % c(5) )
         ALLOCATE( self % s(5) % p(5) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(5) % c(1) = 2.0d0/(hx**2) + 2.0d0/(hy**2)
         self % s(5) % p(1) = 0

         ! aw
         self % s(5) % c(2) = 1.0d0/(hx**2)
         self % s(5) % p(2) = -1

         ! ae
         self % s(5) % c(3) = 1.0d0/(hx**2)
         self % s(5) % p(3) = 1

         ! as
         self % s(5) % c(4) = 1.0d0/(hy**2)
         self % s(5) % p(4) = -Nx

         ! an
         self % s(5) % c(5) = 1.0d0/(hy**2)
         self % s(5) % p(5) = Nx
         !------- 5 = C (Central) -------

         !------- 6 = E (East) -------
         ALLOCATE( self % s(6) % c(4) )
         ALLOCATE( self % s(6) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(6) % c(1) = 1.0d0/(hx**2) + 2.0d0/(hy**2)
         self % s(6) % p(1) = 0

         ! aw
         self % s(6) % c(2) = 1.0d0/(hx**2)
         self % s(6) % p(2) = -1

         ! as
         self % s(6) % c(3) = 1.0d0/(hy**2)
         self % s(6) % p(3) = -Nx

         ! an
         self % s(6) % c(4) = 1.0d0/(hy**2)
         self % s(6) % p(4) = Nx
         !------- 6 = E (East) -------

         !------- 7 = NW (North West) -------
         ALLOCATE( self % s(7) % c(3) )
         ALLOCATE( self % s(7) % p(3) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(7) % c(1) = 1.0d0/(hx**2) + 1.0d0/(hy**2)
         self % s(7) % p(1) = 0

         ! ae
         self % s(7) % c(2) = 1.0d0/(hx**2)
         self % s(7) % p(2) = 1

         ! as
         self % s(7) % c(3) =  1.0d0/(hy**2)
         self % s(7) % p(3) = -Nx

         !------- 7 = NW (North West) -------

         !------- 8 = N (North) -------
         ALLOCATE( self % s(8) % c(4) )
         ALLOCATE( self % s(8) % p(4) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(8) % c(1) = 2.0d0/(hx**2) + 1.0d0/(hy**2)
         self % s(8) % p(1) = 0

         ! aw
         self % s(8) % c(2) = 1.0d0/(hx**2)
         self % s(8) % p(2) = -1

         ! ae
         self % s(8) % c(3) = 1.0d0/(hx**2)
         self % s(8) % p(3) = 1

         ! as
         self % s(8) % c(4) = 1.0d0/(hy**2)
         self % s(8) % p(4) = -Nx
         !------- 8 = N (North) -------

         !------- 9 = NE (North East) -------
         ALLOCATE( self % s(9) % c(3) )
         ALLOCATE( self % s(9) % p(3) )

         ! ap (sempre na primeira posicao dos coeficientes)
         self % s(9) % c(1) = 1.0d0/(hx**2) + 1.0d0/(hy**2)
         self % s(9) % p(1) = 0

         ! aw
         self % s(9) % c(2) = 1.0d0/(hx**2)
         self % s(9) % p(2) = -1

         ! as
         self % s(9) % c(3) = 1.0d0/(hy**2)
         self % s(9) % p(3) = -Nx
         !------- 9 = NE (North East) -------

      END SUBROUTINE stencils_p

END MODULE ClassMatrizA


      SUBROUTINE CATRMV( UPLO, TRANS, DIAG, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
*  -- PBLAS auxiliary routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        DIAG, TRANS, UPLO
      INTEGER            INCX, INCY, LDA, N
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      REAL               Y( * )
      COMPLEX            A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  CATRMV performs one of the matrix-vector operations
*
*     y := abs( alpha )*abs( A )*abs( x )+ abs( beta*y ),
*
*     or
*
*     y := abs( alpha )*abs( A' )*abs( x ) + abs( beta*y ),
*
*     or
*
*     y := abs( alpha )*abs( conjg( A' ) )*abs( x ) + abs( beta*y ),
*
*  where  alpha  and  beta  are real scalars, y is a real vector, x is a
*  vector and A is an n by n unit or non-unit, upper or lower triangular
*  matrix.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          On entry,  UPLO  specifies  whether the matrix is an upper or
*          lower triangular matrix as follows:
*
*             UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*             UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*  TRANS   (input) CHARACTER*1
*          On entry,  TRANS  specifies  the operation to be performed as
*          follows:
*
*             TRANS = 'N' or 'n':
*                y := abs( alpha )*abs( A )*abs( x )+ abs( beta*y )
*
*             TRANS = 'T' or 't':
*                y := abs( alpha )*abs( A' )*abs( x ) + abs( beta*y )
*
*             TRANS = 'C' or 'c':
*                y := abs( alpha )*abs( conjg( A' ) )*abs( x ) +
*                     abs( beta*y )
*
*  DIAG    (input) CHARACTER*1
*          On entry, DIAG  specifies whether or not A is unit triangular
*          as follows:
*
*             DIAG = 'U' or 'u'  A is assumed to be unit triangular.
*
*             DIAG = 'N' or 'n'  A is not assumed to be unit triangular.
*
*  N       (input) INTEGER
*          On entry, N specifies the order of the matrix A. N must be at
*          least zero.
*
*  ALPHA   (input) REAL
*          On entry, ALPHA specifies the real scalar alpha.
*
*  A       (input) COMPLEX array
*          On entry,  A  is an array of dimension (LDA,N).  Before entry
*          with UPLO = 'U' or 'u', the leading n by n part of the  array
*          A must contain the upper triangular part of the matrix A  and
*          the  strictly  lower  triangular part of A is not referenced.
*          When  UPLO = 'L' or 'l', the leading n by n part of the array
*          A  must contain the lower triangular part of the matrix A and
*          the  strictly  upper trapezoidal part of A is not referenced.
*          Note that when  DIAG = 'U' or 'u', the diagonal elements of A
*          are not referenced either, but are assumed to be unity.
*
*  LDA     (input) INTEGER
*          On entry, LDA specifies the leading dimension of the array A.
*          LDA must be at least max( 1, N ).
*
*  X       (input) COMPLEX array of dimension at least
*          ( 1 + ( n - 1 )*abs( INCX ) ).  Before entry, the incremented
*          array X must contain the vector x.
*
*  INCX    (input) INTEGER
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero.
*
*  BETA    (input) REAL
*          On entry,  BETA  specifies the real scalar beta. When BETA is
*          supplied as zero then Y need not be set on input.
*
*  Y       (input/output) REAL array of dimension at least
*          ( 1 + ( n - 1 )*abs( INCY ) ).  Before  entry with  BETA non-
*          zero, the  incremented array  Y must contain the vector y. On
*          exit, the  incremented array  Y is overwritten by the updated
*          vector y.
*
*  INCY    (input) INTEGER
*          On entry, INCY specifies the increment for the elements of Y.
*          INCY must not be zero.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY
      LOGICAL            NOUNIT
      REAL               ABSX, TALPHA, TEMP
      COMPLEX            ZDUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, MAX, REAL
*     ..
*     .. Statement Functions ..
      REAL               CABS1
      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 7
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 9
      ELSE IF( INCY.EQ.0 ) THEN
         INFO = 12
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CATRMV', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
      NOUNIT = LSAME( DIAG , 'N' )
*
*     Set up the start points in  X  and  Y.
*
      IF( INCX.GT.0 ) THEN
         KX = 1
      ELSE
         KX = 1 - ( N - 1 ) * INCX
      END IF
      IF( INCY.GT.0 ) THEN
         KY = 1
      ELSE
         KY = 1 - ( N - 1 ) * INCY
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
*     First form  y := abs( beta*y ).
*
      IF( INCY.EQ.1 ) THEN
         IF( BETA.EQ.ZERO ) THEN
            DO 10, I = 1, N
               Y( I ) = ZERO
   10       CONTINUE
         ELSE IF( BETA.EQ.ONE ) THEN
            DO 20, I = 1, N
               Y( I ) = ABS( Y( I ) )
   20       CONTINUE
         ELSE
            DO 30, I = 1, N
               Y( I ) = ABS( BETA * Y( I ) )
   30       CONTINUE
         END IF
      ELSE
         IY = KY
         IF( BETA.EQ.ZERO ) THEN
            DO 40, I = 1, N
               Y( IY ) = ZERO
               IY      = IY + INCY
   40       CONTINUE
         ELSE IF( BETA.EQ.ONE ) THEN
            DO 50, I = 1, N
               Y( IY ) = ABS( Y( IY ) )
               IY      = IY + INCY
   50       CONTINUE
         ELSE
            DO 60, I = 1, N
               Y( IY ) = ABS( BETA * Y( IY ) )
               IY      = IY + INCY
   60       CONTINUE
         END IF
      END IF
*
      IF( ALPHA.EQ.ZERO )
     $   RETURN
*
      TALPHA = ABS( ALPHA )
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  y := abs( alpha ) * abs( A ) * abs( x ) + y.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            JX = KX
            IF( INCY.EQ.1 ) THEN
               DO 80, J = 1, N
                  ABSX = CABS1( X( JX ) )
                  IF( ABSX.NE.ZERO ) THEN
                     TEMP = TALPHA * ABSX
                     DO 70, I = 1, J - 1
                        Y( I ) = Y( I ) + TEMP * CABS1( A( I, J ) )
   70                CONTINUE
*
                     IF( NOUNIT ) THEN
                        Y( J ) = Y( J ) + TEMP * CABS1( A( J, J ) )
                     ELSE
                        Y( J ) = Y( J ) + TEMP
                     END IF
                  END IF
                  JX = JX + INCX
   80          CONTINUE
*
            ELSE
*
               DO 100, J = 1, N
                  ABSX = CABS1( X( JX ) )
                  IF( ABSX.NE.ZERO ) THEN
                     TEMP = TALPHA * ABSX
                     IY   = KY
                     DO 90, I = 1, J - 1
                        Y( IY ) = Y( IY ) + TEMP * CABS1( A( I, J ) )
                        IY      = IY      + INCY
   90                CONTINUE
*
                     IF( NOUNIT ) THEN
                        Y( IY ) = Y( IY ) + TEMP * CABS1( A( J, J ) )
                     ELSE
                        Y( IY ) = Y( IY ) + TEMP
                     END IF
                  END IF
                  JX = JX + INCX
  100          CONTINUE
*
            END IF
*
         ELSE
*
            JX = KX
            IF( INCY.EQ.1 ) THEN
               DO 120, J = 1, N
                  ABSX = CABS1( X( JX ) )
                  IF( ABSX.NE.ZERO ) THEN
*
                     TEMP = TALPHA * ABSX
*
                     IF( NOUNIT ) THEN
                        Y( J ) = Y( J ) + TEMP * CABS1( A( J, J ) )
                     ELSE
                        Y( J ) = Y( J ) + TEMP
                     END IF
*
                     DO 110, I = J + 1, N
                        Y( I ) = Y( I ) + TEMP * CABS1( A( I, J ) )
  110                CONTINUE
                  END IF
                  JX = JX + INCX
  120          CONTINUE
*
            ELSE
*
               DO 140, J = 1, N
                  ABSX = CABS1( X( JX ) )
                  IF( ABSX.NE.ZERO ) THEN
                     TEMP = TALPHA * ABSX
                     IY   = KY + ( J - 1 ) * INCY
*
                     IF( NOUNIT ) THEN
                        Y( IY ) = Y( IY ) + TEMP * CABS1( A( J, J ) )
                     ELSE
                        Y( IY ) = Y( IY ) + TEMP
                     END IF
*
                     DO 130, I = J + 1, N
                        IY      = IY      + INCY
                        Y( IY ) = Y( IY ) + TEMP * CABS1( A( I, J ) )
  130                CONTINUE
                  END IF
                  JX = JX + INCX
  140          CONTINUE
*
            END IF
*
         END IF
*
      ELSE
*
*        Form  y := abs( alpha ) * abs( A' ) * abs( x ) + y.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            JY = KY
            IF( INCX.EQ.1 ) THEN
               DO 160, J = 1, N
*
                  TEMP = ZERO
*
                  DO 150, I = 1, J - 1
                     TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( I ) )
  150             CONTINUE
*
                  IF( NOUNIT ) THEN
                     TEMP = TEMP + CABS1( A( J, J ) ) * CABS1( X( J ) )
                  ELSE
                     TEMP = TEMP + CABS1( X( J ) )
                  END IF
*
                  Y( JY ) = Y( JY ) + TALPHA * TEMP
                  JY      = JY      + INCY
*
  160          CONTINUE
*
            ELSE
*
               DO 180, J = 1, N
                  TEMP = ZERO
                  IX   = KX
                  DO 170, I = 1, J - 1
                     TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( IX ) )
                     IX   = IX   + INCX
  170             CONTINUE
*
                  IF( NOUNIT ) THEN
                     TEMP = TEMP + CABS1( A( J, J ) ) * CABS1( X( IX ) )
                  ELSE
                     TEMP = TEMP + CABS1( X( IX ) )
                  END IF
*
                  Y( JY ) = Y( JY ) + TALPHA * TEMP
                  JY      = JY      + INCY
*
  180          CONTINUE
*
            END IF
*
         ELSE
*
            JY = KY
            IF( INCX.EQ.1 ) THEN
*
               DO 200, J = 1, N
*
                  IF( NOUNIT ) THEN
                     TEMP = CABS1( A( J, J ) ) * CABS1( X( J ) )
                  ELSE
                     TEMP = CABS1( X( J ) )
                  END IF
*
                  DO 190, I = J + 1, N
                     TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( I ) )
  190             CONTINUE
*
                  Y( JY ) = Y( JY ) + TALPHA * TEMP
                  JY      = JY      + INCY
*
  200          CONTINUE
*
            ELSE
*
               DO 220, J = 1, N
*
                  IX   = KX + ( J - 1 ) * INCX
*
                  IF( NOUNIT ) THEN
                     TEMP = CABS1( A( J, J ) ) * CABS1( X( IX ) )
                  ELSE
                     TEMP = CABS1( X( IX ) )
                  END IF
*
                  DO 210, I = J + 1, N
                     IX   = IX   + INCX
                     TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( IX ) )
  210             CONTINUE
                  Y( JY ) = Y( JY ) + TALPHA * TEMP
                  JY      = JY      + INCY
  220          CONTINUE
            END IF
         END IF
*
      END IF
*
      RETURN
*
*     End of CATRMV
*
      END


!> @ingroup interchange_sort_gen
!>
!> @brief
!> Run an interchange sort on a vector of integer values.
!>
!> @details
!> Run the specified on a vector of integer values to sort them in the specified order.The vector of intergers map is permuted in the same way that the vector vec is permuted to be sorted. It is important that map be at least as long as vec.
!>
!> @param vec
!> The vector integer values to be sorted.
!>
!> @param map
!> Vector of intergers which is permuted in the same way that vec is permuted. If map is a vector of values 1 to N, where N is the length of vec, than, map is the map from vec's original value to vec's final value after the sort.
!>
!> @param ord
!> A logical function which describes the ordering used. The function must take two integer arguments and return true if and only if the first argument must proceed the second argument in the order.
!>
!> @warning
!> The argument types and counts of ord are not checked within this subroutine.
!>
!> @warning
!> The length of map is not checked within this subroutine. If the length of vec is larger than the length of map, than this subroutine may attempt to access elements outside of map.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014
subroutine interchange_sort_gen_map_int(vec,map,ord)
  ! Arguments
  integer, intent(inout) :: vec(:)
  integer, intent(inout) :: map(:)
  procedure(logical) :: ord

  ! Variables
  integer :: i
  integer :: j
  integer :: swap_value
  integer :: swap_value

  ! The interchange sort
  do i = 1,size(vec,1) - 1
     do j = i + 1,size(vec,1)
        if (ord(vec(i),vec(j))) then
           ! Swap integer values vec(i) and vec(j).
           swap_value = vec(i)
           vec(i) = vec(j)
           vec(j) = swap_value
            ! Swap integer values map(i) and map(j).
            swap_value = map(i)
            map(i) = map(j)
            map(j) = swap_value
        end if
     end do
  end do
end subroutine interchange_sort_gen_map_int


C NCLFORTSTART
      subroutine wksmooth121 (vv,vn,nn,spv,dum)
      implicit none
      integer nn,vn
      double precision vv(vn), spv, dum(vn)
C NCLEND

c NCL procedure:   wk_smooth121( x )

c vv  - input and output
c vn  - length of vv
c nn  - length of vv ... near as I can tell
c spv - missing value
c dum - work array same length as vv

c Smooths vv by passing it through a 1-2-1 filter.
c The first and last points are given 3-1 (1st) or 1-3 (last)
c weightings (Note that this conserves the total sum).
c The routine also skips-over missing data (spv)
c There are 'nn' pieces of useful information, which may be less
c than or equal to 'vn'.

      integer i

      i = 0
 10   continue
      i = i+1
      if (vv(i).eq.spv) then
          dum(i) = spv
      elseif(i.eq.1) then
          if(vv(i+1).ne.spv) then
             dum(i) = (3.0d0*vv(i)+vv(i+1))/4.0d0
          else
             dum(i) = vv(i)
          end if
      elseif(vv(i-1).eq.spv) then
          if(vv(i+1).ne.spv) then
             dum(i) = (3.0d0*vv(i)+vv(i+1))/4.0d0
          else
             dum(i) = vv(i)
          end if
      elseif(i.eq.nn.or.vv(i+1).eq.spv) then
          if(vv(i-1).ne.spv) then
             dum(i) = (vv(i-1)+3.0d0*vv(i))/4.0d0
          else
             dum(i) = vv(i)
          end if
      else
           dum(i) = (1.0d0*vv(i-1)+2.0d0*vv(i)+1.0d0*vv(i+1))/4.0d0
      end if
      if (i.ne.nn) go to 10

      do i = 1,nn
         vv(i) = dum(i)
      end do
      end


module pde3d_exp_mod
  use psb_base_mod, only : psb_dpk_
  real(psb_dpk_), save, private :: epsilon=1.d0/80
contains
  subroutine pde3d_set_parm(dat)
    real(psb_dpk_), intent(in) :: dat
    epsilon = dat
  end subroutine pde3d_set_parm
  !
  ! functions parametrizing the differential equation
  !
  function b1(x,y,z)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) :: b1
    real(psb_dpk_), intent(in) :: x,y,z
    b1=1.d0/sqrt(3.d0)-exp(-(x+y+z))
  end function b1
  function b2(x,y,z)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  b2
    real(psb_dpk_), intent(in) :: x,y,z
    b2=1.d0/sqrt(3.d0)-exp(-(x+y+z))
  end function b2
  function b3(x,y,z)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  b3
    real(psb_dpk_), intent(in) :: x,y,z
    b3=1.d0/sqrt(3.d0)-exp(-(x+y+z))
  end function b3
  function c(x,y,z)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  c
    real(psb_dpk_), intent(in) :: x,y,z
    c=0.d0
  end function c
  function a1(x,y,z)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  a1
    real(psb_dpk_), intent(in) :: x,y,z
    a1=epsilon*exp(-(x+y+z))
  end function a1
  function a2(x,y,z)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  a2
    real(psb_dpk_), intent(in) :: x,y,z
    a2=epsilon*exp(-(x+y+z))
  end function a2
  function a3(x,y,z)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  a3
    real(psb_dpk_), intent(in) :: x,y,z
    a3=epsilon*exp(-(x+y+z))
  end function a3
  function g(x,y,z)
    use psb_base_mod, only : psb_dpk_, done, dzero
    real(psb_dpk_) ::  g
    real(psb_dpk_), intent(in) :: x,y,z
    g = dzero
    if (x == done) then
      g = done
    else if (x == dzero) then
      g = done
    end if
  end function g
end module pde3d_exp_mod