!
! Linear_Interpolation
!
! Module containing linear interpolation routines
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 06-Oct-2006
!                       paul.vandelst@ssec.wisc.edu
!

MODULE Linear_Interpolation

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Modules used
  USE Type_Kinds,      ONLY: fp=>fp_kind
  USE Message_Handler, ONLY: SUCCESS, FAILURE, Display_Message
  USE Search_Utility,  ONLY: Value_Locate, Bisection_Search
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Linear_Interpolate

  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE Linear_Interpolate
    MODULE PROCEDURE linint_scalar
    MODULE PROCEDURE linint_rank1
  END INTERFACE Linear_Interpolate

  ! -----------------
  ! Module parameters
  ! -----------------
  ! RCS Id field
  CHARACTER(*), PRIVATE, PARAMETER :: MODULE_RCS_ID = &
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp

CONTAINS

!--------------------------------------------------------------------------------
!
! NAME:
!       Linear_Interpolate
!
! PURPOSE:
!       Function to perform linear interpolation on input scalars
!       or vectors.
!
! CALLING SEQUENCE:
!       Error_Status = Linear_Interpolate( x,                      &  ! Input
!                                          y,                      &  ! Input
!                                          x_int,                  &  ! Input
!                                          y_int,                  &  ! Output
!                                          RCS_Id     =RCS_Id,     &  ! Optional output
!                                          Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       x:            The abscissa values for the tabulated function, y=F(x).
!                     Must be monotonically ascending or descending values.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
!       y:            An input vector of tabulated values, y=F(x), for which
!                     interpolates are required. Must have the same number of
!                     elements as the X input argument.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array, same as x.
!                     ATTRIBUTES: INTENT(IN)
!
!       x_int:        Abscissa values for which interpolates are required.
!                     Must be monotonically ascending or descending in the
!                     same direction as the X input argument.
!                     UNITS:      Data dependent, same as x.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar or Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:  Character string specifying a filename in which any
!                     messages will be logged. If not specified, or if an
!                     error occurs opening the log file, the default action
!                     is to output messages to the screen.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       y_int:        Interpolate values corresponding to the X_INT abscissa
!                     values. Must have the same number of elements as the
!                     X_INT input argument.
!                     UNITS:      Data dependent, same as y.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar or Rank-1 array, same as x_int.
!                     ATTRIBUTES: INTENT(IN)
!
!
! OPTIONAL OUTPUT ARGUMENTS:
!       RCS_Id:       Character string containing the Revision Control System
!                     Id field for the module.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status: The return value is an integer defining the error status.
!                     The error codes are defined in the Message_Handler module.
!                     If == SUCCESS the function executed normally.
!                        == FAILURE an unrecoverable error occurred.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!
! RESTRICTIONS:
!       Input X and X_INT vectors *must* be monotonically ascending
!       or descending in the same direction.
!
! PROCEDURE:
!       The function computes the interpolates like so:
!
!                  y2 - y1
!         y_int = ---------.(x - x1) + y1
!                  x2 - x1
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 06-Oct-2006
!                       paul.vandelst@ssec.wisc.edu
!
!S-
!--------------------------------------------------------------------------------

  FUNCTION linint_scalar( x,            &  ! Input
                          y,            &  ! Input
                          x_int,        &  ! Input
                          y_int,        &  ! Output
                          x_idx,        &  ! Optional input
                          RCS_Id,       &  ! Optional output
                          Message_Log ) &  ! Error messaging
                        RESULT( Error_Status )
    ! Arguments
    REAL(fp), DIMENSION(:), INTENT(IN)  :: y
    REAL(fp), DIMENSION(:), INTENT(IN)  :: x
    REAL(fp),               INTENT(IN)  :: x_int
    REAL(fp),               INTENT(OUT) :: y_int
    INTEGER,      OPTIONAL, INTENT(IN)  :: x_idx
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Linear_Interpolate(scalar)'
    ! Local variables
    INTEGER :: nPoints
    INTEGER :: i

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS
    IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_Id

    ! Check array sizes for consistency
    nPoints = SIZE(x)
    IF ( nPoints /= SIZE(y) ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X and Y vectors have different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! Check that input array is large enough
    IF ( nPoints < 2 ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X and Y arrays must have 2 or '//&
                            'more points for linear interpolation', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! -----------------------------------------------------
    ! Find the locations for which interpolates are desired
    ! -----------------------------------------------------
    ! Result is the lower index, i.e. x(i) < x_int < x(i+1)
    IF ( PRESENT(x_idx) ) THEN
      i = x_idx
    ELSE
      i = Bisection_Search(x, x_int)
    END IF

    ! -------------------------
    ! Perform the interpolation
    ! -------------------------
    y_int = ((y(i+1)-y(i))/(x(i+1)-x(i)))*(x_int-x(i)) + y(i)

  END FUNCTION linint_scalar

  FUNCTION linint_rank1( x,            &  ! Input
                         y,            &  ! Input
                         x_int,        &  ! Input
                         y_int,        &  ! Output
                         x_idx,        &  ! Optional input
                         RCS_Id,       &  ! Optional output
                         Message_Log ) &  ! Error messaging
                       RESULT( Error_Status )
    ! Arguments
    REAL(fp), DIMENSION(:),           INTENT(IN)  :: x
    REAL(fp), DIMENSION(:),           INTENT(IN)  :: y
    REAL(fp), DIMENSION(:),           INTENT(IN)  :: x_int
    REAL(fp), DIMENSION(:),           INTENT(OUT) :: y_int
    INTEGER,  DIMENSION(:), OPTIONAL, INTENT(IN)  :: x_idx
    CHARACTER(*),           OPTIONAL, INTENT(OUT) :: RCS_Id
    CHARACTER(*),           OPTIONAL, INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Linear_Interpolate(rank-1)'
    ! Local variables
    INTEGER :: nPoints, nIntPoints
    INTEGER,  DIMENSION(SIZE(x_int)) :: i

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS
    IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_Id

    ! Check array sizes for consistency
    nPoints = SIZE(x)
    IF ( nPoints /= SIZE(y) ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X and Y vectors have different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF
    nIntPoints = SIZE(x_int)
    IF ( SIZE(y_int) /= nIntPoints ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X_INT and output Y_INT vectors have different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF
    IF ( PRESENT(x_idx) ) THEN
      IF ( SIZE(x_idx) /= nIntPoints ) THEN
        Error_Status = FAILURE
        CALL Display_Message( ROUTINE_NAME, &
                              'Input X_IDX vector has an inconsistent size.', &
                              Error_Status, &
                              Message_Log=Message_Log )
        RETURN
      END IF
    END IF

    ! Check that input array is large enough
    IF ( nPoints < 2 ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X and Y arrays must have 2 or '//&
                            'more points for linear interpolation', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! -----------------------------------------------------
    ! Find the locations for which interpolates are desired
    ! -----------------------------------------------------
    ! Result is the lower index, i.e. x(i) < x_int < x(i+1)
    IF ( PRESENT(x_idx) ) THEN
      i = x_idx
    ELSE
      i = Value_Locate( x, x_int )
    END IF

    ! -------------------------
    ! Perform the interpolation
    ! -------------------------
    y_int = ((y(i+1)-y(i))/(x(i+1)-x(i)))*(x_int-x(i)) + y(i)

  END FUNCTION linint_rank1

END MODULE Linear_Interpolation


!=======================================================================!
! Copyright (c) Intel Corporation - All rights reserved.                !
! This file is part of the LIBXSMM library.                             !
!                                                                       !
! For information on the license, see the LICENSE file.                 !
! Further information: https://github.com/hfp/libxsmm/                  !
! SPDX-License-Identifier: BSD-3-Clause                                 !
!=======================================================================!
! Hans Pabst (Intel Corp.)
!=======================================================================!

      PROGRAM transpose
        USE :: LIBXSMM, ONLY: LIBXSMM_BLASINT_KIND,                     &
     &                        libxsmm_timer_duration,                   &
     &                        libxsmm_timer_tick,                       &
     &                        libxsmm_otrans_omp,                       &
     &                        libxsmm_otrans,                           &
     &                        libxsmm_itrans,                           &
     &                        libxsmm_ptr
        IMPLICIT NONE

        INTEGER, PARAMETER :: T = KIND(0D0)
        INTEGER, PARAMETER :: S = 8

        REAL(T), ALLOCATABLE, TARGET :: a1(:), b1(:)
        !DIR$ ATTRIBUTES ALIGN:64 :: a1, b1
        INTEGER(LIBXSMM_BLASINT_KIND) :: m, n, lda, ldb, i, j, k
        REAL(T), POINTER :: an(:,:), bn(:,:), bt(:,:)
        DOUBLE PRECISION :: duration
        INTEGER(8) :: nbytes, start
        INTEGER :: nrepeat
        REAL(T) :: diff

        CHARACTER(32) :: argv
        CHARACTER :: trans
        INTEGER :: argc

        argc = COMMAND_ARGUMENT_COUNT()
        IF (1 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(1, trans)
        ELSE
          trans = 'o'
        END IF
        IF (2 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(2, argv)
          READ(argv, "(I32)") m
        ELSE
          m = 4096
        END IF
        IF (3 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(3, argv)
          READ(argv, "(I32)") n
        ELSE
          n = m
        END IF
        IF (4 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(4, argv)
          READ(argv, "(I32)") lda
        ELSE
          lda = m
        END IF
        IF (5 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(5, argv)
          READ(argv, "(I32)") ldb
        ELSE
          ldb = n
        END IF
        IF (6 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(6, argv)
          READ(argv, "(I32)") nrepeat
        ELSE
          nrepeat = 3
        END IF

        nbytes = INT(m * n, 8) * T ! size in Byte
        WRITE(*, "(2(A,I0),2(A,I0),A,I0,A)")                            &
     &    "m=", m, " n=", n, " ldi=", lda, " ldo=", ldb,                &
     &    " size=", (nbytes / ISHFT(1, 20)), "MB"

        ALLOCATE(b1(ldb*MAX(m,n)))
        bn(1:ldb,1:n) => b1
        bt(1:ldb,1:m) => b1

        IF (('o'.EQ.trans).OR.('O'.EQ.trans)) THEN
          ALLOCATE(a1(lda*n))
          an(1:lda,1:n) => a1
          !$OMP PARALLEL DO PRIVATE(i, j) DEFAULT(NONE) SHARED(m, n, an)
          DO j = 1, n
            DO i = 1, m
              an(i,j) = initial_value(i - 1, j - 1, m)
            END DO
          END DO
          !$OMP END PARALLEL DO
          start = libxsmm_timer_tick()
          DO k = 1, nrepeat
            CALL libxsmm_otrans_omp(libxsmm_ptr(b1), libxsmm_ptr(a1),   &
     &              S, m, n, lda, ldb)
          END DO
          duration = libxsmm_timer_duration(start, libxsmm_timer_tick())
          DEALLOCATE(a1)
        ELSE ! in-place
          !$OMP PARALLEL DO PRIVATE(i, j) DEFAULT(NONE) SHARED(m, n, bn)
          DO j = 1, n
            DO i = 1, m
              bn(i,j) = initial_value(i - 1, j - 1, m)
            END DO
          END DO
          !$OMP END PARALLEL DO
          start = libxsmm_timer_tick()
          DO k = 1, nrepeat
            CALL libxsmm_itrans(libxsmm_ptr(b1), S, m, n, ldb)
          END DO
          duration = libxsmm_timer_duration(start, libxsmm_timer_tick())
        END IF

        diff = REAL(0, T)
        DO j = 1, n
          DO i = 1, m
            diff = MAX(diff,                                            &
     &                ABS(bt(j,i) - initial_value(i - 1, j - 1, m)))
          END DO
        END DO
        DEALLOCATE(b1)

        IF (0.GE.diff) THEN
          IF ((0.LT.duration).AND.(0.LT.nrepeat)) THEN
            ! out-of-place transpose bandwidth assumes RFO
            WRITE(*, "(1A,A,F10.1,A)") CHAR(9), "bandwidth:  ",         &
     &        REAL(nbytes, T)                                           &
     &        * MERGE(3D0, 2D0, ('o'.EQ.trans).OR.('O'.EQ.trans))       &
     &        * REAL(nrepeat, T) / (duration * REAL(ISHFT(1_8, 30), T)),&
     &        " GB/s"
            WRITE(*, "(1A,A,F10.1,A)") CHAR(9), "duration:   ",         &
     &        1D3 * duration / REAL(nrepeat, T),                        &
     &        " ms"
          END IF
        ELSE
          WRITE(*,*) "Validation failed!"
          STOP 1
        END IF

      CONTAINS
        PURE REAL(T) FUNCTION initial_value(i, j, m)
          INTEGER(LIBXSMM_BLASINT_KIND), INTENT(IN) :: i, j, m
          initial_value = REAL(j * m + i, T)
        END FUNCTION
      END PROGRAM


! Copyright 2005-2017 ECMWF.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!
!  Description: how to get values using keys.
!
!
program get
use grib_api
implicit none

  integer                                         ::  ifile
  integer                                         ::  iret
  integer                                         ::  igrib
  integer                                         ::  i
  real(kind=8)                                    ::  latitudeOfFirstPointInDegrees
  real(kind=8)                                    ::  longitudeOfFirstPointInDegrees
  real(kind=8)                                    ::  latitudeOfLastPointInDegrees
  real(kind=8)                                    ::  longitudeOfLastPointInDegrees
  real(kind=8)                                    ::  jDirectionIncrementInDegrees
  real(kind=8)                                    ::  iDirectionIncrementInDegrees
  integer(kind = 4)                               ::  numberOfPointsAlongAParallel
  integer(kind = 4)                               ::  numberOfPointsAlongAMeridian
  real(kind=8), dimension(:), allocatable         ::  values
  integer(kind = 4)                               ::  numberOfValues
  real(kind=8)                                    ::  average
  character(len = 256)                            ::  error

  call grib_open_file(ifile, &
       '../../data/reduced_latlon_surface.grib1','r')

!     a new grib message is loaded from file
!     igrib is the grib id to be used in subsequent calls
  call  grib_new_from_file(ifile,igrib)

!     get as a integer
  call grib_get(igrib,'numberOfPointsAlongAParallel', &
                               numberOfPointsAlongAParallel)
  write(*,*) 'numberOfPointsAlongAParallel=', &
              numberOfPointsAlongAParallel

!     get as a integer
  call grib_get(igrib,'numberOfPointsAlongAMeridian', &
                                       numberOfPointsAlongAMeridian)
  write(*,*) 'numberOfPointsAlongAMeridian=', &
              numberOfPointsAlongAMeridian

!     get as a real8
call grib_get(igrib, &
                      'latitudeOfFirstGridPointInDegrees', &
                       latitudeOfFirstPointInDegrees)
write(*,*) 'latitudeOfFirstGridPointInDegrees=', &
            latitudeOfFirstPointInDegrees

!     get as a real8
  call grib_get(igrib, &
               'longitudeOfFirstGridPointInDegrees', &
                longitudeOfFirstPointInDegrees)
  write(*,*) 'longitudeOfFirstGridPointInDegrees=', &
     longitudeOfFirstPointInDegrees

!     get as a real8
  call grib_get(igrib, &
     'latitudeOfLastGridPointInDegrees', &
     latitudeOfLastPointInDegrees)
  write(*,*) 'latitudeOfLastGridPointInDegrees=', &
     latitudeOfLastPointInDegrees

!     get as a real8
  call grib_get(igrib, &
     'longitudeOfLastGridPointInDegrees', &
      longitudeOfLastPointInDegrees)
  write(*,*) 'longitudeOfLastGridPointInDegrees=', &
              longitudeOfLastPointInDegrees

!     get as a real8
  call grib_get(igrib, &
                   'jDirectionIncrementInDegrees', &
                    jDirectionIncrementInDegrees)
  write(*,*) 'jDirectionIncrementInDegrees=', &
              jDirectionIncrementInDegrees

!     get as a real8
  call grib_get(igrib, &
       'iDirectionIncrementInDegrees', &
        iDirectionIncrementInDegrees)
  write(*,*) 'iDirectionIncrementInDegrees=', &
              iDirectionIncrementInDegrees

!     get the size of the values array
  call grib_get_size(igrib,'values',numberOfValues)
  write(*,*) 'numberOfValues=',numberOfValues

  allocate(values(2*numberOfValues), stat=iret)
!     get data values
  print*, size(values)
  call grib_get(igrib,'values',values)

  average = 0
  do i=1,numberOfValues
        average = average + values(i);
  enddo

  average =average / numberOfValues

  write(*,*)'There are ',numberOfValues, &
            ' average is ',average

  call grib_release(igrib)

  call grib_close_file(ifile)

  deallocate(values)
end program get


c
c     file tmuh24cr.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the mudpack solver muh24cr
c
c ... required MUDPACK files
c
c     muh24cr.f, muh2cr.f, mudcom.f
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for muh24cr
c
c **********************************************************
c **********************************************************
c
c
c     a sample program/test driver for muh24cr is listed below.  it
c     can be executed as an initial test.  the output is listed
c     for the test case described.
c
c     test muh24cr below by solving the nonseparable elliptic pde
c     with cross derivative term
c
c          (1.+y**2)*pxx + (1.+x**2)*pyy + 2.*x*y*pxy +
c
c          y*px + x*py - (x*y)*pe = r(x,y)
c
c     on a grid as close to 60 by 70 as muh24cr size constraints
c     allow.  the solution region is the unit square.  assume a
c     mixed derivative boundary condition at y=1 of the form
c
c          -x * dp/dx + (1+x) * dp/dy - x * pe = gbdyd(x).
c
c     and specified (Dirchlet) boundary conditions elsewhere.  the
c     exact solution
c
c          p(x,y) = (x*y)**5
c
c     is used to set the right hand side, boundary conditions, and
c     compute the error.
c
c     red/black gauss-seidel point relaxation is used along with the
c     the default multigrid options.  Three multigrid cycles are
c     executed with muh2cr to assure second-order discretization
c     level error for this problem.  muh24cr is then called for
c     a fourth-order estimate.  Choosing grid parameters
c
c       ixp = 15, jyq=9, iex=3,jey=4
c
c     yields a 61 by 73 grid.  The grid coarsening is
c
c       61 X 73 > 31 X 37 > 16 X 19 > 16 X 10
c
c     The coarsest 16 X 10 grid has too much resolution for effective
c     error reduction with relaxation only.  muh24cr uses a direct
c     method whenever the 16 X 10 grid is encountered which maintains
c     multigrid convergence efficiency
c
c ******************************************************
c     output (64 bit floating point arithmetic)
c *******************************************************
c
c     muh2cr test
c
c     integer input arguments
c     intl =  0 nxa =  1 nxb =  1 nyc =  1 nyd =  2
c     ixp = 15 jyq =  9 iex =  3 jey =  5
c     nx =  61 ny = 145 iguess =  0 maxcy =  1
c     method =  0 work space estimate =  149055
c
c     multigrid option arguments
c     kcycle =  2
c     iprer =  2
c     ipost =  1
c     intpol =  3
c
c     floating point input parameters
c     xa =  0.000 xb =  1.000 yc =  0.000 yd =  1.000
c     tolerance (error control) =    0.000E+00
c
c     discretization call to muh2cr intl =  0
c     ierror =  0 minimum work space =  149055
c
c     approximation call to muh2cr
c     intl =  1 method =  0 iguess =  0
c     ierror =  0
c     maximum error  =   0.414E-03
c
c     muh24cr test  ierror =  0
c     maximum error  =   0.202E-05
c
c
c **********************************************************
c      end of output
c **********************************************************
c
      program tmuh24cr
      implicit none
c
c     set grid size params
c
      integer iixp,jjyq,iiex,jjey,nnx,nny,llwork
      integer iixp1,jjyq1
      parameter (iixp = 15 , jjyq = 9, iiex = 3, jjey = 5 )
      parameter(iixp1 = iixp+1, jjyq1 = jjyq+1)
      parameter (nnx=iixp*2**(iiex-1)+1, nny=jjyq*2**(jjey-1)+1)
c
c     set exact minimum work space requried (see tmuh2cr.f)
c
      parameter (llwork = 149055)
      real(8) phi(nnx,nny),rhs(nnx,nny),work(llwork)
      integer iwork(iixp1,jjyq1)
c
c     put integer and floating point argument names in contiguous
c     storeage for labelling in vectors iprm,fprm
c
      integer iprm(16),mgopt(4)
      real(8) fprm(6)
      integer intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      common/itmuh2cr/intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      real(8) xa,xb,yc,yd,tolmax,relmax
      common/ftmuh2cr/xa,xb,yc,yd,tolmax,relmax
      equivalence(intl,iprm)
      equivalence(xa,fprm)
      integer i,j,ierror
      real(8) dlx,dly,x,y,cxx,cxy,cyy,cx,cy,ce
      real(8) pxx,pxy,pyy,px,py,pe,errmax
c
c     declare coefficient and boundary condition input subroutines external
c
      external cofcr,bndcr
c
c
c     set input integer arguments
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 1
      nxb = 1
      nyc = 1
      nyd = 2
c
c     set grid sizes from parameter statements
c
      ixp = iixp
      jyq = jjyq
      iex = iiex
      jey = jjey
      nx = nnx
      ny = nny
c
c     set multigrid arguments (w(2,1) cycling with fully weighted
c     residual restriction and cubic prolongation)
c
      mgopt(1) = 2
      mgopt(2) = 2
      mgopt(3) = 1
      mgopt(4) = 3
c
c     set three cycles
c
      maxcy = 3
c
c     set no initial guess forcing full multigrid cycling
c
      iguess = 0
c
c     set work space length approximation from parameter statement
c
      nwork = llwork
c
c     set point relaxation
c
      method = 0
c
c     set end points of solution rectangle in (x,y) space
c
      xa = 0.0
      xb = 1.0
      yc = 0.0
      yd = 1.0
c
c     set mesh increments
c
      dlx = (xb-xa)/float(nx-1)
      dly = (yd-yc)/float(ny-1)
c
c     set for no error control flag
c
      tolmax = 0.0
c
c     set right hand side in rhs
c     initialize phi to zero
c
      do i=1,nx
      x = xa+float(i-1)*dlx
      do j=1,ny
        y = yc+float(j-1)*dly
        call cofcr(x,y,cxx,cxy,cyy,cx,cy,ce)
        call exacr(x,y,pxx,pxy,pyy,px,py,pe)
        rhs(i,j) = cxx*pxx+cxy*pxy+cyy*pyy+cx*px+cy*py+ce*pe
        phi(i,j) = 0.0
      end do
      end do
c
c     set specified boundaries in phi at x=xa,xb and y=yc
c
      do j=1,ny
      y = yc+float(j-1)*dly
      call exacr(xa,y,pxx,pxy,pyy,px,py,pe)
      phi(1,j) = pe
      call exacr(xb,y,pxx,pxy,pyy,px,py,pe)
      phi(nx,j) = pe
      end do
      do i=1,nx
      x = xa+float(i-1)*dlx
      call exacr(x,yc,pxx,pxy,pyy,px,py,pe)
      phi(i,1) = pe
      end do
      write(*,100)
  100 format(//' muh2cr test ')
      write (*,101) (iprm(i),i=1,15)
  101 format(/' integer input arguments ',
     +/'intl = ',i2,' nxa = ',i2,' nxb = ',i2,' nyc = ',i2,' nyd = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' iex = ',i2,' jey = ',i2
     +/' nx = ',i3,' ny = ',i3,' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space estimate = ',i7)
      write (*,102) (mgopt(i),i=1,4)
  102 format(/' multigrid option arguments ',
     +/' kcycle = ',i2,
     +/' iprer = ',i2,
     +/' ipost = ',i2
     +/' intpol = ',i2)
      write(*,103) xa,xb,yc,yd,tolmax
  103 format(/' floating point input parameters ',
     +/' xa = ',f6.3,' xb = ',f6.3,' yc = ',f6.3,' yd = ',f6.3,
     +/' tolerance (error control) =   ',e10.3)
c
c     intiialization call
c
      write(*,104) intl
  104 format(/' discretization call to muh2cr', ' intl = ', i2)
      call muh2cr(iprm,fprm,work,iwork,cofcr,bndcr,rhs,phi,mgopt,ierror)
      write (*,105) ierror,iprm(16)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     attempt solution
c
      intl = 1
      write(*,106) intl,method,iguess,maxcy
  106 format(/' approximation call to muh2cr',
     +/' intl = ',i2, ' method = ',i2,' iguess = ',i2, ' maxcy = ',i2)
      call muh2cr(iprm,fprm,work,iwork,cofcr,bndcr,rhs,phi,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
c
c     compute and print maximum norm of error
c
      errmax = 0.0
      do j=1,ny
      y = yc+(j-1)*dly
      do i=1,nx
        x = xa+(i-1)*dlx
        call exacr(x,y,pxx,pxy,pyy,px,py,pe)
        errmax = dmax1(errmax,abs((phi(i,j)-pe)))
      end do
      end do
      write(*,108) errmax
  108 format(' maximum error  =  ',e10.3)
c
c     attempt fourth-order
c
      call muh24cr(work,iwork,cofcr,bndcr,phi,ierror)
      write (*,109) ierror
  109 format(/' muh24cr test ', ' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
c
c     compute and print maximum norm of error
c
      errmax = 0.0
      do j=1,ny
      y = yc+(j-1)*dly
      do i=1,nx
        x = xa+(i-1)*dlx
        call exacr(x,y,pxx,pxy,pyy,px,py,pe)
        errmax = dmax1(errmax,abs((phi(i,j)-pe)))
      end do
      end do
      write(*,108) errmax
      end

      subroutine cofcr(x,y,cxx,cxy,cyy,cx,cy,ce)
c
c     input pde coefficients at any grid point (x,y) in the solution region
c     (xa.le.x.le.xb,yc.le.y.le.yd) to muh2cr
c
      implicit none
      real(8) x,y,cxx,cxy,cyy,cx,cy,ce
      cxx = 1.+y**2
      cxy = 2.*x*y
      cyy = 1.+x**2
      cx = y
      cy = x
      ce = -(x*y)
      return
      end

      subroutine bndcr(kbdy,xory,alfa,beta,gama,gbdy)
c
c     input mixed "oblique" derivative b.c. to muh2cr
c     at upper y boundary
c
      implicit none
      integer kbdy
      real(8) xory,alfa,beta,gama,gbdy
      integer intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      common/itmuh2cr/intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      real(8) xa,xb,yc,yd,tolmax,relmax
      common/ftmuh2cr/xa,xb,yc,yd,tolmax,relmax
      real(8) x,y,pxx,pxy,pyy,px,py,pe
      if (kbdy.eq.4) then
c
c     y=yd boundary (nyd must equal 2 if this code is to be executed).
c     b.c. has the form alfyd(x)*px+betyd(x)*py+gamyd(x)*pe = gbdyd(x)
c     where x = yorx.   alfa,beta,gama,gbdy corresponding to alfyd(x),
c     betyd(x),gamyd(x),gbdyd(y) must be output.
c
      y = yd
      x = xory
      alfa = -x
      beta = 1.+x
      gama = -x
      call exacr(x,y,pxx,pxy,pyy,px,py,pe)
      gbdy = alfa*px + beta*py + gama*pe
      return
      end if
      end

      subroutine exacr(x,y,pxx,pxy,pyy,px,py,pe)
c
c     this subroutine is used for setting an exact solution
c     to test subroutine muh2cr.
c
      implicit none
      real(8) x,y,pxx,pxy,pyy,px,py,pe
      pe = (x*y)**5
      px = 5.*(x*y)**4*y
      py = 5.*(x*y)**4*x
      pxx = 20.*(x*y)**3*y*y
      pxy = 25.*(x*y)**4
      pyy = 20.*(x*y)**3*x*x
      return
      end


program q3

  use mqc_gaussian

  implicit none
  character(len=:),allocatable::fileName
  type(mqc_gaussian_unformatted_matrix_file)::fileInfo
  type(mqc_scf_integral)::overlap,density
  type(mqc_scalar)::contract

  call mqc_get_command_argument(1,fileName)
  write(6,'(A14,1X,A)') 'Input file is:',fileName
  call fileInfo%load(fileName)

  call fileInfo%getESTObj('overlap',est_integral=overlap)
  call fileInfo%getESTObj('density',est_integral=density)
  call overlap%print(6,'overlap')
  call density%print(6,'density')
  contract = contraction(density,overlap)
  call contract%print(6,'<PS>')
  contract = mqc_scf_integral_trace(matmul(density,overlap))
  call contract%print(6,'trace(P.S)')

end program q3


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine smoothing(inn,iponn,nktet,
     &     iexternnode,netet_,kontet,cotet,ipoeln,ieln,h,quality,
     &     jfix)
!
!     smoothing the mesh (cf. Triangulation de Delaunay et maillage,
!     P-L George and H. Borouchaki, section 8.4.1)
!
      implicit none
!
      integer netet_,kontet(4,*),ielem,i,j,k,iter,index,indexe,node,
     &     iexternnode(*),iponn(*),inn(2,*),ipoeln(*),ieln(2,*),
     &     indexeold,ielemold,nktet,jfix(*)
!
      real*8 cotet(3,*),quality(*),sumalpha,relaxw,qmax,h(*),
     &     cpycotet(3),sumalphap(3),haverage,alphaj
!
!
!
!     determine the overall quality in the mesh
!
      ielem=0
      call meshquality(netet_,kontet,cotet,quality,ielem)
!
!     relaxation factor
!
      relaxw=0.5d0
!
!     number of smoothing iterations
!
      iter=10
!
      do k=1,iter
!
!     subsurface nodes
!
        loop1: do i=1,nktet
          if(iponn(i).eq.0) cycle
          if(jfix(i).eq.1) cycle
          if(iexternnode(i).ne.0) cycle
          indexe=ipoeln(i)
!
!     calculate the quality of the ball (all elements containing node i)
!
          qmax=0.d0
          do
            if(indexe.eq.0) exit
            ielem=ieln(1,indexe)
            if(kontet(1,ielem).eq.0) then
              indexe=ieln(2,indexe)
              cycle
            endif
            if(quality(ielem).gt.qmax) qmax=quality(ielem)
            indexe=ieln(2,indexe)
          enddo
!
!     initializing numerator (sumalphap) and denominator (sumalpha)
!     of the new position
!
          sumalpha=0.d0
          do j=1,3
            sumalphap(j)=0.d0
          enddo
!
!     calculating the new position: loop over all neighboring nodes
!
          index=iponn(i)
          do
            if(index.eq.0) exit
!
!     neighboring node
!
            node=inn(1,index)
            haverage=(h(i)+h(node))/2.d0
!
!     weight = inverse of the square of the desired edge length
!
            alphaj=1.d0/(haverage*haverage)
            sumalpha=sumalpha+alphaj
            do j=1,3
              sumalphap(j)=sumalphap(j)+alphaj*cotet(j,node)
            enddo
            index=inn(2,index)
          enddo
!
!     storing old position of node i
!     determining new position
!
          do j=1,3
            cpycotet(j)=cotet(j,i)
            cotet(j,i)=(1.d0-relaxw)*cotet(j,i)+
     &           relaxw*sumalphap(j)/sumalpha
          enddo
!
!     check the quality of the tetrahedral elements in the ball for
!     the new position of node i; as soon as a tetrahedron is detected
!     with a quality exceeding qmax the coordinates of node i are reverted
!     to the ones before smoothing
!
          indexe=ipoeln(i)
          do
            if(indexe.eq.0) exit
            ielem=ieln(1,indexe)
            if(kontet(1,ielem).eq.0) then
              indexe=ieln(2,indexe)
              cycle
            endif
            call meshquality(netet_,kontet,cotet,quality,ielem)
            if(quality(ielem).gt.qmax) then
!
!     1. restore the original coordinates
!     2. recalculate the quality of the tetrahedrons in the ball
!     covered so far in the current loop
!
              do j=1,3
                cotet(j,i)=cpycotet(j)
              enddo
              indexeold=ipoeln(i)
              do
                ielemold=ieln(1,indexeold)
                if(kontet(1,ielemold).eq.0) then
                  indexeold=ieln(2,indexeold)
                  cycle
                endif
                call meshquality(netet_,kontet,cotet,quality,ielemold)
                if(ielemold.eq.ielem) exit
                indexeold=ieln(2,indexeold)
              enddo
              cycle loop1
            endif
            indexe=ieln(2,indexe)
          enddo
        enddo loop1
!
!     surface nodes
!
        loop2: do i=1,nktet
          if(iponn(i).eq.0) cycle
          if(iexternnode(i).eq.0) cycle
          indexe=ipoeln(i)
!
!     calculate the quality of the ball (all elements containing node i)
!
          qmax=0.d0
          do
            if(indexe.eq.0) exit
            ielem=ieln(1,indexe)
            if(kontet(1,ielem).eq.0) then
              indexe=ieln(2,indexe)
              cycle
            endif
            if(quality(ielem).gt.qmax) qmax=quality(ielem)
            indexe=ieln(2,indexe)
          enddo
!
!     initializing numerator (sumalphap) and denominator (sumalpha)
!     of the new position
!
          sumalpha=0.d0
          do j=1,3
            sumalphap(j)=0.d0
          enddo
!
!     calculating the new position: loop over all neighboring nodes
!
          index=iponn(i)
          do
            if(index.eq.0) exit
!
!     neighboring node
!
            node=inn(1,index)
            haverage=(h(i)+h(node))/2.d0
!
!     weight = inverse of the square of the desired edge length
!
            alphaj=1.d0/(haverage*haverage)
            sumalpha=sumalpha+alphaj
            do j=1,3
              sumalphap(j)=sumalphap(j)+alphaj*cotet(j,node)
            enddo
            index=inn(2,index)
          enddo
!
!     storing old position of node i
!     determining new position
!
          do j=1,3
            cpycotet(j)=cotet(j,i)
            cotet(j,i)=(1.d0-relaxw)*cotet(j,i)+
     &           relaxw*sumalphap(j)/sumalpha
          enddo
!
!     check the quality of the tetrahedral elements in the ball for
!     the new position of node i; as soon as a tetrahedron is detected
!     with a quality exceeding qmax the coordinates of node i are reverted
!     to the ones before smoothing
!
          indexe=ipoeln(i)
          do
            if(indexe.eq.0) exit
            ielem=ieln(1,indexe)
            if(kontet(1,ielem).eq.0) then
              indexe=ieln(2,indexe)
              cycle
            endif
            call meshquality(netet_,kontet,cotet,quality,ielem)
            if(quality(ielem).gt.qmax) then
!
!     1. restore the original coordinates
!     2. recalculate the quality of the tetrahedrons in the ball
!     covered so far in the current loop
!
              do j=1,3
                cotet(j,i)=cpycotet(j)
              enddo
              indexeold=ipoeln(i)
              do
                ielemold=ieln(1,indexeold)
                if(kontet(1,ielemold).eq.0) then
                  indexeold=ieln(2,indexeold)
                  cycle
                endif
                call meshquality(netet_,kontet,cotet,quality,ielemold)
                if(ielemold.eq.ielem) exit
                indexeold=ieln(2,indexeold)
              enddo
              cycle loop2
            endif
            indexe=ieln(2,indexe)
          enddo
        enddo loop2
!
      enddo
!
      return
      end


*     MB02DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, MMAX, NMAX
      PARAMETER        ( KMAX = 20, MMAX = 20, NMAX = 20 )
      INTEGER          LCS, LDG, LDL, LDR, LDT, LDWORK
      PARAMETER        ( LDG = KMAX*( MMAX + NMAX ),
     $                   LDL = KMAX*( MMAX + NMAX ),
     $                   LDR = KMAX*( MMAX + NMAX ),
     $                   LDT = KMAX*( MMAX + NMAX ),
     $                   LDWORK = ( MMAX + NMAX - 1 )*KMAX )
      PARAMETER        ( LCS = 3*LDWORK )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, M, N, S
      CHARACTER        JOB, TYPET
*     .. Local Arrays ..
*     The arrays are dimensioned for both TYPET = 'R' and TYPET = 'C'.
*     Arrays G and T could be smaller.
*     For array G, it is assumed that MMAX + NMAX >= 2.
*     The matrix TA is also stored in the array T.
      DOUBLE PRECISION CS(LCS), DWORK(LDWORK),
     $                 G(LDG, KMAX*( MMAX + NMAX )),
     $                 L(LDL, KMAX*( MMAX + NMAX )),
     $                 R(LDR, KMAX*( MMAX + NMAX )),
     $                 T(LDT, KMAX*( MMAX + NMAX ))
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DLACPY, MB02CD, MB02DD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, M, JOB, TYPET
      S = ( N + M )*K
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) N
      ELSE
         IF ( K.LE.0 .OR. K.GT.KMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) K
         ELSE
            IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99987 ) M
            ELSE
               IF ( LSAME( TYPET, 'R' ) ) THEN
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,S ), I = 1,K )
               ELSE
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,S )
               END IF
*              Compute the Cholesky factors.
               CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L,
     $                      LDL, CS, LCS, DWORK, LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 10  I = 1, N*K
                     WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, N*K )
   10             CONTINUE
                  IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) ) THEN
                     WRITE ( NOUT, FMT = 99995 )
                     IF ( LSAME( TYPET, 'R' ) ) THEN
                        DO 20  I = 1, 2*K
                           WRITE ( NOUT, FMT = 99990 )
     $                           ( G(I,J), J = 1, N*K )
   20                   CONTINUE
                     ELSE
                        DO 30  I = 1, N*K
                           WRITE ( NOUT, FMT = 99990 )
     $                           ( G(I,J), J = 1, 2*K )
   30                   CONTINUE
                     END IF
                  END IF
                  IF ( LSAME( JOB, 'A' ) ) THEN
                     WRITE ( NOUT, FMT = 99994 )
                     DO 40  I = 1, N*K
                        WRITE ( NOUT, FMT = 99990 )
     $                        ( L(I,J), J = 1, N*K )
   40                CONTINUE
                  END IF
*                 Update the Cholesky factors.
                  IF ( LSAME( TYPET, 'R' ) ) THEN
*                    Copy the last block column of R.
                     CALL DLACPY( 'All', N*K, K, R(1,(N-1)*K+1), LDR,
     $                            R(K+1,N*K+1), LDR )
                     CALL MB02DD( JOB, TYPET, K, M, N, T(1,N*K+1), LDT,
     $                            T, LDT, G, LDG, R(1,N*K+1), LDR,
     $                            L(N*K+1,1), LDL, CS, LCS, DWORK,
     $                            LDWORK, INFO )
                  ELSE
*                    Copy the last block row of R.
                     CALL DLACPY( 'All', K, N*K, R((N-1)*K+1,1), LDR,
     $                            R(N*K+1,K+1), LDR )
                     CALL MB02DD( JOB, TYPET, K, M, N, T(N*K+1,1), LDT,
     $                            T, LDT, G, LDG, R(N*K+1,1), LDR,
     $                            L(1,N*K+1), LDL, CS, LCS, DWORK,
     $                            LDWORK, INFO )
                  END IF
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99997 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 50  I = 1, S
                        WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, S )
   50                CONTINUE
                     IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) )
     $                       THEN
                        WRITE ( NOUT, FMT = 99992 )
                        IF ( LSAME( TYPET, 'R' ) ) THEN
                           DO 60  I = 1, 2*K
                              WRITE ( NOUT, FMT = 99990 )
     $                              ( G(I,J), J = 1, S )
   60                      CONTINUE
                        ELSE
                           DO 70  I = 1, S
                              WRITE ( NOUT, FMT = 99990 )
     $                              ( G(I,J), J = 1, 2*K )
   70                      CONTINUE
                        END IF
                     END IF
                     IF ( LSAME( JOB, 'A' ) ) THEN
                        WRITE ( NOUT, FMT = 99991 )
                        DO 80  I = 1, S
                           WRITE ( NOUT, FMT = 99990 )
     $                           ( L(I,J), J = 1, S )
   80                   CONTINUE
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT ( ' MB02DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT ( ' INFO on exit from MB02CD = ',I2)
99997 FORMAT ( ' INFO on exit from MB02DD = ',I2)
99996 FORMAT ( ' The Cholesky factor is ')
99995 FORMAT (/' The inverse generator is ')
99994 FORMAT (/' The inverse Cholesky factor is ')
99993 FORMAT (/' The updated Cholesky factor is ')
99992 FORMAT (/' The updated inverse generator is ')
99991 FORMAT (/' The updated inverse Cholesky factor is ')
99990 FORMAT (20(1X,F8.4))
99989 FORMAT (/' N is out of range.',/' N = ',I5)
99988 FORMAT (/' K is out of range.',/' K = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
      END


! This is intended as an example

module opacity_table_module

  implicit none

contains

!     ============================================
!
!     opacity for a given temperature and density
!
!     input:   nu    - radiation frequency (Hz)
!              temp  - temperature  (K)
!              rho   - density    (g cm^-3)
!              rhoYe - rho*Ye
!     output:  kp    - Planck mean opacity  (1/cm)
!              kr    - Rosseland mean opacity  (1/cm)

  subroutine get_opacities(kp, kr, rho, temp, rhoYe, nu, get_Planck_mean, get_Rosseland_mean)

    implicit none

    logical, intent(in) :: get_Planck_mean, get_Rosseland_mean
    double precision, intent(in) :: rho, temp, rhoYe, nu
    double precision, intent(out) :: kp, kr

    double precision, parameter :: const_kappa_p = 0.33d-4
    double precision, parameter :: kappa_p_exp_m = 1.0d0
    double precision, parameter :: kappa_p_exp_n = 0.0d0
    double precision, parameter :: kappa_p_exp_p = 0.0d0
    double precision, parameter :: const_kappa_r = 0.33d0
    double precision, parameter :: kappa_r_exp_m = 1.0d0
    double precision, parameter :: kappa_r_exp_n = 0.0d0
    double precision, parameter :: kappa_r_exp_p = 0.0d0
    double precision, parameter :: tiny = 1.d-50
    double precision, parameter :: tfloor = 0.d0
    double precision, parameter :: kfloor = 0.d0

    double precision :: teff, nup_kpp, nup_kpr

    nup_kpp = nu**kappa_p_exp_p
    nup_kpr = nu**kappa_r_exp_p

    teff = max(temp, tiny)
    teff = teff + tfloor * exp(-teff / (tfloor + tiny))

    if (get_planck_mean) then
       kp = const_kappa_p * (rho**kappa_p_exp_m) * (teff**(-kappa_p_exp_n)) * nup_kpp
    end if

    if (get_Rosseland_mean) then
       kr = const_kappa_r * (rho**kappa_r_exp_m) * (teff**(-kappa_r_exp_n)) * nup_kpr
       kr = max(kr, kfloor)
    end if

  end subroutine get_opacities

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  ! dummies

  subroutine get_opacity_emissivity( &
       ab, sc, delta, eta,           &
       rho, rdummy, temp, nu, idummy, comp_ab, comp_sc, ldummy)
    implicit none
    integer, intent(in) :: idummy
    logical, intent(in) :: comp_ab, comp_sc, ldummy
    double precision, intent(in) :: rho, rdummy, temp, nu
    double precision, intent(out) :: ab, sc, delta, eta
    ab = 0.d0
    sc = 0.d0
    delta = 0.d0
    eta = 0.d0
  end subroutine get_opacity_emissivity

  subroutine prep_opacity(g, inu, er, der)
    implicit none
    integer, intent(in) :: g
    integer, intent(out) :: inu
    double precision, intent(out) :: er, der
    inu = -1
    er = 0.d0
    der = 0.d0
  end subroutine prep_opacity

end module opacity_table_module

subroutine init_opacity_table(iverb)
  use opacity_table_module
  implicit none
  integer iverb
end subroutine init_opacity_table


!============================================================================
!
! Program:  stag
!
! Purpose:  Solve the two-dimensional incompressible Navier-Stokes equations
!           on a staggered mesh system
!
! Author:   S. Scott Collis
!           sscollis@gmail.com
!
! Date:     12-23-99
! Revised:  07-27-00
!
! Version:  4.0 (Optimized for OpenMP)
!
! Notes:    All pressure solvers work except Conjugate Gradients
!
!============================================================================

!.... Select the correct version of library routines

#ifdef R8
#define SGEFA dgefa
#define SGESL sgesl
#endif

module global

!.... Module containing globally defined variables for the
!     2-D Navier-Stokes solver

!.... spatial geometry
!
!     nx          := number of nodes in x-direction
!     ny          := number of nodes in y-direction
!     x,y         := nondimensional node locations
!     axis        := Axisymmetric flag

      integer :: nx, ny, nxm, nxmm, nym, nymm, i, j
      real, allocatable :: x(:), y(:), xc(:), yc(:), r(:), fx(:), fy(:)
      logical :: axis

!.... Code parameters
!
!     n       := current timestep index
!     nstep   := number of steps in this run
!     time    := current nondimensional time
!     dt      := current nondimensional timestep
!     dt_max  := maximum allowable timestep
!     cfl     := current CFL number
!     cfl_max := maximum allowable CFL number
!     tol     := convergence tolerance
!     method  := Discrete method
!     eps     := Fourth-order damping coefficient
!     ictype  := initial condition flag
!               0 = start using initial condition in ic() subroutine
!               1 = restart from file 'restart.dat'
!     pmethod := pressure solver
!               0 = point GS with SOR
!               1 = line GS with SOR
!               2 = ADI
!               3 = Direct
!               4 = SIP
!               5 = Conjugate gradients
!     delta_p := if true, use delta p form of discrete equations
!     alfa    := SIP parameter

      integer :: ictype, n, istep, nstep, method, k, kmax, pmethod, nout
      real    :: time, dt, cfl, dt_max, cfl_max, tol, eps, omega, alfa
      real    :: dtau, pnorm, pmax, psum
      logical :: delta_p, first

!.... field variables
!
!     u(nx,ny)      := x-velocity
!     v(nx,ny)      := y-velocity
!     p(nx,ny)      := presure
!     cx(nx,ny)     := mass flux out of the east face
!     cy(nx,ny)     := mass flux out of the north face

      real, allocatable :: u(:,:), v(:,:), p(:,:), cx(:,:), cy(:,:)
      real, allocatable :: u_old(:,:), v_old(:,:), p_old(:,:), ru(:,:), rv(:,:)
      real, allocatable :: uc(:,:),vc(:,:),pc(:,:),div(:,:),wz(:,:),ke(:,:)
      real :: tdiv, tke, enstrophy

!.... flow parameters
!
!     Re     := reference Reynolds number
!     rho    := fluid density
!     vis    := one / Re

      real :: Re, rho, vis

!.... Boundary condition flags

      integer :: bottom_bc = 0, top_bc = 0, left_bc = 0, right_bc = 0

!.... units and filenames

      integer ::  ihist=9, io=10, ipres=11, istat=12
      character*80 :: base, filen
      integer :: iver, lfile=80
      integer, external :: igetver

end module global

module timemod

!.... Variables for monitoring CPU usage
!
!     Note that they must be explicitly declared as real*4

      real(kind=4), external :: second
      real(kind=4) :: cpu0, cpu, cpu2
end module timemod

module const

!.... Module defining some convenient constants to machine precision

      real, parameter :: zero    = 0.00000000000000000000
      real, parameter :: pt25    = 0.25000000000000000000
      real, parameter :: pt33    = 0.33333333333333333333
      real, parameter :: pt5     = 0.50000000000000000000
      real, parameter :: pt66    = 0.66666666666666666667
      real, parameter :: one     = 1.00000000000000000000
      real, parameter :: onept5  = 1.50000000000000000000
      real, parameter :: onept33 = 1.33333333333333333333
      real, parameter :: onept66 = 1.66666666666666666667
      real, parameter :: two     = 2.00000000000000000000
      real, parameter :: three   = 3.00000000000000000000
      real, parameter :: four    = 4.00000000000000000000
      real, parameter :: pi      = 3.14159265358979323846
end module const

!==============================================================================
program Navier_Stokes
!==============================================================================
!     Solve the incompressible, two-dimensional, non-dimensional
!     Navier-Stokes equations on a staggered grid system
!
!     Author:  S. Collis
!
!     Date:    12-8-99
!
!     Compile:
!               (SGI single precision) f90 -0 stag.f90 -o stag
!               (SGI double precision) f90 -r8 -DR8 -O stag.f90 -o stag
!
!     Variable Arrangement on Staggered Mesh:
!
!             u v
!            yc y                           Key
!                                        ---------
!             7 6  x+-+-+-+-+x            u   = -
!             6    -o-o-o-o-o-            v   = +
!               5  ++ + + + ++            u,v = x
!             5    -o-o-o-o-o-            p   = o
!               4  ++ + + + ++
!             4    -o-o-o-o-o-
!               3  ++ + + + ++
!             3    -o-o-o-o-o-
!               2  ++ + + + ++
!             2    -o-o-o-o-o-
!             1 1  x+-+-+-+-+x
!
!                  1 2 3 4 5 6   x , u
!                  12 3 4 5 67   xc, v
!==============================================================================
      use global
      implicit none

!$    integer, external :: omp_get_num_threads, omp_get_thread_num
!$    integer, external :: omp_get_num_procs

!     call omp_set_num_threads(nprocs)
!$omp parallel
!$    if (omp_get_thread_num() == 0) then
!$      write(*,*) 'Running on ',omp_get_num_threads(),' processor(s)'
!$      write(*,*) 'There are ',omp_get_num_procs(),' processor(s) available'
!$    end if
!$omp end parallel

      call setup
      call wgrid

      iver = igetver( base, 'h'//char(0) ) + 1
      call addver(base, 'h'//char(0), iver, filen, lfile)
      open(ihist,file=filen,status='unknown')

      iver = igetver( base, 'p'//char(0) ) + 1
      call addver(base, 'p'//char(0), iver, filen, lfile)
      open(ipres,file=filen,status='unknown')

      iver = igetver( base, 's'//char(0) ) + 1
      call addver(base, 's'//char(0), iver, filen, lfile)
      open(istat,file=filen,status='unknown')

      if (ictype.eq.0) then
        call ic
      else if (ictype.eq.1) then
        call restart
      else
        call error('Navier-Stokes$','Illegal value of ictype$')
      end if

      if (method .eq. 0) then
        call driver                   ! Runge-Kutta 2
      else
        call error('Navier-Stokes$','Illegal value of method$')
      end if

      stop
end program Navier_Stokes

subroutine driver

!.... Main driver for second order Runge-Kutta

      use const
      use global
      use timemod
      implicit none

      real :: fact

      write(*,"(79('='))")

      call interp
      call setdt

      do istep = 1, nstep

!$omp parallel do private(i)
        do j = 1, ny
          do i = 1, nx
            u_old(i,j) = u(i,j)
            v_old(i,j) = v(i,j)
          end do
        end do

        if (delta_p) then
!$omp parallel do private(i)
          do j = 1, ny
            do i = 1, nx
              p_old(i,j) = p(i,j)
              p(i,j) = zero
            end do
          end do
        endif

        n = n + 1

!.... first RK sub-step

        call calc_u( delta_p )
        call calc_v( delta_p )

        time = time + pt5 * dt
        fact = pt5 * dt

!$omp parallel do private(i)
        do j = 1, ny
          do i = 1, nx
            u(i,j) = u_old(i,j) + fact * ru(i,j)
            v(i,j) = v_old(i,j) + fact * rv(i,j)
          end do
        end do
        call bc

        call calc_p( pt5 * dt, u, v, .true.)

!.... second RK sub-step

        call calc_u( delta_p )
        call calc_v( delta_p )

        time = time + pt5 * dt
        fact = dt

!$omp parallel do private(i)
        do j = 1, ny
          do i = 1, nx
            u(i,j) = u_old(i,j) + fact * ru(i,j)
            v(i,j) = v_old(i,j) + fact * rv(i,j)
          end do
        end do
        call bc

        call calc_p ( dt, u, v, .true. )

        if (delta_p) then
!$omp parallel do private(i)
          do j = 1, ny
            do i = 1, nx
              p(i,j) = p_old(i,j) + p(i,j)
            end do
          end do
        endif

        cpu2 = second()
        write(*,"(i5,5(1x,1pe10.3))") n, time, dt, cfl, cpu2, cpu2-cpu
        write(ihist,"(i5,5(1x,1pe10.3))") n, time, dt, cfl, cpu2, cpu2-cpu
        cpu = cpu2

        call interp
        call setdt
        call stats

        call flush(ipres); call flush(istat); call flush(ihist)

!.... write restart file and Plot3d file

        if ( mod(n,nout) .eq. 0 .or. istep .eq. nstep) then
          iver = igetver( base, 'R'//char(0) ) + 1
          call addver(base, 'R'//char(0), iver, filen, lfile)
          write(*,"(79('='))")
          write (*,10) filen(1:index(filen,' ')-2), n
10        format('Writing restart file:  ',a,'  at time step ',i5)
          write(*,"(79('='))")
          open(io,file=filen,form='unformatted')
          write(io) n, nx, ny
          write(io) Re, time
          write(io) u, v, p, cx, cy
          close(io)
          iver = igetver( base, 'q'//char(0) ) + 1
          call addver(base, 'q'//char(0), iver, filen, lfile)
          call wdata( filen )
        end if

      end do

      close(ihist)

      return
end subroutine driver

subroutine calc_u( include_p )

!.... build the u-momentum equation over the u-control volumes

      use const
      use global
      implicit none

      logical :: include_p
      real :: dxwr, dxer, dysr, dynr, volr, vol

      real :: ss, ds, cs, sn, dn, cn, se, de, ce, sw, dw, cw

!.... initialize quantities along the west boundary

      dxwr = one / (x(2)-x(1))
!$omp parallel do private(i,sn,ss,se,sw,dn,ds,de,dw,cn,cs,ce,cw) &
!$omp& private(dynr,dysr,dxer,volr)
      do j = 2, nym
        sw = pt5 * (r(j)+r(j-1)) * (y(j)-y(j-1))
        dw = vis * sw * dxwr
        cw = pt5 * ( cx(2,j) + cx(1,j) )

        se = pt5*(r(j)+r(j-1)) * (y(j)-y(j-1))
        dynr = one / ( yc(j+1) - yc(j) )
        dysr = one / ( yc(j) - yc(j-1) )

!.... main loop - north, south, and east sides

        do i = 2, nxmm

          ss = r(j-1) * (xc(i+1) - xc(i))
          sn = r(j) * (xc(i+1) - xc(i))

          dxer = one / ( x(i+1)-x(i) )

          cn = pt5 * ( cy(i,j) + cy(i+1,j) )
          cs = pt5 * ( cy(i,j-1) + cy(i+1,j-1) )
          ce = pt5 * ( cx(i,j) + cx(i+1,j) )

          dn = vis * sn * dynr
          ds = vis * ss * dysr
          de = vis * se * dxer

          volr = one / ((y(j)-y(j-1))*(xc(i+1)-xc(i)))

          ru(i,j) =  volr * ( &
                pt5 * ( (u(i,j)+u(i-1,j))*cw - (u(i+1,j)+u(i,j))*ce ) - &
                cn * ( u(i,j+1) * fy(j) + u(i,j) * (one-fy(j)) ) + &
                cs * ( u(i,j) * fy(j-1) + u(i,j-1) * (one-fy(j-1)) ) + &
                de * ( u(i+1,j)-u(i,j) ) - dw * ( u(i,j)-u(i-1,j) ) + &
                dn * ( u(i,j+1)-u(i,j) ) - ds * ( u(i,j)-u(i,j-1) ) )

          if (include_p) then
            ru(i,j) = ru(i,j) + volr * ( sw * p_old(i,j) - se * p_old(i+1,j) )
          end if

          sw = se
          dw = de
          cw = ce

        end do
      end do

end subroutine calc_u

subroutine calc_v( include_p )

!.... build the v-momentum equation over the v-control volumes

      use const
      use global
      implicit none

      logical :: include_p
      real :: dxwr, dxer, dysr, dynr, volr
      real :: ss, ds, cs, sn, dn, cn, se, de, ce, sw, dw, cw

!.... initialize quantities along the west boundary

      dxwr = one / (xc(2)-xc(1))
!$omp parallel do private(i,sn,ss,se,sw,dn,ds,de,dw,cn,cs,ce,cw) &
!$omp& private(dynr,dysr,dxer,volr)
      do j = 2, nymm
        sw = pt5 * (r(j+1)+r(j-1)) * (yc(j+1)-yc(j))
        dw = vis * sw * dxwr
        cw = pt5 * ( cx(1,j) + cx(1,j+1) )

        se = pt5 * (r(j+1)+r(j-1)) * (yc(j+1) - yc(j))
        dynr = one / ( y(j+1)-y(j) )
        dysr = one / ( y(j) - y(j-1) )

!.... main loop - north, south, and east sides

        do i = 2, nxm

          ss = pt5 * (r(j)+r(j-1)) * (x(i) - x(i-1))
          sn = pt5 * (r(j+1)+r(j)) * (x(i) - x(i-1))

          dxer = one / ( xc(i+1)-xc(i) )

          cn = pt5 * ( cy(i,j+1) + cy(i,j) )
          cs = pt5 * ( cy(i,j) + cy(i,j-1) )
          ce = pt5 * ( cx(i,j+1) + cx(i,j) )

          dn = vis * sn * dynr
          ds = vis * ss * dysr
          de = vis * se * dxer

          volr = one / ((x(i)-x(i-1))*(yc(j+1)-yc(j)))

          rv(i,j) = volr * ( &
                pt5 * ( (v(i,j)+v(i,j-1))*cs - (v(i,j+1)+v(i,j))*cn ) - &
                ce * ( v(i+1,j) * fx(i) + v(i,j) * (one-fx(i)) ) + &
                cw * ( v(i,j) * fx(i-1) + v(i-1,j) * (one-fx(i-1)) ) + &
                de * ( v(i+1,j)-v(i,j) ) - dw * ( v(i,j)-v(i-1,j) ) + &
                dn * ( v(i,j+1)-v(i,j) ) - ds * ( v(i,j)-v(i,j-1) ) )

          if (include_p) then
            rv(i,j) = rv(i,j) + volr * (ss * p_old(i,j) - sn * p_old(i,j+1))
          end if

          sw = se
          dw = de
          cw = ce

        end do
      end do

end subroutine calc_v

subroutine calc_p( dtl, ul, vl, project )

!.... Find the pressure that makes the (ul, vl) field divergence free
!.... by solving a Poisson equation

!.... If project is true, then project (ul, vl) to the divergence free
!.... space using the computed pressure

!.... Note that p here may be either (p - p_old) or the full
!.... pressure depending on the value of the delta_p flag

      use const
      use global
      implicit none

      real :: ul(nx,ny), vl(nx,ny)
      real :: dtl, dtlr
      logical :: project
      real :: sw, se, sn, ss, dw, de, dn, ds
      real :: dxwr, dxer, dysr, dynr
      real :: aw(nx,ny), ae(nx,ny), as(nx,ny), an(nx,ny), ap(nx,ny), rp(nx,ny)

!.... re-scale the pressure to be consistent

      if (dtl .ne. one) then
!$omp parallel do private(i)
        do j = 1, ny
          do i = 1, nx
            p(i,j) = p(i,j) * dtl
          end do
        end do
      end if

!$omp parallel do private(i)
      do j = 1, ny
        do i = 1, nx
          rp(i,j) = zero; aw(i,j) = zero; ae(i,j) = zero;
          as(i,j) = zero; an(i,j) = zero; ap(i,j) = zero;
        end do
      end do

!.... initialize quantities along the south boundary

      dysr = one / ( yc(2) - yc(1) )
      do i = 2, nxm
        ss = r(1) * (x(i) - x(i-1))
        ds = ss * dysr
        cy(i,1) = rho * ss * vl(i,1)
      end do

!.... initialize quantities along the west boundary

      dxwr = one / (xc(2)-xc(1))
!$omp parallel do private(i,sn,ss,se,sw,dynr,dysr,dxer,dn,ds,de,dw)
      do j = 2, nym
        sw = pt5 * (r(j)+r(j-1)) * (y(j)-y(j-1))
        dw = sw * dxwr
        cx(1,j) = rho * sw * ul(1,j)

        se = pt5 * (r(j)+r(j-1)) * (y(j)-y(j-1))
        dynr = one / (yc(j+1) - yc(j))
        dysr = one / (yc(j) - yc(j-1))

!.... main loop - east and north sides

        do i = 2, nxm

          ss = r(j-1) * (x(i) - x(i-1))
          sn = r(j) * (x(i) - x(i-1))

          dxer = one / ( xc(i+1)-xc(i) )

          cx(i,j) = rho * se * ul(i,j)
          cy(i,j) = rho * sn * vl(i,j)

          dn = sn * dynr
          ds = ss * dysr
          de = se * dxer

          ae(i,j) = de
          aw(i,j) = dw
          an(i,j) = dn
          as(i,j) = ds

          dw = de

        end do
      end do

!.... form the RHS

      psum = zero
!$omp parallel do private(i) reduction(+:psum)
      do j = 2, nym
        do i = 2, nxm
          rp(i,j) = ( cx(i,j) + cy(i,j) - cx(i-1,j) - cy(i,j-1) )
          psum = psum + rp(i,j)**2
        end do
      end do

!.... satisfy wall boundary conditions (zero normal pressure gradient)

!$omp parallel do
      do j = 1, ny
        aw(2,j) = zero
        ae(nxm,j) = zero
      end do
!$omp parallel do
      do i = 1, ny
        as(i,2) = zero
        an(i,nym) = zero
      end do

!.... final assembly

!$omp parallel do private(i)
      do j = 2, nym
        do i = 2, nxm
          ap(i,j) = -(ae(i,j)+aw(i,j)+an(i,j)+as(i,j))
        end do
      end do

      if (pmethod .eq. 0) then
        call point_gs_sor( rp, aw, ae, as, an, ap )
      else if (pmethod .eq. 1) then
        call line_gs_sor( rp, aw, ae, as, an, ap )
      else if (pmethod .eq. 2) then
        call adi( rp, aw, ae, as, an, ap )
      else if (pmethod .eq. 3) then
        call direct( rp, aw, ae, as, an, ap )
      else if (pmethod .eq. 4) then
        call sip( rp, aw, ae, as, an, ap )
      else if (pmethod .eq. 5) then
        call cg( rp, aw, ae, as, an, ap )
      end if

      if (project) then

!.... correct u-velocity and Cx mass flux

!$omp parallel do private(i,se)
      do j = 2, nym
        do i = 2, nxmm
          se = pt5 * (r(j)+r(j-1)) * (y(j)-y(j-1))
          ul(i,j) = ul(i,j) - se * ( p(i+1,j) - p(i,j) ) / &
                   ( rho * (xc(i+1)-xc(i))*(y(j)-y(j-1)) )
          cx(i,j) = rho * se * ul(i,j)
        end do
      end do

!.... correct v-velocity and Cy mass flux

!$omp parallel do private(i,sn)
      do j = 2, nymm
        do i = 2, nxm
          sn = r(j) * ( x(i) - x(i-1) )
          vl(i,j) = vl(i,j) - sn * ( p(i,j+1) - p(i,j) ) / &
                   ( rho * (x(i)-x(i-1)) * (yc(j+1)-yc(j)) )
          cy(i,j) = rho * sn * vl(i,j)
        end do
      end do

      else

!$omp parallel do private(i,se)
      do j = 2, nym
        do i = 2, nxmm
          se = pt5 * (r(j)+r(j-1)) * (y(j)-y(j-1))
          cx(i,j) = rho * se * u(i,j)
        end do
      end do

!.... correct v-velocity and Cy mass flux

!$omp parallel do private(i,sn)
      do j = 2, nymm
        do i = 2, nxm
          sn = r(j) * ( x(i) - x(i-1) )
          cy(i,j) = rho * sn * v(i,j)
        end do
      end do

      end if

!.... re-scale the pressure to be consistent

      dtlr = one / dtl
      if (dtl .ne. one) then
!$omp parallel do private(i)
        do j = 1, ny
          do i = 1, nx
            p(i,j) = p(i,j) * dtlr
          end do
        end do
      end if

!.... compute pressure statistics

      psum = zero
      pmax = zero
      tdiv = zero
!$omp parallel do private(i) reduction(+: psum, tdiv) reduction(max: pmax)
      do j = 2, nym
        do i = 2, nxm
          psum = psum + p(i,j)**2
          pmax = max(abs(p(i,j)),pmax)
          tdiv = tdiv + (cx(i,j) + cy(i,j) - cx(i-1,j) - cy(i,j-1))**2
        end do
      end do
      psum = sqrt( psum / (nxmm*nymm) )
      tdiv = sqrt( tdiv / (nxmm*nymm) )

!.... write to history file

      write(*,"('----> ',4(1pe10.3,1x),'(',i5,')')") tdiv, pnorm, psum, pmax, k
      write(ipres,"(2(i5,1x),8(1pe10.3,1x))") n, k, tdiv, pnorm, psum, pmax

end subroutine calc_p

subroutine point_gs_sor( rp, aw, ae, as, an, ap )

!.... Solve the pressure Poisson equation using point GS with SOR

      use const
      use global
      implicit none

      real :: rp(nx,ny), aw(nx,ny), ae(nx,ny), as(nx,ny), an(nx,ny), ap(nx,ny)
      integer :: pl
      real :: pnorm0

      do k = 1, kmax

!.... solve for pressure using point GS-SOR

!$omp parallel do private(i)
        do j = 2, nym
          do i = 2, nxm
            p(i,j) = (one-omega)*p(i,j) - omega * ( ae(i,j) * p(i+1,j) + &
                     an(i,j) * p(i,j+1) + aw(i,j) * p(i-1,j) + &
                     as(i,j) * p(i,j-1) - rp(i,j) ) / ap(i,j)
          end do
        end do

!.... ensure that boundary conditions are fixed

        p(1,1)         = p(2,2)
        p(nx,1)        = p(nxm,2)
        p(1,ny)        = p(2,nym)
        p(nx,ny)       = p(nxm,nym)

!$omp parallel do
        do i = 2, nxm
          p(i,1)  = p(i,2)
          p(i,ny) = p(i,nym)
        end do

!$omp parallel do
        do j = 2, nym
          p(1,j)  = p(2,j)
          p(nx,j) = p(nxm,j)
        end do

        pl = p(2,2)
!$omp parallel do private(i)
        do j = 2, nym
          do i = 2, nxm
            p(i,j) = p(i,j) - pl  ! hold a point fixed
          end do
        end do

!.... evaluate the residual norm

        pnorm = zero
!$omp parallel do private(i) reduction(+: pnorm)
        do j = 2, nym
          do i = 2, nxm
            pnorm = pnorm + ( ap(i,j) * p(i,j) + ae(i,j) * p(i+1,j) + &
                    an(i,j) * p(i,j+1) + aw(i,j) * p(i-1,j) + &
                    as(i,j) * p(i,j-1) - rp(i,j) )**2
          end do
        end do
        pnorm = sqrt(pnorm / (nxmm*nymm))
        if (k==1) pnorm0 = pnorm
!       pnorm = pnorm / (pnorm0 + 1.0e-20)

        if (pnorm .lt. tol) exit

      end do

      return
end subroutine point_gs_sor

module cg_mod
      real, allocatable :: a(:), rwork(:)
      integer, allocatable :: ia(:), ja(:), iwork(:)
      real :: err
      integer :: nelt, lenw, leniw, iunit=0, ierr
end module cg_mod

subroutine cg( rp, aw, ae, as, an, ap )

      use const
      use global
      use cg_mod
      implicit none

      real :: rp(nx,ny), aw(nx,ny), ae(nx,ny), as(nx,ny), an(nx,ny), ap(nx,ny)

      integer :: nel
      integer :: row

      nelt = 5*nxmm*nymm+2*nx+2*nymm
      lenw = 5*nx*ny+5*nx*ny
      leniw = 5*nx*ny+nx*ny+11

      if (first) then
        allocate( a(nelt), ia(nelt), ja(nelt), rwork(lenw), iwork(leniw) )
        first = .false.
      end if

      as = -as
      an = -an
      aw = -aw
      ae = -ae
      ap = -ap
      rp = -rp

!.... hold a point fixed

      aw(2,2) = zero
      as(2,2) = zero
      ae(2,2) = zero
      an(2,2) = zero
      ap(2,2) = one
      rp(2,2) = zero

!.... Build the SLAP triad format

      do j = 2, nym
        do i = 2, nxm
        row = i + nx*(j-1)

        if (aw(i,j).ne.zero) then
          nel = nel + 1
          ia(nel) = row
          ja(nel) = row-1
          a(nel)  = aw(i,j)
        end if

        if (ae(i,j).ne.zero) then
          nel = nel + 1
          ia(nel) = row
          ja(nel) = row+1
          a(nel)  = ae(i,j)
        end if

        if (ap(i,j).ne.zero) then
          nel = nel + 1
          ia(nel) = row
          ja(nel) = row
          a(nel)  = ap(i,j)
        end if

        if (an(i,j).ne.zero) then
          nel = nel + 1
          ia(nel) = row
          ja(nel) = row+nx
          a(nel)  = an(i,j)
        end if

        if (as(i,j).ne.zero) then
          nel = nel + 1
          ia(nel) = row
          ja(nel) = row-nx
          a(nel)  = as(i,j)
        end if
        end do
      end do

      do i = 1, nx
        nel = nel + 1
        ia(nel) = i
        ja(nel) = i
        a(nel) = one
        nel = nel + 1
        ia(nel) = i+nx*nym
        ja(nel) = i+nx*nym
        a(nel) = one
      end do

      do j = 2, nym
        nel = nel + 1
        ia(nel) = 1+nx*(j-1)
        ja(nel) = 1+nx*(j-1)
        a(nel) = one
        nel = nel + 1
        ia(nel) = nx+nx*(j-1)
        ja(nel) = nx+nx*(j-1)
        a(nel) = one
      end do

      nelt = nel

!     if (nel.ne.nelt) call error('cg$','Nel .ne. Nelt$')

!      do nel = 1, nelt
!       if (ia(nel) .eq. ja(nel)) then
!          write(*,"(2(i5,1x),1pe13.6)") ia(nel), ja(nel), a(nel)
!       end if
!      end do

      call DSICCG(nx*ny, rp, p, nelt, ia, ja, a, 0, 1, tol, kmax, k, &
                  err, ierr, iunit, rwork, lenw, iwork, leniw)

!     call DSDCG(nx*ny, rp, p, nelt, ia, ja, a, 0, 1, tol, kmax, k, &
!                err, ierr, iunit, rwork, lenw, iwork, leniw)

      if (ierr.ne.0) then
        write(*,*) ierr
!       call error('cg$','Error in Conjugate Gradient routine$')
      end if

end subroutine cg

module sip_mod
      real ,allocatable :: ue(:,:), un(:,:), lw(:,:), ls(:,:), &
                           lpr(:,:), res(:,:)
end module sip_mod

subroutine sip( rp, aw, ae, as, an, ap )

!.... SIP solver (Stronly Implicit Solver) -- currently not in parallel

      use const
      use global
      use sip_mod
      implicit none

      real :: rp(nx,ny), aw(nx,ny), ae(nx,ny), as(nx,ny), an(nx,ny), ap(nx,ny)
      real :: p1, p2, pnorm0

!.... coefficients of L and U matrices (these matrices don't change)

      if (first) then
        first = .false.
        allocate( ue(nx,ny), un(nx,ny), lw(nx,ny), ls(nx,ny), &
                  lpr(nx,ny), res(nx,ny) )
        lw = zero; ls = zero; lpr = zero; un = zero; ue = zero
        do j = 2, nym
          do i = 2, nxm
            lw(i,j) = aw(i,j) / ( one + alfa * un(i-1,j) )
            ls(i,j) = as(i,j) / ( one + alfa * ue(i,j-1) )
            p1 = alfa * lw(i,j) * un(i-1,j)
            p2 = alfa * ls(i,j) * ue(i,j-1)
            lpr(i,j) = one / ( ap(i,j) + p1 + p2 - lw(i,j)*ue(i-1,j) - &
                               ls(i,j) * un(i,j-1) + 1.0e-20 )
            un(i,j) = ( an(i,j) - p1 ) * lpr(i,j)
            ue(i,j) = ( ae(i,j) - p2 ) * lpr(i,j)
          end do
        end do
      end if

!.... inner iteration loop

      do k = 1, kmax
        pnorm = zero

!.... form residual

!$omp parallel do private(i) reduction(+: pnorm)
        do j = 2, nym
          do i = 2, nxm
            res(i,j) = rp(i,j) - an(i,j)*p(i,j+1) - as(i,j)*p(i,j-1) - &
                       ae(i,j)*p(i+1,j) - aw(i,j)*p(i-1,j) - ap(i,j)*p(i,j)
            pnorm = pnorm + res(i,j)**2
          end do
        end do
        pnorm = sqrt( pnorm / (nxmm*nymm) )
        if (k.eq.1) pnorm0 = pnorm
!       pnorm = pnorm/(pnorm0+1.0e-20)

!.... forward substitution

        do j = 2, nym
          do i = 2, nxm
             res(i,j) = ( res(i,j) - ls(i,j)*res(i,j-1) - &
                         lw(i,j)*res(i-1,j) ) * lpr(i,j)
          end do
        end do

!.... backward substitution and correction

        do j = nym, 2, -1
          do i = nxm, 2, -1
            res(i,j) = res(i,j) - un(i,j)*res(i,j+1) - ue(i,j)*res(i+1,j)
            p(i,j) = p(i,j) + res(i,j)
          end do
        end do

        if (pnorm .lt. tol) exit

      end do

end subroutine sip

module direct_mod
      use const
      use global
      implicit none
      real, allocatable :: a(:,:)
contains
      subroutine init_direct
        allocate( a(nx*ny,nx*ny) )
      end subroutine init_direct
end module direct_mod

subroutine direct( rp, aw, ae, as, an, ap )

!.... Direct LU-factorization and solve of the Poisson equation for pressure

!.... Note that in general, one only has to factor the matrix operator once
!.... but this is currently done at every time step

      use const
      use global
      use direct_mod
      implicit none

      real :: rp(nx,ny), aw(nx,ny), ae(nx,ny), as(nx,ny), an(nx,ny), ap(nx,ny)
      integer :: row, ipvt(nx*ny), info

!.... hold a point fixed

      aw(2,2) = zero
      as(2,2) = zero
      ae(2,2) = zero
      an(2,2) = zero
      ap(2,2) = one
      rp(2,2) = zero

!$omp parallel do private(i)
      do j = 1, nx*ny
        do i = 1, nx*ny
          a(i,j)  = zero
        end do
      end do

!$omp parallel do private(i, row)
      do j = 2, nym
        do i = 2, nxm
          row = i + nx*(j-1)
          a(row,row-1)  = aw(i,j)
          a(row,row+1)  = ae(i,j)
          a(row,row)    = ap(i,j)
          a(row,row+nx) = an(i,j)
          a(row,row-nx) = as(i,j)
        end do
      end do

!$omp parallel do
      do i = 1, nx
        a(i,i) = one
        a(i+nx*nym,i+nx*nym) = one
      end do

!$omp parallel do
      do j = 1, ny
        a(1+nx*(j-1),1+nx*(j-1)) = one
        a(nx+nx*(j-1),nx+nx*(j-1)) = one
      end do
#ifdef USE_LINPACK
      call SGEFA( a, nx*ny, nx*ny, ipvt, info )
      if (info.ne.0) call error('direct$','Singular matrix$')
      call SGESL( A, nx*ny, nx*ny, ipvt, rp, 0)
#else
      write(*,*) "Need to fix LINPACK reference"
      stop
#endif

!$omp parallel do private(i)
      do j = 1, ny
        do i = 1, nx
          p(i,j) = rp(i,j)
        end do
      end do

!.... evaluate the residual norm

        pnorm = zero
!$omp parallel do private(i) reduction(+: pnorm)
        do j = 2, nym
          do i = 2, nxm
            pnorm = pnorm + ( ap(i,j) * p(i,j) + ae(i,j) * p(i+1,j) + &
                    an(i,j) * p(i,j+1) + aw(i,j) * p(i-1,j) + &
                    as(i,j) * p(i,j-1) - rp(i,j) )**2
          end do
        end do
        pnorm = sqrt(pnorm / (nxmm*nymm))

      return
end subroutine direct

subroutine line_gs_sor( rp, aw, ae, as, an, ap )

!.... Solve the pressure Poisson equation using line GS with SOR

      use const
      use global
      implicit none

      real :: rp(nx,ny), aw(nx,ny), ae(nx,ny), as(nx,ny), an(nx,ny), ap(nx,ny)
      real :: dp(nx,ny), pl

      do k = 1, kmax

!.... solve for pressure using line GS-SOR in y

!!$     do i = 2, nxm
!!$       dp(i,2:nym) = -ae(i,2:nym) * p(i+1,2:nym) - &
!!$                      aw(i,2:nym) * p(i-1,2:nym) + rp(i,2:nym)
!!$       call TRDIAG( nymm, as(i,2:nym), ap(i,2:nym), &
!!$                       an(i,2:nym), dp(i,2:nym), dp(i,2:nym) )
!!$       p(i,2:nym) = (one-omega)*p(i,2:nym) + omega*dp(i,2:nym)
!!$     end do
!!$
!!$     p(2:nxm,2:nym) = p(2:nxm,2:nym) - p(2,2)  ! hold a point fixed

!.... solve for pressure using line GS-SOR in x

!$omp parallel do shared(nxmm)
        do j = 2, nym
          dp(2:nxm,j) = -an(2:nxm,j) * p(2:nxm,j+1) - &
                         as(2:nxm,j) * p(2:nxm,j-1) + rp(2:nxm,j)
          call TRDIAG( nxmm, aw(2:nxm,j), ap(2:nxm,j), &
                       ae(2:nxm,j), dp(2:nxm,j), dp(2:nxm,j) )
          p(2:nxm,j) = (one-omega)*p(2:nxm,j) + omega*dp(2:nxm,j)
        end do

        pl = p(2,2)
!$omp parallel do private(i)
        do j = 2, nym
          do i = 2, nxm
            p(i,j) = p(i,j) - pl  ! hold a point fixed
          end do
        end do

!.... evaluate the residual norm

        pnorm = zero
!$omp parallel do private(i) reduction(+: pnorm)
        do j = 2, nym
          do i = 2, nxm
            pnorm = pnorm + ( ap(i,j) * p(i,j) + ae(i,j) * p(i+1,j) + &
                    an(i,j) * p(i,j+1) + aw(i,j) * p(i-1,j) + &
                    as(i,j) * p(i,j-1) - rp(i,j) )**2
          end do
        end do
        pnorm = sqrt(pnorm / (nxmm*nymm))

        if (pnorm .lt. tol) exit

      end do

      return
end subroutine line_gs_sor

subroutine adi( rp, aw, ae, as, an, ap )

!.... Solve the pressure Poisson equation using ADI

      use const
      use global
      implicit none

      real :: rp(nx,ny), aw(nx,ny), ae(nx,ny), as(nx,ny), an(nx,ny), ap(nx,ny)
      real :: dp(nx,ny), pl

      do k = 1, kmax

!.... solve for pressure using ADI

!$omp parallel do private(i)
        do j = 2, nym
          do i = 2, nxm
            dp(i,j) = dtau * ( ap(i,j) * p(i,j)   + ae(i,j) * p(i+1,j) + &
                      an(i,j) * p(i,j+1) + aw(i,j) * p(i-1,j) + &
                      as(i,j) * p(i,j-1) - rp(i,j) )
          end do
        end do

!$omp parallel do shared( nymm )
        do i = 2, nxm
          call TRDIAG( nymm, &
                       -dtau * as(i,2:nym), &
                        one + dtau * ( as(i,2:nym) + an(i,2:nym) ), &
                       -dtau * an(i,2:nym), dp(i,2:nym), dp(i,2:nym) )
        end do

!$omp parallel do shared( nxmm )
        do j = 2, nym
          call TRDIAG( nxmm, &
                       -dtau * aw(2:nxm,j), &
                       one + dtau * ( aw(2:nxm,j) + ae(2:nxm,j) ), &
                       -dtau * ae(2:nxm,j), dp(2:nxm,j), dp(2:nxm,j) )
        end do

        pl = dp(2,2)
!$omp parallel do private(i)
        do j = 2, nym
          do i = 2, nxm
            p(i,j) = p(i,j) + dp(i,j) - pl
          end do
        end do

!.... evaluate the residual norm

        pnorm = zero
!$omp parallel do private(i) reduction(+: pnorm)
        do j = 2, nym
          do i = 2, nxm
            pnorm = pnorm + ( ap(i,j) * p(i,j) + ae(i,j) * p(i+1,j) + &
                    an(i,j) * p(i,j+1) + aw(i,j) * p(i-1,j) + &
                    as(i,j) * p(i,j-1) - rp(i,j) )**2
          end do
        end do
        pnorm = sqrt(pnorm / (nxmm*nymm))

        if (pnorm .lt. tol) exit

      end do

      return
end subroutine adi

subroutine setdt

!.... set the time-step based on a CFL condition

      use const
      use global
      implicit none

      real :: dtinv, dyinv, dxinv

!.... compute the convective CFL (diffusion effects are not included)

      dtinv = zero
!$omp parallel do private(i,dyinv,dxinv) reduction(max: dtinv)
      do j = 2, nym
        dyinv = one/(y(j) - y(j-1))
        do i = 2, nxm
          dxinv = one/(x(i) - x(i-1))
          dtinv = max( abs(uc(i,j)*dxinv)+ abs(vc(i,j)*dyinv), dtinv)
        end do
      end do

      dt = min( dt_max, cfl_max / dtinv )
      cfl = dt * dtinv

      return
end subroutine setdt

subroutine setup

!.... Input run parameters and form the grid

      use timemod
      use const
      use global
      use direct_mod
      implicit none

      integer :: idum
      real :: rdum, mu

      namelist /in/ Re, nstep, cfl_max, dt_max, tol, ictype, method, &
                    axis, kmax, omega, dtau, pmethod, base, nout, delta_p, &
                    alfa, bottom_bc, top_bc, left_bc, right_bc

!.... start the clock

      cpu  = second()
      cpu0 = cpu

!.... set default values for input variables

      Re=100.0; nstep=1000; cfl_max=0.8; dt_max=1.0e4; tol=1.0e-6; kmax=1000;
      ictype=0; method=0; axis=.false.; rho=one; omega = 1.0; dtau = 0.1;
      pmethod=0; base='output'; nout=100; delta_p = .true.; alfa = 1.9
      first=.true.; bottom_bc=0; top_bc=0; left_bc=0; right_bc=0

!.... get namelist input

      read(*,in)

      base = base(1:index(base,' ')-1)//char(0) ! null terminate
      filen = char(0)

      vis = one / Re

!.... read grid file

      open(io,file='grid.in',form='formatted',status='old',err=100)
      read(io,*,err=110,end=110) nx, ny
      write(*,"('Read grid with (',i3,',',i3,') CV''s ')") nx-2, ny-2
      allocate( x(nx), y(ny) )
      read(io,*,err=110,end=110) ( x(i), i=1,nx )
      read(io,*,err=110,end=110) ( y(j), j=1,ny )
      close(io)

      nxm  = nx - 1
      nym  = ny - 1
      nxmm = nxm - 1
      nymm = nym - 1

!.... allocate Matrix if using direct solver

      if (pmethod.eq.3) call init_direct

!.... dynamically set SOR parameter

      if (omega.eq.0) then
        mu = one - pt25 * pi**2 * ( one/nxmm**2 + one/nymm**2 )
        omega = two / ( one + sqrt( one - mu**2 ) )
        write(*,"('SOR parameter automatically set to ', 1pe13.6)") omega
      end if

!.... compute coordinates of CV-centers

      allocate ( xc(nx), yc(ny) )
      xc(1) = x(1)
      do i = 2, nxm
        xc(i) = pt5 * ( x(i) + x(i-1) )
      end do
      xc(nx) = x(nxm)

      yc(1) = y(1)
      do j = 2, nym
        yc(j) = pt5 * ( y(j) + y(j-1) )
      end do
      yc(ny) = y(nym)

!.... set the radius

      allocate ( r(ny), fx(nx), fy(ny) )
      if (axis) then
        r = y
      else
        r = one
      end if

!.... Interpolation factors (on scalar CVs)

      fx(1) = zero
      do i = 2, nxm
        fx(i) = (x(i)-x(i-1))/(x(i+1)-x(i-1))
      end do
      fx(nx) = zero

      fy(1) = zero
      do j = 2, nym
        fy(j) = (y(j)-y(j-1))/(y(j+1)-y(j-1))
      end do
      fy(ny) = zero

!.... allocate field variables

      allocate( u(nx,ny), v(nx,ny), p(nx,ny) )
      allocate( u_old(nx,ny), v_old(nx,ny), p_old(nx,ny) )
      allocate(uc(nx,ny),vc(nx,ny),pc(nx,ny),div(nx,ny),wz(nx,ny),ke(nx,ny))

!.... allocate mass flux variables

      allocate( cx(nx,ny), cy(nx,ny), ru(nx,ny), rv(nx,ny) )

!.... initialize all fields to zero (first touch policy for OpenMP)

!$omp parallel do private(i)
      do j = 1, ny
        do i = 1, ny
          u(i,j) = zero; v(i,j) = zero; p(i,j) = zero
          u_old(i,j) = zero; v_old(i,j) = zero; p_old(i,j) = zero
          uc(i,j) = zero; vc(i,j) = zero; pc(i,j) = zero;
          div(i,j) = zero; wz(i,j) = zero; ke(i,j) = zero
          cx(i,j) = zero; cy(i,j) = zero; ru(i,j) = zero; rv(i,j) = zero
        end do
      end do

      return
100   call error('setup$','Unable to open grid.in$')
110   call error('setup$','Error reading grid.in$')
end subroutine setup

subroutine bc

!.... Set the boundary conditions

      use const
      use global
      implicit none

!.... Bottom

      select case (bottom_bc)
      case ( 0 )
        u(1:nxm,1) = zero            ! no slip
        v(1:nx,1)  = zero
      case ( 1 )
        u(1:nxm,1) = u(1:nxm,2)      ! slip
        v(1:nx,1)  = zero
      case default
        call error('bc$','Illegal bottom bc code$')
      end select

!.... Top

      select case (top_bc)
      case ( 0 )
        u(1:nxm,ny) = zero           ! no slip
        v(1:nx,nym) = zero
      case ( 1 )
        u(1:nxm,ny) = u(1:nxm,ny-1)  ! slip
        v(1:nx,nym) = zero
      case default
        call error('bc$','Illegal top bc code$')
      end select

!.... Left

      select case (left_bc)
      case ( 0 )
        u(1,1:ny)  = zero           ! no slip
        v(1,1:nym) = zero
      case ( 1 )
        u(1,1:ny)  = zero           ! slip
        v(1,1:nym) = v(2,1:nym)
      case default
        call error('bc$','Illegal left bc code$')
      end select

!.... Right

      select case (right_bc)
      case ( 0 )
        u(nxm,1:ny) = zero          ! no slip
        v(nx,1:nym) = zero
      case ( 1 )
        u(nxm,1:ny) = zero          ! slip
        v(nx,1:nym) = v(nx-1,1:nym)
      case default
        call error('bc$','Illegal right bc code$')
      end select

      return
end subroutine bc

subroutine ic

!.... Set the initial condition

      use const
      use global
      implicit none
      real :: x0 = 2.0, y0 = 16.0

      n = 0         ! time-step zero
      time = zero

!.... Initialize to no-flow

!$omp parallel do private(i)
      do j = 1, ny
        do i = 1, nx
          u(i,j) = zero
          v(i,j) = zero
          p(i,j) = zero
        end do
      end do

!.... Add two Oseen vortices

      call Oseen( -one, -x0, y0, u, v )
      call Oseen(  one,  x0, y0, u, v )

!.... enforce the boundary conditions

      call bc

!.... compute mass fluxes and project to divergence free space

      call calc_p( one, u, v, .true. )

!.... compute the pressure for the initial condition from the divergence
!.... of the discrete momentum equations

      call calc_u( .false. )
      call calc_v( .false. )
      call calc_p( one,  ru, rv, .false. )

!.... interpolate to cell centered mesh and calculate statistics

      call interp
      call stats

!.... save the IC in a restart file and Plot3d file

      iver = 0
      call addver(base, 'R'//char(0), iver, filen, lfile)
      open(io,file=filen,form='unformatted')
      write(io) n, nx, ny
      write(io) Re, time
      write(io) u, v, p, cx, cy
      close(io)
      iver = 0
      call addver(base, 'q'//char(0), iver, filen, lfile)
      call wdata( filen )

      return
end subroutine ic

subroutine wdata( fname )

!.... Write a Plot3d solution file assuming that
!.... pc, uc, vc, wz, and ke are valid

      use const
      use global
      implicit none

      character*80 :: fname

!.... output Plot3d solution-file at CV-centers

      open(io,file=fname,form='unformatted')
      write(io) nx, ny, 1
      write(io) zero, zero, Re, time
      write(io) (( pc(i,j), i=1,nx), j=1,ny), &
                (( uc(i,j), i=1,nx), j=1,ny), &
                (( vc(i,j), i=1,nx), j=1,ny), &
                (( wz(i,j), i=1,nx), j=1,ny), &
                (( ke(i,j), i=1,nx), j=1,ny)
      close(io)

      return
end subroutine wdata

subroutine wgrid

!.... write a Plot3d grid-file at CV-centers

      use const
      use global
      implicit none

      open(io,file='grid.dat',form='unformatted')
      write(io) nx, ny, 1
      write(io) (( xc(i), i = 1, nx), j = 1, ny), &
                (( yc(j), i = 1, nx), j = 1, ny), &
                ((  zero, i = 1, nx), j = 1, ny)
      close(io)

      return
end subroutine wgrid

subroutine stats

!.... Computes divergence, vorticity, kinetic energy, and total enstrophy

      use const
      use global
      implicit none

      real :: area

!.... Vorticity must first be computed on the nodal mesh and then interpolated
!.... to the cell centered mesh

!$omp parallel do private(i)
      do j = 1, nym
        do i = 1, nxm
          div(i,j) = (v(i+1,j)-v(i,j))/(xc(i+1)-xc(i)) - &
                     (u(i,j+1)-u(i,j))/(yc(j+1)-yc(j))
        end do
      end do

!.... Now interpolate back to the cell centered mesh

      wz(1,1)      = div(1,1)
      wz(1,2:nym)  = pt5 * (div(1,2:nym) + div(1,1:nymm))
      wz(1,ny)     = div(1,nym)
      wz(2:nxm,ny) = pt5 * (div(2:nxm,nym) + div(1:nxmm,nym))
      wz(nx,ny)    = div(nxm,nym)
      wz(nx,2:nym) = pt5 * (div(nxm,2:nym) + div(nxm,1:nymm))
      wz(nx,1)     = div(nxm,1)
      wz(2:nxm,1)  = pt5 * (div(2:nxm,1) + div(1:nxmm,1))

!$omp parallel do private(i)
      do j = 2, nym
        do i = 2, nxm
          wz(i,j) = pt25 * ( div(i,j) + div(i-1,j) + &
                             div(i,j-1) + div(i-1,j-1) )
        end do
      end do

!.... Divergence and Kinetic energy are easily computed
!.... on the cell centered mesh

!$omp parallel do private(i)
      do j = 2, nym
        do i = 2, nxm
          div(i,j) = rho * ( (u(i,j) - u(i-1,j)) * (y(j)-y(j-1)) + &
                             (v(i,j) - v(i,j-1)) * (x(i)-x(i-1)) )
          ke(i,j)  = pt5 * ( uc(i,j)**2 + vc(i,j)**2 )
        end do
      end do

!.... Integrate to get the total Energy and Enstrophy

      tke = zero; enstrophy = zero; tdiv = zero
!$omp parallel do private(i, area) reduction(+: tdiv, tke, enstrophy)
      do j = 2, nym
        do i = 2, nxm
          area = (x(i)-x(i-1)) * (y(j)-y(j-1))
          tdiv = tdiv + div(i,j)**2
          tke = tke + ke(i,j) * area
          enstrophy = enstrophy + wz(i,j)**2 * area
        end do
      end do
      enstrophy = pt5 * enstrophy
      tdiv = sqrt( tdiv / (nxmm*nymm) )

      write(istat,"(8(1pe13.6,1x))") time, tdiv, tke, enstrophy

      return
end subroutine stats

subroutine Oseen( Gamma, x0, y0, ul, vl )

!.... Computes the velocity field for an Oseen vortex centered at
!.... (x0,y0) with circulation Gamma

      use global
      use const
      implicit none

      real :: ul(nx,ny), vl(nx,ny)
      real :: gamma, x0, y0, rr, theta, xi, alpha = 1.2564312086261696770
      real :: v_theta, v_r

!.... Oseen vortex at (x0, y0)

      xi = one - exp( -alpha )

!$omp parallel do private(i, rr, theta, v_theta, v_r)
      do j = 1, ny
        do i = 1, nxm
          rr = sqrt( (x(i)-x0)**2 + (yc(j)-y0)**2 )
          theta = atan2( yc(j)-y0, x(i)-x0 )

          if (rr.eq.zero) then
            v_theta = zero
            v_r = zero
          else
            v_theta = gamma * ( one - exp( -alpha * rr**2 ) ) / ( rr * xi )
            v_r = zero
          endif

          ul(i,j) = ul(i,j) + cos(theta) * v_r - sin(theta) * v_theta
        end do
      end do

!$omp parallel do private(i, rr, theta, v_theta, v_r)
      do j = 1, nym
        do i = 1, nx
          rr = sqrt( (xc(i)-x0)**2 + (y(j)-y0)**2 )
          theta = atan2( y(j)-y0, xc(i)-x0 )

          if (rr.eq.zero) then
            v_theta = zero
            v_r = zero
          else
            v_theta = gamma * ( one - exp( -alpha * rr**2 ) ) / ( rr * xi )
            v_r = zero
          endif

          vl(i,j) = vl(i,j) + sin(theta) * v_r + cos(theta) * v_theta
        end do
      end do

      return
end subroutine Oseen

subroutine interp

!.... Interpolate velocities and pressure to cell centered mesh

      use const
      use global
      implicit none

      pc(1,1)      = p(2,2)
      pc(nx,1)     = p(nxm,2)
      pc(1,ny)     = p(2,nym)
      pc(nx,ny)    = p(nxm,nym)
      pc(2:nxm,1)  = p(2:nxm,2)
      pc(2:nxm,ny) = p(2:nxm,nym)
      pc(1,2:nym)  = p(2,2:nym)
      pc(nx,2:nym) = p(nxm,2:nym)
!$omp parallel do private(i)
      do j = 2, nym
        do i = 2, nxm
          pc(i,j) = p(i,j)
        end do
      end do

      uc(1,1) = u(1,1)
      vc(1,1) = v(1,1)
      uc(nx,1) = u(nxm,1)
      vc(nx,1) = v(nx,1)

!$omp parallel do
      do j = 2, nym
        uc(1,j) = u(1,j)
        vc(1,j) = pt5*(v(1,j)+v(1,j-1))
        uc(nx,j) = u(nxm,j)
        vc(nx,j) = pt5*(v(nx,j)+v(nx,j-1))
      end do

      uc(1,ny) = u(1,ny)
      vc(1,ny) = v(1,nym)
      uc(nx,ny) = u(nxm,ny)
      vc(nx,ny) = v(nx,nym)

!$omp parallel do
      do i = 2, nxm
        uc(i,1) = pt5*(u(i,1)+u(i-1,1))
        vc(i,1) = v(i,1)
        uc(i,ny) = pt5*(u(i,ny)+u(i-1,ny))
        vc(i,ny) = v(i,nym)
      end do

!$omp parallel do private(i)
      do j = 2, nym
        do i = 2, nxm
          uc(i,j) = pt5*(u(i,j)+u(i-1,j))
          vc(i,j) = pt5*(v(i,j)+v(i,j-1))
        end do
      end do

      return
end subroutine interp

subroutine restart

!.... restart the computation using data from a previous run

!.... Assumes that the flow field is divergence free

      use const
      use global
      implicit none

      integer :: inx, iny, idum
      real :: rdum

!.... read a restart file

      iver = igetver( base, 'R'//char(0) )
      call addver(base, 'R'//char(0), iver, filen, lfile)
      write (*,10) filen(1:index(filen,' ')-2)
10    format(/,'Restarting from file:  ',a)

      open(io,file=filen,form='unformatted')
      read(io) n, inx, iny
      if (inx.ne.nx .or. iny.ne.ny) &
        call error('restart$','Incompatible restart file.$')
      read(io) rdum, time
      read(io) u, v, p, cx, cy
      close(io)

      write(*,"('Restarting at step ',i5,' at time = ',1pe13.6)") n, time

      return
end subroutine restart

subroutine error(name,msg)

!.... Error handler

      implicit none

      integer loc
      character(*) name, msg

      loc = index(name,'$')-1
      write(*,"(/,'*****************************************************')")
      write(*,"('Error in --> ',a)") name(1:loc)
      loc = index(msg,'$')-1
      write(*,"('-----------> ',a)") msg(1:loc)
      write(*,"('*****************************************************',/)")

      stop
end subroutine error

subroutine TRDIAG (N,A,B,C,X,G)
      dimension A(N),B(N),C(N),X(N),G(N),BB(N)
!.....THIS SUBROUTINE SOLVES TRIDIAGONAL SYSTEMS OF EQUATIONS
!.....BY GAUSS ELIMINATION
!.....THE PROBLEM SOLVED IS MX=G where M=TRI(A,B,C)
!.....THIS ROUTINE DOES NOT DESTROY THE ORIGINAL MATRIX
!.....AND MAY BE CALLED A NUMBER OF TIMES WITHOUT REDEFINING
!.....THE MATRIX
!.....N = NUMBER OF EQUATIONS SOLVED
!.....FORWARD ELIMINATION
!.....BB IS A SCRATCH ARRAY NEEDED TO AVOID DESTROYING B ARRAY
      do I=1,N
        BB(I) = B(I)
      end do
      do I=2,N
        T = A(I)/BB(I-1)
        BB(I) = BB(I) - C(I-1)*T
        G(I) = G(I) - G(I-1)*T
      end do
!.....BACK SUBSTITUTION
      X(N) = G(N)/BB(N)
      do I=1,N-1
        J = N-I
        X(J) = (G(J)-C(J)*X(J+1))/BB(J)
      end do
      return
end subroutine TRDIAG