      subroutine ISSTA1(ITAB, NI, ISTATS, XSTATS, IHIST, ILOW, NCELLS)
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 ISSTA1 Krogh Removed unused parameter ONE.
c>> 1994-10-20 ISSTA1 Krogh Changes to use M77CON
c>> 1994-06-22 ISSTA1 CLL  Changed name to I[D/S]STA1.
C>> 1989-10-20 CLL
C>> 1987-05-01 ISTAT1 Lawson  Initial code.
c
c        This subr computes basic statistics for values of an integer
c     variable, say IVAL, storing the statistics as follows:
c
c             ISTATS(1) = Total count
c             ISTATS(2) = Min
c             ISTATS(3) = Max
c
c             XSTATS(1) = Mean
c             XSTATS(2) = Standard deviation
c
c     This subr also accumulates counts in IHIST() to develop a
c     histogram of values of IVAL.
c
c        The data to be treated is given in ITAB(1:NI).  If the
c     value of ISTATS(1) on entry is positive , say = NCOUNT, it is
c     assumed that NCOUNT data values have been processed previously
c     and results from that processing are in IHIST(), ISTATS(),
c     and XSTATS().  These results will be updated to reflect the
c     additional set of NI values.
c
c        Alternatively, if ISTATS(1) is zero, the initial contents of
c     ISTATS(2:3), XSTATS(), and IHIST() will be ignored and results
c     will be computed just for the present data set ITAB(1:NI).
c
c        The user must specify the range of the histogram
c     by setting ILOW and NCELLS.
c        The cells IHIST(2) through IHIST(NCELLS-1) will
c     be used to count occurences of IVAL = ILOW, ILOW+1, ..
c     ILOW + NCELLS - 3.
c        The end cells, IHIST(1) and IHIST(NCELLS) will be used to
c     count occurences of X less than ILOW or greater than
c     ILOW + NCELLS - 3, respectively.
c
c     The counting cells are associated with values of IVAL as follows:
c
c          Value of IVAL                   Counting cell
c
c          (-Infinity, ILOW-1]              IHIST(1)
c          [ILOW, ILOW+NCELLS-3]            IHIST(IVAL-ILOW +2)
c          [ILOW+NCELLS-2, Infinity)        IHIST(NCELLS)
c
c        After use of this subroutine, the user can call
c     ISTAT2, as appropriate, to produce a
c     printer-plot of the histogram and print the statistics.
c
c        Remark:  It is more efficient to call this subroutine one
c     time giving it N points rather than calling it N times giving it
c     one point each time, but the results will be the same to within
c     arithmetic limitations either way.
c     ------------------------------------------------------------------
c                    Subroutine arguments
c
c     ITAB()  [in]  Array of NI values whose statistics are to be
c           computed.
c     NI    [in]  Number of values given in ITAB().
c           Require NI .ge. 1.
c     ISTATS(), XSTATS()  [inout]  Arrays of length 3 and 2
c           respectively, into which statistics are or
c           will be stored.  Initial value of ISTATS(1) must be positive
c           if IHIST(), ISTATS() and XSTATS() contain prior results that
c           are to be updated.  Otherwise the initial value of STATS(1)
c           must be zero.
c     IHIST()  [inout]  Integer array of length at least NCELLS into
c           which counts will be accumulated.
c     ILOW    [in]  Value whose occurrences will be counted in IHIST(2).
c     NCELLS  [in]  Total number of classification regions.
c           Require NCELLS .ge. 3.
c     ------------------------------------------------------------------
c     C. L. Lawson and S. Y. Chiu, JPL, Apr 1987.
C     1989-10-20 CLL Moved integer declaration earlier to avoid warning
c     msg from Cray compiler.
c     ------------------------------------------------------------------
c--S replaces "?": I?STA1
c     ------------------------------------------------------------------
      integer NCELLS, NCOUNT, NI
      integer I, IHIST(NCELLS), ILOW, INDEX, ISTATS(3), ITAB(NI), IVAL
      integer J, NM1
      real             DELTA, PREV, XSTATS(2)
      real             SUMSQ, TERM, X, ZERO
      parameter(ZERO = 0.0E0)
c     ------------------------------------------------------------------
      if( NI .lt. 1) return
      NCOUNT = ISTATS(1)
      if(NCOUNT .eq. 0) then
         do 10 I=1,NCELLS
            IHIST(I) = 0
   10    continue
         ISTATS(2) = ITAB(1)
         ISTATS(3) = ISTATS(2)
         XSTATS(1) = ZERO
         SUMSQ     = ZERO
      else
         SUMSQ = (NCOUNT-1) * XSTATS(2)**2
      endif
c
         do 30 J=1,NI
            IVAL = ITAB(J)
            X = IVAL
            ISTATS(2) = min(IVAL, ISTATS(2))
            ISTATS(3) = max(IVAL, ISTATS(3))
            PREV = NCOUNT
            NCOUNT = NCOUNT + 1
            DELTA = X - XSTATS(1)
            TERM = DELTA / NCOUNT
            XSTATS(1) = XSTATS(1) + TERM
            SUMSQ = SUMSQ + PREV * DELTA * TERM
c
c           .                         Begin: Tally in histogram.
            INDEX = IVAL - ILOW + 2
            if(INDEX .lt. 1) then
               IHIST(1) = IHIST(1) + 1
            elseif(INDEX .gt. NCELLS) then
               IHIST(NCELLS) = IHIST(NCELLS) + 1
            else
               IHIST(INDEX) = IHIST(INDEX) + 1
            endif
c           .                         End: Tally in histogram.
   30    continue
      ISTATS(1) = NCOUNT
      NM1 = NCOUNT-1
      if(NM1 .gt. 0) then
         XSTATS(2) = sqrt(SUMSQ / NM1 )
      else
         XSTATS(2) = ZERO
      endif
      return
      end


      program SERIES
      implicit none
      real x,sum
      integer i,n
      write(*,*)'give the value of x and n'
      read(*,*)x,n
      i=1
      sum=1.0
10    sum=sum+x**i
      if (i.lt.n)then
      i=i+1
      go to 10
      endif
      write(*,*)"the sum is=",sum
      pause
      stop
      end


module numconstants
  ! Numerical and mathematical constants.
  implicit none
  save
  public
  real, parameter :: almost_zero = tiny(1.0)
  real, parameter :: machine_prec = epsilon(1.0)
  real, parameter :: large = 1.0e10
  real, parameter :: small = 1.0e-12
  real, parameter :: rtol = machine_prec*1.0e-10
  real, parameter :: pi = 4.0*atan(1.0)
  real, parameter :: expMax = log(huge(1.0))
  real, parameter :: expMin = log(tiny(1.0))

end module numconstants


!> Backward auto diff
program main

    use auto_diff, only: tree_t, operator(*), operator(+), exp, rk, assignment(=)
    implicit none
    type(tree_t) :: a, b, c
    type(tree_t) :: y

    a = 2.0_rk
    b = 1.0_rk
    c = 0.0_rk

    print *, "demo1: y = (a + b*b)*exp(c)"

    y = (a + b*b)*exp(c)

    print *, "y     = ", y%get_value()
    call y%backward()

    print *, "dy/da = ", a%get_grad()
    print *, "dy/db = ", b%get_grad()
    print *, "dy/dc = ", c%get_grad()

    ! - - -

    a = 2.0_rk
    b = 1.0_rk

    print *, ""
    print *, "demo2: y = (a + b)*(b + 1.0)"

    y = (a + b)*(b + 1.0_rk)

    print *, "y     = ", y%get_value()

    call y%backward()

    print *, "dy/da = ", a%get_grad()
    print *, "dy/db = ", b%get_grad()

end program main

!>  demo1: y = (a + b*b)*exp(c)
!>  y     =    3.0000000000000000
!>  dy/da =    1.0000000000000000
!>  dy/db =    2.0000000000000000
!>  dy/dc =    3.0000000000000000
!>
!>  demo2: y = (a + b)*(b + 1.0)
!>  y     =    6.0000000000000000
!>  dy/da =    2.0000000000000000
!>  dy/db =    5.0000000000000000


      SUBROUTINE qtrap(func,a,b,s)
      INTEGER JMAX
      REAL a,b,func,s,EPS
      EXTERNAL func
      PARAMETER (EPS=1.e-6, JMAX=20)
CU    USES trapzd
      INTEGER j
      REAL olds
      olds=-1.e30
      do 11 j=1,JMAX
        call trapzd(func,a,b,s,j)
        if (abs(s-olds).lt.EPS*abs(olds)) return
        if (s.eq.0..and.olds.eq.0..and.j.gt.6) return
        olds=s
11    continue
      pause 'too many steps in qtrap'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/qtrap.for


!
! Example: compute real-valued Laplacian
!
program laplacian
  use adjac
  implicit none

  integer, parameter :: n = 5

  double precision, dimension(n) :: x_value
  double precision, dimension(n) :: y_value
  double precision, allocatable, dimension(:) :: jac_val
  integer, allocatable, dimension(:) :: jac_i, jac_j
  double precision, dimension(n,n) :: jac_dense

  type(adjac_double), dimension(n) :: x
  type(adjac_double), dimension(n) :: y
  integer :: j, nnz

  call adjac_reset()
  do j = 1, n
     x_value(j) = j-1
  end do
  call adjac_set_independent(x, x_value)

  ! Compute Laplacian
  y(1) = x(2) - 2*x(1)
  y(n) = x(n-1) - 2*x(n)
  do j = 2, n-1
     y(j) = x(j-1) - 2*x(j) + x(j+1)
  end do

  ! Obtain function value
  write(*,*) '-- values'
  call adjac_get_value(y, y_value)
  write(*,*) real(y_value)

  ! Obtain jacobian in dense format
  write(*,*) '-- dense laplacian'
  call adjac_get_dense_jacobian(y, jac_dense)
  do j = 1, n
     write(*,*) jac_dense(j,:)
  end do

  ! Obtain jacobian in sparse coordinate (i, j, value) format
  write(*,*) '-- COO laplacian'
  call adjac_get_coo_jacobian(y, nnz, jac_val, jac_i, jac_j)
  do j = 1, nnz
     write(*,*) jac_i(j), jac_j(j), real(jac_val(j))
  end do

  call adjac_free()
end program laplacian


! ==================================================================================================================================
!
! # file created #
! 2020/09/20
!
! # tested compiler #
! gcc version 9.3.0 (Ubuntu 9.3.0-10ubuntu2)
!
! ==================================================================================================================================

module mod_interval1D

    ! <module>s to import
    use, intrinsic :: iso_fortran_env

    ! require all variables to be explicitly declared
    implicit none

    ! accessibility of the <subroutine>s and <function>s in this <module>

    ! kind: type
    public :: typ_interval1d_R32
    public :: typ_interval1d_R64

    ! kind: function
    private :: delta_R32
    private :: delta_R64

    private :: inequality_R32
    private :: inequality_R64

    private :: midpoint_R32
    private :: midpoint_R64

    private :: width_R32
    private :: width_R64

    ! kind: interface
    public :: delta
    public :: inequality
    public :: midpoint
    public :: width

    ! <type>s for this <module>
    type typ_interval1d_R32
        real(REAL32), public :: lower
        real(REAL32), public :: upper
    end type typ_interval1d_R32

    type typ_interval1d_R64
        real(REAL64), public :: lower
        real(REAL64), public :: upper
    end type typ_interval1d_R64

    ! <interface>s for this <module>

    interface delta
        module procedure :: delta_R32
        module procedure :: delta_R64
    end interface delta

    interface inequality
        module procedure :: inequality_R32
        module procedure :: inequality_R64
    end interface inequality

    interface midpoint
        module procedure :: midpoint_R32
        module procedure :: midpoint_R64
    end interface midpoint

    interface width
        module procedure :: width_R32
        module procedure :: width_R64
    end interface width

    ! contained <subroutine>s and <function>s are below
    contains

    pure function delta_R32 (interval) result(delta)

        ! arguments for this <function>
        type(typ_interval1d_R32), intent(in) :: interval

        ! return value of this <function>
        real(REAL32) :: delta

        delta = interval%upper - interval%lower

    end function delta_R32

    pure function delta_R64 (interval) result(delta)

        ! arguments for this <function>
        type(typ_interval1d_R64), intent(in) :: interval

        ! return value of this <function>
        real(REAL64) :: delta

        delta = interval%upper - interval%lower

    end function delta_R64

    pure function inequality_R32 (interval) result(stat)

        ! arguments for this <function>
        type(typ_interval1d_R32), intent(in) :: interval

        ! return value of this <function>
        logical :: stat

        stat = interval%lower < interval%upper

    end function inequality_R32

    pure function inequality_R64 (interval) result(stat)

        ! arguments for this <function>
        type(typ_interval1d_R64), intent(in) :: interval

        ! return value of this <function>
        logical :: stat

        stat = interval%lower < interval%upper

    end function inequality_R64

    pure function midpoint_R32 (interval) result(midpoint)

        ! arguments for this <function>
        type(typ_interval1d_R32), intent(in) :: interval

        ! return value of this <function>
        real(REAL32) :: midpoint

        midpoint = 0.5_REAL32 * (interval%lower + interval%upper)

    end function midpoint_R32

    pure function midpoint_R64 (interval) result(midpoint)

        ! arguments for this <function>
        type(typ_interval1d_R64), intent(in) :: interval

        ! return value of this <function>
        real(REAL64) :: midpoint

        midpoint = 0.5_REAL64 * (interval%lower + interval%upper)

    end function midpoint_R64

    pure function width_R32 (interval) result(width)

        ! arguments for this <function>
        type(typ_interval1d_R32), intent(in) :: interval

        ! return value of this <function>
        real(REAL32) :: width

        width = abs( delta(interval) )

    end function width_R32

    pure function width_R64 (interval) result(width)

        ! arguments for this <function>
        type(typ_interval1d_R64), intent(in) :: interval

        ! return value of this <function>
        real(REAL64) :: width

        width = abs( delta(interval) )

    end function width_R64

end module mod_interval1D

! ==================================================================================================================================
! EOF
! ==================================================================================================================================


C
	SUBROUTINE ROTATE_Y(ANGLE,X_INIT,X_TRANS)
C
	REAL X_INIT(3),X_TRANS(3)
C
	X_TRANS(1)=X_INIT(1)*COS(ANGLE)+X_INIT(3)*SIN(ANGLE)
	X_TRANS(2)=X_INIT(2)
	X_TRANS(3)=X_INIT(3)*COS(ANGLE)-X_INIT(1)*SIN(ANGLE)
C
	RETURN
	END


program gridgencirc2d
  implicit none

  ! Definition of double precision
  integer, parameter  :: DP = selected_real_kind(15,307)

  ! Definition of mathematical constant PI
  real(DP) :: pi

  ! Definition of azimuth (defined below)
  real(DP) :: dazimuth

  ! Definition of azimuth offset
  real(DP) :: dazimuth0 = 0.0_DP

  ! Definition of the inner radius
  real(DP) :: dinnerRadius = 0.1_DP

  ! Definition of the outer radius
  real(DP) :: douterRadius = 1.0_DP

  ! Definition of the grid anisotropy
  real(DP) :: danisotropy = 1.0_DP

  ! Definition of the number of segments
  integer :: nsegments = 6

  ! Definition of the minimum number of segments in the inner circle
  integer :: nminsegments = 4

  ! Definition of the number of outer layers
  integer :: nlayers = 1

  ! Definition of output filename
  character(len=80) :: cfilename = "grid"

  ! Definition of output format
  character(LEN=*), parameter :: cFormat = '(F32.15)'

  ! Definition whether to use external triangulation
  logical :: bexternalDelaunay = .false.

  ! local variables
  character(len=80) :: cbuffer
  character(len=32) :: cbuffer1,cbuffer2,cbuffer3,cbuffer4,cbuffer5,cbuffer6
  real(DP) :: x,y,r,dr0,phi,darea,dlength,bdrPar
  integer :: i,j,k,ivt,jvt,iaux,nvt,nel,nmt,i1,i2,i3
  integer :: isegment,irefine,nlineSegments

  !-----------------------------------------------------------------------------
  ! Initialize mathematical constant(s)
  !-----------------------------------------------------------------------------

  pi = asin(1.0_DP)*2.0_DP; dazimuth = 2.0_DP*pi

  !-----------------------------------------------------------------------------
  ! Get command line arguments
  !-----------------------------------------------------------------------------

  do i = 1, command_argument_count()

    call get_command_argument(i, cbuffer)
    select case(cbuffer)
    case('-h','-H','--help')
      write(*,'(A)') 'Usage: gridgen [OPTION]'
      write(*,'(A)') 'Generate an annular grid in TRI/PRM format.'
      write(*,*)
      write(*,'(A,T30,A)') '-h,  -H,  --help','this help screen'
      write(*,'(A,T30,A)') '-A,  --azimuth','azimuth of the circular segment'
      write(*,'(T30,A)')   'If not given, a full circle is adopted.'
      write(*,'(A,T30,A)') '-A0,  --azimuth0','azimuth offset of the circular segment'
      write(*,'(T30,A)')   'If not given, zero offset is adopted.'
      write(*,'(A,T30,A)') '-a,  --anisotropy','degree of radial grid anisotropy in outer region'
      write(*,'(T30,A)')   'If not given, no anisotropy is adopted.'
      write(*,'(A,T30,A)') '-d,  --delaunay','Delaunay triangulation of the inner region'
      write(*,'(T30,A)')   'If not given, no Delaunay triangulation of the inner region is performed.'
      write(*,'(A,T30,A)') '-f,  --filename','name of the output file'
      write(*,'(T30,A)')   'If not given, the generated grid is stored in file "grid.tri/prm".'
      write(*,'(A,T30,A)') '-l,  --layers','number of layers in radial direction in outer region'
      write(*,'(T30,A)')   'If not given, a single layer is adopted.'
      write(*,'(A,T30,A)') '-ri, --innerradius','radius of the inner region'
      write(*,'(T30,A)')   'If not given, 0.1 is adopted as inner radius.'
      write(*,'(A,T30,A)') '-ro, --outerradius','radius of the outer region'
      write(*,'(T30,A)')   'If not given, 1.0 is adopted as inner radius.'
      write(*,'(A,T30,A)') '-s,  --segments','number of segments in azimuthal direction'
      write(*,'(T30,A)')   'If not given, 6 segments are adopted.'
      write(*,'(A,T30,A)') '-si, --minsegments','minimum number of segments in the inner circle'
      write(*,'(T30,A)')   'If not given, 4 segments are adopted. This parameter is not used if'
      write(*,'(T30,A)')   'Delaunay triangulation is used for the inner region.'
      write(*,*)
      write(*,'(A)') 'Report bugs to <matthias.moeller@math.tu-dortmund.de>.'
      stop

    case('-A','--azimuth')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) dazimuth; dazimuth = min(2.0_DP*pi, dazimuth)

    case('-A0','--azimuth0')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) dazimuth0

    case('-a','--anisotropy')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) danisotropy

    case('-d','--delaunay')
      bexternalDelaunay = .true.

    case('-ri','--innerradius')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) dinnerRadius

    case('-ro','--outerradius')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) douterRadius

    case('-s','--segments')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) nsegments

    case('-si','--minsegments')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) nminsegments

    case('-l','--layers')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) nlayers

    case('-f','--filename')
      call get_command_argument(i+1, cbuffer)
      read(cbuffer,*) cfilename
    end select
  end do

  !-----------------------------------------------------------------------------
  ! Write statistics
  !-----------------------------------------------------------------------------

  write(*,'(A)') 'Generating annular grid'
  write(*,'(A)') '-----------------------'
  write(cbuffer, *) dazimuth
  write(*,'(A,T45,A)') 'azimuth of the circular segment:',trim(adjustl(cbuffer))
  write(cbuffer, *) dazimuth0
  write(*,'(A,T45,A)') 'azimuth offset of the circular segment:',trim(adjustl(cbuffer))
  write(cbuffer, *) dinnerRadius
  write(*,'(A,T45,A)') 'radius of inner region:',trim(adjustl(cbuffer))
  write(cbuffer, *) douterRadius
  write(*,'(A,T45,A)') 'radius of outer region:',trim(adjustl(cbuffer))
  write(cbuffer, *) nlayers
  write(*,'(A,T45,A)') 'number of layers in radial direction:',trim(adjustl(cbuffer))
  write(cbuffer, *) nsegments
  write(*,'(A,T45,A)') 'number of segments in azimuthal direction:',trim(adjustl(cbuffer))
  write(cbuffer, *) nminsegments
  write(*,'(A,T45,A)') 'minimum number of segments in inner region:',trim(adjustl(cbuffer))
  write(*,'(A,T45,A)') 'name of output file: ',trim(adjustl(cfilename))

  !-----------------------------------------------------------------------------
  ! Generate PRM-file
  !-----------------------------------------------------------------------------

  open(unit=100, file=trim(adjustl(cfilename))//'.prm')

  if (dazimuth .ge. 2.0_DP*pi) then
    !---------------------------------------------------------------------------
    ! Generate full circle with angle: 2*pi
    !---------------------------------------------------------------------------
    write(100,'(A)') 'NBCT'
    write(100,'(A)') '1'
    write(100,'(A)') 'IBCT'
    write(100,'(A)') '1 '
    write(100,'(A)') 'NCOMP'
    write(100,'(A)') '1'
    write(100,'(A)') 'ITYP NSPLINE NPAR'
    write(100,'(A)') '2 1 3 '
    write(100,'(A)') 'PARAMETERS'
    write(cbuffer1, cFormat) 0.0_DP
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer1)) ! midpoint
    write(cbuffer2, cFormat) douterRadius
    write(100,'(A)') trim(adjustl(cbuffer2))//' '//trim(adjustl(cbuffer1)) ! radius
    write(cbuffer1, cFormat) dazimuth0
    write(cbuffer2, cFormat) dazimuth0+2.0_DP*pi
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! azimuth

  else
    !---------------------------------------------------------------------------
    ! Generate circle segment with angle: dazimuth
    !---------------------------------------------------------------------------
    write(100,'(A)') 'NBCT'
    write(100,'(A)') '1'
    write(100,'(A)') 'IBCT'
    write(100,'(A)') '1 '
    write(100,'(A)') 'NCOMP'
    write(100,'(A)') '3'
    write(100,'(A)') 'ITYP NSPLINE NPAR'
    write(100,'(A)') '2 1 3 '
    write(100,'(A)') '1 1 2 '
    write(100,'(A)') '1 1 2 '
    write(100,'(A)') 'PARAMETERS'
    ! Circular segment
    write(cbuffer1, cFormat) 0.0_DP
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer1)) ! midpoint
    write(cbuffer2, cFormat) douterRadius
    write(100,'(A)') trim(adjustl(cbuffer2))//' '//trim(adjustl(cbuffer1)) ! radius
    write(cbuffer1, cFormat) dazimuth0
    write(cbuffer2, cFormat) dazimuth0+dazimuth
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! azimuth
    ! Line segment
    write(cbuffer1, cFormat) douterRadius*cos(dazimuth0+dazimuth)
    write(cbuffer2, cFormat) douterRadius*sin(dazimuth0+dazimuth)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
    write(cbuffer1, cFormat) -douterRadius*cos(dazimuth0+dazimuth)
    write(cbuffer2, cFormat) -douterRadius*sin(dazimuth0+dazimuth)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    ! Line segment
    write(cbuffer1, cFormat) 0.0
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer1)) ! origin
    write(cbuffer1, cFormat) douterRadius*cos(dazimuth0)
    write(cbuffer2, cFormat) douterRadius*sin(dazimuth0)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction

  end if

  close(100)

  !-----------------------------------------------------------------------------
  ! Prepare generation of TRI-file
  !-----------------------------------------------------------------------------

  if (bexternalDelaunay) then

    !---------------------------------------------------------------------------
    ! Generate inner triangulation by the external program triangle
    !---------------------------------------------------------------------------

    open(unit=100, file=trim(adjustl(cfilename))//'.node')

    ! Write file header
    write(100, '(A)') "# "//trim(adjustl(cfilename))//'.node'
    write(100, '(A)') "#"
    write(100, '(A)') "# Node file generated by gridgencirc2d."
    write(100, '(A)') "#"

    if (dazimuth .ge. 2.0_DP*pi) then
      !-------------------------------------------------------------------------
      ! Generate full circle with angle: 2*pi
      !-------------------------------------------------------------------------

      ! Write number of points
      write(100, '(A)') "# Number of points, 2D, one attribute, boundary markers"
      write(cbuffer1, '(I10)') nsegments+1
      write(100, '(A)') trim(adjustl(cbuffer1))//' 2 1 1'

      ! Write vertex coordinates
      do isegment = 1, nsegments

        ! Compute azimuth
        phi = dazimuth0+(isegment-1)*dazimuth/nsegments

        ! Fill buffers
        write(cbuffer1, '(I10)') isegment
        write(cbuffer2, cFormat) dinnerRadius * cos(phi)
        write(cbuffer3, cFormat) dinnerRadius * sin(phi)
        write(cbuffer4, cFormat) 0.0_DP

        ! Write line to file
        write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                          trim(adjustl(cbuffer2))//' '//&
                          trim(adjustl(cbuffer3))//' '//&
                          trim(adjustl(cbuffer4))//' 0'
      end do

      ! Write single node at the origin
      write(cbuffer1, '(I10)') nsegments+1
      write(cbuffer2, cFormat) 0.0_DP
      write(cbuffer3, cFormat) 0.0_DP
      write(cbuffer4, cFormat) 0.0_DP

      ! Write line to file
      write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                        trim(adjustl(cbuffer2))//' '//&
                        trim(adjustl(cbuffer3))//' '//&
                        trim(adjustl(cbuffer4))//' 0'

      close(100)

      ! Compute minimum edge length
      phi = dazimuth/nsegments
      darea = (dinnerradius**2) * ((cos(phi)-1)**2 + sin(phi)**2)

      ! Generate conforming Delaunay triangulation (-D) subject to a
      ! user-defined element area (-a) without generating additional
      ! Steiner points on the boundary (-Y) based on vertex distribution
      write(cbuffer1, cFormat) darea
      call system('triangle -V -Y -D -e -a'//&
          trim(adjustl(cbuffer1))//' '//trim(adjustl(cfilename))//'.node')

    else
      !-------------------------------------------------------------------------
      ! Generate circle segment with angle = dazimuth
      !-------------------------------------------------------------------------

      ! Compute number of line segments
      dlength = sqrt((dinnerRadius*cos(dazimuth/nsegments)-dinnerRadius)**2 +&
                     (dinnerRadius*sin(dazimuth/nsegments))**2)
      nlineSegments = floor(dinnerRadius/dlength)

      ! Write number of points
      write(100, '(A)') "# Number of points, 2D, one attribute, boundary markers"
      write(cbuffer1, '(I10)') nsegments+2*nlineSegments
      write(100, '(A)') trim(adjustl(cbuffer1))//' 2 1 1'

      ! Write vertex coordinates
      do isegment = 1, nsegments+1

        ! Compute azimuth
        phi = dazimuth0+(isegment-1)*dazimuth/nsegments

        if (isegment .eq. 1) then
          ! Fill buffers
          write(cbuffer1, '(I10)') isegment
          write(cbuffer2, cFormat) dinnerRadius * cos(phi)
          write(cbuffer3, cFormat) dinnerRadius * sin(phi)
          write(cbuffer4, cFormat) 2.0_DP+dinnerRadius/douterRadius

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 2'

        elseif (isegment .eq. nsegments+1) then
          ! Fill buffers
          write(cbuffer1, '(I10)') isegment
          write(cbuffer2, cFormat) dinnerRadius * cos(phi)
          write(cbuffer3, cFormat) dinnerRadius * sin(phi)
          write(cbuffer4, cFormat) 2.0_DP-dinnerRadius/douterRadius

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 2'
        else
          ! Fill buffers
          write(cbuffer1, '(I10)') isegment
          write(cbuffer2, cFormat) dinnerRadius * cos(phi)
          write(cbuffer3, cFormat) dinnerRadius * sin(phi)
          write(cbuffer4, cFormat) 0.0_DP

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 0'
        end if
      end do

      ! Write line segment from last point on circle segment to origin
      x = dinnerRadius * cos(dazimuth0+dazimuth)
      y = dinnerRadius * sin(dazimuth0+dazimuth)

      ! Write vertex coordinates
      do isegment = 1, nlineSegments

        write(cbuffer1, '(I10)') nsegments+1+isegment
        write(cbuffer2, cFormat) (1.0_DP-isegment/real(nlineSegments,DP))*x
        write(cbuffer3, cFormat) (1.0_DP-isegment/real(nlineSegments,DP))*y
        write(cbuffer4, cFormat) (dinnerRadius*real(isegment,DP)/real(nlineSegments,DP)+&
                                  douterRadius-dinnerRadius)/douterRadius+1.0_DP

        write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                          trim(adjustl(cbuffer2))//' '//&
                          trim(adjustl(cbuffer3))//' '//&
                          trim(adjustl(cbuffer4))//' 2'
      end do

      ! Write line segment from origin to first point on circle segment
      x = dinnerRadius * cos(dazimuth0)
      y = dinnerRadius * sin(dazimuth0)

      ! Write vertex coordinates
      do isegment = 1, nlineSegments-1

        write(cbuffer1, '(I10)') nsegments+1+nlineSegments+isegment
        write(cbuffer2, cFormat) real(isegment,DP)/real(nlineSegments,DP)*x
        write(cbuffer3, cFormat) real(isegment,DP)/real(nlineSegments,DP)*y
        write(cbuffer4, cFormat) real(isegment,DP)/real(nlineSegments,DP)*&
                                 dinnerRadius/douterRadius+2.0_DP

        write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                          trim(adjustl(cbuffer2))//' '//&
                          trim(adjustl(cbuffer3))//' '//&
                          trim(adjustl(cbuffer4))//' 2'
      end do

      close(100)

      ! Write PSLG (planar straight line graph) to file
      open(unit=100, file=trim(adjustl(cfilename))//'.poly')

      ! Write file header
      write(100, '(A)') "# "//trim(adjustl(cfilename))//'.poly'
      write(100, '(A)') "#"
      write(100, '(A)') "# PSLG file generated by gridgencirc2d."
      write(100, '(A)') "#"

      ! Write number of points
      write(100, '(A)') "# no points, 2D, no attributes, no boundary markers"
      write(100, '(A)') '0 2 0 0'
      write(100, '(A)') "# Number of segments, no boundary markers"
      write(cbuffer1, '(I10)') nsegments+1+2*nlineSegments
      write(100, '(A)') trim(adjustl(cbuffer1))

      ! Write segments
      do isegment = 1, nsegments+2*nlineSegments+1

        write(cbuffer1, '(I10)') isegment
        write(cbuffer2, '(I10)') mod(isegment,nsegments+2*nlineSegments)+1

        write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                          trim(adjustl(cbuffer1))//' '//&
                          trim(adjustl(cbuffer2))
      end do

      ! Write number of holes
      write(100, '(A)') '0'
      write(100, '(A)') '0'

      close(100)

      ! Compute minimum edge length
      phi = dazimuth/nsegments
      darea = (dinnerradius**2) * ((cos(phi)-1)**2 + sin(phi)**2)

      ! Generate conforming Delaunay triangulation (-D) subject to a
      ! user-defined element area (-a) without generating additional
      ! Steiner points on the boundary (-Y) based on vertex distribution
      write(cbuffer1, cFormat) darea
      call system('triangle -V -Y -D -e -a'//&
          trim(adjustl(cbuffer1))//' '//trim(adjustl(cfilename))//'.node'//&
          ' -p '//trim(adjustl(cfilename))//'.poly')
    end if

    !---------------------------------------------------------------------------
    ! Read data for inner triangulation and convert it into TRI format
    !---------------------------------------------------------------------------

    open(unit=100, file=trim(adjustl(cfilename))//'.1.node')
    read(100, fmt=*) nvt
    close(100)

    open(unit=100, file=trim(adjustl(cfilename))//'.1.ele')
    read(100, fmt=*) nel
    close(100)

    open(unit=100, file=trim(adjustl(cfilename))//'.1.edge')
    read(100, fmt=*) nmt
    close(100)

  else

    !---------------------------------------------------------------------------
    ! Determine the number of inner layers manually
    !---------------------------------------------------------------------------

    ! Determine the number of regular coarsening steps to obtain the
    ! number of vertices/elements/midpoints of the coarse grid.
    isegment = nsegments; irefine  = 0

    inner: do
      if ((mod(isegment, 2) .eq. 0) .and.&
          (isegment .ge. 2*nminsegments)) then
        isegment = isegment/2
        irefine  = irefine+1
      else
        exit inner
      end if
    end do inner

    ! Determine number of vertices/elements in the interior circle.
    ! Thus, we initialize the quantities NEL, NVT and NMT by the
    ! values of the initial coarse grid in perform regular subdivision.
    nel = isegment
    nvt = isegment+1
    nmt = 2*isegment

    do i = 1, irefine
      ! Each edge produces a new vertex
      nvt = nvt + nmt

      ! Each edge is subdivided into two new edges and
      ! each element produces three new edges
      nmt = 2*nmt + 3*nel

      ! Each element is subdivided into four new elements
      nel = 4*nel
    end do

    ! Update number of vertices/midpoints for circle sections
    if (dazimuth .lt. 2.0_DP*pi) then
      nvt = nvt+2**irefine
      nmt = nmt+2**(irefine+1)
    end if

  end if

  !-----------------------------------------------------------------------------
  ! Generate TRI-file
  !-----------------------------------------------------------------------------

  open(unit=100, file=trim(adjustl(cfilename))//'.tri')

  write(100,'(A)') 'Coarse mesh 2D'
  write(100,'(A)') 'Generated by gridgencirc2d'

  write(cbuffer1, '(I10)') nel + nsegments*nlayers
  write(cbuffer2, '(I10)') nvt + nsegments*nlayers +&
                           merge(0, nlayers, dazimuth .ge. 2.0_DP*pi)

  write(100,'(A)') trim(adjustl(cbuffer1))//' '//&
                   trim(adjustl(cbuffer2))//' 0 4 1  NEL NVT NMT NVE NBCT'

  !-----------------------------------------------------------------------------
  write(100,'(A)') 'DCORVG'
  !-----------------------------------------------------------------------------

  if (bexternalDelaunay) then

    !---------------------------------------------------------------------------
    ! Copy/convert coordinates of inner region from external triangulation
    !---------------------------------------------------------------------------

    ! Write interior vertices in the inner layer
    open(unit=200, file=trim(adjustl(cfilename))//'.1.node')
    read(200, fmt=*) nvt

    ! Read node file line by line and convert coordinates
    do ivt = 1, nvt
      read(200, fmt=*) i, x, y, bdrPar, iaux

      if (iaux .gt. 1) then
        ! Write boundary parametrization
        write(cbuffer1, cFormat) bdrPar
        write(cbuffer2, cFormat) 0.0_DP
      else
        ! Write inner vertex
        write(cbuffer1, cFormat) x
        write(cbuffer2, cFormat) y
      end if

      ! Write line to file
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
    end do

    close(200)

  else
    !---------------------------------------------------------------------------
    ! Create coordinates of inner region manually
    !---------------------------------------------------------------------------

    ! Write vertex at origin
    if (dazimuth .ge. 2.0_DP*pi) then
      write(cbuffer1, cFormat) 0.0_DP
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer1))
    else
      write(cbuffer1, cFormat) 2.0_DP
      write(cbuffer2, cFormat) 0.0_DP
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
    end if

    ! Write vertices in the inner layer
    iaux = isegment

    ! Loop over all refinement steps
    do j = 1, 2**irefine

      ! Compute radius of current layer
      r = j*(dinnerRadius)/(2**irefine)

      ! Loop over all segments in current layer
      do i = 1, iaux

        ! Compute azimuth
        phi = dazimuth0+(i-1)*dazimuth/iaux

        if ((dazimuth .lt. 2.0_DP*pi) .and. (i .eq. 1)) then
          ! Fill buffers
          write(cbuffer1, cFormat) 2.0_DP+r/douterRadius
          write(cbuffer2, cFormat) 0.0_DP
        else
          ! Fill buffers
          write(cbuffer1, cFormat) r * cos(phi)
          write(cbuffer2, cFormat) r * sin(phi)
        end if

        ! Write line to file
        write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
      end do

      ! Since the circle is not closed we have to add one extra vertex
      if (dazimuth .lt. 2.0_DP*pi) then
      ! Fill buffers
      write(cbuffer1, cFormat) 2.0_DP-r/douterRadius
        write(cbuffer2, cFormat) 0.0_DP

        ! Write line to file
        write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
      end if

      ! Increate the number of segments
      iaux = iaux + isegment
    end do

  end if

  ! Compute minimal grid spacing (isotropic/anisotropic ?)
  if (danisotropy .eq. 1.0_DP) then
    dr0 = (douterRadius-dinnerRadius)/nlayers
  else
    ! Compute local anisotropy factor
    danisotropy = exp(log(danisotropy)/(nlayers-1.0_DP))
    dr0 = (douterRadius-dinnerRadius)*(danisotropy-1)/(danisotropy**nlayers-1)
  end if

  do i = 1, merge(nsegments, nsegments+1, dazimuth .ge. 2.0_DP*pi)

    !---------------------------------------------------------------------------
    ! Write interior vertices in the outer layer
    !---------------------------------------------------------------------------

    do j = 1, nlayers-1

      ! Compute radius
      if (danisotropy .eq. 1.0_DP) then
        r = dinnerRadius + dr0*j
      else
        r = dinnerRadius + dr0*(danisotropy**(j)-1)/(danisotropy-1)
      end if

      ! Compute azimuth
      phi = dazimuth0+dazimuth*(i-1)/nsegments

      if (dazimuth .ge. 2.0_DP*pi) then
        ! Fill buffers
        write(cbuffer1, cFormat) r * cos(phi)
        write(cbuffer2, cFormat) r * sin(phi)

        ! Write line to file
        write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
      else
        if (i .eq. 1) then
          ! Fill buffer
          write(cbuffer1, cFormat) 2.0_DP+r/douterRadius
          write(cbuffer2, cFormat) 0.0
        elseif (i .eq. nsegments+1) then
          ! Fill buffer
          write(cbuffer1, cFormat) 2.0_DP-r/douterRadius
          write(cbuffer2, cFormat) 0.0
        else
          ! Fill buffers
          write(cbuffer1, cFormat) r * cos(phi)
          write(cbuffer2, cFormat) r * sin(phi)
        end if

        ! Write line to file
        write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
      end if
    end do

    !---------------------------------------------------------------------------
    ! Write parameters for boundary vertex
    !---------------------------------------------------------------------------

    r = real(i-1,DP)/real(nsegments,DP)
    write(cbuffer1, cFormat) r
    write(cbuffer2, cFormat) 0.0
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
  end do

  !-----------------------------------------------------------------------------
  write(100,'(A)') 'KVERT'
  !-----------------------------------------------------------------------------

  if (bexternalDelaunay) then

    !---------------------------------------------------------------------------
    ! Copy elements of inner region from external triangulation
    !---------------------------------------------------------------------------

    open(unit=200, file=trim(adjustl(cfilename))//'.1.ele')
    read(200, fmt=*) nel

    ! Read element file line by line and convert coordinates
    do i = 1, nel
      read(200, fmt=*) iaux, i1, i2, i3

      write(cbuffer1, '(I10)') i1
      write(cbuffer2, '(I10)') i2
      write(cbuffer3, '(I10)') i3
      write(cbuffer4, '(I10)') 0

      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))//' '//&
          trim(adjustl(cbuffer3))//' '//trim(adjustl(cbuffer4))
    end do

    close(200)

    !---------------------------------------------------------------------------
    ! Process connection layer between unstructured and structured grids
    !---------------------------------------------------------------------------

    do i = 1, nsegments

      ! Compute base vertex number
      ivt = nlayers*(i-1)

      if (dazimuth .ge. 2.0_DP*pi) then
        write(cbuffer1, '(I10)') mod(i-1,         nsegments)+1
        write(cbuffer2, '(I10)') mod(ivt,         nsegments*nlayers)+nvt+1
        write(cbuffer3, '(I10)') mod(ivt+nlayers, nsegments*nlayers)+nvt+1
        write(cbuffer4, '(I10)') mod(i,           nsegments)+1
      else
        write(cbuffer1, '(I10)') mod(i-1,         (nsegments+1))+1
        write(cbuffer2, '(I10)') mod(ivt,         (nsegments+1)*nlayers)+nvt+1
        write(cbuffer3, '(I10)') mod(ivt+nlayers, (nsegments+1)*nlayers)+nvt+1
        write(cbuffer4, '(I10)') mod(i,           (nsegments+1))+1
      end if

      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))//' '//&
          trim(adjustl(cbuffer3))//' '//trim(adjustl(cbuffer4))
    end do

  else

    !---------------------------------------------------------------------------
    ! Create triangles of inner region manually
    !---------------------------------------------------------------------------

    ! Process inner most triangles
    do i = 1, isegment

      if (dazimuth .ge. 2.0_DP*pi) then
        write(cbuffer1, '(I10)') 1
        write(cbuffer2, '(I10)') mod(i-1, isegment)+2
        write(cbuffer3, '(I10)') mod(i,   isegment)+2
        write(cbuffer4, '(I10)') 0
      else
        write(cbuffer1, '(I10)') 1
        write(cbuffer2, '(I10)') mod(i-1, isegment+1)+2
        write(cbuffer3, '(I10)') mod(i,   isegment+1)+2
        write(cbuffer4, '(I10)') 0
      end if

      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))//' '//&
          trim(adjustl(cbuffer3))//' '//trim(adjustl(cbuffer4))
    end do

    ! Initialize counter and process triangles in interior region
    iaux = 0

    ! Loop over all layers
    do j = 1, 2**irefine-1

      ! Update counter
      iaux = iaux + j

      ! Loop over all segments of the inner most coarse grid
      do i = 1, isegment

        ! Compute number of starting vertices in current layer and the
        ! next layer which is located interior to the current one
        if (dazimuth .ge. 2.0_DP*pi) then
          ivt = iaux*isegment+(i-1)*j+i+1
          jvt = (iaux-j)*isegment+(i-1)*(j-1)+i+1
        else
          ivt = iaux*isegment+i*(j+1)+1
          jvt = (iaux-j)*isegment+i*j+1
        end if

        ! Loop over all edges in the current layer
        do k = 1, iaux*isegment+i*(j+1)+1-ivt+&
                  merge(0, j, dazimuth .ge. 2.0_DP*pi)

          write(cbuffer1, '(I10)') ivt
          write(cbuffer2, '(I10)') ivt+1
          write(cbuffer3, '(I10)') jvt
          write(cbuffer4, '(I10)') 0

          write(100,'(A)') trim(adjustl(cbuffer1))//' '//&
                           trim(adjustl(cbuffer2))//' '//&
                           trim(adjustl(cbuffer3))//' '//&
                           trim(adjustl(cbuffer4))

          ! Increase vertex number in current layer
          ivt = ivt + 1

          write(cbuffer1, '(I10)') ivt
          ! Check if this is the last=first vertex in the inner layer
          if (jvt+1 .eq. iaux*isegment+&
                         merge(2, 2+j, dazimuth .ge. 2.0_DP*pi)) then
            write(cbuffer2, '(I10)') (iaux-j)*isegment+2
          else
            write(cbuffer2, '(I10)') jvt+1
          end if
          write(cbuffer3, '(I10)') jvt
          write(cbuffer4, '(I10)') 0

          write(100,'(A)') trim(adjustl(cbuffer1))//' '//&
                           trim(adjustl(cbuffer2))//' '//&
                           trim(adjustl(cbuffer3))//' '//&
                           trim(adjustl(cbuffer4))

          ! Increase vertex number in inner layer
          jvt = jvt + 1

        end do

        write(cbuffer1, '(I10)') ivt
        ! Check if this is the last=first vertex in the current layer
        if (ivt+1 .eq. (iaux+j+1)*isegment+2) then
          write(cbuffer2, '(I10)') jvt
        else
          write(cbuffer2, '(I10)') ivt+1
        end if
        ! Check if this is the last=first vertex in the inner layer
        if (jvt .eq. iaux*isegment+&
                     merge(2, 2+j, dazimuth .ge. 2.0_DP*pi)) then
          write(cbuffer3, '(I10)') (iaux-j)*isegment+2
        else
          write(cbuffer3, '(I10)') jvt
        end if
        write(cbuffer4, '(I10)') 0

        write(100,'(A)') trim(adjustl(cbuffer1))//' '//&
                         trim(adjustl(cbuffer2))//' '//&
                         trim(adjustl(cbuffer3))//' '//&
                         trim(adjustl(cbuffer4))
      end do
    end do

    !---------------------------------------------------------------------------
    ! Process connection layer between unstructured and structured grids
    !---------------------------------------------------------------------------
    do i = 1, nsegments

      ! Compute base vertex number
      ivt = nlayers*(i-1)

      if (dazimuth .ge. 2.0_DP*pi) then
        write(cbuffer1, '(I10)') mod(i-1,         nsegments)+nvt-nsegments+1
        write(cbuffer2, '(I10)') mod(ivt,         nsegments*nlayers)+nvt+1
        write(cbuffer3, '(I10)') mod(ivt+nlayers, nsegments*nlayers)+nvt+1
        write(cbuffer4, '(I10)') mod(i,           nsegments)+nvt-nsegments+1
      else
        write(cbuffer1, '(I10)') mod(i-1,         (nsegments+1))+nvt-nsegments
        write(cbuffer2, '(I10)') mod(ivt,         (nsegments+1)*nlayers)+nvt+1
        write(cbuffer3, '(I10)') mod(ivt+nlayers, (nsegments+1)*nlayers)+nvt+1
        write(cbuffer4, '(I10)') mod(i,           (nsegments+1))+nvt-nsegments
      end if

      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))//' '//&
          trim(adjustl(cbuffer3))//' '//trim(adjustl(cbuffer4))
    end do

  end if

  !-----------------------------------------------------------------------------
  ! Process outer structured grid
  !-----------------------------------------------------------------------------
  do i = 1, nsegments
    do j = 1, nlayers-1

      ! Compute base vertex number
      ivt = j-1 + nlayers*(i-1)

      if (dazimuth .ge. 2.0_DP*pi) then
        write(cbuffer1, '(I10)') mod(ivt,           nsegments*nlayers)+nvt+1
        write(cbuffer2, '(I10)') mod(ivt+1,         nsegments*nlayers)+nvt+1
        write(cbuffer3, '(I10)') mod(ivt+nlayers+1, nsegments*nlayers)+nvt+1
        write(cbuffer4, '(I10)') mod(ivt+nlayers,   nsegments*nlayers)+nvt+1
      else
        write(cbuffer1, '(I10)') mod(ivt,           (nsegments+1)*nlayers)+nvt+1
        write(cbuffer2, '(I10)') mod(ivt+1,         (nsegments+1)*nlayers)+nvt+1
        write(cbuffer3, '(I10)') mod(ivt+nlayers+1, (nsegments+1)*nlayers)+nvt+1
        write(cbuffer4, '(I10)') mod(ivt+nlayers,   (nsegments+1)*nlayers)+nvt+1
      end if

      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))//' '//&
                       trim(adjustl(cbuffer3))//' '//trim(adjustl(cbuffer4))
    end do
  end do

  !-----------------------------------------------------------------------------
  write(100,'(A)') 'KNPR'
  !-----------------------------------------------------------------------------

  if (dazimuth .ge. 2.0_DP*pi) then

    !---------------------------------------------------------------------------
    ! Full circle
    !---------------------------------------------------------------------------

    ! Write nodal property for interior vertices
    do i = 1, nvt
      write(100,'(A)') '0'
    end do

    do i = 1, nsegments
      ! Write nodal property for interior vertices
      do j = 1, nlayers-1
        write(100,'(A)') '0'
      end do
      ! Write nodal property for boundary vertices
      write(100,'(A)') '1'
    end do

  else

    !---------------------------------------------------------------------------
    ! Circle segment
    !---------------------------------------------------------------------------

    if (bexternalDelaunay) then

      ! Write nodal property for vertices in inner region
      open(unit=200, file=trim(adjustl(cfilename))//'.1.node')
      read(200, fmt=*) nvt
      do ivt = 1, nvt
        read(200, fmt=*) i, x, y, bdrPar, iaux
        write(100,'(A)') merge('1', '0', iaux .gt. 1)
      end do
      close(200)

    else ! Create nodal properties manually

      ! Write nodal property for vertex at origin
      write(100,'(A)') '1'

      ! Write nodal properties for vertices in the inner layer
      iaux = isegment

      ! Loop over all refinement steps
      do j = 1, 2**irefine

        ! Loop over all segments in current layer
        do i = 1, iaux

          if (i .eq. 1) then
            write(100,'(A)') '1'
          else
            write(100,'(A)') '0'
          end if
        end do

        ! Since the circle is not closed we have to add one extra vertex
        write(100,'(A)') '1'

        ! Increate the number of segments
        iaux = iaux + isegment
      end do

    end if

    ! Write nodal properties for vertices in the outer layer
    do i = 1, nsegments+1
      do j = 1, nlayers-1
        if ((i .eq. 1) .or. (i .eq. nsegments+1)) then
          ! Write nodal property for boundary vertex
          write(100,'(A)') '1'
        else
          ! Write nodal property for interior vertex
          write(100,'(A)') '0'
        end if
      end do

      ! Write nodal property for boundary vertex
      write(100,'(A)') '1'
    end do

  end if

  !-----------------------------------------------------------------------------
  write(100,'(A)') 'KMM'
  !-----------------------------------------------------------------------------

  if (dazimuth .ge. 2.0_DP*pi) then
    write(cbuffer1, '(I10)') nlayers+nvt
    write(cbuffer2, '(I10)') nlayers*nsegments+nvt
  else
    write(cbuffer1, '(I10)') nlayers+nvt
    write(cbuffer2, '(I10)') nlayers+nvt-1
  end if

  write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))

  close(100)

end program gridgencirc2d


!----------------------------------------------------------------------*
! SUBROUTINE SGPC1                                                     *
! Authors: Daniel van Kraalingen                                       *
! Date   : 15-Dec-1993, Version: 1.0                                   *
! Purpose: This subroutine performs a Gaussian integration over        *
!          depth of canopy by selecting three different GAI's and      *
!          computing assimilation at these GAI levels. The             *
!          integrated variable is GPC. Also absorbed PAR is            *
!          integrated in RAPC                                          *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning                                     units  class *
! ----   ---- -------                                     -----  ----- *
! CSLV    R4  Scattering coefficient of leaves for           -      I  *
!             visible radiation (PAR)                                  *
! AMAX    R4  Assimilation rate at light saturation       kg CO2/   I  *
!                                                        ha leaf/h     *
! EFF     R4  Initial light use efficiency               kg CO2/J/  I  *
!                                                        ha/h m2 s     *
! ECPDF   R4  Extinction coefficient for          ha ground/ha leaf I  *
!             diffuse light                                            *
! GAI     R4  Green area index                             ha/ha    I  *
! SINB    R4  Sine of solar height                           -      I  *
! RDPDR   R4  Instantaneous flux of direct photo-          W/m2     I  *
!             synthetically active radiation (PAR)                     *
! RDPDF   R4  Instantaneous flux of diffuse photo-         W/m2     I  *
!             synthetically active irradiation (PAR)                   *
! GPC     R4  Instantaneous assimilation rate of          kg CO2/   O  *
!             whole canopy                               ha soil/h     *
! RAPC    R4  Absorbed PAR                                 W/m2     O  *
!                                                                      *
! Fatal error checks: none                                             *
! Warnings          : none                                             *
! Subprograms called: SGPL                                             *
! File usage        : none                                             *
!----------------------------------------------------------------------*

      SUBROUTINE SGPC1 (CSLV , AMAX , EFF, ECPDF, GAI, SINB, &
                        RDPDR, RDPDF, GPC, RAPC)
      IMPLICIT NONE

!     Formal parameters
      REAL CSLV, AMAX, EFF, ECPDF, GAI, SINB, RDPDR, RDPDF, GPC, RAPC

!     Local parameters

!     Gauss parameters
      INTEGER IGSN
      PARAMETER (IGSN=3)
      REAL GSX(IGSN), GSW(IGSN)

!     Miscellaneous
      REAL GAID, GPL, RAPL
      INTEGER I1

      SAVE         ! TAOLI

!     Gauss weights for three point Gauss
      DATA GSX /0.112702, 0.500000, 0.887298/
      DATA GSW /0.277778, 0.444444, 0.277778/

!     Selection of depth of canopy, canopy assimilation is set to zero
      GPC  = 0.
      RAPC = 0.

      DO I1=1,IGSN
         GAID = GAI * GSX(I1)

         CALL SGPL (CSLV , AMAX , EFF , ECPDF, GAI, GAID, SINB, &
                    RDPDR, RDPDF, GPL , RAPL)

!        Integration of local assimilation rate to canopy
!        assimilation (GPC) and absorption of PAR by canopy (RAPC)
         GPC  = GPC  + GPL  * GSW(I1)
         RAPC = RAPC + RAPL * GSW(I1)

      END DO

      GPC  = GPC  * GAI
      RAPC = RAPC * GAI

      RETURN
      END


      SUBROUTINE jacobi(a,n,np,d,v,nrot)
      INTEGER n,np,nrot,NMAX
      REAL a(np,np),d(np),v(np,np)
      PARAMETER (NMAX=500)
      INTEGER i,ip,iq,j
      REAL c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX)
      do 12 ip=1,n
        do 11 iq=1,n
          v(ip,iq)=0.
11      continue
        v(ip,ip)=1.
12    continue
      do 13 ip=1,n
        b(ip)=a(ip,ip)
        d(ip)=b(ip)
        z(ip)=0.
13    continue
      nrot=0
      do 24 i=1,50
        sm=0.
        do 15 ip=1,n-1
          do 14 iq=ip+1,n
            sm=sm+abs(a(ip,iq))
14        continue
15      continue
        if(sm.eq.0.)return
        if(i.lt.4)then
          tresh=0.2*sm/n**2
        else
          tresh=0.
        endif
        do 22 ip=1,n-1
          do 21 iq=ip+1,n
            g=100.*abs(a(ip,iq))
            if((i.gt.4).and.(abs(d(ip))+
     *g.eq.abs(d(ip))).and.(abs(d(iq))+g.eq.abs(d(iq))))then
              a(ip,iq)=0.
            else if(abs(a(ip,iq)).gt.tresh)then
              h=d(iq)-d(ip)
              if(abs(h)+g.eq.abs(h))then
                t=a(ip,iq)/h
              else
                theta=0.5*h/a(ip,iq)
                t=1./(abs(theta)+sqrt(1.+theta**2))
                if(theta.lt.0.)t=-t
              endif
              c=1./sqrt(1+t**2)
              s=t*c
              tau=s/(1.+c)
              h=t*a(ip,iq)
              z(ip)=z(ip)-h
              z(iq)=z(iq)+h
              d(ip)=d(ip)-h
              d(iq)=d(iq)+h
              a(ip,iq)=0.
              do 16 j=1,ip-1
                g=a(j,ip)
                h=a(j,iq)
                a(j,ip)=g-s*(h+g*tau)
                a(j,iq)=h+s*(g-h*tau)
16            continue
              do 17 j=ip+1,iq-1
                g=a(ip,j)
                h=a(j,iq)
                a(ip,j)=g-s*(h+g*tau)
                a(j,iq)=h+s*(g-h*tau)
17            continue
              do 18 j=iq+1,n
                g=a(ip,j)
                h=a(iq,j)
                a(ip,j)=g-s*(h+g*tau)
                a(iq,j)=h+s*(g-h*tau)
18            continue
              do 19 j=1,n
                g=v(j,ip)
                h=v(j,iq)
                v(j,ip)=g-s*(h+g*tau)
                v(j,iq)=h+s*(g-h*tau)
19            continue
              nrot=nrot+1
            endif
21        continue
22      continue
        do 23 ip=1,n
          b(ip)=b(ip)+z(ip)
          d(ip)=b(ip)
          z(ip)=0.
23      continue
24    continue
      pause 'too many iterations in jacobi'
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/jacobi.for


      SUBROUTINE CONV_GEO_CRD(LATIN,LONIN,HEIGHT,
     $             LATOUT,LONOUT,IFLAG,IERROR)
c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c  Part of "NEWBILCAL" program to produce IGRF geomagnetic model (GSFC)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c  ------------------------------------------------------------------------
C
C Here comes a subroutine from SuperDARN to compute Altitude-corrected
C geomagnetic coordinates
C
C How do I convert a geographic position to AACGM (or vice versa)?
C There are two ways to do this. The direct call to the new AACGM software is:
C
C [in FORTRAN]
C       CALL CONV_GEO_CRD(x_in_lat, x_in_long, x_height,
C                         x_out_lat, x_out_long, i_flag, i_err)
C where:
C   x_in_lat  =  input latitude (in degrees)(real single precision)
C   x_in_long =  input longitude (in degrees) (real single precision)
C   x_height  =  input altitude (in km) (real single precision)
C   x_out_lat =  returned magnetic latitude (real single precision)
C   x_out_long = returned magnetic longitude (real single precision)
C   i_flag    =  1 (32-bit integer) [flag indicating geo->AACGM conversion]
C   i_err     =  returned integer error code (0 = OK)
C
C latitude must be in the range -90 to +90.
C longitude must be in the range 0 to 360
C height must be in the range 0 to 2000
C out_lat is returned in the range -90 to + 90
C out_long is returned in the range 0 to 360
C i_flag must be 1 (geo->AACGM) or 2 (AACGM->geo)
C i_err (see below)
C
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C     Purpose:
C
C         This subroutine uses a set of spherical harmonic coefficients to
C         perform a coordinate conversion between geographic and corrected
C         geomagnetic coordinates (or vice versa).
C
C         The spherical harmonics for the geographic to corrected geomagnetic
C         coordinate system correspond to a conversion from geographic to
C         the corrected geomagnetic coordinates (expressed in terms of
C         centered dipole coordinates at the input altitude), and are then
C         transformed to ground level.
C
C         The spherical harmonic coefficients used for the inverse are
C         computed relative to centered dipole coordinates at the input
C         altitude. The input CGM coordinates are converted to equivalent
C         values in this coordinate sytem using the inverse altitude
C         algorithm before the evaluation of the geographic spherical
C         harmonic expansion.
C
C     Method:
C
C         This subroutine uses a five-step process in converting a position
C         in one coordinate system to a position in the other.
C         The five steps are as follows:
C
C         1.  The appropriate spherical harmonic coefficients for the
C             coordinate conversion are computed for the input altitude.
C
C         2.  The appropriate coordinates for use in the spherical harmonic
C             expansion are computed. For the geographic ==> corrected
C             geomagnetic coordinate version, these are geographic colatitude
C             and longitude. For the inverse coordinate conversion, the
C             input coordinates are first converted into equivalent dipole
C             coordinates at the input altitude.
C
C         3.  The Cartesian coordinates of the unit vector in the desired
C             coordinate system are then computed using the appropriate
C             spherical harmonic expansion.
C
C         4.  For the geographic ==> corrected geomagnetic coordinate
C             conversion, the dipole-equivalent coordinates at input
C             altitude are converted to their cgm cartesian coordinates.
C
C         5.  Standard trigonometric identities are used to compute the
C             latitude and longitude in the desired output coordinate system.
C
C     Input Arguments:
C
C         LATIN        - REAL*4 - The input latitude in degrees.
C                        This could be either geographic latitude
C                        or corrected geomagnetic latitude.  The
C                        acceptable range of values is (-90 to +90
C                        degrees).
C
C         LONIN        - REAL*4 - The input longitude in degrees east.
C                        This could be either geographic longitude
C                        or corrected geomagnetic longitude.  The
C                        acceptable range of values is (0 to 360 degrees).
C
C         HEIGHT       - REAL*4 - The height in kilometers for which the
C                        coordinate transformation will be accomplished.
C                        The acceptable range of values is (0 km to
C                        2000 km)
C
C         IFLAG        - INTEGER - The flag that indicates which way
C                        the conversion will proceed.
C
C                        = 1  convert geographic to corrected
C                                 geomagnetic coordinates
C
C                        = 2  convert corrected geomagnetic
C                                 to geographic coordinates
C
C     Output Arguments:
C
C         LATOUT      - REAL*4 - The output latitude in degrees.
C                       This could be either the geographic latitude
C                       or corrected geomagnetic latitude.  This
C                       value will be between -90 and +90 degrees.
C
C         LONOUT      - REAL*4 - The output longitude in degrees.
C                       This could be either geographic longitude or
C                       corrected geomagnetic longitude.  This
C                       value will be between 0 and 360 degrees.
C
C         IERROR      - INTEGER - The error flag
C
C                       =  0  normal processing
C                       = -2  R_HEIGHT_IN is outside the allowable range
C                       = -4  I_FLAG value is invalid
C                       = -8  R_LAT_IN is outside the allowable range
C                       = -16 R_LON_IN is outside the allowable range
C                       = -32 Magnitude of the "unit vector" of the
C                             target coordinate system deviates
C                             significantly (+/- 10% or more) from 1.
C                       = -64 For altitudes > 0, for the corrected
C                             geomagnetic to geographic coordinate
C                             conversion there is a range of latitudes
C                             for which the transformation is invalid.
C                             This flag is set when the requested input
C                             cgm latitude falls within the invalid
C                             region.
C
C     Local Variables:
C
C         DCINT(,,)       - Double Precision Array (3-D) -
C                            Contains the spherical harmonic coefficients
C                            interpolated to the input height, R_HEIGHT_IN.
C
C         DCOEF(,,,)      - Double Precision Array (3-D) -
C                            Contains the spherical harmonic coefficients
C                            used to compute the Cartesian coordinates of
C                            unit vector in the target coordinate system.
C
C                            First index: sp. harm. coeff. index
C                            Second       x, y, z components of unit vector
C                            Third        altitude indices 0, 300, 1200 km
C                            Fourth       direction of conversion index
C
C                            coefficients for a given altitude have the form
C
C                            a0 + h a1 + h * h a2 where h = alt/1000 [km]
C
C         DCOLTEMP         - Double Precision - colatitude (radians) in the
C                            input coordinate system
C
C         DLONTEMP         - Double Precision - longitude (radians) in the
C                            input coordinatesystem
C
C         DX,DY,DZ         - Double Precision - the XYZ-components of the
C                            unit radius vector in target coordinate system
C
C         DR               - Double Prec unit radius in target coord system
C
C         DYLMVAL          - Double Precision - the array of spherical
C                            harmonic basis functions evaluated at
C                            a particular colatitude and longitude.
C
C         IERR64           - Logical - error flag of CGM2ALT routine
C
C         K,L,M            - Integer  indices of spherical harmonic functions
C
C         HEIGHTOLD(2)     - Real*4 Array  - Variable containing
C                            previous height (km) used to determine whether
C                            the interpolation to compute DCINT() from
C                            DCOEF() needs to be done.
C
C         LATADJ           - Real*4 - result of ALT2CGM or CGM2ALT conversion.
C
C         LATALT           - Real*4 - altitude at dipole latitude.
C
C         RR               - Real*4 - magnitude of unit vector (DR in float)
C
C     Constants:
C         NAXES       - Integer  - the number of axes in a Cartesian
C                            coordinate system (3)
C         NFLAG       - Integer  - the number of coordinate trans-
C                            formation flags available (2)
C         NLEVEL      - Integer  - the number of grid levels
C                            available.  This is the number of
C                            distinct heights for which there are
C                            spherical harmonic coefficients available
C         IORDER          - Integer  - the order of the spherical harmonic
C                            expansion used.
C
C         DEGRAD           - Double Precision  - the multiplicative
C                            conversion factor for converting degrees
C                            to radians
C
C         PI               - Double Precision  - mathematical constant
C
C     Subroutines Required:
C
C         RYLM              - This subroutine returns the spherical harmonic
C                            function value array for a given colatitude and
C                            longitude.  The spherical harmonics are returned
C                            in the D_YLMVAL array.
C
C         CG_ALT_DIP       - Given altitude (km), latitude, and a direction
C                            flag, returns altitude corrected latitude, and
C                            an error flag. See comments in subroutine for
C                            additional information.
C
C     Files Used at Compile Time:
C     Files Used at Run Time:  None
C     Databases Accessed:  None
C
C     Warnings:
C
C     1. For certain values of Corrected Geomagnetic Coordinates, the
C        transformation to Geographic Coordinates (Geocentric) is
C        undefined. When this situation occurs, an error flag is set
C        IERROR = -64 and returned to the calling routine.
C
C     Revision History:
C        Original Routine was converted to a standard library
C        subroutine for SFC$$ by MFS on  14 OCT 1992.
C
C     09/17/93 SPR1993-0203 (SWS) The return condition value needs to
C             be initialized before coordinate conversion processing begins
C
C     08/18/93 SPR1993-0175 (SWS) Routine performed a comparison of
C             Z with a -1.D0. The variable Z should be D_Z.
C
C     The present routine represents the use of an improved algorithm for
C     the computation of corrected geomagnetic coordinates and (where
C     it exists) the inverse, together with the use of an updated
C     magnetic field model (IGRF 1995).
C
C     The present routine incorporates the functionality of the previous
C     routine, and, uses the same subroutine calls. Relevent portions of
C     the old FORTRAN code have been retained where possible.
C
C     The new algorithm and the current code have been developed by
C     Radex, Inc, 3 Preston Court, Bedford, MA 01730. A technical
C     report describing the improved algorithm, and discussing its
C     limitations is in preparation, and will be published as a
C     Philips Laboratory technical report entitled:.
C
C     An Improved Algorithm for the Computation of Corrected Geomagnetic
C     Coordinates, by K. Bhavnani and C. Hein.
C
C     The principal changes implementing the new algorithm and code are
C     as follows:
C
C        (1) The set of spherical harmonic function values are computed
C            recursively using a single call to a new subroutine RYLM
C            rather than using repetitive function call.
C
C            Computationally this method is much faster than computing
C            each of the spherical harmonics as they are needed.
C
C        (2) The new spherical harmonic coefficients are based upon
C            the IGRF 95 magnetic field model. The order of the
C            spherical harmonic expansion used here is 10 (previously
C            was 4).
C
C        (3) The coefficients represent a quadratic fit to the spherical
C            harmonic fits at 0, 300 and 1200 km altitude. The allowable
C            range of altitudes is 0 - 2000 km. The previous version used
C            polynomial interpolations of the coefficients at 0, 150,
C            300 and 450 km.
C
C        (4) The spherical harmonic coefficients were computed in an
C            auxilliary coordinate system, which is aligned with the
C            desired target coordinate system. This results in a
C            considerable simplification of the code, eliminating the
C            need to perform multiple coordinate system rotations.
C
C     17/07/95
C
C     MODIFIED FOR THE IGRF 95 MAGNETIC FIELD MODEL.
C
C     CHANGES: BLOCKDATA SECTION HAS BEEN REPLACED WITH COEFFICIENTS
C              APPROPRIATE FOR THE IGRF 1995 MODEL
C
C              REFERENCES TO IGRF 90 IN THE COMMENT LINES HAVE BEEN
C              CHANGED TO IGRF 95.
C
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   RCS revision log for POSIX systems
c
c $Log: conv_geo_crd.f,v $
c Revision 1.1.1.1  2000/07/12 19:25:10  ecf-poa
c stpoa branch with a close version to the first release
c
c Revision 2.2  2000/07/11 12:26:29  aalexov
c Updated all the code to have a history (new history for poa
c code) and appended a history for calfos files which were
c updated by us.  Also deleted .f files from the reposutory
c which were no longer being used (cleaning up).
c
c Revision 2.1  2000/07/10 19:06:37  aalexov
c These are Michael's changes, for the release.  Comments were
c added for the headers of all poa new files.  Also, new files
c were created in order to make sure that all subroutines were
c in their own files.  mkpkg was updated to look "clean".
c
c Revision 2.0  2000/05/02 14:52:02  mrosa
c Re-delivery of POA_calfos from April 5, 2000
c
c Revision 1.1  1999/12/07 13:22:58  aalexov
c updates to calfos using Michael Rosa's flight software code and
c POA code;  data files are now preprocessed with additions of new
c group parameter keywords which are updated (per group) using these
c new code additions.  the new pieces of code calculate the
c hst positions, velocities, geomagnetic vectors and pixel offsets in
c x and y;  the code places these new values in the new header keywords.
c the results are also printed to the screen.  new "calibration" tables
c are used (norad and dgrf files).
c
c Revision 1.6  1996/03/20  22:53:03  baker
c Explicitly declared the sizes of the arguments to the
c subroutine.  This should help avoid compatibility
c problems when mixing C and Fortran with different
c machines and different compilers.
c
c Revision 1.5  1996/03/12  18:59:18  baker
c Added code to force a recomputation of the
c conversion coefficients at a given ghheight if the
c coordinates model has changed from the last call.
c
c Revision 1.4  1996/03/11  19:25:36  baker
c Modifications for the 1995 version of AACGM.
c
c Revision 1.3  94/10/17  12:35:32  12:35:32  baker (Kile Baker S1G)
c added error code -64 to indicate invalid magnetic coordinates specified
c as input.  This also requires a change in the call to cg_alt_dip
c
c Revision 1.2  94/10/14  10:53:36  10:53:36  baker (Kile Baker S1G)
c Added the SAVE instruction to make variables static
c
c Revision 1.1  94/10/12  15:28:38  15:28:38  baker (Kile Baker S1G)
c Initial revision
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      SAVE    !make all variables static
C
      INTEGER IORDER,IERROR,IFLAG,NTERMS,NAXES,NLEVEL,NFLAG

      REAL*8 DCINT(121,3,2)
      REAL*8 DCOEF(121,3,3,2)
      REAL*8 DYLMVAL(121)
c
      REAL*8 DCOLTEMP,DLONTEMP
      REAL*8 COLATI,COLATO,DLONI,DLONO
      REAL*8 DX,DY,DZ,DR
      REAL*8 PI, DEGRAD
      REAL*8 FCOEFFOLD

      REAL*4 HEIGHT,LATIN,LONIN,LATOUT,LONOUT,LATADJ,LATALT
      REAL*4 HEIGHTOLD(2)
      REAL*4 altvar, altvarsq,rr
      INTEGER i,j,k,l,m
      LOGICAL       IERR64
C
      COMMON /IGRCOEFF/ DCOEF

      DATA IORDER /10/      ! Set the order used in this algorithm to 10.
C         Parameterize the maximum values of the indices of the
C         spherical harmonic coefficient array D_COEF( , , , ) and the
C         interpolated spherical harmonic coefficient array, D_CINT( , , ).
      DATA NTERMS,NAXES,NLEVEL,NFLAG /121,3,3,2/
c      REAL*8 DCINT(NTERMS,NAXES,NFLAG)
c      REAL*8 DCOEF(NTERMS,NAXES,NLEVEL,NFLAG)
c      REAL*8 DYLMVAL(NTERMS)
      DATA PI /3.141592656589793D0/
      DATA DEGRAD /1.745329251994330D-2/
      DATA HEIGHTOLD,FCOEFFOLD/-1.,-1.,-1.D0/ !Initialize to impossible values.
C
C     The COMMON block / SPH_HARM_MODEL / array D_COEF contains
C     the spherical harmonic coefficients used to generate the
C     Cartesian coordinates of the unit vector in the target coordinate
C     system.  The target coordinate system is the system to which
C     the algorithm is converting and is the coordinate system
C     corresponding to the output variables, R_LAT_OUT and R_LON_OUT.
C
C     The coefficient set is stored in a 4-dimensional array with
C     indices defined as follows:
C
C         First Index  - Represents the number of terms used in the
C                        spherical harmonic expansion. Equal to
C                        (I_ORDER + 1) * (I_ORDER + 1)
C
C         Second Index - Represents the Cartesian coordinate a particular
C                        coefficient will be used to generate.  Indices are
C                        defined as follows:
C
C                        1  - X-coordinate (the X-axis points from the
C                             center of the earth to where the prime
C                             meridian crosses the equator.
C
C                        2  - Y-coordinate (the Y-axis points from the
C                             center of the earth to 90 degrees east
C                             of the X-axis)
C
C                        3  - Z-coordinate (the Z-axis points from the
C                             center of the earth to the north pole)
C
C         Third Index  - Represents the terms of a quadratic fit to
C                        altitude (independent variable h =
C                        altitude [km]/1200) for a given spharical
C                        harmonic coefficient. The indices are defined
C                        as follows:
C
C                        1  - Constant term: corresponds to the fit at
C                             0 km altitude
C                        2  - linear term
C                        3  - quadratic term
C
C         Fourth Index - Represents the direction of the coordinate
C                        transformation.  Indices are defined as follows:
C
C                        1  - Conversion of geographic coordinates to
C                             corrected geomagnetic coordinates.
C
C                        2  - Conversion of corrected geomagnetic coordinates
C                             to geographioc coordinates.
C
C
C     The Data for D_COEF is provided in a BLOCK DATA file (see below)
c
C     Initialize the error return condition indicator
      IERROR = 0
      PI = 4.0D0*DATAN(1.0D0)

C
C This IF statement checks to see if the magnetic
C     coordinates model has been changed.  If so, we
C     have to force the recalculation of the conversion
C     coefficients, by resetting the values of the old height
      IF ( FCOEFFOLD .NE. DCOEF(1,1,1,1)) THEN
         HEIGHTOLD(1) = -1
         HEIGHTOLD(2) = -1
      ENDIF
      FCOEFFOLD = DCOEF(1,1,1,1)
C
C Checkin input arguments to ensure they are within allowable ranges.
      IF ((HEIGHT .LT. 0.) .OR. (HEIGHT .GT. 2000.)) THEN
C     The height in kilometers is outside the allowable range.
        IERROR = -2
        RETURN
      ELSEIF ((IFLAG .LT. 1) .OR. (IFLAG .GT. 2)) THEN
C     The conversion flag is neither 1 nor 2.
        IERROR = -4
        RETURN
      ELSEIF (ABS(LATIN) .GT. 90.) THEN
C     The latitude is outside the allowable range.
        IERROR = -8
        RETURN
      ELSEIF ((LONIN .LT. 0.) .OR. (LONIN .GT. 360.)) THEN
C     The longitude is outside the allowable range.
        IERROR = -16
        RETURN
      ENDIF
C All input arguments are within allowable ranges.
C
C Compute Spherical Harmonic Coefficients for current altitude if required
      IF (HEIGHT .NE. HEIGHTOLD(IFLAG)) THEN
        ALTVAR    = HEIGHT/1200.0
        ALTVARSQ  = ALTVAR * ALTVAR
        DO 20 I = 1, 3
         DO 10 J = 1, 121
           DCINT(J,I,IFLAG) = DCOEF(J,I,1,IFLAG) + ALTVAR *
     $     DCOEF(J,I,2,IFLAG) + ALTVARSQ *  DCOEF(J,I,3,IFLAG)
 10        CONTINUE
 20     CONTINUE
        HEIGHTOLD(IFLAG) = HEIGHT
      ENDIF
C
C Zero Sums for Spherical Harmonic Expansion Computation
      DX = 0.0D0
      DY = 0.0D0
      DZ = 0.0D0
C
C Prepare for Spherical Harmonic Expansion Computation
      DLONI   = DBLE(LONIN) * DEGRAD
      IF (IFLAG .EQ. 1) THEN
C     Computing CGM from Geographic Coordinates. No altitude
C     correction required
        COLATI = (90.0D0 - DBLE(LATIN)) * DEGRAD
      ELSE
C     Computing Geographic Coordinates from CGM Coordinates.
C     Convert CGM Latitude to Dipole Latitude at Altitude HEIGHT
        CALL CGM2ALT(HEIGHT,LATIN,LATADJ,IERR64)
        IF (IERR64 .EQV. .TRUE.) THEN
            IERROR = -64
            RETURN
        ENDIF
        COLATI = (90.0D0 - DBLE(LATADJ)) * DEGRAD
      ENDIF
C
C Generate the spherical harmonics at the coordinate point
      CALL RYLM(COLATI,DLONI,IORDER,DYLMVAL)
C
C Calculate cartesian coordinates of unit vector in target coordinate system.
      DO 40 L= 0, IORDER
        DO 30 M = -L, L
          K = L * (L + 1) + M + 1
C         Add the contribution of each spherical harmonic to the
C         Cartesian components of the unit vector in the
C         appropriate coordinate system.
          DX = DX + DCINT(K,1,IFLAG) * DYLMVAL(K)
          DY = DY + DCINT(K,2,IFLAG) * DYLMVAL(K)
          DZ = DZ + DCINT(K,3,IFLAG) * DYLMVAL(K)
 30     CONTINUE
 40   CONTINUE
C
C Compute magnitude of Cartesian unit vector of magnetic dipole coord system.
      DR = SQRT(DX * DX + DY * DY + DZ * DZ)
C       If the magnitude of the unit vector differs significantly
C       from 1, set the error flag and continue processing.
        IF ((DR .LT. 0.9D0) .OR. (DR .GT. 1.1D0)) THEN
          RR = SNGL(DR)
          IERROR = -32
          RETURN
        ENDIF
C
C Adjust the components so they do represent the components of
C       a unit vector.  If DR is equal to 1.0D0, this step will not
C       change the values of D_X, D_Y, or D_Z.
        DZ = DZ / DR
        DX = DX / DR
        DY = DY / DR
C
C Obtain output co_latitude and longitude from the unit
C           vector using standard formulas
        IF (DZ .GT. 1.0D0) THEN
          DCOLTEMP = 0.0D0
        ELSE IF (DZ .LT.- 1.0D0) THEN
          DCOLTEMP = PI
        ELSE
          DCOLTEMP = DACOS(DZ)
        ENDIF
c
        IF ((ABS(DX) .LT. 1.0D-8) .AND. (ABS(DY) .LT. 1.0D-8)) THEN
          DLONTEMP = 0.0D0
        ELSE
          DLONTEMP = DATAN2(DY,DX)
        ENDIF
C
C Prepare Latitude Data for Output
       DLONO   = DLONTEMP
       IF (IFLAG .EQ. 1) THEN
         LATALT = 90.0 - DCOLTEMP/DEGRAD
         CALL ALT2CGM(HEIGHT,LATALT,LATADJ)
         COLATO = (90.0D0 - DBLE(LATADJ)) * DEGRAD
       ELSE
         COLATO = DCOLTEMP
       ENDIF
C
C Convert colatitude into latitude and convert both coordinates
C     from REAL*8 radians to REAL degrees.
      LATOUT = SNGL(90.0D0 - COLATO / DEGRAD)
      LONOUT = SNGL(DLONO / DEGRAD)
      IF (LONOUT .LT. 0.0) LONOUT = LONOUT + 360.
C
      RETURN
c90    FORMAT(' INVERSE UNDEFINED AT CGM LAT ',F6.2,' CGM LON ',F7.2,
c     $ ' ALTITUDE ',F8.2)
      END


!     ------------------------------------------------------------------
!              H N O R M
!     ------------------------------------------------------------------
!
!       Returns the value of the normalization constant for an (nl)
!   hydrogenic function with nuclear charge ZZ.
!
!
      REAL(KIND(0.0D0)) FUNCTION HNORM (N, L, ZZ)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE PARAM_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: L
      REAL(DOUBLE) , INTENT(IN) :: ZZ
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: M, I
      REAL(DOUBLE) :: A, B, T, D
!-----------------------------------------------
      M = L + L + 1
      A = N + L
      B = M
      T = A
      D = B
      M = M - 1
      IF (M /= 0) THEN
         DO I = 1, M
            A = A - D1
            B = B - D1
            T = T*A
            D = D*B
         END DO
      ENDIF
      HNORM = DSQRT(ZZ*T)/(N*D)
      RETURN
      END FUNCTION HNORM


module mod_functional
    use iso_fortran_env, only : i1 => int8, i2 => int16
    implicit none
    private
    public :: f_i1, f_i2

    interface
        ! no result?
        pure integer(kind = i1) function f_i1(x)
            import :: i1
            integer(i1), intent(in) :: x
        end function f_i1
        pure integer(kind = i2) function f_i2(x)
            import :: i2
            integer(i2), intent(in) :: x
        end function f_i2
    end interface
end module mod_functional

module mod_interfaces
    use iso_fortran_env, only : i1 => int8, i2 => int16, i4 => int32
    use mod_functional
    implicit none

    interface map
        module procedure :: map_i1, map_i2
    end interface map

contains
    ! map accepts a function and an array as parameters
    pure function map_i1(f, x) result(map)
        procedure(f_i1) :: f !->?
        integer(i1), dimension(:), intent(in) :: x
        integer(i1), dimension(size(x)) :: map
        integer(i4) :: i
        map = [(f(x(i)), i = 1, size(x))]
    end function map_i1

    pure function map_i2(f, x) result(map)
        procedure(f_i2) :: f
        integer(i2), dimension(:), intent(in) :: x
        integer(i2), dimension(size(x)) :: map
        integer(i4) :: i
        map = [(f(x(i)), i = 1, size(x))]
    end function map_i2
end module mod_interfaces

program test_map
    use iso_fortran_env, only : i1 => int8, i2 => int16, i4 => int32
    use mod_interfaces
    implicit none
    integer(i1), dimension(1:3):: x_i1 = (/ 3_i1, 4_i1, 5_i1 /)
    integer(i2), dimension(1:3):: x_i2 = (/ 3_i2, 4_i2, 5_i2 /)
    integer(i1), dimension(size(x_i1)) :: res_i1
    integer(i2), dimension(size(x_i2)) :: res_i2
    res_i1 =  map_i1(xpowx_i1, x_i1)
    print *, res_i1

    res_i2 =  map_i2(xpowx_i2, x_i2)
    print *, res_i2

contains
    pure integer(i1) function xpowx_i1(x) result(res)
        integer(i1), intent(in) :: x
        res = x * x + 5_i1
    end function xpowx_i1

    pure integer(i2) function xpowx_i2(x) result(res)
        integer(i2), intent(in) :: x
        res = x * x + 3_i2
    end function xpowx_i2
end program test_map


PROGRAM functions
    IMPLICIT NONE

    ! REAL :: x
    ! READ*, x
    ! PRINT*, Negative(x)
    ! CONTAINS
    ! REAL FUNCTION Negative(a)
    !     REAL:: a
    !     Negative = -a
    !     return
    ! END FUNCTION

    ! REAL:: x, y, z
    ! x = 3
    ! y = 4
    ! z = F(x, y)
    ! print *, z
    ! CONTAINS
    ! REAL FUNCTION F(x, y)
    !     IMPLICIT NONE
    !     REAL:: x, y
    !     F = sqrt(x*x + y*y)
    ! END FUNCTION
    ! function F(n1, n2) result(sum)
    !     implicit NONE
    !     real :: n1, n2
    !     real :: sum
    !     sum = sqrt(n1*n1 + n2*n2)
    ! end function

    ! integer:: ans
    ! ans = get_sum2(5, 4)
    ! print *, ans
    ! contains
    ! integer function get_sum(n1, n2)
    !     implicit NONE
    !     integer :: n1, n2, sum
    !     sum = n1 + n2
    ! end function
    ! function get_sum2(n1, n2) result(sum)
    !     implicit NONE
    !     integer :: n1, n2
    !     integer :: sum
    !     sum = n1+n2
    ! end function

END

! REAL FUNCTION F(x, y)
!     IMPLICIT NONE
!     REAL:: x, y
!     F = sqrt(x*x + y*y)
! END FUNCTION


PROGRAM F024

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: N_MAX = 10
    INTEGER, PARAMETER :: I     = 1000000

    CHARACTER (LEN=1), DIMENSION(N_MAX) :: NUMBERS = &
    (/ "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" /)

    INTEGER                    :: N               = N_MAX
    INTEGER (KIND=8)           :: N_PRODUCT       = N_MAX
    INTEGER (KIND=8)           :: MAX_PERMUTATION = 1

    CHARACTER (LEN=N_MAX)      :: DIGITS_VAL

    INTEGER :: J, INDEX_VAL

    DO J = 2, N_MAX
        MAX_PERMUTATION = MAX_PERMUTATION * J
    END DO

    INDEX_VAL = FLOOR(REAL((I - 1) * N_PRODUCT) / REAL(MAX_PERMUTATION)) + 1

    DIGITS_VAL(1:1) = NUMBERS(INDEX_VAL)

    DO J = 2, N_MAX

        N = N - 1
        N_PRODUCT = N_PRODUCT * N

        IF (INDEX_VAL < (N_MAX - 1)) NUMBERS(INDEX_VAL:N_MAX) = EOSHIFT(       &
                                     NUMBERS(INDEX_VAL:N_MAX), 1, "0")

        INDEX_VAL = MOD(FLOOR(REAL((I - 1) * N_PRODUCT)                        &
                  / REAL(MAX_PERMUTATION)), N) + 1

        DIGITS_VAL(J:J) = NUMBERS(INDEX_VAL)

    END DO

    PRINT ('(A)'), DIGITS_VAL

END PROGRAM F024


!--------------------------------------------------
!PHY2063 A1
!URN 6309823 - Penguin Lab Group 1B
!November 19th 2015
!--------------------------------------------------

Program A1
  IMPLICIT NONE

  REAL          ::  ran,lambda,energy,distance,thick
  REAL          ::  sum_distance,ave_distance,ave_distance_sqr,sum_distance_sqr
  REAL          ::  sum_energy, ave_energy,sum_energy_sqr,ave_energy_sqr
  REAL          ::  SD_distance,SD_energy
  INTEGER       ::  i,iseed,first,n
  real,external ::  rand,ran_exp

  first=0
  iseed=971739
  ran=rand(iseed,first)

  write(6,*)' '
  write(6,*)'This program estimates the average fractional energy lost from'
  write(6,*)'particles to a slab of material of thickness, t, due to inelastic'
  write(6,*)'scattering of the particles from the atoms of the material.'
  write(6,*)' '
  write(6,*)'This program assumes, that in each inelastic scattering event,'
  write(6,*)'the particle loses a random fraction, uniformly distributed'
  write(6,*)"between 0 and 1 of it's energy."
  write(6,*)' '

  write(6,*)'The number the pseudo-random number generator'
  write(6,*)'gives me is:',ran
  write(6,*)' '
  write(6,'(a,i9)')'seed value that generates this sequence is ',iseed
  write(6,*)' '

! now the exponential distribution has one parameter
! this is its mean, given by the variable: lambda
! distribution for is then p(x)=exp(-x/lambda) / lambda
! set lambda

! Attempt lambda with values of 1 and 100

  write(6,*)'What is your value of lambda?'
  read (5,*)lambda
  write(6,*)' '

! call lambda

! Attempt thickness with values of 100 and 1

  write(6,*)'What is the thickness of the detector?'
  read (5,*)thick
  write(6,*)' '
  write(6,*)'The number of particles is 10000'
  write(6,*)' '
  ran=ran_exp(iseed,first,lambda)

! this gives a ran number distributed according
! to an exponential distribution with mean = lambda

  n=10000

  do i=1,n
    distance=0
    energy=1
    do

!     This section calculates the distance travelled by the particle between
!     each scattering event until the distance is greater than the thickness
!     of the detector.

      distance=distance+ran_exp(iseed,first,lambda)
      if(distance>thick)exit

!     This section calculates the fractional energy of the particle after each
!     scattering event until the fractional energy is less than 10^-7.

      energy=energy*rand(iseed,first)
      if(energy<1E-7)exit
    end do

!   This section calculates the sum of the distances travelled by the particle
!   between scattering events and the sum of the distances squared.

    sum_distance=sum_distance+distance
    sum_distance_sqr=sum_distance_sqr+distance**2

!   This section calculates the sum of the fractional energy lost by the
!   particle during each scattering event and the sum of the fractional energy
!   squared.

    sum_energy=sum_energy+energy
    sum_energy_sqr=sum_energy_sqr+energy**2
  end do

! This section calculates the mean distance, the mean energy, the mean of the
! distances squared and the mean of the averages squared.

  ave_distance=sum_distance/real(n)
  ave_energy=sum_energy/real(n)
  ave_distance_sqr=sum_distance_sqr/real(n)
  ave_energy_sqr=sum_energy_sqr/real(n)

! SD=Standard deviation

  SD_distance=sqrt(ave_distance_sqr-ave_distance**2)
  write(6,*)'This is the average distance of a particle that'
  write(6,*)'scatters elastically until distance>thickness of the detector'
  write(6,*)ave_distance
  write(6,*)' '
  write(6,*)'This is the standard deviation of the distance of a particle'
  write(6,*)'that scatters elastically until distance>thickness of the detector'
  write(6,*)SD_distance
  write(6,*)' '
  write(6,*)' '

  SD_energy=sqrt(ave_energy_sqr-ave_energy**2)
  write(6,*)'This is the average fractional energy lost by a particle that'
  write(6,*)'scatters elastically until distance>thickness of the detector'
  write(6,*)ave_energy
  write(6,*)' '
  write(6,*)'This is the standard deviation of the average fractional energy'
  write(6,*)'lost by a particle that scatters elastically until'
  write(6,*)'distance>thickness of the detector'
  write(6,*)SD_energy
End Program A1

real function ran_exp(iseed,first,lambda)
  implicit none
  integer :: iseed,first
  real :: dum,lambda
  real, external :: rand
1 continue
  dum=rand(iseed,first)
  if(dum == 0.0d00)goto 1
  ran_exp=-log(dum)*lambda
end function ran_exp

real function rand(iseed,first)

!  This function returns a pseudo-random number for each invocation.
!  It is an f90 adaptation of an
!  FORTRAN 77 adaptation
!  by Dick Valent and Fred Clare
!  http://www.cisl.ucar.edu/zine/96/spring/articles/3.random-6.html
!  of the "Integer Version 2" minimal
!  standard number generator whose Pascal code appears in the article:

!     Park, Steven K. and Miller, Keith W., "Random Number Generators:
!     Good Ones are Hard to Find", Communications of the ACM,
!     October, 1988.

  implicit none
  integer, parameter :: MPLIER=16807
  integer, parameter :: MODLUS=2147483647
  integer, parameter :: MOBYMP=127773
  integer, parameter :: MOMDMP=2836
  integer :: hvlue,lvlue,testv,nextn,first,iseed
  save nextn

  if(first == 0) THEN
    nextn=iseed
    first=1
  endif

  hvlue=nextn/mobymp
  lvlue=mod(nextn,mobymp)
  testv=mplier*lvlue-momdmp*hvlue
  if(testv > 0)then
    nextn=testv
  else
    nextn=testv+modlus
  endif
  rand = real(nextn)/real(modlus)

end function rand


! Copyright 2017 Joseph P. McKenna

! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.

! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.

! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

program main
  implicit none
  integer, parameter :: dp = kind(0.d0)

  integer :: n
  real(dp) :: a
  real(dp), allocatable :: root(:), coeff(:)

  allocate(root(n),coeff(0:n))

  ! expand the polynomial 1*(x-1)^4
  n=4; a=1; root=1
  coeff = expand_polynomial(n, a, root)
  print '(5(f0.1,x))', coeff

  deallocate(root,coeff)

contains

  ! compute coefficients of the polynomial
  ! a*(x-root(1))*...*(x-root(n))
  ! returns array coeff where
  ! coeff(i) = coefficient of x^i for i=0 to n
  function expand_polynomial(n,a,root) result(coeff)
    implicit none

    integer, intent(in) :: n
    real(dp), intent(in) :: a, root(n)
    real(dp) :: coeff(0:n)

    integer :: i, j, k, l
    integer, allocatable :: s(:)
    real(dp), allocatable :: r(:)

    coeff=0._dp
    coeff(n)=1._dp
    do i=1,n
       allocate(s(i),r(i))
       s=(/(j,j=1,i)/)
       s(i)=s(i)-1
       do while(sum(s)<sum((/(j,j=n-i+1,n)/)))
          ! select subset of i roots
          do j=0,i-1
             if (s(i-j)<n-j) then
                s(i-j:i)=(/(k,k=s(i-j)+1,s(i-j)+j+1)/)
                exit
             end if
          end do
          do j=1,i
             r(j)=root(s(j))
          end do
          ! add product of roots to running sum
          coeff(n-i)=coeff(n-i)+product(r)
       end do
       deallocate(s,r)
    end do
    ! scale coeff
    coeff=a*coeff
    ! correct sign of coeff
    do i=n-1,0,-2
       coeff(i)=-coeff(i)
    end do
  end function expand_polynomial

end program main


      PROGRAM xdbrent
C     driver for routine dbrent
      REAL EQL,TOL
      PARAMETER(TOL=1.0E-6,EQL=1.E-4)
      INTEGER i,iflag,j,nmin
      REAL amin(20),ax,bx,cx,dbr,fa,fb,fc,xmin
      REAL bessj0,dbrent,deriv
      EXTERNAL bessj0,deriv
      nmin=0
      write(*,'(/1x,a)') 'Minima of the function BESSJ0'
      write(*,'(/1x,t6,a,t19,a,t27,a,t39,a,t53,a/)') 'Min. #','X',
     *     'BESSJ0(X)','BESSJ1(X)','DBRENT'
      do 12 i=1,100
        ax=i
        bx=i+1.0
        call mnbrak(ax,bx,cx,fa,fb,fc,bessj0)
        dbr=dbrent(ax,bx,cx,bessj0,deriv,TOL,xmin)
        if (nmin.eq.0) then
          amin(1)=xmin
          nmin=1
          write(*,'(1x,5x,i2,3x,4f12.6)') nmin,xmin,
     *         bessj0(xmin),deriv(xmin),dbr
        else
          iflag=0
          do 11 j=1,nmin
            if (abs(xmin-amin(j)).le.EQL*xmin) iflag=1
11        continue
          if (iflag.eq.0) then
            nmin=nmin+1
            amin(nmin)=xmin
            write(*,'(1x,5x,i2,3x,4f12.6)') nmin,xmin,
     *           bessj0(xmin),deriv(xmin),dbr
          endif
        endif
12    continue
      END
      REAL FUNCTION deriv(x)
      REAL bessj1,x
      deriv=-bessj1(x)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xdbrent.for