MODULE tslib

CONTAINS

FUNCTION INDX(ii,jj,np)
  ! Returns the 'lower triangular' index for an np x np array.
  !
  ! indx is equivalent to:
  ! indx=0
  ! DO jj=1,np
  !   DO ii=jj,np
  !     indx=indx+1
  !     <SOME CODE>
  !   ENDDO
  ! ENDDO
  integer :: ii,jj
  integer :: np
  integer :: indx
  IF (jj>ii) THEN
     ! THIS SWAPS ii AND jj VARIABLES WITHOUT A TEMPORARY VARIABLE.
     ii=ii+jj
     jj=ii-jj
     ii=ii-jj
  ENDIF
  indx=(jj-1)*np+ii-(jj*(jj-1))/2
  RETURN
END FUNCTION INDX

FUNCTION r_arr(y,z,ny,nz)
  integer,intent(in) :: ny,nz
  real,intent(in)    :: y(ny),z(nz)
  integer            :: ii,jj
  real,dimension(ny*nz*(ny*nz+1)/2) :: r_arr
  integer            :: iz(nz*ny),iy(nz*ny)

  DO ii=1,ny*nz
     ! The spatial (z,y) indexes are in C order.
     ! This needs to be consistent with the reshape, sub2ind, ind2sub,
     ! and flatten methods in the tsGrid class.
     iy(ii)=mod(ii-1,ny)+1
     iz(ii)=(ii-1)/ny+1
!!$     ! Fortran order
!!$     iz(ii)=mod(ii-1,nz)+1
!!$     iy(ii)=(ii-1)/nz+1
  ENDDO

  DO jj=1,ny*nz ! The packmat (Sij) needs to be in column order for lapack's SPPTRF.
     DO ii=jj,ny*nz
        ind=indx(ii,jj,ny*nz)
        IF (ii==jj) THEN
           r_arr(ind)=0
        ELSE
           r_arr(ind)=(y( iy(ii) )-y( iy(jj) ))**2+( z(iz(ii)) - z( iz(jj) ))**2
        ENDIF
     ENDDO
  ENDDO
  r_arr=SQRT(r_arr)
  RETURN

END FUNCTION r_arr

subroutine nonIECcoh(phr,f,y,z,u,coef_a,coef_b,coefExp,ncore,nf,ny,nz)
  use omp_lib
  implicit none
  complex,intent(inout) :: phr(ny*nz,nf)
  real,intent(in)     ::  f(nf), y(ny), z(nz), u(ny*nz)
  real,intent(in)     :: coef_a,coef_b,coefExp
  integer, intent(in) :: ncore, nf, ny, nz
  complex             :: phr_tmp(ny*nz,nf)
  integer             :: ii, jj, ff, ind, stat, ntot, np!, jj1!, ind2
  integer             :: iz
  real(4),allocatable  :: work(:), um(:), r(:), tmpz(:)
  real(4)                :: tmp_b,ftmp(nf)
  np=ny*nz
  ntot=(np*(np+1))/2
  phr_tmp=phr
  phr(:,:)=0

  allocate(r(ntot))
  allocate(tmpz(ntot))
  allocate(um(ntot))
  allocate(work(ntot))
  iz=0

  IF (ncore > 0) THEN
     CALL OMP_SET_NUM_THREADS(ncore)
  ENDIF

  r=r_arr(y,z,ny,nz)
  ftmp=f

  DO ii=1,np
     DO jj=1,ii
        ind=indx(ii,jj,np)
        um(ind)=(u(ii)+u(jj))/2
!!$        tmpz(ind)=(z(mod(ii-1,nz)+1)+z(mod(jj-1,nz)+1))/2 ! Fortran ordering of space
        tmpz(ind)=(z((ii-1)/ny+1)+z((jj-1)/ny+1))/2 ! C ordering of spatial vars (matches O-TurbSim)
     ENDDO
  ENDDO

  tmp_b=coef_b**2
  IF (coefExp/=0) THEN
     tmpz=-1.0*coef_a*r*(r/tmpz)**coefExp
  ELSE
     tmpz=-1.0*coef_a*r
  ENDIF

  !$omp parallel private(ii, jj, ff, work, stat) default(shared)
  !$omp do schedule( dynamic )
  DO ff=1,nf
     ! Calculate the coherence for this spectral model.
     IF (tmp_b==0) THEN
        work=EXP(tmpz*f(ff)/um)
     ELSE
        work=EXP(tmpz*SQRT((f(ff)/um)**2+tmp_b))
     ENDIF
     ! Perform the Cholesky Factorization (Veers 1984 decomposition)
     CALL SPPTRF('L',np,work,stat)
     DO ii=1,np
        DO jj=1,ii
            ! Multiply the columns of the H matrix (Sij) by the random phases (phr_tmp) and sum the rows.
           phr(ii,ff)=phr(ii,ff)+work(indx(ii,jj,np))*phr_tmp(jj,ff)
        ENDDO
     ENDDO
  ENDDO
  !$omp end do
  !$omp end parallel
  RETURN
end subroutine nonIECcoh

subroutine IECcoh(phr,f,y,z,uhub,a,Lc,ncore,nf,ny,nz)
  use omp_lib
  implicit none
  complex,intent(inout) :: phr(ny*nz,nf)
  real,intent(in)       :: f(nf),y(ny),z(nz),uhub,a,Lc
  integer, intent(in)   :: nf, ny, nz, ncore
  complex               :: phr_tmp(ny*nz,nf)
  real                  :: ftmp(nf)
  integer               :: ii, jj, ff, np, stat!, ind2
  real                  :: r(ny*nz*(ny*nz+1)/2)
  real                  :: work(ny*nz*(ny*nz+1)/2)
  np=ny*nz
  phr_tmp=phr
  phr(:,:)=0

  IF (ncore > 0) THEN
     CALL OMP_SET_NUM_THREADS(ncore)
  ENDIF

  r=r_arr(y,z,ny,nz)

  ftmp=-1*a*SQRT((f/uhub)**2+(0.12/Lc)**2)
  !$omp parallel private(ii, jj, ff, work, stat) default(shared)
  !$omp do schedule( dynamic )
  DO ff=1,nf
     work=EXP(r*ftmp(ff))
     CALL SPPTRF('L',np,work,stat)
     DO ii=1,np
        ! omp'single' directive unnecessary b/c parallel only applies to the outer loop.
        DO jj=1,ii
           phr(ii,ff)=phr(ii,ff)+work(indx(ii,jj,np))*phr_tmp(jj,ff) ! Multiply the columns of the H matrix (Sij) by the random phases (phr) and sum the rows.
        ENDDO
     ENDDO

  ENDDO
  !$omp end do
  !$omp end parallel

  RETURN
end subroutine IECcoh

END MODULE TSLIB


FUNCTION temps(bwtdmx,bwtdmn,bctopt,bctmin)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: bctmin,bctopt,bwtdmn,bwtdmx
REAL :: temps
!
! Local variables
!
REAL :: dst0,rto,tgx,x1
!
!     author : amare retta
!     + + + purpose + + +
!     to calculate the temperature stress factor
!     this algorithms was taken from the epic subroutine cgrow.

!     + + + kewords + + +
!     temperature stress

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     bwtdmx - daily maximum air temperature
!     bwtdmn - daily minimum air temperature
!     bctopt - optimum crop growth temperature
!     bctmin - minimum crop growth temperature
!     temps - value returned by this function for the temperature
!             stress factor

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     dst0 - average of max and min air temperatures
!     rto - interim variable
!     tgx - difference between the soil surface temperature and the minimum
!           temperature for plant growth
!     x1 - difference between the optimum and minimum temperatures for plant
!          growth

!     + + + end of specifications + + +

!     calculate temperature stress factor
!     following one statement to be removed when soil temperature is available
dst0 = (bwtdmx+bwtdmn)/2.0
tgx = dst0 - bctmin
IF (tgx.LE.0.) tgx = 0.
x1 = bctopt - bctmin
rto = tgx/x1
temps = sin(1.5707*rto)
IF (rto.GT.2.) temps = 0.

      ! this reduces temperature stress around the optimum
temps = temps**0.25
!    print *, 'in Temps, temps = ', temps
!
END FUNCTION temps

Project Documents/Source Code Original/Temps.f90


	FUNCTION YPADC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE DC CHANNEL OF THE WIND Y PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
C
C	DONE AND CHECKED
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA R9,C9,R10,CINP /5.E9,24.5E-12,5.E9,4.757E-12/
	DATA R33,C16 /2.2E+03,1.185E-9/
	DATA R1C,R2C,CCOMP /37.4E3,39.2E3,1.982E-6/
	DATA R19 /1.E5/
	DATA TWOPI /6.2831853/
C
C	C16 = 1.185E-9
C	C9  = 24.5E-12
C	CINP = 4.757E-12
C
C
C	C16 = CVAR(1)                             ! ADJUSTING EY
C	C9  = CVAR(2)                             ! ADJUSTING EY
C	CINP = CVAR(3)                            ! ADJUSTING EY
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C
C	EFFECT OF INPUT (211) BOARD
C
	WCC = W*CCOMP
	Z2 = CMPLX(R2C,-1./WCC)
	Y2 = 1./Z2 + 1./R19
	Z1 = R1C + 1./Y2
	Y1 = 1./Z1 + CMPLX(0.,W*C16)
	CGAIN = CGAIN/(1. + R33*Y1)/(1. + R1C*Y2)
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	YPADC = CABS(CGAIN)
	RETURN
	END


c     Fortran translation (Heh!) of test2 in quadpack-tests.lisp.
      program test2
      implicit none
      double precision alpha
      integer key, keyval(3)
      data keyval/1,3,6/

      print *, 'Test integral 2'
      print *
      print *, ' integrate(1/((x-pi/4)^2+1/alpha, x, 0, 1)'
      print *, '   = atan((4-pi)*4^(alpha-1))+atan(pi*4^(alpha-1))'
      print *
      do 10 key = 1,3
         print *, 'QAG, key = ', keyval(key)
         print 9000
         do 20 alpha = 0.0d0, 20d0, 1d0
            call quad(alpha, keyval(key))
   20    continue
   10 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      implicit none
      double precision alpha
      double precision z, pi
      parameter (pi = 3.141592653589793d0)

      z = 4**(alpha-1)
      soln = atan((4-pi)*z) + atan(pi*z)
      return
      end

      double precision function f(x)
      implicit none
      double precision pi
      parameter (pi = 3.141592653589793d0)
      double precision x
      double precision alfa
      common /param/ alfa
      f = 4d0**(-alfa)/((x-pi/4)**2 + 16d0**(-alfa))
      return
      end

      subroutine quad(alpha, key)
      implicit none
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqag(f, 0d0, 1d0, 0d0, 1d-8, key, result, abserr, neval,
     $     ier, limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


	SUBROUTINE MSAMPLESIZE
     .(ALPHA,POWER,PHI,P0,M,PSI,resultN)
!MS$ATTRIBUTES REFERENCE :: resultN
	IMPLICIT NONE
	REAL ALPHA,POWER,PHI,P0,M,PSI
	REAL resultN
c	INTEGER resultN
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine the sample size needed to produce a specified level
C	of statistical power for matched case-control studies.
C
C  Input prompted for from user:
C	ALPHA	Type I error probability for a two sided test
C	POWER	The desired statistical power
C	PHI		Correlation coefficient for exposure between
C			matched cases and controls
C	P0		Probability of exposure in control group
C	M		Number of matched controls per case patient
C	PSI		Odds ratio
C
C  Output:
C	resultN	Number of case patients needed to detect a true
C		odds ratio PSI with power POWER and a two-
C		sided type I error probability ALPHA
C
C  Notes:
C   .   This routine written by Dale Plummer
C   .	Reference:
C	    Dupont, WD: "Power Calculations for Matched Case-Control
C	    Studies", Biometrics, 1988; 44:1157-1168
C   .	Link with subroutines in file SUBS.FOR
C
C-Declarations----------------------------------------------------------
C
C
C  Functions
C
C	REAL ZCRVALUE
C
C  Locals
C
	REAL BETA
	INTEGER ERR
	INTEGER localM
C
C-Code------------------------------------------------------------------
C
	BETA=1.-POWER
	localM=M
C
C    Do the real work.
C
	CALL SSIZE(ALPHA,BETA,PHI,P0,localM,PSI,resultN,ERR)

	RETURN
	END


	FUNCTION PR_SALT  ( alti )
C************************************************************************
C* PR_SALT								*
C*									*
C* This function computes SALT from ALTI.  SALT is a standard		*
C* abbreviated pressure code.  ALTI, the altimeter setting in		*
C* inches is converted to ALTM, the altimeter in millibars.  Then	*
C* ALTM is multiplied by 10, truncated, and the original thousand	*
C* and hundred digits are dropped.  The following equation is used:	*
C*									*
C*              SALT = NINT ( MOD ( ALTM, 100 ) * 10 )			*
C*									*
C* REAL PR_SALT  ( ALTI )						*
C*									*
C* Input parameters:							*
C*	ALTI		REAL		Altimeter setting in inches	*
C*									*
C* Output parameters:							*
C*	PR_SALT		REAL		Abbreviated standard altimeter	*
C**									*
C* Log:									*
C* M. Goodman/RDS	 2/85	Original source				*
C* M. desJardins/GSFC	 9/85	Corrected				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 7/88	Documentation				*
C* M. Linda/GSC		 9/97	Changed a key word in the prologue	*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( alti ) )  THEN
	    pr_salt = RMISSD
	  ELSE
C
C*	    Convert altimeter to millibars,
C
	    altm = PR_ALTM ( alti )
C
C*	    Drop the leading thousand and/or hundreds digits.
C
	    aalt = AMOD ( altm, 100. )
C
C*	    Include the tenths digit.
C
	    aalt = aalt * 10.
	    PR_SALT = ANINT ( aalt )
	END IF
C*
	RETURN
	END


      program test
      real*8  spherdist
      real*8  lon1,lat1,lon2,lat2,sdx,sdy
      integer i
c
      do i= -89,0,1
        lon1 = 0.00d0
        lon2 = 1.00d0
        lat1 = i
        lat2 = i+1
        sdy  = spherdist(lon1,lat1,lon1,lat2)
        sdx  = spherdist(lon1,lat1,lon2,lat1)
        write(6,'(2f15.4,i5)') sdx,sdy,i
      enddo
      lon1 = 0.00d0
      lon2 = 1.00d3/sdx
      sdx  = spherdist(lon1,lat1,lon2,lat1)
      write(6,*) '1km on the equator ',lon1,lon2,' deg'
      write(6,'(f15.4)') sdx
      lon1 = -lon2*0.5d0
      lon2 =  lon2*0.5d0
      sdx  = spherdist(lon1,lat1,lon2,lat1)
      write(6,*) '1km on the equator ',lon1,lon2,' deg'
      write(6,'(f15.4)') sdx
      end
      real*8 function spherdist(lon1,lat1,lon2,lat2)
      implicit none
      real*8, intent(in) :: lon1,lat1,lon2,lat2 ! Pos. in degrees
c
c --- ------------------------------------------------
c --- Computes the distance between geo. pos.
c --- lon1,lat1 and lon2,lat2.
c --- input is in degrees.
c
c --- Based on m_spherdist.F90 from Geir Evanson.
c --- ------------------------------------------------
c
      double precision, parameter :: invradian=0.017453292d0
      double precision, parameter ::    rearth=6371001.0d0  ! Radius of earth
c
      double precision  dlon1,dlon2
      double precision  rlon1,rlat1,rlon2,rlat2           ! Pos. in radians
      double precision  x1,y1,z1,x2,y2,z2                 ! Cartesian position
      double precision  dr                                ! Arc length
c
c     ensure that spherdist(ax,ay,bx,by) == spherdist(bx,by,ax,ay)
c
      dlon1 = lon1
      dlon1 = mod(dlon1,360.d0)
      if     (dlon1.lt.0.d0) then
        dlon1 = dlon1 + 360.d0
      endif
      dlon2 = lon2
      dlon2 = mod(dlon2,360.d0)
      if     (dlon2.lt.0.d0) then
        dlon2 = dlon2 + 360.d0
      endif
      if     ((dlon2-dlon1).gt.180.d0) then
        dlon1 = dlon1+360.d0
      elseif ((dlon1-dlon2).gt.180.d0) then
        dlon2 = dlon2+360.d0
      endif
      write(6,*) 'lon = ',dlon1,dlon2
      if     (lat1.lt.lat2) then
        rlon1=dlon1*invradian            !lon1 in rad
        rlat1=(90.d0-lat1)*invradian     !90-lat1 in rad
        rlon2=dlon2*invradian            !lon2 in rad
        rlat2=(90.d0-lat2)*invradian     !90-lat2 in rad
      elseif (lat1.eq.lat2 .and. dlon1.le.dlon2) then
        rlon1=dlon1*invradian            !lon1 in rad
        rlat1=(90.d0-lat1)*invradian     !90-lat1 in rad
        rlon2=dlon2*invradian            !lon2 in rad
        rlat2=(90.d0-lat2)*invradian     !90-lat2 in rad
      else
        rlon2=dlon1*invradian            !lon1 in rad
        rlat2=(90.d0-lat1)*invradian     !90-lat1 in rad
        rlon1=dlon2*invradian            !lon2 in rad
        rlat1=(90.d0-lat2)*invradian     !90-lat2 in rad
      endif
c
      x1= sin(rlat1)*cos(rlon1)        !x,y,z of pos 1.
      y1= sin(rlat1)*sin(rlon1)
      z1= cos(rlat1)
c
      x2= sin(rlat2)*cos(rlon2)        !x,y,z of pos 2.
      y2= sin(rlat2)*sin(rlon2)
      z2= cos(rlat2)
c
      dr=acos(min(1.d0,x1*x2+y1*y2+z1*z2))  ! Arc length
c
      spherdist=dr*rearth
c
      end function spherdist


      PROGRAM xpolin2
C     driver for routine polin2
      INTEGER N
      REAL PI
      PARAMETER(N=5,PI=3.141593)
      INTEGER i,j
      REAL dy,f,x1,x2,y,x1a(N),x2a(N),ya(N,N)
      do 12 i=1,N
        x1a(i)=i*PI/N
        do 11 j=1,N
          x2a(j)=1.0*j/N
          ya(i,j)=sin(x1a(i))*exp(x2a(j))
11      continue
12    continue
C     test 2-dimensional interpolation
      write(*,'(t9,a,t21,a,t32,a,t40,a,t58,a)')
     *     'x1','x2','f(x)','interpolated','error'
      do 14 i=1,4
        x1=(-0.1+i/5.0)*PI
        do 13 j=1,4
          x2=-0.1+j/5.0
          f=sin(x1)*exp(x2)
          call polin2(x1a,x2a,ya,N,N,x1,x2,y,dy)
          write(*,'(1x,4f12.6,f14.6)') x1,x2,f,y,dy
13      continue
        write(*,*) '***********************************'
14    continue
      END

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


! =============================================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =============================================================================
!
! Riemann problems for the 1D Burgers' equation with entropy fix for
! transonic rarefaction. See "Finite Volume Method for Hyperbolic Problems",
! R. J. LeVeque.

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

    implicit double precision (a-h,o-z)

    integer :: maxmx, meqn, mwaves, mbc, mx

    double precision :: ql(meqn,1-mbc:maxmx+mbc)
    double precision :: qr(meqn,1-mbc:maxmx+mbc)
    double precision :: s(mwaves, 1-mbc:maxmx+mbc)
    double precision :: wave(meqn, mwaves, 1-mbc:maxmx+mbc)
    double precision :: amdq(meqn, 1-mbc:maxmx+mbc)
    double precision :: apdq(meqn, 1-mbc:maxmx+mbc)
    integer :: i
    logical :: efix

    efix = .true.   !# Compute correct flux for transonic rarefactions

    do i=2-mbc,mx+mbc
        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        s(1,i) = 0.5d0 * (qr(1,i-1) + ql(1,i))

        amdq(1,i) = dmin1(s(1,i), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(s(1,i), 0.d0) * wave(1,1,i)

	    if (efix) then
            if (ql(1,i).gt.0.d0 .and. qr(1,i-1).lt.0.d0) then
                amdq(1,i) = - 1.d0/2.d0 * qr(1,i-1)**2
                apdq(1,i) =   1.d0/2.d0 * ql(1,i)**2
            endif
        endif
    enddo

    return
    end subroutine


! Program to test the transpose intrinsic
program intrinsic_transpose
   integer, dimension (3, 3) :: a, b
   complex(kind=8), dimension (2, 2) :: c, d
   complex(kind=4), dimension (2, 2) :: e

   a = 0
   b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = transpose (b)
   if (any (a .ne. reshape ((/1, 4, 7, 2, 5, 8, 3, 6, 9/), (/3, 3/)))) &
      call abort
   c = (0.0, 0.0)
   d = reshape ((/(1d0,2d0), (3d0, 4d0), (5d0, 6d0), (7d0, 8d0)/), (/2, 2/))
   c = transpose (d);
   if (any (c .ne. reshape ((/(1d0, 2d0), (5d0, 6d0), &
                              (3d0, 4d0), (7d0, 8d0)/), (/2, 2/)))) &
    call abort ();

   e = reshape ((/(1.0,2.0), (3.0, 4.0), (5.0, 6.0), (7.0, 8.0)/), (/2, 2/))
   e = transpose (e);
   if (any (e .ne. reshape ((/(1.0, 2.0), (5.0, 6.0), &
                              (3.0, 4.0), (7.0, 8.0)/), (/2, 2/)))) &
    call abort ();
end program


subroutine f(t, y)
  implicit none
  double precision :: t, y

  f = cos(t) * exp(-t) - y

  return
end


*DECK PCHSP
      SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
C***BEGIN PROLOGUE  PCHSP
C***PURPOSE  Set derivatives needed to determine the Hermite represen-
C            tation of the cubic spline interpolant to given data, with
C            specified boundary conditions.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E1A
C***TYPE      SINGLE PRECISION (PCHSP-S, DPCHSP-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, PCHIP,
C             PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          PCHSP:   Piecewise Cubic Hermite Spline
C
C     Computes the Hermite representation of the cubic spline inter-
C     polant to the data given in X and F satisfying the boundary
C     conditions specified by IC and VC.
C
C     To facilitate two-dimensional applications, includes an increment
C     between successive values of the F- and D-arrays.
C
C     The resulting piecewise cubic Hermite function may be evaluated
C     by PCHFE or PCHFD.
C
C     NOTE:  This is a modified version of C. de Boor's cubic spline
C            routine CUBSPL.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  IC(2), N, NWK, IERR
C        REAL  VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK)
C
C        CALL  PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
C
C   Parameters:
C
C     IC -- (input) integer array of length 2 specifying desired
C           boundary conditions:
C           IC(1) = IBEG, desired condition at beginning of data.
C           IC(2) = IEND, desired condition at end of data.
C
C           IBEG = 0  to set D(1) so that the third derivative is con-
C              tinuous at X(2).  This is the "not a knot" condition
C              provided by de Boor's cubic spline routine CUBSPL.
C              < This is the default boundary condition. >
C           IBEG = 1  if first derivative at X(1) is given in VC(1).
C           IBEG = 2  if second derivative at X(1) is given in VC(1).
C           IBEG = 3  to use the 3-point difference formula for D(1).
C                     (Reverts to the default b.c. if N.LT.3 .)
C           IBEG = 4  to use the 4-point difference formula for D(1).
C                     (Reverts to the default b.c. if N.LT.4 .)
C          NOTES:
C           1. An error return is taken if IBEG is out of range.
C           2. For the "natural" boundary condition, use IBEG=2 and
C              VC(1)=0.
C
C           IEND may take on the same values as IBEG, but applied to
C           derivative at X(N).  In case IEND = 1 or 2, the value is
C           given in VC(2).
C
C          NOTES:
C           1. An error return is taken if IEND is out of range.
C           2. For the "natural" boundary condition, use IEND=2 and
C              VC(2)=0.
C
C     VC -- (input) real array of length 2 specifying desired boundary
C           values, as indicated above.
C           VC(1) need be set only if IC(1) = 1 or 2 .
C           VC(2) need be set only if IC(2) = 1 or 2 .
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real array of dependent variable values to be inter-
C           polated.  F(1+(I-1)*INCFD) is value corresponding to X(I).
C
C     D -- (output) real array of derivative values at the data points.
C           These values will determine the cubic spline interpolant
C           with the requested boundary conditions.
C           The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in F and D.
C           This argument is provided primarily for 2-D applications.
C           (Error return if  INCFD.LT.1 .)
C
C     WK -- (scratch) real array of working storage.
C
C     NWK -- (input) length of work array.
C           (Error return if NWK.LT.2*N .)
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C              IERR = -4  if IBEG.LT.0 or IBEG.GT.4 .
C              IERR = -5  if IEND.LT.0 of IEND.GT.4 .
C              IERR = -6  if both of the above are true.
C              IERR = -7  if NWK is too small.
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C             (The D-array has not been changed in any of these cases.)
C              IERR = -8  in case of trouble solving the linear system
C                         for the interior derivative values.
C             (The D-array may have been changed in this case.)
C             (             Do **NOT** use it!                )
C
C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
C                 Verlag, New York, 1978, pp. 53-59.
C***ROUTINES CALLED  PCHDF, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820503  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   870707  Minor cosmetic changes to prologue.
C   890411  Added SAVE statements (Vers. 3.2).
C   890703  Corrected category record.  (WRB)
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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920429  Revised format and order of references.  (WRB,FNF)
C***END PROLOGUE  PCHSP
C  Programming notes:
C
C     To produce a double precision version, simply:
C        a. Change PCHSP to DPCHSP wherever it occurs,
C        b. Change the real declarations to double precision, and
C        c. Change the constants ZERO, HALF, ... to double precision.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  IC(2), N, INCFD, NWK, IERR
      REAL  VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  IBEG, IEND, INDEX, J, NM1
      REAL  G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO
      SAVE ZERO, HALF, ONE, TWO, THREE
      REAL  PCHDF
C
      DATA  ZERO /0./,  HALF /0.5/,  ONE /1./,  TWO /2./,  THREE /3./
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  PCHSP
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  J = 2, N
         IF ( X(J).LE.X(J-1) )  GO TO 5003
    1 CONTINUE
C
      IBEG = IC(1)
      IEND = IC(2)
      IERR = 0
      IF ( (IBEG.LT.0).OR.(IBEG.GT.4) )  IERR = IERR - 1
      IF ( (IEND.LT.0).OR.(IEND.GT.4) )  IERR = IERR - 2
      IF ( IERR.LT.0 )  GO TO 5004
C
C  FUNCTION DEFINITION IS OK -- GO ON.
C
      IF ( NWK .LT. 2*N )  GO TO 5007
C
C  COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO,
C  COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.).
      DO 5  J=2,N
         WK(1,J) = X(J) - X(J-1)
         WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J)
    5 CONTINUE
C
C  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
C
      IF ( IBEG.GT.N )  IBEG = 0
      IF ( IEND.GT.N )  IEND = 0
C
C  SET UP FOR BOUNDARY CONDITIONS.
C
      IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) )  THEN
         D(1,1) = VC(1)
      ELSE IF (IBEG .GT. 2)  THEN
C        PICK UP FIRST IBEG POINTS, IN REVERSE ORDER.
         DO 10  J = 1, IBEG
            INDEX = IBEG-J+1
C           INDEX RUNS FROM IBEG DOWN TO 1.
            XTEMP(J) = X(INDEX)
            IF (J .LT. IBEG)  STEMP(J) = WK(2,INDEX)
   10    CONTINUE
C                 --------------------------------
         D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR)
C                 --------------------------------
         IF (IERR .NE. 0)  GO TO 5009
         IBEG = 1
      ENDIF
C
      IF ( (IEND.EQ.1).OR.(IEND.EQ.2) )  THEN
         D(1,N) = VC(2)
      ELSE IF (IEND .GT. 2)  THEN
C        PICK UP LAST IEND POINTS.
         DO 15  J = 1, IEND
            INDEX = N-IEND+J
C           INDEX RUNS FROM N+1-IEND UP TO N.
            XTEMP(J) = X(INDEX)
            IF (J .LT. IEND)  STEMP(J) = WK(2,INDEX+1)
   15    CONTINUE
C                 --------------------------------
         D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR)
C                 --------------------------------
         IF (IERR .NE. 0)  GO TO 5009
         IEND = 1
      ENDIF
C
C --------------------( BEGIN CODING FROM CUBSPL )--------------------
C
C  **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF
C  F  AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM-
C  INATION, WITH S(J) ENDING UP IN D(1,J), ALL J.
C     WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE.
C
C  CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM
C             WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1)
C
      IF (IBEG .EQ. 0)  THEN
         IF (N .EQ. 2)  THEN
C           NO CONDITION AT LEFT END AND N = 2.
            WK(2,1) = ONE
            WK(1,1) = ONE
            D(1,1) = TWO*WK(2,2)
         ELSE
C           NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2.
            WK(2,1) = WK(1,3)
            WK(1,1) = WK(1,2) + WK(1,3)
            D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3)
     *                        + WK(1,2)**2*WK(2,3)) / WK(1,1)
         ENDIF
      ELSE IF (IBEG .EQ. 1)  THEN
C        SLOPE PRESCRIBED AT LEFT END.
         WK(2,1) = ONE
         WK(1,1) = ZERO
      ELSE
C        SECOND DERIVATIVE PRESCRIBED AT LEFT END.
         WK(2,1) = TWO
         WK(1,1) = ONE
         D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1)
      ENDIF
C
C  IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
C  CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH
C  EQUATION READS    WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J).
C
      NM1 = N-1
      IF (NM1 .GT. 1)  THEN
         DO 20 J=2,NM1
            IF (WK(2,J-1) .EQ. ZERO)  GO TO 5008
            G = -WK(1,J+1)/WK(2,J-1)
            D(1,J) = G*D(1,J-1)
     *                  + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J))
            WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1))
   20    CONTINUE
      ENDIF
C
C  CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM
C           (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N)
C
C     IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK-
C     SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT
C     AT THIS POINT.
      IF (IEND .EQ. 1)  GO TO 30
C
      IF (IEND .EQ. 0)  THEN
         IF (N.EQ.2 .AND. IBEG.EQ.0)  THEN
C           NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2.
            D(1,2) = WK(2,2)
            GO TO 30
         ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0))  THEN
C           EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT*
C           NOT-A-KNOT AT LEFT END POINT).
            D(1,N) = TWO*WK(2,N)
            WK(2,N) = ONE
            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
            G = -ONE/WK(2,N-1)
         ELSE
C           NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR  ALSO NOT-A-
C           KNOT AT LEFT END POINT.
            G = WK(1,N-1) + WK(1,N)
C           DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES).
            D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1)
     *                  + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G
            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
            G = -G/WK(2,N-1)
            WK(2,N) = WK(1,N-1)
         ENDIF
      ELSE
C        SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT.
         D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N)
         WK(2,N) = TWO
         IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
         G = -ONE/WK(2,N-1)
      ENDIF
C
C  COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
C
      WK(2,N) = G*WK(1,N-1) + WK(2,N)
      IF (WK(2,N) .EQ. ZERO)   GO TO 5008
      D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N)
C
C  CARRY OUT BACK SUBSTITUTION
C
   30 CONTINUE
      DO 40 J=NM1,1,-1
         IF (WK(2,J) .EQ. ZERO)  GO TO 5008
         D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J)
   40 CONTINUE
C --------------------(  END  CODING FROM CUBSPL )--------------------
C
C  NORMAL RETURN.
C
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'PCHSP',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING'
     +   , IERR, 1)
      RETURN
C
 5004 CONTINUE
C     IC OUT OF RANGE RETURN.
      IERR = IERR - 3
      CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1)
      RETURN
C
 5007 CONTINUE
C     NWK TOO SMALL RETURN.
      IERR = -7
      CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1)
      RETURN
C
 5008 CONTINUE
C     SINGULAR SYSTEM.
C   *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES   ***
C   *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). ***
      IERR = -8
      CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR,
     +   1)
      RETURN
C
 5009 CONTINUE
C     ERROR RETURN FROM PCHDF.
C   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -9
      CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR,
     +   1)
      RETURN
C------------- LAST LINE OF PCHSP FOLLOWS ------------------------------
      END


! TODO: adapt this to neo2 magfie

  function kappa2()
    real(8) :: kappa2
    kappa2 = (1d0 - eta*B0mn(fsind,1)*(1-eps(fsind)))/(2d0*eta*(B0mn(fsind,1)*eps(fsind)))
    !kappa2 = sqrt((mi*v**2/2d0-J_perp()*om_c(0d0))/(2*J_perp()*&
    !     om_c(pi/2)*eps(fsind)))
    !print *, mi*v**2/2d0, E() - qi*Phi_E(fsind)
  end function kappa2

  ! Shaing2009-035009 - (8) for bounce averaged toroidal drift
  function Omph_shaing()
    real(8) :: Omph_shaing, kappa, Eell, Kell

    ! Elliptic integrals for Shaing formula
    !kappa = sqrt((E()-qi*Phi_E(fsind)-J_perp()*om_c(0.0d0))/(2*J_perp()*&
    !     om_c(pi/2)*eps(fsind)))
    kappa = sqrt((mi*v**2/2d0-J_perp()*om_c(0d0))/(2*J_perp()*&
         om_c(pi/2)*eps))
    !kappa = sqrt(0.83)               ! test case so that 2*E/K = 1
    Kell = ellf(pi/2d0, kappa)
    Eell = elle(pi/2d0, kappa)

    ! Shaing2009-035009 - (8) for bounce averaged toroidal drift
    Omph_shaing = Om_tE +&
         J_perp()*B0mn(fsind,1)/mi*depsdr(fsind)*(2*Eell/Kell-1)
  end function Omph_shaing


! ch0509.f90 --
!     Report the properties of standard types of floating-point numbers
!
!     Courtesy Ian Chivers
!
program ch0509
  implicit none
! real arithmetic

! 32 and 64 bit reals are normally available.
! The IEEE format is as described below.

! 32 bit reals  8 bit exponent, 24 bit mantissa
! 64 bit reals 11 bit exponent, 53 bit mantissa

  real :: r
  integer, parameter :: sp = selected_real_kind(6, 37)
  integer, parameter :: dp = selected_real_kind(15, 307)
  integer, parameter :: qp = selected_real_kind(30, 291)
  real (sp) :: rsp
  real (dp) :: rdp
  real (qp) :: rqp

  print *, '           ====================='
  print *, '           Real kind information'
  print *, '           ====================='
  print *, ' kind number'
  print *, '    ', kind(r), ' ', kind(rsp), ' ', kind(rdp), ' ', kind(rqp)
  print *, ' digits details'
  print *, '    ', digits(r), ' ', digits(rsp), ' ', digits(rdp), ' ', digits(rqp)
  print *, ' epsilon details'
  print *, '    ', epsilon(r)
  print *, '    ', epsilon(rsp)
  print *, '    ', epsilon(rdp)
  print *, '    ', epsilon(rqp)
  print *, ' huge value'
  print *, '    ', huge(r)
  print *, '    ', huge(rsp)
  print *, '    ', huge(rdp)
  print *, '    ', huge(rqp)
  print *, ' maxexponent value'
  print *, '    ', maxexponent(r)
  print *, '    ', maxexponent(rsp)
  print *, '    ', maxexponent(rdp)
  print *, '    ', maxexponent(rqp)
  print *, ' minexponent value'
  print *, '    ', minexponent(r)
  print *, '    ', minexponent(rsp)
  print *, '    ', minexponent(rdp)
  print *, '    ', minexponent(rqp)
  print *, ' precision details'
  print *, '    ', precision(r), ' ', precision(rsp), ' ', precision(rdp), ' ', precision(rqp)
  print *, ' radix details'
  print *, '    ', radix(r), ' ', radix(rsp), ' ', radix(rdp), ' ', radix(rqp)
  print *, ' range details'
  print *, '    ', range(r), ' ', range(rsp), ' ', range(rdp), ' ', range(rqp)
  print *, ' tiny details'
  print *, '    ', tiny(r)
  print *, '    ', tiny(rsp)
  print *, '    ', tiny(rdp)
  print *, '    ', tiny(rqp)
end program ch0509


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j,kk
      real*8 m(16), k(16), x(16), lambda(4), sum, work(16), val

      character arg*32

      m = (/ 0.2, 0.0745355993, -0.0745355993, 0.0333333333,&
     &       0.0745355993, 1., 0.1666666667, -0.0745355993,&
     &      -0.0745355993, 0.1666666667, 1., 0.0745355993,&
     &      0.0333333333, -0.0745355993, 0.0745355993, 0.2 /)
      k = (/ 3.0333333333, -3.4148928136, 0.4982261470, -0.1166666667,&
     &      -3.4148928136, 5.8333333333, -2.9166666667, 0.4982261470,&
     &       0.4982261470, -2.9166666667, 5.8333333333, -3.4148928136,&
     &      -0.1166666667, 0.4982261470, -3.4148928136, 3.0333333333 /)

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)
      call ceedsimultaneousdiagonalization(ceed,k,m,x,lambda,4,err)

!     Check X^T M X = I
      do i=0,3
        do j=0,3
          sum = 0
          do kk=0,3
            sum=sum+m(kk+i*4+1)*x(j+kk*4+1)
          enddo
          work(j+i*4+1)=sum
        enddo
      enddo
      do i=0,3
        do j=0,3
          sum = 0
          do kk=0,3
            sum=sum+x(i+kk*4+1)*work(j+kk*4+1)
          enddo
          m(j+i*4+1)=sum
        enddo
      enddo
      do i=0,3
        do j=1,4
          if (i+1 == j) then
            val=1.0
          else
            val=0.0
          endif
          if (abs(m(i*4+j) - val)>1.0D-13) then
! LCOV_EXCL_START
            write(*,'(A,I1,A,I1,A,F12.8,A,F12.8)') 'Error: [', &
     &      i,',',j,'] ',m(i*4+j),'!=',val
! LCOV_EXCL_STOP
          endif
        enddo
      enddo

!     Check X^T K X = Lambda
      do i=0,3
        do j=0,3
          sum = 0
          do kk=0,3
            sum=sum+k(kk+i*4+1)*x(j+kk*4+1)
          enddo
          work(j+i*4+1)=sum
        enddo
      enddo
      do i=0,3
        do j=0,3
          sum = 0
          do kk=0,3
            sum=sum+x(i+kk*4+1)*work(j+kk*4+1)
          enddo
          k(j+i*4+1)=sum
        enddo
      enddo
      do i=0,3
        do j=1,4
          if (i+1 == j) then
            val=lambda(j)
          else
            val=0.0
          endif
          if (abs(k(i*4+j) - val)>1.0D-13) then
! LCOV_EXCL_START
            write(*,'(A,I1,A,I1,A,F12.8,A,F12.8)') 'Error: [', &
     &      i,',',j,'] ',k(i*4+j),'!=',val
! LCOV_EXCL_STOP
          endif
        enddo
      enddo

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


      function ee(tk)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This function calculates saturation vapor pressure at a given
!!    air temperature.
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      implicit none

      real, intent (in) :: tk        !deg C         |mean air temperature
      real :: ee                     !kPa           |saturation vapor pressure

      ee = 0.
      if (tk + 237.3 /= 0.) then
        ee = (16.78 * tk - 116.9) / (tk + 237.3)
        ee = Exp(ee)
      end if

      return
      end


program weather_stats

  use mod_arrays, only: denan, mean
  use mod_io, only: read_buoy

  implicit none

  character(len=5), allocatable :: ids(:)
  character(len=20), allocatable :: time(:)
  real, allocatable :: wind_speed(:)
  real, allocatable :: max_wind(:), mean_wind(:)
  integer :: i

  ids = ['42001', '42002', '42003', '42020', '42035',&
    '42036', '42039', '42040', '42055']

  allocate(max_wind(size(ids)), mean_wind(size(ids)))

  do i = 1, size(ids)
    call read_buoy('data/buoy_' // ids(i) //  '.csv', time, wind_speed)
    wind_speed = denan(wind_speed)
    max_wind(i) = maxval(wind_speed)
    mean_wind(i) = mean(wind_speed)
  end do

  print *, 'Maximum wind speed measured is ', maxval(max_wind),&
     'at station ', ids(maxloc(max_wind))
  print *, 'Highest mean wind speed is ', maxval(mean_wind),&
     'at station ', ids(maxloc(mean_wind))
  print *, 'Lowest mean wind speed is ', minval(mean_wind),&
     'at station ', ids(minloc(mean_wind))

end program weather_stats


*DECK COMQR2
      SUBROUTINE COMQR2 (NM, N, LOW, IGH, ORTR, ORTI, HR, HI, WR, WI,
     +   ZR, ZI, IERR)
C***BEGIN PROLOGUE  COMQR2
C***PURPOSE  Compute the eigenvalues and eigenvectors of a complex upper
C            Hessenberg matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2B
C***TYPE      COMPLEX (HQR2-S, COMQR2-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of a unitary analogue of the
C     ALGOL procedure  COMLR2, NUM. MATH. 16, 181-204(1970) by Peters
C     and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C     The unitary analogue substitutes the QR algorithm of Francis
C     (COMP. JOUR. 4, 332-345(1962)) for the LR algorithm.
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a COMPLEX UPPER Hessenberg matrix by the QR
C     method.  The eigenvectors of a COMPLEX GENERAL matrix
C     can also be found if  CORTH  has been used to reduce
C     this general matrix to Hessenberg form.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, HR, HI, ZR, and ZI, as declared in the
C          calling program dimension statement.  NM is an INTEGER
C          variable.
C
C        N is the order of the matrix H=(HR,HI).  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  CBAL.  If  CBAL  has not been used,
C          set LOW=1 and IGH equal to the order of the matrix, N.
C
C        ORTR and ORTI contain information about the unitary trans-
C          formations used in the reduction by  CORTH, if performed.
C          Only elements LOW through IGH are used.  If the eigenvectors
C          of the Hessenberg matrix are desired, set ORTR(J) and
C          ORTI(J) to 0.0E0 for these elements.  ORTR and ORTI are
C          one-dimensional REAL arrays, dimensioned ORTR(IGH) and
C          ORTI(IGH).
C
C        HR and HI contain the real and imaginary parts, respectively,
C          of the complex upper Hessenberg matrix.  Their lower
C          triangles below the subdiagonal contain information about
C          the unitary transformations used in the reduction by  CORTH,
C          if performed.  If the eigenvectors of the Hessenberg matrix
C          are desired, these elements may be arbitrary.  HR and HI
C          are two-dimensional REAL arrays, dimensioned HR(NM,N) and
C          HI(NM,N).
C
C     On OUTPUT
C
C        ORTR, ORTI, and the upper Hessenberg portions of HR and HI
C          have been destroyed.
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues of the upper Hessenberg matrix.  If an
C          error exit is made, the eigenvalues should be correct for
C          indices IERR+1, IERR+2, ..., N.  WR and WI are one-
C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
C
C        ZR and ZI contain the real and imaginary parts, respectively,
C          of the eigenvectors.  The eigenvectors are unnormalized.
C          If an error exit is made, none of the eigenvectors has been
C          found.  ZR and ZI are two-dimensional REAL arrays,
C          dimensioned ZR(NM,N) and ZI(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C     Calls CSROOT for complex square root.
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C     Calls CDIV for complex division.
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  CDIV, CSROOT, PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
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  COMQR2
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1
      INTEGER ITN,ITS,LOW,LP1,ENM1,IEND,IERR
      REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
      REAL ORTR(*),ORTI(*)
      REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  COMQR2
      IERR = 0
C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
      DO 100 I = 1, N
C
         DO 100 J = 1, N
            ZR(I,J) = 0.0E0
            ZI(I,J) = 0.0E0
            IF (I .EQ. J) ZR(I,J) = 1.0E0
  100 CONTINUE
C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C                FROM THE INFORMATION LEFT BY CORTH ..........
      IEND = IGH - LOW - 1
      IF (IEND) 180, 150, 105
C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  105 DO 140 II = 1, IEND
         I = IGH - II
         IF (ORTR(I) .EQ. 0.0E0 .AND. ORTI(I) .EQ. 0.0E0) GO TO 140
         IF (HR(I,I-1) .EQ. 0.0E0 .AND. HI(I,I-1) .EQ. 0.0E0) GO TO 140
C     .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
         NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
         IP1 = I + 1
C
         DO 110 K = IP1, IGH
            ORTR(K) = HR(K,I-1)
            ORTI(K) = HI(K,I-1)
  110    CONTINUE
C
         DO 130 J = I, IGH
            SR = 0.0E0
            SI = 0.0E0
C
            DO 115 K = I, IGH
               SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
               SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
  115       CONTINUE
C
            SR = SR / NORM
            SI = SI / NORM
C
            DO 120 K = I, IGH
               ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
               ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  150 L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0E0) GO TO 170
         NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.0E0
C
         DO 155 J = I, N
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = 1, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
         DO 165 J = LOW, IGH
            SI = YR * ZI(J,I) + YI * ZR(J,I)
            ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
            ZI(J,I) = SI
  165    CONTINUE
C
  170 CONTINUE
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0E0
      TI = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  220 IF (EN .LT. LOW) GO TO 680
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
     1             + ABS(HR(L,L)) +ABS(HI(L,L))
         S2 = S1 + ABS(HR(L,L-1))
         IF (S2 .EQ. S1) GO TO 300
  260 CONTINUE
C     .......... FORM SHIFT ..........
  300 IF (L .EQ. EN) GO TO 660
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0E0
      YI = (HI(ENM1,ENM1) - SI) / 2.0E0
      CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI)
      IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
      SR = SR - XR
      SI = SI - XI
      GO TO 340
C     .......... FORM EXCEPTIONAL SHIFT ..........
  320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
      SI = 0.0E0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... REDUCE TO TRIANGLE (ROWS) ..........
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.0E0
         NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
         XR = HR(I-1,I-1) / NORM
         WR(I-1) = XR
         XI = HI(I-1,I-1) / NORM
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.0E0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, N
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0E0) GO TO 540
      NORM = PYTHAG(HR(EN,EN),SI)
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.0E0
      IF (EN .EQ. N) GO TO 540
      IP1 = EN + 1
C
      DO 520 J = IP1, N
         YR = HR(EN,J)
         YI = HI(EN,J)
         HR(EN,J) = SR * YR + SI * YI
         HI(EN,J) = SR * YI - SI * YR
  520 CONTINUE
C     .......... INVERSE OPERATION (COLUMNS) ..........
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = 1, J
            YR = HR(I,J-1)
            YI = 0.0E0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
         DO 590 I = LOW, IGH
            YR = ZR(I,J-1)
            YI = ZI(I,J-1)
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
            ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
            ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  590    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.0E0) GO TO 240
C
      DO 630 I = 1, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      DO 640 I = LOW, IGH
         YR = ZR(I,EN)
         YI = ZI(I,EN)
         ZR(I,EN) = SR * YR - SI * YI
         ZI(I,EN) = SR * YI + SI * YR
  640 CONTINUE
C
      GO TO 240
C     .......... A ROOT FOUND ..........
  660 HR(EN,EN) = HR(EN,EN) + TR
      WR(EN) = HR(EN,EN)
      HI(EN,EN) = HI(EN,EN) + TI
      WI(EN) = HI(EN,EN)
      EN = ENM1
      GO TO 220
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
  680 NORM = 0.0E0
C
      DO 720 I = 1, N
C
         DO 720 J = I, N
            NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J))
  720 CONTINUE
C
      IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001
C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
      DO 800 NN = 2, N
         EN = N + 2 - NN
         XR = WR(EN)
         XI = WI(EN)
         ENM1 = EN - 1
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 780 II = 1, ENM1
            I = EN - II
            ZZR = HR(I,EN)
            ZZI = HI(I,EN)
            IF (I .EQ. ENM1) GO TO 760
            IP1 = I + 1
C
            DO 740 J = IP1, ENM1
               ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
               ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  740       CONTINUE
C
  760       YR = XR - WR(I)
            YI = XI - WI(I)
            IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 775
            YR = NORM
  770       YR = 0.5E0*YR
            IF (NORM + YR .GT. NORM) GO TO 770
            YR = 2.0E0*YR
  775       CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
  780    CONTINUE
C
  800 CONTINUE
C     .......... END BACKSUBSTITUTION ..........
      ENM1 = N - 1
C     .......... VECTORS OF ISOLATED ROOTS ..........
      DO  840 I = 1, ENM1
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
         IP1 = I + 1
C
         DO 820 J = IP1, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  820    CONTINUE
C
  840 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
      DO 880 JJ = LOW, ENM1
         J = N + LOW - JJ
         M = MIN(J-1,IGH)
C
         DO 880 I = LOW, IGH
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
C
            DO 860 K = LOW, M
               ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
               ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  860       CONTINUE
C
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  880 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END


SUBROUTINE realft_sp(data,isign,zdata)
  USE nrtype
  USE nrutil, ONLY : assert,assert_eq,zroots_unity
  USE nr, ONLY : four1
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(INOUT) :: data
  INTEGER(I4B), INTENT(IN) :: isign
  COMPLEX(SPC), DIMENSION(:), OPTIONAL, TARGET :: zdata
  INTEGER(I4B) :: n,ndum,nh,nq
  COMPLEX(SPC), DIMENSION(size(data)/4) :: w
  COMPLEX(SPC), DIMENSION(size(data)/4-1) :: h1,h2
  COMPLEX(SPC), DIMENSION(:), POINTER :: cdata
  COMPLEX(SPC) :: z
  REAL(SP) :: c1=0.5_sp,c2
  n=size(data)
  call assert(iand(n,n-1)==0, 'n must be a power of 2 in realft_sp')
  nh=n/2
  nq=n/4
  if (present(zdata)) then
     ndum=assert_eq(n/2,size(zdata),'realft_sp')
     cdata=>zdata
     if (isign == 1) cdata=cmplx(data(1:n-1:2),data(2:n:2),kind=spc)
  else
     allocate(cdata(n/2))
     cdata=cmplx(data(1:n-1:2),data(2:n:2),kind=spc)
  end if
  if (isign == 1) then
     c2=-0.5_sp
     call four1(cdata,+1)
  else
     c2=0.5_sp
  end if
  w=zroots_unity(sign(n,isign),n/4)
  w=cmplx(-aimag(w),real(w),kind=spc)
  h1=c1*(cdata(2:nq)+conjg(cdata(nh:nq+2:-1)))
  h2=c2*(cdata(2:nq)-conjg(cdata(nh:nq+2:-1)))
  cdata(2:nq)=h1+w(2:nq)*h2
  cdata(nh:nq+2:-1)=conjg(h1-w(2:nq)*h2)
  z=cdata(1)
  if (isign == 1) then
     cdata(1)=cmplx(real(z)+aimag(z),real(z)-aimag(z),kind=spc)
  else
     cdata(1)=cmplx(c1*(real(z)+aimag(z)),c1*(real(z)-aimag(z)),kind=spc)
     call four1(cdata,-1)
  end if
  if (present(zdata)) then
     if (isign /= 1) then
        data(1:n-1:2)=real(cdata)
        data(2:n:2)=aimag(cdata)
     end if
  else
     data(1:n-1:2)=real(cdata)
     data(2:n:2)=aimag(cdata)
     deallocate(cdata)
  end if
END SUBROUTINE realft_sp

SUBROUTINE realft_dp(data,isign,zdata)
  USE nrtype
  USE nrutil, ONLY : assert,assert_eq,zroots_unity
  USE nr, ONLY : four1
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(INOUT) :: data
  INTEGER(I4B), INTENT(IN) :: isign
  COMPLEX(DPC), DIMENSION(:), OPTIONAL, TARGET :: zdata
  INTEGER(I4B) :: n,ndum,nh,nq
  COMPLEX(DPC), DIMENSION(size(data)/4) :: w
  COMPLEX(DPC), DIMENSION(size(data)/4-1) :: h1,h2
  COMPLEX(DPC), DIMENSION(:), POINTER :: cdata
  COMPLEX(DPC) :: z
  REAL(DP) :: c1=0.5_dp,c2
  n=size(data)
  call assert(iand(n,n-1)==0, 'n must be a power of 2 in realft_dp')
  nh=n/2
  nq=n/4
  if (present(zdata)) then
     ndum=assert_eq(n/2,size(zdata),'realft_dp')
     cdata=>zdata
     if (isign == 1) cdata=cmplx(data(1:n-1:2),data(2:n:2),kind=spc)
  else
     allocate(cdata(n/2))
     cdata=cmplx(data(1:n-1:2),data(2:n:2),kind=spc)
  end if
  if (isign == 1) then
     c2=-0.5_dp
     call four1(cdata,+1)
  else
     c2=0.5_dp
  end if
  w=zroots_unity(sign(n,isign),n/4)
  w=cmplx(-aimag(w),real(w),kind=dpc)
  h1=c1*(cdata(2:nq)+conjg(cdata(nh:nq+2:-1)))
  h2=c2*(cdata(2:nq)-conjg(cdata(nh:nq+2:-1)))
  cdata(2:nq)=h1+w(2:nq)*h2
  cdata(nh:nq+2:-1)=conjg(h1-w(2:nq)*h2)
  z=cdata(1)
  if (isign == 1) then
     cdata(1)=cmplx(real(z)+aimag(z),real(z)-aimag(z),kind=dpc)
  else
     cdata(1)=cmplx(c1*(real(z)+aimag(z)),c1*(real(z)-aimag(z)),kind=dpc)
     call four1(cdata,-1)
  end if
  if (present(zdata)) then
     if (isign /= 1) then
        data(1:n-1:2)=real(cdata)
        data(2:n:2)=aimag(cdata)
     end if
  else
     data(1:n-1:2)=real(cdata)
     data(2:n:2)=aimag(cdata)
     deallocate(cdata)
  end if
END SUBROUTINE realft_dp


subroutine phase_space_avg(xin, yin, arr, xout, yout, ndim0, nx, ny, phase)
    ! Compute the mean of the phase-space
    implicit none
    ! Input vars
    integer(kind=4), intent(in) :: ndim0, nx, ny  ! Arrays dimension
    real(kind=8), intent(in), dimension(ndim0) :: xin
    real(kind=8), intent(in), dimension(ndim0) :: yin
    real(kind=8), intent(in), dimension(ndim0) :: arr
    real(kind=8), intent(in), dimension(nx) :: xout
    real(kind=8), intent(in), dimension(ny) :: yout

    ! Output vars
    real(kind=8), intent(out), dimension(ny, nx) :: phase

    ! Parameters
    integer(kind=4) :: i, j, cnt
    real(kind=8) :: dx, dy, total

    dx = ABS(xout(2) - xout(1)) / 2.0
    dy = ABS(yout(2) - yout(1)) / 2.0

    do j = 1, ny
        do i = 1, nx
             cnt = COUNT((xin >= xout(i) - dx).AND. &
                         (xin < xout(i) + dx).AND. &
                         (yin >= yout(j) - dy).AND. &
                         (yin < yout(j) + dy))

            if (cnt.EQ.0) then
                continue
            endif

            total = SUM(arr, MASK=((xin >= xout(i) - dx).AND. &
                                   (xin < xout(i) + dx).AND. &
                                   (yin >= yout(j) - dy).AND. &
                                   (yin < yout(j) + dy)))

            phase(j, i) = total / cnt
       enddo
    enddo
    return
end subroutine phase_space_avg

subroutine phase_space_var(xin, yin, arr, xout, yout, ndim0, nx, ny, phase)
    ! Compute the Variance of the phase-space
    implicit none
    ! Input vars
    integer(kind=4), intent(in) :: ndim0, nx, ny  ! Arrays dimension
    real(kind=8), intent(in), dimension(ndim0) :: xin
    real(kind=8), intent(in), dimension(ndim0) :: yin
    real(kind=8), intent(in), dimension(ndim0) :: arr
    real(kind=8), intent(in), dimension(nx) :: xout
    real(kind=8), intent(in), dimension(ny) :: yout

    ! Output vars
    real(kind=8), intent(out), dimension(ny, nx) :: phase

    ! Parameters
    integer(kind=4) :: i, j, cnt
    real(kind=8) :: dx, dy, total, mean

    dx = ABS(xout(2) - xout(1)) / 2.0
    dy = ABS(yout(2) - yout(1)) / 2.0

    do j = 1, ny
        do i = 1, nx
             cnt = COUNT((xin >= xout(i) - dx).AND. &
                         (xin < xout(i) + dx).AND. &
                         (yin >= yout(j) - dy).AND. &
                         (yin < yout(j) + dy))

            if (cnt.EQ.0) then
                continue
            endif

            total = SUM(arr, MASK=((xin >= xout(i) - dx).AND. &
                                   (xin < xout(i) + dx).AND. &
                                   (yin >= yout(j) - dy).AND. &
                                   (yin < yout(j) + dy)))

            mean = total / cnt
            total = SUM(arr ** 2 - mean ** 2, MASK=((xin >= xout(i) - dx).AND. &
                                                    (xin < xout(i) + dx).AND. &
                                                    (yin >= yout(j) - dy).AND. &
                                                    (yin < yout(j) + dy)))
            if (total <= 0) then
                phase(j, i) = -9999
            else
                phase(j, i) = total / (cnt - 1)
            endif
       enddo
    enddo
    return
end subroutine phase_space_var

subroutine phase_space_count(xin, yin, xout, yout, ndim0, nx, ny, phase)
    ! Count the number of elements in the phase-space
    implicit none
    ! Input vars
    integer(kind=4), intent(in) :: ndim0, nx, ny  ! Arrays dimension
    real(kind=8), intent(in), dimension(ndim0) :: xin
    real(kind=8), intent(in), dimension(ndim0) :: yin
    real(kind=8), intent(in), dimension(nx) :: xout
    real(kind=8), intent(in), dimension(ny) :: yout

    ! Output vars
    integer(kind=4), intent(out), dimension(ny, nx) :: phase

    ! Parameters
    integer(kind=4) :: i, j, cnt
    real(kind=8) :: dx, dy

    dx = ABS(xout(2) - xout(1)) / 2.0
    dy = ABS(yout(2) - yout(1)) / 2.0

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

            cnt = COUNT((xin >= xout(i) - dx).AND. &
                        (xin < xout(i) + dx).AND. &
                        (yin >= yout(j) - dy).AND. &
                        (yin < yout(j) + dy))

            phase(j, i) = cnt
       enddo
    enddo
    return
end subroutine phase_space_count

!subroutine compute_phasespace(x, y, z, phase, bins, nx)
!    ! Count the number of elements in the phase-space
!    implicit none
!    ! Input vars
!    real(kind=8), intent(in), dimension(nx) :: x, y, z
!    integer(kind=4), intent(in) :: nx
!    integer(kind=4), optional :: bins
!
!    ! Output vars
!    integer(kind=4) :: ndim0, i
!    real(kind=8), intent(out), allocatable :: phase(:, :)
!    real(kind=8), allocatable :: xout(:), yout(:)
!    real(kind=8) :: xmax, xmin, ymax, ymin, dx, dy
!
!    if(present(bins)) then
!        ndim0 = bins
!    else
!        ndim0 = 10
!    endif
!
!    ALLOCATE(xout(ndim0), yout(ndim0))
!    ALLOCATE(phase(ndim0, ndim0))
!
!    xmax = MAXVAL(x)
!    xmin = MINVAL(x)
!    ymax = MAXVAL(y)
!    ymin = MINVAL(y)
!    dx = (xmax - xmin) / ndim0
!    dy = (ymax - ymin) / ndim0
!
!    do i = 1, ndim0
!        xout(i) = i * dx + xmin
!        yout(i) = i * dy + ymin
!    enddo
!
!    call phase_space_avg(x, y, z, xout, yout, ndim0, nx, nx, phase)
!    return
!end subroutine compute_phasespace


INTEGER RECURSIVE FUNCTION RECURSIVE_FACTORIAL(X) RESULT(ANS)
    INTEGER, INTENT(IN) :: X

    IF (X <= 1) THEN
        ANS = 1
    ELSE
        ANS = X * RECURSIVE_FACTORIAL(X-1)
    END IF

END FUNCTION RECURSIVE_FACTORIAL


module interpolation_cic_m

use mesh_fields_m
use particles_m

implicit none

contains

subroutine interpolate_eb_cic( p, f )

type(particles_t), intent(inout) :: p
type(fields_3d_t), intent(in)    :: f

real(8) :: a1, a2, a3, a4, a5, a6, a7, a8
real(8) :: xp, yp, zp
integer :: i, j, k
real(8) :: dx,  dy,  dz
real(8) :: dxp, dyp, dzp
integer :: d

integer(8) :: m

dx = f%mesh%dx
dy = f%mesh%dy
dz = f%mesh%dz

do m = 1_8, p%nbpart

   xp = p%x(1,m)/dx
   yp = p%x(2,m)/dy
   zp = p%x(3,m)/dz

   i = floor(xp)
   j = floor(yp)
   k = floor(zp)

   dxp = xp - real(i, kind=8)
   dyp = yp - real(j, kind=8)
   dzp = zp - real(k, kind=8)

   a1 = (1d0 - dxp) * (1d0 - dyp) * (1d0 - dzp)
   a2 = dxp         * (1d0 - dyp) * (1d0 - dzp)
   a3 = (1d0 - dxp) * dyp         * (1d0 - dzp)
   a4 = dxp         * dyp         * (1d0 - dzp)
   a5 = (1d0 - dxp) * (1d0 - dyp) * dzp
   a6 = dxp         * (1d0 - dyp) * dzp
   a7 = (1d0 - dxp) * dyp         * dzp
   a8 = dxp         * dyp         * dzp

   i = i + 1
   j = j + 1
   k = k + 1

   do d = 1, 3

       p%e(d,m) = a1 * f%e(d, i,  j,   k  ) + a2 * f%e(d, i+1, j,   k  ) &
                + a3 * f%e(d, i,  j+1, k  ) + a4 * f%e(d, i+1, j+1, k  ) &
                + a5 * f%e(d, i,  j,   k+1) + a6 * f%e(d, i+1, j,   k+1) &
                + a7 * f%e(d, i,  j+1, k+1) + a8 * f%e(d, i+1, j+1, k+1)

   end do

end do

end subroutine interpolate_eb_cic

end module interpolation_cic_m


c
c***************************************************************************
c

       subroutine maxwell_dist(u0, NUPAR, NUPER,
     .                       UminPara, UmaxPara,
     .                       UPERP, UPARA, DFDUPER, DFDUPAR)
       implicit none

       integer, intent(in) ::NUPAR,NUPER
       integer n,m

       real :: UminPara,UmaxPara
       real :: UPERP(NUPER)
       real :: UPARA(NUPAR)
       real, intent(inout) :: DFDUPER(NUPER,NUPAR), DFDUPAR(NUPER,NUPAR)
       real  pi, fnorm, f, u2, u0, u02

       parameter (PI = 3.141592653597932384)

       fnorm = u0**3 / pi**1.5
       u02 = u0**2

       do n = 1, NUPER
          do m = 1, NUPAR
             u2 = UPERP(n)**2 + UPARA(m)**2
             f = fnorm * exp(-u2 * u02)
             DFDUPER(n, m) = f *(-2.0 * UPERP(n) * u02)
             DFDUPAR(n, m) = f *(-2.0 * UPARA(m) * u02)
          end do
       end do

       end subroutine maxwell_dist

c
c***************************************************************************
c

      subroutine besjc (z,n,b,ier)
c
c subroutine besjc (z,n,b,ier)
c
c dimension of           b(n+1)
c arguments
c
c latest revision        october 1978
c
c purpose                to calculate j bessel functions for complex
c                        argument and integer order
c
c usage                  call besjc (z,n,b,ier)
c
c arguments
c
c on input               z
c                          complex argument for which j bessel functions
c                          are to be calculated.  abs(aimag(z)) must be
c                          less than the largest real argument that the
c                          fortran function exp can handle.
c
c                        n
c                          integer, the highest order to be calculated.
c                          n must be greater than or equal to zero.
c
c on output              b
c                          complex vector of length n+1 containing the
c                          bessel function values j-sub-0(z),j-sub-1(z),
c                          ...,j-sub-n(z) in b(1),b(2),...,b(n+1).
c                        ier
c                          an integer error flag.
c                          =0 if all desired orders have been calculated
c                             satisfactorily,
c                          =1 if abs(aimag(z)) is too large,
c                          =2 if n is less than zero,
c                          =2+k if only the first k results are correct.
c                             in the returned values b(m) for m greater
c                             than k, approximately the last
c                             alog10(abs(b(m)/b(k))) significant digits
c                             are in error.
c
c entry points           besjc
c
c special conditions     none
c
c common blocks          none
c
c i/o                    none, except for error messages produced by
c                        calling the error handling routine uliber.
c
c precision              single
c
c specialist             russ rew, ncar, boulder, colorado
c
c accuracy               in tests run on the 7600 with orders from 0
c                        through 10 using random values of the argument
c                        with absolute value less than 50 but
c                        concentrated around the origin, the maximum
c                        relative error (or absolute error when it was
c                        larger) observed was about 8.2e-14.
c
c timing                 on ncar"s control data 7600, besic takes about
c                        .32+.008*n milliseconds when z=(1.0,1.0).
c
c portability            ansi 1966 standard
c
c
c
c
c
c
      complex         z          ,b(1)
      data iorj/0/,xlarge/1000000./
c
      nb = n+1
      call b2slci (real(z),aimag(z),nb,iorj,b,ncalc)
      ier = 0
      if (ncalc .eq. nb) go to 103
      if (ncalc .ge. 0) go to 102
      if (n .ge. 0) go to 101
      ier = 2
      call uliber (ier,25h in besjc, n out of range,25)
      go to 103
  101 ier = 1
      call uliber (ier,25h in besjc, x out of range,25)
      go to 103
  102 ier = 2+ncalc
      call uliber (ier,40h in besjc, accuracy lost for some orders,40)
  103 return
      end

c
c********************************************************************
c

      subroutine deriv_x(f, id, jd, kd, i, j, k, imax, jmax, kmax,
     .                     dx, dfdx, d2fdx2)

      implicit none

      integer id, jd, kd, i, j, k, imax, jmax, kmax
      real f(id, jd, kd), dx, dfdx, d2fdx2

      if(i .ne. 1 .and. i .ne. imax)then
         dfdx = (f(i+1, j, k) - f(i-1, j, k)) / (2.0 * dx)
         d2fdx2 = (f(i+1,j,k) - 2. * f(i,j,k) + f(i-1,j,k)) / dx**2
      end if

      if(i .eq. 1)then
         dfdx = (f(i+1, j, k) - f(i, j, k)) / dx
         d2fdx2 = (f(i+2,j,k) - 2. * f(i+1,j,k) + f(i,j,k)) / dx**2
      end if

      if(i .eq. imax)then
         dfdx = (f(i, j, k) - f(i-1, j, k)) / dx
         d2fdx2 = (f(i,j,k) - 2. * f(i-1,j,k) + f(i-2,j,k)) / dx**2
      end if

      return
      end

c
c***************************************************************************
c
      subroutine deriv_y(f, id, jd, kd, i, j, k, imax, jmax, kmax,
     .                     dy, dfdy, d2fdy2)

      implicit none

      integer id, jd, kd, i, j, k, imax, jmax, kmax
      real f(id, jd, kd), dy, dfdy, d2fdy2

      if(j .ne. 1 .and. j .ne. jmax)then
         dfdy = (f(i, j+1, k) - f(i, j-1, k)) / (2.0 * dy)
         d2fdy2 = (f(i,j+1,k) - 2. * f(i,j,k) + f(i,j-1,k)) / dy**2
      end if

      if(j .eq. 1)then
         dfdy = (f(i, j+1, k) - f(i, j, k)) / dy
         d2fdy2 = (f(i,j+2,k) - 2. * f(i,j+1,k) + f(i,j,k)) / dy**2
      end if

      if(j .eq. jmax)then
         dfdy = (f(i, j, k) - f(i, j-1, k)) / dy
         d2fdy2 = (f(i,j,k) - 2. * f(i,j-1,k) + f(i,j-2,k)) / dy**2
      end if

      return
      end
c
c***************************************************************************
c
      subroutine deriv_xy(f, id, jd, kd, i, j, k, imax, jmax, kmax,
     .                     dx, dy, d2fdxy)

      implicit none

      integer id, jd, kd, i, j, k, imax, jmax, kmax
      real f(id, jd, kd), dx, dy, d2fdxy

      d2fdxy = 0.0

      if(i .ne. 1 .and. i .ne. imax .and.
     .   j .ne. 1 .and. j .ne. jmax) then

         d2fdxy = (f(i+1, j+1, k) - f(i-1, j+1, k)
     .           - f(i+1, j-1, k) + f(i-1, j-1, k) ) / (4. * dx * dy)
      end if

      return
      end

c
c***************************************************************************
c
      subroutine deriv_phi(f, id, jd, kd, i, j, k, imax, jmax, kmax,
     .                     dphi, dfdphi, d2fdphi2)

      implicit none

      integer id, jd, kd, i, j, k, imax, jmax, kmax, kp1, km1
      real f(id, jd, kd), dphi, dfdphi, d2fdphi2

      kp1 = k + 1
      km1 = k - 1

      if(k .eq. 1)    km1 = kmax
      if(k .eq. kmax) kp1 = 1

      dfdphi = (f(i, j, kp1) - f(i, j, km1)) / (2.0 * dphi)
      d2fdphi2 = (f(i,j,kp1) - 2.0 * f(i,j,k) + f(i,j,km1)) / dphi**2

      return
      end

c
c***************************************************************************
c

      subroutine deriv_xphi(f, id, jd, kd, i, j, k, imax, jmax, kmax,
     .                     dx, dphi, d2fdxphi)

      implicit none

      integer id, jd, kd, i, j, k, imax, jmax, kmax, kp1, km1
      real f(id, jd, kd), dx, dphi, d2fdxphi

      kp1 = k + 1
      km1 = k - 1

      if(k .eq. 1)    km1 = kmax
      if(k .eq. kmax) kp1 = 1

      if (i .ne. 1 .and. i .ne. imax)then

         d2fdxphi = (f(i+1, j, kp1) - f(i+1, j, km1)
     .             - f(i-1, j, kp1) + f(i-1, j, km1)) / (4. * dx * dphi)

      end if

      return
      end

c
c***************************************************************************
c
      subroutine deriv_yphi(f, id, jd, kd, i, j, k, imax, jmax, kmax,
     .                     dy, dphi, d2fdyphi)

      implicit none

      integer id, jd, kd, i, j, k, imax, jmax, kmax, kp1, km1
      real f(id, jd, kd), dy, dphi, d2fdyphi

      kp1 = k + 1
      km1 = k - 1

      if(k .eq. 1)    km1 = kmax
      if(k .eq. kmax) kp1 = 1

      if (j .ne. 1 .and. j .ne. jmax)then

         d2fdyphi = (f(i, j+1, kp1) - f(i, j+1, km1)
     .             - f(i, j-1, kp1) + f(i, j-1, km1)) / (4. * dy * dphi)

      end if

      return
      end
c
c***************************************************************************
c
      subroutine torint(x, y, phi, f,  ans,
     .   nx1, nx2, ny1, ny2, nphi1, nphi2,
     .   capr, nxmax, nymax, nphimax)

      implicit none

      integer i, j, k, nx1, nx2, ny1, ny2, nphi1, nphi2,
     .   nxmax, nymax, nphimax

      real f(nxmax, nxmax, nphimax),
     .     x(nxmax), y(nymax), phi(nphimax),
     .     capr(nxmax), ans, dx, dy, dphi

      ans = 0.0

      do k = nphi1, nphi2 - 1
         dphi = phi(k+1) - phi(k)

         do i = nx1, nx2 - 1
            dx = x(i+1) - x(i)

            do j = ny1, ny2 - 1
               dy = y(j+1) - y(j)

               ans = ans + dx * dy * dphi * (
     .                      capr(i) * (f(i,j,k)   + f(i,j+1,k)
     .                               + f(i,j,k+1) + f(i,j+1,k+1))

     .                  + capr(i+1) * (f(i+1,j,k)   + f(i+1,j+1,k)
     .                               + f(i+1,j,k+1) + f(i+1,j+1,k+1))
     .                                       )/8.0
            end do
         end do
      end do

      return
      end

c
c***************************************************************************
c

      SUBROUTINE ZFUN(Z,FU)
C
C     ROUTINE WHICH EVALUATES THE PLASMA DISPERSION FUNCTION.  USES
C     NUMERICAL INTEGRATION (ABSOLUTE VALUE OF THE COMPLEX ARGUMENT, Z,
C     LESS THAN 5) OR ASYMPTOTIC EXPANSION.
C
      COMPLEX Z,FU,TEMP1,TEMP2,Z2,TPIIOD
      DIMENSION C(21),D(21),E(21),F(21),W(21)
      DATA DELTA/5.0E-1/, YI/-1.0E+0/, N/21/, ITEST/0/
      DATA ZERO/0.0E+0/, OSQPI/5.6418958355E-1/, TPI/6.28318530718E+0/
C
      IF(ITEST .EQ. 1) GO TO 1
      ITEST=1
C***     DEFINE WEIGHTS AND STORE CONSTANTS USED FOR INTEGRATION.
C***     WEIGHTS ARE DERIVED FROM A 3 POINT INTEGRATION SCHEME.
      NM3=N-3
      CONOI=DELTA*OSQPI
      W(1)=CONOI*3.75E-1
      W(2)=CONOI*1.1666666667E+0
      W(3)=CONOI*9.5833333333E-1
      DO 20 I=1,3
        NMIP1=N-I+1
   20 W(NMIP1)=W(I)
      DO 30 I=4,NM3
   30 W(I)=CONOI
      NO2=N/2
      NO2P1=NO2+1
      X=ZERO
      Y=YI
      E(NO2P1)=X
      F(NO2P1)=Y
      TEMP1=CMPLX(X,Y)
      TEMP2=CEXP(-TEMP1*TEMP1)
      C(NO2P1)=REAL(TEMP2)*W(NO2P1)
      D(NO2P1)=AIMAG(TEMP2)*W(NO2P1)
      DO 200 I=1,NO2
      X=DELTA*FLOAT(I)
      NPI=NO2P1+I
      NMI=NO2P1-I
      TEMP1=CMPLX(X,Y)
      TEMP2=CEXP(-TEMP1*TEMP1)
      C(NPI)=REAL(TEMP2)*W(NPI)
      C(NMI)=REAL(TEMP2)*W(NMI)
      D(NPI)=AIMAG(TEMP2)*W(NPI)
      D(NMI)=AIMAG(TEMP2)*W(NMI)*(-1.0E+0)
      E(NMI)=-X
      E(NPI)=X
      F(NPI)=Y
      F(NMI)=Y
  200 CONTINUE
      TPIOD=TPI/DELTA
      TPIIOD=CMPLX(ZERO,TPIOD)
C***     BEGIN CALCULATIONS.
    1 G=REAL(Z)
      YY=AIMAG(Z)
      H=ABS(YY)
      ZA=Z*CONJG(Z)
      IF(ZA .GE. 2.5E+1) GO TO 5
      Z2=Z*Z
C***     NUMERICAL INTEGRATION.
C***     F=1/SQRT(PI)*SUM OF...W(I)*EXP(-X(I)**2)/(X(I)-Z)...I=1,N.
C***     INTEGRATION IS ALONG A LINE X(I) IN THE COMPLEX PLANE, WHERE
C***     THE IMAGINARY PART OF X(I)=YI AND THE DIFFERENCE BETWEEN
C***     SUCCESSIVE REAL PARTS OF X(I)=DELTA.  LIMITS OF INTEGRATION
C***     ARE FROM -DELTA*N/2 TO DELTA*N/2.
C***     COMPUTE THE INTEGRAL BY TAKING THE SUM FROM 1 TO N OF THE
C***     CONSTANTS DIVIDED BY X(I)-Z.  USES REAL ARITHMETIC.
      ZR=0.0E+0
      ZI=0.0E+0
      DO 7 I=1,N
      A=E(I)-G
      B=F(I)-H
      DEN=A*A+B*B
      ODEN=1.0E+0/DEN
      ZR=ZR+(A*C(I)+B*D(I))*ODEN
      ZI=ZI+(A*D(I)-B*C(I))*ODEN
    7 CONTINUE
C***     ADD THE CORRECTION TERM.
      FU=CMPLX(ZR,ZI)+(0.0E+0,-3.5449077018E+0)*CEXP(-Z2-TPIOD*
     *   (H-YI)+TPIIOD*G)
      IF(YY .GE. ZERO) GO TO 6
C***     IMAGINARY PART OF ARGUMENT IS NEGATIVE.
      FU=CONJG(FU)+(0.0E+0,3.5449077018E+0)*CEXP(-Z2)
      GO TO 6
C***     MAGNITUDE OF ARGUMENT IS GREATER THAN 5, USE
C***     ASYMPTOTIC EXPANSION.
    5 CALL AEXPAN(Z,G,H,YY,FU)
    6 RETURN
      END
      SUBROUTINE AEXPAN(Z,G,H,YY,FU)
C
C     ROUTINE WHICH COMPUTES THE PLASMA DISPERSION FUNCTION USING
C     ASYMPTOTIC EXPANSION.  IF THE IMAGINARY PART OF THE ARGUMENT, YY,
C     IS EQUAL TO ZERO REAL ARITHMETIC IS USED.
C
      COMPLEX Z,FU,A,Z2,OZ2
      DATA ZERO/0.0E+0/, N/8/
C
      IF(YY .EQ. ZERO) GO TO 1
C***     COMPLEX ARITHMETIC.
      Z2=Z*Z
      OZ2=1.0E+0/Z2
      FU=-1.0E+0/Z
      A=FU
      EN=5.0E-1
      DO 10 I=1,N
      A=EN*A*OZ2
      FU=FU+A
   10 EN=EN+1.0E+0
      IF(YY .GT. ZERO) GO TO 30
      IF(H .GT. SQRT(G*G+1.72E+2)) GO TO 20
      FU=FU+(0.0E+0,3.5449077018E+0)*CEXP(-Z2)
      GO TO 30
C***     ERROR STOP TO AVOID OVERFLOW.
   20 WRITE (51,100) Z
  100 FORMAT(//1X,'*** ERROR STOP IN FRDCNT ROUTINE, ARGUMENT IS',
     * ' TOO SMALL,  ARG =',1P2E14.6)
      STOP
C***     REAL ARITHMETIC.
    1 X2=G*G
      OX2=1.0E+0/X2
      F=-1.0E+0/G
      B=F
      EN=5.0E-1
      DO 11 I=1,N
      B=EN*B*OX2
      F=F+B
   11 EN=EN+1.0E+0
      C=1.7724538509E+0*EXP(-X2)
      FU=CMPLX(F,C)
   30 RETURN
      END
C
C
C TWO POL APPROXIMATION
C
      SUBROUTINE Z2P(Z,F)
      COMPLEX Z,F
      F=CMPLX(.5,.81)/(CMPLX(.51,-.81)-Z)-CMPLX(.5,-.81)
     1/(CMPLX(.51,.81)+Z)
      RETURN
      END

c
c THIS CODE IS SUPERIOR TO PDF AND PDFLL.  NO ERROR AT ZETA=(4.,0.1)
c  disp(z) is the plasma z function
c
      complex function disp(z)
      complex z
      real im
      x=real(z)
      y=aimag(z)
      call zzdisp(x,y,re,im)
      disp=cmplx(re,im)
      return
      end
c
c***************************************************************************
c
c
c  disp1(z) calculates first derivative of disp(z)
c
      complex function disp1(z)
      complex z,dp,disp
      complex zz
      zz=z
      dp=disp(z)
      disp1=-2.0-2.0*zz*dp
      return
      end
c
c***************************************************************************
c
c
c  calculates plasma z function
c
      subroutine zzdisp(x,y,zzr,zzi)
      x1=abs(x)
      y1=abs(y)
      call wzdisp(x1,y1,wzr1,wzi1)
      if(x.ge.0..and.y.ge.0.) go to 1
      if(x.le.0..and.y.ge.0.) go to 2
      a=2*x1*y1
      b=-(x1*x1-y1*y1)
      abr=2*exp(b)*cos(a)
      abi=-2*exp(b)*sin(a)
      wzr1=abr-wzr1
      wzi1=abi-wzi1
      if(x.le.0..and.y.le.0.) go to 1
    2 wzi1=-wzi1
    1 zzr=-1.7724538509055*wzi1
      zzi=1.7724538509055*wzr1
      return
      end
c
c***************************************************************************
c
cc   needed for z function
cc
      subroutine wzdisp(x,y,re,im)
      equivalence(epsh,epsl,epsy)
      real im,lambda
      integer capn
      logical b
      epsh=1.e-12
      if(y.lt.4.29 .and. x.lt.5.33) go to 10
c
c  (x,y) belongs to q1-r
c
      h=0.
      capn=0
      nu=8
      go to 20
c
c  (x,y) belongs to r
c
   10 s=(1.-y/4.29)*sqrt(1.-x*x/28.41)
      h=1.6*s
      h2=2.*h
      capn=6.+23*s+.5
      nu=9.+21*s+.5
      lambda=h2**capn
   20 b=(h.eq.0. .or. lambda.lt.epsl)
c
c  statement (lambda.lt.epsl) covers the underflow case
c  when h(.gt.0) is very small.
c
      rr=0.
      ri=0.
      sr=0.
      si=0.
      nup=nu+1
      do 100 i=1,nup
      n=nup-i
      np1=n+1
      tr=y+h+np1*rr
      ti=x-np1*ri
      c=.5/(tr*tr+ti*ti)
      rr=c*tr
      ri=c*ti
      if(.not.(h.gt.0..and.n.le.capn)) go to 100
      tr=lambda+sr
      sr=rr*tr-ri*si
      si=ri*tr+rr*si
      lambda=lambda/h2
  100 continue
      cc=1.12837916709551
      if(y.lt.epsy) go to 120
      if(b) go to 110
      re=sr*cc
      go to 130
  110 re=rr*cc
      go to 130
  120 re=exp(-x*x)
  130 if(b) go to 140
      im=si*cc
      go to 150
  140 im=ri*cc
  150 return
      end

c
c***************************************************************************
c
      real function second1(dummy)

      implicit none

      integer mtime, mclock
      real dummy

c*****FALCON:
      double precision mpi_wtime
      external mpi_wtime
      second1 = MPI_WTIME()

c*****EAGLE:
c      mtime = mclock()
c      second1  = 0.01 * mtime

      return
      end


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

module MPi

    implicit none
    private

    type, public :: TPi
    contains
        procedure, nopass :: vietesSeries
        procedure, nopass :: wallisSeries
        procedure, nopass :: leibnizSeries
        procedure, nopass :: nilakanthaSeries
    end type
contains
    function vietesSeries() result(pi)
        real :: pi

        integer, parameter :: ITERATIONS = 15
        integer index
        integer jndex

        real factor

        pi = 1
        do index = ITERATIONS, 2, -1
            factor = 2

            do jndex = 1, index - 1
                factor = 2 + sqrt(factor)
            end do

            factor = sqrt(factor)
            pi = pi * factor / 2
        end do

        pi = pi * sqrt(2.0) / 2
        pi = 2 / pi
    end function

    function wallisSeries() result(pi)
        real(8) :: pi

        integer, parameter :: ITERATIONS = 900000000
        real(8) index

        index = 3
        pi    = 4
        do while (index <= (ITERATIONS + 2))
            pi = pi * ((index - 1) / index) * ((index + 1) / index)

            index = index + 2
        end do
    end function

    function leibnizSeries() result(pi)
        real(8) :: pi

        integer, parameter :: ITERATIONS = 900000000
        integer sign
        integer index

        index = 1
        sign  = 1
        pi    = 0
        do while (index <= (ITERATIONS * 2))
            pi   = pi + sign * (4.0 / index)
            sign = -sign

            index = index + 2
        end do
    end function

    function nilakanthaSeries() result(pi)
        real(8) :: pi

        integer, parameter :: ITERATIONS = 500
        integer sign
        real(8) index

        index = 2
        sign  = 1
        pi    = 3
        do while (index <= (ITERATIONS * 2))
            pi   = pi + sign * (4 / (index * (index + 1) * (index + 2)))
            sign = -sign

            index = index + 2
        end do
    end function
end module


    Program zgesvdx_example

!     ZGESVDX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zgesvdx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: vl, vu
      Integer :: i, il, info, iu, lda, ldu, ldvt, liwork, lrwork, lwork, m, n, &
        ns
      Character (1) :: range
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), u(:, :), vt(:, :), work(:)
      Real (Kind=dp), Allocatable :: rwork(:), s(:)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: nint
!     .. Executable Statements ..
      Write (nout, *) 'ZGESVDX Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldu = m
      ldvt = n
      lwork = 2*n**2 + 4*n
      lrwork = 2*n*2 + 34*n
      liwork = 12*n
      Allocate (a(lda,n), s(n), vt(ldvt,n), u(ldu,m), iwork(liwork), &
        work(lwork), rwork(lrwork))

!     Read the m by n matrix A from data file
      Read (nin, *)(a(i,1:n), i=1, m)

!     Read range for selected singular values
      Read (nin, *) range

      If (range=='I' .Or. range=='i') Then
        Read (nin, *) il, iu
      Else If (range=='V' .Or. range=='v') Then
        Read (nin, *) vl, vu
      End If

!     Compute the singular values and left and right singular vectors
!     of A.

      Call zgesvdx('V', 'V', range, m, n, a, lda, vl, vu, il, iu, ns, s, u, &
        ldu, vt, ldvt, work, lwork, rwork, iwork, info)

      If (info/=0) Then
        Write (nout, 100) 'Failure in ZGESVDX. INFO =', info
100     Format (1X, A, I4)
        Go To 120
      End If

!     Print the selected singular values of A

      Write (nout, *) 'Singular values of A:'
      Write (nout, 110) s(1:ns)
110   Format (1X, 4(3X,F11.4))

      Call compute_error_bounds(m, ns, s)

120   Continue

    Contains
      Subroutine compute_error_bounds(m, n, s)

!       Error estimates for singular values and vectors is computed
!       and printed here.

!       .. Use Statements ..
        Use lapack_interfaces, Only: ddisna
        Use lapack_precision, Only: dp
!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (In) :: m, n
!       .. Array Arguments ..
        Real (Kind=dp), Intent (In) :: s(n)
!       .. Local Scalars ..
        Real (Kind=dp) :: eps, serrbd
        Integer :: i, info
!       .. Local Arrays ..
        Real (Kind=dp), Allocatable :: rcondu(:), rcondv(:), uerrbd(:), &
          verrbd(:)
!       .. Intrinsic Procedures ..
        Intrinsic :: epsilon
!       .. Executable Statements ..
        Allocate (rcondu(n), rcondv(n), uerrbd(n), verrbd(n))

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed singular values.  Note that for
!       the 2-norm, S(1) = norm(A)

        eps = epsilon(1.0E0_dp)
        serrbd = eps*s(1)

!       Call DDISNA to estimate reciprocal condition
!       numbers for the singular vectors

        Call ddisna('Left', m, n, s, rcondu, info)
        Call ddisna('Right', m, n, s, rcondv, info)

!       Compute the error estimates for the singular vectors

        Do i = 1, n
          uerrbd(i) = serrbd/rcondu(i)
          verrbd(i) = serrbd/rcondv(i)
        End Do

!       Print the approximate error bounds for the singular values
!       and vectors

        Write (nout, *)
        Write (nout, *) 'Error estimates (as multiples of machine precision):'
        Write (nout, *) '  for the singular values'
        Write (nout, 100) nint(serrbd/epsilon(1.0E0_dp))
        Write (nout, *)
        Write (nout, *) '  for the left singular vectors'
        Write (nout, 100) nint(uerrbd(1:n)/epsilon(1.0E0_dp))
        Write (nout, *)
        Write (nout, *) '  for the right singular vectors'
        Write (nout, 100) nint(verrbd(1:n)/epsilon(1.0E0_dp))

100     Format (4X, 6I11)

      End Subroutine

    End Program


program main
    integer N
    real*8, dimension(:,:), allocatable :: A
    real*8 diagonal_sum
    real*8 ans

    write(*,*) 'Matrix Size? : '
    read (*,*) N
    allocate(A(N,N))

    do j = 1, N
        do i = 1, N
            write(*,*) 'Input number : '
            read(*,*) A(i,j)
        end do
    end do

    ans = diagonal_sum(N,A)

    write(*,*) "Answer = ", ans
end program main

real*8 function diagonal_sum(N,A)
    integer N
    real*8 A(N,N)

    diagonal_sum = 0.0

    do i = 1 , N
        diagonal_sum = diagonal_sum + abs(A(i,i))
    end do

    return

end function diagonal_sum


program matsum
  implicit none

  ! Variable declarations
  integer :: a_rows, a_cols, b_rows, b_cols, c_rows, c_cols
  integer :: i
  integer :: a_io, b_io, c_io, fa_stat, fb_stat, fc_stat
  real*8, allocatable :: a(:), b(:), c(:)
  character *32 :: fa, fb, fc
  logical :: fa_exists, fb_exists, fc_exists

  ! Ask user for matrices filename
  print *, "Matrix A filename?"
  read  *, fa
  print *, "Matrix B filename?"
  read  *, fb
  print *, "Matrix C filename?"
  read  *, fc

  ! Check if files exist
  inquire(file = fa, exist = fa_exists)
  inquire(file = fb, exist = fb_exists)
  inquire(file = fc, exist = fc_exists)
  if (.not. fa_exists .or. .not. fb_exists) then
    print *, "error: matrix A or B does not exist"
    call exit
  end if

  ! Open files
  open(newunit = a_io, file = fa, action = "read", iostat = fa_stat)
  open(newunit = b_io, file = fb, action = "read", iostat = fb_stat)
  if (fc_exists) then
    open(newunit = c_io, file = fc, status = "replace", action = "write", iostat = fc_stat)
  else
    open(newunit = c_io, file = fc, status = "new", action = "write", iostat = fc_stat)
  end if

  ! Check if files opened correctly
  if (fa_stat /= 0 .or. fb_stat /= 0 .or. fc_stat /= 0) then
    print *, "error: failed to open one of the matrices files"
    call exit
  end if

  ! Read matrix A
  read(a_io, '(I1, X, I1)') a_rows, a_cols
  allocate(a(a_rows * a_cols))
  read(a_io, *) (a(i), i = 1, a_rows * a_cols)

  ! Read matrix B
  read(b_io, '(I1, X, I1)') b_rows, b_cols
  allocate(b(b_rows * b_cols))
  read(b_io, *) (b(i), i = 1, b_rows * b_cols)

  ! Check if matrices a_rowse summable
  if ((a_rows /= b_rows) .and. (a_cols /= b_cols)) then
    print *, "error: matrices cannot be summed (not same size)"
    call exit
  end if

  ! Initialize C matrix
  c_rows = a_rows
  c_cols = a_cols
  allocate(c(c_rows * c_cols))

  ! Compute sum
  c = a + b

  ! Write values to file
  write(c_io, '(I1, X, I1)') c_rows, c_cols
  do i = 1, c_rows * c_cols
    write(c_io, '(F17.15, X)', advance = 'no') c(i)
  end do

  ! Close files
  close(a_io)
  close(b_io)
  close(c_io)

  ! Deallocate arrays
  deallocate(a)
  deallocate(b)
  deallocate(c)
end program matsum


(* Euler1 in F# *)

let rec range i j = i :: if i>j then [] else (range (i+1) j);;
let sum xs = List.fold (+) 0 xs;;

let myTest = fun x -> if x % 3 = 0 || x % 5 = 0 then true else false;;

let euler n = sum (List.filter myTest (range 0 n));;

Printf.printf "%d\n" (euler 998);;