program test_csr3d

use, intrinsic :: iso_fortran_env
use csr3d_mod

implicit none
integer, parameter :: dp = REAL64

!type mesh3d_struct
!  integer :: size(3) = [64, 64, 64]     ! Grid shape
!  real(dp) :: min(3)                    ! Minimim in each dimension
!  real(dp) :: max(3)                    ! Maximum in each dimension
!  real(dp) :: delta(3)                  ! Grid spacing
!  real(dp) :: gamma                     ! Relativistic gamma
!  real(dp) :: charge                    ! Total charge on mesh
!  real(dp), allocatable, dimension(:,:,:) :: density        ! Charge density grid
!  real(dp), allocatable, dimension(:,:,:,:) :: wake        ! wake grid
!end type

! Compatibility with OpenSpaceCharge
type mesh3d_struct
  integer :: nlo(3) = [ 1,  1,  1]       ! Lowest  grid index in x, y, z (m) of rho and the quantity being computed (phi or E)
  integer :: nhi(3) = [64, 64, 64]       ! Highest grid index in x, y, z (m) of rho and the quantity being computed (phi or E)
  integer :: npad(3) = [ 1,  1,  1]      ! Array padding for cyclic convolution
  real(dp) :: min(3)                    ! Minimim in each dimension
  real(dp) :: max(3)                    ! Maximum in each dimension
  real(dp) :: delta(3)                  ! Grid spacing
  real(dp) :: gamma                     ! Relativistic gamma
  real(dp) :: charge                    ! Total charge on mesh
  real(dp), allocatable, dimension(:,:,:) :: rho        ! Charge density grid
  real(dp), allocatable, dimension(:,:,:) :: phi        ! electric potential grid
  real(dp), allocatable, dimension(:,:,:,:) :: efield   ! electric field grid
  real(dp), allocatable, dimension(:,:,:,:) :: bfield   ! magnetic field grid
end type

type(mesh3d_struct) :: mesh3d

real(dp) :: gamma, rho, sigmas(3), gauss_cutoff
real(dp) :: center(3), x0, y0, z0, dummy
integer ::  sizes(3)
logical :: normalize

! File handling
character(200) :: in_file
integer :: open_status, namelist_file
namelist / csr3d_test_params / &
  sizes, gamma, rho, &
  sigmas, gauss_cutoff, center, &
  normalize

!--------------
!Namelist defaults
gamma = 500
rho = 1
sizes = [4,4,4]
sigmas = [10.0e-6_dp, 10.0e-6_dp, 10.0e-6_dp]
gauss_cutoff = 5.0
center = [0.0_dp, 0.0_dp, 0.0_dp]
normalize = .true.  ! Use normalized units 1/m^2, otherwise V/m

!Read namelist
in_file = 'test_opensc.in'
if (command_argument_count() > 0) call get_command_argument(1, in_file)
open(newunit=namelist_file, file = in_file, status = 'old', iostat=open_status)
if (open_status /= 0) then
  print *, 'Input file missing: ', in_file
  print *, 'Using defaults'
else
  read (namelist_file, nml = csr3d_test_params)
  close (namelist_file)
endif

print *, '------------------------'
write(*, csr3d_test_params)
print *, '------------------------'

!
!x0 = -1e-6_dp
!y0 = -1e-6_dp
!z0 = -1e-6_dp
!gamma = 500.0_dp
!
!
!print *, x0, y0, z0, gamma
!
!!dummy = alpha(x0, y0, z0, gamma)
!!print *, 'Alpha: ', dummy
!
!dummy = psi(x0, y0, z0, gamma, 2)
!print *, 'psi_y: ', dummy
!
!stop

mesh3d%nhi = sizes
print *, 'Gaussian mesh'
call gaussian_mesh(mesh3d, sigmas, gauss_cutoff)

!call calc_density_derivative(mesh3d%rho, mesh3d%rho_prime, mesh3d%delta(3))

!print *, '------------------------'
!print *, 'Writing 2d density'
!call write_2d('density0', mesh3d%rho(:,sizes(2)/2,:))
!print *, 'sizes(2)/2', sizes(2)/2
!call write_2d('density0_prime', mesh3d%rho_prime(:,sizes(2)/2,:))
!

mesh3d%gamma = gamma
call print_mesh3d(mesh3d)

print *, '------------------------'
print *, 'csr3d_steady_state'
call csr3d_steady_state(mesh3d, rho)

print *, '------------------------'
print *, 'Writing lines, planes'
!call write_lines(mesh3d, center(1), center(2), center(3))

call write_line('x_line.dat', mesh3d, center, 'x')
call write_line('y_line.dat', mesh3d, center, 'y')
call write_line('z_line.dat', mesh3d, center, 'z')

center = 0
center(1) = -sigmas(1)
call write_line('z_line_-sigma_x.dat', mesh3d, center, 'z')
center(1) = sigmas(1)
call write_line('z_line_+sigma_x.dat', mesh3d, center, 'z')

center = 0
center(2) = -sigmas(2)
call write_line('z_line_-sigma_y.dat', mesh3d, center, 'z')
center(2) = sigmas(2)
call write_line('z_line_+sigma_y.dat', mesh3d, center, 'z')

!call write_plane(mesh3d)

center = 0
call write_plane('xz_plane.dat', mesh3d, center, 'xz')
center(2) = sigmas(2)
call write_plane('xz_plane_+sigma_y.dat', mesh3d, center, 'xz')
center(2) = -sigmas(2)
call write_plane('xz_plane_-sigma_y.dat', mesh3d, center, 'xz')

!call csr3d_calc()
!call ellipinc_test()

contains

! Fills mesh with Gaussian data
subroutine gaussian_mesh(mesh3d, sigmas, cutoff)
type(mesh3d_struct) :: mesh3d
real(dp) :: x, y, z, sigmas(3), cutoff
real(dp) :: dx, dy, dz, xmin, ymin, zmin, norm
integer :: i, j, k, isize, jsize, ksize

if (.not. allocated(mesh3d%rho)) then
  allocate(mesh3d%rho(mesh3d%nhi(1), mesh3d%nhi(2), mesh3d%nhi(3)))
  allocate(mesh3d%efield(mesh3d%nhi(1), mesh3d%nhi(2), mesh3d%nhi(3), 3))
endif

! Fill mesh
mesh3d%min   = -cutoff*sigmas
mesh3d%max   =  cutoff*sigmas
mesh3d%delta = (mesh3d%max - mesh3d%min)/(mesh3d%nhi-1)

! Convenient local variables.
isize = mesh3d%nhi(1)
jsize = mesh3d%nhi(2)
ksize = mesh3d%nhi(3)

dx = mesh3d%delta(1)
dy = mesh3d%delta(2)
dz = mesh3d%delta(3)
xmin = mesh3d%min(1)
ymin = mesh3d%min(2)
zmin = mesh3d%min(3)

do k = 1, ksize
  z = (k-1)*dz + zmin

  do j=1, jsize
    y=(j-1)*dy + ymin

   do i=1, isize
     x = (i-1)*dx + xmin

     mesh3d%rho(i,j,k)= gauss3(x, y, z, sigmas(1), sigmas(2), sigmas(3))
    ! mesh3d%rho_prime(i,j,k)= gauss3_prime(x, y, z, sigmas(1), sigmas(2), sigmas(3))

    enddo
  enddo
enddo

! Normalize
norm = sum(mesh3d%rho) * dx * dy * dz
mesh3d%rho  = mesh3d%rho / norm

end subroutine

! Gaussian
elemental real(dp) function gauss(x, sigma)
real(dp), intent(in):: x, sigma
real(dp), parameter :: pi = 4.0_dp*atan2(1.0_dp,1.0_dp)
gauss =  1/(sigma * sqrt(2 * pi)) * exp( - (x)**2 / (2 * sigma**2) )
end function

! 3D Gaussian
elemental real(dp) function gauss3(x, y, z, sigma_x, sigma_y, sigma_z)
real(dp), intent(in):: x, y, z, sigma_x, sigma_y, sigma_z
real(dp), parameter :: pi = 4.0_dp*atan2(1.0_dp,1.0_dp)
gauss3 =  gauss(x, sigma_x)*gauss(y, sigma_y)*gauss(z, sigma_z)
end function

! 3D d/dz Gaussian
elemental real(dp) function gauss3_prime(x, y, z, sigma_x, sigma_y, sigma_z)
real(dp), intent(in):: x, y, z, sigma_x, sigma_y, sigma_z
real(dp), parameter :: pi = 4.0_dp*atan2(1.0_dp,1.0_dp)
gauss3_prime =  gauss(x, sigma_x)*gauss(y, sigma_y)*gauss(z, sigma_z)*(-z/sigma_z**2)
end function

!------------------------------------------------------------------------
!------------------------------------------------------------------------
!------------------------------------------------------------------------
!+
! Subroutine interpolate_field(x, y, z, mesh3d, wake)
!
! Interpolate field on mesh
!
! Input:
!   x, y, z   -- REAL64: coordinates to interpolate
!   mesh3d    -- mesh3d_struct:  contains efield, bfield
!
! Output:
!   wake(3)      -- REAL64 : interpolated wake field at x, y, z
!
!-

subroutine interpolate_field(x, y, z, mesh3d, wake, density)
type(mesh3d_struct) ::  mesh3d
real(dp) :: x, y, z
real(dp), optional :: wake(3), density
real(dp) :: hxi,hyi,hzi,ab,de,gh
integer :: ip,jp,kp,ip1,jp1,kp1
integer :: nflag
nflag=0
hxi=1.d0/mesh3d%delta(1); hyi=1.d0/mesh3d%delta(2); hzi=1.d0/mesh3d%delta(3)
ip=floor((x-mesh3d%min(1))*hxi+1)
jp=floor((y-mesh3d%min(2))*hyi+1)
kp=floor((z-mesh3d%min(3))*hzi+1)

if(ip<1 .or. ip>mesh3d%nhi(1)-1)then
  nflag=1
  write(6,*)'ierror: ip=', ip, (x-mesh3d%min(1)), (x-mesh3d%min(1))/mesh3d%delta(1)
  if(ip<1)then
    ip=1
  else
    ip=mesh3d%nhi(1)-1
  endif
endif
if(jp<1 .or. jp>mesh3d%nhi(2)-1)then
  nflag=1
  write(6,*)'jerror: jp=', jp, (y-mesh3d%min(2)), (y-mesh3d%min(2))/mesh3d%delta(2)
  write(6,*)ab,de,gh
  if(jp<1)then
    jp=1
  else
    jp=mesh3d%nhi(2)-1
  endif
endif

if(kp<1 .or. kp>mesh3d%nhi(3)-1)then
    nflag=1
    write(6,*)'kerror:  kp=',kp
    write(6,*)'z=',z
    write(6,*)'mesh3d%min(3)=',mesh3d%min(3)
!!!!!!!!!!write(6,*)ab,de,gh
  if(kp<1)then
    kp=1
  else
    kp=mesh3d%nhi(3)-1
  endif
endif
ab=((mesh3d%min(1)-x)+ip*mesh3d%delta(1))*hxi
de=((mesh3d%min(2)-y)+jp*mesh3d%delta(2))*hyi
gh=((mesh3d%min(3)-z)+kp*mesh3d%delta(3))*hzi
if(nflag.eq.1)then
  write(6,*)ab,de,gh
  nflag=0
endif

ip1=ip+1
jp1=jp+1
kp1=kp+1

if (present(wake)) then
    wake=mesh3d%efield(ip, jp,  kp,  :)*ab*de*gh                 &
     +mesh3d%efield(ip, jp1, kp,  :)*ab*(1.-de)*gh            &
     +mesh3d%efield(ip, jp1, kp1, :)*ab*(1.-de)*(1.-gh)       &
     +mesh3d%efield(ip, jp,  kp1, :)*ab*de*(1.-gh)            &
     +mesh3d%efield(ip1,jp,  kp1, :)*(1.-ab)*de*(1.-gh)       &
     +mesh3d%efield(ip1,jp1, kp1, :)*(1.-ab)*(1.-de)*(1.-gh)  &
     +mesh3d%efield(ip1,jp1, kp,  :)*(1.-ab)*(1.-de)*gh       &
     +mesh3d%efield(ip1,jp,  kp,  :)*(1.-ab)*de*gh
endif

if (present(density)) then
    density=mesh3d%rho(ip, jp,  kp  )*ab*de*gh                 &
          +mesh3d%rho(ip, jp1, kp  )*ab*(1.-de)*gh            &
          +mesh3d%rho(ip, jp1, kp1 )*ab*(1.-de)*(1.-gh)       &
          +mesh3d%rho(ip, jp,  kp1 )*ab*de*(1.-gh)            &
          +mesh3d%rho(ip1,jp,  kp1 )*(1.-ab)*de*(1.-gh)       &
          +mesh3d%rho(ip1,jp1, kp1 )*(1.-ab)*(1.-de)*(1.-gh)  &
          +mesh3d%rho(ip1,jp1, kp  )*(1.-ab)*(1.-de)*gh       &
          +mesh3d%rho(ip1,jp,  kp  )*(1.-ab)*de*gh
endif

end subroutine

! -----------------
! -----------------
!! Write line utility
!!
subroutine write_line(fname, mesh3d, center, axis)
type(mesh3d_struct) :: mesh3d
real(dp) :: center(3), x, y, z, wake(3)
integer :: i, outfile
character(*) :: fname
character(1) :: axis

open(newunit=outfile, file = trim(fname))

select case(axis)
case('x')
    z = center(3)
    y = center(2)
    do i = 1, mesh3d%nhi(1) -1 ! skip last point
      x = (i-1)*mesh3d%delta(1) + mesh3d%min(1)
      call interpolate_field(x, y, z, mesh3d, wake=wake)
      write(outfile, '(6(1pe14.7,1x))') x,y,z, wake(1:3)
    enddo

case('y')
x = center(1)
    z = center(3)
    do i = 1, mesh3d%nhi(2) -1 ! skip last point
      y = (i-1)*mesh3d%delta(2) + mesh3d%min(2)
      call interpolate_field(x, y, z, mesh3d, wake=wake)
      write(outfile, '(6(1pe14.7,1x))') x,y,z, wake(1:3)
    enddo

case('z')
    x = center(1)
    y = center(2)
    do i = 1, mesh3d%nhi(3) -1 ! skip last point
      z = (i-1)*mesh3d%delta(3) + mesh3d%min(3)
      call interpolate_field(x, y, z, mesh3d, wake=wake)
      write(outfile, '(6(1pe14.7,1x))') x,y,z,wake(1:3)
    enddo
end select

close(outfile)
end subroutine

! -----------------
! -----------------
!! Write plane utility
!!
subroutine write_plane(fname, mesh3d, center, axes)
type(mesh3d_struct) :: mesh3d
real(dp) :: center(3), x, y, z, wake(3), density
integer :: i, k, outfile
character(*) :: fname
character(2) :: axes

open(newunit=outfile,  file = trim(fname))

write(outfile, '(6(a, 1x))') 'x', 'z', 'Wx', 'Wy', 'Ws', 'density'

select case(axes)
case('xz')
y = center(2)
do k = 1, mesh3d%nhi(3) -1 ! skip last point
  z = (k-1)*mesh3d%delta(3) + mesh3d%min(3)
  do i = 1, mesh3d%nhi(1) -1 ! skip last point
    x = (i-1)*mesh3d%delta(1) + mesh3d%min(1)
    call interpolate_field(x, y, z, mesh3d, wake=wake, density=density)
    write(outfile, *) x, z, wake(1), wake(2), wake(3), density
  enddo
enddo

end select

close(outfile)
end subroutine

! -----------------
! -----------------
!! Write grid utility
!!
!subroutine write_2d(fname, grid)
!real(dp) :: grid(:,:)
!integer :: i, j, outfile
!character(*) :: fname
!
!open(newunit=outfile, file = trim(fname))
!
!write(outfile, *)  size(grid, 1)
!write(outfile, *)  size(grid, 2)
!do j = 1, size(grid, 2)
!  do i = 1, size(grid, 1)
!    write(outfile, *) grid(i, j)
!  enddo
!enddo
!close(outfile)
!end subroutine
!! -----------------
! -----------------

!------------------------------------------------------------------------
!+
subroutine print_mesh3d(mesh3d)
type(mesh3d_struct) :: mesh3d
print *, '------------------------'
print *, 'Mesh: '
print *, 'size: ', mesh3d%nhi
print *, 'min: ', mesh3d%min
print *, 'max: ', mesh3d%max
print *, 'delta: ', mesh3d%delta
print *, 'gamma: ', mesh3d%gamma
print *, 'charge: ', mesh3d%charge
if (allocated(mesh3d%rho)) print *, 'density allocated'
if (allocated(mesh3d%efield)) print *, 'wake allocated'
print *, '------------------------'
end subroutine

!------------------------------------------------------------------------
!+
! Subroutine csr3d_steady_state(mesh3d, offset)
!
! Performs the space charge calculation using the integrated Green function method
! and FFT-based convolutions.
!
! Input:
!   mesh3d        -- mesh3d_struct: populated with %rho
!
!   offset        -- real(3), optional: Offset coordinates x0, y0, z0 to evaluate the field,
!                    relative to rho.
!                    Default: (0,0,0)
!                        For example, an offset of (0,0,10) can be used to compute
!                        the field at z=+10 m relative to rho.
!
!
!
! Output:
!   mesh3d        -- mesh3d_struct: populated with %wake
!
!
!
! Notes:
!
!
!
!-
subroutine csr3d_steady_state(mesh3d, rho, offset, normalize)
type(mesh3d_struct), intent(inout):: mesh3d
real(dp), intent(in) :: rho
logical, optional :: normalize
real(dp), allocatable, dimension(:,:,:,:) :: image_efield   ! electric field grid
real(dp), optional :: offset(3)
real(dp) :: offset0(3)
real(dp), parameter :: c_light = 299792458.0

print *, 'csr3d_steady_state'

! Free space field
call csr3d_steady_state_solver(mesh3d%rho, mesh3d%gamma, rho, mesh3d%delta, &
   mesh3d%efield, offset=offset0, normalize=normalize)

end subroutine csr3d_steady_state

end program


c This file includes the Applied Statistics algorithm AS 66 for calculating
c the tail area under the normal curve, and two alternative routines which
c give higher accuracy.   The latter have been contributed by Alan Miller of
c CSIRO Division of Mathematics & Statistics, Clayton, Victoria.   Notice
c that each function or routine has different call arguments.
c
c
      double precision function alnorm(x,upper)
c
c         Algorithm AS66 Applied Statistics (1973) vol22 no.3
c
c       Evaluates the tail area of the standardised normal curve
c       from x to infinity if upper is .true. or
c       from minus infinity to x if upper is .false.
c
      double precision zero,one,half
      double precision con,z,y,x
      double precision p,q,r,a1,a2,a3,b1,b2,c1,c2,c3,c4,c5,c6
      double precision d1,d2,d3,d4,d5
      logical upper,up
c*** machine dependent constants
      double precision ltone,utzero
      data zero/0.0d0/, one/1.0d0/, half/0.5d0/
      data ltone/7.0d0/,utzero/18.66d0/
      data con/1.28d0/
      data p/0.398942280444d0/,q/0.39990348504d0/,r/0.398942280385d0/
      data a1/5.75885480458d0/,a2/2.62433121679d0/,a3/5.92885724438d0/
      data b1/-29.8213557807d0/,b2/48.6959930692d0/
      data c1/-3.8052d-8/,c2/3.98064794d-4/,c3/-0.151679116635d0/
      data c4/4.8385912808d0/,c5/0.742380924027d0/,c6/3.99019417011d0/
      data d1/1.00000615302d0/,d2/1.98615381364d0/,d3/5.29330324926d0/
      data d4/-15.1508972451d0/,d5/30.789933034d0/
c
      up=upper
      z=x
      if(z.ge.zero)goto 10
      up=.not.up
      z=-z
   10 if(z.le.ltone.or.up.and.z.le.utzero)goto 20
      alnorm=zero
      goto 40
   20 y=half*z*z
      if(z.gt.con) goto 30
c
      alnorm=half-z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
      goto 40
   30 alnorm=r*dexp(-y)/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/
     2   (z+c6))))))
   40 if(.not.up)alnorm=one-alnorm
      return
      end
c
c
c
        SUBROUTINE NORMP(Z, P, Q, PDF)
C
C       Normal distribution probabilities accurate to 1.e-15.
C       Z = no. of standard deviations from the mean.
C       P, Q = probabilities to the left & right of Z.   P + Q = 1.
C       PDF = the probability density.
C
C       Based upon algorithm 5666 for the error function, from:
C       Hart, J.F. et al, 'Computer Approximations', Wiley 1968
C
C       Programmer: Alan Miller
C
C       Latest revision - 30 March 1986
C
        IMPLICIT DOUBLE PRECISION (A-H, O-Z)
        DATA P0, P1, P2, P3, P4, P5, P6/220.20 68679 12376 1D0,
     *    221.21 35961 69931 1D0, 112.07 92914 97870 9D0,
     *    33.912 86607 83830 0D0, 6.3739 62203 53165 0D0,
     *    .70038 30644 43688 1D0, .35262 49659 98910 9D-01/,
     *    Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7/440.41 37358 24752 2D0,
     *    793.82 65125 19948 4D0, 637.33 36333 78831 1D0,
     *    296.56 42487 79673 7D0, 86.780 73220 29460 8D0,
     *    16.064 17757 92069 5D0, 1.7556 67163 18264 2D0,
     *    .88388 34764 83184 4D-1/,
     *    CUTOFF/7.071D0/, ROOT2PI/2.5066 28274 63100 1D0/
C
        ZABS = ABS(Z)
C
C       |Z| > 37.
C
        IF (ZABS .GT. 37.D0) THEN
          PDF = 0.D0
          IF (Z .GT. 0.D0) THEN
            P = 1.D0
            Q = 0.D0
          ELSE
            P = 0.D0
            Q = 1.D0
          END IF
          RETURN
        END IF
C
C       |Z| <= 37.
C
        EXPNTL = EXP(-0.5D0*ZABS**2)
        PDF = EXPNTL/ROOT2PI
C
C       |Z| < CUTOFF = 10/sqrt(2).
C
        IF (ZABS .LT. CUTOFF) THEN
          P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS +
     *          P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS +
     *          Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS +
     *          Q0)
C
C       |Z| >= CUTOFF.
C
        ELSE
          P = PDF/(ZABS + 1.D0/(ZABS + 2.D0/(ZABS + 3.D0/(ZABS + 4.D0/
     *          (ZABS + 0.65D0)))))
        END IF
C
        IF (Z .LT. 0.D0) THEN
          Q = 1.D0 - P
        ELSE
          Q = P
          P = 1.D0 - Q
        END IF
        RETURN
        END
c
c
c
        SUBROUTINE NPROB(Z,P,Q,PDF)
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C       P, Q = PROBABILITIES TO THE LEFT AND RIGHT OF Z
C       FOR THE STANDARD NORMAL DISTRIBUTION.
C       PDF  = THE PROBABILITY DENSITY FUNCTION
C
C       REFERENCE: ADAMS,A.G. AREAS UNDER THE NORMAL CURVE,
C       ALGORITHM 39, COMPUTER J., VOL. 12, 197-8, 1969.
C
C       LATEST REVISION - 23 JANUARY 1981
C
C********************************************************************
C
        DATA A0,A1,A2,A3,A4,A5,A6,A7/0.5D0, 0.398942280444D0,
     1  0.399903438504D0, 5.75885480458D0, 29.8213557808D0,
     2  2.62433121679D0, 48.6959930692D0, 5.92885724438D0/,
     3  B0,B1,B2,B3,B4,B5,B6,B7,B8,B9,B10,B11/0.398942280385D0,
     4  3.8052D-8, 1.00000615302D0, 3.98064794D-4, 1.98615381364D0,
     5  0.151679116635D0, 5.29330324926D0, 4.8385912808D0,
     6  15.1508972451D0, 0.742380924027D0, 30.789933034D0,
     7  3.99019417011D0/
C
        ZABS = ABS(Z)
        IF(ZABS.GT.12.7D0) GO TO 20
        Y = A0*Z*Z
        PDF = EXP(-Y)*B0
        IF(ZABS.GT.1.28D0) GO TO 10
C
C       Z BETWEEN -1.28 AND +1.28
C
        Q = A0-ZABS*(A1-A2*Y/(Y+A3-A4/(Y+A5+A6/(Y+A7))))
        IF(Z.LT.0.D0) GO TO 30
        P = 1.D0-Q
        RETURN
C
C       ZABS BETWEEN 1.28 AND 12.7
C
   10   Q = PDF/(ZABS-B1+B2/(ZABS+B3+B4/(ZABS-B5+B6/(ZABS+B7-B8/
     1  (ZABS+B9+B10/(ZABS+B11))))))
        IF(Z.LT.0.D0) GO TO 30
        P = 1.D0-Q
        RETURN
C
C       Z FAR OUT IN TAIL
C
   20   Q = 0.D0
        PDF = 0.D0
        IF(Z.LT.0.D0) GO TO 30
        P = 1.D0
        RETURN
C
C       NEGATIVE Z, INTERCHANGE P AND Q
C
   30   P = Q
        Q = 1.D0-P
        RETURN
        END


! { dg-do compile }
! { dg-options "-Wall" }

! PR 57022: [4.7/4.8/4.9 Regression] Inappropriate warning for use of TRANSFER with arrays
! Contributed by William Clodius <wclodius@los-alamos.net>

subroutine transfers (test)

  use, intrinsic :: iso_fortran_env

  integer, intent(in) :: test

  integer(int8)  :: test8(8)  = 0
  integer(int16) :: test16(4) = 0
  integer(int32) :: test32(2) = 0
  integer(int64) :: test64    = 0

  select case(test)
  case(0)
    test64 = transfer(test8, test64)
  case(1)
    test64 = transfer(test16, test64)
  case(2)
    test64 = transfer(test32, test64)
  case(3)
    test8  = transfer(test64, test8, 8)
  case(4)
    test16 = transfer(test64, test16, 4)
  case(5)
    test32 = transfer(test64, test32, 2)
  end select

end subroutine

! PR 53685: surprising warns about transfer with explicit character range
! Contributed by Jos de Kloe <kloedej@knmi.nl>

subroutine mytest(byte_array,val)
  integer, parameter :: r8_ = Selected_Real_Kind(15,307)  ! = real*8
  character(len=1), dimension(16), intent(in) :: byte_array
  real(r8_),intent(out) :: val
  val = transfer(byte_array(1:8),val)
end subroutine


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

      double precision function randlc (x, a)

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

c---------------------------------------------------------------------
c
c   This routine returns a uniform pseudorandom double precision number in the
c   range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The returned value RANDLC is normalized to be
c   between 0 and 1, i.e. RANDLC = 2^(-46) * x_1.  X is updated to contain
c   the new seed x_1, so that subsequent calls to RANDLC using the same
c   arguments will generate a continuous sequence.
c
c   This routine should produce the same results on any computer with at least
c   48 mantissa bits in double precision floating point data.  On 64 bit
c   systems, double precision should be disabled.
c
c   David H. Bailey     October 26, 1990
c
c---------------------------------------------------------------------

      implicit none

      double precision r23,r46,t23,t46,a,x,t1,t2,t3,t4,a1,a2,x1,x2,z
      parameter (r23 = 0.5d0 ** 23, r46 = r23 ** 2, t23 = 2.d0 ** 23,
     >  t46 = t23 ** 2)

c---------------------------------------------------------------------
c   Break A into two parts such that A = 2^23 * A1 + A2.
c---------------------------------------------------------------------
      t1 = r23 * a
      a1 = int (t1)
      a2 = a - t23 * a1

c---------------------------------------------------------------------
c   Break X into two parts such that X = 2^23 * X1 + X2, compute
c   Z = A1 * X2 + A2 * X1  (mod 2^23), and then
c   X = 2^23 * Z + A2 * X2  (mod 2^46).
c---------------------------------------------------------------------
      t1 = r23 * x
      x1 = int (t1)
      x2 = x - t23 * x1
      t1 = a1 * x2 + a2 * x1
      t2 = int (r23 * t1)
      z = t1 - t23 * t2
      t3 = t23 * z + a2 * x2
      t4 = int (r46 * t3)
      x = t3 - t46 * t4
      randlc = r46 * x

      return
      end

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

      subroutine vranlc (n, x, a, y)

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

c---------------------------------------------------------------------
c
c   This routine generates N uniform pseudorandom double precision numbers in
c   the range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The N results are placed in Y and are normalized
c   to be between 0 and 1.  X is updated to contain the new seed, so that
c   subsequent calls to VRANLC using the same arguments will generate a
c   continuous sequence.  If N is zero, only initialization is performed, and
c   the variables X, A and Y are ignored.
c
c   This routine is the standard version designed for scalar or RISC systems.
c   However, it should produce the same results on any single processor
c   computer with at least 48 mantissa bits in double precision floating point
c   data.  On 64 bit systems, double precision should be disabled.
c
c---------------------------------------------------------------------

      implicit none

      integer i,n
      double precision y,r23,r46,t23,t46,a,x,t1,t2,t3,t4,a1,a2,x1,x2,z
      dimension y(*)
      parameter (r23 = 0.5d0 ** 23, r46 = r23 ** 2, t23 = 2.d0 ** 23,
     >  t46 = t23 ** 2)

c---------------------------------------------------------------------
c   Break A into two parts such that A = 2^23 * A1 + A2.
c---------------------------------------------------------------------
      t1 = r23 * a
      a1 = int (t1)
      a2 = a - t23 * a1

c---------------------------------------------------------------------
c   Generate N results.   This loop is not vectorizable.
c---------------------------------------------------------------------
      do i = 1, n

c---------------------------------------------------------------------
c   Break X into two parts such that X = 2^23 * X1 + X2, compute
c   Z = A1 * X2 + A2 * X1  (mod 2^23), and then
c   X = 2^23 * Z + A2 * X2  (mod 2^46).
c---------------------------------------------------------------------
        t1 = r23 * x
        x1 = int (t1)
        x2 = x - t23 * x1
        t1 = a1 * x2 + a2 * x1
        t2 = int (r23 * t1)
        z = t1 - t23 * t2
        t3 = t23 * z + a2 * x2
        t4 = int (r46 * t3)
        x = t3 - t46 * t4
        y(i) = r46 * x
      enddo

      return
      end


      PROGRAM xrzextr
C     driver for routine rzextr
      INTEGER NV
      PARAMETER(NV=4)
      INTEGER i,iest,j
      REAL dum,xest,yest(NV),yz(NV),dy(NV)
      do 12 i=1,10
        iest=i
        xest=1.0/float(i)
        dum=1.0-xest+xest**3
        do 11 j=1,NV
          dum=dum/(xest+1.0)
          yest(j)=dum
11      continue
        call rzextr(iest,xest,yest,yz,dy,NV)
        write(*,'(/1x,a,i2,a,f8.4)') 'IEST = ',i,'   XEST =',xest
        write(*,'(1x,a,4f12.6)') 'Extrap. Function: ',(yz(j),j=1,NV)
        write(*,'(1x,a,4f12.6)') 'Estimated Error:  ',(dy(j),j=1,NV)
12    continue
      write(*,'(/1x,a,4f12.6)') 'Actual Values:    ',1.0,1.0,1.0,1.0
      END

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


program test

use spherical_splines

implicit none
real(8) :: h,d,h_ref
real(8),parameter :: tol = 0.001_8
integer :: iostatus

!  Read values from file with precomputed half-widths (radians) and values of h
open(10,file='half-width.text')

iostatus = 0
do while (iostatus == 0)
   read(10,*,iostat=iostatus) h_ref,d
   if (iostatus < 0) exit  ! EOF
   if (iostatus > 0) then
      write(0,'(a)') 'Problem reading file'
      stop
   endif
   h = sph_splines_AP_width2h(d)
   if (abs(h-h_ref) > tol) write(*,'(a,f0.5)') 'h and h_ref differ by more than ',tol
enddo

close(10)

end program test


! Probability Distribution Function (PDF) related routines
!
! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ------------------------------------------------------------------------------

module type_pdf

  use lib_array
  use lib_random

  implicit none

  private

  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)

  real,parameter :: unset = -1.e30

  !!@FOR real(sp):sp real(dp):dp

  public :: pdf_<T>
  type pdf_<T>
     integer :: n = 0
     @T,allocatable :: x(:)
     @T,allocatable :: pdf(:)
     @T,allocatable :: cdf(:)
     logical :: log = .false.
     logical :: normalized = .false.

     ! Simple mode means that the interpolation in the CDF is done in an
     ! approximate way, and does not take into account that computing a CDF from
     ! a linear function gives a non-linear CDF. The correct calculation is done
     ! by default, and actually ends up being faster because there are fewer calls
     ! to functions. The 'correct' way required 3 or 4 additional arrays to be
     ! pre-computed to make it faster, so it is more RAM intensive.
     logical :: simple = .false.
     @T,allocatable :: a(:),b(:),r(:),rx(:),rc(:)

  end type pdf_<T>

  public :: pdf_discrete_<T>
  type pdf_discrete_<T>
     integer :: n = 0
     @T,allocatable :: pdf(:)
     @T,allocatable :: cdf(:)
     logical :: normalized = .false.
  end type pdf_discrete_<T>

  !!@END FOR

  public :: allocate_pdf
  interface allocate_pdf
     module procedure allocate_pdf_discrete_sp
     module procedure allocate_pdf_discrete_dp
     module procedure allocate_pdf_cont_sp
     module procedure allocate_pdf_cont_dp
  end interface allocate_pdf

  public :: set_pdf
  interface set_pdf
     module procedure set_pdf_discrete_sp
     module procedure set_pdf_discrete_dp
     module procedure set_pdf_cont_sp
     module procedure set_pdf_cont_dp
  end interface set_pdf

  public :: normalize_pdf
  interface normalize_pdf
     module procedure normalize_pdf_discrete_sp
     module procedure normalize_pdf_discrete_dp
     module procedure normalize_pdf_cont_sp
     module procedure normalize_pdf_cont_dp
  end interface normalize_pdf

  public :: check_pdf
  interface check_pdf
     module procedure check_pdf_discrete_sp
     module procedure check_pdf_discrete_dp
     module procedure check_pdf_cont_sp
     module procedure check_pdf_cont_dp
  end interface check_pdf

  public :: find_cdf
  interface find_cdf
     module procedure find_cdf_discrete_sp
     module procedure find_cdf_discrete_dp
     module procedure find_cdf_cont_sp
     module procedure find_cdf_cont_dp
  end interface find_cdf

  public :: sample_pdf
  interface sample_pdf
     module procedure sample_pdf_discrete_sp
     module procedure sample_pdf_discrete_dp
     module procedure sample_pdf_cont_sp
     module procedure sample_pdf_cont_dp
  end interface sample_pdf

  public :: sample_pdf_log
  interface sample_pdf_log
     module procedure sample_pdf_cont_log_sp
     module procedure sample_pdf_cont_log_dp
  end interface sample_pdf_log

  public :: interpolate_pdf
  interface interpolate_pdf
     module procedure interpolate_pdf_cont_sp
     module procedure interpolate_pdf_cont_dp
  end interface interpolate_pdf

contains

  !!@FOR real(sp):sp real(dp):dp

  subroutine find_cdf_discrete_<T>(p)
    implicit none
    type(pdf_discrete_<T>),intent(inout) :: p
    integer :: i
    @T :: norm
    if(p%n==0) stop "[find_cdf_discrete] PDF is not set correctly (y)"
    p%cdf(1) = p%pdf(1)
    do i=2,p%n
       p%cdf(i) = p%cdf(i-1) + p%pdf(i)
    end do
    norm = p%cdf(p%n)
    if(norm==0._<T>) stop "[find_cdf_discrete] all PDF elements are zero"
    p%cdf = p%cdf / norm
  end subroutine find_cdf_discrete_<T>

  subroutine allocate_pdf_discrete_<T>(p,n)
    implicit none
    type(pdf_discrete_<T>),intent(out) :: p
    integer,intent(in) :: n
    p%n = n
    allocate(p%pdf(n))
    allocate(p%cdf(n))
  end subroutine allocate_pdf_discrete_<T>

  subroutine allocate_pdf_cont_<T>(p,n)
    implicit none
    type(pdf_<T>),intent(out) :: p
    integer,intent(in) :: n
    p%n = n
    allocate(p%x(n))
    allocate(p%pdf(n))
    allocate(p%cdf(n))
  end subroutine allocate_pdf_cont_<T>

  subroutine normalize_pdf_discrete_<T>(p)
    implicit none
    type(pdf_discrete_<T>),intent(inout) :: p
    @T :: norm
    norm = sum(p%pdf)
    if(norm==0._<T>) stop "[normalize_pdf_discrete] all PDF elements are zero"
    p%pdf = p%pdf / norm
    p%normalized = .true.
  end subroutine normalize_pdf_discrete_<T>

  subroutine normalize_pdf_cont_<T>(p)
    implicit none
    type(pdf_<T>),intent(inout) :: p
    if(p%log) then
       p%pdf = p%pdf / integral_loglog(p%x, p%pdf)
    else
       p%pdf = p%pdf / integral(p%x, p%pdf)
    end if
    p%normalized = .true.
  end subroutine normalize_pdf_cont_<T>

  subroutine set_pdf_discrete_<T>(p,y)
    implicit none
    type(pdf_discrete_<T>),intent(out) :: p
    @T,intent(in) :: y(:)
    call allocate_pdf(p,size(y))
    p%pdf = y
    call normalize_pdf(p)
    call find_cdf(p)
    call check_pdf(p)
  end subroutine set_pdf_discrete_<T>

  subroutine set_pdf_cont_<T>(p,x,y,log,simple)
    implicit none
    type(pdf_<T>),intent(out) :: p
    @T,intent(in) :: x(:),y(:)
    logical,intent(in),optional :: log,simple
    if(size(x).ne.size(y)) stop "[set_pdf] x and y array sizes differ"
    call allocate_pdf(p,size(y))
    p%x   = x
    p%pdf = y
    if(present(log)) p%log = log
    if(present(simple)) p%simple = simple
    call normalize_pdf(p)
    call find_cdf(p)
    call check_pdf(p)
  end subroutine set_pdf_cont_<T>

  subroutine check_pdf_discrete_<T>(p)
    implicit none
    type(pdf_discrete_<T>),intent(in) :: p
    if(p%n==0) stop "[check_pdf_discrete] PDF size not set"
    if(.not.allocated(p%pdf)) stop "[check_pdf_discrete] PDF pdf array not allocated"
    if(.not.allocated(p%cdf)) stop "[check_pdf_discrete] PDF cdf array not allocated"
    if(p%n.ne.size(p%pdf)) stop "[check_pdf_discrete] PDF pdf array has incorrect size"
    if(p%n.ne.size(p%cdf)) stop "[check_pdf_discrete] PDF cdf array has incorrect size"
    if(any(p%pdf < 0.)) stop "[check_pdf_discrete] PDF has negative probabilities"
    if(.not.p%normalized) stop "[check_pdf_discrete] PDF is not normalized"
  end subroutine check_pdf_discrete_<T>

  subroutine check_pdf_cont_<T>(p)
    implicit none
    type(pdf_<T>),intent(in) :: p
    integer :: i
    if(p%n==0) stop "[check_pdf] PDF size not set"
    if(.not.allocated(p%x))   stop "[check_pdf] PDF x array not allocated"
    if(.not.allocated(p%pdf)) stop "[check_pdf] PDF pdf array not allocated"
    if(.not.allocated(p%cdf)) stop "[check_pdf] PDF cdf array not allocated"
    if(p%n.ne.size(p%x))   stop "[check_pdf] PDF x array has incorrect size"
    if(p%n.ne.size(p%pdf)) stop "[check_pdf] PDF pdf array has incorrect size"
    if(p%n.ne.size(p%cdf)) stop "[check_pdf] PDF cdf array has incorrect size"
    do i=2,p%n
       if(.not.(p%x(i)>p%x(i-1))) stop "[check_pdf] PDF x array is not sorted"
    end do
    if(any(p%pdf < 0.)) stop "[check_pdf] PDF has negative probabilities"
    if(.not.p%normalized) stop "[check_pdf] PDF is not normalized"
  end subroutine check_pdf_cont_<T>

  subroutine find_cdf_cont_<T>(p)
    implicit none
    type(pdf_<T>),intent(inout) :: p
    integer :: i
    call check_pdf(p)
    if(p%log) then
       p%cdf = cumulative_integral_loglog(p%x,p%pdf)
    else
       p%cdf = cumulative_integral(p%x,p%pdf)
    end if
    p%cdf = p%cdf / p%cdf(p%n)
    if(.not.p%simple) then
       if(p%log) then
          allocate(p%b(p%n-1))
          allocate(p%r(p%n-1))
          do i=1,p%n-1
             p%b(i) = log10(p%pdf(i) / p%pdf(i+1)) / log10(p%x(i) / p%x(i+1))
             p%r(i) = (p%x(i+1) / p%x(i)) ** (p%b(i) + 1._dp)
          end do
       else
          allocate(p%a(p%n-1))
          allocate(p%b(p%n-1))
          allocate(p%rx(p%n-1))
          allocate(p%rc(p%n-1))
          do i=1,p%n-1
             p%a(i) = (p%pdf(i) - p%pdf(i+1)) / (p%x(i) - p%x(i+1))
             p%b(i) = p%pdf(i) - p%a(i) * p%x(i)
             p%rx(i) = p%x(i+1) / p%x(i)
             p%rc(i) = p%b(i) / p%a(i)
          end do
       end if
    end if
  end subroutine find_cdf_cont_<T>

  integer function sample_pdf_discrete_<T>(p)
    implicit none
    type(pdf_discrete_<T>) :: p
    integer :: j,jmin,jmax
    @T :: xi
    call random(xi)
    if(xi <= p%cdf(1)) then
       sample_pdf_discrete_<T> = 1
    else if(xi >= p%cdf(p%n)) then
       sample_pdf_discrete_<T> = p%n
    else
       jmin = 1
       jmax = p%n
       do
          j = (jmax + jmin) / 2
          if(xi > p%cdf(j)) then
             jmin = j
          else
             jmax = j
          end if
          if(jmax == jmin + 1) exit
       end do
       sample_pdf_discrete_<T> = jmax
    end if
  end function sample_pdf_discrete_<T>

  @T function sample_pdf_cont_<T>(p,xi_alt)
    implicit none
    type(pdf_<T>),intent(in) :: p
    @T,optional,intent(in) :: xi_alt
    @T :: xi
    integer :: i
    if(present(xi_alt)) then
       xi = xi_alt
    else
       call random(xi)
    end if
    if(xi <= p%cdf(1)) then
       sample_pdf_cont_<T> = p%x(1)
    else if(xi >= p%cdf(p%n)) then
       sample_pdf_cont_<T> = p%x(p%n)
    else
       if(p%simple) then
          if(p%log) then
             sample_pdf_cont_<T> = interp1d_linlog(p%cdf(:), p%x(:), xi)
          else
             sample_pdf_cont_<T> = interp1d(p%cdf(:), p%x(:), xi)
          end if
       else
          i = locate(p%cdf, xi)
          xi = (xi - p%cdf(i)) / (p%cdf(i+1) - p%cdf(i))
          if(p%log) then
             sample_pdf_cont_<T> = (xi * (p%r(i) - 1._dp) + 1._dp) ** (1._dp / (p%b(i) + 1._dp)) * p%x(i)
          else
             if(p%a(i)==0._dp) then
                sample_pdf_cont_<T> = xi * (p%x(i+1) - p%x(i)) + p%x(i)
             else if(p%x(i)==0._dp) then
                sample_pdf_cont_<T> = - p%rc(i) + sign(sqrt(p%rc(i) * p%rc(i) &
                     &                                      + xi * p%x(i+1) * p%x(i+1) &
                     &                                      + 2._<T> * p%rc(i) * xi * p%x(i+1)), p%a(i))
             else
                sample_pdf_cont_<T> = - p%rc(i) + sign(sqrt(p%rc(i) * p%rc(i) &
                     &                                      + p%x(i) * p%x(i) * (xi * (p%rx(i) * p%rx(i) - 1._<T>) + 1._<T>) &
                     &                                      + 2._<T> * p%rc(i) * p%x(i) * (xi * (p%rx(i) - 1._<T>) + 1._<T>)), p%a(i))
             end if
          end if
       end if
    end if
  end function sample_pdf_cont_<T>

  @T function sample_pdf_cont_log_<T>(p,xi_alt)
    implicit none
    type(pdf_<T>),intent(in) :: p
    @T,optional,intent(in) :: xi_alt
    @T :: xi
    if(present(xi_alt)) then
       xi = xi_alt
    else
       call random(xi)
    end if
    sample_pdf_cont_log_<T> = interp1d_loglog(p%cdf(:),p%x(:),xi)
  end function sample_pdf_cont_log_<T>

  @T function interpolate_pdf_cont_<T>(p, x, bounds_error, fill_value) result(prob)
    implicit none
    type(pdf_<T>),intent(in) :: p
    @T,intent(in) :: x
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    if(.not.p%normalized) stop "[interpolate_pdf] PDF is not normalized"
    if(p%log) then
       prob = interp1d_loglog(p%x, p%pdf, x, bounds_error, fill_value)
    else
       prob = interp1d(p%x, p%pdf, x, bounds_error, fill_value)
    end if
  end function interpolate_pdf_cont_<T>

  !!@END FOR

end module type_pdf


module ccpdata

  implicit none

  ! PARAMETERS

  ! Number of observations in order to build the correlation matrix
  integer, parameter :: NOBS = 5
  ! Sparsity rate
  real(8), parameter :: SPRATE = 1.0D-01
  ! Relative error for subroutine MVNDST
  real(8), parameter :: RELERR = 1.0D-04
  ! Absolute error for subroutine MVNDST
  real(8), parameter :: ABSERR = 1.0D-04

  ! COMMON ARRAYS

  integer, allocatable :: cA(:), pA(:)
  real(8), allocatable :: A(:), b(:), c(:), corr(:), mu(:)

  ! COMMON SCALARS

  ! Penalization term for the chance constraint
  real(8) :: PEN = 1.0D+01

  integer :: m, np
  real(8) :: plim

  ! PRIVATE SCALARS

  integer :: initial_seed
  real(8) :: epsfeas

  private :: initial_seed, epsfeas

contains

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

  subroutine set_epsfeas(ep)

    ! SCALAR ARGUMENTS
    real(8), intent(in) :: ep

    epsfeas = ep

  end subroutine set_epsfeas

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

  subroutine set_seed(is)

    ! This subroutine sets the initial seed. It is usefull for massive
    ! random tests.

    ! SCALAR ARGUMENTS
    integer :: is

    initial_seed = is

  end subroutine set_seed

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

  subroutine initialize(n, np_, mi, x, l, u, plim_)

    ! This subroutine randomly initializes the structure needed by the
    ! Chance Constrained Problem.

    implicit none

    ! SCALAR ARGUMENTS
    integer :: n, np_, mi
    real(8) :: plim_

    ! ARRAY ARGUMENTS
    real(8) :: l(n), u(n), x(n)

    intent(in ) :: n, np_, mi, plim_
    intent(out) :: l, u, x

    ! INTERFACES

    interface

       SUBROUTINE UNBIASED_CORRELATION( N, A, B, msg, lag, r, t, m)

         INTEGER, INTENT(IN)                :: N
         REAL(8), DIMENSION(N), INTENT(IN)  :: A
         REAL(8), DIMENSION(N), INTENT(IN)  :: B
         REAL(8), INTENT(IN)                :: msg
         INTEGER, INTENT(IN)                :: lag
         REAL(8), INTENT(OUT)               :: r
         REAL(8), INTENT(OUT)               :: t
         INTEGER, INTENT(OUT)               :: m

       END SUBROUTINE UNBIASED_CORRELATION

    end interface

    ! LOCAL SCALARS

    integer :: i, j, k, nover, nseed, pos
    real(8) :: pi, randnum, t, u1, u2

    ! LOCAL ARRAYS

    integer, allocatable :: seed(:)
    real(8), target, allocatable :: mObs(:,:)

    ! POINTERS

    real(8), pointer :: tmpA(:), tmpB(:)

    m  = mi

    np = np_

    plim = plim_

    ! Initialize the random structure

    call random_seed(SIZE=nseed)

    allocate(seed(nseed))

    do i = 1,nseed
       seed(i) = initial_seed
    end do

    call random_seed(PUT=seed)

    ! Initialize module objects

    allocate(b(m), c(n), corr((np - 1) * np / 2), mu(np), &
             mObs(np, np), A(n * m), pA(m + 1), cA(n * m))

    ! Randomly generates vector 'c'

    do i = 1, np

       call random_number(randnum)

       c(i) = 1.0D0 + 1.0D+01 * randnum

    end do

    do i = np + 1, n

       call random_number(randnum)

       c(i) = - 1.0D+01 + 2.0D+01 * randnum

    end do

    ! Randomly generates sparse matrix 'A' in vector form

    pA(1) = 1

    do i = 1, m

       pos = pA(i)

       do j = 1, n

          call random_number(randnum)

          if ( randnum .le. SPRATE ) then

             call random_number(A(pos))

             if ( j .le. np ) A(pos) = - abs(A(pos))

             cA(pos) = j

             pos = pos + 1

          end if

       end do

       pA(i + 1) = pos

    end do

    ! Randomly generates mean 'mu'

    do i = 1, np

       call random_number(randnum)

       mu(i) = 5.0D0 * randnum

    end do

    ! Randomly generates the initial guess, lower and upper bounds

    do i = 1, np

       x(i) = 0.0D0

       l(i) = mu(i)

       u(i) = 1.0D+20

    end do

    do i = np + 1, n

       call random_number(randnum)

       x(i) = - 1.0D+01 + 2.0D+01 * randnum

       l(i) = - 1.0D+01

       u(i) =   1.0D+01

    end do

    ! Generate feasible right hand side 'b'

    do i = 1, m

       b(i) = 0.0D0

       do j = pA(i), pA(i + 1) - 1

          b(i) = b(i) + x(cA(j)) * A(j)

       end do

    end do

    ! Randomly generates correlation matrix 'corr', which is
    ! simmetric, definite positive and has 1's in the diagonal (in
    ! vector form)

    call genRandHouseDP(np,mObs,0.0D0,1.0D+02)

    do j = 1, np

       do i = 1, j - 1

          pos = i + (j - 1) * (j - 2) / 2

          corr(pos) = mObs(i,j) / (sqrt(mObs(i,i)) * sqrt(mObs(j,j)))

          ! write(*,*) i, j, corr(pos)

       end do

    end do

!!$    pi  = acos(-1.0D0)
!!$
!!$    do j = 1, np
!!$
!!$       do i = 1, NOBS, 2
!!$
!!$          call random_number(u1)
!!$
!!$          call random_number(u2)
!!$
!!$          mObs(i,j) = sqrt(- 2.0D0 * log(u1)) * cos(2.0D0 * pi * u2)
!!$
!!$          if ( i + 1 .le. NOBS ) then
!!$
!!$             mObs(i + 1,j) = sqrt(- 2.0D0 * log(u1)) * sin(2.0D0 * pi * u2)
!!$
!!$          end if
!!$
!!$       end do
!!$
!!$    end do
!!$
!!$    do j = 1, np
!!$
!!$       tmpA => mObs(:,j)
!!$
!!$       do i = 1, j - 1
!!$
!!$          tmpB => mObs(:,i)
!!$
!!$          call unbiased_correlation(NOBS, tmpA, tmpB, 1.0D0, 0, &
!!$               corr(i + (j - 1) * (j - 2) / 2), t, nover)
!!$
!!$          !write(*,*) (tmpA(k), k = 1,NOBS)
!!$          write(*,*) i, j, corr(i + (j - 1) * (j - 2) / 2)
!!$
!!$       end do
!!$
!!$    end do

    deallocate(mObs, seed)

  end subroutine initialize

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

  subroutine genRandHouseDP(n,A,prob,magnitude)
    ! This subroutine generates a random symmetric matrix A with
    ! dimension n.
    !
    ! prob: is the probability of a eigenvalue to be very near to zero
    !
    ! magnitude: if is positive, defines the range of random
    ! values. If is negative, also defines this range, but the matrix
    ! has chance to be indefinite

    implicit none

    ! PARAMETERS
    real(8),parameter :: epsdiag = 1.0D-5

    ! ARRAY ARGUMENTS
    real(8) :: A(n,n)

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: prob,magnitude

    intent( in) :: prob,n,magnitude
    intent(out) :: A

    ! LOCAL SCALARS
    integer :: i,j,k
    real(8) :: rnumber

    ! LOCAL ARRAYS
    real(8) :: Q(n,n),d(n)

    call genHouseholderOrt(n,Q,magnitude)

    ! Generates a random diagonal matrix D and calculates Q * D * Q^t

    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       if (rnumber .lt. prob) then
          ! Semi-definite positiveness probability
          CALL RANDOM_NUMBER(rnumber)
          d(i) = (1.0D0 + rnumber) * epsdiag
       else if (magnitude .gt. 0.0D0) then
          ! Matrix is positive definite
          CALL RANDOM_NUMBER(rnumber)
          d(i) = epsdiag + magnitude * rnumber
       else
          ! Matrix is indefinite
          CALL RANDOM_NUMBER(rnumber)
          d(i) = - abs(magnitude) + 2.0D0 * abs(magnitude) * rnumber
       end if
    end do

    do j = 1,n
       do i = 1,n
          A(i,j) = 0.0D0
       end do
    end do

    do j = 1,n
       do i = 1,n
          do k = 1,n
             A(k,j) = A(k,j) + Q(k,i) * Q(j,i) * d(i)
          end do
       end do
    end do

  end subroutine genRandHouseDP

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

  subroutine genHouseholderOrt(n,Q,magnitude)

    ! This subroutine generates an randomly generated orthogonal
    ! Householder matrix:
    !
    ! I - 2 * (u * u^T) / (u^T * u)
    !
    ! and returns such matrix in Q

    implicit none

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: magnitude

    ! ARRAY ARGUMENTS
    real(8) :: Q(n,n)

    intent( in) :: n,magnitude
    intent(out) :: Q

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: rnumber,dp

    ! LOCAL ARRAYS
    real(8) :: u(n)

    dp = 0.0D0
    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       u(i) = - abs(magnitude) + 2.0D0 * abs(magnitude) * rnumber
       dp = dp + u(i) ** 2.0D0
    end do

    do j = 1,n
       do i = 1,n
          Q(i,j) = - 2.0D0 * u(i) * u(j) / dp
       end do
       Q(j,j) = Q(j,j) + 1.0D0
    end do

  end subroutine genHouseholderOrt

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

  subroutine destroy()

    deallocate(A, b, c, corr, mu, pA, cA)

  end subroutine destroy

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

  subroutine fromfile(n, np_, mi, x, l, u, plim_, filename)

    implicit none

    ! LOCAL SCALARS

    integer :: n, np_, mi
    real(8) :: plim_

    ! ARRAY ARGUMENTS

    real(8), allocatable :: l(:), u(:), x(:)
    character(200) :: filename

    ! LOCAL SCALARS

    integer :: i, j, lin, col, nnzA, pos
    real(8) :: val

    ! LOCAL ARRAYS

    real(8), allocatable :: T(:,:)

    intent(in ) :: filename
    intent(out) :: n, np_, mi, l, u, x, plim_

    open(99, FILE=filename)

    ! Initialize parameters

    read(99,*) n, mi, np_, plim_

    m = mi

    np = np_

    plim = plim_

    read(99,*) nnzA

    ! Initialize module objects

    allocate(b(m), c(n), corr((np - 1) * np / 2), mu(np), &
             T(m, n), A(nnzA), pA(m + 1), cA(nnzA), l(n), &
             u(n), x(n))

    ! Load sparse A

    T(:,:) = 0.0D0

    do i = 1,nnzA

       read(99, *) lin, col, val

       T(lin,col) = val

    end do

    pA(1) = 1

    do i = 1, m

       pos = pA(i)

       do j = 1, n

          if ( T(i,j) .ne. 0.0D0 ) then

             A(pos) = T(i,j)

             cA(pos) = j

             pos = pos + 1

          end if

       end do

       pA(i + 1) = pos

    end do

    ! Load b

    do i = 1, m

       read(99, *) b(i)

    end do

    ! Load l and u

    do i = 1, n

       read(99, *) l(i)

    end do

    do i = 1, n

       read(99, *) u(i)

    end do

    ! Load initial x

    do i = 1, n

       read(99, *) x(i)

    end do

    ! Load mu

    do i = 1, np

       read(99, *) mu(i)

    end do

    ! Load c

    do i = 1, n

       read(99, *) c(i)

    end do

    ! Load sigma

    do i = 1, (np * (np - 1) / 2)

       read(99, *) corr(i)

    end do

    close(99)

    deallocate(T)

  end subroutine fromfile

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

  subroutine tofile(n, np, mi, x, l, u, filename)

    implicit none

    ! SCALAR ARGUMENTS
    integer :: n, np, mi

    ! ARRAY ARGUMENTS
    real(8)       :: l(n), u(n), x(n)
    character(80) :: filename

    intent(in ) :: filename, n, np, mi, l, u, x

    ! LOCAL SCALARS
    integer :: i, j

    ! LOCAL ARRAYS
    real(8) :: tmpA(n)

    open(99, FILE=filename)

    write(99, FMT=010) n, np, mi

    do i = 1, mi

       do j = 1, n

          tmpA(j) = 0.0D0

       end do

       do j = pA(i), pA(i + 1) - 1

          tmpA(cA(j)) = A(j)

       end do

       do j = 1, n

          write(99,FMT=020) tmpA(j)

       end do

       write(99,*)

    end do

    write(99,*)

    close(99)

    ! NON-EXECUTABLE STATEMENTS

010 FORMAT(I5,1X,I5,1X,I5,/)
020 FORMAT(1P,E15.8)

  end subroutine tofile

end module ccpdata


program test9
  use UtilitiesM
  use SparseKit
  implicit none
  type(Sparse) :: identity, matrixA, matrixL
  integer :: n

  print'(A)', 'SparseKit Test'

  n = 4

  matrixA = sparse(nnz = 16, rows = 4)

  call matrixA%append( val =    4._rkind, row = 1, col = 1)
  call matrixA%append( val =  -30._rkind, row = 1, col = 2)
  call matrixA%append( val =   60._rkind, row = 1, col = 3)
  call matrixA%append( val =  -35._rkind, row = 1, col = 4)
  call matrixA%append( val =  -30._rkind, row = 2, col = 1)
  call matrixA%append( val =  300._rkind, row = 2, col = 2)
  call matrixA%append( val = -675._rkind, row = 2, col = 3)
  call matrixA%append( val =  420._rkind, row = 2, col = 4)
  call matrixA%append( val =   60._rkind, row = 3, col = 1)
  call matrixA%append( val = -675._rkind, row = 3, col = 2)
  call matrixA%append( val = 1620._rkind, row = 3, col = 3)
  call matrixA%append( val =-1050._rkind, row = 3, col = 4)
  call matrixa%append( val =  -35._rkind, row = 4, col = 1)
  call matrixA%append( val =  420._rkind, row = 4, col = 2)
  call matrixA%append( val =-1050._rkind, row = 4, col = 3)
  call matrixA%append( val =  700._rkind, row = 4, col = 4)

  call matrixA%makeCRS

  print'(/,A)', 'Matrix A'
  call matrixA%printAll

  identity = id(n)

  print'(/,A)', 'Identity'
  call identity%printAll

  matrixL = transpose(matrixA)
  print'(/,A)','Matrix L'
  call matrixL%printAll

end program test9


* This file contains the following subroutines, related to interpolations
* of input data, addition of points to arrays, and zeroing of arrays:
*     inter1
*     inter2
*     inter3
*     inter4
*     addpnt
*     zero1
*     zero2
*=============================================================================*

      SUBROUTINE inter1(ng,xg,yg, n,x,y)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Map input data given on single, discrete points, onto a discrete target  =*
*=  grid.                                                                    =*
*=  The original input data are given on single, discrete points of an       =*
*=  arbitrary grid and are being linearly interpolated onto a specified      =*
*=  discrete target grid.  A typical example would be the re-gridding of a   =*
*=  given data set for the vertical temperature profile to match the speci-  =*
*=  fied altitude grid.                                                      =*
*=  Some caution should be used near the end points of the grids.  If the    =*
*=  input data set does not span the range of the target grid, the remaining =*
*=  points will be set to zero, as extrapolation is not permitted.           =*
*=  If the input data does not encompass the target grid, use ADDPNT to      =*
*=  expand the input array.                                                  =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NG  - INTEGER, number of points in the target grid                    (I)=*
*=  XG  - REAL, target grid (e.g. altitude grid)                          (I)=*
*=  YG  - REAL, y-data re-gridded onto XG                                 (O)=*
*=  N   - INTEGER, number of points in the input data set                 (I)=*
*=  X   - REAL, grid on which input data are defined                      (I)=*
*=  Y   - REAL, input y-data                                              (I)=*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:
      INTEGER n, ng
      REAL xg(ng)
      REAL x(n), y(n)

* output:
      REAL yg(ng)

* local:
      REAL slope
      INTEGER jsave, i, j
*_______________________________________________________________________

      jsave = 1
      DO 20, i = 1, ng
         yg(i) = 0.
         j = jsave
   10    CONTINUE
            IF ((x(j) .GT. xg(i)) .OR. (xg(i) .GE. x(j+1))) THEN
               j = j+1
               IF (j .LE. n-1) GOTO 10
*        ---- end of loop 10 ----
            ELSE
               slope = (y(j+1)-y(j)) / (x(j+1)-x(j))
               yg(i) = y(j) + slope * (xg(i) - x(j))
               jsave = j
             ENDIF
   20 CONTINUE
*_______________________________________________________________________

      RETURN
      END

*=============================================================================*

      SUBROUTINE inter2(ng,xg,yg,n,x,y,ierr)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Map input data given on single, discrete points onto a set of target     =*
*=  bins.                                                                    =*
*=  The original input data are given on single, discrete points of an       =*
*=  arbitrary grid and are being linearly interpolated onto a specified set  =*
*=  of target bins.  In general, this is the case for most of the weighting  =*
*=  functions (action spectra, molecular cross section, and quantum yield    =*
*=  data), which have to be matched onto the specified wavelength intervals. =*
*=  The average value in each target bin is found by averaging the trapezoi- =*
*=  dal area underneath the input data curve (constructed by linearly connec-=*
*=  ting the discrete input values).                                         =*
*=  Some caution should be used near the endpoints of the grids.  If the     =*
*=  input data set does not span the range of the target grid, an error      =*
*=  message is printed and the execution is stopped, as extrapolation of the =*
*=  data is not permitted.                                                   =*
*=  If the input data does not encompass the target grid, use ADDPNT to      =*
*=  expand the input array.                                                  =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NG  - INTEGER, number of bins + 1 in the target grid                  (I)=*
*=  XG  - REAL, target grid (e.g., wavelength grid);  bin i is defined    (I)=*
*=        as [XG(i),XG(i+1)] (i = 1..NG-1)                                   =*
*=  YG  - REAL, y-data re-gridded onto XG, YG(i) specifies the value for  (O)=*
*=        bin i (i = 1..NG-1)                                                =*
*=  N   - INTEGER, number of points in input grid                         (I)=*
*=  X   - REAL, grid on which input data are defined                      (I)=*
*=  Y   - REAL, input y-data                                              (I)=*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:
      INTEGER ng, n
      REAL x(n), y(n), xg(ng)

* output:
      REAL yg(ng)

* local:
      REAL area, xgl, xgu
      REAL darea, slope
      REAL a1, a2, b1, b2
      INTEGER ngintv
      INTEGER i, k, jstart
      INTEGER ierr
*_______________________________________________________________________

      ierr = 0

*  test for correct ordering of data, by increasing value of x

      DO 10, i = 2, n
         IF (x(i) .LE. x(i-1)) THEN
            ierr = 1
            WRITE(*,*)'data not sorted'
            write(*,*) x
            RETURN
         ENDIF
   10 CONTINUE

      DO i = 2, ng
        IF (xg(i) .LE. xg(i-1)) THEN
           ierr = 2
          WRITE(0,*) '>>> ERROR (inter2) <<<  xg-grid not sorted!'
          write(*,*) xg
          RETURN
        ENDIF
      ENDDO

* check for xg-values outside the x-range

      IF ( (x(1) .GT. xg(1)) .OR. (x(n) .LT. xg(ng)) ) THEN
          WRITE(0,*) '>>> ERROR (inter2) <<<  Data do not span '//
     >               'grid.  '
          WRITE(0,*) '                        Use ADDPNT to '//
     >               'expand data and re-run.'
          STOP
      ENDIF

*  find the integral of each grid interval and use this to
*  calculate the average y value for the interval
*  xgl and xgu are the lower and upper limits of the grid interval

      jstart = 1
      ngintv = ng - 1
      DO 50, i = 1,ngintv

* initalize:

            area = 0.0
            xgl = xg(i)
            xgu = xg(i+1)

*  discard data before the first grid interval and after the
*  last grid interval
*  for internal grid intervals, start calculating area by interpolating
*  between the last point which lies in the previous interval and the
*  first point inside the current interval

            k = jstart
            IF (k .LE. n-1) THEN

*  if both points are before the first grid, go to the next point
   30         CONTINUE
                IF (x(k+1) .LE. xgl) THEN
                   jstart = k - 1
                   k = k+1
                   IF (k .LE. n-1) GO TO 30
                ENDIF

*  if the last point is beyond the end of the grid, complete and go to the next
*  grid
   40         CONTINUE
                 IF ((k .LE. n-1) .AND. (x(k) .LT. xgu)) THEN

                    jstart = k-1

* compute x-coordinates of increment

                    a1 = MAX(x(k),xgl)
                    a2 = MIN(x(k+1),xgu)

*  if points coincide, contribution is zero

                    IF (x(k+1).EQ.x(k)) THEN
                       darea = 0.e0
                    ELSE
                       slope = (y(k+1) - y(k))/(x(k+1) - x(k))
                       b1 = y(k) + slope*(a1 - x(k))
                       b2 = y(k) + slope*(a2 - x(k))
                       darea = (a2 - a1)*(b2 + b1)/2.
                    ENDIF

*  find the area under the trapezoid from a1 to a2

                    area = area + darea

* go to next point

                    k = k+1
                    GO TO 40

                ENDIF

            ENDIF

*  calculate the average y after summing the areas in the interval
            yg(i) = area/(xgu - xgl)

   50 CONTINUE
*_______________________________________________________________________

      RETURN
      END

*=============================================================================*

      SUBROUTINE inter3(ng,xg,yg, n,x,y, FoldIn)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Map input data given on a set of bins onto a different set of target     =*
*=  bins.                                                                    =*
*=  The input data are given on a set of bins (representing the integral     =*
*=  of the input quantity over the range of each bin) and are being matched  =*
*=  onto another set of bins (target grid).  A typical example would be an   =*
*=  input data set spcifying the extra-terrestrial flux on wavelength inter- =*
*=  vals, that has to be matched onto the working wavelength grid.           =*
*=  The resulting area in a given bin of the target grid is calculated by    =*
*=  simply adding all fractional areas of the input data that cover that     =*
*=  particular target bin.                                                   =*
*=  Some caution should be used near the endpoints of the grids.  If the     =*
*=  input data do not span the full range of the target grid, the area in    =*
*=  the "missing" bins will be assumed to be zero.  If the input data extend =*
*=  beyond the upper limit of the target grid, the user has the option to    =*
*=  integrate the "overhang" data and fold the remaining area back into the  =*
*=  last target bin.  Using this option is recommended when re-gridding      =*
*=  vertical profiles that directly affect the total optical depth of the    =*
*=  model atmosphere.                                                        =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NG     - INTEGER, number of bins + 1 in the target grid               (I)=*
*=  XG     - REAL, target grid (e.g. working wavelength grid);  bin i     (I)=*
*=           is defined as [XG(i),XG(i+1)] (i = 1..NG-1)                     =*
*=  YG     - REAL, y-data re-gridded onto XG;  YG(i) specifies the        (O)=*
*=           y-value for bin i (i = 1..NG-1)                                 =*
*=  N      - INTEGER, number of bins + 1 in the input grid                (I)=*
*=  X      - REAL, input grid (e.g. data wavelength grid);  bin i is      (I)=*
*=           defined as [X(i),X(i+1)] (i = 1..N-1)                           =*
*=  Y      - REAL, input y-data on grid X;  Y(i) specifies the            (I)=*
*=           y-value for bin i (i = 1..N-1)                                  =*
*=  FoldIn - Switch for folding option of "overhang" data                 (I)=*
*=           FoldIn = 0 -> No folding of "overhang" data                     =*
*=           FoldIn = 1 -> Integerate "overhang" data and fold back into     =*
*=                         last target bin                                   =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:
      INTEGER n, ng
      REAL xg(ng)
      REAL x(n), y(n)

      INTEGER FoldIn

* output:
      REAL yg(ng)

* local:
      REAL a1, a2, sum
      REAL tail
      INTEGER jstart, i, j, k
*_______________________________________________________________________

* check whether flag given is legal
      IF ((FoldIn .NE. 0) .AND. (FoldIn .NE. 1)) THEN
         WRITE(0,*) '>>> ERROR (inter3) <<<  Value for FOLDIN invalid. '
         WRITE(0,*) '                        Must be 0 or 1'
         STOP
      ENDIF

* do interpolation

      jstart = 1

      DO 30, i = 1, ng - 1

         yg(i) = 0.
         sum = 0.
         j = jstart

         IF (j .LE. n-1) THEN

   20      CONTINUE

             IF (x(j+1) .LT. xg(i)) THEN
                jstart = j
                j = j+1
                IF (j .LE. n-1) GO TO 20
             ENDIF

   25      CONTINUE

           IF ((x(j) .LE. xg(i+1)) .AND. (j .LE. n-1)) THEN

              a1 = AMAX1(x(j),xg(i))
              a2 = AMIN1(x(j+1),xg(i+1))

              sum = sum + y(j) * (a2-a1)/(x(j+1)-x(j))
              j = j+1
              GO TO 25

           ENDIF

           yg(i) = sum

        ENDIF

   30 CONTINUE

* if wanted, integrate data "overhang" and fold back into last bin

      IF (FoldIn .EQ. 1) THEN

         j = j-1
         a1 = xg(ng)            ! upper limit of last interpolated bin
         a2 = x(j+1)            ! upper limit of last input bin considered

*        do folding only if grids don't match up and there is more input
         IF ((a2 .GT. a1) .OR. (j+1 .LT. n)) THEN
            tail = y(j) * (a2-a1)/(x(j+1)-x(j))
            DO k = j+1, n-1
               tail = tail + y(k) * (x(k+1)-x(k))
            ENDDO
            yg(ng-1) = yg(ng-1) + tail
         ENDIF

      ENDIF
*_______________________________________________________________________

      RETURN
      END

*=============================================================================*

      SUBROUTINE inter4(ng,xg,yg, n,x,y, FoldIn)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Map input data given on a set of bins onto a different set of target     =*
*=  bins.                                                                    =*
*=  The input data are given on a set of bins (representing the integral     =*
*=  of the input quantity over the range of each bin) and are being matched  =*
*=  onto another set of bins (target grid).  A typical example would be an   =*
*=  input data set spcifying the extra-terrestrial flux on wavelength inter- =*
*=  vals, that has to be matched onto the working wavelength grid.           =*
*=  The resulting area in a given bin of the target grid is calculated by    =*
*=  simply adding all fractional areas of the input data that cover that     =*
*=  particular target bin.                                                   =*
*=  Some caution should be used near the endpoints of the grids.  If the     =*
*=  input data do not span the full range of the target grid, the area in    =*
*=  the "missing" bins will be assumed to be zero.  If the input data extend =*
*=  beyond the upper limit of the target grid, the user has the option to    =*
*=  integrate the "overhang" data and fold the remaining area back into the  =*
*=  last target bin.  Using this option is recommended when re-gridding      =*
*=  vertical profiles that directly affect the total optical depth of the    =*
*=  model atmosphere.                                                        =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NG     - INTEGER, number of bins + 1 in the target grid               (I)=*
*=  XG     - REAL, target grid (e.g. working wavelength grid);  bin i     (I)=*
*=           is defined as [XG(i),XG(i+1)] (i = 1..NG-1)                     =*
*=  YG     - REAL, y-data re-gridded onto XG;  YG(i) specifies the        (O)=*
*=           y-value for bin i (i = 1..NG-1)                                 =*
*=  N      - INTEGER, number of bins + 1 in the input grid                (I)=*
*=  X      - REAL, input grid (e.g. data wavelength grid);  bin i is      (I)=*
*=           defined as [X(i),X(i+1)] (i = 1..N-1)                           =*
*=  Y      - REAL, input y-data on grid X;  Y(i) specifies the            (I)=*
*=           y-value for bin i (i = 1..N-1)                                  =*
*=  FoldIn - Switch for folding option of "overhang" data                 (I)=*
*=           FoldIn = 0 -> No folding of "overhang" data                     =*
*=           FoldIn = 1 -> Integerate "overhang" data and fold back into     =*
*=                         last target bin                                   =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:
      INTEGER n, ng
      REAL xg(ng)
      REAL x(n), y(n)

      INTEGER FoldIn

* output:
      REAL yg(ng)

* local:
      REAL a1, a2, sum
      REAL tail
      INTEGER jstart, i, j, k
*_______________________________________________________________________

* check whether flag given is legal
      IF ((FoldIn .NE. 0) .AND. (FoldIn .NE. 1)) THEN
         WRITE(0,*) '>>> ERROR (inter3) <<<  Value for FOLDIN invalid. '
         WRITE(0,*) '                        Must be 0 or 1'
         STOP
      ENDIF

* do interpolation

      jstart = 1

      DO 30, i = 1, ng - 1

         yg(i) = 0.
         sum = 0.
         j = jstart

         IF (j .LE. n-1) THEN

   20      CONTINUE

             IF (x(j+1) .LT. xg(i)) THEN
                jstart = j
                j = j+1
                IF (j .LE. n-1) GO TO 20
             ENDIF

   25      CONTINUE

           IF ((x(j) .LE. xg(i+1)) .AND. (j .LE. n-1)) THEN

              a1 = AMAX1(x(j),xg(i))
              a2 = AMIN1(x(j+1),xg(i+1))

              sum = sum + y(j) * (a2-a1)

              j = j+1
              GO TO 25

           ENDIF

           yg(i) = sum /(xg(i+1)-xg(i))

        ENDIF

 30   CONTINUE

* if wanted, integrate data "overhang" and fold back into last bin

      IF (FoldIn .EQ. 1) THEN

         j = j-1
         a1 = xg(ng)     ! upper limit of last interpolated bin
         a2 = x(j+1)     ! upper limit of last input bin considered

*        do folding only if grids don't match up and there is more input
         IF ((a2 .GT. a1) .OR. (j+1 .LT. n)) THEN
           tail = y(j) * (a2-a1)/(x(j+1)-x(j))
           DO k = j+1, n-1
              tail = tail + y(k) * (x(k+1)-x(k))
           ENDDO
           yg(ng-1) = yg(ng-1) + tail
         ENDIF

      ENDIF
*_______________________________________________________________________

      RETURN
      END

*=============================================================================*

      SUBROUTINE addpnt ( x, y, ld, n, xnew, ynew )

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Add a point <xnew,ynew> to a set of data pairs <x,y>.  x must be in      =*
*=  ascending order                                                          =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  X    - REAL vector of length LD, x-coordinates                       (IO)=*
*=  Y    - REAL vector of length LD, y-values                            (IO)=*
*=  LD   - INTEGER, dimension of X, Y exactly as declared in the calling  (I)=*
*=         program                                                           =*
*=  N    - INTEGER, number of elements in X, Y.  On entry, it must be:   (IO)=*
*=         N < LD.  On exit, N is incremented by 1.                          =*
*=  XNEW - REAL, x-coordinate at which point is to be added               (I)=*
*=  YNEW - REAL, y-value of point to be added                             (I)=*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* calling parameters

      INTEGER ld, n
      REAL x(ld), y(ld)
      REAL xnew, ynew

* local variables

      INTEGER insert
      INTEGER i

*-----------------------------------------------------------------------

* check n<ld to make sure x will hold another point

      IF (n .GE. ld) THEN
         WRITE(0,*) '>>> ERROR (ADDPNT) <<<  Cannot expand array '
         WRITE(0,*) '                        All elements used.'
         STOP
      ENDIF

      insert = 1
      i = 2

* check whether x is already sorted.
* also, use this loop to find the point at which xnew needs to be inserted
* into vector x, if x is sorted.

 10   CONTINUE
      IF (i .LT. n) THEN

        IF (x(i) .LT. x(i-1)) THEN
           WRITE(0,*) '>>> ERROR (ADDPNT) <<<  x-data must be '//
     >                'in ascending order!'
           STOP
        ELSE
Csm 21 April 2016, correct:
C           IF (xnew .GT. x(i)) insert = i + 1
           IF (xnew .GT. x(i-1)) insert = i
        ENDIF
        i = i+1
        GOTO 10
      ENDIF

* if <xnew,ynew> needs to be appended at the end, just do so,
* otherwise, insert <xnew,ynew> at position INSERT

      IF ( xnew .GT. x(n) ) THEN

         x(n+1) = xnew
         y(n+1) = ynew

      ELSE

* shift all existing points one index up

         DO i = n, insert, -1
           x(i+1) = x(i)
           y(i+1) = y(i)
         ENDDO

* insert new point

         x(insert) = xnew
         y(insert) = ynew

      ENDIF

* increase total number of elements in x, y

      n = n+1

      END

*=============================================================================*

      SUBROUTINE zero1(x,m)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Initialize all elements of a floating point vector with zero.            =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  X  - REAL, vector to be initialized                                   (O)=*
*=  M  - INTEGER, number of elements in X                                 (I)=*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INTEGER i, m
      REAL x(m)
      DO 1 i = 1, m
         x(i) = 0.
 1    CONTINUE
      RETURN
      END

*=============================================================================*

      SUBROUTINE zero2(x,m,n)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Initialize all elements of a 2D floating point array with zero.          =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  X  - REAL, array to be initialized                                    (O)=*
*=  M  - INTEGER, number of elements along the first dimension of X,      (I)=*
*=       exactly as specified in the calling program                         =*
*=  N  - INTEGER, number of elements along the second dimension of X,     (I)=*
*=       exactly as specified in the calling program                         =*
*-----------------------------------------------------------------------------*

      IMPLICIT none

* m,n : dimensions of x, exactly as specified in the calling program

      INTEGER i, j, m, n
      REAL x(m,n)
      DO 1 j = 1, n
         DO 2 i = 1, m
            x(i,j) = 0.
 2       CONTINUE
 1    CONTINUE
      RETURN
      END


module modmyprecond
 use iso_fortran_env
 !$ use omp_lib
#if (COARRAY==1)
 use modprecond,only:gen_precond
#endif
 implicit none
 private
 public::arrayprecond

#if (COARRAY==1)
 type,extends(gen_precond)::arrayprecond
#else
 type::arrayprecond
#endif
  integer(kind=int32)::dim1
  real(kind=real64),allocatable::array1(:)
  real(kind=real64),allocatable::array2(:)
 contains
  procedure,public::solve
 end type

contains

!SOLVE
subroutine solve(this,x,y)
 !solve this*x=y, by doing x=inv(this)*y
 class(arrayprecond),intent(inout)::this
 real(kind=real64),intent(out)::x(:)
 real(kind=real64),intent(inout)::y(:)

 integer(kind=int32)::i
 integer(kind=int32)::iter=1
 logical,save::lnotinverse1=.true.
 logical,save::lnotinverse2=.true.

 if(iter.eq.1)then
  if(lnotinverse1)then
   call inversediag(this%dim1,this%array1)
   lnotinverse1=.false.
  endif
  call solvediag(this%dim1,this%array1,x,y)
  iter=2
 elseif(iter.eq.2)then
  if(lnotinverse2)then
   call inversediag(this%dim1,this%array2)
   lnotinverse2=.false.
  endif
  call solvediag(this%dim1,this%array2,x,y)
  iter=1
 endif

end subroutine

subroutine inversediag(dim1,array)
 integer(kind=int32),intent(in)::dim1
 real(kind=real64),intent(inout)::array(:)

 integer(kind=int32)::i

 do i=1,dim1
  if(array(i).ne.0_real64)array(i)=1._real64/array(i)
 enddo

end subroutine

subroutine solvediag(dim1,array,x,y)
 integer(kind=int32),intent(in)::dim1
 real(kind=real64),intent(inout)::array(:)
 real(kind=real64),intent(inout)::y(:)
 real(kind=real64),intent(out)::x(:)

 integer(kind=int32)::i

 do i=1,dim1
  x(i)=array(i)*y(i)
 enddo

end subroutine

end module


module SETTINGS
! Description:
!    Settings for Thalassa.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!    180531: Add THALASSA version.
!    180608: Add F107 flag.
!    190113: add Moon collision flag.
!
! ==============================================================================

! MODULES
use KINDS, only: dk

implicit none
! Settings file id and path
integer,parameter      ::  id_set = 13
character(len=4096)    ::  input_path
! Physical model
integer  ::  insgrav            ! Non-spherical gravity field flag.
integer  ::  isun               ! 0 = no Sun perturbation, >1 otherwise.
integer  ::  imoon              ! 0 = no Moon perturbation, >1 otherwise.
integer  ::  idrag              ! 0 = no atmospheric drag, 1 = Wertz model, 2 = US76 (PATRIUS), 3 = J77 (Carrara - INPE), 4 = NRLMSISE-00 (Picone - NRL)
integer  ::  iF107              ! 0 = constant F10.7 flux, 1 = variable F10.7 flux
integer  ::  iSRP               ! 0 = no SRP, 1 = otherwise.
integer  ::  iephem             ! Ephemerides source. 1 = DE431 ephemerides. 2 = Simpl. Meeus & Brown
integer  ::  gdeg,gord          ! Gravitational potential - maximum degree and order
integer  ::  Mord,Sord          ! Order of the Legendre expansion for the Moon and the Sun
! Integrator settings
integer  ::  mxstep             ! Max. number of integration/output steps.
real(dk) ::  tol                ! Integrator tolerance.
integer  ::  imcoll             ! 0 = do not check for collisions with the Moon, 1 = otherwise.
! Equations of motion settings
integer  ::  eqs                ! Equations of motion type. 1 = Cowell,
!                                 2 = EDromo(t), 3 = EDromo(c), 4 = EDromo(l)
! Output settings
character(len=512)  ::  outpath
integer  ::  verb

! THALASSA version
character(len=20),parameter   ::  THALASSA_ver = 'v1.2'

contains

subroutine READ_SETTINGS(tspan,tstep)
! Description:
!    Reads the settings file.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!     180608: add iF107 flag.
!     190113: add Moon collision flag.
!
! ==============================================================================

implicit none
real(dk),intent(out) ::  tspan,tstep
integer,parameter    ::  hlines = 13  ! <- Check this when modifying input.txt
integer  :: i
character(len=4096)  ::  dummy
real(dk)  ::  rmxstep

! Open and skip header lines
open(unit=id_set,file=adjustl(trim(input_path)),status='old',action='read')
read(id_set,'(a)') (dummy, i = 1,hlines)

read(id_set,'(a11,i3)') dummy, insgrav
read(id_set,'(a11,i3)') dummy, isun
read(id_set,'(a11,i3)') dummy, imoon
read(id_set,'(a11,i3)') dummy, idrag
read(id_set,'(a11,i3)') dummy, iF107
read(id_set,'(a11,i3)') dummy, iSRP
read(id_set,'(a11,i3)') dummy, iephem
read(id_set,'(a11,i3)') dummy, gdeg
read(id_set,'(a11,i3,7(/))') dummy, gord
read(id_set,'(a11,e22.15)') dummy, tol
read(id_set,'(a11,e22.15)') dummy, tspan
read(id_set,'(a11,e22.15)') dummy, tstep
read(id_set,'(a11,e10.1)') dummy, rmxstep
read(id_set,'(a11,i3,5(/))') dummy, imcoll
read(id_set,'(a11,i3,4(/))') dummy, eqs
read(id_set,'(a11,i3)') dummy, verb
read(id_set,'(a4,a)') dummy,outpath

close(id_set)

mxstep = int(rmxstep)

! If either of isun and imoon > 1, interpret it as the order of the Legendre expansion
Sord = isun
Mord = imoon

end subroutine READ_SETTINGS

end module SETTINGS


! { dg-do run }
! { dg-options "-fno-range-check" }
! PR fortran/32083
!
! Test transfers of +Inf and -Inf
! Testcase contributed by Jos de Kloe <kloedej@knmi.nl>
!

PROGRAM TestInfinite
  IMPLICIT NONE
  integer, parameter :: i8_ = Selected_Int_Kind(18)  ! = integer*8
  integer, parameter :: r8_ = Selected_Real_Kind(15,307)  ! = real*8

  integer(i8_), parameter :: bit_pattern_PosInf_i8_p = 9218868437227405312_i8_
  integer(i8_), parameter :: bit_pattern_NegInf_i8_p = -4503599627370496_i8_

  integer(i8_) :: bit_pattern_PosInf_i8 = 9218868437227405312_i8_
  integer(i8_) :: bit_pattern_NegInf_i8 = -4503599627370496_i8_

  integer(i8_) :: bit_pattern_PosInf_i8_hex
  integer(i8_) :: bit_pattern_NegInf_i8_hex

  integer(i8_) :: i
  real(r8_)    :: r

  data bit_pattern_PosInf_i8_hex /z'7FF0000000000000'/
  !data bit_pattern_NegInf_i8_hex /z'FFF0000000000000'/
  ! not portable, replaced by:
  bit_pattern_NegInf_i8_hex = ibset(bit_pattern_PosInf_i8_hex,63)

  if (bit_pattern_NegInf_i8_hex /= bit_pattern_NegInf_i8) STOP 1
  if (bit_pattern_PosInf_i8_hex /= bit_pattern_PosInf_i8) STOP 2

  r = transfer(bit_pattern_PosInf_i8,r)
  if (r /= 1.0_r8_/0.0_r8_) STOP 3
  i = transfer(r,i)
  if (bit_pattern_PosInf_i8 /= i) STOP 4

  r = transfer(bit_pattern_NegInf_i8,r)
  if (r /= -1.0_r8_/0.0_r8_) STOP 5
  i = transfer(r,i)
  if (bit_pattern_NegInf_i8 /= i) STOP 6

  r = transfer(bit_pattern_PosInf_i8_p,r)
  if (r /= 1.0_r8_/0.0_r8_) STOP 7
  i = transfer(r,i)
  if (bit_pattern_PosInf_i8_p /= i) STOP 8

  r = transfer(bit_pattern_NegInf_i8_p,r)
  if (r /= -1.0_r8_/0.0_r8_) STOP 9
  i = transfer(r,i)
  if (bit_pattern_NegInf_i8_p /= i) STOP 10
END PROGRAM TestInfinite


*DECK ELMBAK
      SUBROUTINE ELMBAK (NM, LOW, IGH, A, INT, M, Z)
C***BEGIN PROLOGUE  ELMBAK
C***PURPOSE  Form the eigenvectors of a real general matrix from the
C            eigenvectors of the upper Hessenberg matrix output from
C            ELMHES.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (ELMBAK-S, COMBAK-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure ELMBAK,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     This subroutine forms the eigenvectors of a REAL GENERAL
C     matrix by back transforming those of the corresponding
C     upper Hessenberg matrix determined by  ELMHES.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix.
C
C        A contains the multipliers which were used in the reduction
C          by  ELMHES  in its lower triangle below the subdiagonal.
C          A is a two-dimensional REAL array, dimensioned A(NM,IGH).
C
C        INT contains information on the rows and columns interchanged
C          in the reduction by  ELMHES.  Only elements LOW through IGH
C          are used.  INT is a one-dimensional INTEGER array,
C          dimensioned INT(IGH).
C
C        M is the number of columns of Z to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the real and imaginary parts of the eigenvectors
C          to be back transformed in its first M columns.  Z is a
C          two-dimensional REAL array, dimensioned Z(NM,M).
C
C     On OUTPUT
C
C        Z contains the real and imaginary parts of the transformed
C          eigenvectors in its first M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ELMBAK
C
      INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
      REAL A(NM,*),Z(NM,*)
      REAL X
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  ELMBAK
      IF (M .EQ. 0) GO TO 200
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 140 MM = KP1, LA
         MP = LOW + IGH - MM
         MP1 = MP + 1
C
         DO 110 I = MP1, IGH
            X = A(I,MP-1)
            IF (X .EQ. 0.0E0) GO TO 110
C
            DO 100 J = 1, M
  100       Z(I,J) = Z(I,J) + X * Z(MP,J)
C
  110    CONTINUE
C
         I = INT(MP)
         IF (I .EQ. MP) GO TO 140
C
         DO 130 J = 1, M
            X = Z(I,J)
            Z(I,J) = Z(MP,J)
            Z(MP,J) = X
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END