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

subroutine sub1(a)
  integer :: a
  a = 1
end

! CHECK-LABEL: func @_QPsub1(
! CHECK-SAME:    %[[ARG0:.*]]: !fir.ref<i32>
! CHECK:         %[[C1:.*]] = arith.constant 1 : i32
! CHECK:         fir.store %[[C1]] to %[[ARG0]] : !fir.ref<i32>

subroutine sub2(a, b)
  integer(4) :: a
  integer(8) :: b
  a = b
end

! CHECK-LABEL: func @_QPsub2(
! CHECK:         %[[A:.*]]: !fir.ref<i32> {fir.bindc_name = "a"}
! CHECK:         %[[B:.*]]: !fir.ref<i64> {fir.bindc_name = "b"}
! CHECK:         %[[B_VAL:.*]] = fir.load %arg1 : !fir.ref<i64>
! CHECK:         %[[B_CONV:.*]] = fir.convert %[[B_VAL]] : (i64) -> i32
! CHECK:         fir.store %[[B_CONV]] to %[[A]] : !fir.ref<i32>

integer function negi(a)
  integer :: a
  negi = -a
end

! CHECK-LABEL: func @_QPnegi(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<i32> {fir.bindc_name = "a"}) -> i32 {
! CHECK:         %[[FCTRES:.*]] = fir.alloca i32 {bindc_name = "negi", uniq_name = "_QFnegiEnegi"}
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<i32>
! CHECK:         %[[C0:.*]] = arith.constant 0 : i32
! CHECK:         %[[NEG:.*]] = arith.subi %[[C0]], %[[A_VAL]] : i32
! CHECK:         fir.store %[[NEG]] to %[[FCTRES]] : !fir.ref<i32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<i32>
! CHECK:         return %[[RET]] : i32

real function negr(a)
  real :: a
  negr = -a
end

! CHECK-LABEL: func @_QPnegr(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<f32> {fir.bindc_name = "a"}) -> f32 {
! CHECK:         %[[FCTRES:.*]] = fir.alloca f32 {bindc_name = "negr", uniq_name = "_QFnegrEnegr"}
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<f32>
! CHECK:         %[[NEG:.*]] = arith.negf %[[A_VAL]] : f32
! CHECK:         fir.store %[[NEG]] to %[[FCTRES]] : !fir.ref<f32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<f32>
! CHECK:         return %[[RET]] : f32

complex function negc(a)
  complex :: a
  negc = -a
end

! CHECK-LABEL: func @_QPnegc(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "a"}) -> !fir.complex<4> {
! CHECK:         %[[FCTRES:.*]] = fir.alloca !fir.complex<4> {bindc_name = "negc", uniq_name = "_QFnegcEnegc"}
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[NEG:.*]] = fir.negc %[[A_VAL]] : !fir.complex<4>
! CHECK:         fir.store %[[NEG]] to %[[FCTRES]] : !fir.ref<!fir.complex<4>>

integer function addi(a, b)
  integer :: a, b
  addi = a + b
end

! CHECK-LABEL: func @_QPaddi(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<i32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<i32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca i32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<i32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<i32>
! CHECK:         %[[ADD:.*]] = arith.addi %[[A_VAL]], %[[B_VAL]] : i32
! CHECK:         fir.store %[[ADD]] to %[[FCTRES]] : !fir.ref<i32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<i32>
! CHECK:         return %[[RET]] : i32

integer function subi(a, b)
  integer :: a, b
  subi = a - b
end

! CHECK-LABEL: func @_QPsubi(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<i32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<i32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca i32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<i32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<i32>
! CHECK:         %[[SUB:.*]] = arith.subi %[[A_VAL]], %[[B_VAL]] : i32
! CHECK:         fir.store %[[SUB]] to %[[FCTRES]] : !fir.ref<i32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<i32>
! CHECK:         return %[[RET]] : i32

integer function muli(a, b)
  integer :: a, b
  muli = a * b
end

! CHECK-LABEL: func @_QPmuli(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<i32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<i32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca i32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<i32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<i32>
! CHECK:         %[[MUL:.*]] = arith.muli %[[A_VAL]], %[[B_VAL]] : i32
! CHECK:         fir.store %[[MUL]] to %[[FCTRES]] : !fir.ref<i32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<i32>
! CHECK:         return %[[RET]] : i32

integer function divi(a, b)
  integer :: a, b
  divi = a / b
end

! CHECK-LABEL: func @_QPdivi(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<i32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<i32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca i32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<i32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<i32>
! CHECK:         %[[DIV:.*]] = arith.divsi %[[A_VAL]], %[[B_VAL]] : i32
! CHECK:         fir.store %[[DIV]] to %[[FCTRES]] : !fir.ref<i32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<i32>
! CHECK:         return %[[RET]] : i32

real function addf(a, b)
  real :: a, b
  addf = a + b
end

! CHECK-LABEL: func @_QPaddf(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<f32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<f32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca f32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<f32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<f32>
! CHECK:         %[[ADD:.*]] = arith.addf %[[A_VAL]], %[[B_VAL]] : f32
! CHECK:         fir.store %[[ADD]] to %[[FCTRES]] : !fir.ref<f32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<f32>
! CHECK:         return %[[RET]] : f32

real function subf(a, b)
  real :: a, b
  subf = a - b
end

! CHECK-LABEL: func @_QPsubf(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<f32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<f32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca f32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<f32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<f32>
! CHECK:         %[[SUB:.*]] = arith.subf %[[A_VAL]], %[[B_VAL]] : f32
! CHECK:         fir.store %[[SUB]] to %[[FCTRES]] : !fir.ref<f32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<f32>
! CHECK:         return %[[RET]] : f32

real function mulf(a, b)
  real :: a, b
  mulf = a * b
end

! CHECK-LABEL: func @_QPmulf(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<f32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<f32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca f32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<f32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<f32>
! CHECK:         %[[MUL:.*]] = arith.mulf %[[A_VAL]], %[[B_VAL]] : f32
! CHECK:         fir.store %[[MUL]] to %[[FCTRES]] : !fir.ref<f32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<f32>
! CHECK:         return %[[RET]] : f32

real function divf(a, b)
  real :: a, b
  divf = a / b
end

! CHECK-LABEL: func @_QPdivf(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<f32> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<f32> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca f32
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<f32>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<f32>
! CHECK:         %[[DIV:.*]] = arith.divf %[[A_VAL]], %[[B_VAL]] : f32
! CHECK:         fir.store %[[DIV]] to %[[FCTRES]] : !fir.ref<f32>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<f32>
! CHECK:         return %[[RET]] : f32

complex function addc(a, b)
  complex :: a, b
  addc = a + b
end

! CHECK-LABEL: func @_QPaddc(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca !fir.complex<4>
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[ADD:.*]] = fir.addc %[[A_VAL]], %[[B_VAL]] : !fir.complex<4>
! CHECK:         fir.store %[[ADD]] to %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         return %[[RET]] : !fir.complex<4>

complex function subc(a, b)
  complex :: a, b
  subc = a - b
end

! CHECK-LABEL: func @_QPsubc(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca !fir.complex<4>
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[SUB:.*]] = fir.subc %[[A_VAL]], %[[B_VAL]] : !fir.complex<4>
! CHECK:         fir.store %[[SUB]] to %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         return %[[RET]] : !fir.complex<4>

complex function mulc(a, b)
  complex :: a, b
  mulc = a * b
end

! CHECK-LABEL: func @_QPmulc(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca !fir.complex<4>
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[MUL:.*]] = fir.mulc %[[A_VAL]], %[[B_VAL]] : !fir.complex<4>
! CHECK:         fir.store %[[MUL]] to %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         return %[[RET]] : !fir.complex<4>

complex function divc(a, b)
  complex :: a, b
  divc = a / b
end

! CHECK-LABEL: func @_QPdivc(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "a"},
! CHECK-SAME:    %[[B:.*]]: !fir.ref<!fir.complex<4>> {fir.bindc_name = "b"}
! CHECK:         %[[FCTRES:.*]] = fir.alloca !fir.complex<4>
! CHECK:         %[[A_VAL:.*]] = fir.load %[[A]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[B_VAL:.*]] = fir.load %[[B]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[DIV:.*]] = fir.divc %[[A_VAL]], %[[B_VAL]] : !fir.complex<4>
! CHECK:         fir.store %[[DIV]] to %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         %[[RET:.*]] = fir.load %[[FCTRES]] : !fir.ref<!fir.complex<4>>
! CHECK:         return %[[RET]] : !fir.complex<4>

subroutine real_constant()
  real(2) :: a
  real(4) :: b
  real(8) :: c
  real(10) :: d
  real(16) :: e
  a = 2.0_2
  b = 4.0_4
  c = 8.0_8
  d = 10.0_10
  e = 16.0_16
end

! CHECK: %[[A:.*]] = fir.alloca f16
! CHECK: %[[B:.*]] = fir.alloca f32
! CHECK: %[[C:.*]] = fir.alloca f64
! CHECK: %[[D:.*]] = fir.alloca f80
! CHECK: %[[E:.*]] = fir.alloca f128
! CHECK: %[[C2:.*]] = arith.constant 2.000000e+00 : f16
! CHECK: fir.store %[[C2]] to %[[A]] : !fir.ref<f16>
! CHECK: %[[C4:.*]] = arith.constant 4.000000e+00 : f32
! CHECK: fir.store %[[C4]] to %[[B]] : !fir.ref<f32>
! CHECK: %[[C8:.*]] = arith.constant 8.000000e+00 : f64
! CHECK: fir.store %[[C8]] to %[[C]] : !fir.ref<f64>
! CHECK: %[[C10:.*]] = arith.constant 1.000000e+01 : f80
! CHECK: fir.store %[[C10]] to %[[D]] : !fir.ref<f80>
! CHECK: %[[C16:.*]] = arith.constant 1.600000e+01 : f128
! CHECK: fir.store %[[C16]] to %[[E]] : !fir.ref<f128>

subroutine complex_constant()
  complex(4) :: a
  a = (0, 1)
end

! CHECK-LABEL: func @_QPcomplex_constant()
! CHECK:         %[[A:.*]] = fir.alloca !fir.complex<4> {bindc_name = "a", uniq_name = "_QFcomplex_constantEa"}
! CHECK:         %[[C0:.*]] = arith.constant 0.000000e+00 : f32
! CHECK:         %[[C1:.*]] = arith.constant 1.000000e+00 : f32
! CHECK:         %[[UNDEF:.*]] = fir.undefined !fir.complex<4>
! CHECK:         %[[INS0:.*]] = fir.insert_value %[[UNDEF]], %[[C0]], [0 : index] : (!fir.complex<4>, f32) -> !fir.complex<4>
! CHECK:         %[[INS1:.*]] = fir.insert_value %[[INS0]], %[[C1]], [1 : index] : (!fir.complex<4>, f32) -> !fir.complex<4>
! CHECK:         fir.store %[[INS1]] to %[[A]] : !fir.ref<!fir.complex<4>>

subroutine sub1_arr(a)
  integer :: a(10)
  a(2) = 10
end

! CHECK-LABEL: func @_QPsub1_arr(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<!fir.array<10xi32>> {fir.bindc_name = "a"})
! CHECK-DAG:     %[[C10:.*]] = arith.constant 10 : i32
! CHECK-DAG:     %[[C2:.*]] = arith.constant 2 : i64
! CHECK-DAG:     %[[C1:.*]] = arith.constant 1 : i64
! CHECK:         %[[ZERO_BASED_INDEX:.*]] = arith.subi %[[C2]], %[[C1]] : i64
! CHECK:         %[[COORD:.*]] = fir.coordinate_of %[[A]], %[[ZERO_BASED_INDEX]] : (!fir.ref<!fir.array<10xi32>>, i64) -> !fir.ref<i32>
! CHECK:         fir.store %[[C10]] to %[[COORD]] : !fir.ref<i32>
! CHECK:         return

subroutine sub2_arr(a)
  integer :: a(10)
  a = 10
end

! CHECK-LABEL: func @_QPsub2_arr(
! CHECK-SAME:    %[[A:.*]]: !fir.ref<!fir.array<10xi32>> {fir.bindc_name = "a"})
! CHECK-DAG:     %[[C10_0:.*]] = arith.constant 10 : index
! CHECK:         %[[SHAPE:.*]] = fir.shape %[[C10_0]] : (index) -> !fir.shape<1>
! CHECK:         %[[LOAD:.*]] = fir.array_load %[[A]](%[[SHAPE]]) : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> !fir.array<10xi32>
! CHECK-DAG:     %[[C10_1:.*]] = arith.constant 10 : i32
! CHECK-DAG:     %[[C1:.*]] = arith.constant 1 : index
! CHECK-DAG:     %[[C0:.*]] = arith.constant 0 : index
! CHECK-DAG:     %[[UB:.*]] = arith.subi %[[C10_0]], %c1 : index
! CHECK:         %[[DO_RES:.*]] = fir.do_loop %[[ARG1:.*]] = %[[C0]] to %[[UB]] step %[[C1]] unordered iter_args(%[[ARG2:.*]] = %[[LOAD]]) -> (!fir.array<10xi32>) {
! CHECK:           %[[RES:.*]] = fir.array_update %[[ARG2]], %[[C10_1]], %[[ARG1]] : (!fir.array<10xi32>, i32, index) -> !fir.array<10xi32>
! CHECK:           fir.result %[[RES]] : !fir.array<10xi32>
! CHECK:         }
! CHECK:         fir.array_merge_store %[[LOAD]], %[[DO_RES]] to %[[A]] : !fir.array<10xi32>, !fir.array<10xi32>, !fir.ref<!fir.array<10xi32>>
! CHECK:         return


program main
    use mpi
    implicit none
    integer :: ntasks, rank, ierr
    integer, allocatable :: status(:)
    integer :: clock, n
    integer, allocatable :: seed(:)
    integer(4) :: i, n_tot = 100000000
    real(8), parameter :: l = 0.d0, r = 1.d0, b = 0.d0, t = 1.d0
    real(8) :: x, y, z, H
    real(8) :: integral_local = 0.d0, integral

    ! initialize the MPI environment
    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
    allocate(status(MPI_STATUS_SIZE))

    ! initialize the random number for different processes
    if (rank == 0) then
        call SYSTEM_CLOCK(clock)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
        do i = 1, ntasks - 1
            call RANDOM_NUMBER(x)
            clock = clock + Int(x * 1000000)
            call MPI_SEND(clock, 1, MPI_INTEGER, i, i, MPI_COMM_WORLD, ierr)
        end do
    else
        call MPI_RECV(clock, 1, MPI_INTEGER, 0, rank, MPI_COMM_WORLD, status, ierr)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
    end if

    do i = 1, n_tot
        call RANDOM_NUMBER(x)
        x = x * (r - l) + l
        call RANDOM_NUMBER(y)
        y = y * (t - b) + b
        call func(x, y, z)
        call inArea(x, y, H)
        integral_local = integral_local + z * H
    end do
    integral_local = (r - l) * (t - b) / dble(n_tot) * integral_local

    call MPI_REDUCE(integral_local, integral, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, ierr)

    if (rank == 0) then
        integral = integral / dble(ntasks)
        write(*,'(f10.5)') integral
    end if

    call MPI_FINALIZE(ierr)
end program main

subroutine func(x, y, z)
    ! the function to be integrated
    implicit none
    real(8), intent(in) :: x, y
    real(8), intent(out) :: z

    z = x * y
end subroutine func

subroutine inArea(x, y, H)
    ! judge whether the dot is in the integral area
    real(8), intent(in) :: x, y
    real(8), intent(out) :: H

    H = 1.d0
end subroutine inArea


subroutine coarse_to_fine(e_2h, nx, ny, xi_2h, xf_2h, xi_h, xf_h, e_h)
use parallel_variables
use kind_parameters
implicit none
!include 'mpif.h'

integer, intent(in):: nx, ny, xi_h, xf_h, xi_2h, xf_2h
real(kind=dp), intent(in), dimension(nx,xi_2h-1:xf_2h+1):: e_2h
real(kind=dp), intent(out), dimension(nx*2-2,xi_h-1:xf_h+1):: e_h
!character*50:: filename, string
integer:: i, j, io, jo, ie, je

! Apply linear interpolation to get values from coarse to fine grid
! Input
! e_2h   Variable in coarse grid
! hx, hy     grid spacing
!
! Output
! e_h     Variable in fine grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Indices Rechecked on Jan 13, 2013

do j = xi_h,xf_h

    do i = 2,2*nx-3

    io = (i+1)/2
    jo = (j+1)/2

    ie = i/2
    je = j/2

    if (i .eq. 2) then

        if (j .eq. 2) then

        e_h(i,j) =  (1.0/4.0)*(e_2h(ie,je) + e_2h(ie,je+1) + e_2h(ie+1,je) + e_2h(ie+1,je+1))

        else if (j .eq. 2*ny-3) then

        e_h(i,j) = (1.0/4.0)*(e_2h(ie,jo) + e_2h(ie,jo+1) + e_2h(ie+1,jo) + e_2h(ie+1,jo+1))

        else

            if(mod(j,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(ie,je+1) + 3.0*e_2h(ie+1,je+1) + e_2h(ie,je) + e_2h(ie+1,je))

            else

            e_h(i,j) = (1.0/8.0)*(e_2h(ie,jo+1) + e_2h(ie+1,jo+1) + 3.0*e_2h(ie,jo) + 3.0*e_2h(ie+1,jo))

            end if

        end if

   else if (i .eq. 2*nx-3) then

        if (j .eq. 2) then

        e_h(i,j) =  (1.0/4.0)*(e_2h(io,je) + e_2h(io,je+1) + e_2h(io+1,je) + e_2h(io+1,jo+1))

        else if (j .eq. 2*ny-3) then

        e_h(i,j) = (1.0/4.0)*(e_2h(io,jo) + e_2h(io,jo+1) + e_2h(io+1,jo) + e_2h(io+1,jo+1))

        else

            if(mod(j,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(io,je+1) + 3.0*e_2h(io+1,je+1) + e_2h(io,je) + e_2h(io+1,je))

            else

            e_h(i,j) = (1.0/8.0)*(e_2h(io,jo+1) + e_2h(io+1,jo+1) + 3.0*e_2h(io,jo) + 3.0*e_2h(io+1,jo))

            end if

        end if

    else

        if (j .eq. 2) then

            if(mod(i,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(ie+1,je) + 3.0*e_2h(ie+1,je+1) + e_2h(ie,je) + e_2h(ie,je+1))

            else

            e_h(i,j) = (1.0/8.0)*(e_2h(io+1,je) + e_2h(io+1,je+1) + 3.0*e_2h(io,je) + 3.0*e_2h(io,je+1))

            end if

        else if (j .eq. 2*ny-3) then

            if(mod(i,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(ie+1,jo+1) + 3.0*e_2h(ie+1,jo) + e_2h(ie,jo) + e_2h(ie,jo+1))

            else

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(io,jo+1) + e_2h(io+1,jo+1) + 3.0*e_2h(io,jo) + e_2h(io+1,jo))

            end if

        else

            if (mod(i,2) .ne. 0 .and. mod(j,2) .ne. 0) e_h(i,j) = (1.0/16.0)*(9.0*e_2h(io,jo) + 3.0*e_2h(io,jo+1) + 3.0*e_2h(io+1,jo) + e_2h(io+1,jo+1))
            if (mod(i,2) .eq. 0 .and. mod(j,2) .eq. 0) e_h(i,j) = (1.0/16.0)*(e_2h(ie,je) + 3.0*e_2h(ie,je+1) + 3.0*e_2h(ie+1,je) + 9.0*e_2h(ie+1,je+1))
            if (mod(i,2) .ne. 0 .and. mod(j,2) .eq. 0) e_h(i,j) = (1.0/16.0)*(3.0*e_2h(io,je) + 3.0*e_2h(io+1,je+1) + e_2h(io+1,je) + 9.0*e_2h(io,je+1))
            if (mod(i,2) .eq. 0 .and. mod(j,2) .ne. 0) e_h(i,j) = (1.0/16.0)*(3.0*e_2h(ie,jo) + 3.0*e_2h(ie+1,jo+1) + 9.0*e_2h(ie+1,jo) + e_2h(ie,jo+1))

        end if

    end if

    end do

end do

call exchange_data(e_h, nx*2-2, xi_h, xf_h)

end subroutine


*DECK EXPREL
      FUNCTION EXPREL (X)
C***BEGIN PROLOGUE  EXPREL
C***PURPOSE  Calculate the relative error exponential (EXP(X)-1)/X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      SINGLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  EXPREL(X) = (EXP(X) - 1.0) / X.   For small ABS(X) the
C Taylor series is used.  If X is negative, the reflection formula
C         EXPREL(X) = EXP(X) * EXPREL(ABS(X))
C may be used.  This reflection formula will be of use when the
C evaluation for small ABS(X) is done by Chebyshev series rather than
C Taylor series.  EXPREL and X are single precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   770801  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  EXPREL
      LOGICAL FIRST
      SAVE NTERMS, XBND, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  EXPREL
      IF (FIRST) THEN
         ALNEPS = LOG(R1MACH(3))
         XN = 3.72 - 0.3*ALNEPS
         XLN = LOG((XN+1.0)/1.36)
         NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5
         XBND = R1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      ABSX = ABS(X)
      IF (ABSX.GT.0.5) EXPREL = (EXP(X) - 1.0) / X
      IF (ABSX.GT.0.5) RETURN
C
      EXPREL = 1.0
      IF (ABSX.LT.XBND) RETURN
C
      EXPREL = 0.0
      DO 20 I=1,NTERMS
        EXPREL = 1.0 + EXPREL*X/(NTERMS+2-I)
 20   CONTINUE
C
      RETURN
      END


           program demo_log10
           use, intrinsic :: iso_fortran_env, only : real_kinds, &
           & real32, real64, real128
           implicit none
           real(kind=real64) :: x = 10.0_real64
             x = log10(x)
           end program demo_log10


program yolo
	! compilation et lien: gfortran -O matrice_grad_conj_perso.f90 -o matrice_grad_conj_perso.exe

	! ce code est inspiré du programme "matricegrad".

	! l'objectif est de faire varier la précision pour observer le comportement de réduction du gradient

	!integer,parameter :: p4 = selected_real_kind(6) 	!4
	!integer,parameter :: p8 = selected_real_kind(15)	!8
	!integer,parameter :: p10 = selected_real_kind(16)	!10
	!integer,parameter :: p16 = selected_real_kind(33)	!16

	integer, parameter :: P = 8 ! faire varier

	real(kind=selected_real_kind(P)), allocatable, dimension(:):: x,xx,b
	real(kind=selected_real_kind(P)), allocatable, dimension(:,:):: a
	real(kind=selected_real_kind(P)), allocatable, dimension(:):: gk,agk,dk,adk
	real(kind=selected_real_kind(P)), allocatable, dimension(:):: solg,solgc

	character(len=1024) :: filename

	print *,'Taille matrice ?'
	read(5,*) N

	!real(kind=l), allocatable, dimension(:):: x,xx,b
	!real(kind=l), allocatable, dimension(:,:):: a
	!real(kind=l), allocatable, dimension(:):: gk,agk,dk,adk
	!real(kind=l), allocatable, dimension(:):: solg,solgc

	allocate(x(N))
	allocate(xx(N))
	allocate(b(N))
	allocate(a(N,N))
	allocate(gk(N))
	allocate(agk(N))
	allocate(dk(N))
	allocate(adk(N))
	allocate(solg(N))
	allocate(solgc(N))

	igc=1  ! gradient ou gradient conjugue
	nbgrad=30 ! nbre iterations gradient

	b(1:N)=0

	open(1,file='matrix.dat',status='unknown')
	do i=1,N
		x(i)=i
		do j=1,N
			a(i,j)=exp(-0.05*(i-j)**2)
			write(1,*) i,j,a(i,j)
		enddo
		write(1,'()')
	enddo
	close(1)

	! visualisation de matrix.dat avec gnuplot
	! splot 'matrix.dat' w l

	b=matmul(a,x)  !cible

	!
	!inversion par minimisation d'energie
	! methode de gradient a x = b , il faut retrouver x
	!
	! initialisation

	xx(1:N)=0

	if(igc.eq.0) then

		do 1 iter=1,nbgrad

			!gk=matmul(a,xx)-b

			do i=1,N
				gk(i)=0
				do j=1,N
					gk(i)=gk(i)+a(i,j)*xx(j)
				enddo
				gk(i)=gk(i)-b(i)
			enddo

			!agk=matmul(a,gk)

			do i=1,N
				agk(i)=0
				do j=1,N
					agk(i)=agk(i)+a(i,j)*gk(j)
				enddo
			enddo

			!gkgk=dot_product(gk,gk)
			!agkgk=dot_product(agk,gk)

			gkgk=0
			agkgk=0
			do i=1,N
				gkgk=gkgk+gk(i)**2
				agkgk=agkgk+agk(i)*gk(i)
			enddo

			alphak=gkgk/agkgk

			! xx(1:N)=xx(1:N)-alphak*gk(1:N)

			do i=1,N
				xx(i)=xx(i)-alphak*gk(i)
			enddo

			print *,iter,gkgk

			1 continue  !nbgrad

			solg(1:N)=xx(1:N)

	endif ! igc=0

		if(igc.eq.1) then ! gradient conjugue

			xx(1:N)=0
			gk=matmul(a,xx)-b
			dk(1:N)=gk(1:N)

			do 2 iter=1,nbgrad

				adk=matmul(a,dk)
				gkgk=dot_product(gk,gk)
				adkdk=dot_product(adk,dk)
				alphak=gkgk/adkdk
				xx(1:N)=xx(1:N)-alphak*dk(1:N)
				gk(1:N)=gk(1:N)-alphak*adk(1:N)

				gkgk2=0
				do i=1,N
					gkgk2=gkgk2+gk(i)**2
				enddo
				gkgk2=sqrt(gkgk2);

				gk1gk1=dot_product(gk,gk)
				betak1=gk1gk1/gkgk
				dk(1:N)=gk(1:N)+betak1*dk(1:N)

				print *,iter,gkgk
				! write(77,*) iter,gkgk2

				2 continue

				solgc(1:N)=xx(1:N)

			endif !igc=1

			do i=1,N9
				print *,x(i),solgc(i)
			enddo

			! visu gnuplot :  plot 'sol_ggc16.dat' w l,'sol_ggc16.dat' u 1:3 w l,'sol_ggc16.dat' u 1:4 w l

			write (filename, "(A7,I2,A4)") "sol_ggc", P, ".dat"
			open(1,file=filename,status='unknown')
			do i=1,N
				write(1,*) i,x(i),solgc(i)
			enddo
			close(1)

			print *, "plot 'sol_ggc",P,".dat' u 1:4 w l"

			deallocate(x)
			deallocate(xx)
			deallocate(b)
			deallocate(a)
			deallocate(gk)
			deallocate(agk)
			deallocate(dk)
			deallocate(adk)
			deallocate(solg)
			deallocate(solgc)

			print *,'fin normal'
		end


c     program DRIDRANP
c>> 1996-07-09 DRIDRANP Krogh Added external statement.
c>> 1994-10-19 DRIDRANP Krogh  Changes to use M77CON
c>> 1994-06-23 DRIDRANP Changing name to DRI[D/S]RANP.
c>> 1987-12-09 DRIDRANP  Lawson  Initial Code.
c
c     Driver to demonstrate use of IDRANP to generate random integers
c     from the Poisson distribution with mean, XMEAN.
c     Program computes histogram for N samples.
c     ------------------------------------------------------------------
c--D replaces "?": DRI?RANP, I?RANP, I?STA1, I?STA2
c     ------------------------------------------------------------------
      integer NCELLS, NI
      parameter(NCELLS = 7+2, NI = 100)
      external IDRANP
      integer I, IHIST(NCELLS), IDRANP, ISTATS(3), ITAB(NI), ILOW, J, N
      double precision XMEAN, XSTATS(2)
c
      data N / 10000 /
      data ILOW / 0 /
      data XMEAN / 1.0d0 /
c     ------------------------------------------------------------------
      ISTATS(1) = 0
      do 30 J = 1, N/NI
         do 20 I = 1, NI
c                                   Get random integer.
           ITAB(I) =  IDRANP(XMEAN)
   20    continue
c                                 Accumulate statistics and histogram.
c
        call IDSTA1(ITAB, NI, ISTATS, XSTATS, IHIST, ILOW, NCELLS)
   30 continue
c                             Print the statistics and histogram.
c
      print '(11x,''Poisson random integers from IDRANP'')'
      print '(11x,''with XMEAN = '',g12.4,/1x)', XMEAN
      call IDSTA2(ISTATS, XSTATS, IHIST, ILOW, NCELLS)
      end


      COMPLEX*16 FUNCTION C0IRF(M12,M22,P2)
*------------------------------------------
      IMPLICIT NONE!
*-------------------
      REAL*8 P2,D2,DREAL,DABS
      COMPLEX*16 M12,M22,SQR,P2P,P2M,X1,X2,OMX1,OMX2,F1
      COMPLEX*16 LOG,SQRT,DCMPLX,XSPENZ
      PARAMETER (D2=1.64493406684822618D0)
*
      IF((DREAL(M12).EQ.DREAL(M22)).AND.DREAL(M12).LT.1d-6) THEN
       C0IRF=1D0/P2*(1D0/2D0*(LOG((P2-DCMPLX(0D0,1D-20))/M12))**2-D2)
       RETURN
      ENDIF
*
* General, exact case of C0IR
*
      SQR=SQRT(P2**2+2D0*P2*(M12+M22)+(M12-M22)**2)
      P2P=P2-M12+M22+SQR
      P2M=P2-M12+M22-SQR
      IF(DABS(DREAL(P2P)).GE.DABS(DREAL(P2M))) THEN
        X1=P2P/2D0/P2
        X2=-2D0*M12/P2P
      ELSE
        X2=P2M/2D0/P2
        X1=-2D0*M12/P2M
      ENDIF
      P2P=P2+M12-M22+SQR
      P2M=P2+M12-M22-SQR
      IF(DABS(DREAL(P2P)).GE.DABS(DREAL(P2M))) THEN
        OMX2=P2P/2D0/P2
        OMX1=-2D0*M22/P2P
      ELSE
        OMX1=P2M/2D0/P2
        OMX2=-2D0*M22/P2M
      ENDIF
*
      C0IRF=1D0/2/SQR*(
     &      LOG((P2-DCMPLX(0D0,1D-20))/M12)*LOG(-X1/X2)
     &     +LOG((P2-DCMPLX(0D0,1D-20))/M22)*LOG(-OMX2/OMX1)
     & +.5D0*LOG( OMX2*(X1-X2))**2
     & -.5D0*LOG(  -X2*(X1-X2))**2
     & -.5D0*LOG(-OMX1*(X1-X2))**2
     & +.5D0*LOG(   X1*(X1-X2))**2
     & -XSPENZ(OMX2/(X1-X2))+XSPENZ((-X2)/(X1-X2))
     & +XSPENZ(OMX1/(X2-X1))-XSPENZ((-X1)/(X2-X1)) )
*
      RETURN
      END


subroutine build_grids
    use grids; use dimensions; use structural_p1;use files_savings
    implicit none
    integer::i_l,j_l
    real(SP)::sigma2_xi

    !Grid of cash on hand
    coh_grid(1)=coh_min
    do i_l=2,nkk
        coh_grid(i_l)=(coh_max-coh_min)/real(nkk-1)*real(i_l-1)
    end do

    !Upload medical expenditures parameter process
    open(unit=10,file=fdir_med//"med_coef.txt")
        read(10,*) med_coef
    close(10)
    rho=med_coef(13,1)
    sigma2_ep=med_coef(14,1)
    sigma2_ze=med_coef(15,1)

    !Grid for persistent and transitory shock of medical expenditures using quadrature methods
    call discretize_shocks(rho,sigma2_ep,sigma2_ze,nzz,ep_grid,pr_ep,xi_grid,pr0_xi,pr_pxi)

end subroutine


*DECK GAMIT
      REAL FUNCTION GAMIT (A, X)
C***BEGIN PROLOGUE  GAMIT
C***PURPOSE  Calculate Tricomi's form of the incomplete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (GAMIT-S, DGAMIT-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB,
C             SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   Evaluate Tricomi's incomplete gamma function defined by
C
C   GAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) *
C             T**(A-1.)
C
C   for A .GT. 0.0 and by analytic continuation for A .LE. 0.0.
C   GAMMA(X) is the complete gamma function of X.
C
C   GAMIT is evaluated for arbitrary real values of A and for non-
C   negative values of X (even though GAMIT is defined for X .LT.
C   0.0), except that for X = 0 and A .LE. 0.0, GAMIT is infinite,
C   which is a fatal error.
C
C   The function and both arguments are REAL.
C
C   A slight deterioration of 2 or 3 digits accuracy will occur when
C   GAMIT is very large or very small in absolute value, because log-
C   arithmic variables are used.  Also, if the parameter  A  is very
C   close to a negative integer (but not a negative integer), there is
C   a loss of accuracy, which is reported if the result is less than
C   half machine precision.
C
C***REFERENCES  W. Gautschi, A computational procedure for incomplete
C                 gamma functions, ACM Transactions on Mathematical
C                 Software 5, 4 (December 1979), pp. 466-481.
C               W. Gautschi, Incomplete gamma functions, Algorithm 542,
C                 ACM Transactions on Mathematical Software 5, 4
C                 (December 1979), pp. 482-489.
C***ROUTINES CALLED  ALGAMS, ALNGAM, GAMR, R1MACH, R9GMIT, R9LGIC,
C                    R9LGIT, XERCLR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  GAMIT
      LOGICAL FIRST
      SAVE ALNEPS, SQEPS, BOT, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  GAMIT
      IF (FIRST) THEN
         ALNEPS = -LOG(R1MACH(3))
         SQEPS = SQRT(R1MACH(4))
         BOT = LOG(R1MACH(1))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMIT', 'X IS NEGATIVE',
     +   2, 2)
C
      IF (X.NE.0.0) ALX = LOG(X)
      SGA = 1.0
      IF (A.NE.0.0) SGA = SIGN (1.0, A)
      AINTA = AINT (A+0.5*SGA)
      AEPS = A - AINTA
C
      IF (X.GT.0.0) GO TO 20
      GAMIT = 0.0
      IF (AINTA.GT.0.0 .OR. AEPS.NE.0.0) GAMIT = GAMR(A+1.0)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 40
      IF (A.GE.(-0.5) .OR. AEPS.NE.0.0) CALL ALGAMS (A+1.0, ALGAP1,
     1  SGNGAM)
      GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX)
      RETURN
C
 40   IF (A.LT.X) GO TO 50
      T = R9LGIT (A, X, ALNGAM(A+1.0))
      IF (T.LT.BOT) CALL XERCLR
      GAMIT = EXP(T)
      RETURN
C
 50   ALNG = R9LGIC (A, X, ALX)
C
C EVALUATE GAMIT IN TERMS OF LOG(GAMIC(A,X))
C
      H = 1.0
      IF (AEPS.EQ.0.0 .AND. AINTA.LE.0.0) GO TO 60
      CALL ALGAMS (A+1.0, ALGAP1, SGNGAM)
      T = LOG(ABS(A)) + ALNG - ALGAP1
      IF (T.GT.ALNEPS) GO TO 70
      IF (T.GT.(-ALNEPS)) H = 1.0 - SGA*SGNGAM*EXP(T)
      IF (ABS(H).GT.SQEPS) GO TO 60
      CALL XERCLR
      CALL XERMSG ('SLATEC', 'GAMIT', 'RESULT LT HALF PRECISION', 1, 1)
C
 60   T = -A*ALX + LOG(ABS(H))
      IF (T.LT.BOT) CALL XERCLR
      GAMIT = SIGN (EXP(T), H)
      RETURN
C
 70   T = T - A*ALX
      IF (T.LT.BOT) CALL XERCLR
      GAMIT = -SGA*SGNGAM*EXP(T)
      RETURN
C
      END


!*****************************************************************************
! Conduction in Hollow Cylinder with Heat Generation

!                                Adiabatic
!                ________________________________________
!               |                |           |           |
!               |                |S=200-0.1T |           |
!               |                |    k=4    |           |
!               |                |___________|           |
!               |                                        | <-
!  T = T0(y+1)  |                                        | <- q'' = 50
!               |          T0 = 20                       | <-
!               |          k = 2                         |
!               |                                        |
!               |                                        |
!               |                                        |
!               |________________________________________|
!                              -> -> -> -> ->
!                              h = 50, Tf = 5
!

!  Length = 2.0
!  Thickness = 1.0
!  Inner radius = 1.0
!  Thermal conductivity = 2.0
!  initial temperature = 20
!  A heating region with a different conductivity (S=80-2T, k=1)

!  B.C.:
!       left - prescribed temperature
!       right - constant heat flux
!       top - adiabatic
!       bottom - convective heat flux

!   Finite volume method, steady state simulation
!   Solves temperature only.
!   Problem is specified in module user.

!!*****************************************************************************
module vars
implicit none
character(len=80) :: errmsg
integer, parameter :: dp = selected_real_kind(15)
integer, parameter :: max_nq = 10 ! max no. of variables to solve
integer :: nq ! 1=u, 2=v, 3=p, 4=T
integer :: ierr
integer :: ni, nj, nim1, njm1, nim2, njm2
integer :: icrd ! 1:Cartisian 2:Cylindrical 3:Polar
integer :: iadv ! 1:CDS 2:UDS 3:Hybrid 4:Power-law
integer :: imon = 2, jmon = 2, ipref = 1, jpref = 1
integer :: iter = 0, screen_iter = 100, max_iter = 10000
integer, dimension(max_nq) :: nsweep = 3 ! number of sweeps for TDMA
logical :: llast = .false.
logical :: ltec = .false., ltxt = .false.
logical, dimension(max_nq) :: lsolve = .false.
logical, dimension(max_nq) :: lprint = .false.
real(dp) :: xstart, xend, ystart, yend, rstart
real(dp) :: den_ini = 1.0_dp, cp_ini = 1.0_dp ! initial rho and cp
real(dp), dimension(max_nq) :: urf = 0.8_dp ! under-relaxation factor
real(dp), dimension(max_nq) :: resor = 0.0_dp ! residual
real(dp), allocatable, dimension(:) :: x, xu, xdif, sew, sewu, xcvi, xcvip
real(dp), allocatable, dimension(:) :: y, yv, ydif, sns, snsv, ycvr, ycvrs
real(dp), allocatable, dimension(:) :: arx, arxj, arxjp, r, rmn, sx, sxmn
real(dp), allocatable, dimension(:) :: fv, fvp, fx, fxm
real(dp), allocatable, dimension(:) :: fy, fym
real(dp), allocatable, dimension(:,:) :: u, v, p, pp, du, dv, t, uc, vc
real(dp), allocatable, dimension(:,:) :: den, gam, cp
real(dp), allocatable, dimension(:,:) :: ae, aw, an, as, ap, su, sp
end module vars

module user
! case of study
use vars
implicit none
integer :: ibnd = 2 ! boundary treatment 1:boundary value update
!                                        2:additional source term
integer :: is1, is2, js1, js2 ! region of heating
real(dp) :: t0, gam0, gam1, htc, tf, qin, qwall
contains

subroutine control()
! mesh input
implicit none
icrd = 2 ! 1:Cartesian 2:Axisym cylind 3:polar
! solution domain
ni = 52
nj = 52
xstart = 0.0_dp
xend = 2.0_dp
ystart = 0.0_dp
yend = 1.0_dp
rstart = 1.0_dp
! control params
lsolve(1:3) = .false.
lsolve(4) = .true.
lprint(1:3) = .false.
lprint(4) = .true.
ltec = .true.
ltxt = .false.
iadv = 1 ! 1:CDS 2:UDS 3:Hybrid 4:Power-law
max_iter = 19999 ! max iteration
screen_iter = 500 ! interval for screen print
urf(1) = 0.3_dp
urf(2) = 0.3_dp
urf(3) = 0.9_dp
urf(4) = 1.0_dp
nsweep(1) = 3
nsweep(2) = 3
nsweep(3) = 3
nsweep(4) = 3
imon = ni / 2
jmon = nj / 2
end subroutine control

subroutine initial()
! initial values and unchanged b.c.
implicit none
integer :: i, j
is1 = ni/2 - 10
is2 = ni/2 + 10
js2 = nj
js1 = js2 - 20
gam0 = 3.0_dp ! thermal conductivity of the domain
gam1 = 1.0_dp ! thermal conductivity of the heating material
qin = 50.0_dp ! heat input at south boundary
htc = 50.0_dp ! convective heat transfer coef of cooling fluid
t0 = 20.0_dp ! initial temperature
tf = 10.0_dp ! temperature of cooling fluid
t(2:,:) = t0
t(1,:) = t0 * (1.0_dp + y(:)) ! temperature at left boundary
end subroutine initial

subroutine density()
! specify fluid density as function of temperature
implicit none
end subroutine density

subroutine boundary()
! update boundary
implicit none
if (ibnd == 2 .and. .not.llast) return ! boundary only update at last
t(2:nim1,nj) = t(2:nim1,njm1) ! north
t(2:nim1,1) = (gam0*t(2:nim1,2) + htc*ydif(2)*tf) / (gam0 + htc*ydif(2)) ! south
t(ni,2:njm1) = t(nim1,2:njm1) + qin * xdif(ni) / gam0 ! east
end subroutine boundary

subroutine gamsor()
! set and update diffusion coefficients
! store sp and su of variables
! set up additional source terms
! diffusion coefs
implicit none
integer :: i, j
gam(:,:) = gam0
gam(is1:is2,js1:js2) = gam1
su(is1:is2,js1:js2) = 200.0_dp ! linear source term
sp(is1:is2,js1:js2) = -0.1_dp ! heat generation
if (ibnd == 1) return ! no further treatment, boundary value is updated
gam(2:nim1,nj) = 0.0_dp ! north, adiabatic
do i = 2, nim1 ! south
  su(i,2) = su(i,2) + r(1)/arx(2) * tf / (ydif(2)/gam(i,2) + 1.0_dp/htc)
  sp(i,2) = sp(i,2) - r(1)/arx(2) / (ydif(2)/gam(i,2) + 1.0_dp/htc)
  gam(i,1) = 0.0_dp
end do
su(nim1,2:njm1) = su(nim1,2:njm1) + qin / sew(nim1) ! east +q*A/V
gam(ni,2:njm1) = 0.0_dp ! east
end subroutine gamsor

subroutine output()
! output to screen and files.
implicit none
integer :: i, j
if (.not.llast) then
  if (mod(iter, screen_iter) == 0) then
    write(*,'(/,a,i6,4(1x,a,es10.3),/,11x,*(1x,a,es13.6))') &
            'Iter=', iter, 'URes=', resor(1), 'VRes=', resor(2), 'MRes=', resor(3), &
            'TRes=', resor(4), 'U=', u(imon,jmon), 'V=', v(imon,jmon), &
            'P=', p(imon,jmon), 'T=', t(imon,jmon)
  end if
  ! this is a rather crude convergence criterion
  if (maxval(resor) < 1.0e-10_dp .or. iter == max_iter-1) llast = .true.
else
! write to screen
  qwall = 0.0_dp
  do j = 2, njm1
    qwall = qwall + gam(1,j)*(y(j)-y(j-1))*(t(1,j)-t(2,j))/(x(2)-x(1))
  end do
  write(*,'(/,a,/)') 'Conduction in Hollow Cylinder'
  write(*,*) 'Finite Volume Method'
  if (any(lsolve(:3))) then ! if flow is solved
    if (iadv == 1) then
      write(*,*) 'CDS for advection'
    else if (iadv == 3) then
      write(*,*) 'Hybrid for advection'
    else if (iadv == 4) then
      write(*,*) 'Power-law for advection'
    else
      write(*,*) 'UDS for advection'
    end if
  end if
  write(*,'(/,2a,i3,3x,a,i3)') 'Grid: ', 'x-cv = ', ni-2, 'y-cv = ', nj-2
  write(*,'(/,a)') 'Values at monitor:'
  write(*,'(*(a,es10.3,3x))') 'x_mon =', x(imon), 'y_mon =', y(jmon)
  write(*,'(*(a,es18.10,3x))') 'u_mon =', uc(imon,jmon), &
          'v_mon =', vc(imon,jmon), 't_mon =', t(imon,jmon)
  write(*,'(a,1x,es12.5)') 'Qwall_west = ', qwall
  ! write to tecplot
  if (ltec) then
    open(unit=1, file='result.dat', status='replace')
    write(1,*) 'title="Natural Convection in a Square Cavity"'
    write(1,*) 'variables="x", "y", "Cond", "T"'
    write(1,'(a,2x,a,i3,2x,a,i3,2x,a)') 'zone', 'i=', ni, 'j=', nj, 'f=point'
    do j = 1, nj
      do i = 1, ni
        write(1,'(*(1x,es14.7))') x(i), y(j), &
                                  gam(i,j), t(i,j)
      end do
    end do
    close(1)
  end if
  ! write to text files
  if (ltxt) then
    open(unit=2, file='uvel.txt', status='replace')
    do j = 1, nj
      write(2,'(*(1x,es14.7))') x(imon), y(j), uc(imon,j)
    end do
    open(unit=3, file='vvel.txt', status='replace')
    do i = 1, ni
      write(3,'(*(1x,es14.7))') x(i), y(jmon), vc(i,jmon)
    end do
    close(2); close(3)
  end if
end if
end subroutine output

end module user

module serv
use vars, only: dp
implicit none
contains

function DAPEC(flow, diff, iadv)
! calculate D*A(Pe) for aw and as
implicit none
integer, intent(in) :: iadv ! 1:CDS, 2:UDS, 3:Hybrid, 4:Power-law
real(dp), intent(in) :: diff, flow
real(dp) :: DAPEC
real(dp) :: temp
if (flow == 0.0_dp) then ! diffusion only
  DAPEC = diff
  return
end if
select case(iadv)
case(1) ! CDS
  DAPEC = diff - 0.5_dp*abs(flow)
case(2) ! UDS
  DAPEC = diff
case(3) ! Hybrid
  DAPEC = max(0.0_dp, diff-0.5_dp*abs(flow))
case(4) ! Power-law
  DAPEC = max(0.0_dp, (1.0_dp-0.1_dp*abs(flow/diff))**5)
  DAPEC = DAPEC * diff
case default ! UDS
  DAPEC = diff
end select
end function DAPEC

function ARIMEAN(phi1, phi2, wf2)
! arithmetic mean
implicit none
real(dp), intent(in) :: phi1, phi2, wf2
real(dp) :: ARIMEAN
ARIMEAN = phi1 * (1 - wf2) + phi2 * wf2
end function ARIMEAN

function HARMEAN(phi1, phi2, wf2)
! harmonic mean
implicit none
real(dp), intent(in) :: phi1, phi2, wf2
real(dp) :: HARMEAN
HARMEAN = phi1 * phi2 / (phi1 * (1.0_dp - wf2) + phi2 * wf2)
end function HARMEAN

end module serv
!*****************************************************************************
program main
! main program
use vars
use user
implicit none
call control()
call array_init()
call grid()
call initial()
do iter = 1, max_iter
  call boundary()
  if (lsolve(1)) then
    call calcu()
    call calcv()
    call calcp()
  end if
  if (lsolve(4)) call calct
  if (llast) exit
  call output()
end do
call postproc()
call output()
call array_close()
stop
end program main
!*****************************************************************************
subroutine grid()
! Cell centred, backward staggered, uniform
use vars
implicit none
integer :: i, j
real(dp) :: dx, dy
!                   w                 e
!        W          |        P        |         E
!                   ^                 ^
!      x(i-1)     xu(i)     x(i)    xu(i+1)   x(i+1)

! wf_e = (x_e-x_P)/(x_E-x_P)
! phi_e = phi_E * wf_e + phi_P * (1 - wf_e)
! Uniform grid is used in this program
nim1 = ni - 1
nim2 = ni - 2
njm1 = nj - 1
njm2 = nj - 2
dx = (xend-xstart)/(ni-2)
xu(2) = xstart
do i = 3, ni
  xu(i) = xu(i-1) + dx
end do
sew(2:nim1) = xu(3:ni) - xu(2:nim1)
x(1) = xu(2) ! = 0
x(2:nim1) = 0.5_dp*(xu(2:nim1)+xu(3:ni)) ! cell-centred
x(ni) = xu(ni)
xdif(2:ni) = x(2:ni) - x(1:nim1) ! distance between nodes
sewu(3:nim1) = xdif(3:nim1) ! u-cv
sewu(3) = sewu(3) + xdif(2) ! u-cv at west boundary
sewu(nim1) = sewu(nim1) + xdif(ni) ! u-cv at east boundary
xcvi(3:nim2) = 0.5_dp*sew(3:nim2) ! first half of cv
xcvip(3:nim2) = xcvi(3:nim2) ! second half of cv
xcvip(2) = sew(2) ! west boundary
xcvi(nim1) = sew(nim1) ! east boundary
dy = (yend-ystart)/(nj-2)
yv(2) = ystart
do j = 3, nj
  yv(j) = yv(j-1) + dy
end do
sns(2:njm1) = yv(3:nj) - yv(2:njm1)
y(1) = yv(2) ! = 0
y(2:njm1) = 0.5_dp*(yv(2:njm1)+yv(3:nj))
y(nj) = yv(nj)
ydif(2:nj) = y(2:nj) - y(1:njm1)
snsv(3:njm1) = ydif(3:njm1)
snsv(3) = snsv(3) + ydif(2)
snsv(njm1) = snsv(njm1) + ydif(nj)
r(1) = rstart ! starting radius
if (icrd == 1) then ! Cartesian
  rmn(:) = 1.0_dp ! norminal radius
  r(:) = 1.0_dp
else ! Cylind and polar
  do j = 2, nj ! r(1) specified
    r(j) = r(j-1) + ydif(j)
  end do
  rmn(2) = r(1) ! cell face starts from 2
  do j = 3, nj
    rmn(j) = rmn(j-1) + sns(j-1) ! radial position of v(i,j)
  end do
end if
sx(:) = 1.0_dp
sxmn(:) = 1.0_dp
if (icrd == 3) then ! polar
  sx(:) = r(:)
  sxmn(2:) = rmn(2:) ! cell face starts from 2
end if
ycvr(2:njm1) = r(2:njm1)*sns(2:njm1) ! w-e area
arx(2:njm1) = ycvr(2:njm1) ! area normal to x
if (icrd == 3) arx(:) = sns(:)
ycvrs(4:njm2) = 0.5_dp*(r(4:njm2)+r(3:njm2-1))*ydif(4:njm2) ! w-e area of v(i,j)
ycvrs(3) = 0.5_dp*(r(3)+r(1))*snsv(3)
ycvrs(njm1) = 0.5_dp*(r(nj)+r(njm2))*snsv(njm1)
if (icrd == 2) then ! cylind
  arxj(3:njm2) = 0.25_dp*(1.0_dp+rmn(3:njm2)/r(3:njm2))*arx(3:njm2)
  arxjp(3:njm2) = arx(3:njm2) - arxj(3:njm2)
else
  arxj(3:njm2) = 0.5_dp*arx(3:njm2)
  arxjp(3:njm2) = arxj(3:njm2)
end if
arxjp(2) = arx(2) ! south boundary
arxj(njm1) = arx(njm1) ! north boundary
! interpolation factors
fv(3:njm2) = arxjp(3:njm2) / arx(3:njm2)
fvp(3:njm2) = 1.0_dp - fv(3:njm2)
fx(2:ni) = 0.5_dp*sew(1:nim1)/xdif(2:ni)
fxm(2:ni) = 1.0_dp - fx(2:ni)
fy(2:nj) = 0.5_dp*sns(1:njm1)/ydif(2:nj)
fym(2:nj) = 1.0_dp - fy(2:nj)
! initialise density and specific heat
den(:,:) = den_ini
cp(:,:) = cp_ini
end subroutine grid

subroutine calcu()
! u control volume using compass notation
use vars
use serv, only: DAPEC, ARIMEAN, HARMEAN
use user, only: gamsor
implicit none
integer :: i, j, n
real(dp) :: vis_ne, vis_nw ! viscosity at north corners of u-cv
real(dp) :: vol, fl, flm, flp, flow, diff, acof
real(dp) :: reseq
nq = 1
call clrsor()
call gamsor()
do i = 3, njm1 ! south boundary for as(i,2)
  fl = xcvi(i) * v(i,2) * den(i,1)
  flm = xcvip(i-1) * v(i-1,2) * den(i-1,1)
  flow = r(1) * (fl+flm)
  diff = r(1) * (xcvi(i)*gam(i,1)+xcvip(i-1)*gam(i-1,1)) / ydif(2)
  acof = DAPEC(flow, diff, iadv) ! get D*A(Pe)
  as(i,2) = acof + max(0.0_dp, flow)
end do
resor(1) = 0.0_dp
do j = 2, njm1
  ! calculate aw
  flow = arx(j) * u(2,j) * den(1,j) ! west boundary for aw(3,j)
  diff = arx(j) * gam(1,j) / (sew(2)*sx(j))
  acof = DAPEC(flow, diff, iadv)
  aw(3,j) = acof + max(0.0_dp, flow)
  do i = 3, njm1
    if (i == njm1) then ! east boundary for aw(ni,j)
      flow = arx(j) * u(ni,j) *den(ni,j)
      diff = arx(j) * gam(ni,j) / (sew(nim1)*sx(j))
    else
      fl = u(i,j) * ARIMEAN(den(i-1,j), den(i,j), fx(i))
      flp = u(i+1,j) * ARIMEAN(den(i,j), den(i+1,j), fx(i+1))
      flow = arx(j) * 0.5_dp * (fl+flp)
      diff = arx(j) * gam(i,j) / (sew(i)*sx(j))
    end if
    acof = DAPEC(flow, diff, iadv)
    aw(i+1,j) = acof + max(0.0_dp, flow)
    ae(i,j) = aw(i+1,j) - flow ! relationship
    if (j == njm1) then
      fl = xcvi(i) * v(i,nj) * den(i,nj)
      flm = xcvip(i-1) * v(i-1,nj) * den(i-1,nj)
      diff = r(nj) * (xcvi(i)*gam(i,nj)+xcvip(i-1)*gam(i-1,nj)) / ydif(nj)
    else
      fl = xcvi(i) * v(i,j+1) * ARIMEAN(den(i,j), den(i,j+1), fy(j+1))
      flm = xcvip(i-1) * v(i-1,j+1) * ARIMEAN(den(i-1,j), den(i-1,j+1), fy(j+1))
      vis_ne = HARMEAN(gam(i,j), gam(i,j+1), fy(j+1))
      vis_nw = HARMEAN(gam(i-1,j), gam(i-1,j+1), fy(j+1))
      diff = rmn(j+1) * (vis_ne*xcvi(i)+vis_nw*xcvip(i-1)) / ydif(j+1)
    end if
    flow = rmn(j+1) * (fl + flm)
    acof = DAPEC(flow, diff, iadv)
    as(i,j+1) = acof + max(0.0_dp, flow)
    an(i,j) = as(i,j+1) - flow
    vol = ycvr(j) * sewu(i)
    ! source
    su(i,j) = su(i,j) * vol
    sp(i,j) = sp(i,j) * vol
    ! pressure gradient term
    du(i,j) = vol / (xdif(i)*sx(j)) ! linear interp for boundary pressure
    su(i,j) = su(i,j) + du(i,j)*(p(i-1,j)-p(i,j))
    ! assemble and under-relax
    ap(i,j) = ae(i,j) + aw(i,j) + an(i,j) + as(i,j) - sp(i,j)
    reseq = ap(i,j)*u(i,j) - ae(i,j)*u(i+1,j) - aw(i,j)*u(i-1,j) &
          - an(i,j)*u(i,j+1) -as(i,j)*u(i,j-1) - su(i,j)
    resor(1) = resor(1) + abs(reseq)
    ap(i,j) = ap(i,j) / urf(1)
    su(i,j) = su(i,j) + (1-urf(1))*ap(i,j)*u(i,j)
    du(i,j) = du(i,j) / ap(i,j) ! for pressure correction
  end do
end do
do n = 1, nsweep(1)
  call tdma(3, 2, ni, nj, u)
end do
end subroutine calcu

subroutine calcv()
use vars
use serv, only: DAPEC, ARIMEAN, HARMEAN
use user, only: gamsor
implicit none
integer :: i, j, n
real(dp) :: vis_ne, vis_se, gm, gmm
real(dp) :: area, vol, fl, flm, flp, flow, diff, acof
real(dp) :: reseq
nq = 2
call clrsor()
call gamsor()
do i = 2, nim1
  ! calculate as(i,3) from south boundary
  area = r(1) * sew(i)
  flow = area * v(i,2) * den(i,1)
  diff = area * gam(i,1) * sns(2)
  acof = DAPEC(flow, diff, iadv)
  as(i,3) = acof + max(0.0_dp, flow)
end do
resor(2) = 0.0_dp
do j = 3, njm1
  fl = arxj(j) * u(2,j) * den(1,j)
  flm = arxjp(j-1) * u(2,j-1) * den(1,j-1)
  flow = fl + flm
  diff = (arxj(j)*gam(1,j) + arxjp(j-1)*gam(1,j-1)) / (xdif(2)*sxmn(j))
  acof = DAPEC(flow, diff, iadv)
  aw(2,j) = acof + max(0.0_dp, flow)
  do i = 2, nim1
    if (i == nim1) then ! east bound for aw(i+1)
      fl = arxj(j) * u(ni,j) * den(ni,j)
      flm = arxjp(j-1) * u(ni,j-1) * den(ni,j-1)
      diff = (arxj(j)*gam(ni,j) + arxjp(j-1)*gam(ni,j-1)) / (xdif(ni)*sxmn(j))
    else
      fl = arxj(j) * u(i+1,j) * ARIMEAN(den(i,j), den(i+1,j), fx(i+1))
      flm = arxjp(j-1) * u(i+1,j-1) * ARIMEAN(den(i,j-1), den(i+1,j-1), fx(i+1))
      vis_ne = HARMEAN(gam(i,j), gam(i+1,j), fx(i+1))
      vis_se = HARMEAN(gam(i,j-1), gam(i+1,j-1), fx(i+1))
      diff = (vis_ne*arxj(j) + vis_se*arxjp(j-1)) / (xdif(i+1)*sxmn(j))
    end if
    flow = fl + flm
    acof = DAPEC(flow, diff, iadv)
    aw(i+1,j) = acof + max(0.0_dp, flow)
    ae(i,j) = aw(i+1,j) - flow
    if (j == njm1) then
      area = r(nj) * sew(i) ! north bound
      flow = area * v(i,nj) * den(i,nj)
      diff = area * gam(i,nj) / sns(njm1)
    else
      area = r(j) * sew(i) ! north face of v-cv
      fl = v(i,j) * rmn(j)*sew(i) * ARIMEAN(den(i,j-1), den(i,j), fy(j))
      flp = v(i,j+1) * rmn(j+1)*sew(i) * ARIMEAN(den(i,j), den(i,j+1), fy(j+1))
      flow = ARIMEAN(fl, flp, fvp(j))
      diff = area * gam(i,j) / sns(j)
    end if
    acof = DAPEC(flow, diff, iadv)
    as(i,j+1) = acof + max(0.0_dp, flow)
    an(i,j) = as(i,j+1) - flow
    vol = ycvrs(j) * sew(i) ! v-cv volume
    ! source
    su(i,j) = su(i,j) * vol
    sp(i,j) = sp(i,j) * vol
    dv(i,j) = vol / ydif(j)
    su(i,j) = su(i,j) + dv(i,j)*(p(i,j-1)-p(i,j))
    ! assemble and under-relax
    ap(i,j) = ae(i,j) + aw(i,j) + an(i,j) + as(i,j) - sp(i,j)
    reseq = ap(i,j)*v(i,j) - ae(i,j)*v(i+1,j) - aw(i,j)*v(i-1,j) &
          - an(i,j)*v(i,j+1) - as(i,j)*v(i,j-1) - su(i,j)
    resor(2) = resor(2) + abs(reseq)
    ap(i,j) = ap(i,j) / urf(2)
    su(i,j) = su(i,j) + (1.0_dp-urf(2))*ap(i,j)*v(i,j)
    dv(i,j) = dv(i,j) / ap(i,j)
  end do
end do
do n = 1, nsweep(2)
  call tdma(2, 3, ni, nj, v)
end do
end subroutine calcv

subroutine calcp()
! solve pressure correction equation in main cv
! SIMPLE algorithm
use vars
use serv, only: DAPEC, ARIMEAN, HARMEAN
use user, only: gamsor
implicit none
integer :: i, j, n
real(dp) :: areaew, arean, areas, vol ! face areas and cell volume
real(dp) :: dene, denw, denn, dens ! face densities
real(dp) :: ce, cw, cn, cs ! convection coefs
real(dp) :: ppref ! reference pressure correction
nq = 3
call clrsor()
call gamsor()
do j = 2, njm1
  do i = 2, nim1
    vol = ycvr(j) * sew(i)
    sp(i,j) = sp(i,j) * vol
    su(i,j) = su(i,j) * vol ! extra sources
  end do
end do
do i = 2, nim1 ! as(i,2)
  areas = rmn(2) * sew(i) ! area of south bound
  cs = den(i,1) * v(i,2) * areas
  su(i,2) = su(i,2) + cs
  as(i,2) = 0.0_dp ! adiabatic-like
end do
resor(3) = 0.0_dp
do j = 2, njm1 ! aw(2,j)
  areaew = arx(j)
  cw = den(1,j) * u(2,j) * areaew
  su(2,j) = su(2,j) + cw
  aw(2,j) = 0.0_dp
  do i = 2, nim1
    if (i == nim1) then ! ae(nim1,j)
      ce = den(ni,j) * u(ni,j) * areaew
      su(i,j) = su(i,j) - ce
      ae(i,j) = 0.0_dp
    else
      dene = ARIMEAN(den(i,j), den(i+1,j), fx(i+1))
      ce = den(i+1,j) * u(i+1,j) * areaew
      su(i,j) = su(i,j) - ce
      ae(i,j) = dene * areaew * du(i+1,j)
      su(i+1,j) = su(i+1,j) + ce
      aw(i+1,j) = ae(i,j) ! relationship
    end if
    arean = rmn(j+1) * sew(i)
    if (j == njm1) then ! an(i,njm1)
      cn = den(i,nj) * v(i,nj) * arean
      su(i,j) = su(i,j) - cn
      an(i,j) = 0.0_dp
    else
      denn = ARIMEAN(den(i,j), den(i,j+1), fy(j+1))
      cn = denn * v(i,j+1) * arean
      su(i,j) = su(i,j) - cn
      an(i,j) = denn * arean * dv(i,j+1)
      su(i,j+1) = su(i,j+1) + cn
      as(i,j+1) = an(i,j) ! relationship
    end if
    ap(i,j) = ae(i,j) + aw(i,j) + an(i,j) + as(i,j) - sp(i,j)
    resor(3) = resor(3) + abs(su(i,j))
    pp(i,j) = 0.0_dp ! initial pressure correction field
  end do
end do
do n = 1, nsweep(3)
  call tdma(2, 2, ni, nj, pp)
end do
! update u, v, p
ppref = pp(ipref,jpref)
do j = 2, njm1
  do i = 2, nim1
    p(i,j) = p(i,j) + urf(3)*(pp(i,j)-ppref)
    if (i /= 2) u(i,j) = u(i,j) + du(i,j)*(pp(i-1,j)-pp(i,j))
    if (j /= 2) v(i,j) = v(i,j) + dv(i,j)*(pp(i,j-1)-pp(i,j))
  end do
end do
end subroutine calcp

subroutine calct()
use vars
use serv, only: DAPEC, ARIMEAN, HARMEAN
use user, only: gamsor
implicit none
integer :: i, j, n
real(dp) :: areaew, arean, areas, vol
real(dp) :: dene, denw, denn, dens
real(dp) :: game, gamw, gamn, gams
real(dp) :: flow, diff, acof
real(dp) :: reseq
nq = 4
call clrsor()
call gamsor()
if (lsolve(4)) den(:,:) = den(:,:) * cp(:,:) ! nominal density: rho*hc
do i = 2, nim1 ! as(i,2)
  areas = r(1) * sew(i)
  flow = den(i,1) * v(i,2) * areas
  diff = gam(i,1) * areas / ydif(2)
  acof = DAPEC(flow, diff, iadv)
  as(i,2) = acof + max(0.0_dp, flow)
end do
resor(4) = 0.0_dp
do j = 2, njm1
  areaew = arx(j)
  denw = den(1,j)
  flow = denw * u(2,j) * areaew
  diff = gam(1,j) * areaew / (xdif(2)*sx(j))
  acof = DAPEC(flow, diff, iadv)
  aw(2,j) = acof + max(0.0_dp, flow)
  do i = 2, nim1
    if (i == nim1) then
      dene = den(nj,j)
      flow = dene * u(ni,j) * areaew
      diff = gam(ni,j) * areaew / (xdif(ni)*sx(j))
    else
      dene = ARIMEAN(den(i,j), den(i+1,j), fx(i+1))
      flow = dene * u(i+1,j) * areaew
      game = HARMEAN(gam(i,j), gam(i+1,j), fx(i+1))
      diff = game * areaew / (xdif(i+1)*sx(j))
    end if
    acof = DAPEC(flow, diff, iadv)
    aw(i+1,j) = acof + max(0.0_dp, flow)
    ae(i,j) = aw(i+1,j) - flow
    arean = rmn(j+1) * sew(i)
    if (j == njm1) then
      denn = den(i,nj)
      flow = denn * v(i,nj) * arean
      diff = gam(i,nj) * arean / ydif(nj)
    else
      denn = ARIMEAN(den(i,j), den(i,j+1), fy(j+1))
      flow = denn * v(i,j+1) * arean
      gamn = HARMEAN(gam(i,j), gam(i,j+1), fy(j+1))
      diff = gamn * arean / ydif(j+1)
    end if
    acof = DAPEC(flow, diff, iadv)
    as(i,j+1) = acof + max(0.0_dp, flow)
    an(i,j) = as(i,j+1) - flow
    vol = ycvr(j) * sew(i)
    ! source
    sp(i,j) = sp(i,j) * vol
    su(i,j) = su(i,j) * vol
    ! assemble and under-relax
    ap(i,j) = ae(i,j) + aw(i,j) + an(i,j) + as(i,j) - sp(i,j)
    reseq = ap(i,j)*t(i,j) - ae(i,j)*t(i+1,j) - aw(i,j)*t(i-1,j) &
          - an(i,j)*t(i,j+1) - as(i,j)*t(i,j-1) - su(i,j)
    resor(4) = resor(4) + abs(reseq)
    ap(i,j) = ap(i,j)/urf(4)
    su(i,j) = su(i,j) + (1.0_dp-urf(4))*ap(i,j)*t(i,j)
  end do
end do
do n = 1, nsweep(4)
  call tdma(2, 2, ni, nj, t)
end do
if (lsolve(4)) den(:,:) = den(:,:) / cp(:,:) ! recover density
end subroutine calct

subroutine postproc()
use vars
implicit none
integer :: i, j
if (lprint(1)) then ! centre u vel
  uc(1,:) = u(2,:)
  uc(ni,:) = u(ni,:)
  uc(2:nim1,:) = 0.5_dp*(u(2:nim1,:)+u(3:ni,:))
end if
if (lprint(2)) then ! centre v vel
  vc(:,1) = v(:,2)
  vc(:,nj) = v(:,nj)
  vc(:,2:njm1) = 0.5_dp*(v(:,2:njm1)+v(:,3:nj))
end if
if (lprint(3)) then ! pressure
  ! extrapolate pressure to boundary
  p(1,:) = p(2,:) + (p(2,:)-p(3,:))*xdif(2)/xdif(3)
  p(ni,:) = p(nim1,:) + (p(nim1,:)-p(nim2,:))*xdif(ni)/xdif(nim1)
  p(:,1) = p(:,2) + (p(:,2)-p(:,3))*ydif(2)/ydif(3)
  p(:,nj) = p(:,njm1) + (p(:,njm1)-p(:,njm2))*ydif(nj)/ydif(njm1)
  ! corner pressure
  p(1,1) = p(2,1) + p(1,2) - p(2,2)
  p(1,nj) = p(1,njm1) + p(2,nj) - p(2,njm1)
  p(ni,1) = p(nim1,1) + p(ni,2) - p(nim1,2)
  p(ni,nj) = p(ni,njm1) + p(nim1,nj) - p(nim1,njm1)
  ! with respect to reference point
  p(:,:) = p(:,:) - p(ipref,jpref)
end if
if (lprint(4)) then ! corner temperature
  t(1,1) = t(2,1) + t(1,2) - t(2,2)
  t(1,nj) = t(1,njm1) + t(2,nj) - t(2,njm1)
  t(ni,1) = t(nim1,1) + t(ni,2) - t(nim1,2)
  t(ni,nj) = t(ni,njm1) + t(nim1,nj) - t(nim1,njm1)
end if
end subroutine postproc

subroutine tdma(istart, jstart, ni, nj, phi)
! line by line tdma solver
use vars, only: dp, ap, an, as, ae, aw, su, sp
implicit none
integer, intent (in) :: istart, jstart, ni, nj
real(dp), dimension (ni,nj), intent (out) :: phi
real(dp), dimension (nj) :: a, b, c, d
integer :: i, j, jj, nim1, njm1, jsrm1
real(dp) :: term
nim1 = ni - 1
njm1 = nj - 1
jsrm1 = jstart - 1
a(jsrm1) = 0.0_dp
!-----commence w-e sweep
do i = istart, nim1
  c(jsrm1) = phi(i, jsrm1)
!-----commence s-n traverse
  do j = jstart, njm1
!-----assemble tdma coefficients
    a(j) = an(i, j)
    b(j) = as(i, j)
    c(j) = ae(i, j)*phi(i+1, j) + aw(i, j)*phi(i-1, j) + su(i, j)
    d(j) = ap(i, j)
!-----calculate coefficients of recurrence formula
    term = 1.0_dp/(d(j)-b(j)*a(j-1))
    a(j) = a(j)*term
    c(j) = (c(j)+b(j)*c(j-1))*term
  end do
!-----obtain new phi"s
  do jj = jstart, njm1
    j = nj + jsrm1 - jj
    phi(i, j) = a(j)*phi(i, j+1) + c(j)
  end do
end do
end subroutine tdma

subroutine clrsor()
! clean source terms for accumulation
use vars, only: dp, sp, su
implicit none
sp(:,:) = 0.0_dp
su(:,:) = 0.0_dp
end subroutine clrsor

subroutine array_init()
! allocate arrays
use vars
implicit none
allocate(x(1:ni), xu(1:ni), xdif(1:ni), sew(1:ni), sewu(1:ni), xcvi(1:ni), &
         xcvip(1:ni), fx(1:ni), fxm(1:ni), &
         stat=ierr, errmsg=errmsg)
if (ierr /= 0) write(*,*) 'ALLOACAE ERROR! ', errmsg
x(:) = 0.0_dp; xu(:) = 0.0_dp; xdif(:) = 0.0_dp;  sew(:) = 0.0_dp
sewu(:) = 0.0_dp; xcvi(:) = 0.0_dp; xcvip(:) = 0.0_dp
fx(:) = 0.0_dp; fxm(:) = 0.0_dp

allocate(y(1:nj), yv(1:nj), ydif(1:nj), sns(1:nj), snsv(1:nj), &
         ycvr(1:nj), ycvrs(1:nj), arx(1:nj), arxj(1:nj), arxjp(1:nj), &
         r(1:nj), rmn(1:nj), sx(1:nj), sxmn(1:nj), &
         fy(1:nj), fym(1:nj), fv(1:nj), fvp(1:nj), stat=ierr, errmsg=errmsg)
if (ierr /= 0) write(*,*) 'ALLOACAE ERROR! ', errmsg
y(:) = 0.0_dp; yv(:) = 0.0_dp; ydif(:) = 0.0_dp; sns(:) = 0.0_dp
snsv(:) = 0.0_dp; ycvr(:) = 0.0_dp; ycvrs(:) = 0.0_dp; ycvr(:) = 0.0_dp
ycvrs(:) = 0.0_dp; arx(:) = 0.0_dp; arxj(:) = 0.0_dp; arxjp(:) = 0.0_dp
r(:) = 0.0_dp; rmn(:) = 0.0_dp; sx(:) = 0.0_dp; sxmn(:) = 0.0_dp
fy(:) = 0.0_dp; fym(:) = 0.0_dp; fv(:) = 0.0_dp; fvp(:) = 0.0_dp
allocate(u(1:ni,1:nj), v(1:ni,1:nj), p(1:ni,1:nj), pp(1:ni, 1:nj), &
         den(1:ni,1:nj), du(1:ni,1:nj), dv(1:ni,1:nj), &
         stat=ierr, errmsg=errmsg)
if (ierr /= 0) write(*,*) 'ALLOCATE ERROR! ', errmsg
u(:,:) = 0.0_dp; v(:,:) = 0.0_dp; p(:,:) = 0.0_dp; pp(:,:) = 0.0_dp
den(:,:) = 0.0_dp; du(:,:) = 0.0_dp; dv(:,:) = 0.0_dp

allocate(t(1:ni,1:nj), gam(1:ni,1:nj), cp(1:ni,1:nj), stat=ierr, errmsg=errmsg)
if (ierr /= 0) write(*,*) 'ALLOCATE ERROR! ', errmsg
t(:,:) = 0.0_dp; gam(:,:) = 0.0_dp; cp(:,:) = 0.0_dp

allocate(uc(1:ni,1:nj), vc(1:ni,1:nj), stat=ierr, errmsg=errmsg)
if (ierr /= 0) write(*,*) 'ALLOCATE ERROR! ', errmsg
uc(:,:) = 0.0_dp; vc(:,:) = 0.0_dp

allocate(ae(1:ni,1:nj), aw(1:ni,1:nj), an(1:ni,1:nj), as(1:ni,1:nj), &
         ap(1:ni,1:nj), su(1:ni,1:nj), sp(1:ni,1:nj), &
          stat=ierr, errmsg=errmsg)
if (ierr /= 0) write(*,*) 'ALLOCATE ERROR! ', errmsg
ae(:,:) = 0.0_dp; aw(:,:) = 0.0_dp; an(:,:) = 0.0_dp; as(:,:) = 0.0_dp
ap(:,:) = 0.0_dp; su(:,:) = 0.0_dp; sp(:,:) = 0.0_dp
end subroutine array_init

subroutine array_close()
! deallocate arrays
use vars
implicit none
deallocate(x, xu, xdif, sew, sewu, xcvi, xcvip, fv, fvp, fx, fxm, &
           stat=ierr)
if (ierr /= 0) write(*,*) 'DEALLOCATE ERROR'
deallocate(y, yv, ydif, sns, snsv, ycvr, ycvrs, &
           arx, arxj, arxjp, r, rmn, sx, sxmn, &
           fy, fym, stat=ierr)
if (ierr /= 0) write(*,*) 'DEALLOCATE ERROR'
deallocate(u, v, p, pp, den, gam, du, dv, uc, vc, stat=ierr)
if (ierr /= 0) write(*,*) 'DEALLOCATE ERROR'
deallocate(ae, aw, an, as, ap, su, sp, stat=ierr)
if (ierr /= 0) write(*,*) 'DEALLOCATE ERROR'
if (allocated(t)) deallocate(t, stat=ierr)
if (ierr /= 0) write(*,*) 'DEALLOCATE ERROR'
if (allocated(cp)) deallocate(cp, stat=ierr)
if (ierr /= 0) write(*,*) 'DEALLOCATE ERROR'
end subroutine array_close


function relerror_c(A,B) result(E)
complex(kind=8),  intent(in)  :: A(:)
complex(kind=8),  intent(in)  :: B(:)
real(kind=8)  :: E
E = maxval(abs(A - B))/maxval(abs(B))
end function relerror_c


module utilities
      !! module with utilities like printing a matrix, or some constants

      implicit none

      real :: pi = acos(-1.)
      !! mathematical constant pi
      real :: e = exp(1.)
      !! mathematical constante e

contains

      subroutine print_matrix(A)
      !! Prints a real matrix in a tabular form
      !! (can be improved)
          real, intent(in) :: A(:,:)
          !! matriz to be displayed
          integer :: M, N, i

          M = size(A,1)
          N = size(A,2)

          do i = 1, M
            print '(*(1x,G0,:,","))', A(i,:)
          end do
      end subroutine

      subroutine to_csv(D,filename)
        !! saves two-dimensional array **D** to csv
        !! file **filename**
          real, intent(in) :: D(:,:)
          !! array to be saved
          character(len=*), intent(in) :: filename
          !! path to the csv file

          integer :: i, N, u

          open(file=filename,newunit=u,status='new', action='write')
          N = size(D,1)
          do i = 1, N
            write(u,'(*(G0,:,",",1x))') D(i,:)
          end do
          close(u)
       end subroutine

      subroutine read_2_columns_csv(filename,D)
        !! Reads a two-column csv from file **filename**
        !! and stores it in **D**
        character(len=*), intent(in) :: filename
        !! path to the file
        real, intent(inout), allocatable :: D(:,:)
        !! array containing the two columns read

        integer :: i, N, u, IO_status

        open(file=filename,newunit=u, status='old')
        N = 0
        do
          read(u,*,IOstat=IO_status)
          if ( is_iostat_end(IO_status) ) exit
          N = N+1
        end do
        allocate(D(N,2))
        rewind(u)
        do i = 1, N
          read(u,*) D(i,1), D(i,2)
        end do
        close(u)
     end subroutine
end module


! { dg-do run }
!
! Tests fix for PR82184
!
! Contributed by Andrey Guskov  <andrey.y.guskov@intel.com)
!
program r187
  call s()
  call s()
contains
  subroutine s()
    complex(4), allocatable, save :: a(:, :)
    complex(4), pointer,     save :: b(:, :)
    if (.not. associated(b)) then
      allocate(a(2, 2))
      allocate(b(2, 2))
      a = reshape ([cmplx(1, 1), cmplx(2, 2), cmplx(1, 2), cmplx(2, 1)], [2,2])
    else
      b = transpose(a)
      if (merge("PASSED", "FAILED", all (transpose (a) .eq. b)) .eq. "FAILED") STOP 1
    end if
  end subroutine s
end program r187


MODULE support

  USE ISO_FORTRAN_ENV
  IMPLICIT NONE

  CONTAINS

  FUNCTION get_cols() RESULT(cols)

    CHARACTER(LEN=1000) :: str_arg
    INTEGER :: cols, err

    IF (COMMAND_ARGUMENT_COUNT() /= 1) THEN
      CALL GET_COMMAND_ARGUMENT(0,str_arg)
      PRINT *, 'Usage : ',TRIM(str_arg),' <number_of_matrix_elements>'
      STOP
    END IF

    CALL GET_COMMAND_ARGUMENT(1,str_arg)
    READ(str_arg, *, iostat=err) cols

    IF (err /= 0) THEN
      PRINT *, 'Number of matrix elements specified must be an integer!'
      STOP
    END IF
  END FUNCTION get_cols

  SUBROUTINE random_init

    LOGICAL, SAVE :: init_done = .FALSE.
    INTEGER :: n, count
    INTEGER, DIMENSION(:), ALLOCATABLE :: seed
    REAL :: warm(1000)

    IF (init_done) RETURN
    init_done = .TRUE.
    CALL RANDOM_SEED(size=n)
    ALLOCATE(seed(n))
    DO n = 1, SIZE(seed)
      seed(n) = n
    END DO
    CALL RANDOM_SEED(put = seed)

    !Warm up the RNG
    CALL RANDOM_NUMBER(warm)

  END SUBROUTINE random_init

END MODULE support

PROGRAM matrix_timer

  USE support
  IMPLICIT NONE

  REAL(REAL64), DIMENSION(:,:), ALLOCATABLE :: matrix1, matrix2, result
  INTEGER :: cols,t1, t2

  cols = get_cols()

  ALLOCATE(matrix1(cols,cols), matrix2(cols,cols), result(cols, cols))
  CALL random_init
  CALL RANDOM_NUMBER(matrix1)
  CALL RANDOM_NUMBER(matrix2)

  CALL SYSTEM_CLOCK(t1)
  result = MATMUL(matrix1, matrix2)
  CALL SYSTEM_CLOCK(t2)

  PRINT *, 'Time in matrix multiply is ', t2-t1
  PRINT *, "Maximum value of result matrix is ", MAXVAL(result)
  PRINT *, "(This is needed to prevent the compiler optimising the work away)"

END PROGRAM matrix_timer