module utility_m
  use, intrinsic :: iso_fortran_env, only : int32, real64, error_unit
  implicit none
  integer    , parameter :: ikind = int32, rkind = real64
  real(rkind), parameter :: epsilon = 1e-7_rkind
contains

  !> `util_linspace`: calculate Internal division point.
  pure function util_linspace(from, to, num) result(arr)
    real(rkind), intent(in) :: from, to
    integer    , intent(in) :: num
    real(rkind)             :: arr(num)
    integer                 :: i
    do i = 1, num
       arr(i) = ( (num-1-i+1)*from + (i-1)*to ) / (num-1)
    end do
  end function util_linspace

  !> `util_debug_print`: print mesage if compiler flag is -DDEBUG.
  subroutine util_debug_print(message, linum, filename)
    integer, intent(in) :: linum
    character(len=*)    :: message, filename
#ifdef DEBUG
    write(error_unit, '(a, i0)') "debug message in "//filename//":", linum
    write(error_unit, '(a)'    ) message
#endif
  end subroutine util_debug_print

  !> `util_warning`: print warning. error stop if -DDEBUG.
  subroutine util_warning(message, linum, filename)
    integer, intent(in) :: linum
    character(len=*)    :: message, filename
    write(error_unit, '(a, i0)') "warning in "//filename//":", linum
    write(error_unit, '(a)'    ) message
#ifdef DEBUG
    error stop 1
#endif
  end subroutine util_warning

  !> `util_error_stop`: print error. error stop.
  subroutine util_error_stop(message, linum, filename)
    integer, intent(in) :: linum
    character(len=*)    :: message, filename
    write(error_unit, '(a, i0)') "error in "//filename//":", linum
    write(error_unit, '(a)'    ) message
    error stop 2
  end subroutine util_error_stop

end module utility_m


! { dg-do run }
!
! PR fortran/56810
!
! Contributed by Jonathan Hogg
!
program test
   implicit none

   integer :: i
   complex :: a(4)

   open (99, status='scratch')
   write (99, *) '4*(1.0,2.0)'
   rewind (99)
   read (99,*) a(:)
   close (99)
   if (any (a /= cmplx (1.0,2.0))) call abort()
end program test


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPproduct_test(
! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?xi32>>{{.*}}) -> i32
integer function product_test(a)
integer :: a(:)
! CHECK-DAG:  %[[c0:.*]] = arith.constant 0 : index
! CHECK-DAG:  %[[a1:.*]] = fir.absent !fir.box<i1>
! CHECK-DAG: %[[a3:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?xi32>>) -> !fir.box<none>
! CHECK-DAG:  %[[a5:.*]] = fir.convert %[[c0]] : (index) -> i32
! CHECK-DAG:  %[[a6:.*]] = fir.convert %[[a1]] : (!fir.box<i1>) -> !fir.box<none>
product_test = product(a)
! CHECK:  %{{.*}} = fir.call @_FortranAProductInteger4(%[[a3]], %{{.*}}, %{{.*}}, %[[a5]], %[[a6]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
end function

! CHECK-LABEL: func @_QPproduct_test2(
! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x?xi32>>{{.*}}, %[[arg1:.*]]: !fir.box<!fir.array<?xi32>>
subroutine product_test2(a,r)
integer :: a(:,:)
integer :: r(:)
! CHECK-DAG:  %[[c2_i32:.*]] = arith.constant 2 : i32
! CHECK-DAG:  %[[a0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
! CHECK-DAG:  %[[a1:.*]] = fir.absent !fir.box<i1>
! CHECK-DAG:  %[[a6:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG:  %[[a7:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<none>
! CHECK-DAG:  %[[a9:.*]] = fir.convert %[[a1]] : (!fir.box<i1>) -> !fir.box<none>
r = product(a,dim=2)
! CHECK:  %{{.*}} = fir.call @_FortranAProductDim(%[[a6]], %[[a7]], %[[c2_i32]], %{{.*}}, %{{.*}}, %[[a9]]) : (!fir.ref<!fir.box<none>>, !fir.box<none>, i32, !fir.ref<i8>, i32, !fir.box<none>) -> none
! CHECK-DAG: %[[a11:.*]] = fir.load %[[a0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
! CHECK-DAG:  %[[a13:.*]] = fir.box_addr %[[a11]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
! CHECK-DAG:  fir.freemem %[[a13]]
end subroutine

! CHECK-LABEL: func @_QPproduct_test3(
! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x!fir.complex<4>>>{{.*}}) -> !fir.complex<4>
complex function product_test3(a)
complex :: a(:)
! CHECK-DAG:  %[[c0:.*]] = arith.constant 0 : index
! CHECK-DAG:  %[[a0:.*]] = fir.alloca !fir.complex<4>
! CHECK-DAG:  %[[a3:.*]] = fir.absent !fir.box<i1>
! CHECK-DAG: %[[a5:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.complex<4>>) -> !fir.ref<complex<f32>>
! CHECK-DAG:  %[[a6:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x!fir.complex<4>>>) -> !fir.box<none>
! CHECK-DAG:  %[[a8:.*]] = fir.convert %[[c0]] : (index) -> i32
! CHECK-DAG:  %[[a9:.*]] = fir.convert %[[a3]] : (!fir.box<i1>) -> !fir.box<none>
product_test3 = product(a)
! CHECK:  %{{.*}} = fir.call @_FortranACppProductComplex4(%[[a5]], %[[a6]], %{{.*}}, %{{.*}}, %[[a8]], %[[a9]]) : (!fir.ref<complex<f32>>, !fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> none
end function

! CHECK-LABEL: func @_QPproduct_test4(
! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x!fir.complex<10>>>{{.*}}) -> !fir.complex<10>
complex(10) function product_test4(x)
complex(10):: x(:)
! CHECK-DAG:  %[[c0:.*]] = arith.constant 0 : index
! CHECK-DAG:  %[[a0:.*]] = fir.alloca !fir.complex<10>
product_test4 = product(x)
! CHECK-DAG: %[[a2:.*]] = fir.absent !fir.box<i1>
! CHECK-DAG: %[[a4:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.complex<10>>) -> !fir.ref<complex<f80>>
! CHECK-DAG: %[[a5:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x!fir.complex<10>>>) -> !fir.box<none>
! CHECK-DAG:  %[[a7:.*]] = fir.convert %[[c0]] : (index) -> i32
! CHECK-DAG:  %[[a8:.*]] = fir.convert %[[a2]] : (!fir.box<i1>) -> !fir.box<none>
! CHECK: fir.call @_FortranACppProductComplex10(%[[a4]], %[[a5]], %{{.*}}, %{{.*}}, %[[a7]], %8) : (!fir.ref<complex<f80>>, !fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> ()
end

! CHECK-LABEL: func @_QPproduct_test_optional(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>
real function product_test_optional(mask, x)
real :: x(:)
logical, optional :: mask(:)
product_test_optional = product(x, mask=mask)
! CHECK:  %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
! CHECK:  fir.call @_FortranAProductReal4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_9]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> f32
end function

! CHECK-LABEL: func @_QPproduct_test_optional_2(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>>
real function product_test_optional_2(mask, x)
real :: x(:)
logical, pointer :: mask(:)
product_test_optional = product(x, mask=mask)
! CHECK:  %[[VAL_4:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>>
! CHECK:  %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>) -> !fir.ptr<!fir.array<?x!fir.logical<4>>>
! CHECK:  %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ptr<!fir.array<?x!fir.logical<4>>>) -> i64
! CHECK:  %[[VAL_7:.*]] = arith.constant 0 : i64
! CHECK:  %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64
! CHECK:  %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>>
! CHECK:  %[[VAL_10:.*]] = fir.absent !fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>
! CHECK:  %[[VAL_11:.*]] = arith.select %[[VAL_8]], %[[VAL_9]], %[[VAL_10]] : !fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>
! CHECK:  %[[VAL_18:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>) -> !fir.box<none>
! CHECK:  fir.call @_FortranAProductReal4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_18]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> f32
end function

! CHECK-LABEL: func @_QPproduct_test_optional_3(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.array<10x!fir.logical<4>>>
real function product_test_optional_3(mask, x)
real :: x(:)
logical, optional :: mask(10)
product_test_optional = product(x, mask=mask)
! CHECK:  %[[VAL_2:.*]] = arith.constant 10 : index
! CHECK:  %[[VAL_5:.*]] = fir.is_present %[[VAL_0]] : (!fir.ref<!fir.array<10x!fir.logical<4>>>) -> i1
! CHECK:  %[[VAL_6:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
! CHECK:  %[[VAL_7:.*]] = fir.embox %[[VAL_0]](%[[VAL_6]]) : (!fir.ref<!fir.array<10x!fir.logical<4>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.logical<4>>>
! CHECK:  %[[VAL_8:.*]] = fir.absent !fir.box<!fir.array<10x!fir.logical<4>>>
! CHECK:  %[[VAL_9:.*]] = arith.select %[[VAL_5]], %[[VAL_7]], %[[VAL_8]] : !fir.box<!fir.array<10x!fir.logical<4>>>
! CHECK:  %[[VAL_18:.*]] = fir.convert %[[VAL_9]] : (!fir.box<!fir.array<10x!fir.logical<4>>>) -> !fir.box<none>
! CHECK:  fir.call @_FortranAProductReal4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_18]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> f32
end function

! CHECK-LABEL: func @_QPproduct_test_optional_4(
real function product_test_optional_4(x, use_mask)
! Test that local allocatable tracked in local variables
! are dealt as optional argument correctly.
real :: x(:)
logical :: use_mask
logical, allocatable :: mask(:)
if (use_mask) then
  allocate(mask(size(x, 1)))
  call set_mask(mask)
  ! CHECK: fir.call @_QPset_mask
end if
product_test_optional = product(x, mask=mask)
! CHECK:  %[[VAL_20:.*]] = fir.load %[[VAL_3:.*]] : !fir.ref<!fir.heap<!fir.array<?x!fir.logical<4>>>>
! CHECK:  %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.heap<!fir.array<?x!fir.logical<4>>>) -> i64
! CHECK:  %[[VAL_22:.*]] = arith.constant 0 : i64
! CHECK:  %[[VAL_23:.*]] = arith.cmpi ne, %[[VAL_21]], %[[VAL_22]] : i64
! CHECK:  %[[VAL_24:.*]] = fir.load %[[VAL_4:.*]] : !fir.ref<index>
! CHECK:  %[[VAL_25:.*]] = fir.load %[[VAL_5:.*]] : !fir.ref<index>
! CHECK:  %[[VAL_26:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.heap<!fir.array<?x!fir.logical<4>>>>
! CHECK:  %[[VAL_27:.*]] = fir.shape_shift %[[VAL_24]], %[[VAL_25]] : (index, index) -> !fir.shapeshift<1>
! CHECK:  %[[VAL_28:.*]] = fir.embox %[[VAL_26]](%[[VAL_27]]) : (!fir.heap<!fir.array<?x!fir.logical<4>>>, !fir.shapeshift<1>) -> !fir.box<!fir.array<?x!fir.logical<4>>>
! CHECK:  %[[VAL_29:.*]] = fir.absent !fir.box<!fir.array<?x!fir.logical<4>>>
! CHECK:  %[[VAL_30:.*]] = arith.select %[[VAL_23]], %[[VAL_28]], %[[VAL_29]] : !fir.box<!fir.array<?x!fir.logical<4>>>
! CHECK:  %[[VAL_37:.*]] = fir.convert %[[VAL_30]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
! CHECK:  fir.call @_FortranAProductReal4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_37]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> f32
end function


! { dg-do compile }
!
! PR fortran/65532
! The partial initialization through data statements was producing
! shape mismatch errors.
!
! Contributed by Harald Anlauf  <anlauf@gmx.de>

module gfcbug131
  implicit none
contains
  DOUBLE PRECISION FUNCTION d1mach(i)
    INTEGER, INTENT(IN)         :: i

    INTEGER :: small(4)
    INTEGER :: large(4)
    INTEGER :: right(4)
    INTEGER :: diver(4)
    INTEGER :: LOG10(4)
    DOUBLE PRECISION :: dmach(5)

    EQUIVALENCE (dmach(1),small(1))
    EQUIVALENCE (dmach(2),large(1))
    EQUIVALENCE (dmach(3),right(1))
    EQUIVALENCE (dmach(4),diver(1))
    EQUIVALENCE (dmach(5),LOG10(1))

    DATA small(1),small(2) /          0,    1048576 /
    DATA large(1),large(2) /         -1, 2146435071 /
    DATA right(1),right(2) /          0, 1017118720 /
    DATA diver(1),diver(2) /          0, 1018167296 /
    DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 /

    d1mach = dmach(i)
  END FUNCTION d1mach

  DOUBLE PRECISION FUNCTION foo (x)
    DOUBLE PRECISION, INTENT(IN) :: x
    foo = SQRT (d1mach(4))
  END FUNCTION foo

end module gfcbug131


! RUN: bbc %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPi
subroutine i
  implicit none
  integer :: ctemp(10) = (/1,2,3,4,5,6,7,8,9,22/)
  print *, ctemp(1:10)
end subroutine i

! CHECK-LABEL: func @_QPs2
subroutine s2
  real :: x(10)
  x = 0.0
  ! CHECK: fir.call @_FortranAioBeginExternalListOutput
  print *, x
  ! CHECK: %[[s:.*]] = fir.slice {{.*}} !fir.slice<1>
  ! CHECK: %[[p:.*]] = fir.array_coor %{{.*}} [%[[s]]] %
  ! CHECK: fir.store %{{.*}} to %[[p]] : !fir.ref<f32>
  x(1:10:3) = 2.0
  ! CHECK: fir.call @_FortranAioBeginExternalListOutput
  print *, x
end subroutine s2

! CHECK-LABEL: func @_QQmain
program main
  integer :: A(10)
  A(1) = 1
  A(2) = 2
  A(3) = 3
  print *, A
  ! CHECK: %[[A:.*]] = fir.address_of(@_QFEa)
  ! CHECK: %[[shape:.*]] = fir.shape %c10
  ! CHECK: %[[slice:.*]] = fir.slice %
  ! CHECK: fir.embox %[[A]](%[[shape]]) [%[[slice]]] :
  print*, A(1:3:1)
  call s
  call i
end program main


       function crossdyadic_22(T1, T2)
        implicit none

        type(Tensor2), intent(in) :: T1, T2
        type(Tensor4) :: crossdyadic_22
        integer i, j, k, l

        forall(i=1:3,j=1:3,k=1:3,l=1:3) crossdyadic_22%abcd(i,j,k,l)
     *                                = (T1%ab(i,k) * T2%ab(j,l) +
     *                                   T1%ab(i,l) * T2%ab(j,k))/2.d0

       end function crossdyadic_22

       function crossdyadic_2s2s(T1, T2)
       ! check if correct
       ! contraction of dual shear terms (4:6,i)
        implicit none

        type(Tensor2s), intent(in) :: T1, T2
        type(Tensor4s) :: crossdyadic_2s2s

        crossdyadic_2s2s%a6b6(1,1) = T1%a6(1) * T2%a6(1)
        crossdyadic_2s2s%a6b6(2,1) = T1%a6(4) * T2%a6(4)
        crossdyadic_2s2s%a6b6(3,1) = T1%a6(6) * T2%a6(6)
        crossdyadic_2s2s%a6b6(4,1) = T1%a6(1) * T2%a6(4)
        crossdyadic_2s2s%a6b6(5,1) = T1%a6(4) * T2%a6(6)
        crossdyadic_2s2s%a6b6(6,1) = T1%a6(6) * T2%a6(1)

        crossdyadic_2s2s%a6b6(1,2) = T1%a6(4) * T2%a6(4)
        crossdyadic_2s2s%a6b6(2,2) = T1%a6(2) * T2%a6(2)
        crossdyadic_2s2s%a6b6(3,2) = T1%a6(5) * T2%a6(5)
        crossdyadic_2s2s%a6b6(4,2) = T1%a6(4) * T2%a6(2)
        crossdyadic_2s2s%a6b6(5,2) = T1%a6(2) * T2%a6(5)
        crossdyadic_2s2s%a6b6(6,2) = T1%a6(5) * T2%a6(4)

        crossdyadic_2s2s%a6b6(1,3) = T1%a6(6) * T2%a6(6)
        crossdyadic_2s2s%a6b6(2,3) = T1%a6(5) * T2%a6(5)
        crossdyadic_2s2s%a6b6(3,3) = T1%a6(3) * T2%a6(3)
        crossdyadic_2s2s%a6b6(4,3) = T1%a6(6) * T2%a6(5)
        crossdyadic_2s2s%a6b6(5,3) = T1%a6(5) * T2%a6(3)
        crossdyadic_2s2s%a6b6(6,3) = T1%a6(3) * T2%a6(6)

        crossdyadic_2s2s%a6b6(1,4) = (T1%a6(1) * T2%a6(4)
     *                               +T1%a6(4) * T2%a6(1))/2.d0
        crossdyadic_2s2s%a6b6(2,4) = (T1%a6(4) * T2%a6(2)
     *                               +T1%a6(2) * T2%a6(4))/2.d0
        crossdyadic_2s2s%a6b6(3,4) = (T1%a6(6) * T2%a6(5)
     *                               +T1%a6(5) * T2%a6(6))/2.d0
        crossdyadic_2s2s%a6b6(4,4) = (T1%a6(1) * T2%a6(2)
     *                               +T1%a6(4) * T2%a6(4))/2.d0!*2.
        crossdyadic_2s2s%a6b6(5,4) = (T1%a6(4) * T2%a6(5)
     *                               +T1%a6(2) * T2%a6(6))/2.d0!*2.
        crossdyadic_2s2s%a6b6(6,4) = (T1%a6(6) * T2%a6(4)
     *                               +T1%a6(5) * T2%a6(1))/2.d0!*2.

        crossdyadic_2s2s%a6b6(1,5) = (T1%a6(6) * T2%a6(4)
     *                               +T1%a6(4) * T2%a6(6))/2.d0
        crossdyadic_2s2s%a6b6(2,5) = (T1%a6(5) * T2%a6(2)
     *                               +T1%a6(2) * T2%a6(5))/2.d0
        crossdyadic_2s2s%a6b6(3,5) = (T1%a6(3) * T2%a6(5)
     *                               +T1%a6(5) * T2%a6(3))/2.d0
        crossdyadic_2s2s%a6b6(4,5) = (T1%a6(4) * T2%a6(5)
     *                               +T1%a6(6) * T2%a6(2))/2.d0!*2.
        crossdyadic_2s2s%a6b6(5,5) = (T1%a6(2) * T2%a6(3)
     *                               +T1%a6(5) * T2%a6(5))/2.d0!*2.
        crossdyadic_2s2s%a6b6(6,5) = (T1%a6(5) * T2%a6(6)
     *                               +T1%a6(3) * T2%a6(4))/2.d0!*2.

        crossdyadic_2s2s%a6b6(1,6) = (T1%a6(1) * T2%a6(6)
     *                               +T1%a6(6) * T2%a6(1))/2.d0
        crossdyadic_2s2s%a6b6(2,6) = (T1%a6(4) * T2%a6(5)
     *                               +T1%a6(5) * T2%a6(4))/2.d0
        crossdyadic_2s2s%a6b6(3,6) = (T1%a6(6) * T2%a6(3)
     *                               +T1%a6(3) * T2%a6(6))/2.d0
        crossdyadic_2s2s%a6b6(4,6) = (T1%a6(6) * T2%a6(4)
     *                               +T1%a6(1) * T2%a6(5))/2.d0!*2.
        crossdyadic_2s2s%a6b6(5,6) = (T1%a6(5) * T2%a6(6)
     *                               +T1%a6(4) * T2%a6(3))/2.d0!*2.
        crossdyadic_2s2s%a6b6(6,6) = (T1%a6(3) * T2%a6(1)
     *                               +T1%a6(6) * T2%a6(6))/2.d0!*2.

       end function crossdyadic_2s2s


  function pmom (j, t, r1)

! ======================================================================
!
!     Calculation of a secondary particle's random 3-momentum, weighted
!     by the momentum distribution.  See SR BD1 for significance of
!     index j.
!
!   Called by: VMNSP
!
!   CEM95 written by S. G. Mashnik
!
!    Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!    Edited by AJS, July, 1997.
!    Modified by AJS, February, 1999.
!   "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Modified by KKG, February, 2004.
!    Modified by A. J. Sierk, LANL T-16, March, 2004.
!    Modified by A. J. Sierk, LANL T-16, January, 2005.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: zro, one
    use standardDCMData,  only: bnkj, ckj

    implicit none
    integer(int32), intent(in   ) :: j
    real(real64),   intent(in   ) :: t
    real(real64),   intent(in   ) :: r1
    real(real64)                  :: pmom

    integer(int32) :: k, n
    real(real64)   :: pmax, s1, s2, term
    real(real64)   :: rn(5), tk(4)

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

    s1 = zro
    s2 = zro
    pmax = zro
    rn(1) = one
    rn(2) = r1
    rn(3) = r1*r1
    rn(4) = r1*r1*r1
    rn(5) = rn(3)*rn(3)
    tk(1) = one
    tk(2) = t
    tk(3) = t*t
    tk(4) = t*t*t
    do n = 1,4
       do k = 1,4
          term = bnkj(n,k,j)*tk(k)
          s1 = s1 + term*rn(n)
          s2 = s2 + term
       end do
    end do
    do k = 1,3
       pmax = pmax + ckj(k,j)*tk(k)
    end do
    pmom = pmax*sqrt(abs(r1))*(s1 + (one - s2)*rn(5))
    return

! ====================================================================
  end function pmom


      SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC,
     $                   Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the pair (A,E) to a real generalized Schur form
C     by using an orthogonal equivalence transformation
C     (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation
C     to the matrices B and C: B <-- Q'*B and C <-- C*Z.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation,
C             i.e., the order of the matrices A and E.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs, or of columns of B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs, or of rows of C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Q' * A * Z in an upper quasi-triangular form.
C             The elements below the first subdiagonal are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original descriptor matrix E.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Q' * E * Z in an upper triangular form.
C             The elements below the diagonal are set to zero.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q' * B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C * Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
C             The leading N-by-N part of this array contains the left
C             orthogonal transformation matrix used to reduce (A,E) to
C             the real generalized Schur form.
C             The columns of Q are the left generalized Schur vectors
C             of the pair (A,E).
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= max(1,N).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             The leading N-by-N part of this array contains the right
C             orthogonal transformation matrix used to reduce (A,E) to
C             the real generalized Schur form.
C             The columns of Z are the right generalized Schur vectors
C             of the pair (A,E).
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= max(1,N).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j),
C             j=1,...,N, will be the generalized eigenvalues.
C             ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the
C             diagonals of the complex Schur form that would result if
C             the 2-by-2 diagonal blocks of the real Schur form of
C             (A,E) were further reduced to triangular form using
C             2-by-2 complex unitary transformations.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real;
C             if positive, then the j-th and (j+1)-st eigenvalues are a
C             complex conjugate pair, with ALPHAI(j+1) negative.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of working array DWORK.  LDWORK >= 8*N+16.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, the QZ algorithm failed to compute
C                   the generalized real Schur form; elements i+1:N of
C                   ALPHAR, ALPHAI, and BETA should be correct.
C
C     METHOD
C
C     The pair (A,E) is reduced to a real generalized Schur form using
C     an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z)
C     and the transformation is applied to the matrices B and C:
C     B <-- Q'*B and C <-- C*Z.
C
C     NUMERICAL ASPECTS
C                                     3
C     The algorithm requires about 25N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001.
C
C     KEYWORDS
C
C     Orthogonal transformation, generalized real Schur form, similarity
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ,
     $                  M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*),
     $                  BETA(*),  C(LDC,*),  DWORK(*),  E(LDE,*),
     $                  Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           BLAS3, BLOCK
      INTEGER           BL, CHUNK, I, J, MAXWRK, SDIM
C     .. Local Arrays ..
      LOGICAL           BWORK(1)
C     .. External Functions ..
      LOGICAL           LSAME, DELCTG
      EXTERNAL          LSAME, DELCTG
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DGGES, DLACPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Check the scalar input parameters.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDWORK.LT.8*N+16 ) THEN
         INFO = -20
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TG01WD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Reduce (A,E) to real generalized Schur form using an orthogonal
C     equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z), accumulate
C     the transformations in Q and Z, and compute the generalized
C     eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA).
C
C     Workspace:  need   8*N+16;
C                 prefer larger.
C
      CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N,
     $            A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ,
     $            Z, LDZ, DWORK, LDWORK, BWORK, INFO )
      IF( INFO.NE.0 )
     $   RETURN
      MAXWRK = INT( DWORK(1) )
C
C     Apply the transformation: B <-- Q'*B. Use BLAS 3, if enough space.
C
      CHUNK = LDWORK / N
      BLOCK = M.GT.1
      BLAS3 = CHUNK.GE.M .AND. BLOCK
C
      IF( BLAS3 ) THEN
C
C        Enough workspace for a fast BLAS 3 algorithm.
C
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N )
         CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, Q, LDQ,
     $               DWORK, N, ZERO, B, LDB )
C
      ELSE IF ( BLOCK ) THEN
C
C        Use as many columns of B as possible.
C
         DO 10 J = 1, M, CHUNK
            BL = MIN( M-J+1, CHUNK )
            CALL DLACPY( 'Full', N, BL, B(1,J), LDB, DWORK, N )
            CALL DGEMM( 'Transpose', 'NoTranspose', N, BL, N, ONE, Q,
     $                  LDQ, DWORK, N, ZERO, B(1,J), LDB )
   10    CONTINUE
C
      ELSE
C
C        Use a BLAS 2 algorithm. Here, M <= 1.
C
         IF ( M.GT.0 ) THEN
            CALL DCOPY( N, B, 1, DWORK, 1 )
            CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, ZERO,
     $                  B, 1 )
         END IF
      END IF
      MAXWRK = MAX( MAXWRK, N*M )
C
C     Apply the transformation: C <-- C*Z.  Use BLAS 3, if enough space.
C
      BLOCK = P.GT.1
      BLAS3 = CHUNK.GE.P .AND. BLOCK
C
      IF ( BLAS3 ) THEN
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P )
         CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE,
     $               DWORK, P, Z, LDZ, ZERO, C, LDC )
C
      ELSE IF ( BLOCK ) THEN
C
C        Use as many rows of C as possible.
C
         DO 20 I = 1, P, CHUNK
            BL = MIN( P-I+1, CHUNK )
            CALL DLACPY( 'Full', BL, N, C(I,1), LDC, DWORK, BL )
            CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE,
     $                  DWORK, BL, Z, LDZ, ZERO, C(I,1), LDC )
   20    CONTINUE
C
      ELSE
C
C        Use a BLAS 2 algorithm. Here, P <= 1.
C
         IF ( P.GT.0 ) THEN
            CALL DCOPY( N, C, LDC, DWORK, 1 )
            CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, ZERO,
     $                  C, LDC )
         END IF
C
      END IF
      MAXWRK = MAX( MAXWRK, P*N )
C
      DWORK(1) = DBLE( MAXWRK )
C
      RETURN
C *** Last line of TG01WD ***
      END


      subroutine gen3m(r,p,m3,m4,m5,wt3,*)
c----generate 3 dimensional phase space weight and vectors p(mxpart,4)
c----           p1+p2+p3+p4+p5=0
c----and x1 and x2 given seven random numbers
c----p(6,i) and p(7,i) are set equal to zero
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'masses.f'
      include 'process.f'
      include 'phasemin.f'
      include 'x1x2.f'
      integer nu,j
      double precision r(mxdim),wt3
      double precision p(mxpart,4),taulowest,
     . p1(4),p2(4),p3(4),p4(4),p5(4),p6(4),p7(4),m3,m4,m5
      double precision pswt,xjac,tau,y
      include 'energy.f'

      do nu=1,4
      do j=1,mxpart
      p(j,nu)=0d0
      enddo
      enddo
      wt3=0d0

      taulowest=max(taumin,((m3+m4+m5)/sqrts)**2)

      tau=exp(log(taulowest)*r(6))
      y=0.5d0*log(tau)*(1d0-2d0*r(7))
      xjac=log(taulowest)*tau*log(tau)

      xx(1)=dsqrt(tau)*exp(+y)
      xx(2)=dsqrt(tau)*exp(-y)

c--- for comparison with C. Oleari's e+e- --> QQbg calculation
c      if (runstring(1:5) .eq. 'carlo') then
c        xx(1)=1d0
c      xx(2)=1d0
c      xjac=1d0
c      endif

c---if x's out of normal range alternative return
      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) return 1

      p1(4)=-xx(1)*sqrts*half
      p1(1)=zip
      p1(2)=zip
      p1(3)=-xx(1)*sqrts*half

      p2(4)=-xx(2)*sqrts*half
      p2(1)=zip
      p2(2)=zip
      p2(3)=+xx(2)*sqrts*half

      call phase3m(r,p1,p2,p3,p4,p5,p6,p7,m3,m4,m5,pswt)

      do nu=1,4
      p(1,nu)=p1(nu)
      p(2,nu)=p2(nu)
      p(3,nu)=p3(nu)
      p(4,nu)=p4(nu)
      p(5,nu)=p5(nu)
      enddo

      wt3=xjac*pswt

      if(wt3 .eq. 0d0) return 1

      return
      end


      MODULE MOD_CALCLAMBDAS

      CONTAINS

      !*** micha: Caclulate the accelerated Lambda Iterator.
      !PURE FUNCTION CALCLAMBDAS(OPA,ETA,THOMSON,R,EDDI,ND)

      FUNCTION CALCLAMBDAS(OPA, R, EDDI, ND)
      ! called by como.for
      ! calculate the LambdaStar operator
      IMPLICIT NONE
      integer, intent(in):: ND                 !Number of Depth/Frequency points, index
      real*8, dimension(ND) :: CALCLAMBDAS     !Approximated Lambda Operator
      real*8, intent(in), dimension(ND)  :: OPA, R  !OPA: Opacity, R: Distance from surface
      !real*8,intent(in),dimension(ND)  :: THOMSON !relative Electron Scattering factor
      real*8, intent(in), dimension(3,ND):: EDDI    !Eddi,sphericity and flux factors, see comment below
      real*8, dimension(ND)  :: A,B, C             !calculate the Lambda Operator
      ! real*8 :: DA, DC, DR,DRM, FL, FM, FP, QL, QM, QP, H, HPLUS     !helper variables
      integer:: L             !index
      real*8 :: dXm, dXl,dX
      !**** EDDI(1,L) is the eddington factor  f_nu = K_nu / J_nu = 2nd order
      !***            acceleration / mean Intensity
      !***  EDDI(2,L) is the sphericity factor q see Mihalas 2nd Edition,
      !***            7-6 Extended Atmospheres, eq. 7-193 p. 251
      !***  EDDI(3,L) is the eddington factor h / j  (only at the boundaries)
      !***  EDDI(3,ND-1) is the outward flux hplus at the inner boundary
      !***            See Mihalas "Stellar Atmospheres", 2nd Edition, p. 251:
      !***            7-196, 7-198, 7-200) Source function = ETA/OPA
      !*** A,B,C give a triangular matrix of the following form:
      !***                B  -C
      !***               -A   B  -C
      !***                   -A   B  -C
      !***                       -A   B
      !### For the Boundary Conditions see Auer "Improved Boundary Conditions
      !### for the Feautrier Method" 1967.
      !***=== OUTER BOUNDARY ================================================
      dXl = (OPA(2)+OPA(1))/2d0*(R(2)-R(1))!*RSTAR
      dX = dXl*EDDI(2,1)  ! EDDI(2,L) = q(l)
      A(1) =  0d0
      C(1) =  2./(dX*dXl)
      !***===  NON-BOUNDARY POINTS ==========================================
      !*** from G.B. Rybicki and D.G. Hummer, "An accelerated lambda
      !***   iteration method for multilevel radiative transfer", A&A 254,
      !***   171-181 (1991), [1991A&A...245..171R]
      !*** and R.J. Rutten, "Radiative Transfer in Stellar Atmospheres",
      !*** Intitute of Theoretical Astrophysics Oslo, May 8, 2003 (sphericity
      !*** factor) the complete model is described in Auer, 1967.
      NonBoundary: DO L=2,ND-1
        !*** See Mihalas, Equation 7-196
        !*** Define the Operator "2nd Derivative" (e.g. Rutten, 5.23-25 )
        dXm = dXl
        dXl = (OPA(L+1)+OPA(L))/2d0*(R(l+1)-R(l))!*RSTAR
        dX = (dXm+dXl)/2d0*EDDI(2,L)**2  ! EDDI(2,L) = q(l)
        A(L) =  2d0/(dX*dXm)
        C(L) =  2d0/(dX*dXl)
      ENDDO NonBoundary
      !***===  INNER BOUNDARY (Auer, 1967) ==================================
      !dXm=dXl
      dXl = (OPA(ND)+OPA(ND-1))/2d0*(R(ND)-R(ND-1))!*RSTAR
      !dX = (dXm+dXl)/2d0*EDDI(2,ND)  ! EDDI(2,L) = q(l)
      dX = (dXl)*EDDI(2,ND)  ! EDDI(2,L) = q(l)
      A(ND) =  2d0/(dX*dX)
      C(ND) = 0d0
      B =  A+C+1d0

      CALCLAMBDAS = INVTRIDIAG(A, B, C)

      END FUNCTION

      FUNCTION INVTRIDIAG(A, B, C)

      !***  ==== DIAGONAL ELEMENTS OF THE INVERSE OF A TRIDIAGONAL MATRIX ====
      !*  W(LMAX)=RL*RL*(ETA(LMAX)+two*QL*X*HPLUS/DX)
      !*  A,B,C for T=tri(A,B,C) are calculated, now calculate
      !*  \Lambda* = diag(T^(-1)) according to G.B. Rybicki and D.G. Hummer
      !*  in Astron Astrophysics, 245, 171--181 (1991) (Appendix B, p.180)
      !*  A(1) is one below the top of the matrix
      !*  C(LMAX) is one above the bottom of the matrix
      !*  D(0), E(LMAX+1) are the initial help-vectors for xL
      !*  D(0) = 0d0;z
      !*   Matrix:
      !* /  B1  C1                   \
      !* |  A2  B2  C2               |
      !* |      A3  B3  C3           |
      !* |                           |
      !* |                 AM BM CM  |
      !* \                    AN BN  /, M=N-1, A1=CN=0

      IMPLICIT NONE

      REAL*8, INTENT(IN), DIMENSION(:) :: A, B, C

      INTEGER :: L, LMAX

      REAL*8 :: INVTRIDIAG(size(A))
      REAL*8 :: E(2 : size(A) + 1)  ! for the inverse
      REAL*8 :: DL, DLM             ! DL -> DLM at the end of each iteration

      LMAX = size(A)

      DLM = 0.0d0

      E(LMAX + 1) = 0.0d0
      E(LMAX) = A(LMAX) / B(LMAX)

      DO L = LMAX - 1, 2, -1; E(L) = A(L) / (B(L) - C(L) * E(L + 1)); ENDDO

      DO L = 1, LMAX

         DL = C(L) / (B(L) - A(L) * DLM);

         INVTRIDIAG(L) = 1.0d0 / ((1.0d0 - DL * E(L + 1)) * (B(L) - A(L) * DLM))

         DLM = DL

!        RINAT TAGIROV:
!        Check if INVTRIDIAG(L) is a NaN, in which case the coefficients of the
!        Feautrier matrix are infinite which in turn means that we're in the optically
!        thin case => no need for acceleration.

         if (isnan(INVTRIDIAG(L))) INVTRIDIAG(L) = 0.0D0

      ENDDO

      END FUNCTION

      END MODULE


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAU5 ON BECKER DOERING PROBLEM
C * * * * * * * * * * * * * * * * * * * * * * * * *
        IMPLICIT REAL*8 (A-H,O-Z)
C --- PARAMETERS FOR RADAU5 (FULL JACOBIAN)
        PARAMETER (ND=5000,LJAC=5,LMAS=1,LE=8)
        PARAMETER (LWORK=ND*(LJAC+LMAS+3*LE+12)+20,LIWORK=3*ND+20)
        DIMENSION Y(ND),WORK(LWORK),IWORK(LIWORK),ISTAT(20)
C -------- END PARAMETER LIST --------
        REAL*4 TARRAY(2),TRESULT
        EXTERNAL FBECK,JBECK,FBECKD,JBECKD,MBECK,SOLOUT,JBECKF
        COMMON /PRJECTION/RHO,FACT
        COMMON /COEFF/B(5000),RHO1
        R0=0.0D0
        DO I=1,ND-1
           R1=I**(2.D0/3.D0)
           B(I+1)=EXP((2*I-1.0D0)/(R1*R1+R1*R0+R0*R0))
           R0=R1
        END DO
c ------ FILE DE DONNEES ----------
        OPEN(8,FILE='res_rad5')
        REWIND 8
C --- LOOP FOR DIFFERENT TOLERANCES
        NTOLMN=2
        NTOLMX=10
        NTOLDF=4
        NRLOOP=(NTOLMX-NTOLMN)*NTOLDF+1
        TOLST=0.1D0**NTOLMN
        TOLFC=0.1D0**(1.D0/NTOLDF)
        DO 30 NTOL=1,NRLOOP
C --- DIMENSION OF THE SYSTEM
        N=ND
C --- COMPUTE THE JACOBIAN ANALYTICALLY
        IJAC=1
C --- THE FOLLOWING VALUES HAVE TO BE USED ONLY IF
C --- DC_DECSOL_BD.F  IS USED
        MLJAC=3
        MUJAC=1
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
        IMAS=0
        MLMAS=0
        MUMAS=0
C --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION
        IOUT=0
C --- INITIAL VALUES
        RHO=7.5D0
        RHO1=RHO
        X=0.0D0
        Y(1)=RHO
        DO I=2,N
           Y(I)=0.0D0
        END DO
C --- REQUIRED TOLERANCE
        RTOL=TOLST
        ATOL=1.0D-3*RTOL
        ITOL=0
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- SET DEFAULT VALUES
        DO I=1,20
           WORK(I)=0.D0
           IWORK(I)=0
           ISTAT(I)=0
        END DO
C --- ENDPOINT OF INTEGRATION
        XEND=1.0D0
        CALL DTIME(TARRAY,TRESULT)
        DO 20 I=1,15
C --- CALL OF THE SUBROUTINE RADAU5
        CALL RADAU5(N,FBECK,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JBECK,IJAC,MLJAC,MUJAC,
     &                  MBECK,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT SOLUTION
        WRITE (8,*) Y(1)
        DO J=2,N-1,1000
           WRITE (8,*) Y(J)
        END DO
        WRITE (8,*) Y(N)
C --- PRINT STATISTICS
         DO J=14,20
            ISTAT(J)=ISTAT(J)+IWORK(J)
         END DO
 20     XEND=XEND*10.D0
        CALL DTIME(TARRAY,TRESULT)
        WRITE(8,*)TARRAY(1)
        WRITE (8,*)(ISTAT(J),J=14,20)
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
 91     FORMAT(' fcn=',I5,' jac=',I4,' step=',I4,
     &        ' accpt=',I4,' rejct=',I3,' dec=',I4,
     &        ' sol=',I5)
C -------- NEW TOLERANCE ---
        TOLST=TOLST*TOLFC
           SUM=Y(1)
           DO I=2,N
              SUM=SUM+I*Y(I)
           END DO
           write (6,*) '  rho ',sum,rho
        IF (TARRAY(1).GT.500.) STOP
 30     CONTINUE
        STOP
        END
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N,RPAR,IPAR,IRTRN)
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),CONT(LRC)
        LOGICAL PROJECT
        COMMON /INTERN/XOUT
        COMMON /PRJECTION/RHO,FACT
        COMMON /COEFF/B(5000),RHO1
        PROJECT=.TRUE.
        IF (PROJECT) THEN
           IF (NR.EQ.1) FACT=N*(N+1.D0)*(1+2*N)/6.0D0
           SUM=0.D0
           DO I=N,1,-1
              SUM=SUM+I*Y(I)
           END DO
           ALAM=(SUM-RHO)/FACT
           DO I=1,N
              Y(I)=Y(I)-I*ALAM
           END DO
        END IF
        RETURN
        END


PROGRAM array4_test

 CALL claw_test ( )
END PROGRAM array4_test

SUBROUTINE claw_test ( )
 INTEGER , ALLOCATABLE :: vec1 ( : , : )
 INTEGER , ALLOCATABLE :: vec2 ( : , : )

 INTEGER :: claw_induction_0
 INTEGER :: claw_induction_1

 ALLOCATE ( vec1 ( 10 , 20 ) )
 ALLOCATE ( vec2 ( 10 , 20 ) )
 vec1 ( : , : ) = 0
 vec2 ( : , : ) = 100
 DO claw_induction_0 = 1 , size ( vec1 , 1 )
  DO claw_induction_1 = 1 , size ( vec1 , 2 )
   vec1 ( claw_induction_0 , claw_induction_1 ) = vec2 ( claw_induction_0 ,&
    claw_induction_1 ) + 10
   vec2 ( claw_induction_0 , claw_induction_1 ) = vec2 ( claw_induction_0 ,&
    claw_induction_1 ) + 10
  END DO
 END DO
 PRINT * , sum ( vec1 )
 PRINT * , sum ( vec2 )
 DEALLOCATE ( vec1 )
 DEALLOCATE ( vec2 )
END SUBROUTINE claw_test


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

module geometry

    use constants

    implicit none

    private

    type, public :: t_halfspace
        real, dimension(3) :: point
        real, dimension(3) :: normal
    end type

    type, public :: t_circle
      ! Untransformed circle has unit radius and lies in x-y plane.
        real, dimension(3)   :: center
        real, dimension(3,3) :: transform
    end type

    type, public :: t_polygon
        real, dimension(:,:), allocatable :: points
    end type

    public point_in_halfspace
    public get_piercingpoint
    public nearest_point_on_polygon
    public circle_to_polygon
    public trim_polygon
    public copy_polygon
    public polygon_box
    public polygon_area
    public polygon_destroy

    interface trim_polygon
        module procedure trim_polygon_one
        module procedure trim_polygon_more
    end interface

  contains

    pure function point_in_halfspace( point, halfspace )

      ! Decide if point is in the halfspace.
      !
      ! Returns true if the point is in the halfspace, from which the normal
      ! vector is pointing away, or if it lies on the borderplane.

        real, dimension(3), intent(in) :: point
        type(t_halfspace), intent(in)  :: halfspace
        logical :: point_in_halfspace

        point_in_halfspace = &
           (dot_product( halfspace%normal, halfspace%point(:)-point(:) ) >= 0.0)

    end function

    pure subroutine get_piercingpoint( point_a, point_b, halfspace, piercingpoint, &
                                  between_ab, parallel, a_inside_, b_inside_ )

      ! Get the piercing point of line between a and b with halfspace border.

        real, dimension(3), intent(in) :: point_a
        real, dimension(3), intent(in) :: point_b
        type(t_halfspace), intent(in)  :: halfspace
        real, dimension(3), intent(out) :: piercingpoint
        logical, intent(out)            :: between_ab, parallel
        logical, intent(out), optional  ::  a_inside_, b_inside_
        logical ::  a_inside, b_inside

        real :: lambda_a, lambda_b, lambda_ab
        real, dimension(3) :: ab

        ab(:) = point_b(:) - point_a(:)

        lambda_a = dot_product( halfspace%normal, halfspace%point(:) - point_a(:) )
        lambda_b = dot_product( halfspace%normal, halfspace%point(:) - point_b(:) )
        lambda_ab = dot_product( halfspace%normal, ab )

        a_inside = (lambda_a >= 0.)
        b_inside = (lambda_b >= 0.)
        if (present(a_inside_)) a_inside_ = a_inside
        if (present(b_inside_)) b_inside_ = b_inside
        between_ab = ((a_inside .and. .not. b_inside) .or. &
                      (b_inside .and. .not. a_inside))

        parallel = ( lambda_ab*lambda_ab < dot_product(ab,ab) / 2**(digits(lambda_ab)) )

        if (parallel .and. between_ab) then
            ! AB lies (almost) in plane
            if (abs(lambda_a) <= abs(lambda_b)) then
                piercingpoint(:) = point_a(:)
            else
                piercingpoint(:) = point_b(:)
            end if
            return
        end if

        if (parallel .and. .not. between_ab) then
            piercingpoint = (/0.,0.,0./)
            return
        end if

        piercingpoint(:) = point_a(:) + ab(:)*lambda_a/lambda_ab

    end subroutine

    pure function nearest_point_on_polygon( polygon, point ) result(nearest_point)

        type(t_polygon), intent(in)    :: polygon
        real, dimension(3), intent(in) :: point
        real, dimension(3)             :: nearest_point

        type(t_halfspace)   :: halfspace
        real, dimension(3)  :: piercingpoint
        logical             :: does_pierce, parallel
        integer             :: npoints, ipoint, jpoint
        real                :: distsquare, comp_distsquare

        nearest_point = point
        if (.not. allocated(polygon%points)) return
        if (size(polygon%points,2) == 0) return

        npoints = size(polygon%points,2)
        halfspace%point = point
        distsquare = huge(distsquare)
        nearest_point = polygon%points(:,1)
        if (size(polygon%points,2) == 1) return

        do ipoint=1,npoints
            jpoint = mod(ipoint,npoints)+1
            halfspace%normal = polygon%points(:,jpoint) - polygon%points(:,ipoint)
            call get_piercingpoint( polygon%points(:,ipoint), polygon%points(:,jpoint), &
                                    halfspace, piercingpoint, &
                                    does_pierce, parallel )

            comp_distsquare = vecsqr(piercingpoint-point)
            if (does_pierce .and. comp_distsquare < distsquare) then
                distsquare = comp_distsquare
                nearest_point = piercingpoint
            end if

            comp_distsquare = vecsqr(polygon%points(:,ipoint)-point)
            if (comp_distsquare < distsquare) then
                distsquare = comp_distsquare
                nearest_point = polygon%points(:,ipoint)
            end if
        end do

    end function

    pure function vecsqr( a )
        real, dimension(3), intent(in)  :: a
        real :: vecsqr
        vecsqr = dot_product(a,a)
    end function

    pure subroutine circle_to_polygon( circle, npoints, polygon )

      ! Create a polygon approximating the circle.

        type(t_circle), intent(in)          :: circle
        integer, intent(in)                 :: npoints
        type(t_polygon), intent(inout)      :: polygon
        integer :: i

        if (allocated(polygon%points)) deallocate(polygon%points)
        allocate(polygon%points(3,npoints))

        do i=1,npoints
            polygon%points(:,i) = matmul(circle%transform,(/cos(i*2.*pi/npoints), &
                                                            sin(i*2.*pi/npoints), &
                                                            0./)) + circle%center(:)
        end do

    end subroutine

    pure subroutine trim_polygon_one( polygon, halfspace, polygon_trimmed )

      ! Cut off parts of polygon, which lie outside of halfspace.

        type(t_polygon), intent(in)              :: polygon
        type(t_halfspace), intent(in)            :: halfspace
        type(t_polygon), intent(inout)           :: polygon_trimmed

        real, dimension(3,size(polygon%points,2))  :: piercingpoints
        logical, dimension(size(polygon%points,2)) :: does_pierce, point_inside
        integer :: npoints, npoints_trimmed, ipoint, jpoint
        logical :: parallel, b_inside

        npoints = size(polygon%points,2)

        if (allocated(polygon_trimmed%points)) deallocate(polygon_trimmed%points)

        npoints_trimmed = 0
        do ipoint=1,npoints
            jpoint = mod(ipoint,npoints)+1
            call get_piercingpoint( polygon%points(:,ipoint), polygon%points(:,jpoint), &
                                    halfspace, piercingpoints(:,ipoint), &
                                    does_pierce(ipoint), parallel, &
                                    point_inside(ipoint), b_inside )

            if (point_inside(ipoint)) npoints_trimmed = npoints_trimmed + 1
            if (does_pierce(ipoint)) npoints_trimmed = npoints_trimmed + 1
        end do

        allocate(polygon_trimmed%points(3,npoints_trimmed))

        jpoint = 1
        do ipoint=1,npoints
            if (point_inside(ipoint)) then
                polygon_trimmed%points(:,jpoint) = polygon%points(:,ipoint)
                jpoint = jpoint + 1
            end if
            if (does_pierce(ipoint)) then
                polygon_trimmed%points(:,jpoint) = piercingpoints(:,ipoint)
                jpoint = jpoint + 1
            end if
        end do

    end subroutine

    pure subroutine trim_polygon_more( polygon, halfspaces, polygon_trimmed )

      ! Cut off parts of polygon, which lie outside of halfspaces.

        type(t_polygon), intent(in)                 :: polygon
        type(t_halfspace), dimension(:), intent(in) :: halfspaces
        type(t_polygon), intent(inout)              :: polygon_trimmed

        type(t_polygon) :: temp
        integer :: icon

        call copy_polygon( polygon, temp )
        do icon=1,size(halfspaces)
            if (icon /= 1) call copy_polygon( polygon_trimmed, temp )
            call trim_polygon( temp, halfspaces(icon), polygon_trimmed )
        end do

    end subroutine

    pure subroutine polygon_box( polygon, mi, ma )

         type(t_polygon), intent(in) :: polygon
         real, intent(out), dimension(3) :: mi, ma

         mi = minval(polygon%points,2)
         ma = maxval(polygon%points,2)

    end subroutine

    pure subroutine copy_polygon( a, b )

        type(t_polygon), intent(in)    :: a
        type(t_polygon), intent(inout) :: b

        if (allocated(b%points)) deallocate(b%points)
        allocate(b%points(3,size(a%points,2)))
        b%points = a%points

    end subroutine

    pure function polygon_area( polygon ) result(area)

        type(t_polygon), intent(in) :: polygon
        real :: area

        real :: area_xy, area_yz, area_zx
        integer :: ip, jp, np

        np = size(polygon%points,2)

        area_xy = 0.
        area_yz = 0.
        area_zx = 0.

        if (.not. allocated(polygon%points)) return

        np = size(polygon%points,2)
        if (np <= 2) return

        do ip=1,np
            jp = mod(ip,np)+1
            area_xy = area_xy + (polygon%points(1,ip)-polygon%points(1,jp))* &
                                (polygon%points(2,ip)+polygon%points(2,jp))*0.5
            area_yz = area_yz + (polygon%points(2,ip)-polygon%points(2,jp))* &
                                (polygon%points(3,ip)+polygon%points(3,jp))*0.5
            area_zx = area_zx + (polygon%points(3,ip)-polygon%points(3,jp))* &
                                (polygon%points(1,ip)+polygon%points(1,jp))*0.5
        end do

        area = sqrt(area_xy**2 + area_yz**2 + area_zx**2)

    end function

    pure subroutine polygon_destroy( poly )

        type(t_polygon), intent(inout) :: poly
        if (allocated(poly%points)) deallocate( poly%points )

    end subroutine

end module


module shape_module
    !! This module contains the base class for various geometric shapes
    implicit none

    private

    real(kind=4) :: pi = 3.14

    public :: shape_type

    ! Class shape
    type shape_type
        real(kind=4) :: dim1 = 1.
        real(kind=4) :: dim2 = 1.
        real(kind=4) :: dim3 = 0.
    contains
        procedure, public  :: area   => calculate_area
        procedure, public  :: volume => calculate_volume
    end type shape_type

    ! Definition of the constructor
    interface shape_type
        module procedure shape_constructor
    end interface shape_type

contains

! Constructor for class shape
function shape_constructor() result(shape)
type(shape_type) :: shape
real(kind=4)     :: dim1
real(kind=4)     :: dim2
real(kind=4)     :: dim3

shape%dim1   = dim1
shape%dim2   = dim2
shape%dim3   = dim3

end function shape_constructor

subroutine calculate_area(this, dim1, dim2, area)
class(shape_type), intent(inout) :: this

real(kind=4), intent(in)  :: dim1
real(kind=4), intent(in)  :: dim2
real(kind=4), intent(out) :: area

    area = dim1 * dim2

end subroutine calculate_area

subroutine calculate_volume(this, dim1, dim2, dim3, volume)
class(shape_type), intent(inout) :: this

real(kind=4), intent(in)  :: dim1
real(kind=4), intent(in)  :: dim2
real(kind=4), intent(in)  :: dim3
real(kind=4), intent(out) :: volume

volume = this%dim1 * this%dim2 * this%dim3

end subroutine calculate_volume

end module shape_module


    !-------------------------------------------------------------------------------------------------------------
    !
    ! DISCLAIMER
    ! ==========
    !
    ! All of the programming herein is original unless otherwise specified.  Details of contributions to the
    ! programming are given below.
    !
    !
    ! Revisions:
    ! ==========
    !
    !    Date          Programmer         Description of change
    !    ----          ----------         ---------------------
    !    09/12/2013    M.H.A. Piro        Original code
    !
    !
    ! Purpose:
    ! ========
    !
    ! The purpose of this subroutine is to calculate the update to the Broyden matrix that can be used for
    ! the Levenberg-Marquartd Algorithm (LMA).  For this case, the Broyden matrix is rectangular.
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in] m             The number of data-points to be optimized.
    !> \param[in] n             The number of unknown parameters.
    !> \param[inout] s          The change of the unknown variable vector.
    !> \param[in] y             The change of the functional vector.
    !> \param[in] f             The functional vector.
    !> \param[inout] dBroyden   The Broyden matrix (rectangular).
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine optimaBroyden(m, n, y, s, dBroyden)

    implicit none

    integer                :: i, j, m, n
    real(8)                :: dTempVar
    real(8),dimension(m)   :: y, dTempVec
    real(8),dimension(n)   :: s
    real(8),dimension(m,n) :: dBroyden

    ! Initialize variables:
    dTempVar = 0D0
    dTempVec = 0D0

    ! Check input variables:
    if (n > m) then
        print *, 'The number of data-points must be greater than or equal to the '
        print *, 'number of unknown parameters.  The program will halt.'
        print *
        stop
    end if

    ! Compute Bs:
    do j = 1, n
        do i = 1, m
            dTempVec(i) = dTempVec(i) + dBroyden(i,j) * s(j)
        end do
    end do

    ! Compute sTs:
    do j = 1, n
        dTempVar = dTempVar + s(j)**2
    end do

    ! Make sTs multiplicative:
    dTempVar = 1D0 / dTempVar

    ! Compute (y - Bs) / sTs
    do i = 1, m
        dTempVec(i) = (y(i) - dTempVec(i)) * dTempVar
    end do

    ! Update the Broyden matrix:
    do j = 1, n
        do i = 1, m
            dBroyden(i,j) = dBroyden(i,j) + dTempVec(i) * s(j)
        end do
    end do

    return

end subroutine optimaBroyden


!##############################################################################
!# Tutorial 023c: Calculate an L2 and H1 norm, block integration, subdomains
!##############################################################################

module tutorial023c

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation
  use derivatives
  use collection

  use feevaluation2
  use blockmatassemblybase
  use blockmatassembly
  use blockmatassemblystdop

  implicit none
  private

  public :: start_tutorial023c

contains

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

!<subroutine>

  subroutine fcalc_L2norm_subdomain(Dintvalues,rassemblyData,rintAssembly,&
      npointsPerElement,nelements,revalVectors,rcollection)

!<description>
    ! Calculates the L2 norm of the function passed by revalVectors
    ! on the subdomains (x <= 0.25) and (x >= 0.25).
!</description>

!<input>
    ! Data necessary for the assembly. Contains determinants and
    ! cubature weights for the cubature,...
    type(t_bmaIntegralAssemblyData), intent(in) :: rassemblyData

    ! Structure with all data about the assembly
    type(t_bmaIntegralAssembly), intent(in) :: rintAssembly

    ! Number of points per element
    integer, intent(in) :: npointsPerElement

    ! Number of elements
    integer, intent(in) :: nelements

    ! Values of FEM functions automatically evaluated in the
    ! cubature points.
    type(t_fev2Vectors), intent(in) :: revalVectors

    ! User defined collection structure
    type(t_collection), intent(inout), target, optional :: rcollection
!</input>

!<output>
    ! Returns the value of the integral(s)
    real(DP), dimension(:), intent(out) :: Dintvalues
!</output>

!</subroutine>

    ! Local variables
    real(DP) :: dx,dy,dval
    integer :: iel, icubp
    real(DP), dimension(:,:), pointer :: p_DcubWeight
    real(DP), dimension(:,:), pointer :: p_Dfunc
    real(DP), dimension(:,:,:), pointer :: p_Dpoints

    ! Get cubature weights data
    p_DcubWeight => rassemblyData%p_DcubWeight

    ! Initial integral values
    Dintvalues(1) = 0.0_DP    ! x <= 0.25
    Dintvalues(2) = 0.0_DP    ! x >= 0.25

    ! Get the coordinates of the cubature points
    p_Dpoints => rassemblyData%revalElementSet%p_DpointsReal

    ! Get the data array with the values of the FEM function
    ! in the cubature points
    p_Dfunc => revalVectors%p_RvectorData(1)%p_Ddata(:,:,DER_FUNC)

    ! Loop over the elements in the current set.
    do iel = 1,nelements

      ! Loop over all cubature points on the current element
      do icubp = 1,npointsPerElement

        ! Get the coordinates of the point
        dx = p_Dpoints(1,icubp,iel)
        dy = p_Dpoints(2,icubp,iel)

        ! Get the value of the FEM function
        dval = p_Dfunc(icubp,iel)

        ! Multiply the values by the cubature weight and sum up
        ! into the integral value
        if (dx .le. 0.25_DP) then
          ! 1st subdomain
          Dintvalues(1) = Dintvalues(1) + p_DcubWeight(icubp,iel) * dval**2
        else
          ! 2nd subdomain
          Dintvalues(2) = Dintvalues(2) + p_DcubWeight(icubp,iel) * dval**2
        end if

      end do ! icubp

    end do ! iel

  end subroutine

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

!<subroutine>

  subroutine fcalc_H1norm_subdomain(Dintvalues,rassemblyData,rintAssembly,&
      npointsPerElement,nelements,revalVectors,rcollection)

!<description>
    ! Calculates the H1 (semi-)norm of the function passed by revalVectors
    ! on the subdomain (x <= 0.25) and (x >= 0.25).
!</description>

!<input>
    ! Data necessary for the assembly. Contains determinants and
    ! cubature weights for the cubature,...
    type(t_bmaIntegralAssemblyData), intent(in) :: rassemblyData

    ! Structure with all data about the assembly
    type(t_bmaIntegralAssembly), intent(in) :: rintAssembly

    ! Number of points per element
    integer, intent(in) :: npointsPerElement

    ! Number of elements
    integer, intent(in) :: nelements

    ! Values of FEM functions automatically evaluated in the
    ! cubature points.
    type(t_fev2Vectors), intent(in) :: revalVectors

    ! User defined collection structure
    type(t_collection), intent(inout), target, optional :: rcollection
!</input>

!<output>
    ! Returns the value of the integral(s)
    real(DP), dimension(:), intent(out) :: Dintvalues
!</output>

!</subroutine>

    ! Local variables
    real(DP) :: dx,dy,dderivX,dderivY
    integer :: iel, icubp
    real(DP), dimension(:,:), pointer :: p_DcubWeight
    real(DP), dimension(:,:), pointer :: p_DderivX,p_DderivY
    real(DP), dimension(:,:,:), pointer :: p_Dpoints

    ! Get cubature weights data
    p_DcubWeight => rassemblyData%p_DcubWeight

    ! Initial integral value
    Dintvalues(1) = 0.0_DP    ! x <= 0.25
    Dintvalues(2) = 0.0_DP    ! x >= 0.25

    ! Get the coordinates of the cubature points
    p_Dpoints => rassemblyData%revalElementSet%p_DpointsReal

    ! Get the data array with the values of the FEM function
    ! in the cubature points
    p_DderivX => revalVectors%p_RvectorData(1)%p_Ddata(:,:,DER_DERIV2D_X)
    p_DderivY => revalVectors%p_RvectorData(1)%p_Ddata(:,:,DER_DERIV2D_Y)

    ! Loop over the elements in the current set.
    do iel = 1,nelements

      ! Loop over all cubature points on the current element
      do icubp = 1,npointsPerElement

        ! Get the coordinates of the point
        dx = p_Dpoints(1,icubp,iel)
        dy = p_Dpoints(2,icubp,iel)

        ! Get the value of the FEM function
        dderivX = p_DderivX(icubp,iel)
        dderivY = p_DderivY(icubp,iel)

        ! Multiply the values by the cubature weight and sum up
        ! into the integral value
        if (dx .le. 0.25_DP) then
          ! 1st subdomain
          Dintvalues(1) = Dintvalues(1) + p_DcubWeight(icubp,iel) * &
              ( dderivX**2 + dderivY**2 )
        else
          ! 2nd subdomain
          Dintvalues(2) = Dintvalues(2) + p_DcubWeight(icubp,iel) * &
              ( dderivX**2 + dderivY**2 )
        end if

      end do ! icubp

    end do ! iel

  end subroutine

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

  subroutine start_tutorial023c

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_vectorBlock) :: rx
    type(t_fev2Vectors) :: rcoeffVectors

    integer :: ivt
    real(DP) :: dx
    real(DP), dimension(2) :: Dintvalues
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:), pointer :: p_Ddata

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 023c")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 9x9-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 8, 8)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rspatialDiscr
    ! which describes the discretisation.
    ! We generate a 1x1 system with Q1.
    ! =================================

    ! Create a spatial discretisation with Q1
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Create a block discretisation with 1 block Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a scalar vector.
    ! =================================

    ! Create a vector.
    call lsysbl_createVector (rblockDiscr,rx)

    ! =================================
    ! Fill the vector with data.
    ! =================================

    ! Get a pointer to the data.
    call lsyssc_getbase_double (rx%RvectorBlock(1),p_Ddata)

    ! Get a pointer to the point coordinates.
    call storage_getbase_double2d (rtriangulation%h_DvertexCoords,p_DvertexCoords)

    ! Set the entries of the vector according to the function
    !    u(x,y) = 1/exp(x)
    do ivt=1,rx%NEQ
      dx = p_DvertexCoords(1,ivt)
      p_Ddata(ivt) = 1.0_DP / exp(dx)
    end do

    ! =================================
    ! Define cubature formula
    ! =================================

    ! Use a Gauss 3x3 formula for the discretisation.
    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Calculate the L2-norm of u
    ! on the subdomains (x <= 0.25) and (x >= 0.25)
    ! =================================

    ! Pass u via rcoeffVectors to bma_buildIntegral
    call fev2_addVectorToEvalList (rcoeffVectors,rx%RvectorBlock(1),0)

    ! Calculate ||u||_L2^2 simultaneously on subdomain
    ! (x <= 0.25) and (x >= 0.25).
    call bma_buildIntegrals (Dintvalues,BMA_CALC_STANDARD,&
        fcalc_L2norm_subdomain,revalVectors=rcoeffVectors,rcubatureInfo=rcubatureInfo)

    call fev2_releaseVectorList(rcoeffVectors)

    ! Take the square roots to get ||u||
    Dintvalues(:) = sqrt(Dintvalues(:))

    call output_line ("L2-norm(A) = "//trim(sys_sdL(Dintvalues(1),10)))
    call output_line ("L2-norm(B) = "//trim(sys_sdL(Dintvalues(2),10)))

    ! =================================
    ! Calculate the H1-(semi)norm of u
    ! on the subdomains (x <= 0.25) and (x >= 0.25)
    ! =================================

    ! Pass u and Du via rcoeffVectors to bma_buildIntegral
    call fev2_addVectorToEvalList (rcoeffVectors,rx%RvectorBlock(1),1)

    ! Calculate |u|_H1^2 = ||Du||_L2^2 simultaneously on subdomain
    ! (x <= 0.25) and (x >= 0.25).
    call bma_buildIntegrals (Dintvalues,BMA_CALC_STANDARD,&
        fcalc_H1norm_subdomain,revalVectors=rcoeffVectors,rcubatureInfo=rcubatureInfo)

    call fev2_releaseVectorList(rcoeffVectors)

    ! Take the square roots to get |u|_H1
    Dintvalues(:) = sqrt(Dintvalues(:))

    call output_line ("H1-norm(A) = "//trim(sys_sdL(Dintvalues(1),10)))
    call output_line ("H1-norm(B) = "//trim(sys_sdL(Dintvalues(2),10)))

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsysbl_releaseVector (rx)

    ! Cubature done.
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


*DECK DCV
      DOUBLE PRECISION FUNCTION DCV (XVAL, NDATA, NCONST, NORD, NBKPT,
     +   BKPT, W)
C***BEGIN PROLOGUE  DCV
C***PURPOSE  Evaluate the variance function of the curve obtained
C            by the constrained B-spline fitting subprogram DFC.
C***LIBRARY   SLATEC
C***CATEGORY  L7A3
C***TYPE      DOUBLE PRECISION (CV-S, DCV-D)
C***KEYWORDS  ANALYSIS OF COVARIANCE, B-SPLINE,
C             CONSTRAINED LEAST SQUARES, CURVE FITTING
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     DCV( ) is a companion function subprogram for DFC( ).  The
C     documentation for DFC( ) has complete usage instructions.
C
C     DCV( ) is used to evaluate the variance function of the curve
C     obtained by the constrained B-spline fitting subprogram, DFC( ).
C     The variance function defines the square of the probable error
C     of the fitted curve at any point, XVAL.  One can use the square
C     root of this variance function to determine a probable error band
C     around the fitted curve.
C
C     DCV( ) is used after a call to DFC( ).  MODE, an input variable to
C     DFC( ), is used to indicate if the variance function is desired.
C     In order to use DCV( ), MODE must equal 2 or 4 on input to DFC( ).
C     MODE is also used as an output flag from DFC( ).  Check to make
C     sure that MODE = 0 after calling DFC( ), indicating a successful
C     constrained curve fit.  The array SDDATA, as input to DFC( ), must
C     also be defined with the standard deviation or uncertainty of the
C     Y values to use DCV( ).
C
C     To evaluate the variance function after calling DFC( ) as stated
C     above, use DCV( ) as shown here
C
C          VAR=DCV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W)
C
C     The variance function is given by
C
C      VAR=(transpose of B(XVAL))*C*B(XVAL)/DBLE(MAX(NDATA-N,1))
C
C     where N = NBKPT - NORD.
C
C     The vector B(XVAL) is the B-spline basis function values at
C     X=XVAL.  The covariance matrix, C, of the solution coefficients
C     accounts only for the least squares equations and the explicitly
C     stated equality constraints.  This fact must be considered when
C     interpreting the variance function from a data fitting problem
C     that has inequality constraints on the fitted curve.
C
C     All the variables in the calling sequence for DCV( ) are used in
C     DFC( ) except the variable XVAL.  Do not change the values of
C     these variables between the call to DFC( ) and the use of DCV( ).
C
C     The following is a brief description of the variables
C
C     XVAL    The point where the variance is desired, a double
C             precision variable.
C
C     NDATA   The number of discrete (X,Y) pairs for which DFC( )
C             calculated a piece-wise polynomial curve.
C
C     NCONST  The number of conditions that constrained the B-spline in
C             DFC( ).
C
C     NORD    The order of the B-spline used in DFC( ).
C             The value of NORD must satisfy 1 < NORD < 20 .
C
C             (The order of the spline is one more than the degree of
C             the piece-wise polynomial defined on each interval.  This
C             is consistent with the B-spline package convention.  For
C             example, NORD=4 when we are using piece-wise cubics.)
C
C     NBKPT   The number of knots in the array BKPT(*).
C             The value of NBKPT must satisfy NBKPT .GE. 2*NORD.
C
C     BKPT(*) The double precision array of knots.  Normally the problem
C             data interval will be included between the limits
C             BKPT(NORD) and BKPT(NBKPT-NORD+1).  The additional end
C             knots BKPT(I),I=1,...,NORD-1 and I=NBKPT-NORD+2,...,NBKPT,
C             are required by DFC( ) to compute the functions used to
C             fit the data.
C
C     W(*)    Double precision work array as used in DFC( ).  See DFC( )
C             for the required length of W(*).  The contents of W(*)
C             must not be modified by the user if the variance function
C             is desired.
C
C***REFERENCES  R. J. Hanson, Constrained least squares curve fitting
C                 to discrete data using B-splines, a users guide,
C                 Report SAND78-1291, Sandia Laboratories, December
C                 1978.
C***ROUTINES CALLED  DDOT, DFSPVN
C***REVISION HISTORY  (YYMMDD)
C   780801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DCV
      INTEGER I, ILEFT, IP, IS, LAST, MDG, MDW, N, NBKPT, NCONST,
     *     NDATA, NORD
      DOUBLE PRECISION BKPT, DDOT, V, W, XVAL, ZERO
      DIMENSION BKPT(*),W(*),V(40)
C***FIRST EXECUTABLE STATEMENT  DCV
      ZERO = 0.0D0
      MDG = NBKPT - NORD + 3
      MDW = NBKPT - NORD + 1 + NCONST
      IS = MDG*(NORD + 1) + 2*MAX(NDATA,NBKPT) + NBKPT + NORD**2
      LAST = NBKPT - NORD + 1
      ILEFT = NORD
   10 IF (XVAL .LT. BKPT(ILEFT+1) .OR. ILEFT .GE. LAST - 1) GO TO 20
         ILEFT = ILEFT + 1
      GO TO 10
   20 CONTINUE
      CALL DFSPVN(BKPT,NORD,1,XVAL,ILEFT,V(NORD+1))
      ILEFT = ILEFT - NORD + 1
      IP = MDW*(ILEFT - 1) + ILEFT + IS
      N = NBKPT - NORD
      DO 30 I = 1, NORD
         V(I) = DDOT(NORD,W(IP),1,V(NORD+1),1)
         IP = IP + MDW
   30 CONTINUE
      DCV = MAX(DDOT(NORD,V,1,V(NORD+1),1),ZERO)
C
C     SCALE THE VARIANCE SO IT IS AN UNBIASED ESTIMATE.
      DCV = DCV/MAX(NDATA-N,1)
      RETURN
      END


	FUNCTION GAL_MASS(IO,T,SFR)

c	Computes the galaxy mass up to time t as the integral of the SFR

c	Array declaration
	real*8 glast,trapz8,tg(20000),sf(20000)
	data ic,ig,tg,sf/0,0,40000*0./,glast/0./

c	Zero arrays on first call
	if (ic.eq.0) then
		do i=1,10000
		tg(i)=0.
		sf(i)=0.
		enddo
		gal_mass=0.
		ic=1
		ig=0
	endif

c	Check if SSP (IO=0)
	if (io.eq.0) then
c		SSP, 1 Mo of stars formed at t = 0
		gal_mass=1.
	else
c		Store SFR and compute integral
		ig=ig+1
		tg(ig)=t
		sf(ig)=sfr
		if (sfr > 0.) then
			glast =trapz8(tg,sf,ig)
			if (ig == 1) glast = sfr*t
		endif
		gal_mass=glast
	endif
!	if (t.gt.19.9E9) ic=0
	if (t >= 20.0E9) ic=0
	return
	end

	REAL*8 FUNCTION TRAPZ8(X,Y,N)
	REAL*8 X(N),Y(N)
	TRAPZ8=0.
	IF (N.LE.1) RETURN
	DO J=2,N
	TRAPZ8= TRAPZ8 + ABS(X(J)-X(J-1))*(Y(J)+Y(J-1))/2.
	ENDDO
	RETURN
	END


!*==zgeesx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGEESX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W,
!                          VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK,
!                          BWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVS, SENSE, SORT
!       INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
!       DOUBLE PRECISION   RCONDE, RCONDV
!       ..
!       .. Array Arguments ..
!       LOGICAL            BWORK( * )
!       DOUBLE PRECISION   RWORK( * )
!       COMPLEX*16         A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
!       ..
!       .. Function Arguments ..
!       LOGICAL            SELECT
!       EXTERNAL           SELECT
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the
!> eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!> vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).
!>
!> Optionally, it also orders the eigenvalues on the diagonal of the
!> Schur form so that selected eigenvalues are at the top left;
!> computes a reciprocal condition number for the average of the
!> selected eigenvalues (RCONDE); and computes a reciprocal condition
!> number for the right invariant subspace corresponding to the
!> selected eigenvalues (RCONDV).  The leading columns of Z form an
!> orthonormal basis for this invariant subspace.
!>
!> For further explanation of the reciprocal condition numbers RCONDE
!> and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
!> these quantities are called s and sep respectively).
!>
!> A complex matrix is in Schur form if it is upper triangular.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVS
!> \verbatim
!>          JOBVS is CHARACTER*1
!>          = 'N': Schur vectors are not computed;
!>          = 'V': Schur vectors are computed.
!> \endverbatim
!>
!> \param[in] SORT
!> \verbatim
!>          SORT is CHARACTER*1
!>          Specifies whether or not to order the eigenvalues on the
!>          diagonal of the Schur form.
!>          = 'N': Eigenvalues are not ordered;
!>          = 'S': Eigenvalues are ordered (see SELECT).
!> \endverbatim
!>
!> \param[in] SELECT
!> \verbatim
!>          SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument
!>          SELECT must be declared EXTERNAL in the calling subroutine.
!>          If SORT = 'S', SELECT is used to select eigenvalues to order
!>          to the top left of the Schur form.
!>          If SORT = 'N', SELECT is not referenced.
!>          An eigenvalue W(j) is selected if SELECT(W(j)) is true.
!> \endverbatim
!>
!> \param[in] SENSE
!> \verbatim
!>          SENSE is CHARACTER*1
!>          Determines which reciprocal condition numbers are computed.
!>          = 'N': None are computed;
!>          = 'E': Computed for average of selected eigenvalues only;
!>          = 'V': Computed for selected right invariant subspace only;
!>          = 'B': Computed for both.
!>          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          On entry, the N-by-N matrix A.
!>          On exit, A is overwritten by its Schur form T.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] SDIM
!> \verbatim
!>          SDIM is INTEGER
!>          If SORT = 'N', SDIM = 0.
!>          If SORT = 'S', SDIM = number of eigenvalues for which
!>                         SELECT is true.
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is COMPLEX*16 array, dimension (N)
!>          W contains the computed eigenvalues, in the same order
!>          that they appear on the diagonal of the output Schur form T.
!> \endverbatim
!>
!> \param[out] VS
!> \verbatim
!>          VS is COMPLEX*16 array, dimension (LDVS,N)
!>          If JOBVS = 'V', VS contains the unitary matrix Z of Schur
!>          vectors.
!>          If JOBVS = 'N', VS is not referenced.
!> \endverbatim
!>
!> \param[in] LDVS
!> \verbatim
!>          LDVS is INTEGER
!>          The leading dimension of the array VS.  LDVS >= 1, and if
!>          JOBVS = 'V', LDVS >= N.
!> \endverbatim
!>
!> \param[out] RCONDE
!> \verbatim
!>          RCONDE is DOUBLE PRECISION
!>          If SENSE = 'E' or 'B', RCONDE contains the reciprocal
!>          condition number for the average of the selected eigenvalues.
!>          Not referenced if SENSE = 'N' or 'V'.
!> \endverbatim
!>
!> \param[out] RCONDV
!> \verbatim
!>          RCONDV is DOUBLE PRECISION
!>          If SENSE = 'V' or 'B', RCONDV contains the reciprocal
!>          condition number for the selected right invariant subspace.
!>          Not referenced if SENSE = 'N' or 'E'.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,2*N).
!>          Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),
!>          where SDIM is the number of selected eigenvalues computed by
!>          this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also
!>          that an error is only returned if LWORK < max(1,2*N), but if
!>          SENSE = 'E' or 'V' or 'B' this may not be large enough.
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates upper bound on the optimal size of the
!>          array WORK, returns this value as the first entry of the WORK
!>          array, and no error message related to LWORK is issued by
!>          XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[out] BWORK
!> \verbatim
!>          BWORK is LOGICAL array, dimension (N)
!>          Not referenced if SORT = 'N'.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value.
!>          > 0: if INFO = i, and i is
!>             <= N: the QR algorithm failed to compute all the
!>                   eigenvalues; elements 1:ILO-1 and i+1:N of W
!>                   contain those eigenvalues which have converged; if
!>                   JOBVS = 'V', VS contains the transformation which
!>                   reduces A to its partially converged Schur form.
!>             = N+1: the eigenvalues could not be reordered because some
!>                   eigenvalues were too close to separate (the problem
!>                   is very ill-conditioned);
!>             = N+2: after reordering, roundoff changed values of some
!>                   complex eigenvalues so that leading eigenvalues in
!>                   the Schur form no longer satisfy SELECT=.TRUE.  This
!>                   could also be caused by underflow due to scaling.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup complex16GEeigen
!
!  =====================================================================
      SUBROUTINE ZGEESX(Jobvs,Sort,SELECT,Sense,N,A,Lda,Sdim,W,Vs,Ldvs, &
     &                  Rconde,Rcondv,Work,Lwork,Rwork,Bwork,Info)
      IMPLICIT NONE
!*--ZGEESX242
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobvs , Sense , Sort
      INTEGER Info , Lda , Ldvs , Lwork , N , Sdim
      DOUBLE PRECISION Rconde , Rcondv
!     ..
!     .. Array Arguments ..
      LOGICAL Bwork(*)
      DOUBLE PRECISION Rwork(*)
      COMPLEX*16 A(Lda,*) , Vs(Ldvs,*) , W(*) , Work(*)
!     ..
!     .. Function Arguments ..
      LOGICAL SELECT
      EXTERNAL SELECT
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , scalea , wantsb , wantse , wantsn , wantst ,     &
     &        wantsv , wantvs
      INTEGER hswork , i , ibal , icond , ierr , ieval , ihi , ilo ,    &
     &        itau , iwrk , lwrk , maxwrk , minwrk
      DOUBLE PRECISION anrm , bignum , cscale , eps , smlnum
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DLABAD , DLASCL , XERBLA , ZCOPY , ZGEBAK , ZGEBAL ,     &
     &         ZGEHRD , ZHSEQR , ZLACPY , ZLASCL , ZTRSEN , ZUNGHR
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , ZLANGE
      EXTERNAL LSAME , ILAENV , DLAMCH , ZLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      wantvs = LSAME(Jobvs,'V')
      wantst = LSAME(Sort,'S')
      wantsn = LSAME(Sense,'N')
      wantse = LSAME(Sense,'E')
      wantsv = LSAME(Sense,'V')
      wantsb = LSAME(Sense,'B')
      lquery = (Lwork==-1)
!
      IF ( (.NOT.wantvs) .AND. (.NOT.LSAME(Jobvs,'N')) ) THEN
         Info = -1
      ELSEIF ( (.NOT.wantst) .AND. (.NOT.LSAME(Sort,'N')) ) THEN
         Info = -2
      ELSEIF ( .NOT.(wantsn .OR. wantse .OR. wantsv .OR. wantsb) .OR.   &
     &         (.NOT.wantst .AND. .NOT.wantsn) ) THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvs<1 .OR. (wantvs .AND. Ldvs<N) ) THEN
         Info = -11
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of real workspace needed at that point in the
!       code, as well as the preferred amount for good performance.
!       CWorkspace refers to complex workspace, and RWorkspace to real
!       workspace. NB refers to the optimal block size for the
!       immediately following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by ZHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.
!       If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
!       depends on SDIM, which is computed by the routine ZTRSEN later
!       in the code.)
!
      IF ( Info==0 ) THEN
         IF ( N==0 ) THEN
            minwrk = 1
            lwrk = 1
         ELSE
            maxwrk = N + N*ILAENV(1,'ZGEHRD',' ',N,1,N,0)
            minwrk = 2*N
!
            CALL ZHSEQR('S',Jobvs,N,1,N,A,Lda,W,Vs,Ldvs,Work,-1,ieval)
            hswork = Work(1)
!
            IF ( .NOT.wantvs ) THEN
               maxwrk = MAX(maxwrk,hswork)
            ELSE
               maxwrk = MAX(maxwrk,N+(N-1)                              &
     &                  *ILAENV(1,'ZUNGHR',' ',N,1,N,-1))
               maxwrk = MAX(maxwrk,hswork)
            ENDIF
            lwrk = maxwrk
            IF ( .NOT.wantsn ) lwrk = MAX(lwrk,(N*N)/2)
         ENDIF
         Work(1) = lwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -15
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGEESX',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Sdim = 0
         RETURN
      ENDIF
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = ZLANGE('M',N,N,A,Lda,dum)
      scalea = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         scalea = .TRUE.
         cscale = smlnum
      ELSEIF ( anrm>bignum ) THEN
         scalea = .TRUE.
         cscale = bignum
      ENDIF
      IF ( scalea ) CALL ZLASCL('G',0,0,anrm,cscale,N,N,A,Lda,ierr)
!
!
!     Permute the matrix to make it more nearly triangular
!     (CWorkspace: none)
!     (RWorkspace: need N)
!
      ibal = 1
      CALL ZGEBAL('P',N,A,Lda,ilo,ihi,Rwork(ibal),ierr)
!
!     Reduce to upper Hessenberg form
!     (CWorkspace: need 2*N, prefer N+N*NB)
!     (RWorkspace: none)
!
      itau = 1
      iwrk = N + itau
      CALL ZGEHRD(N,ilo,ihi,A,Lda,Work(itau),Work(iwrk),Lwork-iwrk+1,   &
     &            ierr)
!
      IF ( wantvs ) THEN
!
!        Copy Householder vectors to VS
!
         CALL ZLACPY('L',N,N,A,Lda,Vs,Ldvs)
!
!        Generate unitary matrix in VS
!        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
!        (RWorkspace: none)
!
         CALL ZUNGHR(N,ilo,ihi,Vs,Ldvs,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
      ENDIF
!
      Sdim = 0
!
!     Perform QR iteration, accumulating Schur vectors in VS if desired
!     (CWorkspace: need 1, prefer HSWORK (see comments) )
!     (RWorkspace: none)
!
      iwrk = itau
      CALL ZHSEQR('S',Jobvs,N,ilo,ihi,A,Lda,W,Vs,Ldvs,Work(iwrk),       &
     &            Lwork-iwrk+1,ieval)
      IF ( ieval>0 ) Info = ieval
!
!     Sort eigenvalues if desired
!
      IF ( wantst .AND. Info==0 ) THEN
         IF ( scalea ) CALL ZLASCL('G',0,0,cscale,anrm,N,1,W,N,ierr)
         DO i = 1 , N
            Bwork(i) = SELECT(W(i))
         ENDDO
!
!        Reorder eigenvalues, transform Schur vectors, and compute
!        reciprocal condition numbers
!        (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM)
!                     otherwise, need none )
!        (RWorkspace: none)
!
         CALL ZTRSEN(Sense,Jobvs,Bwork,N,A,Lda,Vs,Ldvs,W,Sdim,Rconde,   &
     &               Rcondv,Work(iwrk),Lwork-iwrk+1,icond)
         IF ( .NOT.wantsn ) maxwrk = MAX(maxwrk,2*Sdim*(N-Sdim))
!
!           Not enough complex workspace
!
         IF ( icond==-14 ) Info = -15
      ENDIF
!
!
!        Undo balancing
!        (CWorkspace: none)
!        (RWorkspace: need N)
!
      IF ( wantvs ) CALL ZGEBAK('P','R',N,ilo,ihi,Rwork(ibal),N,Vs,Ldvs,&
     &                          ierr)
!
      IF ( scalea ) THEN
!
!        Undo scaling for the Schur form of A
!
         CALL ZLASCL('U',0,0,cscale,anrm,N,N,A,Lda,ierr)
         CALL ZCOPY(N,A,Lda+1,W,1)
         IF ( (wantsv .OR. wantsb) .AND. Info==0 ) THEN
            dum(1) = Rcondv
            CALL DLASCL('G',0,0,cscale,anrm,1,1,dum,1,ierr)
            Rcondv = dum(1)
         ENDIF
      ENDIF
!
      Work(1) = maxwrk
!
!     End of ZGEESX
!
      END SUBROUTINE ZGEESX


      real lat(25),pln(25)
      real xlat(25),xp(25),t(25,25),fp(25,25)
      real pi

      pi = 3.141592653589793238

c Read input fields of T,fp.
      ilatmax = 25
      ipmax   = 10
      open(unit=1,file='t_p_lt.j43',status='old')
      read(1,*)
     +  ((xlat(ilat),xp(ip), t(ilat,ip),ilat=1,ilatmax),ip=1,ipmax)
      close(1)
      open(unit=1,file='fp_p_lt.j43',status='old')
      read(1,*)
     +  ((xlat(ilat),xp(ip),fp(ilat,ip),ilat=1,ilatmax),ip=1,ipmax)
      close(1)

c Switch to ln p[bars] coordinate, and to latitude[deg].
      do i=1,ipmax
        pln(i)=(2.d0-xp(i))*log(10.d0)
      enddo
      do i=1,ilatmax
        lat(i)=(90.d0-xlat(i))
      enddo

c Write output p[mbar], lat[deg]:
      open(unit=3,file='fpara.dat',status='unknown')
      write(3,'(1x,i3,1x,i3)') ilatmax,ipmax
      write(3,'(1x,a9,10(1x,f6.2))') ' p[mbar]:',
     +         (1000.*exp(pln(i)),i=1,ipmax)
      write(3,*) 'lat[deg]'
      do ilat=1,ilatmax
        write(3,'(1x,f7.1,2x,10(1x,f6.4))')
     +        lat(ilat),(fp(ilat,ip),ip=1,ipmax)
      enddo
      close(3)

      open(unit=3,file='temperature.dat',status='unknown')
      write(3,'(1x,i3,1x,i3)') ilatmax,ipmax
      write(3,'(1x,a9,10(1x,f6.2))') ' p[mbar]:',
     +         (1000.*exp(pln(i)),i=1,ipmax)
      write(3,*) 'lat[deg]'
      do ilat=1,ilatmax
        write(3,'(1x,f7.1,2x,10(1x,f6.2))')
     +        lat(ilat),(t(ilat,ip),ip=1,ipmax)
      enddo
      close(3)

      end