!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: beta = 0.95d0
    real*8, parameter :: a0 = 100d0

    ! numerical parameters
    real*8, parameter :: sig = 1d-6
    integer, parameter :: itermax = 2000

    ! time path of consumption and resource
    integer, parameter :: TT = 200
    real*8 :: c_t(0:TT), a_t(0:TT)

    ! policy function
    integer, parameter :: NA = 1000
    real*8 :: a(0:NA), c(0:NA)

    ! variables to numerically determine policy function
    real*8 :: c_new(0:NA), coeff_c(NA+3)
    real*8 :: con_lev, x_in
    logical :: check

    ! variables to communicate with function
    integer :: ia_com

contains

    ! the first order condition
    function foc(x_in)

        use toolbox

        implicit none
        real*8, intent(in) :: x_in
        real*8 :: foc, cplus

        ! calculate right hand side of foc
        cplus = spline_eval(x_in, coeff_c, 0d0, a0)

        ! get foc
        foc = a(ia_com) - x_in - beta**(-gamma)*cplus

    end function

end module


PROGRAM main

  USE mpi
  implicit none

  integer ierr
  integer n, i, master, myrank, nprocs
  real (kind=8) h, s, x, cpi

  call MPI_INIT(ierr)
  call MPI_COMM_GET_PARENT(master, ierr)
  call MPI_COMM_SIZE(master, nprocs, ierr)
  call MPI_COMM_RANK(master, myrank, ierr)

  call MPI_BCAST(n, 1, MPI_INTEGER, &
                 0, master, ierr)

  h = 1 / DFLOAT(n)
  s = 0.0
  DO i=myrank+1,n,nprocs
     x = h * (DFLOAT(i) - 0.5)
     s = s +  4.0 / (1.0 + x*x)
  END DO
  cpi = s * h

  call MPI_REDUCE(cpi, MPI_BOTTOM, 1, MPI_DOUBLE_PRECISION, &
                  MPI_SUM, 0, master, ierr)

  call MPI_COMM_DISCONNECT(master, ierr)
  call MPI_FINALIZE(ierr)

END PROGRAM main


!>
module hydrogen

  implicit none

contains

  ! hydrogen_wf
  !
  ! Hydrogen wavefunctions and energies for given l, alpha, n_b, n_r, r_grid
  subroutine hydrogen_wf (l, alpha, n_b, n_r, r_grid, wf, energies, status)
    integer , intent(in) :: l
    double precision , intent(in) :: alpha
    integer , intent(in) :: n_b
    integer , intent(in) :: n_r
    double precision , intent(in) :: r_grid(n_r)
    double precision , intent(out) :: wf(n_r, n_b)
    double precision , intent(out) :: energies(n_b)
    integer , intent(out) :: status
    double precision :: basis(n_r, n_b)
    double precision :: B(n_b, n_b), K(n_b, n_b), V(n_b, n_b), H(n_b, n_b)
    double precision :: eigenvectors(n_b, n_b)
    integer :: ii, jj, kk

    ! check if arguments are valid
    status = 0

    if ((l < 0) .or. (n_b < 1) .or. (alpha < 0.0d0) .or. (n_r < 1)) then
      status = 1
      return
    end if

    ! setup basis
    call radial_basis(l, alpha, n_b, n_r, r_grid, basis, status)
    if (status /= 0) return

    ! setup matrices
    call overlap_matrix(l, n_b, B, status)
    if (status /= 0) return

    call kinetic_matrix(l, alpha, n_b, K, status)
    if (status /= 0) return

    call potential_matrix(l, alpha, n_b, V, status)
    if (status /= 0) return

    H(:, :) = K(:, :) + V(:, :)

    ! diagonalise
    energies(:) = 0d0
    eigenvectors(:, :) = 0d0

    call rsg(n_b, n_b, H, B, energies, 1, eigenvectors, status)
    if (status /= 0) return

    ! calculate wavefunctions
    wf(:, :) = 0d0

    do jj = 1, n_b
      do ii = 1, n_r
        do kk = 1, n_b
          wf(ii, jj) = wf(ii, jj)  + (eigenvectors(kk, jj) * basis(ii, kk))
        end do
      end do
    end do

    ! re-orient wavefunctions to be initially positive
    do jj = 1, n_b
      if (wf(1, jj) < 0.0d0) then
        wf(:, jj) = - wf(:, jj)
      end if
    end do

  end subroutine hydrogen_wf

  ! radial_basis
  !
  ! For given l, alpha, and r_grid, yields the functions varphi_{k, l}(r) for
  ! k = 1, ..., n_b, on the radial values specified in the grid.
  subroutine radial_basis (l, alpha, n_b, n_r, r_grid, basis, status)
    integer , intent(in) :: l
    double precision , intent(in) :: alpha
    integer , intent(in) :: n_b
    integer , intent(in) :: n_r
    double precision , intent(in) :: r_grid(n_r)
    double precision , intent(out) :: basis(n_r, n_b)
    integer , intent(out) :: status
    double precision :: norm(n_b)
    double precision :: alpha_grid(n_r)
    integer :: kk

    ! check if arguments are valid
    status = 0

    if ((l < 0) .or. (n_b < 1) .or. (n_r < 1)) then
      status = 1
      return
    end if

    ! recurrence relation for basis normalisation constants
    norm(1) = sqrt(alpha / dble((l + 1d0) * gamma(dble((2d0 * l) + 2d0))))

    if (n_b >= 2) then
      do kk = 2, n_b
        norm(kk) = norm(kk-1) * sqrt(dble((kk - 1d0) * (kk - 1d0 + l)) / &
            dble((kk + l) * (kk + (2d0 * l))))
      end do
    end if

    ! in-lined array since r_grid(:) on its own is never used
    alpha_grid(:) = alpha * r_grid(:)

    ! recurrence relation for basis functions
    basis(:, 1) = ((2.0d0 * alpha_grid(:)) ** (l + 1)) * &
        exp(-alpha_grid(:))

    if (n_b >= 2) then
      basis(:, 2) = 2.0d0 * (dble(l + 1d0) - alpha_grid(:)) * basis(:, 1)
    end if

    if (n_b >= 3) then
      do kk = 3, n_b
        basis(:, kk) = &
            ((2.0d0 * (dble(kk - 1d0 + l) - alpha_grid(:)) * basis(:, kk-1)) &
            - dble(kk + (2d0 * l) - 1d0) * basis(:, kk-2)) / dble(kk - 1)
      end do
    end if

    ! scaling basis functions by normalisation constants
    do kk = 1, n_b
      basis(:, kk) = basis(:, kk) * norm(kk)
    end do

  end subroutine radial_basis

  ! overlap_matrix
  !
  ! Overlap matrix elements for given l.
  subroutine overlap_matrix(l, n_b, B, status)
    integer , intent(in) :: l
    integer , intent(in) :: n_b
    double precision , intent(out) :: B(n_b, n_b)
    integer , intent(out) :: status
    integer :: kk

    ! check if arguments are valid
    status = 0

    if ((l < 0) .or. (n_b < 1)) then
      status = 1
      return
    end if

    ! initialise overlap matrix to zero
    B(:, :) = 0.0d0

    ! determine tri-diagonal overlap matrix elements
    do kk = 1, n_b-1
      B(kk, kk) = 1.0d0

      B(kk, kk+1) = - 0.5d0 * sqrt(1 - &
          (dble(l * (l + 1)) / dble((kk + l) * (kk + l + 1))))

      B(kk+1, kk) = B(kk, kk+1)
    end do

    ! last term (not covered by loop)
    B(n_b, n_b) = 1.0d0

  end subroutine overlap_matrix

  ! kinetic_matrix
  !
  ! Kinetic matrix elements for given l, alpha.
  subroutine kinetic_matrix(l, alpha, n_b, K, status)
    integer , intent(in) :: l
    integer , intent(in) :: n_b
    double precision , intent(in) :: alpha
    double precision , intent(out) :: K(n_b, n_b)
    integer , intent(out) :: status
    integer :: kk

    ! check if arguments are valid
    status = 0

    if ((l < 0) .or. (n_b < 1)) then
      status = 1
      return
    end if

    ! initialise kinetic matrix to zero
    K(:, :) = 0.0d0

    ! determine tri-diagonal kinetic matrix elements
    do kk = 1, n_b-1
      K(kk, kk) = 0.5d0 * (alpha ** 2)

      K(kk, kk+1) = (alpha ** 2) * 0.25d0 * sqrt(1 - &
          (dble(l * (l + 1)) / dble((kk + l) * (kk + l + 1))))

      K(kk+1, kk) = K(kk, kk+1)
    end do

    ! last term (not covered by loop)
    K(n_b, n_b) = 0.5d0 * (alpha ** 2)

  end subroutine kinetic_matrix

  ! potential_matrix
  !
  ! Hydrogen potential matrix elements for given l, alpha.
  subroutine potential_matrix(l, alpha, n_b, V, status)
    integer , intent(in) :: l
    integer , intent(in) :: n_b
    double precision , intent(in) :: alpha
    double precision , intent(out) :: V(n_b, n_b)
    integer , intent(out) :: status
    integer :: kk

    ! check if arguments are valid
    status = 0

    if ((l < 0) .or. (n_b < 1)) then
      status = 1
      return
    end if

    ! initialise coulomb matrix to zero
    V(:, :) = 0.0d0

    ! determine diagonal coulomb matrix elements
    do kk = 1, n_b
      V(kk, kk) = - alpha / dble(kk + l)
    end do

  end subroutine potential_matrix

end module hydrogen


        subroutine resample(a,nxmod,nymod,ar,nx,ny,rmag)

! Resample array a (nxmod by nymod) onto a grid ar (nx by ny) at
! intervals of 1/rmag, mapping the centre pixel of the old array
! into the centre pixel of the new one.

        implicit real (a-h,o-z)
        implicit integer (i-n)

        real,   intent(in),                        &
        &       dimension(nxmod,nymod)  ::   a      ! input array

        real,   intent(out),                       &
        &       dimension(nx,ny)        ::   ar     ! output (resampled) array

        real(8),   allocatable             ::   grid(:,:)
        real(8) x,xmin,xmax,y,ymin,ymax,z,zx,zy,zxx,zyy,zxy

        allocate( grid(0:nxmod, 0:nymod) )
        grid = 0.

        do j = 1,nymod
        do i = 1,nxmod
            grid(i,j) = a(i,j)
        enddo
        enddo

        ixmod = nxmod/2 + 1
        iymod = nymod/2 + 1
        ix = nx/2 + 1
        iy = ny/2 + 1

        do j = 1,ny
        do i = 1,nx
            x = ixmod + (i-ix)/rmag
            y = iymod + (j-iy)/rmag
            if (x >=1.d0 .and. x <= nxmod*1.d0 .and. &
                y >=1.d0 .and. y <= nymod*1.d0) then
                call intrp2(x, 0.d0, nxmod*1.d0, nxmod, y, 0.d0, &
                    nymod*1.d0, nymod, grid, z,zx,zy,zxx,zyy,zxy)
            else
                z = 0.
            endif

            ar(i,j) = z
        enddo
        enddo

        deallocate(grid)
        return

        end subroutine resample


subroutine rkc4b(neqn,t0,tf,u0,nsteps,abserr,relerr,u)
!
! Subroutine rkc4b computes an ODE solution by a variable
! step classical fourth order RK method for a series of
! points along the solution by repeatedly calling
! subroutine ssrkc4 for a single classical fourth order RK
! step. The truncation error is estimated along the
! solution to adjust the integration step according to a
! specified error tolerance.
!
! Argument list
!
! neqn number of first order ODEs
!
! t0 initial value of independent variable
!
! tf final value of independent variable
!
! u0 initial condition vector of length neqn
!
! nsteps maximum number of rkc4 steps
!
! abserr absolute error tolerance
!
! relerr relative error tolerance
!
! u ODE solution vector of length neqn after
! nsteps steps
!
! Double precision coding is used
implicit double precision(a-h,o-z)
!
! Size the arrays
parameter(neq=500)
dimension e(neq)
dimension u0(neqn), u(neqn)
!
! Integration step
h=(tf-t0)/2.0d0
!
! Minimum allowable step
hmin=(tf-t0)/dfloat(nsteps)
!
! Start integration
t=t0
!
! While independent variable is less than the final
! value, continue the integration
do while(t.le.tf*0.999d0)
!
! If the next step along the solution will go past
! the final value of the independent variable, set
! the step to the remaining distance to the final
! value
if((t+h).gt.tf)then
h=tf-t
end if
!
! Single rkc4 step
call ssrkc4(neqn,t0,u0,h,t,u,e)
!
! Flag for the end of the integration
nfin1=1
!
! Check if any of the ODEs have violated the error
! critreria
do i=1,neqn
if(dabs(e(i)).gt.dabs(u(i))*relerr+abserr)then
!
! Error violation, so integration is not
! complete. Reduce integration step because
! of error violation and repeat integration
! from the base point
nfin1=0
h=h/2.0d0
!
! If the current step is less than the minimum
! allowable step, set the step to the minimum
! allowable value and continue integration from
! new base point
if(h.lt.hmin)then
h=hmin
nfin1=1
end if
go to 1
end if
end do
!
! Ifthere is no error violation, continue the
! integration from new base point
1 if(nfin1.eq.1)then
do i=1,neqn
u0(i)=u(i)
end do
t0=t
!
! Test if integration step can be increased
do i=1,neqn
if(dabs(e(i)).gt.(dabs(u(i))*relerr+abserr)/16.0d0)then
!
! Integration step cannot be increased
    go to 2
end if
end do
!
! Increase integration step
h=h*2.0d0
!
! Continue for no error violation (nfin1=1)
2 end if
!
! Continue do while
end do
return
!
! End of rkc4b
end


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

*   Double precision arithmetic operations (+, -, *, /),
*   including constant folding and implied type
*   conversions of integer operands.

	programp
        implicit double precision (x)

	parameter(N = 33)
	parameter(x5dn5 = 3d-5 + 2d-5)
	double precision  rslts(N), expect(N)

c   tests 1 - 6:
	data expect /-2.0d0, 2.0d0, 3.0d0,
c   tests 7 - 22:
     +           3.5d0, 2 * x5dn5, -1.0d0, 3.5d0, 0.0d0, 4.0d0, 4.0d0,
c   tests 23 - 36:
     +           -0.5d0, -0.5d0, 5.0d0, -8.0d0, 0.5d0, 1.0d0, 2.0d0,
c   tests 37 - 50:
     +           1.5d0, -6.0d0, 1.0d0, 1.0d0, -9.0d0, 4.0d0, 4.0d0,
c   tests 51 - 66:
     +           10.0d0, -1.5d0, 4.0d0, 1.0d0,-2.5d0,4.0d0,3.0d0,1.0d0/

	data i2 / 2/, x2, xn3, x2dn5 / 2.0d0, - 3.0d0, 2.0d-5 /

c   tests 1 - 6, unary minus:

	rslts(1) = -2.0d0
	rslts(2) = - ( -x2)
	rslts(3) = -xn3

c   tests 7 - 22, addition:

	rslts(4) = 1.5d0 + 2.0d0
	rslts(5) = x2dn5 + 3d-5
	rslts(6) = 3d-5 + x2dn5
	rslts(7) = x2 + xn3

	rslts(8) = 2 + 1.5d0
	rslts(9) = xn3 + (+3)
	rslts(10) = +x2 + i2
	rslts(11) = i2 + x2

c   tests 23 - 36, subtraction:

	rslts(12) = 1.5d0 - 2.0d0
	rslts(13) = 1.5d0 - x2
	rslts(14) = x2 - xn3

	rslts(15) = (-5) - (- xn3)
	rslts(16) = i2 - 1.5d0
	rslts(17) = 3.0d0 - i2
	rslts(18) = 3.0d0 - 1

c   tests 37 - 50, multiplication:

	rslts(19) = 0.5d0 * 3.0d0
	rslts(20) = x2 * xn3
	rslts(21) = x2 * .5d0

	rslts(22) = 2 * .5d0
	rslts(23) = xn3 * 3
	rslts(24) = x2 * i2
	rslts(25) = i2 * x2

c   tests 51 - 66, division:

	rslts(26) = 5.0d0 / .5d0
	rslts(27) = xn3 / x2
	rslts(28) = x2 / .5d0
	rslts(29) = 2.0d0 / x2

	rslts(30) = 5 / (-x2)
	rslts(31) = i2 / .5d0
	rslts(32) = 3.0d0 / (i2 - 1)
	rslts(33) = 5.0d0 / 5

c   check results:

	call check(rslts, expect, 2*N)
	end


module ipgmio

implicit none

integer, parameter, private :: iounit = 10
integer, parameter :: thresh = 255

contains

!  Routine to get size of a PGM image
!  Note that this assumes no comments and no other white space
!  You can create PGMS using:
!  convert image.jpg -colorspace gray -compress none -depth 8 image.pgm
!  then edit them slightly.

subroutine ipgmsize(filename, nx, ny)

  integer :: nx, ny

  character*(*) :: filename

  open(unit=iounit, file=filename)

  read(iounit,*)
  read(iounit,*) nx, ny

  close(unit=iounit)

end subroutine ipgmsize

subroutine ipgmread(filename, x)

  character*(*) :: filename
  integer :: nx, ny, nxt, nyt
  integer, dimension(:,:) :: x

  integer i, j

  nx = size(x,1)
  ny = size(x,2)

  write(*,*) 'Reading ', nx, ' x ', ny, ' picture from file: ', filename

  open(unit=iounit, file=filename)

  read(iounit,*)
  read(iounit,*) nxt, nyt

  if (nx .ne. nxt .or. ny .ne. nyt) then
    write(*,*) 'pgmread: size mismatch, (nx,ny) = (', nxt, ',', nyt, &
               ') expected (', nx, ',', ny, ')'
    stop
  end if

  read(iounit,*)
  read(iounit,*) ((x(i,ny-j+1), i=1,nx), j=1,ny)

  close(unit=iounit)

end subroutine ipgmread

subroutine ipgmwrite(filename, x)

  implicit none

  character*(*) :: filename
  integer, dimension(:,:) :: x

  integer :: i, j, nx, ny

  nx = size(x,1)
  ny = size(x,2)

  write(*,*) 'Writing ', nx, ' x ', ny, ' picture into file: ', filename

  open(unit=iounit, file=filename)

  write(iounit,fmt='(''P2''/''# Written by ipgmwrite'')')
  write(iounit,fmt='(i4, '' '', i4)') nx, ny

  write(iounit,fmt='(i4)') thresh
  write(iounit,fmt='(12('' '', i5))') ((x(i, ny-j+1) , i=1,nx), j=1,ny)

  close(unit=iounit)

end subroutine ipgmwrite

double precision function boundaryval(i, m)

  implicit none

  integer :: i, m
  double precision :: val

  val = 2.0*dble(i-1)/dble(m-1)
  if (i .ge. m/2+1) val = 2.0-val

  boundaryval = val

end function boundaryval

end module ipgmio

program pgm2edge

  use ipgmio

  implicit none

  integer, allocatable, dimension(:,:) :: image, edge

  integer, parameter :: maxlen = 32

  character*(maxlen) :: infile, outfile

  double precision :: val

  integer :: i, j, nx, ny, imax, imin

  if (command_argument_count() /= 2) then
     write(*,*) 'Usage: pgm2edge <input image file> <output edge file>'
     stop
  end if

  call get_command_argument(1, infile)
  call get_command_argument(2, outfile)

  infile  = trim(infile)
  outfile = trim(outfile)

  write(*,*) 'pgm2edge: infile = ',  infile, 'outfile = ', outfile

  call ipgmsize(infile, nx, ny)

  write(*,*) 'nx, ny = ', nx, ny

  allocate(image(0:nx+1,0:ny+1))
  allocate(edge(nx,ny))

  call ipgmread(infile, image(1:nx, 1:ny))

! periodic bcs on top and bottom

  image(:,0)    = image(:,ny)
  image(:,ny+1) = image(:,1)

  do j = 1, ny

! compute sawtooth value on left and right

     val = boundaryval(j,ny)

     image(0,j)    = dble(thresh)*(1.0-val)
     image(nx+1,j) = dble(thresh)*val

  end do

  write(*,*) 'pgmread: image min, max = ', minval(image(1:nx, 1:ny)), &
                                           maxval(image(1:nx, 1:ny))

  do j = 1,ny
    do i = 1, nx

      edge(i,j) = image(i+1,j) + image(i-1,j) + image(i,j+1) + image(i,j-1) &
                  - 4.0*image(i,j)

    end do
  end do

  call ipgmwrite(outfile, edge)

  deallocate(image)
  deallocate(edge)

  write(*,*) 'pgm2edge: finished'

end program pgm2edge


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C        SOLVER : Gradient conjugue            20.10.96
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE pcg(N, x, b, A, IA, JA, ALU,JU,JLU, epsilon,
     #              it_max,r, w, p, z, iflag)
C
C Input  : N           : Dim. du systeme.
C          x           : Vecteur initial x0.
C          b           : Second membre.
C          A           : Matrice du syst.
C          epsilon     : Precision relative du resultat.
C          it_max      : Nbre d'iterations max. a effectuer.
C          r, w, p, ax : Vecteurs (dim = N) auxiliaires.
C
C Output : x           : Solution du systeme.
C          it_max      : Nbre d'iterations effectuees.
C          epsilon     : Norme du residu.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     -- Declarations --------------------------------------
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION A(*), IA(*), JA(*),
     #          ALU(*),JLU(*),JU(*),
     #          b(N), x(N), r(N), w(N), p(N), z(N)

C
C     -- Initialisations -----------------------------------
C
      CALL SMMV(N, A, IA, JA, x, z)
      CALL VectSub(N, b, z, r)
      IF(iflag.NE.0) THEN
         CALL LLTSOL(N, r, z, ALU, JLU, JU)
      ELSE
         CALL VectAssign(N,z,r)
      ENDIF

      rho   = ProdScal(N, z, r)
      no_it = 0
      tol   = epsilon * VectNorm(N, b)
C
      WRITE(*,200)
C
C     -- Boucle principale ---------------------------------

10    IF ((DSQRT(rho).GT.tol).AND.(no_it.LT.it_max)) THEN
         IF (no_it.EQ.0) THEN
            CALL VectAssign(N, p, z)
         ELSE
            beta = rho / rho_old
            DO 20 i = 1, N
               p(i) = z(i) + beta * p(i)
20          CONTINUE
         ENDIF
         CALL SMMV(N, A, IA, JA, p, w)
         alpha = rho / ProdScal(N, p, w)
         DO 30 i = 1, N
            x(i) = x(i) + alpha * p(i)
            r(i) = r(i) - alpha * w(i)
30       CONTINUE
         rho_old = rho
         IF(iflag.NE.0) THEN
            CALL LLTSOL(N, r, z, ALU, JLU, JU)
         ELSE
            CALL VectAssign(N,z,r)
         ENDIF
         rho     = ProdScal(N, z, r)
         no_it   = no_it + 1
         WRITE(*,210) no_it, DSQRT(rho)
         goto 10
      ENDIF

C-- Commentaires finaux ------------------------------------

      WRITE(*,*)
      IF (no_it.EQ.it_max) THEN
         WRITE(*,*)'Nbre max d it atteint -> divergence possible !'
      ELSE
         WRITE(*,*)'Convergence !'
      ENDIF
C
      RETURN

200   FORMAT(/' SOLVEUR Gradient Conjugue'
     #       /' -------------------------'/)
210   FORMAT(' Iteration :',T13,I4,'   Residu :',T31,D10.5)
      END


c  File: dfrenl.[for|f|c]
c  Contains procedures: DFRENC(), DFRENF(), DFRENG(), DFRENS()
c  and private low-level procedure: DFREN1().
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2000-12-01 DFRENL Krogh Removed parameter PID2.
c>> 2000-09-07 DFRENL Krogh Changed text on x to one on ax.
c>> 1996-01-08 DFRENL WV Snyder Use DCSPXX for cos(Pi/2 x**2), etc.
C>> 1995-11-03 DFRENL Krogh  Removed blanks in numbers for C conversion.
c>> 1994-11-02 DFRENL Krogh  Changes to use M77CON
c>> 1994-10-18 DFRENL WV Snyder More specializing instructions
c>> 1993-02-25 DFRENL CLL. Edited to eliminate ENTRY and EQUIVALENCE.
c>> 1992-09-15 DFRENL WV Snyder Specializing instructions
c>> 1992-04-13 DFRENL WV Snyder Declare DFRENF, DFRENG, DFRENS
c>> 1992-03-18 DFRENL WV Snyder Move declarations for coefficient arrays
c>> 1992-01-24 DFRENL WV Snyder Original code
c--D replaces "?": ?FRENC, ?FREN1, ?FRENF, ?FRENG, ?FRENS, ?FRENL
c--&               ?CSPXX, ?SNPXX
c Subprograms in this file compute the Fresnel Cosine and Sine
c integrals C(x) and S(x), and the auxiliary functions f(x) and g(x),
c for any X:
c     DFRENC(X) for Fresnel integral C(X)
c     DFRENS(X) for Fresnel integral S(x)
c     DFRENF(X) for Fresnel integral auxiliary function f(x)
c     DFRENG(X) for Fresnel integral auxiliary function g(x).
c
c Developed by W. V. Snyder, Jet Propulsion Laboratory, 24 January 1992.
c
c Ref: W. J. Cody, "Chebyshev Approximations for the Fresnel Integrals",
c Mathematics of Computation, 1968, pp 450-453 plus Microfiche Suppl.
c W. V. Snyder, "Algorithm 723: Fresnel Integrals," ACM Trans. Math.
c Softw. 19, 4 (December 1993) 452-456.
c Accuracies of highest order formulae, where E is relative error:
c
c Range           Function   -log10(E)   Function   -log10(E)
c |X|<=1.2          C(x)       16.24       S(x)       17.26
c 1.2<|X|<=1.6      C(x)       17.47       S(x)       18.66
c 1.6<|X|<=1.9      f(x)       17.13       g(x)       16.25
c 1.9<|X|<=2.4      f(x)       16.64       g(x)       15.65
c 2.4<|X|           f(x)       16.89       g(x)       15.58
c
c Refer to Cody for accuracy of other approximations.
c
c     ==================================================================
      double precision function DFRENC(X)
      external DFREN1
      double precision X, DFREN1
      DFRENC = DFREN1(1,X)
      return
      end
c     ==================================================================
      double precision function DFRENF(X)
      external DFREN1
      double precision X, DFREN1
      DFRENF = DFREN1(3,X)
      return
      end
c     ==================================================================
      double precision function DFRENG(X)
      external DFREN1
      double precision X, DFREN1
      DFRENG = DFREN1(4,X)
      return
      end
c     ==================================================================
      double precision function DFRENS(X)
      external DFREN1
      double precision X, DFREN1
      DFRENS = DFREN1(2,X)
      return
      end
c     ==================================================================
      double precision function DFREN1(MODE, X)
c     MODE = 1 means compute C.
c     MODE = 2 means compute S.
c     MODE = 3 means compute F.
c     MODE = 4 means compute G.
c     ------------------------------------------------------------------
c                        Internal variables.
c
c RPI is the reciprocal of PI.
c RPISQ is the reciprocal of PI squared.
c AX is abs(x).
c BIGX is 1/sqrt(round-off).  If X > BIGX then to the working
c         precision x**2 is an integer (which we assume to be a multiple
c         of four), so cos(pi/2 * x**2) = 1, and sin(pi/2 * x**2) = 0.
c C and S are values of C(x) and S(x), respectively.
c CX and SX are cos(pi/2 * ax**2) and sin(pi/2 * ax**2), respectively.
c F and G are used to compute f(x) and g(x) when X > 1.6.
c HAVEC, HAVEF, HAVEG, HAVES are logical variables that indicate
c         whether the values stored in C, F, G and S correspond to the
c         value stored in X.  HAVEF indicates we have both F and G when
c         XSAVE .le. 1.6, and HAVEC indicates we have both C and S when
c         XSAVE .gt. 1.6.
c LARGEF is 1/(pi * underflow).  If X > LARGEF then f ~ 0.
c LARGEG is cbrt(1/(pi**2 * underflow)).  If X > LARGEG then g ~ 0.
c LARGEX is 1/sqrt(sqrt(underflow)).  If X > LARGEX then f ~ 1/(pi * x)
c         and g ~ 1/(pi**2 * x**3).
c MODE indicates the function to be computed: 1 = C(x), 2 = S(x),
c         3 = f(x), 4 = g(x).
c NEEDC, NEEDF, NEEDG, NEEDS are arrays indexed by MODE (MODE+4 when
c         X .gt. 1.6) that indicate what functions are needed.
c WANTC indicates whether C and S must be computed from F and G.
c WANTF and WANTG indicate we computed F and G on the present call.
c XSAVE is the most recently provided value of X.
c X4 is either X ** 4 or (1.0/X) ** 4.
c     If you change the order of approximation, you must change the
c     declarations and DATA statements for the coefficient arrays,
c     and the executable statements that evaluate the approximations.
c     ------------------------------------------------------------------
      external D1MACH, DCSPXX, DSNPXX
      double precision D1MACH, DCSPXX, DSNPXX
      double precision RPI, RPISQ
      parameter (RPI = 0.3183098861837906715377675267450287240689d0)
      parameter (RPISQ = RPI * RPI)
      double precision AX, BIGX, C, CX, F, G, LARGEF, LARGEG, LARGEX
      double precision S, SX, X, XSAVE, X4
      integer MODE
      logical HAVEC, HAVEF, HAVEG, HAVES, WANTC, WANTF, WANTG
      logical NEEDC(8), NEEDF(8), NEEDG(8), NEEDS(8)
      save BIGX, C, F, G, LARGEF, LARGEG, LARGEX, S, XSAVE
      save HAVEC, HAVEF, HAVEG, HAVES
c++   default digits=16
c++   code for digits <= 3 is inactive
c      double precision PC1(0:1), QC1(1:1)
c++   code for digits > 3 & digits <= 6 is inactive
c      double precision PC1(0:2), QC1(1:2)
c++   code for digits > 6 & digits <= 11 is inactive
c      double precision PC1(0:3), QC1(1:3)
c++   code for digits > 11 is active
      double precision PC1(0:4), QC1(1:4)
c++   end
c++   code for digits <= 2 is inactive
c      double precision PC2(0:1), QC2(1:1)
c++   code for digits > 2 & digits <= 5 is inactive
c      double precision PC2(0:2), QC2(1:2)
c++   code for digits > 5 & digits <= 8 is inactive
c      double precision PC2(0:3), QC2(1:3)
c++   code for digits > 8 & digits <= 12 is inactive
c      double precision PC2(0:4), QC2(1:4)
c++   code for digits > 12 is active
      double precision PC2(0:5), QC2(1:5)
c++   end
c++   code for digits <= 3 is inactive
c      double precision PS1(0:1), QS1(1:1)
c++   code for digits > 3 & digits <= 7 is inactive
c      double precision PS1(0:2), QS1(1:2)
c++   code for digits > 7 & digits <= 12 is inactive
c      double precision PS1(0:3), QS1(1:3)
c++   code for digits > 12 is active
      double precision PS1(0:4), QS1(1:4)
c++   end
c++   code for digits <= 2 is inactive
c      double precision PS2(0:1), QS2(1:1)
c++   code for digits > 2 & digits <= 5 is inactive
c      double precision PS2(0:2), QS2(1:2)
c++   code for digits > 5 & digits <= 9 is inactive
c      double precision PS2(0:3), QS2(1:3)
c++   code for digits > 9 & digits <= 14 is inactive
c      double precision PS2(0:4), QS2(1:4)
c++   code for digits > 14 is active
      double precision PS2(0:5), QS2(1:5)
c++   end
c++   code for digits <= 5 is inactive
c      double precision PF1(0:1), QF1(1:1)
c++   code for digits > 5 & digits <= 8 is inactive
c      double precision PF1(0:2), QF1(1:2)
c++   code for digits > 8 & digits <= 11 is inactive
c      double precision PF1(0:3), QF1(1:3)
c++   code for digits > 11 & digits <= 14 is inactive
c      double precision PF1(0:4), QF1(1:4)
c++   code for digits > 14 is active
      double precision PF1(0:5), QF1(1:5)
c++   end
c++   code for digits <= 5 is inactive
c      double precision PF2(0:1), QF2(1:1)
c++   code for digits > 5 & digits <= 8 is inactive
c      double precision PF2(0:2), QF2(1:2)
c++   code for digits > 8 & digits <= 11 is inactive
c      double precision PF2(0:3), QF2(1:3)
c++   code for digits > 11 & digits <= 14 is inactive
c      double precision PF2(0:4), QF2(1:4)
c++   code for digits > 14 is active
      double precision PF2(0:5), QF2(1:5)
c++   end
c++   code for digits <= 3 is inactive
c      double precision PF3(0:0)
c++   code for digits > 3 & digits <= 6 is inactive
c      double precision PF3(0:1), QF3(1:1)
c++   code for digits > 6 & digits <= 9 is inactive
c      double precision PF3(0:2), QF3(1:2)
c++   code for digits > 9 & digits <= 11 is inactive
c      double precision PF3(0:3), QF3(1:3)
c++   code for digits > 11 & digits <= 13 is inactive
c      double precision PF3(0:4), QF3(1:4)
c++   code for digits > 13 & digits <= 15 is inactive
c      double precision PF3(0:5), QF3(1:5)
c++   code for digits > 15 is active
      double precision PF3(0:6), QF3(1:6)
c++   end
c++   code for digits <= 4 is inactive
c      double precision PG1(0:1), QG1(1:1)
c++   code for digits > 4 & digits <= 7 is inactive
c      double precision PG1(0:2), QG1(1:2)
c++   code for digits > 7 & digits <= 10 is inactive
c      double precision PG1(0:3), QG1(1:3)
c++   code for digits > 10 & digits <= 13 is inactive
c     double precision PG1(0:4), QG1(1:4)
c++   code for digits > 13 is active
      double precision PG1(0:5), QG1(1:5)
c++   end
c++   code for digits <= 4 is inactive
c      double precision PG2(0:1), QG2(1:1)
c++   code for digits > 4 & digits <= 7 is inactive
c      double precision PG2(0:2), QG2(1:2)
c++   code for digits > 7 & digits <= 10 is inactive
c      double precision PG2(0:3), QG2(1:3)
c++   code for digits > 10 & digits <= 13 is inactive
c      double precision PG2(0:4), QG2(1:4)
c++   code for digits > 13 is active
      double precision PG2(0:5), QG2(1:5)
c++   end
c++   code for digits <= 3 is inactive
c      double precision PG3(0:0)
c++   code for digits > 3 & digits <= 5 is inactive
c      double precision PG3(0:1), QG3(r:1)
c++   code for digits > 5 & digits <= 8 is inactive
c      double precision PG3(0:2), QG3(1:2)
c++   code for digits > 8 & digits <= 10 is inactive
c      double precision PG3(0:3), QG3(1:3)
c++   code for digits > 10 & digits <= 12 is inactive
c      double precision PG3(0:4), QG3(1:4)
c++   code for digits = 13 is inactive
c      double precision PG3(0:5), QG3(1:5)
c++   code for digits > 13 is active
      double precision PG3(0:6), QG3(1:6)
c++   end
c
      data BIGX /-1.0d0/
      data C /0.0d0/, F /0.5d0/, G /0.5d0/, S /0.0d0/, XSAVE /0.0d0/
      data HAVEC/.TRUE./, HAVEF/.TRUE./, HAVEG/.TRUE./, HAVES/.TRUE./
c        C(x)    S(x)    f(x)    g(x)    C(x)    S(x)    f(x)    g(x)
      data NEEDC
     1 /.TRUE., .FALSE.,.TRUE., .TRUE., .TRUE., .FALSE.,.FALSE.,.FALSE./
      data NEEDS
     1 /.FALSE.,.TRUE., .TRUE., .TRUE., .FALSE.,.TRUE., .FALSE.,.FALSE./
      data NEEDF
     1 /.FALSE.,.FALSE.,.TRUE., .FALSE.,.TRUE., .TRUE., .TRUE., .FALSE./
      data NEEDG
     1 /.FALSE.,.FALSE.,.FALSE.,.TRUE. ,.TRUE., .TRUE., .FALSE.,.TRUE. /
c
c     Coefficients for C(x), |X| <= 1.2
c++   code for digits <= 3 is inactive
c      data pc1 / 1.00053d0, -1.12353d-1/, qc1 /1.38937d-1/
c++   code for digits > 3 & digits <= 6 is inactive
c      data pc1 / 9.99999896d-1, -1.63090954d-1, 1.06388604d-2/
c      data qc1 / 8.36467414d-2,  3.10155884d-3/
c++   code for digits > 6 & digits <= 11 is inactive
c      data pc1 / 1.0000000000042d0,  -1.8651127631106d-1,
c     *           1.5065663274457d-2, -3.1058074693185d-4/
c      data qc1 / 6.0228833908128d-2,  1.7410300558198d-3,
c     *            .6308617899210d-5/
c++   code for digits > 11 is active
      data pc1 / 9.999999999999999421d-1 ,
     *          -1.994608988261842706d-1 ,
     *           1.761939525434914045d-2 ,
     *          -5.280796513726226960d-4 ,
     *           5.477113856826871660d-6/
      data qc1 / 4.727921120104532689d-2 ,
     *           1.099572150256418851d-3 ,
     *           1.552378852769941331d-5 ,
     *           1.189389014228757184d-7/
c++   end
c
c     Coefficients for C(x), 1.2 < |X| <= 1.6
c++   code for digits <= 2 is inactive
c      data pc2 / 1.3139d0, -5.8827d-2/, qc2 / 4.7324d-1/
c++   code for digits > 2 & digits <= 5 is inactive
c      data pc2 / 9.9790890d-1, -1.5391895d-1, 9.9817933d-3/
c      data qc2 / 8.9878647d-2,  5.6003071d-3/
c++   code for digits > 5 & digits <= 8 is inactive
c      data pc2 / 1.00000440109d0, -1.83413851908d-1,
c     *           1.45776170828d-2,-2.78980705270d-4/
c      data qc2 / 6.33347445637d-2, 2.01245738369d-3,
c     *           4.03949004646d-5/
c++   code for digits > 8 & digits <= 12 is inactive
c      data pc2 / 9.999999966496876d-1, -1.980300987022688d-1,
c     *           1.735518748450023d-2, -5.069442297935788d-4,
c     *           5.059962254678234d-6/
c      data qc2 / 4.871000308997918d-2,  1.188406974004084d-3,
c     *           1.824527635843850d-5,  1.678314257874103d-7/
c++   code for digits > 12 is active
      data pc2 / 1.00000000000111043640d0  ,
     *          -2.07073360335323894245d-1 ,
     *           1.91870279431746926505d-2 ,
     *          -6.71376034694922109230d-4 ,
     *           1.02365435056105864908d-5 ,
     *          -5.68293310121870728343d-8/
      data qc2 / 3.96667496952323433510d-2 ,
     *           7.88905245052359907842d-4 ,
     *           1.01344630866749406081d-5 ,
     *           8.77945377892369265356d-8 ,
     *           4.41701374065009620393d-10/
c++   end
c
c     Coefficients for S(x), |X| <= 1.2
c++   code for digits <= 3 is inactive
c      data ps1 / 5.23677d-1, -4.67900d-2/, qs1 / 8.81622d-2/
c++   code for digits > 3 & digits <= 7 is inactive
c      data ps1 / 5.235987665d-1,-5.837763961d-2, 2.165920196d-3/
c      data qs1 / 6.474944765d-2, 1.713287588d-3/
c++   code for digits > 7 & digits <= 12 is inactive
c      data ps1 / 5.23598775598566d-1, -6.59149581139046d-2,
c     *           3.21501649828293d-3, -4.88704436240178d-5/
c      data qs1 / 5.03546388670085d-2,  1.17835980356588d-3,
c     *           1.37089875826980d-5/
c++   code for digits > 12 is active
      data ps1 / 5.2359877559829887021d-1 ,
     *          -7.0748991514452302596d-2 ,
     *           3.8778212346368287939d-3 ,
     *          -8.4555728435277680591d-5 ,
     *           6.7174846662514086196d-7/
      data qs1 / 4.1122315114238422205d-2 ,
     *           8.1709194215213447204d-4 ,
     *           9.6269087593903403370d-6 ,
     *           5.9528122767840998345d-8/
c++   end
c
c     coefficients for S(x), 1.2 < |X| <= 1.6
c++   code for digits <= 2 is inactive
c      data ps2 / 5.4766d-1, -3.7151d-2/, qs2 / 1.4559d-1/
c++   code for digits > 2 & digits <= 5 is inactive
c      data ps2 / 5.2343994d-1, -5.4828347d-2, 1.9020881d-3/
c      data qs2 / 7.1104704d-2,  2.5596274d-3/
c++   code for digits > 5 & digits <= 9 is inactive
c      data ps2 / 5.23599040498d-1, -6.46593392426d-2,
c     *           3.08030794361d-3, -4.40800854418d-5/
c      data qs2 / 5.27536681685d-2,  1.34311026821d-3,
c     *           1.90476612849d-5/
c++   code for digits > 9 & digits <= 14 is inactive
c      data ps2 / 5.2359877543509178d-1,-7.0149076634833662d-2,
c     *           3.8031581605987038d-3,-8.0964948714408156d-5,
c     *           6.1908080210052772d-7/
c      data qs2 / 4.2268067370395487d-2, 8.7642753831073237d-4,
c     *           1.1088542889789282d-5, 7.8725829545478464d-8/
c++   code for digits > 14 is active
      data ps2 / 5.23598775598344165913d-1 ,
     *          -7.37766914010191323867d-2 ,
     *           4.30730526504366510217d-3 ,
     *          -1.09540023911434994566d-4 ,
     *           1.28531043742724820610d-6 ,
     *          -5.76765815593088804567d-9/
      data qs2 / 3.53398342767472162540d-2 ,
     *           6.18224620195473216538d-4 ,
     *           6.87086265718620117905d-6 ,
     *           5.03090581246612375866d-8 ,
     *           2.05539124458579596075d-10/
c++   end
c
c     coefficients for f(x), 1.6 < |X| <= 1.9
c++   code for digits <= 5 is inactive
c      data pf1 / 3.1803519d-1, 4.2352332d-1/, qf1 / 1.6015403d0/
c++   code for digits > 5 & digits <= 8 is inactive
c      data pf1 / 3.18285252094d-1,  2.02860275713d0,
c     *           1.08108136048d0 /
c      data qf1 / 6.67171548135d0,   4.52997553972d0 /
c++   code for digits > 8 & digits <= 11 is inactive
c      data pf1 / 3.1830646311448d-1,  4.6077249266684d0,
c     *           1.1914578438074d1,   3.5555073665830d0 /
c      data qf1 / 1.4778464938936d1,   4.0902971163705d1,
c     *           1.6130432784819d1 /
c++   code for digits > 11 & digits <= 14 is inactive
c      data pf1 / 3.1830926850490599d-1,  8.0358812280394156d0,
c     *           4.8034065557792487d1,   6.9853426160102065d1,
c     *           1.3530423554038784d1 /
c      data qf1 / 2.5549161843579529d1,   1.5761100558012250d2,
c     *           2.4956199380517229d2,   6.5563064008391554d1 /
c++   code for digits > 14 is active
      data pf1 / 3.1830975293580985290d-1 ,
     *           1.2226000551672961219d1  ,
     *           1.2924886131901657025d2  ,
     *           4.3886367156695547655d2  ,
     *           4.1466722177958961672d2  ,
     *           5.6771463664185116454d1 /
      data qf1 / 3.8713003365583442831d1  ,
     *           4.1674359830705629745d2  ,
     *           1.4740030733966610568d3  ,
     *           1.5371675584895759916d3  ,
     *           2.9113088788847831515d2 /
c++   end
c
c     coefficients for f(x), 1.9 < |X| <= 2.4
c++   code for digits <= 5 is inactive
c      data pf2 / 3.1825112d-1, 5.8395951d-1/, qf2 / 2.1243944d0 /
c++   code for digits > 5 & digits <= 8 is inactive
c      data pf2 / 3.1830699932d-1, 2.9993457087d0, 2.3956340010d0/
c      data qf2 / 9.7254517756d0,  9.4814077696d0 /
c++   code for digits > 8 & digits <= 11 is inactive
c      data pf2 / 3.1830963944521d-1,  7.0770431878327d0,
c     *           2.8756083262903d1,   1.3583685742326d1 /
c      data qf2 / 2.2536994405207d1,   9.6127568469278d1,
c     *           5.7407028004031d1 /
c++   code for digits > 11 & digits <= 14 is inactive
c      data pf2 / 3.183098568640159d-1,  1.265129469683175d1,
c     *           1.219467616498339d2,   2.910033655512762d2,
c     *           9.278397828631516d1/
c      data qf2 / 4.004915302781009d1,   3.942059697951583d2,
c     *           1.001368403495691d3,   4.142676224222433d2/
c++   code for digits > 14 is active
      data pf2 / 3.183098818220169217d-1 ,
     *           1.958839410219691002d1  ,
     *           3.398371349269842400d2  ,
     *           1.930076407867157531d3  ,
     *           3.091451615744296552d3  ,
     *           7.177032493651399590d2 /
      data qf2 / 6.184271381728873709d1  ,
     *           1.085350675006501251d3  ,
     *           6.337471558511437898d3  ,
     *           1.093342489888087888d4  ,
     *           3.361216991805511494d3 /
c++   end
c
c     coefficients for f(x), 2.4 < |X|
c++   code for digits <= 3 is inactive
c      data pf3 /-8.97969d-2/
c++   code for digits > 3 & digits <= 6 is inactive
c      data pf3 / -9.67122165d-2, -3.73565920d-1/
c      data qf3 / 7.29466572d0 /
c++   code for digits > 6 & digits <= 9 is inactive
c      data pf3 /-9.67541443648d-2, -2.26566293818d0,
c      *         -3.53429821084d0 /
c      data qf3 / 2.69596939977d1,   9.72883957469d1 /
c++   code for digits > 9 & digits <= 11 is inactive
c      data pf3 /-9.6754596389025d-2, -5.5254943840897d0,
c     *          -5.8606282086171d1,  -5.2235560918394d1 /
c      data qf3 / 6.0654483020979d1,   7.8528841711294d2,
c     *           1.8592498578831d3 /
c++   code for digits > 11 & digits <= 13 is inactive
c      data pf3 /-9.675460316952504d-2, -1.023876428129288d1,
c     *          -2.712579634037998d2,  -1.766119345282127d3,
c     *          -1.043464426656267d3 /
c      data qf3 / 1.093682244053459d2,   3.155843461920557d3,
c     *           2.625634316204420d4,   4.578252057246393d4 /
c++   code for digits > 13 & digits <= 15 is inactive
c      data pf3 /-9.67546032967090380d-2,-1.64797712841245767d1,
c     *          -8.16343401784374598d2, -1.34922028171857248d4,
c     *          -6.13547113614699772d4, -2.61294753225141779d4/
c      data qf3 / 1.73871690673649114d2,  9.01827596231524147d3,
c     *           1.65946462621853184d5,  1.00105478900791339d6,
c     *           1.37012364817225972d6 /
c++   code for digits > 15 is active
      data pf3 /-9.675460329952532343d-2 ,
     *          -2.431275407194161683d1  ,
     *          -1.947621998306889176d3  ,
     *          -6.059852197160773639d4  ,
     *          -7.076806952837779823d5  ,
     *          -2.417656749061154155d6  ,
     *          -7.834914590078317336d5 /
      data qf3 / 2.548289012949732752d2  ,
     *           2.099761536857815105d4  ,
     *           6.924122509827708985d5  ,
     *           9.178823229918143780d6  ,
     *           4.292733255630186679d7  ,
     *           4.803294784260528342d7 /
c++   end
c
c     coefficients for g(x), 1.6 < |X| <= 1.9
c++   code for digits <= 4 is inactive
c      data pg1 / 1.007011d-1, 1.457780d-1/, qg1 / 2.700253d0 /
c++   code for digits > 4 & digits <= 7 is inactive
c      data pg1 / 1.012500483d-1, 7.735207446d-1, 3.878282770d-1/
c      data qg1 / 9.101956178d0,  1.002234185d1 /
c++   code for digits > 7 & digits <= 10 is inactive
c      data pg1 / 1.013095436817d-1,  1.731937984173d0,
c     *           5.036588245265d0,   1.290707246507d0 /
c      data qg1 / 1.860077430076d1,   6.901951935725d1,
c     *           4.308918659989d1 /
c++   code for digits > 10 & digits <= 13 is inactive
c      data pg1 / 1.013188096509180d-1,  2.966220554725899d0,
c     *           2.015435299505393d1,   3.155605679387908d1,
c     *           4.916012830646366d0 /
c      data qg1 / 3.079178736724045d1,   2.362874318980473d2,
c     *           4.953861258248338d2,   2.026144493403599d2 /
c++   code for digits > 13 is active
      data pg1 / 1.013206188102747985d-1 ,
     *           4.445338275505123778d0  ,
     *           5.311228134809894481d1  ,
     *           1.991828186789025318d2  ,
     *           1.962320379716626191d2  ,
     *           2.054214324985006303d1 /
      data qg1 / 4.539250196736893605d1  ,
     *           5.835905757164290666d2  ,
     *           2.544731331818221034d3  ,
     *           3.481121478565452837d3  ,
     *           1.013794833960028555d3 /
c++   end
c
c     coefficients for g(x), 1.9 < |X| <= 2.4
c++   code for digits <= 4 is inactive
c      data pg2 / 1.011711d-1,  2.239630d-1/, qg2 / 3.609237d0 /
c++   code for digits > 4 & digits <= 7 is inactive
c      data pg2 / 1.013115463d-1,  1.182021191d0,  9.886315969d-1/
c      data qg2 / 1.317219285d1,   2.101104994d1 /
c++   code for digits > 7 & digits <= 10 is inactive
c      data pg2 / 1.013202025653d-1,  2.690767013770d0,
c     *           1.283624749271d1,   5.791337587723d0 /
c      data qg2 / 2.807457005500d1,   1.598704313522d2,
c     *           1.525630385045d2 /
c++   code for digits > 10 & digits <= 13 is inactive
c      data pg2 / 1.013210509409046d-1,  4.682769769757399d0,
c     *           5.241351613346472d1,   1.411735944550041d2,
c     *           4.019756012788710d1 /
c      data qg2 / 4.773652966704634d1,   5.802036967947208d2,
c     *           1.947179327244406d3,   1.266041236960445d3 /
c++   code for digits > 13 is active
      data pg2 / 1.01321161761804586d-1 ,
     *           7.11205001789782823d0  ,
     *           1.40959617911315524d2  ,
     *           9.08311749529593938d2  ,
     *           1.59268006085353864d3  ,
     *           3.13330163068755950d2 /
      data qg2 / 7.17128596939302198d1  ,
     *           1.49051922797329229d3  ,
     *           1.06729678030580897d4  ,
     *           2.41315567213369742d4  ,
     *           1.15149832376260604d4 /
c++   end
c
c     coefficients for g(x), 2.4 < |X|
c++   code for digits <= 3 is inactive
c      data pg3 /-1.3549d-1/
c++   code for digits > 3 & digits <= 5 is inactive
c      data pg3 /-1.5382824d-1, -6.4547464d-1/, qg3 / 1.0290328d1/
c++   code for digits > 5 & digits <= 8 is inactive
c      data pg3 /-1.5398760302d-1, -4.2772857997d0,
c     *          -6.5940181141d0 /
c      data qg3 / 3.4149986477d1,   1.7071708816d2 /
c++   code for digits > 8 & digits <= 10 is inactive
c      data pg3 /-1.539896971616d-1, -1.024638314446d1,
c     *          -1.252507402120d2,  -1.029189676144d2 /
c      data qg3 / 7.292229303754d1,   1.186528673248d3,
c     *           3.844430908476d3 /
c++   code for digits > 10 & digits <= 12 is inactive
c      data pg3 /-1.53989733057971d-1, -1.86483223831639d1,
c     *          -5.66882778026550d2,  -4.16714647017489d3,
c     *          -2.14678074364341d3 /
c      data qg3 / 1.27484298075273d2,   4.40258858159927d3,
c     *           4.57583830694684d4,   1.08207883281275d5 /
c++   code for digits = 13 is inactive
c      data pg3 /-1.539897338019247d-1, -2.959078231855258d1,
c     *          -1.661867087183632d3,  -3.112796454920657d4,
c     *          -1.573536286819766d5,  -5.574884113746041d4 /
c      data qg3 / 1.985439813544440d2,   1.196693134508007d4,
c     *           2.625573864512749d5,   1.969055829311119d6,
c     *           3.629081333313312d6 /
c++   code for digits > 13 is active
      data pg3 /-1.53989733819769316d-1 ,
     *          -4.31710157823357568d1  ,
     *          -3.87754141746378493d3  ,
     *          -1.35678867813756347d5  ,
     *          -1.77758950838029676d6  ,
     *          -6.66907061668636416d6  ,
     *          -1.72590224654836845d6 /
      data qg3 / 2.86733194975899483d2  ,
     *           2.69183180396242536d4  ,
     *           1.02878693056687506d6  ,
     *           1.62095600500231646d7  ,
     *           9.38695862531635179d7  ,
     *           1.40622441123580005d8 /
c++   end
c     ------------------------------------------------------------------
      if (bigx .lt. 0.0d0) then
         bigx = 1.0d0 / D1MACH(4)
         largef = rpi / D1MACH(1)
         largeg = (rpi * largef) ** (1.0d0 / 3.0d0)
         largex = 1.0d0/sqrt(sqrt(D1MACH(1)))
      end if
      if (x .ne. xsave) then
         havec = .false.
         havef = .false.
         haveg = .false.
         haves = .false.
      end if
      ax = abs(x)
      if (ax .le. 1.6d0) then
         x4 = ax**4
         if (needc(mode) .and. .not. havec) then
            if (ax .le. 1.2d0) then
c++             code for digits <= 3 is inactive
c               c = x * (pc1(1)*x4+pc1(0)) / (qc1(1)*x4+1.0d0)
c++             code for digits > 3 & digits <= 6 is inactive
c               c = x * ((pc1(2)*x4+pc1(1))*x4+pc1(0))
c     1               / ((qc1(2)*x4+qc1(1))*x4+1.0d0)
c++             code for digits > 6 & digits <= 11 is inactive
c               c = x * (((pc1(3)*x4+pc1(2))*x4+pc1(1))*x4+pc1(0))
c     1               / (((qc1(3)*x4+qc1(2))*x4+qc1(1))*x4+1.0d0)
c++             code for digits > 11 is active
               c = x * ((((pc1(4)*x4+pc1(3))*x4+pc1(2))*x4+pc1(1))*x4+
     1                     pc1(0))
     2           / ((((qc1(4)*x4+qc1(3))*x4+qc1(2))*x4+qc1(1))*x4+1.0d0)
c++             end
            else
c++             code for digits <= 2 is inactive
c               c = x * (pc2(1)*x4+pc2(0)) / (qc2(1)*x4+1.0d0)
c++             code for digits > 2 & digits <= 5 is inactive
c               c = x * ((pc2(2)*x4+pc2(1))*x4+pc2(0))
c     1               / ((qc2(2)*x4+qc2(1))*x4+1.0d0)
c++             code for digits > 5 & digits <= 8 is inactive
c               c = x * (((pc2(3)*x4+pc2(2))*x4+pc2(1))*x4+pc2(0))
c     1               / (((qc2(3)*x4+qc2(2))*x4+qc2(1))*x4+1.0d0)
c++             code for digits > 8 & digits <= 12 is inactive
c               c = x * ((((pc2(4)*x4+pc2(3))*x4+pc2(2))*x4+pc2(1))*x4+
c     1                   pc2(0))
c     2               / ((((qc2(4)*x4+qc2(3))*x4+qc2(2))*x4+qc2(1))*x4+
c     3                   1.0d0)
c++             code for digits > 12 is active
               c = x * (((((pc2(5)*x4+pc2(4))*x4+pc2(3))*x4+pc2(2))*x4+
     1                     pc2(1))*x4+pc2(0))
     2               / (((((qc2(5)*x4+qc2(4))*x4+qc2(3))*x4+qc2(2))*x4+
     3                   qc2(1))*x4+1.0d0)
c++             end
            end if
            havec = .true.
         end if
         if (needs(mode) .and. .not. haves) then
            if (ax .le. 1.2d0) then
c++             code for digits <= 3 is inactive
c               s = x**3*(ps1(1)*x4+ps1(0)) / (qs1(1)*x4+1.0d0)
c++             code for digits > 3 & digits <= 7 is inactive
c               s = x**3*((ps1(2)*x4+ps1(1))*x4+ps1(0))
c     1                / ((qs1(2)*x4+qs1(1))*x4+1.0d0)
c++             code for digits > 7 & digits <= 12 is inactive
c               s = x**3*(((ps1(3)*x4+ps1(2))*x4+ps1(1))*x4+ps1(0))
c     1                / (((qs1(3)*x4+qs1(2))*x4+qs1(1))*x4+1.0d0)
c++             code for digits > 12 is active
               s = x**3*((((ps1(4)*x4+ps1(3))*x4+ps1(2))*x4+ps1(1))*x4+
     1                      ps1(0))
     2           / ((((qs1(4)*x4+qs1(3))*x4+qs1(2))*x4+qs1(1))*x4+1.0d0)
c++             end
            else
c++             code for digits <= 2 is inactive
c               s = x**3*(ps2(1)*x4+ps2(0)) / (qs2(1)*x4+1.0d0)
c++             code for digits > 2 & digits <= 5 is inactive
c               s = x**3*((ps2(2)*x4+ps2(1))*x4+ps2(0))
c     1              /   ((qs2(2)*x4+qs2(1))*x4+1.0d0)
c++             code for digits > 5 & digits <= 9 is inactive
c               s = x**3*(((ps2(3)*x4+ps2(2))*x4+ps2(1))*x4+ps2(0))
c     1              /   (((qs2(3)*x4+qs2(2))*x4+qs2(1))*x4+1.0d0)
c++             code for digits > 9 & digits <= 14 is inactive
c               s = x**3*((((ps2(4)*x4+ps2(3))*x4+ps2(2))*x4+ps2(1))*x4+
c     1                      ps2(0))
c     2              /   ((((qs2(4)*x4+qs2(3))*x4+qs2(2))*x4+qs2(1))*x4+
c     3                      1.0d0)
c++             code for digits > 14 is active
               s = x**3*(((((ps2(5)*x4+ps2(4))*x4+ps2(3))*x4+ps2(2))*x4+
     1                      ps2(1))*x4+ps2(0))
     2              /   (((((qs2(5)*x4+qs2(4))*x4+qs2(3))*x4+qs2(2))*x4+
     3                      qs2(1))*x4+1.0d0)
c++             end
            end if
            haves = .true.
         end if
         if ((needf(mode) .or. needg(mode)) .and. .not. havef) then
            cx = dcspxx (ax)
            sx = dsnpxx (ax)
            f = (0.5d0 - s) * cx - (0.5d0 - c) * sx
            g = (0.5d0 - c) * cx + (0.5d0 - s) * sx
            havef = .true.
         end if
      else
         if (ax .le. largex) then
            x4 = (1.0d0 / ax) ** 4
            wantf = needf(mode+4) .and. .not. havef
            if (wantf) then
               if (ax .le. 1.9d0) then
c++                code for digits <= 5 is inactive
c                  f = (pf1(1)*x4+pf1(0)) / ((qf1(1)*x4+1.0d0) * ax)
c++                code for digits > 5 & digits <= 8 is inactive
c                  f = ((pf1(2)*x4+pf1(1))*x4+pf1(0))
c     1             / (((qf1(2)*x4+qf1(1))*x4+1.0d0) * ax)
c++                code for digits > 8 & digits <= 11 is inactive
c                  f = (((pf1(3)*x4+pf1(2))*x4+pf1(1))*x4+pf1(0))
c     1             / ((((qf1(3)*x4+qf1(2))*x4+qf1(1))*x4+1.0d0) * ax)
c++                code for digits > 11 & digits <= 14 is inactive
c                  f = ((((pf1(4)*x4+pf1(3))*x4+pf1(2))*x4+pf1(1))*x4+
c     1                    pf1(0))
c     2             / (((((qf1(4)*x4+qf1(3))*x4+qf1(2))*x4+qf1(1))*x4+
c     3                    1.0d0) * ax)
c++                code for digits > 14 is active
                  f = (((((pf1(5)*x4+pf1(4))*x4+pf1(3))*x4+pf1(2))*x4+
     1                    pf1(1))*x4+pf1(0))
     2             / ((((((qf1(5)*x4+qf1(4))*x4+qf1(3))*x4+qf1(2))*x4+
     3                    qf1(1))*x4+1.0d0) * ax)
c++                end
               else if (ax .le. 2.4) then
c++                code for digits <= 5 is inactive
c                  f = (pf2(1)*x4+pf2(0)) / ((qf2(1))*x4+1.0d0) * ax)
c++                code for digits > 5 & digits <= 8 is inactive
c                  f = ((pf2(2)*x4+pf2(1))*x4+pf2(0))
c     1             / (((qf2(2)*x4+qf2(1))*x4+1.0d0) * ax)
c++                code for digits > 8 & digits <= 11 is inactive
c                  f = (((pf2(3)*x4+pf2(2))*x4+pf2(1))*x4+pf2(0))
c     1             / ((((qf2(3)*x4+qf2(2))*x4+qf2(1))*x4+1.0d0) * ax)
c++                code for digits > 11 & digits <= 14 is inactive
c                  f = ((((pf2(4)*x4+pf2(3))*x4+pf2(2))*x4+pf2(1))*x4+
c     1                    pf2(0))
c     2             / (((((qf2(4)*x4+qf2(3))*x4+qf2(2))*x4+qf2(1))*x4+
c     3                    1.0d0) * ax)
c++                code for digits > 14 is active
                  f = (((((pf2(5)*x4+pf2(4))*x4+pf2(3))*x4+pf2(2))*x4+
     1                    pf2(1))*x4+pf2(0))
     2             / ((((((qf2(5)*x4+qf2(4))*x4+qf2(3))*x4+qf2(2))*x4+
     3                    qf2(1))*x4+1.0d0) * ax)
c++                end
               else
c++                code for digits <= 3 is inactive
c                  f = (rpi + x4*pf3(0)) / ax
c++                code for digits > 3 & digits <= 6 is inactive
c                  f = (rpi + x4*(pf3(1)*x4+pf3(0)) / (qf3(1)*x4+1.0d0))
c                      / ax
c++                code for digits > 6 & digits <= 9 is inactive
c                  f = (rpi +
c     1              x4*((pf3(2)*x4+pf3(1))*x4+pf3(0))
c     2            /    ((qf3(2)*x4+qf3(1))*x4+1.0d0)) / ax
c++                code for digits > 9 & digits <= 11 is inactive
c                  f = (rpi +
c     1              x4*(((pf3(3)*x4+pf3(2))*x4+pf3(1))*x4+pf3(0))
c     2            /    (((qf3(3)*x4+qf3(2))*x4+qf3(1))*x4+1.0d0)) / ax
c++                code for digits > 11 & digits <= 13 is inactive
c                  f = (rpi +
c     1              x4*((((pf3(4)*x4+pf3(3))*x4+pf3(2))*x4+pf3(1))*x4+
c     2                   pf3(0))
c     3            /    ((((qf3(4)*x4+qf3(3))*x4+qf3(2))*x4+qf3(1))*x4+
c     4                   1.0d0)) / ax
c++                code for digits > 13 & digits <= 15 is inactive
c                  f = (rpi +
c     1              x4*(((((pf3(5)*x4+pf3(4))*x4+pf3(3))*x4+pf3(2))*x4+
c     2                   pf3(1))*x4+pf3(0))
c     3            /    (((((qf3(5)*x4+qf3(4))*x4+qf3(3))*x4+qf3(2))*x4+
c     4                   qf3(1))*x4+1.0d0)) / ax
c++                code for digits > 15 is active
                  f = (rpi +
     1              x4*((((((pf3(6)*x4+pf3(5))*x4+pf3(4))*x4+pf3(3))*x4+
     2                   pf3(2))*x4+pf3(1))*x4+pf3(0))
     3            /    ((((((qf3(6)*x4+qf3(5))*x4+qf3(4))*x4+qf3(3))*x4+
     4                   qf3(2))*x4+qf3(1))*x4+1.0d0)) / ax
c++                end
               end if
               havef = .true.
            end if
            wantg = needg(mode+4) .and. .not. haveg
            if (wantg) then
               if (ax .le. 1.9d0) then
c++                code for digits <=4 is inactive
c                  g = (pg1(1)*x4+pg1(0)) / ((qg1(1)*x4+1.0d0) * ax**3)
c++                code for digits > 4 & digits <= 7 is inactive
c                  g = ((pg1(2)*x4+pg1(1))*x4+pg1(0))
c     1             / (((qg1(2)*x4+qg1(1))*x4+1.0d0) * ax**3)
c++                code for digits > 7 & digits <= 10 is inactive
c                  g = (((pg1(3)*x4+pg1(2))*x4+pg1(1))*x4+pg1(0))
c     1             / ((((qg1(3)*x4+qg1(2))*x4+qg1(1))*x4+1.0d0) *ax**3)
c++                code for digits > 10 & digits <= 13 is inactive
c                  g = ((((pg1(4)*x4+pg1(3))*x4+pg1(2))*x4+pg1(1))*x4+
c     1                    pg1(0))
c     2             / (((((qg1(4)*x4+qg1(3))*x4+qg1(2))*x4+qg1(1))*x4+
c     3                    1.0d0) * ax**3)
c++                code for digits > 13 is active
                  g = (((((pg1(5)*x4+pg1(4))*x4+pg1(3))*x4+pg1(2))*x4+
     1                    pg1(1))*x4+pg1(0))
     2             / ((((((qg1(5)*x4+qg1(4))*x4+qg1(3))*x4+qg1(2))*x4+
     3                    qg1(1))*x4+1.0d0) * ax**3)
c++                end
               else if (ax .le. 2.4d0) then
c++                code for digits <=4 is inactive
c                  g = (pg2(1)*x4+pg2(0)) / ((qg2(1)*x4+1.0d0) * ax**3)
c++                code for digits > 4 & digits <= 7 is inactive
c                  g = ((pg2(2)*x4+pg2(1))*x4+pg2(0))
c     1             / (((qg2(2)*x4+qg2(1))*x4+1.0d0) * ax**3)
c++                code for digits > 7 & digits <= 10 is inactive
c                  g = (((pg2(3)*x4+pg2(2))*x4+pg2(1))*x4+pg2(0))
c     1             / ((((qg2(3)*x4+qg2(2))*x4+qg2(1))*x4+1.0d0) *ax**3)
c++                code for digits > 10 & digits <= 13 is inactive
c                  g = ((((pg2(4)*x4+pg2(3))*x4+pg2(2))*x4+pg2(1))*x4+
c     1                    pg2(0))
c     2             / (((((qg2(4)*x4+qg2(3))*x4+qg2(2))*x4+qg2(1))*x4+
c     3                    1.0d0) * ax**3)
c++                code for digits > 13 is active
                  g = (((((pg2(5)*x4+pg2(4))*x4+pg2(3))*x4+pg2(2))*x4+
     1                     pg2(1))*x4+pg2(0))
     2             / ((((((qg2(5)*x4+qg2(4))*x4+qg2(3))*x4+qg2(2))*x4+
     3                    qg2(1))*x4+1.0d0) * ax**3)
c++                end
               else
c++                code for digits <=3 is inactive
c                  g = (rpisq + x4*pg3(0)) / ax**3
c++                code for digits > 3 & digits <= 5 is inactive
c                  g = (rpisq + x4*(pg3(1)*x4+pg3(0))
c     1            /    (qg3(1)*x4+1.0d0)) / ax**3
c++                code for digits > 5 & digits <= 8 is inactive
c                  g = (rpisq + x4*((pg3(2)*x4+pg3(1))*x4+pg3(0))
c     1            /    ((qg3(2)*x4+qg3(1))*x4+1.0d0)) / ax**3
c++                code for digits > 8 & digits <= 10 is inactive
c                  g = (rpisq +
c     1              x4*(((pg3(3)*x4+pg3(2))*x4+pg3(1))*x4+pg3(0))
c     2            /    (((qg3(3)*x4+qg3(2))*x4+qg3(1))*x4+1.0d0))
c     3            / ax**3
c++                code for digits > 10 & digits <= 12 is inactive
c                  g = (rpisq +
c     1              x4*((((pg3(4)*x4+pg3(3))*x4+pg3(2))*x4+pg3(1))*x4+
c     2                     pg3(0))
c     3            /    ((((qg3(4)*x4+qg3(3))*x4+qg3(2))*x4+qg3(1))*x4+
c     4                     1.0d0)) / ax**3
c++                code for digits = 13 is inactive
c                  g = (rpisq +
c     1              x4*(((((pg3(5)*x4+pg3(4))*x4+pg3(3))*x4+pg3(2))*x4+
c     2                      pg3(1))*x4+pg3(0))
c     3            /    (((((qg3(5)*x4+qg3(4))*x4+qg3(3))*x4+qg3(2))*x4+
c     4                      qg3(1))*x4+1.0d0)) / ax**3
c++                code for digits > 13 is active
                  g = (rpisq +
     1              x4*((((((pg3(6)*x4+pg3(5))*x4+pg3(4))*x4+pg3(3))*x4+
     2                   pg3(2))*x4+pg3(1))*x4+pg3(0))
     3            /    ((((((qg3(6)*x4+qg3(5))*x4+qg3(4))*x4+qg3(3))*x4+
     4                   qg3(2))*x4+qg3(1))*x4+1.0d0)) / ax**3
c++                end
               end if
               haveg = .true.
            end if
         else
            wantf = needf(mode)
            if (wantf) then
               if (x .le. largef) then
                  f = rpi / ax
               else
                  f = 0.0d0
               end if
            end if
            wantg = needg(mode)
            if (wantg) then
               if (x .le. largeg) then
                  g = rpisq / ax**3
               else
                  g = 0.0d0
               end if
            end if
         end if
         wantc = (needc(mode+4) .or. needs(mode+4)) .and. .not. havec
         if (wantc .or. x.lt.0.0d0) then
            cx = dcspxx (ax)
            sx = dsnpxx (ax)
            if (wantc) then
               c = 0.5d0 + f*sx - g*cx
               s = 0.5d0 - f*cx - g*sx
               if (x .lt. 0.0) then
                  c = -c
                  s = -s
               end if
               havec = .true.
            end if
            if (x .lt. 0.0) then
c              We COULD do the following before the preceeding, and then
c              not put in a test in the preceeding for x .lt. 0, but
c              even though the results are mathematically identical, we
c              would have some cancellation above if we did so.
               if (wantg) g = cx + sx - g
               if (wantf) f = cx - sx - f
            end if
          end if
      end if
      xsave = x
      go to (1, 2, 3, 4), MODE
    1    DFREN1 = c
         return
    2    DFREN1 = s
         return
    3    DFREN1 = f
         return
    4    DFREN1 = g
         return
      end


*DECK DMNORM
      DOUBLE PRECISION FUNCTION DMNORM (N, V, W)
C-----------------------------------------------------------------------
C This function routine computes the weighted max-norm
C of the vector of length N contained in the array V, with weights
C contained in the array w of length N:
C   DMNORM = MAX(i=1,...,N) ABS(V(i))*W(i)
C-----------------------------------------------------------------------
      INTEGER N,   I
      DOUBLE PRECISION V, W,   VM
      DIMENSION V(N), W(N)
      VM = 0.0D0
      DO 10 I = 1,N
 10     VM = MAX(VM,ABS(V(I))*W(I))
      DMNORM = VM
      RETURN
C----------------------- End of Function DMNORM ------------------------
      END


c subroutine xfit.f
c
c source
c   Bevington, page 76.
c
c purpose
c   calculate the mean and estimated errors for a set of data points
c
c usage
c   call xfit (x, sigmax, npts, mode, xmean, sigmam, sigma)
c
c description of parameters
c   x      - array of data points
c   sigmax - array of standard deviations for data points
c   npts   - number of data points
c   mode   - determines method of weighting
c            +1 (instrumental) weight(i) = 1./sigmax(i)**2
c             0 (no weighting) weight(i) = 1.
c            -1 (statistical)  weight(i) = 1.
c   xmean  - weighted mean
c   sigmam - standard deviation of mean
c   sigma  - standard deviation of data
c
c subroutines and function subprograms required
c   none
c
	subroutine xfit (x,sigmax,npts,mode,xmean,sigmam,sigma)
	double precision sum,sumx,weight,free
	dimension x(1),sigmax(1)
c
c accumulate weighted sums
c
11	sum=0.
	sumx=0.
	sigma=0.
	sigmam=0.
20	do 32 i=1,npts
21	if (mode) 22,22,24
22	weight=1.
	goto 31
24	weight=1./sigmax(i)**2
31	sum=sum+weight
32	sumx=sumx+weight*x(i)
c
c evaluate mean and standard deviations
c
41	xmean=sumx/sum
51	do 52 i=1,npts
52	sigma=sigma+(x(i)-xmean)**2
	free=npts-1
54	sigma=dsqrt(sigma/free)
61	if (mode) 62,64,66
62	sigmam=dsqrt(xmean/sum)
	goto 70
64	sigmam=sigma/dsqrt(sum)
	goto 70
66	sigmam=dsqrt(1./sum)
70	return
	end


!-------------------------------------------------------------------------
!Author: Matias Pablo, Borghi Orue
!Title: 2D Monte Carlo simulation of the Ising Model
!Version: 1
!Comments:  $ gfortran ranmar_seed.f95 subroutines.f95 kawasaki.f95 -o runv1
!INPUTS: None
!OUTPUTS: Two dat files: 'Magnetization30L.dat' and 'Energy30L.dat'
!-------------------------------------------------------------------------
program kawasaki

use subroutines
use rm
implicit none

	integer::nrows,ncols, average
	integer::posx,posy,dim
	integer:: MCS, EquilSteps, NumofTempPoints
	integer:: i,k,indexTemp !Dummy indeces
	integer :: index1, index2
	integer::exchangeSpin
	integer::Delta_E
	integer,allocatable::matriz(:,:)
	integer,allocatable::ip(:),im(:)
	integer::promediateCounter = 0
	real::rvec(1)
	real,allocatable::MagnetizationAver(:), MagnetizationAver2(:),MagnetizationAver4(:),EnergyAver(:),EnergyAver2(:)
	real,dimension(3)::DeltaE
	real::Tmax,Tmin,TempInterval,currentTemp,beta
	character(len=100)::MagFile ='Magnetization20L.dat', EnergFile = 'Energy20L.dat'

	! Read in input parameters from file "ising.in"
	open(unit=11,file="ConfigurationFile",status="old",action="read")
	read(11,*);read(11,*) nrows
	read(11,*);read(11,*) ncols
	read(11,*);read(11,*) MCS
	read(11,*);read(11,*) EquilSteps
	read(11,*);read(11,*) Tmax
	read(11,*);read(11,*) Tmin
	read(11,*);read(11,*) TempInterval
	read(11,*);read(11,*) average
	close(11)
	! Set the dimensions of the matrix of spin arrays. This program uses
	! periodic boundary conditions, so the first two rows and columns are
	! the same as the last two.
	allocate(matriz(nrows,ncols))

	allocate(MagnetizationAver(average))
	allocate(MagnetizationAver2(average))
	allocate(MagnetizationAver4(average))
	allocate(EnergyAver(average))
	allocate(EnergyAver2(average))

	!Change this to take in count that the matrix can be rectangular
	allocate(im(nrows))
	allocate(ip(nrows))

	do i = 1,nrows
		ip(i) = i+1
		im(i) = i-1
	end do
	ip(nrows) = 1
	im(1) = nrows

	dim = nrows*ncols
	MCS = dim*10
	EquilSteps = int (0.5*MCS)

	if ( EquilSteps >= MCS ) then
		STOP 'Change the value of EquilSteps in the Configuration File! It can not be greater than MCS'
	end if

	print *, "MCS = ",MCS, " EquilSteps = ", EquilSteps
	NumofTempPoints = int ( (Tmax - Tmin)/TempInterval ) + 1
	!If the file exists overwrite erase it.
	open (UNIT=1, FILE=MagFile,ACTION='write',STATUS='replace')
	write(1,*) "Temperature AverMagnetization AverMagnetization^2 Suceptibility Cumulant"
	open (UNIT=33, FILE=EnergFile,ACTION='write',STATUS='replace')
	write(33,*) "Temperature AverEnergy AverEnergy^2 C_v"

	!Initialize the matrix
	!with spin-up initial values
	call ini_matriz(matriz,nrows,ncols)

	do indexTemp = 1,NumofTempPoints !Loop over all the temperatures from Tmax to Tmin
		!Change the temperature value
		call New_Temp(indexTemp,currentTemp,Tmax,Tmin,TempInterval)
		beta = 1.0/currentTemp
		print *, "Current Temperature T = ", currentTemp

		!Initialize some variables to zero
		call SetToZeroVariables(MagnetizationAver,MagnetizationAver2, &
									MagnetizationAver4,EnergyAver,EnergyAver2,average)

		!Define the values of DeltaE knowing the Temperature
		!Only two possible values
		! 1) DeltaE(1) = exp(-4/Temp)
		! 2) DeltaE(2) = exp(-8/Temp)
		call Inicializacion_DeltaE(DeltaE,currentTemp)

		do k = 1 , average
			promediateCounter = 0
			!Choose a random point (posx,posy) where we begin calculating
			call elegir_sitio(nrows,ncols,posx,posy)

			!Sum over one MonteCarlo time //dim = 1MC
			!Sum over A MonteCarlo time: A*dim
			!In the next loop we flip a sping according to some conditions
			do i=1,MCS
				!Calculate the Magnetization and Energy after equilibrium
				if (i > EquilSteps ) then
					promediateCounter = promediateCounter + 1
					call CalculationsINequilibrium (nrows,ncols,matriz,Delta_E,EnergyAver,EnergyAver2, &
										MagnetizationAver,MagnetizationAver2,MagnetizationAver4,k,average,ip,im)

				end if
				!Calculate DeltaE for a given point (posx,posy)
				call CalcDeltaEnergy(nrows,ncols,posx,posy,matriz,Delta_E,ip,im)
				!print *, "Delta E: ",Delta_E
				! ..Flipping Spin..
				!If the new Energy spin-state is negative with flip the spin
				!If not it will depend on the probability exp(-DeltaE/Temp) > random point
				if (Delta_E <= 0) then
					exchangeSpin = matriz(posx,posy)
					if (posx == nrows) then
						matriz(posx,posy) = matriz(1,posy)
						matriz(1,posy) = exchangeSpin
					else
						matriz(posx,posy) = matriz(posx + 1,posy)
						matriz(posx+1,posy) = exchangeSpin
					end if
				else if(Delta_E == 4) then
					call ranmar(rvec,1)
					if( DeltaE(1) > rvec(1) ) then
						exchangeSpin = matriz(posx,posy)
						if (posx == nrows) then
							matriz(posx,posy) = matriz(1,posy)
							matriz(1,posy) = exchangeSpin
						else
							!print *,"OLD Pos x y: ", matriz(posx,posy)," Posx+1,y: ",matriz(posx+1,posy)
							matriz(posx,posy) = matriz(posx + 1,posy)
							matriz(posx+1,posy) = exchangeSpin
						end if
						!print *,"Spin exchanged for DeltaE = 1"
						!print *, "NEW Pos x y: ", matriz(posx,posy)," Posx+1,y: ",matriz(posx+1,posy)
					end if
				else if(Delta_E == 8) then
					call ranmar(rvec,1)
					if( DeltaE(2) > rvec(1) ) then
						exchangeSpin = matriz(posx,posy)
						if (posx == nrows) then
							matriz(posx,posy) = matriz(1,posy)
							matriz(1,posy) = exchangeSpin
						else
							matriz(posx,posy) = matriz(posx + 1,posy)
							matriz(posx+1,posy) = exchangeSpin
						end if
						!print *,"Spin exchanged for DeltaE = 6"
					end if
				else if(Delta_E == 12) then
					call ranmar(rvec,1)
					if( DeltaE(3) > rvec(1) ) then
						exchangeSpin = matriz(posx,posy)
						if (posx == nrows) then
							matriz(posx,posy) = matriz(1,posy)
							matriz(1,posy) = exchangeSpin
						else
							matriz(posx,posy) = matriz(posx + 1,posy)
							matriz(posx+1,posy) = exchangeSpin
						end if
						!print *,"Spin exchanged for DeltaE = 6"
					end if
				else
					STOP 'Error Delta_E take a value that is not one of the desired!!'
				end if

				!Choose a new random point (posx,posy) where we begin calculating
				call elegir_sitio(nrows,ncols,posx,posy)
				!----------------------------------------------------------------
				!-----PRINTF IN DYNAMIC LATTICE ---------------------------------
				!do index1=1,nrows
				!	do index2=1,ncols
				!		write(*,*) index1,index2,matriz(index1,index2)
				!	end do
				!end do
				!----------------------------------------------------------------
			end do !End loop of the MC steps
		end do ! End loop of averages
		!Write the results in a file
		call Write2File(promediateCounter, beta,currentTemp, MagnetizationAver,MagnetizationAver2, &
						MagnetizationAver4,EnergyAver,EnergyAver2,average)
	end do !End loop of Temperatures

	close(1)
	close(33)
end program kawasaki


module Trigmul
    use Def_prec
    implicit none

contains
    ! тут массивы с единицы, надо подумать прежде чем передать n из остальной
    ! части проги
    function trdmatmul(a, b, n) result(c)
            real(mpc), intent(in), dimension(n, 3) :: a, b
!             real(mpc), intent(in), dimension(n), optional :: weigths
            integer, intent(in) :: n
            real(mpc), dimension (n, 5) :: c
            integer :: i

            c(3:n  , 1) = a(3:n, 1)*b(2:n-1, 1)
            c(2:n  , 2) = a(2:n,1)*b(1:n-1, 2) + a(2:n, 2)*b(2:n,1)

            c(1:n  , 3) = a(:, 2)*b(:, 2)
            c(2:n  , 3) = c(2:n, 3) + a(2:n, 1)*b(1:n-1, 3)
            c(1:n-1, 3) = c(1:n-1, 3) + a(1:n-1, 3)*b(2:n, 1)

            c(1:n-1, 4) = a(1:n-1, 2)*b(1:n-1, 3) + a(1:n-1, 3)*b(2:n, 2)
            c(1:n-2, 5) = a(1:n-2, 3)*b(2:n-1, 3)

    end function trdmatmul

    function transptrd(a, n) result(aT)
        integer :: n
        real(mpc), intent(in), dimension(n, 3) :: a
        real(mpc), dimension(n, 3) :: aT

        aT = a
        aT(1:n-1, 3) = a(2:n, 1)
        aT(2:n, 1) = a(1:n-1, 1)

    end function transptrd

    ! умножение трёхдиагональной матрицы на вектор (линейный оператор)
    function trdlinop(a, x, n) result(y)
        integer, intent(in) :: n
        real(mpc), intent(in) :: a(n,3), x(n)
        real(mpc), dimension (n) :: y
        integer :: i
        y(1) = sum(a(1, 2:3)*x(1:2))
        y(n) = sum(a(n, 1:2)*x(n-1:n))
        forall (i = 2:n-1) y(i) = dot_product(a(i, :), x(i-1:i+1))
    end function trdlinop

end module Trigmul


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program circ_stats
!===============================================================================
!  Returns some circular statistics

   use statistical, only: circ_mean, circ_res_length, circ_variance

   implicit none

   integer, parameter :: nmax = 100000
   real(8) :: atemp, a(nmax)
   integer :: n, iostatus

   if (command_argument_count() /= 0) then
      write(0,'(a)') 'Usage: circ_stats < [list of angles (degrees)]'
      stop
   endif

!  Read values from stdin
   iostatus = 0
   n = 0
   do while (iostatus == 0)
      read(*,*,iostat=iostatus) atemp
      if (iostatus > 0) then    ! Bad input
         write(0,'(a)') 'circ_stats: Error: problem reading from stdin.'
         stop
      endif
      if (iostatus < 0) exit    ! EOF

      if (n+1 > nmax) then      ! Read past compiled limits of a(nmax)
         write(0,'(a,i0.1,a)') 'circ_stats: Error: Compiled max no. data is ', &
           nmax, '.  Current datum is beyond that.  Recompile with larger nmax.'
         stop
      endif

      a(n+1) = atemp
      n = n + 1
   enddo

!  Calculate statistics and write them out
   write(*,'("n = ",i0,"  Mean = ",f0.5,"  R = ",f0.5,"  Var = ",f0.6)') &
         n, circ_mean(a(1:n)), circ_res_length(a(1:n)), circ_variance(a(1:n))

end program


! Demonstrates the units of a scaling function. doubler is polymorphic
! in its units (it takes an 'a and gives an 'a).

! > camfort units-infer poly-scale.f90
! Inferring units for 'poly-scale.f90'
! Finished running unit inference on input 'poly-scale.f90' ...
! Logs:
!
! Result... OK:
!
! poly-scale.f90:
!   24:11 unit s :: t
!   29:1 unit 'a :: doubler
!   30:10 unit 'a :: x
!   31:13 unit 1 :: k
!
! Note: how doubler takes an x of unit 'a and returns an 'a.
!
! Note: k is a literal in a polymorphic context and camfort assumes it
! to be unitless

program main
  != unit(s) :: t
  real :: t
  t = 1
  t = doubler(t)
end program main

real function doubler(x)
    real x
    real :: k = 2
    doubler = k*x
end function


C SUBROUTINE GRIDLS.F
C
C SOURCE
C   BEVINGTON, PAGES 212-213.
C
C PURPOSE
C   MAKE A GRID-SEARCH LEAST-SQUARES FIT TO DATA WITH A SPECIFIED
C   FUNCTION WHICH IS NOT LINEAR IN COEFFICIENTS
C
C USAGE
C   CALL GRIDLS (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA,
C      SIGMAA, YFIT, CHISQR)
C
C DESCRIPTION OF PARAMETERS
C   X	   - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE
C   Y	   - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
C   SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS
C   NPTS   - NUMBER OF PAIRS OF DATA POINTS
C   NTERMS - NUMBER OF PARAMETERS
C   MODE   - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT
C	     +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
C	      0 (NO WEIGHTING) WEIGHT(I) = 1.
C	     -1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
C   A	   - ARRAY OF PARAMETERS
C   DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A
C   SIGMAA - ARRAY OF STANDARD DEVIATIONS FOR PARAMETERS A
C   YFIT   - ARRAY OF CALCULATED VALUES OF Y
C   CHISQR - REDUCED CHI SQUARE FOR FIT
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   FUNCTN (X, I, A)
C      EVALUATES THE FITTING FUNCTION FOR THE ITH TERM
C   FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT)
C      EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA
C
C COMMENTS
C   DELTAA VALUES ARE MODIFIED BY THE PROGRAM
C
      SUBROUTINE GRIDLS (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA,
     *SIGMAA,YFIT,CHISQR)
      DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),SIGMAA(1),
     *YFIT(1)
      REAL FUNCTN
      EXTERNAL FUNCTN

C
11    NFREE=NPTS-NTERMS
      FREE=NFREE
      CHISQR=0.
      IF (NFREE) 100,100,20
20    DO 90 J=1,NTERMS
C
C EVALUATE CHI SQUARE AT FIRST TWO SEARCH POINTS
C
21    DO 22 I=1,NPTS
22    YFIT(I)=FUNCTN (X,I,A)
23    CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
      FN=0.
      DELTA=DELTAA(J)
41    A(J)=A(J)+DELTA
      DO 43 I=1,NPTS
43    YFIT(I)=FUNCTN (X,I,A)
44    CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
45    IF (CHISQ1-CHISQ2) 51,41,61
C
C REVERSE DIRECTION OF SEARCH IF CHI SQUARE IS INCREASING
C
51    DELTA=-DELTA
      A(J)=A(J)+DELTA
      DO 54 I=1,NPTS
54    YFIT(I)=FUNCTN (X,I,A)
      SAVE=CHISQ1
      CHISQ1=CHISQ2
57    CHISQ2=SAVE
C
C INCREMENT A(J) UNTIL CHI SQUARE INCREASES
C
61    FN=FN+1.
      A(J)=A(J)+DELTA
      DO 64 I=1,NPTS
64    YFIT(I)=FUNCTN (X,I,A)
      CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
66    IF (CHISQ3-CHISQ2) 71,81,81
71    CHISQ1=CHISQ2
      CHISQ2=CHISQ3
      GOTO 61
C
C FIND MINIMUM OF PARABOLA DEFINED BY LAST THREE POINTS
C
81    DELTA=DELTA*(1./(1.+(CHISQ1-CHISQ2)/(CHISQ3-CHISQ2))+0.5)
82    A(J)=A(J)-DELTA
83    SIGMAA(J)=DELTAA(J)*SQRT(2./(FREE*(CHISQ3-2.*CHISQ2+CHISQ1)))
84    DELTAA(J)=DELTAA(J)*FN/3.
90    CONTINUE
C
C EVALUATE FIT AND CHI SQUARE FOR FINAL PARAMETERS
C
91    DO 92 I=1,NPTS
92    YFIT(I)=FUNCTN (X,I,A)
93    CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
100   RETURN
      END


C Work performed under the auspices of the U.S. Department of Energy
C by Lawrence Livermore National Laboratory under contract number
C W-7405-Eng-48.
C
C Copyright 1995 the Regents of the University of California.
C All rights reserved.
C
C***BEGIN PROLOGUE  DHEATILU
C***REFER TO  DDASPK
C***DATE WRITTEN   951005   (YYMMDD)
C***REVISION DATE  951005   Reworking of heat example using banded J
C***REVISION DATE  990117   Sensitivity analysis for parameters
C
C***DESCRIPTON
C
C-----------------------------------------------------------------------
C Example program for DDASPK.
C DAE system derived from the discretized heat equation on a square.
C
C This is the double precision version.
C-----------------------------------------------------------------------
C
C This program solves a DAE system that arises from the heat equation,
C   du/dt = u   + u
C            xx    yy
C posed on the 2-D unit square with zero Dirichlet boundary conditions.
C An M+2 by M+2 mesh is set on the square, with uniform spacing 1/(M+1).
C The spatial deriviatives are represented by standard central finite
C difference approximations.  At each interior point of the mesh,
C the discretized PDE becomes an ODE for the discrete value of u.
C At each point on the boundary, we pose the equation u = 0.  The
C discrete values of u form a vector U, ordered first by x, then by y.
C The result is a DAE system G(t,U,U') = 0 of size NEQ = (M+2)*(M+2).
C
C Initial conditions are posed as u = 16x(1-x)y(1-y) at t = 0.
C The problem is solved by DDASPK on the time interval t .le. 10.24.
C
C The Krylov linear system solution method, with preconditioning, is
C selected.  The preconditioner is a sparse matrix with half-bandwidths
C equal to 1, i.e. a tridiagonal matrix.  (The true half-bandwidths
C are equal to M+2.)  This corresponds to ignoring the y-direction
C coupling in the ODEs, for purposes of preconditioning.  The extra
C iterations resulting from this approximation are offset by the lower
C storage and linear system solution costs for a tridiagonal matrix.
C
C The routines DJACILU and DPSOLILU that generate and solve the sparse
C preconditioner are provided in a separate file for general use.
C
C The output times are t = .01 * 2**n (n = 0,...,10).  The maximum of
C abs(u) over the mesh, and various performance statistics, are printed.
C
C For details and test results on this problem, see the reference:
C   Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C   Using Krylov Methods in the Solution of Large-Scale Differential-
C   Algebraic Systems, SIAM J. Sci. Comput., 15 (1994), pp. 1467-1488.
C-----------------------------------------------------------------------
C
C***ROUTINES CALLED
C   UINIT, DDASPK
C
C***END PROLOGUE  DHEATILU
C
C Here are necessary declarations.  The dimension statements use a
C maximum value for the mesh parameter M.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL RESH, DJACILU, DPSOLILU, QRES
C Load parameters for sparse preconditioner.
      PARAMETER (LENPFAC = 5)   ! the average number of non-zeros
      PARAMETER (LENPLUFAC = 5)
      PARAMETER (IPREMETH = 1)  ! =1 means ILUT preconditioner used
                                ! =2 means ILUTP preconditioner used
                                ! =3 ILUD
                                ! =4 ILUDP
      PARAMETER (LFILILUT = 5)
      PARAMETER (IREORDER = 1)
      PARAMETER (ISRNORM = 1)
      PARAMETER (NORMTYPE = 2)
      PARAMETER (JACOUT = 0)
      PARAMETER (JSCALCOL = 1)
      PARAMETER (TOLILUT = 0.001)
      PARAMETER (PERMTOL = 0.01)
C Load workspace lengths.
      parameter (Npara=20)
      PARAMETER (MAXM = 50, MAXM2 = MAXM+2, MXNEQ=(npara+6)*MAXM2*MAXM2)
      PARAMETER (MXNY = MAXM2*MAXM2)
      PARAMETER (LENWP = 2*LENPFAC*MXNY + LENPLUFAC*MXNY
     .                   + ISRNORM*MXNY + 2*(MXNY+1) )
C      PARAMETER (LENWP = 2*LENPFAC*MXNEQ + LENPLUFAC*MXNEQ
C     .                   + ISRNORM*MXNEQ + 2*(MXNEQ+1) )
C      PARAMETER (LENIWP = 4*(MXNEQ+1) + 3*LENPFAC*MXNEQ
C     .                    + 2*LENPLUFAC*MXNEQ + IREORDER*2*MXNEQ
C     .                    + (IPREMETH-1)*2*MXNEQ )
      PARAMETER (LENIWP = 4*(MXNY+1) + 3*LENPFAC*MXNY
     .                    + 2*LENPLUFAC*MXNY + IREORDER*2*MXNY
     .                    + (IPREMETH-1)*2*MXNY )
      PARAMETER (LENRW = 91 + 18*MXNEQ, LENIW  = 40)
      DIMENSION U(MXNEQ),UPRIME(MXNEQ),
     *          RWORK(LENRW+LENWP),IWORK(LENIW+LENIWP)
*      DIMENSION INFO(20), RPAR(4), IPAR(34)
      DIMENSION INFO(30), RPAR(4), IPAR(35), SENPAR(2), QSEN(100)
      real*4   t1, t2, t3, tt(2),secnds
c
c === CPU time set-up
c
C Set LOUT, the unit number of the output device.
      LOUT = 6

C Open output file if JACOUT .EQ. 1.
      IF (JACOUT .EQ. 1) THEN
         IPAR(29) = 1
         OPEN(UNIT=1, FILE='Heat_Test_Matrix.dat', STATUS='unknown')
      ENDIF
C
C Here set parameters for the problem being solved.  Use RPAR and IPAR
C to communicate these to the other routines.
C
      M = 40
c      M = MAXM
      DX = 1.0D0/(M+1)
      NEQ = (M+2)*(M+2)
      COEFF = 1.0D0/(DX*DX)
      IPAR(33) = NEQ
      IPAR(34) = M
      RPAR(3) = DX
      RPAR(4) = COEFF
      SENPAR(1) = 1.0d0
      SENPAR(2) = 1.0d0
C
C Here set the lengths of the preconditioner work arrays WP and IWP,
C load them into IWORK, and set the total lengths of WORK and IWORK.
      IWORK(27) = LENWP
      IWORK(28) = LENIWP
      LRW = LENRW + LENWP
      LIW = LENIW + LENIWP
C Load values into IPAR and RPAR for sparse preconditioner.
      ML = M+3
      MU = ML
      IPAR(1) = ML
      IPAR(2) = MU
      MBAND = ML + MU + 1
      IPAR(3) = LENPFAC
      IPAR(4) = LENPLUFAC
      IPAR(5) = IPREMETH
      IPAR(6) = LFILILUT
      IPAR(7) = IREORDER
      IPAR(8) = ISRNORM
      IPAR(9) = NORMTYPE
      IPAR(10) = JACOUT
      IPAR(11) = JSCALCOL
      IPAR(12) = 0          ! Jacobian evaluation method
      IPAR(13) = 0          ! data dependence for rpar(*)
      IPAR(30) = 0
      RPAR(1) = TOLILUT
      RPAR(2) = PERMTOL
C Check IPAR, RPAR, LENWP and LENIWP for illegal entries and long
C enough work array lengths.
      CALL DSPSETUP (NEQ, LENWP, LENIWP, RPAR, IPAR, IERR,
     .               LWPMIN, LIWPMIN)
      IF (IERR .NE. 0) THEN
         WRITE(LOUT,15) IERR
 15      FORMAT(' Error return from DSPSETUP: IERR = ',i5)
         IF (LWPMIN .GT. LENWP) THEN
            WRITE(LOUT,*) ' More WP work array length needed'
         ENDIF
         IF (LIWPMIN .GT. LENIWP) THEN
            WRITE(LOUT,*) ' More IWP work array length needed'
         ENDIF
         STOP
      ENDIF
C
C-----------------------------------------------------------------------
C Here we set up the INFO array, which describes the various options
C in the way we want DDASPK to solve the problem.
C In this case, we select the iterative preconditioned Krylov method,
C and we supply the sparse preconditioner routines DJACILU/DPSOLILU.
C
C We first initialize the entire INFO array to zero, then set select
C entries to nonzero values for desired solution options.
C
C To select the Krylov iterative method for the linear systems,
C we set INFO(12) = 1.
C
C Since we are using a preconditioner that involves approximate
C Jacobian elements requiring preprocessing, we have a JAC routine,
C namely subroutine DJACILU, and we must set INFO(15) = 1 to indicate
C this to DDASPK.
C
C No other entries of INFO need to be changed for this example.
C-----------------------------------------------------------------------
C
      DO 20 I = 1,30
 20     INFO(I) = 0
C
      INFO(12) = 1
      INFO(15) = 1
c---------------------------------------------------------------
c  sensitivity analysis
c---------------------------------------------------------------
      inso = 18
      info(inso+1) = npara
      print *, ' number of sensitivities? (0..20) '
      read(*,*) info(inso+1)
      neq = neq*(info(inso+1) + 1)
      ipar(35) = info(inso+1)
      if (info(inso+1) .eq. 0) go to 25
      info(inso+2) = 2          ! 0, central, 1, forward, 2 supply
      print *, ' method for computing sensitivity residues:(0,1,2) '
      print *, '    0: central differencing '
      print *, '    1: one-side forward differencing '
      print *, '    2: user supply '
      read (*,*) info(inso+2)
      info(inso+3) = 0          ! default perturbed factor
      info(inso+4) = 2          ! two parameter appears in the RES
      info(inso+5) = 0          ! 0, full control 1. partial control
      print *, ' Error control: (0,1)'
      print *, '    0: full error control with sensitivity '
      print *, '    1: partial error control on state variables only '
      read(*, *) info(inso+5)
      info(inso+6) = 1          ! one derived information
      info(inso+7) = 1          ! simultaneous corrector(0), staggered(1)
      print *, ' Corrector method: (0, 1)'
      print *, '    0:  simultaneous corrector method '
      print *, '    1:  staggered corrector method'
      read(*,*) info(inso+7)
 25   continue
      iwork(38) = 0
      print *, info(20)
C
C Call subroutine UINIT to initialize U and UPRIME.
C
      CALL UINIT (U, UPRIME, RPAR, IPAR)
C
C Here we set tolerances for DDASPK to indicate how much accuracy
C we want in the solution, in the sense of local error control.
C For this example, we ask for pure absolute error control with a
C tolerance of 1.0D-3.
      RTOL = 1.0d-4
      ATOL = 1.0D-4
C
C Here we generate a heading with important parameter values.
C
      WRITE (LOUT,30) M,NEQ,INFO(12),ML,MU,IPREMETH,RTOL,ATOL
 30   FORMAT(' Heat Equation for DDASPK'//
     1       '    M+2 by M+2 mesh, M =',I3,',  System size NEQ =',I4//
     1       '    Linear solver method flag INFO(12) =',I3,
     1       '    (0 = direct, 1 = Krylov)'/
     1       '    Preconditioner is a sparse approximation with ML =',
     1            I3,'  MU =',I3/
     1       '    Incomplete factorization option =',I2,
     1       '    (1=ILUT,  2=ILUTP, 3=ILUD,'/
     1       '                                       ',
     1       '     4=ILUDP, 5=ILU0,  6=MILU0)'/,
     1       '    Tolerances are RTOL =',E10.1,'   ATOL =',E10.1//)
      WRITE (LOUT,40)
 40   FORMAT(5X,'t',12X,'UMAX',8X,'NQ',8X,'H',8X,'STEPS',
     1       5X,'NNI',5X,'NLI', 2x, 'Time'/)
C
C-----------------------------------------------------------------------
C Now we solve the problem.
C
C DDASPK will be called to compute 11 intermediate solutions from
C tout = 0.01 to tout = 10.24 by powers of 2.
C
C We pass to DDASPK the names DJACILU and DPSOLILU for the JAC and PSOL
C routines to do the preconditioning.
C
C At each output time, we compute and print the max-norm of the
C solution (which should decay exponentially in t).  We also print
C some relevant statistics -- the current method order and step size,
C the number of time steps so far, and the numbers of nonlinear and
C linear iterations so far.
C
C If DDASPK failed in any way (IDID .lt. 0) we print a message and
C stop the integration.
C-----------------------------------------------------------------------
C
      NOUT = 11
      T = 0.0D0
      TOUT = 0.01D0
      t1 = dtime(tt)
      t1 = secnds(0.0e0)

      DO 70 IOUT = 1,NOUT
 55      continue
         CALL DDASPK (
     1        RESH, NEQ, T, U, UPRIME, TOUT, INFO, RTOL, ATOL,
     1        IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR,
     1        DJACILU, DPSOLILU, SENPAR, H_RES)
         CALL DSENSD(
     *        QRES, NEQ, T, U, UPRIME, QSEN, INFO,
     *        RWORK, IWORK, IRES, RPAR, IPAR, SENPAR)
C
c         write(20, *) qsen(1), qsen(2), qsen(3)
         IF (IDID .EQ. 1) GOTO 55
         UMAX = 0.0D0
         DO I = 1,NEQ/(info(inso+1)+1)
            UMAX = MAX (UMAX, ABS(U(I)) )
         END DO
         HU = RWORK(7)
         NQU = IWORK(8)
         NST = IWORK(11)
         NNI = IWORK(19)
         NLI = IWORK(20)
         t2 = secnds(t1)
         WRITE (LOUT,60) T,UMAX,NQU,HU,NST,NNI,NLI, t2
 60      FORMAT(E15.5,E12.4,I5,E14.3,I7,I9,I8, f7.2)
C
         IF (IDID .LT. 0) THEN
           WRITE(LOUT,65)T
 65        FORMAT(//' Final time reached =',E12.4//)
           GO TO 80
           ENDIF
C
         TOUT = TOUT*2.0D0
 70      CONTINUE
C
C Here we display some final statistics for the problem.
C The ratio of NLI to NNI is the average dimension of the Krylov
C subspace involved in the Krylov linear iterative method.
 80   CONTINUE
      NST = IWORK(11)
      NPE = IWORK(13)
c      NRE = IWORK(12) + NPE*MBAND
      NRE = IWORK(12)
      LIW = IWORK(17)
      LRW = IWORK(18)
      NNI = IWORK(19)
      NLI = IWORK(20)
      NPS = IWORK(21)
      NSE = IWORK(22)
      IF (NNI .NE. 0) AVDIM = REAL(NLI)/REAL(NNI)
      NETF = IWORK(14)
      NCFN = IWORK(15)
      NCFL = IWORK(16)
      WRITE (LOUT,90) LRW,LIW,NST,NRE+IPAR(30),NSE,NPE,NPS,NNI,NLI,
     1                AVDIM,NETF,NCFN,NCFL
 90   FORMAT(//' Final statistics for this run..'/
     1   ' RWORK size =',I8,'   IWORK size   =',I6/
     2   ' Number of time steps              =',I5/
     3   ' Number of residual evaluations    =',I5/
     3   ' Number of sensitivity evaluations =',I5/
     4   ' Number of Jac. or prec. evals.    =',I5/
     5   ' Number of preconditioner solves   =',I5/
     6   ' Number of nonlinear iterations    =',I5/
     7   ' Number of linear iterations       =',I5/
     8   ' Average Krylov subspace dimension =',F8.4/
     1   ' Error test failure .............. =',I5/
     1   I5,' nonlinear conv. failures,',I5,' linear conv. failures')
      WRITE(LOUT,100) LWPMIN, LIWPMIN
 100  FORMAT(' Minimum lengths for work arrays WP and IWP: ',i7,1x,i7)
C
C------  End of main program for DHEATILU example program --------------
      t2 = dtime(tt)
c      t3 = tt(1)
c      t2 = secnds(t1)
c      t3 = t2
      write(6,*) '   Time it took:', tt(1)+tt(2)
      STOP
      END

      SUBROUTINE UINIT (U, UPRIME, RPAR, IPAR)
C
C This routine computes and loads the vector of initial values.
C The initial U values are given by the polynomial u = 16x(1-x)y(1-y).
C The initial UPRIME values are set to zero.  (DDASPK corrects these
C during the first time step.)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*), UPRIME(*), RPAR(*), IPAR(*)
C
      NEQ = IPAR(33)
      M = IPAR(34)
      m2 = m + 2
      NP = IPAR(35)
      DX = RPAR(3)

      do i = 1, (np+1)*neq
         u(i) = 0.0d0
         uprime(i) = 0.0d0
      end do

      ii = 4*M2 + 4
      do i = 4, np+1
         ii = ii + 1
         u((i-1)*neq + ii) = 1.0d0
      end do

C
      DO 20 K = 0,M+1
        YK = K*DX
        IOFF = (M+2)*K
        DO 10 J = 0,M+1
           XJ = J*DX
           I = IOFF + J + 1
           U(I) = 16.0D0*XJ*(1.0D0-XJ)*YK*(1.0D0-YK)
 10     CONTINUE
 20   CONTINUE

      RETURN
C------------  End of Subroutine UINIT  --------------------------------
      END

      SUBROUTINE RESH (T, U, UPRIME, CJ, DELTA, IRES, RPAR,IPAR,SENPAR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*), UPRIME(*), DELTA(*), RPAR(*), IPAR(*),SENPAR(*)

      if (ires .eq. 0) then
         call RESH1 (T, U, UPRIME, CJ, DELTA, IRES, RPAR, IPAR,SENPAR)
      else if (ires. eq. 1) then
         call RESSA (T, U, UPRIME, CJ, DELTA, IRES, RPAR, IPAR,SENPAR)
      else
         ires = -2
      end if
      return
      end

      SUBROUTINE RESH1 (T, U, UPRIME, CJ, DELTA,IRES,RPAR,IPAR,SENPAR)
C
C This is the user-supplied RES subroutine for this example.
C It computes the residuals for the 2-D discretized heat equation,
C with zero boundary values.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*), UPRIME(*), DELTA(*), RPAR(*), IPAR(*),SENPAR(*)
C
C Set problem constants using IPAR and RPAR.
      NEQ = IPAR(33)
      M = IPAR(34)
      COEFF = RPAR(4)
      M2 = M + 2
C
C Load U into DELTA, in order to set boundary values.
      DO 10 I = 1,NEQ
 10     DELTA(I) = U(I)
C
C Loop over interior points, and load residual values.
      DO 30 K = 1,M
        IOFF = M2*K
        DO 20 J = 1,M
           I = IOFF + J + 1
           TEMX = SENPAR(1)*(U(I-1)  + U(I+1)  - 2.0d0*u(i))
           TEMY = SENPAR(2)*(U(I-M2) + U(I+M2) - 2.0d0*u(i))
           DELTA(I) = UPRIME(I) - (TEMX + TEMY)*COEFF
 20     CONTINUE
 30   CONTINUE
C
      RETURN
C------------  End of Subroutine RESH  ---------------------------------
      END

      subroutine ressa(t,u,uprime,cj,delta,ires,rpar,ipar,SENPAR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*), UPRIME(*), DELTA(*), RPAR(*), IPAR(*),SENPAR(*)
C
C Set problem constants using IPAR and RPAR.
      NEQ = IPAR(33)
      M = IPAR(34)
      NP = ipar(35)
      COEFF = RPAR(4)
      M2 = M + 2
C
C Load U into DELTA, in order to set boundary values.
      DO 10 I = 1,(np+1)*NEQ
 10     DELTA(I) = U(I)
C
C Loop over interior points, and load residual values.
      DO 30 K = 1,M
        IOFF = M2*K
        DO 20 J = 1,M
           I = IOFF + J + 1
           TEMX = (U(I-1)  + U(I+1)  - 2.0d0*u(i))
           TEMY = (U(I-M2) + U(I+M2) - 2.0d0*u(i))
           Delta(i) = UPRIME(I) -
     &          (SENPAR(1)*TEMX + SENPAR(2)*TEMY)*COEFF
           do ip = 1, np
              i = i + neq
              TEMXp = (U(I-1)  + U(I+1)  - 2.0d0*u(i))
              TEMYp = (U(I-M2) + U(I+M2) - 2.0d0*u(i))
              Delta(i) = UPRIME(I) -  (SENPAR(1)*TEMXp +
     &             SENPAR(2)*TEMYp)*COEFF
              if (ip .eq. 1) delta(i) = delta(i) - temx*coeff
              if (ip .eq. 2) delta(i) = delta(i) - temy*coeff
           end do
 20     CONTINUE
 30   CONTINUE

      return
      end