module probdata_module
  use eos_module
  implicit none

  double precision, save :: initP, Tstart, Tend, delta
  integer, save :: TestNum, numPoints
  character(len=128) :: OutputFile

contains

  subroutine RunEOStests

    use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UEINT, UEDEN, UTEMP, UFS
    use chemistry_module, only : nspecies, get_species_index,Ru
    use eos_type_module
    use transport_module

    integer :: iN2, iC2H6, iCO2
    type(eos_t) :: eos_state
    type(eos_t) :: eos_rhoT
    type(eos_t) :: eos_rhoP
    type(eos_t) :: eos_rhoE
    double precision :: tauDelta
    double precision :: dP_dT, dP_dtau, dH_dtau
    double precision :: PatT, PatTplus
    double precision :: PatTau, PatTauplus
    double precision :: HatTau, HatTauplus
    double precision :: amT, amTplus, amTminus
    double precision :: dam_dT, d2am_dT2, dam_dT_analy, d2am_dT2_analy
    double precision :: hmix,sumhyk
    double precision :: invdelta
    double precision :: dtaudY_analy(nspec),dtaudY_chain(nspec)
    double precision :: fYkplus,fYk,muK,sumFyk,muatYk
    type(trv_t)  :: TestTrans
    type(wtr_t)  :: whichTest
    character(len=128) :: FileName
    integer :: iunit,i
    double precision :: errorP, errorT, errorRHO, errorE
    double precision :: MaXerrorP_rhoT,MaXerrorP_rhoE
    double precision :: MaXerrorT_rhoP,MaXerrorT_rhoE
    double precision :: MaXerrorE_rhoP,MaXerrorE_rhoT

    call build(eos_state)
    call build(eos_rhoT)
    call build(eos_rhoP)
    call build(eos_rhoE)

    call transport_init()

    whichTest % wtr_get_xi    = .false.
    whichTest % wtr_get_mu    = .true.
    whichTest % wtr_get_lam   = .true.
    whichTest % wtr_get_Ddiag = .false.

    call trv_build(TestTrans,1)

    iN2 = get_species_index("N2")
    iC2H6 = get_species_index("C2H6")
    iCO2 = get_species_index("CO2")

!!$      Test the species thermodynamic quantities one species at a time
!!$      rho, Cp, Cv, Speed of Sound, Internal energy and enthalpy

    print*,"=== Testing Thermodynamic and transport property calculation for single species, N2 ====="

    ! N2
    FileName = trim(OutputFile)//'_vsNIST_N2.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    eos_state % molefrac(1:nspec) = 0.0d0
    eos_state % molefrac(iN2) = 1.0d0

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)
    eos_state % P = initP

    TestTrans % eos_state(1) % massfrac(1:nspec) = eos_state% massfrac(1:nspec)
    TestTrans % eos_state(1) % P = eos_state% P

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % T = Tstart + (Tend-Tstart)*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       ! Call to test transport - viscosity and thermal conductivity
       TestTrans % eos_state(1) % T = eos_state% T
       TestTrans % eos_state(1) % rho = eos_state% rho

       ! call to compute mu and lambda
       call transport(whichTest, TestTrans)

       write(iunit,'(8(E20.8,4x))') eos_state%P, eos_state % T, eos_state % rho, eos_state%cp, eos_state%cv, eos_state%cs, TestTrans%mu(1),TestTrans%lam(1)

    end do
    CLOSE(UNIT=iunit)

!!$       Test mixture rules
    print*,"=========Testing mixture rules==================="

    print*,"======= Running CO2 + C2H6 mixture eq.ratio test = 1 ========="

    FileName = trim(OutputFile)//'_CO2_C2H6_Xco2_0_0.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    eos_state % molefrac(1:nspec) = 0.0d0

    eos_state % molefrac(iC2H6) = 1.0d0
    eos_state % molefrac(iCO2)  = 0.0000d0

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)

    eos_state % T = 350.0d0

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % P = 1.0d0*1e6*10.0d0 + 40.0d0*1e6*10.0*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       write(iunit,'(6(E20.8,4x))') eos_state%P, eos_state % T, eos_state % rho, eos_state%cp, eos_state%cv, eos_state%cs

    end do
    CLOSE(UNIT=iunit)

    print*,"======= Running CO2 + C2H6 mixture eq. ratio test = 2 ========="

    FileName = trim(OutputFile)//'_CO2_C2H6_Xco2_0_251.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    eos_state % molefrac(1:nspec) = 0.0d0

    eos_state % molefrac(iCO2)  = 0.25166d0
    eos_state % molefrac(iC2H6) = 1.0d0 - eos_state % molefrac(iCO2)

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)

    eos_state % T = 350.0d0

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % P = 1.0d0*1e6*10.0d0 + 40.0d0*1e6*10.0*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       write(iunit,'(6(E20.8,4x))') eos_state%P, eos_state % T, eos_state % rho, eos_state%cp, eos_state%cv, eos_state%cs

    end do
    CLOSE(UNIT=iunit)

    print*,"======= Running CO2 + C2H6 mixture eq. ratio test = 3 ========="

    FileName = trim(OutputFile)//'_CO2_C2H6_Xco2_0_49245.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    eos_state % molefrac(1:nspec) = 0.0d0

    eos_state % molefrac(iCO2)  = 0.49245d0
    eos_state % molefrac(iC2H6) = 1.0d0 - eos_state % molefrac(iCO2)

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)

    eos_state % T = 350.0d0

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % P = 1.0d0*1e6*10.0d0 + 40.0d0*1e6*10.0*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       write(iunit,'(6(E20.8,4x))') eos_state%P, eos_state % T, eos_state % rho, eos_state%cp, eos_state%cv, eos_state%cs

    end do
    CLOSE(UNIT=iunit)

    print*,"======= Running CO2 + C2H6 mixture eq. ratio test = 4 ========="

    FileName = trim(OutputFile)//'_CO2_C2H6_Xco2_0_73978.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    eos_state % molefrac(1:nspec) = 0.0d0

    eos_state % molefrac(iCO2)  = 0.73978d0
    eos_state % molefrac(iC2H6) = 1.0d0 - eos_state % molefrac(iCO2)

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)

    eos_state % T = 350.0d0

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % P = 1.0d0*1e6*10.0d0 + 40.0d0*1e6*10.0*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       write(iunit,'(6(E20.8,4x))') eos_state%P, eos_state % T, eos_state % rho, eos_state%cp, eos_state%cv, eos_state%cs

    end do
    CLOSE(UNIT=iunit)

    print*,"======= Running CO2 + C2H6 mixture eq. ratio test = 5 ========="

    FileName = trim(OutputFile)//'_CO2_C2H6_Xco2_0_90367.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    eos_state % molefrac(1:nspec) = 0.0d0

    eos_state % molefrac(iCO2)  = 0.90367d0
    eos_state % molefrac(iC2H6) = 1.0d0 - eos_state % molefrac(iCO2)

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)

    eos_state % T = 350.0d0

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % P = 1.0d0*1e6*10.0d0 + 40.0d0*1e6*10.0*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       write(iunit,'(6(E20.8,4x))') eos_state%P, eos_state % T, eos_state % rho, eos_state%cp, eos_state%cv, eos_state%cs

    end do
    CLOSE(UNIT=iunit)

    print*,"======= Running CO2 + C2H6 mixture eq ratio test 6 ========="

    FileName = trim(OutputFile)//'_CO2_C2H6_Xco2_1_0.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    eos_state % molefrac(1:nspec) = 0.0d0

    eos_state % molefrac(iCO2)  = 1.0d0
    eos_state % molefrac(iC2H6) = 0.0d0

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)

    eos_state % T = 350.0d0

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % P = 1.0d0*1e6*10.0d0 + 40.0d0*1e6*10.0*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       write(iunit,'(6(E20.8,4x))') eos_state%P, eos_state % T, eos_state % rho, eos_state%cp, eos_state%cv, eos_state%cs

    end do
    CLOSE(UNIT=iunit)

!!$       Conversion between various state variables
    print*,"=====Starting testing of state variable conversion=========="
    print*,"          === Testing RHO & T as input -> Compute P and e "
    print*,"          === Testing RHO & P as input -> Compute T and e "
    print*,"          === Testing RHO & E as input -> Compute T and P "

    FileName = trim(OutputFile)//'_Convert_StateVar.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    ! Default to N2
    eos_state % molefrac(1:nspec) = 0.0d0
    eos_state % molefrac(iN2) = 1.0d0

    eos_rhoT % molefrac(1:nspec) = 0.0d0
    eos_rhoT % molefrac(iN2) = 1.0d0

    eos_rhoP % molefrac(1:nspec) = 0.0d0
    eos_rhoP % molefrac(iN2) = 1.0d0

    eos_rhoE % molefrac(1:nspec) = 0.0d0
    eos_rhoE % molefrac(iN2) = 1.0d0

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)
    call eos_xty(eos_rhoT)
    call eos_xty(eos_rhoP)
    call eos_xty(eos_rhoE)

    eos_state % P = initP

    MaXerrorP_rhoT = -1e12;MaXerrorP_rhoE = -1e12
    MaXerrorT_rhoP = -1e12;MaXerrorT_rhoE = -1e12
    MaXerrorE_rhoP = -1e12;MaXerrorE_rhoT = -1e12

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % T = Tstart + (Tend-Tstart)*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       ! Use this rho and T as inputs and compute P and e
       eos_rhoT % rho = eos_state % rho
       eos_rhoT % T   = eos_state % T

       call eos_rt(eos_rhoT)

       errorP = abs(eos_state%P - eos_rhoT%P)*100.0d0/eos_state%P
       errorE = abs(eos_state%e - eos_rhoT%e)*100.0d0/abs(eos_state%e)

       MaXerrorE_rhoT = max(MaXerrorE_rhoT,errorE)
       MaXerrorP_rhoT = max(MaXerrorP_rhoT,errorP)

       ! Use this rho and P as inputs and compute T and e
       eos_rhoP % rho = eos_state % rho
       eos_rhoP  % P  = eos_state % P
       call eos_rp(eos_rhoP)

       errorE = abs(eos_state%e - eos_rhoP%e)*100.0d0/abs(eos_state%e)
       errorT = abs(eos_state%T - eos_rhoP%T)*100.0d0/eos_state%T

       MaXerrorE_rhoP = max(MaXerrorE_rhoP,errorE)
       MaXerrorT_rhoP = max(MaXerrorT_rhoP,errorT)

       ! Use this rho and e as inputs and compute T and P
       eos_rhoE % rho = eos_state % rho
       eos_rhoE % e =   eos_state % e
       eos_rhoE % P =   eos_state % P
       eos_rhoE % T =   eos_state % T !! Used to generate a guess for Newton solver for Temperature
       call eos_re(eos_rhoE)

       errorP = abs(eos_state%P - eos_rhoE%P)*100.0d0/eos_state%P
       errorT = abs(eos_state%T - eos_rhoE%T)*100.0d0/eos_state%T

       MaXerrorP_rhoE = max(MaXerrorP_rhoE,errorP)
       MaXerrorT_rhoE = max(MaXerrorT_rhoE,errorT)

       write(iunit,'(9(E20.8,4x))') eos_state%P, eos_rhoT%P, eos_rhoE%P, eos_state % T,eos_rhoP % T, eos_rhoE % T , eos_state % e, eos_rhoT % e , eos_rhoP % e

    end do

    CLOSE(UNIT=iunit)

    print*,"===== RHO & T as input -> Compute P and e ==="
    print*,"Error in P computation =", MaXerrorP_rhoT, "  ","Error in E computation=", MaXerrorE_rhoT

    print*,"===== RHO & P as input -> Compute T and e ==="
    print*,"Error in T computation =", MaXerrorT_rhoP, "  ","Error in E computation=", MaXerrorE_rhoP

    print*,"===== RHO & E as input -> Compute P and T  ==="
    print*,"Error in P computation =", MaXerrorP_rhoE, "  ","Error in T computation=", MaXerrorT_rhoE

    print*,"=====Finished testing of state variable conversion=========="

!!$    Test derivatives dP/dT, dP/dtau, dhm/dtau and thereafter test species Enthalpy
    print*,"=== Testing various derivatives of EOS  ====="

    FileName = trim(OutputFile)//'_Derivatives.txt'
    iunit = 10
    OPEN(UNIT=iunit,FILE=trim(FileName),FORM="FORMATTED",STATUS="REPLACE",ACTION="WRITE")

    invdelta = 1.0d0/delta

    ! Default to N2
    eos_state % molefrac(1:nspec) = 0.0d0
    eos_state % molefrac(iN2) = 1.0d0

    ! get mass fractions from mole fractions
    call eos_xty(eos_state)

    eos_state % P = initP

    do i = 1,numPoints

       ! Generate these quantities over a range of temperature
       eos_state % T = Tstart + (Tend-Tstart)*dble(i-1)/(numPoints-1)

       ! call to compute rho and e
       call eos_tp(eos_state)

       ! Analytical expressions for the derivatives
       call eos_deriv(eos_state)

       dtaudY_analy(:) = eos_state%taui(:)

       ! Second derivative of am analytical expression
       d2am_dT2_analy = eos_state%d2AmdT2

       ! Mixture enthalpy
       call eos_h(eos_state)
       hmix = eos_state%h

       ! call to compute P at T and tau,Y
       call eos_rt(eos_state)
       PatT = eos_state%p
       dam_dT_analy = eos_state%damdT

       ! Store am at T
       amT = eos_state%am

       ! call to compute P at T+epsilon and tau,Y
       eos_state % T = eos_state % T + delta
       call eos_rt(eos_state)
       PatTplus = eos_state%p
       amTplus  = eos_state%am

       ! dp/dT at constant tau (or rho)
       dP_dT = (PatTplus - PatT)/delta

       ! Test derivative dam/dT and d2amdT2
       dam_dT   = (amTplus-amT)/delta

       ! call to compute P at T+epsilon and tau,Y
       eos_state % T = eos_state % T - 2.d0* delta
       call eos_rt(eos_state)
       amTminus = eos_state%am

       ! Second derivative of am w.r.t. to Temperature, T
       d2am_dT2 = (amTminus - 2.0d0*amT + amTplus)*invdelta*invdelta

       ! Compute derivative w.r.t to tau (specific volume) constant T
       eos_state % T = Tstart + (Tend-Tstart)*dble(i-1)/(numPoints-1)

       ! call to compute P at tau and T
       call eos_rt(eos_state)
       PatTau = eos_state%p

       ! call to compute H at tau and T
       call eos_h(eos_state)
       HatTau = eos_state%h

       ! call to compute P at tau+Delta and T, Y
       tauDelta = 1.0d0/eos_state % rho + delta
       eos_state % rho = 1.0d0/tauDelta

       call eos_rt(eos_state)
       PatTauplus = eos_state%p

       ! call to compute H at tau+Delta and T,Y
       call eos_h(eos_state)
       HatTauplus = eos_state%h

       ! dp/dTau and dHdTau at constant T
       dP_dtau = (PatTauplus - PatTau)/delta
       dH_dtau = (HatTauplus - HatTau)/delta

       ! Reset rho
       eos_state % P = initP
       call eos_tp(eos_state)

       ! Get species h_i
       call eos_hi(eos_state)
       sumhyk = sum(eos_state%massFrac(:)*eos_state%hi(:))

       ! Derivatives w.r.t to species Y_k

       ! Evaluate Free energy at Yk
       eos_state % massfrac(1:nspec) = 0.0d0
       eos_state % massfrac(iN2) = 1.0d0
       call eos_mui(eos_state)
       fYk = eos_state%f
       sumFyk = sum(eos_state%massFrac(:)*eos_state%mui(:))
       muatYk = eos_state%mui(iN2)

       ! Evaluate Free energy at Yk
       eos_state % massfrac(1:nspec) = 0.0d0
       eos_state % massfrac(iN2) = 1.0d0 + delta
       call eos_mui(eos_state)
       fYkplus = eos_state%f

       muK = (fYkplus - fYk)*invdelta

       ! Output in the file - filename provided by the user
       write(iunit,'(19(E20.8,4x))') initP, eos_state % T, eos_state % rho,eos_state%dpdT,dP_dT, eos_state%dpdtau,dP_dtau,eos_state%dhdr,dH_dtau,hmix,sumhyk,dam_dT_analy, dam_dT,d2am_dT2_analy,d2am_dT2,muK,muatYk,fYk,sumFyk

    end do

    CLOSE(UNIT=iunit)

    call destroy(eos_state)
    call destroy(eos_rhoT)
    call destroy(eos_rhoP)
    call destroy(eos_rhoE)
    call trv_destroy(TestTrans)

    stop '====== Finished runnning EOS tests============'

  end subroutine RunEOStests

end module probdata_module


! =============================================================================
!                       Test nearest algorithm
!
!           This unit test checks:
!               (2a) a = b
!               (2b) a - B
! =============================================================================
program test_nearest_1
    use unit_test
    use permute, only : permute_generate, permute_dealloc, n_permutes, permutes
    use constants, only : pi, zero, two, five, ten
    use parcel_container
    use options, only : parcel
    use parameters, only : update_parameters, lower, extent, nx, nz
    use parcel_nearest
    use timer
    implicit none

    logical                            :: passed = .true.
    integer, allocatable, dimension(:) :: isma
    integer, allocatable, dimension(:) :: iclo
    integer                            :: n_merge, n, ordering(2)

    nx = 1
    nz = 1
    lower  = (/-pi / two, -pi /two/)
    extent = (/pi, pi/)

    call register_timer('merge nearest', merge_nearest_timer)
    call register_timer('merge tree resolve', merge_tree_resolve_timer)

    parcel%lambda_max = five
    parcel%min_vratio = ten

    call update_parameters

    call parcel_alloc(2)
    n_parcels = 2

    call permute_generate(n_parcels)

    !
    !   (2a) a = b
    !
    do n = 1, n_permutes
        ordering = permutes(n, :)
        call parcel_setup_2a(ordering)

        call find_nearest(isma, iclo, n_merge)

        call AtoB_or_BtoA
    enddo

    call print_result_logical('Test nearest algorithm: a = b', passed)

    !
    !   (2b) a - B
    !
    passed = .true.

    do n = 1, n_permutes
        ordering = permutes(n, :)
        call parcel_setup_2b(ordering)

        call find_nearest(isma, iclo, n_merge)

        call AtoB
    enddo

    call print_result_logical('Test nearest algorithm: a - B', passed)

    contains

        ! (2a) a = b
        subroutine parcel_setup_2a(p)
            integer, intent(in) :: p(2)

            parcels%position(1, p(1)) = -0.25d0
            parcels%position(2, p(1)) = zero
            parcels%volume(p(1)) = 0.1d0 * pi

            parcels%position(1, p(2)) = 0.25d0
            parcels%position(2, p(2)) = zero
            parcels%volume(p(2)) = 0.2d0 * pi
        end subroutine parcel_setup_2a

        ! (2b) a - B
        subroutine parcel_setup_2b(p)
            integer, intent(in) :: p(2)

            parcels%position(1, p(1)) = -0.25d0
            parcels%position(2, p(1)) = zero
            parcels%volume(p(1)) = 0.1d0 * pi

            parcels%position(1, p(2)) = 0.25d0
            parcels%position(2, p(2)) = zero
            parcels%volume(p(2)) = 0.4d0 * pi
        end subroutine parcel_setup_2b

        subroutine AtoB_or_BtoA
            logical :: a_to_b, b_to_a

            passed = (passed .and. (n_merge == 1))

            a_to_b = ((isma(1) == ordering(1)) .and. (iclo(1) == ordering(2)))
            b_to_a = ((iclo(1) == ordering(1)) .and. (isma(1) == ordering(2)))
            passed = (passed .and. (a_to_b .or. b_to_a))
        end subroutine AtoB_or_BtoA

        subroutine AtoB
            logical :: a_to_b
            passed = (passed .and. (n_merge == 1))

            a_to_b = ((isma(1) == ordering(1)) .and. (iclo(1) == ordering(2)))
            passed = (passed .and. a_to_b)
        end subroutine AtoB

end program test_nearest_1


program  pcgrowcorray
 use iso_fortran_env
 !$ use omp_lib
 use modsparse
 use modcoarraysolver
 implicit none
 integer(kind=int32)::thisimage,unlog
 integer(kind=int32)::i
 integer(kind=int32)::neq
 integer(kind=int32)::startrow[*],endrow[*],startcol[*],endcol[*]
 character(len=80)::host,cdummy,cdummy1
 real(kind=real64),allocatable::x(:)[:]
 !$ real(kind=real64)::t2
 type(crssparse)::crs
 type(crssparse)::crsprecond
 type(pcg)::pcgsolver

 !$ t2=omp_get_wtime()

 thisimage=this_image()

 write(cdummy,'(i0)')thisimage
 open(newunit=unlog,file='log.pcgrow.'//adjustl(cdummy(:len_trim(cdummy))),action='write',status='replace')

 write(unlog,'(/a)')' PCG solver with a LHS divided by rows...'

 call get_environment_variable("HOSTNAME",value=host)
 write(unlog,'(/2(a,i0),2a)')" Hello from image ",thisimage," out of ",num_images()," total images on host ",trim(host)

 write(unlog,'(/" Number of images            : ",i0)')num_images()
 !$omp parallel
 !$omp master
 !$ write(unlog,'(" Number of threads for OpenMP: ",i0)')omp_get_num_threads()
 !$omp end master
 !$omp end parallel

 !read the parameter file on image 1
 if(thisimage.eq.1)then
  call readparam(startrow,endrow,startcol,endcol,unlog)
 endif

 sync all

 !Reads the matrix
 cdummy1='crs_subpcg.row'//adjustl(cdummy(:len_trim(cdummy)))
 crs=crssparse(cdummy1,unlog)
 call crs%printstats()

 neq=crs%getdim(2)

 !create preconditioner
 cdummy1='crs_precond.row'//adjustl(cdummy(:len_trim(cdummy)))
 crsprecond=crssparse(cdummy1,unlog)
 call crsprecond%setpermutation([(i,i=1,crsprecond%getdim(1))])
 call crsprecond%printstats()

 !solution vector
 allocate(x(neq)[*])
 x=0.d0

 sync all

 !call pcgrowcoarray(neq,crs,x,'rhs.bin',crsprecond,startrow,endrow,unlog)
 pcgsolver=pcg(neq)
 call pcgsolver%setoutput(unlog)
 call pcgsolver%solve(crs,x,'rhs.bin',crsprecond,startrow,endrow)

 sync all

 if(thisimage.eq.1)call print_ascii(x,1,neq,unlog)

 write(unlog,'(/2(a,i0),a)')" End for image ",thisimage," out of ",num_images()," total images!"
 !$ write(unlog,'("   Wall clock time: ",f12.2)')omp_get_wtime()-t2
 close(unlog)

contains

subroutine readparam(startrow,endrow,startcol,endcol,unlog)
 integer(kind=int32),intent(in)::unlog
 integer(kind=int32),intent(inout)::startrow[*],endrow[*],startcol[*],endcol[*]

 integer(kind=int32)::io,un,i,j,k,l,m,n

 open(newunit=un,file='param.pcgcoarray.row',status='old',action='read')
 n=0
 do
  read(un,*,iostat=io)i,j,k,l,m
  if(io.ne.0)exit
  n=n+1
  if(n.gt.num_images())then
   write(unlog,'(a)')' The parameter file is not correct!'
   error stop
  endif
  startrow[i]=j
  endrow[i]=k
  startcol[i]=l
  endcol[i]=m
 enddo
 close(un)
 if(n.ne.num_images())then
  write(unlog,'(a)')' The parameter file is not correct!'
  error stop
 endif

end subroutine

!PRINT
subroutine print_ascii(x,startpos,endpos,unlog)
 integer(kind=int32),intent(in)::startpos,endpos,unlog
 real(kind=real64),intent(in)::x(:)

 integer(kind=int32)::un,i

 write(unlog,'(/a,i0,a)')" Image ",this_image()," starts to write the solutions!"

#if (TOUTPUT==1)
 open(newunit=un,file='solutions.pcgcoarray.row.dist')
#elif (TOUTPUT==2)
 open(newunit=un,file='solutions.pcgcoarray.row.shared')
#else
 open(newunit=un,file='solutions.pcgcoarray.row')
#endif

 do i=startpos,endpos
  write(un,*)x(i)
 enddo
 close(un)

end subroutine

end program


program main
  use mpi
  implicit none
  integer, parameter :: n = 8, nb = 1
  integer :: provided, ierr, myrank, nprocs
  integer :: icontxt, npcol, nprow, desc(9)
  integer :: i, j, info
  double precision, allocatable :: a(:, :), z(:,:), w(:)
  integer :: lwork
  double precision, allocatable :: work(:)

  call MPI_init_thread(MPI_THREAD_MULTIPLE, provided, ierr)
  call MPI_comm_rank(MPI_COMM_WORLD, myrank, ierr)
  call MPI_comm_size(MPI_COMM_WORLD, nprocs, ierr)
  nprow = int(sqrt(1. * nprocs + 0.5))
  npcol = int(1. * nprocs / nprow)
  if (myrank == 0) then
     print *, "n =", n
     print *, "nprocs =", nprocs
     print *, "nprow =", nprow
     print *, "npcol =", npcol
     if ((nprocs /= nprow * npcol) .or. (mod(n, nprow) /= 0) .or. &
          (mod(n, npcol) /= 0)) then
        print *, "incompatible matrix size and number of processes"
        call MPI_Abort(MPI_COMM_WORLD, 127, ierr)
     end if
  end if
  call BLACS_get(0, 0, icontxt)
  call BLACS_gridinit(icontxt, 'R', nprow, npcol)

  call descinit(desc, n, n, nb, nb, 0, 0, icontxt, n/nprow, info)
  allocate(a(n/nprow, n/npcol), z(n/nprow, n/npcol), w(n))
  do j = 1, n
     do i = 1, n
        call pdelset(a, i, j, desc, dble(min(i, j)))
     end do
  end do

  lwork = -1
  allocate(work(1))
  call pdsyev('V', 'U', n, a, 1, 1, desc, w, z, 1, 1, desc, work, lwork, info)
  lwork = int(work(1))
  deallocate(work)
  allocate(work(lwork))

  call pdsyev('V', 'U', n, a, 1, 1, desc, w, z, 1, 1, desc, work, lwork, info)
  if (myrank == 0) then
     print *, "eigenvalues:", w(:)
  end if

  deallocate(a, z, w, work)
  call BLACS_gridexit(icontxt)
  call MPI_finalize(ierr)
end program main


subroutine amrex_probinit (init,name,namlen,problo,probhi) bind(c)

  use probdata_module

  implicit none

  integer, intent(in) :: init, namlen
  integer, intent(in) :: name(namlen)
  double precision, intent(in) :: problo(*), probhi(*)

  integer untin,i

  namelist /fortin/ adv_vel

  !
  ! Build "probin" filename -- the name of file containing fortin namelist.
  !
  integer maxlen
  parameter (maxlen=256)
  character probin*(maxlen)

  if (namlen .gt. maxlen) then
     write(6,*) 'probin file name too long'
     stop
  end if

  do i = 1, namlen
     probin(i:i) = char(name(i))
  end do

  ! set the namelist default
  adv_vel(:) = 1.d0

  ! Read namelists
  untin = 9
  open(untin,file=probin(1:namlen),form='formatted',status='old')
  read(untin,fortin)
  close(unit=untin)

end subroutine amrex_probinit

subroutine initdata(level, time, lo, hi, &
     phi, phi_lo, phi_hi, &
     dx, prob_lo) bind(C, name="initdata")

  use amrex_fort_module, only : amrex_real, dim=>bl_spacedim
  implicit none
  integer, intent(in) :: level, lo(3), hi(3), phi_lo(3), phi_hi(3)
  double precision, intent(in) :: time
  double precision, intent(inout) :: phi(phi_lo(1):phi_hi(1), &
       &                                 phi_lo(2):phi_hi(2), &
       &                                 phi_lo(3):phi_hi(3))
  double precision, intent(in) :: dx(3), prob_lo(3)

  integer          :: i,j,k
  double precision :: xlo,ylo,xhi,yhi,zlo,zhi, pi, denom, integralval, freq

  freq = 2.0d0
  pi = 3.14159265358979323846264338327950288d0
  if(dim.eq.2) then
     denom = (dx(1)*dx(2)*pi*pi*freq*freq)
  else
     denom = (dx(1)*dx(2)*dx(3)*pi*pi*pi*freq*freq*freq)
  endif
  !$omp parallel do private(i,j,k,x,y,z,r2) collapse(2)
  do k=lo(3),hi(3)
     zlo = dx(3)*(k)
     zhi = dx(3)*(k+1)

     do j=lo(2),hi(2)
        ylo = dx(2)*(j)
        yhi = dx(2)*(j+1)

        do i=lo(1),hi(1)
           xlo = dx(1)*(i)
           xhi = dx(1)*(i+1)

           if(dim .eq. 2) then
              integralval = (sin(freq*pi*xhi) - sin(freq*pi*xlo))*(sin(freq*pi*yhi) - sin(freq*pi*ylo))
           else
              integralval = (sin(freq*pi*xhi) - sin(freq*pi*xlo))*(sin(freq*pi*yhi) - sin(freq*pi*ylo))*(sin(freq*pi*zhi) - sin(freq*pi*zlo))
           end if

!!debug set to 1d
           integralval = (sin(freq*pi*xhi) - sin(freq*pi*xlo))
           denom = dx(1)*pi*freq
!           if(j.eq.0) then
!!              if((i.eq.0).or.(i.eq.63)) then
!             if(i.eq.63) then
!!                 print*, "i xlo xhi sinxhi sinxlo integralval, denom", i, xlo, xhi, sin(freq*pi*xhi), sin(freq*pi*xlo), integralval, denom
!                 print*, "i xlo xhi sinxhi sinxlo integralval, denom", i, xlo, xhi, sin(freq*pi*1.0d0), sin(freq*pi*xlo), integralval, denom
!              endif
!           endif
!!!end debug
           phi(i,j,k) = integralval/denom

        end do
     end do
  end do
  !$omp end parallel do

!  j = 0
!  k = 0
!  print*, "*** init phi 0  1  62 63= ", j, phi(0,j,k),phi(1,j,k),phi(62,j,k),phi(63,j,k), "****"

end subroutine initdata


! Program to test the upper and lower bound intrinsics
program testbounds
   implicit none
   real, dimension(:, :), allocatable :: a
   integer, dimension(5) :: j
   integer i

   ! Check compile time simplification
   if (lbound(j,1).ne.1 .or. ubound(j,1).ne.5) call abort ()

   allocate (a(3:8, 6:7))

   ! With one parameter
   j = 0;
   j(3:4) = ubound(a)
   if (j(3) .ne. 8) call abort
   if (j(4) .ne. 7) call abort

   ! With two parameters, assigning to an array
   j = lbound(a, 1)
   if ((j(1) .ne. 3) .or. (j(5) .ne. 3)) call abort

   ! With a variable second parameter
   i = 2
   i = lbound(a, i)
   if (i .ne. 6) call abort

   call test(a)
contains
subroutine test (a)
   real, dimension (1:, 1:) :: a
   integer i

   i = 2
   if ((ubound(a, 1) .ne. 6) .or. (ubound(a, i) .ne. 2)) call abort
end subroutine
end program


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      SUBROUTINE Matrix_Unique_Row_Int(m,n,m_Finish,Matrix,
     &                             Uniqued_Matrix,Uniqued_m,
     &                             Uni_Mat_Count)
c     delete reduplicated rows of a matrix

      implicit none
      integer,intent(in):: m,n,m_Finish
      integer,intent(in):: Matrix(m,n)
      integer,intent(out):: Uniqued_m
      integer,intent(out):: Uniqued_Matrix(m,n)
      integer,intent(out):: Uni_Mat_Count(m)

      integer tem(n)
      integer i,j,k

      Uniqued_Matrix(1:m,1:n) = 0
      Uni_Mat_Count(1:m)=1

      k = 1
      Uniqued_Matrix(1,:) = Matrix(1,:)

      outer: do i=2,m_Finish
          do j=1,k
              tem = Uniqued_Matrix(j,:) - Matrix(i,:)
              if ((maxval(tem).eq. 0).and.
     &            (minval(tem).eq. 0)) then
                  !Found a match so start looking again
                  Uni_Mat_Count(j) = Uni_Mat_Count(j)+1
                  cycle outer
              end if
          end do
          !No match found so add it to the output
          k = k + 1
          Uniqued_Matrix(k,:) = Matrix(i,:)
      end do outer

      Uniqued_m = k

      return
      END SUBROUTINE Matrix_Unique_Row_Int


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

! Test lowering of operations sub-expression inside elemental call arguments.
! This tests array contexts where an address is needed for each element (for
! the argument), but part of the array sub-expression must be lowered by value
! (for the operation)

module test_ops
    interface
      integer elemental function elem_func(i)
        integer, intent(in) :: i
      end function
      integer elemental function elem_func_logical(l)
        logical(8), intent(in) :: l
      end function
      integer elemental function elem_func_logical4(l)
        logical, intent(in) :: l
      end function
      integer elemental function elem_func_real(x)
        real(8), value :: x
      end function
    end interface
    integer :: i(10), j(10), iscalar
    logical(8) :: a(10), b(10)
    real(8) :: x(10), y(10)
    complex(8) :: z1(10), z2

  contains
  ! CHECK-LABEL: func @_QMtest_opsPcheck_binary_ops() {
  subroutine check_binary_ops()
    print *,  elem_func(i+j)
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
  ! CHECK:  %[[VAL_27:.*]] = arith.addi %[[VAL_25]], %[[VAL_26]] : i32
  ! CHECK:  fir.store %[[VAL_27]] to %[[VAL_0]] : !fir.ref<i32>
  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_binary_ops_2() {
  subroutine check_binary_ops_2()
    print *,  elem_func(i*iscalar)
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
  ! CHECK:  %[[VAL_13:.*]] = fir.load %{{.*}} : !fir.ref<i32>
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
  ! CHECK:  %[[VAL_27:.*]] = arith.muli %[[VAL_25]], %[[VAL_13]] : i32
  ! CHECK:  fir.store %[[VAL_27]] to %[[VAL_0]] : !fir.ref<i32>
  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_negate() {
  subroutine check_negate()
    print *,  elem_func(-i)
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
  ! CHECK:  %[[VAL_22:.*]] = arith.constant 0 : i32
  ! CHECK:  %[[VAL_23:.*]] = arith.subi %[[VAL_22]], %[[VAL_21]] : i32
  ! CHECK:  fir.store %[[VAL_23]] to %[[VAL_0]] : !fir.ref<i32>
  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_convert() {
  subroutine check_convert()
    print *,  elem_func(int(x))
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
  ! CHECK:  %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (f64) -> i32
  ! CHECK:  fir.store %[[VAL_22]] to %[[VAL_0]] : !fir.ref<i32>
  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_exteremum() {
  subroutine check_exteremum()
    print *,  elem_func(min(i, j))
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
  ! CHECK:  %[[VAL_27:.*]] = arith.cmpi slt, %[[VAL_25]], %[[VAL_26]] : i32
  ! CHECK:  %[[VAL_28:.*]] = arith.select %[[VAL_27]], %[[VAL_25]], %[[VAL_26]] : i32
  ! CHECK:  fir.store %[[VAL_28]] to %[[VAL_0]] : !fir.ref<i32>
  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_logical_unary_ops() {
  subroutine check_logical_unary_ops()
    print *,  elem_func_logical(.not.b)
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<8>
  ! CHECK:  %[[VAL_12:.*]] = arith.constant true
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_22:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
  ! CHECK:  %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (!fir.logical<8>) -> i1
  ! CHECK:  %[[VAL_24:.*]] = arith.xori %[[VAL_23]], %[[VAL_12]] : i1
  ! CHECK:  %[[VAL_25:.*]] = fir.convert %[[VAL_24]] : (i1) -> !fir.logical<8>
  ! CHECK:  fir.store %[[VAL_25]] to %[[VAL_0]] : !fir.ref<!fir.logical<8>>
  ! CHECK:  fir.call @_QPelem_func_logical(%[[VAL_0]]) : (!fir.ref<!fir.logical<8>>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_logical_binary_ops() {
  subroutine check_logical_binary_ops()
    print *,  elem_func_logical(a.eqv.b)
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<8>
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
  ! CHECK:  %[[VAL_27:.*]] = fir.convert %[[VAL_25]] : (!fir.logical<8>) -> i1
  ! CHECK:  %[[VAL_28:.*]] = fir.convert %[[VAL_26]] : (!fir.logical<8>) -> i1
  ! CHECK:  %[[VAL_29:.*]] = arith.cmpi eq, %[[VAL_27]], %[[VAL_28]] : i1
  ! CHECK:  %[[VAL_30:.*]] = fir.convert %[[VAL_29]] : (i1) -> !fir.logical<8>
  ! CHECK:  fir.store %[[VAL_30]] to %[[VAL_0]] : !fir.ref<!fir.logical<8>>
  ! CHECK:  fir.call @_QPelem_func_logical(%[[VAL_0]]) : (!fir.ref<!fir.logical<8>>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_compare() {
  subroutine check_compare()
    print *,  elem_func_logical4(x.lt.y)
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<4>
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
  ! CHECK:  %[[VAL_27:.*]] = arith.cmpf olt, %[[VAL_25]], %[[VAL_26]] : f64
  ! CHECK:  %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (i1) -> !fir.logical<4>
  ! CHECK:  fir.store %[[VAL_28]] to %[[VAL_0]] : !fir.ref<!fir.logical<4>>
  ! CHECK:  fir.call @_QPelem_func_logical4(%[[VAL_0]]) : (!fir.ref<!fir.logical<4>>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_pow() {
  subroutine check_pow()
    print *,  elem_func_real(x**y)
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca f64
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
  ! CHECK:  %[[VAL_27:.*]] = fir.call @__fd_pow_1(%[[VAL_25]], %[[VAL_26]]) : (f64, f64) -> f64
  ! CHECK:  fir.store %[[VAL_27]] to %[[VAL_0]] : !fir.ref<f64>
  ! CHECK:  %[[VAL_28:.*]] = fir.call @_QPelem_func_real(%[[VAL_0]]) : (!fir.ref<f64>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_cmplx_part() {
  subroutine check_cmplx_part()
    print *,  elem_func_real(AIMAG(z1 + z2))
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca f64
  ! CHECK:  %[[VAL_13:.*]] = fir.load %{{.*}} : !fir.ref<!fir.complex<8>>
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_23:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.complex<8>>, index) -> !fir.complex<8>
  ! CHECK:  %[[VAL_24:.*]] = fir.addc %[[VAL_23]], %[[VAL_13]] : !fir.complex<8>
  ! CHECK:  %[[VAL_25:.*]] = fir.extract_value %[[VAL_24]], [1 : index] : (!fir.complex<8>) -> f64
  ! CHECK:  fir.store %[[VAL_25]] to %[[VAL_0]] : !fir.ref<f64>
  ! CHECK:  fir.call @_QPelem_func_real(%[[VAL_0]]) : (!fir.ref<f64>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_parentheses() {
  subroutine check_parentheses()
    print *,  elem_func_real((x))
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca f64
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
  ! CHECK:  %[[VAL_22:.*]] = fir.no_reassoc %[[VAL_21]] : f64
  ! CHECK:  fir.store %[[VAL_22]] to %[[VAL_0]] : !fir.ref<f64>
  ! CHECK:  fir.call @_QPelem_func_real(%[[VAL_0]]) : (!fir.ref<f64>) -> i32
  end subroutine

  ! CHECK-LABEL: func @_QMtest_opsPcheck_parentheses_logical() {
  subroutine check_parentheses_logical()
    print *,  elem_func_logical((a))
  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<8>
  ! CHECK:  fir.do_loop
  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
  ! CHECK:  %[[VAL_22:.*]] = fir.no_reassoc %[[VAL_21]] : !fir.logical<8>
  ! CHECK:  fir.store %[[VAL_22]] to %[[VAL_0]] : !fir.ref<!fir.logical<8>>
  ! CHECK:  fir.call @_QPelem_func_logical(%[[VAL_0]]) : (!fir.ref<!fir.logical<8>>) -> i32
  end subroutine

  subroutine check_parentheses_derived(a)
    type t
      integer :: i
    end type
    interface
      integer elemental function elem_func_derived(x)
        import :: t
        type(t), intent(in) :: x
      end function
    end interface
    type(t), pointer :: a(:)
    print *,  elem_func_derived((a))
  ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>
  ! CHECK: fir.do_loop
  ! CHECK: %[[VAL_21:.*]] = fir.array_access %{{.}}, %{{.*}}
  ! CHECK: %[[VAL_22:.*]] = fir.no_reassoc %[[VAL_21]] : !fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>
  ! CHECK: %[[FIELD:.*]] = fir.field_index i, !fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>
  ! CHECK: %[[FROM:.*]] = fir.coordinate_of %[[VAL_22]], %[[FIELD]] : (!fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
  ! CHECK: %[[TO:.*]] = fir.coordinate_of %[[VAL_0]], %[[FIELD]] : (!fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
  ! CHECK: %[[VAL:.*]] = fir.load %[[FROM]] : !fir.ref<i32>
  ! CHECK: fir.store %[[VAL]] to %[[TO]] : !fir.ref<i32>
  ! CHECK: %25 = fir.call @_QPelem_func_derived(%[[VAL_0]]) : (!fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>) -> i32
  end subroutine
  end module


c     Use 2D template and profile to calculate the relative phase shift and
c     DM difference

      Subroutine tmplmatch2(prof,tmpl,nchan,nbins,shift,eshift,
     +                            dDM,edDM,D_0,freq,mfit,wt)

      parameter (twopi=3.141592653589793*2)
      integer nchan,nbins,mfit,rmsbegin,i,j,jd,ct,rbin
      integer ia(mfit)
      real*8 prof(nchan,nbins),tmpl(nchan,nbins),kk
      real*8 amp_prof(nchan,nbins/2),pha_prof(nchan,nbins/2)
      real*8 amp_tmpl(nchan,nbins/2),pha_tmpl(nchan,nbins/2)
      real*8 readrms(nchan),sca(nchan),freq(nchan),wt(nchan)
      real*8 shift,eshift,shift_bg,dDM,edDM,dDM_bg,D_0,coef
      real*8 a(mfit),alpha(mfit,mfit),covar(mfit,mfit)
      real*8 alamda,chisq,ochisq,beta(mfit),shift0,eshift_bg
      real*8 Rchi

      fac=nbins/twopi
      shift0=0.0;

c     Initial guess when no DM fit
      if(mfit.eq.nchan+1) then
         call initialguessnoDM(prof,tmpl,nchan,nbins,shift_bg,eshift_bg,
     +   sca,wt)
c     write(*,*)"Initial guess:"
c     write(*,*)"Shift in phase:",shift_bg/twopi,eshift_bg/twopi
c     write(*,*)"In microsec:",shift_bg/twopi*0.002946981889463*1.0d6,
c    +          eshift_bg/twopi*0.002946981889463*1.0d6
      end if

c     Initial guess when DM fit included
      if(mfit.eq.nchan+2) then
C     Obtain initial guess of the parameters,shift_bg in rad
         call initialguess(prof,tmpl,nchan,nbins,shift_bg,eshift_bg,
     +                     dDM_bg,edDM,sca,freq,D_0,coef)
c     write(*,*)"Initial guess:"
c     write(*,*)"Shift in phase:",shift_bg/twopi,eshift_bg/twopi
c     write(*,*)"dDM:",dDM_bg,edDM
c     write(*,*)"Coefficient:",coef
      end if

C     Make template more aligned to profile
      rbin=shift_bg/twopi*nbins
      shift0=dble(rbin)/nbins*twopi
      shift_bg=shift_bg-shift0
      call wrap(prof,nchan,nbins,-rbin)

c     Perform FFT to each individual band and fill in the phase and amplitude arrays
      call sepFFT(tmpl,nchan,nbins,amp_tmpl,pha_tmpl)
      call sepFFT(prof,nchan,nbins,amp_prof,pha_prof)

      rmsbegin=nbins/2/8*5
c     Calculate rms of individual channels from the high frequency harmonics
      do i=1,nchan
        readrms(i)=0.0
        do j=rmsbegin,nbins/2
          readrms(i)=readrms(i)+amp_prof(i,j)**2
        end do
        readrms(i)=sqrt(readrms(i)/(nbins/2-rmsbegin+1))
c       write(*,*)readrms(i)
c       readrms(1)=0.15551729582017640
c       readrms(2)=0.17413314476746058
c       readrms(3)=0.18144244685305003
c       readrms(4)=0.16557314485112190
c       readrms(5)=0.18401485224820879
c       readrms(6)=0.24807599238724765
c       readrms(7)=0.27979888870514180
c       readrms(8)=0.17581917163384378
      end do
c     readrms(1)=readrms(1)*2.0

      Rchi=999999.0
C     Loop over different starting values
      do kk=-5.0,5.0,1

C     Initialize input for the LM routine
        do i=1,nchan
          a(i)=sca(i)
          ia(i)=1
        end do
c       a(1)=sca(1)*(1.0-kk/100.0)
c       a(2)=sca(2)*(1.0+kk/100.0)
c       a(3)=sca(3)*(1.0-kk/100.0)
c       a(4)=sca(4)*(1.0+kk/100.0)
c       a(5)=sca(5)*(1.0-kk/100.0)
c       a(6)=sca(6)*(1.0+kk/100.0)
c       a(7)=sca(7)*(1.0-kk/100.0)
c       a(8)=sca(8)*(1.0+kk/100.0)
        ia(nchan+1)=1
        a(nchan+1)=shift_bg+eshift_bg*kk
        if(mfit.eq.nchan+2) then
          ia(nchan+2)=1
          a(nchan+2)=dDM_bg
        end if
        alamda=-0.1
        jd=0
        ct=0

c     write(*,*)"Loop",a(nchan+1)/twopi+shift0/twopi,kk
c     Call the hacked LM routine
 10     call mrqmin(amp_prof,pha_prof,amp_tmpl,pha_tmpl,readrms,nchan,
     +              nbins,a,ia,covar,alpha,beta,chisq,ochisq,alamda,
     +              freq,D_0,mfit,jd)

c     write(*,*)"Reduced chisq of fitting:",chisq/(nbins*nchan-1-mfit)
c     write(*,*)"New shift:", a(nchan+1)*fac/nbins+shift0*fac/nbins
        if(jd.lt.2) then
          ct=ct+1
          if(ct.gt.100) then
c           write(*,*)"Loop over 100"
            goto 100
          endif
          goto 10
        end if

 100    alamda=0.0d0
        call mrqmin(amp_prof,pha_prof,amp_tmpl,pha_tmpl,readrms,nchan,
     +              nbins,a,ia,covar,alpha,beta,chisq,ochisq,alamda,
     +              freq,D_0,mfit,jd)
c     write(*,*)"New:",chisq
c       write(*,*)"New shift:", (a(nchan+1)*fac/nbins+shift0*fac/nbins
c    +            )*0.002946981889463*1.0d6

c        write(*,*)"Fitted shift in bin:"
c        write(*,*)a(nchan+1)*fac,sqrt(covar(nchan+1,nchan+1))*fac
        if(mfit.eq.nchan+2) then
c         write(*,*)"Fitted DM difference:"
c         write(*,*)a(nchan+2),sqrt(covar(nchan+2,nchan+2))
c         write(*,*)"Correlation coefficient:",covar(nchan+2,nchan+1)
c    +            /sqrt(covar(nchan+2,nchan+2)*covar(nchan+1,nchan+1))
        end if
c       write(*,*)"Reduced chisq of fitting:",chisq/(nbins*nchan-1-mfit)

c       Better value than before
        if(chisq/(nbins*nchan-1-mfit).lt.Rchi) then
           Rchi=chisq/(nbins*nchan-1-mfit)
           shift=a(nchan+1)*fac+shift0*fac
c          write(*,*)"Shift:",shift
c          if(shift/nbins.gt.0.5) then
c            shift=shift-dble(nbins)
c          endif
c          if(shift/nbins.lt.-0.5) then
c            shift=shift+dble(nbins)
c          endif

c      Times the variance from covariance matrix by reduced chi-square
c     eshift=sqrt(covar(nchan+1,nchan+1))*fac
           eshift=sqrt(covar(nchan+1,nchan+1)*Rchi)*fac
           if(mfit.eq.nchan+2) then
             dDM=a(nchan+2)
             edDM=sqrt(covar(nchan+2,nchan+2))
           endif
        endif
      enddo
c     write(*,*)"Reduced chisq of fitting:",Rchi

      return
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccc


      SUBROUTINE TB03AY( NR, A, LDA, INDBLK, NBLK, VCOEFF, LDVCO1,
     $                   LDVCO2, PCOEFF, LDPCO1, LDPCO2, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To calculate the (PWORK-by-NR) polynomial matrix V(s) one
C     (PWORK-by-NBLK(L-1)) block V:L-1(s) at a time, in reverse order
C     (L = INDBLK,...,1).  At each stage, the (NBLK(L)-by-NBLK(L)) poly-
C     nomial matrix W(s) = V2(s) * A2 is formed, where V2(s) is that
C     part of V(s) already computed and A2 is the subdiagonal (incl.)
C     part of the L-th column block of A; W(s) is temporarily stored in
C     the top left part of P(s), as is subsequently the further matrix
C     Wbar(s) = s * V:L(s) - W(s).  Then, except for the final stage
C     L = 1 (when the next step is to calculate P(s) itself, not here),
C     the top left part of V:L-1(s) is given by Wbar(s) * inv(R), where
C     R is the upper triangular part of the L-th superdiagonal block of
C     A.  Finally, note that the coefficient matrices W(.,.,K) can only
C     be non-zero for K = L + 1,...,INPLUS, with each of these matrices
C     having only its first NBLK(L-1) rows non-trivial.  Similarly,
C     Wbar(.,.,K) (and so clearly V:L-1(.,.,K) ) can only be non-zero
C     for K = L,...,INPLUS, with each of these having only its first
C     NBLK(K-1) rows non-trivial except for K = L, which has NBLK(L)
C     such rows.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Coprime matrix fraction, elementary polynomial operations,
C     polynomial matrix, state-space representation, transfer matrix.
C
C     NOTE: In the interests of speed, this routine does not check the
C           inputs for errors.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INDBLK, INFO, LDA, LDPCO1, LDPCO2, LDVCO1,
     $                  LDVCO2, NR
C     .. Array Arguments ..
      INTEGER           NBLK(*)
      DOUBLE PRECISION  A(LDA,*), PCOEFF(LDPCO1,LDPCO2,*),
     $                  VCOEFF(LDVCO1,LDVCO2,*)
C     .. Local Scalars ..
      INTEGER           I, INPLUS, IOFF, J, JOFF, K, KPLUS, L, LSTART,
     $                  LSTOP, LWORK, NCOL, NROW
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DGEMM, DLACPY, DSCAL, DTRSM
C     .. Executable Statements ..
C
      INFO = 0
      INPLUS = INDBLK + 1
      JOFF = NR
C
C     Calculate each column block V:LWORK-1(s) of V(s) in turn.
C
      DO 70 L = 1, INDBLK
         LWORK = INPLUS - L
C
C        Determine number of columns of V:LWORK(s) & its position in V.
C
         NCOL = NBLK(LWORK)
         JOFF = JOFF - NCOL
C
C        Find limits for V2(s) * A2 calculation: skips zero rows
C        in V(s).
C
         LSTART = JOFF + 1
         LSTOP = JOFF
C
C        Calculate W(s) and store (temporarily) in top left part
C        of P(s).
C
         DO 10 K = LWORK + 1, INPLUS
            NROW = NBLK(K-1)
            LSTOP = LSTOP + NROW
            CALL DGEMM( 'No transpose', 'No transpose', NROW, NCOL,
     $                  LSTOP-LSTART+1, ONE, VCOEFF(1,LSTART,K), LDVCO1,
     $                  A(LSTART,JOFF+1), LDA, ZERO, PCOEFF(1,1,K),
     $                  LDPCO1 )
   10    CONTINUE
C
C        Replace W(s) by Wbar(s) = s * V:L(s) - W(s).
C
         NROW = NCOL
C
         DO 30 K = LWORK, INDBLK
            KPLUS = K + 1
C
            DO 20 J = 1, NCOL
               CALL DSCAL( NROW, -ONE, PCOEFF(1,J,K), 1 )
               CALL DAXPY( NROW, ONE, VCOEFF(1,JOFF+J,KPLUS), 1,
     $                     PCOEFF(1,J,K), 1 )
   20       CONTINUE
C
            NROW = NBLK(K)
   30    CONTINUE
C
         DO 40 J = 1, NCOL
            CALL DSCAL( NROW, -ONE, PCOEFF(1,J,INPLUS), 1 )
   40    CONTINUE
C
         IF ( LWORK.NE.1 ) THEN
C
C           If not final stage, use the upper triangular R (from A)
C           to calculate V:L-1(s), finally storing this new block.
C
            IOFF = JOFF - NBLK(LWORK-1)
C
            DO 50 I = 1, NCOL
               IF ( A(IOFF+I,JOFF+I).EQ.ZERO ) THEN
C
C                 Error return.
C
                  INFO = I
                  RETURN
               END IF
   50       CONTINUE
C
            NROW = NBLK(LWORK)
C
            DO 60 K = LWORK, INPLUS
               CALL DLACPY( 'Full', NROW, NCOL, PCOEFF(1,1,K), LDPCO1,
     $                      VCOEFF(1,IOFF+1,K), LDVCO1 )
               CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit',
     $                     NROW, NCOL, ONE, A(IOFF+1,JOFF+1), LDA,
     $                     VCOEFF(1,IOFF+1,K), LDVCO1 )
               NROW = NBLK(K)
   60       CONTINUE
C
         END IF
   70 CONTINUE
C
      RETURN
C *** Last line of TB03AY ***
      END


      SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the dual right (left) polynomial matrix representation of
C     a given left (right) polynomial matrix representation, where the
C     right and left polynomial matrix representations are of the form
C     Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LERI    CHARACTER*1
C             Indicates whether a left or right matrix fraction is input
C             as follows:
C             = 'L':  A left matrix fraction is input;
C             = 'R':  A right matrix fraction is input.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     INDLIM  (input) INTEGER
C             The highest value of K for which PCOEFF(.,.,K) and
C             QCOEFF(.,.,K) are to be transposed.
C             K = kpcoef + 1, where kpcoef is the maximum degree of the
C             polynomials in P(s).  INDLIM >= 1.
C
C     PCOEFF  (input/output) DOUBLE PRECISION array, dimension
C             (LDPCO1,LDPCO2,INDLIM)
C             If LERI = 'L' then porm = P, otherwise porm = M.
C             On entry, the leading porm-by-porm-by-INDLIM part of this
C             array must contain the coefficients of the denominator
C             matrix P(s).
C             PCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of
C             polynomial (I,J) of P(s), where K = 1,2,...,INDLIM.
C             On exit, the leading porm-by-porm-by-INDLIM part of this
C             array contains the coefficients of the denominator matrix
C             P'(s) of the dual system.
C
C     LDPCO1  INTEGER
C             The leading dimension of array PCOEFF.
C             LDPCO1 >= MAX(1,P) if LERI = 'L',
C             LDPCO1 >= MAX(1,M) if LERI = 'R'.
C
C     LDPCO2  INTEGER
C             The second dimension of array PCOEFF.
C             LDPCO2 >= MAX(1,P) if LERI = 'L',
C             LDPCO2 >= MAX(1,M) if LERI = 'R'.
C
C     QCOEFF  (input/output) DOUBLE PRECISION array, dimension
C             (LDQCO1,LDQCO2,INDLIM)
C             On entry, the leading P-by-M-by-INDLIM part of this array
C             must contain the coefficients of the numerator matrix
C             Q(s).
C             QCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of
C             polynomial (I,J) of Q(s), where K = 1,2,...,INDLIM.
C             On exit, the leading M-by-P-by-INDLIM part of the array
C             contains the coefficients of the numerator matrix Q'(s)
C             of the dual system.
C
C     LDQCO1  INTEGER
C             The leading dimension of array QCOEFF.
C             LDQCO1 >= MAX(1,M,P).
C
C     LDQCO2  INTEGER
C             The second dimension of array QCOEFF.
C             LDQCO2 >= MAX(1,M,P).
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
C     METHOD
C
C     If the given M-input/P-output left (right) polynomial matrix
C     representation has numerator matrix Q(s) and denominator matrix
C     P(s), its dual P-input/M-output right (left) polynomial matrix
C     representation simply has numerator matrix Q'(s) and denominator
C     matrix P'(s).
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TC01CD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, March 1982.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Coprime matrix fraction, elementary polynomial operations,
C     polynomial matrix, state-space representation, transfer matrix.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER         LERI
      INTEGER           INFO, INDLIM, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M,
     $                  P
C     .. Array Arguments ..
      DOUBLE PRECISION  PCOEFF(LDPCO1,LDPCO2,*), QCOEFF(LDQCO1,LDQCO2,*)
C     .. Local Scalars ..
      LOGICAL           LLERI
      INTEGER           J, K, MINMP, MPLIM, PORM
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LLERI = LSAME( LERI, 'L' )
      MPLIM = MAX( M, P )
      MINMP = MIN( M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( INDLIM.LT.1 ) THEN
         INFO = -4
      ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN
         INFO = -6
      ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF( LDQCO1.LT.MAX( 1, MPLIM ) ) THEN
         INFO = -9
      ELSE IF( LDQCO2.LT.MAX( 1, MPLIM ) ) THEN
         INFO = -10
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TC01OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 .OR. P.EQ.0 )
     $   RETURN
C
      IF ( MPLIM.NE.1 ) THEN
C
C        Non-scalar system: transpose numerator matrix Q(s).
C
         DO 20 K = 1, INDLIM
C
            DO 10 J = 1, MPLIM
               IF ( J.LT.MINMP ) THEN
                  CALL DSWAP( MINMP-J, QCOEFF(J+1,J,K), 1,
     $                        QCOEFF(J,J+1,K), LDQCO1 )
               ELSE IF ( J.GT.P ) THEN
                  CALL DCOPY( P, QCOEFF(1,J,K), 1, QCOEFF(J,1,K),
     $                        LDQCO1 )
               ELSE IF ( J.GT.M ) THEN
                  CALL DCOPY( M, QCOEFF(J,1,K), LDQCO1, QCOEFF(1,J,K),
     $                        1 )
               END IF
   10       CONTINUE
C
   20    CONTINUE
C
C        Find dimension of denominator matrix P(s): M (P) for
C        right (left) polynomial matrix representation.
C
         PORM = M
         IF ( LLERI ) PORM = P
         IF ( PORM.NE.1 ) THEN
C
C           Non-scalar P(s): transpose it.
C
            DO 40 K = 1, INDLIM
C
               DO 30 J = 1, PORM - 1
                  CALL DSWAP( PORM-J, PCOEFF(J+1,J,K), 1,
     $                        PCOEFF(J,J+1,K), LDPCO1 )
   30          CONTINUE
C
   40       CONTINUE
C
         END IF
      END IF
C
      RETURN
C *** Last line of TC01OD ***
      END


      DOUBLE PRECISION FUNCTION erf1(x)
C-----------------------------------------------------------------------
C             EVALUATION OF THE REAL ERROR FUNCTION
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ax,bot,c,t,top,x2
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION a(5),b(3),p(8),q(8),r(5),s(4)
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp,sign
C     ..
C     .. Data statements ..
C-------------------------
C-------------------------
C-------------------------
C-------------------------
      DATA c/.564189583547756D0/
      DATA a(1)/.771058495001320D-04/,a(2)/-.133733772997339D-02/,
     +     a(3)/.323076579225834D-01/,a(4)/.479137145607681D-01/,
     +     a(5)/.128379167095513D+00/
      DATA b(1)/.301048631703895D-02/,b(2)/.538971687740286D-01/,
     +     b(3)/.375795757275549D+00/
      DATA p(1)/-1.36864857382717D-07/,p(2)/5.64195517478974D-01/,
     +     p(3)/7.21175825088309D+00/,p(4)/4.31622272220567D+01/,
     +     p(5)/1.52989285046940D+02/,p(6)/3.39320816734344D+02/,
     +     p(7)/4.51918953711873D+02/,p(8)/3.00459261020162D+02/
      DATA q(1)/1.00000000000000D+00/,q(2)/1.27827273196294D+01/,
     +     q(3)/7.70001529352295D+01/,q(4)/2.77585444743988D+02/,
     +     q(5)/6.38980264465631D+02/,q(6)/9.31354094850610D+02/,
     +     q(7)/7.90950925327898D+02/,q(8)/3.00459260956983D+02/
      DATA r(1)/2.10144126479064D+00/,r(2)/2.62370141675169D+01/,
     +     r(3)/2.13688200555087D+01/,r(4)/4.65807828718470D+00/,
     +     r(5)/2.82094791773523D-01/
      DATA s(1)/9.41537750555460D+01/,s(2)/1.87114811799590D+02/,
     +     s(3)/9.90191814623914D+01/,s(4)/1.80124575948747D+01/
C     ..
C     .. Executable Statements ..
C-------------------------
      ax = abs(x)
      IF (ax.GT.0.5D0) GO TO 10
      t = x*x
      top = ((((a(1)*t+a(2))*t+a(3))*t+a(4))*t+a(5)) + 1.0D0
      bot = ((b(1)*t+b(2))*t+b(3))*t + 1.0D0
      erf1 = x* (top/bot)
      RETURN
C
   10 IF (ax.GT.4.0D0) GO TO 20
      top = ((((((p(1)*ax+p(2))*ax+p(3))*ax+p(4))*ax+p(5))*ax+p(6))*ax+
     +      p(7))*ax + p(8)
      bot = ((((((q(1)*ax+q(2))*ax+q(3))*ax+q(4))*ax+q(5))*ax+q(6))*ax+
     +      q(7))*ax + q(8)
      erf = 0.5D0 + (0.5D0-exp(-x*x)*top/bot)
      IF (x.LT.0.0D0) erf1 = -erf1
      RETURN
C
   20 IF (ax.GE.5.8D0) GO TO 30
      x2 = x*x
      t = 1.0D0/x2
      top = (((r(1)*t+r(2))*t+r(3))*t+r(4))*t + r(5)
      bot = (((s(1)*t+s(2))*t+s(3))*t+s(4))*t + 1.0D0
      erf1 = (c-top/ (x2*bot))/ax
      erf1 = 0.5D0 + (0.5D0-exp(-x2)*erf1)
      IF (x.LT.0.0D0) erf1 = -erf1
      RETURN
C
   30 erf1 = sign(1.0D0,x)
      RETURN

      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!cd incompressible for long orifices (eq.6)
!
!     author: Yannick Muller
!
       subroutine pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl)
!
       implicit none
!
      real*8 lqd,rqd,reynolds,beta,cdi_rl,rqd_cor,lrqd,cdi_r,glrqd
!
      rqd_cor=rqd
!
      if (rqd_cor.gt.lqd) then
         rqd_cor=lqd
      endif
!
      lrqd=lqd-rqd_cor
!
      call pk_cdi_r(rqd_cor,reynolds,beta,cdi_r)
!
      glrqd=(1d0+1.298d0*exp(-1.593d0*lrqd**2.33d0))
     &     *(0.435d0+0.021d0*lrqd)/(2.298d0*0.435d0)
!
      cdi_rl=1.d0-glrqd*(1.d0-cdi_r)
!
      return
!
      end