#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_unifact_deflationcheck
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks for deflations in a unitary upper hessenberg
! matrix that is stored as a product of givens rotations and a complex
! diagonal matrix. When a deflation occurs the corresponding rotation
! is set to the identity matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    generators must be orthogonal to working precision
!
! OUTPUT VARIABLES:
!
!  ZERO            INTEGER
!                     index of the last known deflation
!                     on output contains index of newest deflation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_unifact_deflationcheck(N,Q,D,ZERO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  integer, intent(inout) :: ZERO
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N)

  ! compute variables
  integer :: ii, jj, down
  real(8), parameter :: tol = EISCOR_DBL_EPS
  real(8) :: dr, di, qr, qi, s, nrm

  ! intialize ZERO
  ZERO = 0

  ! check for deflation
  do ii=1,(N-1)

    ! deflate if subdiagonal is small enough
    nrm = abs(Q(3*(N-ii)))
    if(nrm < tol)then

      ! set ZERO
      ZERO = max(0,N-ii)  ! why 0?

      ! extract diagonal
      qr = Q(3*ZERO-2)
      qi = Q(3*ZERO-1)

      ! set rotation to identity
      Q(3*ZERO-2) = 1d0
      Q(3*ZERO-1) = 0d0
      Q(3*ZERO) = 0d0

      ! update first diagonal
      dr = D(2*ZERO-1)
      di = D(2*ZERO)

      nrm = qr*dr - qi*di
      di = qr*di + qi*dr
      dr = nrm
      call d_rot2_vec2gen(dr,di,D(2*ZERO-1),D(2*ZERO),nrm)

      ! deflate downward
      do jj = 1,(N-1-ZERO)

        ! set downward index
        down = ZERO+jj

        ! update Q
        dr = Q(3*down-2)
        di = Q(3*down-1)
        s = Q(3*down)

        nrm = qr*dr + qi*di
        di = qr*di - qi*dr
        dr = nrm

        call z_rot3_vec3gen(dr,di,s,Q(3*down-2),Q(3*down-1),Q(3*down),nrm)

      end do

      ! update second diagonal
      dr = D(2*N-1)
      di = D(2*N)

      nrm = qr*dr + qi*di
      di = qr*di - qi*dr
      dr = nrm
      call d_rot2_vec2gen(dr,di,D(2*N-1),D(2*N),nrm)

      ! exit loop
      exit

    end if

  end do

end subroutine z_unifact_deflationcheck


*
*     --------------------------------------------------------------
*       T R E D 1
*     --------------------------------------------------------------
*
*
      SUBROUTINE TRED1(NM,N,A,D,E,E2)
*
      INTEGER I,J,K,L,N,II,NM,JP1
      DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N)
      DOUBLE PRECISION F,G,H,SCALE
      DOUBLE PRECISION DSQRT,DABS,DSIGN
*
*     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
*     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
*     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
*
*     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
*     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
*     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
*
*     ON INPUT:
*
*        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
*          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
*          DIMENSION STATEMENT;
*
*        N IS THE ORDER OF THE MATRIX;
*
*        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
*          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
*
*     ON OUTPUT:
*
*        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
*          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
*          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED;
*
*        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX;
*
*        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
*          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO;
*
*        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
*          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
*
*     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
*     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
*
*     ------------------------------------------------------------------
*
      DO 100 I = 1, N
  100 D(I) = A(I,I)
*     :::::::::: FOR I=N STEP -1 UNTIL 1 DO -- ::::::::::
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         IF (L .LT. 1) GO TO 130
*     :::::::::: SCALE ROW (ALGOL TOL THEN NOT NEEDED) ::::::::::
         DO 120 K = 1, L
  120    SCALE = SCALE + DABS(A(I,K))
*
         IF (SCALE .NE. 0.0D0) GO TO 140
  130    E(I) = 0.0D0
         E2(I) = 0.0D0
         GO TO 290
*
  140    DO 150 K = 1, L
            A(I,K) = A(I,K) / SCALE
            H = H + A(I,K) * A(I,K)
  150    CONTINUE
*
         E2(I) = SCALE * SCALE * H
         F = A(I,L)
         G = -DSIGN(DSQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         A(I,L) = F - G
         IF (L .EQ. 1) GO TO 270
         F = 0.0D0
*
         DO 240 J = 1, L
            G = 0.0D0
*     :::::::::: FORM ELEMENT OF A*U ::::::::::
            DO 180 K = 1, J
  180       G = G + A(J,K) * A(I,K)
*
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
*
            DO 200 K = JP1, L
  200       G = G + A(K,J) * A(I,K)
*     :::::::::: FORM ELEMENT OF P ::::::::::
  220       E(J) = G / H
            F = F + E(J) * A(I,J)
  240    CONTINUE
*
         H = F / (H + H)
*     :::::::::: FORM REDUCED A ::::::::::
         DO 260 J = 1, L
            F = A(I,J)
            G = E(J) - H * F
            E(J) = G
*
            DO 260 K = 1, J
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  260    CONTINUE
*
  270    DO 280 K = 1, L
  280    A(I,K) = SCALE * A(I,K)
*
  290    H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
  300 CONTINUE
*
      RETURN
*     :::::::::: LAST CARD OF TRED1 ::::::::::
      END


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

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_FIELD_VARS

    USE MR_MOC_K_EPS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_UPDT_KI_N_DI

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: TBUV_MOD

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:,  :  ) :: EQKD_PRO_XY , EQKD_PRO_Z , EQKD_BRO_Z

    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:,  :  ) :: EQK_A3 , EQK_B3 , EQK_C3
    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:,  :  ) :: EQK_D3
    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:,  :  ) :: EQD_A3 , EQD_B3 , EQD_C3
    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:,  :  ) :: EQD_D3

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

  CONTAINS

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

    USE MR_MOD_OPERATOR_SS
    USE MR_MOD_OPERATOR_UV

    USE MR_MOD_CALC_EQKD_PRO_XY
    USE MR_MOD_CALC_EQKD_PRO_Z
    USE MR_MOD_CALC_EQKD_BRO_Z

    USE MR_MOD_CALC_EQK_A3_B3_C3_D3
    USE MR_MOD_CALC_EQD_A3_B3_C3_D3

    USE MR_MOD_TDMA3

    IMPLICIT NONE

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( EQKD_PRO_XY(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) ,   &
    & EQKD_PRO_Z(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) ,   &
    & EQKD_BRO_Z(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) )

      CALL MR_CALC_EQKD_PRO_XY( NI , NJ , NK , EQKD_PRO_XY )
      CALL MR_CALC_EQKD_PRO_Z(  NI , NJ , NK , EQKD_PRO_Z  )
      CALL MR_CALC_EQKD_BRO_Z(  NI , NJ , NK , EQKD_BRO_Z  )

     !BLOCK
    ! CALCULATE KI(:,:, 1 )
      ALLOCATE( TBUV_MOD(1:NI1(NI,FDRD_KIND),1:NJ) )
        TBUV_MOD = .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. TBUV ) )
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            KI( I , J , 1 ) = TBUV_MOD( I , J ) / ( SQRT(CV0) )
          END DO
        END DO
      DEALLOCATE( TBUV_MOD )
     !END BLOCK

      ALLOCATE( EQK_D3(1:NI1(NI,CARD_KIND),1:NJ,1:NK) )
        CALL MR_CALC_EQK_D3( NI , NJ , NK , EQKD_PRO_XY , EQKD_PRO_Z , EQKD_BRO_Z , EQK_D3 )
        ALLOCATE( EQK_A3(1:NI1(NI,CARD_KIND),1:NJ,2:NK) ,   &
        & EQK_B3(1:NI1(NI,CARD_KIND),1:NJ,1:NK  ) ,   &
        & EQK_C3(1:NI1(NI,CARD_KIND),1:NJ,1:NK-1) )
          CALL MR_CALC_EQK_A3_B3_C3( NI , NJ , NK , EQK_A3 , EQK_B3 , EQK_C3 )
          !BLOCK
            KI = MAX( MR_TDMA3_SS( NI , NJ , NK , EQK_A3 , EQK_B3 , EQK_C3 , EQK_D3 ) , EPSILON(KI) )
          !END BLOCK
        DEALLOCATE( EQK_A3 , EQK_B3 , EQK_C3 )
      DEALLOCATE( EQK_D3 )

     !BLOCK
    ! CALCULATE DI(:,:, 1 ), DI(:,:,NK )
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          DI( I , J , 1 ) = ( ( KI( I , J , 1 ) * SQRT(CV0) )**1.5 ) / ( SQRT(RBT) * KAR * H( I , J ) * ( 0.5 * DSIGMA ) )
          DI( I , J ,NK ) = ( ( KI( I , J ,NK )             )**1.5 ) / ( SQRT(RBT) *0.430* H( I , J )                    )
        END DO
      END DO
     !END BLOCK

      ALLOCATE( EQD_D3(1:NI1(NI,CARD_KIND),1:NJ,1:NK) )
        CALL MR_CALC_EQD_D3( NI , NJ , NK , EQKD_PRO_XY , EQKD_PRO_Z , EQD_D3 )
        ALLOCATE( EQD_A3(1:NI1(NI,CARD_KIND),1:NJ,2:NK) ,   &
        & EQD_B3(1:NI1(NI,CARD_KIND),1:NJ,1:NK  ) ,   &
        & EQD_C3(1:NI1(NI,CARD_KIND),1:NJ,1:NK-1) )
          CALL MR_CALC_EQD_A3_B3_C3( NI , NJ , NK , EQD_A3 , EQD_B3 , EQD_C3 )
          !BLOCK
            DI = MAX( MR_TDMA3_SS( NI , NJ , NK , EQD_A3 , EQD_B3 , EQD_C3 , EQD_D3 ) , EPSILON(DI) )
          !END BLOCK
        DEALLOCATE( EQD_A3 , EQD_B3 , EQD_C3 )
      DEALLOCATE( EQD_D3 )

    DEALLOCATE( EQKD_PRO_XY , EQKD_PRO_Z , EQKD_BRO_Z )

  END SUBROUTINE MR_UPDT_KI_N_DI

  END MODULE MR_MOD_UPDT_KI_N_DI


!---------------------------------------------------------------*

PROGRAM test_calcVolume

!

      use mt19937, only : grnd, init_genrand, rnorm, mt, mti

  IMPLICIT NONE
!   Random number generator initiation
    integer IDUM
    character*8 datedum
    character*10 timedum
    character*5 zonedum
    integer seedvalues(8)

    integer, parameter :: NBINX=30
    integer confineType
    double precision DEL, lbox
    double precision Vol(NBINX*NBINX*NBINX)

    integer I  !for loops
    double precision Voltotal
    confineType=3
    DEL=1.0
    lbox=30.0

    !   Seed the random number generator off the computer clock

    call date_and_time(datedum,timedum,zonedum,seedvalues)
    ! concatenate filename, time within mins, secs, millisecs to seed random number generator
    IDUM=-seedvalues(5)*1E7-seedvalues(6)*1E5-seedvalues(7)*1E3-seedvalues(8)
    call init_genrand(IDUM)

    call MC_caclVolume(confineType,NBINX,DEL, LBox, &
                               Vol)
    Voltotal=0.0
    Do I=1,NBINX**3
        VolTotal=volTotal+Vol(I)
    enddo
    print*, "Vol total: ", VolTotal

end program


!>------------------------------------------------------------
!!  Module to test the calendar routines
!!
!!  Loops through 2100? years checking that conversions two and from an
!!  internal date-time (e.g. Modified Julian Day) and YMD hms are consistent
!!  test multiple calendars
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!!------------------------------------------------------------
module calendar_test_module
    use time
    integer, parameter :: STRING_LENGTH = 255
    real, parameter :: MAX_ERROR = 1e-5 ! allow less than 1 second error (over a 2100 yr period)
contains
    logical function calendar_test(calendar_name,error)
        character(len=STRING_LENGTH), intent(in) :: calendar_name
        character(len=STRING_LENGTH), intent(out) :: error

        double precision :: mjd_input, mjd_output
        double precision :: min_mjd, max_mjd, mjd_step
        integer :: year, month, day, hour, minute, second

        error=""
        calendar_test=.True.

        call time_init(calendar_name)
        min_mjd=365.0*1.d0
        max_mjd=365.0*2100.d0
        mjd_step=0.1

        MJDLOOP: do mjd_input = min_mjd, max_mjd, mjd_step
            ! test that input and output Modified Julian Days stay the same
            call calendar_date(mjd_input, year, month, day, hour, minute, second)
            mjd_output=date_to_mjd(year, month, day, hour, minute, second)

            ! test that month and day values are at least realistic (rare to fail)
            if ((day<1).or.(day>31)) then
                calendar_test=.False.
                write(error,'(6I6, " Error:",f10.6)') year, month, day, hour, minute, second, (mjd_output-mjd_input)
                print*, "Testing range:"
                print*, "   min_mjd, max_mjd, mjd_step"
                print*, min_mjd, max_mjd, mjd_step
                print*, "   Corresponding First Date"
                call calendar_date(min_mjd, year, month, day, hour, minute, second)
                print*, year, month, day, hour, minute, second
                print*, "   Corresponding Last Date"
                call calendar_date(max_mjd, year, month, day, hour, minute, second)
                print*, year, month, day, hour, minute, second
                print*, " "
                EXIT MJDLOOP
            endif
            if ((month<1).or.(month>12)) then
                calendar_test=.False.
                write(error,'(6I6, " Error:",f10.6)') year, month, day, hour, minute, second, (mjd_output-mjd_input)
                print*, "Testing range:"
                print*, "   min_mjd, max_mjd, mjd_step"
                print*, min_mjd, max_mjd, mjd_step
                print*, "   Corresponding First Date"
                call calendar_date(min_mjd, year, month, day, hour, minute, second)
                print*, year, month, day, hour, minute, second
                print*, "   Corresponding Last Date"
                call calendar_date(max_mjd, year, month, day, hour, minute, second)
                print*, year, month, day, hour, minute, second
                print*, " "
                EXIT MJDLOOP
            endif

            ! this is the main test it is likely to fail
            if (abs(mjd_output-mjd_input)>MAX_ERROR) then
                calendar_test=.False.
                write(error,'(6I6, " Error:",f10.6)') year, month, day, hour, minute, second, (mjd_output-mjd_input)
                print*, "Testing range:"
                print*, "   min_mjd, max_mjd, mjd_step"
                print*, min_mjd, max_mjd, mjd_step
                print*, "   Corresponding First Date"
                call calendar_date(min_mjd, year, month, day, hour, minute, second)
                print*, year, month, day, hour, minute, second
                print*, "   Corresponding Last Date"
                call calendar_date(max_mjd, year, month, day, hour, minute, second)
                print*, year, month, day, hour, minute, second
                print*, " "
                EXIT MJDLOOP
            endif
        end do MJDLOOP

    end function calendar_test

    subroutine detailed_tests(calendar_name)
        character(len=STRING_LENGTH), intent(in) :: calendar_name

        double precision :: mjd_input, mjd_output
        double precision :: min_mjd, max_mjd, mjd_step
        integer :: year, month, day, hour, minute, second

        call time_init(calendar_name)
        min_mjd=365.0*1.d0
        max_mjd=365.0*2.d0
        mjd_step=1
        print*, "Detailed testoutput:"
        print*, "Testing range:"
        print*, "   min_mjd, max_mjd, mjd_step"
        print*, min_mjd, max_mjd, mjd_step
        print*, "   Corresponding First Date"
        call calendar_date(min_mjd, year, month, day, hour, minute, second)
        print*, year, month, day, hour, minute, second
        print*, "   Corresponding Last Date"
        call calendar_date(max_mjd, year, month, day, hour, minute, second)
        print*, year, month, day, hour, minute, second

        MJDLOOP: do mjd_input = min_mjd, max_mjd, mjd_step
            ! test that input and output Modified Julian Days stay the same
            call calendar_date(mjd_input, year, month, day, hour, minute, second)
            mjd_output=date_to_mjd(year, month, day, hour, minute, second)
            print*, mjd_input, mjd_output, mjd_output - mjd_input
            print*, year, month, day, hour, minute, second
        end do MJDLOOP

    end subroutine

end module calendar_test_module

program test_calendar
    use calendar_test_module
    integer, parameter :: NCALENDARS=5
    character(len=STRING_LENGTH),dimension(NCALENDARS) :: calendars_to_test
    character(len=STRING_LENGTH) :: calendar_error
    character(len=STRING_LENGTH) :: options

    integer :: current_calendar
    integer :: error
    logical :: file_exists

    calendars_to_test=[character(len=STRING_LENGTH) :: "gregorian","standard","365-day","noleap","360-day"]
    options=""

    if (command_argument_count()>0) then
        call get_command_argument(1,options, status=error)
    endif

    if (trim(options)=="help") then
        print*, "calendar_test [detailed] [help]"
        print*, "   detailed: print an entire year of dates for visual inspection"
        print*, "   help: print this message"
        stop
    endif

    do current_calendar=1,NCALENDARS
        print*, "Testing : ", trim(calendars_to_test(current_calendar))
        if (calendar_test(calendars_to_test(current_calendar),error=calendar_error)) then
            print*, " PASSED "
            if (trim(options)=="detailed") then
                call detailed_tests(calendars_to_test(current_calendar))
            endif
        else
            print*, " FAILED ", trim(calendars_to_test(current_calendar))
            print*, trim(calendar_error)
            call detailed_tests(calendars_to_test(current_calendar))
        endif
    end do
end program test_calendar


      subroutine bsplvd ( t, lent, k, x, left, a, dbiatx, nderiv )
c     --------   ------
c      implicit none

C calculates value and deriv.s of all b-splines which do not vanish at x
C calls bsplvb
c
c******  i n p u t  ******
c  t     the knot array, of length left+k (at least)
c  k     the order of the b-splines to be evaluated
c  x     the point at which these values are sought
c  left  an integer indicating the left endpoint of the interval of
c        interest. the  k  b-splines whose support contains the interval
c               (t(left), t(left+1))
c        are to be considered.
c  a s s u m p t i o n  - - -  it is assumed that
c               t(left) < t(left+1)
c        division by zero will result otherwise (in  b s p l v b ).
c        also, the output is as advertised only if
c               t(left) <= x <= t(left+1) .
c  nderiv   an integer indicating that values of b-splines and their
c        derivatives up to but not including the  nderiv-th  are asked
c        for. ( nderiv  is replaced internally by the integer in (1,k)
c        closest to it.)
c
c******  w o r k   a r e a  ******
c  a     an array of order (k,k), to contain b-coeff.s of the derivat-
c        ives of a certain order of the  k  b-splines of interest.
c
c******  o u t p u t  ******
c  dbiatx   an array of order (k,nderiv). its entry  (i,m)  contains
c        value of  (m-1)st  derivative of  (left-k+i)-th  b-spline of
c        order  k  for knot sequence  t , i=m,...,k; m=1,...,nderiv.
c
c******  m e t h o d  ******
c  values at  x  of all the relevant b-splines of order k,k-1,...,
c  k+1-nderiv  are generated via  bsplvb  and stored temporarily
c  in  dbiatx .  then, the b-coeffs of the required derivatives of the
c  b-splines of interest are generated by differencing, each from the
c  preceding one of lower order, and combined with the values of b-
c  splines of corresponding order in  dbiatx  to produce the desired
c  values.

C Args
      integer lent,k,left,nderiv
      double precision t(lent),x, dbiatx(k,nderiv), a(k,k)
C Locals
      double precision factor,fkp1mm,sum
      integer i,ideriv,il,j,jlow,jp1mid, kp1,kp1mm,ldummy,m,mhigh

      mhigh = max0(min0(nderiv,k),1)
c     mhigh is usually equal to nderiv.
      kp1 = k+1
      call bsplvb(t,lent,kp1-mhigh,1,x,left,dbiatx)
      if (mhigh .eq. 1) return
c     the first column of  dbiatx  always contains the b-spline values
c     for the current order. these are stored in column k+1-current
c     order  before  bsplvb  is called to put values for the next
c     higher order on top of it.
      ideriv = mhigh
      do 15 m=2,mhigh
         jp1mid = 1
         do 11 j=ideriv,k
            dbiatx(j,ideriv) = dbiatx(jp1mid,1)
            jp1mid = jp1mid + 1
   11       continue
         ideriv = ideriv - 1
         call bsplvb(t,lent,kp1-ideriv,2,x,left,dbiatx)
   15    continue
c
c     at this point,  b(left-k+i, k+1-j)(x) is in  dbiatx(i,j) for
c     i=j,...,k and j=1,...,mhigh ('=' nderiv). in particular, the
c     first column of  dbiatx  is already in final form. to obtain cor-
c     responding derivatives of b-splines in subsequent columns, gene-
c     rate their b-repr. by differencing, then evaluate at  x.
c
      jlow = 1
      do 20 i=1,k
         do 19 j=jlow,k
            a(j,i) = 0d0
   19       continue
         jlow = i
         a(i,i) = 1d0
   20    continue
c     at this point, a(.,j) contains the b-coeffs for the j-th of the
c     k  b-splines of interest here.
c
      do 45 m=2,mhigh
         kp1mm = kp1 - m
         fkp1mm = dble(kp1mm)
         il = left
         i = k
c
c        for j=1,...,k, construct b-coeffs of  (m-1)st  derivative of
c        b-splines from those for preceding derivative by differencing
c        and store again in  a(.,j) . the fact that  a(i,j) = 0  for
c        i < j  is used.sed.
         do 25 ldummy=1,kp1mm
            factor = fkp1mm/(t(il+kp1mm) - t(il))
c           the assumption that t(left) < t(left+1) makes denominator
c           in  factor  nonzero.
            do 24 j=1,i
               a(i,j) = (a(i,j) - a(i-1,j))*factor
   24          continue
            il = il - 1
            i = i - 1
   25       continue
c
c        for i=1,...,k, combine b-coeffs a(.,i) with b-spline values
c        stored in dbiatx(.,m) to get value of  (m-1)st  derivative of
c        i-th b-spline (of interest here) at  x , and store in
c        dbiatx(i,m). storage of this value over the value of a b-spline
c        of order m there is safe since the remaining b-spline derivat-
c        ive of the same order do not use this value due to the fact
c        that  a(j,i) = 0  for j < i .
         do 40 i=1,k
            sum = 0.d0
            jlow = max0(i,m)
            do 35 j=jlow,k
               sum = a(j,i)*dbiatx(j,m) + sum
   35       continue
            dbiatx(i,m) = sum
   40    continue
   45 continue
      end

      subroutine bsplvb ( t, lent,jhigh, index, x, left, biatx )
c      implicit none
c     -------------

calculates the value of all possibly nonzero b-splines at  x  of order
c
c               jout  =  dmax( jhigh , (j+1)*(index-1) )
c
c  with knot sequence  t .
c
c******  i n p u t  ******
c  t.....knot sequence, of length  left + jout  , assumed to be nonde-
c        creasing.
c    a s s u m p t i o n  :  t(left)  <  t(left + 1)
c    d i v i s i o n  b y  z e r o  will result if  t(left) = t(left+1)
c
c  jhigh,
c  index.....integers which determine the order  jout = max(jhigh,
c        (j+1)*(index-1))  of the b-splines whose values at  x  are to
c        be returned.  index  is used to avoid recalculations when seve-
c        ral columns of the triangular array of b-spline values are nee-
c        ded (e.g., in  bvalue  or in  bsplvd ). precisely,
c                     if  index = 1 ,
c        the calculation starts from scratch and the entire triangular
c        array of b-spline values of orders 1,2,...,jhigh  is generated
c        order by order , i.e., column by column .
c                     if  index = 2 ,
c        only the b-spline values of order  j+1, j+2, ..., jout  are ge-
c        nerated, the assumption being that  biatx , j , deltal , deltar
c        are, on entry, as they were on exit at the previous call.
c           in particular, if  jhigh = 0, then  jout = j+1, i.e., just
c        the next column of b-spline values is generated.
c
c  w a r n i n g . . .  the restriction   jout <= jmax (= 20)  is
c        imposed arbitrarily by the dimension statement for  deltal and
c        deltar  below, but is  n o w h e r e  c h e c k e d  for .
c
c  x.....the point at which the b-splines are to be evaluated.
c  left.....an integer chosen (usually) so that
c                  t(left) <= x <= t(left+1)  .
c
c******  o u t p u t  ******
c  biatx.....array of length  jout , with  biatx(i)  containing the val-
c        ue at  x  of the polynomial of order  jout  which agrees with
c        the b-spline  b(left-jout+i,jout,t)  on the interval (t(left),
c        t(left+1)) .
c
c******  m e t h o d  ******
c  the recurrence relation
c
c                       x - t(i)               t(i+j+1) - x
c     b(i,j+1)(x)  =  ----------- b(i,j)(x) + --------------- b(i+1,j)(x)
c                     t(i+j)-t(i)             t(i+j+1)-t(i+1)
c
c  is used (repeatedly) to generate the
c  (j+1)-vector  b(left-j,j+1)(x),...,b(left,j+1)(x)
c  from the j-vector  b(left-j+1,j)(x),...,b(left,j)(x),
c  storing the new values in  biatx  over the old.  the facts that
c            b(i,1) = 1         if  t(i) <= x < t(i+1)
c  and that
c            b(i,j)(x) = 0  unless  t(i) <= x < t(i+j)
c  are used. the particular organization of the calculations follows
c  algorithm (8)  in chapter x of the text.
c

C Arguments
      integer lent, jhigh, index, left
      double precision t(lent),x, biatx(jhigh)
c     dimension     t(left+jout), biatx(jout)
c     -----------------------------------
c current fortran standard makes it impossible to specify the length of
c  t  and of  biatx  precisely without the introduction of otherwise
c  superfluous additional arguments.

C Local Variables
      integer jmax
      parameter(jmax = 20)
      integer i,j,jp1
      double precision deltal(jmax), deltar(jmax),saved,term

      save j,deltal,deltar
      data j/1/
c
c                                        go to (10,20), index
      if (index .eq. 2) go to 20
      j = 1
      biatx(1) = 1d0
      if (j .ge. jhigh) return
c
   20    jp1 = j + 1
         deltar(j) = t(left+j) - x
         deltal(j) = x - t(left+1-j)
         saved = 0d0
         do 26 i=1,j
            term = biatx(i)/(deltar(i) + deltal(jp1-i))
            biatx(i) = saved + deltar(i)*term
            saved = deltal(jp1-i)*term
   26       continue
         biatx(jp1) = saved
         j = jp1
         if (j .lt. jhigh)              go to 20
      end


Let Nat = forall A . (A -> A) -> A -> A in
Let idT = forall A . A -> A in
let id : idT = Lambda A . lambda x : A . x in
let zero : Nat = Lambda A . lambda f : A -> A . lambda x : A . x in
zero [idT] (id [idT]) id


!==============================================================================!
  real function Field_Mod_U_Tan(flow, s)
!------------------------------------------------------------------------------!
!   Computes tangential velocity component at the cell near a wall.            !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type), target :: flow
  integer                  :: s     ! wall face
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type), pointer :: grid
  integer                  :: c1, c2
  real                     :: u_tot_sq, u_nor_sq, u_nor
!==============================================================================!

  ! Take aliases
  grid => flow % pnt_grid

  ! Take cells around the face
  ! (Note that c2 should be less than zero!
  !  Also note that there is no ckecking yet!)
  c1 = grid % faces_c(1, s)
  c2 = grid % faces_c(2, s)

  ! Compute tangential velocity component
  u_tot_sq = flow % u % n(c1) * flow % u % n(c1)  &
           + flow % v % n(c1) * flow % v % n(c1)  &
           + flow % w % n(c1) * flow % w % n(c1)
  u_nor  = ( flow % u % n(c1) * grid % sx(s)     &
           + flow % v % n(c1) * grid % sy(s)     &
           + flow % w % n(c1) * grid % sz(s) )   &
         / grid % s(s)
  u_nor_sq = u_nor**2

  if( u_tot_sq  > u_nor_sq) then
    Field_Mod_U_Tan = sqrt(u_tot_sq - u_nor_sq)
  else
    Field_Mod_U_Tan = TINY
  end if

  end function


!NCLFORTSTART
SUBROUTINE DCOMPUTEPW(p, tv, qv, ht, pw, nx, ny, nz, nzh)
    USE wrf_constants, ONLY : RD

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: pw

    INTEGER, INTENT(IN) :: nx, ny, nz, nzh
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: p, tv, qv
    REAL(KIND=8), DIMENSION(nx,ny,nzh), INTENT(IN) :: ht
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(OUT) :: pw

!NCLEND

    INTEGER :: i, j, k
    !REAL(KIND=8),PARAMETER :: R=287.06

    pw = 0

    !$OMP PARALLEL

    DO k=1,nz
        !$OMP DO COLLAPSE(2) SCHEDULE(runtime)
        DO j=1,ny
            DO i=1,nx
                pw(i,j) = pw(i,j) + ((p(i,j,k)/(RD*tv(i,j,k)))*qv(i,j,k)*(ht(i,j,k+1) - ht(i,j,k)))
            END DO
        END DO
        !$OMP END DO
    END DO

    !$OMP END PARALLEL

    RETURN

END SUBROUTINE DCOMPUTEPW


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine AB_matrix
  use global_variables
  implicit none
  integer :: i,j
  real(8) :: detA
  real(8) :: a(3,3),b(3,3)

  A_matrix(:,:)=a_Cvec(:,:)
  a=A_matrix

  detA=a(1,1)*a(2,2)*a(3,3)+a(2,1)*a(3,2)*a(1,3)+a(3,1)*a(1,2)*a(2,3) &
    -a(1,3)*a(2,2)*a(3,1)-a(2,3)*a(3,2)*a(1,1)-a(3,3)*a(1,2)*a(2,1)

  b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2)
  b(2,1)=a(2,3)*a(3,1)-a(2,1)*a(3,3)
  b(3,1)=a(2,1)*a(3,2)-a(2,2)*a(3,1)

  b(1,2)=a(1,3)*a(3,2)-a(1,2)*a(3,3)
  b(2,2)=a(1,1)*a(3,3)-a(1,3)*a(3,1)
  b(3,2)=a(1,2)*a(3,1)-a(1,1)*a(3,2)

  b(1,3)=a(1,2)*a(2,3)-a(1,3)*a(2,2)
  b(2,3)=a(1,3)*a(2,1)-a(1,1)*a(2,3)
  b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1)

  B_matrix=b/detA

  if(myrank == 0)then
    write(*,*)'AB check'
    write(*,*)sum(A_matrix(1,:)*B_matrix(:,1)),sum(A_matrix(1,:)*B_matrix(:,2)),sum(A_matrix(1,:)*B_matrix(:,3))
    write(*,*)sum(A_matrix(2,:)*B_matrix(:,1)),sum(A_matrix(2,:)*B_matrix(:,2)),sum(A_matrix(2,:)*B_matrix(:,3))
    write(*,*)sum(A_matrix(3,:)*B_matrix(:,1)),sum(A_matrix(3,:)*B_matrix(:,2)),sum(A_matrix(3,:)*B_matrix(:,3))
  end if

  do i=1,3
  do j=1,3
    B_t_matrix(i,j)=sum(B_matrix(i,:)*B_matrix(j,:))
  end do
  end do

  return
end subroutine AB_matrix


      subroutine bilinear_fill(t,imax,jmax,nskip,r_missing_data)

      integer lowi_lut(imax)
      integer lowj_lut(jmax)

      dimension t(imax,jmax)

!     Bilinearly interpolate to fill in rest of domain
!     Fills in final analysis value and weights from obs alone
!     We may have to extrapolate at the N and E edges
      do i = 1,imax
          lowi_lut(i) = ((i-1)/nskip)*nskip + 1
          il = lowi_lut(i)
          ih = il + nskip
          if(ih .gt. imax)lowi_lut(i) = lowi_lut(i) - nskip
!         write(6,*)' i,il,ih',i,il,ih
      enddo ! i
      do j = 1,jmax
          lowj_lut(j) = ((j-1)/nskip)*nskip + 1
          jl = lowj_lut(j)
          jh = jl + nskip
          if(jh .gt. jmax)lowj_lut(j) = lowj_lut(j) - nskip
      enddo ! i

      do j=1,jmax
          jl = lowj_lut(j)
          jh = jl + nskip
          fracj = dble(j-jl)/dble(nskip)

          do i=1,imax

              il = lowi_lut(i)
              ih = il + nskip
              fraci = dble(i-il)/dble(nskip)

!             write(6,*)' i,il,ih',i,il,ih
!             write(6,*)i,j,il,ih,jl,jh

!             Calculate interpolated cloud cover
              Z1=t(il,jl)
              Z2=t(ih,jl)
              Z3=t(ih,jh)
              Z4=t(il,jh)

              t(i,j) = Z1+(Z2-Z1)*fraci+(Z4-Z1)*fracj &
                     - (Z2+Z4-Z3-Z1)*fraci*fracj

          enddo ! i
      enddo ! j

      return
      end


 SUBROUTINE POLATES6(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,GI, &
                     NO,RLAT,RLON,IBO,LO,GO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 71314 $
!
! SUBPROGRAM:  POLATES6   INTERPOLATE SCALAR FIELDS (BUDGET)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS BUDGET INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR SCALAR FIELDS.
!           IT REQUIRES A GRID FOR THE OUTPUT FIELDS (KGDSO(1)>=0).
!           THE ALGORITHM SIMPLY COMPUTES (WEIGHTED) AVERAGES
!           OF NEIGHBOR POINTS ARRANGED IN A SQUARE BOX
!           CENTERED AROUND EACH OUTPUT GRID POINT AND STRETCHING
!           NEARLY HALFWAY TO EACH OF THE NEIGHBORING GRID POINTS.
!           OPTIONS ALLOW CHOICES OF NUMBER OF POINTS IN EACH RADIUS
!           FROM THE CENTER POINT (IPOPT(1)) WHICH DEFAULTS TO 2
!           (IF IPOPT(1)=-1) MEANING THAT 25 POINTS WILL BE AVERAGED;
!           FURTHER OPTIONS ARE THE RESPECTIVE WEIGHTS FOR THE RADIUS
!           POINTS STARTING AT THE CENTER POINT (IPOPT(2:2+IPOPT(1))
!           WHICH DEFAULTS TO ALL 1 (IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!           ANOTHER OPTION IS THE MINIMUM PERCENTAGE FOR MASK,
!           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
!           (IPOPT(3+IPOPT(1)) WHICH DEFAULTS TO 50 (IF -1).
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!           THE GRIDS ARE DEFINED BY THEIR GRID DESCRIPTION SECTIONS
!           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63).
!           THE CURRENT CODE RECOGNIZES THE FOLLOWING PROJECTIONS:
!             (KGDS(1)=000) EQUIDISTANT CYLINDRICAL
!             (KGDS(1)=001) MERCATOR CYLINDRICAL
!             (KGDS(1)=003) LAMBERT CONFORMAL CONICAL
!             (KGDS(1)=004) GAUSSIAN CYLINDRICAL (SPECTRAL NATIVE)
!             (KGDS(1)=005) POLAR STEREOGRAPHIC AZIMUTHAL
!             (KGDS(1)=203) ROTATED EQUIDISTANT CYLINDRICAL (E-STAGGER)
!             (KGDS(1)=205) ROTATED EQUIDISTANT CYLINDRICAL (B-STAGGER)
!           WHERE KGDS COULD BE EITHER INPUT KGDSI OR OUTPUT KGDSO.
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED.
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   96-10-04  IREDELL  NEIGHBOR POINTS NOT BILINEAR INTERPOLATION
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      VERSION OF GDSWZD.
!
! USAGE:    CALL POLATES6(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,GI,
!    &                    NO,RLAT,RLON,IBO,LO,GO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS NUMBER OF RADIUS POINTS
!                (DEFAULTS TO 2 IF IPOPT(1)=-1);
!                IPOPT(2:2+IPOPT(1)) ARE RESPECTIVE WEIGHTS
!                (DEFAULTS TO ALL 1 IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!                IPOPT(3+IPOPT(1)) IS MINIMUM PERCENTAGE FOR MASK
!                (DEFAULTS TO 50 IF IPOPT(3+IPOPT(1)=-1)
!     KGDSI    - INTEGER (200) INPUT GDS PARAMETERS AS DECODED BY W3FI63
!     KGDSO    - INTEGER (200) OUTPUT GDS PARAMETERS
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     GI       - REAL (MI,KM) INPUT FIELDS TO INTERPOLATE
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     GO       - REAL (MO,KM) OUTPUT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!                31   INVALID UNDEFINED OUTPUT GRID
!                32   INVALID BUDGET METHOD PARAMETERS
!
! SUBPROGRAMS CALLED:
!   GDSWZD       GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
!   (IJKGDS1)    RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   POLFIXS      MAKE MULTIPLE POLE SCALAR VALUES CONSISTENT
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,    INTENT(IN   ) :: IBI(KM), IPOPT(20), KM, MI, MO
 INTEGER,    INTENT(IN   ) :: KGDSI(200), KGDSO(200)
 INTEGER,    INTENT(  OUT) :: IBO(KM), IRET, NO
!
 LOGICAL*1,  INTENT(IN   ) :: LI(MI,KM)
 LOGICAL*1,  INTENT(  OUT) :: LO(MO,KM)
!
 REAL,       INTENT(IN   ) :: GI(MI,KM)
 REAL,       INTENT(  OUT) :: GO(MO,KM), RLAT(MO), RLON(MO)
!
 REAL,       PARAMETER     :: FILL=-9999.
!
 INTEGER                   :: IB, I1, IJKGDS1, IJKGDSA(20)
 INTEGER                   :: JB, J1, K, LB, LSW, MP, N
 INTEGER                   :: N11(MO), NB, NB1, NB2, NB3, NB4, NV
!
 REAL                      :: PMP,RLOB(MO),RLAB(MO)
 REAL                      :: WB, WO(MO,KM), XI, YI
 REAL                      :: XPTB(MO),YPTB(MO),XPTS(MO),YPTS(MO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
 IRET=0
 IF(KGDSO(1).GE.0) THEN
   CALL GDSWZD(KGDSO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO)
   IF(NO.EQ.0) IRET=3
 ELSE
   IRET=31
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 NB1=IPOPT(1)
 IF(NB1.EQ.-1) NB1=2
 IF(IRET.EQ.0.AND.NB1.LT.0) IRET=32
 LSW=1
 IF(IPOPT(1).EQ.-1.OR.IPOPT(2).EQ.-1) LSW=0
 IF(IRET.EQ.0.AND.LSW.EQ.1.AND.NB1.GT.15) IRET=32
 MP=IPOPT(3+IPOPT(1))
 IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
 IF(MP.LT.0.OR.MP.GT.100) IRET=32
 PMP=MP*0.01
 IF(IRET.EQ.0) THEN
   NB2=2*NB1+1
   NB3=NB2*NB2
   NB4=NB3
   IF(LSW.EQ.1) THEN
     NB4=IPOPT(2)
     DO IB=1,NB1
       NB4=NB4+8*IB*IPOPT(2+IB)
     ENDDO
   ENDIF
 ELSE
   NB2=0
   NB3=0
   NB4=0
 ENDIF
 DO K=1,KM
   DO N=1,NO
     GO(N,K)=0.
     WO(N,K)=0.
   ENDDO
 ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX
 CALL IJKGDS0(KGDSI,IJKGDSA)
 DO NB=1,NB3
!  LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS
   JB=(NB-1)/NB2-NB1
   IB=NB-(JB+NB1)*NB2-NB1-1
   LB=MAX(ABS(IB),ABS(JB))
   WB=1
   IF(LSW.EQ.1) WB=IPOPT(2+LB)
   IF(WB.NE.0) THEN
     DO N=1,NO
       XPTB(N)=XPTS(N)+IB/REAL(NB2)
       YPTB(N)=YPTS(N)+JB/REAL(NB2)
     ENDDO
     CALL GDSWZD(KGDSO, 1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV)
     CALL GDSWZD(KGDSI,-1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV)
     IF(IRET.EQ.0.AND.NV.EQ.0.AND.LB.EQ.0) IRET=2
     DO N=1,NO
       XI=XPTB(N)
       YI=YPTB(N)
       IF(XI.NE.FILL.AND.YI.NE.FILL) THEN
         I1=NINT(XI)
         J1=NINT(YI)
         N11(N)=IJKGDS1(I1,J1,IJKGDSA)
       ELSE
         N11(N)=0
       ENDIF
     ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE WITH OR WITHOUT BITMAPS
     DO K=1,KM
       DO N=1,NO
         IF(N11(N).GT.0) THEN
           IF(IBI(K).EQ.0.OR.LI(N11(N),K)) THEN
             GO(N,K)=GO(N,K)+WB*GI(N11(N),K)
             WO(N,K)=WO(N,K)+WB
           ENDIF
         ENDIF
       ENDDO
     ENDDO
   ENDIF
 ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE OUTPUT BITMAPS AND FIELDS
 DO K=1,KM
   IBO(K)=IBI(K)
   DO N=1,NO
     LO(N,K)=WO(N,K).GE.PMP*NB4
     IF(LO(N,K)) THEN
       GO(N,K)=GO(N,K)/WO(N,K)
     ELSE
       IBO(K)=1
       GO(N,K)=0.
     ENDIF
   ENDDO
 ENDDO
 IF(KGDSO(1).EQ.0) CALL POLFIXS(NO,MO,KM,RLAT,RLON,IBO,LO,GO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATES6


*     SB03UD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 3, 2*NMAX*NMAX ) +
     $                                 NMAX*NMAX + 2*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SCALE, SEPD
      INTEGER          I, INFO, J, N
      CHARACTER*1      DICO, FACT, JOB, LYAPUN, TRANA, UPLO
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB03UD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      DICO = 'D'
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $                               READ ( NIN, FMT = * ) SCALE
         IF ( LSAME( FACT, 'N' ) .OR. ( LSAME( LYAPUN, 'O' ) .AND.
     $                             .NOT.LSAME( JOB, 'X') ) )
     $      READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N )
            IF ( LSAME( LYAPUN, 'O' ) )
     $         READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N )
         END IF
         IF ( .NOT.LSAME( JOB, 'S' ) )
     $      READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $      READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N )
*        Solve the discrete-time Lyapunov matrix equation and/or
*        estimate the condition and error bound on the solution.
         CALL SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, LDA,
     $                T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, FERR,
     $                DWORK(1), DWORK(N+1), IWORK, DWORK(2*N+1),
     $                LDWORK-2*N, INFO )
*
         IF ( INFO.EQ.0 ) THEN
            IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99996 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99993 ) SCALE
            END IF
            IF ( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'C' )
     $                             .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99992 ) SEPD
            IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99991 ) RCOND
            IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99990 ) FERR
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03UD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03UD =',I2)
99996 FORMAT (' The solution matrix X is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' Scaling factor = ',F8.4)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END


!!!!
!! File: H_hex.f90
!! Description: Create and diagonalize Hamiltonian for Fermi-Hubbard model on a triangular lattice
!! Author: Bruno R. de Abreu  |  babreu at illinois dot edu
!! National Center for Supercomputing Applications (NCSA)
!!
!! Creation Date: Friday, 6th August 2021, 11:25:48 am
!! Last Modified: Friday, 6th August 2021, 11:27:01 am
!!
!! Copyright (c) 2021, Bruno R. de Abreu, National Center for Supercomputing Applications.
!! All rights reserved.
!! License: This program and the accompanying materials are made available to any individual
!!          under the citation condition that follows: On the event that the software is
!!          used to generate data that is used implicitly or explicitly for research
!!          purposes, proper acknowledgment must be provided in the citations section of
!!          publications. This includes both the author's name and the National Center
!!          for Supercomputing Applications. If you are uncertain about how to do
!!          so, please check this page: https://github.com/babreu-ncsa/cite-me.
!!          This software cannot be used for commercial purposes in any way whatsoever.
!!          Omitting this license when redistributing the code is strongly disencouraged.
!!          The software is provided without warranty of any kind. In no event shall the
!!          author or copyright holders be liable for any kind of claim in connection to
!!          the software and its usage.
!!!!
program H_hex
    implicit none
    integer :: Lx, Ly  !! sides of the lattice
    integer :: N_sites, N_up, N_down   !! number of sites, spins up, spins down
    integer :: i, j, k, l, lmax, my   !! integer helpers
    real*8 :: dx, dy    !! lattice parameters
    real*8 :: x, y, r2  !! double helpers
    real*8, allocatable :: sites(:,:)   !! matrix with lattice sites positions
    real*8, allocatable :: eigvals(:) !! eigenvalues of the Hamiltonian
    complex*16, allocatable :: H_0(:,:), eigvecs(:,:) !! hamiltonian, its eigenvectors

    Lx=10
    Ly=9
    N_sites=106
    N_up=53
    N_down=53
    my = (Ly+1) / 2
    dx=0.5
    dy = sqrt(3.0)/2.0

    allocate(sites(0:N_sites-1,2))
    sites = 0.0
    allocate(H_0(N_sites,N_sites))
    H_0 = (0.0, 0.0)
    allocate(eigvecs(N_sites,N_sites))
    allocate(eigvals(N_sites))

!! start giving lattice sites their positions (this needs to be re-thought, lattice only needs to be created once)
    k=1
    do i = 0, my-1
        x = -i*dx
        y = -i*dy
        do j = 1, Lx+i
            sites(k,1) = x + j - 1;
            sites(k,2) = y
            k = k + 1
        enddo
    enddo

    lmax = Lx + my + 1
    l=1
    do i = my, Ly-1
        x = x + dx
        y = -i*dy
        do j = 1, lmax - l
            sites(k,1) = x + j - 1
            sites(k,2) = y
            k = k + 1
        enddo
    enddo

    !! construct Hamiltonian
    do i = 1, N_sites
        do j = 1, N_sites
            r2 = (sites(i,1) - sites(j,1))**2.0 + (sites(i,2) - sites(j,2)**2.0)
            if (r2 <= 1.5) then
                if(r2 >= 0.5) then
                    H_0(i,j) = (-1.0,0.0)
                endif
            endif
        enddo
    enddo

    ! diagonalize hamiltonian
    call hermitean_diagonalization(H_0,N_sites,eigvals,eigvecs)

    ! write eigen vector to file
    call write_Umatrix_to_file(N_sites,eigvecs)

    ! calculate diagonal densities ?? IMPLEMENT

    deallocate(sites)
    deallocate(H_0)
    deallocate(eigvecs)
    deallocate(eigvals)
end program

subroutine hermitean_diagonalization(matrix,order,eigvals,eigvecs)
    !! This uses LAPACK's ZHEEV to diagonalize HERMITEAN matrices
    IMPLICIT NONE
    COMPLEX*16, intent(in) :: matrix(order,order)
    INTEGER, intent(in) :: order
    REAL*8, intent(out) :: eigvals(order)
    COMPLEX*16, intent(out) :: eigvecs(order,order)
    INTEGER LWMAX
    PARAMETER (LWMAX=1000)
    INTEGER INFO, LWORK
    REAL*8 RWORK(3*order-2)
    COMPLEX*16, allocatable :: WORK(:)

    allocate(WORK(LWMAX))
    eigvecs = matrix
    LWORK=-1
    call ZHEEV('V', 'U', order, eigvecs, order, eigvals, WORK, LWORK, RWORK, INFO)
    LWORK = min(LWMAX, int(WORK(1)))
    deallocate(WORK)
    allocate(WORK(LWORK))
    call ZHEEV('V', 'U', order, eigvecs, order, eigvals, WORK, LWORK, RWORK, INFO)
    if(INFO == 0) then
        write(*,*) 'Diagonalization performed.'
    else
        write(*,*) 'Diagonalization failed.'
        return
    endif

end subroutine hermitean_diagonalization

subroutine write_Umatrix_to_file(order,matrix)
    !! This writes the UPPER TRIANGULAR part of a matrix to a file
    implicit none
    integer, intent(in) :: order
    complex*16, intent(in) :: matrix(order,order)
    integer :: i, j     ! helpers
    character*20 :: filename

    filename = 'psif90_hex.in'
    open(1, file=filename, status='new')

    do j=1,order
        do i=j,order
            write(1,*) matrix(i,j)
        enddo
    enddo

    close(1)
end subroutine write_Umatrix_to_file


! (C) Copyright 2017-2018 UCAR
!
! 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.

module fv3jedi_constants_mod

use fv3jedi_kinds_mod, only: kind_real

implicit none
private

real(kind=kind_real), parameter, public :: rad2deg = 57.2957779186820_kind_real
real(kind=kind_real), parameter, public :: deg2rad = 0.01745329300562541_kind_real
real(kind=8)        , parameter, public :: pi_r8   = 3.14159265358979323846
real(kind=kind_real), parameter, public :: pi      = real(pi_r8,kind_real)
real(kind=kind_real), parameter, public :: grav    = 9.80665_kind_real
real(kind=kind_real), parameter, public :: radius  = 6371.0e3_kind_real
real(kind=kind_real), parameter, public :: omega   = 2.0_kind_real*pi/86164.0_kind_real
real(kind=kind_real), parameter, public :: stfbol  = 5.6734e-8_kind_real
real(kind=kind_real), parameter, public :: airmw   = 28.965_kind_real
real(kind=kind_real), parameter, public :: h2omw   = 18.015_kind_real
real(kind=kind_real), parameter, public :: o3mw    = 47.9982_kind_real
real(kind=kind_real), parameter, public :: runiv   = 8314.47_kind_real
real(kind=kind_real), parameter, public :: alhl    = 2.4665e6_kind_real
real(kind=kind_real), parameter, public :: alhf    = 3.3370e5_kind_real
real(kind=kind_real), parameter, public :: alhs    = alhl+alhf
real(kind=kind_real), parameter, public :: rdry    = runiv/airmw
real(kind=kind_real), parameter, public :: cpdry   = 3.5_kind_real*rdry
real(kind=kind_real), parameter, public :: cvdry   = cpdry-rdry
real(kind=kind_real), parameter, public :: rvap    = runiv/h2omw
real(kind=kind_real), parameter, public :: cpvap   = 4._kind_real*rvap
real(kind=kind_real), parameter, public :: cvvap   = cpvap-rvap
real(kind=kind_real), parameter, public :: kappa   = rdry/cpdry
real(kind=kind_real), parameter, public :: epsilon = h2omw/airmw
real(kind=kind_real), parameter, public :: deltap  = cpvap/cpdry
real(kind=kind_real), parameter, public :: deltav  = cvvap/cvdry
real(kind=kind_real), parameter, public :: gammad  = cpdry/cvdry
real(kind=kind_real), parameter, public :: rgas    = rdry
real(kind=kind_real), parameter, public :: cp      = rgas/kappa
real(kind=kind_real), parameter, public :: zvir    = rvap/rgas - 1._kind_real
real(kind=kind_real), parameter, public :: vireps  = 1.0_kind_real/epsilon-1.0_kind_real
real(kind=kind_real), parameter, public :: p00     = 100000.0_kind_real
real(kind=kind_real), parameter, public :: ps      = 101300.0_kind_real
real(kind=kind_real), parameter, public :: capice  = 2000._kind_real
real(kind=kind_real), parameter, public :: capwtr  = 4218._kind_real
real(kind=kind_real), parameter, public :: rhowtr  = 1000._kind_real
real(kind=kind_real), parameter, public :: nuair   = 1.533e-5_kind_real
real(kind=kind_real), parameter, public :: tice    = 273.16_kind_real
real(kind=kind_real), parameter, public :: srfprs  = 98470_kind_real
real(kind=kind_real), parameter, public :: karman  = 0.40_kind_real
real(kind=kind_real), parameter, public :: usmin   = 1.00_kind_real
real(kind=kind_real), parameter, public :: avogad  = 6.023e26_kind_real
real(kind=kind_real), parameter, public :: rho_seawater  = 1026.0_kind_real
real(kind=kind_real), parameter, public :: rho_seaice    = 917.0_kind_real
real(kind=kind_real), parameter, public :: rho_snow      = 330.0_kind_real
real(kind=kind_real), parameter, public :: f_coriolis_angle = 0.0_kind_real
!real(kind=kind_real), parameter, public :: kg_kg_to_ppmv_o3 = 1.0e6_kind_real*airmw/o3mw ! kg/kg -> ppmv
real(kind=kind_real), parameter, public :: constoz = 604229.0_kind_real ! kg/kg -> ppmv (what the GSI uses, but of unknown origin)

end module fv3jedi_constants_mod


c
c
c
c     =====================================================
       subroutine qinit(meqn,mbc,mx,my,xcorn,ycorn,
     &                   dx,dy,q,maux,aux,lstgrd,irr)
c     =====================================================
c
c     # Set initial conditions for q.
c     # rotated channel problem
c
       use amr_module
       implicit double precision (a-h,o-z)

       dimension q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
       dimension aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)
       integer irr(1-mbc:mx+mbc, 1-mbc:my+mbc)

       common /moredata/ sloc

c
c      mach 10 flow 30 degree ramp
c
       pi = 3.14159265358979d0
c      alpha = 30.d0 * pi/180.d0
       alpha = pi/6.d0

       rhol = 8.d0
       ul   = cos(alpha)*8.25d0
       vl   = -sin(alpha)*8.25d0
       pl   = 116.5d0

       rhor = 1.4d0
       ur   = 0.d0
       vr   = 0.d0
       pr   = 1.0d0

c      do 20 i=1,mx
c      do 20 j=1,my
c      uncomment next 2 lines to initialize ghost cells too.
c      helps with plotting
       do 20 i=1-mbc,mx+mbc
       do 20 j=1-mbc,my+mbc
          kuse = irr(i,j)
          if (kuse .ne. -1 .and. kuse .ne. lstgrd) then
             xcen = xcirr(kuse)
             ycen = ycirr(kuse)
          else
             xcen = xcorn + (i-0.5d0)*dx
             ycen = ycorn + (j-0.5d0)*dy
          endif

          ! for this cells y, where is shock in x
          xshock =  sloc + ycen/sqrt(3.0d0)
          if (xcen .lt. xshock) then
            q(1,i,j) = rhol
            q(2,i,j) = rhol * ul
            q(3,i,j) = rhol * vl
            q(4,i,j) = pl/.4d0 + 0.5d0*rhol*(ul**2 + vl**2)
          else
            q(1,i,j) = rhor
            q(2,i,j) = rhor * ur
            q(3,i,j) = rhor * vr
            q(4,i,j) = pr/.4d0 + 0.5d0*rhor*(ur**2 + vr**2)
          endif
  20   continue

       return
       end


PROGRAM mciklv

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       =========================================================
!       Purpose: This program computes modified Bessel functions
!                Iv(z) and Kv(z) and their derivatives for a
!                large order and a complex argument using
!                subroutine CIKLV
!       Input:   v --- Order of Iv(z) and Kv(z)
!                z --- Complex argument
!       Output:  CBIV --- Iv(z)
!                CDIV --- Iv'(z)
!                CBKV --- Kv(z)
!                CDKV --- Kv'(z)
!       Examples:
!                v =100.00,    z =   4.00 + i   2.00

!       Iv(z) = -.7373606617-123 + .6461109082-123 i
!       Iv'(z)= -.8307094243-122 + .2030132500-121 i
!       Kv(z) = -.3836166007+121 - .3356017795+121 i
!       Kv'(z)=  .1103271276+123 + .2886519240+122 i

!                v =100.50,    z =   4.00 + i   2.00
!       Iv(z) = -.1289940051-123 + .6845756182-124 i
!       Iv'(z)= -.1907996261-122 + .2672465997-122 i
!       Kv(z) = -.3008779281+122 - .1593719779+122 i
!       Kv'(z)=  .7653781978+123 + .1857772148+122 i
!       =========================================================

IMPLICIT DOUBLE PRECISION (v,x,y)
IMPLICIT COMPLEX*16 (c,z)
WRITE(*,*)'Please enter v,x,y ( z = x+iy )'
!        READ(*,*)V,X,Y
v=100.00
x=4.0
y=2.0
WRITE(*,10)v,x,y
z=CMPLX(x,y)
CALL ciklv(v,z,cbiv,cdiv,cbkv,cdkv)
WRITE(*,*)
WRITE(*,20)cbiv
WRITE(*,30)cdiv
WRITE(*,*)
WRITE(*,40)cbkv
WRITE(*,50)cdkv
10      FORMAT(8X,'v =',f6.2,',    ','z =',f7.2,' + i',f7.2)
20      FORMAT(8X,'Iv(z) =',d17.10,' + i ',d17.10)
30      FORMAT(8X,'Iv''(Z)=',d17.10,' + I ',d17.10)
40      FORMAT(8X,'Kv(z) =',d17.10,' + i ',d17.10)
50      FORMAT(8X,'Kv''(Z)=',d17.10,' + I ',d17.10)
END PROGRAM mciklv

SUBROUTINE ciklv(v,z,cbiv,cdiv,cbkv,cdkv)

!       =====================================================
!       Purpose: Compute modified Bessel functions Iv(z) and
!                Kv(z) and their derivatives with a complex
!                argument and a large order
!       Input:   v --- Order of Iv(z) and Kv(z)
!                z --- Complex argument
!       Output:  CBIV --- Iv(z)
!                CDIV --- Iv'(z)
!                CBKV --- Kv(z)
!                CDKV --- Kv'(z)
!       Routine called:
!                CJK to compute the expansion coefficients
!       ====================================================

DOUBLE PRECISION, INTENT(IN)             :: v
COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: cbiv
COMPLEX, INTENT(OUT)                     :: cdiv
COMPLEX, INTENT(OUT)                     :: cbkv
COMPLEX, INTENT(OUT)                     :: cdkv
IMPLICIT DOUBLE PRECISION (a,b,d-h,o-y)
IMPLICIT COMPLEX*16 (c,z)
DIMENSION cf(12),a(91)

pi=3.141592653589793D0
km=12
CALL cjk(km,a)
DO  l=1,0,-1
  v0=v-l
  cws=CDSQRT(1.0D0+(z/v0)*(z/v0))
  ceta=cws+CDLOG(z/v0/(1.0D0+cws))
  ct=1.0D0/cws
  ct2=ct*ct
  DO  k=1,km
    l0=k*(k+1)/2+1
    lf=l0+k
    cf(k)=a(lf)
    DO  i=lf-1,l0,-1
      cf(k)=cf(k)*ct2+a(i)
    END DO
    cf(k)=cf(k)*ct**k
  END DO
  vr=1.0D0/v0
  csi=(1.0D0,0.0D0)
  DO  k=1,km
    csi=csi+cf(k)*vr**k
  END DO
  cbiv=CDSQRT(ct/(2.0D0*pi*v0))*CDEXP(v0*ceta)*csi
  IF (l == 1) cfi=cbiv
  csk=(1.0D0,0.0D0)
  DO  k=1,km
    csk=csk+(-1)**k*cf(k)*vr**k
  END DO
  cbkv=CDSQRT(pi*ct/(2.0D0*v0))*CDEXP(-v0*ceta)*csk
  IF (l == 1) cfk=cbkv
END DO
cdiv=cfi-v/z*cbiv
cdkv=-cfk-v/z*cbkv
RETURN
END SUBROUTINE ciklv

SUBROUTINE cjk(km,a)

!       ========================================================
!       Purpose: Compute the expansion coefficients for the
!                asymptotic expansion of Bessel functions
!                with large orders
!       Input :  Km   --- Maximum k
!       Output:  A(L) --- Cj(k) where j and k are related to L
!                         by L=j+1+[k*(k+1)]/2; j,k=0,1,...,Km
!       ========================================================

INTEGER, INTENT(IN)                      :: km
DOUBLE PRECISION, INTENT(OUT)            :: a(*)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

a(1)=1.0D0
f0=1.0D0
g0=1.0D0
DO  k=0,km-1
  l1=(k+1)*(k+2)/2+1
  l2=(k+1)*(k+2)/2+k+2
  f=(0.5D0*k+0.125D0/(k+1))*f0
  g=-(1.5D0*k+0.625D0/(3.0*(k+1.0D0)))*g0
  a(l1)=f
  a(l2)=g
  f0=f
  g0=g
END DO
DO  k=1,km-1
  DO  j=1,k
    l3=k*(k+1)/2+j+1
    l4=(k+1)*(k+2)/2+j+1
    a(l4)=(j+0.5D0*k+0.125D0/(2.0*j+k+1.0))*a(l3)  &
        -(j+0.5D0*k-1.0+0.625D0/(2.0*j+k+1.0))*a(l3-1)
  END DO
END DO
RETURN
END SUBROUTINE cjk


      SUBROUTINE SETUP_LINKCELL
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!  routine to determine which link cell each particle resides in
!!!  and to form appropriate lists. This is used for an order
!!!  N force/energy evaluation
!!!  Written by K.Travis 24/02/12
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file  !!use stuff in main module

      IMPLICIT NONE

      INTEGER :: I,ICELL,ICX,ICY,ICZ,NCXY

      REAL(kind = double) :: RA,RB,RC,XX,YY,ZZ

      NCXY = NCELLX*NCELLY
!!!  zero arrays

      HEAD = (/ (I*0,I = 1,NCELL) /)
      LIST = (/ (I*0,I = 1,N)     /)

!!! sort particles into cells

      DO I = 1,N
        XX = X(I)
        YY = Y(I)
        ZZ = Z(I)
        CALL CARTFRAC(XX,YY,ZZ,RA,RB,RC)
        ICX = INT(RA*NCELLX)
        ICX = MAX(0,ICX)
        ICX = MIN(ICX,NCELLX-1)
        ICY = INT(RB*NCELLY)
        ICY = MAX(0,ICY)
        ICY = MIN(ICY,NCELLY-1)
        ICZ = INT(RC*NCELLZ)
        ICZ = MAX(0,ICZ)
        ICZ = MIN(ICZ,NCELLZ-1)
        ICELL = 1 + ICX + ICY*NCELLX + ICZ*NCXY
        LIST(I) = HEAD(ICELL)
        HEAD(ICELL) = I
      END DO

      END SUBROUTINE


C
C
C  Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
C
C  This program is free software; you can redistribute it and/or modify it
C  under the terms of version 2.1 of the GNU Lesser General Public License
C  as published by the Free Software Foundation.
C
C  This program is distributed in the hope that it would be useful, but
C  WITHOUT ANY WARRANTY; without even the implied warranty of
C  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
C
C  Further, this software is distributed without any warranty that it is
C  free of the rightful claim of any third person regarding infringement
C  or the like.  Any license provided herein, whether implied or
C  otherwise, applies only to this software file.  Patent licenses, if
C  any, provided herein do not apply to combinations of this program with
C  other software, or any other product whatsoever.
C
C  You should have received a copy of the GNU Lesser General Public
C  License along with this program; if not, write the Free Software
C  Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307,
C  USA.
C
C  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
C  Mountain View, CA 94043, or:
C
C  http://www.sgi.com
C
C  For further information regarding this notice, see:
C
C  http://oss.sgi.com/projects/GenInfo/NoticeExplan
C
C

      SUBROUTINE _CGEMVX( ICONJ, M, N, ALPHA, A, INCCA, INCRA, X, INCX,
     $                   BETA, Y, INCY )
!DIR$ ID "@(#) libfi/matrix/cgemvx.f	92.0	"
!DIR$ ID "10/08/98 14:37:14"
*     ENTRY CGEMVX_( ICONJ, M, N, ALPHA, A, INCCA, INCRA, X, INCX,
*    $                   BETA, Y, INCY )
*
*  -- X-interface BLAS specification --
*     E. Anderson, Cray Research Inc.
*     February 25, 1993
*
*     .. Scalar Arguments ..
      INTEGER            ICONJ, INCCA, INCRA, INCX, INCY, M, N
      COMPLEX(KIND=8)    ALPHA, BETA
C     COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      COMPLEX(KIND=8)    A( * ), X( * ), Y( * )
C     COMPLEX*16         A( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  CGEMVX performs the matrix-vector multiplication
*
*     y := alpha*A*x + beta*y,  or  y := alpha*conjg( A )*x + beta*y,
*
*  where alpha and beta are scalars, x is an n-vector, y is an m-vector,
*  and A is an m-by-n matrix.
*
*  Arguments
*  =========
*
*  ICONJ   (input) INTEGER
*          Specifies whether the matrix A or its conjugate will be used.
*          = 0:  No conjugate for A,  y := alpha*A*x + beta*y
*          = 1:  Use conjugate of A,  y := alpha*conjg( A )*x + beta*y
*
*  M       (input) INTEGER
*          The length of the vector y, and the number of rows of the
*          matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The length of the vector x, and the number of columns of the
*          matrix A.  N >= 0.
*
*  ALPHA   (input) COMPLEX
*          The scalar alpha.
*
*  A       (input) COMPLEX array, dimension
*                  (1 + abs(INCCA)*(M-1) + abs(INCRA)*(N-1))
*          The m-by-n matrix A with column and row increments specified
*          by INCCA and INCRA.
*
*  INCCA   (input) INTEGER
*          The increment between elements in a column of A.
*
*  INCRA   (input) INTEGER
*          The increment between elements in a row of A.
*
*  X       (input) COMPLEX array, dimension (1 + (n-1)*abs(INCX))
*          The n-element vector x.
*
*  INCX    (input) INTEGER
*          The increment for the elements of X.  INCX must not be zero.
*
*  BETA    (input) COMPLEX
*          The scalar beta.
*
*  Y       (input/output) COMPLEX array, dimension (1 + (m-1)*abs(INCY))
*          On entry, the m-element vector y.
*          On exit, Y is overwritten by the updated vector y.
*
*  INCY    (input) INTEGER
*          The increment for the elements of Y.  INCY must not be zero.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX(KIND=8)    ONE, ZERO
C     COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IA, IAJ, IY, J, JX, JY
      COMPLEX(KIND=8)    TEMP
C     COMPLEX*16         TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IY = 1
      IF( ( M.NE.0 ) .AND. ( N.EQ.0 ) ) THEN
*     Set the result to zeros and exit
         DO, I = 1, M
            Y( IY ) = ZERO
            IY = IY + INCY
         END DO
         RETURN
       END IF

      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) .OR.
     $    ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )RETURN
*
*     First form  y := beta*y.
*
      IY = 1
      IF( BETA.EQ.ZERO ) THEN
         DO 10 I = 1, M
            Y( IY ) = ZERO
            IY = IY + INCY
   10    CONTINUE
      ELSE IF( BETA.NE.ONE ) THEN
         DO 20 I = 1, M
            Y( IY ) = BETA*Y( IY )
            IY = IY + INCY
   20    CONTINUE
      END IF
*
      IF( ALPHA.EQ.ZERO )
     $   RETURN
*
      IAJ = 1
      JX = 1
      JY = 1
      IF( ICONJ.EQ.0 ) THEN
*
*        Form  y := alpha*A*x + y.
*
         DO 40 J = 1, N
            IF( X( JX ).NE.ZERO ) THEN
               TEMP = ALPHA*X( JX )
               IA = IAJ
               IY = JY
               DO 30 I = 1, M
                  Y( IY ) = Y( IY ) + TEMP*A( IA )
                  IA = IA + INCCA
                  IY = IY + INCY
   30          CONTINUE
            END IF
            IAJ = IAJ + INCRA
            JX = JX + INCX
   40    CONTINUE
      ELSE
*
*        Form  y := alpha*conjg( A )*x + y.
*
         DO 60 J = 1, N
            IF( X( JX ).NE.ZERO ) THEN
               TEMP = ALPHA*X( JX )
               IA = IAJ
               IY = JY
               DO 50 I = 1, M
                  Y( IY ) = Y( IY ) + TEMP*CONJG( A( IA ) )
                  IA = IA + INCCA
                  IY = IY + INCY
   50          CONTINUE
            END IF
            IAJ = IAJ + INCRA
            JX = JX + INCX
   60    CONTINUE
      END IF
*
      RETURN
*
*     End of CGEMVX
*
      END


      subroutine flood(zslice, dry, wet_mask, delta,
     &                 flooded_zslice, im, jm, nbdry)

!-----------------------------------------------------------------------

      implicit none

!-----------------------------------------------------------------------
!
!     input arrays
!
!-----------------------------------------------------------------------

      integer :: delta

      integer, dimension(nbdry, 2), intent(in) :: dry

      real*8, dimension(jm, im), intent(in) :: zslice, wet_mask

!-----------------------------------------------------------------------
!
!     output variables
!
!-----------------------------------------------------------------------

      real*8, dimension(jm, im), intent(out) :: flooded_zslice

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      integer :: im, jm, nbdry, n
      integer :: imin, imax, jmin, jmax, dxy
      integer :: idry, jdry

      real*8 :: wet_sum

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

      flooded_zslice = zslice

      ! loop over the dry point that need to be flooded
      do n=1,nbdry
        idry = dry(n,2)
        jdry = dry(n,1)
        ! compute wet point distance
        dxy = 0
        wet_sum = 0
        do while (wet_sum .eq. 0)
          dxy =  dxy + delta
          imin = MAX(idry-dxy,1)
          imax = MIN(idry+dxy,im)
          jmin = MAX(jdry-dxy,1)
          jmax = MIN(jdry+dxy,jm)
          wet_sum = SUM(wet_mask(jmin:jmax,imin:imax))
        enddo
        flooded_zslice(jdry,idry) = SUM(zslice(jmin:jmax,imin:imax)
     &                                  * wet_mask(jmin:jmax,imin:imax))
     &                                  / wet_sum
      enddo

!-----------------------------------------------------------------------

      end subroutine flood

!-----------------------------------------------------------------------


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of lamf in forward (tangent) mode:
!   variations   of useful results: lamf
!   with respect to varying inputs: *temp
!   Plus diff mem management of: temp:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!> @brief calculate the thermal conductivity kf in W/(m*K) of water
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return thermal conductivity [W/(m*K)]
!> @details
!> Calculate the thermal conductivity kf in W/(m*K) of freshwater,
!> given temperature in degC. Thermal conductivity of freshwater, kfw
!> is calculated using the Phillips (1981) formulation (page 8). \n\n
!>
!> Source:\n\n
!>
!> Phillips, S., Igbene, A., Fair, J., Ozbek, H., & Tavana, M.,
!> Technical databook for geothermal energy utilization (1981).
!> http://dx.doi.org/10.2172/6301274 \n\n
!>
!> Range of validity:  20 to 330 degC\n\n
!>
!>      temperature tlocal in [C]\n
DOUBLE PRECISION FUNCTION g_LAMF(i, j, k, ismpl, lamf)
  USE ARRAYS

  USE g_ARRAYS

  IMPLICIT NONE
! Location indices
  INTEGER, INTENT(IN) :: i
  INTEGER, INTENT(IN) :: j
  INTEGER, INTENT(IN) :: k
! Sample index
  INTEGER :: ismpl
! Temperature (degC)
  DOUBLE PRECISION :: tlocal
  DOUBLE PRECISION :: g_tlocal
! Monomials of temperatures quotient
  DOUBLE PRECISION :: tr, tr2, tr3, tr4
  DOUBLE PRECISION :: g_tr, g_tr2, g_tr3, g_tr4
! Coefficients of approximation
  DOUBLE PRECISION, PARAMETER :: c0=-0.92247d0
  DOUBLE PRECISION, PARAMETER :: c1=2.8395d0
  DOUBLE PRECISION, PARAMETER :: c2=1.8007d0
  DOUBLE PRECISION, PARAMETER :: c3=0.52577d0
  DOUBLE PRECISION, PARAMETER :: c4=0.07344d0
  DOUBLE PRECISION :: lamf
! Local Temperature in degC
  g_tlocal = g_temp(i, j, k, ismpl)
  tlocal = temp(i, j, k, ismpl)
! Monomials of temperature quotient
  g_tr = g_tlocal/273.15d0
  tr = (tlocal+273.15d0)/273.15d0
  g_tr2 = 2*tr*g_tr
  tr2 = tr*tr
  g_tr3 = tr*g_tr2 + tr2*g_tr
  tr3 = tr2*tr
  g_tr4 = tr*g_tr3 + tr3*g_tr
  tr4 = tr3*tr
! Thermal conductivity [W/(m*K)]
  g_lamf = c1*g_tr - c2*g_tr2 + c3*g_tr3 - c4*g_tr4
  lamf = c0 + c1*tr - c2*tr2 + c3*tr3 - c4*tr4
  RETURN
END FUNCTION g_LAMF


      Subroutine FAST2D(PYRHO,PYVR,PYVZ,PYERG)
!  BURSTING DIAPHRAGM "MUZZLE FLASH" - LCPFCT TEST # 4       August 1992
c
c  The problem begins with 1000:1 pressure and 100:1 density ratios
c  across a diaphragm inside a solid cylindrical barrel.  The ideal wall
c  of the barrel is 10 cells thick (1.0 cm) with its inner radius given
c  as 1.5 cm and its outer radius of 2.5 cm.  The run starts at time
c  t = 0.0 when the diaphragm at interface J = 11 (inside the barrel) is
c  ruptured.  The flow then expands upward in a 1D manner, spilling out
c  of the barrel in a 2D flow which eventually reaches the boundaries at
c  R = 4.0 cm and Z = 4.0 cm where a very simple extrapolative outflow
c  condition is expressed through the LCPFCT boundary conditions values.
c  The outflow condition used here includes a slow relaxation to ambient
c  conditions far from the origin.

         implicit none

         Logical,parameter :: doplot = .false.

         Integer   I, J, IJ
         Integer,Parameter ::  NPT = 202, NR = 64, NZ=64 , MAXSTP=801

c        Real,   Intent(OUT)   ::   PYOUT(NR,9,MAXSTP)
         Real,Intent(OUT) :: PYRHO(NR,NZ,MAXSTP),PYVR(NR,NZ,MAXSTP),
     &                       PYVZ(NR,NZ,MAXSTP),PYERG(NR,NZ,MAXSTP)

         Integer   NRP, IALFR,     BC_AXIS, BC_WALL, BC_OUTF
         Integer   NZP, IALFZ,        IPRINT
         Integer   ICIN, ICOUT, JCTOP,      ISTEP
         Real      DR,         DZ,         DT,         TIME
         Real      COURANT,    DTNEW,      VTYPICAL,   RELAX
         Real      DTMAX,      VZMAX,      R(NPT),     Z(NPT)
         Real      RHO(NR,NZ), RVR(NR,NZ), RVZ(NR,NZ), ERG(NR,NZ)
         Real      DIN(9)

         Real      RHO_IN,     PRE_IN,     VEL_IN,     GAMMA0
         Real      RHOAMB,     PREAMB,     VELAMB,     GAMMAM
         Real      RHON(NPT),  RVRN(NPT),  RVTN(NPT),  ERGN(NPT)
         Common    / ARRAYS / RHON,   RVRN,   RVTN,   ERGN,   RELAX,
     &                         RHO_IN, PRE_IN, VEL_IN, GAMMA0,
     &                         RHOAMB, PREAMB, VELAMB, GAMMAM

 1000 Format ('1', /, '   LCPFCT Test # 4 - FAST2D Barrel Explosion:',
     1        '  Step =', I4, /, 5X, I3, ' x', I3, ' Uniform Grid.',
     2        '  Time=', 1PE12.4, ' and   DT =', E12.4 )
 1005 Format (' After step ', I5, '  TIME = ', 1PE12.4,
     &           ' and timestep DT = ', E12.4 )
 1010 Format (1X, /, ' Fluid variables on selected lines ',
     1           /, ' I, J', '    RHO axis VZ     PRE ',
     2                      '     RHO top  VR     PRE ',
     3                      '     RHO wall VZ     PRE ', / )
 1011 Format ( I3, 1X, 3(1X, F8.2, F8.2, F8.2) )

c  The 2D barrel explosion program control parameters are specified.
c  (Change here to run other cases) . . .
C-----------------------------------------------------------------------
c      NR      =  64  ! Number of cells in the first (radial R) direction
      IALFR   =   2  ! Sets cylindrical coordinates in the R direction
      DR      =  0.1 ! Cell size (e.g., cm) in the radial direction
c      NZ      =  64  ! Number of cells in the second (axial Z) direction
      IALFZ   =   1  ! Sets Cartesian coordinates in the Z direction
      DZ      =  0.1 ! Cell size (e.g., cm) in the axial direction
      BC_AXIS =   1  ! Cylindrical axis set as an impermeable wall
      BC_OUTF =   2  ! Outer boundaries set as extrapolative outflow
      BC_WALL =   1  ! Walls of the barrel set as an ideal solid wall
c      MAXSTP  = 801  ! Maximum number of timesteps of length DT
      IPRINT  =  25  ! Initial frequency of validation printout results
      COURANT =  0.4 ! Approximate maximum Courant number allowed
      DTMAX = 2.0E-7 ! Maximum timestep allowed in the computation
      DT    = 1.0E-9 ! Initial (small guess) for starting timestep

c  Initialize the test problem geometry, a cylindrical shell JCTOP cells
c  high in Z (indexed by J) which extends from the left of cell ICIN to
c  the right of cell ICOUT in X (indexed by I).
C-----------------------------------------------------------------------
      ICIN    =  16  ! Number of the innermost radial cell in the barrel
      ICOUT   =  25  ! Number of the outermost radial cell in the barrel
      JCTOP   =  20  ! Number of the uppermost axial cell in the barrel
      GAMMA0 = 1.4   ! Gas constant
      RHOAMB = 0.00129       ! Initialization and relaxation BCN = 2
      PREAMB = 1.013E+6      ! Initialization and relaxation BCN = 2
      VELAMB = 0.0           ! Initialization and relaxation BCN = 2
      RHO_IN = 100.0*RHOAMB  ! Initialization and relaxation BC1 = 2
      PRE_IN = 1000.0*PREAMB ! Initialization and relaxation BC1 = 2
      VEL_IN = 0.0           ! Initialization and relaxation BC1 = 2
      RELAX =  0.002 ! Relaxation rate, used when BC1 or BCN = 2
      GAMMAM = GAMMA0 - 1.0

c  Determine the cell interface locations, here a uniform grid . . .
C-----------------------------------------------------------------------
      NRP = NR + 1
      NZP = NZ + 1
      Do I = 1, NRP
       R(I) = DR*FLOAT(I-1)
      End do
      Do J = 1, NZP
       Z(J) = DZ*FLOAT(J-1)
      End do
c  Fill the arrays with air at STP and behind the diaphragm increase the
c  density by 100 to 1 and the pressure by 1000 to 1 . . .
C-----------------------------------------------------------------------
      Do J = 1, NZ
        Do  I = 1, NR
         RHO(I,J) = RHOAMB
         RVR(I,J) = 0.0
         RVZ(I,J) = 0.0
         ERG(I,J) = PREAMB/GAMMAM
        End do
      End do
      Do J = 1, JCTOP/2
        Do I = 1, ICIN - 1
         ERG(I,J) = PRE_IN/GAMMAM
         RHO(I,J) = RHO_IN
        End do
      End do
c  Mark the unused cells inside the cylindrical 'barrel' so they will
c  show up distinctly compared to ambient values in the plots.  This
c  has no effect as the simulation does not access these values . . .
C-----------------------------------------------------------------------
      Do J = 1, JCTOP
        Do I = ICIN, ICOUT
         ERG(I,J) = 20.0*ERG(I,J)
         RHO(I,J) = 20.0*RHO(I,J)
        End do
      End do
c  Begin loop over the timesteps . . .
C-----------------------------------------------------------------------
      TIME = 0.0
      Do 9999 ISTEP = 1, MAXSTP

c  Compute the next timestep based on a 'Courant' number COURANT . . .
C-----------------------------------------------------------------------
         VZMAX = 0.0
         Do J = 1, NZ
           Do I = 1, NR
            VTYPICAL = ERG(I,J)/RHO(I,J)
            VZMAX = MAX ( VTYPICAL, VZMAX )
           End do
         End do
         VZMAX = SQRT ( VZMAX )
         DTNEW = COURANT*MIN(DR,DZ)/VZMAX
         DT = MIN ( DTMAX, 1.25*DT, DTNEW )

c  The results are printed when required . . .
C-----------------------------------------------------------------------
          If (doplot) Then
            Do IJ = 1, 64
               DIN(1) = RHO(1,IJ)/RHOAMB
               DIN(2) = 0.01*RVZ(1,IJ)/RHO(1,IJ)
               DIN(3) = (GAMMAM/PREAMB)*(ERG(1,IJ) - 0.5*
     &                  (RVR(1,IJ)**2 + RVZ(1,IJ)**2)/RHO(1,IJ))
               DIN(4) = RHO(IJ,64)/RHOAMB
               DIN(5) = 0.01*RVR(IJ,64)/RHO(IJ,64)
               DIN(6) = (GAMMAM/PREAMB)*(ERG(IJ,64) - 0.5*
     &                  (RVR(IJ,64)**2 + RVZ(IJ,64)**2)/RHO(IJ,64))
               DIN(7) = RHO(64,IJ)/RHOAMB
               DIN(8) = 0.01*RVZ(64,IJ)/RHO(64,IJ)
               DIN(9) = (GAMMAM/PREAMB)*(ERG(64,IJ) - 0.5*
     &                  (RVR(64,IJ)**2 + RVZ(64,IJ)**2)/RHO(64,IJ))
c                write (*,*) ISTEP
c                PYOUT(IJ,:,ISTEP) = DIN
            End do
          End If

c  Integrate the fluid equations in the radial direction (indexed by I).
c  The outer boundary condition at interface I = NR+1 is an extra-
c  polation from the interior cell values with a slow relaxation to
c  the known distant ambient conditions . . .
C-----------------------------------------------------------------------
         Call RESIDIFF ( 0.999 )
         Call MAKEGRID ( R, R, 1, NRP, IALFR )
         Do J = 1, NZ

c  Pick up the data from the 2D arrays in the radial direction, setting
c  the temporary, compact 1D arrays for GASDYN . . .
C-----------------------------------------------------------------------
            Do I = 1, NR
               RHON(I) = RHO(I,J)
               RVRN(I) = RVR(I,J)
               RVTN(I) = RVZ(I,J)
               ERGN(I) = ERG(I,J)
            End do
c  Integrate along the radials inside and outside the cylinder  . . .
C-----------------------------------------------------------------------
            If ( J .le. JCTOP ) Then
               Call GASDYN ( 1, ICIN-1, BC_AXIS, BC_WALL, DT )
               Call GASDYN ( ICOUT+1, NR, BC_WALL, BC_OUTF, DT)

c  Integrate along the radials (indexing in I) above the cylinder
c  which reach from the axis to the outer boundary . ..
C-----------------------------------------------------------------------
            Else
               Call GASDYN ( 1, NR, BC_AXIS, BC_OUTF, DT )
            End If

c  Put the data back into the 2D arrays in the radial direction . . .
C-----------------------------------------------------------------------
            Do I = 1, NR
               RHO(I,J) = RHON(I)
               RVR(I,J) = RVRN(I)
               RVZ(I,J) = RVTN(I)
               ERG(I,J) = ERGN(I)
            End do
         End do     ! End loop integrating the NZ rows.

c  Integrate along the axials (indexing in J) which reach from the
c  lower active J cell (1 or JCTOP+1) to the upper boundary.  The
c  upper boundary condition at interface J = NZ+1 (BCN = 2 ) is an
c  extrapolation from the interior cell values with a slow relaxation
c  to the known distant ambient conditions . . .
C-----------------------------------------------------------------------
         Call MAKEGRID ( Z, Z, 1, NZP, IALFZ )
         Do I = 1, NR

c  Pick up the data from the 2D arrays in the axial direction, setting
c  the temporary, compact 1D arrays for GASDYN . . .
C-----------------------------------------------------------------------
            Do J = 1, NZ
               RHON(J) = RHO(I,J)
               RVTN(J) = RVR(I,J)
               RVRN(J) = RVZ(I,J)
               ERGN(J) = ERG(I,J)
            End do
c  Integrate along the axials either from the lower solid boundary at
c  interface J = 1 or from the top of the barrel at J = 21 for cells
c  with I = ICIN to ICOUT . . .
C-----------------------------------------------------------------------
            If ( I.ge.ICIN .and. I.le.ICOUT ) Then
               Call GASDYN ( JCTOP+1, NZ, BC_WALL, BC_OUTF, DT)
            Else
               Call GASDYN ( 1, NZ, BC_WALL, BC_OUTF, DT )
            End If

c  Put the data back into the 2D arrays in the axial direction . . .
C-----------------------------------------------------------------------
            Do J = 1, NZ
               RHO(I,J) = RHON(J)
               RVR(I,J) = RVTN(J)
               RVZ(I,J) = RVRN(J)
               ERG(I,J) = ERGN(J)
            End do
         End do     ! End loop integrating the NR columns.

         TIME = TIME + DT

         PYRHO(:,:,ISTEP) = RHO
         PYVR(:,:,ISTEP)  = RVR
         PYVZ(:,:,ISTEP)  = RVZ
         PYERG(:,:,ISTEP) = ERG

 9999 End do        ! End of the timestep loop.

      End Subroutine FAST2D