module micro_params

use grid, only: nzm

implicit none

!  Microphysics stuff:

! Densities of hydrometeors

real, parameter :: rhor = 1000. ! Density of water, kg/m3

real, parameter :: qp_threshold = 1.e-12 ! minimal rain/snow water content

real, parameter :: rd_min = 25.e-6 ! Minimum drizzle drop size
real, parameter :: rd_max = 200.e-6 ! Maximum drizzle volume radius
real, parameter :: coefrv = 3./(4.*3.1415*1000.) ! coef to compute volume radius: rv = (coefrv * qr * N)^1/3
real, parameter :: coefconpmin = coefrv/rd_max**3
real, parameter :: coefconpmax = coefrv/rd_min**3

! Note: Using the MICRO_DRIZZLE namelist, the user can specify:
!    + the cloud droplet number concentration (Nc0, in units of #/cm3),
!    + the geometric standard deviation (sigmag, unitless) of the assumed
!        lognormal droplet size distribution, and
!    + whether to use the computed cloud droplet effective radius in
!        the radiation scheme (douse_reffc, logical).
!
real :: Nc0 = 40. ! Prescribed cloud drop concentration, cm-3
real :: sigmag = 1.5 ! geometric standard deviation of cloud drop size distribution
logical :: douse_reffc = .true. ! compute cloud droplet effective radius from drop size distribution.

! Possible values for sigmag:
!   1.5 (default): Ackerman et al (2004, Nature, doi:10.1038/nature03174)
!                  Ackerman et al (2009, MWR, doi:10.1175/2008MWR2582.1)
!   1.34: Geoffroy et al (2010, ACP, doi:10.5194/acp-10-4835-2010)
!       Observations from various field campaigns.  See their table 2.
!   1.2: Van Zanten et al (2005, MWR, doi:10.1175/2008MWR2582.1)
!       DYCOMS observations.  See their figure 5d.
!
! The value of Nc0 affects the autoconversion rate, the cloud droplet sedimentation rate and the
!    cloud droplet effective radius.  The value of sigmag affects sedimentation and the effective radius.
!
!  Using douse_reffc==.true. will only affect results if using full interactive radiation.

real evapr1(nzm),evapr2(nzm)

!bloss: The following parameters are needed for the cloud optics schemes in M2005 and Thompson.
!  However, we use the rho_water in MICRO_DRIZZLE in the computation of effective radius
!  and cloud droplet sedimentation.
real, parameter :: rho_snow = 100., rho_water = 1000., rho_cloud_ice = 500.

end module micro_params


!< Jiang-Shu and Gerolymos-Senechal-Vallet optimal weights.
module wenoof_optimal_weights_js
!< Jiang-Shu and Gerolymos-Senechal-Vallet optimal weights.
!<
!< @note The provided WENO optimal weights implements the optimal weights defined in *Efficient Implementation of Weighted ENO
!< Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
!< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
!< doi:10.1016/j.jcp.2009.07.039

use penf, only : I_P, R_P
use wenoof_optimal_weights

implicit none
private
public :: optimal_weights_js
public :: optimal_weights_js_constructor
public :: create_optimal_weights_js_constructor

type, extends(optimal_weights_constructor) :: optimal_weights_js_constructor
  !< Jiang-Shu and Gerolymos-Senechal-Vallet optimal weights object constructor.
endtype optimal_weights_js_constructor

type, extends(optimal_weights):: optimal_weights_js
  !< Jiang-Shu and Gerolymos-Senechal-Vallet optimal weights object.
  !<
  !< @note The provided WENO optimal weights implements the optimal weights defined in *Efficient Implementation of Weighted ENO
  !< Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
  !< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
  !< doi:10.1016/j.jcp.2009.07.039
  contains
    ! deferred public methods
    procedure, pass(self) :: compute     !< Compute weights.
    procedure, nopass     :: description !< Return weights string-description.
endtype optimal_weights_js

contains
  ! public non TBP
  subroutine create_optimal_weights_js_constructor(S, constructor)
  !< Create optimal weights constructor.
  integer(I_P),                                    intent(in)  :: S           !< Stencils dimension.
  class(optimal_weights_constructor), allocatable, intent(out) :: constructor !< Optimal weights constructor.

  allocate(optimal_weights_js_constructor :: constructor)
  constructor%S = S
  endsubroutine create_optimal_weights_js_constructor

  ! deferred public methods
  pure subroutine compute(self, S)
  !< Compute weights.
  class(optimal_weights_js), intent(inout) :: self !< Optimal weights.
  integer(I_P),              intent(in)    :: S    !< Number of stencils used.

  associate(opt => self%opt)
    select case(S)
      case(2) ! 3rd order
        ! 1 => left interface (i-1/2)
        opt(1, 0) = 2._R_P/3._R_P ! stencil 0
        opt(1, 1) = 1._R_P/3._R_P ! stencil 1
        ! 2 => right interface (i+1/2)
        opt(2, 0) = 1._R_P/3._R_P ! stencil 0
        opt(2, 1) = 2._R_P/3._R_P ! stencil 1
      case(3) ! 5th order
        ! 1 => left interface (i-1/2)
        opt(1, 0) = 0.3_R_P ! stencil 0
        opt(1, 1) = 0.6_R_P ! stencil 1
        opt(1, 2) = 0.1_R_P ! stencil 2
        ! 2 => right interface (i+1/2)
        opt(2, 0) = 0.1_R_P ! stencil 0
        opt(2, 1) = 0.6_R_P ! stencil 1
        opt(2, 2) = 0.3_R_P ! stencil 2
      case(4) ! 7th order
        ! 1 => left interface (i-1/2)
        opt(1, 0) =  4._R_P/35._R_P ! stencil 0
        opt(1, 1) = 18._R_P/35._R_P ! stencil 1
        opt(1, 2) = 12._R_P/35._R_P ! stencil 2
        opt(1, 3) =  1._R_P/35._R_P ! stencil 3
        ! 2 => right interface (i+1/2)
        opt(2, 0) =  1._R_P/35._R_P ! stencil 0
        opt(2, 1) = 12._R_P/35._R_P ! stencil 1
        opt(2, 2) = 18._R_P/35._R_P ! stencil 2
        opt(2, 3) =  4._R_P/35._R_P ! stencil 3
      case(5) ! 9th order
        ! 1 => left interface (i-1/2)
        opt(1, 0) =  5._R_P/126._R_P ! stencil 0
        opt(1, 1) = 20._R_P/63._R_P  ! stencil 1
        opt(1, 2) = 10._R_P/21._R_P  ! stencil 2
        opt(1, 3) = 10._R_P/63._R_P  ! stencil 3
        opt(1, 4) =  1._R_P/126._R_P ! stencil 4
        ! 2 => right interface (i+1/2)
        opt(2, 0) =  1._R_P/126._R_P ! stencil 0
        opt(2, 1) = 10._R_P/63._R_P  ! stencil 1
        opt(2, 2) = 10._R_P/21._R_P  ! stencil 2
        opt(2, 3) = 20._R_P/63._R_P  ! stencil 3
        opt(2, 4) =  5._R_P/126._R_P ! stencil 4
      case(6) ! 11th order
        ! 1 => left interface (i-1/2)
        opt(1, 0) =   1._R_P/77._R_P  ! stencil 0
        opt(1, 1) =  25._R_P/154._R_P ! stencil 1
        opt(1, 2) = 100._R_P/231._R_P ! stencil 2
        opt(1, 3) =  25._R_P/77._R_P  ! stencil 3
        opt(1, 4) =   5._R_P/77._R_P  ! stencil 4
        opt(1, 5) =   1._R_P/462._R_P ! stencil 5
        ! 2 => right interface (i+1/2)
        opt(2, 0) =   1._R_P/462._R_P ! stencil 0
        opt(2, 1) =   5._R_P/77._R_P  ! stencil 1
        opt(2, 2) =  25._R_P/77._R_P  ! stencil 2
        opt(2, 3) = 100._R_P/231._R_P ! stencil 3
        opt(2, 4) =  25._R_P/154._R_P ! stencil 4
        opt(2, 5) =   1._R_P/77._R_P  ! stencil 5
      case(7) ! 13th order
        ! 1 => left interface (i-1/2)
        opt(1, 0) =   7._R_P/1716._R_P ! stencil 0
        opt(1, 1) =  21._R_P/286._R_P  ! stencil 1
        opt(1, 2) = 175._R_P/572._R_P  ! stencil 2
        opt(1, 3) = 175._R_P/429._R_P  ! stencil 3
        opt(1, 4) = 105._R_P/572._R_P  ! stencil 4
        opt(1, 5) =   7._R_P/286._R_P  ! stencil 5
        opt(1, 6) =   1._R_P/1716._R_P ! stencil 6
        ! 2 => right interface (i+1/2)
        opt(2, 0) =   1._R_P/1716._R_P ! stencil 0
        opt(2, 1) =   7._R_P/286._R_P  ! stencil 1
        opt(2, 2) = 105._R_P/572._R_P  ! stencil 2
        opt(2, 3) = 175._R_P/429._R_P  ! stencil 3
        opt(2, 4) = 175._R_P/572._R_P  ! stencil 4
        opt(2, 5) =  21._R_P/286._R_P  ! stencil 5
        opt(2, 6) =   7._R_P/1716._R_P ! stencil 6
      case(8) ! 15th order
        ! 1 => left interface (i-1/2)
        opt(1, 0) =   8._R_P/6435._R_P ! stencil 0
        opt(1, 1) = 196._R_P/6435._R_P ! stencil 1
        opt(1, 2) = 392._R_P/2145._R_P ! stencil 2
        opt(1, 3) = 490._R_P/1287._R_P ! stencil 3
        opt(1, 4) = 392._R_P/1287._R_P ! stencil 4
        opt(1, 5) = 196._R_P/2145._R_P ! stencil 5
        opt(1, 6) =  56._R_P/6435._R_P ! stencil 6
        opt(1, 7) =   1._R_P/6435._R_P ! stencil 7
        ! 2 => right interface (i+1/2)
        opt(2, 0) =   1._R_P/6435._R_P ! stencil 0
        opt(2, 1) =  56._R_P/6435._R_P ! stencil 1
        opt(2, 2) = 196._R_P/2145._R_P ! stencil 2
        opt(2, 3) = 392._R_P/1287._R_P ! stencil 3
        opt(2, 4) = 490._R_P/1287._R_P ! stencil 4
        opt(2, 5) = 392._R_P/2145._R_P ! stencil 5
        opt(2, 6) = 196._R_P/6435._R_P ! stencil 6
        opt(2, 7) =   8._R_P/6435._R_P ! stencil 7
      case(9) ! 17th order
        ! 1 => left interface (i-1/2)
        opt(1, 0) =    9._R_P/24310._R_P ! stencil 0
        opt(1, 1) =  144._R_P/12155._R_P ! stencil 1
        opt(1, 2) = 1176._R_P/12155._R_P ! stencil 2
        opt(1, 3) = 3528._R_P/12155._R_P ! stencil 3
        opt(1, 4) =  882._R_P/2431._R_P  ! stencil 4
        opt(1, 5) = 2352._R_P/12155._R_P ! stencil 5
        opt(1, 6) =  504._R_P/12155._R_P ! stencil 6
        opt(1, 7) =   36._R_P/12155._R_P ! stencil 7
        opt(1, 8) =    1._R_P/24310._R_P ! stencil 8
        ! 2 => right interface (i+1/2)
        opt(2, 0) =    1._R_P/24310._R_P ! stencil 0
        opt(2, 1) =   36._R_P/12155._R_P ! stencil 1
        opt(2, 2) =  504._R_P/12155._R_P ! stencil 2
        opt(2, 3) = 2352._R_P/12155._R_P ! stencil 3
        opt(2, 4) =  882._R_P/2431._R_P  ! stencil 4
        opt(2, 5) = 3528._R_P/12155._R_P ! stencil 5
        opt(2, 6) = 1176._R_P/12155._R_P ! stencil 6
        opt(2, 7) =  144._R_P/12155._R_P ! stencil 7
        opt(2, 8) =    9._R_P/24310._R_P ! stencil 8
    endselect
  endassociate
  endsubroutine compute

  pure function description() result(string)
  !< Return string-description of weights.
  character(len=:), allocatable :: string           !< String-description.
  character(len=1), parameter   :: nl=new_line('a') !< New line character.

  string = 'WENO optimal weights,'//nl
  string = string//'  based on the work by Jiang and Shu "Efficient Implementation of Weighted ENO Schemes", see '// &
           'JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and'//nl
  string = string//'  on the work by Gerolymos, Senechal and Vallet "Very-high-order weno schemes", see '// &
           'JCP, 2009, vol. 228, pp. 8481--8524, doi:10.1016/j.jcp.2009.07.039'//nl
  string = string//'    The optimal weights are allocated in a two-dimensional array, in which the first index'//nl
  string = string//'    is the face selected (1 => i-1/2, 2 => i+1/2) and the second index is the number of the stencil '//nl
  string = string//'    (from 0 to S-1)'
  endfunction description
endmodule wenoof_optimal_weights_js


subroutine mmul(mat, vec, vecout, m, n)
  integer, intent(in) :: m, n
  real*8, intent(in) :: mat(m, n), vec(n)
  real*8, intent(out) :: vecout(n)
  vecout = matmul(mat, vec)
end subroutine


PROGRAM main_time

! ----------------------------------------------------------------------
! Program:	main_time.f03
! ----------------------------------------------------------------------
! Purpose: This function is used to convert different time systems, including
!          MJD, GPS week, calendar year and day of year
!
! ----------------------------------------------------------------------
! Author :	Dr. Tzupang Tseng, Geoscience Australia, Frontier-SI
! Created:	03-Apr-2020
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_timeconfig

      IMPLICIT NONE

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: jd0
      REAL (KIND = prec_d) :: GPS_wsec
      DOUBLE PRECISION FD, mjd_1980, delta_days
      DOUBLE PRECISION MJDD0, MJDref
      INTEGER (KIND = prec_int8) :: GPSweek_mod1024
      INTEGER (KIND = prec_int4) :: J
      INTEGER J_flag

! Initialize variables
MJD_IN    = 0.D0
WEEK_IN   = 0
WEEKDAY_IN= 0
YEAR_IN   = 0
MONTH_IN  = 0
DAY_IN    = 0
DOY_IN    = 0

CALL time_cmdline

IF (MJD_IN /= 0.D0) THEN
! Print MJD
        PRINT*,'MJD  ', MJD_IN
        PRINT*,''

! Compute calendar year
        jd0 = 2400000.5D0
        CALL iau_JD2CAL ( jd0, MJD_IN, YEAR_IN, MONTH_IN, DAY_IN, FD, J_flag )
        PRINT*,'YEAR-MONTH-DAY  ', YEAR_IN, MONTH_IN, DAY_IN
        PRINT*,''

! Compute day of year
        CALL iau_CAL2JD ( YEAR_IN, 1, 1, MJDD0, MJDref, J )
        DOY_IN = IDNINT(MJD_IN-MJDref) + 1
        PRINT*,'DOY  ', YEAR_IN, DOY_IN
        PRINT*,''

! Compute GPS week
        CALL time_GPSweek (MJD_IN , WEEK_IN, GPS_wsec, GPSweek_mod1024)
        WEEKDAY_IN = IDNINT(GPS_wsec/86400.D0)
        PRINT*,'GPSWEEKDAY  ', WEEK_IN, WEEKDAY_IN
        PRINT*,''

ELSE IF (DOY_IN /= 0) THEN
! Compte MJD
        CALL iau_CAL2JD ( YEAR_IN, 1, 1, MJDD0, MJDref, J )
        MJD_IN = DOY_IN -1 + MJDref
        PRINT*,'MJD  ', MJD_IN
        PRINT*,''

! Compute calendar year
        jd0 = 2400000.5D0
        CALL iau_JD2CAL ( jd0, MJD_IN, YEAR_IN, MONTH_IN, DAY_IN, FD, J_flag )
        PRINT*,'YEAR-MONTH-DAY  ', YEAR_IN, MONTH_IN, DAY_IN
        PRINT*,''

! Print DOY
        PRINT*,'DOY  ', YEAR_IN, DOY_IN
        PRINT*,''

! Compute GPS week
        CALL time_GPSweek (MJD_IN , WEEK_IN, GPS_wsec, GPSweek_mod1024)
        WEEKDAY_IN = IDNINT(GPS_wsec/86400.D0)
        PRINT*,'GPSWEEKDAY  ', WEEK_IN, WEEKDAY_IN
        PRINT*,''

ELSE IF (MONTH_IN /= 0) THEN
! Compute MJD
        CALL iau_CAL2JD ( YEAR_IN, MONTH_IN, DAY_IN, MJDD0, MJD_IN, J )
        PRINT*,'MJD  ', MJD_IN
        PRINT*,''

! Print canlendar year
        PRINT*,'YEAR-MONTH-DAY  ', YEAR_IN, MONTH_IN, DAY_IN
        PRINT*,''

! Compute day of year
        CALL iau_CAL2JD ( YEAR_IN, 1, 1, MJDD0, MJDref, J )
        DOY_IN = IDNINT(MJD_IN-MJDref) + 1
        PRINT*,'DOY  ', YEAR_IN, DOY_IN
        PRINT*,''

! Compute GPS week
        CALL time_GPSweek (MJD_IN , WEEK_IN, GPS_wsec, GPSweek_mod1024)
        WEEKDAY_IN = IDNINT(GPS_wsec/86400.D0)
        PRINT*,'GPSWEEKDAY  ', WEEK_IN, WEEKDAY_IN
        PRINT*,''

ELSE IF (WEEK_IN /= 0) THEN
        delta_days = WEEKDAY_IN + WEEK_IN*7
! 06 Jan. 1980 : GPS_week = 0
        CALL iau_CAL2JD ( 1980, 01, 06, MJDD0, mjd_1980, J_flag )
! Compute MJD
        MJD_IN = delta_days + mjd_1980
        PRINT*,'MJD  ', MJD_IN
        PRINT*,''

! Compute calendar year
        jd0 = 2400000.5D0
        CALL iau_JD2CAL ( jd0, MJD_IN, YEAR_IN, MONTH_IN, DAY_IN, FD, J_flag )
        PRINT*,'YEAR-MONTH-DAY  ', YEAR_IN, MONTH_IN, DAY_IN
        PRINT*,''

! Compute day of year
        CALL iau_CAL2JD ( YEAR_IN, 1, 1, MJDD0, MJDref, J )
        DOY_IN = IDNINT(MJD_IN-MJDref) + 1
        PRINT*,'DOY  ', YEAR_IN, DOY_IN
        PRINT*,''

! Print GPSWEEK DAY
        PRINT*,'GPSWEEKDAY  ', WEEK_IN, WEEKDAY_IN
        PRINT*,''

END IF

END PROGRAM


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mnspal : spalde test program                       cc
cc    evaluation of a spline function through its polynomial          cc
cc            representation in each knot interval.                   cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(21),y(21),t(20),c(20),d(6),cof(6)
      integer i,i1,i2,ier,j,jj,k,k1,l,l1,m,n,nk1
      real ai,aj,arg,fac,pol,tt,xx
c  set up the points where the splines will be evaluated.
      m = 21
      do 10 i=1,m
        ai = i-1
        x(i) = ai*0.5e-01
  10  continue
c  main loop for the different spline degrees.
      do 100 k=3,5,2
        k1 = k+1
c  n denotes the total number of knots.
        n = 2*k1+4
c  set up the knots of the spline
        j = n
c  the boundary knots
        do 20 i=1,k1
          t(i) = 0.
          t(j) = 0.1e+01
          j = j-1
  20    continue
c  the interior knots
        t(k1+1) = 0.1e+0
        t(k1+2) = 0.3e+0
        t(k1+3) = 0.4e+0
        t(k1+4) = 0.8e+0
c  generate the b-spline coefficients.
        nk1 = n-k1
        do 30 i=1,nk1
          ai = i
          c(i) = 0.1e-01*ai*(ai-0.5e01)
  30    continue
c  print the data for the spline.
        write(6,900) k
        write(6,905)
        write(6,910) (t(i),i=1,n)
        write(6,915)
        write(6,920) (c(i),i=1,nk1)
        l = k
        l1 = k1
c  main loop for the different points of evaluation.
        do 80 i=1,m
          arg = x(i)
c  search for knot interval t(l)<=x(i)<t(l+1).
  40      if(arg.lt.t(l1) .or. l.eq.nk1) go to 60
c  a new knot interval.
          l = l1
          l1 = l+1
          if(t(l).eq.t(l1)) go to 40
          write(6,925) t(l),t(l1)
c  calculate the spline derivatives at the midpoint tt of the interval
          tt = (t(l)+t(l1))*0.5e0
          call spalde(t,n,c,k1,tt,d,ier)
          write(6,930)
          write(6,935) (d(j),j=1,k1)
c  calculate the coefficients cof in the polynomial representation of
c  the spline in the current knot interval,i.e.
c    s(x) = cof(1)+cof(2)*(x-tt)+...+cof(k1)*(x-tt)**k
          fac = 0.1e01
          do 50 j=1,k1
            cof(j) = d(j)/fac
            aj = j
            fac = fac*aj
  50      continue
          write(6,940)
          write(6,935) (cof(j),j=1,k1)
          go to 40
c  evaluate the polynomial
  60      xx = arg-tt
          pol = cof(k1)
          jj = k1
          do 70 j=1,k
            jj = jj-1
            pol = pol*xx+cof(jj)
  70      continue
          y(i) = pol
  80    continue
        write(6,945)
        i2 = 0
        do 90 j=1,7
          i1 = i2+1
          i2 = i1+2
          write(6,950) (i,x(i),y(i),i=i1,i2)
  90    continue
 100  continue
      stop
c  format statements.
 900  format(25h0degree of the spline k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,15f5.1)
 915  format(1x,21hb-spline coefficients)
 920  format(5x,8f9.5)
 925  format(16h0knot interval (,f4.1,1h,,f4.1,1h))
 930  format(1x,49hderivative values at the midpoint of the interval)
 935  format(2x,6e13.5)
 940  format(1x,45hcoefficients in the polynomial representation)
 945  format(1h0,3(7x,1hi,3x,4hx(i),4x,7hs(x(i))))
 950  format(1x,3(i8,f7.2,f11.5))
      end


c     Module fints.f
c
c     A F77 implementation of the functions in the cints/pyints
c     routines of PyQuante.
c     This program is part of the PyQuante quantum chemistry suite.
c     Copyright 2002 California Institute of Technology.  All Rights
c     Reserved.  You may contact the author, Richard P. Muller at
c     rpm@wag.caltech.edu.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation provided that the above copyright notice
c     and this complete notice appear in all copies.
c
c     This program is distributed in the hope that it will be useful, and in
c     no event shall California Institute of Technology be liable to any
c     party for direct, indirect, special, incidental or consequential
c     damages, including lost profits, arising out of the use of this
c     software and its documentation, even if the California Institute of
c     Technology has been advised of the possibility of such damage. The
c     California Institute of Technology specifically disclaims any
c     warranties, including the implied warranties or merchantability and
c     fitness for a particular purpose. The software and documentation
c     provided hereunder is on an AS IS basis, and the California Institute
c     of Technology has no obligations to provide maintenance, support,
c     updates, enhancements or modifications.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307

c     Functions in this module:
c     coulomb_repulsion: Compute the coulomb repulsion between four
c       primitive gaussian functions.
c     overlap: Compute the overlap between two primitive gaussians
c     kinetic: Compute the kinetic energy matrix element between two
c      primitive gaussian functions

c--------------------------------------------------------------------------

      real*8 function overlap(alpha1,l1,m1,n1,x1,y1,z1,
     $     alpha2,l2,m2,n2,x2,y2,z2)
c     Note: this function does multiply by the normalization constant

      implicit none

c     Arguments and local variables
      real*8 alpha1,x1,y1,z1,alpha2,x2,y2,z2,
     $     rab2,gamma,xp,yp,zp,factor,wx,wy,wz,pi
      integer l1,m1,n1,l2,m2,n2

c     Functions
      real*8 product_center_1D,dist2,overlap1D

c     Constants
      pi = 3.1415927

      rab2 = dist2(x1,y1,z1,x2,y2,z2)

      gamma = alpha1+alpha2
      xp = product_center_1D(alpha1,x1,alpha2,x2)
      yp = product_center_1D(alpha1,y1,alpha2,y2)
      zp = product_center_1D(alpha1,z1,alpha2,z2)

      factor = ((pi/gamma)**1.5)*exp(-alpha1*alpha2*rab2/gamma)

      wx = overlap1D(l1,l2,xp-x1,xp-x2,gamma)
      wy = overlap1D(m1,m2,yp-y1,yp-y2,gamma)
      wz = overlap1D(n1,n2,zp-z1,zp-z2,gamma)
      overlap = factor*wx*wy*wz;
      return
      end

c--------------------------------------------------------------------------

      real*8 function kinetic(alpha1,l1,m1,n1,x1,y1,z1,
     $     alpha2,l2,m2,n2,x2,y2,z2)

      implicit none

c     Arguments and local variables
      real*8 alpha1,x1,y1,z1,alpha2,x2,y2,z2,
     $     term0,term1,term2x,term2y,term2z
      integer l1,m1,n1,l2,m2,n2

c     Constants
      real*8 zero,one,two,three,half

c     Functions
      real*8 overlap

      zero = 0.0d0
      one = 1.0d0
      two = 2*one
      three = 3*one
      half = one/two

      term0 = alpha2*(two*(l2+m2+n2)+three)*
     $     overlap(alpha1,l1,m1,n1,x1,y1,z1,
     $     alpha2,l2,m2,n2,x2,y2,z2)

      term1 = -two*alpha2*alpha2*(
     $     overlap(alpha1,l1,m1,n1,x1,y1,z1,alpha2,l2+2,m2,n2,x2,y2,z2)+
     $     overlap(alpha1,l1,m1,n1,x1,y1,z1,alpha2,l2,m2+2,n2,x2,y2,z2)+
     $     overlap(alpha1,l1,m1,n1,x1,y1,z1,alpha2,l2,m2,n2+2,x2,y2,z2))

      if (l2 .ge. 2) then
         term2x = -half*l2*(l2-1)*overlap(alpha1,l1,m1,n1,x1,y1,z1,
     $        alpha2,l2-2,m2,n2,x2,y2,z2)
      else
         term2x = zero
      endif

      if (m2 .ge. 2) then
         term2y = -half*m2*(m2-1)*overlap(alpha1,l1,m1,n1,x1,y1,z1,
     $        alpha2,l2,m2-2,n2,x2,y2,z2)
      else
         term2y = zero
      endif

      if (n2 .ge. 2) then
         term2z = -half*n2*(n2-1)*overlap(alpha1,l1,m1,n1,x1,y1,z1,
     $        alpha2,l2,m2,n2-2,x2,y2,z2)
      else
         term2z = zero
      endif

      kinetic = term0+term1+term2x+term2y+term2z

      return
      end

c--------------------------------------------------------------------------

      real*8 function overlap1D(l1,l2,xap,xbp,gamma)
      implicit none
      integer l1,l2,i
      real*8 xap,xbp,gamma,sum
      real*8 binomial_prefactor
      integer fact2
      sum = 0.0d0
      do i=0, int(0.5*(l1+l2))
         sum = sum + binomial_prefactor(2*i,l1,l2,xap,xbp)*
     $        fact2(2*i-1)/((2*gamma)**i)
      enddo
      overlap1D = sum
      return
      end

c--------------------------------------------------------------------------

      real*8 function coulomb_repulsion(
     $     xa, ya, za, norma, la, ma, na, alphaa,
     $     xb, yb, zb, normb, lb, mb, nb, alphab,
     $     xc, yc, zc, normc, lc, mc, nc, alphac,
     $     xd, yd, zd, normd, ld, md, nd, alphad)

      implicit none

c     Parameters
      integer MAXLEN
      parameter (MAXLEN=25)

c     Arguments
      real*8 xa,ya,za,norma,alphaa,xb,yb,zb,normb,alphab,
     $     xc,yc,zc,normc,alphac,xd,yd,zd,normd,alphad
      integer la,ma,na,lb,mb,nb,lc,mc,nc,ld,md,nd

c     Local variables
      real*8 rab2, rcd2,rpq2,xp,yp,zp,xq,yq,zq,gamma1,gamma2,delta,sum,
     $     xval
      real*8 Bx(0:MAXLEN-1), By(0:MAXLEN-1), Bz(0:MAXLEN-1)
      integer i,j,k

c     Functions
      real*8 dist2,product_center_1D,Fgamma

c     Constants
      real*8 pi

      pi = 3.1415927

      rab2 = dist2(xa,ya,za,xb,yb,zb)
      rcd2 = dist2(xc,yc,zc,xd,yd,zd)
      xp = product_center_1D(alphaa,xa,alphab,xb)
      yp = product_center_1D(alphaa,ya,alphab,yb)
      zp = product_center_1D(alphaa,za,alphab,zb)
      xq = product_center_1D(alphac,xc,alphad,xd)
      yq = product_center_1D(alphac,yc,alphad,yd)
      zq = product_center_1D(alphac,zc,alphad,zd)
      rpq2 = dist2(xp,yp,zp,xq,yq,zq)
      gamma1 = alphaa+alphab
      gamma2 = alphac+alphad
      delta = (1./gamma1+1./gamma2)/4.

      call B_array(la+lb+lc+ld+1,Bx,
     $     la,lb,lc,ld,xp,xa,xb,xq,xc,xd,gamma1,gamma2,delta)
      call B_array(ma+mb+mc+md+1,By,
     $     ma,mb,mc,md,yp,ya,yb,yq,yc,yd,gamma1,gamma2,delta)
      call B_array(na+nb+nc+nd+1,Bz,
     $     na,nb,nc,nd,zp,za,zb,zq,zc,zd,gamma1,gamma2,delta)

      sum = 0.d0
      do i = 0,la+lb+lc+ld
         do j = 0, ma+mb+mc+md
            do k = 0, na+nb+nc+nd
               xval = float(i+j+k) ! cast to double
               sum = sum +
     $              Bx(i)*By(j)*Bz(k)
     $              *Fgamma(xval,0.25*rpq2/delta)
            enddo
         enddo
      enddo

      coulomb_repulsion = 2.*pi**2.5
     $     /(gamma1*gamma2*sqrt(gamma1+gamma2))
     $     *exp(-alphaa*alphab*rab2/gamma1)
     $     *exp(-alphac*alphad*rcd2/gamma2)
     $     *sum*norma*normb*normc*normd

      return
      end

c--------------------------------------------------------------------------

      real*8 function dist2(xa,ya,za,xb,yb,zb)

      implicit none
      real*8 xa,ya,za,xb,yb,zb,dx,dy,dz

      dx = xa-xb
      dy = ya-yb
      dz = za-zb
      dist2 = dx*dx+dy*dy+dz*dz

      return
      end

c--------------------------------------------------------------------------

      real*8 function dist(xa,ya,za,xb,yb,zb)

      implicit none
      real*8 xa,ya,za,xb,yb,zb

      real*8 dist2

      dist = sqrt(dist2(xa,ya,za,xb,yb,zb))

      return
      end

c--------------------------------------------------------------------------

      real*8 function product_center_1D(alphaa,xa,alphab,xb)

      implicit none

      real*8 alphaa,xa,alphab,xb

      product_center_1D = (alphaa*xa+alphab*xb)/(alphaa+alphab)

      return
      end

c--------------------------------------------------------------------------

      subroutine B_array(n,barry,l1,l2,l3,l4,
     $     p,a,b,q,c,d,g1,g2,delta)

      implicit none

      integer n,l1,l2,l3,l4,i,i1,i2,j1,j2,k,index
      real*8 barry(0:n-1),p,a,b,q,c,d,g1,g2,delta,zero

      real*8 b_term ! External function

      zero = 0.

      do i = 0, n-1
         barry(i) = zero
      enddo

      do i1=0, l1+l2
         do i2=0, l3+l4
            do j1=0, i1/2
               do j2=0, i2/2
                  do k=0, (i1+i2)/2-j1-j2
                     index = i1+i2-2*(j1+j2)-k
                     barry(index) = barry(index)
     $                    + b_term(i1,i2,j1,j2,k,l1,l2,l3,l4,
     $                             p,a,b,q,c,d,g1,g2,delta)
                  enddo
               enddo
            enddo
         enddo
      enddo

      return
      end

c--------------------------------------------------------------------------

      real*8 function b_term(i1,i2,j1,j2,k,l1,l2,l3,l4,
     $     p,a,b,q,c,d,g1,g2,delta)

      integer i1,i2,j1,j2,k,l1,l2,l3,l4
      real*8 p,a,b,q,c,d,g1,g2,delta
      real*8 fB
      integer fact_ratio2

      b_term = fB(i1,l1,l2,p,a,b,j1,g1)
     $     *(-1**i2)*fB(i2,l3,l4,q,c,d,j2,g2)
     $     *(-1**k)*fact_ratio2(i1+i2-2*(j1+j2),k)
     $     *(q-p)**(i1+i2-2*(j1+j2)-2*k)
     $     /(delta)**(i1+i2-2*(j1+j2)-k)
      return
      end

c--------------------------------------------------------------------------

      real*8 function fB(i, l1, l2, px, ax, bx, ir, g)
      implicit none

      integer i,l1,l2,ir
      real*8 px,ax,bx,g

      real*8 binomial_prefactor,Bfunc

      fB = binomial_prefactor(i,l1,l2,px-ax,px-bx)*Bfunc(i,ir,g)

      return
      end

c--------------------------------------------------------------------------

      real*8 function Bfunc(i,ir,g)
      implicit none
      integer i,ir
      real*8 g
      integer fact_ratio2

      Bfunc = fact_ratio2(i,ir)*((4*g)**(ir-i))

      return
      end

c--------------------------------------------------------------------------

      real*8 function binomial_prefactor(s,ia,ib,xpa,xpb)
      implicit none
      integer s,ia,ib,j
      real*8 xpa,xpb,sum
      integer binomial

      sum = 0.
      do j=0,s
         if ((s-ia .le. j) .and. (j .le. ib))
     $        sum = sum + binomial(ia,s-j)*binomial(ib,j)
     $        *(xpa**(ia-s+j))*(xpb**(ib-j))
      enddo
      binomial_prefactor = sum
      return
      end

c--------------------------------------------------------------------------

      integer function binomial(i,j)
      implicit none
      integer i,j
      integer fact

      binomial = fact(i)/fact(j)/fact(i-j)

      return
      end

c--------------------------------------------------------------------------

      integer function fact_ratio2(i,j)
      implicit none
      integer i,j
      integer fact

      fact_ratio2 = fact(i)/fact(j)/fact(i-2*j)

      return
      end

c--------------------------------------------------------------------------

      integer function fact2(n)
      implicit none
      integer i,n

      fact2=1
      if (n .le. 1) return
      do i = 1,n,2
         fact2 = fact2*i
      enddo
      return
      end

c--------------------------------------------------------------------------

      integer function fact(n)
      implicit none
      integer i,n

      fact=1
      if (n .le. 1) return
      do i=1,n
         fact = fact*i
      enddo
      return
      end

c--------------------------------------------------------------------------

      real*8 function Fgamma(a,x)
      implicit none
      real*8 a,x,val
      real*8 gammp

      if (x .lt. 0.00001d0) x = 0.000001d0

      val = gammp(a+0.5,x)
      Fgamma = 0.5*(x**(-a-0.5))*val

      return
      end

c--------------------------------------------------------------------------

c     The following are from Numerical Recipes
c     gammp is hacked a bit to return exp(gln)*gamma
      FUNCTION gammp(a,x)
      REAL*8 a,gammp,x
CU    USES gcf,gser
      REAL*8 gammcf,gamser,gln

      if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammp'
      if(x.lt.a+1.)then
        call gser(gamser,a,x,gln)
        gammp=exp(gln)*gamser
      else
        call gcf(gammcf,a,x,gln)
        gammp=exp(gln)*(1.-gammcf)
      endif

      return
      END

c--------------------------------------------------------------------------

      SUBROUTINE gser(gamser,a,x,gln)
      INTEGER ITMAX
      REAL*8 a,gamser,gln,x,EPS
      PARAMETER (ITMAX=100,EPS=3.e-7)
CU    USES gammln
      INTEGER n
      REAL*8 ap,del,sum,gammln
      gln=gammln(a)
      if(x.le.0.)then
        if(x.lt.0.)pause 'x < 0 in gser'
        gamser=0.
        return
      endif
      ap=a
      sum=1./a
      del=sum
      do 11 n=1,ITMAX
        ap=ap+1.
        del=del*x/ap
        sum=sum+del
        if(abs(del).lt.abs(sum)*EPS)goto 1
11    continue
      pause 'a too large, ITMAX too small in gser'
1     gamser=sum*exp(-x+a*log(x)-gln)
      return
      END

c--------------------------------------------------------------------------

      FUNCTION gammln(xx)
      REAL*8 gammln,xx
      INTEGER j
      real*8 ser,stp,tmp,x,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      do 11 j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
11    continue
      gammln=tmp+log(stp*ser/x)
      return
      END

c--------------------------------------------------------------------------

      SUBROUTINE gcf(gammcf,a,x,gln)
      INTEGER ITMAX
      REAL*8 a,gammcf,gln,x,EPS,FPMIN
      PARAMETER (ITMAX=100,EPS=3.e-7,FPMIN=1.e-30)
CU    USES gammln
      INTEGER i
      REAL*8 an,b,c,d,del,h,gammln
      gln=gammln(a)
      b=x+1.-a
      c=1./FPMIN
      d=1./b
      h=d
      do 11 i=1,ITMAX
        an=-i*(i-a)
        b=b+2.
        d=an*d+b
        if(abs(d).lt.FPMIN)d=FPMIN
        c=b+an/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1./d
        del=d*c
        h=h*del
        if(abs(del-1.).lt.EPS)goto 1
11    continue
      pause 'a too large, ITMAX too small in gcf'
1     gammcf=exp(-x+a*log(x)-gln)*h
      return
      END

c--------------------------------------------------------------------------


!***************************************************************************************************
! xnet_integrate_bd.f90 10/18/17
! Bader-Deufelhard solver
!
! The routines in this file perform the Bader-Deufelhard time integration for thermonuclear reaction
! network. Based on routines from Press et al (1992,1996) "Numerical Recipes" and inspired by
! Timmes (1999; ApJS 124 241-263).
!***************************************************************************************************

Module xnet_integrate_bd
  Implicit None

Contains

  Subroutine solve_bd(kstep,its)
    !-----------------------------------------------------------------------------------------------
    ! This routine performs semi-implicit extrapolation of integrations returned by step_bd. Success
    ! of a timestep is judged against truncation errors from successive integrations of increasing
    ! order. Subsequent timesteps are also based on these truncation errors.
    ! Based on stifbs routine of Numerical Recipes.
    !-----------------------------------------------------------------------------------------------
    Use nuclear_data, Only: ny, nname
    Use reaction_data
    Use xnet_abundances, Only: y, ydot, yo, yt
    Use xnet_conditions
    Use xnet_controls, Only: idiag, iheat, kmon, ktot, lun_diag, lun_stdin, lun_stdout, tolm, yacc
    Use xnet_types, Only: dp
    Implicit None

    ! Input variables
    Integer, Intent(in) :: kstep

    ! Output variables
    Integer, Intent(out) :: its

    ! Local variables
    Real(dp), Parameter :: safe1 = 0.25, safe2 = 0.7, scalmx = 0.1
    Real(dp), Parameter :: redmax = 1.0e-5, redmin = 0.7, errmin = 1.0e-30
    Integer, Parameter :: imax = 8, kmaxx = imax-1, ktsmx = 100
    Integer, Parameter :: nseq(imax) = (/ 2, 6, 10, 14, 22, 34, 50, 70 /)
    Real(dp), Save :: alf(kmaxx,kmaxx), a(imax)
    Integer, Save :: kopt, kmax
    Real(dp) :: yerr(ny), yseq(ny), yscal(ny), err(kmaxx), t9seq, t9err
    Real(dp) :: eps, eps1, errmax, fact, red, scal, wrkmin, test
    Integer :: i, iq, k, km, kts, iminloc
    Logical :: reduct

    ! Set accuracy limits
    eps = tolm
    yscal = max(yacc,abs(y))

    tt = t + tdel
    If ( idiag >= 2 ) Write(lun_diag,"(a,i4,2es10.3)") 'Solve_BD',kstep,t,tt

    If ( kstep == 1 ) Then

      ! Initialize values
      kopt = kmaxx
      eps1 = safe1*eps

      ! Compute work coeffs a(k)
      a(1) = nseq(1) + 1
      Do k = 1, kmaxx
        a(k+1) = a(k) + nseq(k+1)
      EndDo

      ! Compute alf
      Do iq = 2, kmaxx
        Do k = 1, iq-1
          alf(k,iq) = eps1**( (a(k+1) - a(iq+1)) / ((a(iq+1) - a(1) + 1.0) * real((2*k+1),dp)) )
        EndDo
      EndDo

      a(1) = ny + a(1)
      Do k = 1, kmaxx
        a(k+1) = a(k) + nseq(k+1)
      EndDo

      Do kopt = 2, kmaxx-1
        If ( a(kopt+1) > a(kopt)*alf(kopt-1,kopt) ) Exit
      EndDo
      kmax = kopt
    EndIf

    reduct = .false.

  TS: Do kts = 1, ktsmx
      k = 0
      ktot(2) = ktot(2) + k
      Do k = 1, kmax
        tt = t + tdel
        If ( tt <= t ) Then
          Write(lun_stdout,*) 'Stepsize zero in solve_bd'
          Read(lun_stdin,*)
        EndIf
        If ( idiag >=2 ) Write(lun_diag,"(a7,2i4,2es10.3)") 'Step_BD',kts,k,t,tdel

        ! Reset temperature, density, electron fraction, and abundances
        If ( iheat > 0 ) t9t = t9
        yet = ye
        yt = y

        ! Attempt BD integration
        Call step_bd(kstep,nseq(k),yseq,t9seq)
        test = (tdel / nseq(k))**2

        ! Perform Richardson Extrapolation
        If ( iheat > 0 ) Then
          Call poly_extr_t9(k,test,yseq,yt,yerr,t9seq,t9t,t9err)
        Else
          Call poly_extr(k,test,yseq,yt,yerr)
        EndIf

        If ( idiag >= 2 ) Then
          Write(lun_diag,"(a5,i4,3es10.3)") 'Extrp',nseq(k),t,test,tdel
          Write(lun_diag,"(3es10.3)") (yt(i),yseq(i),yerr(i),i=1,ny)
          If ( iheat > 0 ) Write(lun_diag,"(3es10.3)") t9t,t9seq,t9err
        EndIf

        If ( k /= 1 ) Then
          errmax = maxval(abs(yerr / yscal))
          errmax = max(errmin,errmax) / eps
          If ( iheat > 0 ) errmax = max(t9err,errmax)
          km = k - 1
          err(km) = (errmax/safe1)**(1.0/real(2*km+1,dp))
        EndIf

        If ( k /= 1 .and. ( k >= kopt-1 .or. kstep==1 ) ) Then
          If ( errmax < 1.0 ) Exit TS
          If ( k == kmax .or. k == kopt+1 ) Then
            red = safe2 / err(km)
            Exit
          ElseIf ( k == kopt ) Then
            If ( alf(kopt-1,kopt) < err(km) ) Then
              red = 1.0 / err(km)
              Exit
            EndIf
          ElseIf ( kopt == kmax ) Then
            If ( alf(km,kmax-1) < err(km) ) Then
              red = alf(km,kmax-1) * safe2 / err(km)
              Exit
            EndIf
          ElseIf ( alf(km,kopt) < err(km) ) Then
            red = alf(km,kopt-1) / err(km)
            Exit
          EndIf
        EndIf
      EndDo
      ktot(2) = ktot(2) + k
      red = max(min(red,redmin),redmax)
      tdel = tdel*red
      reduct = .true.
    EndDo TS
    iminloc = minloc(a(2:km+1) * max(err(1:km),scalmx),dim=1)
    kopt = 1 + iminloc
    scal = max(err(kopt-1),scalmx)
    wrkmin = scal * a(kopt)
    tdel_next = tdel / scal
    If ( kopt >= k .and. kopt /= kmax .and. .not. reduct ) Then
      fact = max(scal/alf(kopt-1,kopt),scalmx)
      If ( a(kopt+1)*fact <= wrkmin ) Then
        tdel_next = tdel/fact
        kopt = kopt+1
      EndIf
    EndIf

    ! Update time, time_step, and abundances for successful timestep
    If ( kts <= ktsmx ) Then
      its = 0
      nto = nt   ; nt = ntt
      to = t     ; t = tt
      t9o = t9   ; t9 = t9t
      rhoo = rho ; rho = rhot
      yeo = ye   ; ye = yet
      yo = y     ; y = yt
    Else
      its = 1
    EndIf
    kmon(1) = kts; kmon(2) = k
    ktot(1) = ktot(1) + kts
    Write(lun_diag,"(a,4es10.3)") 'dt',tdel,tdel_next

    Return
  End Subroutine solve_bd

  Subroutine step_bd(kstep,numsteps,yout,t9out)
    !-----------------------------------------------------------------------------------------------
    ! This routine performs one step of the semi-implicit midpoint rule, starting from initial
    ! abundances, y, to final abundances, yout. Based on simpr routine of Numerical Recipes.
    !-----------------------------------------------------------------------------------------------
    Use nuclear_data
    Use xnet_abundances
    Use xnet_conditions
    Use xnet_controls
    Use xnet_types, Only: dp
    Implicit None

    ! Input variables
    Integer, Intent(in) :: kstep, numsteps

    ! Output variables
    Real(dp), Intent(out) :: yout(ny), t9out

    ! Local variables
    Real(dp) :: yrhs(ny), del(ny), dy(ny)
    Real(dp) :: t9rhs, dt9, delt9, relt9
    Real(dp) :: d, ttemp, dt
    Integer :: i, j, step_loop

    ! Set length of sub-timesteps
    ttemp = t
    dt = tdel / numsteps

    ! Calculate the thermodynamic factors necessary for reaction rates, including
    ! screening, and the reaction rates, if thermodynamic conditions are changing.
    If ( nh > 1 .or. iheat > 0 ) Call cross_sect

    ! Calculate the reaction rates and abundance time derivatives
    Call yderiv

    ! Build the Jacobian and LU decompose
    Call jacobian_build(1.0,-dt)
    Call jacobian_decomp(kstep)

    ! First step
    ! Calculate the right hand side
    yrhs = dt*ydot
    If ( iheat > 0 ) t9rhs = 0.0

    If ( idiag >= 2 ) Write(lun_diag,"(i10,(7es10.3))") 0,ttemp,yt
    If ( idiag >= 4 ) Then
      Write(lun_diag,"(a2,i5,es14.7)") 'First',kstep,dt
      Write(lun_diag,"(a5,4es23.15)") (nname(i),yrhs(i),ydot(i),yt(i),y(i),i=1,ny)
      If ( iheat > 0 ) Write(lun_diag,"(a9,3es23.15)") '   T9',t9rhs,t9dot,t9t,t9
    EndIf

    ! Do the back substitution
    Call jacobian_bksub(kstep,yrhs,dy,t9rhs,dt9)

    ! Save values for the next iteration
    del = dy
    yt = y + del
    If ( iheat > 0 ) Then
      delt9 = dt9
      t9t = t9t + delt9
      Call cross_sect
    EndIf

    ! Advance time
    ttemp = ttemp + dt
    If ( idiag >= 2 ) Write(lun_diag,"(i10,(7es10.3))") 1,ttemp,yt

    Call yderiv

    ! For intermediate steps
    Do step_loop = 2, numsteps

      ! Calculate right hand side
      yrhs = dt*ydot - del
      If ( iheat > 0 ) t9rhs = dt*t9dot - delt9

      ! Perform back substitution
      Call jacobian_bksub(kstep,yrhs,dy,t9rhs,dt9)

      ! Save values for the next iteration
      del = del + 2.0*dy
      yt = yt + del
      If ( iheat > 0 ) Then
        delt9 = delt9 + 2.0*dt9
        t9t = t9t + delt9
        Call cross_sect
      EndIf

      ! Advance time
      ttemp = ttemp + dt
      If ( idiag >= 2 ) Write(lun_diag,"(i10,(7es10.3))") step_loop,ttemp,yt
      Call yderiv
    EndDo

    ! Final step
    ! Calculate right hand side
    yrhs = dt*ydot - del
    If ( iheat > 0 ) t9rhs = dt*t9dot - delt9

    ! Perform back substition
    Call jacobian_bksub(kstep,yrhs,dy,t9rhs,dt9)

    ! Use yout for the final population
    yt = yt + dy
    yout = yt
    If ( iheat > 0 ) Then
      t9t = t9t + dt9
      t9out = t9t
    EndIf
    If ( idiag >= 2 ) Write(lun_diag,"(i10,(7es10.3))") step_loop,ttemp,yout

    Return
  End Subroutine step_bd

  Subroutine poly_extr(iest,test,yest,yz,dy)
    !-----------------------------------------------------------------------------------------------
    ! This routine performs a Richardson extrapolation, using a polynomial basis, of successive
    ! estimates of the abundances from finer timesliced integrations.
    ! Based on the psextr routine from Numerical Recipes.
    !-----------------------------------------------------------------------------------------------
    Use nuclear_data, Only: ny
    Use xnet_controls, Only: lun_stdout
    Use xnet_types, Only: dp
    Implicit None

    ! Input variables
    Integer, Intent(in) :: iest
    Real(dp), Intent(in) :: test, yest(ny)

    ! Output variables
    Real(dp), Intent(out) :: yz(ny), dy(ny)
    Integer, Parameter :: iest_max = 16
    Integer :: j
    Real(dp) :: delta, f1, f2
    Real(dp) :: d(ny), tmp(ny), q(ny)
    Real(dp), Save :: t(iest_max)
    Real(dp), Allocatable, Save :: qcol(:,:)
    !$omp threadprivate(qcol,t)

    If (iest > iest_max) Write(lun_stdout,*) 'Probable misuse, too much extrapolation'
    If ( .not. Allocated(qcol) ) Allocate(qcol(ny,iest_max))
    t(iest) = test
    dy = yest
    yz = yest
    If ( iest == 1 ) Then
      qcol(:,1) = yest
    Else
      d = yest
      Do j = 1, iest-1
        delta = 1.0 / (t(iest-j) - test)
        f1 = test * delta
        f2 = t(iest-j) * delta
        q = qcol(:,j)
        qcol(:,j) = dy
        tmp = d - q
        dy = f1 * tmp
        d = f2 * tmp
        yz = yz + dy
      EndDo
      qcol(:,iest) = dy
    EndIf

    Return
  End Subroutine poly_extr

  Subroutine poly_extr_t9(iest,test,yest,yz,dy,t9est,t9z,dt9)
    !-----------------------------------------------------------------------------------------------
    ! This routine performs a Richardson extrapolation, using a polynomial basis, of successive
    ! estimates of the abundances from finer timesliced integrations.
    ! Based on the psextr routine from Numerical Recipes.
    !-----------------------------------------------------------------------------------------------
    Use nuclear_data, Only: ny
    Use xnet_controls, Only: lun_stdout
    Use xnet_types, Only: dp
    Implicit None

    ! Input variables
    Integer, Intent(in) :: iest
    Real(dp), Intent(in) :: test, yest(ny), t9est

    ! Output variables
    Real(dp), Intent(out) :: yz(ny), dy(ny), t9z, dt9

    ! Local variables
    Integer, Parameter :: iest_max = 16
    Integer :: j
    Real(dp) :: delta, f1, f2
    Real(dp) :: d(ny), tmp(ny), q(ny)
    Real(dp), Save :: t(iest_max)
    Real(dp), Allocatable, Save :: qcol(:,:)
    !$omp threadprivate(qcol,t)

    If ( iest > iest_max ) Write(lun_stdout,*) 'Probable misuse, too much extrapolation'
    If ( .not. Allocated(qcol) ) Allocate(qcol(ny+1,iest_max))
    t(iest) = test
    dy = yest
    yz = yest
    dt9 = t9est
    t9z = t9est
    If ( iest == 1 ) Then
      qcol(:,1) = (/ yest, t9est /)
    Else
      d = (/ yest, t9est /)
      Do j = 1, iest-1
        delta = 1.0 / (t(iest-j) - test)
        f1 = test * delta
        f2 = t(iest-j) * delta
        q = qcol(:,j)
        qcol(:,j) = dy
        tmp = d - q
        dy = f1 * tmp
        dt9 = f1 * tmp(ny+1)
        d = f2 * tmp
        yz = yz + dy
        t9z = t9z + dt9
      EndDo
      qcol(:,iest) = (/ dy, dt9 /)
    EndIf

    Return
  End Subroutine poly_extr_t9

End Module xnet_integrate_bd


module stdlib_stats_distribution_uniform
    use stdlib_kinds
    use stdlib_error, only : error_stop
    use stdlib_random, only : dist_rand

    implicit none
    private

    real(dp), parameter  :: MESENNE_NUMBER = 1.0_dp / (2.0_dp ** 53 - 1.0_dp)
    integer(int64), parameter :: INT_ONE = 1_int64

    public :: rvs_uniform
    public :: pdf_uniform
    public :: cdf_uniform
    public :: shuffle

    interface rvs_uniform
    !! version: experimental
    !!
    !! Get uniformly distributed random variate for integer, real and complex
    !! variables.
    !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
    !! rvs_uniform-uniform-distribution-random-variates))

        module procedure rvs_unif_0_rdp  ! 0 dummy variable

        module procedure rvs_unif_1_iint32     ! 1 dummy variable
        module procedure rvs_unif_1_rdp     ! 1 dummy variable
        module procedure rvs_unif_1_cdp     ! 1 dummy variable

        module procedure rvs_unif_iint32       ! 2 dummy variables
        module procedure rvs_unif_rdp       ! 2 dummy variables
        module procedure rvs_unif_cdp       ! 2 dummy variables

        module procedure rvs_unif_array_iint32 ! 3 dummy variables
        module procedure rvs_unif_array_rdp ! 3 dummy variables
        module procedure rvs_unif_array_cdp ! 3 dummy variables
    end interface rvs_uniform

    interface pdf_uniform
    !! version: experimental
    !!
    !! Get uniform distribution probability density (pdf) for integer, real and
    !! complex variables.
    !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
    !! pdf_uniform-uniform-probability-density-function))

        module procedure pdf_unif_iint32
        module procedure pdf_unif_rdp
        module procedure pdf_unif_cdp
    end interface pdf_uniform

    interface cdf_uniform
    !! version: experimental
    !!
    !! Get uniform distribution cumulative distribution function (cdf) for integer,
    !! real and complex variables.
    !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
    !! cdf_uniform-uniform-cumulative-distribution-function))
    !!
        module procedure cdf_unif_iint32
        module procedure cdf_unif_rdp
        module procedure cdf_unif_cdp
    end interface cdf_uniform

    interface shuffle
    !! version: experimental
    !!
    !! Fisher-Yates shuffle algorithm for a rank one array of integer, real and
    !! complex variables.
    !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
    !! shuffle-using-fisher-yates-algorithm-to-generate-a-random-permutation-of-a-list))
    !!
        module procedure shuffle_iint32
        module procedure shuffle_rdp
        module procedure shuffle_cdp
    end interface shuffle

contains

    impure elemental function rvs_unif_1_iint32(scale) result(res)
    !
    ! Uniformly distributed integer in [0, scale]
    ! Bitmask with rejection
    ! https://www.pcg-random.org/posts/bounded-rands.html
    !
    ! Fortran 90 translated from c by Jim-215-fisher
    !
        integer(int32), intent(in) :: scale
        integer(int32) ::  res, u, mask
        integer :: zeros, bits_left, bits

        if(scale <= 0_int32) call error_stop("Error(rvs_unif_1): Uniform"     &
            //" distribution scale parameter must be positive")
        zeros = leadz(scale)
        bits = bit_size(scale) - zeros
        mask = shiftr(not(0_int32), zeros)
        L1 : do
            u = dist_rand(scale)
            res = iand(u, mask)
            if(res <= scale) exit L1
            bits_left = zeros
            L2 : do
                if(bits_left < bits) exit L2
                u = shiftr(u, bits)
                res = iand(u, mask)
                if(res <= scale) exit L1
                bits_left = bits_left - bits
            end do L2
        end do L1
    end function rvs_unif_1_iint32

    impure elemental function rvs_unif_iint32(loc, scale) result(res)
    !
    ! Uniformly distributed integer in [loc, loc + scale]
    !
        integer(int32), intent(in) :: loc, scale
        integer(int32)  ::  res

        if(scale <= 0_int32) call error_stop("Error(rvs_unif): Uniform"       &
            //" distribution scale parameter must be positive")
        res = loc + rvs_unif_1_iint32(scale)
    end function rvs_unif_iint32

    impure elemental function rvs_unif_0_rdp( ) result(res)
    !
    ! Uniformly distributed float in [0,1]
    ! Based on the paper by Frederic Goualard, "Generating Random Floating-
    ! Point Numbers By Dividing Integers: a Case Study", Proceedings of
    ! ICCS 2020, June 2020, Amsterdam, Netherlands
    !
        real(dp)  ::  res
        integer(int64) :: tmp

        tmp = shiftr(dist_rand(INT_ONE), 11)        ! Get random from [0,2^53-1]
        res = real(tmp * MESENNE_NUMBER, kind = dp) ! convert to [0,1]
    end function rvs_unif_0_rdp

    impure elemental function rvs_unif_1_rdp(scale) result(res)
    !
    ! Uniformly distributed float in [0, scale]
    !
        real(dp), intent(in) :: scale
        real(dp)  ::  res

        if(scale == 0._dp) call error_stop("Error(rvs_unif_1): "           &
            //"Uniform distribution scale parameter must be non-zero")
        res = scale * rvs_unif_0_rdp( )
    end function rvs_unif_1_rdp

    impure elemental function rvs_unif_rdp(loc, scale) result(res)
    !
    ! Uniformly distributed float in [loc, loc + scale]
    !
        real(dp), intent(in) :: loc, scale
        real(dp)  ::  res

        if(scale == 0._dp) call error_stop("Error(rvs_unif): "             &
           //"Uniform distribution scale parameter must be non-zero")
        res = loc + scale * rvs_unif_0_rdp( )
    end function rvs_unif_rdp

    impure elemental function rvs_unif_1_cdp(scale) result(res)
    !
    ! Uniformly distributed complex in [(0,0i), (scale, i(scale))]
    ! The real part and imaginary part are independent of each other, so that
    ! the joint distribution is on an unit square [(0,0i), (scale,i(scale))]
    !
        complex(dp), intent(in) :: scale
        complex(dp) :: res
        real(dp) :: r1, tr, ti

        if(scale == (0.0_dp, 0.0_dp)) call error_stop("Error(rvs_uni_" &
           //"1): Uniform distribution scale parameter must be non-zero")
        r1 = rvs_unif_0_rdp( )
        if(scale % re == 0.0_dp) then
            ti = scale % im * r1
            tr = 0.0_dp
        else if(scale % im == 0.0_dp) then
            tr = scale % re * r1
            ti = 0.0_dp
        else
            tr = scale % re * r1
            r1 = rvs_unif_0_rdp( )
            ti = scale % im * r1
        end if
        res = cmplx(tr, ti, kind=dp)
    end function rvs_unif_1_cdp

    impure elemental function rvs_unif_cdp(loc, scale) result(res)
    !
    ! Uniformly distributed complex in [(loc,iloc), (loc + scale, i(loc +
    ! scale))].
    ! The real part and imaginary part are independent of each other, so that
    ! the joint distribution is on an unit square [(loc,iloc), (loc + scale,
    ! i(loc + scale))]
    !
        complex(dp), intent(in) :: loc, scale
        complex(dp) :: res
        real(dp) :: r1, tr, ti

        if(scale == (0.0_dp, 0.0_dp)) call error_stop("Error(rvs_uni_" &
            //"): Uniform distribution scale parameter must be non-zero")
        r1 = rvs_unif_0_rdp( )
        if(scale % re == 0.0_dp) then
            tr = loc % re
            ti = loc % im + scale % im * r1
        else if(scale % im == 0.0_dp) then
            tr = loc % re + scale % re * r1
            ti = loc % im
        else
            tr = loc % re + scale % re * r1
            r1 = rvs_unif_0_rdp( )
            ti = loc % im + scale % im * r1
        end if
        res = cmplx(tr, ti, kind=dp)
    end function rvs_unif_cdp

    function rvs_unif_array_iint32(loc, scale, array_size) result(res)

        integer, intent(in) :: array_size
        integer(int32), intent(in) :: loc, scale
        integer(int32) :: res(array_size)
        integer(int32) :: u, mask, nn
        integer :: i, zeros, bits_left, bits

        if(scale == 0_int32) call error_stop("Error(rvs_unif_array): "        &
            //"Uniform distribution scale parameter must be non-zero")
        zeros = leadz(scale)
        bits = bit_size(scale) - zeros
        mask = shiftr(not(0_int32), zeros)
        do i = 1, array_size
            L1 : do
                u = dist_rand(scale)
                nn = iand(u, mask)
                if(nn <= scale) exit L1
                bits_left = zeros
                L2 : do
                    if(bits_left < bits) exit L2
                    u = shiftr(u, bits)
                    nn = iand(u, mask)
                    if(nn <= scale) exit L1
                    bits_left = bits_left - bits
                end do L2
            end do L1
            res(i) = loc + nn
        end do
    end function rvs_unif_array_iint32

    function rvs_unif_array_rdp(loc, scale, array_size) result(res)

        integer, intent(in) :: array_size
        real(dp), intent(in) :: loc, scale
        real(dp) :: res(array_size)
        real(dp) :: t
        integer(int64) :: tmp
        integer :: i

        if(scale == 0._dp) call error_stop("Error(rvs_unif_array):"        &
           //" Uniform distribution scale parameter must be non-zero")
        do i = 1, array_size
            tmp = shiftr(dist_rand(INT_ONE), 11)
            t = real(tmp * MESENNE_NUMBER, kind = dp)
            res(i) = loc + scale * t
        end do
    end function rvs_unif_array_rdp

    function rvs_unif_array_cdp(loc, scale, array_size) result(res)

        integer, intent(in) :: array_size
        complex(dp), intent(in) :: loc, scale
        complex(dp) :: res(array_size)
        real(dp) :: r1, tr, ti
        integer(int64) :: tmp
        integer :: i

        if(scale == (0.0_dp, 0.0_dp)) call error_stop("Error(rvs_unif" &
           //"_array): Uniform distribution scale parameter must be non-zero")
        do i = 1, array_size
            tmp = shiftr(dist_rand(INT_ONE), 11)
            r1 = real(tmp * MESENNE_NUMBER, kind = dp)
            if(scale % re == 0.0_dp) then
                tr = loc % re
                ti = loc % im + scale % im * r1
            else if(scale % im == 0.0_dp) then
                tr = loc % re + scale % re * r1
                ti = loc % im
            else
                tr = loc % re + scale % re * r1
                tmp = shiftr(dist_rand(INT_ONE), 11)
                r1 = real(tmp * MESENNE_NUMBER, kind = dp)
                ti = loc % im + scale % im * r1
            end if
            res(i) = cmplx(tr, ti, kind=dp)
        end do
    end function rvs_unif_array_cdp

    elemental function pdf_unif_iint32(x, loc, scale) result(res)

        integer(int32), intent(in) :: x, loc, scale
        real :: res

        if(scale == 0_int32) then
            res = 0.0
        else if(x < loc .or. x > (loc + scale)) then
            res = 0.0
        else
            res = 1. / (scale + 1_int32)
        end if
    end function pdf_unif_iint32

    elemental function pdf_unif_rdp(x, loc, scale) result(res)

        real(dp), intent(in) :: x, loc, scale
        real :: res

        if(scale == 0.0_dp) then
            res = 0.0
        else if(x < loc .or. x > (loc + scale)) then
            res = 0.0
        else
            res = 1.0 / scale
        end if
    end function pdf_unif_rdp

    elemental function pdf_unif_cdp(x, loc, scale) result(res)

        complex(dp), intent(in) :: x, loc, scale
        real :: res
        real(dp) :: tr, ti

        tr = loc % re + scale % re; ti = loc % im + scale % im
        if(scale == (0.0_dp,0.0_dp)) then
            res = 0.0
        else if((x % re >= loc % re .and. x % re <= tr) .and.                  &
            (x % im >= loc % im .and. x % im <= ti)) then
            res = 1.0 / (scale % re * scale % im)
        else
            res = 0.0
        end if
    end function pdf_unif_cdp

    elemental function cdf_unif_iint32(x, loc, scale) result(res)

        integer(int32), intent(in) :: x, loc, scale
        real :: res

        if(scale == 0_int32) then
            res = 0.0
        else if(x < loc) then
            res = 0.0
        else if(x >= loc .and. x <= (loc + scale)) then
            res = real((x - loc + 1_int32)) / real((scale + 1_int32))
        else
            res = 1.0
        end if
    end function cdf_unif_iint32

    elemental function cdf_unif_rdp(x, loc, scale) result(res)

        real(dp), intent(in) :: x, loc, scale
        real :: res

        if(scale == 0.0_dp) then
            res = 0.0
        else if(x < loc) then
            res = 0.0
        else if(x >= loc .and. x <= (loc + scale)) then
            res = (x - loc) / scale
        else
            res = 1.0
        end if
    end function cdf_unif_rdp

    elemental function cdf_unif_cdp(x, loc, scale) result(res)

        complex(dp), intent(in) :: x, loc, scale
        real :: res
        logical :: r1, r2, i1, i2

        if(scale == (0.0_dp,0.0_dp)) then
            res = 0.0
            return
        end if
        r1 = x % re < loc % re
        r2 = x % re > (loc % re + scale % re)
        i1 = x % im < loc % im
        i2 = x % im > (loc % im + scale % im)
        if(r1 .or. i1) then
            res = 0.0
        else if((.not. r1) .and. (.not. r2) .and. i2) then
            res = (x % re - loc % re) / scale % re
        else if((.not. i1) .and. (.not. i2) .and. r2) then
            res = (x % im - loc % im) / scale % im
        else if((.not. r1) .and. (.not. r2) .and. (.not. i1) .and. (.not. i2)) &
            then
            res = (x % re - loc % re) * (x % im - loc % im) /                  &
                   (scale % re * scale % im)
        else if(r2 .and. i2)then
             res = 1.0
        end if
    end function cdf_unif_cdp

    function shuffle_iint32( list ) result(res)

        integer(int32), intent(in) :: list(:)
        integer(int32) :: res(size(list))
        integer(int32) :: tmp
        integer :: n, i, j

        n = size(list)
        res = list
        do i = 1, n - 1
            j = rvs_uniform(n - i) + i
            tmp = res(i)
            res(i) = res(j)
            res(j) = tmp
        end do
    end function shuffle_iint32

    function shuffle_rdp( list ) result(res)

        real(dp), intent(in) :: list(:)
        real(dp) :: res(size(list))
        real(dp) :: tmp
        integer :: n, i, j

        n = size(list)
        res = list
        do i = 1, n - 1
            j = rvs_uniform(n - i) + i
            tmp = res(i)
            res(i) = res(j)
            res(j) = tmp
        end do
    end function shuffle_rdp

    function shuffle_cdp( list ) result(res)

        complex(dp), intent(in) :: list(:)
        complex(dp) :: res(size(list))
        complex(dp) :: tmp
        integer :: n, i, j

        n = size(list)
        res = list
        do i = 1, n - 1
            j = rvs_uniform(n - i) + i
            tmp = res(i)
            res(i) = res(j)
            res(j) = tmp
        end do
    end function shuffle_cdp

end module stdlib_stats_distribution_uniform


! { dg-do run }
! { dg-options "-O" }
! PR 48412 - function elimination got temporary varibles in the wrong order.
! Test case contributed by Joost VandeVondele.

INTEGER FUNCTION S1(m,ma,lx)
INTEGER :: m,ma,lx

IF (((m < 0).AND.(MODULO(ABS(ma-lx),2) == 1)).OR.&
    ((m > 0).AND.(MODULO(ABS(ma-lx),2) == 0))) THEN
   S1=1
ELSE
   S1=0
ENDIF

END FUNCTION

INTEGER :: s1
IF (S1(1,2,1).NE.0) STOP 1
END


! { dg-do compile }
! { dg-options "-Warray-temporaries -O" }
module foo
  implicit none
contains
  pure function bar(i,j)
    integer, intent(in) :: i,j
    integer, dimension(2,2) :: bar
    bar = 33
  end function bar
end module foo

program main
  use foo
  implicit none
  integer a(2,2), b(2,2),c(2,2), d(2,2), e(2)

  read (*,*) b, c, d
  a = matmul(b,c) + d
  a = b + bar(3,4)
  a = bar(3,4)*5 + b
  e = sum(b,1) + 3
end program main
! { dg-final { cleanup-modules "foo" } }


      subroutine dc(n, rhs, sol, ipar, fpar, w)
      implicit none
      integer n, ipar(16)
      real*8 rhs(n), sol(n), fpar(16), w(*)
c-----------------------------------------------------------------------
c     This a version of Defect Correction Method (DC) implemented
c     with reverse communication.
c
c     the space of the `w' is used as follows:
c     (1) input
c     (2) output
c
c     TOTAL SIZE REQUIRED == 2*n
c
c     Implemented by Allan P. Engsig-Karup, apek@imm.dtu.dk.
c
c     SPARSKIT2 routine for GMRES method was used as template for
c     this implementation.
c
c-----------------------------------------------------------------------
c     external functions used
c
      real*8 distdot
      external distdot
c
      real*8 one, zero
      parameter(one=1.0D0, zero=0.0D0)
c
c     local variables
c
      integer i,ii,k,m
      real*8 alpha, c, s
      logical lp, rp
      save
c
c     check the status of the call
c
      if (ipar(1).le.0) ipar(10) = 0
      goto (10, 20) ipar(10)
c
c     initialization
c
      i = 2*n
      call bisinit(ipar,fpar,i,1,lp,rp,w)
      if (ipar(1).lt.0) return
c
c     request for matrix vector multiplication A*x in the initialization
c
      ipar(1)  = 1
      ipar(8)  = n+1
      ipar(9)  = 1
      ipar(10) = 1
c
c     copy initial guess to workspace to be input vector
c
      do i = 1, n
         w(n+i) = sol(i)
      enddo
      return
c
c     compute residual r = b - Ax
c
 10   ipar(7) = ipar(7) + 1
c
c     put residual in workspace as input vector
c
      do i = 1, n
         w(n+i) = rhs(i) - w(i)
      enddo
      fpar(11) = fpar(11) + n
      ipar(1)  = 3
      ipar(10) = 2
      return
c
c     left preconditioning
c
 20   alpha = sqrt(distdot(n,w,1,w,1))
c      print *,alpha
      fpar(11) = fpar(11) + 2*n
      if (ipar(7).eq.1 .and. ipar(3).ne.999) then
c
c     compute initial error norm. Only, do this after first matvec.
c
         fpar(3) = alpha
c
c     compute target error norm (scaled by user-defined tolerance levels)
c
         fpar(4) = fpar(1) * alpha + fpar(2)
c      print *,'fpar(4)=',fpar(4)

      endif
c
c     compute CURRENT error norm
c
      fpar(5) = alpha
c      print *,'current error norm = ',alpha
c
c     check if we satisfy the stopping condition by comparing current
c     error norm with target error norm
c
      if (alpha.le.fpar(4) .and. ipar(3).ge.0 .and. ipar(3).ne.999) then
c
c        if full-filled, then terminate solver
c
c      print *,'we should stop because condition is satisfied'

         ipar(1) = 0
c
c        current error norm is stored
c
         fpar(6) = alpha
         goto 300
      endif
c
c     defect correction step
c
      do i = 1, n
         sol(i) = sol(i) + w(i)
      enddo
c
c     copy solution to workspace
c
      do i = 1, n
         w(n+i) = sol(i)
      enddo
      fpar(11) = fpar(11) + n
c
c     repeat defect correction procedure
c
      if (ipar(7)<ipar(6)) then
          ipar(1)  = 1
          ipar(10) = 1
      else
c
c         terminate because of user-defined limit to number of iterations
c
          ipar(1) = -1
      endif
      return
 300  if (fpar(3).ne.zero .and. fpar(6).ne.zero .and.
     +     ipar(7).gt.ipar(13)) then
c
c    estimate convergence rate
c
         fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13))
      else
         fpar(7) = zero
      endif
      return
      end
c-----end-of-dc


program main

!*****************************************************************************80
!
!! MAIN is the main program for MD_OPENMP.
!
!  Discussion:
!
!    MD_OPENMP implements a simple molecular dynamics simulation.
!
!    The program uses OpenMP directives to allow parallel computation.
!
!    The velocity Verlet time integration scheme is used.
!
!    The particles interact with a central pair potential.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 July 2009
!
!  Author:
!
!    Original FORTRAN90 version by Bill Magro.
!    This FORTRAN90 version by John Burkardt.
!
  use omp_lib

  implicit none

  integer ( kind = 4 ), parameter :: nd = 3
  integer ( kind = 4 ), parameter :: np = 1000

  real ( kind = 8 ) acc(nd,np)
  real ( kind = 8 ) box(nd)
  real ( kind = 8 ), parameter :: dt = 0.0001D+00
  real ( kind = 8 ) e0
  real ( kind = 8 ) force(nd,np)
  integer ( kind = 4 ) id
  real ( kind = 8 ) kinetic
  real ( kind = 8 ), parameter :: mass = 1.0D+00
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) potential
  integer ( kind = 4 ) proc_num
  integer ( kind = 4 ) seed
  integer ( kind = 4 ) step
  integer ( kind = 4 ), parameter :: step_num = 400
  integer ( kind = 4 ) step_print
  integer ( kind = 4 ) step_print_index
  integer ( kind = 4 ) step_print_num
  integer ( kind = 4 ) thread_num
  real ( kind = 8 ) vel(nd,np)
  real ( kind = 8 ) wtime

  call timestamp ( )

  proc_num = omp_get_num_procs ( )
  thread_num = omp_get_max_threads ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MD_OPENMP'
  write ( *, '(a)' ) '  FORTRAN90/OpenMP version'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  A molecular dynamics program.'
  write ( *, '(a)' ) ' '
  write ( *, '(a,i8)' ) &
    '  NP, the number of particles in the simulation is ', np
  write ( *, '(a,i8)' ) '  STEP_NUM, the number of time steps, is ', step_num
  write ( *, '(a,g14.6)' ) '  DT, the size of each time step, is ', dt
  write ( *, '(a)' ) ' '
  write ( *, '(a,i8)' ) '  The number of processors available is: ', proc_num
  write ( *, '(a,i8)' ) '  The number of threads available is:    ', thread_num
!
!  Set the dimensions of the box.
!
  box(1:nd) = 10.0D+00
!
!  Set initial positions, velocities, and accelerations.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Initializing positions, velocities, and accelerations.'

  seed = 123456789
  call initialize ( np, nd, box, seed, pos, vel, acc )
!
!  Compute the forces and energies.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Computing initial forces and energies.'

  call compute ( np, nd, pos, vel, mass, force, potential, kinetic )
!
!  Save the initial total energy for use in the accuracy check.
!
  e0 = potential + kinetic
!
!  This is the main time stepping loop:
!    Compute forces and energies,
!    Update positions, velocities, accelerations.
!
  step_print = 0
  step_print_index = 0
  step_print_num = 10

  step = 0
  write ( *, '(2x,i8,2x,g14.6,2x,g14.6,2x,g14.6)' ) &
    step, potential, kinetic, ( potential + kinetic - e0 ) / e0
  step_print_index = step_print_index + 1
  step_print = ( step_print_index * step_num ) / step_print_num

  wtime = omp_get_wtime ( )

  do step = 1, step_num

    call compute ( np, nd, pos, vel, mass, force, potential, kinetic )

    if ( step == step_print ) then

      write ( *, '(2x,i8,2x,g14.6,2x,g14.6,2x,g14.6)' ) &
        step, potential, kinetic, ( potential + kinetic - e0 ) / e0

      step_print_index = step_print_index + 1
      step_print = ( step_print_index * step_num ) / step_print_num

    end if

    call update ( np, nd, pos, vel, force, acc, mass, dt )

  end do

  wtime = omp_get_wtime ( ) - wtime
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Elapsed time for main computation:'
  write ( *, '(2x,g14.6,a)' ) wtime, ' seconds'
!
!  Terminate.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MD_OPENMP'
  write ( *, '(a)' ) '  Normal end of execution.'

  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end
subroutine compute ( np, nd, pos, vel, mass, f, pot, kin )

!*****************************************************************************80
!
!! COMPUTE computes the forces and energies.
!
!  Discussion:
!
!    The computation of forces and energies is fully parallel.
!
!    The potential function V(X) is a harmonic well which smoothly
!    saturates to a maximum value at PI/2:
!
!      v(x) = ( sin ( min ( x, PI2 ) ) )^2
!
!    The derivative of the potential is:
!
!      dv(x) = 2.0D+00 * sin ( min ( x, PI2 ) ) * cos ( min ( x, PI2 ) )
!            = sin ( 2.0 * min ( x, PI2 ) )
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    15 July 2008
!
!  Author:
!
!    Original FORTRAN90 version by Bill Magro.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input, real ( kind = 8 ) POS(ND,NP), the position of each particle.
!
!    Input, real ( kind = 8 ) VEL(ND,NP), the velocity of each particle.
!
!    Input, real ( kind = 8 ) MASS, the mass of each particle.
!
!    Output, real ( kind = 8 ) F(ND,NP), the forces.
!
!    Output, real ( kind = 8 ) POT, the total potential energy.
!
!    Output, real ( kind = 8 ) KIN, the total kinetic energy.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) d
  real ( kind = 8 ) d2
  real ( kind = 8 ) f(nd,np)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) kin
  real ( kind = 8 ) mass
  real ( kind = 8 ), parameter :: PI2 = 3.141592653589793D+00 / 2.0D+00
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) pot
  real ( kind = 8 ) rij(nd)
  real ( kind = 8 ) vel(nd,np)

  pot = 0.0D+00
  kin = 0.0D+00

!$omp parallel &
!$omp shared ( f, nd, np, pos, vel ) &
!$omp private ( d, d2, i, j, rij )

!$omp do reduction ( + : pot, kin )

  do i = 1, np
!
!  Compute the potential energy and forces.
!
    f(1:nd,i) = 0.0D+00

    do j = 1, np

      if ( i /= j ) then

        call dist ( nd, pos(1,i), pos(1,j), rij, d )
!
!  Attribute half of the potential energy to particle J.
!
        d2 = min ( d, PI2 )

        pot = pot + 0.5D+00 * ( sin ( d2 ) )**2

        f(1:nd,i) = f(1:nd,i) - rij(1:nd) * sin ( 2.0D+00 * d2 ) / d

      end if

    end do
!
!  Compute the kinetic energy.
!
    kin = kin + sum ( vel(1:nd,i)**2 )

  end do
!$omp end do

!$omp end parallel

  kin = kin * 0.5D+00 * mass

  return
end
subroutine dist ( nd, r1, r2, dr, d )

!*****************************************************************************80
!
!! DIST computes the displacement and distance between two particles.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    17 March 2002
!
!  Author:
!
!    Original FORTRAN90 version by Bill Magro.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input, real ( kind = 8 ) R1(ND), R2(ND), the positions of the particles.
!
!    Output, real ( kind = 8 ) DR(ND), the displacement vector.
!
!    Output, real ( kind = 8 ) D, the Euclidean norm of the displacement,
!    in other words, the distance between the two particles.
!
  implicit none

  integer ( kind = 4 ) nd

  real ( kind = 8 ) d
  real ( kind = 8 ) dr(nd)
  real ( kind = 8 ) r1(nd)
  real ( kind = 8 ) r2(nd)

  dr(1:nd) = r1(1:nd) - r2(1:nd)

  d = sqrt ( sum ( dr(1:nd)**2 ) )

  return
end
subroutine initialize ( np, nd, box, seed, pos, vel, acc )

!*****************************************************************************80
!
!! INITIALIZE initializes the positions, velocities, and accelerations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 November 2007
!
!  Author:
!
!    Original FORTRAN90 version by Bill Magro.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input, real ( kind = 8 ) BOX(ND), specifies the maximum position
!    of particles in each dimension.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) POS(ND,NP), the position of each particle.
!
!    Output, real ( kind = 8 ) VEL(ND,NP), the velocity of each particle.
!
!    Output, real ( kind = 8 ) ACC(ND,NP), the acceleration of each particle.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) acc(nd,np)
  real ( kind = 8 ) box(nd)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) seed
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) r8_uniform_01
  real ( kind = 8 ) vel(nd,np)
!
!  Start by setting the positions to random numbers between 0 and 1.
!
  call random_number ( harvest = pos(1:nd,1:np) )
!
!  Use these random values as scale factors to pick random locations
!  inside the box.
!
!$omp parallel &
!$omp shared ( box, nd, np, pos ) &
!$omp private ( j )

!$omp do

  do j = 1, np
    pos(1:nd,j) = box(1:nd) * pos(1:nd,j)
  end do

!$omp end do
!$omp end parallel
!
!  Velocities and accelerations begin at 0.
!
!$omp parallel &
!$omp shared ( acc, nd, np, vel )

!$omp workshare

  vel(1:nd,1:np) = 0.0D+00
  acc(1:nd,1:np) = 0.0D+00

!$omp end workshare

!$omp end parallel

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end
subroutine update ( np, nd, pos, vel, f, acc, mass, dt )

!*****************************************************************************80
!
!! UPDATE updates positions, velocities and accelerations.
!
!  Discussion:
!
!    The time integration is fully parallel.
!
!    A velocity Verlet algorithm is used for the updating.
!
!    x(t+dt) = x(t) + v(t) * dt + 0.5 * a(t) * dt * dt
!    v(t+dt) = v(t) + 0.5 * ( a(t) + a(t+dt) ) * dt
!    a(t+dt) = f(t) / m
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 November 2007
!
!  Author:
!
!    Original FORTRAN90 version by Bill Magro.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input/output, real ( kind = 8 ) POS(ND,NP), the position of each particle.
!
!    Input/output, real ( kind = 8 ) VEL(ND,NP), the velocity of each particle.
!
!    Input, real ( kind = 8 ) F(ND,NP), the force on each particle.
!
!    Input/output, real ( kind = 8 ) ACC(ND,NP), the acceleration of each
!    particle.
!
!    Input, real ( kind = 8 ) MASS, the mass of each particle.
!
!    Input, real ( kind = 8 ) DT, the time step.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) acc(nd,np)
  real ( kind = 8 ) dt
  real ( kind = 8 ) f(nd,np)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) mass
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) rmass
  real ( kind = 8 ) vel(nd,np)

  rmass = 1.0D+00 / mass

!$omp parallel &
!$omp shared ( acc, dt, f, nd, np, pos, rmass, vel ) &
!$omp private ( i, j )

!$omp do
  do j = 1, np
    do i = 1, nd
      pos(i,j) = pos(i,j) + vel(i,j) * dt + 0.5D+00 * acc(i,j) * dt * dt
      vel(i,j) = vel(i,j) + 0.5D+00 * dt * ( f(i,j) * rmass + acc(i,j) )
      acc(i,j) = f(i,j) * rmass
    end do
  end do
!$omp end do

!$omp end parallel

  return
end


!==============================================================================!
  subroutine Prec_Solve(ni, a, d, x, b, prec)
!------------------------------------------------------------------------------!
!   Solves the preconditioning system [d]{x}={b}                               !
!------------------------------------------------------------------------------!
!   Allows preconditioning of the system by:                                   !
!     1. Diagonal preconditioning                                              !
!     2. Incomplete Cholesky preconditioning                                   !
!                                                                              !
!   The type of precondtioning is chosen by setting the variable prec to 0     !
!   (for no preconditioning), 1 (for diagonal preconditioning) or 2 (for       !
!   incomplete Cholesky preconditioning)                                       !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer           :: ni
  type(Matrix_Type) :: a
  type(Matrix_Type) :: d
  real              :: x(:)
  real              :: b(:)
  character(len=80) :: prec  ! preconditioner
!-----------------------------------[Locals]-----------------------------------!
  integer :: i, j, k
  real    :: sum1
!==============================================================================!

  !---------------------------------!
  !   1) diagonal preconditioning   !
  !---------------------------------!
  if(prec .eq. 'DIAGONAL') then
    do i = 1, ni
      x(i) = b(i)/d % val(d % dia(i))
    end do

  !--------------------------------------------!
  !   2) incomplete cholesky preconditioning   !
  !--------------------------------------------!
  else if(prec .eq. 'INCOMPLETE_CHOLESKY') then

    ! Forward substitutionn
    do i = 1, ni
      sum1 = b(i)
      do j = a % row(i),a % dia(i)-1     ! only the lower triangular
        k = a % col(j)
        sum1 = sum1 - a % val(j)*x(k)
      end do
      x(i) = sum1 * d % val(d % dia(i))  ! BUG ?
    end do

    do i = 1, ni
      x(i) = x(i) / ( d % val(d % dia(i)) + TINY )
    end do

    ! Backward substitution
    do i = ni, 1, -1
      sum1 = x(i)
      do j = a % dia(i)+1, a % row(i+1)-1        ! upper triangular
        k = a % col(j)
        if(k <= ni) sum1 = sum1 - a % val(j)*x(k)  ! avoid buffer entries
      end do
      x(i) = sum1* d % val(d % dia(i))           ! BUG ?
    end do

  !---------------------------!
  !   .) no preconditioning   !
  !---------------------------!
  else
    do i = 1, ni
      x(i) = b(i)
    end do
  end if

  end subroutine


PROGRAM Cylinder_test
    USE Precision,      ONLY : i4k, r8k
    USE vtk_datasets,   ONLY : struct_grid
    USE vtk_attributes, ONLY : scalar, attributes
    USE vtk,            ONLY : vtk_legacy_write
    IMPLICIT NONE
    !! author: Ian Porter
    !! date: 12/20/2017
    !!
    !! This is a test of a cylindrical geometry using a rectilinear grid
    !!
    INTEGER(i4k), PARAMETER     :: n_params_to_write = 1
    TYPE (struct_grid)          :: cylinder
    TYPE (attributes), DIMENSION(n_params_to_write) :: vals_to_write
    INTEGER(i4k)                :: i, j, k, cnt = 1
    INTEGER(i4k),     PARAMETER :: n_x = 19, n_y = 1, n_z = 4, unit = 20
    CHARACTER(LEN=*), PARAMETER :: filename = 'cylinder.vtk'
    CHARACTER(LEN=*), PARAMETER :: title    = 'Testing of cylindrical geometry'
    INTEGER(i4k), DIMENSION(3)  :: dims
    REAL(r8k), DIMENSION(n_x), PARAMETER :: x_vals = &
      & [ 0.00E+00_r8k, 8.03E-04_r8k, 1.51E-03_r8k, 2.12E-03_r8k, 2.64E-03_r8k, &
      &   3.08E-03_r8k, 3.45E-03_r8k, 3.75E-03_r8k, 3.99E-03_r8k, 4.18E-03_r8k, &
      &   4.32E-03_r8k, 4.42E-03_r8k, 4.49E-03_r8k, 4.53E-03_r8k, 4.56E-03_r8k, &
      &   4.56E-03_r8k, 4.56E-03_r8k, 4.65E-03_r8k, 5.38E-03_r8k ]
    REAL(r8k), DIMENSION(n_y), PARAMETER :: y_vals = &
      & [ 0.00E+00_r8k ]
    REAL(r8k), DIMENSION(n_z), PARAMETER :: z_vals = &
      & [ 2.50E-03_r8k, 5.00E-03_r8k, 7.50E-03_r8k, 1.00E-03_r8k ]
    REAL(r8k), DIMENSION(n_x*n_y*n_z), PARAMETER :: temp = &
      & [ 1.27E+03_r8k, 1.25E+03_r8k, 1.21E+03_r8k, 1.15E+03_r8k, 1.08E+03_r8k, &
      &   1.02E+03_r8k, 9.63E+02_r8k, 9.11E+02_r8k, 8.67E+02_r8k, 8.32E+02_r8k, &
      &   8.04E+02_r8k, 7.84E+02_r8k, 7.70E+02_r8k, 7.61E+02_r8k, 7.56E+02_r8k, &
      &   7.55E+02_r8k, 7.54E+02_r8k, 5.68E+02_r8k, 5.28E+02_r8k, 1.40E+03_r8k, &
      &   1.37E+03_r8k, 1.31E+03_r8k, 1.23E+03_r8k, 1.14E+03_r8k, 1.06E+03_r8k, &
      &   9.83E+02_r8k, 9.20E+02_r8k, 8.68E+02_r8k, 8.27E+02_r8k, 7.96E+02_r8k, &
      &   7.74E+02_r8k, 7.60E+02_r8k, 7.51E+02_r8k, 7.46E+02_r8k, 7.44E+02_r8k, &
      &   7.44E+02_r8k, 5.68E+02_r8k, 5.28E+02_r8k, 1.39E+03_r8k, 1.36E+03_r8k, &
      &   1.30E+03_r8k, 1.22E+03_r8k, 1.14E+03_r8k, 1.06E+03_r8k, 9.82E+02_r8k, &
      &   9.20E+02_r8k, 8.69E+02_r8k, 8.28E+02_r8k, 7.97E+02_r8k, 7.75E+02_r8k, &
      &   7.60E+02_r8k, 7.51E+02_r8k, 7.47E+02_r8k, 7.45E+02_r8k, 7.45E+02_r8k, &
      &   5.68E+02_r8k, 5.28E+02_r8k, 1.39E+03_r8k, 1.36E+03_r8k, 1.30E+03_r8k, &
      &   1.22E+03_r8k, 1.14E+03_r8k, 1.06E+03_r8k, 9.83E+02_r8k, 9.20E+02_r8k, &
      &   8.69E+02_r8k, 8.28E+02_r8k, 7.97E+02_r8k, 7.75E+02_r8k, 7.60E+02_r8k, &
      &   7.52E+02_r8k, 7.47E+02_r8k, 7.45E+02_r8k, 7.45E+02_r8k, 5.68E+02_r8k, &
      &   5.28E+02_r8k ]
    REAL(r8k), DIMENSION(1:3,n_x*n_y*n_z)    :: points
    REAL(r8k), DIMENSION(n_x*n_y*n_z,1:n_params_to_write) :: vals
    CHARACTER(LEN=20), DIMENSION(n_params_to_write), PARAMETER :: dataname = &
      & [ 'Temperature_(K)     ' ]

    cnt = 1
    DO k = 1, n_z
        DO j = 1, n_y
            DO i = 1, n_x
                points(1,cnt) = x_vals(i)
                points(2,cnt) = y_vals(j)
                points(3,cnt) = z_vals(k)
                cnt = cnt + 1
            END DO
        END DO
    END DO

    vals(:,1) = temp(:)
    dims = [ n_x, n_y, n_z ]

    CALL cylinder%init (dims=dims, points=points)

    DO i = 1, n_params_to_write
        IF (.NOT. ALLOCATED(vals_to_write(i)%attribute))THEN
            ALLOCATE(scalar::vals_to_write(i)%attribute)
        END IF
        CALL vals_to_write(i)%attribute%init (dataname(i), numcomp=1, real1d=vals(:,i))
    END DO

    CALL vtk_legacy_write (cylinder, unit=unit, pointdatasets=vals_to_write)

    WRITE(*,*) 'Finished'

END PROGRAM Cylinder_test


      SUBROUTINE GLOBAL_TO_LOCAL (N, LDU, CRD, U_G, U_L)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      INTEGER(KIND=IK) N
      INTEGER(KIND=IK) LDU
      REAL   (KIND=RK) CRD (2, 2, *)
      REAL   (KIND=RK) U_G (LDU, *)
      REAL   (KIND=RK) U_L (LDU, *)
C
      INTEGER(KIND=IK) I
C
      DO I = 1, N
        CALL G2L (CRD (1, 1, I), U_G (1, I), U_L (1, I))
      END DO
C
      END

      SUBROUTINE G2L (CRD, U_G, U_L)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE "knd_params.inc"
C
      REAL(KIND=RK) CRD (2, 2)
      REAL(KIND=RK) U_G (2)
      REAL(KIND=RK) U_L (2)
C
      REAL(KIND=RK) J_I
C
      J_I = 1.0D0 / SQRT (CRD (1, 2) ** 2 + CRD (2, 2) ** 2)
      U_L (1) = J_I * (CRD (1, 2) * U_G (1) + CRD (2, 2) * U_G (2))
      U_L (2) = J_I * (CRD (1, 2) * U_G (2) - CRD (2, 2) * U_G (1))
C
      END SUBROUTINE

      SUBROUTINE LOCAL_TO_GLOBAL (N, LDU, CRD, U_L, U_G)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      INTEGER(KIND=IK) N
      INTEGER(KIND=IK) LDU
      REAL   (KIND=RK) CRD (2, 2, *)
      REAL   (KIND=RK) U_L (LDU, *)
      REAL   (KIND=RK) U_G (LDU, *)
C
      INTEGER(KIND=IK) I
C
      DO I = 1, N
        CALL L2G (CRD (1, 1, I), U_L (1, I), U_G (1, I))
      END DO
C
      END

      SUBROUTINE L2G (CRD, U_L, U_G)
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE "knd_params.inc"
C
      REAL(KIND=RK) CRD (2, 2)
      REAL(KIND=RK) U_L (2)
      REAL(KIND=RK) U_G (2)
C
      REAL(KIND=RK) J_I
C
      J_I = 1.0D0 / SQRT (CRD (1, 2) ** 2 + CRD (2, 2) ** 2)
      U_G (1) = J_I * (CRD (1, 2) * U_L (1) - CRD (2, 2) * U_L (2))
      U_G (2) = J_I * (CRD (1, 2) * U_L (2) + CRD (2, 2) * U_L (1))
C
      END SUBROUTINE


      program w17

C     Check refined transformer for while loop with anded condition

      integer i

      i = 0

      if(.TRUE.) then
         do while(i.gt.-5.and.i.lt.5)
            if(y.gt.0.) then
               i = i + 1
            else
               i = i - 1
            endif
         enddo
      endif

      print *, i

      end


! chk_complex.f90 --
!     Check: does the compiler support the %RE and %IM syntax for complex numbers?
!
program chk_complex
    implicit none

    complex :: z

    z%re = 1.0
    z%im = 1.0

    write( *, '(a,2f7.4)'      ) 'Complex number 1+i:  ', z
    write( *, '(a,f7.4,a,f.4)' ) 'Real component:      ', z%re, ' -- ', real(z)
    write( *, '(a,f7.4,a,f.4)' ) 'Imaginary component: ', z%im, ' -- ', imag(z)
end program chk_complex


*----------------------------------------------------------------------*
      logical function next_comb(comb,items,imax,nreg)
*----------------------------------------------------------------------*
*     produces next possible combination with ascending order
*     nreg=1 : only one register (simple combination)
*     matthias, 2008
*----------------------------------------------------------------------*
      implicit none

      integer, intent(in) ::
     &     imax(nreg), items, nreg

      integer, intent(inout) ::
     &     comb(items)

      integer ::
     &     digit, ii, counter(items), jj, temp(items+1), old, ireg, tot

      logical ::
     &     add, correct, skip

      next_comb = .false.
      correct = .true.

      ! return false for zero dimension
      if (items.eq.0.or.maxval(imax).eq.0) then
        return
      end if

      ! if combination is zero vector, find initial combination
      if (all(comb.eq.0)) then
        correct = .false. ! correct but don't need further treatment
        do ireg = 1,nreg
          if (imax(ireg).ge.items) then
            do ii = 1,items
              comb(ii) = maxval(imax)*(ireg-1)+ii
            end do
            next_comb = .true.
            exit
          end if
        end do
      end if

      ! each item should be larger than the previous
      do ii = 1,items-1
        if (comb(ii).ge.comb(ii+1)) correct = .false.
      end do
      ! all items should be of the same register. determine register
      do ii = 1,items
        if (ii.eq.1) then
          ireg = (comb(ii)-1)/maxval(imax)+1
        else if (ireg.ne.(comb(ii)-1)/maxval(imax)+1) then
          correct = .false.
        end if
      end do

      if (correct) then
        ! check out next possible combination in current register
        temp(1:items) = comb(1:items)
        temp(items+1) = (ireg-1)*maxval(imax)+imax(ireg)+1
        digit = items
        skip = .false.
        do ii = items,1,-1
          if ((temp(ii)+1.eq.temp(ii+1)).and.(.not.skip)) then
            digit = digit -1
          else
            skip = .true.
          end if
        end do
        if (skip) then
          ! set next combination
          temp(digit) = temp(digit) + 1
          do ii = digit+1,items
            temp(ii) = temp(ii-1) + 1
          end do
          next_comb = .true.
          comb(1:items) = temp(1:items)
        else
          ! scan size of following registers and take next possible one
          do while (.not.next_comb.and.ireg.lt.nreg)
            ireg = ireg + 1
            if (imax(ireg).ge.items) then
              do ii = 1,items
                comb(ii) = (ireg-1)*maxval(imax) + ii
              end do
              next_comb = .true.
            end if
          end do
        end if
      end if

      return
      end


program ch0806
    ! Rank 1 Array Initialisation Using an Implied
    ! Do Loop
    implicit none

    integer, parameter :: n = 10
    real, parameter :: us = 3.7854118
    real, parameter :: uk = 4.545
    integer :: i
    integer, dimension(1:n) :: litre = &
        [ (i, i = 1, n) ]
    real, dimension(1:n) :: gallon, usgallon

    gallon = litre/uk
    usgallon = litre/us
    print *, ' Litres Imperial USA'
    print *, ' Gallon Gallon'
    do i = 1, n
        print *, litre(i), ' ', gallon(i), ' ', &
            usgallon(i)
    end do
end program


! { dg-do run }
! Test maxloc for strings for different code paths

program main
  implicit none
  integer, parameter :: n=4
  character(len=4), dimension(n,n) :: c
  integer, dimension(n,n) :: a
  integer, dimension(2) :: res1, res2
  real, dimension(n,n) :: r
  logical, dimension(n,n) :: amask
  logical(kind=8) :: smask
  integer :: i,j
  integer, dimension(n) :: q1, q2
  character(len=4,kind=4), dimension(n,n) :: c4
  character(len=4), dimension(n*n) :: e
  integer, dimension(n*n) :: f
  logical, dimension(n*n) :: cmask

  call random_number (r)
  a = int(r*100)
  do j=1,n
     do i=1,n
        write (unit=c(i,j),fmt='(I4.4)') a(i,j)
        write (unit=c4(i,j),fmt='(I4.4)') a(i,j)
     end do
  end do
  res1 = maxloc(c)
  res2 = maxloc(a)

  if (any(res1 /= res2)) STOP 1
  res1 = maxloc(c4)
  if (any(res1 /= res2)) STOP 2

  amask = a < 50
  res1 = maxloc(c,mask=amask)
  res2 = maxloc(a,mask=amask)

 if (any(res1 /= res2)) STOP 3

 amask = .false.
 res1 = maxloc(c,mask=amask)
 if (any(res1 /= 0)) STOP 4

 amask(2,3) = .true.
 res1 = maxloc(c,mask=amask)
 if (any(res1 /= [2,3])) STOP 5

 res1 = maxloc(c,mask=.false.)
 if (any(res1 /= 0)) STOP 6

 res2 = maxloc(a)
 res1 = maxloc(c,mask=.true.)
 if (any(res1 /= res2)) STOP 7

 q1 = maxloc(c, dim=1)
 q2 = maxloc(a, dim=1)
 if (any(q1 /= q2)) STOP 8

 q1 = maxloc(c, dim=2)
 q2 = maxloc(a, dim=2)
 if (any(q1 /= q2)) STOP 9

 q1 = maxloc(c, dim=1, mask=amask)
 q2 = maxloc(a, dim=1, mask=amask)
 if (any(q1 /= q2)) STOP 10

 q1 = maxloc(c, dim=2, mask=amask)
 q2 = maxloc(a, dim=2, mask=amask)
 if (any(q1 /= q2)) STOP 11

  amask = a < 50

 q1 = maxloc(c, dim=1, mask=amask)
 q2 = maxloc(a, dim=1, mask=amask)
 if (any(q1 /= q2)) STOP 12

 q1 = maxloc(c, dim=2, mask=amask)
 q2 = maxloc(a, dim=2, mask=amask)
 if (any(q1 /= q2)) STOP 13

 e = reshape(c, shape(e))
 f = reshape(a, shape(f))
 if (maxloc(e,dim=1) /= maxloc(f,dim=1)) STOP 14

 cmask = .false.
 if (maxloc(e,dim=1,mask=cmask) /= 0) STOP 15

 cmask = f > 50
 if ( maxloc(e, dim=1, mask=cmask) /= maxloc (f, dim=1, mask=cmask)) STOP 16
end program main