      subroutine curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,
     * wrk,lwrk,iwrk,ier)
c  given the set of data points (x(i),y(i)) and the set of positive
c  numbers w(i),i=1,2,...,m,subroutine curfit determines a smooth spline
c  approximation of degree k on the interval xb <= x <= xe.
c  if iopt=-1 curfit calculates the weighted least-squares spline
c  according to a given set of knots.
c  if iopt>=0 the number of knots of the spline s(x) and the position
c  t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
c  ness of s(x) is then achieved by minimalizing the discontinuity
c  jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,...,
c  n-k-1. the amount of smoothness is determined by the condition that
c  f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non-
c  negative constant, called the smoothing factor.
c  the fit s(x) is given in the b-spline representation (b-spline coef-
c  ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of
c  subroutine splev.
c
c  calling sequence:
c     call curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk,
c    * lwrk,iwrk,ier)
c
c  parameters:
c   iopt  : integer flag. on entry iopt must specify whether a weighted
c           least-squares spline (iopt=-1) or a smoothing spline (iopt=
c           0 or 1) must be determined. if iopt=0 the routine will start
c           with an initial set of knots t(i)=xb, t(i+k+1)=xe, i=1,2,...
c           k+1. if iopt=1 the routine will continue with the knots
c           found at the last call of the routine.
c           attention: a call with iopt=1 must always be immediately
c           preceded by another call with iopt=1 or iopt=0.
c           unchanged on exit.
c   m     : integer. on entry m must specify the number of data points.
c           m > k. unchanged on exit.
c   x     : real array of dimension at least (m). before entry, x(i)
c           must be set to the i-th value of the independent variable x,
c           for i=1,2,...,m. these values must be supplied in strictly
c           ascending order. unchanged on exit.
c   y     : real array of dimension at least (m). before entry, y(i)
c           must be set to the i-th value of the dependent variable y,
c           for i=1,2,...,m. unchanged on exit.
c   w     : real array of dimension at least (m). before entry, w(i)
c           must be set to the i-th value in the set of weights. the
c           w(i) must be strictly positive. unchanged on exit.
c           see also further comments.
c   xb,xe : real values. on entry xb and xe must specify the boundaries
c           of the approximation interval. xb<=x(1), xe>=x(m).
c           unchanged on exit.
c   k     : integer. on entry k must specify the degree of the spline.
c           1<=k<=5. it is recommended to use cubic splines (k=3).
c           the user is strongly dissuaded from choosing k even,together
c           with a small s-value. unchanged on exit.
c   s     : real.on entry (in case iopt>=0) s must specify the smoothing
c           factor. s >=0. unchanged on exit.
c           for advice on the choice of s see further comments.
c   nest  : integer. on entry nest must contain an over-estimate of the
c           total number of knots of the spline returned, to indicate
c           the storage space available to the routine. nest >=2*k+2.
c           in most practical situation nest=m/2 will be sufficient.
c           always large enough is  nest=m+k+1, the number of knots
c           needed for interpolation (s=0). unchanged on exit.
c   n     : integer.
c           unless ier =10 (in case iopt >=0), n will contain the
c           total number of knots of the spline approximation returned.
c           if the computation mode iopt=1 is used this value of n
c           should be left unchanged between subsequent calls.
c           in case iopt=-1, the value of n must be specified on entry.
c   t     : real array of dimension at least (nest).
c           on successful exit, this array will contain the knots of the
c           spline,i.e. the position of the interior knots t(k+2),t(k+3)
c           ...,t(n-k-1) as well as the position of the additional knots
c           t(1)=t(2)=...=t(k+1)=xb and t(n-k)=...=t(n)=xe needed for
c           the b-spline representation.
c           if the computation mode iopt=1 is used, the values of t(1),
c           t(2),...,t(n) should be left unchanged between subsequent
c           calls. if the computation mode iopt=-1 is used, the values
c           t(k+2),...,t(n-k-1) must be supplied by the user, before
c           entry. see also the restrictions (ier=10).
c   c     : real array of dimension at least (nest).
c           on successful exit, this array will contain the coefficients
c           c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x)
c   fp    : real. unless ier=10, fp contains the weighted sum of
c           squared residuals of the spline approximation returned.
c   wrk   : real array of dimension at least (m*(k+1)+nest*(7+3*k)).
c           used as working space. if the computation mode iopt=1 is
c           used, the values wrk(1),...,wrk(n) should be left unchanged
c           between subsequent calls.
c   lwrk  : integer. on entry,lwrk must specify the actual dimension of
c           the array wrk as declared in the calling (sub)program.lwrk
c           must not be too small (see wrk). unchanged on exit.
c   iwrk  : integer array of dimension at least (nest).
c           used as working space. if the computation mode iopt=1 is
c           used,the values iwrk(1),...,iwrk(n) should be left unchanged
c           between subsequent calls.
c   ier   : integer. unless the routine detects an error, ier contains a
c           non-positive value on exit, i.e.
c    ier=0  : normal return. the spline returned has a residual sum of
c             squares fp such that abs(fp-s)/s <= tol with tol a relat-
c             ive tolerance set to 0.001 by the program.
c    ier=-1 : normal return. the spline returned is an interpolating
c             spline (fp=0).
c    ier=-2 : normal return. the spline returned is the weighted least-
c             squares polynomial of degree k. in this extreme case fp
c             gives the upper bound fp0 for the smoothing factor s.
c    ier=1  : error. the required storage space exceeds the available
c             storage space, as specified by the parameter nest.
c             probably causes : nest too small. if nest is already
c             large (say nest > m/2), it may also indicate that s is
c             too small
c             the approximation returned is the weighted least-squares
c             spline according to the knots t(1),t(2),...,t(n). (n=nest)
c             the parameter fp gives the corresponding weighted sum of
c             squared residuals (fp>s).
c    ier=2  : error. a theoretically impossible result was found during
c             the iteration process for finding a smoothing spline with
c             fp = s. probably causes : s too small.
c             there is an approximation returned but the corresponding
c             weighted sum of squared residuals does not satisfy the
c             condition abs(fp-s)/s < tol.
c    ier=3  : error. the maximal number of iterations maxit (set to 20
c             by the program) allowed for finding a smoothing spline
c             with fp=s has been reached. probably causes : s too small
c             there is an approximation returned but the corresponding
c             weighted sum of squared residuals does not satisfy the
c             condition abs(fp-s)/s < tol.
c    ier=10 : error. on entry, the input data are controlled on validity
c             the following restrictions must be satisfied.
c             -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m
c             xb<=x(1)<x(2)<...<x(m)<=xe, lwrk>=(k+1)*m+nest*(7+3*k)
c             if iopt=-1: 2*k+2<=n<=min(nest,m+k+1)
c                         xb<t(k+2)<t(k+3)<...<t(n-k-1)<xe
c                       the schoenberg-whitney conditions, i.e. there
c                       must be a subset of data points xx(j) such that
c                         t(j) < xx(j) < t(j+k+1), j=1,2,...,n-k-1
c             if iopt>=0: s>=0
c                         if s=0 : nest >= m+k+1
c             if one of these conditions is found to be violated,control
c             is immediately repassed to the calling program. in that
c             case there is no approximation returned.
c
c  further comments:
c   by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the spline will be too smooth and signal will be
c   lost ; if s is too small the spline will pick up too much noise. in
c   the extreme cases the program will return an interpolating spline if
c   s=0 and the weighted least-squares polynomial of degree k if s is
c   very large. between these extremes, a properly chosen s will result
c   in a good compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the weights w(i). if these are
c   taken as 1/d(i) with d(i) an estimate of the standard deviation of
c   y(i), a good s-value should be found in the range (m-sqrt(2*m),m+
c   sqrt(2*m)). if nothing is known about the statistical error in y(i)
c   each w(i) can be set equal to one and s determined by trial and
c   error, taking account of the comments above. the best is then to
c   start with a very large value of s ( to determine the least-squares
c   polynomial and the corresponding upper bound fp0 for s) and then to
c   progressively decrease the value of s ( say by a factor 10 in the
c   beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
c   approximation shows more detail) to obtain closer fits.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt=0.
c   if iopt=1 the program will continue with the set of knots found at
c   the last call of the routine. this will save a lot of computation
c   time if curfit is called repeatedly for different values of s.
c   the number of knots of the spline returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   function underlying the data. but, if the computation mode iopt=1
c   is used, the knots returned may also depend on the s-values at
c   previous calls (if these were smaller). therefore, if after a number
c   of trials with different s-values and iopt=1, the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   curfit once more with the selected value for s but now with iopt=0.
c   indeed, curfit may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c
c  other subroutines required:
c    fpback,fpbspl,fpchec,fpcurf,fpdisc,fpgivs,fpknot,fprati,fprota
c
c  references:
c   dierckx p. : an algorithm for smoothing, differentiation and integ-
c                ration of experimental data using spline functions,
c                j.comp.appl.maths 1 (1975) 165-184.
c   dierckx p. : a fast algorithm for smoothing data on a rectangular
c                grid while using spline functions, siam j.numer.anal.
c                19 (1982) 1286-1304.
c   dierckx p. : an improved algorithm for curve fitting with spline
c                functions, report tw54, dept. computer science,k.u.
c                leuven, 1981.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : may 1979
c  latest update : march 1987
c
c  ..
c  ..scalar arguments..
      real*8 xb,xe,s,fp
      integer iopt,m,k,nest,n,lwrk,ier
c  ..array arguments..
      real*8 x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk)
      integer iwrk(nest)
c  ..local scalars..
      real*8 tol
      integer i,ia,ib,ifp,ig,iq,iz,j,k1,k2,lwest,maxit,nmin
c  ..
c  we set up the parameters tol and maxit
      maxit = 20
      tol = 0.1d-02
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(k.le.0 .or. k.gt.5) go to 50
      k1 = k+1
      k2 = k1+1
      if(iopt.lt.(-1) .or. iopt.gt.1) go to 50
      nmin = 2*k1
      if(m.lt.k1 .or. nest.lt.nmin) go to 50
      lwest = m*k1+nest*(7+3*k)
      if(lwrk.lt.lwest) go to 50
      if(xb.gt.x(1) .or. xe.lt.x(m)) go to 50
      do 10 i=2,m
         if(x(i-1).gt.x(i)) go to 50
  10  continue
      if(iopt.ge.0) go to 30
      if(n.lt.nmin .or. n.gt.nest) go to 50
      j = n
      do 20 i=1,k1
         t(i) = xb
         t(j) = xe
         j = j-1
  20  continue
      call fpchec(x,m,t,n,k,ier)
      if (ier.eq.0) go to 40
      go to 50
  30  if(s.lt.0.) go to 50
      if(s.eq.0. .and. nest.lt.(m+k1)) go to 50
c we partition the working space and determine the spline approximation.
  40  ifp = 1
      iz = ifp+nest
      ia = iz+nest
      ib = ia+nest*k1
      ig = ib+nest*k2
      iq = ig+nest*k2
      call fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp,
     * wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq),iwrk,ier)
  50  return
      end


      SUBROUTINE SRFVAL (X, Y, Z, RF, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>>   1998-10-29 SRFVAL Krogh  Moved external statement up for mangle.
C>>   1995-11-17 SRFVAL Krogh  Converted SFTRAN to Fortran 77.
c>>   1994-11-02 SRFVAL Krogh  Changes to use M77CON
c>>   1994-08-15 SRFVAL WV Snyder JPL use 2-arg min and max for C conv.
c>>   1993-02-23 SRFVAL WV Snyder JPL Split SRFVLX into a separate subr.
C>>   1991-10-31 SRFVAL WV Snyder JPL Incorporate changes from Carlson
C>>   1990-11-27 SRFVAL WV Snyder JPL Convert Carlson's code for MATH77
C
C--S replaces "?": ?ERM1, ?ERV1, ?RFVAL, ?RFVLX
C
C     CHECK ARGUMENT RANGES AND CALL SRFVLX TO DO THE COMPUTATION
C     OF CARLSON'S ELLIPTIC INTEGRAL RF(X,Y,Z).
C
C     INPUT ...
C
C     X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z).
C
C     OUTPUT ...
C
C     RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C     IERR IS THE RETURN ERROR CODE.
C          IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C          IERR = 1  X, Y, OR Z IS NEGATIVE.
C          IERR = 2  X+Y, X+Z, OR Y+Z IS TOO SMALL.
C          IERR = 3  X, Y, OR Z IS TOO LARGE.
C
      REAL             X, Y, Z, RF
      INTEGER IERR
C ----------------------------------------------------------------------
      EXTERNAL R1MACH
      REAL             R1MACH
C ----------------------------------------------------------------------
C
C     MACHINE DEPENDENT PARAMETERS ...
C
C     LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C     LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5.
C     UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5.
C
      REAL             LOLIM, UPLIM
      SAVE LOLIM, UPLIM
      DATA LOLIM /-1.0e0/
C ----------------------------------------------------------------------
C     WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C     EXPENSE OF ROBUSTNESS.
C ----------------------------------------------------------------------
C
      RF = 0.0e0
      IF (MIN(X,MIN(Y,Z)) .LT. 0.0e0) THEN
         IERR = 1
         CALL SERM1 ('SRFVAL',1,0,'One of X, Y or Z is negative','X',x,
     1     ',')
         CALL SERV1 ('Y',Y,',')
         CALL SERV1 ('Z',Z,'.')
         RETURN
      END IF
      IF (LOLIM .LT. 0.0e0) THEN
         LOLIM = 5.0e0 * R1MACH(1)
         UPLIM = R1MACH(2) / 5.0e0
      END IF
      IF (MAX(X,MAX(Y,Z)) .GT. UPLIM) THEN
         IERR = 3
         CALL SERM1 ('SRFVAL',3,0,'One of X, Y or Z > UPLIM','X',
     1     x,',')
         CALL SERV1 ('Y',Y,',')
         CALL SERV1 ('Z',Z,',')
         CALL SERV1 ('UPLIM',UPLIM,'.')
         RETURN
      END IF
      IF (MIN(X+Y,MIN(X+Z,Y+Z)) .LT. LOLIM) THEN
         IERR = 2
         CALL SERM1 ('SRFVAL',2,0,'One of X+Y, X+Z or Y+Z < LOLIM','X',
     1     x,',')
         CALL SERV1 ('Y',Y,',')
         CALL SERV1 ('Z',Z,',')
         CALL SERV1 ('LOLIM',LOLIM,'.')
         RETURN
      END IF
C
      IERR = 0
      CALL SRFVLX (X, Y, Z, RF)
      RETURN
      END

      SUBROUTINE SRFVLX (X, Y, Z, RF)
c>>   1993-02-23 SRFVLX WV Snyder JPL Split SRFVLX into a separate subr.
C     ------------------------------------------------------------------
C     SRFVLX SHOULD ONLY BE CALLED FROM OTHER LIBRARY ROUTINES, WHERE WE
C     KNOW X, Y, Z ARE IN RANGE.  USERS SHOULD NOT CALL SRFVLX DIRECTLY.
C     ------------------------------------------------------------------
C
C     COMPUTE THE INCOMPLETE ELLIPTIC INTEGRAL OF THE FIRST KIND
C
C     RF(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                           -1/2     -1/2     -1/2
C                 (1/2)(T+X)    (T+Y)    (T+Z)    DT,
C
C     WHERE X, Y, AND Z ARE NONNEGATIVE AND AT MOST ONE OF THEM
C     IS ZERO.  IF ONE OF THEM IS ZERO, THE INTEGRAL IS COMPLETE.
C     THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE
C     NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR
C     SERIES TO FIFTH ORDER.
C     REFERENCES: B. C. CARLSON AND E. M. NOTIS, ALGORITHMS FOR
C     INCOMPLETE ELLIPTIC INTEGRALS, ACM TRANSACTIONS ON MATHEMA-
C     TICAL SOFTWARE, 7 (1981), 398-403; B. C. CARLSON, COMPUTING
C     ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH., 33 (1979),
C     1-16.
C     AUTHORS: B. C. CARLSON AND ELAINE M. NOTIS, AMES LABORATORY-
C     DOE, IOWA STATE UNIVERSITY, AMES, IA 50011, AND R. L. PEXTON,
C     LAWRENCE LIVERMORE NATIONAL LABORATORY, LIVERMORE, CA 94550.
C     AUG. 1, 1979, REVISED JAN. 15, 1987.
C
C     CHECK VALUE: RF(0,1,2) = 1.31102 87771 46059 90523 24198
C     CHECK BY ADDITION THEOREM: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W)
C     = RF(0,Z,W), WHERE X,Y,Z,W ARE POSITIVE AND X * Y = Z * W.
C
      REAL             X, Y, Z, RF
C     INPUT ...
C
C     X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z).
C
C     OUTPUT ...
C
C     RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C ----------------------------------------------------------------------
      EXTERNAL R1MACH
      REAL             R1MACH
      REAL             C1,C2,C3,E2,E3,EPSLON,ERRTOL,LAMDA
      REAL             MU,S,XN,XNDEV,XNROOT
      REAL             YN,YNDEV,YNROOT,ZN,ZNDEV,ZNROOT
      PARAMETER (C1 = 10.0e0 / 24.0e0)
      PARAMETER (C2 = 30.0e0 / 44.0e0)
      PARAMETER (C3 = 10.0e0 / 14.0e0)
C ----------------------------------------------------------------------
C     MACHINE DEPENDENT PARAMETER ...
C     ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C     RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C     ERRTOL ** 6 / (4 * (1 - ERRTOL)).
C
      SAVE ERRTOL
      DATA ERRTOL /-1.0E0/
C ----------------------------------------------------------------------
      IF (ERRTOL .LT. 0.0e0) ERRTOL = (3.6e0 * R1MACH(4))**(1.0e0/6.0e0)
      XN = X
      YN = Y
      ZN = Z
C
   20 CONTINUE
         MU = (XN + YN + ZN) / 3.0e0
         XNDEV = 2.0e0 - (MU + XN) / MU
         YNDEV = 2.0e0 - (MU + YN) / MU
         ZNDEV = 2.0e0 - (MU + ZN) / MU
         EPSLON = MAX(ABS(XNDEV),MAX(ABS(YNDEV),ABS(ZNDEV)))
         IF (EPSLON .LT. ERRTOL) THEN
            E3 = XNDEV * YNDEV
            E2 = E3 - ZNDEV * ZNDEV
            E3 = E3 * ZNDEV
            S = 10.0e0 + (C1 * E2 - 1.0e0 - C2 * E3) * E2 + C3 * E3
            RF = S / (10.0e0*SQRT(MU))
            RETURN
         END IF
         XNROOT = SQRT(XN)
         YNROOT = SQRT(YN)
         ZNROOT = SQRT(ZN)
         LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
         XN = (XN + LAMDA) * 0.25e0
         YN = (YN + LAMDA) * 0.25e0
         ZN = (ZN + LAMDA) * 0.25e0
      GO TO 20
      END


module testRandNum
  use randomNumbers
  use statTests

  use iso_fortran_env
  implicit none

  private
  integer, parameter :: dp = kind(0.d0)

  public :: randNumTest

contains

  subroutine randNumTest()
    implicit none

    integer :: i

    ! Variables to time functions
    integer(int64) :: t1, t2, clock_rate, clock_max

    ! Variables to test random number generators
    integer, parameter :: randArrayN = 50000000
    integer, parameter :: randChiSqK = 500
    integer :: randArrayInt(randArrayN)
    real(dp) :: randArray(randArrayN)
    real(dp) :: randMean, randStdDev

    integer, parameter :: chiSqDOF = 999
    real(dp) :: chiSq

    write(*,'(a)') '*************************************'
    write(*,'(a,1x,i0,1x,a)') 'Testing random number generators with', randArrayN,'numbers:'

    call randSeedGenerator(1234)

    !xorshift
    write(*,'(2x,a)') 'xorshift:'
    call system_clock(t1, clock_rate, clock_max)
    do i=1,randArrayN
      randArray(i) = xorshift()
    end do
    call system_clock(t2, clock_rate, clock_max)
    write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time to generate', randArrayN, 'numbers =', dble(t2-t1)/dble(clock_rate), ' sec'
    call stdDev(randArray,randMean,randStdDev)
    write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
              'min =', minval(randArray,1), 'max =', maxval(randArray,1)
    call chiSqTest(randArray, chiSqDOF+1, 0.d0, 1.d0, chiSq)
    write(*,'(4x,a,1x,es12.5,1x,a,1x,i0,1x,a)') 'chi-squared value:', chiSq, 'with', chiSqDOF, 'degrees of freedom'
    write(*,*)

    write(*,'(2x,a)') 'xorshiftInt:'
    call randSeedGenerator(12345679)
    call system_clock(t1, clock_rate, clock_max)
    do i=1,randArrayN
      randArrayInt(i) = xorshiftInt(101)
    end do
    call system_clock(t2, clock_rate, clock_max)
    write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, ' numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
    call stdDev(randArrayInt,randMean,randStdDev)
    write(*,'(3x,2(1x,a,1x,es12.5),2(1x,a,1x,i0))') 'mean =', randMean, 'stdDev =', randStdDev, &
              'min =', minval(randArrayInt,1), 'max =', maxval(randArrayInt,1)
    write(*,*)

    write(*,'(2x,a)') 'xorshift64star:'
    call randSeedGenerator(12345679)
    call system_clock(t1, clock_rate, clock_max)
    do i=1,randArrayN
      randArray(i) = xorshift64star()
    end do
    call system_clock(t2, clock_rate, clock_max)
    write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time to generate', randArrayN, 'numbers =', dble(t2-t1)/dble(clock_rate), ' sec'
    call stdDev(randArray,randMean,randStdDev)
    write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
              'min =', minval(randArray,1), 'max =', maxval(randArray,1)
    call chiSqTest(randArray, chiSqDOF+1, 0.d0, 1.d0, chiSq)
    write(*,'(4x,a,1x,es12.5,1x,a,1x,i0,1x,a)') 'chi-squared value:', chiSq, 'with', chiSqDOF, 'degrees of freedom'
    write(*,*)

    write(*,'(2x,a)') 'xorshift64starInt:'
    call randSeedGenerator(12345679)
    call system_clock(t1, clock_rate, clock_max)
    do i=1,randArrayN
      randArrayInt(i) = xorshift64starInt(101)
    end do
    call system_clock(t2, clock_rate, clock_max)
    write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, ' numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
    call stdDev(randArrayInt,randMean,randStdDev)
    write(*,'(3x,2(1x,a,1x,es12.5),2(1x,a,1x,i0))') 'mean =', randMean, 'stdDev =', randStdDev, &
              'min =', minval(randArrayInt,1), 'max =', maxval(randArrayInt,1)
    write(*,*)

    write(*,'(2x,a)') 'xorshift128:'
    call system_clock(t1, clock_rate, clock_max)
    do i=1,randArrayN
      randArray(i) = xorshift128()
    end do
    call system_clock(t2, clock_rate, clock_max)
    write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time to generate', randArrayN, 'numbers =', dble(t2-t1)/dble(clock_rate), ' sec'
    call stdDev(randArray,randMean,randStdDev)
    write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
              'min =', minval(randArray,1), 'max =', maxval(randArray,1)
    call chiSqTest(randArray, chiSqDOF+1, 0.d0, 1.d0, chiSq)
    write(*,'(4x,a,1x,es12.5,1x,a,1x,i0,1x,a)') 'chi-squared value:', chiSq, 'with', chiSqDOF, 'degrees of freedom'
    write(*,*)

    write(*,'(2x,a)') 'xorshift128Int:'
    call randSeedGenerator(12345679)
    call system_clock(t1, clock_rate, clock_max)
    do i=1,randArrayN
      randArrayInt(i) = xorshift128Int(101)
    end do
    call system_clock(t2, clock_rate, clock_max)
    write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, ' numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
    call stdDev(randArrayInt,randMean,randStdDev)
    write(*,'(3x,2(1x,a,1x,es12.5),2(1x,a,1x,i0))') 'mean =', randMean, 'stdDev =', randStdDev, &
              'min =', minval(randArrayInt,1), 'max =', maxval(randArrayInt,1)
    write(*,*)

    write(*,'(2x,a)') 'mt19937:'
    call randSeedGenerator(12345678)
    call system_clock(t1, clock_rate, clock_max)
    do i=1,randArrayN
      randArray(i) = mt19937()
    end do
    call system_clock(t2, clock_rate, clock_max)
    write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time to generate', randArrayN, 'numbers =', dble(t2-t1)/dble(clock_rate), ' sec'
    call stdDev(randArray,randMean,randStdDev)
    write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
              'min =', minval(randArray,1), 'max =', maxval(randArray,1)
    call chiSqTest(randArray, chiSqDOF+1, 0.d0, 1.d0, chiSq)
    write(*,'(4x,a,1x,es12.5,1x,a,1x,i0,1x,a)') 'chi-squared value:', chiSq, 'with', chiSqDOF, 'degrees of freedom'
    write(*,*)

  end subroutine

end module


SUBROUTINE formtb(pb,km,g)
!
! This subroutine assembles an unsymmetrical band matrix pb from
! element constituent matrices km.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:)
 INTEGER,INTENT(IN)::g(:)
 REAL(iwp),INTENT(OUT)::pb(:,:)
 INTEGER::i,j,idof,icd,iw
 idof=SIZE(km,1)
 iw=(SIZE(pb,2)-1)/2
 DO i=1,idof
   IF(g(i)/=0)THEN
     DO j=1,idof
       IF(g(j)/=0)THEN
         icd=g(j)-g(i)+iw+1
         pb(g(i),icd)=pb(g(i),icd)+km(i,j)
       END IF
     END DO
   END IF
 END DO
RETURN
END SUBROUTINE formtb


! { dg-options "-ffast-math -O2 -fgraphite-identity" }

module mcc_m
  integer, parameter, private :: longreal = selected_real_kind(15,90)
contains
  subroutine mutual_ind_cir_cir_coils (m, l12)
    real (kind = longreal), intent(out) :: l12
    real (kind = longreal), dimension(1:9), save :: zw
    gauss:do i = 1, 9
       theta_l12 = 0.0_longreal
       theta1:   do n1 = 1, 2*m
          theta_1 = pi*real(n1,longreal)/real(m,longreal)
          theta2:       do n2 = 1, 2*m
             numerator = -sin(theta_1)*tvx + cos(theta_1)*tvy
             theta_l12 = theta_l12 + numerator/denominator
          end do theta2
       end do theta1
       l12 = l12 + zw(i)*theta_l12
    end do gauss
    l12 = coefficient * l12
  end subroutine mutual_ind_cir_cir_coils
end module mcc_m


! -*- f90 -*-
subroutine strfn_vec(ax,ay,az,nt,lags,nlag,orders,nord,dt,r,S)
   implicit none
   integer*8, intent(in) :: nt,nlag,nord
   double precision, intent(in), dimension(nt) :: ax,ay,az
   integer*8, intent(in), dimension(nlag) :: lags
   integer*8, intent(in), dimension(nord) :: orders
   double precision, intent(in) :: dt
   integer*8 :: i,k,l,n
   double precision, intent(out), dimension(nord,nlag) :: S
   double precision, intent(out), dimension(nlag) :: r
   double precision :: dux, duy, duz, cnt, absu

   S = 0.0
   do k=1,nlag
      l=lags(k)
      cnt=nt-l
      do i=l+1,nt
         if ( isnan(ax(i)) .or. isnan(ax(i-l)) &
         .or. isnan(ay(i)) .or. isnan(ay(i-l)) &
         .or. isnan(az(i)) .or. isnan(az(i-l)) &
            ) then
            cnt=cnt-1
         else
            dux = ax(i)-ax(i-l)
            duy = ay(i)-ay(i-l)
            duz = az(i)-az(i-l)
            absu = sqrt(dux**2+duy**2+duz**2)
         endif
         do n=1,nord
            S(n,k) = S(n,k)+absu**orders(n)
         enddo
      enddo
      S(:,k) = S(:,k)/cnt!(nt-l-1)
      r(k)   = l*dt
   enddo
end subroutine strfn_vec

subroutine strfn(ax,nt,lags,nlag,orders,nord,dt,r,S)
   implicit none
   integer*8, intent(in) :: nt,nlag,nord
   double precision, intent(in), dimension(nt) :: ax
   integer*8, intent(in), dimension(nlag) :: lags
   integer*8, intent(in), dimension(nord) :: orders
   double precision, intent(in) :: dt
   integer*8 :: i,k,l,n
   double precision, intent(out), dimension(nord,nlag) :: S
   double precision, intent(out), dimension(nlag) :: r
   double precision :: cnt, absu

   S = 0.0
   do k=1,nlag
      l=lags(k)
      cnt=nt-l
      do i=l+1,nt
         if (isnan(ax(i)) .or. isnan(ax(i-l))) then
            cnt=cnt-1
         else
            absu = abs(ax(i)-ax(i-l))
         endif
         do n=1,nord
            S(n,k) = S(n,k)+absu**orders(n)
         enddo
      enddo
      S(:,k) = S(:,k)/cnt!(nt-l-1)
      r(k)   = l*dt
   enddo
end subroutine strfn
! -*- f90 -*-
! Correlation func using Blackman-Tukey

! Nested loop for finding the diagonal correlation functions
! x, y are the two (scalar) variables as function of time

subroutine corr_loop(nlag,M,x,y,R)

 implicit none
 integer*8, intent(in) :: M,nlag
 real(8) :: my_sum
 real(8), intent(in), dimension(0:M-1) :: x, y
 real(8), intent(out), dimension(0:nlag-1) :: R
 integer :: P, n

 DO n = 0,nlag-1,1
   my_sum = 0.0
    DO P = 0,M-n-1,1
     my_sum = my_sum + x(P)*y(P+n)
    END DO
    R(n) = my_sum/real(M-n)
  END DO

end subroutine

subroutine correlation(a,b,nt,lags,nlag,dt,r,cr)
  !use ieee_arithmetic
   implicit none
   integer*8, intent(in) :: nt, nlag
   double precision, intent(in) :: dt
   integer*8, intent(in), dimension(nlag) :: lags
   double precision, intent(in), dimension(nt) :: a,b
   double precision, intent(out), dimension(nlag) :: r,cr
   double precision :: aav, bav
   integer*8 :: i,k,l,cnt

   do k=1,nlag
      l=lags(k)
      cr(k)=0; aav=0; bav=0; cnt=nt-l
      do i=1,nt-l
        !if (ieee_is_nan(a(i)) .and. ieee_is_nan(b(i+l)) then
         if (isnan(a(i)) .or. isnan(b(i+l))) then
            cnt=cnt-1
           !continue
         else
            cr(k) = cr(k)+a(i)*b(i+l)
            aav = aav+a(i)
            bav = bav+b(i+l)
!           cnt=cnt+1
         endif
      enddo
      r(k)  = l*dt
      cr(k) = (cr(k)*cnt - aav*bav)/cnt**2
   enddo
!  cr = cr/cr(1)
end subroutine correlation


module module_kernels_par_sum

    contains

subroutine reduce_result_out_8(input_array,tsize,global_result_out_array)

    integer :: chunk_size
    integer :: local_id
    integer :: local_id_fortran
    integer :: group_id
    integer :: group_id_fortran
    integer :: global_id
    integer :: r_iter
    integer :: local_chunk_size
    integer :: start_position

    integer, Dimension(tsize), Intent(In) :: input_array
    integer, Intent(In) :: tsize

    ! Arrays prefixed with 'local_' should be declared using the '__local' modifier in C kernel version
    integer, Dimension(1:NTH) :: local_result_out_array
    integer, Dimension(1:NUNITS), Intent(Out) :: global_result_out_array
    integer :: local_result_out

    call get_local_id(local_id,0)
    call get_group_id(group_id,0)
    call get_global_id(global_id,0)

    ! local_id_fortran and group_id_fortran are used to reconcile the fact that fortran arrays are referenced from 1
    ! not 0 like other OpenCL supporting languages
    local_id_fortran = (local_id + 1)
    group_id_fortran = (group_id + 1)
    local_chunk_size = ((tsize / NTH) / NUNITS)
    start_position = local_chunk_size * global_id
    local_result_out = 0

    do r_iter=start_position, ((start_position + local_chunk_size) - 1)
        i_rel = r_iter
        i = (i_rel + 1)
        local_result_out = (local_result_out + input_array(i))
    end do

    local_result_out_array(local_id_fortran) = local_result_out

    call barrier(CLK_LOCAL_MEM_FENCE)

    local_result_out = 0
    do r_iter=1, NTH
        local_result_out = (local_result_out + local_result_out_array(r_iter))
    end do
    global_result_out_array(group_id_fortran) = local_result_out

end subroutine reduce_result_out_8

end module module_kernels_par_sum


SUBROUTINE GM_de

! ----------------------------------------------------------------------
! SUBROUTINE: GM_de.f90
! ----------------------------------------------------------------------
! Purpose:
!  Reading and storing the GM gravity constant of Sun, Moon and Planets
!  from the JPL/NASA DE (Development Ephemeris) data
! ----------------------------------------------------------------------
! Input arguments:
!
! Output arguments:
!
! Input/Output arguments are defined via the module mdl_planets.f90
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou                               October  2015
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_planets
      USE mdl_num
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------

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

! ---------------------------------------------------------------------------
! Local variables declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q) :: GMearth
      INTEGER (KIND = prec_int4) :: N_CVAL, I
! ---------------------------------------------------------------------------

! ----------------------------------------------------------------------
! GMconstant = [GM1 GM2 GMB GM4 GM5 GM6 GM7 GM8 GM9 GMmoon GMS]'
! ----------------------------------------------------------------------
      N_CVAL = size(CVAL_2)
      DO  I = 1 , N_CVAL
          IF ( CNAM_2(I) .EQ. 'GM1   ' )  GMconst_au(1) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GM2   ' )  GMconst_au(2) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GMB   ' )  GMconst_au(3) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GM4   ' )  GMconst_au(4) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GM5   ' )  GMconst_au(5) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GM6   ' )  GMconst_au(6) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GM7   ' )  GMconst_au(7) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GM8   ' )  GMconst_au(8) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GM9   ' )  GMconst_au(9) = CVAL_2(I)
          IF ( CNAM_2(I) .EQ. 'GMS   ' )  GMconst_au(11) = CVAL_2(I)
      END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! GM units conversion from au^3/day^2 to m^3/sec^2
! ----------------------------------------------------------------------
DO I = 1 , 11
   GMconst(I) = GMconst_au(I) * (AU_2**3 * 1D9) / ( (24D0 * 3600D0)**2 )
END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! GMmoon = GMearth / EMRAT;
!	  GMearth = 0.39860044150D+15
	  GMearth = GM_gfm
      GMconst(10) = GMearth / EMRAT_2
! ----------------------------------------------------------------------

END


      SUBROUTINE EXCHNG( IREL, NSP, DS, EX, VX )

C *****************************************************************
C  Finds local exchange energy density and potential
C  Adapted by J.M.Soler from routine velect of Froyen's
C    pseudopotential generation program. Madrid, Jan'97. Version 0.5.
C **** Input ******************************************************
C INTEGER IREL    : relativistic-exchange switch (0=no, 1=yes)
C INTEGER NSP     : spin-polarizations (1=>unpolarized, 2=>polarized)
C REAL*8  DS(NSP) : total (nsp=1) or spin (nsp=2) electron density
C **** Output *****************************************************
C REAL*8  EX      : exchange energy density
C REAL*8  VX(NSP) : (spin-dependent) exchange potential
C **** Units ******************************************************
C Densities in electrons/Bohr**3
C Energies in Hartrees
C *****************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ZERO=0.D0,ONE=1.D0,PFIVE=.5D0,OPF=1.5D0,C014=0.014D0)
      DIMENSION DS(NSP), VX(NSP)

       PI=4*ATAN(ONE)
       TRD = ONE/3
       FTRD = 4*TRD
       TFTM = 2**FTRD-2
       A0 = (4/(9*PI))**TRD

C      X-alpha parameter:
       ALP = 2 * TRD

       IF (NSP .EQ. 2) THEN
         D = DS(1) + DS(2)
         IF (D .LE. ZERO) THEN
           EX = ZERO
           VX(1) = ZERO
           VX(2) = ZERO
           RETURN
         ENDIF
         Z = (DS(1) - DS(2)) / D
         FZ = ((1+Z)**FTRD+(1-Z)**FTRD-2)/TFTM
         FZP = FTRD*((1+Z)**TRD-(1-Z)**TRD)/TFTM
       ELSE
         D = DS(1)
         IF (D .LE. ZERO) THEN
           EX = ZERO
           VX(1) = ZERO
           RETURN
         ENDIF
         Z = ZERO
         FZ = ZERO
         FZP = ZERO
       ENDIF
       RS = (3 / (4*PI*D) )**TRD
       VXP = -3*ALP/(2*PI*A0*RS)
       EXP = 3*VXP/4
       IF (IREL .EQ. 1) THEN
         BETA = C014/RS
         SB = SQRT(1+BETA*BETA)
         ALB = LOG(BETA+SB)
         VXP = VXP * (-PFIVE + OPF * ALB / (BETA*SB))
         EXP = EXP * (ONE-OPF*((BETA*SB-ALB)/BETA**2)**2)
       ENDIF
       VXF = 2**TRD*VXP
       EXF = 2**TRD*EXP
       IF (NSP .EQ. 2) THEN
         VX(1) = VXP + FZ*(VXF-VXP) + (1-Z)*FZP*(EXF-EXP)
         VX(2) = VXP + FZ*(VXF-VXP) - (1+Z)*FZP*(EXF-EXP)
         EX    = EXP + FZ*(EXF-EXP)
       ELSE
         VX(1) = VXP
         EX    = EXP
       ENDIF
      END


program partition
implicit none

!---------------------------------------
! calculates the rate constant
! for the reaction H + H2 -> H-H-H
!---------------------------------------

integer, parameter :: dp = SELECTED_REAL_KIND(15)
integer :: i !counter

!------------
!constants:
!------------

real(dp), parameter :: boltzmann = 1.380648813D-23 ![m^(2)kg/(s^(2)K)]
real(dp), parameter :: h = 6.626069573D-34 ![m^(2)kg/s]
real(dp), parameter :: pi = 3.141592654
real(dp), parameter :: c = 299792458  !speed of light - [m/s]
real(dp), parameter :: Ea = 9.7 ![kcal/mol]
real(dp), parameter :: kcaltoJ = 4184 !conversion factor
real(dp), parameter :: angstrom = 1D-10 !convert angstrom to meters
real(dp), parameter :: mp = 1.672621777D-27 !mass of proton - [kg]
real(dp), parameter :: me = 9.10938291D-31 !mass of electron - [kg]
real(dp), parameter :: symm = 2 !symmetry number.
real(dp), parameter :: R = 8.314462175 !gas constant [J/(Kmol)]
real(dp), parameter :: N = 6.0221412927D+23!avogadro's number - [mole^(-1)]

!---------------
!variables:
!---------------

real, parameter :: V = 1 !volume -> [dm^3]
real(dp) :: E, vim, elec !Energy to cross the barrier, imaginary
                              !frequency and electronic p.f.
real(dp), dimension(701) :: k, Q, T, trans, vib, rot! rate constant,
                                       !temperature and partition
                                       !function for the reaction
real(dp), parameter :: eH = 2, eH2 = 1, eHHH = 2 !electronic partition
                                                      !functions
real(dp), dimension(701) :: dG, dH, dS, KC, wigner, kcorr
                                 !Gibbs free energy, enthalpy and
                                 !entropy of the transition state
                                 !reaction, the equilibrium constant and
                                 ! the wigner correction.

!Hydrogen:
real(dp) :: mH !mass of hydrogen
real(dp), dimension(701) :: qtrans

!Hydrogen molecule:
real(dp), dimension(701) :: vibH2, rotH2, transH2
real(dp) :: f !vibrational frequency [s^(-1)].
real(dp) :: mH2, rH2 !mass of hydrogen atom, mass
                                 !and radius of hydrogen molecule
real(dp) :: IH2 ! angular momentum
real(dp) :: ZPEH2 !ZP correction

!H-H-H:
real(dp), dimension(701) :: HHHrot, HHHvib, HHHtrans, QHHH
real(dp) :: IHHH, rHHH, mHHH !rotational momentum, distances and mass for
                                             !the transition state
real(dp) :: vHHH1, vHHH2 ! vibrational frequencies, ali toa vtoroto
                                       !moze da bide greska
real(dp) :: ZPEHHH !zero point correction

!---------------------------------
! Define some values first:
!---------------------------------

vim = 850*c *100
elec = eHHH/(eH2*eH)
mH = mp + me ![kg] - mass of hydrogen
f = 4401 * c * 100
mH2 = (2.)*(mp + me) ![kg]
rH2 = 0.741*angstrom !distance between hydrogen atoms - [m]
IH2 = ((mH*mH)/(mH+mH))*(rH2**(2)) !moment of inertia of hydrogen molecule
ZPEH2 = (h*f*N)/2

!moment of inertia and mass of transition state:
rHHH = 0.929*angstrom
IHHH = (2.)*mH*(rHHH**(2.))
!IDHH = mD*(rDHH**(2)) + mH*(rDHH**(2)) - ((mD*rDHH-mH*rDHH)**(2))/(mD+mH+mH)
mHHH = mH + mH + mH
vHHH1 = (1780.)*c*(100.)
vHHH2 = (861.)*c*(100.)
ZPEHHH = Ea*kcaltoJ + N*(0.5)*(h*vHHH1 + (2.)*h*vHHH2)

E = (ZPEHHH-ZPEH2)

open (unit=1, file='results_H2.txt', status='new', action='write')
write(1,*) 'T', '	', 'k', '	', 'Kc', '	', 'G', '	', 'H', '	', 'S', '	',&
'wigner', '	', 'kcorr'

!-----------------------------------------
! calculate the partition functions:
!-----------------------------------------

do i = 1, 701 !701
   T(i) = i + 299

   !-------------------------------------------------------------Deuterium:
   !-----------------------------------------------------------------------

   qtrans(i) = ((((2.)*pi*mH*boltzmann*T(i))**(.3/.2))/(h**(3.)))*V

   !-----------------------------------------------------Hydrogen molecule:
   !-----------------------------------------------------------------------

   vibH2(i) = (1.) / ((1.) - exp(-h*f/(boltzmann*T(i))))
   rotH2(i) = ((8.)*(pi**(2.))*IH2*boltzmann*T(i))/h
   transH2(i) = (((2.)*pi*mH2*boltzmann*T(i))**(3./2.))/(h**(3.))*V

   !-----------------------------------------------------------------D-H-H:
   !-----------------------------------------------------------------------

   HHHrot(i) = ((8.)*(pi**(2.))*IHHH*boltzmann*T(i))/h
   HHHvib(i) = ((1.) / ((1.) - exp(-h*vHHH2/(boltzmann*T(i))))**(2.))*((1.) / ((1.) - exp(-h*vHHH1/(boltzmann*T(i)))))

   HHHtrans(i) = (((2.)*pi*mHHH*boltzmann*T(i))**(3./2.))/(h**(3.))*V

   !------------------------------------------------------------value of k:
   !-----------------------------------------------------------------------

   rot(i) = HHHrot(i)/rotH2(i)
   trans(i) = HHHtrans(i)/(qtrans(i)*transH2(i))
   vib(i) = HHHvib(i)/vibH2(i)
   Q(i) = rot(i)*vib(i)*trans(i)*elec
   KC(i) = Q(i)*N*(1000.)*exp(-(E/(R*T(i)))) !L/mol
   k(i) = symm*((boltzmann*T(i))/h)*Q(i)*exp(-(E/(R*T(i))))*N*1000
   dG(i) = -R*T(i)*LOG(KC(i))
   dH(i) = E - (2.)*R*T(i)
   dS(i) = (dH(i)-dG(i))/T(i)
   wigner(i) = (1.) + ((1./24.))*((h*vim)/(boltzmann*T(i)))**(2.)
   kcorr(i) = k(i)*wigner(i)

   write(1,*) T(i), k(i), Kc(i), dG(i), dH(i), dS(i), wigner(i), kcorr(i)
end do

end program partition


      SUBROUTINE GELOOP(RBUF,BUF,XX,YY,ZZ,HC1,HC2,HC3)
C
C GELOOP COMPUTES MAGNETIC FIELD COMPONENTS HC1,HC2,HC3(IN BASIC
C COORDS. AT XX,YY,ZZ DUE TO GEMLOOP CARD. DATA FIELDS(EXCEPT SET ID)
C OF GEMLOOP ARE IN RBUF=REAL AND BUF=INTEGER
C
      INTEGER BUF(50),TI1,TI2
      DIMENSION RBUF(50),ZI(3),ZJ(3),ZK(3),ZJXI(3)
      DATA FPI/12.566371/
C
      HC1=0.
      HC2=0.
      HC3=0.
C
      XI=RBUF(1)
C
C ICID IS 0 FOR NOW AND UNUSED
C
      ICID=BUF(2)
      NPTS=BUF(3)
      NPTSM1=NPTS-1
      DO 10 I=1,NPTSM1
C
C 2 CONSECUTIVE POINTS DEFINE A SEGMENT OF A COIL. LET ZI BE THE VECTOR
C FROM 1ST POINT OF SEGMENT TO 2ND. LET ZJ BE VECTOR FROM FILED POINT
C XX,YY,ZZ TO 1ST POINT OF SEGMENT. ZK IS VECTOR FROM FILED POINT
C TO 2ND POINT. IF THE FILED POINT LIES ON A SEGMENT, IGNORE THE
C COMPUTATION FOR THAT SEGMENT FOR THAT POINT
C
      TI1=3*I+3
      TI2=3*(I+1)+3
      ZI(1)=RBUF(TI2-2)-RBUF(TI1-2)
      ZI(2)=RBUF(TI2-1)-RBUF(TI1-1)
      ZI(3)=RBUF(TI2)-RBUF(TI1)
      ZJ(1)=RBUF(TI1-2)-XX
      ZJ(2)=RBUF(TI1-1)-YY
      ZJ(3)=RBUF(TI1)-ZZ
      ZK(1)=RBUF(TI2-2)-XX
      ZK(2)=RBUF(TI2-1)-YY
      ZK(3)=RBUF(TI2)-ZZ
C
      ZKL=SQRT(ZK(1)**2+ZK(2)**2+ZK(3)**2)
      IF(ZKL.LT.1.E-8)GO TO 10
      ZJL=SQRT(ZJ(1)**2+ZJ(2)**2+ZJ(3)**2)
      IF(ZJL.LT.1.E-8)GO TO 10
      ZDOT=0.
      DO 5 II=1,3
      ZDOT=ZDOT+ZI(II)*(ZK(II)/ZKL-ZJ(II)/ZJL)
    5 CONTINUE
      ZJXI(1)=ZJ(2)*ZI(3)-ZJ(3)*ZI(2)
      ZJXI(2)=ZJ(3)*ZI(1)-ZJ(1)*ZI(3)
      ZJXI(3)=ZJ(1)*ZI(2)-ZJ(2)*ZI(1)
      ZLEN2=ZJXI(1)**2+ZJXI(2)**2+ZJXI(3)**2
      IF(ZLEN2.LT.1.E-8)GO TO 10
      FACTOR=XI*ZDOT/FPI/ZLEN2
      HC1=HC1+ZJXI(1)*FACTOR
      HC2=HC2+ZJXI(2)*FACTOR
      HC3=HC3+ZJXI(3)*FACTOR
   10 CONTINUE
      RETURN
      END


      subroutine appdiskforce(s,z,fsad,fzad)

      include 'commonblocks'

      r=sqrt(s*s + z*z)
      t=sqrt(0.5d0)*(r-outdisk)/drtrunc
      if (t.lt.-4.0) then
          eerfc=1.
          derfc=0.0
      elseif(t.gt.4.0) then
          eerfc = 0.0
          derfc = 0.0
      else
          eerfc=0.5*erfc(t)
          derfc = exp(-t**2)/(sqrt(2.0*pi)*drtrunc)
      endif

      r1 = r/rdisk
      if (r1.eq.0.) then
         fprime=0
         f=0
      else
          texp = diskconst*zdisk**2*exp(-r1)
          f = texp*eerfc
          fprime = -texp*(derfc + eerfc/rdisk)/r
      endif

      zz = abs(z/zdisk)
      if( zz .lt. 10 ) then
          e2zz = exp(-2.0*zz)
      else
          e2zz = 0.0
      endif
      tlncoshz = zz + log(0.5*(1.0 + e2zz))

      fsad = -4.0*pi*fprime*s*tlncoshz
      fzad = -4.0*pi*(fprime*z*tlncoshz + f/zdisk*tanh(z/zdisk))

      return
      end


	  PROGRAM DFT
c
c             period search by a discrete fourier transform
c             -- adapted from Sky and Telescope, 9/88, p. 288
c                -The coarse, medium, fine spacing option omitted.
c                -User selects number of frequency bins.
c             revised by Paul Cohen, 5/31/89
c

	implicit double precision (a-h, o-z)
	real m
	Character*20 infile, outfile
	dimension x(15000), y(15000), dum(15000)
c
c   **** routine to read data, and to set q ****
c

	write(*,*) 'Discrete Fourier Transform'
	write(*,*)

	write(*,*) 'Time series file: '
	read(*,1) infile
1       Format (a20)

	write(*,*) 'Number of points in the time series: '
	read(*,*) numpt
	q = 0
	open (1, file = infile,status='old')
	read(1,*) ( x(i), dum(i), I = 1, numpt)

	avgy = 0
	do 10  i = 1, numpt
 10     avgy = avgy + dum(i)
	avgy = avgy/numpt
	do 20  i = 1, numpt
		y(i) = dum(i) - avgy
 20     q = q + y(i)*y(i)

c
c  ***** setting output *****
c

	write(*,*) 'Two column output file: '
	read(*,1) outfile
	open( 2, file = outfile, status = 'new' )

c
c  ***** the initializing routine *****
c

	p2 = 2 * 3.14159265
	l = 0
	x4 = x(numpt) - x(1)
	write(*,*) 'Longest useful period (in seconds) = ',(x4*86400)/2

	write(*,*) 'Longest period to use (in seconds): '
	read(*,*) p9
	write(*,*) 'Shortest period to use (in seconds): '
	read(*,*) p0

	f8 = 1/(p0/86400)
	f1 = 1/(p9/86400)
	Write(*,*) 'Number of frequency bins to use: '
	read(*,*) ibins
	m = (f8-f1)/ibins

c
c  **** the dft *****
c

	z9 = 0
	a5 = 0
	f0 = f1 - m
	co = (numpt - 1)/(numpt * q)
	do 100 k = 1, ibins
		write(*,*) 'Bin ',k
		f = f0 + k*m
		b = p2 * f
		c = 0
		s = 0
		do 110 i = 1, numpt
			a = b * x(i)
			s = s + y(i)* dsin(a)
  110           c = c + y(i)* dcos(a)
		z = (c*c +s*s)*co
		a5 = a5 + z
		if (z .le. z9) then
			goto 120
		endif
		z9 = z
		f9 = f
120             if (j .eq. 2) then
			goto 100
		endif
		write(2,95) (86400/f), z
95              format ( E15.9, 5x, E15.9 )
100     continue

	end


      SUBROUTINE SB02OY( TYPE, DICO, JOBB, FACT, UPLO, JOBL, JOBE, N, M,
     $                   P, A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, E,
     $                   LDE, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct the extended matrix pairs for the computation of the
C     solution of the algebraic matrix Riccati equations arising in the
C     problems of optimal control, both discrete and continuous-time,
C     and of spectral factorization, both discrete and continuous-time.
C     These matrix pairs, of dimension 2N + M, are given by
C
C           discrete-time                   continuous-time
C
C     |A   0   B|     |E   0   0|    |A   0   B|     |E   0   0|
C     |Q  -E'  L| - z |0  -A'  0|,   |Q   A'  L| - s |0  -E'  0|.   (1)
C     |L'  0   R|     |0  -B'  0|    |L'  B'  R|     |0   0   0|
C
C     After construction, these pencils are compressed to a form
C     (see [1])
C
C        lambda x A  - B ,
C                  f    f
C
C     where A  and B  are 2N-by-2N matrices.
C            f      f
C                              -1
C     Optionally, matrix G = BR  B' may be given instead of B and R;
C     then, for L = 0, 2N-by-2N matrix pairs are directly constructed as
C
C         discrete-time            continuous-time
C
C     |A   0 |     |E   G |    |A  -G |     |E   0 |
C     |      | - z |      |,   |      | - s |      |.               (2)
C     |Q  -E'|     |0  -A'|    |Q   A'|     |0  -E'|
C
C     Similar pairs are obtained for non-zero L, if SLICOT Library
C     routine SB02MT is called before SB02OY.
C     Other options include the case with E identity matrix, L a zero
C     matrix, or Q and/or R given in a factored form, Q = C'C, R = D'D.
C     For spectral factorization problems, there are minor differences
C     (e.g., B is replaced by C').
C     The second matrix in (2) is not constructed in the continuous-time
C     case if E is specified as being an identity matrix.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPE    CHARACTER*1
C             Specifies the type of problem to be addressed as follows:
C             = 'O':  Optimal control problem;
C             = 'S':  Spectral factorization problem.
C
C     DICO    CHARACTER*1
C             Specifies the type of linear system considered as follows:
C             = 'C':  Continuous-time system;
C             = 'D':  Discrete-time system.
C
C     JOBB    CHARACTER*1
C             Specifies whether or not the matrix G is given, instead
C             of the matrices B and R, as follows:
C             = 'B':  B and R are given;
C             = 'G':  G is given.
C             For JOBB = 'G', a 2N-by-2N matrix pair is directly
C             obtained assuming L = 0 (see the description of JOBL).
C
C     FACT    CHARACTER*1
C             Specifies whether or not the matrices Q and/or R (if
C             JOBB = 'B') are factored, as follows:
C             = 'N':  Not factored, Q and R are given;
C             = 'C':  C is given, and Q = C'C;
C             = 'D':  D is given, and R = D'D (if TYPE = 'O'), or
C                     R = D + D' (if TYPE = 'S');
C             = 'B':  Both factors C and D are given, Q = C'C, R = D'D
C                     (or R = D + D').
C
C     UPLO    CHARACTER*1
C             If JOBB = 'G', or FACT = 'N', specifies which triangle of
C             the matrices G and Q (if FACT = 'N'), or Q and R (if
C             JOBB = 'B'), is stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     JOBL    CHARACTER*1
C             Specifies whether or not the matrix L is zero, as follows:
C             = 'Z':  L is zero;
C             = 'N':  L is nonzero.
C             JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed.
C             Using SLICOT Library routine SB02MT to compute the
C             corresponding A and Q in this case, before calling SB02OY,
C             enables to obtain 2N-by-2N matrix pairs directly.
C
C     JOBE    CHARACTER*1
C             Specifies whether or not the matrix E is identity, as
C             follows:
C             = 'I':  E is the identity matrix;
C             = 'N':  E is a general matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, Q, and E, and the number
C             of rows of the matrices B and L.  N >= 0.
C
C     M       (input) INTEGER
C             If JOBB = 'B', M is the order of the matrix R, and the
C             number of columns of the matrix B.  M >= 0.
C             M is not used if JOBB = 'G'.
C
C     P       (input) INTEGER
C             If FACT = 'C' or 'D' or 'B', or if TYPE = 'S', P is the
C             number of rows of the matrix C and/or D, respectively.
C             P >= 0, and if JOBB = 'B' and TYPE = 'S', then P = M.
C             Otherwise, P is not used.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             state matrix A of the system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,*)
C             If JOBB = 'B', the leading N-by-M part of this array must
C             contain the input matrix B of the system.
C             If JOBB = 'G', the leading N-by-N upper triangular part
C             (if UPLO = 'U') or lower triangular part (if UPLO = 'L')
C             of this array must contain the upper triangular part or
C             lower triangular part, respectively, of the matrix
C                   -1
C             G = BR  B'. The strictly lower triangular part (if
C             UPLO = 'U') or strictly upper triangular part (if
C             UPLO = 'L') is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
C             If FACT = 'N' or 'D', the leading N-by-N upper triangular
C             part (if UPLO = 'U') or lower triangular part (if UPLO =
C             'L') of this array must contain the upper triangular part
C             or lower triangular part, respectively, of the symmetric
C             output weighting matrix Q. The strictly lower triangular
C             part (if UPLO = 'U') or strictly upper triangular part (if
C             UPLO = 'L') is not referenced.
C             If FACT = 'C' or 'B', the leading P-by-N part of this
C             array must contain the output matrix C of the system.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= MAX(1,N) if FACT = 'N' or 'D',
C             LDQ >= MAX(1,P) if FACT = 'C' or 'B'.
C
C     R       (input) DOUBLE PRECISION array, dimension (LDR,M)
C             If FACT = 'N' or 'C', the leading M-by-M upper triangular
C             part (if UPLO = 'U') or lower triangular part (if UPLO =
C             'L') of this array must contain the upper triangular part
C             or lower triangular part, respectively, of the symmetric
C             input weighting matrix R. The strictly lower triangular
C             part (if UPLO = 'U') or strictly upper triangular part (if
C             UPLO = 'L') is not referenced.
C             If FACT = 'D' or 'B', the leading P-by-M part of this
C             array must contain the direct transmission matrix D of the
C             system.
C             If JOBB = 'G', this array is not referenced.
C
C     LDR     INTEGER
C             The leading dimension of array R.
C             LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C';
C             LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B';
C             LDR >= 1        if JOBB = 'G'.
C
C     L       (input) DOUBLE PRECISION array, dimension (LDL,M)
C             If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of
C             this array must contain the cross weighting matrix L.
C             If JOBL = 'Z' or JOBB = 'G', this array is not referenced.
C
C     LDL     INTEGER
C             The leading dimension of array L.
C             LDL >= MAX(1,N) if JOBL = 'N';
C             LDL >= 1        if JOBL = 'Z' or JOBB = 'G'.
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             If JOBE = 'N', the leading N-by-N part of this array must
C             contain the matrix E of the descriptor system.
C             If JOBE = 'I', E is taken as identity and this array is
C             not referenced.
C
C     LDE     INTEGER
C             The leading dimension of array E.
C             LDE >= MAX(1,N) if JOBE = 'N';
C             LDE >= 1        if JOBE = 'I'.
C
C     AF      (output) DOUBLE PRECISION array, dimension (LDAF,*)
C             The leading 2N-by-2N part of this array contains the
C             matrix A  in the matrix pencil.
C                     f
C             Array AF must have 2*N+M columns if JOBB = 'B', and 2*N
C             columns, otherwise.
C
C     LDAF    INTEGER
C             The leading dimension of array AF.
C             LDAF >= MAX(1,2*N+M) if JOBB = 'B',
C             LDAF >= MAX(1,2*N)   if JOBB = 'G'.
C
C     BF      (output) DOUBLE PRECISION array, dimension (LDBF,2*N)
C             If DICO = 'D' or JOBB = 'B' or JOBE = 'N', the leading
C             2N-by-2N part of this array contains the matrix B  in the
C                                                              f
C             matrix pencil.
C             The last M zero columns are never constructed.
C             If DICO = 'C' and JOBB = 'G' and JOBE = 'I', this array
C             is not referenced.
C
C     LDBF    INTEGER
C             The leading dimension of array BF.
C             LDBF >= MAX(1,2*N+M) if JOBB = 'B',
C             LDBF >= MAX(1,2*N)   if JOBB = 'G' and ( DICO = 'D' or
C                                                      JOBE = 'N' ),
C             LDBF >= 1            if JOBB = 'G' and ( DICO = 'C' and
C                                                      JOBE = 'I' ).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used to test for near singularity of
C             the original matrix pencil, specifically of the triangular
C             factor obtained during the reduction process. If the user
C             sets TOL > 0, then the given value of TOL is used as a
C             lower bound for the reciprocal condition number of that
C             matrix; a matrix whose estimated condition number is less
C             than 1/TOL is considered to be nonsingular. If the user
C             sets TOL <= 0, then a default tolerance, defined by
C             TOLDEF = EPS, is used instead, where EPS is the machine
C             precision (see LAPACK Library routine DLAMCH).
C             This parameter is not referenced if JOBB = 'G'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK >= M if JOBB = 'B',
C             LIWORK >= 1 if JOBB = 'G'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK. If JOBB = 'B', DWORK(2) returns the reciprocal
C             of the condition number of the M-by-M lower triangular
C             matrix obtained after compression.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1                  if JOBB = 'G',
C             LDWORK >= MAX(1,2*N + M,3*M) if JOBB = 'B'.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the computed extended matrix pencil is singular,
C                   possibly due to rounding errors.
C
C     METHOD
C
C     The extended matrix pairs are constructed, taking various options
C     into account. If JOBB = 'B', the problem order is reduced from
C     2N+M to 2N (see [1]).
C
C     REFERENCES
C
C     [1] Van Dooren, P.
C         A Generalized Eigenvalue Approach for Solving Riccati
C         Equations.
C         SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981.
C
C     [2] Mehrmann, V.
C         The Autonomous Linear Quadratic Control Problem. Theory and
C         Numerical Solution.
C         Lect. Notes in Control and Information Sciences, vol. 163,
C         Springer-Verlag, Berlin, 1991.
C
C     [3] Sima, V.
C         Algorithms for Linear-Quadratic Optimization.
C         Pure and Applied Mathematics: A Series of Monographs and
C         Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C     Supersedes Release 2.0 routine SB02CY by T.G.J. Beelen, Philips,
C     Eindhoven, Holland, M. Vanbegin, and P. Van Dooren, Philips
C     Research Laboratory, Brussels, Belgium.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, optimal regulator, Schur form.
C
C     ******************************************************************
C
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, FACT, JOBB, JOBE, JOBL, TYPE, UPLO
      INTEGER           INFO, LDA, LDAF, LDB, LDBF, LDE, LDL, LDQ, LDR,
     $                  LDWORK, M, N, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*),
     $                  DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), R(LDR,*)
C     .. Local Scalars ..
      LOGICAL           DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBE,
     $                  LJOBL, LUPLO, OPTC
      INTEGER           I, ITAU, J, JWORK, N2, N2P1, NM, NNM, NP1,
     $                  WRKOPT
      DOUBLE PRECISION  RCOND, TOLDEF
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEQLF, DLACPY, DLASET, DORMQL, DSYRK,
     $                  DTRCON, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO  = 0
      OPTC  = LSAME( TYPE, 'O' )
      DISCR = LSAME( DICO, 'D' )
      LJOBB = LSAME( JOBB, 'B' )
      LFACN = LSAME( FACT, 'N' )
      LFACQ = LSAME( FACT, 'C' )
      LFACR = LSAME( FACT, 'D' )
      LFACB = LSAME( FACT, 'B' )
      LUPLO = LSAME( UPLO, 'U' )
      LJOBE = LSAME( JOBE, 'I' )
      N2 = N + N
      IF ( LJOBB ) THEN
         LJOBL = LSAME( JOBL, 'Z' )
         NM  = N + M
         NNM = N2 + M
      ELSE
         NM = N
         NNM = N2
      END IF
      NP1  = N + 1
      N2P1 = N2 + 1
C
C     Test the input scalar arguments.
C
      IF( .NOT.OPTC .AND. .NOT.LSAME( TYPE, 'S' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB
     $                                     .AND. .NOT.LFACN ) THEN
         INFO = -4
      ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN
         IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) )
     $      INFO = -5
      ELSE IF( LJOBB ) THEN
         IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'N' ) )
     $      INFO = -6
      ELSE IF( .NOT.LJOBE .AND. .NOT.LSAME( JOBE, 'N' ) ) THEN
         INFO = -7
      ELSE IF( N.LT.0 ) THEN
         INFO = -8
      ELSE IF( LJOBB ) THEN
         IF( M.LT.0 )
     $      INFO = -9
      ELSE IF( .NOT.LFACN .OR. .NOT.OPTC ) THEN
         IF( P.LT.0 ) THEN
            INFO = -10
         ELSE IF( LJOBB ) THEN
            IF( .NOT.OPTC .AND. P.NE.M )
     $         INFO = -10
         END IF
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR.
     $         ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN
         INFO = -16
      ELSE IF( LDR.LT.1 ) THEN
         INFO = -18
      ELSE IF( LJOBB ) THEN
         IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR.
     $        ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN
            INFO = -18
         ELSE IF( ( .NOT.LJOBL .AND. LDL.LT.MAX( 1, N ) ) .OR.
     $            (      LJOBL .AND. LDL.LT.1 ) ) THEN
            INFO = -20
         END IF
      END IF
      IF( ( .NOT.LJOBE .AND. LDE.LT.MAX( 1, N ) ) .OR.
     $    (      LJOBE .AND. LDE.LT.1 ) ) THEN
         INFO = -22
      ELSE IF( LDAF.LT.MAX( 1, NNM ) ) THEN
         INFO = -24
      ELSE IF( ( ( LJOBB .OR. DISCR .OR. .NOT.LJOBE ) .AND.
     $           LDBF.LT.NNM ) .OR. ( LDBF.LT.1 ) ) THEN
         INFO = -26
      ELSE IF( ( LJOBB .AND. LDWORK.LT.MAX( NNM, 3*M ) ) .OR.
     $                       LDWORK.LT.1 ) THEN
         INFO = -30
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02OY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      DWORK(1) = ONE
      IF ( N.EQ.0 )
     $   RETURN
C
C     Construct the extended matrices in AF and BF, by block-columns.
C
      CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF )
C
      IF ( .NOT.LFACQ .AND. .NOT.LFACB ) THEN
         CALL DLACPY( UPLO, N, N, Q, LDQ, AF(NP1,1), LDAF )
         IF ( LUPLO ) THEN
C
C           Construct the lower triangle of Q.
C
            DO 20 J = 1, N - 1
               CALL DCOPY( N-J, Q(J,J+1), LDQ, AF(NP1+J,J), 1 )
   20       CONTINUE
C
         ELSE
C
C           Construct the upper triangle of Q.
C
            DO 40 J = 2, N
               CALL DCOPY( J-1, Q(J,1), LDQ, AF(NP1,J), 1 )
   40       CONTINUE
C
         END IF
      ELSE
         CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, Q, LDQ, ZERO,
     $               AF(NP1,1), LDAF )
C
         DO 60 J = 2, N
            CALL DCOPY( J-1, AF(NP1,J), 1, AF(N+J,1), LDAF )
   60    CONTINUE
C
      END IF
C
      IF ( LJOBB ) THEN
         IF ( LJOBL ) THEN
            CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,1), LDAF )
         ELSE
C
            DO 80 I = 1, N
               CALL DCOPY( M, L(I,1), LDL, AF(N2P1,I), 1 )
   80       CONTINUE
C
         END IF
      END IF
C
      IF ( DISCR.OR.LJOBB ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ZERO, AF(1,NP1), LDAF )
      ELSE
         IF ( LUPLO ) THEN
C
C           Construct (1,2) block of AF using the upper triangle of G.
C
            DO 140 J = 1, N
C
               DO 100 I = 1, J
                  AF(I,N+J)= -B(I,J)
  100          CONTINUE
C
               DO 120 I = J + 1, N
                  AF(I,N+J)= -B(J,I)
  120          CONTINUE
C
  140       CONTINUE
C
         ELSE
C
C           Construct (1,2) block of AF using the lower triangle of G.
C
            DO 200 J = 1, N
C
               DO 160 I = 1, J - 1
                  AF(I,N+J)= -B(J,I)
  160          CONTINUE
C
               DO 180 I = J, N
                  AF(I,N+J)= -B(I,J)
  180          CONTINUE
C
  200       CONTINUE
C
         END IF
      END IF
C
      IF ( DISCR ) THEN
         IF ( LJOBE ) THEN
            CALL DLASET( 'Full', NM, N, ZERO, -ONE, AF(NP1,NP1), LDAF )
         ELSE
C
            DO 240 J = 1, N
C
               DO 220 I = 1, N
                  AF(N+I,N+J)= -E(J,I)
  220          CONTINUE
C
  240       CONTINUE
C
            IF ( LJOBB )
     $         CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,NP1),
     $                      LDAF )
         END IF
      ELSE
C
         DO 280 J = 1, N
C
            DO 260 I = 1, N
               AF(N+I,N+J)= A(J,I)
  260       CONTINUE
C
  280    CONTINUE
C
         IF ( LJOBB ) THEN
            IF ( OPTC ) THEN
C
               DO 300 J = 1, N
                  CALL DCOPY ( M, B(J,1), LDB, AF(N2P1,N+J), 1 )
  300          CONTINUE
C
            ELSE
               CALL DLACPY( 'Full', P, N, Q, LDQ, AF(N2P1,NP1), LDAF )
            END IF
         END IF
      END IF
C
      IF ( LJOBB ) THEN
C
         IF ( OPTC ) THEN
            CALL DLACPY( 'Full', N, M, B, LDB, AF(1,N2P1), LDAF )
         ELSE
C
            DO 320 I = 1, P
               CALL DCOPY( N, Q(I,1), LDQ, AF(1,N2+I), 1 )
  320       CONTINUE
C
         END IF
C
         IF ( LJOBL ) THEN
            CALL DLASET( 'Full', N, M, ZERO, ZERO, AF(NP1,N2P1), LDAF )
         ELSE
            CALL DLACPY( 'Full', N, M, L, LDL, AF(NP1,N2P1), LDAF )
         END IF
C
         IF ( .NOT.LFACR .AND. .NOT.LFACB ) THEN
            CALL DLACPY( UPLO, M, M, R, LDR, AF(N2P1,N2P1), LDAF )
            IF ( LUPLO ) THEN
C
C              Construct the lower triangle of R.
C
               DO 340 J = 1, M - 1
                  CALL DCOPY( M-J, R(J,J+1), LDR, AF(N2P1+J,N2+J), 1 )
  340          CONTINUE
C
            ELSE
C
C              Construct the upper triangle of R.
C
               DO 360 J = 2, M
                  CALL DCOPY( J-1, R(J,1), LDR, AF(N2P1,N2+J), 1 )
  360          CONTINUE
C
            END IF
         ELSE IF ( OPTC ) THEN
            CALL DSYRK( 'Upper', 'Transpose', M, P, ONE, R, LDR, ZERO,
     $                  AF(N2P1,N2P1), LDAF )
C
            DO 380 J = 2, M
               CALL DCOPY( J-1, AF(N2P1,N2+J), 1, AF(N2+J,N2P1), LDAF )
  380       CONTINUE
C
         ELSE
C
            DO 420 J = 1, M
C
               DO 400 I = 1, P
                  AF(N2+I,N2+J) = R(I,J) + R(J,I)
  400          CONTINUE
C
  420       CONTINUE
C
         END IF
      END IF
C
      IF ( .NOT.LJOBB .AND. .NOT.DISCR .AND. LJOBE )
     $   RETURN
C
C     Construct the first two block columns of BF.
C
      IF ( LJOBE ) THEN
         CALL DLASET( 'Full', N+NM, N, ZERO, ONE, BF, LDBF )
      ELSE
         CALL DLACPY( 'Full', N, N, E, LDE, BF, LDBF )
         CALL DLASET( 'Full', NM, N, ZERO, ZERO, BF(NP1,1), LDBF )
      END IF
C
      IF ( .NOT.DISCR.OR.LJOBB ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ZERO, BF(1,NP1), LDBF )
      ELSE
         IF ( LUPLO ) THEN
C
C           Construct (1,2) block of BF using the upper triangle of G.
C
            DO 480 J = 1, N
C
               DO 440 I = 1, J
                  BF(I,N+J)= B(I,J)
  440          CONTINUE
C
               DO 460 I = J + 1, N
                  BF(I,N+J)= B(J,I)
  460          CONTINUE
C
  480       CONTINUE
C
         ELSE
C
C           Construct (1,2) block of BF using the lower triangle of G.
C
            DO 540 J = 1, N
C
               DO 500 I = 1, J - 1
                  BF(I,N+J)= B(J,I)
  500          CONTINUE
C
               DO 520 I = J, N
                  BF(I,N+J)= B(I,J)
  520          CONTINUE
C
  540       CONTINUE
C
         END IF
      END IF
C
      IF ( DISCR ) THEN
C
         DO 580 J = 1, N
C
            DO 560 I = 1, N
               BF(N+I,N+J)= -A(J,I)
  560       CONTINUE
C
  580    CONTINUE
C
         IF ( LJOBB ) THEN
C
            IF ( OPTC ) THEN
C
               DO 620 J = 1, N
C
                  DO 600 I = 1, M
                     BF(N2+I,N+J)= -B(J,I)
  600             CONTINUE
C
  620          CONTINUE
C
            ELSE
C
               DO 660 J = 1, N
C
                  DO 640 I = 1, P
                     BF(N2+I,N+J) = -Q(I,J)
  640             CONTINUE
C
  660          CONTINUE
C
            END IF
         END IF
C
      ELSE
         IF ( LJOBE ) THEN
            CALL DLASET( 'Full', NM, N, ZERO, -ONE, BF(NP1,NP1), LDBF )
         ELSE
C
            DO 700 J = 1, N
C
               DO 680 I = 1, N
                  BF(N+I,N+J)= -E(J,I)
  680          CONTINUE
C
  700       CONTINUE
C
            IF ( LJOBB )
     $         CALL DLASET( 'Full', M, N, ZERO, ZERO, BF(N2P1,NP1),
     $                      LDBF )
         END IF
      END IF
C
      IF ( .NOT.LJOBB )
     $   RETURN
C
C     Compress the pencil lambda x BF - AF, using QL factorization.
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
C     Workspace: need 2*M;  prefer M + M*NB.
C
      ITAU  = 1
      JWORK = ITAU + M
      CALL DGEQLF( NNM, M, AF(1,N2P1), LDAF, DWORK(ITAU), DWORK(JWORK),
     $             LDWORK-JWORK+1, INFO )
      WRKOPT = DWORK(JWORK)
C
C     Workspace: need 2*N+M;  prefer M + 2*N*NB.
C
      CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF,
     $             DWORK(ITAU), AF, LDAF, DWORK(JWORK), LDWORK-JWORK+1,
     $             INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
      CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF,
     $             DWORK(ITAU), BF, LDBF, DWORK(JWORK), LDWORK-JWORK+1,
     $             INFO )
C
C     Check the singularity of the L factor in the QL factorization:
C     if singular, then the extended matrix pencil is also singular.
C     Workspace 3*M.
C
      TOLDEF = TOL
      IF ( TOLDEF.LE.ZERO )
     $   TOLDEF = DLAMCH( 'Epsilon' )
C
      CALL DTRCON( '1-norm', 'Lower', 'Non unit', M, AF(N2P1,N2P1),
     $             LDAF, RCOND, DWORK, IWORK, INFO )
      WRKOPT = MAX( WRKOPT, 3*M )
C
      IF ( RCOND.LE.TOLDEF )
     $   INFO = 1
C
      DWORK(1) = WRKOPT
      DWORK(2) = RCOND
C
      RETURN
C *** Last line of SB02OY ***
      END


      FUNCTION BESSI1(X)
      REAL*8 Y,P1,P2,P3,P4,P5,P6,P7,
     *    Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9
      DATA P1,P2,P3,P4,P5,P6,P7/0.5D0,0.87890594D0,0.51498869D0,
     *    0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,-0.3988024D-1,
     *    -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1,
     *    -0.2895312D-1,0.1787654D-1,-0.420059D-2/
      IF (ABS(X).LT.3.75) THEN
        Y=(X/3.75)**2
        BESSI1=X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
      ELSE
        AX=ABS(X)
        Y=3.75/AX
        BESSI1=(EXP(AX)/SQRT(AX))*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+
     *      Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9))))))))
      ENDIF
      RETURN
      END


      REAL FUNCTION BESSJ0(X)
      IMPLICIT NONE
C-----------------------------------------------------------------------
C Purpose: Calculates J0(X)
C
C Arguments:
C
      REAL X
C
C Local Arrays:
C
      REAL*8 PCOF(0:4),QCOF(0:4),RCOF(0:5),SCOF(0:5)
C
C Local Scalars:
C
      REAL*8 Y,Z,AX,XX,DX,TMP1,TMP2
      INTEGER I
C
C Data:
C
      DATA PCOF/ 0.2093887211D-06,-0.2073370639D-05, 0.2734510407D-04,
     &          -0.1098628627D-02, 1.0D0/

      DATA QCOF/-0.9349451520D-07, 0.7621095161D-06,-0.6911147651D-05,
     &           0.1430488765D-03,-0.1562499995D-01/

      DATA RCOF/-0.1849052456D+03, 0.7739233017D+05,-0.1121442418D+08,
     &           0.6516196407D+09,-0.13362590354D+11,0.57568490574D+11/

      DATA SCOF/ 1.0D0           , 0.2678532712D+03, 0.5927264853D+05,
     &           0.9494680718D+07, 0.1029532985D+10, 0.57568490411D+11/
C
C-----------------------------------------------------------------------
      DX = DBLE(X)
      IF(ABS(X).LT.8.0)THEN
         Y = DX*DX
         TMP1 = RCOF(0)
         TMP2 = SCOF(0)
         DO 10 I=1,5
            TMP1 = TMP1*Y + RCOF(I)
            TMP2 = TMP2*Y + SCOF(I)
 10      CONTINUE
         BESSJ0 = SNGL(TMP1/TMP2)
      ELSE
         AX = ABS(DX)
         Z = 8.0D0/AX
         Y = Z*Z
         XX = AX - 0.785398164D0
         TMP1 = PCOF(0)
         TMP2 = QCOF(0)
         DO 20 I=1,4
            TMP1 = TMP1*Y + PCOF(I)
            TMP2 = TMP2*Y + QCOF(I)
 20      CONTINUE
         BESSJ0 = SNGL(SQRT(0.636619772D0/AX)
     &                 *(COS(XX)*TMP1-Z*SIN(XX)*TMP2))
      ENDIF
      RETURN
      END


      SUBROUTINE REALFT(DATA,N,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
      THETA=6.28318530717959D0/2.0D0/DBLE(N)
      WR=1.0D0
      WI=0.0D0
      C1=0.5
      IF (ISIGN.EQ.1) THEN
        C2=-0.5
        CALL FOUR1(DATA,N,+1)
        DATA(2*N+1)=DATA(1)
        DATA(2*N+2)=DATA(2)
      ELSE
        C2=0.5
        THETA=-THETA
        DATA(2*N+1)=DATA(2)
        DATA(2*N+2)=0.0
        DATA(2)=0.0
      ENDIF
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      N2P3=2*N+3
      DO 11 I=1,N/2+1
        I1=2*I-1
        I2=I1+1
        I3=N2P3-I2
        I4=I3+1
        WRS=SNGL(WR)
        WIS=SNGL(WI)
        H1R=C1*(DATA(I1)+DATA(I3))
        H1I=C1*(DATA(I2)-DATA(I4))
        H2R=-C2*(DATA(I2)+DATA(I4))
        H2I=C2*(DATA(I1)-DATA(I3))
        DATA(I1)=H1R+WRS*H2R-WIS*H2I
        DATA(I2)=H1I+WRS*H2I+WIS*H2R
        DATA(I3)=H1R-WRS*H2R+WIS*H2I
        DATA(I4)=-H1I+WRS*H2I+WIS*H2R
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
11    CONTINUE
      IF (ISIGN.EQ.1) THEN
        DATA(2)=DATA(2*N+1)
      ELSE
        CALL FOUR1(DATA,N,-1)
      ENDIF
      RETURN
      END
      SUBROUTINE FOUR1(DATA,NN,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
      N=2*NN
      J=1
      DO 11 I=1,N,2
        IF(J.GT.I)THEN
          TEMPR=DATA(J)
          TEMPI=DATA(J+1)
          DATA(J)=DATA(I)
          DATA(J+1)=DATA(I+1)
          DATA(I)=TEMPR
          DATA(I+1)=TEMPI
        ENDIF
        M=N/2
1       IF ((M.GE.2).AND.(J.GT.M)) THEN
          J=J-M
          M=M/2
        GO TO 1
        ENDIF
        J=J+M
11    CONTINUE
      MMAX=2
2     IF (N.GT.MMAX) THEN
        ISTEP=2*MMAX
        THETA=6.28318530717959D0/(ISIGN*MMAX)
        WPR=-2.D0*DSIN(0.5D0*THETA)**2
        WPI=DSIN(THETA)
        WR=1.D0
        WI=0.D0
        DO 13 M=1,MMAX,2
          DO 12 I=M,N,ISTEP
            J=I+MMAX
            TEMPR=SNGL(WR)*DATA(J)-SNGL(WI)*DATA(J+1)
            TEMPI=SNGL(WR)*DATA(J+1)+SNGL(WI)*DATA(J)
            DATA(J)=DATA(I)-TEMPR
            DATA(J+1)=DATA(I+1)-TEMPI
            DATA(I)=DATA(I)+TEMPR
            DATA(I+1)=DATA(I+1)+TEMPI
12        CONTINUE
          WTEMP=WR
          WR=WR*WPR-WI*WPI+WR
          WI=WI*WPR+WTEMP*WPI+WI
13      CONTINUE
        MMAX=ISTEP
      GO TO 2
      ENDIF
      RETURN
      END


 SUBROUTINE POLATEV6(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
                     MI,MO,KM,IBI,LI,UI,VI, &
                     NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATEV6   INTERPOLATE VECTOR FIELDS (BUDGET)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS BUDGET INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR VECTOR FIELDS.
!           THE ALGORITHM SIMPLY COMPUTES (WEIGHTED) AVERAGES
!           OF NEIGHBOR POINTS ARRANGED IN A SQUARE BOX
!           CENTERED AROUND EACH OUTPUT GRID POINT AND STRETCHING
!           NEARLY HALFWAY TO EACH OF THE NEIGHBORING GRID POINTS.
!           OPTIONS ALLOW CHOICES OF NUMBER OF POINTS IN EACH RADIUS
!           FROM THE CENTER POINT (IPOPT(1)) WHICH DEFAULTS TO 2
!           (IF IPOPT(1)=-1) MEANING THAT 25 POINTS WILL BE AVERAGED;
!           FURTHER OPTIONS ARE THE RESPECTIVE WEIGHTS FOR THE RADIUS
!           POINTS STARTING AT THE CENTER POINT (IPOPT(2:2+IPOPT(1))
!           WHICH DEFAULTS TO ALL 1 (IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!           ANOTHER OPTION IS THE MINIMUM PERCENTAGE FOR MASK,
!           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
!           (IPOPT(3+IPOPT(1)) WHICH DEFAULTS TO 50 (IF -1).
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!
!           THE INPUT AND OUTPUT GRIDS ARE DEFINED BY THEIR GRIB 2 GRID
!           DEFINITION TEMPLATE AS DECODED BY THE NCEP G2 LIBRARY.  THE
!           CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMI/O=01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMI/O=10) MERCATOR CYLINDRICAL
!             (IGDTNUMI/O=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMI/O=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!
!           THE INPUT AND OUTPUT VECTORS ARE ROTATED SO THAT THEY ARE
!           EITHER RESOLVED RELATIVE TO THE DEFINED GRID
!           IN THE DIRECTION OF INCREASING X AND Y COORDINATES
!           OR RESOLVED RELATIVE TO EASTERLY AND NORTHERLY DIRECTIONS,
!           AS DESIGNATED BY THEIR RESPECTIVE GRID DESCRIPTION SECTIONS.
!
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED
!           ALONG WITH THEIR VECTOR ROTATION PARAMETERS.
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
! 2002-01-17  IREDELL  SAVE DATA FROM LAST CALL FOR OPTIMIZATION
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      ROUTINE GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATEV6(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
!                         MI,MO,KM,IBI,LI,UI,VI, &
!                         NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS NUMBER OF RADIUS POINTS
!                (DEFAULTS TO 2 IF IPOPT(1)=-1);
!                IPOPT(2:2+IPOPT(1)) ARE RESPECTIVE WEIGHTS
!                (DEFAULTS TO ALL 1 IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!                IPOPT(3+IPOPT(1)) IS MINIMUM PERCENTAGE FOR MASK
!                (DEFAULTS TO 50 IF IPOPT(3+IPOPT(1)=-1)
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATEV FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                SAME DEFINITION AS "IGDTNUMI"
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATEV FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     UI       - REAL (MI,KM) INPUT U-COMPONENT FIELDS TO INTERPOLATE
!     VI       - REAL (MI,KM) INPUT V-COMPONENT FIELDS TO INTERPOLATE
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES
!     CROT     - REAL (MO) VECTOR ROTATION COSINES
!     SROT     - REAL (MO) VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     UO       - REAL (MO,KM) OUTPUT U-COMPONENT FIELDS INTERPOLATED
!     VO       - REAL (MO,KM) OUTPUT V-COMPONENT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!                31   INVALID UNDEFINED OUTPUT GRID
!                32   INVALID BUDGET METHOD PARAMETERS
!
! SUBPROGRAMS CALLED:
!   GDSWZD        GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0       SET UP PARAMETERS FOR IJKGDS1
!   IJKGDS1       RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   MOVECT        MOVE A VECTOR ALONG A GREAT CIRCLE
!   POLFIXV       MAKE MULTIPLE POLE VECTOR VALUES CONSISTENT
!   CHECK_GRIDS6V DETERMINE IF INPUT OR OUTPUT GRIDS HAVE CHANGED
!                 BETWEEN CALLS TO THIS ROUTINE.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,         INTENT(IN   ) :: IPOPT(20), IBI(KM)
 INTEGER,         INTENT(IN   ) :: KM, MI, MO
 INTEGER,         INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,         INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,         INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,         INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
 INTEGER,         INTENT(  OUT) :: IRET, NO, IBO(KM)
!
 LOGICAL*1,       INTENT(IN   ) :: LI(MI,KM)
 LOGICAL*1,       INTENT(  OUT) :: LO(MO,KM)
!
 REAL,            INTENT(IN   ) :: UI(MI,KM),VI(MI,KM)
 REAL,            INTENT(INOUT) :: RLAT(MO),RLON(MO)
 REAL,            INTENT(  OUT) :: UO(MO,KM),VO(MO,KM)
 REAL,            INTENT(  OUT) :: CROT(MO),SROT(MO)
!
 REAL,            PARAMETER     :: FILL=-9999.
!
 INTEGER                        :: IJKGDS1, N11(MO), IJKGDSA(20)
 INTEGER                        :: IB, JB, I1, J1
 INTEGER                        :: K, LB, LSW, MP, N, NV
 INTEGER,                 SAVE  :: MIX=-1
 INTEGER                        :: NB, NB1, NB2, NB3, NB4
!
 LOGICAL                        :: SAME_GRID
!
 REAL                           :: C11(MO),S11(MO)
 REAL,        ALLOCATABLE,SAVE  :: CROI(:),SROI(:)
 REAL                           :: CM11, SM11, PMP
 REAL                           :: U11, V11, UROT, VROT
 REAL                           :: WB, WO(MO,KM), XI, YI
 REAL                           :: RLOB(MO),RLAB(MO)
 REAL,        ALLOCATABLE,SAVE  :: RLOI(:),RLAI(:)
 REAL                           :: XPTS(MO),YPTS(MO)
 REAL,        ALLOCATABLE,SAVE  :: XPTI(:),YPTI(:)
 REAL                           :: XPTB(MO),YPTB(MO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
 IRET=0
 IF(IGDTNUMO.GE.0) THEN
   CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS, &
               RLON,RLAT,NO,CROT,SROT)
   IF(NO.EQ.0) IRET=3
 ELSE
   IRET=31
 ENDIF
 CALL CHECK_GRIDS6V(IGDTNUMI,IGDTMPLI,IGDTLENI,SAME_GRID)
 IF(.NOT.SAME_GRID) THEN
   IF(MIX.NE.MI) THEN
     IF(MIX.GE.0) DEALLOCATE(XPTI,YPTI,RLOI,RLAI,CROI,SROI)
     ALLOCATE(XPTI(MI),YPTI(MI),RLOI(MI),RLAI(MI),CROI(MI),SROI(MI))
     MIX=MI
   ENDIF
   CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI, 0,MI,FILL,XPTI,YPTI, &
               RLOI,RLAI,NV,CROI,SROI)
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 NB1=IPOPT(1)
 IF(NB1.EQ.-1) NB1=2
 IF(IRET.EQ.0.AND.NB1.LT.0) IRET=32
 LSW=1
 IF(IPOPT(1).EQ.-1.OR.IPOPT(2).EQ.-1) LSW=0
 IF(IRET.EQ.0.AND.LSW.EQ.1.AND.NB1.GT.15) IRET=32
 MP=IPOPT(3+IPOPT(1))
 IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
 IF(MP.LT.0.OR.MP.GT.100) IRET=32
 PMP=MP*0.01
 IF(IRET.EQ.0) THEN
   NB2=2*NB1+1
   NB3=NB2*NB2
   NB4=NB3
   IF(LSW.EQ.1) THEN
     NB4=IPOPT(2)
     DO IB=1,NB1
       NB4=NB4+8*IB*IPOPT(2+IB)
     ENDDO
   ENDIF
 ELSE
   NB2=0
   NB3=0
   NB4=0
 ENDIF
 DO K=1,KM
   DO N=1,NO
     UO(N,K)=0
     VO(N,K)=0
     WO(N,K)=0.
   ENDDO
 ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX
 CALL IJKGDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IJKGDSA)
 DO NB=1,NB3
!  LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS AND ROTATIONS
   JB=(NB-1)/NB2-NB1
   IB=NB-(JB+NB1)*NB2-NB1-1
   LB=MAX(ABS(IB),ABS(JB))
   WB=1
   IF(LSW.EQ.1) WB=IPOPT(2+LB)
   IF(WB.NE.0) THEN
     DO N=1,NO
       XPTB(N)=XPTS(N)+IB/REAL(NB2)
       YPTB(N)=YPTS(N)+JB/REAL(NB2)
     ENDDO
     CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 1,NO,FILL,XPTB,YPTB, &
                 RLOB,RLAB,NV)
     CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,NO,FILL,XPTB,YPTB, &
                 RLOB,RLAB,NV)
     IF(IRET.EQ.0.AND.NV.EQ.0.AND.LB.EQ.0) IRET=2
     DO N=1,NO
       XI=XPTB(N)
       YI=YPTB(N)
       IF(XI.NE.FILL.AND.YI.NE.FILL) THEN
         I1=NINT(XI)
         J1=NINT(YI)
         N11(N)=IJKGDS1(I1,J1,IJKGDSA)
         IF(N11(N).GT.0) THEN
           CALL MOVECT(RLAI(N11(N)),RLOI(N11(N)),RLAT(N),RLON(N),CM11,SM11)
           C11(N)=CM11*CROI(N11(N))+SM11*SROI(N11(N))
           S11(N)=SM11*CROI(N11(N))-CM11*SROI(N11(N))
         ENDIF
       ELSE
         N11(N)=0
       ENDIF
     ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE WITH OR WITHOUT BITMAPS
     DO K=1,KM
       DO N=1,NO
         IF(N11(N).GT.0) THEN
           IF(IBI(K).EQ.0.OR.LI(N11(N),K)) THEN
             U11=C11(N)*UI(N11(N),K)-S11(N)*VI(N11(N),K)
             V11=S11(N)*UI(N11(N),K)+C11(N)*VI(N11(N),K)
             UO(N,K)=UO(N,K)+WB*U11
             VO(N,K)=VO(N,K)+WB*V11
             WO(N,K)=WO(N,K)+WB
           ENDIF
         ENDIF
       ENDDO
     ENDDO
   ENDIF
 ENDDO  ! NB LOOP
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE OUTPUT BITMAPS AND FIELDS
 DO K=1,KM
   IBO(K)=IBI(K)
   DO N=1,NO
     LO(N,K)=WO(N,K).GE.PMP*NB4
     IF(LO(N,K)) THEN
       UO(N,K)=UO(N,K)/WO(N,K)
       VO(N,K)=VO(N,K)/WO(N,K)
       UROT=CROT(N)*UO(N,K)-SROT(N)*VO(N,K)
       VROT=SROT(N)*UO(N,K)+CROT(N)*VO(N,K)
       UO(N,K)=UROT
       VO(N,K)=VROT
     ELSE
       IBO(K)=1
       UO(N,K)=0.
       VO(N,K)=0.
     ENDIF
   ENDDO
 ENDDO
 IF(IGDTNUMO.EQ.0) CALL POLFIXV(NO,MO,KM,RLAT,RLON,IBO,LO,UO,VO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATEV6
!
 SUBROUTINE CHECK_GRIDS6V(IGDTNUM,IGDTMPL,IGDTLEN,SAME_GRID)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  CHECK_GRIDS6V   CHECK GRID INFORMATION
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: DETERMINE WHETHER THE GRID SPECS
!           HAVE CHANGED.
!
! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:  CALL CHECK_GRIDS6V(IGDTNUM,IGDTMPL,IGDTLEN,SAME_GRID)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!               CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!               NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPL - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY.
!               CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!               OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLEN - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!               TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!               COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!
!   OUTPUT ARGUMENT LIST:
!     SAME_GRID  - WHEN TRUE, THE GRID HAS NOT CHANGED BETWEEN CALLS.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,        INTENT(IN   ) :: IGDTMPL(IGDTLEN)
!
 LOGICAL,        INTENT(  OUT) :: SAME_GRID
!
 INTEGER, SAVE                 :: IGDTNUM_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLEN_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPL_SAVE(1000)=-9999
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SAME_GRID=.FALSE.
 IF(IGDTNUM==IGDTNUM_SAVE)THEN
   IF(IGDTLEN==IGDTLEN_SAVE)THEN
     IF(ALL(IGDTMPL==IGDTMPL_SAVE(1:IGDTLEN)))THEN
       SAME_GRID=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUM_SAVE=IGDTNUM
 IGDTLEN_SAVE=IGDTLEN
 IGDTMPL_SAVE(1:IGDTLEN)=IGDTMPL
 IGDTMPL_SAVE(IGDTLEN+1:1000)=-9999
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE CHECK_GRIDS6V


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! Bad coding example 1
!
! Shamefully written by Ross Walker (SDSC, 2006)
!
! This code reads a series of coordinates and charges from the file
! specified as argument $1 on the command line.
!
! This file should have the format:
!  I9
! 4F10.4   (repeated I9 times representing x,y,z,q)
!
! It then calculates the following fictional function:
!
!             exp(rij*qi)*exp(rij*qj)   1
!    E = Sum( ----------------------- - - )  (rij <= cut)
!        j<i           r(ij)            a
!
! where cut is a cut off value specified on the command line ($2),
! r(ij) is a function of the coordinates read in for each atom and
! a is a constant.
!
! The code prints out the number of atoms, the cut off, total number of
! atom pairs which were less than or equal to the distance cutoff, the
! value of E, the time take to generate the coordinates and the time
! taken to perform the calculation of E.
!
! All calculations are done in double precision.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

program calc_energy

     implicit none

     integer*4 :: iarg  !Intrinsic getarg require 4 byte integers so this
                  ! provides a guard against 64 bit integer compilation.
     integer :: natom, ier, ios, i, j, cut_count

     !Timer variables
     integer :: int_time, int_count_rate
     REAL*8 :: time0, time1, time2, count_rate

     character(len=80) :: arg, filename
     REAL*8 :: cut     !Cut off for Rij in distance units
     REAL*8, allocatable, dimension(:,:) :: coords
     REAL*8, allocatable, dimension(:) :: q
     REAL*8 :: total_e, current_e, vec2, rij
     REAL*8 :: a

     a = 3.2d0

     call system_clock(int_time, int_count_rate)  !Start time
     time0 = real(int_time)
     write(6,'(''Value of system clock at start = '',F14.4,/)') time0

     ! Step 1 - obtain the filename of the coord file and the value of
     ! cut from the command line.
     !         Argument 1 should be the filename of the coord file (char).
     !         Argument 2 should be the cut off (float).
     iarg = 1
     call getarg(iarg, arg)
     filename = arg
     write(6,'(''Coordinates will be read from file: '',A,/)') filename
     iarg=2
     call getarg(iarg, arg)
     read(arg,'(f10.5)') cut

     ! Step 2 - Open the coordinate file and read the first line to
     ! obtain the number of atoms
     open(unit=10,file=filename,form='FORMATTED',iostat=ios)
     read(10,'(i9)') natom

     write(6,*) 'Natom = ', natom
     write(6,*) '  cut = ', cut

     ! Step 3 - Allocate the arrays to store the coordinate and charge data
     ier = 0
     allocate ( coords(natom,3), stat=ier )
     if ( ier /= 0 ) then
       write(6,*) 'Allocation error coords'
       stop
     end if
     allocate ( q(natom), stat=ier )
     if ( ier /= 0 ) then
       write(6,*) 'Allocation error q'
       stop
     end if

     ! Step 4 - read the coordinates and charges.
     do i = 1, natom
        read(10,'(4f10.4)') coords(i,1:3),q(i)
     end do

     call system_clock(int_time, int_count_rate)  !time after reading of file
     time1 = real(int_time)
     write(6,'(''Value of system clock after coord read = '',F14.4,/)') time1

     ! Step 5 - calculate the number of pairs and E. - this is the
     ! majority of the work.
     total_e = 0.0d0
     cut_count = 0
     do i = 1, natom
       do j = 1, natom
         if ( j < i ) then   !Avoid double counting.
           vec2 = (coords(i,1)-coords(j,1))**2 + (coords(i,2)-coords(j,2))**2 &
                + (coords(i,3)-coords(j,3))**2
                  !X^2 + Y^2 + Z^2
           rij = sqrt(vec2)
           !Check if this is below the cut off
           if ( rij <= cut ) then
              !Increment the counter of pairs below cutoff
             cut_count = cut_count+1
             current_e = (exp(rij*q(i))*exp(rij*q(j)))/rij
             total_e = total_e + current_e - 1.0d0/a
           end if
         end if
       end do
     end do

     !time after reading of file and calculation
     call system_clock(int_time, int_count_rate)
     time2 = real(int_time)
     count_rate = real(int_count_rate)
     write(6,'(''Value of system clock after coord read and E calc = '',F14.4,/)') &
          time2

     ! Step 6 - write out the results
     write(6,*) '                         Final Results'
     write(6,*) '                         -------------'
     write(6,*) '                   Num Pairs = ',cut_count
     write(6,*) '                     Total E = ',total_e
     write(6,'(''     Time to read coord file = '',F14.4, '' Seconds'')') &
          (time1-time0)/count_rate
     write(6,'(''         Time to calculate E = '',F14.4, '' Seconds'')') &
          (time2-time1)/count_rate
     write(6,'(''        Total Execution Time = '',F14.4, '' Seconds'')') &
          (time2-time0)/count_rate

     ! Step 7 - Deallocate the arrays - we should strictly check the
     ! return values here but for the purposes of this tutorial we
     ! can ignore this.
     deallocate(q, stat=ier)
     deallocate(coords, stat=ier)

     close (unit=10)

     stop

end program calc_energy


program main

  use coarray_collectives
  implicit none

  integer :: a, b
  a = this_image()
  b = a*(a+1)/2 ! expected sum scan
  call co_sum_scan(a)

  !! Output the the computed sum scan
  if (this_image() == 1) write(*,'(a)') 'image: expected, computed'
  if (this_image() > 1) sync images (this_image()-1)
  write(*,'(i0,": ",i0,1x,i0)') this_image(), b, a
  if (this_image() < num_images()) sync images (this_image()+1)

  sync all
  if (a /= b) error stop 1

end program