!>  \file sfc_diff.f
!! This file contains the surface roughness length formulation based on
!! the surface sublayer scheme in
!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998.

!> This module contains the CCPP-compliant GFS surface layer scheme.
      module sfc_ex_coef
      contains

      subroutine sfc_ex_coef_init
      end subroutine sfc_ex_coef_init

      subroutine sfc_ex_coef_finalize
      end subroutine sfc_ex_coef_finalize

!> \defgroup GFS_diff_main GFS sfc_diff Main
!! @{
!> \brief This subroutine calculates surface roughness length.
!!
!! This subroutine includes the surface roughness length formulation
!! based on the surface sublayer scheme in
!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998.
!> \section arg_table_sfc_ex_coef_run Argument Table
!! | local_name     | standard_name                                                                | long_name                                                        | units      | rank | type      |    kind   | intent | optional |
!! |----------------|------------------------------------------------------------------------------|------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------|
!! | im             | horizontal_loop_extent                                                       | horizontal loop extent                                           | count      |    0 | integer   |           | in     | F        |
!! | ps             | surface_air_pressure                                                         | surface pressure                                                 | Pa         |    1 | real      | kind_phys | in     | F        |
!! | u1             | x_wind_at_lowest_model_layer                                                 | x component of 1st model layer wind                              | m s-1      |    1 | real      | kind_phys | in     | F        |
!! | v1             | y_wind_at_lowest_model_layer                                                 | y component of 1st model layer wind                              | m s-1      |    1 | real      | kind_phys | in     | F        |
!! | t1             | air_temperature_at_lowest_model_layer                                        | 1st model layer air temperature                                  | K          |    1 | real      | kind_phys | in     | F        |
!! | q1             | water_vapor_specific_humidity_at_lowest_model_layer                          | 1st model layer specific humidity                                | kg kg-1    |    1 | real      | kind_phys | in     | F        |
!! | z1             | height_above_ground_at_lowest_model_layer                                    | height above ground at 1st model layer                           | m          |    1 | real      | kind_phys | in     | F        |
!! | snwdph         | surface_snow_thickness_water_equivalent                                      | water equivalent surface snow thickness                          | mm         |    1 | real      | kind_phys | in     | F        |
!! | tskin          | surface_skin_temperature                                                     | surface skin temperature                                         | K          |    1 | real      | kind_phys | in     | F        |
!! | z0rl           | surface_roughness_length                                                     | surface roughness length                                         | cm         |    1 | real      | kind_phys | inout  | F        |
!! | cm             | surface_drag_coefficient_for_momentum_in_air                                 | surface exchange coeff for momentum                              | none       |    1 | real      | kind_phys | inout  | F        |
!! | ch             | surface_drag_coefficient_for_heat_and_moisture_in_air                        | surface exchange coeff heat & moisture                           | none       |    1 | real      | kind_phys | inout  | F        |
!! | rb             | bulk_richardson_number_at_lowest_model_level                                 | bulk Richardson number at the surface                            | none       |    1 | real      | kind_phys | inout  | F        |
!! | prsl1          | air_pressure_at_lowest_model_layer                                           | Model layer 1 mean pressure                                      | Pa         |    1 | real      | kind_phys | in     | F        |
!! | prslki         | ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer | Exner function ratio bt midlayer and interface at 1st layer      | ratio      |    1 | real      | kind_phys | in     | F        |
!! | islimsk        | sea_land_ice_mask                                                            | landmask: sea/land/ice=0/1/2                                     | flag       |    1 | integer   |           | in     | F        |
!! | stress         | surface_wind_stress                                                          | surface wind stress                                              | m2 s-2     |    1 | real      | kind_phys | inout  | F        |
!! | fm             | Monin-Obukhov_similarity_function_for_momentum                               | Monin-Obukhov similarity parameter for momentum                  | none       |    1 | real      | kind_phys | inout  | F        |
!! | fh             | Monin-Obukhov_similarity_function_for_heat                                   | Monin-Obukhov similarity parameter for heat                      | none       |    1 | real      | kind_phys | inout  | F        |
!! | ustar          | surface_friction_velocity                                                    | surface friction velocity                                        | m s-1      |    1 | real      | kind_phys | inout  | F        |
!! | wind           | wind_speed_at_lowest_model_layer                                             | wind speed at lowest model level                                 | m s-1      |    1 | real      | kind_phys | inout  | F        |
!! | ddvel          | surface_wind_enhancement_due_to_convection                                   | surface wind enhancement due to convection                       | m s-1      |    1 | real      | kind_phys | in     | F        |
!! | fm10           | Monin-Obukhov_similarity_function_for_momentum_at_10m                        | Monin-Obukhov similarity parameter for momentum                  | none       |    1 | real      | kind_phys | inout  | F        |
!! | fh2            | Monin-Obukhov_similarity_function_for_heat_at_2m                             | Monin-Obukhov similarity parameter for heat                      | none       |    1 | real      | kind_phys | inout  | F        |
!! | sigmaf         | bounded_vegetation_area_fraction                                             | areal fractional cover of green vegetation bounded on the bottom | frac       |    1 | real      | kind_phys | in     | F        |
!! | vegtype        | vegetation_type_classification                                               | vegetation type at each grid cell                                | index      |    1 | integer   |           | in     | F        |
!! | shdmax         | maximum_vegetation_area_fraction                                             | max fractnl cover of green veg                                   | frac       |    1 | real      | kind_phys | in     | F        |
!! | ivegsrc        | vegetation_type_dataset_choice                                               | land use dataset choice                                          | index      |    0 | integer   |           | in     | F        |
!! | z0pert         | perturbation_of_momentum_roughness_length                                    | perturbation of momentum roughness length                        | frac       |    1 | real      | kind_phys | in     | F        |
!! | ztpert         | perturbation_of_heat_to_momentum_roughness_length_ratio                      | perturbation of heat to momentum roughness length ratio          | frac       |    1 | real      | kind_phys | in     | F        |
!! | tsurf          | surface_skin_temperature_after_iteration                                     | surface skin temperature after iteration                         | K          |    1 | real      | kind_phys | in     | F        |
!! | flag_iter      | flag_for_iteration                                                           | flag for iteration                                               | flag       |    1 | logical   |           | in     | F        |
!! | redrag         | flag_for_reduced_drag_coefficient_over_sea                                   | flag for reduced drag coefficient over sea                       | flag       |    0 | logical   |           | in     | F        |
!! | errmsg         | ccpp_error_message                                                           | error message for error handling in CCPP                         | none       |    0 | character | len=*     | out    | F        |
!! | errflg         | ccpp_error_flag                                                              | error flag for error handling in CCPP                            | flag       |    0 | integer   |           | out    | F        |
!!
!>  \section general_diff GFS Surface Layer Scheme General Algorithm
!! @{
!! - Calculate the thermal roughness length formulation over the ocean (see eq. (25) and (26)
!!  in Zeng et al. (1998) \cite zeng_et_al_1998).
!! - Calculate Zeng's momentum roughness length formulation over land and sea ice.
!! - Calculate the new vegetation-dependent formulation of thermal roughness length
!! (Zheng et al.(2009) \cite zheng_et_al_2009).
!! Zheng et al. (2009) \cite zheng_et_al_2009 proposed a new formulation on
!! \f$ln(Z_{0m}^,/Z_{0t})\f$ as follows:
!! \f[
!!  ln(Z_{0m}^,/Z_{0t})=(1-GVF)^2C_{zil}k(u*Z_{0g}/\nu)^{0.5}
!! \f]
!! where \f$Z_{0m}^,\f$ is the effective momentum roughness length
!! computed in the following equation for each grid, \f$Z_{0t}\f$
!! is the roughness lenghth for heat, \f$C_{zil}\f$ is a coefficient
!! (taken as 0.8), k is the Von Karman constant (0.4),
!! \f$\nu=1.5\times10^{-5}m^{2}s^{-1}\f$ is the molecular viscosity,
!! \f$u*\f$ is the friction velocity, and \f$Z_{0g}\f$ is the bare
!! soil roughness length for momentum (taken as 0.01).
!! \n In order to consider the convergence of \f$Z_{0m}\f$ between
!! fully vegetated and bare soil, the effective \f$Z_{0m}^,\f$ is
!! computed:
!! \f[
!!  \ln(Z_{0m}^,)=(1-GVF)^{2}\ln(Z_{0g})+\left[1-(1-GVF)^{2}\right]\ln(Z_{0m})
!!\f]
!! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and \f$stress\f$ as inputs of other \a sfc schemes.
!!
      subroutine sfc_ex_coef_run                                        &
     &                   (im,ps,u1,v1,t1,q1,z1,                         &
     &                    snwdph,tskin,z0rl,cm,ch,rb,                   &
     &                    prsl1,prslki,islimsk,                         &
     &                    stress,fm,fh,                                 &
     &                    ustar,wind,ddvel,fm10,fh2,                    &
     &                    sigmaf,vegtype,shdmax,ivegsrc,                &
     &                    z0pert,ztpert,                                &
     &                    tsurf,flag_iter,redrag,errmsg,errflg          &
     &                   )
!
      use machine , only : kind_phys
      use funcphys, only : fpvs
      use physcons, grav => con_g,       cp => con_cp                   &
     &,             rvrdm1 => con_fvirt, rd => con_rd                   &
     &,             eps => con_eps, epsm1 => con_epsm1
!
      implicit none
!
      integer, intent(in) :: im, ivegsrc
      real(kind=kind_phys), dimension(im), intent(in) ::                &
     &                                       ps,  u1, v1, t1, q1, z1
      real(kind=kind_phys), dimension(im), intent(in) ::                &
     &                                       snwdph, tskin, prsl1       &
     &,                                      prslki
      real(kind=kind_phys), dimension(im), intent(inout) ::             &
     &                                       z0rl
      real(kind=kind_phys), dimension(im), intent(inout) ::             &
     &                                       cm,  ch, rb

      real(kind=kind_phys), dimension(im), intent(inout) ::             &
     &                                       stress, fm, fh, ustar, wind
      real(kind=kind_phys), dimension(im), intent(in) ::                &
     &                                       ddvel
      real(kind=kind_phys), dimension(im), intent(inout) ::             &
     &                                       fm10, fh2
      real(kind=kind_phys), dimension(im), intent(in) ::                &
     &                                       sigmaf, shdmax, tsurf
      real(kind=kind_phys), dimension(im), intent(in) ::                &
     &                                       z0pert,ztpert
      integer, dimension(im), intent(in) ::  vegtype, islimsk
!
      logical, intent(in) :: flag_iter(im)
      logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han)
!
      character(len=*), intent(out) :: errmsg
      integer,          intent(out) :: errflg
!
!     locals
!
      integer   i
!
      real(kind=kind_phys) aa,     aa0,    bb,     bb0, dtv,   adtv,qs1,&
     &                     hl1,    hl12,   pm,     ph,  pm10,  ph2, rat,&
     &                     thv1,   tvs,    z1i,    z0,  z0max, ztmax,   &
     &                     fms,    fhs,    hl0,    hl0inf, hlinf,       &
     &                     hl110,  hlt,    hltinf, olinf,               &
     &                     restar, czilc,  tem1,   tem2, ztmax1
!
      real(kind=kind_phys), parameter ::
     &              charnock=.014, ca=.4  ! ca - von karman constant
     &,             z0s_max=.317e-2       ! a limiting value at high winds over sea

     &,             alpha=5.,   a0=-3.975, a1=12.32, alpha4=4.0*alpha
     &,             b1=-7.755,  b2=6.041,  alpha2=alpha+alpha, beta=1.0
     &,             a0p=-7.941, a1p=24.75, b1p=-8.705, b2p=7.899
     &,             vis=1.4e-5, rnu=1.51e-5, visi=1.0/vis

     &,             log01=log(0.01), log05=log(0.05), log07=log(0.07)
     &,             ztmin1=-999.0

!     parameter (charnock=.014,ca=.4)!c ca is the von karman constant
!     parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041)
!     parameter (a0p=-7.941,a1p=24.75,b1p=-8.705,b2p=7.899,vis=1.4e-5)

!     real(kind=kind_phys) aa1,bb1,bb2,cc,cc1,cc2,arnu
!     parameter (aa1=-1.076,bb1=.7045,cc1=-.05808)
!     parameter (bb2=-.1954,cc2=.009999)
!     parameter (arnu=.135*rnu)
!
!    z0s_max=.196e-2 for u10_crit=25 m/s
!    z0s_max=.317e-2 for u10_crit=30 m/s
!    z0s_max=.479e-2 for u10_crit=35 m/s
!
! mbek -- toga-coare flux algorithm
!     parameter (rnu=1.51e-5,arnu=0.11*rnu)
!
      ! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0
!
!  initialize variables. all units are supposedly m.k.s. unless specified
!  ps is in pascals, wind is wind speed,
!  surface roughness length is converted to m from cm
!
      do i=1,im
        if(flag_iter(i)) then
          wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i))
     &                + max(0.0, min(ddvel(i), 30.0)), 1.0)
          tem1    = 1.0 + rvrdm1 * max(q1(i),1.e-8)
          thv1    = t1(i) * prslki(i) * tem1
          tvs     = 0.5 * (tsurf(i)+tskin(i)) * tem1
          qs1     = fpvs(t1(i))
          qs1     = max(1.0e-8, eps * qs1 / (prsl1(i) + epsm1 * qs1))

          z0      = 0.01 * z0rl(i)
          z0max   = max(1.0e-6, min(z0,z1(i)))
          z1i     = 1.0 / z1(i)

!  compute stability dependent exchange coefficients
!  this portion of the code is presently suppressed
!

          if(islimsk(i) == 0) then            ! over ocean
! - Over the ocean, calculate friction velocity in eq.(A10) in \cite zeng_et_al_1998 .
            ustar(i) = sqrt(grav * z0 / charnock)

!**  test xubin's new z0

!           ztmax  = z0max

! - Over the ocean, calculate the roughness Reynolds number:
            restar = max(ustar(i)*z0max*visi, 0.000001)

!           restar = log(restar)
!           restar = min(restar,5.)
!           restar = max(restar,-5.)
!           rat    = aa1 + (bb1 + cc1*restar) * restar
!           rat    = rat    / (1. + (bb2 + cc2*restar) * restar))
!  rat taken from zeng, zhao and dickinson 1997

! - Over the ocean, calculate the roughness length of temperature
!! (see eq.(25) and (26) in Zeng et al.(1998) \cite zeng_et_al_1998).
            rat    = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57)
            ztmax  = z0max * exp(-rat)

          else                                ! over land and sea ice
!** xubin's new z0  over land and sea ice
            tem1 = 1.0 - shdmax(i)
            tem2 = tem1 * tem1
            tem1 = 1.0  - tem2

            if( ivegsrc == 1 ) then
! - Calculate the roughness length of momentum over land and sea ice.
              if (vegtype(i) == 10) then
                z0max = exp( tem2*log01 + tem1*log07 )
              elseif (vegtype(i) == 6) then
                z0max = exp( tem2*log01 + tem1*log05 )
              elseif (vegtype(i) == 7) then
!               z0max = exp( tem2*log01 + tem1*log01 )
                z0max = 0.01
              elseif (vegtype(i) == 16) then
!               z0max = exp( tem2*log01 + tem1*log01 )
                z0max = 0.01
              else
                z0max = exp( tem2*log01 + tem1*log(z0max) )
              endif

            elseif (ivegsrc == 2 ) then

                if (vegtype(i) == 7) then
                  z0max = exp( tem2*log01 + tem1*log07 )
                elseif (vegtype(i) == 8) then
                  z0max = exp( tem2*log01 + tem1*log05 )
                elseif (vegtype(i) == 9) then
!                 z0max = exp( tem2*log01 + tem1*log01 )
                  z0max = 0.01
                elseif (vegtype(i) == 11) then
!                 z0max = exp( tem2*log01 + tem1*log01 )
                  z0max = 0.01
                else
                  z0max = exp( tem2*log01 + tem1*log(z0max) )
                endif

            endif
! - Calculate the roughness length for heat (see eq.(1) of \cite zheng_et_al_2012 ) .
! mg, sfc-perts: add surface perturbations to z0max over land
!! Following Gehne et al. (2018) \cite gehne_et_al_2018, a perturbation of the momentum
!! roughness length (z0pert) is added using a logrithmic scaling. The spatial pattern of
!! z0pert is drawn from a normal distribution with a standard deviation of 0.14 while is
!! bounded between -0.5 and 0.5. Similarly, a perturbation of the ratio between the roughness
!! length for heat to the momentum roughness length (ztpert) is added. The spatial pattern
!! of ztpert is drawn from a normal distribution with a standard deviation of 0.08.

            if ( islimsk(i) == 1 .and. z0pert(i) /= 0.0 ) then
              z0max = z0max * (10.**z0pert(i))
            endif

            z0max = max(z0max,1.0e-6)
!
!           czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil
            czilc = 0.8

            tem1 = 1.0 - sigmaf(i)
            ztmax = z0max*exp( - tem1*tem1
     &                         * czilc*ca*sqrt(ustar(i)*(0.01/1.5e-05)))

! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land
            if ( islimsk(i) == 1  .and. ztpert(i) /= 0.0) then
              ztmax = ztmax * (10.**ztpert(i))
            endif

          endif       ! end of if(islimsk(i) == 0) then

          ztmax  = max(ztmax,1.0e-6)
          tem1   = z0max/z1(i)
          if (abs(1.0-tem1) > 1.0e-6) then
            ztmax1 = - beta*log(tem1)/(alpha2*(1.-tem1))
          else
            ztmax1 = 99.0
          endif
          if( z0max < 0.05 .and. snwdph(i) < 10.0 ) ztmax1 = 99.0

!  compute stability indices (rb and hlinf)

          dtv     = thv1 - tvs
          adtv    = max(abs(dtv),0.001)
          dtv     = sign(1.,dtv) * adtv
          rb(i)   = max(-5000.0, (grav+grav) * dtv * z1(i)
     &            / ((thv1 + tvs) * wind(i) * wind(i)))
          tem1    = 1.0 / z0max
          tem2    = 1.0 / ztmax
          fm(i)   = log((z0max+z1(i)) * tem1)
          fh(i)   = log((ztmax+z1(i)) * tem2)
          fm10(i) = log((z0max+10.)   * tem1)
          fh2(i)  = log((ztmax+2.)    * tem2)
          hlinf   = rb(i) * fm(i) * fm(i) / fh(i)
          hlinf   = min(max(hlinf,ztmin1),ztmax1)
!
!  stable case
!
          if (dtv >= 0.0) then
            hl1 = hlinf
            if(hlinf > .25) then
              tem1   = hlinf * z1i
              hl0inf = z0max * tem1
              hltinf = ztmax * tem1
              aa     = sqrt(1. + alpha4 * hlinf)
              aa0    = sqrt(1. + alpha4 * hl0inf)
              bb     = aa
              bb0    = sqrt(1. + alpha4 * hltinf)
              pm     = aa0 - aa + log( (aa + 1.)/(aa0 + 1.) )
              ph     = bb0 - bb + log( (bb + 1.)/(bb0 + 1.) )
              fms    = fm(i) - pm
              fhs    = fh(i) - ph
              hl1    = fms * fms * rb(i) / fhs
              hl1    = min(max(hl1, ztmin1), ztmax1)
            endif
!
!  second iteration
!
            tem1  = hl1 * z1i
            hl0   = z0max * tem1
            hlt   = ztmax * tem1
            aa    = sqrt(1. + alpha4 * hl1)
            aa0   = sqrt(1. + alpha4 * hl0)
            bb    = aa
            bb0   = sqrt(1. + alpha4 * hlt)
            pm    = aa0 - aa + log( (1.0+aa)/(1.0+aa0) )
            ph    = bb0 - bb + log( (1.0+bb)/(1.0+bb0) )
            hl110 = hl1 * 10. * z1i
            hl110 = min(max(hl110, ztmin1), ztmax1)
            aa    = sqrt(1. + alpha4 * hl110)
            pm10  = aa0 - aa + log( (1.0+aa)/(1.0+aa0) )
            hl12  = (hl1+hl1) * z1i
            hl12  = min(max(hl12,ztmin1),ztmax1)
!           aa    = sqrt(1. + alpha4 * hl12)
            bb    = sqrt(1. + alpha4 * hl12)
            ph2   = bb0 - bb + log( (1.0+bb)/(1.0+bb0) )
!
!  unstable case - check for unphysical obukhov length
!
          else                          ! dtv < 0 case
            olinf = z1(i) / hlinf
            tem1  = 50.0 * z0max
            if(abs(olinf) <= tem1) then
              hlinf = -z1(i) / tem1
              hlinf = min(max(hlinf,ztmin1),ztmax1)
            endif
!
!  get pm and ph
!
            if (hlinf >= -0.5) then
              hl1   = hlinf
              pm    = (a0  + a1*hl1)  * hl1   / (1.+ (b1+b2*hl1)  *hl1)
              ph    = (a0p + a1p*hl1) * hl1   / (1.+ (b1p+b2p*hl1)*hl1)
              hl110 = hl1 * 10. * z1i
              hl110 = min(max(hl110, ztmin1), ztmax1)
              pm10  = (a0 + a1*hl110) * hl110 / (1.+(b1+b2*hl110)*hl110)
              hl12  = (hl1+hl1) * z1i
              hl12  = min(max(hl12, ztmin1), ztmax1)
              ph2   = (a0p + a1p*hl12) * hl12 / (1.+(b1p+b2p*hl12)*hl12)
            else                       ! hlinf < 0.05
              hl1   = -hlinf
              tem1  = 1.0 / sqrt(hl1)
              pm    = log(hl1) + 2. * sqrt(tem1) - .8776
              ph    = log(hl1) + .5 * tem1 + 1.386
!             pm    = log(hl1) + 2.0 * hl1 ** (-.25) - .8776
!             ph    = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386
              hl110 = hl1 * 10. * z1i
              hl110 = min(max(hl110, ztmin1), ztmax1)
              pm10  = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776
!             pm10  = log(hl110) + 2. * hl110 ** (-.25) - .8776
              hl12  = (hl1+hl1) * z1i
              hl12  = min(max(hl12, ztmin1), ztmax1)
              ph2   = log(hl12) + 0.5 / sqrt(hl12) + 1.386
!             ph2   = log(hl12) + .5 * hl12 ** (-.5) + 1.386
            endif

          endif          ! end of if (dtv >= 0 ) then loop
!
!  finish the exchange coefficient computation to provide fm and fh
!
! - Finish the exchange coefficient computation to provide cm, ch, stress as input of other
! \a sfc schemes.
          fm(i)     = fm(i) - pm
          fh(i)     = fh(i) - ph
          fm10(i)   = fm10(i) - pm10
          fh2(i)    = fh2(i) - ph2
          cm(i)     = ca * ca / (fm(i) * fm(i))
          ch(i)     = ca * ca / (fm(i) * fh(i))
          tem1      = 0.00001/z1(i)
          cm(i) = max(cm(i), tem1)
          ch(i) = max(ch(i), tem1)
          stress(i) = cm(i) * wind(i) * wind(i)
          ustar(i)  = sqrt(stress(i))
!
!  update z0 over ocean
!
          if(islimsk(i) == 0) then
            z0 = (charnock / grav) * ustar(i) * ustar(i)

! mbek -- toga-coare flux algorithm
!           z0 = (charnock / grav) * ustar(i)*ustar(i) +  arnu/ustar(i)
!  new implementation of z0
!           cc = ustar(i) * z0 / rnu
!           pp = cc / (1. + cc)
!           ff = grav * arnu / (charnock * ustar(i) ** 3)
!           z0 = arnu / (ustar(i) * ff ** pp)

            if (redrag) then
              z0rl(i) = 100.0 * max(min(z0, z0s_max), 1.e-7)
            else
              z0rl(i) = 100.0 * max(min(z0,.1), 1.e-7)
            endif
          endif
        endif                ! end of if(flagiter) loop
      enddo

      return
      end subroutine sfc_ex_coef_run
!! @}
!! @}
      end module sfc_ex_coef


module Box3dModule

use NumberKindsModule
use UtilitiesModule
use SphereGeomModule
use LoggerModule

#include "LpmConfig.h"

implicit none
private

public Box3d
public BOX_PAD

type :: Box3d
   real(kreal) :: xmin, xmax
   real(kreal) :: ymin, ymax
   real(kreal) :: zmin, zmax
   real(kreal) :: min_radius, max_radius
   real(kreal), dimension(3) :: centroid
   real(kreal) :: volume
   real(kreal) :: aspectRatio

   contains
     procedure :: initSpecific
     procedure :: initPadded
     generic :: init => initSpecific, initPadded
     procedure :: containsPoint
     procedure :: bisectAll
     !procedure :: bisectAlongDims
     procedure :: logStats
     procedure :: minEdgeLength
     procedure :: maxEdgeLength
     procedure, private :: calc_min_radius
     procedure, private :: calc_max_radius
     procedure :: corners
     procedure :: faceCentroids
end type

real(kreal), parameter :: BOX_PAD = 0.00001

contains

pure subroutine initPadded(self, radius)
    class(Box3d), intent(inout) ::  self
    real(kreal), intent(in) :: radius

    self%xmin = -radius - BOX_PAD
    self%xmax = radius + BOX_PAD
    self%ymin = -radius - BOX_PAD
    self%ymax = radius + BOX_PAD
    self%zmin = -radius - BOX_PAD
    self%zmax = radius + BOX_PAD

    self%volume = (2.0_kreal * (radius + BOX_PAD))**3
    self%centroid = 0.0_kreal
    self%aspectRatio = 1.0_kreal
    self%min_radius = self%calc_min_radius()
    self%max_radius = self%calc_max_radius()
end subroutine

pure subroutine initSpecific(self, xmin, xmax, ymin, ymax, zmin, zmax)
  class(Box3d), intent(inout) :: self
  real(kreal), intent(in) :: xmin, xmax, ymin, ymax, zmin, zmax

  self%xmin = xmin
  self%xmax = xmax
  self%ymin = ymin
  self%ymax = ymax
  self%zmin = zmin
  self%zmax = zmax

  self%volume = (xmax-xmin)*(ymax-ymin)*(zmax-zmin)
  self%centroid = 0.5_kreal * [xmin+xmax, ymin+ymax, zmin+zmax]
  self%aspectRatio = self%maxEdgeLength() / self%minEdgeLength()
  self%min_radius = self%calc_min_radius()
  self%max_radius = self%calc_max_radius()
end subroutine

pure function minEdgeLength(self)
  real(kreal) :: minEdgeLength
  class(Box3d), intent(in) :: self
  real(kreal), dimension(3) :: lens
  lens(1) = self%xmax - self%xmin
  lens(2) = self%ymax - self%ymin
  lens(3) = self%zmax - self%zmin
  minEdgeLength = minval(lens)
end function

pure function maxEdgeLength(self)
  real(kreal) :: maxEdgeLength
  class(Box3d), intent(in) :: self
  real(kreal), dimension(3) :: lens
  lens(1) = self%xmax-self%ymin
  lens(2) = self%ymax-self%ymin
  lens(3) = self%zmax-self%zmin
  maxEdgeLength = maxval(lens)
end function

pure function calc_min_radius(self)
  class(Box3d), intent(in) :: self
  real(kreal) :: calc_min_radius
  real(kreal), dimension(3, 6) :: face_locs
  integer(kint) :: i
  real(kreal) :: test_dist

  face_locs = self%faceCentroids()
  calc_min_radius = huge(1.0_kreal)
  do i=1, 6
    test_dist = ChordDistance(self%centroid, face_locs(:,i))
    if (test_dist < calc_min_radius) then
        calc_min_radius = test_dist
    endif
  enddo
end function

pure function calc_max_radius(self)
    real(kreal) :: calc_max_radius
    class(Box3d), intent(in) :: self
    real(kreal), dimension(3,8) :: corners
    integer(kint) :: i
    real(kreal) :: test_dist

    corners = self%corners()
    calc_max_radius = 0.0_kreal
    do i=1,8
        test_dist = ChordDistance(self%centroid, corners(:,i))
        if (test_dist > calc_max_radius) then
            calc_max_radius = test_dist
        endif
    enddo
end function

pure function faceCentroids(self)
    real(kreal), dimension(3,6) :: faceCentroids
    class(Box3d), intent(in) :: self
    real(kreal) :: midx, midy, midz
    midx = 0.5_kreal*(self%xmin + self%xmax)
    midy = 0.5_kreal*(self%ymin + self%ymax)
    midz = 0.5_kreal*(self%zmin + self%zmax)
    faceCentroids(:,1) = [midx, self%ymin, midz]
    faceCentroids(:,2) = [self%xmax, midy, midz]
    faceCentroids(:,3) = [midx, self%ymax, midz]
    faceCentroids(:,4) = [self%xmin, midy, midz]
    faceCentroids(:,5) = [midx, midy, self%zmin]
    faceCentroids(:,6) = [midx, midy, self%zmax]
end function

pure function corners(self)
    real(kreal), dimension(3,8) :: corners
    class(Box3d), intent(in) :: self
    corners(:,1) = [self%xmin, self%ymin, self%zmin]
    corners(:,2) = [self%xmin, self%ymax, self%zmin]
    corners(:,3) = [self%xmin, self%ymin, self%zmax]
    corners(:,4) = [self%xmin, self%ymax, self%zmax]
    corners(:,5) = [self%xmax, self%ymin, self%zmin]
    corners(:,6) = [self%xmax, self%ymax, self%zmin]
    corners(:,7) = [self%xmax, self%ymin, self%zmax]
    corners(:,8) = [self%xmax, self%ymax, self%zmax]
end function

pure function containsPoint(self, queryPt)
    logical(klog) :: containsPoint
    class(Box3d), intent(in) :: self
    real(kreal), dimension(3), intent(in) :: queryPt
    containsPoint = (self%xmin <= queryPt(1) .and. queryPt(1) <= self%xmax) .and. &
                    (self%ymin <= queryPt(2) .and. queryPt(2) <= self%ymax) .and. &
                    (self%zmin <= queryPt(3) .and. queryPt(3) <= self%zmax)
end function

pure function bisectAll(self)
    type(Box3d), dimension(8) :: bisectAll
    class(Box3d), intent(in) :: self
    real(kreal) :: midx, midy, midz
    midx = 0.5_kreal*(self%xmin + self%xmax)
    midy = 0.5_kreal*(self%ymin + self%ymax)
    midz = 0.5_kreal*(self%zmin + self%zmax)

    call bisectAll(1)%init(self%xmin, midx, self%ymin, midy, self%zmin, midz)
    call bisectAll(2)%init(midx, self%xmax, self%ymin, midy, self%zmin, midz)
    call bisectAll(3)%init(self%xmin, midx, midy, self%ymax, self%zmin, midz)
    call bisectAll(4)%init(midx, self%xmax, midy, self%ymax, self%zmin, midz)
    call bisectAll(5)%init(self%xmin, midx, self%ymin, midy, midz, self%zmax)
    call bisectAll(6)%init(midx, self%xmax, self%ymin, midy, midz, self%zmax)
    call bisectAll(7)%init(self%xmin, midx, midy, self%ymax, midz, self%zmax)
    call bisectAll(8)%init(midx, self%xmax, midy, self%ymax, midz, self%zmax)
end function

subroutine logStats(self, aLog)
    class(Box3d), intent(in) :: self
    type(Logger), intent(inout) :: aLog
    character(len=256) :: infostring

    call StartSection(aLog)
    write(infostring,'(6(A,G10.4),A)') 'x in [', self%xmin, ', ', self%xmax, &
        ']; y in [', self%ymin, ', ', self%ymax, ']; z in [', self%zmin, ', ', self%zmax, ']'
    call LogMessage(aLog, TRACE_LOGGING_LEVEL, "box info: ", trim(infostring))
    call LogMessage(aLog, TRACE_LOGGING_LEVEL, "volume = ", self%volume)
    call LogMessage(aLog, TRACE_LOGGING_LEVEL, "aspect ratio = ", self%aspectRatio)
    call LogMessage(aLog, TRACE_LOGGING_LEVEL, "min_radius = ", self%min_radius)
    call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max_radius = ", self%max_radius)
    call LogMessage(aLog, TRACE_LOGGING_LEVEL, "centroid = ", self%centroid)
    call EndSection(aLog)
end subroutine

end module


      SUBROUTINE CFEER4
C
C     CFEER4 OBTAINS THE EIGENVALUES AND EIGENVECTORS FROM THE
C     REDUCED TRIDIAGONAL MATRIX FOR THE COMPLEX FEER METHOD
C
      LOGICAL           NO B     ,DECREM   ,QPR      ,LZ(1)     ,
     1                  DPMACH
      INTEGER           NAME(2)  ,IZ(1)    ,EOR
      INTEGER           WRTREW
      DOUBLE PRECISION  LAMBDA   ,EPS      ,DZ(1)    ,D(4)      ,
     1                  LAM1(2)
      DIMENSION         S(8)     ,DMP1(2)  ,ALAM(2)  ,DM(2)     ,
     1                  STATUS(2),ACCEPT(2),REJECT(2)
      CHARACTER         UFM*23   ,UWM*25   ,UIM*29
      COMMON  /XMSSG /  UFM      ,UWM      ,UIM
      COMMON  /FEERAA/  IKMB(21) ,ILAM(7)  ,IPHI(7)  ,IDMPFL    ,
     1                  ISCR(11) ,DUMAA(84),MCBVEC(7)
      COMMON  /FEERXC/  LAMBDA(2),SWDUM    ,MREDUC   ,NORD      ,
     1                  IDIAG    ,EPS      ,NORTHO   ,NORD2     ,
     2                  NORD4    ,NORDP1   ,NSWP(2)  ,NO B      ,
     3                  IT       ,TEN2MT   ,TENMHT   ,NSTART    ,
     4                  QPR      ,JREG     ,NOREG    ,NZERO     ,
     5                  TENMTT   ,MINOPN
      COMMON  /ZZZZZZ/  Z(1)
      COMMON  /UNPAKX/  IPRC     ,II       ,NN       ,INCR
      COMMON  /SYSTEM/  KSYSTM(65)
      COMMON  /NAMES /  RD       ,RDREW    ,WRT      ,WRTREW    ,
     1                  REW      ,NOREW    ,EOFNRW
      EQUIVALENCE       (KSYSTM(2 ),NOUT ) ,(NROW,MREDUC)       ,
     1                  (KSYSTM(55),IPREC) ,(D(1),S(1)  )       ,
     2                  (Z(1),IZ(1),LZ(1),DZ(1))
      DATA     NAME  /  4HCFEE,4HR4  /
      DATA     ACCEPT,  REJECT/4H  AC,4HCEPT,4H -RE,4HJECT      /
C
C     CORE ALLOCATION FOR ALLMAT
C
C     CONTENTS                SIZE             POINTER   TYPE   NAME
C     --------                ----             -------   ----   ----
C     INPUT MATRIX--VECTORS   2*NROW*NROW      IA        COMP   A
C     EIGENVALUES             2*NROW           IL        COMP   LAM
C     H  MATRIX               2*NROW*NROW      IH        COMP   H
C     HL MATRIX               2*NROW*NROW      IHL       COMP   HL
C     VECTOR STORAGE          2*NROW           IV        COMP   VEC
C     MULTIPLIERS             2*NROW           IM        COMP   MULT
C     INTH                    NROW             INTH      INTG   INTH
C     INTQ                    NROW             INTQ      LOGL   INTQ
C
C     CORE ALLOCATION AFTER ALLMAT IS FINISHED
C
C     ALLMAT OUTPUT EIGENVECTORS               IA
C     EIGENVALUES                              IL
C     ORDER OF EXTRACTION                      IH
C     THEORETICAL ERRORS                       IHL
C     NOT USED                                 IV,IM
C     STATUS OF SOLUTIONS                      INTH
C     DISTANCES FROM CENTER                    INTQ
C     VARIABLE PRECISION PHYSICAL EIGENVECTORS IV1
C     VARIABLE PRECISION ORTHOGONAL VECTORS    IV2
C
C     DEFINITION OF INTERNAL PARAMETERS
C
C     DMP1     = D-SUB-M-PLUS-1 = EXTRANEOUS OFF-DIAGONAL ELEMENT
C                OF REDUCED TRIDIAGONAL MATRIX, USED FOR COMPUTING
C                THEORETICAL ERRORS
C     DM       = FINAL OFF-DIAGONAL ELEMENT OF REDUCED TRIDIAGONAL
C                MATRIX
C     NO B     = LOGICAL INDICATOR FOR ABSENCE OF DAMPING MATRIX B
C     DECREM   = LOGICAL INDICATOR FOR DECREMENTED SIZE OF REDUCED
C                PROBLEM
C     NROW     = SIZE OF THE REDUCED PROBLEM (EQUIVALENT TO MREDUC)
C     RMS      = ROOT-MEAN-SQUARE OF EIGENVALUES, USED IN RIGID-BODY
C                ERROR TEST
C     NOTE.....SEE LISTING OF CFCNTL FOR ADDITIONAL DEFINITIONS
C
      IF (QPR) WRITE (NOUT,600)
      DPMACH = IPREC .EQ. 2
      NORD8  = 2*NORD4
      DECREM = .FALSE.
    4 NROW2  = 2*NROW
      NROWSQ = NROW*NROW2
C
C     ALLOCATE CORE FOR ALLMAT
C
      IA  = 1
      IL  = IA  + NROWSQ
      IH  = IL  + NROW2
      IHL = IH  + NROWSQ
      IV  = IHL + NROWSQ
      IM  = IV  + NROW2
      INTH= IM  + NROW2
      INTQ= INTH+ NROW
C
C     ALLOCATE CORE FOR PHYSICAL EIGENVECTORS (LEFT FOLLOWS RIGHT)
C
      IV1 = INTQ + NROW
      IV2 = IV1  + NORD8
      IF (DPMACH .AND. MOD(IV2,2).EQ.0) IV2 = IV2 + 1
      IV1X = IV1 - 1
C
C     TEST FOR INSUFFICIENT CORE
C
      NZ    = KORSZ(Z(1))
      IBUF1 = NZ    - KSYSTM(1)
      IBUF2 = IBUF1 - KSYSTM(1)
      IOPN  = IBUF2 - (IV2 + NORD8)
      IF (IDIAG .NE. 0) WRITE (NOUT,610) IOPN
      IF (IOPN  .LE. 0) CALL MESAGE (-8,0,NAME(1))
      IF (IOPN .LT. MINOPN) MINOPN = IOPN
      IF (NSWP(2)  .LT.  0) GO TO 209
C
C     CONSTRUCT REDUCED TRIDIAGONAL MATRIX
C
      DO 10 I = IA,IL
   10 Z(I) = 0.
      NROW22 = NROW2 + 2
      CALL GOPEN (ISCR(5),Z(IBUF1),RDREW)
      NW  = 4*IPREC
      EOR = 1
      M   = 0
      NROW1 = NROW - 1
C
C     ENTER LOOP
C
      DO 20 I = 1,NROW
      I1 = I - 1
      CALL READ (*420,*430,ISCR(5),S(1),NW,EOR,M)
      IF (QPR .AND. .NOT.DPMACH) WRITE (NOUT,620) I,(S(J),J=1,4)
      IF (QPR .AND.      DPMACH) WRITE (NOUT,630) I,(D(J),J=1,4)
C
C     ALLMAT ACCEPTS ONLY SINGLE PRECISION ARRAY
C
      J = IA + NROW22*I1
      IF (.NOT.DPMACH) GO TO 15
C
C     LOAD MAIN DIAGONAL ELEMENT
C
      Z(J  ) = D(3)
      Z(J+1) = D(4)
      IF (I .NE. NROW1) GO TO 12
C
C     SAVE LAST OFF-DIAGONAL ELEMENT
C
      DM(1) = D(1)
      DM(2) = D(2)
   12 IF (I .EQ. NROW) GO TO 20
C
C     LOAD OFF-DIAGONAL ELEMENTS
C
      Z(J+2) = D(1)
      Z(J+3) = D(2)
      J  = J + NROW2
      Z(J  ) = D(1)
      Z(J+1) = D(2)
      GO TO 20
C
C     LOAD MAIN DIAGONAL ELEMENT
C
   15 Z(J  ) = S(3)
      Z(J+1) = S(4)
      IF (I .NE. NROW1) GO TO 16
C
C     SAVE LAST OFF-DIAGONAL ELEMENT
C
      DM(1) = S(1)
      DM(2) = S(2)
   16 IF (I .EQ. NROW) GO TO 20
C
C     LOAD OFF-DIAGONAL ELEMENTS
C
      Z(J+2) = S(1)
      Z(J+3) = S(2)
      J  = J + NROW2
      Z(J  ) = S(1)
      Z(J+1) = S(2)
   20 CONTINUE
C
C     SAVE ERROR ELEMENT FROM TRIDIAGONAL MATRIX
C
      IF (.NOT.DPMACH) GO TO 25
      DMP1(1) = D(1)
      DMP1(2) = D(2)
      GO TO 26
   25 DMP1(1) = S(1)
      DMP1(2) = S(2)
   26 CONTINUE
      IF (QPR) WRITE (NOUT,640) (Z(I),I=1,NROWSQ)
      CALL CLOSE (ISCR(5),REW)
      IF (DECREM) GO TO 30
C
C     DECREMENT THE REDUCED PROBLEM SIZE IF THE ERROR ELEMENT IS NULL
C
      IF (DMP1(1).NE.0. .OR. DMP1(2).NE.0.) GO TO 30
      MREDUC = MREDUC - 1
      WRITE (NOUT,570) UWM,MREDUC
      IF (MREDUC .EQ. 0) GO TO 440
      IF (DM(1).NE.0. .OR. DM(2).NE.0.) GO TO 29
C
C     NEW ERROR ELEMENT IS ALSO NULL. RESTORE ORIGINAL REDUCED SIZE.
C
      MREDUC  = MREDUC + 1
      DMP1(1) = SNGL(EPS)
      WRITE (NOUT,590) UWM,MREDUC,DMP1
      GO TO 30
   29 DECREM = .TRUE.
      GO TO 4
C
   30 CALL ALLMAT (Z(IA),Z(IL),Z(IH),Z(IHL),Z(IV),Z(IM),Z(INTH),Z(INTQ),
     1             NROW,NROW,INIDUM)
C
C     --------------- SPECIAL PRINT -------------------------
C
      IF (.NOT.QPR) GO TO 4429
      WRITE  (NOUT,4408)
 4408 FORMAT (1H0,10X,15HALLMAT EXECUTED,/,1H0)
      J = IH - 1
      WRITE  (NOUT,4420) (Z(I),I=IL,J)
 4420 FORMAT (1H0,11HEIGENVALUES, //,(1H ,2E16.8))
      WRITE  (NOUT,4422)
 4422 FORMAT (1H0,12HEIGENVECTORS,//)
      DO 4428 I = 1,NROW
      L = IA + NROW2*(I-1)
      K = L  + NROW2 - 1
      WRITE (NOUT,4424) (Z(J),J=L,K)
C
C     CHECK NORMALITY
C
      SUMR = 0.
      SUMI = 0.
      DO 7760 J = L,K,2
      JJ   = J + 1
      SUMR = SUMR + Z(J)**2 - Z(JJ)**2
 7760 SUMI = SUMI + 2.*Z(J)*Z(JJ)
      WRITE  (NOUT,7770) SUMR,SUMI
 7770 FORMAT (//,35H SELF INNER-PRODUCT OF ABOVE VECTOR, /,1H ,6X,
     1        11HREAL PART =,E16.8,8X,16HIMAGINARY PART =,E16.8)
 4424 FORMAT (//,(1H ,6E16.8))
 4428 CONTINUE
 4429 CONTINUE
C     -------------------------------------------------------
C
C     NORMALIZE THE EIGENVECTORS OUTPUT FROM ALLMAT
C
      IF (QPR) WRITE (NOUT,4422)
      DO 36 I = 1,NROW
      L = IA + NROW2*(I-1)
      K = L  + NROW2 - 1
      SUMR = 0.
      SUMI = 0.
      DO 33 J = L,K,2
      JJ   = J + 1
      SUMR = SUMR + Z(J)**2 - Z(JJ)**2
   33 SUMI = SUMI + 2.*Z(J)*Z(JJ)
      RSQRT= SQRT(SQRT(SUMR**2 + SUMI**2))
      IF (RSQRT .GT. 0.) GO TO 34
      WRITE (NOUT,560) UWM,NAME
      GO TO 36
   34 THETA2= .5*ATAN2(SUMI,SUMR)
      SUMR  = RSQRT*COS(THETA2)
      SUMI  = RSQRT*SIN(THETA2)
      THETA2= 1./(SUMR**2 + SUMI**2)
      SUMR  = SUMR*THETA2
      SUMI  =-SUMI*THETA2
      DO 35 J = L,K,2
      JJ    = J + 1
      THETA2= Z(J)
      Z(J ) = SUMR*Z(J)   - SUMI*Z(JJ)
   35 Z(JJ) = SUMI*THETA2 + SUMR*Z(JJ)
C
C     -------------- SPECIAL PRINT --------------------------
C
      IF (.NOT.QPR) GO TO 36
      WRITE (NOUT,4424) (Z(J),J=L,K)
C
C     CHECK NORMALITY
C
      SUMR = 0.
      SUMI = 0.
      DO 1008 J = L,K,2
      JJ   = J + 1
      SUMR = SUMR + Z(J)**2 - Z(JJ)**2
 1008 SUMI = SUMI + 2.*Z(J)*Z(JJ)
      WRITE (NOUT,7770) SUMR,SUMI
C     -------------------------------------------------------
C
   36 CONTINUE
C
C     COMPUTE THEORETICAL EIGENVALUE ERRORS
C
      IF (QPR) WRITE (NOUT,650) DMP1
      IHL1 = IHL - 1
      DO 50 I = 1,NROW
      K = IL + 2*(I-1)
      DENOM = SQRT(Z(K)**2 + Z(K+1)**2)
      IF (DENOM .GT. 0.) GO TO 40
      WRITE (NOUT,550) UIM,I
      DENOM = 1.E-10
   40 DENOM = 1./DENOM
      K  = IA + NROW2*I - 2
      KK = K  + 1
      J  = IHL1 + I
      Z(J) = DENOM*SQRT((DMP1(1)*Z(K) - DMP1(2)*Z(KK))**2
     1     + (DMP1(1)*Z(KK) + DMP1(2)*Z(K))**2)
      IF (QPR) WRITE (NOUT,660) I,Z(J),Z(K),Z(KK),DENOM
   50 CONTINUE
C
C     RECOVER PHYSICAL EIGENVALUES
C
      RMS = 0.
      IF (NO B) GO TO 54
      ALAM(1) = LAMBDA(1)
      ALAM(2) = LAMBDA(2)
      GO TO 55
   54 ALAM(1) = LAMBDA(1)**2 - LAMBDA(2)**2
      ALAM(2) = 2.D0*LAMBDA(1)*LAMBDA(2)
   55 DO 70 I = 1,NROW
      K  = IL + 2*(I-1)
      KK = K  + 1
      DENOM = Z(K)**2 + Z(KK)**2
      IF (DENOM .EQ. 0.) DENOM = 1.E-20
      DENOM = 1./DENOM
      Z( K) = DENOM*Z( K) + ALAM(1)
      Z(KK) =-DENOM*Z(KK) + ALAM(2)
      IF (NO B) GO TO 60
      GO TO 70
C
C     DAMPING MATRIX ABSENT
C
   60 RSQRT  = SQRT(SQRT(Z(K)**2 + Z(KK)**2))
      THETA2 = .5*ATAN2(Z(KK),Z(K))
      Z( K)  = RSQRT*COS(THETA2)
      Z(KK)  = RSQRT*SIN(THETA2)
      IF (Z(KK) .GE. 0.) GO TO 70
      Z( K)  =-Z( K)
      Z(KK)  =-Z(KK)
C
C     COMPUTE RMS FOR RIGID-BODY ERROR TEST
C
   70 RMS = RMS + SQRT((Z(K)**2-Z(KK)**2)**2 + 4.*(Z(K)*Z(KK))**2)
      RMS = SQRT(RMS)/FLOAT(NROW)
      IF (QPR) WRITE (NOUT,800) RMS
      J  = IH - 1
      IF (QPR) WRITE (NOUT,4420) (Z(I),I=IL,J)
C
C     PERFORM RIGID-BODY ERROR TEST
C
      IF (RMS .LT. 1.E-20) RMS = 1.E-20
      RMS = 1./RMS
      DO 80 I = 1,NROW
      K = IL + 2*(I-1)
      J = IHL1 + I
      IF (RMS*SQRT(Z(K)**2+Z(K+1)**2) .LE. TENMTT) Z(J) = 0.
   80 CONTINUE
C
C     COMPUTE DISTANCES OF EIGENVALUES TO CENTER OF NEIGHBORHOOD
C
      ALAM(1) = LAMBDA(1)
      ALAM(2) = LAMBDA(2)
      JJ = INTQ - 1
      KK = IH   - 1
      LL = INTH - 1
      DO 90 I = 1,NROW
      J  = JJ + I
      K  = IL + 2*(I-1)
      Z(J) = SQRT((ALAM(1) - Z(K))**2 + (ALAM(2)-Z(K+1))**2)
C
C     LOAD ORDER OF EXTRACTION
C
      K = KK + I
      IZ(K) = I
C
C     LOAD STATUS OF EACH SOLUTION
C
      K = LL + I
      LZ(K) = .FALSE.
      J = IHL1 + I
      IF (Z(J) .LT. SNGL(EPS)) LZ(K) = .TRUE.
   90 CONTINUE
C
C     SORT EIGENVALUES ACCORDING TO DISTANCE FROM CURRENT CENTER
C
      IF (NROW .EQ. 1) GO TO 150
      LL = NROW - 1
      DO 140 I = 1,LL
      K  = JJ + I
      I1 = KK + I
      LLL= I  + 1
      DO 130 J = LLL,NROW
      L  = JJ + J
      IF (Z(K) .LT. Z(L)) GO TO 130
      UNIDUM = Z(L)
      Z(L)   = Z(K)
      Z(K)   = UNIDUM
      I2     = KK + J
      INIDUM = IZ(I1)
      IZ(I1) = IZ(I2)
      IZ(I2) = INIDUM
  130 CONTINUE
  140 CONTINUE
  150 LLL = IL - 1
      LL  = INTH - 1
      IF (IDIAG .EQ. 0) GO TO 170
C
C     PRINT OUT FULL SUMMARY FOR CURRENT NEIGHBORHOOD
C
      WRITE (NOUT,670) JREG,NOREG,ALAM
      WRITE (NOUT,680)
      WRITE (NOUT,690)
      DO 160 I = 1,NROW
      K   = KK  + I
      IZZ = 2*IZ(K) - 1
      J   = JJ  + I
      L   = LLL + IZZ
      L1  = L   + 1
      I1  = IHL1+ IZ(K)
      Z(I1) = 100.*Z(I1)
      I2  = LL  + IZ(K)
      STATUS(1) = ACCEPT(1)
      STATUS(2) = ACCEPT(2)
      IF (LZ(I2)) GO TO 160
      STATUS(1) = REJECT(1)
      STATUS(2) = REJECT(2)
  160 WRITE (NOUT,700) I,IZ(K),Z(J),Z(L),Z(L1),Z(I1),STATUS
C
C     DECREMENT COUNTERS SO THAT ONLY ACCEPTABLE SOLUTIONS ARE RETAINED
C
  170 MSAVE = NROW
      DO 180 I = 1,MSAVE
      I2 = LL + I
      IF (LZ(I2)) GO TO 180
      NROW   = NROW - 1
      NORTHO = NORTHO - 1
      IF (NROW .EQ. 0) GO TO 450
  180 CONTINUE
      NFOUND = NZERO + NROW
      IF (NROW .EQ. MSAVE) WRITE (NOUT,720) UIM,MSAVE
      IF (IDIAG.EQ.0 .OR. NROW.EQ.MSAVE) GO TO 200
C
C     PRINT OUT SUMMARY WITH REJECTED SOLUTIONS DELETED
C
      WRITE (NOUT,670) JREG,NOREG,ALAM
      WRITE (NOUT,730)
      WRITE (NOUT,690)
      M  = 0
      DO 190 I = 1,MSAVE
      K  = KK + I
      I2 = LL + IZ(K)
      IF (.NOT.LZ(I2)) GO TO 190
      M  = M + 1
      IZZ= 2*IZ(K) - 1
      J  = JJ  + I
      L  = LLL + IZZ
      L1 = L   + 1
      I1 = IHL1+ IZ(K)
      WRITE (NOUT,700) M,IZ(K),Z(J),Z(L),Z(L1),Z(I1),ACCEPT
  190 CONTINUE
  200 M = MSAVE - NROW
      IF (M .GT. 0) WRITE (NOUT,740) UIM,NROW,M
C
C     WRITE EIGENVALUES TO OUTPUT FILE
C
      CALL GOPEN (ILAM(1),Z(IBUF1),WRT)
      DO 210 I = 1,MSAVE
      K  = KK + I
      I2 = LL + IZ(K)
      IF (.NOT.LZ(I2)) GO TO 210
      IZZ = 2*IZ(K) - 1
      L   = LLL + IZZ
      LAM1(1) = DBLE(Z(L  ))
      LAM1(2) = DBLE(Z(L+1))
      CALL WRITE (ILAM(1),LAM1(1),4,1)
  210 CONTINUE
      CALL CLOSE (ILAM(1),EOFNRW)
      IF (JREG.LT.NOREG .AND. NFOUND.LT.NORD) GO TO 214
      IF (NZERO .EQ. 0) GO TO 214
C
C     IF THIS IS THE FINAL (BUT NOT THE FIRST) NEIGHBORHOOD, THEN
C     RE-WRITE THE EIGENVECTOR FILE PERTAINING TO ALL PRIOR
C     NEIGHBORHOODS (ELIMINATE LEFT-HAND VECTORS)
C
  209 IF (IDIAG .NE. 0) WRITE (NOUT,810) NZERO,NORTHO
      INIDUM = ISCR(10)
      CALL OPEN  (*455,ISCR(10),Z(IBUF2),WRTREW)
      CALL CLOSE (ISCR(10),REW)
      J = NORD2
      IF (NO B) J = 2*J
      INIDUM = IPHI(1)
      CALL OPEN (*455,IPHI(1),Z(IBUF1),0)
      DO 212 I = 1,NZERO
      CALL READ (*460,*211,IPHI(1),Z(IV2),NORD8+10,0,N3)
      GO TO 470
  211 CALL GOPEN (ISCR(10),Z(IBUF2),WRT)
      CALL WRITE (ISCR(10),Z(IV2),J,1)
  212 CALL CLOSE (ISCR(10),NOREW)
      CALL CLOSE (IPHI(1),NOREW)
      CALL OPEN  (*455,IPHI(1),Z(IBUF1),WRTREW)
      CALL CLOSE (IPHI(1),REW)
      INIDUM = ISCR(10)
      CALL OPEN  (*455,ISCR(10),Z(IBUF2),0)
      DO 213 I = 1,NZERO
      CALL READ  (*460,*206,ISCR(10),Z(IV2),J+10,0,N3)
      GO TO 470
  206 CALL GOPEN (IPHI(1),Z(IBUF1),WRT)
      CALL WRITE (IPHI(1),Z(IV2),J,1)
  213 CALL CLOSE (IPHI(1),EOFNRW)
      CALL CLOSE (ISCR(10),NOREW)
      IF(NSWP(2) .LT. 0) GO TO 500
C
C     RECOVER PHYSICAL EIGENVECTORS, PRINT, AND WRITE TO OUTPUT FILE
C
  214 IPRC = IPREC + 2
      II   = 1
      NN   = NORD2
      INCR = 1
      IA1  = IA - 1
      IF (QPR) WRITE (NOUT,750)
      ISHFT = NORD2*IPREC
      I1  = 0
C
C     ENTER LOOP
C
      DO 300 I = 1,MSAVE
      K  = KK + I
      I2 = LL + IZ(K)
      IF (.NOT. LZ(I2)) GO TO 300
      CALL GOPEN (ISCR(7),Z(IBUF2),RDREW)
      IF (NZERO .GT. 0) CALL SKPREC (ISCR(7),NZERO)
      DO 215 J = 1,NORD8
      M = IV1X + J
  215 Z(M) = 0.
C
C     SET POINTER TO ALLMAT OUTPUT VECTOR
C
      IB = IA1 + 2*MSAVE*(IZ(K)-1)
C
C     CYCLE THRU ALL ORTHOGONAL VECTORS
C
      DO 225 J = 1,MSAVE
C
C     NOTE.... Z(IV2) MAY BE LOADED DOUBLE-PRECISION....HIGHER DIGITS
C              ARE NOT USED
C     (HIGHER DIGITS MUST BE INCLUDED FOR THE D.P.MACHINES.  G.C/UNISYS)
C
      CALL UNPACK (*225,ISCR(7),Z(IV2))
      KR = IB + 2*J - 1
      KI = KR + 1
      DO 220 MM = 1,NORD2,2
      MR = IV2 + (MM-1)*IPREC
      MI = MR  + IPREC
      JR = IV1X+ MM
      JI = JR  + 1
      IF (.NOT.DPMACH) GO TO 216
      MRD = (MR+1)/2
      MID = MRD + 1
C
C     RECOVER RIGHT-HAND PHYSICAL EIGENVECTOR
C
      Z(JR) = Z(JR) + DZ(MRD)*Z(KR) - DZ(MID)*Z(KI)
      Z(JI) = Z(JI) + DZ(MID)*Z(KR) + DZ(MRD)*Z(KI)
      GO TO 217
  216 Z(JR) = Z(JR) + Z(MR)*Z(KR) - Z(MI)*Z(KI)
      Z(JI) = Z(JI) + Z(MI)*Z(KR) + Z(MR)*Z(KI)
  217 MR = MR + ISHFT
      MI = MR + IPREC
      JR = JR + NORD4
      JI = JR + 1
      IF (.NOT.DPMACH) GO TO 218
      MRD = (MR+1)/2
      MID = MRD + 1
C
C     RECOVER LEFT-HAND PHYSICAL EIGENVECTOR
C
      Z(JR) = Z(JR) + DZ(MRD)*Z(KR) - DZ(MID)*Z(KI)
      Z(JI) = Z(JI) + DZ(MID)*Z(KR) + DZ(MRD)*Z(KI)
      GO TO 220
  218 Z(JR) = Z(JR) + Z(MR)*Z(KR) - Z(MI)*Z(KI)
      Z(JI) = Z(JI) + Z(MI)*Z(KR) + Z(MR)*Z(KI)
  220 CONTINUE
  225 CONTINUE
      CALL CLOSE (ISCR(7),EOFNRW)
      IF (.NOT.QPR) GO TO 230
      I1  = I1 + 1
      IZZ = 2*IZ(K) - 1
      L   = LLL  + IZZ
      MM  = IV1X + NORD8
      WRITE (NOUT,760) I1,IZ(K),Z(L),Z(L+1),(Z(J),J=IV1,MM)
      WRITE (NOUT,770)
C
C     EXPAND PHYSICAL EIGENVECTORS TO DOUBLE PRECISION FOR OUTPUT
C
  230 LIM1 = IV1  + NORD2
      LIM2 = LIM1 + NORD4
      INIDUM = IV1X + NORD4
      DO 240 J = 1,NORD2
      KI  = LIM1 - J
      MI  = 2*KI - IV1X
      MR  = MI - 1
      MRD = (MR+1)/2
C
C     EXPAND RIGHT-HAND VECTOR
C
      Z(MI) = 0.
      Z(MR) = Z(KI)
      IF (DPMACH) DZ(MRD) = Z(KI)
      KI  = LIM2 - J
      MI  = 2*KI - INIDUM
      MR  = MI - 1
      MRD = (MR+1)/2
C
C     EXPAND LEFT -HAND VECTOR
C
      Z(MI) = 0.
      Z(MR) = Z(KI)
      IF (DPMACH) DZ(MRD) = Z(KI)
  240 CONTINUE
      IF (.NOT.QPR) GO TO 250
      WRITE (NOUT,770)
      LIM1 = IV1X + NORD4
      WRITE (NOUT,780) (Z(J),J=IV1,LIM1)
      WRITE (NOUT,770)
      LIM2 = LIM1 + NORD4
      LIM1 = LIM1 + 1
      WRITE (NOUT,780) (Z(J),J=LIM1,LIM2)
      WRITE (NOUT,770)
C
C     PERFORM SPECIAL NORMALIZATION OF VECTORS FOR OUTPUT
C
  250 CALL CNORM1 (Z(IV1),IKMB(2))
      IF (QPR) WRITE (NOUT,790)
      INIDUM = INIDUM + 1
      CALL CNORM1 (Z(INIDUM),IKMB(2))
      IF (QPR) WRITE (NOUT,790)
      CALL GOPEN (IPHI(1),Z(IBUF1),WRT)
      IF (JREG.LT.NOREG .AND. NFOUND.LT.NORD) GO TO 260
      J = NORD2
      IF (NO B) J = 2*J
      CALL WRITE (IPHI(1),Z(IV1),J,1)
      CALL CLOSE (IPHI(1),EOFNRW)
      GO TO 300
C
C     MUST USE NORD8 TO WRITE FULL RIGHT AND LEFT EIGENVECTORS
C
  260 CALL WRITE (IPHI(1),Z(IV1),NORD8,1)
      CALL CLOSE (IPHI(1),NOREW)
  300 CONTINUE
      GO TO 500
  420 WRITE (NOUT,530) NAME
      GO TO 500
  430 WRITE (NOUT,540) M,NAME
      GO TO 500
  440 WRITE (NOUT,580) UWM
      IF(NZERO.GT.0 .AND. JREG.EQ.NOREG) NSWP(2) = -1
      GO TO 500
  450 WRITE (NOUT,710) UWM,MSAVE
      GO TO 500
  455 CALL MESAGE (-1,INIDUM,NAME)
  460 CALL MESAGE (-2,INIDUM,NAME)
  470 CALL MESAGE (-8,INIDUM,NAME)
  500 RETURN
C
  530 FORMAT (27H UNEXPECTED EOF ENCOUNTERED,2X,2A4)
  540 FORMAT (22H UNEXPECTED WORD COUNT,I5,2X,2A4)
  550 FORMAT (A29,' 3152', //5X,'SUBROUTINE ALLMAT OUTPUT EIGENVALUE',
     1       I4,' IS NULL.',//)
  560 FORMAT (A25,' 3153', //5X,'ATTEMPT TO NORMALIZE NULL VECTOR IN ',
     1       'SUBROUTINE ',A4,A2,'. NO ACTION TAKEN.',//)
  570 FORMAT (A25,' 3154', //5X,'SIZE OF REDUCED PROBLEM DECREMENTED ',
     1       'ONCE (NOW',I6,') DUE TO NULL ERROR ELEMENT.',//)
  580 FORMAT (A25,' 3155', //5X,'REDUCED PROBLEM HAS VANISHED. NO ',
     1       'ROOTS FOUND.',//)
  590 FORMAT (A25,' 3156', //5X,'SIZE OF REDUCED PROBLEM RESTORED TO',
     1       I8,' BECAUSE NEXT ERROR ELEMENT WAS ALSO NULL.', /5X,
     3       'ERROR ELEMENT SET = ',2E16.8,//)
  600 FORMAT (1H0,//7H CFEER4,//)
  610 FORMAT (1H ,I10,36H SINGLE PRECISION WORDS OF OPEN CORE,
     1       29H NOT USED (SUBROUTINE CFEER4))
  620 FORMAT (4H ROW,I5,2(4X,2E16.8))
  630 FORMAT (4H ROW,I5,2(4X,2D16.8))
  640 FORMAT (1H0,26HREDUCED TRIDIAGONAL MATRIX, /(1H ,6E16.8))
  650 FORMAT (1H0,//30H THEORETICAL EIGENVALUE ERRORS,
     1       20X,18HD-SUB-M-PLUS-ONE =,2E16.8,/)
  660 FORMAT (1H ,I5,E16.8,20X,2E16.8,10X,E16.8)
  670 FORMAT (1H1,27X,39H*****  F E E R  *****  (FAST EIGENVALUE,
     1       27H EXTRACTION ROUTINE)  *****, //4X,
     2       24HSUMMARY FOR NEIGHBORHOOD,I3,3H OF,I3,1H.,10X,
     3       21HNEIGHBORHOOD CENTER =,2E16.8,/)
  680 FORMAT (4X,43HALL SOLUTIONS FOUND IN CURRENT NEIGHBORHOOD,
     1       12H ARE LISTED.,/)
  690 FORMAT (4X,7X,8HSOLUTION,7X,8HORDER OF,7X,8HDISTANCE,
     1       10X,10HEIGENVALUE,14X,11HTHEORETICAL, /4X,
     2       9X,6HNUMBER,5X,10HEXTRACTION,4X,11HFROM CENTER,
     3       6X,4HREAL,9X,9HIMAGINARY,9X,5HERROR,12X,6HSTATUS,/)
  700 FORMAT (4X,I12,I15,1P,E18.8,1P,3E15.7,7X,2A4)
  710 FORMAT (A25,' 3163', //5X,'ALL',I6,' SOLUTIONS HAVE FAILED ',
     1       'ACCURACY TEST. NO ROOTS FOUND.',//)
  720 FORMAT (A29,' 3164',//5X,'ALL',I6,' SOLUTIONS ARE ACCEPTABLE.',//)
  730 FORMAT (4X,37HREJECTED SOLUTIONS HAVE BEEN DELETED.,/)
  740 FORMAT (A29,' 3165', //4X,I6,' SOLUTIONS HAVE BEEN ACCEPTED AND',
     1       I4,' SOLUTIONS HAVE BEEN REJECTED.',//)
  750 FORMAT (1H1,27X,39H*****  F E E R  *****  (FAST EIGENVALUE,
     1       27H EXTRACTION ROUTINE)  *****,//
     2       42X,37HE I G E N V E C T O R   S U M M A R Y,//1H ,
     3       32(4H----),2H--)
  760 FORMAT (1H ,8HSOLUTION,I4,8X,16HEXTRACTION ORDER,I4,
     1       10X,10HEIGENVALUE,2X,1P,2E16.8, /(1H ,3(4X,1P,2E16.8)))
  770 FORMAT (3H --,32(4H----))
  780 FORMAT ((1H ,3(3X,2E16.8)))
  790 FORMAT (1H  ,12HAFTER CNORM1)
  800 FORMAT (1H  ,10X,5HRMS =,E16.8)
  810 FORMAT (1H  ,33HLEFT-HAND EIGENVECTORS ELIMINATED,20X,2I8)
      END


!*****************************************************************************
module gconstant
    use gprec
    real(q)   ,parameter :: pi =3.141592653589793238_q,tpi=2*pi
    complex(q),parameter :: zi=(0._q,1._q)
    complex(q),parameter :: zitpi = (0._q,1._q)*tpi
    real(q)   ,parameter :: rytoev=13.60569193_q
    complex(q),parameter :: z1=(1._q,0._q),z0=(0._q,0._q)
    real(q)   ,parameter :: d1=1._q,d0=0._q
    real(q)   ,parameter :: small=1.e-10_q
    real(q)   ,parameter :: ktoev=8.617e-5_q ! ev/k
    real(q)   ,parameter :: ktory=0.63333787391e-5_q ! rydberg/k
    integer   ,parameter :: maxnnz=100000000
    real(q)   ,parameter :: rubound=1.e30_q, rlbound=1.e-30_q
    integer   ,parameter :: iu_kgen=14

end module gconstant


c
c   Example 5
c
c   Interface:    Linear-Algebraic (IJ), Fortran (77) version
c
c   Compile with: make ex5f
c
c   Sample run:   mpirun -np 4 ex5f
c
c   Description:  This example solves the 2-D
c                 Laplacian problem with zero boundary conditions
c                 on an nxn grid.  The number of unknowns is N=n^2.
c                 The standard 5-point stencil is used, and we solve
c                 for the interior nodes only.
c
c                 This example solves the same problem as Example 3.
c                 Available solvers are AMG, PCG, and PCG with AMG,
c                 and PCG with ParaSails
c
c
c                 Notes: for PCG, GMRES and BiCGStab, precond_id means:
c                        0 - do not set up a preconditioner
c                        1 - set up a ds preconditioner
c                        2 - set up an amg preconditioner
c                        3 - set up a pilut preconditioner
c                        4 - set up a ParaSails preconditioner
c

      program ex5f

      implicit none

      include 'mpif.h'

      integer    MAX_LOCAL_SIZE
      integer    HYPRE_PARCSR

      parameter  (MAX_LOCAL_SIZE=123000)

c     the following is from HYPRE.c
      parameter  (HYPRE_PARCSR=5555)

      integer    ierr
      integer    num_procs, myid
      integer    local_size, extra
      integer    n, solver_id, print_solution, ng
      integer    nnz, ilower, iupper, i
      integer    precond_id;
      double precision h, h2
      double precision rhs_values(MAX_LOCAL_SIZE)
      double precision x_values(MAX_LOCAL_SIZE)
      integer    rows(MAX_LOCAL_SIZE)
      integer    cols(5)
      double precision values(5)
      integer    num_iterations
      double precision final_res_norm, tol

      integer    mpi_comm

      integer*8  parcsr_A
      integer*8  A
      integer*8  b
      integer*8  x
      integer*8  par_b
      integer*8  par_x
      integer*8  solver
      integer*8  precond

c-----------------------------------------------------------------------
c     Initialize MPI
c-----------------------------------------------------------------------

      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
      mpi_comm = MPI_COMM_WORLD

c   Default problem parameters
      n = 33
      solver_id = 0
      print_solution  = 0
      tol = 1.0d-7

c   The input section not implemented yet.

c   Preliminaries: want at least one processor per row
      if ( n*n .lt. num_procs ) then
         n = int(sqrt(real(num_procs))) + 1
      endif
c     ng = global no. rows, h = mesh size
      ng = n*n
      h = 1.0d0/(n+1)
      h2 = h*h

c     Each processor knows only of its own rows - the range is denoted by ilower
c     and upper.  Here we partition the rows. We account for the fact that
c     N may not divide evenly by the number of processors.
      local_size = ng/num_procs
      extra = ng - local_size*num_procs

      ilower = local_size*myid
      ilower = ilower + min(myid, extra)

      iupper = local_size*(myid+1)
      iupper = iupper + min(myid+1, extra)
      iupper = iupper - 1

c     How many rows do I have?
      local_size = iupper - ilower + 1

c     Create the matrix.
c     Note that this is a square matrix, so we indicate the row partition
c     size twice (since number of rows = number of cols)
      call HYPRE_IJMatrixCreate(mpi_comm, ilower,
     1     iupper, ilower, iupper, A, ierr)

c     Choose a parallel csr format storage (see the User's Manual)
      call HYPRE_IJMatrixSetObjectType(A, HYPRE_PARCSR, ierr)

c     Initialize before setting coefficients
      call HYPRE_IJMatrixInitialize(A, ierr)

c     Now go through my local rows and set the matrix entries.
c     Each row has at most 5 entries. For example, if n=3:
c
c      A = [M -I 0; -I M -I; 0 -I M]
c      M = [4 -1 0; -1 4 -1; 0 -1 4]
c
c     Note that here we are setting one row at a time, though
c     one could set all the rows together (see the User's Manual).

      do i = ilower, iupper
         nnz = 1

c        The left identity block:position i-n
         if ( (i-n) .ge. 0 ) then
	    cols(nnz) = i-n
	    values(nnz) = -1.0d0
	    nnz = nnz + 1
         endif

c         The left -1: position i-1
         if ( mod(i,n).ne.0 ) then
            cols(nnz) = i-1
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

c        Set the diagonal: position i
         cols(nnz) = i
         values(nnz) = 4.0d0
         nnz = nnz + 1

c        The right -1: position i+1
         if ( mod((i+1),n) .ne. 0 ) then
            cols(nnz) = i+1
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

c        The right identity block:position i+n
         if ( (i+n) .lt. ng ) then
            cols(nnz) = i+n
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

c        Set the values for row i
         call HYPRE_IJMatrixSetValues(
     1        A, 1, nnz-1, i, cols, values, ierr)

      enddo

c     Assemble after setting the coefficients
      call HYPRE_IJMatrixAssemble(A, ierr)

c     Get parcsr matrix object
      call HYPRE_IJMatrixGetObject(A, parcsr_A, ierr)

c     Create the rhs and solution
      call HYPRE_IJVectorCreate(mpi_comm,
     1     ilower, iupper, b, ierr)
      call HYPRE_IJVectorSetObjectType(b, HYPRE_PARCSR, ierr)
      call HYPRE_IJVectorInitialize(b, ierr)

      call HYPRE_IJVectorCreate(mpi_comm,
     1     ilower, iupper, x, ierr)
      call HYPRE_IJVectorSetObjectType(x, HYPRE_PARCSR, ierr)
      call HYPRE_IJVectorInitialize(x, ierr)

c     Set the rhs values to h^2 and the solution to zero
      do i = 1, local_size
         rhs_values(i) = h2
         x_values(i) = 0.0
         rows(i) = ilower + i -1
      enddo
      call HYPRE_IJVectorSetValues(
     1     b, local_size, rows, rhs_values, ierr)
      call HYPRE_IJVectorSetValues(
     1     x, local_size, rows, x_values, ierr)

      call HYPRE_IJVectorAssemble(b, ierr)
      call HYPRE_IJVectorAssemble(x, ierr)

c get the x and b objects

      call HYPRE_IJVectorGetObject(b, par_b, ierr)
      call HYPRE_IJVectorGetObject(x, par_x, ierr)

c     Choose a solver and solve the system

c     AMG
      if ( solver_id .eq. 0 ) then

c        Create solver
         call HYPRE_BoomerAMGCreate(solver, ierr)

c        Set some parameters (See Reference Manual for more parameters)

c        print solve info + parameters
         call HYPRE_BoomerAMGSetPrintLevel(solver, 3, ierr)
c        old defaults, Falgout coarsening, mod. class. interpolation
         call HYPRE_BoomerAMGSetOldDefault(solver, ierr)
c        G-S/Jacobi hybrid relaxation
         call HYPRE_BoomerAMGSetRelaxType(solver, 3, ierr)
c        C/F relaxation
         call HYPRE_BoomerAMGSetRelaxOrder(solver, 1, ierr)
c        Sweeeps on each level
         call HYPRE_BoomerAMGSetNumSweeps(solver, 1, ierr)
c         maximum number of levels
         call HYPRE_BoomerAMGSetMaxLevels(solver, 20, ierr)
c        conv. tolerance
         call HYPRE_BoomerAMGSetTol(solver, 1.0d-7, ierr)

c        Now setup and solve!
         call HYPRE_BoomerAMGSetup(
     1        solver, parcsr_A, par_b, par_x, ierr)
         call HYPRE_BoomerAMGSolve(
     1        solver, parcsr_A, par_b, par_x, ierr)

c        Run info - needed logging turned on
         call HYPRE_BoomerAMGGetNumIterations(solver, num_iterations,
     1        ierr)
         call HYPRE_BoomerAMGGetFinalReltvRes(solver, final_res_norm,
     1        ierr)

         if ( myid .eq. 0 ) then
            print *
            print '(A,I2)', " Iterations = ", num_iterations
            print '(A,ES16.8)',
     1            " Final Relative Residual Norm = ", final_res_norm
            print *
         endif

c        Destroy solver
         call HYPRE_BoomerAMGDestroy(solver, ierr)

c     PCG (with DS)
      elseif ( solver_id .eq. 50 ) then

c        Create solver
         call HYPRE_ParCSRPCGCreate(MPI_COMM_WORLD, solver, ierr)

c        Set some parameters (See Reference Manual for more parameters)
         call HYPRE_ParCSRPCGSetMaxIter(solver, 1000, ierr)
         call HYPRE_ParCSRPCGSetTol(solver, 1.0d-7, ierr)
         call HYPRE_ParCSRPCGSetTwoNorm(solver, 1, ierr)
         call HYPRE_ParCSRPCGSetPrintLevel(solver, 2, ierr)
         call HYPRE_ParCSRPCGSetLogging(solver, 1, ierr)

c        set ds (diagonal scaling) as the pcg preconditioner
         precond_id = 1
         call HYPRE_ParCSRPCGSetPrecond(solver, precond_id,
     1        precond, ierr)

c        Now setup and solve!
         call HYPRE_ParCSRPCGSetup(solver, parcsr_A, par_b,
     &                            par_x, ierr)
         call HYPRE_ParCSRPCGSolve(solver, parcsr_A, par_b,
     &                            par_x, ierr)

c        Run info - needed logging turned on

        call HYPRE_ParCSRPCGGetNumIterations(solver, num_iterations,
     &                                       ierr)
        call HYPRE_ParCSRPCGGetFinalRelative(solver, final_res_norm,
     &                                       ierr)

       if ( myid .eq. 0 ) then
            print *
            print *, "Iterations = ", num_iterations
            print *, "Final Relative Residual Norm = ", final_res_norm
            print *
         endif

c       Destroy solver
        call HYPRE_ParCSRPCGDestroy(solver, ierr)

c     PCG with AMG preconditioner
      elseif ( solver_id == 1 ) then

c        Create solver
         call HYPRE_ParCSRPCGCreate(MPI_COMM_WORLD, solver, ierr)

c        Set some parameters (See Reference Manual for more parameters)
         call HYPRE_ParCSRPCGSetMaxIter(solver, 1000, ierr)
         call HYPRE_ParCSRPCGSetTol(solver, 1.0d-7, ierr)
         call HYPRE_ParCSRPCGSetTwoNorm(solver, 1, ierr)
         call HYPRE_ParCSRPCGSetPrintLevel(solver, 2, ierr)
         call HYPRE_ParCSRPCGSetLogging(solver, 1, ierr)

c        Now set up the AMG preconditioner and specify any parameters

         call HYPRE_BoomerAMGCreate(precond, ierr)

c        Set some parameters (See Reference Manual for more parameters)

c        print less solver info since a preconditioner
         call HYPRE_BoomerAMGSetPrintLevel(precond, 1, ierr);
c        Falgout coarsening
         call HYPRE_BoomerAMGSetCoarsenType(precond, 6, ierr)
c        old defaults
         call HYPRE_BoomerAMGSetOldDefault(precond, ierr)
c        SYMMETRIC G-S/Jacobi hybrid relaxation
         call HYPRE_BoomerAMGSetRelaxType(precond, 6, ierr)
c        Sweeeps on each level
         call HYPRE_BoomerAMGSetNumSweeps(precond, 1, ierr)
c        conv. tolerance
         call HYPRE_BoomerAMGSetTol(precond, 0.0d0, ierr)
c        do only one iteration!
         call HYPRE_BoomerAMGSetMaxIter(precond, 1, ierr)

c        set amg as the pcg preconditioner
         precond_id = 2
         call HYPRE_ParCSRPCGSetPrecond(solver, precond_id,
     1        precond, ierr)

c        Now setup and solve!
         call HYPRE_ParCSRPCGSetup(solver, parcsr_A, par_b,
     1                            par_x, ierr)
         call HYPRE_ParCSRPCGSolve(solver, parcsr_A, par_b,
     1                            par_x, ierr)

c        Run info - needed logging turned on

        call HYPRE_ParCSRPCGGetNumIterations(solver, num_iterations,
     1                                       ierr)
        call HYPRE_ParCSRPCGGetFinalRelative(solver, final_res_norm,
     1                                       ierr)

       if ( myid .eq. 0 ) then
            print *
            print *, "Iterations = ", num_iterations
            print *, "Final Relative Residual Norm = ", final_res_norm
            print *
         endif

c       Destroy precond and solver

        call HYPRE_BoomerAMGDestroy(precond, ierr)
        call HYPRE_ParCSRPCGDestroy(solver, ierr)

c     PCG with ParaSails
      elseif ( solver_id .eq. 8 ) then

c        Create solver
         call HYPRE_ParCSRPCGCreate(MPI_COMM_WORLD, solver, ierr)

c        Set some parameters (See Reference Manual for more parameters)
         call HYPRE_ParCSRPCGSetMaxIter(solver, 1000, ierr)
         call HYPRE_ParCSRPCGSetTol(solver, 1.0d-7, ierr)
         call HYPRE_ParCSRPCGSetTwoNorm(solver, 1, ierr)
         call HYPRE_ParCSRPCGSetPrintLevel(solver, 2, ierr)
         call HYPRE_ParCSRPCGSetLogging(solver, 1, ierr)

c        Now set up the Parasails preconditioner and specify any parameters
         call HYPRE_ParaSailsCreate(MPI_COMM_WORLD, precond,ierr)
         call HYPRE_ParaSailsSetParams(precond, 0.1d0, 1, ierr)
         call HYPRE_ParaSailsSetFilter(precond, 0.05d0, ierr)
         call HYPRE_ParaSailsSetSym(precond, 1, ierr)
         call HYPRE_ParaSailsSetLogging(precond, 3, ierr)

c        set parsails as the pcg preconditioner
         precond_id = 4
         call HYPRE_ParCSRPCGSetPrecond(solver, precond_id,
     1        precond, ierr)

c        Now setup and solve!
         call HYPRE_ParCSRPCGSetup(solver, parcsr_A, par_b,
     1                            par_x, ierr)
         call HYPRE_ParCSRPCGSolve(solver, parcsr_A, par_b,
     1                            par_x, ierr)

c        Run info - needed logging turned on

        call HYPRE_ParCSRPCGGetNumIterations(solver, num_iterations,
     1                                       ierr)
        call HYPRE_ParCSRPCGGetFinalRelative(solver, final_res_norm,
     1                                       ierr)

       if ( myid .eq. 0 ) then
            print *
            print *, "Iterations = ", num_iterations
            print *, "Final Relative Residual Norm = ", final_res_norm
            print *
         endif

c       Destroy precond and solver

        call HYPRE_ParaSailsDestroy(precond, ierr)
        call HYPRE_ParCSRPCGDestroy(solver, ierr)

      else
         if ( myid .eq. 0 ) then
           print *,'Invalid solver id specified'
           stop
         endif
      endif

c     Print the solution
      if ( print_solution .ne. 0 ) then
         call HYPRE_IJVectorPrint(x, "ij.out.x", ierr)
      endif

c     Clean up

      call HYPRE_IJMatrixDestroy(A, ierr)
      call HYPRE_IJVectorDestroy(b, ierr)
      call HYPRE_IJVectorDestroy(x, ierr)

c     Finalize MPI
      call MPI_Finalize(ierr)

      stop
      end


program main
    use IOClass
    use randomclass
    use ArrayClass
    implicit none

    real(real64),allocatable :: a(:,:)
    integer(int32) :: i
    type(random_) :: random
    a = zeros(2000,2000)

    ! create a matrix
    do i=1, 2000
        a(i,i) = random%random()
    enddo

    do i=2, 1990
        a(i-1,i-1) = random%random()
        a(i-1,i+1) = random%random()
        a(i+1,i+1) = random%random()
        a(i+1,i-1) = random%random()
    enddo

    do i=3, 1990
        a(i-2,i-2) = random%random()
        a(i-2,i+2) = random%random()
        a(i+2,i+2) = random%random()
        a(i+2,i-2) = random%random()
    enddo

    do i=50, 1000
        a(i-40,i-40) = random%random()
        a(i-40,i+40) = random%random()
        a(i+40,i+40) = random%random()
        a(i+40,i-40) = random%random()
    enddo

    ! show sparse matrix (zero=> white, non-zero=>blue)
    call spy(a)

end program main


!*******************************************************************************
!  File limiter_iso_T.f
!  Contains module limiter_iso_T
!  Defines derived-types: limiter_iso

!*******************************************************************************
!  MODULE limiter_iso_T
!    (limiter_iso Type Definition, for the V3FIT code)
! SECTION I.    VARIABLE DECLARATIONS
! SECTION II.   DERIVED-TYPE DECLARATIONS
! SECTION III.  INTERFACE BLOCKS
! SECTION IV.   CONSTRUCTION SUBROUTINES
! SECTION V.    DESTRUCTION SUBROUTINES
! SECTION VI.   ASSIGNMENT SUBROUTINES
! SECTION VII.  OUTPUT SUBROUTINES
! SECTION VIII. FUNCTION EVALUATION SUBROUTINES
! SECTION XII.  AUXILIARY SUBROUTINES
! SECTION XIII. DEBUGGING SUBROUTINES
! SECTION XV.   DUPLICATE CODING FOR TESTING
! SECTION XVI.  COMMENTS FOR DIFFERENT REVISIONS
!*******************************************************************************
      MODULE limiter_iso_T

!*******************************************************************************
! SECTION I. VARIABLE DECLARATIONS
!*******************************************************************************

!-------------------------------------------------------------------------------
!  Type declarations - lengths of reals, integers, and complexes.
!  Frequently used mathematical constants, lots of extra precision.
!-------------------------------------------------------------------------------
      USE stel_kinds, only : rprec, cprec
      USE stel_constants, only : pi, twopi, one, zero

!-------------------------------------------------------------------------------
!  Use Statements for V3 Utilities
!-------------------------------------------------------------------------------
      USE v3_utilities

!-------------------------------------------------------------------------------
!  Implicit None comes after USE statements, before other declarations
!-------------------------------------------------------------------------------
      IMPLICIT NONE

!-------------------------------------------------------------------------------
!  Make type declarations and constants Private, so there are no conflicts.
!-------------------------------------------------------------------------------
      PRIVATE rprec, cprec, pi, twopi, one, zero

!*******************************************************************************
! SECTION II. DERIVED-TYPE DECLARATIONS
! 1)   Limiter iso:
!         limiter_iso
!     Contains the data to define a scalar function of position, so that the
!     iso-contour f=0 of the function corresponds to a geometric limit to the
!     plasma
!        Also contains data to specify the minimum number poloidal points on the
!     s=1 surface to use, and the toroidal planes on which to s=1 surface will
!     be evaluated
!
!    Second attempt:
!     e = SUM_over_i(0,4)_j(0,4) [
!       arz(i,j) (r - rc)^i (z - zc)^j]
!     f = e / |grad(e)|
!
!  Note
!   1) For now, axisymmetric
!   2) Easy to put in circles, ellipses, and planes
!   3) Ffnction f is approximately distance.
!
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Declare type limiter_iso
!       arz(i,j) (r - rc)^i (z - zc)^j]
!     f = e / |grad(e)|
!   arz         Real array (0:4,0:4), coefficients for function
!   rc          Real, offset for function
!   zc          Real, offset for function!   zc          Real array (4), coefficients for function
!   numin       Integer, minimum number of poloidal angles for s=1 surface
!   vgrid       Real array (POINTER), values of toroidal angle at which
!                  to compute s=1 surface.
!      ^ USE AS ALLOCATABLE ARRAY
!-------------------------------------------------------------------------------
      TYPE limiter_iso
         REAL(rprec), DIMENSION(0:4,0:4)       :: arz
         REAL(rprec)                           :: rc, zc
         INTEGER                               :: numin
         REAL(rprec), DIMENSION(:), POINTER    :: vgrid => null()
       END TYPE limiter_iso

!*******************************************************************************
! SECTION III. INTERFACE BLOCKS
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Assignment for structures
!-------------------------------------------------------------------------------
      INTERFACE ASSIGNMENT (=)
         MODULE PROCEDURE limiter_iso_assign, limiter_iso_assign_a
      END INTERFACE

!-------------------------------------------------------------------------------
!  End of interface blocks
!-------------------------------------------------------------------------------
      CONTAINS
!*******************************************************************************
! SECTION IV. CONSTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Construct a limiter_iso
!-------------------------------------------------------------------------------
      SUBROUTINE limiter_iso_construct(this,arz,rc,zc,numin,vgrid)
      IMPLICIT NONE

!  Declare Arguments
      TYPE (limiter_iso), INTENT(inout)                     :: this
      REAL(rprec), DIMENSION(0:4,0:4), INTENT(in), OPTIONAL :: arz
      REAL(rprec), INTENT(in), OPTIONAL                     :: rc
      REAL(rprec), INTENT(in), OPTIONAL                     :: zc
      INTEGER, INTENT(in), OPTIONAL                         :: numin
      REAL(rprec), DIMENSION(:), INTENT(in), OPTIONAL       :: vgrid

!  Declare local variables
      INTEGER :: ier1
      CHARACTER(len=*), PARAMETER :: sub_name =                                &
     &  'limiter_iso_construct: '

!  Start of executable code

!  First, destroy this
      CALL limiter_iso_destroy(this)

      IF (PRESENT(arz)) THEN
         this % arz = arz
      ELSE
!  Default case is a circle of radius 1.
         this % arz = zero
         this % arz(2,0) = one
         this % arz(0,2) = one
         this % arz(0,0) = - one
      ENDIF

      IF (PRESENT(rc)) THEN
         this % rc = rc
      ELSE
         this % rc = one
      ENDIF

      IF (PRESENT(zc)) THEN
         this % zc = zc
      ELSE
         this % zc = zero
      ENDIF

      IF (PRESENT(numin)) THEN
         this % numin = numin
      ELSE
         this % numin = 1
      ENDIF

      IF (PRESENT(vgrid)) THEN
         ALLOCATE(this % vgrid(1:SIZE(vgrid)),STAT=ier1)
         CALL assert_eq(0,ier1,sub_name // 'alloc')
         this % vgrid = vgrid
      ELSE
         ALLOCATE(this % vgrid(1),STAT=ier1)
         CALL assert_eq(0,ier1,sub_name // 'alloc')
         this % vgrid(1) = zero
      ENDIF

      END SUBROUTINE limiter_iso_construct

!*******************************************************************************
! SECTION V. DESTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Destroy a limiter_iso
!-------------------------------------------------------------------------------
      SUBROUTINE limiter_iso_destroy(this)
      IMPLICIT NONE

!  Declare Arguments
      TYPE (limiter_iso), INTENT(inout) :: this

!  Declare local variables
      INTEGER :: ier1
      CHARACTER(len=*), PARAMETER :: sub_name =                                &
     &  'limiter_iso_destroy: '

!  Start of executable code

!  Get rid of all components
      this % arz = zero
      this % rc = zero
      this % zc = zero
      this % numin = 0
      IF (ASSOCIATED(this % vgrid)) THEN
         DEALLOCATE(this % vgrid,STAT=ier1)
         CALL assert_eq(0,ier1,sub_name // 'deallocate error')
      ENDIF

      END SUBROUTINE limiter_iso_destroy

!*******************************************************************************
! SECTION VI. ASSIGNMENT SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Assignment for limiter_iso
!-------------------------------------------------------------------------------
      SUBROUTINE limiter_iso_assign(left,right)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (limiter_iso), INTENT (inout) :: left
      TYPE (limiter_iso), INTENT (in) :: right

!  Declare local variables
      CHARACTER(len=*), PARAMETER :: sub_name =                                &
     &  'limiter_iso_assign: '
      CHARACTER (len=*), PARAMETER :: err_mess1 =                              &
     & 'left-right vgrid are the same?. FIX IT'
      INTEGER :: ier1

!  Start of executable code

!  Check to see if the 'use as allocatable array' pointers are pointing
!  to the same location
      CALL assert(.not.ASSOCIATED(left % vgrid,right % vgrid),                 &
     &   sub_name // err_mess1)

!  Destroy left
      CALL limiter_iso_destroy(left)

      left % arz = right % arz
      left % rc = right % rc
      left % zc = right % zc
      left % numin = right % numin

!  Allocate space for the 'use as allocatable array' pointer variables
      ALLOCATE(left % vgrid(1:SIZE(right % vgrid)),STAT=ier1)
      CALL assert_eq(0,ier1,sub_name // 'Allocation error')

      left % vgrid = right % vgrid

      END SUBROUTINE limiter_iso_assign

!-------------------------------------------------------------------------------
!  Assignment for array of limiter_iso
!-------------------------------------------------------------------------------
      SUBROUTINE limiter_iso_assign_a(left,right)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (limiter_iso), DIMENSION(:), INTENT (inout) :: left
      TYPE (limiter_iso), DIMENSION(:), INTENT (in) :: right

!  Declare local variables
      INTEGER :: n_left, n_right, i
      CHARACTER(len=*), PARAMETER :: sub_name =                                &
     &  'limiter_iso_assign_a: '
      CHARACTER (len=*), PARAMETER :: err_mess1 =                              &
     & 'left-right array lengths are not the same.'

!  Start of executable code

      n_left = SIZE(left)
      n_right = SIZE(right)
      CALL assert_eq(n_left,n_right,sub_name // err_mess1)
      DO i = 1,n_left
         left(i) = right(i)
      END DO

      END SUBROUTINE limiter_iso_assign_a

!*******************************************************************************
! SECTION VII.  OUTPUT SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Write out the contents of a limiter_iso
!-------------------------------------------------------------------------------

      SUBROUTINE limiter_iso_write(this,identifier,unit,verbose)
      IMPLICIT NONE

!  Declare Arguments
      TYPE (limiter_iso), INTENT (in) :: this
      CHARACTER (len=*), INTENT(in), OPTIONAL :: identifier
      INTEGER, INTENT(in), OPTIONAL :: unit
      INTEGER, INTENT(in), OPTIONAL :: verbose
!  identifier   character variable, also written out
!  unit         I/O unit number to write to
!  verbose      integer, to specify verbosity level of write

!  Declare local variables and constants
      INTEGER :: iv_default = 1
      INTEGER :: iv
      INTEGER :: iou_default = 6
      INTEGER :: iou
      CHARACTER (len=60) :: id

!  Declare Format array
      CHARACTER(len=*), PARAMETER, DIMENSION(7) :: fmt1 = (/                   &
     & '(" start limiter_iso write, called with id = ",a)         ',           &
     & '(" arz = ",5(3x,es12.5))                                  ',           &
     & '(" rc = ",3x,es12.5)                                      ',           &
     & '(" zc = ",3x,es12.5)                                      ',           &
     & '(" numin = ",i6)                                          ',           &
     & '(" vgrid = ",5(3x,es12.5))                                ',           &
     & '(" end limiter_iso write, called with id = ",a)           '            &
     &  /)

!  start of executable code
!  Check for arguments present
      IF (PRESENT(identifier)) THEN
         id = identifier
      ELSE
         id = ' '
      END IF

      IF (PRESENT(unit)) THEN
         iou = unit
      ELSE
         iou = iou_default
      END IF

      IF (PRESENT(verbose)) THEN
         iv = verbose
      ELSE
         iv = iv_default
      END IF

!  Select Case of Verbosity Level
!  Will need Select Case on s_type
      SELECT CASE(iv)
      CASE( :0)  ! VERY Terse
         WRITE(iou,*) this % arz
         WRITE(iou,*) this % rc
         WRITE(iou,*) this % zc
         WRITE(iou,*) this % numin
         WRITE(iou,*) this % vgrid

      CASE(1:)    ! Default, more verbose
         WRITE(iou,fmt1(1)) id
         WRITE(iou,fmt1(2)) this % arz
         WRITE(iou,fmt1(3)) this % rc
         WRITE(iou,fmt1(4)) this % zc
         WRITE(iou,fmt1(5)) this % numin
         WRITE(iou,fmt1(6)) this % vgrid
         WRITE(iou,fmt1(7)) id

      END SELECT

      END SUBROUTINE limiter_iso_write

!*******************************************************************************
! SECTION VIII. FUNCTION EVALUATION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Evaluate the limiter function
!-------------------------------------------------------------------------------
      SUBROUTINE limiter_iso_f_cyl(this,rpz_arg,fval)
      IMPLICIT NONE

!  Declare Arguments
      TYPE (limiter_iso), INTENT(in)          :: this
      REAL(rprec), DIMENSION(3), INTENT(in)   :: rpz_arg
      REAL(rprec), INTENT(out)                :: fval

!  Declare local variables
      CHARACTER(len=*), PARAMETER :: sub_name =                                &
     &  'limiter_iso_f_cyl: '
      REAL(rprec)                 :: e, er, ez, grad_e
      INTEGER                     :: i,j

!  Start of executable code

      e = zero
      DO i = 0,4
      DO j = 0,4
         e = e +
     &      this % arz(i,j) * ((rpz_arg(1) - this % rc) ** i) *                &
     &         ((rpz_arg(3) - this % zc) ** j)
      END DO
      END DO

      er = zero
      DO i = 1,4
      DO j = 0,4
         er = er +
     &      this % arz(i,j) * i * ((rpz_arg(1) - this % rc) ** (i-1)) *        &
     &         ((rpz_arg(3) - this % zc) ** j)
      END DO
      END DO

      ez = zero
      DO i = 0,4
      DO j = 1,4
         ez = ez +
     &      this % arz(i,j) * j * ((rpz_arg(1) - this % rc) ** i) *            &
     &         ((rpz_arg(3) - this % zc) ** (j - 1))
      END DO
      END DO

      grad_e = MAX(1.E-12,SQRT(er * er + ez * ez))

      fval = e / grad_e

      END SUBROUTINE limiter_iso_f_cyl

!*******************************************************************************
! SECTION XVI.  COMMENTS FOR DIFFERENT REVISIONS
!*******************************************************************************
!
!  JDH 2009-01-14
!     Modifying signal_T.f to get limiter_function_T
!
!  JDH 2009-01-31
!     Changed name to limiter_iso_T. Added numin and vgrid components.
!
!  JDH 2009-04-10
!     Changed details of function parameterization. (second attempt)
!
!  JDH 2011-03-16
!    In construct, added call to destroy first.
!
      END MODULE limiter_iso_T


C######################################################################|
      module electric_fields
C----------------------------------------------------------------------|
C     This module is used to calculate characteristic electric fields.
C
C     Functions:
C       - E_ceff_ocer_E_c(.):       normalised effective critical field
C       - E_c(ne, T):               critical electric field
C       - E_D(ne, T):               Dreicer electric field
C
C     Function arguments:
C       - Z:    atomic number of each ion species
C       - Z0:   net charge of plasma for each ion species
C       - nj:   density of each ion species (m**-3)
C       - nSpe: number of ion species
C       - T:    electron temperature (eV)
C       - B:    magnetic field (T)
C       - ne:   free electron density (m**-3)
C
C----------------------------------------------------------------------|
      use double
      use physical_constants, only :
     >  alpha
      use Coulomb_logarithms, only :
     >  ln_Lambda_0, ln_Lambda_c
      use collision_frequencies, only :
     >  calc_nuBar_D01, calc_nuBar_S01

      implicit none

      private

      public ::
     >  E_ceff_over_E_c,
     >  E_c,
     >  E_D

      contains

C======================================================================|
      real(kind=dp) function E_ceff_over_E_c(Z, Z0, nj, nSpecies,
     >  T, B)
C----------------------------------------------------------------------|
C     The effective critical field is calculated as in
C     L. Hesslow et al., Plasma Phys. Control. Fusion 60, 074010 (2018)
C     in Eq. (23)-(24) for a plasma composition with any fully ionised
C     species in combination with partially ionized neon and/or argon.
C
C       Input:
C           Z   : atomic number of each ion species
C           Z0  : net charge of plasma for each ion species
C           nj  : density of each ion species (m**-3)
C           nSpe: number of ion species
C               Z, Z0 and nj must be vectors of length nSpecies
C           T   : temperature (eV)
C           B   : magnetic field (T)
C
C       Output:
C           Eceff/Ec, where Ec = ne e^3 lnLc/(4 pi epsilon_0^2 m_e c^2)
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      integer, intent(in) ::
     >  nSpecies, Z(nSpecies), Z0(nSpecies)

      real(kind=dp), intent(in) ::
     >  B, nj(nSpecies), T

        ! ----- Local variables ---------------------------------------|
      integer ::
     >  i

      real(kind=dp) ::
     >  a0, a1, a2, ne, nuBar_D0, nuBar_D1, nuBar_S0, nuBar_S1,
     >  tau_rad_inv

C----------------------------------------------------------------------|
C     Construct required quantities
C----------------------------------------------------------------------|
        ! ----- Free electron density ---------------------------------|
      ne = sum(Z0(:)*nj(:))

        ! ----- Generalised deflection frequency ----------------------|
      call calc_nuBar_D01(Z, Z0, nj, nSpecies, T, nuBar_D0, nuBar_D1)

        ! ----- Slowing down frequency --------------------------------|
      call calc_nuBar_S01(Z, Z0, nj, nSpecies, T, nuBar_S0, nuBar_S1)

        ! ----- Synchrotron radiation term ----------------------------|
      tau_rad_inv = B**2/(15.44_dp*ln_Lambda_c(ne, T))/(1.e-20_dp*ne)

C----------------------------------------------------------------------|
C     Calculate Eceff/Ec analytically
C----------------------------------------------------------------------|
C     With ideas from Vinodh Bandaru (IPP)

        ! ----- Coefficients of cubic equation ------------------------|
        ! a3*x**3 + a2*x**2 + a1*x + a0 = 0
        ! Note, that a3 = 1 in this case and is thus ignored.
      a0 = log(nuBar_D0/(2*nuBar_S1))

      a2 = -2._dp*(nuBar_S0 + nuBar_S1*(1+nuBar_D1/nuBar_D0)*a0)
      a1 = (.5_dp*a2)**2 - (.7_dp+.4_dp*a0)*alpha*nuBar_D0*nuBar_D1
     >      - nuBar_S1**2
      a0 = -2._dp*tau_rad_inv*nuBar_D0**2

        ! ----- Factors of the solution for x -------------------------|
        ! For the solution, the factors are
        ! a0 -> R = (9*a2*a1 - 27*a0 - 2*a2**3)/54
        ! a1 -> Q = (3*a1 - a2**2)/9
        ! a1 -> D = Q**3 + R**2
      a0 = (9*a2*a1 - 27*a0 - 2*a2**3)/54._dp
      a1 = (3*a1 - a2**2)/9._dp
      a1 = a1**3 + a0**2

        ! ----- Solution for x ----------------------------------------|
        ! The solution is given by:
        ! x = (R + sqrt(D))**(1/3) + (R - sqrt(D))**(1/3) - a2/3
        ! Since it may be that D < 0, complex numbers have to be used
        ! Note, that a1 -> D and a0 -> R
      E_ceff_over_E_c = real(
     >    (a0 + sqrt(cmplx(a1, 0._dp, kind=dp)))**(1._dp/3._dp)
     >  + (a0 - sqrt(cmplx(a1, 0._dp, kind=dp)))**(1._dp/3._dp)
     >  - a2/3._dp)

      return
      end function E_ceff_over_E_c
C======================================================================|

C======================================================================|
      real(kind=dp) function E_c(ne, T)
C----------------------------------------------------------------------|
C     Calculates the critical electric field E_c:
C       E_c = me*c/e/tauc = ne*e**3*ln Lambda_c/(4*pi*eps0**2*me*c**2).
C
C     Input:
C       ne  : free electron density (m**-3)
C       T   : electron temperature (eV)
C
C     Output:
C       E_c : critical electric field (V)
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      real(kind=dp), intent(in) ::
     >  ne, T

C----------------------------------------------------------------------|
      E_c = 5.09909908817339515e-23_dp*ne*ln_Lambda_c(ne, T)

      return
      end function E_c
C======================================================================|

C======================================================================|
      real(kind=dp) function E_D(ne, T)
C----------------------------------------------------------------------|
C     Calculates the Dreicer electric field E_D:
C       E_D = ne*e**3*ln Lambda/(4*pi*eps0**2*T).
C
C     Input:
C       ne  : free electron density (m**-3)
C       T   : electron temperature (eV)
C
C     Output:
C       E_D : Dreicer electric field (V)
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      real(kind=dp), intent(in) ::
     >  ne, T

C----------------------------------------------------------------------|
      E_D = 2.6056342609758366e-17_dp*ne*ln_Lambda_0(ne, T)/T

      return
      end function E_D
C======================================================================|

      end module electric_fields
C######################################################################|


c=======================================================================
c
c     SOLSCOR
c
c     Computing the solution of SDLS optimization from the dual solution
c     specific to obtain a correlation matrix
c
c-----------------------------------------------------------------------
      SUBROUTINE solscor ( nmat, cmat, ydual, iwork, dwork,
     &                     xmat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            nmat   : dimension of the matrix                    integer
c            cmat   : symmetric matrix (nmat*nmat) to optimize
c                     vectorized  vector(nmat*(nmat+1)/2)         double
c            mct    : number of constraints                      integer
c            ydual  : dual solution                   vector(mct) double
c
c     WORKSPACE
c            iwork  : vector (12*nmat)                           integer
c            dwork  : vector (nmat*(nmat+1)/2 + nmat*(3*nmat+27)) double
c
c     OUTPUT
c            xmat   : symmetric matrix solution
c                     vectorized  vector(nmat*(nmat+1)/2)         double
c            info   : = 0 successful exit                        integer
c
c     CALL
c        CVMDS    : converting a vector in vectorized symmetric
c                   diagonal matrix
c        SMS      : computing the sum of 2 vectorized symmetric matrices
c        PROJECTS : projection of a symmetric matrix
c                   on the cone of semidefinite matrices
c                   version with vector (n*(n+1)/2) in input/output
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER nmat, info
      DOUBLE PRECISION cmat(*), ydual(*), xmat(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER ssm, piw, pmat, pdw
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      ssm = (nmat*(nmat+1)/2)
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piw    = 1
c     piw    : pointer for workspace used by PROJECTS, so nmat more
c     pinext : pointer for the next iwork array
c              pinext = piw + 12*nmat
c
c     Total size of iwork array (12*nmat)
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pmat = 1
c     pmat  : pointer for a work vectorized symmetric matrix
c             so ssm = (nmat*(nmat+1)/2) more
      pdw = pmat + ssm
c     pdw   : pointer for workspace used by PROJECTS
c             so (nmat*(3*nmat+27))  more
c     pnext :  pointer for the next work array
c              pnext = pdw + (nmat*(3*nmat+27)
c                    = 1 + ssm + (nmat*(3*nmat+27))
c
c     Total size of work array
c                    = (nmat*(nmat+1)/2) + (nmat*(3*nmat+27))
c
c-----------------------------------------------------------------------
c
c     computing the adjoint : symmetric matrix sum of Ai*y(i)
c     for correlation : gives a diagonal matrix with y
      CALL CVMDS ( nmat, ydual, dwork(pmat) )
c
c     computing the sum C + adjoint = ( C+Aiy(i) )
      CALL SMS ( nmat, cmat, dwork(pmat), dwork(pmat) )
c
c     projection x = pK( C+Aiy(i) )
      CALL PROJECTS ( nmat, dwork(pmat), iwork(piw), dwork(pdw),
     &                xmat, info  )
c
      RETURN
      END


c*************************************************************************
c                        DRIFT_KEPU_NEW.F
c*************************************************************************
c subroutine for solving kepler's equation in universal variables.
c using NEWTON'S METHOD
c
c             Input:
c                 s             ==>  inital value of universal variable
c                 dt            ==>  time step (real scalor)
c                 r0            ==>  Distance between `Sun' and paritcle
c                                     (real scalor)
c                 mu            ==>  Reduced mass of system (real scalor)
c                 alpha         ==>  energy (real scalor)
c                 u             ==>  angular momentun  (real scalor)
c             Output:
c                 s             ==>  final value of universal variable
c                 fp            ==>  f' from p170
c                                       (real scalors)
c                 c1,c2,c3      ==>  c's from p171-172
c                                       (real scalors)
c                 iflgn          ==>  =0 if converged; !=0 if not
c
c Author:  Hal Levison
c Date:    2/3/93
c Last revision: 4/21/93

      subroutine drift_kepu_new(s,dt,r0,mu,alpha,u,fp,c1,c2,c3,iflgn)

      include '../../swift.inc'

c...  Inputs:
      real*8 s,dt,r0,mu,alpha,u

c...  Outputs:
      real*8 fp,c1,c2,c3
      integer iflgn

c...  Internals:
      integer nc
      real*8 x,c0,ds
      real*8 f,fpp,fppp,fdt

c----
c...  Executable code

      do nc=0,6
         x = s*s*alpha
         call drift_kepu_stumpff(x,c0,c1,c2,c3)
         c1 = c1*s
         c2 = c2*s*s
         c3 = c3*s*s*s
         f = r0*c1 + u*c2 + mu*c3 - dt
         fp = r0*c0 + u*c1 + mu*c2
         fpp = (-r0*alpha + mu)*c1 + u*c0
         fppp = (- r0*alpha + mu)*c0 - u*alpha*c1
         ds = - f/fp
         ds = - f/(fp + ds*fpp/2.0)
         ds = -f/(fp + ds*fpp/2.0 + ds*ds*fppp/6.0)
         s = s + ds
         fdt = f/dt

c..      quartic convergence
         if( fdt*fdt.lt.DANBYB*DANBYB) then
             iflgn = 0
             return
         endif
c...     newton's method succeeded

        enddo

c..     newton's method failed
        iflgn = 1
        return

        end  ! drift_kepu_new
c----------------------------------------------------------------------