c     program DRCBLAS
c>> 1997-06-13 DRCBLAS Krogh  Added External Statement.
c>> 1992-03-13 CLL
c   DRCBLAS..  Demo driver for SCNRM2, CCOPY, CDOTC, and CDOTU.
c     ------------------------------------------------------------------
      external SCNRM2, CDOTC, CDOTU
      real    SCNRM2
      complex CDOTC, CDOTU

      real    S2
      complex C1, C2, C3, C4, CX(4), CY(4), CZ(4)
      integer N
      data CX / (5.0,  3.0), (-2.0,  6.0), (4.0, -7.0), (-8.0, -11.0)/
      data CY / (1.0, -2.0), (4.0,  8.0), (-5.0, -6.0), (-3.0, 7.0)/
c     ------------------------------------------------------------------
      print*,
     * ' DRCBLAS..  Demo driver for SCNRM2, CCOPY, CDOTC, and CDOTU.'
      N = 4
      call CCOPY(N, CY, 1, CZ, 1)
c
      C1 = CDOTC(N, CX, 1, CY, 1) - cmplx(8.0, -201.0)
      C2 = CDOTC(N, CX, 1, CZ, 1) - cmplx(8.0, -201.0)
      print'(/a)',
     *   ' Using CCOPY and CDOTC.  Expect C1 = C2 = (0.0, 0.0)'
      print'(a,2f8.2/10x,a,2f8.2)',' Computed: C1 =',C1,' C2 =',C2
c
      C3 = CDOTU(N, CX, 1, CY, 1) - cmplx(-6.0, -11.0)
      C4 = CDOTU(N, CX, 1, CZ, 1) - cmplx(-6.0, -11.0)
      print'(/a)',
     *   ' Using CCOPY and CDOTU.  Expect C3 = C4 = (0.0, 0.0)'
      print'(a,2f8.2/10x,a,2f8.2)',' Computed: C3 =',C3,' C4 =',C4
c
      S2 = SCNRM2(N, CX, 1) - 18.0
      print'(/a,f9.4)',
     *   ' Using SCNRM2.  Expect S2 = 0.0.  Computed: ',S2
      end


! The binomial coefficients nCk can be arranged in triangular form, Pascal's
 ! triangle, like this:
 !
 ! It can be seen that the first eight rows of Pascal's triangle contain twelve
 ! distinct numbers: 1, 2, 3, 4, 5, 6, 7, 10, 15, 20, 21 and 35.
 !
 ! A positive integer n is called squarefree if no square of a prime divides n.
 ! Of the twelve distinct numbers in the first eight rows of Pascal's triangle,
 ! all except 4 and 20 are squarefree. The sum of the distinct squarefree
 ! numbers in the first eight rows is 105.
 !
 ! Find the sum of the distinct squarefree numbers in the first 51 rows of
 ! Pascal's triangle.

program main

        ! a few FUTURE optimisations;
        ! We only have to calculate half the entries in Pascal's triange.
        ! The last (distinct) value of squarefree nums can be kept in a
        ! variable as the new entries will always be of increasing value...
        ! Kinda... Maybe if I do it from the top, and work down...
        ! We can check whether the row contains any by seeing if the product of
        ! the row is divisible by a squarefree number and if not we don't check
        ! it. There is a relationship between the products of consecutive rows;
        ! if the new product is divisible by a square prime, then we check
        ! individual entries, otherwise not
        ! We can traverse this in order by finding the max
        ! If the row number starts with a prime, then all subsequent numbers
        ! are divisible by that prime.

        use euler

implicit none

        integer (C_INT64_t), dimension(:), allocatable, TARGET :: sqrfree_arr;
        integer (int32), parameter :: MAX_ARR_LEN = 1000;
        integer (int32), parameter :: ROW_HEIGHT = 50;
        integer (C_INT64_t) :: n, k, tmp;
        integer (C_SIZE_T) :: arr_in;

        allocate(sqrfree_arr(MAX_ARR_LEN));
        sqrfree_arr = 0;

        arr_in = 1;

        row_loop: &
        do n = 1, ROW_HEIGHT

                index_loop: &
                do k = 0, ((n / 2) + merge(0, 0, BTEST(n, 0)))
                        tmp = binomial_coefficient(n, k);
                        if(squarefree(tmp)) then
                                sqrfree_arr(arr_in) = tmp;
                                arr_in = arr_in + 1;
                        endif

                end do index_loop

        end do row_loop

        print*, sum_discrete(sqrfree_arr, arr_in);

        deallocate(sqrfree_arr)

contains

        ! This function accepts an array to count discrete entries in the
        ! array. This is done by sorting the array and ignoring duplicates.

        function sum_discrete(array, len_)

                external compar
                integer (C_INT) :: compar;

                integer (C_SIZE_T) :: len_;
                integer (C_INT64_t) :: prev, sum_discrete, sum, n;
                integer (C_INT64_t), dimension(:), allocatable, TARGET :: array;

                sum = 0; prev = 0;

                call qsort(c_loc(array(1)), len_, sizeof(len_), c_funloc(compar))

                do n = 1, len_
                        sum = sum + merge(array(n), 0_i64, (array(n) /= prev));
                        prev = array(n);
                end do

                sum_discrete = sum;

        end function

        ! The factors of the number `lim' are tested by iterating up to the
        ! square of that number. All factors that may be squared and remain a
        ! factor are tested for primality. The number of divisors is taken note
        ! of in the iterations so that it may be divided by that number so we
        ! approach the square faster.

        pure function squarefree(lim)

                integer (C_INT64_t), intent(in) :: lim;
                integer (C_INT64_t) :: n, i, ndiv;
                logical :: squarefree;

                n = lim; i = 2;

                squarefree = .TRUE.;

                do while ((i * i) <= n .AND. squarefree)

                        ndiv = intbool(mod(n, i) == 0);
                        ndiv = ndiv + intbool(ndiv > 0 .AND. (mod(n/i, i) == 0));
                        squarefree = .NOT. (ndiv == 2 .AND. isprime(i));
                        n = n / (i ** ndiv);
                        i = i + 1;

                end do

        end function squarefree

        ! This function directly replicates the integer equivalence of booleans
        ! in C. This is solid functionality that it turns out I can't live
        ! without.

        pure function intbool(logical)

                integer (C_INT64_T) :: intbool;
                logical, intent(in) :: logical

                intbool = merge(1, 0, (logical));

        end function intbool

        ! N is the row, k is the index
        pure function binomial_coefficient(n, k)

                integer (C_INT64_t), intent(in) :: n, k
                integer (C_INT64_t) :: i, binomial_coefficient;

                binomial_coefficient = 1;

                do i = 0, k - 1
                        call imult(binomial_coefficient, (n - i));
                        call idiv(binomial_coefficient, (i + 1));
                end do

        end function binomial_coefficient

end program main

! This is the comparison function that is referenced by 'compar'. Fortran
! automatically appends an '_' to the end of the function prototype. Due to the
! C function signature, it must always return an integer.
integer (C_INT) function compar_ (a, b) BIND(C)

        use ISO_C_BINDING
        use ISO_FORTRAN_ENV

        integer (C_INT64_t) :: a, b

        if (a .lt. b) compar_ = -1
        if (a .eq. b) compar_ = 0
        if (a .gt. b) compar_ = 1

end function compar_


chapter xvii, example 2. bivariate spline interpolation
c  from  * a practical guide to splines *  by c. de boor
calls  spli2d(bsplvb,banfac/slv),interv,bvalue(bsplvb*,interv*)
c     parameter nx=7,kx=3,ny=6,ky=4
c     integer i,iflag,j,jj,lefty,mflag,
c     real bcoef(nx,ny),taux(nx),tauy(ny),tx(10),ty(10)
c    *	       ,work1(nx,ny),work2(nx),work3(42)
      integer i,iflag,j,jj,kp1,kx,ky,lefty,mflag,nx,ny
      real bcoef(7,6),taux(7),tauy(6),tx(10),ty(10)
     *	       ,work1(7,6),work2(7),work3(42)
      real bvalue,g,x,y
      data nx,kx,ny,ky /7,3,6,4/
      g(x,y) = amax1(x-3.5,0.)**2 + amax1(y-3.,0.)**3
c *** set up data points and knots
c     in x, interpolate between knots by parabolic splines, using
c     not-a-knot end condition
      do 10 i=1,nx
   10	 taux(i) = float(i)
      do 11 i=1,kx
	 tx(i) = taux(1)
   11	 tx(nx+i) = taux(nx)
      kp1 = kx+1
      do 12 i=kp1,nx
   12	 tx(i) = (taux(i-kx+1) + taux(i-kx+2))/2.
c     in y, interpolate at knots by cubic splines, using not-a-knot
c     end condition
      do 20 i=1,ny
   20	 tauy(i) = float(i)
      do 21 i=1,ky
	 ty(i) = tauy(1)
   21	 ty(ny+i) = tauy(ny)
      kp1 = ky+1
      do 22 i=kp1,ny
   22	 ty(i) = tauy(i-ky+2)
c  *** generate and print out function values
      print 620,(tauy(i),i=1,ny)
  620 format(11h given data//6f12.1)
      do 32 i=1,nx
	 do 31 j=1,ny
   31	    bcoef(i,j) = g(taux(i),tauy(j))
   32	 print 632,taux(i),(bcoef(i,j),j=1,ny)
  632 format(f5.1,6e12.5)
c
c  *** construct b-coefficients of interpolant
c
      call spli2d(taux,bcoef,tx,nx,kx,ny,work2,work3,work1,iflag)
      call spli2d(tauy,work1,ty,ny,ky,nx,work2,work3,bcoef,iflag)
c
c  *** evaluate interpolation error at mesh points and print out
      print 640,(tauy(j),j=1,ny)
  640 format(//20h interpolation error//6f12.1)
      do 45 j=1,ny
	 call interv(ty,ny,tauy(j),lefty,mflag)
	 do 45 i=1,nx
	    do 41 jj=1,ky
   41	       work2(jj)=bvalue(tx,bcoef(1,lefty-ky+jj),nx,kx,taux(i),0)
   45	    work1(i,j) = g(taux(i),tauy(j)) -
     *			bvalue(ty(lefty-ky+1),work2,ky,ky,tauy(j),0)
      do 46 i=1,nx
   46	 print 632,taux(i),(work1(i,j),j=1,ny)
					stop
      end


!Crown Copyright 2012 AWE.
!
! This file is part of CloverLeaf.
!
! CloverLeaf 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.
!
! CloverLeaf 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
! CloverLeaf. If not, see http://www.gnu.org/licenses/.

!>  @brief Fortran ideal gas kernel.
!>  @author Wayne Gaudin
!>  @details Calculates the pressure and sound speed for the mesh chunk using
!>  the ideal gas equation of state, with a fixed gamma of 1.4.

MODULE ideal_gas_kernel_module

CONTAINS

SUBROUTINE ideal_gas_kernel(x_min,x_max,y_min,y_max,z_min,z_max,    &
                            density,                                &
                            energy,                                 &
                            pressure,                               &
                            soundspeed                              )

  IMPLICIT NONE

  INTEGER :: x_min,x_max,y_min,y_max,z_min,z_max
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+2) :: density
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+2) :: energy
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+2) :: pressure
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+2) :: soundspeed

  INTEGER :: j,k,l

  REAL(KIND=8) :: sound_speed_squared,v,pressurebyenergy,pressurebyvolume

!$OMP PARALLEL
!$OMP DO PRIVATE(v,pressurebyenergy,pressurebyvolume,sound_speed_squared)
  DO l=z_min,z_max
    DO k=y_min,y_max
      DO j=x_min,x_max
        v=1.0_8/density(j,k,l)
        pressure(j,k,l)=(1.4_8-1.0_8)*density(j,k,l)*energy(j,k,l)
        pressurebyenergy=(1.4_8-1.0_8)*density(j,k,l)
        pressurebyvolume=-density(j,k,l)*pressure(j,k,l)
        sound_speed_squared=v*v*(pressure(j,k,l)*pressurebyenergy-pressurebyvolume)
        soundspeed(j,k,l)=SQRT(sound_speed_squared)
      ENDDO
    ENDDO
  ENDDO
!$OMP END DO
!$OMP END PARALLEL

END SUBROUTINE ideal_gas_kernel

END MODULE ideal_gas_kernel_module


program example
  use autodiff
  implicit none

  type(dual_number) :: x,y

  x = init_dual(1.0)
  y = f1(x)
  print *,'f1(x)  at x=1:',y%val
  print *,'f1''(x) at x=1:',y%eps

contains

  function f1(a) result(r)
    type(dual_number), intent(in) :: a
    type(dual_number) :: r
    r = 2.0*a - a / (-a + 3.0) + exp(3.0 - 2.0*a) - log(2.0 + 1.0/(2.0 * a))
  end function f1

end program example


c#################################################################
      subroutine flat1(h,ro,vp,vs,h1,ro1,vp1,vs1,n,kind)
c     subroutine applies earth-flattening corrections by
c     scaling the model.for reference see Biswas 1972.
c     kind=1 for Love wave calculations
c     kind=2 for Rayleigh wave calculations
c     h -is thickness
c-input h,ro,vp,vs,n,kind; output h1,ro1,vp1,vs1.
C     TRANSFORMATION
C-----R(i)-radius of i-th boundary (free surfase is ignored)
C-----h(i) by R0*(ln(R0/R(i))-ln(R0/R(i-1));R(0)=R0
C-----vs,vp mult by factor "dif"=R0*(1/R(i+1)-1/R(i))/ln(R(i)/R(i+1))
C-----ro  mult by factor (R(i)**pwr-R(i+1)**pwr)/(ln(R(i)/R(i+1))*pwr*R0**pwr)
C-----for Rayleigh pwr=2.275
C-----for Love     pwr=5.000
      implicit none
      real*8 h(2),ro(2),vp(2),vs(2),hh(1000)
      real*8 h1(2),ro1(2),vp1(2),vs1(2)
c --
      integer*4 i,ii,n,kind,nm
      real*8    dif,a,fact,difr,z0,fltd,ht,hs,pwr,z1
      data a/6371.0d0/
      do i=1,n
      hh(i)=h(i)
      enddo
      pwr=2.2750d0
C     pwr=1.2750
      if(kind.eq.1) pwr=5.0d0
      nm=n-1
      hs=0.0d0
C-----transfer thickness in radius------
      do 5 i=1,n
      ht=hs
      hs=hs+hh(i)
    5 hh(i)=a-ht
C-----now hh(i) are radii  (starting from the first boundary)
c -layers' scaling
      do 10 i=1,nm
      ii=i+1
      fltd=dlog(hh(i)/hh(ii))
      dif=(1.0d0/hh(ii)-1.0d0/hh(i))*a/fltd
      difr=hh(i)**pwr-hh(ii)**pwr
      ro1(i)=ro(i)*difr/(fltd*(a**pwr)*pwr)
      vp1(i)=vp(i)*dif
   10 vs1(i)=vs(i)*dif
c half space scaling
      fact=a/hh(n)
      vp1(n)=vp(n)*fact
      vs1(n)=vs(n)*fact
      ro1(n)=ro(n)*(1.0d0/fact)**pwr
      z0=0.0d0
C-----new thicknesses----------------------------
      do 15 i=2,n
      z1=a*dlog(a/hh(i))
      h1(i-1)=z1-z0
   15 z0=z1
      h1(n)=0.0d0
      return
      end


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program test_exp

! test the exponential distribution random number generator routine
! with different means, standard deviations, and iteration counts.

use      types_mod, only : r8
use  utilities_mod, only : register_module, &
                           open_file, close_file, &
                           initialize_utilities, finalize_utilities, &
                           squeeze_out_blanks
use random_seq_mod, only : random_seq_type, init_random_seq, random_exponential

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type (random_seq_type) :: r
integer :: i, j, n, f
real(r8) :: r1, sum, sumsq, rate
real(r8) :: mean, var, sd, compmean, compvar, compsd, compdiffm, compdiffsd
logical  :: write_this_one
character(len=256) :: fname, temp

character(len=50) :: formf = '(I12,1(F8.3),4(F12.5),2(F16.10),2(F12.5))'
logical :: write_me = .true.       ! if true, write each distribution into a file for later diagnostics
integer :: write_limit = 1000000   ! but only if rep count is not greater than this limit

type t_inputs
 real(r8) :: t_rate
 integer  :: t_nreps
end type

! to add more tests or change the parameters, specify a test count
! and update the sets of inputs here:

integer, parameter :: ntests = 25
type(t_inputs) :: t(ntests) = (/ &
    t_inputs( 1.0_r8,       100), &
    t_inputs( 1.0_r8,     10000), &
    t_inputs( 1.0_r8,   1000000), &
    t_inputs( 1.0_r8, 100000000), &
    t_inputs( 5.0_r8,       100), &
    t_inputs( 5.0_r8,     10000), &
    t_inputs( 5.0_r8,   1000000), &
    t_inputs( 5.0_r8, 100000000), &
    t_inputs( 5.0_r8,   1000000), &
    t_inputs( 0.5_r8,   1000000), &
    t_inputs( 0.8_r8,   1000000), &
    t_inputs( 0.9_r8,   1000000), &
    t_inputs( 8.0_r8,   1000000), &
    t_inputs( 8.2_r8,   1000000), &
    t_inputs( 8.4_r8,   1000000), &
    t_inputs( 8.6_r8,   1000000), &
    t_inputs( 8.8_r8,   1000000), &
    t_inputs( 9.0_r8,   1000000), &
    t_inputs( 1.0_r8,   1000000), &
    t_inputs(18.0_r8,   1000000), &
    t_inputs(99.0_r8,   1000000), &
    t_inputs( 0.1_r8,   1000000), &
    t_inputs( 0.8_r8,   1000000), &
    t_inputs( 0.5_r8,   1000000), &
    t_inputs(33.5_r8,   1000000)  /)

call initialize_utilities('test_exp')
call register_module(source,revision,revdate)

write(*, *) ''
write(*, *) 'sample size   input rate computed mean, sd         actual mean, sd       diff mean         diff sd        % diff mean,  sd'
write(*, *) ''

do j=1, ntests

   call init_random_seq(r, 5)

   rate = t(j)%t_rate
   n = t(j)%t_nreps

   ! save all values in a file for post-plotting?
   write_this_one = (write_me .and. n <= write_limit)

   if (write_this_one) then
      write(temp, "(A,F8.3,A,I10)") "exp_", rate, "_", n
      call squeeze_out_blanks(temp, fname)
      f = open_file(fname)
   endif

   ! analytical values:
   mean = 1.0_r8/rate
   sd = mean

   sum = 0.0_r8
   sumsq = 0.0_r8

   do i = 1, n
      r1 = random_exponential(r, rate)

      if (write_this_one) write(f,*) r1

      sum = sum + r1
      sumsq = sumsq + (r1 - mean)**2
   end do

   if (write_this_one) call close_file(f)

   ! computed values:
   compmean = sum / n
   compsd = sqrt(sumsq/n)

   ! differences
   compdiffm  = compmean - mean
   compdiffsd = compsd - sd

   write(*, formf) n, rate, mean, sd, compmean, compsd, compdiffm, compdiffsd, &
                      abs(compdiffm/mean) * 100._r8, abs(compdiffsd/sd) * 100._r8

enddo

call finalize_utilities()

end program test_exp

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


C bug seen in Transformations/eval.c: modulo evaluatiaon for negative arguments

      program main

      i = mod(3, 2)
      print *, i, "must be 1"

      i = mod(-3, 2)
      print *, i, "must be -1"

      i = mod(3, -2)
      print *, i, "must be 1"

      i = mod(-3, -2)
      print *, i, "must be -1"

      end


      program main
      include 'mpif.h'

      ! Size of vectors
      integer :: n = 100000

      ! Input vectors
      real(8),dimension(:),allocatable :: a
      real(8),dimension(:),allocatable :: b
      ! Output vector
      real(8),dimension(:),allocatable :: c

      integer :: i
      real(8) :: sum

      call MPI_Init(ierr)
      call MPI_Comm_size(MPI_COMM_WORLD, isize, ierr)
      call MPI_Comm_rank(MPI_COMM_WORLD, irank, ierr)

      ! Allocate memory for each vector
      allocate(a(n))
      allocate(b(n))
      allocate(c(n))

      ! Initialize content of input vectors, vector a[i] = sin(i)^2 vector b[i] = cos(i)^2
      do i=1,n
          a(i) = sin(i*1D0)*sin(i*1D0)
          b(i) = cos(i*1D0)*cos(i*1D0)
      enddo

      ! Sum component wise and save result into vector c

      !$acc kernels copyin(a(1:n),b(1:n)), copyout(c(1:n))
      do i=1,n
          c(i) = a(i) + b(i)
      enddo
      !$acc end kernels

      sum = 0d0
      ! Sum up vector c and print result divided by n, this should equal 1 within error
      do i=1,n
          sum = sum +  c(i)
      enddo
      sum = sum/n/isize

      if (irank.eq.0) then
          call MPI_Reduce(MPI_IN_PLACE, sum, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
          print *, 'final result: ', sum
      else
          call MPI_Reduce(sum, sum, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
      end if

      ! Release memory
      deallocate(a)
      deallocate(b)
      deallocate(c)

      call MPI_Finalize(ierr)

      end program


program potential
 implicit none
 integer::i,j,n =108
 real(kind=8)::boxl,sigsq,epslon,sr2,sr6,sr12,rcutoff,v,sig,kb
 real (kind=8) :: rij
 real (kind=8), allocatable :: r(:,:), rijvec(:)

 open(1,file='argon.init')

 allocate (r(n,3), rijvec(3))

 do  i=1,n
   read(1,*)r(i,:)
 end do

 boxl =17.158d0
 sig = 3.405d0
 sigsq = sig * sig
 kb = 1.38E-23
 epslon = 120.0d0 * kb

 rcutoff = 0.50d0 * boxl

 v=0.0d0
 do i=1,n-1
   do j=i+1,n
      rijvec(:) = r(i,:) - r(j,:)
      rijvec(:) = rijvec(:) - (boxl*anint(rijvec(:)/boxl))
      rij = dsqrt(dot_product(rijvec(:),rijvec(:)))
      !write(11,*)rijvec(:)
      !write(12,*)rij

      sr2 = (sigsq/(rij*rij))
      sr6 = sr2 * sr2 * sr2
      sr12 = sr6 * sr6
        if(rij<rcutoff) then
           v = v + sr12 -sr6
        endif

   end do
 end do

 v = 4.0d0*epslon*v
 write(*,*),v

end program potential


      SUBROUTINE QLMNINIT

!PURPOSE: Compute Ql,m,n for spherical harmonics up to L=34 - only does even orders
!     and only even N terms - by R.I. Sheldon & modified by R. Von Dreele for GSAS

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

!INCLUDE STATEMENTS:

      REAL*4        QT
      COMMON /QLMNVAL/QT(2109)

!LOCAL VARIABLES:

      REAL*8        SUM,TEMP,TEMP1
      INTEGER*4     I,LMN,M,MM

!FUNCTION DEFINITIONS:

      REAL*8        FACTLN              !Compute ln-factorial & binominal coeffs.

!DATA STATEMENTS:

!CODE:

      J = 1
      QT(1) = 1.0
      DO L=2,34,2
        DO M=0,L
          DO N=0,M,2
            J = J+1
            LMN = L-M-N
            TEMP = 0.5D0*(FACTLN(L+N)+FACTLN(L+M)+
     1        FACTLN(L-M)+FACTLN(L-N))
            SUM = 0.0D0
            DO I=0,L-N
              IF ( (L-M-I).GE.0 .AND. (M+N+I).GE.0 ) THEN
                TEMP1 = TEMP-FACTLN(I)-FACTLN(L-M-I)-
     1            FACTLN(L-N-I)-FACTLN(M+N+I)
                TEMP1 = DEXP(TEMP1)
                IF ( MOD(I,2).NE.0 ) TEMP1 = -TEMP1
                SUM = SUM+TEMP1
              END IF
            END DO
            QT(J) = SUM/2.**(1.*L)
            IF ( MOD(LMN,2).NE.0 ) QT(J) = -QT(J)
!            PRINT '(A,3I4,F12.8)',' l,m,n,Q(lmn)',L,M,N,QT(J)
          END DO
        END DO
      END DO
      RETURN
      END


*DECK HSTART
      SUBROUTINE HSTART (F, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL,
     +   BIG, SPY, PV, YP, SF, RPAR, IPAR, H)
C***BEGIN PROLOGUE  HSTART
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DEABM, DEBDF and DERKF
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (HSTART-S, DHSTRT-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   HSTART computes a starting step size to be used in solving initial
C   value problems in ordinary differential equations.
C **********************************************************************
C  Abstract
C
C     Subroutine HSTART computes a starting step size to be used by an
C     initial value method in solving ordinary differential equations.
C     It is based on an estimate of the local Lipschitz constant for the
C     differential equation (lower bound on a norm of the Jacobian),
C     a bound on the differential equation (first derivative), and
C     a bound on the partial derivative of the equation with respect to
C     the independent variable.
C     (All approximated near the initial point A.)
C
C     Subroutine HSTART uses a function subprogram HVNRM for computing
C     a vector norm.  The maximum norm is presently utilized though it
C     can easily be replaced by any other vector norm.  It is presumed
C     that any replacement norm routine would be carefully coded to
C     prevent unnecessary underflows or overflows from occurring, and
C     also, would not alter the vector or number of components.
C
C **********************************************************************
C  On Input you must provide the following
C
C      F -- This is a subroutine of the form
C                               F(X,U,UPRIME,RPAR,IPAR)
C             which defines the system of first order differential
C             equations to be solved.  For the given values of X and the
C             vector  U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must
C             evaluate the NEQ components of the system of differential
C             equations  dU/DX=F(X,U)  and store the derivatives in the
C             array UPRIME(*), that is,  UPRIME(I) = * dU(I)/DX *  for
C             equations I=1,...,NEQ.
C
C             Subroutine F must not alter X or U(*).  You must declare
C             the name F in an EXTERNAL statement in your program that
C             calls HSTART.  You must dimension U and UPRIME in F.
C
C             RPAR and IPAR are real and integer parameter arrays which
C             you can use for communication between your program and
C             subroutine F.  They are not used or altered by HSTART.  If
C             you do not need RPAR or IPAR, ignore these parameters by
C             treating them as dummy arguments.  If you do choose to use
C             them, dimension them in your program and in F as arrays
C             of appropriate length.
C
C      NEQ -- This is the number of (first order) differential equations
C             to be integrated.
C
C      A -- This is the initial point of integration.
C
C      B -- This is a value of the independent variable used to define
C             the direction of integration.  A reasonable choice is to
C             set  B  to the first point at which a solution is desired.
C             You can also use  B, if necessary, to restrict the length
C             of the first integration step because the algorithm will
C             not compute a starting step length which is bigger than
C             ABS(B-A), unless  B  has been chosen too close to  A.
C             (It is presumed that HSTART has been called with  B
C             different from  A  on the machine being used.  Also see
C             the discussion about the parameter  SMALL.)
C
C      Y(*) -- This is the vector of initial values of the NEQ solution
C             components at the initial point  A.
C
C      YPRIME(*) -- This is the vector of derivatives of the NEQ
C             solution components at the initial point  A.
C             (defined by the differential equations in subroutine F)
C
C      ETOL -- This is the vector of error tolerances corresponding to
C             the NEQ solution components.  It is assumed that all
C             elements are positive.  Following the first integration
C             step, the tolerances are expected to be used by the
C             integrator in an error test which roughly requires that
C                        ABS(local error) .LE. ETOL
C             for each vector component.
C
C      MORDER -- This is the order of the formula which will be used by
C             the initial value method for taking the first integration
C             step.
C
C      SMALL -- This is a small positive machine dependent constant
C             which is used for protecting against computations with
C             numbers which are too small relative to the precision of
C             floating point arithmetic.  SMALL  should be set to
C             (approximately) the smallest positive real number such
C             that  (1.+SMALL) .GT. 1.  on the machine being used. the
C             quantity  SMALL**(3/8)  is used in computing increments of
C             variables for approximating derivatives by differences.
C             also the algorithm will not compute a starting step length
C             which is smaller than  100*SMALL*ABS(A).
C
C      BIG -- This is a large positive machine dependent constant which
C             is used for preventing machine overflows.  A reasonable
C             choice is to set big to (approximately) the square root of
C             the largest real number which can be held in the machine.
C
C      SPY(*),PV(*),YP(*),SF(*) -- These are real work arrays of length
C             NEQ which provide the routine with needed storage space.
C
C      RPAR,IPAR -- These are parameter arrays, of real and integer
C             type, respectively, which can be used for communication
C             between your program and the F subroutine.  They are not
C             used or altered by HSTART.
C
C **********************************************************************
C  On Output  (after the return from HSTART),
C
C      H -- Is an appropriate starting step size to be attempted by the
C             differential equation method.
C
C           All parameters in the call list remain unchanged except for
C           the working arrays SPY(*),PV(*),YP(*) and SF(*).
C
C **********************************************************************
C
C***SEE ALSO  DEABM, DEBDF, DERKF
C***ROUTINES CALLED  HVNRM
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891024  Changed references from VNORM to HVNRM.  (WRB)
C   891024  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  HSTART
C
      DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*),SF(*),
     1   RPAR(*),IPAR(*)
      EXTERNAL F
C
C.......................................................................
C
C***FIRST EXECUTABLE STATEMENT  HSTART
      DX = B - A
      ABSDX = ABS(DX)
      RELPER = SMALL**0.375
      YNORM = HVNRM(Y,NEQ)
C
C.......................................................................
C
C     COMPUTE A WEIGHTED APPROXIMATE BOUND (DFDXB) ON THE PARTIAL
C     DERIVATIVE OF THE EQUATION WITH RESPECT TO THE
C     INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. ALSO
C     COMPUTE A WEIGHTED BOUND (FBND) ON THE FIRST DERIVATIVE LOCALLY.
C
      DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX),100.*SMALL*ABS(A)),DX)
      IF (DA .EQ. 0.) DA = RELPER*DX
      CALL F(A+DA,Y,SF,RPAR,IPAR)
C
      IF (MORDER .EQ. 1) GO TO 20
      POWER = 2./(MORDER+1)
      DO 10 J=1,NEQ
        WTJ = ETOL(J)**POWER
        SPY(J) = SF(J)/WTJ
        YP(J) = YPRIME(J)/WTJ
   10   PV(J) = SPY(J) - YP(J)
      GO TO 40
C
   20 DO 30 J=1,NEQ
        SPY(J) = SF(J)/ETOL(J)
        YP(J) = YPRIME(J)/ETOL(J)
   30   PV(J) = SPY(J) - YP(J)
C
   40 DELF = HVNRM(PV,NEQ)
      DFDXB = BIG
      IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA)
      YPNORM = HVNRM(YP,NEQ)
      FBND = MAX(HVNRM(SPY,NEQ),YPNORM)
C
C.......................................................................
C
C     COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ CONSTANT FOR
C     THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS ALSO REPRESENTS AN
C     ESTIMATE OF THE NORM OF THE JACOBIAN LOCALLY.
C     THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO ESTIMATE THE
C     LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. THE FIRST
C     PERTURBATION VECTOR IS BASED ON THE INITIAL DERIVATIVES AND
C     DIRECTION OF INTEGRATION. THE SECOND PERTURBATION VECTOR IS
C     FORMED USING ANOTHER EVALUATION OF THE DIFFERENTIAL EQUATION.
C     THE THIRD PERTURBATION VECTOR IS FORMED USING PERTURBATIONS BASED
C     ONLY ON THE INITIAL VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS
C     CHANGED TO NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN
C     INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT COMPONENTS
C     OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE CONSISTENT WITH
C     THE SLOPES OF LOCAL SOLUTION CURVES.
C     ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST DERIVATIVE.
C     NO ATTEMPT IS MADE TO KEEP THE PERTURBATION VECTOR SIZE CONSTANT.
C
      IF (YPNORM .EQ. 0.) GO TO 60
C                       USE INITIAL DERIVATIVES FOR FIRST PERTURBATION
      ICASE = 1
      DO 50 J=1,NEQ
        SPY(J) = YPRIME(J)
   50   YP(J) = YPRIME(J)
      GO TO 80
C                       CANNOT HAVE A NULL PERTURBATION VECTOR
   60 ICASE = 2
      DO 70 J=1,NEQ
        SPY(J) = YPRIME(J)
   70   YP(J) = ETOL(J)
C
   80 DFDUB = 0.
      LK = MIN(NEQ+1,3)
      DO 260 K=1,LK
C                       SET YPNORM AND DELX
        YPNORM = HVNRM(YP,NEQ)
        IF (ICASE .EQ. 1  .OR.  ICASE .EQ. 3) GO TO 90
        DELX = SIGN(1.0,DX)
        GO TO 120
C                       TRY TO ENFORCE MEANINGFUL PERTURBATION VALUES
   90   DELX = DX
        IF (ABS(DELX)*YPNORM .GE. RELPER*YNORM) GO TO 100
        DELXB = BIG
        IF (RELPER*YNORM .LT. BIG*YPNORM) DELXB = RELPER*YNORM/YPNORM
        DELX = SIGN(DELXB,DX)
  100   DO 110 J=1,NEQ
          IF (ABS(DELX*YP(J)) .GT. ETOL(J)) DELX=SIGN(ETOL(J)/YP(J),DX)
  110     CONTINUE
C                       DEFINE PERTURBED VECTOR OF INITIAL VALUES
  120   DO 130 J=1,NEQ
  130     PV(J) = Y(J) + DELX*YP(J)
        IF (K .EQ. 2) GO TO 150
C                       EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED
C                       VECTOR  AND  COMPUTE CORRESPONDING DIFFERENCES
        CALL F(A,PV,YP,RPAR,IPAR)
        DO 140 J=1,NEQ
  140     PV(J) = YP(J) - YPRIME(J)
        GO TO 170
C                       USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE
C                                             IN COMPUTING ONE ESTIMATE
  150   CALL F(A+DA,PV,YP,RPAR,IPAR)
        DO 160 J=1,NEQ
  160     PV(J) = YP(J) - SF(J)
C                       CHOOSE LARGEST BOUND ON THE WEIGHTED FIRST
C                                                   DERIVATIVE
  170   IF (MORDER .EQ. 1) GO TO 190
        DO 180 J=1,NEQ
  180     YP(J) = YP(J)/ETOL(J)**POWER
        GO TO 210
  190   DO 200 J=1,NEQ
  200     YP(J) = YP(J)/ETOL(J)
  210   FBND = MAX(FBND,HVNRM(YP,NEQ))
C                       COMPUTE BOUND ON A LOCAL LIPSCHITZ CONSTANT
        DELF = HVNRM(PV,NEQ)
        IF (DELF .EQ. 0.) GO TO 220
        DELY = ABS(DELX)*YPNORM
        IF (DELF .GE. BIG*DELY) GO TO 270
        DFDUB = MAX(DFDUB,DELF/DELY)
C
  220   IF (K .EQ. LK) GO TO 280
C                       CHOOSE NEXT PERTURBATION VECTOR
        DO 250 J=1,NEQ
          IF (K .EQ. LK-1) GO TO 230
          ICASE = 3
          DY = ABS(PV(J))
          IF (DY .EQ. 0.) DY = MAX(DELF,ETOL(J))
          GO TO 240
  230     ICASE = 4
          DY = MAX(RELPER*ABS(Y(J)),ETOL(J))
  240     IF (SPY(J) .EQ. 0.) SPY(J) = YP(J)
          IF (SPY(J) .NE. 0.) DY = SIGN(DY,SPY(J))
  250     YP(J) = DY
  260   CONTINUE
C
C                       PROTECT AGAINST AN OVERFLOW
  270 DFDUB = BIG
C
C.......................................................................
C
C     COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE
C
  280 YDPB = DFDXB + DFDUB*FBND
C
C.......................................................................
C
C     COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND SECOND
C     DERIVATIVE INFORMATION
C
C                       RESTRICT THE STEP LENGTH TO BE NOT BIGGER THAN
C                       ABS(B-A).   (UNLESS  B  IS TOO CLOSE TO  A)
      H = ABSDX
C
      IF (YDPB .NE. 0.  .OR.  FBND .NE. 0.) GO TO 290
C
C                       BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND
C                                    DERIVATIVE TERM (YDPB) ARE ZERO
      GO TO 310
C
  290 IF (YDPB .NE. 0.) GO TO 300
C
C                       ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO
      IF (1.0 .LT. FBND*ABSDX) H = 1./FBND
      GO TO 310
C
C                       SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO
  300 SRYDPB = SQRT(0.5*YDPB)
      IF (1.0 .LT. SRYDPB*ABSDX) H = 1./SRYDPB
C
C                       FURTHER RESTRICT THE STEP LENGTH TO BE NOT
C                                                 BIGGER THAN  1/DFDUB
  310 IF (H*DFDUB .GT. 1.) H = 1./DFDUB
C
C                       FINALLY, RESTRICT THE STEP LENGTH TO BE NOT
C                       SMALLER THAN  100*SMALL*ABS(A).  HOWEVER, IF
C                       A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO,
C                       THE ALGORITHM RETURNS  SMALL*ABS(B)  FOR THE
C                                                       STEP LENGTH.
      H = MAX(H,100.*SMALL*ABS(A))
      IF (H .EQ. 0.) H = SMALL*ABS(B)
C
C                       NOW SET DIRECTION OF INTEGRATION
      H = SIGN(H,DX)
C
      RETURN
      END


	  PROGRAM MAIN
	  IMPLICIT NONE

	  INTEGER :: i
	  INTEGER, PARAMETER :: num_steps = 100000
	  REAL :: x0, x1, x2, x3, pi, sum
	  REAL :: step

	  sum = 0.0
	  step = 1.0/num_steps

	  DO i = 1, num_steps, 4
	     x0 = (i - 0.5) * step
	     x1 = (i + 0.5) * step
	     x2 = (i + 1.5) * step
	     x3 = (i + 2.5) * step
	     sum = sum + 4.0 * (1.0 / (1.0 + x0 * x0) + 1.0 /(1.0 + x1 * x1)  &
		       & + 1.0 / (1.0 + x2 * x2) + 1.0 /(1.0 + x3 * x3))
	  ENDDO

	  pi = step * sum

          WRITE(*,100) pi, num_steps
100       FORMAT('pi = ', f15.8, ',', i14, ' steps')

          END PROGRAM MAIN


      subroutine zenith(calday, dgr_lat, dgr_lon, delta, zen, coszrs)
c
c Computes solar zenith angle
c
c In
      real calday     ! Calender day
      real deg_lat    ! Latitude [dgr]
      real deg_lon    ! Longitude [dgr]
      real delta      ! Solar declination angle [rad]
c Out
      real zen        ! Zenith angle [dgr]
      real coszrs     ! Cosine of zenith angle
c Local
      real clat       ! Current centered latitude (radians)
      real clon       ! Centered longitude (radians)
      real orb_pi     ! pi, mathematical constant
      parameter( orb_pi = 3.14159265358979323846)
      real orb_jday   ! Julian calender day (1.xx to 365.xx)
      real orb_lat    ! Centered latitude (radians)
      real orb_lon    ! Centered longitude (radians)
      real orb_declin ! Solar declination (radians)
      real orb_cosz   ! Cosine of the solar zenith angle

c Statement function
      orb_cosz( orb_jday, orb_lat, orb_lon, orb_declin ) =
     $   sin(orb_lat)*sin(orb_declin) - cos(orb_lat)*cos(orb_declin)
     $   *cos(orb_jday*2.0*orb_pi + orb_lon)

      deg2rad = orb_pi/180.
      clat = dgr_lat*deg2rad
      clon = dgr_lon*deg2rad

      coszrs = orb_cosz( calday, clat, clon, delta )
      zen = acos(coszrs)/deg2rad

      end


      include 'VICMAIN_FOR'
      subroutine main44
C**** VERSION 3 VICAR-2 PARAMS 20 AUGUST 1984 MEM
C     VERSION 2 VICAR-2 IO     13 AUGUST 1984 MEM
C     VERSION 1 VAX CONVERSION 7 AUGUST 1984 MEM
c      INCLUDE 'fortport'
	implicit none
c      COMMON/C1/DN
	character*8 string
	integer*4 outunit,ind,cnt,nl,ns,sl,ss
	integer*4 ix,iy,ishape,ival,count,def
	integer*4 dnmax,sigmax,sigmay,x0,y0
	integer*4 size(4)
	real*4 af,dxmx,eps,fact,r,r2,tmpf,xarg,yarg,yargs
	byte dn(2048)
C
C**** PARAMETER INITIALIZATION
c      nl=1024				!default
c      ns=1024
      sl=1
      ss=1
      dnmax=255
      sigmax=125
      sigmay=125
      x0=512
      y0=512
C**** VICAR*2 OPENS
      call xvmessage('SPOT version 04-Nov-2010',' ')
c      call xvsize(sl,ss,nl,ns,nli,nsi)
	call xvparm ('SIZE',size,count,def,4)
c	print *, 'def = ',def
	if (size(3).eq.0) then
	    call xvp ('NL',nl,cnt)
            call xvp ('NS',ns,cnt)
	else
	    nl=size(3)
	    ns=size(4)
        end if
c	print *, 'nl = ns = ',nl, ns
      call xvunit(outunit,'OUT',1,ind,' ')
      call xvopen(outunit,ind,'U_NL',nl,'U_NS',ns,'OP','WRITE',' ')
C**** NOW PROCESS THE TAE/PDF
C     TO GET THE PARAMETER VALUES
C     USE DEFAULTS IF "CNT"=0
      call xvp('DNMAX',dnmax,cnt)
      call xvp('SIGMAX',sigmax,cnt)
      if(cnt.eq.0)sigmax=ns/8
      call xvp('SIGMAY',sigmay,cnt)
      if(cnt.eq.0)sigmay=nl/8
      call xvp('X0',x0,cnt)
      if(cnt.eq.0)x0=ns/2
      call xvp('Y0',y0,cnt)
      if(cnt.eq.0)y0=nl/2

c
c     bam 7/98 AR-9267
c
c     make sure we don't have a divide by 0
c
      if (dnmax .ne. 0 ) then
          dxmx=255/dnmax
      else
          dxmx = 0
      end if

	eps=1.E-5
	ishape = 1			!default is GAUSSIAN
	call xvp('SHAPE',string,cnt)
	if(string.eq.'GAUSSIAN') ishape=1
	if(string.eq.'CONICAL') ishape=2
	if(string.eq.'RECPROCL') ishape=3
	if(string.eq.'RECPSQRE') ishape=4
	if(string.eq.'EXPONENT') ishape=5
	if(string.eq.'DOME') ishape=6
	if(string.eq.'DISK') ishape=7

C**** COMPUTE RADIAL DISTANCE

      do 100 iy=1,nl
c
c     bam 7/98 AR-9267
c
c     make sure we don't have a divide by 0
c     for both sigmay and sigmax
c
      if (sigmay .ne. 0 ) then
          yarg=(iy-y0)*1./(sigmay*1.)
      else
          yarg = 0
      end if

      yargs=yarg**2

      do 99 ix=1,ns
          if (sigmax .ne. 0 ) then
              xarg=(ix-x0)*1./(sigmax*1.)
          else
              xarg = 0
          end if

      r2=xarg**2+yargs

      r=sqrt(r2)
	tmpf = 0
C**** BRANCH TO SHAPE
               GO TO (51,52,53,54,55,56,57),ISHAPE
C     GAUSSIAN SPOT
   51 if (r2.ge.100.) r2=100.
      fact=exp((-0.5)*(r2))
      go to 60
C     CONICAL SPOT
   52 fact=1. - r
      if (fact.lt.0.) fact=0.
      go to 60
C     RECIPROCAL SPOT
   53 if (r.gt.eps) tmpf=1./r
      if ((r.eq.0.).or.(tmpf.ge.dxmx)) tmpf=dxmx
      fact=tmpf
      go to 60
C     RECIPROCAL SQUARED SPOT
   54 if (r2.gt.eps) tmpf=1./r2
      if ((r2.eq.0.).or.(tmpf.gt.dxmx)) tmpf=dxmx
      fact=tmpf
      go to 60
C     EXPONENTIAL SPOT
   55 if (r.ge.100.) r=100.
      fact=exp((-1.)*(r))
      go to 60
C     DOME SPOT
   56 af=1. - r2
      if (af.le.0.) af=0.
      fact=sqrt(af)
	go to 60
C	UNIFORM DISK
   57 af=1. - r
	if (af.le.0) af=0.
	if (af.gt.0) af=1.
	fact=af
C**** CALCULATE OUTPUT VALUE AT SAMPLE LOCATION OF EACH PIXEL
   60 ival = dnmax*fact
c      dn(ix)=int2byte(ival)
	dn(ix) = ival
   99 continue
      call xvwrit(outunit,dn,ind,' ')
  100 continue
	if(ishape.eq.1)call xvmessage('****GAUSSIAN PATTERN GENERATED ',' ')
	if(ishape.eq.2)call xvmessage('****CONICAL PATTERN GENERATED ',' ')
	if(ishape.eq.3)call xvmessage('****RECIPROCAL PATTERN GENERATED ',' ')
	if(ishape.eq.4)call xvmessage('****RECP SQUARED PATTERN GENERATED',' ')
	if(ishape.eq.5)call xvmessage('****EXPONENTIAL PATTERN GENERATED',' ')
	if(ishape.eq.6)call xvmessage('****DOME PATTERN GENERATED ',' ')
	if(ishape.eq.7)call xvmessage('****UNIFORM DISK PATTERN GENERATED ',' ')
      call xvclose(outunit,ind,' ')
      return
      end


SUBROUTINE zinv(N,A)
    IMPLICIT NONE
    INTEGER N
    COMPLEX*16 A(N,N), WORK(2*N)
    INTEGER INFO, IPIV(N), LWORK
    !f2py intent(inout) :: A
    !f2py intent(in) :: N
    IF(N<=0)STOP 'INVALID DIM @ ZINVERT'
    IF(N==1)THEN; A=1/A; RETURN; END IF
    CALL ZGETRF(N, N, A, N, IPIV, INFO)
    IF(INFO/=0)PRINT*, 'LU@INVERSE DETECTED A SINGULARITY'
    LWORK=2*N
    CALL ZGETRI(N, A, N, IPIV, WORK, LWORK, INFO)
    IF(INFO/=0)STOP 'ZINVERT FAILED'
    RETURN
END SUBROUTINE zinv

!``` Python Code
!GL=array([sum([sum([dot(Ti.T.conj(),dot(H2G(Ei,w=w,geta=smearing*1./nz*max(1e-3,abs(w))),Ti))\
!        for Ei,Ti in zip(Elist[:,i],Tlist[:,i])],axis=0) for i in xrange(nz)],axis=0)/nz for w in wlist])
!AL=1j*(GL-transpose(GL,axes=(0,2,1)).conj())/(pi*2.)
subroutine hybri_sun(tlist,elist,wlist,hybri,smearing,nsite,nz,nband,nw)
    implicit none
    integer,intent(in) :: nsite,nw,nz,nband
    complex*16,intent(in) :: tlist(nsite,nz,nband,nband),elist(nsite,nz,nband,nband)
    real*8,intent(in) :: wlist(nw),smearing
    complex*16,intent(out) :: hybri(nw,nband,nband)
    complex*16 :: ti(nband,nband),gi(nband,nband),sigma(nband,nband)
    integer :: isite,iz,iw,iband
    real*8 :: identity(nband,nband),wi
    real*8,parameter :: pi=2*asin(1D0)
    complex*16,parameter :: one=dcmplx(0D0,1D0)

    !initialize identity matrix
    identity=0D0
    do iband=1,nband
        identity(iband,iband)=1D0
    enddo

    do iw=1,nw
        wi=wlist(iw)
        sigma=0
        do iz=1,nz
            do isite=1,nsite
                ti=tlist(isite,iz,:,:)
                gi=dcmplx(wi,smearing*max(1D-4,abs(wi)))*identity-elist(isite,iz,:,:)
                call zinv(nband,gi)
                sigma=sigma+matmul(matmul(transpose(conjg(ti)),gi),ti)
            enddo
        enddo
        hybri(iw,:,:)=one*(sigma-transpose(conjg(sigma)))/2/pi
    enddo
    hybri=hybri/nz
end subroutine hybri_sun

!``` Python Code
!dlv=[]
!for iz in xrange(nz):
!    print 'Recovering spectrum for %s-th z number.'%iz
!    chain=chains[iz]
!    el=chain.elist
!    tl=concatenate([chain.t0[newaxis,...],chain.tlist],axis=0)
!    dl=[]
!    for w in wlist:
!        sigma=0
!        for e,t in zip(el[::-1],tl[::-1]):
!            geta=abs(w)+1e-10
!            g0=H2G(w=w,h=e+sigma,geta=smearing*geta/nz)
!            tH=transpose(conj(t))
!            sigma=dot(tH,dot(g0,t))
!        dl.append(1j*(sigma-sigma.T.conj())/2./pi)
!    dlv.append(dl)
!dlv=mean(dlv,axis=0)
subroutine hybri_chain(tlist,elist,wlist,hybri,smearing,nsite,nz,nband,nw)
    implicit none
    integer,intent(in) :: nsite,nw,nz,nband
    complex*16,intent(in) :: tlist(nz,nsite,nband,nband),elist(nz,nsite,nband,nband)
    real*8,intent(in) :: wlist(nw),smearing
    complex*16,intent(out) :: hybri(nw,nband,nband)
    complex*16 :: ti(nband,nband),gi(nband,nband),sigma(nband,nband)
    integer :: isite,iz,iw,iband
    real*8 :: identity(nband,nband),wi
    real*8,parameter :: pi=2*asin(1D0)
    complex*16,parameter :: one=dcmplx(0D0,1D0)

    !initialize identity matrix
    identity=0D0
    do iband=1,nband
        identity(iband,iband)=1D0
    enddo
    hybri=0

    do iw=1,nw
        wi=wlist(iw)
        do iz=1,nz
            sigma=0
            do isite=nsite,1,-1
                ti=tlist(iz,isite,:,:)
                gi=dcmplx(wi,maxval(abs(ti))*smearing)*identity-elist(iz,isite,:,:)-sigma
                !gi=dcmplx(wi,smearing*max(1D-4,abs(wi)))*identity-elist(iz,isite,:,:)-sigma
                call zinv(nband,gi)
                sigma=matmul(matmul(transpose(conjg(ti)),gi),ti)
            enddo
            hybri(iw,:,:)=hybri(iw,:,:)+one*(sigma-conjg(transpose(sigma)))/2/pi
        enddo
    enddo
    hybri=hybri/nz
end subroutine hybri_chain


! mathmodule.f90 - useful math functions for astrolib
module mathmodule

    implicit none

    contains

    ! Two-norm that works with complex numbers
    function astnorm(x)

        use kindmodule

        ! DECLARATION
        implicit none

        complex(wp),dimension(:),intent(in) :: x
        complex(wp) :: astnorm

        ! EXECUTION
        astnorm = sqrt(dot_product(x,x))

    end function astnorm

end module mathmodule


! solve b=Ax using parallel log-ent mart.
! Matlab by Joshua Semeter
! Fortran by Michael Hirsch

program test_logmart
use iso_fortran_env, only: wp=>real64
implicit none

integer, parameter :: N=3
real(wp) :: A(N,N)
real(wp), parameter :: x_true(N)=[5,5,5]
real(wp),parameter :: pi = 4.*atan(1.), errtol=0.05_wp
real(wp), dimension(N) :: x, noise, b,bias

call init_random_seed()

A = reshape([1,0,0,0,1,0,0,0,1],[N,N])

! ---- noisy observation
call randn(bias)
print*,'bias',bias
A = A! * spread(bias,2,N)

call randn(noise)
print*,'noise',noise
b = matmul(A,x_true) + 0.1_wp*noise

! ---- inversion
call logmart(A,b,x=x)

! --- check estimate
if (all(abs(x-x_true) < errtol*maxval(x_true))) then
  print*,'logmart SUCCESS'
else
  print*,x
  print*,'larger than',errtol*100,' % error'
  stop
endif

contains

pure subroutine logmart(A,b,relax,x0,sigma,max_iter,x)
! delta Chisquare.
! stopped if Chisquare increases.
!
! Inputs
! ------
! A: NxM array
! b: N vector
! relax: user specified relaxation constant	(default is 20.)
! x0: user specified initial guess (Nx1 vector)  (default is backproject y, i.e., y#A)
! max_iter: user specified max number of iterations (default is 20)
!
!
! Outputs
! -------
! x: N vector
!
!
!    AUTHOR:	Joshua Semeter
!    LAST MODIFIED:	5-2015
!
!      Simple test problem
!    A = diag([5, 5, 5])
!    x = [1,2,3]
!    b = A*x

use iso_fortran_env, only: wp=>real64

! --- parameter check
real(wp), intent(in) :: A(:,:), b(:)
real(wp), optional, value :: relax
real(wp), intent(in),optional :: x0(:), sigma(:)
integer, optional, value :: max_iter
real(wp), intent(out) :: x(:)

real(wp), dimension(size(b)) :: xA, op_sigma, W, op_b, arg,xold,c
integer :: i
logical :: done
real(wp) :: t,chi2,chiold

op_b = b

if (.not.size(A,1) == size(b)) error stop 'A and b row numbers must match'

! --- set defaults
if (.not.present(relax)) relax = 1._wp
if (.not.present(max_iter)) max_iter = 200

if (.not.present(x0)) then
  x  = matmul(transpose(A), b) / sum(A)
  xA = matmul(A, x)
  x  = x * maxval(b) / maxval(xA)
else
  x = x0
endif

if (.not.present(sigma)) then
  op_sigma = 1._wp
else
  op_sigma = sigma
endif

! --- make sure there are no 0's in b
where(op_b<=1e-8) op_b = 1e-8_wp

! W=sigma;
! W=linspace(1,0,size(A,1))';
! W=rand(size(A,1),1);
W = 1
W = W / sum(W)

! --- iterate solution
i=0
done=.false.
arg= ((matmul(A,x) - op_b) / op_sigma)**2
chi2 = sqrt(sum(arg))

do while (.not.done)
  i = i+1
  xold = x
  xA = matmul(A,x)
  t = minval(1/xA)
  C = relax*t*(1-(xA/b))
  x = x / (1-x*matmul(transpose(A),W*C))
! monitor solution
  chiold = chi2
  chi2 = sqrt( sum(((xA - b)/op_sigma)**2) )
  ! dchi2=(chi2-chiold)
  done = ((chi2>chiold) .and. (i>2)) .or. (i==max_iter) .or. (chi2<0.7)
enddo

x = xold

end subroutine logmart

subroutine randn(noise)
! implements Box-Muller Transform
! https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform
!
! Output:
! noise: Gaussian noise vector

real(wp),intent(out) :: noise(:)
real(wp),dimension(size(noise)) :: u1, u2

call random_number(u1)
call random_number(u2)

noise = sqrt(-2._wp * log(u1)) * cos(2._wp * pi * u2)

end subroutine randn

subroutine init_random_seed()
! don't call this function repeatedly in your program.
! The time resolution of int32 clock isn't so high, and the seed only
! accepts int32, despite nice clock performance with int64
integer :: n,i, clock
integer, allocatable :: seed(:)

call random_seed(size=n)
allocate(seed(n))
call system_clock(count=clock)
seed = clock + 37 * [ (i - 1, i = 1, n) ]
call random_seed(put=seed)

end subroutine

end program


module slope_module

  implicit none

  double precision, parameter:: four3rd=4.d0/3.d0, sixth=1.d0/6.d0

  private

  public :: slopex, slopey

contains

  subroutine slopex(lo, hi, &
                    q, qlo, qhi, &
                    dq, dqlo, dqhi)

    implicit none

    integer, intent(in) :: lo(2), hi(2), qlo(2), qhi(2), dqlo(2), dqhi(2)
    double precision, intent(in ) ::  q( qlo(1): qhi(1), qlo(2): qhi(2))
    double precision, intent(out) :: dq(dqlo(1):dqhi(1),dqlo(2):dqhi(2))

    integer :: i, j
    double precision, dimension(lo(1)-1:hi(1)+1) :: dsgn, dlim, df, dcen
    double precision :: dlft, drgt, dq1

    do j = lo(2), hi(2)

       ! first compute Fromm slopes
       do i = lo(1)-1, hi(1)+1
          dlft = q(i  ,j) - q(i-1,j)
          drgt = q(i+1,j) - q(i  ,j)
          dcen(i) = .5d0 * (dlft+drgt)
          dsgn(i) = sign(1.d0, dcen(i))
          if (dlft*drgt .ge. 0.d0) then
             dlim(i) = 2.d0 * min( abs(dlft), abs(drgt) )
          else
             dlim(i) = 0.d0
          endif
          df(i) = dsgn(i)*min( dlim(i), abs(dcen(i)) )
       end do

       ! Now limited fourth order slopes
       do i = lo(1), hi(1)
          dq1 = four3rd*dcen(i) - sixth*(df(i+1) + df(i-1))
          dq(i,j) = dsgn(i)*min(dlim(i),abs(dq1))
       end do
    enddo

  end subroutine slopex

  subroutine slopey(lo, hi, &
                    q, qlo, qhi, &
                    dq, dqlo, dqhi)

    use amrex_mempool_module, only : bl_allocate, bl_deallocate

    integer, intent(in) :: lo(2), hi(2), qlo(2), qhi(2), dqlo(2), dqhi(2)
    double precision, intent(in ) ::  q( qlo(1): qhi(1), qlo(2): qhi(2))
    double precision, intent(out) :: dq(dqlo(1):dqhi(1),dqlo(2):dqhi(2))

    ! Some compiler may not support 'contiguous'.  Remove it in that case.
    double precision, dimension(:,:), pointer, contiguous :: dsgn, dlim, df, dcen

    call bl_allocate(dsgn, lo(1), hi(1), lo(2)-1, hi(2)+1)
    call bl_allocate(dlim, lo(1), hi(1), lo(2)-1, hi(2)+1)
    call bl_allocate(df  , lo(1), hi(1), lo(2)-1, hi(2)+1)
    call bl_allocate(dcen, lo(1), hi(1), lo(2)-1, hi(2)+1)

    call slopey_doit(lo, hi, &
                     q, qlo, qhi, &
                     dq, dqlo, dqhi, &
                     dsgn, dlim, df, dcen, (/lo(1),lo(2)-1/), (/hi(1),hi(2)+1/))

    call bl_deallocate(dsgn)
    call bl_deallocate(dlim)
    call bl_deallocate(df)
    call bl_deallocate(dcen)

  end subroutine slopey

  subroutine slopey_doit(lo, hi, &
                         q, qlo, qhi, &
                         dq, dqlo, dqhi, &
                         dsgn, dlim, df, dcen, ddlo, ddhi)

    integer, intent(in) :: lo(2), hi(2), qlo(2), qhi(2), dqlo(2), dqhi(2), &
         ddlo(2), ddhi(2)
    double precision, intent(in ) ::  q  ( qlo(1): qhi(1), qlo(2): qhi(2))
    double precision, intent(out) :: dq  (dqlo(1):dqhi(1),dqlo(2):dqhi(2))
    double precision              :: dsgn(ddlo(1):ddhi(1),ddlo(2):ddhi(2))
    double precision              :: dlim(ddlo(1):ddhi(1),ddlo(2):ddhi(2))
    double precision              :: df  (ddlo(1):ddhi(1),ddlo(2):ddhi(2))
    double precision              :: dcen(ddlo(1):ddhi(1),ddlo(2):ddhi(2))

    integer :: i, j
    double precision :: dlft, drgt, dq1

    ! first compute Fromm slopes
    do j    = lo(2)-1, hi(2)+1
       do i = lo(1)  , hi(1)
          dlft = q(i,j  ) - q(i,j-1)
          drgt = q(i,j+1) - q(i,j  )
          dcen(i,j) = .5d0 * (dlft+drgt)
          dsgn(i,j) = sign( 1.d0, dcen(i,j) )
          if (dlft*drgt .ge. 0.d0) then
             dlim(i,j) = 2.d0 * min( abs(dlft), abs(drgt) )
          else
             dlim(i,j) = 0.d0
          endif
          df(i,j) = dsgn(i,j)*min( dlim(i,j),abs(dcen(i,j)) )
       end do
    end do

    ! Now compute limited fourth order slopes
    do j    = lo(2), hi(2)
       do i = lo(1), hi(1)
          dq1 = four3rd*dcen(i,j) - sixth*( df(i,j+1) + df(i,j-1) )
          dq(i,j) = dsgn(i,j)*min(dlim(i,j),abs(dq1))
       end do
    end do

  end subroutine slopey_doit

end module slope_module


      PROGRAM MAIN
      IMPLICIT NONE

      INTEGER DAY
      DOUBLE PRECISION RAIN, YIELD_EST, TOTAL_RAIN, NEWS
      DOUBLE PRECISION MAX_RAIN, CONSISTENCY, ABSORBTION

      MAX_RAIN = 4.0
      CONSISTENCY = 64.0
      ABSORBTION = 0.6

      YIELD_EST = 0
      TOTAL_RAIN = 0

      DAY = 1
      DO WHILE (DAY <= 31)
        PRINT *, "(", DAY, CONSISTENCY, MAX_RAIN, ABSORBTION, ")"
*       Compute rainfall for the current day
        RAIN = (-(DAY - 16) ** 2 / CONSISTENCY + MAX_RAIN) * ABSORBTION
        PRINT *, RAIN

*       Update rainfall estimate
        YIELD_EST = UPDATE_EST(RAIN, TOTAL_RAIN, YIELD_EST)
        NEWS = TEST_FUNC(TOTAL_RAIN, YIELD_EST)

        PRINT *, "Day ", DAY, " Estimate: ", YIELD_EST
        DAY = DAY + 1
      ENDDO

            PRINT *, "Crop Yield(%): ", YIELD_EST
      PRINT *, "News: ", NEWS

      CONTAINS
       DOUBLE PRECISION FUNCTION UPDATE_EST(RAIN, TOTAL_RAIN, YIELD_EST)
          IMPLICIT NONE
          DOUBLE PRECISION RAIN, YIELD_EST, TOTAL_RAIN
          TOTAL_RAIN = TOTAL_RAIN + RAIN

*         Yield increases up to a point
          IF(TOTAL_RAIN .le. 40) THEN
            YIELD_EST = -(TOTAL_RAIN - 40) ** 2 / 16 + 100

*         Then sharply declines
          ELSE
              YIELD_EST = -TOTAL_RAIN + 140
          ENDIF
          UPDATE_EST = YIELD_EST

        END FUNCTION UPDATE_EST

       DOUBLE PRECISION FUNCTION TEST_FUNC(TOTAL_RAIN, YIELD_EST)
          IMPLICIT NONE
          DOUBLE PRECISION TOTAL_RAIN, YIELD_EST, NEW_VAR
          NEW_VAR = 5.0
          IF (NEW_VAR .le. 4.0) THEN
            TEST_FUNC = 17.0
          ELSE
            TEST_FUNC = YIELD_EST
          ENDIF

       END FUNCTION TEST_FUNC

      END PROGRAM MAIN


      PROGRAM xorthog
C     driver for routine orthog
      INTEGER NP
      PARAMETER(NP=64)
      INTEGER i,n
      REAL func,amu0,check,xx,a(NP),b(NP),x(NP),w(NP),anu(2*NP),
     *     alpha(2*NP-1),beta(2*NP-1)
1     write(*,*) 'Enter N'
      read(*,*,END=99) n
      alpha(1)=.5
      beta(1)=1.
      do 11 i=2,2*n-1
        alpha(i)=0.5
        beta(i)=1./(4.*(4.-1./(i-1)**2))
11    continue
      anu(1)=1.
      anu(2)=-.25
      do 12 i=2,2*n-1
        anu(i+1)=-anu(i)*i*(i-1)/(2.*(i+1)*(2*i-1))
12    continue
      call orthog(n,anu,alpha,beta,a,b)
      amu0=1.
      call gaucof(n,a,b,amu0,x,w)
      write(*,'(/1x,t3,a,t10,a,t22,a/)') '#','X(I)','W(I)'
      do 13 i=1,n
        write(*,'(1x,i2,2e14.6)') i,x(i),w(i)
13    continue
      check=0.
      do 14 i=1,n
        check=check+w(i)
14    continue
      write(*,'(/1x,a,e15.7,a,e15.7)') 'Check value:',check,
     *  '  should be:',amu0
C     demonstrate the use of ORTHOG for an integral
      xx=0.0
      do 15 i=1,n
        xx=xx+w(i)*func(x(i))
15    continue
      write(*,'(/1x,a,f12.6)') 'Integral from ORTHOG:',xx
      write(*,'(1x,a,f12.6)') 'Actual value:        ',log(2.)
      go to 1
99    stop
      END
      REAL FUNCTION func(x)
      REAL x
      func=1./(1.+x)**2
      END

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


SUBROUTINE gasdev_s(harvest)

  USE nrtype
  USE nr, ONLY : ran1

  IMPLICIT NONE
  REAL(SP), INTENT(OUT) :: harvest
  REAL(SP) :: rsq,v1,v2
  REAL(SP), SAVE :: g
  LOGICAL, SAVE :: gaus_stored=.false.

  if (gaus_stored) then
    harvest=g
    gaus_stored=.false.
  else
    do
      call ran1(v1)
      call ran1(v2)
      v1=2.0_sp*v1-1.0_sp
      v2=2.0_sp*v2-1.0_sp
      rsq=v1**2+v2**2
      if (rsq > 0.0 .and. rsq < 1.0) exit
    end do
    rsq=sqrt(-2.0_sp*log(rsq)/rsq)
    harvest=v1*rsq
    g=v2*rsq
    gaus_stored=.true.
  end if
END SUBROUTINE gasdev_s

SUBROUTINE gasdev_v(harvest)

  USE nrtype; USE nrutil, ONLY : array_copy
  USE nr, ONLY : ran1

  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
  REAL(SP), DIMENSION(size(harvest)) :: rsq,v1,v2
  REAL(SP), ALLOCATABLE, DIMENSION(:), SAVE :: g
  INTEGER(I4B) :: n,ng,nn,m
  INTEGER(I4B), SAVE :: last_allocated=0
  LOGICAL, SAVE :: gaus_stored=.false.

  LOGICAL, DIMENSION(size(harvest)) :: mask
  n=size(harvest)
  if (n /= last_allocated) then
    if (last_allocated /= 0) deallocate(g)
    allocate(g(n))
    last_allocated=n
    gaus_stored=.false.
  end if
  if (gaus_stored) then
    harvest=g
    gaus_stored=.false.
  else
    ng=1
    do
      if (ng > n) exit
      call ran1(v1(ng:n))
      call ran1(v2(ng:n))
      v1(ng:n)=2.0_sp*v1(ng:n)-1.0_sp
      v2(ng:n)=2.0_sp*v2(ng:n)-1.0_sp
      rsq(ng:n)=v1(ng:n)**2+v2(ng:n)**2
      mask(ng:n)=(rsq(ng:n)>0.0 .and. rsq(ng:n)<1.0)
      call array_copy(pack(v1(ng:n),mask(ng:n)),v1(ng:),nn,m)
      v2(ng:ng+nn-1)=pack(v2(ng:n),mask(ng:n))
      rsq(ng:ng+nn-1)=pack(rsq(ng:n),mask(ng:n))
      ng=ng+nn
    end do
    rsq=sqrt(-2.0_sp*log(rsq)/rsq)
    harvest=v1*rsq
    g=v2*rsq
    gaus_stored=.true.
  end if
END SUBROUTINE gasdev_v


      subroutine clawpack46_rpn2(ixy,maxm,meqn,mwaves,mbc,mx,
     &      ql,qr,auxl,auxr,wave,s,amdq,apdq)
c     =====================================================
c
c     # Riemann solver for Burgers' equation in 2d:
c     #  u_t + 0.5*(u^2)_x + 0.5*(u^2)_y = 0
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c
c     # This data is along a slice in the x-direction if ixy=1
c     #                            or the y-direction if ixy=2.
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #            amdq the  left-going flux difference  A^- \Delta q
c     #            apdq the right-going flux difference  A^+ \Delta q
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routines, this routine is called with ql = qr
c
c
      implicit double precision (a-h,o-z)
c
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      dimension   ql(1-mbc:maxm+mbc, meqn)
      dimension   qr(1-mbc:maxm+mbc, meqn)
      dimension  apdq(1-mbc:maxm+mbc, meqn)
      dimension  amdq(1-mbc:maxm+mbc, meqn)
      logical efix
c
c
c     # x- and y- Riemann problems are identical, so it doesn't matter if
c     # ixy=1 or 2.
c
      efix = .true.
c
      do 10 i = 2-mbc, mx+mbc
c        # wave is jump in q, speed comes from R-H condition:
         wave(i,1,1) = ql(i,1) - qr(i-1,1)
         s(i,1) = 0.5d0*(qr(i-1,1) + ql(i,1))
c
c        # compute left-going and right-going flux differences:
c        ------------------------------------------------------
c
         amdq(i,1) = dmin1(s(i,1), 0.d0) * wave(i,1,1)
         apdq(i,1) = dmax1(s(i,1), 0.d0) * wave(i,1,1)
c
         if (efix) then
c           # entropy fix for transonic rarefactions:
            if (qr(i-1,1).lt.0.d0 .and. ql(i,1).gt.0.d0) then
               amdq(i,1) = - 0.5d0 * qr(i-1,1)**2
               apdq(i,1) =   0.5d0 * ql(i,1)**2
               endif
            endif
   10   continue
c
      return
      end


PROGRAM mlpni

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!     ========================================================
!     Purpose: This program computes the Legendre polynomials
!     Pn(x), Pn'(x) and the integral of Pn(t) from 0
!     to x using subroutine LPNI
!     Input :  x --- Argument of Pn(x)
!     n --- Degree of Pn(x) ( n = 0,1,... )
!     Output:  PN(n) --- Pn(x)
!     PD(n) --- Pn'(x)
!     PL(n) --- Integral of Pn(t) from 0 to x
!     Example: x = 0.50
!     n       Pn(x)         Pn'(x)        Pn(t)dt
!     ---------------------------------------------
!     0    1.00000000     .00000000     .50000000
!     1     .50000000    1.00000000     .12500000
!     2    -.12500000    1.50000000    -.18750000
!     3    -.43750000     .37500000    -.14843750
!     4    -.28906250   -1.56250000     .05859375
!     5     .08984375   -2.22656250     .11816406
!     ========================================================

DOUBLE PRECISION :: pn,pd,pl,x
DIMENSION pn(0:100),pd(0:100),pl(0:100)
WRITE(*,*)'  Please enter Nmax and x'
!     READ(*,*)N,X
n=5
x=.5
WRITE(*,30)x
WRITE(*,*)
WRITE(*,*)'  n        Pn(x)          Pn''(X)         PN(T)DT'
WRITE(*,*)' ---------------------------------------------------'
CALL lpni(n,x,pn,pd,pl)
DO  k=0,n
  WRITE(*,20)k,pn(k),pd(k),pl(k)
END DO
20   FORMAT(1X,i3,3E16.8)
30   FORMAT(3X,'x =',f5.2)
END PROGRAM mlpni

SUBROUTINE lpni(n,x,pn,pd,pl)

!     =====================================================
!     Purpose: Compute Legendre polynomials Pn(x), Pn'(x)
!     and the integral of Pn(t) from 0 to x
!     Input :  x --- Argument of Pn(x)
!     n --- Degree of Pn(x) ( n = 0,1,... )
!     Output:  PN(n) --- Pn(x)
!     PD(n) --- Pn'(x)
!     PL(n) --- Integral of Pn(t) from 0 to x
!     =====================================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: pn(0:n)
DOUBLE PRECISION, INTENT(OUT)            :: pd(0:n)
DOUBLE PRECISION, INTENT(OUT)            :: pl(0:n)
IMPLICIT DOUBLE PRECISION (p,r,x)

pn(0)=1.0D0
pn(1)=x
pd(0)=0.0D0
pd(1)=1.0D0
pl(0)=x
pl(1)=0.5D0*x*x
p0=1.0D0
p1=x
DO  k=2,n
  pf=(2.0D0*k-1.0D0)/k*x*p1-(k-1.0D0)/k*p0
  pn(k)=pf
  IF (DABS(x) == 1.0D0) THEN
    pd(k)=0.5D0*x**(k+1)*k*(k+1.0D0)
  ELSE
    pd(k)=k*(p1-x*pf)/(1.0D0-x*x)
  END IF
  pl(k)=(x*pn(k)-pn(k-1))/(k+1.0D0)
  p0=p1
  p1=pf
  IF (.NOT.(k == 2*INT(k/2))) THEN
    r=1.0D0/(k+1.0D0)
    n1=(k-1)/2
    DO  j=1,n1
      r=(0.5D0/j-1.0D0)*r
    END DO
    pl(k)=pl(k)+r
  END IF
END DO
RETURN
END SUBROUTINE lpni


! { dg-do compile }
!
! PR fortran/48821
!
! Contributed by Daniel Carrera
!

contains
     pure subroutine rk4_vec(t, Y, dY, h)
         real, intent(inout) :: t, Y(:)
         real, intent(in) :: h
         real, dimension(size(Y)) :: k1, k2, k3, k4

         interface
             pure function dY(t0, y0)
                 import :: Y
                 real, intent(in) :: t0, y0(size(Y))
                 real :: dY(size(y0))
             end function
         end interface

         k1 = dY(t, Y)
         k2 = dY(t + h/2, Y + k1*h/2)
         k3 = dY(t + h/2, Y + k2*h/2)
         k4 = dY(t + h  , Y + k3*h)

         Y = Y + (k1 + 2*k2 + 2*k3 + k4) * h/6
         t = t + h
     end subroutine
end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                  mnpogr : pogrid test program                      cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  ..local scalars..
      real cv,del,ermax,er0,exz0,fp,pi,r,sum,sv,x,y,z0,one,ai,s
      integer i,ier,is,j,k,kwrk,lwrk,m,mu,mv,nc,nuest,nu,nvest,nv
c  ..local arrays..
      integer ider(2),iopt(3),iwrk(100),iw(29)
      real u(9),v(20),z(180),c(300),tu(50),tv(50),f(180),wk(116),
     * exact(180),err(9),sp(9),wrk(1600)
c  ..function references..
      real abs,atan2,cos,sin,tespog
c  ..
c  set constants
      one = 1
      pi = atan2(0.,-one)
c we set up the radius of the disc
      r = one
c we set up the number of u (radius)-values of the grid.
      mu = 9
c we set up the u-coordinates of the grid.
      do 10 i=1,mu
         ai = i
         u(i) = ai*0.1
  10  continue
c we set up the number of v (angle)-values of the grid
      mv = 20
c we set up the v-coordinates of the grid.
      del = pi*0.1
      do 20 j=1,mv
         ai = j-1
         v(j) = ai*del-pi
  20  continue
c we fetch the data values at the grid points.
      m = mu*mv
      read(5,900) (z(i),i=1,m)
c we fetch the data value at the origin.
      read(5,900) z0
c we print the data values at the grid points. we also compute and print
c the exact value of the test function underlying the data.
      write(6,905)
      write(6,910) (i,i=1,mu)
      write(6,915)
      exz0 = tespog(0.,0.)
      er0 = abs(exz0-z0)
      ermax = er0
      sum = er0
      do 40 j=1,mv
         cv = cos(v(j))
         sv = sin(v(j))
         k = j
         do 30 i=1,mu
            x = u(i)*cv
            y = u(i)*sv
            exact(k) = tespog(x,y)
            err(i) = abs(exact(k)-z(k))
            sum = sum+err(i)
            if(err(i).gt.ermax) ermax = err(i)
            k = k+mv
  30     continue
         write(6,920) j,(z(k),k=j,m,mv)
         write(6,925) (exact(k),k=j,m,mv)
  40  continue
      ai = m+1
      sum = sum/ai
      write(6,930) z0,exz0
      write(6,935) sum,ermax
c  we set up the dimension information
      nuest = 16
      nvest = 27
      kwrk = 100
      lwrk = 1600
c main loop for the different spline approximations
      do 300 is=1,6
        go to (110,120,130,140,150,160),is
c  we start computing a set of spline approximations with
c  only c0-continuity at the origin,
 110    iopt(2) = 0
        ider(2) = 0
c  non-vanishing at the boundary of the disc,
        iopt(3) = 0
c  with a data value at the origin.
        ider(1) = 0
c  initialisation
        iopt(1) = 0
c  a large value for s for computing the least-squares polynomial
        s = 5.
        go to 200
c  iopt(1) = 1 from the second call on
 120    s = 0.1
        iopt(1) = 1
        go to 200
c  an interpolating spline
 130    s = 0.
        go to 200
c  a second set of approximations with c1-continuity at the origin
 140    iopt(2) = 1
c  vanishing at the boundary of the disc.
        iopt(3) = 1
c  exact value at the origin.
        ider(1) = 1
        z0 = exz0
c reinitialization
        iopt(1) = 0
        s = 0.1
        go to 200
c  no data value at the origin
 150    ider(1) = -1
c  vanishing partial derivatives at the origin
        ider(2) = 1
c reinitialization
        iopt(1) = 0
        go to 200
c finally we calculate the least-squares spline according to the current
c  set of knots
 160    iopt(1) = -1
 200    call pogrid(iopt,ider,mu,u,mv,v,z,z0,r,s,nuest,nvest,
     *    nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c printing of the fitting results.
        if(iopt(1).ge.0) go to 210
        write(6,940)
        go to 220
 210    write(6,945) s
 220    write(6,950) iopt(2)
        if(ider(2).eq.1) write(6,955)
        if(iopt(3).eq.1) write(6,960)
        write(6,965) fp,ier
        write(6,970) nu
        write(6,975)
        write(6,980) (tu(i),i=1,nu)
        write(6,985) nv
        write(6,975)
        write(6,980) (tv(i),i=1,nv)
        nc = (nu-4)*(nv-4)
        write(6,990)
        write(6,980) (c(i),i=1,nc)
c  evaluation of the spline approximation
        call bispev(tu,nu,tv,nv,c,3,3,u,mu,v,mv,f,wk,116,iw,29,ier)
        write(6,995)
        write(6,910) (i,i=1,mu,2)
        write(6,915)
        er0 = abs(exz0-c(1))
        ermax = er0
        sum = er0
        do 240 j=1,mv
          k = j
          do 230 i=1,mu
            sp(i) = f(k)
            err(i) = abs(exact(k)-f(k))
            sum = sum+err(i)
            if(err(i).gt.ermax) ermax = err(i)
            k = k+mv
 230      continue
          if( (j/3)*3 .ne.j ) go to 240
          write(6,920) j,(sp(i),i=1,mu,2)
          write(6,925) (err(i),i=1,mu,2)
 240    continue
        sum = sum/ai
        write(6,1000) c(1),er0
        write(6,935) sum,ermax
 300  continue
      stop
 900  format(10f8.3)
 905  format(49h1data value (exact function value) at grid points)
 910  format(8h u(i),i=,3x,9(i1,7x))
 915  format(8h v(j),j=)
 920  format(1x,i5,9(2x,f6.3))
 925  format(7x,9(2h (,f5.3,1h)))
 930  format(23h0data value at (0,0) = ,f7.3,5x,14hexact value = ,f7.3)
 935  format(19h0mean abs. error = ,f9.3,5x,18hmax. abs. error = ,f9.3)
 940  format(21h0least-squares spline)
 945  format(25h0smoothing spline with s=,f7.2)
 950  format(1x,35horder of continuity at the origin =,i3)
 955  format(1x,43hvanishing partial derivatives at the origin)
 960  format(1x,37hvanishing at the boundary of the disc)
 965  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i3)
 970  format(1x,42htotal number of knots in the u-direction =,i3)
 975  format(1x,22hposition of the knots )
 980  format(5x,8f9.4)
 985  format(1x,42htotal number of knots in the v-direction =,i3)
 990  format(23h0b-spline coefficients )
 995  format(50h0spline value (approximation error) at grid points)
1000  format(25h0spline value at (0,0) = ,f7.3,5x,8herror = ,f7.3)
      end
c
      real function tespog(x,y)
c function program tespog calculates the value of the test function
c underlying the data.
c  ..
c  ..scalar arguments..
      real x,y,f
c  ..
      f = 1.-((3.*x-1.)**2+(3.*y-1.)**2)/(11.-6.*(x+y))
      tespog = f-(1.-x**2-y**2)*(x+y)*54./121.
      return
      end