      PROGRAM LANGTONSANT
C   Langton's ant wanders across an initially all-white board, stepping one cell at a go.
C   If the current cell is white, it becomes black and the ant turns right.
C   If the current cell is black, it becomes white and the ant turns left.
C   The ant advances one cell in its latest direction, and reconsiders.
      INTEGER ENUFF
      PARAMETER (ENUFF = 100)		!Said to be so.
      CHARACTER*1 CELL(ENUFF,ENUFF)	!The work area.
      COMPLEX WAY,PLACE		!A direction and a position.
      INTEGER X,Y,XN,Y1		!Integer versions.
      INTEGER STEP		!A counter.
      CELL = ""				!Clear for action.
      PLACE = CMPLX(ENUFF/2,ENUFF/2)	!Start at the middle.
      WAY = (1,0)		!Initial direction is +x.
Commence wandering.
      DO STEP = 1,20000	!Enough to be going on with.
        X = REAL(PLACE)		!Change languages.
        Y = AIMAG(PLACE)	!Could mess about with EQUIVALENCE...
        IF (X.LE.0 .OR. X.GT.ENUFF	!Are we still
     1  .OR.Y.LE.0 .OR. Y.GT.ENUFF) THEN!Within bounds?
          WRITE (6,1) STEP - 1,X,Y		!No! Offer details.
    1     FORMAT ("Step ",I0," to (",I0,",",I0,") is out of bounds!")
          EXIT					!And wander no further.
        END IF				!But, if we're within bounds,
        IF (CELL(X,Y).NE."#") THEN	!Consider our position.
          CELL(X,Y) = "#"		!A blank cell becomes black. Ish.
          WAY = WAY*(0,-1)		!Turn right.
         ELSE				!Otherwise,
          CELL(X,Y) = "+"		!A black cell becomes white. Ish.
          WAY = WAY*(0,+1)		!Turn left.
        END IF			!So much for changing direction.
        PLACE = PLACE + WAY	!Advance one step.
      END DO		!On to the next step.
Consider the bounds...
      DO Y1 = 1,ENUFF		!Work up from the bottom.
        IF (ANY(CELL(:,Y1).NE." ")) EXIT	!The last line with a splot.
      END DO			!Subsequent lines would be blank.
      DO XN = ENUFF,1,-1	!Work back from the right hand side.
        IF (ANY(CELL(XN,:).NE." ")) EXIT	!The last column with a splot.
      END DO			!Subsequent columns would be blank.
Cast forth the splotches.
      DO Y = ENUFF,Y1,-1	!The topmost y-coordinate first!
        WRITE (6,"(666A1)") CELL(1:XN,Y)	!Roll a line's worth.
      END DO			!On to the next line.
Completed.
      END


*DECK CCOSH
      COMPLEX FUNCTION CCOSH (Z)
C***BEGIN PROLOGUE  CCOSH
C***PURPOSE  Compute the complex hyperbolic cosine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      COMPLEX (CCOSH-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC COSINE
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CCOSH(Z) calculates the complex hyperbolic cosine of Z.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CCOSH
      COMPLEX Z, CI
      SAVE CI
      DATA CI /(0.,1.)/
C***FIRST EXECUTABLE STATEMENT  CCOSH
      CCOSH = COS (CI*Z)
C
      RETURN
      END


! RUN: bbc -fopenmp -emit-fir %s -o - | \
! RUN: FileCheck %s --check-prefix=FIRDialect
! RUN: bbc -fopenmp %s -o - | fir-opt --fir-to-llvm-ir | \
! RUN: FileCheck %s --check-prefix=LLVMDialect

! This test checks the lowering of atomic write

!FIRDialect: func @_QQmain() {
!FIRDialect: %[[VAR_X:.*]] = fir.alloca i32 {bindc_name = "x", uniq_name = "_QFEx"}
!FIRDialect: %[[VAR_Y:.*]] = fir.alloca i32 {bindc_name = "y", uniq_name = "_QFEy"}
!FIRDialect: %[[VAR_Z:.*]] = fir.alloca i32 {bindc_name = "z", uniq_name = "_QFEz"}
!FIRDialect: %[[CONST_44:.*]] = arith.constant 44 : i32
!FIRDialect: omp.atomic.write %[[VAR_X]] = %[[CONST_44]] hint(uncontended) memory_order(seq_cst) : !fir.ref<i32>, i32
!FIRDialect: %[[CONST_7:.*]] = arith.constant 7 : i32
!FIRDialect: {{.*}} = fir.load %[[VAR_Y]] : !fir.ref<i32>
!FIRDialect: %[[VAR_7y:.*]] = arith.muli %[[CONST_7]], {{.*}} : i32
!FIRDialect: omp.atomic.write %[[VAR_X]] = %[[VAR_7y]] memory_order(relaxed) : !fir.ref<i32>, i32
!FIRDialect: %[[CONST_10:.*]] = arith.constant 10 : i32
!FIRDialect: {{.*}} = fir.load %[[VAR_X]] : !fir.ref<i32>
!FIRDialect: {{.*}} = arith.muli %[[CONST_10]], {{.*}} : i32
!FIRDialect: {{.*}} = fir.load %[[VAR_Z]] : !fir.ref<i32>
!FIRDialect: %[[CONST_2:.*]] = arith.constant 2 : i32
!FIRDialect: {{.*}} = arith.divsi {{.*}}, %[[CONST_2]] : i32
!FIRDialect: {{.*}} = arith.addi {{.*}}, {{.*}} : i32
!FIRDialect: omp.atomic.write %[[VAR_Y]] = {{.*}} hint(speculative) memory_order(release) : !fir.ref<i32>, i32
!FIRDialect: return
!FIRDialect: }

!LLVMDialect: llvm.func @_QQmain() {
!LLVMDialect: %[[LLVM_VAR_2:.*]] = llvm.mlir.constant(2 : i32) : i32
!LLVMDialect: %[[LLVM_VAR_10:.*]] = llvm.mlir.constant(10 : i32) : i32
!LLVMDialect: %[[LLVM_VAR_7:.*]] = llvm.mlir.constant(7 : i32) : i32
!LLVMDialect: %[[LLVM_VAR_44:.*]] = llvm.mlir.constant(44 : i32) : i32
!LLVMDialect: %[[LLVM_VAR_1:.*]] = llvm.mlir.constant(1 : i64) : i64
!LLVMDialect: %[[LLVM_VAR_X:.*]] = llvm.alloca {{.*}} x i32 {bindc_name = "x", in_type = i32, operand_segment_sizes = dense<0> : vector<2xi32>, uniq_name = "_QFEx"} : (i64) -> !llvm.ptr<i32>
!LLVMDialect: %[[LLVM_VAR_1_SECOND:.*]] = llvm.mlir.constant(1 : i64) : i64
!LLVMDialect: %[[LLVM_VAR_Y:.*]] = llvm.alloca {{.*}} x i32 {bindc_name = "y", in_type = i32, operand_segment_sizes = dense<0> : vector<2xi32>, uniq_name = "_QFEy"} : (i64) -> !llvm.ptr<i32>
!LLVMDialect: %[[LLVM_VAR_1_THIRD:.*]] = llvm.mlir.constant(1 : i64) : i64
!LLVMDialect: %[[LLVM_VAR_Z:.*]] = llvm.alloca {{.*}} x i32 {bindc_name = "z", in_type = i32, operand_segment_sizes = dense<0> : vector<2xi32>, uniq_name = "_QFEz"} : (i64) -> !llvm.ptr<i32>
!LLVMDialect: omp.atomic.write %[[LLVM_VAR_X]] = %[[LLVM_VAR_44]] hint(uncontended) memory_order(seq_cst) : !llvm.ptr<i32>, i32
!LLVMDialect: {{.*}} = llvm.load %[[LLVM_VAR_Y]] : !llvm.ptr<i32>
!LLVMDialect: %[[LLVM_VAR_MUL_RESULT:.*]] = llvm.mul {{.*}}, %[[LLVM_VAR_7]] : i32
!LLVMDialect: omp.atomic.write %[[LLVM_VAR_X]] = %[[LLVM_VAR_MUL_RESULT]] memory_order(relaxed) : !llvm.ptr<i32>, i32
!LLVMDialect: {{.*}} = llvm.load %[[LLVM_VAR_X]] : !llvm.ptr<i32>
!LLVMDialect: {{.*}} = llvm.mul {{.*}}, %[[LLVM_VAR_10]] : i32
!LLVMDialect: {{.*}} = llvm.load %[[LLVM_VAR_Z]] : !llvm.ptr<i32>
!LLVMDialect: {{.*}} = llvm.sdiv {{.*}}, %[[LLVM_VAR_2]] : i32
!LLVMDialect: {{.*}} = llvm.add {{.*}} : i32
!LLVMDialect: omp.atomic.write %[[LLVM_VAR_Y]] = {{.*}} hint(speculative) memory_order(release) : !llvm.ptr<i32>, i32
!LLVMDialect: llvm.return
!LLVMDialect: }

program OmpAtomicWrite
    use omp_lib
    integer :: x, y, z
    !$omp atomic seq_cst write hint(omp_sync_hint_uncontended)
        x = 8*4 + 12

    !$omp atomic write relaxed
        x = 7 * y

    !$omp atomic write release hint(omp_sync_hint_speculative)
        y = 10*x + z/2
end program OmpAtomicWrite


!==============================================================================!
  subroutine Surf_Mod_Relax_Geometry(surf)
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Surf_Type), target :: surf
!-----------------------------------[Locals]-----------------------------------!
  type(Vert_Type), pointer :: vert(:)
  type(Side_Type), pointer :: side(:)
  type(Elem_Type), pointer :: elem(:)
  integer,         pointer :: nv, ns, ne
  integer                  :: a, b, c, d, s, t
  real                     :: dist_ab, dist_cd
!==============================================================================!

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

  call Surf_Mod_Find_Boundaries(surf)

  do t = 6, 3, -1
    do s = 1, ns

      a = side(s) % a
      b = side(s) % b
      c = side(s) % c
      d = side(s) % d

      ! This is how I check if side is on a boundary
      if( min(a, b, c, d) > 0 ) then

        if( .not. side(s) % boundary ) then

          dist_ab = Math_Mod_Distance(                       &
               vert(a) % x_n, vert(a) % y_n, vert(a) % z_n,  &
               vert(b) % x_n, vert(b) % y_n, vert(b) % z_n)
          dist_cd = Math_Mod_Distance(                       &
               vert(c) % x_n, vert(c) % y_n, vert(c) % z_n,  &
               vert(d) % x_n, vert(d) % y_n, vert(d) % z_n)

          if(dist_ab < dist_cd*TWO_THIRDS) then
            call Surf_Mod_Swap_Side(surf, s)
          end if

        end if
      end if  ! side is on a boundary

    end do
  end do

  end subroutine


module explib
 contains
   subroutine dexp_mv(n, m, tau, v, w, tol, anorm, matvec, verb)
     implicit none
     integer, intent(in) :: n, m
     real(8), intent(in) :: tau, tol, anorm
     real(8), intent(in) :: v(n)
     real(8), intent(out) :: w(n)
     real(8) :: vtmp(n)
     integer, intent(in), optional :: verb
     integer :: m1
     integer :: ideg = 6
     integer :: lwsp
     integer :: liwsp
     real(8), allocatable :: wsp(:)
     integer, allocatable :: iwsp(:)
     integer :: itrace = 0
     integer iflag
     real(8) :: dnrm2, nrm
     external dnrm2
     external matvec
     lwsp = (n*(m+1)+n+(m+2)**2+4*(m+2)**2+ideg+1)
     lwsp = max(lwsp,200)
     liwsp = max((m+2),200)
     allocate(wsp(lwsp))
     allocate(iwsp(liwsp))
     m1 = min(m, n) !Fix sizes
     if ( m1 .eq. 1 ) then !The matrix is 1 x 1 :)
        call matvec((1d0,0d0), w)
        w(1) = v(1) * exp(w(1) * tau)
     else
         nrm = dnrm2(n, v, 1)
         if (nrm > 0) then
             vtmp = v/nrm
             call dgexpv(n, m1, tau, vtmp, w, tol, anorm, wsp, &
                       lwsp, iwsp, liwsp, matvec, itrace, iflag)
             if ( iflag .ne. 0 ) then
                 print *, 'zexp_mv failed with iflag=', iflag
             end if
             w(1:n) = w*nrm
         else
             w(1:n) = 0d0
         end if
     end if
     if ( present(verb) ) then
        write(*, '(a, I5)') 'matvecs: ', iwsp(1)
     end if
     deallocate(wsp)
     deallocate(iwsp)
 end subroutine dexp_mv

   subroutine zexp_mv(n, m, tau, v, w, tol, anorm, matvec, verb)
     ! Thin layer around EXPOKIT package
     ! Input arguments:
     !
     ! integer n - the problem size
     !
     ! integer m - maximum size of the Krylov basis
     !
     ! real(8) tau - the time step
     !
     ! complexl(8) v(n), input - the starting vector
     !
     ! complex(8) w(n), output - the result
     !
     ! real(8) tol ---  solution tolerance
     !
     ! real(8) anorm --- norm estimate
     !
     ! external matvec --- matrix-by-vector procedure, call matvec(x,y)
     !
     ! integer verb --- optional, verbosity level

     implicit none
     integer, intent(in) :: n, m
     real(8), intent(in) :: tau, tol, anorm
     integer, intent(in), optional :: verb
     complex(8), intent(in) :: v(n)
     complex(8), intent(out) :: w(n)
     complex(8) :: vtmp(n)
     integer :: m1
     integer :: ideg = 6
     integer :: lwsp
     integer :: liwsp
     integer, allocatable :: iwsp(:)
     integer :: itrace = 0
     integer iflag
     complex(8), allocatable :: wsp(:)
     external matvec
     real(8) :: dznrm2, nrm
     external dznrm2
     lwsp = (n*(m+1)+n+(m+2)**2+4*(m+2)**2+ideg+1)
     lwsp = max(lwsp,200)
     liwsp = max((m+2),200)
     allocate(wsp(lwsp))
     allocate(iwsp(liwsp))
     m1 = min(m, n) !Fix sizes
     if ( m1 .eq. 1 ) then !The matrix is 1 x 1 :)
        call matvec((1d0, 0d0), w)
        w(1) = v(1) * exp(w(1) * tau)
     else
         nrm = dznrm2(n, v, 1)
         if (nrm > 0) then
             vtmp(1:n) = v(1:n)/nrm
             call zgexpv(n, m1, tau, vtmp, w, tol, anorm, wsp, &
                       lwsp, iwsp, liwsp, matvec, itrace, iflag)
             if ( iflag .ne. 0 ) then
                 print *, 'zexp_mv failed with iflag=', iflag
             end if
             w(1:n) = w(1:n)*nrm
         else
             w(1:n) = 0d0
         end if
     end if
     if ( present(verb) ) then
        write(*, '(a, I5)') 'matvecs: ', iwsp(1)
        print *,'time covered:', wsp(8)
        print *,'error:', wsp(6)
        print *,'anorm:', anorm
     end if
     deallocate(wsp)
     deallocate(iwsp)
   end subroutine zexp_mv
end module explib


	SUBROUTINE TI_JTOI  ( jyear, jday, idtarr, iret )
C************************************************************************
C* TI_JTOI								*
C*									*
C* This subroutine converts from the day of the year to a date array.	*
C* Note that this routine returns only 3 values, namely year, month	*
C* and day.								*
C*									*
C* TI_JTOI  ( JYEAR, JDAY, IDTARR, IRET )				*
C*									*
C* Input parameters:							*
C*	JYEAR		INTEGER		Year				*
C*	JDAY		INTEGER		Day of the year			*
C*									*
C* Output parameters:							*
C*	IDTARR (3)	INTEGER		Date array (YYYY,MM,DD)		*
C* 	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -7 = invalid year		*
C*					 -9 = invalid day		*
C**									*
C* Log:									*
C* S. Jacobs/NMC	 9/94						*
C* P. Bruehl/Unidata	12/94		Fixed bug for December		*
C* S. Jacobs/NMC	12/94		Fixed check for leap year	*
C* I. Durham/GSC         9/98		Cleaned up			*
C* D. Kidwell/NCEP       2/99		Corrected return code, 7 -> -7  *
C* D. Kidwell/NCEP       4/99		Changed to use TI_YY24          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
	INTEGER		idtarr (*)
C*
	LOGICAL		done
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for valid day.
C
	IF  ( ( jday .lt. 0 ) .or. ( jday .gt. 366 ) )  THEN
	    iret  = -9
	    RETURN
	END IF
C
C*	Check for valid year. Make sure that the year includes the
C*	century.
C
	CALL TI_YY24 ( jyear, iyear, iret )
	IF ( iret .lt. 0 )  RETURN
C
C*	Find the date by stepping through the months and subtracting
C*	the number of days in the month, from the day of the year.
C
	i = 1
	iday = jday
	done = .false.
	DO  WHILE ( ( i .le. 12 ) .and. ( .not. done ) )
	    CALL TI_DAYM ( iyear, i, ndays, ier )
	    IF ( iday .gt. ndays ) THEN
	       IF ( i .eq. 12 ) THEN
		  iret = -9
		  RETURN
	       ELSE
		  iday = iday-ndays
		  i=i+1
               END IF
	    ELSE
		imonth = i
		done =.true.
	    END IF
	END DO
C
C*	Put time in output array.
C
	idtarr (1) = iyear
	idtarr (2) = imonth
	idtarr (3) = iday
C*
	RETURN
	END


program ex

  use gabriel
  use MPI
  implicit none

  integer,parameter :: n=10
  integer,parameter :: s=3
  real,parameter :: delta=0.01

  logical :: correct = .true.

  real,dimension(:),allocatable :: a,b
  integer ierr,rank,right,left,mpisize,i,j,k
  integer hor

  type(box) :: c
  type(distribution) :: d

  call MPI_Init(ierr)
  print*,'Initialization...'
  call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr)
  call MPI_Comm_size(MPI_COMM_WORLD,mpisize,ierr)
  right=rank+1
  left=rank-1
  if (right.ge.mpisize)right=0
  if (left.lt.0)left=mpisize-1
  print*,'left,rank,right=',left,rank,right

  hor=rank
  allocate(a(hor*s-1:hor*s+s))
  a=rank
  do i=lbound(a,1),ubound(a,1)
    a(i)=a(i)+i*delta
  enddo

  write(*,'(a,4i4)')'Size,Rank,hor=',mpisize,rank,hor

  write(*,'(a,i3,a,5f13.3,2i5)')'BEFORE Rank',rank,' data=',a,lbound(a,1),ubound(a,1)

  print*,'Gabriel setup...'
  call gabriel_init
  call c%init(a,(/hor*s/),(/hor*s+s-1/),MPI_COMM_WORLD,periodic=(/.true./))
  call d%halo(c)
  call d%create
!  call d%autocreate(a,(/hor*s/),(/hor*s+s-1/),MPI_COMM_WORLD,periodic=(/.true./))
!  call d%autocreate(a,(/hor*s,ver*s+1,1/),(/hor*s+s-1,ver*s+s,6/),MPI_COMM_WORLD,periodic=(/.true.,.false.,.false./))

  print*,'Update decomposition..'
  call d%update(a)

  write(*,'(a,i4,a,5f13.3)')' AFTER Rank',rank,' data=',a

  if (rank.ne.0 .and. a(hor*s-1).ne.left+(hor*s-1)*delta) correct=.false.
  if (rank.ne.mpisize-1 .and. a(hor*s+s).ne.right+(hor*s+s)*delta) correct=.false.
  if (rank.eq.0 .and. a(hor*s-1).ne.left+(left*s+s-1)*delta) correct=.false.
  if (rank.eq.mpisize-1 .and. a(hor*s+s).ne.right+(right*s)*delta) correct=.false.
  deallocate(a)

  call MPI_Finalize(ierr)
  if (.not.correct) stop 1
end


! { dg-do compile }
! { dg-options "-fmax-array-constructor=100000" }
! Test for PR19925
!
program pr19925
  implicit none
  integer j
  integer, parameter :: n = 100000
  integer, parameter :: i(n) = (/ (j, j=1, n) /)
  print *, i(5)
end program pr19925


subroutine g
x = y
x = 2*y
end subroutine

subroutine g
x = y

x = 2*y
end subroutine

subroutine g

    x = y

    x = 2*y

end subroutine

subroutine g
x = y
;;;;;; ; ; ;
x = 2*y
end subroutine

subroutine g
x = y;
x = 2*y;
end subroutine

subroutine g
x = y; ;
x = 2*y;; ;
end subroutine

subroutine g; x = y; x = 2*y; end subroutine

subroutine f
subroutine = y
x = 2*subroutine
end subroutine

subroutine f
integer :: x
end subroutine

subroutine f()
integer :: x
end subroutine

subroutine f(a, b, c, d)
integer, intent(in) :: a, b
integer, intent ( in ) :: c, d
integer :: z
integer::y
end subroutine

subroutine f(a, b, c, d)
integer, intent(out) :: a, b
integer, intent(in out) :: c, d
integer :: z
integer::y
end subroutine

subroutine saxpy(n, a, x, y)
real(dp), intent(in) :: x(:), a
real(dp), intent(inout) :: y(:)
integer, intent(in) :: n
integer :: i
do i = 1, n
    y(i) = a*x(i)+y(i)
enddo
end subroutine saxpy


!! demonstrates  timing methods
use, intrinsic:: iso_fortran_env, only: dp=>real64, int64

integer(int64) :: tic,toc,rate

call system_clock(tic,count_rate=rate)
call timempi()
call system_clock(toc)

print '(A,ES12.5,A)','instrinsic time: ',(toc-tic)/real(rate,dp),' seconds.'

contains

subroutine timempi()

use omp_lib

integer :: Ncore, Nthread
real(dp) :: tic,toc,rate

rate = omp_get_wtick()
print '(A,ES10.3,A)','OpenMP tick time: ',rate,' second.'

!$omp parallel private(tic,toc)

tic = omp_get_wtime()
! left these statements here to give a little entropy to per-thread timing.
Ncore = omp_get_num_procs()
Nthread = omp_get_num_threads()

!$omp master
  print *,Nthread,'CPU threads used.',Ncore,' processor cores detected.'
!$omp end master

toc = omp_get_wtime()

print *,'Thread: ',omp_get_thread_num(),(toc-tic)/rate

!$omp end parallel
end subroutine timempi

end program


program ex25

    use utils

    implicit none

    real(rk) :: A(10,10)
    logical  :: B(10,10)
    real(rk) :: v1(3)
    real(rk) :: v2(3)
    real(rk) :: dp

    call initRand()
    call randMat(A, -10.0_rk, 10.0_rk)

    B = .true.

    if (all(B) .eqv. .true.) then
        print*, 'All elements are true.'
    else
        print*, 'Not all elements are true'
    end if

    B = .false.

    if (any(B) .eqv. .true.) then
        print*, 'Some of the elements in B are true'
    else
        print*, 'None of the elements in B are true'
    end if

    B(5,5) = .true.

    if (any(B) .eqv. .true.) then
        print*, 'Some of the elements in B are true'
    else
        print*, 'None of the elements in B are true'
    end if

    print*, 'Max value in A = ', maxval(A)
    print*, 'Max value in A = ', minval(A)
    print*, 'Product of A   = ', product(A)
    print*, 'Sum of A       = ', sum(A)

end program ex25


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time = 0.0_dp
!real(dp), parameter :: stop_time = 2.00_dp
!real(dp), parameter :: stop_time = 0.25_dp
real(dp), parameter :: stop_time = 3.7_dp
!real(dp), parameter :: stop_time = 0.0_dp

real(dp), parameter :: CFL = 0.9_dp

real(dp), parameter :: dt_checkpoint = 0.5_dp

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

real(dp), parameter :: dt_analyze = dt_checkpoint

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

real(dp), parameter :: diameter = 2.0_dp

real(dp), parameter :: xlim(2) = diameter * ((/0.0_dp,1.0_dp/) - 0.5_dp)
real(dp), parameter :: ylim(2) = diameter * ((/0.0_dp,1.0_dp/) - 0.5_dp)

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

real(dp), parameter :: dens0 = 0.5_dp
real(dp), parameter :: dens1 = 1.5_dp
real(dp), parameter :: pres0 = 1.0_dp
real(dp), parameter :: velx0 = 0.5_dp
real(dp), parameter :: vely0 = 0.1_dp
real(dp), parameter :: slope = 15.0_dp

real(dp), parameter :: kappa = 1.4_dp
! real(dp), parameter :: mu0 = 1.0_dp

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

real(dp), parameter :: refine_radius = 0.75_dp

integer, parameter :: mesh_minlevel = 6
integer, parameter :: mesh_maxlevel = mesh_minlevel

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module


! Copyright (c) 2016 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level of this distribution.

module resids
  ! Residual analysis module

  use log, only: log_log_info
  use numerics, only: numerics_trapz
  use stats, only: stats_mean, stats_variance, stats_fivenum, &
       stats_residuals, stats_mean_sq_err, stats_mean_abs_err, &
       stats_median

  use progvars
  use gaussian, only: gaussian_p
  use output, only: logfile_unit=>output_logfile_unit

  implicit none

  private

  public :: resids_calculate
  public :: resids_stats

contains

  subroutine resids_calculate()

    integer(ip) :: i_p
    real(fp) :: p

    call log_log_info("Constructing residuals.", logfile_unit)

    do i_p = 1, vd_np
       p = vdx%p_range(i_p)
       theor_np_arr(i_p) = abs(gaussian_p(p))**2
    end do

    call stats_residuals(vdx%vd_p_arr, theor_np_arr, resid_np_arr)
    resid_np_mask(:) = resid_np_arr(:) .ge. resid_p_eps

    do i_p = 1, vd_np
       resid_np_cum_arr(i_p) = numerics_trapz(resid_np_arr(1:i_p), vdx%dp)
    end do

  end subroutine resids_calculate

  subroutine resids_stats()
    call log_log_info("Generating statistical summary of residuals.", logfile_unit)

    resid_mean = stats_mean(resid_np_arr, mask=resid_np_mask)
    resid_var = stats_variance(resid_np_arr, mask=resid_np_mask)

    call stats_fivenum(resid_np_arr, resid_fivenum_arr, mask=resid_np_mask)
    resid_mean_sq_err = stats_mean_sq_err(resid_np_arr, mask=resid_np_mask)
    resid_mean_abs_err = stats_mean_abs_err(resid_np_arr, mask=resid_np_mask)

  end subroutine resids_stats

end module resids


      DOUBLE PRECISION FUNCTION DP_TRAN( SPNUM )

!***********************************************************************
!* Translates a Single Precision Number into a Double Precision Number
!* Getting Full Double Precision for Apparently "Rounded" Values
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/10/17
!***********************************************************************

      ! Arguments ______________________________________________________

      REAL SPNUM ! Single precision input value

      ! Variables ______________________________________________________

      INTEGER IOS, IE, L10, LDIG, I

      REAL SPLOG

      CHARACTER DP_C*20, DIG*2

      ! Check for zero case
      IF ( SPNUM .EQ. 0. ) THEN
        DP_TRAN = 0.D0
        RETURN
      END IF

      ! Translate SP number to get DP precision
      WRITE( DP_C, '(E20.6)', IOSTAT=IOS ) SPNUM
      IE = INDEX( DP_C, 'E' )
      IF ( DP_C(IE-2:IE-1) .EQ. '00' ) THEN ! Assume rounded value
        SPLOG = LOG10( ABS( SPNUM ) )
        L10 = INT( ABS( SPLOG ) ) + 1
        LDIG = INT( SPLOG + L10 ) - L10
        IF ( ( LDIG .GE. -13 ) .AND. ( LDIG .LE. 16 ) ) THEN
          READ( DP_C, '(BN,F20.0)', IOSTAT=IOS ) DP_TRAN
          IF ( IOS .NE. 0 ) THEN
            DP_TRAN = SPNUM
            RETURN
          END IF
          WRITE( DIG, '(I2)', IOSTAT=IOS ) MAX( 3-LDIG, 0 )
          WRITE( DP_C, '(F20.'//DIG//')', IOSTAT=IOS ) DP_TRAN
          IF ( LDIG .GT. 3 ) THEN ! Zero out past 4 signif. digits
            DO I = 23-LDIG, 19
              DP_C(I:I) = '0'
            END DO
          END IF
        END IF
        READ( DP_C, '(BN,F20.0)', IOSTAT=IOS ) DP_TRAN
        IF ( IOS .NE. 0 ) DP_TRAN = SPNUM
      ELSE ! Straight assignment
        DP_TRAN = SPNUM
      END IF

      RETURN
      END


      SUBROUTINE QUAD3D(X1,X2,SS)
      EXTERNAL H
      CALL QGAUSX(H,X1,X2,SS)
      RETURN
      END
C
      FUNCTION F(ZZ)
      EXTERNAL FUNC
      COMMON /XYZ/ X,Y,Z
      Z=ZZ
      F=FUNC(X,Y,Z)
      RETURN
      END
C
      FUNCTION G(YY)
      EXTERNAL Z1,Z2,F
      COMMON /XYZ/ X,Y,Z
      Y=YY
      CALL QGAUSZ(F,Z1(X,Y),Z2(X,Y),SS)
      G=SS
      RETURN
      END
C
      FUNCTION H(XX)
      EXTERNAL Y1,Y2,G
      COMMON /XYZ/ X,Y,Z
      X=XX
      CALL QGAUSY(G,Y1(X),Y2(X),SS)
      H=SS
      RETURN
      END


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time = 0.0
real(dp), parameter :: stop_time = 0.15

real(dp), parameter :: CFL = 0.9

real(dp), parameter :: beta = 0.8

real(dp), parameter :: dt_checkpoint = 0.05

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

real(dp), parameter :: dt_analyze = 0.01

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

real(dp), parameter :: diameter = 1.0

real(dp), parameter :: xlim(2) = diameter * ((/0.0,1.0/) - 0.5)
real(dp), parameter :: ylim(2) = diameter * ((/0.0,1.0/) - 0.5)

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

real(dp), parameter :: radius_inner = 0.1_dp
real(dp), parameter :: radius_outer = 0.115_dp

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

real(dp), parameter :: kappa = 1.4_dp

real(dp), parameter :: dens0 = 1.0_dp

real(dp), parameter :: pres0 = 1.0_dp

real(dp), parameter :: velx0 = 0.0_dp
real(dp), parameter :: vely0 = 0.0_dp
real(dp), parameter :: velz0 = 0.0_dp

real(dp), parameter :: magx0 = 5.0_dp/SQRT(4.0_dp*pi)
real(dp), parameter :: magy0 = 0.0_dp
real(dp), parameter :: magz0 = 0.0_dp

real(dp), parameter :: glmp0 = 0.0_dp

real(dp), parameter :: mu0 = 1.0_dp

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

integer, parameter :: mesh_minlevel = 4
integer, parameter :: mesh_maxlevel = 6

real(dp), parameter :: setup_amr_threshold_refine = -6
real(dp), parameter :: setup_amr_threshold_coarsen = -7

real(dp), parameter :: dens_refine_threshold = 1.1*dens0
real(dp), parameter :: dens_coarse_threshold = 1.0*dens0

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module


program arr2
  integer:: a(10,10), b(-10:10)
  integer:: c = -3
  integer:: d = 5
  a(d,d) = 10
  b(c) = 10
  print *,(a(d,d) + b(-3))
end program arr2


! test_sets.f90 --
!     Test program for (unordered) sets
!
!     Note:
!     The module "MYDATA_MODULE" defines
!     the appropriate data type for the
!     data in the sets, the module
!     MYDATA_SET_STRUCTS is meant to prepare
!     the underlying data structure for the
!     sets.
!
!     $Id: test_sets.f90,v 1.2 2006-03-26 19:03:53 arjenmarkus Exp $
!
module MYDATA_MODULE

!
! The data that will be stored in the sets
!
type MYDATA
    integer :: value
end type MYDATA

!
! As derived types are compared, we need to define
! how to compare them
!
interface operator(.eq.)
    module procedure mydata_isequal
end interface

contains
logical function mydata_isequal( v1, v2 )
    type(MYDATA), intent(in) :: v1
    type(MYDATA), intent(in) :: v2

    mydata_isequal = v1%value .eq. v2%value
end function mydata_isequal

end module MYDATA_MODULE

module MYDATA_SET_STRUCTS
    use MYDATA_MODULE, SET_DATA => MYDATA

    include "data_for_sets.f90"
end module MYDATA_SET_STRUCTS

module MYDATA_SETS
    use MYDATA_SET_STRUCTS

    include "sets.f90"
end module MYDATA_SETS

program test_sets
    use MYDATA_SETS

    implicit none

    type(SET)      :: dataset
    type(SET)      :: dataset2
    type(SET)      :: result
    type(SET_DATA) :: data
    integer        :: i
    integer        :: size

    !
    ! Create a small set with the numbers 1 to 10
    !
    call set_create( dataset )

    do i = 1,10
        data%value = i
        call set_add( dataset, data )
    enddo

    !
    ! Add a redundant element
    !
    data%value = 5
    call set_add( dataset, data )

    !
    ! Check the size (must be 10)
    !
    size = set_size( dataset )
    if ( size /= 10 ) then
        write(*,*) 'Error: Size should be 10, is:', size
    endif

    !
    ! Check that the elements 1, 2, 3 are there,
    ! that 11, 12 and 13 are not
    !
    do i = 1,3
        data%value = i
        if ( .not. (data .elementof. dataset) ) then
            write(*,*) 'Error: Element ', i, 'is missing'
        endif
    enddo
    do i = 11,13
        data%value = i
        if ( data .elementof. dataset ) then
            write(*,*) 'Error: Element ', i, 'is present'
        endif
    enddo

    !
    ! Create another set that partly overlaps
    !
    call set_create( dataset2 )

    do i = 5,25
        data%value = i
        call set_add( dataset2, data )
    enddo

    !
    ! Now some simple set operations ...
    !
    result = dataset .union. dataset2

    do i = 1,25
        data%value = i
        if ( .not. (data .elementof. result) ) then
            write(*,*) 'Error: Element ', i, 'is missing from union'
        endif
    enddo

    call set_destroy( result )

    !
    ! Intersection ...
    !
    result = dataset .intersect. dataset2

    do i = 1,4
        data%value = i
        if ( data .elementof. result ) then
            write(*,*) 'Error: Element ', i, 'is present in intersection'
        endif
    enddo

    do i = 5,10
        data%value = i
        if ( .not. (data .elementof. result) ) then
            write(*,*) 'Error: Element ', i, 'is missing from intersection'
        endif
    enddo

    call set_destroy( result )

    !
    ! Exclusion ...
    !
    result = dataset .exclude. dataset2

    do i = 1,4
        data%value = i
        if ( .not. (data .elementof. result) ) then
            write(*,*) 'Error: Element ', i, 'is missing from exclusion'
        endif
    enddo

    do i = 5,10
        data%value = i
        if ( data .elementof. result ) then
            write(*,*) 'Error: Element ', i, 'is present in exclusion'
        endif
    enddo

    !
    ! Deletion ...
    !
    data%value = 3
    call set_delete_element( dataset, data )
    if ( data .elementof. dataset ) then
        write(*,*) 'Error: Element ', i, 'is still present after deletion'
    endif
    if ( set_size(dataset) /= 9 ) then
        write(*,*) 'Error: Size should 9, is ', set_size(dataset)
    endif

    write(*,*) 'If all is well, no error messages printed'
end program


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the main program supplied by the user.
! This is a simple example that just solves one linear elliptic pde.
!----------------------------------------------------

!       ------------
program phaml_master
!       ------------

!----------------------------------------------------
! This is the main program.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Local variables

type(phaml_solution_type) :: soln
!----------------------------------------------------
! Begin executable code

call phaml_create(soln,nproc=1,system_size=2, &
                  draw_grid_who=MASTER)

call phaml_solve_pde(soln,                   &
                     max_vert=2000,          &
                     draw_grid_when=PHASES,  &
                     pause_after_phases=.true., &
                     mg_cycles=10, &
                     print_grid_when=PHASES, &
                     print_grid_who=MASTER  ,&
                     print_error_when=PHASES    , &
                     print_error_what=ENERGY_LINF_ERR, &
                     print_errest_what=ENERGY_LINF_ERREST, &
                     print_error_who=MASTER)

call phaml_destroy(soln)

end program phaml_master


      SUBROUTINE MA02EZ( UPLO, TRANS, SKEW, N, A, LDA )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To store by (skew-)symmetry the upper or lower triangle of a
C     (skew-)symmetric/Hermitian complex matrix, given the other
C     triangle.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which part of the matrix is given as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C             For all other values, the array A is not referenced.
C
C     TRANS   CHARACTER*1
C             Specifies whether to use transposition or conjugate
C             transposition as follows:
C             = 'T':  Use transposition;
C             = 'C':  Use conjugate transposition.
C
C     SKEW    CHARACTER*1
C             Specifies whether the matrix is symmetric/Hermitian or
C             skew-symmetric/Hermitian as follows:
C             = 'N':  The matrix is symmetric/Hermitian;
C             = 'S':  The matrix is skew-symmetric/Hermitian.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper triangular part
C             (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'),
C             of this array must contain the corresponding upper or
C             lower triangle of the (skew-)symmetric/Hermitian matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the (skew-)symmetric/Hermitian matrix A with all elements
C             stored. If the resulted matrix should be Hermitian, the
C             imaginary parts of the diagonal entries are set to zero.
C             If the resulted matrix should be skew-Hermitian, the real
C             parts of the diagonal entries are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Sep. 2012. Based on SLICOT Library routine MA02ED.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER          SKEW, TRANS, UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      COMPLEX*16         A(LDA,*)
C     .. Local Scalars ..
      INTEGER            I, J
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..Intrinsic Functions..
      INTRINSIC          CONJG, DBLE, DIMAG
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked for errors.
C
      IF( LSAME( UPLO, 'L' ) ) THEN
C
C        Construct the upper triangle of A.
C
         IF( LSAME( TRANS, 'T' ) ) THEN
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 20 I = 1, N
                  DO 10 J = 2, N
                     A(I,J) = A(J,I)
   10             CONTINUE
   20          CONTINUE
C
            ELSE
C
               DO 40 I = 1, N
                  DO 30 J = 2, N
                     A(I,J) = -A(J,I)
   30             CONTINUE
   40          CONTINUE
C
            END IF
C
         ELSE
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 60 I = 1, N
                  A(I,I) = DBLE( A(I,I) )
                  DO 50 J = 2, N
                     A(I,J) = CONJG( A(J,I) )
   50             CONTINUE
   60          CONTINUE
C
            ELSE
C
               DO 80 I = 1, N
                  A(I,I) = DIMAG( A(I,I) )
                  DO 70 J = 2, N
                     A(I,J) = -CONJG( A(J,I) )
   70             CONTINUE
   80          CONTINUE
C
            END IF
C
         END IF
C
      ELSE IF( LSAME( UPLO, 'U' ) ) THEN
C
C        Construct the lower triangle of A.
C
         IF( LSAME( TRANS, 'T' ) ) THEN
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 100 I = 1, N
                  DO 90 J = 2, N
                     A(J,I) = A(I,J)
   90             CONTINUE
  100          CONTINUE
C
            ELSE
C
               DO 120 I = 1, N
                  DO 110 J = 2, N
                     A(J,I) = -A(I,J)
  110             CONTINUE
  120          CONTINUE
C
            END IF
C
         ELSE
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 140 I = 1, N
                  A(I,I) = DBLE( A(I,I) )
                  DO 130 J = 2, N
                     A(J,I) = CONJG( A(I,J) )
  130             CONTINUE
  140          CONTINUE
C
            ELSE
C
               DO 160 I = 1, N
                  A(I,I) = DIMAG( A(I,I) )
                  DO 150 J = 2, N
                     A(J,I) = -CONJG( A(I,J) )
  150             CONTINUE
  160          CONTINUE
C
            END IF
C
         END IF
C
      END IF
      RETURN
C *** Last line of MA02EZ ***
      END


!==============================================================================!
  subroutine Calculate_Vis_T_Spalart_Allmaras(grid)
!------------------------------------------------------------------------------!
!   Computes the turbulent viscosity for RANS models.                          !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Flow_Mod
  use Comm_Mod
  use Les_Mod
  use Rans_Mod
  use Grid_Mod
  use Control_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer         :: c
  real            :: x_rat, f_v1
!==============================================================================!

  if(turbulence_model .eq. DES_SPALART) then
    do c = 1, grid % n_cells
      x_rat    = vis % n(c)/viscosity
      f_v1     = x_rat**3/(x_rat**3 + c_v1**3)
      vis_t(c) = density * f_v1 * vis % n(c)
    end do
  end if

  if(turbulence_model .eq. SPALART_ALLMARAS) then
    do c = 1, grid % n_cells
      x_rat    = vis % n(c)/viscosity
      f_v1     = x_rat**3/(x_rat**3 + c_v1**3)
      vis_t(c) = density * f_v1 * vis % n(c)
    end do
  end if

  call Comm_Mod_Exchange_Real(grid, vis_t)

  end subroutine


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!                   UVT, UUT, VVT    :    COVARIANT HORIZONTAL VELOCITY VECTOR
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_HYD_ADV_N_DIF_XY

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_HYD_ADV_N_DIF_XY

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:,:    ) :: UVT , UUT , VVT

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

  CONTAINS

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

    USE MR_MOD_INTERP_XY

    USE MR_MOD_CALC_QADV_N_QDIF_XY
    USE MR_MOD_CALC_GRAD_XY

    USE MR_MOD_OPERATOR_UV

    IMPLICIT NONE

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

    INTEGER(KKID_KIND) , INTENT(IN ) :: K

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

    REAL   (FDRD_KIND) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ,1:2) :: HYD_QADV_XY_U , HYD_QDIF_XY_U
    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ,1:2) :: HYD_QADV_XY_V , HYD_QDIF_XY_V

    ALLOCATE( UVT(1:NI1(NI,FDRD_KIND),1:NJ,1:2) )

      UVT = ( JUV .MRUVTFM. UV(:,:,1:2, K ) )

      ALLOCATE( VVT(1:NI1(NI,FDRD_KIND),0:NJ,1:2) )
        CALL MR_INTERP_XY_UV_V_TO_GET_U_AT_V( NI , NJ , UV(:,:,1:2, K ) , VVT(:,:,1) )
       !CALL MR_INTERP_XY_UV_V_BY_LINEAR( NI , NJ , UV(:,:,1:2, K ) , VVT(:,:,2) )
        VVT(:,:,2) = V(:,:, K )

        VVT = ( JVV .MRUVTFM. VVT )

        CALL MR_CALC_QADV_N_QDIF_XY_UV_U( NI , NJ ,   &
        & UVT , VVT , RB , U(:,:, K ) , HYD_QADV_XY_U , EKXY , VXYU(:,:, K ) , HYD_QDIF_XY_U )

      DEALLOCATE( VVT )

      ALLOCATE( UUT(0:NI0(NI,FDRD_KIND),1:NJ,1:2) )
        CALL MR_INTERP_XY_UV_U_TO_GET_V_AT_U( NI , NJ , UV(:,:,1:2, K ) , UUT(:,:,2) )
       !CALL MR_INTERP_XY_UV_U_BY_LINEAR( NI , NJ , UV(:,:,1:2, K ) , UUT(:,:,1) )
        UUT(:,:,1) = U(:,:, K )

        UUT = ( JUU .MRUVTFM. UUT )

        CALL MR_CALC_QADV_N_QDIF_XY_UV_V( NI , NJ ,   &
        & UVT , UUT , RB , V(:,:, K ) , HYD_QADV_XY_V , EKXY , VXYV(:,:, K ) , HYD_QDIF_XY_V )

      DEALLOCATE( UUT )

    DEALLOCATE( UVT )

  ! CALCULATE ADVECTION
  ! REVISE ADVECTION BY THE DEPTH H
    HYD_QADV_XY_U = ( HYD_QADV_XY_U .MRUVMTP. HU )
    HYD_QADV_XY_V = ( HYD_QADV_XY_V .MRUVMTP. HV )
    CALL MR_CALC_REDC_GRAD_XY_UV( NI , NJ , HYD_QADV_XY_U , HYD_QADV_XY_V , HYD_ADV_XY )
  ! CONTRAVARIANTLY TRANSFORM
    HYD_ADV_XY = ( IUV .MRUVTFM. ( HYD_ADV_XY .MRUVDIV. H ) )

  ! CALCULATE DIFFUSION
  ! REVISE DIFFUSION BY THE DEPTH H
    HYD_QDIF_XY_U = ( HYD_QDIF_XY_U .MRUVMTP. HU )
    HYD_QDIF_XY_V = ( HYD_QDIF_XY_V .MRUVMTP. HV )
    CALL MR_CALC_REDC_GRAD_XY_UV( NI , NJ , HYD_QDIF_XY_U , HYD_QDIF_XY_V , HYD_DIF_XY )
  ! CONTRAVARIANTLY TRANSFORM
    HYD_DIF_XY = ( IUV .MRUVTFM. ( HYD_DIF_XY .MRUVDIV. H ) )

  END SUBROUTINE MR_CALC_HYD_ADV_N_DIF_XY

  END MODULE MR_MOD_CALC_HYD_ADV_N_DIF_XY


SUBROUTINE layer_cryst(nn)
   !
   USE kind
   USE phy_const, ONLY : const_pi
   USE my_math
   USE find2d_com, ONLY : cvec, atom_type, atom_tau, dist_a_min, dist_a_new, &
                          gv_vec, avec, rvolume, nat
   !
   !---------------------------------------------------------------------------
   IMPLICIT NONE
   !
   INTEGER, INTENT(IN) :: nn
   REAL(KIND=DP), DIMENSION(3) :: a1,a2,a3, gv, dv
   ! a1,a2,a3 : layered basis vectors, i.e. avec(:,:,nn)
   ! gv : gvectors, i.e. gv_vec(:,nn)
   ! dv : parallel to gv, magnitude is distance between layers
   !
   INTEGER :: cell_num, nat_layer
   ! cell_num : number of unit cells in the cell defined by a1a2a3
   ! nat_layer : number of atoms in layer unit cell
   !
   REAL(KIND=DP), ALLOCATABLE, DIMENSION(:,:) :: at_tau
   REAL(KIND=DP), ALLOCATABLE, DIMENSION(:) :: at_posp
   INTEGER, ALLOCATABLE, DIMENSION(:)   :: at_typ
   INTEGER, ALLOCATABLE, DIMENSION(:) :: at_lay
   ! atom position in cell defined by a1,a2,a3
   ! atom position projected on dv
   ! atom type
   ! atom layer
   !
   REAL(KIND=DP), ALLOCATABLE, DIMENSION(:) :: layer_dist
   REAL(KIND=DP) :: max_dist
   INTEGER :: layer_num
   !
   INTEGER :: ii,jj,kk,ll,cnt   ! counters
   REAL(KIND=DP), DIMENSION(3) :: vtmp
   REAL(KIND=DP) :: prj1, prj2, prj3, ptmp
   !
   CHARACTER(LEN=30) :: nametmp
   !
   !---------------------------------------------------------------------------
   !

   !
   ! Initialize----------------------------------------------------------------
   !
   a1 = avec(:,1,nn)
   a2 = avec(:,2,nn)
   a3 = avec(:,3,nn)
   gv = gv_vec(:,nn)
   dv = gv/dot_prod(gv,gv)*2*const_pi
   cell_num = nint(abs(dot_prod(a1,x_prod(a2,a3)))/rvolume)
   nat_layer = cell_num*nat
   ALLOCATE(at_tau(3,nat_layer))
   ALLOCATE(at_posp(nat_layer))
   ALLOCATE(at_typ(nat_layer))
   !
   ! generating new cell defined by a1,a2,a3 ----------------------------------
   !
   cnt = 1
   ii = 0
   jj = 0
   kk = 0
   !
   DO ! ii
      DO ! jj
         DO ! kk
            !
            vtmp = ii*cvec(:,1) + jj*cvec(:,2) + kk*cvec(:,3)
            prj1 = dot_prod(vtmp,a1)/dot_prod(a1,a1)
            prj2 = dot_prod(vtmp,a1)/dot_prod(a1,a1)
            prj3 = dot_prod(vtmp,a1)/dot_prod(a1,a1)
            !
            IF ( prj1>=0.0 .AND. prj1<1.0 .AND. prj2>=0 .AND. prj2<1.0 .AND. &
                 prj3>=0.0 .AND. prj3<1.0 ) THEN
               !
               DO ll=1,nat
                  at_tau(:,(cnt-1)*nat + ll) = atom_tau(:,ll) + vtmp
                  at_typ((cnt-1)*nat + ll) = atom_type(ll)
               ENDDO
               cnt = cnt + 1
               !
            ENDIF
            !
            IF (cnt>=cell_num) EXIT
            kk = -kk
            IF (kk >= 0) kk=kk+1
         ENDDO ! kk
         !
         IF (cnt>=cell_num) EXIT
         jj = -jj
         IF (jj >= 0) jj=jj+1
      ENDDO ! jj
      !
      IF (cnt>=cell_num) EXIT
      ii = -ii
      IF (ii >= 0) ii = ii + 1
      !
   ENDDO ! ii
   !
   ! sort atoms in dv(gv) direction--------------------------------------------
   !
   IF (nat_layer>1) THEN
      DO ii=1,nat_layer-1
         DO jj=nat_layer, ii+1, -1
           !
           IF ( dot_prod(dv,at_tau(:,jj-1)) > dot_prod(dv,at_tau(:,jj)) ) THEN
              vtmp = at_tau(:,jj-1)
              at_tau(:,jj-1) = at_tau(:,jj)
              at_tau(:,jj) = vtmp
              !
              ll = at_typ(jj-1)
              at_typ(jj-1) = at_typ(jj)
              at_typ(jj) = ll
           ENDIF
           !
         ENDDO ! jj
         !
         at_posp(ii) = dot_prod(dv,at_tau(:,ii))/vect_len(dv)
      ENDDO ! ii
      at_posp(nat_layer) = dot_prod(dv,at_tau(:,nat_layer))/vect_len(dv)
   ELSE
      at_posp(1) = dot_prod(dv,at_tau(:,1))/vect_len(dv)
   ENDIF
   !
   ! move to one cell
   !
   DO WHILE( at_posp(nat_layer)-at_posp(1) > vect_len(dv) )
         !
         vtmp = at_tau(:,1) + a3
         ll = at_typ(1)
         ptmp = dot_prod(dv,vtmp)/vect_len(dv)
         !
         ii=2
         DO WHILE ( at_posp(ii)<ptmp )
            at_typ(ii-1) = at_typ(ii)
            at_posp(ii-1) = at_posp(ii)
            at_tau(:,ii-1) = at_tau(:,ii)
            ii = ii + 1
         ENDDO
         !
         ii = ii - 1
         at_typ(ii) = ll
         at_posp(ii) = ptmp
         at_tau(:,ii) = vtmp
         !
   ENDDO
   !
   ! find atom layers----------------------------------------------------------
   !
   ALLOCATE(at_lay(nat_layer))
   ALLOCATE(layer_dist(nat_layer))
   !
   cnt = 0
   DO ii=1,nat_layer
      IF (ii==1) THEN
         layer_dist(1) = at_posp(1) + vect_len(dv) - at_posp(nat_layer)
         !
      ELSE
         layer_dist(ii) = at_posp(ii) - at_posp(ii-1)
         !
      ENDIF
      !
      IF (layer_dist(ii)>=dist_a_min) cnt = cnt + 1
      at_lay(ii) = cnt
   ENDDO
   layer_num = cnt
   !
   ! output -------------------------------------------------------------------
   !
   WRITE(*,102) vect_len(dv)
   102 FORMAT(T5,"|dv|=",F9.4)
   !
   WRITE(*,100) layer_num
   100 FORMAT(T5,"There are ",I2," atom layers in an unit cell:")
   !
   IF (layer_num>=1) THEN
      WRITE(*,103) max_dist(nat_layer,layer_dist)
      103 FORMAT("!",T4, "Maximal distance between layers is ", F9.4)
   ENDIF
   !
   DO ii=1,nat_layer
      !
      WRITE(*,101) at_typ(ii), ii, at_tau(:,ii), at_posp(ii), at_lay(ii), layer_dist(ii)
      101 FORMAT( T8, 'type=', I3,', tau(', I3, ')=(', 3F9.4, &
           ' ), proj=', F9.4, ', layer=', I2, ', dist=', F9.4 )
      !
   ENDDO
   !
   ! new cell with larger layer-distance
   !
 IF (layer_num>0) THEN
   DO ii=1,nat_layer
      !
      ! if this atom is the bottom of a layer, enlarge the distance
      !
      IF (layer_dist(ii)>dist_a_min) THEN
         !
         DO jj=ii,nat_layer
            at_tau(:,jj) = at_tau(:,jj) + (dist_a_new-layer_dist(ii))/vect_len(dv)*dv
         ENDDO
         !
         a3 = a3 + (dist_a_new-layer_dist(ii))/vect_len(dv)*dv
         !
      ENDIF
   ENDDO
   !
   dv = dot_prod(a3,dv)/vect_len(dv)/vect_len(dv)*dv
   !
   WRITE(*,120)
   120 FORMAT(T5,"New cell with larger layer-distance")
   !
   WRITE(*,121) 1, a1
   WRITE(*,121) 2, a2
   WRITE(*,121) 3, a3
   121 FORMAT(T8,'a(',I1,')=(', 3ES12.4,' )')
   !
   DO ii=1,nat_layer
      at_posp(ii) = dot_prod(at_tau(:,ii),dv)/vect_len(dv)
   ENDDO
   !
   DO ii=1,nat_layer
      IF (ii==1) THEN
         WRITE(*,122) at_typ(ii), ii, at_tau(:,ii), at_posp(ii), &
             at_lay(ii), at_posp(1) + vect_len(dv) - at_posp(nat_layer)
         122 FORMAT( T8, 'type=', I3,', tau(', I3, ')=(', 3F9.4, &
              ' ), proj=', F9.4, ', layer=', I2, ', dist=', F9.4 )
      ELSE
         WRITE(*,122) at_typ(ii), ii, at_tau(:,ii), at_posp(ii), &
                          at_lay(ii), at_posp(ii) - at_posp(ii-1)
      ENDIF
      !
   ENDDO
   !
   ! make xsf
   !
   WRITE(nametmp,'(I3)') nn
   nametmp = "xsf.g"//trim(adjustl(nametmp))//".xsf"
   CALL make_xsf(a1,a2,a3,nat_layer,at_tau,at_typ,nametmp)
   !
 ENDIF

   DEALLOCATE(at_tau)
   DEALLOCATE(at_typ)
   DEALLOCATE(at_posp)
   DEALLOCATE(at_lay)
   DEALLOCATE(layer_dist)
   !
ENDSUBROUTINE

FUNCTION max_dist(n,dist)
   !
   USE kind
   !
   IMPLICIT NONE
   !
   REAL(KIND=DP) :: max_dist
   INTEGER, INTENT(IN) :: n
   REAL(KIND=DP), DIMENSION(n), INTENT(IN) :: dist
   !
   INTEGER :: ii
   !
   max_dist = dist(1)
   DO ii=2,n
      IF (dist(ii)>max_dist) max_dist = dist(ii)
   ENDDO
   !
ENDFUNCTION

SUBROUTINE make_xsf(a1,a2,a3,na,tau,typ,filname)
   !
   USE kind
   !
   REAL(KIND=DP), DIMENSION(3), INTENT(IN) :: a1,a2,a3
   INTEGER, INTENT(IN) :: na
   REAL(KIND=DP), DIMENSION(3,na), INTENT(IN) :: tau
   INTEGER, DIMENSION(na), INTENT(IN) :: typ
   CHARACTER(LEN=40), INTENT(IN) :: filname
   !
   INTEGER, PARAMETER :: fil=1234
   INTEGER :: ii
   !
   ii=index(filname,' ')
   OPEN(UNIT=fil, FILE=filname(1:ii-1), STATUS='REPLACE', ACTION='WRITE', POSITION='REWIND')
   !
   WRITE(fil,140)
   140 FORMAT("CRYSTAL",/,"PRIMVEC")
   !
   WRITE(fil,141) a1(:)
   WRITE(fil,141) a2(:)
   WRITE(fil,141) a3(:)
   141 FORMAT(T4,3F20.8)
   !
   WRITE(fil,142)
   142 FORMAT("CONVVEC")
   !
   WRITE(fil,141) a1(:)
   WRITE(fil,141) a2(:)
   WRITE(fil,141) a3(:)
   !
   WRITE(fil,143)
   143 FORMAT("PRIMCOORD")
   WRITE(fil,144) na, 1
   144 FORMAT(I3,I3)
   !
   DO ii=1,na
      WRITE(fil,145) typ(ii), tau(:,ii)
      145 FORMAT(I3,3F20.8)
   ENDDO
   !
   CLOSE(fil)
   !
ENDSUBROUTINE


************************************************************************
*              Support routines for quadric surfaces                   *
************************************************************************
* EAM Jun 1997	- initial version, supports version 2.4(alpha) of render
* EAM May 1998	- additional error checking to go with Parvati/rastep
* EAM Jan 1999	- version 2.4i
* EAM Mar 2008	- Gfortran optimization breaks the object accounting.
*		  No real solution yet.  Move qinp.f into separate file
************************************************************************
*
* Quadric surfaces include spheres, cones, ellipsoids, paraboloids, and
* hyperboloids.  The motivation for this code was to allow rendering
* thermal ellipsoids for atoms, so the other shapes have not been
* extensively tested.
* A quadric surface is described by 10 parameters (A ... J).
* For efficiency during rendering it is also useful to know the center and
* a bounding sphere. So a QUADRIC descriptor to render has 17 parameters:
* 14 (object type QUADRIC)
*    X Y Z RADLIM RED GRN BLU
*    A B C D E F G H I J
*
* The surface itself is the set of points for which Q(x,y,z) = 0
* where
*      Q(x,y,z)	=  A*x^2 +  B*y^2 +  C*z^2
*         	+ 2D*x*y + 2E*y*z + 2F*z*x
*         	+ 2G*x   + 2H*y   + 2I*z
*         	+  J
*
* It is convenient to store this information in a matrix QQ
*	| QA QD QF QG |		QA = A    QB = B    QC = C
* QQ =	| QD QB QE QH |		QD = D    QE = E    QF = F
*	| QF QE QC QI |		QG = G    QH = H    QI = I
*	| QG QH QI QJ |		QJ = J
*
* Then Q(x,y,x) = XT*QQ*X	where X = (x,y,z,1)
* The point of this is that a 4x4 homogeneous transformation T can be
* applied to QQ by matrix multiplication:     QQ' = TinvT * QQ * Tinv
*
* The surface normal is easily found by taking the partial derivatives
* of Q(x,y,z) at the point of interest.
************************************************************************
* TO DO:
*	- can we distinguish an ellipsoid from other quadrics? Do we care?
************************************************************************

CCC	Calculate the matrices for quadric transformation
CC	QQ' = TINVT * QQ * TINV      (TINV is inverse of transposed TMAT)
C
	subroutine qsetup
*
      COMMON /MATRICES/ XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT,
     &                  TMAT, TINV, TINVT, SROT, SRTINV, SRTINVT
     &                 ,RAFTER, TAFTER
      REAL   XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT
      REAL   TMAT(4,4), TINV(4,4),   TINVT(4,4)
      REAL   SROT(4,4), SRTINV(4,4), SRTINVT(4,4)
      REAL   RAFTER(4,4), TAFTER(3)
*
      COMMON /ASSCOM/ noise, verbose
      integer         noise
      logical         verbose
*
	real   TRAN(4,4), POST(4,4), det
*
*	TMAT is a post-multiplier matrix, but unfortunately the
*	quadric surface math was worked out for pre-multipliers
*	So the quadric math uses the transpose of TMAT
	call trnsp4( TRAN, TMAT )
*
*	Remove translation component from TMAT.
*	I had to make a choice whether the X,Y,Z "center" of the quadric
*	is implicitly coded into the coefficients, or whether it is to be
*	maintained explicitly.  Since all other object types do the latter,
*	I have chosen to keep all translation components out of the quadric
*	coefficients
	tran(1,4) = 0.0
	tran(2,4) = 0.0
	tran(3,4) = 0.0
*
*	July 1999 - Allow post-hoc rotation matrix also
	call tmul4( POST, RAFTER, TRAN )
*
	det = tinv4( TINV, POST ) / TMAT(4,4)
	call trnsp4( TINVT, TINV )
*
*	While we're at it, check for legality of rotation matrix
	if (abs(1. - abs(det)) .gt. 0.02) then
	    write (noise,901) abs(det)
  901	    format('>>> Warning: Determinant of rotation matrix =',
     &           F7.3,' <<<')
	endif
	if (TMAT(1,4).ne.0.or.TMAT(2,4).ne.0.or.TMAT(3,4).ne.0) then
	    write (noise,902)
  902       format('>>> Warning: Non-zero cross terms in 4th column of',
     &             ' TMAT <<<')
	endif
*
*	Same thing again for shadow rotation matrix
	call  trnsp4( TRAN, SROT )
	det = tinv4( SRTINV, TRAN )
	call  trnsp4( SRTINVT, SRTINV )
	if (abs(1. - abs(det)) .gt. 0.02) then
	    write (noise,903) abs(det)
  903	    format('>>> Warning: Determinant of shadow matrix =',
     &           F7.3,' <<<')
	endif
*
	return
	end

************************************************************************
* This routine does the exact test for pixel impingement of a quadric  *
* in both pixel and shadow space.                                      *
* Find Z coordinate of point on quadric surface with given X, Y        *
* Also return surface normal at that point                             *
************************************************************************
CCC
CC
C
	function qtest( center, coeffs, xp, yp, zp, qnorm, shadowspace,
     &                  backside )
	IMPLICIT NONE
	logical  qtest, shadowspace
	logical  backside
	real    center(3), coeffs(10), xp, yp, zp, qnorm(3)
*
      COMMON /MATRICES/ XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT,
     &                  TMAT, TINV, TINVT, SROT, SRTINV, SRTINVT
     &                 ,RAFTER, TAFTER
      REAL   XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT
      REAL   TMAT(4,4), TINV(4,4),   TINVT(4,4)
      REAL   SROT(4,4), SRTINV(4,4), SRTINVT(4,4)
      REAL   RAFTER(4,4), TAFTER(3)
*
	real    QA,QB,QC,QD,QE,QF,QG,QH,QI,QJ
	real    AA,BB,CC,DD,EE
	real    x,y,z
*
	QA = coeffs(1)
	QB = coeffs(2)
	QC = coeffs(3)
	QD = coeffs(4)
	QE = coeffs(5)
	QF = coeffs(6)
	QG = coeffs(7)
	QH = coeffs(8)
	QI = coeffs(9)
	QJ = coeffs(10)
*
*	xp and yp are in pixel coordinates, rather than in normalized ones
*	First displace center of quadric surface from the implicit origin
*	to the point specified by center(3), then convert to pixel coords
*
	x = (xp - center(1)) / scale
	y = (yp - center(2)) / scale
*
	AA = QC
	BB = 2.0 * (QF*x + QE*y + QI)
	CC = QA*x*x + QB*y*y + 2.0*(QD*x*y + QG*x + QH*y) + QJ
	DD = BB*BB - 4*AA*CC
	if (DD.LT.0) then
	    qtest = .false.
	    return
	else
	    qtest = .true.
	    EE = sqrt(DD)
	endif
	if (AA .eq. 0.) then
CDEBUG	    Can this happen????
	    z = 9999.
	else if (backside) then
	    if (AA .le. 0.) then
	    	z = (-BB + EE) / (2*AA)
	    else
	    	z = (-BB - EE) / (2*AA)
	    endif
	else
	    if (AA .gt. 0.) then
	    	z = (-BB + EE) / (2*AA)
	    else
	    	z = (-BB - EE) / (2*AA)
	    endif
	endif
	zp = z * scale
	zp = zp + center(3)
*
*	Surface normal comes from partial derivatives at this point
	if (.not. shadowspace) then
	    qnorm(1) = QA*x + QD*y + QF*z + QG
	    qnorm(2) = QB*y + QD*x + QE*z + QH
	    qnorm(3) = QC*z + QF*x + QE*y + QI
	endif
*
	return
	end

CCC	Convert ANISOU description of anisotropic displacement parameters
CC	into quadric surface enclosing a given probability volume
C	Returns -1 if the Uij are non-positive definite, 1 otherwise
C
	function anitoquad( ANISOU, PROB, QUADRIC, EIGENS, EVECS)
	implicit NONE
	integer  anitoquad
	real     ANISOU(6), PROB, QUADRIC(10)
	real     EIGENS(3), EVECS(4,4)
c
	COMMON /ASSCOM/ noise, verbose
	integer         noise
	logical         verbose
c
	real	UU(4,4), UINV(4,4)
	integer i
c
	real     tinv4, det
c
c	Save FPU traps later by checking that ANISOU is non-zero
	do i = 1,3
	    EIGENS(i) = 0.0
	end do
	if (ANISOU(1).eq.0.and.ANISOU(2).eq.0.and.ANISOU(3).eq.0 .and.
     &      ANISOU(4).eq.0.and.ANISOU(5).eq.0.and.ANISOU(6).eq.0) then
     		anitoquad = -2
		return
	end if
c
c	Build matrix from Uij coefficients and invert it
	UU(1,1) = ANISOU(1)
	UU(2,2) = ANISOU(2)
	UU(3,3) = ANISOU(3)
 	UU(4,4) = -(1/PROB**2)
	UU(1,2) = ANISOU(4)
	UU(2,1) = ANISOU(4)
	UU(2,3) = ANISOU(6)
	UU(3,2) = ANISOU(6)
	UU(1,3) = ANISOU(5)
	UU(3,1) = ANISOU(5)
	UU(1,4) = 0.0
	UU(4,1) = 0.0
	UU(2,4) = 0.0
	UU(4,2) = 0.0
	UU(3,4) = 0.0
	UU(4,3) = 0.0
	det = tinv4( UINV, UU )
c
c	and from that we extract the coefficients of the surface
	QUADRIC(1)  = UINV(1,1)
	QUADRIC(2)  = UINV(2,2)
	QUADRIC(3)  = UINV(3,3)
	QUADRIC(4)  = UINV(1,2)
	QUADRIC(5)  = UINV(2,3)
	QUADRIC(6)  = UINV(1,3)
	QUADRIC(7)  = UINV(1,4)
	QUADRIC(8)  = UINV(2,4)
	QUADRIC(9)  = UINV(3,4)
	QUADRIC(10) = UINV(4,4)
c
c	Find eigenvalues of the ellipsoid
	call jacobi( UU,   3, 4, EIGENS, EVECS )
c
c	Units of this matrix are A**2; we want values in A
	anitoquad = 1
	do i = 1,3
	    if (EIGENS(i).gt.0.) then
		EIGENS(i) = sqrt(EIGENS(i))
	    else
C		write (noise,*) 'Non-positive definite ellipsoid!'
		EIGENS(i) = 0.
		anitoquad = -1
	    endif
	enddo
c
	return
	end

CCC	Matrix manipulation routines for 4x4 homogeneous transformations
CC
C
	subroutine tmul4( C, A, B )
	real   C(4,4), A(4,4), B(4,4)
	integer i,j
	do i = 1,4
	do j = 1,4
	    C(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j)
     &		   + A(i,3)*B(3,j) + A(i,4)*B(4,j)
	enddo
	enddo
	return
	end

	subroutine trnsp4( B, A )
	real   B(4,4), A(4,4)
	integer i,j
	do i=1,4
	do j=1,4
	    B(i,j) = A(j,i)
	enddo
	enddo
	return
	end

CCC	Matrix inversion for a 4x4 matrix A
CC
C
	function tinv4( AI, A )
	real     tinv4
	real     AI(4,4), A(4,4)
c
	real	TMP(4,4), D
	integer index(4)
c
	do i=1,4
	    do j=1,4
		TMP(i,j) = A(i,j)
		AI(i,j) = 0.
	    enddo
	    AI(i,i) = 1.
	enddo
	call ludcmp( TMP, 4, index, D )
	tinv4 = D * TMP(1,1)*TMP(2,2)*TMP(3,3)*TMP(4,4)
	do j=1,4
	    call lubksb( TMP, 4, index, AI(1,j) )
	enddo
	return
	end

************************************************************************
*              Matrix inversion via LU decomposition                   *
*	adapted from Numerical Recipes in Fortran (1986)               *
************************************************************************
*
CCC	input  NxN matrix A is replaced by its LU decomposition
CC	output index(N) records row permutation due to pivoting
C	output D is parity of row permutations
c
	subroutine ludcmp( A, n, index, D )
	implicit  NONE
	integer   n,index(n)
	real      A(n,n)
	real      D
c
	integer   i,imax,j,k
	real      aamax,dum,sum
	integer    NMAX
	parameter (NMAX=10)
	real      vv(NMAX)
c
	d = 1.
	do i=1,n
	    aamax = 0.
	    do j=1,n
	    	if (abs(A(i,j)).gt.aamax) aamax = abs(A(i,j))
	    enddo
	    call assert(aamax.ne.0.,'Singular matrix')
	    vv(i) = 1. / aamax
	enddo
c
	imax = 1
	do j=1,n
	    if (j.gt.1) then
		do i=1,j-1
		    sum = A(i,j)
		    if (i.gt.1) then
			do k=1,i-1
			    sum = sum - A(i,k)*A(k,j)
			enddo
			A(i,j) = sum
		    endif
		enddo
	    endif
	    aamax = 0.
	    do i=j,n
		sum = A(i,j)
		if (j.gt.1) then
		    do k=1,j-1
			sum = sum - A(i,k)*A(k,j)
		    enddo
		    A(i,j) = sum
		endif
		dum = vv(i) * abs(sum)
		if (dum.ge.aamax) then
		    imax = i
		    aamax = dum
		endif
	    enddo
	    if (j.ne.imax) then
		do k=1,n
		    dum = A(imax,k)
		    A(imax,k) = A(j,k)
		    A(j,k) = dum
		enddo
		d = -d
		vv(imax) = vv(j)
	    endif
	    index(j) = imax
	    call assert(A(j,j).ne.0.,'Singular matrix')
	    if (j.ne.n) then
		dum = 1. / A(j,j)
		do i=j+1,n
		    A(i,j) = A(i,j) * dum
		enddo
	    endif
	enddo
	return
	end

CCC	corresponding back-substitution routine
CC
C
	subroutine lubksb( A, N, index, B )
	implicit NONE
	integer  n, index(n)
	real     A(n,n), B(n)
c
	integer  i,ii,j,ll
	real     sum
c
	ii = 0
	do i=1,n
	    ll = index(i)
	    sum = B(ll)
	    B(ll) = B(i)
	    if (ii.ne.0) then
		do j=ii,i-1
		    sum = sum - A(i,j)*B(j)
		enddo
	    else if (sum.ne.0.) then
		ii = i
	    endif
	    B(i) = sum
	enddo
c
	do i=n,1,-1
	    sum = B(i)
	    if (i.lt.n) then
		do j=i+1,n
		    sum = sum - A(i,j)*B(j)
		enddo
	    endif
	    B(i) = sum / A(i,i)
	enddo
	return
	end

************************************************************************
* Find eigenvalues and eigenvectors of nxn symmetric matrix using      *
* cyclic Jacobi method. NP is (Fortran) physical storage dimension.    *
* On return A is destroyed, D contains eigenvalues,and each column of  *
* V is a normalized eigenvector                                        *
* Adapted from Numerical Recipes in Fortran (1986)                     *
* We only need it for 3x3 symmetric matrices, so it's overkill.        *
************************************************************************
CCC
CC
C
	subroutine jacobi( A, n, np, D, V )
	PARAMETER (NMAX=4)
c	Machine dependent! (converge when off-diagonal sum is less than this)
	PARAMETER (TINY = 1.e-37)
	real A(np,np), D(n), V(np,np)
	real B(NMAX), Z(NMAX)
c
	call assert(n.le.NMAX,'Matrix too big for eigenvector routine')
c
c	Initialize V to identity matrix, B and D to diagonal of A
	do ip = 1,n
	do iq = 1,n
	    V(ip,iq) = 0.0
	enddo
	V(ip,ip) = 1.0
	B(ip) = A(ip,ip)
	D(ip) = B(ip)
	Z(ip) = 0.0
	enddo
	nrot = 0
c
c	50 sweeps is never expected to happen; Press et al (1986) claim
c	6 to 10 are typical for moderate matrix sizes
c	Empirical trials of rastep show 6 sweeps, 8-10 rotations
	do i = 1,50
	    sm = 0.0
	    do ip = 1,n-1
	    do iq = ip+1,n
		sm = sm+abs(A(ip,iq))
	    enddo
	    enddo
	    if (sm .lt. TINY) return
c	    After 4 sweeps skip rotation if the off-diagonal is small
	    if (i .lt. 4) then
		thresh = 0.2*sm/(n*n)
	    else
		thresh = 0.0
	    endif
	    do ip = 1,n-1
	    do iq = ip+1,n
		g = 100. * abs(A(ip,iq))
		if ((i.gt.4) .and.
     &		    (abs(D(ip)) + g .eq. abs(D(ip))) .and.
     &		    (abs(D(iq)) + g .eq. abs(D(iq)))) then
		    A(ip,iq) = 0.0
		else if (abs(A(ip,iq)).gt.thresh) then
		    h = D(iq) - D(ip)
		    if (abs(h) + g .eq. abs(h)) then
			t = A(ip,iq) / h
		    else
			theta = 0.5 * h / A(ip,iq)
			t = 1. / (abs(theta) + sqrt(1.+theta*theta))
			if (theta.lt.0.) t = -t
		    endif
		    c = 1./sqrt(1.+t*t)
		    s = t * c
		    tau = s/(1.+c)
		    h = t * A(ip,iq)
		    Z(ip) = Z(ip) - h
		    Z(iq) = Z(iq) + h
		    D(ip) = D(ip) - h
		    D(iq) = D(iq) + h
		    A(ip,iq) = 0.0
		    do j = 1,ip-1
			g = A(j,ip)
			h = A(j,iq)
			A(j,ip) = g - s*(h+g*tau)
			A(j,iq) = h + s*(g-h*tau)
		    enddo
		    do j = ip+1,iq-1
			g = A(ip,j)
			h = A(j, iq)
			A(ip,j) = g - s*(h+g*tau)
			A(j,iq) = h + s*(g-h*tau)
		    enddo
		    do j = iq+1,n
			g = A(ip,j)
			h = A(iq,j)
			A(ip,j) = g - s*(h+g*tau)
			A(iq,j) = h + s*(g-h*tau)
		    enddo
		    do j = 1,n
			g = V(j,ip)
			h = V(j,iq)
			V(j,ip) = g - s*(h+g*tau)
			V(j,iq) = h + s*(g-h*tau)
		    enddo
		    nrot = nrot + 1
		endif
	    enddo
	    enddo
c
c	    Update D with sum and reinitialize Z
	    do ip = 1,n
		B(ip) = B(ip) + Z(ip)
		D(ip) = B(ip)
		Z(ip) = 0.0
	    enddo
	enddo
c
	call assert(.false.,'Failed to find eigenvectors')
	return
	end
c

C	This one really has nothing to do with quadrics per se,
C	but since it's invoked by qinp, both render and rastep
C	need to be able to see it.
C	Should really be in separate file of support routines
C
	FUNCTION PERSP( Z )
	REAL PERSP, Z
	COMMON /MATRICES/ XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT,
     &                  TMAT, TINV, TINVT, SROT, SRTINV, SRTINVT
     &                 ,RAFTER, TAFTER
	REAL   XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT
	REAL   TMAT(4,4), TINV(4,4),   TINVT(4,4)
	REAL   SROT(4,4), SRTINV(4,4), SRTINVT(4,4)
	REAL   RAFTER(4,4), TAFTER(3)
	IF (Z/EYEPOS .GT. 0.999) THEN
	    PERSP = 1000.
	ELSE
	    PERSP = 1. / (1. - Z/EYEPOS)
	ENDIF
	RETURN
	END


  function photoCrossSection (photonEG, e, a0)

! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    class(PhotonEventGenerator), intent(inout) :: photonEG
    real(real64),   intent(in   ) :: e
    real(real64),   intent(in   ) :: a0
    real(real64)                  :: photoCrossSection

    real(real64) :: sigkos

! ======================================================================

    if ( abs(a0-one)<divZerLim ) then
       call skosgp (e, sigkos)
    elseif ( abs(a0-two)<divZerLim) then
       call photonEG%skosgd (e, sigkos)
    else
       call photonEG%skosga (e, a0, sigkos)
    endif

    photoCrossSection = sigkos
    return

! ======================================================================
  end function photoCrossSection


      PROGRAM co2_continuum

      IMPLICIT NONE

C     Number of data sets
      INTEGER, PARAMETER ::
     &    n_data = 2
C     Pointers to data sets
      INTEGER, PARAMETER ::
     &    ip_gruszka = 1
C           Gruszka & Borysow (1997)
     &  , ip_baranov = 2
C           Baranov et al. (2004)

C     Loschmidt constant
      REAL(KIND=8), PARAMETER :: loschmidt_cnst = 2.6867774D+19

C     CIA table
      REAL(KIND=8), ALLOCATABLE ::
     &    wn_tbl(:)
C           Wavenumber
     &  , temp_tbl(:)
C           Temperatures

C     Wavenumber and temperature data
      REAL(KIND=8) ::
     &    wn_min(n_data)
C           Minimum wavenumber
     &  , wn_max(n_data)
C           Maximum wavenumber
     &  , temp_min(n_data)
C           Minimum temperature
     &  , temp_max(n_data)
C           Maximum temperature

C     As comments in CIA header
      CHARACTER(LEN=21) ::
     &    comment(n_data)

C     Increments
      REAL(KIND=8), PARAMETER ::
     &    wn_tbl_inc   = 1.0D-01
C           Wavenumber increment
     &  , temp_tbl_inc = 1.0D+01
C           Temperature increment

C     Table parameters
      REAL(KIND=8), PARAMETER ::
     &    temp_tbl_min = 1.0D+02
C           Minimum temperature at which to tabulate CIA
     &  , temp_tbl_max = 4.0D+02
C           Maximum temperature at which to tabulate CIA
      INTEGER ::
     &    n_wn_tbl(n_data)
C           Number of wavenumber points
     &  , n_temp_tbl
C           Number of temperatures in CIA table

      INTEGER ::
     &    i, i_wn, j
C           Loop indices
     &  , n_offset
C           Offset of index in wavenumber array

C     File ID
      INTEGER, PARAMETER :: fid = 100

C     Calculated CIA absorption coefficient
      REAL(KIND=8), ALLOCATABLE :: kabs(:)

      OPEN(UNIT=fid, FILE='co2-co2.cia')

C     Set minimum and maximum wns and temps
      wn_min(ip_gruszka)   = 0.00D+00
      wn_max(ip_gruszka)   = 2.50D+02
      wn_min(ip_baranov)   = 1.15D+03
      wn_max(ip_baranov)   = 1.55D+03
      temp_min(ip_gruszka) = 2.00D+02
      temp_max(ip_gruszka) = 8.00D+02
      temp_min(ip_baranov) = 1.00D+02
      temp_max(ip_baranov) = 3.50D+02

C     Put sources in the comments
      comment(ip_gruszka) = 'Gruszka, Borysow 1997'
      comment(ip_baranov) = 'Baranov et al. 2004'

C     Set temp table
      n_temp_tbl = 1 + NINT(
     &    (temp_tbl_max - temp_tbl_min)/temp_tbl_inc)
      ALLOCATE(temp_tbl(n_temp_tbl))
      DO i=1, n_temp_tbl
        temp_tbl(i) = temp_tbl_min + (i-1)*temp_tbl_inc
      END DO

C     Set number of wavenumbers
      DO i=1, n_data
        n_wn_tbl(i) = FLOOR(
     &    (wn_max(i) - wn_min(i))/wn_tbl_inc)
      END DO
      ALLOCATE(wn_tbl(SUM(n_wn_tbl)))
      DO i=1, n_data
        DO i_wn=1, n_wn_tbl(i)
          n_offset = SUM(n_wn_tbl(1:(i-1)))
          wn_tbl(n_offset+i_wn) = wn_min(i) + i_wn*wn_tbl_inc
        END DO
      END DO
      ALLOCATE(kabs(SUM(n_wn_tbl)))

C     Get data and print to file
      DO i=1, n_temp_tbl
        DO i_wn=1, SUM(n_wn_tbl)

C         Get the CIA at this temperature and wavenumber
          IF (wn_tbl(i_wn) >= wn_min(ip_gruszka) .AND.
     &        wn_tbl(i_wn) <= wn_max(ip_gruszka)) THEN
            IF (temp_tbl(i) < temp_min(ip_gruszka)) THEN
              CALL getspc(temp_min(ip_gruszka), wn_tbl(i_wn),
     &            kabs(i_wn))
            ELSE IF (temp_tbl(i) > temp_max(ip_gruszka)) THEN
              CALL getspc(temp_max(ip_gruszka), wn_tbl(i_wn),
     &            kabs(i_wn))
            ELSE
              CALL getspc(temp_tbl(i), wn_tbl(i_wn),
     &            kabs(i_wn))
            END IF

          ELSE IF (wn_tbl(i_wn) >= wn_min(ip_baranov) .AND.
     &        wn_tbl(i_wn) <= wn_max(ip_baranov)) THEN
            IF (temp_tbl(i) < temp_min(ip_baranov)) THEN
              CALL baranov(temp_min(ip_baranov), wn_tbl(i_wn),
     &            kabs(i_wn))
            ELSE IF (temp_tbl(i) > temp_max(ip_baranov)) THEN
              CALL baranov(temp_max(ip_baranov), wn_tbl(i_wn),
     &            kabs(i_wn))
            ELSE
              CALL baranov(temp_tbl(i), wn_tbl(i_wn),
     &            kabs(i_wn))
            END IF
          ELSE
            WRITE(*,*) 'Error: Data for this wavelngth not found.'
            WRITE(*,*) wn_tbl(i_wn)
            STOP
          END IF

        END DO

C       For each data set, print the CIA data at this temperature
        DO j=1, n_data
          WRITE(fid, '(A20, F10.3, F10.3, I7, F7.1, 22X, A21, 3X)')
     &        'CO2-CO2', wn_min(j), wn_max(j), n_wn_tbl(j),
     &        temp_tbl(i), comment(j)
          DO i_wn=1, n_wn_tbl(j)
            n_offset = SUM(n_wn_tbl(1:(j-1)))
            WRITE(fid, '(F10.3, 1X, ES10.3)')
     &          wn_tbl(n_offset+i_wn),
     &          kabs(n_offset+i_wn)/(loschmidt_cnst**2)
          END DO
        END DO
      END DO

      DEALLOCATE(temp_tbl)

      CLOSE(fid)

      CONTAINS

c     This program computes RT CIA spectra of CO2 at low density limit
C     at temperatures between 200 and 800K.
C
C     ============================================================================
C     Copyright (C) 1997   Marcin Gruszka
C     ============================================================================
C
C     Copyright Notice:
C     You may use this program for your scientific applications,
C     but please do not	distribute it yourself.
C     Direct all your inquires to the  author: e-mail aborysow@stella.nbi.dk
C     Final request: If you publish  your work which benefited from this
C     program, please acknowledge using this program and quote
C     the original paper describing the procedure:
C     M. Gruszka and A. Borysow,
C     Roto-translational collision-induced absorption of CO2
C     for the Atmosphere of Venus at Frequencies from 0 to 250 cm$^{-1}$
C     and at temperature from 200K to 800K,
C     Icarus, vol. 129, pp. 172-177, (1997).

C
C     The paper (Icarus) describing this computer model, is based on  original paper by
C     M. Gruszka and A. Borysow,
C     "Computer Simulation of the Far Infrared Collision-induced absorption spectra
C     of gaseous CO2", Mol. Phys., vol. 93, pp. 1007-1016, 1998.
C     ============================================================================
C
C     NOTE: The program gives data at spacing corresponding to
c     Freq(max)-Freq(min)/(npoint-1),
c     Since reasons are unknown (author's secret), it is recommended to
c     request one more point that neccesary and get the right freq. step
c     ==================================================================

c
c     The following input parametres are required (*):
c     ------------------------------------------------
c     (*) some input parameters are Fortran REAL numbers
c     and should be entered with a decimal point,
c     not like INTEGER!
c
c     1. Temperature: (in K) (REAL)
c     -the model is restricted to the temperature range from
c     200 K to 800 K.
c
c     2. Frequency limits: (in cm^-1) (REAL,REAL)
c     -the model has been designed to reproduce the MD and the
c     experimental data up to 250 cm^-1. There is no restriction
c     on requesting a higher value, but the accuracy may decrease
c     significantly.
c
c     3. Number of points in the output file: (less than Npmx) (INTEGER)
c     -the frequency grid is controled by the number of points
c     in the output file.
c     (i.e. if the upper limit = 250.0 and the number of points = 50.0,
c     the spectrum will be computed every 5 cm^-1 )
c
c     4. The output in automaticaly directed to output.dat file.
c
c     STRUCTURE OF THE PROGRAM:
c     --------------------------------------------------------------
c     The MAIN program consists of three modules:
c
c     1. getdat - provides the user interface,
c     in this subroutine the Temperature, Frequency Limits and
c     the number of points are read from the keyboard.
c
c     2. getspc - the main subroutine, where the spectrum is computed.
c     The three input parameters (temp, range and n; all REAL numbers)
c     are transmited by value and the absorption coefficient abcoef(..)
c     is returned. The default lenght of abcoef(..) is Npmx and if
c     n < Npmx, the empty places are set to 0. If a denser grid is
c     required please change the n appropriaetly in the data declaration
c     of the MAIN program and inside the getspc.
c
c     3. putdat - generates the output file.
c     The frequency (in cm^-1) and
c     the absorption coefficient (in cm^-1 amagat^-2) are written
c     to the 'output.dat' file in the followinf format:
c     format(f10.3,e20.7)
c
c===========================================================================
c
c
c     ---------------------------------------------------------------------------------------------------------------
c     2008/10/15
c
c     Modifications of the code by V. Eymet as follows:
c     + only the "getspc" routine remains
c     + inputs: temp (temperature in K), wn (wavenumber in cm^-1); output: abcoef (absorption coefficient, in cm^-1 amagat^-2)
c     ---------------------------------------------------------------------------------------------------------------
c
c
c
c     ---------------------------------------------------------------------------------------------------------------
c     2009/2/28
c
c     Modifications of the code by R. Wordsworth as follows:
c     + "baranov" routine added to calculate CIA dimer spectrum between 1100 and 1600 cm^-1
c     + this uses recorded data rather than an analytical function, so bilinear interpolation is needed
c     + inputs and outputs are identical to those of getspc
c     ---------------------------------------------------------------------------------------------------------------

      subroutine getspc(temp,wn,abcoef)
      implicit none
c
c     Purpose: to compute coliision-induced absorption coefficient
c
c     Input:
c       + temp: temperature (K)
c       + wn: wavenumber (inv. cm)
c
c     Output:
c       + abcoef: absorption coefficient, (cm^-1 amagat^-2)
c
c     I/O
      real*8 temp               !temperature
      real*8 wn        !wavenumber
      real*8 abcoef       !absorption coefficient
c     -------------------------------------------------------
c     The A, B and C parameters as given in the paper:
      integer ndeg
      parameter (ndeg=3)
      real*8 ah(ndeg),bh(ndeg),at(ndeg),bt(ndeg),gam(ndeg)
c     tau^{L}_{1}:
      data ah /0.1586914382D+13,-0.9344296879D+01,0.6943966881D+00/
c     tau^{L}_{2}:
      data bh /0.1285676961D-12,0.9420973263D+01,-0.7855988401D+00/
c     tau^{H}_{1}:
      data at /0.3312598766D-09,0.7285659464D+01,-0.6732642658D+00/
c     tau^{H}_{2}:
      data bt /0.1960966173D+09,-0.6834613750D+01,0.5516825232D+00/
c     gamma_{1}:
      data gam /0.1059151675D+17,-0.1048630307D+02, 0.7321430968D+00/
c     **************************************************************
c     The S - shape function parameters:
      real*8 w1,w2
      data w1,w2 /50.0d0, 100.0d0/
c     --------------------------------------------------------------
c     local variables:
c     ----------------------------------
      real*8 incrmt
      integer p1,p2,n
      real*8 a1,b1,a2,b2,gamma
      real*8 bc1,bc2,bcbc
      real*8 scon,mtot,spunit,gm0con
      real*8 icm, frq, lntemp
      real*8 x1,x2

      incrmt=250.0D+0
      n=1
      p1=idint(dnint(w1/incrmt))
      p2=idint(dnint(w2/incrmt))
      lntemp=dlog(temp)
      a1=1.0d0/(ah(1)*dexp(ah(2)*lntemp+ah(3)*lntemp*lntemp))
      b1=bh(1)*dexp(bh(2)*lntemp+bh(3)*lntemp*lntemp)
      a2=1.0d0/(at(1)*dexp(at(2)*lntemp+at(3)*lntemp*lntemp))
      b2=bt(1)*dexp(bt(2)*lntemp+bt(3)*lntemp*lntemp)
      gamma=gam(1)*dexp(gam(2)*lntemp+gam(3)*lntemp*lntemp)
      icm=0.1885d0
      frq=wn
      x1=b1*dsqrt(a1*a1+icm*icm*frq*frq)
      bc1=dexp(a1*b1)*a1*XK1(x1)/(a1*a1+icm*icm*frq*frq)
      x2=b2*dsqrt(a2*a2+icm*icm*frq*frq)
      bc2=dexp(a2*b2)*a2*XK1(x2)/(a2*a2+icm*icm*frq*frq)
      if (p1.ge.1) then
         bcbc=bc1
      else if (p2.lt.1) then
         bcbc=bc2
      else
         bcbc=dexp( (1.0d0-dble(1-p1)/dble(p2-p1))*dlog(bc1)+
     &        dble(1-p1)/dble(p2-p1)*dlog(bc2) )
      endif
      spunit=1.296917d55
      gm0con=1.259009d-6
      scon=spunit/temp
      mtot=gm0con*temp*gamma*1.0d-56
      frq=wn
      abcoef=scon*mtot*bcbc*frq*frq
      return
      end
c
c
      FUNCTION XK1(X)
C     MODIFIED BESSEL FUNCTION K1(X) TIMES X
C     PRECISION IS BETTER THAN 2.2e-7 EVERYWHERE.
C     ABRAMOWITZ AND S,TEGUN, P.379; TABLES P.417.
      implicit double precision (a-h,o-z)
      IF(X-2.) 10,10,20
 10   T=(X/3.75)**2
      FI1=X*((((((.00032411*T+.00301532)*T+.02658733)*T+.15084934)
     1     *T+.51498869)*T+.87890594)*T+.5)
      T=(X/2.)**2
      P=(((((-.00004686*T-.00110404)*T-.01919402)*T-.18156897)*T-
     1     .67278579)*T+.15443144)*T+1.
      XK1=X*dLOG(X/2)*FI1+P
      RETURN
 20   T=2./X
      P=(((((-.00068245*T+.00325614)*T-.00780353)*T+.01504268)*T-
     1     .03655620)*T+.23498619)*T+1.25331414
      X=dMIN1(X,330.d0)
      XK1=dSQRT(X)*dEXP(-X)*P
      RETURN
      END

c     ----------------------------------------------------------------------------------------------
c     Added by RDW for inclusion of Baranov (2004) data
      subroutine baranov(temp,wn,abcoef)
      implicit none
c
c     Purpose: to compute coliision-induced absorption coefficient
c
c     Input:
c       + temp: temperature (K)
c       + wn: wavenumber (inv. cm)
c
c     Output:
c       + abcoef: absorption coefficient, (cm^-1 amagat^-2)
c
c     I/O
      real*8 temp               !temperature
      real*8 wn                 !wavenumber
      real*8 abcoef             !absorption coefficient
c     temp
      integer nS,nT
      parameter(nS=1713)
      parameter(nT=9)

      real*8 wn_arr(nS)
      real*8 temp_arr(nT)
      real*8 dim_arr(nS,nT)

      integer pop
      logical firstcall

      save wn_arr, temp_arr, dim_arr

      character(len=*),parameter :: dt_file='co2_baranov2004'
      integer ios
      character(len=*),parameter :: label='subroutine baranov'

      open(33,file=dt_file,
     &     form='unformatted',
     &     status='old',iostat=ios)
      if (ios.ne.0) then        ! file not found
         write(*,*) 'Error from ',label,' :'
         write(*,*) 'Data file could not be found:'
         write(*,*) dt_file
         stop
      else
         read(33) wn_arr
         read(33) temp_arr
         read(33) dim_arr
      endif
      close(33)

      call bilinear(wn_arr,temp_arr,nS,nT,dim_arr,wn,temp,abcoef)

 111  continue
      return
      end
c     ----------------------------------------------------------------------------------------------

c     ----------------------------------------------------------------------------------------------
c     Added by RDW for inclusion of Baranov (2004) data
      subroutine bilinear(x_arr,y_arr,nX,nY,f2d_arr,x,y,f)

      implicit none

      integer nX,nY,i,j,a,b

      real*8 x,y,x1,x2,y1,y2
      real*8 f,f11,f12,f21,f22,fA,fB
      real*8 x_arr(nX)
      real*8 y_arr(nY)
      real*8 f2d_arr(nX,nY)

      character(len=*),parameter :: label='subroutine bilinear'

c     1st check we're within the wavenumber range
      if ((x.lt.x_arr(2)).or.(x.gt.x_arr(nX-2))) then
         f=0.0D+0
c     print*,'x=',x,x_Arr(2),x_arr(nX-2)
c     stop('Outside CIA dimer wavenumber range!\n')
         goto 112
      else

c     in the x (wavenumber) direction 1st
         i=1
 10      if (i.lt.(nX+1)) then ! what passes for a 'while' loop in this sorry language...
            if (x_arr(i).gt.x) then
               x1=x_arr(i-1)
               x2=x_arr(i)
               a=i-1
               i=9999
            endif
            i=i+1
            goto 10
         endif
      endif

      if ((y.lt.y_arr(1)).or.(y.gt.y_arr(nY))) then
         write(*,*) 'Error from ',label,' :'
         write(*,*) 'Outside CIA dimer temperature range!'
         stop
      else
c     in the y (temperature) direction 2nd
         j=1
 20      if (j.lt.(nY+1)) then
            if (y_arr(j).gt.y) then
               y1=y_arr(j-1)
               y2=y_arr(j)
               b=j-1
               j=9999
            endif
            j=j+1
            goto 20
         endif
      endif

      f11=f2d_arr(a,b)
      f21=f2d_arr(a+1,b)
      f12=f2d_arr(a,b+1)
      f22=f2d_arr(a+1,b+1)

c     1st in x-direction
      fA=f11*(x2-x)/(x2-x1)+f21*(x-x1)/(x2-x1)
      fB=f12*(x2-x)/(x2-x1)+f22*(x-x1)/(x2-x1)

c     then in y-direction
      f=fA*(y2-y)/(y2-y1)+fB*(y-y1)/(y2-y1)

 112  continue
      return
      end
c     ----------------------------------------------------------------------------------------------
      END PROGRAM co2_continuum


      subroutine assumed_size(a)
        implicit none
        integer, dimension(10:*), intent(inout) :: a

        a(10:20) = 5

      end subroutine

      subroutine const_expr(a)
        implicit none
        integer, dimension(10:20), intent(inout) :: a
        integer i

        do i = 10, 20
            a(i) = i
        enddo

      end subroutine const_expr

      subroutine arg_expr(a, n1, n2)
        implicit none
        integer, intent(in) :: n1, n2
        integer, dimension(n1-n1+3:n1+n2*2) :: a

        a = 12

      end subroutine arg_expr

      subroutine param_expr(a)
        implicit none
        integer, parameter :: d1=1
        integer, parameter :: d2=d1+2+int(3.0)
        integer, parameter :: d3=d1+d2
        integer, dimension(d1:d2+d3, d2:d3+1, -d3:0) :: a

        integer i,j,k

        do k = lbound(a, 3), ubound(a, 3)
            do j = lbound(a, 2), ubound(a, 2)
                do i = lbound(a, 1), ubound(a, 1)
                    a(i,j,k) = k + j + i
                enddo
            enddo
        enddo

      end subroutine param_expr


!=====================================================|
subroutine io
!=====================================================|
  use geometry_def, only: ns,nd,time,data_dir,time &
       & ,nx,nxg,margin,xmax,xmin,qq,mtype
  use const_def, only: gm
  implicit none
  integer :: idf = 10
  character (len=8) :: cnd
!-----------------------------------------------------|

  write(*,913) ns,time,nd

  if(ns == 0) then
     open(idf,file=trim(data_dir)//'params.dac',form='formatted')
     write(idf,'(1x,i8,1x,i8,1x,e16.10,1x,e16.10,1x,e16.10)') nx,mtype,xmax,xmin,gm
     close(idf)
  endif

  open(idf,file=trim(data_dir)//'nd.dac',form='formatted')
  write(idf,'(i8)') nd
  close(idf)

  write(cnd,'(i8.8)') nd

  open(idf,file=trim(data_dir)//'t.dac.'//cnd,form='unformatted',access='stream')
  write(idf) time
  close(idf)

  open(idf,file=trim(data_dir)//'qq.dac.'//cnd,form='unformatted',access='stream')
  write(idf) qq(1+margin:nxg-margin,:)
  close(idf)

  return
913 format(1x,' write    ','step=',i8,' time=',e10.3,' nd=',i4)
end subroutine io


module projector

    use numbers
    use openmpi
    use io
    use parameters
    use fieldio
    use fftw
    use vfield

    complex(dpc), allocatable :: proj_bases(:,:,:,:,:), proj_origin(:, :, :, :)
    real(dp), allocatable :: proj_results(:)

    real(dp)    :: proj_ekin
    integer(i4) :: proj_ch, proj_uindex

    character(1), parameter :: proj_uname = 'u'
    character(255) :: proj_num_bases_str
    character(255) :: proj_results_format
    character(255) :: proj_dir

    logical :: proj_written = .false.

    contains

!==============================================================================

    subroutine projector_init

        integer :: i, un

        write(proj_num_bases_str, *) num_proj_bases
        proj_results_format = "(A2,"//i4_f//","//sp_f//","//dp_f//","//TRIM(proj_num_bases_str)//dp_f//")"

        if (my_id == 0) allocate(proj_results(num_proj_bases))
        if (subtract_origin) allocate(proj_origin(nx_perproc, ny_half, nz, 3))
        allocate(proj_bases(nx_perproc, ny_half, nz, 3,num_proj_bases))

        inquire(file='basis.in', exist=there)
        if (.not. there) then
            write(out,*) 'basis.in not found.'
            flush(out)
            stop
        else
            open(newunit=un,status='old',file='basis.in')
            read(un,'(A)') proj_dir
            close(un)

            write(out, *) 'proj_dir:'
            write(out, *) proj_dir
        end if

        ! Read the average
        if (subtract_origin) then
            proj_uindex = 0
            call projector_read(proj_origin)
        end if

        ! Read the modes
        do i=1, num_proj_bases
            proj_uindex = i
            call projector_read(proj_bases(:,:,:,:,i))
        end do

        ! Create the projections file, replace it if it exists
        if (my_id == 0) then
            open(newunit=proj_ch,file='projections.gp',status='replace')
            write(proj_ch, "(A2,"//i4_len//","//sp_len//","//dp_len//","//dp_len//")") "# ", "itime", "time", "proj_ekin", "projections"

            proj_written = .true.
        end if

    end subroutine projector_init

!==============================================================================

    subroutine projector_project(vfieldk)
        complex(dpc), intent(in) :: vfieldk(:, :, :, :)
        integer :: i
        real(dp) :: inprod
        complex(dpc) :: proj_vfieldk(nx_perproc, ny_half, nz, 3)

        ! Subtract the average
        if (subtract_origin) then
            proj_vfieldk(:,:,:,1:3) = vfieldk(:,:,:,1:3) - proj_origin(:,:,:,1:3)
        else
            proj_vfieldk(:,:,:,1:3) = vfieldk(:,:,:,1:3)
        end if

        do i = 1, num_proj_bases
            call vfield_inprod(proj_vfieldk, proj_bases(:,:,:,1:3,i), inprod, .false.)
            if (my_id == 0) proj_results(i) = inprod
        end do

        ! Compute the energy
        call vfield_norm2(proj_vfieldk, proj_ekin, .false.)

    end subroutine projector_project

!==============================================================================

    subroutine projector_write

        ! Write the projections
        if (my_id == 0) then
            write(proj_ch, TRIM(proj_results_format)) "  ", itime, time, proj_ekin, proj_results
        end if

    end subroutine projector_write

!==============================================================================

    subroutine projector_read(vfieldk)
        complex(dpc), intent(out) :: vfieldk(:, :, :, :)

        write(file_ext, "(i6.6)") proj_uindex
        fname = TRIM(proj_dir)//'/'//proj_uname//'.'//file_ext
        call fieldio_read(vfieldk)

    end subroutine projector_read

!==============================================================================

end module projector


module c_hfsolver

use iso_c_binding, only: c_int, c_double
use special_functions, only: Inu_formula2, Knu_formula2
implicit none

contains

subroutine hfsolver_Inu(k, x, r) bind(c, name="hfsolver_Inu")
integer(c_int), intent(in) :: k
real(c_double), intent(in) :: x
real(c_double), intent(out) :: r
r = Inu_formula2(k, x)
end subroutine

subroutine hfsolver_Knu(k, x, r) bind(c, name="hfsolver_Knu")
integer(c_int), intent(in) :: k
real(c_double), intent(in) :: x
real(c_double), intent(out) :: r
r = Knu_formula2(k, x)
end subroutine

end module


! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! 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, either version 3 of the License, or
! (at your option) any later version.
!
! 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, see <http://www.gnu.org/licenses/>.

module luSolv_module
USE nrtype
implicit none
private
public::ludcmp,lubksb
contains

 ! *********************************************************************************************************************
 ! public subroutine ludcmp: Replaces an n-by-n matrix, a, with the LU decomposition of a row-wise permutation of itself
 ! *********************************************************************************************************************
 SUBROUTINE ludcmp(a,indx,d,err,message)
 IMPLICIT NONE
 ! input/output
 REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
 INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx
 REAL(DP), INTENT(OUT) :: d
 integer(i4b),intent(out)           :: err
 character(*),intent(out)           :: message
 ! local variables
 REAL(DP), DIMENSION(size(a,1)) :: vv
 REAL(DP), PARAMETER :: TINY=1.0e-20_dp
 INTEGER(I4B) :: j,n,imax
 ! initialize error control
 err=0; message='ludcmp/'
 n = size(indx)
 if(size(a,1) /= n .or. size(a,2) /= n)then
  message=trim(message)//'mismatch in size of matrices'
  err=20; return
 endif
 d=1.0_dp
 vv=maxval(abs(a),dim=2)
 if (any(vv == 0.0))then
  message=trim(message)//'singular matrix'
  err=20; return
 endif
 vv=1.0_dp/vv
 do j=1,n
  imax=(j-1)+imaxloc(vv(j:n)*abs(a(j:n,j)))
  if (j /= imax) then
   call swap(a(imax,:),a(j,:))
   d=-d
   vv(imax)=vv(j)
  end if
  indx(j)=imax
  if (a(j,j) == 0.0) a(j,j)=TINY
  a(j+1:n,j)=a(j+1:n,j)/a(j,j)
  a(j+1:n,j+1:n)=a(j+1:n,j+1:n)-outerprod(a(j+1:n,j),a(j,j+1:n))
 end do
 END SUBROUTINE ludcmp

 ! *********************************************************************************************************************
 ! public subroutine lubksb: Solves the set of n linear equations Ax = b (used with ludcmp to do this)
 ! *********************************************************************************************************************
 SUBROUTINE lubksb(a,indx,b,err,message)
 IMPLICIT NONE
 ! input/output
 REAL(DP), DIMENSION(:,:), INTENT(IN) :: a
 INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
 REAL(DP), DIMENSION(:), INTENT(INOUT) :: b
 integer(i4b),intent(out)           :: err
 character(*),intent(out)           :: message
 ! local
 INTEGER(I4B) :: i,n,ii,ll
 REAL(DP) :: summ
 ! initialize error control
 err=0; message='lubksb/'
 n = size(indx)
 if(size(a,1) /= n .or. size(a,2) /= n)then
  message=trim(message)//'mismatch in size of matrices'
  err=20; return
 endif
 ii=0
 do i=1,n
  ll=indx(i)
  summ=b(ll)
  b(ll)=b(i)
  if (ii /= 0) then
   summ=summ-dot_product(a(i,ii:i-1),b(ii:i-1))
  else if (summ /= 0.0) then
   ii=i
  end if
  b(i)=summ
 end do
 do i=n,1,-1
  b(i) = (b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/a(i,i)
 end do
 END SUBROUTINE lubksb

 ! *********************************************************************************************************************
 ! private subroutine swap: swap two reals
 ! *********************************************************************************************************************
 SUBROUTINE swap(a,b)
 REAL(DP), DIMENSION(:), INTENT(INOUT) :: a,b
 REAL(DP), DIMENSION(SIZE(a)) :: dum
 dum=a
 a=b
 b=dum
 END SUBROUTINE swap

 ! *********************************************************************************************************************
 ! private subroutine outerprod: outer product of vectors a and b
 ! *********************************************************************************************************************
 FUNCTION outerprod(a,b)
 REAL(DP), DIMENSION(:), INTENT(IN) :: a,b
 REAL(DP), DIMENSION(size(a),size(b)) :: outerprod
 outerprod = spread(a,dim=2,ncopies=size(b)) * &
  spread(b,dim=1,ncopies=size(a))
 END FUNCTION outerprod

 ! *********************************************************************************************************************
 ! private subroutine imaxloc: returns the index of the maxloc on an array
 ! *********************************************************************************************************************
 FUNCTION imaxloc(arr)
 REAL(DP), DIMENSION(:), INTENT(IN) :: arr
 INTEGER(I4B) :: imaxloc
 INTEGER(I4B), DIMENSION(1) :: imax
 imax=maxloc(arr(:))
 imaxloc=imax(1)
 END FUNCTION imaxloc

end module luSolv_module