! Test if MIN and MAX intrinsics behave correctly when passed NaNs
! as arguments
!
! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }
!
module aux2
  interface isnan
    module procedure isnan_r
    module procedure isnan_d
  end interface isnan

  interface isinf
    module procedure isinf_r
    module procedure isinf_d
  end interface isinf
contains

  pure function isnan_r(x) result (isnan)
    logical :: isnan
    real, intent(in) :: x

    isnan = (.not.(x == x))
  end function isnan_r

  pure function isnan_d(x) result (isnan)
    logical :: isnan
    double precision, intent(in) :: x

    isnan = (.not.(x == x))
  end function isnan_d

  pure function isinf_r(x) result (isinf)
    logical :: isinf
    real, intent(in) :: x

    isinf = (x > huge(x)) .or. (x < -huge(x))
  end function isinf_r

  pure function isinf_d(x) result (isinf)
    logical :: isinf
    double precision, intent(in) :: x

    isinf = (x > huge(x)) .or. (x < -huge(x))
  end function isinf_d
end module aux2

program test
  use aux2
  implicit none
  real :: nan, large, inf

  ! Create a NaN and check it
  nan = 0
  nan = nan / nan
  if (nan == nan .or. nan > nan .or. nan < nan .or. nan >= nan &
      .or. nan <= nan) call abort
  if (isnan (2.d0) .or. (.not. isnan(nan)) .or. &
      (.not. isnan(real(nan,kind=kind(2.d0))))) call abort

  ! Create an INF and check it
  large = huge(large)
  inf = 2 * large
  if (isinf(nan) .or. isinf(large) .or. .not. isinf(inf)) call abort
  if (isinf(-nan) .or. isinf(-large) .or. .not. isinf(-inf)) call abort

  ! Check that MIN and MAX behave correctly
  if (max(2.0, nan) /= 2.0) call abort
  if (min(2.0, nan) /= 2.0) call abort
  if (max(nan, 2.0) /= 2.0) call abort
  if (min(nan, 2.0) /= 2.0) call abort

  if (max(2.d0, nan) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (min(2.d0, nan) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (max(nan, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (min(nan, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }

  if (.not. isnan(min(nan,nan))) call abort
  if (.not. isnan(max(nan,nan))) call abort

  ! Same thing, with more arguments

  if (max(3.0, 2.0, nan) /= 3.0) call abort
  if (min(3.0, 2.0, nan) /= 2.0) call abort
  if (max(3.0, nan, 2.0) /= 3.0) call abort
  if (min(3.0, nan, 2.0) /= 2.0) call abort
  if (max(nan, 3.0, 2.0) /= 3.0) call abort
  if (min(nan, 3.0, 2.0) /= 2.0) call abort

  if (max(3.d0, 2.d0, nan) /= 3.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (min(3.d0, 2.d0, nan) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (max(3.d0, nan, 2.d0) /= 3.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (min(3.d0, nan, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (max(nan, 3.d0, 2.d0) /= 3.d0) call abort ! { dg-warning "Extension: Different type kinds" }
  if (min(nan, 3.d0, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }

  if (.not. isnan(min(nan,nan,nan))) call abort
  if (.not. isnan(max(nan,nan,nan))) call abort
  if (.not. isnan(min(nan,nan,nan,nan))) call abort
  if (.not. isnan(max(nan,nan,nan,nan))) call abort
  if (.not. isnan(min(nan,nan,nan,nan,nan))) call abort
  if (.not. isnan(max(nan,nan,nan,nan,nan))) call abort

  ! Large values, INF and NaNs
  if (.not. isinf(max(large, inf))) call abort
  if (isinf(min(large, inf))) call abort
  if (.not. isinf(max(nan, large, inf))) call abort
  if (isinf(min(nan, large, inf))) call abort
  if (.not. isinf(max(large, nan, inf))) call abort
  if (isinf(min(large, nan, inf))) call abort
  if (.not. isinf(max(large, inf, nan))) call abort
  if (isinf(min(large, inf, nan))) call abort

  if (.not. isinf(min(-large, -inf))) call abort
  if (isinf(max(-large, -inf))) call abort
  if (.not. isinf(min(nan, -large, -inf))) call abort
  if (isinf(max(nan, -large, -inf))) call abort
  if (.not. isinf(min(-large, nan, -inf))) call abort
  if (isinf(max(-large, nan, -inf))) call abort
  if (.not. isinf(min(-large, -inf, nan))) call abort
  if (isinf(max(-large, -inf, nan))) call abort

end program test

! { dg-final { cleanup-modules "aux2" } }


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Fri Jun  7 21:00:12
!
!a=./f && make $a && $a
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none f.f08 -o f
!f.f08:57.29:
!
!  subroutine process1(fmt,s,b)
!                             1
!Warning: Unused dummy argument 'b' at (1)
!digit sum       n
!        1 1
!       10 1234
!       29 fe
!       29 f0e
! sum of digits of n expressed in base is...
!      n   base    sum
!      1     10      1
!   1234     10     10
!    254     16     29
!   3854     16     29
!
!Compilation finished at Fri Jun  7 21:00:12

module base_mod
  private :: reverse
contains
  subroutine reverse(a)
    integer, dimension(:), intent(inout) :: a
    integer :: i, j, t
    do i=1,size(a)/2
       j = size(a) - i + 1
       t = a(i)
       a(i) = a(j)
       a(j) = t
    end do
  end subroutine reverse

  function antibase(b, n) result(a)
    integer, intent(in) :: b,n
    integer, dimension(32) :: a
    integer :: m, i
    a = 0
    m = n
    i = 1
    do while (m .ne. 0)
       a(i) = mod(m, b)
       m = m/b
       i = i+1
    end do
    call reverse(a)
  end function antibase
end module base_mod

program digit_sum
  use base_mod
  call still
  call confused
contains
  subroutine still
    character(len=6),parameter :: fmt = '(i9,a)'
    print'(a9,a8)','digit sum','n'
    call process1(fmt,'1',10)
    call process1(fmt,'1234',10)
    call process1(fmt,'fe',16)
    call process1(fmt,'f0e',16)
  end subroutine still

  subroutine process1(fmt,s,b)
    character(len=*), intent(in) :: fmt, s
    integer, intent(in), optional :: b
    integer :: i
    print fmt,sum((/(index('123456789abcdef',s(i:i)),i=1,len(s))/)),' '//s
  end subroutine process1

  subroutine confused
    character(len=5),parameter :: fmt = '(3i7)'
    print*,'sum of digits of n expressed in base is...'
    print'(3a7)','n','base','sum'
    call process0(10,1,fmt)
    call process0(10,1234,fmt)
    call process0(16,254,fmt)
    call process0(16,3854,fmt)
  end subroutine confused

  subroutine process0(b,n,fmt)
    integer, intent(in) :: b, n
    character(len=*), intent(in) :: fmt
    print fmt,n,b,sum(antibase(b, n))
  end subroutine process0
end program digit_sum


! { dg-do run }
! PR35994 [4.3/4.4 regression] MAXLOC and MINLOC off by one with mask
program GA4076
  REAL DDA(100)
  dda = (/(J1,J1=1,100)/)
  IDS = MAXLOC(DDA,1)
  if (ids.ne.100) call abort  !expect 100

  IDS = MAXLOC(DDA,1, (/(J1,J1=1,100)/) > 50)
  if (ids.ne.100) call abort  !expect 100

  IDS = minLOC(DDA,1)
  if (ids.ne.1) call abort  !expect 1

  IDS = MinLOC(DDA,1, (/(J1,J1=1,100)/) > 50)
  if (ids.ne.51) call abort !expect 51

END


    program program1
    implicit none

    double precision :: area, r, pi, volume
    write(*,*)"Entre o valor do raio"
    read(*,*) r
    pi = 3.1415
    area = pi*(r**2)
    volume = (4d0/3d0)*pi*(r**3)
    write(*,*) "O volume da esfera é",volume

    end program program1


      PROGRAM main

      IMPLICIT none
      REAL*8 mag,mom
  101 read (*,*,end=102) mom
          mag = 2.0d0/3.0d0*dlog10(mom) - 10.7
          write(*,1001) mag
          goto 101
  102 continue
 1001 format('Magnitude: ',F5.2)
      END


program intrinsics_02
real :: x

x = sin(1.5)

print *, x

end


      program oscillator

      call scan1()
      call timeloop()
      end

      subroutine scan1()
C     Read input data (physical and numerical parameters)
C     from standard input. The data are stored in a common block.

      real*8 m_, b_, c_, A_, w_, y0_, tstop_, dt_
      character func_*20
      read(*,*) m_, b_, c_, func_, A_, w_, y0_, tstop_, dt_

C      write(*,*) 'scan1', ' m=', m_, ' b=', b_, ' c=', c_, ' A=', A_,
C     >           ' w=', w_, ' y0=', y0_, ' tstop=', tstop_, ' dt=', dt_,
C     >           ' c-term function:', func_
      call scan2(m_, b_, c_, A_, w_, y0_, tstop_, dt_, func_)
      return
      end

      subroutine scan2(m_, b_, c_, A_, w_, y0_, tstop_, dt_, func_)
C     Initialize the data needed in the solver, and store in a
C     common block /data/, from the arguments to this subroutine.

      real*8 m_, b_, c_, A_, w_, y0_, tstop_, dt_
      character func_*(*)

      real*8 m, b, c, A, w, y0, tstop, dt
      character func*20
      common /data/ m, b, c, A, w, y0, tstop, dt, func

      m = m_
      b = b_
      c = c_
      A = A_
      w = w_
      y0 = y0_
      tstop = tstop_
      dt = dt_
      func = func_
      return
      end

      subroutine adv_fe(y, n, t, dt, scratch)
C     Advance the solution one time step using the
C     Forward Euler method.

      integer n, i
      real*8 y(n), t, dt, scratch(n)

      call rhs(scratch, y, n, t)
C     Forward Euler scheme:
      do 10 i = 1,n
         y(i) = y(i) + dt*scratch(i)
 10   continue
      return
      end

      subroutine adv_rk2(y, n, t, dt, scratch1, scratch2)
C     Advance the solution one time step using a
C     2nd order Runge-Kutta method.

      integer n, i
      real*8 y(n), t, dt, scratch1(n), scratch2(n), t2

      call rhs(scratch1, y, n, t)
      do 10 i = 1,n
         scratch2(i) = y(i) + dt*scratch1(i)
 10   continue
      t2 = t + dt
      call rhs(scratch2, scratch2, n, t2)
      do 20 i = 1,n
         y(i) = y(i) + 0.5*dt*(scratch1(i) + scratch2(i))
 20   continue
      return
      end

      subroutine rhs(f, y, n, t)
C     Define the right-hand side of the ODE system.

      integer n
      real*8 f(n), y(n), t
      real*8 cterm

      real*8 m, b, c, A, w, y0, tstop, dt
      character func*20
      common /data/ m, b, c, A, w, y0, tstop, dt, func

      if (func .eq. 'y') then
         cterm = y(1)
      else if (func .eq. 'siny') then
         cterm = sin(y(1))
      else if (func .eq. 'y3') then
         cterm = y(1) - (y(1)**3)/6.0
      else
         write(*,*) 'Error: spring-term ',func,' illegal'
         cterm = 0.0
      endif

      f(1) = y(2)
      f(2) = ( -b*y(2) - c*cterm + A*cos(w*t) )/m
      return
      end

      subroutine timeloop()
C     Integrate the ODEs in time by calling adv_fe or
C     adv_rk2 at every time step.

      integer n, nmax
      parameter (nmax=2)
      real*8 time, y(nmax), scratch1(nmax), scratch2(nmax)
      real*8 m, b, c, A, w, y0, tstop, dt
      character func*20
      common /data/ m, b, c, A, w, y0, tstop, dt, func

C      write(*,*) 'timeloop', ' m=', m, ' b=', b, ' c=', c, ' A=', A,
C     >           ' w=', w, ' y0=', y0, ' tstop=', tstop, ' dt=', dt,
C     >           ' c-term function:', func

      n = 2
C     initial conditions:
      y(1) = y0
      y(2) = 0.0

      open(21, file='sim.dat', status='unknown', form='formatted')
      do 10 time = dt, tstop, dt
C         call adv_fe (y, n, time, dt, scratch1)
         call adv_rk2 (y, n, time, dt, scratch1, scratch2)
         write(21,1000) time, y(1)
 10   continue
      close(21)
      return
 1000 FORMAT(F12.4, F12.4)
      end


      subroutine setprob_annulus(beta_in)
      implicit none

      double precision pi
      common /compi/ pi

      double precision beta_in, beta
      common /commannulus/ beta

      pi = 4.d0*atan(1.d0)

      beta = beta_in

      end


! { dg-do run }
! { dg-options "-fbounds-check" }
!
! Test the fix for PR52162 in which the elemental and conversion
! intrinsics in lines 14 and 19 would cause the bounds check to fail.
!
! Contributed by Dominique d'Humieres  <dominiq@lps.ens.fr>
!
    integer(4), allocatable :: a(:)
    integer(8), allocatable :: b(:)
    real, allocatable :: c(:)
    allocate (b(7:11), source = [7_8,8_8,9_8,10_8,11_8])

    a = b ! Implicit conversion

    if (lbound (a, 1) .ne. lbound(b, 1)) STOP 1
    if (ubound (a, 1) .ne. ubound(b, 1)) STOP 2

    c = sin(real(b(9:11))/100_8) ! Elemental intrinsic

    if ((ubound(c, 1) - lbound(c, 1)) .ne. 2) STOP 3
    if (any (nint(asin(c)*100.0) .ne. b(9:11))) STOP 4
    deallocate (a, b, c)
  end


c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   utilities for normalisation of time series
c   author T. Schreiber (1998)
c===========================================================================
      subroutine rms(nmax,x,sc,sd)
c  return mean sc and rms amplitude sd
      dimension x(nmax)

      sc=0.
      do 10 n=1,nmax
 10      sc=sc+x(n)
      sc=sc/nmax
      sd=0.
      do 20 n=1,nmax
 20      sd=sd+(x(n)-sc)**2
      sd=sqrt(sd/nmax)
      end

      subroutine normal(nmax,x,sc,sd)
c  subtract mean, return mean sc and rms amplitude sd
      dimension x(nmax)

      call rms(nmax,x,sc,sd)
      do 10 n=1,nmax
 10      x(n)=x(n)-sc
      end

      subroutine normal1(nmax,x,sc,sd)
c  subtract mean, rescale to unit variance,
c  return mean sc and rms amplitude sd
      dimension x(nmax)

      call rms(nmax,x,sc,sd)
      if(sd.eq.0.) stop
     .   "normal1: zero variance, cannot normalise"
      do 10 n=1,nmax
 10      x(n)=(x(n)-sc)/sd
      end

      subroutine minmax(nmax,x,xmin,xmax)
c  obtain smallest and  largest value in x
      dimension x(nmax)

      xmin=x(1)
      xmax=x(1)
      do 10 n=2,nmax
         xmin=min(x(n),xmin)
 10      xmax=max(x(n),xmax)
      end


module jacobi_module
  implicit none
  INTEGER, PARAMETER :: real4 = selected_real_kind(6,37)
  INTEGER, PARAMETER :: real8 = selected_real_kind(15,307)

  REAL(real8), DIMENSION(:,:), ALLOCATABLE, TARGET :: Temp     ! solution array
  REAL(real8), DIMENSION(:,:), ALLOCATABLE, TARGET :: oldTemp  ! previous iteration
  REAL(real8) :: del, gdel=1.0d0
  REAL(real4) :: start_time, end_time
  INTEGER :: par_size, ierr, below, above, par_rank, m, mp, iter=0
  INTEGER, PARAMETER :: MAXSTEPS = 80000, INCREMENT = 100
  REAL(real8), PARAMETER :: TOL = 1.d-6
#if ( defined _VISIT_ )
  LOGICAL :: visRunFlag, visUpdateFlag
  INTEGER simUpdate, visitstate, blocking, visResult
  REAL(real8)  simtime
#endif
  include "mpif.h"
  public

contains

  subroutine set_initial_bc()
! PDE: Laplacian u = 0;      0<=x<=1;  0<=y<=1
! B.C.: u(x,0)=sin(pi*x); u(x,1)=sin(pi*x)*exp(-pi); u(0,y)=u(1,y)=0
! SOLUTION: u(x,y)=sin(pi*x)*exp(-pi*y)
    implicit none
    INTEGER j
    REAL(real8), DIMENSION(0:m+1) :: y0

    y0 = sin(3.141593*(/(j,j=0,m+1)/)/(m+1))
    oldTemp = 0.0d0
    if(par_size > 1) then
      Temp = 0.0d0
      if (par_rank == 0  ) Temp(:,   0) = y0
      if (par_rank == par_size-1) Temp(:,mp+1) = y0*exp(-3.141593)
    else
      Temp = 0.0d0
      Temp(:,0) = y0
      Temp(:,m+1) = y0*exp(-3.141593)
    end if
    return
  end subroutine set_initial_bc

  subroutine simulate_one_timestep()
#if ( defined _VISIT_ )
    external visittimestepchanged, visitupdateplots
    integer visittimestepchanged, visitupdateplots
#endif

    REAL(real8), DIMENSION(:,:), POINTER :: cold, c, n, e, w, s

    oldTemp = Temp                            ! save current solution array to buffer

    c    =>    Temp(1:m  ,1:mp  )             ! i  ,j    for 1<=i<=m; 1<=j<=mp
    cold => oldTemp(1:m  ,1:mp  )             ! i  ,j    for 1<=i<=m; 1<=j<=mp
    n =>    oldTemp(1:m  ,2:mp+1)             ! i  ,j+1
    s =>    oldTemp(1:m  ,0:mp-1)             ! i,  j-1
    e =>    oldTemp(2:m+1,1:mp  )             ! i+1,j
    w =>    oldTemp(0:m-1,1:mp  )             ! i-1,j

    c = ( n + e + w + s ) * 0.25   ! new solution
    del = SUM(DABS(c-cold))           ! local error sum
!    if(MOD(iter,INCREMENT)==0) then
!      if( par_rank == 0) WRITE(*,"('par_rank,iter,del:',i4,i6,e12.4)")par_rank,iter,del
!    endif

    call MPI_Allreduce( del, gdel, 1, MPI_DOUBLE_PRECISION, MPI_MAX,   &
         MPI_COMM_WORLD, ierr )     ! find global max error

    call exchange_ghost_lines()     ! update lowest and uppermost grid lines

    iter = iter + 1
#if ( defined _VISIT_ )
    ierr = visittimestepchanged()
    ierr = visitupdateplots()
#endif
  end subroutine simulate_one_timestep

  subroutine exchange_ghost_lines()
    INTEGER :: ierr
    INTEGER status(MPI_STATUS_SIZE)
! send my last computed row above and receive from below my south boundary wall
    call MPI_SendRECV(                                       &
              Temp(1,mp  ), m, MPI_DOUBLE_PRECISION, above, 0,  &
              Temp(1,   0), m, MPI_DOUBLE_PRECISION, below, 0,  &
              MPI_COMM_WORLD, status, ierr )
! send my first computed row below and receive from above my north boundary wall
    call MPI_SendRECV(                                       &
              Temp(1,   1), m, MPI_DOUBLE_PRECISION, below, 1,  &
              Temp(1,mp+1), m, MPI_DOUBLE_PRECISION, above, 1,  &
              MPI_COMM_WORLD, status, ierr )
    return
  end subroutine exchange_ghost_lines

  subroutine neighbors()
    implicit none

    if(par_rank == 0) then
      below = MPI_PROC_NULL        ! tells MPI not to perform send/recv
      if(par_size > 1) then
         above = par_rank+1
      else
         above = MPI_PROC_NULL
      endif
    else if(par_rank == par_size-1) then
      below = par_rank-1
      above = MPI_PROC_NULL        ! tells MPI not to perform send/recv
    else
      below = par_rank-1
      above = par_rank+1
    endif
    return
  end subroutine neighbors

  subroutine InitMPI()
    INTEGER :: ierr, rc

    call MPI_Init( ierr )

    if (ierr .ne. MPI_SUCCESS) then
      print *,'Error in MPI_Init. Terminating.'
      call MPI_ABORT(MPI_COMM_WORLD, rc, ierr)
    end if

    call MPI_Comm_Size( MPI_COMM_WORLD, par_size, ierr )

    if (ierr .ne. MPI_SUCCESS) then
      print *,'Error in MPI_Comm_Size. Terminating.'
      call MPI_ABORT(MPI_COMM_WORLD, rc, ierr)
    end if

    call MPI_Comm_Rank( MPI_COMM_WORLD, par_rank, ierr )

    if (ierr .ne. MPI_SUCCESS) then
      print *,'Error in MPI_Comm_Rank. Terminating.'
      call MPI_ABORT(MPI_COMM_WORLD, rc, ierr)
    end if

    call neighbors()  ! determines MPI-domain border flags
  end subroutine InitMPI

  subroutine MPIIOWriteData(Filename)
    INTEGER :: dimuids(2), ustart(2), ucount(2)
    CHARACTER(len=*) :: Filename
    INTEGER(KIND=MPI_OFFSET_KIND) :: disp
    INTEGER :: ierr, filehandle, filetype
    ! global size of array on disk
    dimuids(1) = m + 2
    dimuids(2) = m + 2
    disp = 0
    call MPI_File_open(MPI_COMM_WORLD, Filename,             &
                          IOR(MPI_MODE_CREATE, MPI_MODE_WRONLY),  &
                          MPI_INFO_NULL, filehandle, ierr)

    if(par_rank .eq. 0) then
      call MPI_File_write(filehandle, dimuids, 2, MPI_INTEGER, MPI_STATUS_IGNORE, ierr)
    endif
    disp = SIZEOF(dimuids) !offset because we just wrote 2 integers

    ustart(2) = (mp * par_rank)
    ustart(1) = 0 ! in the X direction, always start at 0

    ucount(1) = m+2;
    ucount(2) = mp;
! all tasks write mp lines except last rank which writes (mp+2)
! in total, we have  the (m+2)*(m+2) grid written, including the b.c.
    if(par_rank .eq. (par_size-1)) then
      ucount(2) = mp + 2
    endif

! Create the subarray representing the local block
    call MPI_Type_create_subarray(2, dimuids, ucount, ustart, &
                                       MPI_ORDER_FORTRAN, MPI_REAL8, filetype, ierr)
    call MPI_Type_commit(filetype, ierr)

    call MPI_File_set_view(filehandle, disp, MPI_REAL8, &
                                filetype, "native", MPI_INFO_NULL, ierr)

    call MPI_File_write_all(filehandle, Temp, PRODUCT(ucount), MPI_REAL8, MPI_STATUS_IGNORE, ierr)
    call MPI_Type_free(filetype, ierr)
    call MPI_File_close(filehandle, ierr)

  end subroutine MPIIOWriteData

end module jacobi_module


program intrinsics_03
real :: x

x = cos(9.5)

print *, x

end


program main
    use, intrinsic :: iso_fortran_env
    use :: type_vector2
    implicit none
    real(real64), parameter :: pi = acos(-1d0)

    integer(int32) :: num1, num2 !input number 1 and 2
    integer(int32) :: add, sub, mul, neg !add, subtruct, multiply, negate operations
    real(real64) :: div !division operation

    ! integer(int32) :: longlonglonglonglonglonglonglonglonglonglong_name_variable1, longlonglonglonglonglonglonglonglonglonglong_name_variable2
    type(vector2) :: vec

    write (*, '(a,x)', advance="no") "input num1"
    read *, num1

    !num2 must be greater than 0.
    get_num2: do
        write (*, '(a,x)', advance="no") "input num2 (>=0)"
        read *, num2

        if (num2 == 0 .and. num2 < 0) then
            cycle get_num2
        end if
        if (num2 > 0) exit get_num2
    end do get_num2

    add = num1 + num2
    sub = num1 - num2
    mul = num1*num2
    div = dble(num1)/dble(num2)
    neg = -num1

    print '(i0,"+",i0,"=",i0)', num1, num2, add
    print '(i0,"-",i0,"=",i0)', num1, num2, sub
    print '(i0,"*",i0,"=",i0)', num1, num2, mul
    print '(i0,"/",i0,"=",g0)', num1, num2, div
    print '("-(",i0,")=",i0)', num1, neg

    vec = vector2(0d0, 0d0)
    vec%x = cos(pi/4d0); vec%y = sin(pi/4d0)
    print *, "hypotenuse=", hypot(vec%x, &
                                  vec%y)
    call clear(vec)

    block
        integer(int32) :: i, j, k, Nx = 1, Ny = 1, Nz = 1
        do k = 1, Nz
        do j = 1, Ny
        do i = 1, Nx
            print *, .not. .true.
        end do
        end do
        end do
    end block

    block
        integer(int32) :: i, j, k, Nx = 1, Ny = 1, Nz = 1
        !&<
        do k = 1, Nz
        do j = 1, Ny
        do i = 1, Nx
            print *, i, &
                     j, &
                     k
        end do
        end do
        end do
        !&>
    end block
end program main


!
! ej8c.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! 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 2 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.
!
program orbitmap

use precision, pr => dp

implicit none
integer, parameter      :: N = 10300, nbins = 16
integer                 :: i, j, k, t, ibin
real(pr)                :: xt, xt_1, x0, r, dbin
real(pr), dimension(:)  :: counts(nbins)

open(unit=10, file='ej8c.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#  t   xt   r"

x0 = 0.6_pr
t = 0
r = 4._pr
xt_1 = x0
dbin = 1._pr/nbins
counts = (/ (0, i = 1, nbins) /)
print*, counts, dbin, nbins
do i = 1, N
    !print *, i
    xt = r * xt_1 * (1._pr - xt_1)

    if (i > 300) then
        write(10, *) t + i, xt, r
    end if

    xt_1 = xt

    ibin = int(xt*nbins)
    counts(ibin) = counts(ibin) + 1
end do

close(10)

print *, "========================================================"
print *, counts

end program orbitmap


!> \file mo_linfit.f90

!> \brief  Fitting a straight line.

!> \details This module provides a routine to fit a straight line with model I or model II regression.

!> \authors Matthias Cuntz
!> \date Mar 2011

MODULE mo_linfit

  ! This module provides a routine to fit a straight line with model I or model II regression.
  ! Written  Matthias Cuntz, Mar 2011

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2011 Matthias Cuntz - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind, ONLY: sp, dp

  Implicit NONE

  PUBLIC :: linfit ! Fitting straight line (without error bars on input), Model I or Model II

  ! ------------------------------------------------------------------

  !     NAME
  !         linfit

  !     PURPOSE
  !>        \brief Fits a straight line to input data by minimizing chi^2.

  !>        \details Given a set of data points x(1:ndata), y(1:ndata),
  !>         fit them to a straight line \f$ y = a+bx \f$ by minimizing chi2.\n
  !>         Model I minimizes y vs. x while Model II takes the geometric mean of y vs. x and x vs. y.
  !>         Returned is the fitted line at x.
  !>         Optional returns are a, b and their respective probable uncertainties siga and sigb,
  !>         and the chi-square chi2.

  !     CALLING SEQUENCE
  !         out = linfit(x, y, a=a, b=b, siga=siga, sigb=sigb, chi2=chi2, model2=model2)

  !     INTENT(IN)
  !>         \param[in] "real(sp/dp) :: x(:)"                1D-array with input x
  !>         \param[in] "real(sp/dp) :: y(:)"                1D-array with input y

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !>         \param[in] "logical, optional :: model2"        If present, use geometric mean regression
  !>                                                         instead of ordinary least square

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !>        \param[out] "real(sp/dp), dimension(M) :: a"      intercept
  !>        \param[out] "real(sp/dp), dimension(M) :: b"      slope
  !>        \param[out] "real(sp/dp), dimension(M) :: siga"   error on intercept
  !>        \param[out] "real(sp/dp), dimension(M) :: sigb"   error on slope
  !>        \param[out] "real(sp/dp)               :: chisq"  Minimum chi^2

  !     RETURN
  !>       \return real(sp/dp), dimension(:), allocatable :: out — fitted values at x(:).

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ytmp = linfit(x, y, a=inter, b=slope, model2=.true.)

  !     LITERATURE
  !     Model I follows closely
  !         Press WH, Teukolsky SA, Vetterling WT, & Flannery BP - Numerical Recipes in Fortran 90 -
  !             The Art of Parallel Scientific Computing, 2nd Edition, Volume 2 of Fortran Numerical Recipes,
  !             Cambridge University Press, UK, 1996
  !     For Model II (geometric mean regression)
  !         Robert R. Sokal and F. James Rohlf, Biometry: the principle and practice of statistics
  !             in biological research, Freeman & Co., ISBN 0-7167-2411-1

  !     HISTORY
  !         Written Matthias Cuntz, March 2011 - following closely the routine fit of Numerical Recipes
  !                                            - linfit Model II: geometric mean regression
  !         Modified Matthias Cuntz, Nov 2011  - sp, dp
  !                                            - documentation
  INTERFACE linfit
     MODULE PROCEDURE linfit_sp, linfit_dp
  END INTERFACE linfit

  ! ------------------------------------------------------------------

  PRIVATE

  ! ------------------------------------------------------------------

CONTAINS

  ! ------------------------------------------------------------------

  FUNCTION linfit_dp(x, y, a, b, siga, sigb, chi2, model2)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(IN)  :: x, y
    REAL(dp), OPTIONAL,     INTENT(OUT) :: a, b, siga, sigb, chi2
    LOGICAL , OPTIONAL,     INTENT(IN)  :: model2
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:), allocatable :: linfit_dp
#else
    REAL(dp), DIMENSION(size(x))        :: linfit_dp
#endif

    REAL(dp) :: sigdat, nx, sx, sxoss, sy, st2
    REAL(dp), DIMENSION(size(x)), TARGET :: t
    REAL(dp) :: aa, bb, cchi2
    LOGICAL :: mod2
    REAL(dp) :: mx, my, sx2, sy2, sxy, sxy2, syx2, ssigb
    !REAL(dp) :: r

    if (size(x) /= size(y))   stop 'linfit_dp: size(x) /= size(y)'
#ifndef __PYTHON__
    if (.not. allocated(linfit_dp)) allocate(linfit_dp(size(x)))
#endif
    if (present(model2)) then
       mod2 = model2
    else
       mod2 = .false.
    endif

    if (mod2) then
       nx = real(size(x),dp)
       mx = sum(x)/nx
       my = sum(y)/nx
       sx2 = sum((x-mx)*(x-mx))
       sy2 = sum((y-my)*(y-my))
       sxy = sum((x-mx)*(y-my))
       !r = sxy / sqrt(sx2) / sqrt(sy2)
       bb = sign(sqrt(sy2/sx2),sxy)
       aa = my - bb*mx
       linfit_dp(:) = aa + bb*x(:)
       if (present(a)) a = aa
       if (present(b)) b = bb
       if (present(chi2)) then
          t(:) = y(:)-linfit_dp(:)
          chi2 = dot_product(t,t)
       endif
       if (present(siga) .or. present(sigb)) then
          syx2 = (sy2 - sxy*sxy/sx2) / (nx-2.0_dp)
          sxy2 = (sx2 - sxy*sxy/sy2) / (nx-2.0_dp)
          ! syx2 should be >0
          ! ssigb = sqrt(syx2/sx2)
          ssigb = sqrt(abs(syx2)/sx2)
          if (present(sigb)) sigb = ssigb
          if (present(siga)) then
             ! siga = sqrt(syx2*(1.0_dp/nX+mx*mx/sx2))
             siga = sqrt(abs(syx2)*(1.0_dp/nX+mx*mx/sx2))
             ! Add Extra Term for Error in xmean which is not in Sokal & Rohlf.
             ! They take the error estimate of the chi-squared error for a.
             ! siga = sqrt(siga*siga + bb*bb*sxy2/nx)
             siga = sqrt(siga*siga + bb*bb*abs(sxy2)/nx)
          endif
       endif
    else
       nx = real(size(x),dp)
       sx = sum(x)
       sy = sum(y)
       sxoss = sx/nx
       t(:) = x(:)-sxoss
       bb = dot_product(t,y)
       st2 = dot_product(t,t)
       bb = bb/st2
       aa = (sy-sx*bb)/nx
       linfit_dp(:) = aa + bb*x(:)
       if (present(a)) a = aa
       if (present(b)) b = bb
       if (present(chi2) .or. present(siga) .or. present(sigb)) then
          t(:) = y(:)-linfit_dp(:)
          cchi2 = dot_product(t,t)
          if (present(chi2)) chi2 = cchi2
          if (present(siga) .or. present(sigb)) then
             sigdat = sqrt(cchi2/(size(x)-2))
             if (present(siga)) then
                siga = sqrt((1.0_dp+sx*sx/(nx*st2))/nx)
                siga = siga*sigdat
             endif
             if (present(sigb)) then
                sigb = sqrt(1.0_dp/st2)
                sigb = sigb*sigdat
             endif
          endif
       endif
    endif

  END FUNCTION linfit_dp

  FUNCTION linfit_sp(x, y, a, b, siga, sigb, chi2, model2)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:), INTENT(IN)  :: x, y
    REAL(sp), OPTIONAL,     INTENT(OUT) :: a, b, siga, sigb, chi2
    LOGICAL , OPTIONAL,     INTENT(IN)  :: model2
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:), allocatable :: linfit_sp
#else
    REAL(sp), DIMENSION(size(x))        :: linfit_sp
#endif
    REAL(sp) :: sigdat, nx, sx, sxoss, sy, st2
    REAL(sp), DIMENSION(size(x)), TARGET :: t
    REAL(sp) :: aa, bb, cchi2
    LOGICAL :: mod2
    REAL(sp) :: mx, my, sx2, sy2, sxy, sxy2, syx2, ssigb
    !REAL(sp) :: r

    if (size(x) /= size(y))   stop 'linfit_sp: size(x) /= size(y)'
#ifndef __PYTHON__
    if (.not. allocated(linfit_sp)) allocate(linfit_sp(size(x)))
#endif
    if (present(model2)) then
       mod2 = model2
    else
       mod2 = .false.
    endif

    if (mod2) then
       nx = real(size(x),sp)
       mx = sum(x)/nx
       my = sum(y)/nx
       sx2 = sum((x-mx)*(x-mx))
       sy2 = sum((y-my)*(y-my))
       sxy = sum((x-mx)*(y-my))
       !r = sxy / sqrt(sx2) / sqrt(sy2)
       bb = sign(sqrt(sy2/sx2),sxy)
       aa = my - bb*mx
       linfit_sp(:) = aa + bb*x(:)
       if (present(a)) a = aa
       if (present(b)) b = bb
       if (present(chi2)) then
          t(:) = y(:)-linfit_sp(:)
          chi2 = dot_product(t,t)
       endif
       if (present(siga) .or. present(sigb)) then
          syx2 = (sy2 - sxy*sxy/sx2) / (nx-2.0_sp)
          sxy2 = (sx2 - sxy*sxy/sy2) / (nx-2.0_sp)
          ! syx2 should be >0
          ! ssigb = sqrt(syx2/sx2)
          ssigb = sqrt(abs(syx2)/sx2)
          if (present(sigb)) sigb = ssigb
          if (present(siga)) then
             ! siga = sqrt(syx2*(1.0_sp/nX+mx*mx/sx2))
             siga = sqrt(abs(syx2)*(1.0_sp/nX+mx*mx/sx2))
             ! Add Extra Term for Error in xmean which is not in Sokal & Rohlf.
             ! They take the error estimate of the chi-squared error for a.
             ! siga = sqrt(siga*siga + bb*bb*sxy2/nx)
             siga = sqrt(siga*siga + bb*bb*abs(sxy2)/nx)
          endif
       endif
    else
       nx = real(size(x),sp)
       sx = sum(x)
       sy = sum(y)
       sxoss = sx/nx
       t(:) = x(:)-sxoss
       bb = dot_product(t,y)
       st2 = dot_product(t,t)
       bb = bb/st2
       aa = (sy-sx*bb)/nx
       linfit_sp(:) = aa + bb*x(:)
       if (present(a)) a = aa
       if (present(b)) b = bb
       if (present(chi2) .or. present(siga) .or. present(sigb)) then
          t(:) = y(:)-linfit_sp(:)
          cchi2 = dot_product(t,t)
          if (present(chi2)) chi2 = cchi2
          if (present(siga) .or. present(sigb)) then
             sigdat = sqrt(cchi2/(size(x)-2))
             if (present(siga)) then
                siga = sqrt((1.0_sp+sx*sx/(nx*st2))/nx)
                siga = siga*sigdat
             endif
             if (present(sigb)) then
                sigb = sqrt(1.0_sp/st2)
                sigb = sigb*sigdat
             endif
          endif
       endif
    endif

  END FUNCTION linfit_sp

  ! ------------------------------------------------------------------

END MODULE mo_linfit


program array_timings
    use, intrinsic :: iso_fortran_env, only : DP => REAL64, error_unit
    implicit none
    integer, parameter :: nr_rows = 10000, nr_cols = 10000
    real(kind=DP), parameter :: delta = 1e-7_DP
    real(kind=DP), dimension(:, :), allocatable :: A, B, C, A_old
    real :: start_time, end_time
    integer :: istat, row, col

    ! allocate arrays
    allocate (A(nr_rows, nr_cols), B(nr_rows, nr_cols), C(nr_rows, nr_cols), &
              A_old(nr_rows, nr_cols), stat=istat)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocated arrays'
        stop 1
    end if

    ! initialize arrays
    call random_number(B)
    call random_number(C)

    ! compute array expressions
    call cpu_time(start_time)
    A = 5.0_DP*B + sqrt(2.5_DP*C)/3.2_DP
    call cpu_time(end_time)
    print '(A, F12.6)', 'array expression: ', end_time - start_time

    ! store result for comparison
    A_old = A

    ! compute do loops
    call cpu_time(start_time)
    do col = 1, nr_cols
        do row = 1, nr_rows
            A(row, col) = 5.0_DP*B(row, col) + sqrt(2.5_DP*C(row, col))/3.2_DP
        end do
    end do
    call cpu_time(end_time)
    print '(A, F12.6)', 'do loops: ', end_time - start_time

    ! check result
    if (.not. are_almost_equal(A, A_old, delta)) &
        print '(A, E7.2)', 'warning: not equal up to ', delta

    ! compute forall
    call cpu_time(start_time)
    forall (row = 1:nr_rows, col=1:nr_cols)
        A(row, col) = 5.0_DP*B(row, col) + sqrt(2.5_DP*C(row, col))/3.2_DP
    end forall
    call cpu_time(end_time)
    print '(A, F12.6)', 'forall: ', end_time - start_time

    ! check result
    if (.not. are_almost_equal(A, A_old, delta)) &
        print '(A, E7.2)', 'warning: not equal up to ', delta

    ! compute do concurrent
    call cpu_time(start_time)
    do concurrent (row = 1:nr_rows, col=1:nr_cols)
        A(row, col) = 5.0_DP*B(row, col) + sqrt(2.5_DP*C(row, col))/3.2_DP
        end do
    call cpu_time(end_time)
    print '(A, F12.6)', 'do concurrent: ', end_time - start_time

    ! check result
    if (.not. are_almost_equal(A, A_old, delta)) &
        print '(A, E7.2)', 'warning: not equal up to ', delta
    ! deallocate arrays
    deallocate(A, B, C, A_old)

contains

    function are_almost_equal(A, B, delta) result(are_same)
        implicit none
        real(kind=DP), dimension(:, :), intent(in) :: A, B
        real(kind=DP), value :: delta
        logical :: are_same

        are_same = all(abs(A - B)/A < delta)
    end function are_almost_equal

end program array_timings


!> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLARTG( F, G, C, S, R )
!
!       .. Scalar Arguments ..
!       REAL(wp)           C
!       COMPLEX(wp)        F, G, R, S
!       ..
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLARTG generates a plane rotation so that
!>
!>    [  C         S  ] . [ F ]  =  [ R ]
!>    [ -conjg(S)  C  ]   [ G ]     [ 0 ]
!>
!> where C is real and C**2 + |S|**2 = 1.
!>
!> The mathematical formulas used for C and S are
!>
!>    sgn(x) = {  x / |x|,   x != 0
!>             {  1,         x = 0
!>
!>    R = sgn(F) * sqrt(|F|**2 + |G|**2)
!>
!>    C = |F| / sqrt(|F|**2 + |G|**2)
!>
!>    S = sgn(F) * conjg(G) / sqrt(|F|**2 + |G|**2)
!>
!> When F and G are real, the formulas simplify to C = F/R and
!> S = G/R, and the returned values of C, S, and R should be
!> identical to those returned by DLARTG.
!>
!> The algorithm used to compute these quantities incorporates scaling
!> to avoid overflow or underflow in computing the square root of the
!> sum of squares.
!>
!> This is a faster version of the BLAS1 routine ZROTG, except for
!> the following differences:
!>    F and G are unchanged on return.
!>    If G=0, then C=1 and S=0.
!>    If F=0, then C=0 and S is chosen so that R is real.
!>
!> Below, wp=>dp stands for double precision from LA_CONSTANTS module.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is COMPLEX(wp)
!>          The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is COMPLEX(wp)
!>          The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is REAL(wp)
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is COMPLEX(wp)
!>          The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!>          R is COMPLEX(wp)
!>          The nonzero component of the rotated vector.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
subroutine ZLARTG( f, g, c, s, r )
   use LA_CONSTANTS, &
   only: wp=>dp, zero=>dzero, one=>done, two=>dtwo, czero=>zzero, &
         rtmin=>drtmin, rtmax=>drtmax, safmin=>dsafmin, safmax=>dsafmax
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     February 2021
!
!  .. Scalar Arguments ..
   real(wp)           c
   complex(wp)        f, g, r, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
   complex(wp) :: fs, gs, t
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, aimag, conjg, max, min, real, sqrt
!  ..
!  .. Statement Functions ..
   real(wp) :: ABSSQ
!  ..
!  .. Statement Function definitions ..
   ABSSQ( t ) = real( t )**2 + aimag( t )**2
!  ..
!  .. Executable Statements ..
!
   if( g == czero ) then
      c = one
      s = czero
      r = f
   else if( f == czero ) then
      c = zero
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         g2 = ABSSQ( g )
         d = sqrt( g2 )
         s = conjg( g ) / d
         r = d
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = ABSSQ( gs )
         d = sqrt( g2 )
         s = conjg( gs ) / d
         r = d*u
      end if
   else
      f1 = max( abs(real(f)), abs(aimag(f)) )
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( f1 > rtmin .and. f1 < rtmax .and. &
          g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         f2 = ABSSQ( f )
         g2 = ABSSQ( g )
         h2 = f2 + g2
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = f2*p
         s = conjg( g )*( f*p )
         r = f*( h2*p )
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, f1, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = ABSSQ( gs )
         if( f1*uu < rtmin ) then
!
!           f is not well-scaled when scaled by g1.
!           Use a different scaling for f.
!
            v = min( safmax, max( safmin, f1 ) )
            vv = one / v
            w = v * uu
            fs = f*vv
            f2 = ABSSQ( fs )
            h2 = f2*w**2 + g2
         else
!
!           Otherwise use the same scaling for f and g.
!
            w = one
            fs = f*uu
            f2 = ABSSQ( fs )
            h2 = f2 + g2
         end if
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = ( f2*p )*w
         s = conjg( gs )*( fs*p )
         r = ( fs*( h2*p ) )*u
      end if
   end if
   return
end subroutine


      function scale10(x,nx,xpinch,size)
c----------------------------------------------------------------------
c     scales input array by increments of powers of ten.  that is
c  the scaling is increased by higher and higher powers of ten until
c  the input array would be plotting as a substantial size.
c  warning - the routine is designed mostly for plots with the x
c  axis near the center of the plot because scaling is done with
c  respect to the absolute value of the x values.
c
c  arguments-
c
c      x-input array to be rescaled.
c      nx - length of x
c      xpinch - initial x per inch scale.  the scaling constant
c           returned is obtained by deceasing this value by orders
c           of magnitude to a limit set in a data statement.
c           (currently 50 orders of magnitude)
c      size - size in inches from x=0.0 to closest plot boundary.
c----------------------------------------------------------------------
      dimension x(nx)
      data maxtry/50/
      xmax=0.0
c--scan for the largest x in absolute value.
      do 100 i=1,nx
  100      xmax=amax1(xmax,abs(x(i)))
      xmax=xmax/xpinch
c--scale to a plot size one order of magnitude smaller than that
c--which would cause clipping of the plot.
      do 200 i=1,maxtry
           dec = 10.0**i
           test=xmax*dec
           if(test.gt.size) then
                scale10=xpinch/(10.0**(i-1))
                return
           endif
  200 continue
      scale10=xpinch
      return
      end

c $Id$


! File VersionID:
!   $Id: calcgrid.for 176 2010-03-13 11:36:14Z kroes006 $
! ----------------------------------------------------------------------
      subroutine calcgrid
! ----------------------------------------------------------------------
!     Date               : Aug 2004
!     Purpose            : calculate grid parameters
! ----------------------------------------------------------------------

      use variables
      implicit none

      integer i,j,lay,node,layold
      character messag*200,tmp*11

! --- check correct input of number and height of soil compartments
      do i = 1,nsublay
        if (abs(ncomp(i)*hcomp(i) - hsublay(i)) .gt. 1.d-5) then
! ---     error in input data
          write(tmp,'(i11)') i
          tmp = adjustl(tmp)
          messag ='At the soil water section, part 4, at layer '//
     &   trim(tmp)//' the height of this soil layer hsublay corresponds'
     &    //' not to the product of height and number of compartments'
          call fatalerr ('initsol',messag)
        endif
      end do

! --- position of nodal points and distances between them; also layer
! --- of each node
      node = 0
      do i = 1,nsublay
        do j = 1,ncomp(i)
          node = node + 1
          dz(node) = hcomp(i)
          if (node .eq. 1) then
            z(node) = - 0.5 * dz(node)
            disnod(node) = - z(node)
            layer(node) = isoillay(i)
          else
            z(node) = z(node-1) - 0.5*(dz(node-1)+dz(node))
            disnod(node) = z(node-1)-z(node)
            layer(node) = isoillay(i)
          endif
        end do
      end do
      numnod = node
      disnod(numnod+1) = 0.5*dz(numnod)

! --- determine bottom compartment of each soil layer
      layold = 1
      do node = 1, numnod
        if (layer(node) .gt. layold) then
          botcom(layold) = node - 1
          layold = layold + 1
        endif
      end do
      numlay = layold
      botcom(numlay) = numnod

! --- linear interpolation values between nodes
      inpolb(1) = 0.5*dz(1)/disnod(2)
      do node = 2,numnod-1
        inpola(node) = 0.5*dz(node)/disnod(node)
        inpolb(node) = 0.5*dz(node)/disnod(node+1)
      end do
      inpola(numnod) = 0.5*dz(numnod)/disnod(numnod)

! --- find first Node of the Layer
      do lay = 1,numlay
        Node = 1
        do while(Layer(Node).ne.lay)
           Node = Node + 1
        enddo
        nod1lay(lay) = node
      enddo

      return
      end


module angle
  ! ############################################################################
  ! Setup the angular quadrature
  ! ############################################################################

  use control, only : dp

  implicit none

  real(kind=dp), allocatable, dimension(:) :: &
      mu,                       & ! cosine of angles
      eta,                      & ! sine of angles
      wt                          ! quadrature weight (sum to 1)
  real(kind=dp), allocatable, dimension(:,:) :: &
      p_leg                       ! Container for the legendre polynomials
  integer, parameter :: &
      GL = 1, &                   ! Gauss Legendre quadrature
      DGL = 2                     ! Double Gauss Legendre quadrature
  real(kind=dp), parameter :: &
      PI = 3.141592653589793116_8 ! Setting the value of pi

  contains

  subroutine initialize_angle()
    ! ##########################################################################
    ! Allocate quadrature arrays
    ! ##########################################################################

    ! Use Statements
    use control, only : spatial_dimension, angle_option, number_angles, number_angles_per_octant, angle_order

    ! Variable definitions
    integer :: &
        a, & ! Angle index
        i, & ! Counting variable
        j    ! Counting variable
    real(kind=dp), allocatable, dimension(:) :: &
        mu_vals, & !
        wt_vals    !
    integer, allocatable, dimension(:) :: &
        wt_map

    if (spatial_dimension == 1) then

      number_angles_per_octant = angle_order
      number_angles = 2 * number_angles_per_octant
      allocate(mu(number_angles_per_octant), wt(number_angles_per_octant))

      ! Generate the Legendre quadrature
      if (angle_option == GL) then
        call generate_gl_parameters(number_angles, mu, wt)
      else if (angle_option == DGL) then
        call generate_gl_parameters(number_angles_per_octant, mu, wt)
        mu = 0.5_8 * mu + 0.5_8
        wt = 0.5_8 * wt
        do a = 1, number_angles_per_octant / 2
          mu(number_angles_per_octant - a + 1) = 1.0_8 - mu(a)
          wt(number_angles_per_octant - a + 1) = wt(a)
        end do  ! End a loop
      else
        stop "Invalid quadrature option."
      end if
    else if (spatial_dimension == 2) then

      if (angle_order < 2 .or. angle_order > 24) then
        print *, 'angles are only defined for 2 <= angle_order <= 24'
        stop
      else if (modulo(angle_order,  2) /= 0) then
        print *, 'angles are only defined for even angle_order'
      end if

      ! Compute the total number of angles
      number_angles_per_octant = angle_order * (angle_order + 2) / 8
      number_angles = number_angles_per_octant * 2 ** spatial_dimension
      allocate(mu(number_angles_per_octant), eta(number_angles_per_octant), &
               wt(number_angles_per_octant), wt_map(number_angles_per_octant))
      if (angle_order == 2) then
        allocate(mu_vals(1), wt_vals(1))
        mu_vals(1) = 0.577350269189625764509149_8
        wt_vals(1) = 1.000000000000000000000000_8
        wt_map = [0]
      else if (angle_order == 4) then
        allocate(mu_vals(2), wt_vals(1))
        mu_vals(1) = 0.350021174581540677777041_8
        mu_vals(2) = 0.868890300722201205229788_8
        wt_vals(1) = 0.333333333333333333333333_8
        wt_map = [0, 0, 0]
      else if (angle_order == 6) then
        allocate(mu_vals(3), wt_vals(2))
        mu_vals(1) = 0.266635401516704720331535_8
        mu_vals(2) = 0.681507726536546927403750_8
        mu_vals(3) = 0.926180935517489107558380_8
        wt_vals(1) = 0.176126130863383433783565_8
        wt_vals(2) = 0.157207202469949899549768_8
        wt_map = [0, 1, 0, 1, 1, 0]
      else if (angle_order == 8) then
        allocate(mu_vals(4), wt_vals(3))
        mu_vals(1) = 0.218217890235992381266097_8
        mu_vals(2) = 0.577350269189625764509149_8
        mu_vals(3) = 0.786795792469443145800830_8
        mu_vals(4) = 0.951189731211341853132399_8
        wt_vals(1) = 0.120987654320987654320988_8
        wt_vals(2) = 0.0907407407407407407407407_8
        wt_vals(3) = 0.0925925925925925925925926_8
        wt_map = [0, 1, 1, 0, 1, 2, 1, 1, 1, 0]
      else if (angle_order == 10) then
        allocate(mu_vals(5), wt_vals(4))
        mu_vals(1) = 0.189321326478010476671494_8
        mu_vals(2) = 0.508881755582618974382711_8
        mu_vals(3) = 0.694318887594384317279217_8
        mu_vals(4) = 0.839759962236684758403029_8
        mu_vals(5) = 0.963490981110468484701598_8
        wt_vals(1) = 0.0893031479843567214704325_8
        wt_vals(2) = 0.0725291517123655242296233_8
        wt_vals(3) = 0.0450437674364086390490892_8
        wt_vals(4) = 0.0539281144878369243545650_8
        wt_map = [0, 1, 2, 1, 0, 1, 3, 3, 1, 2, 3, 2, 1, 1, 0]
      else if (angle_order == 12) then
        allocate(mu_vals(6), wt_vals(5))
        mu_vals(1) = 0.167212652822713264084504_8
        mu_vals(2) = 0.459547634642594690016761_8
        mu_vals(3) = 0.628019096642130901034766_8
        mu_vals(4) = 0.760021014833664062877138_8
        mu_vals(5) = 0.872270543025721502340662_8
        mu_vals(6) = 0.971637719251358378302376_8
        wt_vals(1) = 0.0707625899700910439766549_8
        wt_vals(2) = 0.0558811015648888075828962_8
        wt_vals(3) = 0.0373376737588285824652402_8
        wt_vals(4) = 0.0502819010600571181385765_8
        wt_vals(5) = 0.0258512916557503911218290_8
        wt_map = [0, 1, 2, 2, 1, 0, 1, 3, 4, 3, 1, 2, 4, 4, 2, 2, 3, 2, 1, 1, 0]
      else if (angle_order == 14) then
        allocate(mu_vals(7), wt_vals(7))
        mu_vals(1) = 0.151985861461031912404799_8
        mu_vals(2) = 0.422156982304796966896263_8
        mu_vals(3) = 0.577350269189625764509149_8
        mu_vals(4) = 0.698892086775901338963210_8
        mu_vals(5) = 0.802226255231412057244328_8
        mu_vals(6) = 0.893691098874356784901111_8
        mu_vals(7) = 0.976627152925770351762946_8
        wt_vals(1) = 0.0579970408969969964063611_8
        wt_vals(2) = 0.0489007976368104874582568_8
        wt_vals(3) = 0.0227935342411872473257345_8
        wt_vals(4) = 0.0394132005950078294492985_8
        wt_vals(5) = 0.0380990861440121712365891_8
        wt_vals(6) = 0.0258394076418900119611012_8
        wt_vals(7) = 0.00826957997262252825269908_8
        wt_map = [0, 1, 2, 3, 2, 1, 0, 1, 4, 5, 5, 4, 1, 2, &
                  5, 6, 5, 2, 3, 5, 5, 3, 2, 4, 2, 1, 1, 0]
      else if (angle_order == 16) then
        allocate(mu_vals(8), wt_vals(8))
        mu_vals(1) = 0.138956875067780344591732_8
        mu_vals(2) = 0.392289261444811712294197_8
        mu_vals(3) = 0.537096561300879079878296_8
        mu_vals(4) = 0.650426450628771770509703_8
        mu_vals(5) = 0.746750573614681064580018_8
        mu_vals(6) = 0.831996556910044145168291_8
        mu_vals(7) = 0.909285500943725291652116_8
        mu_vals(8) = 0.980500879011739882135849_8
        wt_vals(1) = 0.0489872391580385335008367_8
        wt_vals(2) = 0.0413295978698440232405505_8
        wt_vals(3) = 0.0203032007393652080748070_8
        wt_vals(4) = 0.0265500757813498446015484_8
        wt_vals(5) = 0.0379074407956004002099321_8
        wt_vals(6) = 0.0135295047786756344371600_8
        wt_vals(7) = 0.0326369372026850701318409_8
        wt_vals(8) = 0.0103769578385399087825920_8
        wt_map = [0, 1, 2, 3, 3, 2, 1, 0, 1, 4, 5, 6, 5, 4, &
                  1, 2, 5, 7, 7, 5, 2, 3, 6, 7, 6, 3, 3, 5, &
                  5, 3, 2, 4, 2, 1, 1, 0]
      else if (angle_order == 18) then
        allocate(mu_vals(9), wt_vals(10))
        mu_vals(1)  = 0.129344504545924818514086_8
        mu_vals(2)  = 0.368043816053393605686086_8
        mu_vals(3)  = 0.504165151725164054411848_8
        mu_vals(4)  = 0.610662549934881101060239_8
        mu_vals(5)  = 0.701166884252161909657019_8
        mu_vals(6)  = 0.781256199495913171286914_8
        mu_vals(7)  = 0.853866206691488372341858_8
        mu_vals(8)  = 0.920768021061018932899055_8
        mu_vals(9)  = 0.983127661236087115272518_8
        wt_vals(1)  = 0.0422646448843821748535825_8
        wt_vals(2)  = 0.0376127473827281471532380_8
        wt_vals(3)  = 0.0122691351637405931037187_8
        wt_vals(4)  = 0.0324188352558815048715646_8
        wt_vals(5)  = 0.00664438614619073823264082_8
        wt_vals(6)  = 0.0312093838436551370068864_8
        wt_vals(7)  = 0.0160127252691940275641645_8
        wt_vals(8)  = 0.0200484595308572875885066_8
        wt_vals(9)  = 0.000111409402059638628382279_8
        wt_vals(10) = 0.0163797038522425240494567_8
        wt_map = [0, 1, 2, 3, 4, 3, 2, 1, 0, 1, 5, 6, 7, 7, &
                  6, 5, 1, 2, 6, 8, 9, 8, 6, 2, 3, 7, 9, 9, &
                  7, 3, 4, 7, 8, 7, 4, 3, 6, 6, 3, 2, 5, 2, &
                  1, 1, 0]
      else if (angle_order == 20) then
        allocate(mu_vals(10), wt_vals(12))
        mu_vals(1)  = 0.120603343036693597409418_8
        mu_vals(2)  = 0.347574292315847257336779_8
        mu_vals(3)  = 0.476519266143665680817278_8
        mu_vals(4)  = 0.577350269189625764509149_8
        mu_vals(5)  = 0.663020403653288019308783_8
        mu_vals(6)  = 0.738822561910371432904974_8
        mu_vals(7)  = 0.807540401661143067193530_8
        mu_vals(8)  = 0.870852583760463975580977_8
        mu_vals(9)  = 0.929863938955324566667817_8
        mu_vals(10) = 0.985347485558646574628509_8
        wt_vals(1)  = 0.0370210490604481342320295_8
        wt_vals(2)  = 0.0332842165376314841003910_8
        wt_vals(3)  = 0.0111738965965092519614021_8
        wt_vals(4)  = 0.0245177476959359285418987_8
        wt_vals(5)  = 0.0135924329650041789567081_8
        wt_vals(6)  = 0.0318029065936585971501960_8
        wt_vals(7)  = 0.00685492401402507781062634_8
        wt_vals(8)  = 0.0308105481755299327227893_8
        wt_vals(9)  = -0.000139484716502602877593527_8
        wt_vals(10) = 0.00544675187330776223879437_8
        wt_vals(11) = 0.00474564692642379971238396_8
        wt_vals(12) = 0.0277298541009064049325246_8
        wt_map = [0, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1, 5, 6, 7, &
                  8, 7, 6, 5, 1, 2, 6, 9, 10, 10, 9, 6, 2, 3, 7, &
                  10, 11, 10, 7, 3, 4, 8, 10, 10, 8, 4, 4, 7, 9, 7, 4, &
                  3, 6, 6, 3, 2, 5, 2, 1, 1, 0]
      else if (angle_order == 22) then
        allocate(mu_vals(11), wt_vals(14))
        mu_vals(1)  = 0.113888641383070838173488_8
        mu_vals(2)  = 0.330271760593086736334651_8
        mu_vals(3)  = 0.452977095507524183904005_8
        mu_vals(4)  = 0.548905330875560154226714_8
        mu_vals(5)  = 0.630401360620980621392149_8
        mu_vals(6)  = 0.702506006153654989703184_8
        mu_vals(7)  = 0.767869456282208576047898_8
        mu_vals(8)  = 0.828089557415325768804621_8
        mu_vals(9)  = 0.884217805921983001958912_8
        mu_vals(10) = 0.936989829997455780115072_8
        mu_vals(11) = 0.986944149751056870330152_8
        wt_vals(1)  = 0.0329277718552552308051381_8
        wt_vals(2)  = 0.0309569328165031538543025_8
        wt_vals(3)  = 0.00577105953220643022391829_8
        wt_vals(4)  = 0.0316834548379952775919418_8
        wt_vals(5)  = -0.00669350304140992494103696_8
        wt_vals(6)  = 0.0368381622687682466526634_8
        wt_vals(7)  = 0.0273139698006629537455404_8
        wt_vals(8)  = 0.0100962716435030437817055_8
        wt_vals(9)  = 0.0195181067555849392224199_8
        wt_vals(10) = 0.0117224275470949786864925_8
        wt_vals(11) = -0.00442773155233893239996431_8
        wt_vals(12) = 0.0156214785078803432781324_8
        wt_vals(13) = -0.0101774221315738297143270_8
        wt_vals(14) = 0.0135061258938431808485310_8
        wt_map = [0, 1, 2, 3, 4, 5, 4, 3, 2, 1, 0, 1, 6, 7, 8, 9, &
                  9, 8, 7, 6, 1, 2, 7, 10, 11, 12, 11, 10, 7, 2, 3, &
                  8, 11, 13, 13, 11, 8, 3, 4, 9, 12, 13, 12, 9, 4, 5, &
                  9, 11, 11, 9, 5, 4, 8, 10, 8, 4, 3, 7, 7, 3, 2, 6, 2, 1, 1, 0]
      else if (angle_order == 24) then
        allocate(mu_vals(12), wt_vals(16))
        mu_vals(1)  = 0.107544208775147285552086_8
        mu_vals(2)  = 0.315151630853896874875332_8
        mu_vals(3)  = 0.432522073446742487657060_8
        mu_vals(4)  = 0.524242441631224399254880_8
        mu_vals(5)  = 0.602150256328323868809286_8
        mu_vals(6)  = 0.671073561381361944701265_8
        mu_vals(7)  = 0.733549261041044861004094_8
        mu_vals(8)  = 0.791106384731321324814121_8
        mu_vals(9)  = 0.844750913317919895113069_8
        mu_vals(10) = 0.895186516397704814461305_8
        mu_vals(11) = 0.942928254285052510917188_8
        mu_vals(12) = 0.988366574868785749937406_8
        wt_vals(1)  = 0.0295284942030736546025272_8
        wt_vals(2)  = 0.0281530651743695026834932_8
        wt_vals(3)  = 0.00519730128072174996473824_8
        wt_vals(4)  = 0.0259897467786242920448933_8
        wt_vals(5)  = 0.00146378160153344429844948_8
        wt_vals(6)  = 0.0166609651269037212368055_8
        wt_vals(7)  = 0.0281343344093849194875108_8
        wt_vals(8)  = 0.00214364311909247909952968_8
        wt_vals(9)  = 0.0331943417648083019611294_8
        wt_vals(10) = -0.0142483904822400753741381_8
        wt_vals(11) = 0.0416812529998231580614934_8
        wt_vals(12) = 0.00323522898964475022578598_8
        wt_vals(13) = 0.000813552611571786631179287_8
        wt_vals(14) = 0.00228403610697848813660369_8
        wt_vals(15) = 0.0338971925236628645848112_8
        wt_vals(16) = -0.00644725595698339499416262_8
        wt_map = [0, 1, 2, 3, 4, 5, 5, 4, 3, 2, 1, 0, 1, 6, 7, 8, 9, 10, &
                  9, 8, 7, 6, 1, 2, 7, 11, 12, 13, 13, 12, 11, 7, 2, 3, 8, &
                  12, 14, 15, 14, 12, 8, 3, 4, 9, 13, 15, 15, 13, 9, 4, 5, 10, &
                  13, 14, 13, 10, 5, 5, 9, 12, 12, 9, 5, 4, 8, 11, 8, 4, 3, 7, &
                  7, 3, 2, 6, 2, 1, 1, 0]
      else
        allocate(mu_vals(0), wt_vals(0))
      end if

      a = 1
      do i = 0, angle_order / 2 - 1
        do j = 0, angle_order / 2 - i - 1
          mu(a) = mu_vals(i + 1)
          eta(a) = mu_vals(j + 1)
          wt(a) = wt_vals(wt_map(a) + 1)
          a = a + 1
        end do  ! End j loop
      end do  ! End i loop

      wt(:) = 0.5_8 * PI * wt(:)

      deallocate(mu_vals, wt_vals)

    end if

  end subroutine initialize_angle

  subroutine finalize_angle()
    ! ##########################################################################
    ! Deallocated quadrature arrays
    ! ##########################################################################

    if (allocated(mu)) then
      deallocate(mu)
    end if
    if (allocated(eta)) then
      deallocate(eta)
    end if
    if (allocated(wt)) then
      deallocate(wt)
    end if
    if (allocated(p_leg)) then
      deallocate(p_leg)
    end if
  end subroutine finalize_angle

  subroutine generate_gl_parameters(m, x, w)
    ! ##########################################################################
    ! Generate Gauss-Legendre parameters.
    ! ##########################################################################

    ! Variable definitions
    integer, intent(in) :: &
        m    ! Number of angles
    real(kind=dp), intent(inout), dimension(:) :: &
        x, & ! Quadrature points
        w    ! Quadrature weights
    integer :: &
        i, & ! Looping variable
        j    ! Looping variable
    real(kind=dp) :: &
        p, & ! Legendre polynomial value
        dp   ! Double Legendre polynomial value

    ! The roots are symmetric, so we only find half of them.
    do i = 1, int(m / 2) + mod(m, 2)
      ! Asymptotic approx. due to F. Tricomi, Ann. Mat. Pura Appl., 31 (1950)
      x(i) = cos(pi * (i - 0.25_8) / (m + 0.5_8)) * (1.0_8 - 0.125_8 * (1.0_8 / m ** 2 - 1.0_8 / m ** 3.0_8))
      do j = 1, 100
        p = legendre_p(m, x(i))
        dp = d_legendre_p(m, x(i))
        if (abs(p/dp) < 1e-16_8) then
          exit
        end if
        ! Newton step
        x(i) = x(i) - p / dp
      end do  ! End j loop
      w(i) = 2.0_8 / ((1.0_8 - x(i) ** 2.0_8) * d_legendre_p(m, x(i)) ** 2.0_8)
    end do  ! End i loop

  end subroutine generate_gl_parameters

  subroutine initialize_polynomials()
    ! ##########################################################################
    ! Fill p_leg with the discrete column vectors of DLP
    ! ##########################################################################

    ! Use Statements
    use control, only : number_angles, number_legendre, spatial_dimension, number_angles_per_octant

    ! Variable definitions
    integer :: &
        l,             & ! Legendre order index
        ll,            & ! Total order
        o,             & ! Octant index
        m,             & ! Legendre moment index
        mu_sign,       & ! Sign of the cosine of angle
        eta_sign,      & ! Sign of the sine of angle
        an,            & ! Global angle index
        a                ! Angle index
    real(kind=dp) :: &
        xi               ! direction cosine w/r to z axis

    if (spatial_dimension == 1) then
      allocate(p_leg(0:number_legendre, number_angles))

      do a = 1, number_angles_per_octant
        do l = 0, number_legendre
          p_leg(l, a) = legendre_p(l, mu(a))
          p_leg(l, number_angles - a + 1) = legendre_p(l, -mu(a))
        end do  ! End l loop
      end do  ! End a loop
    else if (spatial_dimension == 2) then
      ll = 0
      do l = 0, number_legendre
        do m = -l, l
          ll = ll + 1
        end do  ! End m loop
      end do  ! End l loop

      allocate(p_leg(0:(number_legendre + 1) ** 2 - 1, number_angles))

      do o = 1, 4
        mu_sign = merge(1, -1, o ==1 .or. o == 2)
        eta_sign = merge(1, -1, o == 1 .or. o == 4)
        do a = 1, number_angles_per_octant
          an = (o - 1) * number_angles_per_octant + a
          xi = abs(sqrt(1 - mu(a) ** 2 - eta(a) ** 2))
          ll = 0
          do l = 0, number_legendre
            do m = -l, l
              p_leg(ll, an) = generate_y_lm(l, m, mu_sign * mu(a), eta_sign * eta(a), xi)
              p_leg(ll, an) = p_leg(ll, an) + generate_y_lm(l, m, mu_sign * mu(a), eta_sign * eta(a), -xi)
              p_leg(ll, an) = p_leg(ll, an) * 0.5
              ll = ll + 1
            end do  ! End m loop
          end do  ! End l loop
        end do  ! End a loop
      end do  ! End o loop
    end if

  end subroutine initialize_polynomials

  real(kind=dp) function legendre_p(l, x)
    ! ##########################################################################
    ! Compute P_l(x) using recursion relationship
    ! ##########################################################################

    integer, intent(in) :: &
        l      ! Order of legendre polynomial
    real(kind=dp), intent(in) :: &
        x      ! Coordinate for polynomial value
    real(kind=dp) :: &
        P_0, & ! Polynomial for order l
        P_1, & ! Polynomial for order l-1
        P_2    ! Polynomial for order l-2
    integer :: &
        m      ! Order index

    if (l == 0) then
      P_0 = 1.0_8
    else if (l == 1) then
      P_0 = x
    else
      P_1 = 1.0_8 ! P(l-2, x)
      P_0 = x     ! P(l-1, x)
      do m = 2, l
        P_2 = P_1
        P_1 = P_0
        P_0 = ((2 * m - 1) * x * P_1 - (m - 1) * P_2) / m
      end do  ! End m loop
    end if
    legendre_p = P_0

  end function legendre_p

  real(kind=dp) function d_legendre_p(l, x)
    ! ##########################################################################
    ! Compute dP_l/dx using recursion relationship
    ! ##########################################################################

    integer, intent(in) :: &
        l ! Order of legendre polynomial
    real(kind=dp), intent(in) :: &
        x ! Coordinate for polynomial value

    if (l == 0) then
      d_legendre_p = 0.0_8
    else
      d_legendre_p = (legendre_p(l - 1, x) - x * legendre_p(l, x)) * l / (1 - x ** 2)
    end if

  end function d_legendre_p

  real(kind=dp) function generate_y_lm(l, m, mu, eta, xi)
    ! ##########################################################################
    ! Calculate the spherical harmonic of degree l, order m
    ! ##########################################################################

    integer, intent(in) :: &
        l,   & ! Legendre order (or spherical harmonic degree)
        m      ! Spherical harmonic order
    real(kind=dp), intent(in) :: &
        mu,  & ! direction cosine w/r to x axis
        eta, & ! direction cosine w/r to y axis
        xi     ! direction cosine w/r to z axis

    if (l < 0) then
      print *, 'Bad value for l in angle.f90 (l < 0)'
      stop
    else if (abs(m) > l) then
      print *, 'Bad value for m in angle.f90 (abs(m) > 0)'
      stop
    else if (abs(mu) > 1) then
      print *, 'Bad value for mu in angle.f90 (abs(mu) > 1)'
      stop
    else if (abs(eta) > 1) then
      print *, 'Bad value for eta in angle.f90 (abs(eta) > 1)'
      stop
    else if (abs(xi) > 1) then
      print *, 'Bad value for xi in angle.f90 (abs(xi) > 1)'
      stop
    else if (mu ** 2 + eta ** 2 + xi ** 2 - 1 > 1e-5) then
      print *, 'Angles do not math to unity'
      stop
    end if

    if (l == 0) then
      if (m == 0) then
        ! R_0^0 = 1.0
        generate_y_lm = 1.0
      end if
    else if (l == 1) then
      if (m == -1) then
        ! R_1^-1 = eta
        generate_y_lm = eta
      else if (m == 0) then
        ! R_1^0 = xi
        generate_y_lm = xi
      else if (m == 1) then
        ! R_1^1 = mu
        generate_y_lm = mu
      end if
    else if (l == 2) then
      if (m == -2) then
        ! R_2^-2 = sqrt(3)*eta*mu
        generate_y_lm = sqrt(3.0)*eta*mu
      else if (m == -1) then
        ! R_2^-1 = sqrt(3)*eta*xi
        generate_y_lm = sqrt(3.0)*eta*xi
      else if (m == 0) then
        ! R_2^0 = 1.5*xi**2 - 0.5
        generate_y_lm = 1.5*xi**2 - 0.5
      else if (m == 1) then
        ! R_2^1 = sqrt(3)*mu*xi
        generate_y_lm = sqrt(3.0)*mu*xi
      else if (m == 2) then
        ! R_2^2 = 0.5*sqrt(3)*(-eta**2 + mu**2)
        generate_y_lm = 0.5*sqrt(3.0)*(-eta**2 + mu**2)
      end if
    else if (l == 3) then
      if (m == -3) then
        ! R_3^-3 = sqrt(10)*eta*(-0.25*eta**2 + 0.75*mu**2)
        generate_y_lm = sqrt(10.0)*eta*(-0.25*eta**2 + 0.75*mu**2)
      else if (m == -2) then
        ! R_3^-2 = sqrt(15)*eta*mu*xi
        generate_y_lm = sqrt(15.0)*eta*mu*xi
      else if (m == -1) then
        ! R_3^-1 = sqrt(6)*eta*(1.25*xi**2 - 0.25)
        generate_y_lm = sqrt(6.0)*eta*(1.25*xi**2 - 0.25)
      else if (m == 0) then
        ! R_3^0 = xi*(2.5*xi**2 - 1.5)
        generate_y_lm = xi*(2.5*xi**2 - 1.5)
      else if (m == 1) then
        ! R_3^1 = sqrt(6)*mu*(1.25*xi**2 - 0.25)
        generate_y_lm = sqrt(6.0)*mu*(1.25*xi**2 - 0.25)
      else if (m == 2) then
        ! R_3^2 = 0.5*sqrt(15)*xi*(-eta**2 + mu**2)
        generate_y_lm = 0.5*sqrt(15.0)*xi*(-eta**2 + mu**2)
      else if (m == 3) then
        ! R_3^3 = sqrt(10)*mu*(-0.75*eta**2 + 0.25*mu**2)
        generate_y_lm = sqrt(10.0)*mu*(-0.75*eta**2 + 0.25*mu**2)
      end if
    else if (l == 4) then
      if (m == -4) then
        ! R_4^-4 = 0.5*sqrt(35)*eta*mu*(-eta**2 + mu**2)
        generate_y_lm = 0.5*sqrt(35.0)*eta*mu*(-eta**2 + mu**2)
      else if (m == -3) then
        ! R_4^-3 = sqrt(70)*eta*xi*(-0.25*eta**2 + 0.75*mu**2)
        generate_y_lm = sqrt(70.0)*eta*xi*(-0.25*eta**2 + 0.75*mu**2)
      else if (m == -2) then
        ! R_4^-2 = sqrt(5)*eta*mu*(3.5*xi**2 - 0.5)
        generate_y_lm = sqrt(5.0)*eta*mu*(3.5*xi**2 - 0.5)
      else if (m == -1) then
        ! R_4^-1 = sqrt(10)*eta*xi*(1.75*xi**2 - 0.75)
        generate_y_lm = sqrt(10.0)*eta*xi*(1.75*xi**2 - 0.75)
      else if (m == 0) then
        ! R_4^0 = 4.375*xi**4 - 3.75*xi**2 + 0.375
        generate_y_lm = 4.375*xi**4 - 3.75*xi**2 + 0.375
      else if (m == 1) then
        ! R_4^1 = sqrt(10)*mu*xi*(1.75*xi**2 - 0.75)
        generate_y_lm = sqrt(10.0)*mu*xi*(1.75*xi**2 - 0.75)
      else if (m == 2) then
        ! R_4^2 = -1.75*sqrt(5)*(eta - mu)*(eta + mu)*(xi**2 - 1.0/7)
        generate_y_lm = -1.75*sqrt(5.0)*(eta - mu)*(eta + mu)*(xi**2 - 1.0/7)
      else if (m == 3) then
        ! R_4^3 = sqrt(70)*mu*xi*(-0.75*eta**2 + 0.25*mu**2)
        generate_y_lm = sqrt(70.0)*mu*xi*(-0.75*eta**2 + 0.25*mu**2)
      else if (m == 4) then
        ! R_4^4 = sqrt(35)*(0.125*eta**4 - 0.75*eta**2*mu**2 + 0.125*mu**4)
        generate_y_lm = sqrt(35.0)*(0.125*eta**4 - 0.75*eta**2*mu**2 + 0.125*mu**4)
      end if
    else if (l == 5) then
      if (m == -5) then
        ! R_5^-5 = sqrt(14)*eta*(0.1875*eta**4 - 1.875*eta**2*mu**2 + 0.9375*mu**4)
        generate_y_lm = sqrt(14.0)*eta*(0.1875*eta**4 - 1.875*eta**2*mu**2 + 0.9375*mu**4)
      else if (m == -4) then
        ! R_5^-4 = 1.5*sqrt(35)*eta*mu*xi*(-eta**2 + mu**2)
        generate_y_lm = 1.5*sqrt(35.0)*eta*mu*xi*(-eta**2 + mu**2)
      else if (m == -3) then
        ! R_5^-3 = -1.6875*sqrt(70)*eta*(1.0/3*eta**2 - mu**2)*(xi - 1.0/3)*(xi + 1.0/3)
        generate_y_lm = -1.6875*sqrt(70.0)*eta*(1.0/3*eta**2 - mu**2)*(xi - 1.0/3)*(xi + 1.0/3)
      else if (m == -2) then
        ! R_5^-2 = sqrt(105)*eta*mu*xi*(1.5*xi**2 - 0.5)
        generate_y_lm = sqrt(105.0)*eta*mu*xi*(1.5*xi**2 - 0.5)
      else if (m == -1) then
        ! R_5^-1 = sqrt(15)*eta*(2.625*xi**4 - 1.75*xi**2 + 0.125)
        generate_y_lm = sqrt(15.0)*eta*(2.625*xi**4 - 1.75*xi**2 + 0.125)
      else if (m == 0) then
        ! R_5^0 = xi*(7.875*xi**4 - 8.75*xi**2 + 1.875)
        generate_y_lm = xi*(7.875*xi**4 - 8.75*xi**2 + 1.875)
      else if (m == 1) then
        ! R_5^1 = sqrt(15)*mu*(2.625*xi**4 - 1.75*xi**2 + 0.125)
        generate_y_lm = sqrt(15.0)*mu*(2.625*xi**4 - 1.75*xi**2 + 0.125)
      else if (m == 2) then
        ! R_5^2 = -0.75*sqrt(105)*xi*(eta - mu)*(eta + mu)*(xi**2 - 1.0/3)
        generate_y_lm = -0.75*sqrt(105.0)*xi*(eta - mu)*(eta + mu)*(xi**2 - 1.0/3)
      else if (m == 3) then
        ! R_5^3 = -1.6875*sqrt(70)*mu*(eta**2 - 1.0/3*mu**2)*(xi - 1.0/3)*(xi + 1.0/3)
        generate_y_lm = -1.6875*sqrt(70.0)*mu*(eta**2 - 1.0/3*mu**2)*(xi - 1.0/3)*(xi + 1.0/3)
      else if (m == 4) then
        ! R_5^4 = sqrt(35)*xi*(0.375*eta**4 - 2.25*eta**2*mu**2 + 0.375*mu**4)
        generate_y_lm = sqrt(35.0)*xi*(0.375*eta**4 - 2.25*eta**2*mu**2 + 0.375*mu**4)
      else if (m == 5) then
        ! R_5^5 = sqrt(14)*mu*(0.9375*eta**4 - 1.875*eta**2*mu**2 + 0.1875*mu**4)
        generate_y_lm = sqrt(14.0)*mu*(0.9375*eta**4 - 1.875*eta**2*mu**2 + 0.1875*mu**4)
      end if
    else if (l == 6) then
      if (m == -6) then
        ! R_6^-6 = sqrt(462)*eta*mu*(0.1875*eta**4 - 0.625*eta**2*mu**2 + 0.1875*mu**4)
        generate_y_lm = sqrt(462.0)*eta*mu*(0.1875*eta**4 - 0.625*eta**2*mu**2 + 0.1875*mu**4)
      else if (m == -5) then
        ! R_6^-5 = sqrt(154)*eta*xi*(0.1875*eta**4 - 1.875*eta**2*mu**2 + 0.9375*mu**4)
        generate_y_lm = sqrt(154.0)*eta*xi*(0.1875*eta**4 - 1.875*eta**2*mu**2 + 0.9375*mu**4)
      else if (m == -4) then
        ! R_6^-4 = -8.25*sqrt(7)*eta*mu*(eta - mu)*(eta + mu)*(xi**2 - 1.0/11)
        generate_y_lm = -8.25*sqrt(7.0)*eta*mu*(eta - mu)*(eta + mu)*(xi**2 - 1.0/11)
      else if (m == -3) then
        ! R_6^-3 = -2.0625*sqrt(210)*eta*xi*(1.0/3*eta**2 - mu**2)*(xi**2 - 3/11)
        generate_y_lm = -2.0625*sqrt(210.0)*eta*xi*(1.0/3*eta**2 - mu**2)*(xi**2 - 3.0/11)
      else if (m == -2) then
        ! R_6^-2 = sqrt(210)*eta*mu*(2.0625*xi**4 - 1.125*xi**2 + 0.0625)
        generate_y_lm = sqrt(210.0)*eta*mu*(2.0625*xi**4 - 1.125*xi**2 + 0.0625)
      else if (m == -1) then
        ! R_6^-1 = sqrt(21)*eta*xi*(4.125*xi**4 - 3.75*xi**2 + 0.625)
        generate_y_lm = sqrt(21.0)*eta*xi*(4.125*xi**4 - 3.75*xi**2 + 0.625)
      else if (m == 0) then
        ! R_6^0 = 14.4375*xi**6 - 19.6875*xi**4 + 6.5625*xi**2 - 0.3125
        generate_y_lm = 14.4375*xi**6 - 19.6875*xi**4 + 6.5625*xi**2 - 0.3125
      else if (m == 1) then
        ! R_6^1 = sqrt(21)*mu*xi*(4.125*xi**4 - 3.75*xi**2 + 0.625)
        generate_y_lm = sqrt(21.0)*mu*xi*(4.125*xi**4 - 3.75*xi**2 + 0.625)
      else if (m == 2) then
        ! R_6^2 = -1.03125*sqrt(210)*(eta - mu)*(eta + mu)*(xi**4 - 6/11*xi**2 + 1.0/33)
        generate_y_lm = -1.03125*sqrt(210.0)*(eta - mu)*(eta + mu)*(xi**4 - 6.0/11*xi**2 + 1.0/33)
      else if (m == 3) then
        ! R_6^3 = -2.0625*sqrt(210)*mu*xi*(eta**2 - 1.0/3*mu**2)*(xi**2 - 3/11)
        generate_y_lm = -2.0625*sqrt(210.0)*mu*xi*(eta**2 - 1.0/3*mu**2)*(xi**2 - 3.0/11)
      else if (m == 4) then
        ! R_6^4 = -8.25*sqrt(7)*(xi**2 - 1.0/11)*(-0.5*eta**2 + eta*mu + 0.5*mu**2)*(0.5*eta**2 + eta*mu - 0.5*mu**2)
        generate_y_lm = -8.25*sqrt(7.0)*(xi**2 - 1.0/11)*(-0.5*eta**2 + eta*mu + 0.5*mu**2)*(0.5*eta**2 + eta*mu - 0.5*mu**2)
      else if (m == 5) then
        ! R_6^5 = sqrt(154)*mu*xi*(0.9375*eta**4 - 1.875*eta**2*mu**2 + 0.1875*mu**4)
        generate_y_lm = sqrt(154.0)*mu*xi*(0.9375*eta**4 - 1.875*eta**2*mu**2 + 0.1875*mu**4)
      else if (m == 6) then
        ! R_6^6 = sqrt(462)*(-0.03125*eta**6 + 0.46875*eta**4*mu**2 - 0.46875*eta**2*mu**4 + 0.03125*mu**6)
        generate_y_lm = sqrt(462.0)*(-0.03125*eta**6 + 0.46875*eta**4*mu**2 - 0.46875*eta**2*mu**4 + 0.03125*mu**6)
      end if
    else if (l == 7) then
      if (m == -7) then
        ! R_7^-7 = sqrt(429)*eta*(-0.03125*eta**6 + 0.65625*eta**4*mu**2 - 1.09375*eta**2*mu**4 + 0.21875*mu**6)
        generate_y_lm = sqrt(429.0)*eta*(-0.03125*eta**6 + 0.65625*eta**4*mu**2 - 1.09375*eta**2*mu**4 + 0.21875*mu**6)
      else if (m == -6) then
        ! R_7^-6 = sqrt(6006)*eta*mu*xi*(0.1875*eta**4 - 0.625*eta**2*mu**2 + 0.1875*mu**4)
        generate_y_lm = sqrt(6006.0)*eta*mu*xi*(0.1875*eta**4 - 0.625*eta**2*mu**2 + 0.1875*mu**4)
      else if (m == -5) then
        ! R_7^-5 = 4.0625*sqrt(231)*eta*(xi**2 - 1.0/13)*(0.1*eta**4 - eta**2*mu**2 + 0.5*mu**4)
        generate_y_lm = 4.0625*sqrt(231.0)*eta*(xi**2 - 1.0/13)*(0.1*eta**4 - eta**2*mu**2 + 0.5*mu**4)
      else if (m == -4) then
        ! R_7^-4 = -3.25*sqrt(231)*eta*mu*xi*(eta - mu)*(eta + mu)*(xi**2 - 3/13)
        generate_y_lm = -3.25*sqrt(231.0)*eta*mu*xi*(eta - mu)*(eta + mu)*(xi**2 - 3.0/13)
      else if (m == -3) then
        ! R_7^-3 = -13.40625*sqrt(21)*eta*(1.0/3*eta**2 - mu**2)*(xi**4 - 6/13*xi**2 + 3/143)
        generate_y_lm = -13.40625*sqrt(21.0)*eta*(1.0/3*eta**2 - mu**2)*(xi**4 - 6.0/13*xi**2 + 3.0/143)
      else if (m == -2) then
        ! R_7^-2 = sqrt(42)*eta*mu*xi*(8.9375*xi**4 - 6.875*xi**2 + 0.9375)
        generate_y_lm = sqrt(42.0)*eta*mu*xi*(8.9375*xi**4 - 6.875*xi**2 + 0.9375)
      else if (m == -1) then
        ! R_7^-1 = sqrt(7)*eta*(13.40625*xi**6 - 15.46875*xi**4 + 4.21875*xi**2 - 0.15625)
        generate_y_lm = sqrt(7.0)*eta*(13.40625*xi**6 - 15.46875*xi**4 + 4.21875*xi**2 - 0.15625)
      else if (m == 0) then
        ! R_7^0 = xi*(26.8125*xi**6 - 43.3125*xi**4 + 19.6875*xi**2 - 2.1875)
        generate_y_lm = xi*(26.8125*xi**6 - 43.3125*xi**4 + 19.6875*xi**2 - 2.1875)
      else if (m == 1) then
        ! R_7^1 = sqrt(7)*mu*(13.40625*xi**6 - 15.46875*xi**4 + 4.21875*xi**2 - 0.15625)
        generate_y_lm = sqrt(7.0)*mu*(13.40625*xi**6 - 15.46875*xi**4 + 4.21875*xi**2 - 0.15625)
      else if (m == 2) then
        ! R_7^2 = -4.46875*sqrt(42)*xi*(eta - mu)*(eta + mu)*(xi**4 - 10.0/13.0*xi**2 + 15.0/143.0)
        generate_y_lm = -4.46875*sqrt(42.0)*xi*(eta - mu)*(eta + mu)*(xi**4 - 10.0/13.0*xi**2 + 15.0/143.0)
      else if (m == 3) then
        ! R_7^3 = -13.40625*sqrt(21)*mu*(eta**2 - 1.0/3*mu**2)*(xi**4 - 6/13*xi**2 + 3/143)
        generate_y_lm = -13.40625*sqrt(21.0)*mu*(eta**2 - 1.0/3*mu**2)*(xi**4 - 6.0/13*xi**2 + 3.0/143)
      else if (m == 4) then
        ! R_7^4 = -3.25*sqrt(231)*xi*(xi**2 - 3/13)*(-0.5*eta**2 + eta*mu + 0.5*mu**2)*(0.5*eta**2 + eta*mu - 0.5*mu**2)
        generate_y_lm = -3.25*sqrt(231.0)*xi*(xi**2 - 3.0/13)*(-0.5*eta**2 + eta*mu + 0.5*mu**2)*(0.5*eta**2 + eta*mu - 0.5*mu**2)
      else if (m == 5) then
        ! R_7^5 = 4.0625*sqrt(231)*mu*(xi**2 - 1.0/13)*(0.5*eta**4 - eta**2*mu**2 + 0.1*mu**4)
        generate_y_lm = 4.0625*sqrt(231.0)*mu*(xi**2 - 1.0/13)*(0.5*eta**4 - eta**2*mu**2 + 0.1*mu**4)
      else if (m == 6) then
        ! R_7^6 = sqrt(6006)*xi*(-0.03125*eta**6 + 0.46875*eta**4*mu**2 - 0.46875*eta**2*mu**4 + 0.03125*mu**6)
        generate_y_lm = sqrt(6006.0)*xi*(-0.03125*eta**6 + 0.46875*eta**4*mu**2 - 0.46875*eta**2*mu**4 + 0.03125*mu**6)
      else if (m == 7) then
        ! R_7^7 = sqrt(429)*mu*(-0.21875*eta**6 + 1.09375*eta**4*mu**2 - 0.65625*eta**2*mu**4 + 0.03125*mu**6)
        generate_y_lm = sqrt(429.0)*mu*(-0.21875*eta**6 + 1.09375*eta**4*mu**2 - 0.65625*eta**2*mu**4 + 0.03125*mu**6)
      end if
    else
      print *, 'Order l=', l, ' not implemented'
      stop
    end if

  end function generate_y_lm

end module angle