       recursive function factorial(num) result(fact)
       use kind_spec
       implicit none
       integer, intent(IN) :: num
       real(rprec) :: fact
       integer:: nfact

       if(num == 1 .or. num == 0) then
         nfact = 1
       else
         nfact = num*factorial(num-1)
       endif

       fact = nfact

       end function factorial

       subroutine build_matrices_legendre(n, a, b, a_inv, b_inv)
       use kind_spec
       implicit none
       integer, intent(IN) :: n
       real(rprec), intent(OUT), dimension(0:n,0:n) :: a, b,
     1  a_inv, b_inv
       integer :: idx, i, j
       real(rprec) :: factorial
       real(rprec), dimension(13), parameter :: norm_legend =
     1    ( / 1, 1, 3, 5, 35, 63, 231, 429, 6435,
     2        12155, 46189, 88179, 676039 / )
       real(rprec), dimension(13), parameter ::  norm_inv_legend =
     1    ( / 1, 1, 2, 2, 8, 8, 16, 16, 128,
     2        128, 256, 256, 1024 / )
       real(rprec), dimension(13*13), parameter :: b_legend =
     1  ( / 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     2  0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     3  1, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     4  0, 3, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     5  7, 0, 20, 0, 8, 0, 0, 0, 0, 0, 0, 0, 0,
     6  0, 27, 0, 28, 0, 8, 0, 0, 0, 0, 0, 0, 0,
     7  33, 0, 110, 0, 72, 0, 16, 0, 0, 0, 0, 0, 0,
     8  0, 143, 0, 182, 0, 88, 0, 16, 0, 0, 0, 0, 0,
     9  715, 0, 2600, 0, 2160, 0, 832, 0, 128, 0, 0, 0, 0,
     A  0, 3315, 0, 4760, 0, 2992, 0, 960, 0, 128, 0, 0, 0,
     B  4199, 0, 16150, 0, 15504, 0, 7904, 0, 2176, 0,
     C  256, 0, 0,
     D  0, 20349, 0, 31654, 0, 23408, 0, 10080, 0, 2432,
     E  0, 256, 0,
     F  52003, 0, 208012, 0, 220248, 0, 133952, 0, 50048,
     G  0, 10752, 0, 1024 / )
       real(rprec), dimension(13*13), parameter :: b_legend_inv =
     1  ( / 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     2  0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     3  -1, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     4  0, -3, 0, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     5  3, 0, -30, 0, 35, 0, 0, 0, 0, 0, 0, 0, 0,
     6  0, 15, 0, -70, 0, 63, 0, 0, 0, 0, 0, 0, 0,
     7  -5, 0, 105, 0, -315, 0, 231, 0, 0, 0, 0, 0, 0,
     8  0, -35, 0, 315, 0, -693, 0, 429, 0, 0, 0, 0, 0,
     9  35, 0, -1260, 0, 6930, 0, -12012, 0, 6435, 0, 0,
     A  0, 0,
     B  0, 315, 0, -4620, 0, 18018, 0, -25740, 0, 12155,
     C  0, 0, 0,
     D  -63, 0, 3465, 0, -30030, 0, 90090, 0, -109395, 0,
     E  46189, 0, 0,
     F  0, -693, 0, 15015, 0, -90090, 0, 218790, 0, -230945,
     G  0, 88179, 0,
     H  231, 0, -18018, 0, 225225, 0, -1021020, 0, 2078505,
     I  0, -1939938, 0, 676039 / )

!--------------------------------------------------------------------------------------------------
!      P_n(y):: LEGENDRE polynomial in [-1,1]. Matrix coefficients from
!      "Handbook of Mathematical Functions", Abramowitz and Stegun, 1973, p.795.
!      If higher degree polyn. needed, then data set must be extended.
!
!      DESCRIPTION OF MATRICES:
!
!      A, A_inv: convert Legendre Pol. to and from y-powers in [-1,1]
!
!              norm_legend(m)*y**m = SUM_n=0^m (b_legend{mn} L_n)
!              norm_legend_inv(m)*L_m = SUM_n=0^N (b_legend_inv{mn} y**n)
!
!           ==>   A_{mn} = b_legend_{mn}/norm_legend(m)                if  m<=n  or  0. otherwise
!           ==>   A_inv_{mn} = b_legend_inv_{mn}/norm_inv_legend(m)    if  m<=n  or  0. otherwise
!
!      B, B_inv: convert y-powers in [-1,1] to and from x-powers in [0,1]
!
!             x = (y + 1)/2;   x**m =  SUM_n=0^m  2**(-m) m!/(n!(m-n)!)  y**n
!             y = 2*x - 1;     y**m =  SUM_n=0^m  2**n (-1)**(m-n) m!/(n!(m-n)!)  x**n
!
!           ==>   B_{mn} =  2**(-m) m!/(n!(m-n)!)                     if  m<=n  or  0. otherwise
!           ==>   B_inv_{mn} =  2**n (-1)**(m-n) m!/(n!(m-n)!)        if  m<=n  or  0. otherwise
!
!
!      NOTICE that:   A_inv = (A)**(-1);  B_inv = (B)**(-1)
!--------------------------------------------------------------------------------------------------

       if (n > 12) stop 'N(Legendre) CANNOT be larger than 12!!!'

       a = 0
       a_inv = 0
       b = 0
       b_inv = 0

       do i = 0, n
         idx = 13*i
         do j = 0, i
           a(i,j) = b_legend(idx+j+1)/norm_legend(i+1)
           a_inv(i,j) = b_legend_inv(idx+j+1)/norm_inv_legend(i+1)
           b(i,j) = 2._dp**(-i) * factorial(i)/
     1       (factorial(j)*factorial(i-j))
           b_inv(i,j) = 2._dp**j*(-1._dp)**(i-j)* factorial(i)/
     1       (factorial(j)*factorial(i-j))
         enddo
       enddo

       end subroutine build_matrices_legendre

       subroutine power_to_legendre(n, a, b, ac, tc)
       use kind_spec
       implicit none
       integer, intent(IN):: n
       real(rprec), dimension(0:n), intent(IN):: ac
       real(rprec), dimension(0:n), intent(OUT):: tc
       real(rprec), dimension(0:n,0:n), intent(IN):: a, b
       integer:: i, j, k
!------------------------------------------------------------------
!      Given the following notation:
!
!           TC == (tc(1), ...tc(n))==>  vector of coefficients
!                 for Legendre series in [-1,1]
!           AC == (ac(1), ...ac(n))==>  vector of coefficients
!                 for power series in [0,1]
!      then:
!                        TC = AC* B * A
!------------------------------------------------------------------
       do i = 0, n
         tc(i) = 0
         do j= 0, n
           do k = 0, n
             tc(i) = tc(i) + ac(j) * b(j,k) * a(k,i)
           enddo
         enddo
       enddo

       end subroutine power_to_legendre

       subroutine legendre_to_power(n, a_inv, b_inv, tc, ac)
       use kind_spec
       implicit none
       integer, intent(IN):: n
       real(rprec), dimension(0:n), intent(IN):: tc
       real(rprec), dimension(0:n), intent(OUT):: ac
       real(rprec), dimension(0:n,0:n), intent(IN):: a_inv, b_inv
       integer:: i, j, k
!---------------------------------------------------------------------
!      Given the following notation:
!
!           AC == (ac(1), ...ac(n))==>  vector of coefficients for
!                 power series in [0,1]
!           TC == (tc(1), ...tc(n))==>  vector of coefficients for
!                 Legendre series in [-1,1]
!      then:
!                        AC = TC* A_INV * B_INV
!----------------------------------------------------------------------
       do i = 0, n
         ac(i) = 0
         do j= 0, n
           do k = 0, n
             ac(i) = ac(i) + tc(j) * a_inv(j,k) * b_inv(k,i)
           enddo
         enddo
       enddo

       end subroutine legendre_to_power

       subroutine point_wise_to_power(npts, x, f, n, ac, i_full,
     1   nsp_pts)
       use kind_spec
       implicit none
       integer, intent(IN):: npts, i_full, nsp_pts
       integer, intent(INOUT):: n
       real(rprec), dimension(npts), intent(IN):: x, f
       real(rprec), dimension(0:n), intent(OUT):: ac
       integer :: i, j, k , n_count, n_int
       character(LEN=2) :: cdum
       character(LEN=15) :: form
       real(rprec) :: res, ohs_sp
       real(rprec), dimension(:), allocatable :: tc, norm, y,
     1   fy, y_sp, fy_sp
       real(rprec), dimension(:,:), allocatable:: a_inv, b_inv,
     1   a, b, inorm, tleg
!-----------------------------------------------
!   E x t e r n a l   F u n c t i o n s
!-----------------------------------------------
       REAL(rprec) , EXTERNAL :: integral
!--------------------------------------------------------------------------------
!      MEANING OF ARGUMENTS:
!      NPTS = number of points where the point-wise function is given
!      X = independent variable values for these points in [0,1]
!      F = dependent variable values on the X points
!      N = tentative number of Legendre polynomials used in the reconstruction
!      AC = final power series coefficients in x ([0,1])
!      I_FULL =0, if input data on full mesh; =1, if on half mesh
!      NSP_PTS = number of points for the spline fit of F on the half mesh.
!--------------------------------------------------------------------------------
!
!      ABSTRACT:
!      Conversion of a point-wise solution in [0,1] given on a discrete set
!      of NPTS radial points (either on the half or the full mesh, see below)
!      first to an expansion in Legendre polynomials in [-1,1] via:
!
!          F = sum_m=0^N  <F,P_m>/<P_m,P_m>   <f,g> == INT_[-1,1] f(x)g(x)dx
!
!      and defining the Legendre coefficient vector TC as:
!
!          TC = {<F,P_m>/<P_m,P_m>, m=1, N}
!
!      then calculates the equivalent power series coefficients vector in
!      [0,1], AC:
!
!                AC = TC*A_inv*B_inv
!
!      The value of Legendre Polynomials used "N" depends CRITICALLY on the
!      number of points NPTS in the discrete data set of the incoming point-wise
!      solution. Because if the integrals are evaluated using these points, the
!      wiggles in the polynomial may not be well sampled by the existing set of
!      points and may cause deviations of the ortogonality condition:
!
!                        <P_m,P_n> = 2/(2*n+1)* delta_{mn}
!
!      This makes the reconstruction to deteriorate quickly for increasing "N".
!      To avoid this, the incoming data values are SPLINED to a number of points
!      NSP_PTS on a half-like mesh using Hermite cubic splines. Then, the
!      value of "N" is chosen requiring:
!
!               | 1- .5*(2*n+1)*<P_N,P_n> | < RES
!
!      RES is prescribed to be <= .5%. Until this condition is achieved, "N" is
!      subsequently reduced. If "N" gets equal to 2 in this reduction, the
!      calculation is stopped and an error message issued.
!
!      WARNING: The point-wise solution MAY BE given on the half mesh or full mesh
!      of a equally spaced radial grid, that is:
!
!      ***I_FULL = 1 beginning with x(3/2) and finishing with x(M-1/2), where
!         x(1) = 0. and x(M) = 1.
!      ***I_FULL = 0 beginning with x(1) = 0. and finishing with x(M) = 1.
!
!--------------------------------------------------------------------------------

       ac = 0
       res = 1

!...   Map [0,1] to [-1,1]

       allocate (y(npts), fy(npts), y_sp(nsp_pts), fy_sp(nsp_pts))

       y(:npts) = 2*x(:npts) - 1
       fy(:npts) = f(:npts)

!...   I_full = 0 if FY given on the full mesh, and =1 if on the half mesh.
!      FY is splined on nsp_pts on the half_mesh

       ohs_sp = 2._dp/nsp_pts
       y_sp= (/( -1._dp+ (real(i,rprec)-0.5_dp)*ohs_sp,
     1    i = 1, nsp_pts)/)

       call spline_it(npts, y, fy, nsp_pts, y_sp, fy_sp, i_full)

!...   Determine number of Legendre Polynomials to be used

       n_count = 0
       do
         if(res <= 0.005_dp) exit
           n_int = n - n_count
           if(n_int < n) deallocate (a, b, a_inv, b_inv, tleg,
     1       inorm, norm)
           allocate(a(0:n_int,0:n_int), b(0:n_int,0:n_int),
     1        a_inv(0:n_int,0:n_int), b_inv(0:n_int,0:n_int),
     2        tleg(0:n_int, nsp_pts), inorm(0:n_int,0:n_int),
     3        norm(0:n_int))

           norm(0:n_int) = (/(2._dp/(2*i+1),
     1       i=0, n_int)/)

           call build_matrices_legendre (n_int, a, b, a_inv, b_inv)

!...   Build Initial Legendre polynomials on grid

           do i = 0, n_int
             tleg(i,:nsp_pts) = 0
             do k = n_int, 0, -1
               tleg(i,:nsp_pts)= a_inv(i,k) + y_sp(:nsp_pts)
     1            *tleg(i,:nsp_pts)
             enddo
           enddo

!...   Compute orthogonality and norms

           do j = 0, n_int
             do i = 0, n_int
               inorm(i,j) = integral(nsp_pts, y_sp, tleg(j,1:nsp_pts),
     1           tleg(i,1:nsp_pts))
             enddo
           write(cdum,'(i2)')n_int+1
           cdum = adjustl(cdum)
           form = '('//trim(cdum)//'(x,f8.3))'
           form = adjustl(form)
!          write(20,trim(form)) (inorm(i,j), i=0, n)
           enddo

!...   Compute residual. If res > 0.02, reduce N and iterate

           res = abs((norm(n_int) - inorm(n_int,n_int))/(norm(n_int)))
           n_count = n_count + 1
           if(n_count == n-1) stop 'Precision bad for even 2 Polynomial'

       enddo

       allocate(tc(0:n_int))
       do j = 0, n_int
         tc(j) = integral(nsp_pts, y_sp, fy_sp, tleg(j,1:nsp_pts))
     1    /norm(j)
       enddo

       call legendre_to_power(n_int, a_inv, b_inv, tc, ac(0))

       deallocate(a_inv, b_inv, a, b, tc, tleg, inorm, norm, fy,
     1   y, y_sp, fy_sp)

       end subroutine point_wise_to_power

       subroutine spline_it(ndata, xdata, ydata, npts, x, y, i_full)
       use kind_spec
       implicit none
       integer, intent(IN) :: ndata, npts, i_full
       real(rprec), dimension(ndata), intent(IN):: xdata, ydata
       real(rprec), dimension(npts), intent(OUT):: x, y
       real(rprec), dimension(npts) :: dy
       real(rprec), dimension(:), allocatable:: xfull, yfull,
     1   dyfull, wk
       integer:: iwk, ierr
       logical:: spline

       allocate(xfull(ndata+i_full), yfull(ndata+i_full),
     1     dyfull(ndata+i_full), wk(2*(ndata+i_full)) )

       if (i_full .eq. 1) then                                            !! I_FULL= 1, data on HALF_mesh
         xfull(1) = -1
         xfull(ndata+1) = 1
         xfull(2:ndata) = 0.5_dp*(xdata(1:ndata-1)+xdata(2:ndata))
         yfull(1) = ydata(1) + (xdata(1)+1.)*
     1    (ydata(2)-ydata(1))/(xdata(2)-xdata(1))
         yfull(2:ndata) = 0.5_dp*(ydata(1:ndata-1)+ydata(2:ndata))
         yfull(ndata+1) = ydata(ndata) + (1 - xdata(ndata))*
     1    (ydata(ndata-1)-ydata(ndata))/(xdata(ndata-1)-xdata(ndata))
       else                                                              !!I_FULL =0, data on FULL mesh;
         xfull(1:ndata) = xdata(1:ndata)
         yfull(1:ndata) = ydata(1:ndata)
       endif

       spline = .false.
       wk = 0
       ierr = 0
       iwk = 2*ndata

       call PCHEZ(ndata+i_full, xfull, yfull, dyfull, spline,
     1   wk, iwk, ierr)
        if(ierr.lt.0) stop 'LEGENDRE: error in SPLINE'

       call PCHEV(ndata+i_full, xfull, yfull, dyfull,
     1   npts, x, y, dy, ierr)
        if(ierr.lt.0) stop 'LEGENDRE: error in EVAL_SPLINE'

       deallocate(xfull, yfull, dyfull, wk)

       end subroutine spline_it

       function integral (n, x, y1, y2)
       use kind_spec
       implicit none
       integer, intent(IN) :: n
       real(rprec), intent(IN), dimension(n) :: y1, y2 , x
       real(rprec), parameter :: one = 1
       real(rprec), dimension(n) :: coef
       real(rprec) :: h, integral
!------------------------------------------------------------------------------
!      WARNING: The integral formula assumes values on the half MESH,
!      that is, the independent variable is given from x(3/2) to x(M-1/2),
!      but the limits of the integral are x(1)=-1 and x(M)=1. N = M-1 is the
!      number of points on the half mesh.
!      In the current version, fulfilment of this condition is only checked
!      for the case in which the interval of integration is the interval
!      of orthogonality of Legendre polynomias, i.e., [-1,1].
!      Integration formula is a 2-nd order HALF-MESH formula from
!      "Numerical Recipes", W.Press et al, Chapter 4, page 110.
!------------------------------------------------------------------------------
       if (n < 10) stop 'Too few points to carry out integration.!'
       if (x(n) < x(1)) stop' B <<A in INTEGRAL!!!!!'
       if (x(n) == one .or. x(1) == -one) stop 'HALF MESH INTEGRAL!'

       coef = 1

       h = (x(n)-x(1))/(n-1)
       integral = h* SUM(coef*y1*y2)

       end function integral


Program NearestNeighbor
real, dimension(3) :: qpoint = (/3,6,5/)
real, dimension(3,3) :: points = transpose(reshape((/1,2,3,3,4,5,5,6,7/),(/3,3/)))
write(*,*) minloc(norm2(points-spread(qpoint, 1, size(points, 1)), 2))
End Program NearestNeighbor


C
      SUBROUTINE HSTSSP (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE STANDARD FIVE-POINT FINITE
C                        DIFFERENCE APPROXIMATION ON A STAGGERED GRID
C                        TO THE HELMHOLTZ EQUATION IN SPHERICAL
C                        COORDINATES AND ON THE SURFACE OF THE UNIT
C                        SPHERE (RADIUS OF 1).  THE EQUATION IS
C
C                          (1/SIN(THETA))(D/DTHETA)(SIN(THETA)
C                          (DU/DTHETA)) + (1/SIN(THETA)**2)
C                          (D/DPHI)(DU/DPHI) + LAMBDA*U = F(THETA,PHI)
C
C                        WHERE THETA IS COLATITUDE AND PHI IS
C                        LONGITUDE.
C
C USAGE                  CALL HSTSSP (A,B,M,MBDCND,BDA,BDB,C,D,N,
C                                     NBDCND,BDC,BDD,ELMBDA,F,IDIMF,
C                                     PERTRB,IERROR,W)
C
C
C ARGUMENTS
C ON INPUT
C
C                        A,B
C                          THE RANGE OF THETA (COLATITUDE),
C                          I.E. A .LE. THETA .LE. B.
C                          A MUST BE LESS THAN B AND A MUST BE
C                          NON-NEGATIVE.  A AND B ARE IN RADIANS.
C                          A = 0 CORRESPONDS TO THE NORTH POLE AND
C                          B = PI CORRESPONDS TO THE SOUTH POLE.
C
C
C                            * * *  IMPORTANT  * * *
C
C                          IF B IS EQUAL TO PI, THEN B MUST BE
C                          COMPUTED USING THE STATEMENT
C                            B = PIMACH(DUM)
C
C                          THIS INSURES THAT B IN THE USER"S PROGRAM
C                          IS EQUAL TO PI IN THIS PROGRAM WHICH
C                          PERMITS SEVERAL TESTS OF THE INPUT
C                          PARAMETERS THAT OTHERWISE WOULD NOT BE
C                          POSSIBLE.
C
C                            * * * * * * * * * * * *
C                        M
C                          THE NUMBER OF GRID POINTS IN THE INTERVAL
C                          (A,B).  THE GRID POINTS IN THE THETA
C                          DIRECTION ARE GIVEN BY
C                          THETA(I) = A + (I-0.5)DTHETA
C                          FOR I=1,2,...,M WHERE DTHETA =(B-A)/M.
C                          M MUST BE GREATER THAN 2.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT THETA = A AND THETA = B.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = A AND THETA = B.
C                               (SEE NOTE 3 BELOW)
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = A AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO THETA IS
C                               SPECIFIED AT THETA = B
C                               (SEE NOTES 2 AND 3 BELOW).
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                             WITH RESPECT TO THETA IS SPECIFIED
C                             AT THETA = A
C                             (SEE NOTES 1, 2 BELOW) AND THETA = B.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = A
C                               (SEE NOTES 1 AND 2 BELOW) AND THE
C                               SOLUTION IS SPECIFIED AT THETA = B.
C
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = A = 0 AND THE SOLUTION IS
C                               SPECIFIED AT THETA = B.
C                               (SEE NOTE 3 BELOW)
C
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = A = 0 AND THE DERIVATIVE
C                               OF THE SOLUTION WITH RESPECT TO THETA
C                               IS SPECIFIED AT THETA = B
C                               (SEE NOTE 2 BELOW).
C
C                          = 7  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = A AND THE SOLUTION IS
C                               UNSPECIFIED AT THETA = B = PI.
C                               (SEE NOTE 3 BELOW)
C
C                          = 8  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED AT
C                               THETA = A (SEE NOTE 1 BELOW)
C                               AND THE SOLUTION IS UNSPECIFIED AT
C                               THETA = B = PI.
C
C                          = 9  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = A = 0 AND THETA = B = PI.
C
C                          NOTE 1:
C                          IF A = 0, DO NOT USE MBDCND = 3, 4, OR 8,
C                          BUT INSTEAD USE MBDCND = 5, 6, OR 9.
C
C                          NOTE 2:
C                          IF B = PI, DO NOT USE MBDCND = 2, 3, OR 6,
C                          BUT INSTEAD USE MBDCND = 7, 8, OR 9.
C
C                          NOTE 3:
C                          WHEN THE SOLUTION IS SPECIFIED AT
C                          THETA = 0 AND/OR THETA = PI AND THE OTHER
C                          BOUNDARY CONDITIONS ARE COMBINATIONS
C                          OF UNSPECIFIED, NORMAL DERIVATIVE, OR
C                          PERIODICITY A SINGULAR SYSTEM RESULTS.
C                          THE UNIQUE SOLUTION IS DETERMINED BY
C                          EXTRAPOLATION TO THE SPECIFICATION OF THE
C                          SOLUTION AT EITHER THETA = 0 OR THETA = PI.
C                          BUT IN THESE CASES THE RIGHT SIDE OF THE
C                          SYSTEM  WILL BE PERTURBED BY THE CONSTANT
C                          PERTRB.
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES (IF ANY) OF
C                          THE SOLUTION AT THETA = A.
C
C                          WHEN MBDCND = 1, 2, OR 7,
C                            BDA(J) = U(A,PHI(J)) ,      J=1,2,...,N.
C
C                          WHEN MBDCND = 3, 4, OR 8,
C                            BDA(J) = (D/DTHETA)U(A,PHI(J)) ,
C                            J=1,2,...,N.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE,
C                          BDA IS A DUMMY VARIABLE.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT THETA = B.
C
C                          WHEN MBDCND = 1,4, OR 5,
C                            BDB(J) = U(B,PHI(J)) ,       J=1,2,...,N.
C
C                          WHEN MBDCND = 2,3, OR 6,
C                            BDB(J) = (D/DTHETA)U(B,PHI(J)) ,
C                            J=1,2,...,N.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDB IS
C                          A DUMMY VARIABLE.
C
C                        C,D
C                          THE RANGE OF PHI (LONGITUDE),
C                          I.E. C .LE. PHI .LE. D.
C                          C MUST BE LESS THAN D.  IF D-C = 2*PI,
C                          PERIODIC BOUNDARY CONDITIONS ARE USUALLY
C                          USUALLY PRESCRIBED.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE INTERVAL
C                          (C,D).  THE UNKNOWNS IN THE PHI-DIRECTION
C                          ARE GIVEN BY PHI(J) = C + (J-0.5)DPHI,
C                          J=1,2,...,N, WHERE DPHI = (D-C)/N.
C                          N MUST BE GREATER THAN 2.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT PHI = C  AND PHI = D.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN PHI,
C                               I.E.  U(I,J) = U(I,N+J).
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               PHI = C AND PHI = D
C                               (SEE NOTE BELOW).
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               PHI = C AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO PHI IS
C                               SPECIFIED AT PHI = D
C                               (SEE NOTE BELOW).
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO PHI IS SPECIFIED
C                               AT PHI = C AND PHI = D.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO PHI IS SPECIFIED
C                               AT PHI = C AND THE SOLUTION IS
C                               SPECIFIED AT PHI = D
C                               (SEE NOTE BELOW).
C
C                          NOTE:
C                          WHEN NBDCND = 1, 2, OR 4, DO NOT USE
C                          MBDCND = 5, 6, 7, 8, OR 9
C                          (THE FORMER INDICATES THAT THE SOLUTION
C                          IS SPECIFIED AT A POLE; THE LATTER
C                          INDICATES THE SOLUTION IS UNSPECIFIED).
C                          USE INSTEAD MBDCND = 1 OR 2.
C
C                        BDC
C                          A ONE DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT PHI = C.
C
C                          WHEN NBDCND = 1 OR 2,
C                            BDC(I) = U(THETA(I),C) ,     I=1,2,...,M.
C
C                          WHEN NBDCND = 3 OR 4,
C                            BDC(I) = (D/DPHI)U(THETA(I),C),
C                            I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDC IS A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT PHI = D.
C
C                          WHEN NBDCND = 1 OR 4,
C                            BDD(I) = U(THETA(I),D) ,     I=1,2,...,M.
C
C                          WHEN NBDCND = 2 OR 3,
C                            BDD(I) = (D/DPHI)U(THETA(I),D) ,
C                            I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDD IS A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION.  IF LAMBDA IS GREATER THAN 0,
C                          A SOLUTION MAY NOT EXIST.  HOWEVER,
C                          HSTSSP WILL ATTEMPT TO FIND A SOLUTION.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE RIGHT SIDE OF THE
C                          HELMHOLTZ EQUATION.
C                          FOR I=1,2,...,M AND J=1,2,...,N
C
C                            F(I,J) = F(THETA(I),PHI(J)) .
C
C                          F MUST BE DIMENSIONED AT LEAST M X N.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HSTSSP.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.
C                          IDIMF MUST BE AT LEAST M.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          W MAY REQUIRE UP TO 13M + 4N +
C                          M*INT(LOG2(N))  LOCATIONS.
C                          THE ACTUAL NUMBER OF LOCATIONS USED IS
C                          COMPUTED BY HSTSSP AND IS RETURNED IN
C                          THE LOCATION W(1).
C
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (THETA(I),PHI(J)) FOR
C                          I=1,2,...,M, J=1,2,...,N.
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC, DERIVATIVE,
C                          OR UNSPECIFIED BOUNDARY CONDITIONS IS
C                          SPECIFIED FOR A POISSON EQUATION
C                          (LAMBDA = 0), A SOLUTION MAY NOT EXIST.
C                          PERTRB IS A CONSTANT, CALCULATED AND
C                          SUBTRACTED FROM F, WHICH ENSURES THAT A
C                          SOLUTION EXISTS.  HSTSSP THEN COMPUTES
C                          THIS SOLUTION, WHICH IS A LEAST SQUARES
C                          SOLUTION TO THE ORIGINAL APPROXIMATION.
C                          THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C                          A SOLUTION; HENCE, THE SOLUTION IS NOT
C                          UNIQUE.  THE VALUE OF PERTRB SHOULD BE
C                          SMALL COMPARED TO THE RIGHT SIDE F.
C                          OTHERWISE, A SOLUTION IS OBTAINED TO AN
C                          ESSENTIALLY DIFFERENT PROBLEM.
C                          THIS COMPARISON SHOULD ALWAYS BE MADE TO
C                          INSURE THAT A MEANINGFUL SOLUTION HAS BEEN
C                          OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS. EXCEPT TO NUMBERS 0 AND 14,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR
C
C                          =  1  A .LT. 0 OR B .GT. PI
C
C                          =  2  A .GE. B
C
C                          =  3  MBDCND .LT. 1 OR MBDCND .GT. 9
C
C                          =  4  C .GE. D
C
C                          =  5  N .LE. 2
C
C                          =  6  NBDCND .LT. 0 OR NBDCND .GT. 4
C
C                          =  7  A .GT. 0 AND MBDCND = 5, 6, OR 9
C
C                          =  8  A = 0 AND MBDCND = 3, 4, OR 8
C
C                          =  9  B .LT. PI AND MBDCND .GE. 7
C
C                          = 10  B = PI AND MBDCND = 2,3, OR 6
C
C                          = 11  MBDCND .GE. 5 AND NDBCND = 1, 2, OR 4
C
C                          = 12  IDIMF .LT. M
C
C                          = 13  M .LE. 2
C
C                          = 14  LAMBDA .GT. 0
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HSTSSP, THE
C                          USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       COMF, GENBUN, GNBNAUX, AND POISTG
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN 1977.
C                        RELEASED ON NCAR'S PUBLIC SOFTWARE LIBRARIES
C                        IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77.
C
C ALGORITHM              THIS SUBROUTINE DEFINES THE FINITE-
C                        DIFFERENCE EQUATIONS, INCORPORATES BOUNDARY
C                        DATA, ADJUSTS THE RIGHT SIDE WHEN THE SYSTEM
C                        IS SINGULAR AND CALLS EITHER POISTG OR GENBUN
C                        WHICH SOLVES THE LINEAR SYSTEM OF EQUATIONS.
C
C TIMING                 FOR LARGE M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO M*N*LOG2(N).
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN
C                        A LOSS OF NO MORE THAN FOUR SIGNIFICANT
C                        DIGITS FOR N AND M AS LARGE AS 64.
C                        MORE DETAILED INFORMATION ABOUT ACCURACY
C                        CAN BE FOUND IN THE DOCUMENTATION FOR
C                        ROUTINE POISTG WHICH IS THE ROUTINE THAT
C                        ACTUALLY SOLVES THE FINITE DIFFERENCE
C                        EQUATIONS.
C
C REFERENCES             U. SCHUMANN AND R. SWEET,"A DIRECT METHOD
C                        FOR THE SOLUTION OF POISSON'S EQUATION WITH
C                        NEUMANN BOUNDARY CONDITIONS ON A STAGGERED
C                        GRID OF ARBITRARY SIZE," J. COMP. PHYS.
C                        20(1976), PP. 171-182.
C***********************************************************************
      DIMENSION       F(IDIMF,1) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C
      IERROR = 0
      PI = PIMACH(DUM)
      IF (A.LT.0. .OR. B.GT.PI) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GT.9) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9))
     1    IERROR = 7
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.8))
     1    IERROR = 8
      IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 9
      IF (B.EQ.PI .AND. (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6))
     1    IERROR = 10
      IF (MBDCND.GE.5 .AND.
     1    (NBDCND.EQ.1 .OR. NBDCND.EQ.2 .OR. NBDCND.EQ.4)) IERROR = 11
      IF (IDIMF .LT. M) IERROR = 12
      IF (M .LE. 2) IERROR = 13
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/FLOAT(M)
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/FLOAT(N)
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
      ISW = 1
      JSW = 1
      MB = MBDCND
      IF (ELMBDA .NE. 0.) GO TO 105
      GO TO (101,102,105,103,101,105,101,105,105),MBDCND
  101 IF (A.NE.0. .OR. B.NE.PI) GO TO 105
      MB = 9
      GO TO 104
  102 IF (A .NE. 0.) GO TO 105
      MB = 6
      GO TO 104
  103 IF (B .NE. PI) GO TO 105
      MB = 8
  104 JSW = 2
  105 CONTINUE
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      IWS = IWR+M
      DO 106 I=1,M
         J = IWR+I
         W(J) = SIN(A+(FLOAT(I)-0.5)*DELTAR)
         W(I) = SIN((A+FLOAT(I-1)*DELTAR))/DLRSQ
  106 CONTINUE
      MM1 = M-1
      DO 107 I=1,MM1
         K = IWC+I
         W(K) = W(I+1)
         J = IWR+I
         K = IWB+I
         W(K) = ELMBDA*W(J)-(W(I)+W(I+1))
  107 CONTINUE
      W(IWR) = SIN(B)/DLRSQ
      W(IWC) = ELMBDA*W(IWS)-(W(M)+W(IWR))
      DO 109 I=1,M
         J = IWR+I
         A1 = W(J)
         DO 108 J=1,N
            F(I,J) = A1*F(I,J)
  108    CONTINUE
  109 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
      GO TO (110,110,112,112,114,114,110,112,114),MB
  110 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 111 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  111 CONTINUE
      GO TO 114
  112 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 113 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  113 CONTINUE
  114 GO TO (115,117,117,115,115,117,119,119,119),MB
  115 A1 = 2.*W(IWR)
      W(IWC) = W(IWC)-W(IWR)
      DO 116 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  116 CONTINUE
      GO TO 119
  117 A1 = DELTAR*W(IWR)
      W(IWC) = W(IWC)+W(IWR)
      DO 118 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  118 CONTINUE
C
C     ENTER BOUNDARY DATA FOR PHI-BOUNDARIES.
C
  119 A1 = 2./DLTHSQ
      GO TO (129,120,120,122,122),NP
  120 DO 121 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)-A1*BDC(I)/W(J)
  121 CONTINUE
      GO TO 124
  122 A1 = 1./DELTHT
      DO 123 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)+A1*BDC(I)/W(J)
  123 CONTINUE
  124 A1 = 2./DLTHSQ
      GO TO (129,125,127,127,125),NP
  125 DO 126 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  126 CONTINUE
      GO TO 129
  127 A1 = 1./DELTHT
      DO 128 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  128 CONTINUE
  129 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 139,131,130
  130 IERROR = 14
      GO TO 139
  131 GO TO (139,139,132,139,139,132,139,132,132),MB
  132 GO TO (133,139,139,133,139),NP
  133 CONTINUE
      ISW = 2
      DO 135 J=1,N
         DO 134 I=1,M
            PERTRB = PERTRB+F(I,J)
  134    CONTINUE
  135 CONTINUE
      A1 = FLOAT(N)*(COS(A)-COS(B))/(2.*SIN(0.5*DELTAR))
      PERTRB = PERTRB/A1
      DO 137 I=1,M
         J = IWR+I
         A1 = PERTRB*W(J)
         DO 136 J=1,N
            F(I,J) = F(I,J)-A1
  136    CONTINUE
  137 CONTINUE
      A2 = 0.
      A3 = 0.
      DO 138 J=1,N
         A2 = A2+F(1,J)
         A3 = A3+F(M,J)
  138 CONTINUE
      A2 = A2/W(IWR+1)
      A3 = A3/W(IWS)
  139 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  R(I)*DELTHT**2
C
      DO 141 I=1,M
         J = IWR+I
         A1 = DLTHSQ*W(J)
         W(I) = A1*W(I)
         J = IWC+I
         W(J) = A1*W(J)
         J = IWB+I
         W(J) = A1*W(J)
         DO 140 J=1,N
            F(I,J) = A1*F(I,J)
  140    CONTINUE
  141 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (NBDCND .EQ. 0) GO TO 142
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 143
  142 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  143 CONTINUE
      W(1) = W(IWR+1)+3.*FLOAT(M)
      IF (ISW.NE.2 .OR. JSW.NE.2) GO TO 150
      IF (MB .NE. 8) GO TO 145
      A1 = 0.
      DO 144 J=1,N
         A1 = A1+F(M,J)
  144 CONTINUE
      A1 = (A1-DLRSQ*A3/16.)/FLOAT(N)
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(M)-BDC(M))/(D-C)
      A1 = BDB(1)-A1
      GO TO 147
  145 A1 = 0.
      DO 146 J=1,N
         A1 = A1+F(1,J)
  146 CONTINUE
      A1 = (A1-DLRSQ*A2/16.)/FLOAT(N)
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C)
      A1 = BDA(1)-A1
  147 DO 149 I=1,M
         DO 148 J=1,N
            F(I,J) = F(I,J)+A1
  148    CONTINUE
  149 CONTINUE
  150 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


	!------------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Klein-Gordon equation in 1 dimension
	! u_{tt}-u_{xx}+u=Es*|u|^2u
	! using a fourth order implicit time stepping scheme.
	!
	! The boundary conditions are u(x=0)=u(2*Lx*\pi),
	! The initial condition is u=sqrt(2)*sech((x-c*t)/sqrt(1-c^2));
	!
	! .. Parameters ..
	!  Nx                   = number of modes in x - power of 2 for FFT
	!  Nt			= number of timesteps to take
	!  Tmax			= maximum simulation time
	!  plotgap		= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD         = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx			= width of box in x direction
	!  ES			= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i			= loop counter in x direction
	!  n			= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start		= variable to record start time of program
	!  finish		= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfx		= Forward 2d fft plan
	!  planbx		= Backward 2d fft plan
	!  dt			= timestep
	!  ierr			= error code
	!  plotnum		= number of plot
	! .. Arrays ..
	!  unew 		= approximate solution
	!  vnew 		= Fourier transform of approximate solution
	!  u 			= approximate solution
	!  v 			= Fourier transform of approximate solution
	!  uold 		= approximate solution
	!  vold 		= Fourier transform of approximate solution
	!  nonlin 		= nonlinear term, u^3
	!  nonlinhat 		= Fourier transform of nonlinear term, u^3
	! .. Vectors ..
	!  kx			= fourier frequencies in x direction
	!  x			= x locations
	!  time			= times at which save data
	!  en			= total energy
	!  enstr		= strain energy
	!  enpot		= potential energy
	!  enkin		= kinetic energy
	!  name_config		= array to store filename for data to be saved
	!  fftfx		= array to setup 1D Fourier transform
	!  fftbx		= array to setup 1D Fourier transform
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!	getgrid.f90	-- Get initial grid of points
	! 	initialdata.f90 -- Get initial data
	!	enercalc.f90 -- Subroutine to calculate the energy
	!	savedata.f90 -- Save initial data
	!	storeold.f90 -- Store old data
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	OpenMP library

	PROGRAM Kg
	USE mpi
	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4), PARAMETER		:: Nx=1024
	INTEGER(kind=4), PARAMETER		:: Nt=1024
	INTEGER(kind=4), PARAMETER		:: plotgap=32
        INTEGER(kind=4), PARAMETER              :: maxiter=50
	REAL(kind=8), PARAMETER			:: &
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER			:: Lx=9.0d0
	REAL(kind=8), PARAMETER			:: Es=1.0d0
        REAL(kind=8), PARAMETER         	:: c=0.5
        REAL(kind=8), PARAMETER                 :: tol=0.1d0**12
	REAL(kind=8)				:: dt=5.0d0/REAL(Nt,kind(0d0))
	COMPLEX(kind=8), DIMENSION(1:Nx/2+1)	:: kx
	REAL(kind=8),  	 DIMENSION(1:Nx)	:: x
	REAL(kind=8), DIMENSION(1:Nx)           :: u,uold,unew,utemp,nonlin,nonlinfix
	COMPLEX(kind=8), DIMENSION(1:Nx/2+1)    :: v,vold,vnew,vtemp,nonlinhat,nonlinfixhat
	REAL(kind=8), DIMENSION(1:Nt+1)         :: time,enkin,enstr,enpot,en
        INTEGER(kind=4), DIMENSION(1:Nt+1)      :: itercount
        REAL(kind=8)                            :: chg,err,runtime,start,finish
	INTEGER(kind=4)				:: ierr,i,j,n,nn,iter
	INTEGER(kind=4)				:: count_rate,plotnum
	INTEGER(kind=4), PARAMETER              :: ntable=2*Nx+64,nwork=4*Nx
        INTEGER(kind=4),PARAMETER               :: isign=0,isignf=-1,isignb=1
        REAL(kind=8),PARAMETER                  :: scalef=1.0d0,scaleb=1.0d0/DBLE(Nx)
        REAL(kind=8), DIMENSION(1:ntable), SAVE :: tabledz,tablezd
        REAL(kind=8), DIMENSION(1:nwork)        :: work
        INTEGER(kind=4), SAVE                   :: isys
        CHARACTER*100                           :: name_config
        CALL MPI_INIT(ierr)
        ! set up fft
        CALL DZFFT(isign,Nx,scalef,u,v,tabledz,work,isys)
        CALL ZDFFT(isign,Nx,scaleb,v,u,tablezd,work,isys)

        PRINT *,'Setup FFTs'
	! setup fourier frequencies
	CALL getgrid(Nx,Lx,pi,name_config,x,kx)
	PRINT *,'Setup grid and fourier frequencies'
	CALL initialdata(Nx,dt,c,x,u,uold)
	plotnum=1
	name_config = 'data/u'
	!CALL savedata(Nx,plotnum,name_config,u)
        CALL DZFFT(isignf,Nx,scalef,u,   v,   tabledz,work,isys)
        CALL DZFFT(isignf,Nx,scalef,uold,vold,tabledz,work,isys)
        DO i=1,Nx/2 + 1
           nonlinhat(i)=v(i)
        END DO
        CALL ZDFFT(isignb,Nx,scaleb,nonlinhat,nonlin,tablezd,work,isys)
        PRINT *,'Transformed initialdata'
        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                        enkin(plotnum),enstr(plotnum),&
                        enpot(plotnum),en(plotnum),&
                        kx,nonlin,nonlinhat,&
                        v,vold,u,uold,tabledz,tablezd,work)
        DO i=1,Nx
           unew(i)=u(i)
           utemp(i)=u(i)
        END DO

	PRINT *,'Got initial data, starting timestepping'
	time(plotnum)=0.0d0
        start = MPI_WTIME()
	DO n=1,(Nt/3)
               ! Iteration 1
                nn=nn+1
		DO i=1,Nx
		       nonlinfix(i)=Es*u(i)**3&
                             +(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                              (3.0d0*(u(i)**2)*(-2.0d0*u(i)+uold(i))+&
                               6.0d0*u(i)*(-1.0d0*u(i))*(u(i)-uold(i)))
		END DO
                CALL DZFFT(isignf,Nx,scalef,nonlinfix,nonlinfixhat,&
                           tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        nonlinfixhat(i)=nonlinfixhat(i)+&
                             (kx(i)*kx(i) -1.0d0)*v(i) + &
                             (2.0d0*v(i)-vold(i))*(1.0d0/(dt*dt)-&
                             (kx(i)*kx(i) -1.0d0)*2.0d0/(4.0d0*3.0d0*2.0d0))
                END DO

                chg=1.0d0
                iter=1
                DO WHILE ((chg .gt. tol) .and. (iter .lt. maxiter))
                   DO i=1,Nx
                        utemp(i)=unew(i)
                        nonlin(i)=(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                                  (3.0d0*(u(i)**2)*unew(i)+&
                                   6.0d0*u(i)*unew(i)*(u(i)-uold(i)))
                   END DO
                   CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,&
                              tabledz,work,isys)
		   DO i=1,Nx/2 + 1
			vnew(i)=(nonlinhat(i)+nonlinfixhat(i) ) &
			/(1.0d0/(dt*dt) - (2.0d0/(4.0d0*3.0d0*2.0d0))*(kx(i)*kx(i) - 1.0d0))
		   END DO
                   CALL ZDFFT(isignb,Nx,scaleb,vnew,unew,tablezd,work,isys)
                   chg=0.0d0
		   ! normalize result
		   DO i=1,Nx
                        chg=chg+(unew(i)-utemp(i))**2
		   END DO
                   chg=SQRT(chg/REAL(Nx,kind(0d0)))
                   iter=iter+1
                END DO
		IF (mod(nn,plotgap)==0) then
			plotnum=plotnum+1
			time(plotnum)=nn*dt
			PRINT *,'time',nn*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                      enkin(plotnum),enstr(plotnum),&
                                      enpot(plotnum),en(plotnum),&
                                      kx,nonlin,nonlinhat,&
                                      vnew,v,unew,u,tabledz,tablezd,work)
			!CALL savedata(Nx,plotnum,name_config,unew)
		END IF
                ! Iteration 2
                nn=nn+1
                DO i=1,Nx
                       nonlinfix(i)=Es*unew(i)**3&
                             +(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                              (3.0d0*(unew(i)**2)*(-2.0d0*unew(i)+u(i))+&
                               6.0d0*unew(i)*(-1.0d0*unew(i))*(unew(i)-u(i)))
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlinfix,nonlinfixhat,&
                           tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        nonlinfixhat(i)=nonlinfixhat(i)+&
                             (kx(i)*kx(i) -1.0d0)*vnew(i) + &
                             (2.0d0*vnew(i)-v(i))*(1.0d0/(dt*dt)-&
                             (kx(i)*kx(i)-1.0d0)*2.0d0/(4.0d0*3.0d0*2.0d0))
                END DO

                chg=1.0d0
                iter=1
                DO WHILE ((chg .gt. tol) .and. (iter .lt. maxiter))
                   DO i=1,Nx
                        utemp(i)=uold(i)
                        nonlin(i)=(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                                  (3.0d0*(unew(i)**2)*uold(i)+&
                                   6.0d0*unew(i)*uold(i)*(unew(i)-u(i)))
                   END DO
                   CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,&
                              tabledz,work,isys)
                   DO i=1,Nx/2 + 1
                        vold(i)=(nonlinhat(i)+nonlinfixhat(i) ) &
                        /(1.0d0/(dt*dt) - (2.0d0/(4.0d0*3.0d0*2.0d0))*(kx(i)*kx(i) - 1.0d0))
                   END DO
                   CALL ZDFFT(isignb,Nx,scaleb,vold,uold,tablezd,work,isys)
                   chg=0.0d0
                   ! normalize result
                   DO i=1,Nx
                        chg=chg+(uold(i)-utemp(i))**2
                   END DO
                   chg=SQRT(chg/REAL(Nx,kind(0d0)))
                   iter=iter+1
                END DO
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=nn*dt
                        PRINT *,'time',nn*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                      enkin(plotnum),enstr(plotnum),&
                                      enpot(plotnum),en(plotnum),&
                                      kx,nonlin,nonlinhat,&
                                      vold,vnew,uold,unew,tabledz,tablezd,work)
                        !CALL savedata(Nx,plotnum,name_config,unew)
                END IF
                ! Iteration 3
                nn=nn+1
                DO i=1,Nx
                       nonlinfix(i)=Es*uold(i)**3&
                             +(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                              (3.0d0*(uold(i)**2)*(-2.0d0*uold(i)+unew(i))+&
                               6.0d0*uold(i)*(-1.0d0*uold(i))*(uold(i)-unew(i)))
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlinfix,nonlinfixhat,&
                           tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        nonlinfixhat(i)=nonlinfixhat(i)+&
                             (kx(i)*kx(i) -1.0d0)*vold(i) + &
                             (2.0d0*vold(i)-vnew(i))*(1.0d0/(dt*dt)-&
                             (kx(i)*kx(i)-1.0d0)*2.0d0/(4.0d0*3.0d0*2.0d0))
                END DO

                chg=1.0d0
                iter=1
                DO WHILE ((chg .gt. tol) .and. (iter .lt. maxiter))
                   DO i=1,Nx
                        utemp(i)=u(i)
                        nonlin(i)=(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                                  (3.0d0*(uold(i)**2)*u(i)+&
                                   6.0d0*uold(i)*u(i)*(uold(i)-unew(i)))
                   END DO
                   CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,&
                              tabledz,work,isys)
                   DO i=1,Nx/2 + 1
                        v(i)=(nonlinhat(i)+nonlinfixhat(i) ) &
                        /(1.0d0/(dt*dt) - (2.0d0/(4.0d0*3.0d0*2.0d0))*(kx(i)*kx(i) - 1.0d0))
                   END DO
                   CALL ZDFFT(isignb,Nx,scaleb,v,u,tablezd,work,isys)
                   chg=0.0d0
                   ! normalize result
                   DO i=1,Nx
                        chg=chg+(u(i)-utemp(i))**2
                   END DO
                   chg=SQRT(chg/REAL(Nx,kind(0d0)))
                   iter=iter+1
                END DO
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=nn*dt
                        PRINT *,'time',nn*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                      enkin(plotnum),enstr(plotnum),&
                                      enpot(plotnum),en(plotnum),&
                                      kx,nonlin,nonlinhat,&
                                      v,vold,u,uold,tabledz,tablezd,work)
                        !CALL savedata(Nx,plotnum,name_config,unew)
                END IF
	END DO
        IF(mod(Nt,3)>0) THEN
               ! Iteration 1
                nn=nn+1
                DO i=1,Nx
                       nonlinfix(i)=Es*u(i)**3&
                             +(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                              (3.0d0*(u(i)**2)*(-2.0d0*u(i)+uold(i))+&
                               6.0d0*u(i)*(-1.0d0*u(i))*(u(i)-uold(i)))
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlinfix,nonlinfixhat,&
                           tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        nonlinfixhat(i)=nonlinfixhat(i)+&
                             (kx(i)*kx(i) -1.0d0)*v(i) + &
                             (2.0d0*v(i)-vold(i))*(1.0d0/(dt*dt)-&
                             (kx(i)*kx(i)-1.0d0)*2.0d0/(4.0d0*3.0d0*2.0d0))
                END DO

                chg=1.0d0
                iter=1
                DO WHILE ((chg .gt. tol) .and. (iter .lt. maxiter))
                   DO i=1,Nx
                        utemp(i)=unew(i)
                        nonlin(i)=(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                                  (3.0d0*(u(i)**2)*unew(i)+&
                                   6.0d0*u(i)*unew(i)*(u(i)-uold(i)))
                   END DO
                   CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,&
                              tabledz,work,isys)
                   DO i=1,Nx/2 + 1
                        vnew(i)=(nonlinhat(i)+nonlinfixhat(i) ) &
                        /(1.0d0/(dt*dt) - (2.0d0/(4.0d0*3.0d0*2.0d0))*(kx(i)*kx(i) - 1.0d0))
                   END DO
                   CALL ZDFFT(isignb,Nx,scaleb,vnew,unew,tablezd,work,isys)
                   chg=0.0d0
                   ! normalize result
                   DO i=1,Nx
                        chg=chg+(unew(i)-utemp(i))**2
                   END DO
                   chg=SQRT(chg/REAL(Nx,kind(0d0)))
                   iter=iter+1
                END DO
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=nn*dt
                        PRINT *,'time',nn*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                      enkin(plotnum),enstr(plotnum),&
                                      enpot(plotnum),en(plotnum),&
                                      kx,nonlin,nonlinhat,&
                                      vnew,v,unew,u,tabledz,tablezd,work)
                        !CALL savedata(Nx,plotnum,name_config,unew)
                END IF
        ENDIF
        IF(mod(Nt,3)>1) THEN
                ! Iteration 2
                nn=nn+1
                DO i=1,Nx
                       nonlinfix(i)=Es*unew(i)**3&
                             +(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                              (3.0d0*(unew(i)**2)*(-2.0d0*unew(i)+u(i))+&
                               6.0d0*unew(i)*(-1.0d0*unew(i))*(unew(i)-u(i)))
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlinfix,nonlinfixhat,&
                           tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        nonlinfixhat(i)=nonlinfixhat(i)+&
                             (kx(i)*kx(i) -1.0d0)*vnew(i) + &
                             (2.0d0*vnew(i)-v(i))*(1.0d0/(dt*dt)-&
                             (kx(i)*kx(i)-1.0d0)*2.0d0/(4.0d0*3.0d0*2.0d0))
                END DO

                chg=1.0d0
                iter=1
                DO WHILE ((chg .gt. tol) .and. (iter .lt. maxiter))
                   DO i=1,Nx
                        utemp(i)=uold(i)
                        nonlin(i)=(2.0d0/(4.0d0*3.0d0*2.0d0))*&
                                  (3.0d0*(unew(i)**2)*uold(i)+&
                                   6.0d0*unew(i)*uold(i)*(unew(i)-u(i)))
                   END DO
                   CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,&
                              tabledz,work,isys)
                   DO i=1,Nx/2 + 1
                        vold(i)=(nonlinhat(i)+nonlinfixhat(i) ) &
                        /(1.0d0/(dt*dt) -(2.0d0/(4.0d0*3.0d0*2.0d0))*(kx(i)*kx(i) - 1.0d0))
                   END DO
                   CALL ZDFFT(isignb,Nx,scaleb,vold,uold,tablezd,work,isys)
                   chg=0.0d0
                   ! normalize result
                   DO i=1,Nx
                        chg=chg+(uold(i)-utemp(i))**2
                   END DO
                   chg=SQRT(chg/REAL(Nx,kind(0d0)))
                   iter=iter+1
                END DO
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=nn*dt
                        PRINT *,'time',nn*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                      enkin(plotnum),enstr(plotnum),&
                                      enpot(plotnum),en(plotnum),&
                                      kx,nonlin,nonlinhat,&
                                      vold,vnew,uold,unew,tabledz,tablezd,work)
                        !CALL savedata(Nx,plotnum,name_config,unew)
                END IF
        END IF
        finish=MPI_WTIME()
        PRINT*,'Finished timestepping'
        runtime=REAL(finish-start,kind(0d0))
	PRINT*,'Program took ',runtime,'for Time stepping'
	CALL saveresults(Nt,plotgap,time(1:1+n/plotgap),en(1:1+n/plotgap),&
			enstr(1:1+n/plotgap),enkin(1:1+n/plotgap),&
                        enpot(1:1+n/plotgap))

	! Save times at which output was made in text format
	PRINT *,'Saved data'
        IF(mod(Nt,3)==0) CALL errorcalc(Nt,Nx,dt,c,x,u,err)
        IF(mod(Nt,3)==1) CALL errorcalc(Nt,Nx,dt,c,x,unew,err)
        IF(mod(Nt,3)==2) CALL errorcalc(Nt,Nx,dt,c,x,uold,err)

        name_config = 'data/errortime'
        CALL savetimeanderror(Nx,Nt,err,runtime,name_config)

	PRINT *,'Program execution complete'
        CALL MPI_FINALIZE(ierr)
	END PROGRAM Kg


MODULE SOI_thermal_source

    USE type_kinds, only : fpk => fp_kind

    IMPLICIT NONE

    REAL(fpk), PRIVATE, PARAMETER    :: ONE = 1.0_fpk
    REAL(fpk), PRIVATE, PARAMETER    :: TWO = 2.0_fpk
    REAL(fpk), PRIVATE, PARAMETER    :: HALF = 0.5_fpk
    REAL(fpk), PRIVATE, PARAMETER    :: ZERO = 0.0_fpk
    REAL(fpk), PRIVATE, PARAMETER    :: TWELVE = 12.0_fpk
    REAL(fpk), PRIVATE, PARAMETER    :: cut_opd = 0.2_fpk

    PUBLIC :: thermal_source, thermal_source_TL, thermal_source_AD

CONTAINS

    subroutine    thermal_source( slopd, &    ! Slant optical depth of layer (opd/mu)
                                ssa,     &    ! ssa of layer
                                tau,     &    ! slant transmittance of layer (exp(-opd/mu))
                                Ttop,    &    ! Top Temp (or BB radiance) of layer
                                Tbot,    &    ! Bot Temp (or BB radiance) of layer
                                Sp,      &    ! Upwelling Source
                                Sm )          ! Downwelling Source

        REAL(fpk), intent(in)        ::    slopd
        REAL(fpk), intent(in)        ::    ssa
        REAL(fpk), intent(in)        ::    tau
        REAL(fpk), intent(in)        ::    Ttop
        REAL(fpk), intent(in)        ::    Tbot
        REAL(fpk), intent(out)       ::    Sp, Sm

        REAL(fpk)                    ::    A, B

        A = HALF * (Tbot + Ttop) * (ONE-tau)
        if (slopd < cut_opd) then
            B = (Ttop-Tbot)*(slopd/TWELVE)*(ONE-tau)
        else
            B = (Ttop-Tbot)*( tau + (ONE - tau)*(HALF - ONE/slopd) )
        endif

        sp = (A + B) * (ONE - ssa)
        sm = (A - B) * (ONE - ssa)

    end subroutine thermal_source

    subroutine thermal_source_TL( slopd, ssa, tau, Ttop, Tbot, &
                                  slopd_TL, ssa_TL, tau_TL, Ttop_TL, Tbot_TL, &
                                  Sp, Sm, Sp_TL, Sm_TL )

        REAL(fpk), intent(in)        ::    slopd, ssa, tau, Ttop, Tbot  ! regular input variables
        REAL(fpk), intent(in)        ::    slopd_TL, ssa_TL, tau_TL, Ttop_TL, Tbot_TL ! TL inputs
        REAL(fpk), intent(out)       ::    Sp, Sm, Sp_TL, Sm_TL    ! TL outputs

        REAL(fpk)                    ::    A, B, A_TL, B_TL

        A_TL = HALF * (Tbot_TL + Ttop_TL) * (ONE-tau) - HALF * (Tbot+Ttop)*tau_TL
        A = HALF * (Tbot + Ttop) * (ONE-tau)
        if (slopd < cut_opd) then
            B_TL = (Ttop_TL - Tbot_TL) * (slopd/TWELVE)*(ONE-tau) + &
                    (Ttop-Tbot)*( slopd_TL*(ONE-tau) - slopd*tau_TL)/TWELVE
               B = (Ttop-Tbot)*(slopd/TWELVE)*(ONE-tau)
        else
            B_TL = (Ttop_TL - Tbot_TL) * (tau + (ONE-tau)*(HALF-ONE/slopd) ) + &
                    (Ttop-Tbot) * ( tau_TL + (ONE-tau)*(slopd_TL/(slopd*slopd)) - &
                    tau_TL*(HALF - ONE/slopd) )
               B = (Ttop-Tbot)*( tau + (ONE - tau)*(HALF - ONE/slopd) )
        endif

        sp = (A + B) * (ONE - ssa)
        sm = (A - B) * (ONE - ssa)
        sp_TL = (A_TL + B_TL) * (ONE - ssa) - (A+B) * ssa_TL
        sm_TL = (A_TL - B_TL) * (ONE - ssa) - (A-B) * ssa_TL

    end subroutine thermal_source_TL

    subroutine thermal_source_AD( slopd, ssa, tau, Ttop, Tbot, &  ! input variables
                                  slopd_AD, ssa_AD, tau_AD, Ttop_AD, Tbot_AD, & !output AD variables
                                  sp_AD, sm_AD )     ! input AD variables

        REAL(fpk), intent(in)    :: slopd, ssa, tau, Ttop, Tbot
        REAL(fpk), intent(inout) :: slopd_AD, ssa_AD, tau_AD, Ttop_AD, Tbot_AD
        REAL(fpk), intent(in)    :: sp_AD, sm_AD

        REAL(fpk)            ::    A, B, A_AD, B_AD, dT, tmp
        ! forward re-computations
        dT = Ttop - Tbot
        A = HALF * (Tbot + Ttop) * (ONE - tau)
        if (slopd < cut_opd) then
            B = dT*(slopd/TWELVE)*(ONE - tau)
        else
            B = dT*( tau + (ONE - tau)*(HALF - ONE/slopd) )
        endif

        ! adjoint computations
        A_AD = (ONE - ssa) * (sp_AD + sm_AD)
        B_AD = (ONE - ssa) * (sp_AD - sm_AD)
        ssa_AD = -(A+B) * sp_AD - (A-B)*sm_AD + ssa_AD

        if (slopd < cut_opd) then
            tmp = slopd/TWELVE*(ONE - tau)
            Ttop_AD = tmp * B_AD + Ttop_AD
            Tbot_AD = -tmp * B_AD + Tbot_AD
            slopd_AD = dT/TWELVE * (ONE - tau)*B_AD + slopd_AD
            tau_AD = -dT*slopd/TWELVE * B_AD + tau_AD
        else
            tmp = tau + (ONE - tau)*(HALF - ONE/slopd)
            Ttop_AD =  tmp * B_AD + TTop_AD
            Tbot_AD = -tmp * B_AD + Tbot_AD
            slopd_AD = dT * (ONE - tau)/(slopd*slopd) * B_AD + slopd_AD
            tau_AD = dT * (HALF + ONE/slopd) * B_AD + tau_AD
        endif

        tau_AD = -HALF * (Tbot+Ttop) * A_AD + tau_AD
        tmp = HALF * (ONE - tau) * A_AD
        Ttop_AD = tmp + Ttop_AD
        Tbot_AD = tmp + Tbot_AD

    end subroutine thermal_source_AD

end module SOI_thermal_source


!-----subroutine---------------------------------------------g.guidati--
!
     subroutine SPL_E1A (xa, ya, y2a, n, x, y, dydx, khi, klo)
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             execute spline interpolation
!                       (natural splines)
!
!.......................................................................
!               declarations
!.......................................................................
USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: klo,khi,n

REAL(DbKi)                   :: a,b,h,x
REAL(DbKi)                   :: xa(n)

COMPLEX (DbKi)               ::  ya(n), y2a(n), y, dydx

!.......................................................................
!               execute spline interpolation
!.......................................................................

      h = xa(khi) - xa(klo)
      if (h.eq.0.) then
          write(*,*)'ERROR:TINoise:SPL_E0A: bad xa input in splint'
          STOP 1
      endif
      a = (xa(khi) - x) / h
      b = (x - xa(klo)) / h
      y = a * ya(klo) + b * ya(khi) + ((a**3.0d0 - a) * y2a(klo) &
          +  (b**3.0d0 - b) * y2a(khi))* (h**2.0d0) / 6.0d0
      dydx = (-ya(klo) + ya(khi)) / h + ((-3.0d0*a**2.0d0 + 1.0d0) &
             * y2a(klo)+(+3.0d0*b**2.0d0-1.0d0)*y2a(khi))*h/6.0d0

!.......................................................................
!               end of subroutine
!.......................................................................
      return
!***********************************************************************
      end


c $Id: dwidth.f,v 1.1 2012/11/29 21:00:07 jwebb Exp $
C####C##1#########2#########3#########4#########5#########6#########7##
      real*8 function mmean (io,m0,g,mmin,mmax)
c
cinput  io  : flag (see bleow)
cinput  m0  : pole mass
cinput  g   : nominal width
cinput mmin : minimal mass
cinput mmax : maximal mass
c
c   io=0 : Yields average mass between {\rm mmin} and {\rm mmax}
c          according to a Breit-Wigner function with constant width {\rm g}
c          and pole {\rm m0}.\\
c   io=1 : Chooses a mass randomly between {\rm mmin} and {\rm mmax}
c	     according to a Breit-Wigner function with constant
c	     width {\rm g} and pole {\rm m0}.\\
c    else: Integral of a Breit-Wigner function from {\rm mmin} to {\rm mmax}.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none

      real*8 m0,g,mmin,mmax,x,i0,i1,inv,fmin,fmax,ranf,f,gcut
      parameter(gcut=1d-10)
      integer io
      logical errchk
      parameter (errchk=.true.)

      i0(x) =2.*g*atan( 2.* (x-m0)/ g  )
      i1(x) =.5*g**2*log( (x-m0)**2+g**2/4. ) + m0*i0(x)
      inv(x)=.5*g*tan( 0.5*x/g )+m0

c...check for some error conditions
      if(errchk)then
        if(mmin.gt.mmax)
     .    write(6,*)'mmean: mass range negative (mmin>mmax)'
     .          ,mmin,mmax
        if(g.le.gcut.and.(m0.gt.mmax.or.m0.lt.mmin))
     .    write(6,*)'mmean: narrow particle out of mass range'
      end if

      if(io.eq.0)then
        if(g.le.gcut)then
          mmean=0d0
          if(mmin.le.m0.and.m0.le.mmax)mmean=1d0
        else
          mmean=(i1(mmax)-i1(mmin))/(i0(mmax)-i0(mmin))
        end if
      else if(io.eq.1)then
c... determin a mass in a given interval
        if(g.le.gcut)then
          mmean=max(mmin,min(mmax,m0))
        else
          fmin=i0(mmin)
          fmax=i0(mmax)
          f=fmin+(fmax-fmin)*ranf(0)
          mmean=inv(f)
        end if
      else
	    mmean=i0(mmax)-i0(mmin) !this might not work for narrow part.
      end if
      return
      end

C####C##1#########2#########3#########4#########5#########6#########7##
      subroutine getmas(m0,g0,i,iz,mmin,mmax,mrest,m)
c
cinput  m0   : pole mass of resonance
cinput  g0   : nominal width of resonance
cinput  i    : resonance ID
cinput  iz   : iso3 of resonance
cinput  mmin : minimal mass
cinput  mmax : maximal mass
coutput m    : actual mass of the resonance
c
c	{\tt getmas} (not $\rightarrow$ {\tt getmass}) first chooses the
c	mass {\tt m} of resonance {\tt i} between {\tt mmin} and {\tt mmax}
c	by a call of {\tt mmean}. Since {\tt mmean} only handles Breit-Wigners
c	with constant widths it follows
c	a correction such that  {\tt m} is distributed according to mass
c	dependent widths (corresponding to {\tt fbrwig(...,m,1)}).
c
C####C##1#########2#########3#########4#########5#########6#########7##
      implicit none
      include 'options.f'
      include 'comres.f'
      integer i,iz,nrej, nrejmax
      real*8 m,m0,g0,mmin,mmax,x,x0,gg,f,g,h,pi,al,alpha,ce,mmax2
      real*8 phi,k,k0,mrest
c...functions
      real*8 ranf,mmean,fbrwig,bwnorm,pcms
      parameter(pi=3.1415926535d0)
      parameter(alpha=3d0, ce=2d0, nrejmax=1000000)

c 'broadened' Breit-Wigner function with h(x0,al)=h(x0,1)
c normalised to alpha
      h(x,x0,gg,al)=al*0.5/pi*(al*gg)/((x-x0)**2+0.25*(al*gg)**2)

c cut-off for maximum resonance mass
      mmax2=min(mresmax,mmax)

      if(g0.lt.1d-4.or.CTOption(1).ne.0.or.CTOption(32).ne.0)then
        m=mmean(1,m0,g0,mmin,mmax2)
        return
      else
	  nrej=0

c This is a Monte Carlo rejection method, where the invertable
c BW-distribution with constant widths is used to limit the BW-distribution
c with mass-dep. widths whose inverse is not known analytically.

108     continue
        m=mmean(1,m0,alpha*g0,mmin,mmax2)
        if(m.gt.(mmax2+1d-8).or.m.lt.(mmin-1d-8))then
           write(*,*)'getmas (W): m outside (mmin,mmax2)',m,mmin,mmax2
           write(*,*)'called as getmas(',m0,g0,i,mmin,mmax,')'
           write(*,*)'Program stopped'
           stop
        endif
        if ((CTOption(25).eq.1).and.(mrest.gt.0.0)) then
           k=pcms(mmax2+mrest,mrest,m)
           k0=pcms(mmax2+mrest,mrest,mmin)
           phi = m*k / (mmin*k0)
        else
           phi = 1.0
        endif

c Breit-Wigner with mass dependent widths and phase space correction

	    f=fbrwig(i,iz,m,1)*phi/bwnorm(i)
	    g=ce*h(m,m0,g0,alpha)

	    if(g.lt.f)then
	      write(*,*)'(W) getmas: C h(m) not limiting at m=',m
	      write(*,*)'->mass distribution of ',i,'might be corrupt'
	    endif
          nrej=nrej+1
        if (nrej.le.nrejmax.and.(ranf(0)*g).gt.f) goto 108
        if (nrej.gt.nrejmax) then
c           write(*,*)'(W) getmas_space: too many rejections, m= ',m
c           write(*,*)'called with (',m0,g0,i,mmin,mmax,mrest,')'
c           write(*,*)'->mass distribution of ',i,' might be corrupt'
           m=mmean(1,m0,alpha*g0,mmin,mmax2)
        endif

      endif

      return
      end

C####C##1#########2#########3#########4#########5#########6#########7##
	real*8 function bwnorm(ires)
c
cinput  ires   : itype of resonance
c
c	This function calculates the integral of {\tt fbrwig}
c	between parameters {\tt mmin}(= 0~GeV) and {\tt mmax}(= 30~GeV) by
c	calling {\tt qsimp3} resp. by table lookup. It's value shall
c	serve as the norm of the Breit-Wigner function of particle {\tt ires}
c	with mass dependent width.
c
C####C##1#########2#########3#########4#########5#########6#########7##

	implicit none
	include 'comres.f'
	include 'comwid.f'
	include 'options.f'
	integer ires,iz,isoit,it
	real*8 mmin,mmax,pole,norm1,norm2
	real*8 widit,massit
	parameter(mmin=0d0,mmax=50d0)
	real*8 fbrwig
        external fbrwig

	if((CTOption(36).ne.0.or.CTOption(1).ne.0).and.wtabflg.gt.1)then
	  bwnorm=1d0
	  return
	endif

	it=iabs(ires)

      if (wtabflg.ge.2.and.CTOption(33).eq.0) then
c table lookup
         if (it.ge.minbar.and.it.le.maxbar) then
           bwnorm=bwbarnorm(it)
         else if (it.ge.minmes.and.it.le.maxmes) then
           bwnorm=bwmesnorm(it)
         else
           write (6,*) '*** error(bwnorm) wrong id:',it
           bwnorm=1d0
         endif
	else
c calculate
	   if (widit(it).gt.1d-3)then

           pole=massit(it)
c arbitrary value of iz
	     iz=isoit(it)

c     the integration is divided by the pole of the Breit-Wigner -
c     thus two integrations with pole as upper or lower boundary
c     respectively are necessary

	     call qsimp3(fbrwig,mmin,pole,it,iz,norm1,-1)
	     call qsimp3(fbrwig,pole,mmax,it,iz,norm2,+1)
	     bwnorm=norm1+norm2
	   else
	     bwnorm=1d0
	   endif
	endif

	return
	end

c no physics after these routines!
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c(c) numerical receipies, adapted for f(idum1,idum2,x)
      SUBROUTINE qsimp3(func,a,b,idum1,idum2,s,flag)
c
c     Simpson integration via Numerical Receipies.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none

      include 'options.f'

      INTEGER JMAX,j,idum1,idum2,flag
      REAL*8 a,b,func,s,EPS
      REAL*8 os,ost,st
      PARAMETER (JMAX=100)
      external func
      if(b-a.le.1.d-4) then
         s=0.d0
         return
      endif

      EPS = 5d-3
      if (CTOption(35).eq.1) EPS=5d-4

      ost=-1.d30
      os= -1.d30
      do 11 j=1,JMAX
         if(flag.eq.-1) then
            call midsqu3(func,a,b,idum1,idum2,st,j)
         elseif(flag.eq.1) then
            call midsql3(func,a,b,idum1,idum2,st,j)
         endif
        s=(9.*st-ost)/8.

        if (abs(s-os).le.EPS*abs(os)) return
        os=s
        ost=st
11    continue

      write(6,*)  'too many steps in qsimp3, increase JMAX!'

      return
      END

      SUBROUTINE midsqu3(funk,aa,bb,idum1,idum2,s,n)
c     modified midpoint rule; allows singuarity at upper limit
      implicit none
      integer idum1,idum2
      INTEGER n
      REAL*8 aa,bb,s,funk
      EXTERNAL funk
      INTEGER it,j
      REAL*8 ddel,del,sum,tnm,x,func,a,b
      func(x)=2.*x*funk(idum1,idum2,bb-x**2,1)
      b=sqrt(bb-aa)
      a=0.
      if (n.eq.1) then
        s=(b-a)*func(0.5*(a+b))
      else
        it=3**(n-2)
        tnm=it
        del=(b-a)/(3.*tnm)
        ddel=del+del
        x=a+0.5*del
        sum=0.
        do 11 j=1,it
          sum=sum+func(x)
          x=x+ddel
          sum=sum+func(x)
          x=x+del
11      continue
        s=(s+(b-a)*sum/tnm)/3.
      endif
      return
      END

      SUBROUTINE midsql3(funk,aa,bb,idum1,idum2,s,n)
c     modified midpoint rule; allows singularity at lower limit
      implicit none
      integer idum1,idum2
      INTEGER n
      REAL*8 aa,bb,s,funk
      EXTERNAL funk
      INTEGER it,j
      REAL*8 ddel,del,sum,tnm,x,func,a,b
      func(x)=2.*x*funk(idum1,idum2,aa+x**2,1)
      b=sqrt(bb-aa)
      a=0.
      if (n.eq.1) then
        s=(b-a)*func(0.5*(a+b))
      else
        it=3**(n-2)
        tnm=it
        del=(b-a)/(3.*tnm)
        ddel=del+del
        x=a+0.5*del
        sum=0.
        do 11 j=1,it
          sum=sum+func(x)
          x=x+ddel
          sum=sum+func(x)
          x=x+del
11      continue
        s=(s+(b-a)*sum/tnm)/3.
      endif
      return
      END


! =============================================================================
!                       Test Jacobi diagonalisation
!
!               This unit test checks the eigenvalue solver for
!               spherical parcels. In the spherical case, the eigenvectors
!               can point in any direction (but they are orthogonal to each
!               other)
! =============================================================================
program test_jacobi_3
    use unit_test
    use constants, only : zero, ten
    use jacobi
    implicit none

    double precision     :: error
    integer              :: n, k, sk
    double precision     :: V(3, 3)
    double precision     :: B(3, 3), D(3)
    double precision     :: A(3, 3), eval ! reference
    integer, allocatable :: seed(:)

    call random_seed(size=sk)
    allocate(seed(1:sk))
    seed(:) = 42
    call random_seed(put=seed)

    error = zero

    do n = 1, 10000

        call create_symmetric_matrix

        call jacobi_diagonalise(B, D, V)

        ! check eigenvalues
        error = max(error, dabs(eval - D(1)) &
                         + dabs(eval - D(2)) &
                         + dabs(eval - D(3)))

        ! check eigenvectors
        B = matmul(matmul(transpose(V), B), V)

        B = dabs(A - B)

        error = max(error, sum(B))

        ! check if orthogonal
        error = max(error, dabs(dot_product(V(:, 1), V(:, 2))))
        error = max(error, dabs(dot_product(V(:, 1), V(:, 3))))
        error = max(error, dabs(dot_product(V(:, 2), V(:, 3))))
    enddo

    call print_result_dp('Test Jacobi 3', error, atol=dble(1.0e-11))

    contains

        subroutine create_symmetric_matrix
            integer          :: i, j
            double precision :: rndm(3, 3), val
            logical          :: valid
            double precision :: Q(3, 3)

            valid = .false.

            do while (.not. valid)
                call random_number(eval)
                eval = 10 * eval

                ! Create orthogonal vectors using Gram-Schmidt orthogonalization
                ! (https://de.wikipedia.org/wiki/Gram-Schmidtsches_Orthogonalisierungsverfahren)
                do i = 1, 3
                    do j = 1, 3
                        call random_number(val)
                        rndm(i, j) = 10.0d0 * val
                    enddo
                enddo

                Q = 0.0d0

                do j = 1, 3
                    Q(:, j) = rndm(:, j)
                    do i = 1, j - 1
                        Q(:, j) = Q(:, j) &
                                - Q(:, i) * dot_product(Q(:, i), rndm(:, j)) &
                                        / dot_product(Q(:, i), Q(:, i))
                    enddo
                    Q(:, j) = Q(:, j) / norm2(Q(:, j))
                enddo

                ! Check orthogonalization error:
                val = dabs(dot_product(Q(:, 1), Q(:, 2))) &
                    + dabs(dot_product(Q(:, 1), Q(:, 3))) &
                    + dabs(dot_product(Q(:, 2), Q(:, 3)))

                valid = (val < 1.0e-13)
            enddo

            ! Create symmetric B matrix
            B = zero
            do i = 1, 3
                do j = 1, 3
                    do k = 1, 3
                        B(i, j) = B(i, j) + Q(i, k) * eval * Q(j, k)
                    enddo
                enddo
            enddo

            A = B
        end subroutine create_symmetric_matrix

end program test_jacobi_3


SUBROUTINE p810(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.10 Plane analysis of the diffusion-convection equation
!              using 4-node rectangular quadrilaterals. Implicit time
!              integration using the "theta" method.
!              Untransformed solution.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,j,k,nband,ndim=2,nels,neq,fixed_freedoms,nip=4,nlen,nn,   &
   nod=4,npri,np_types,nres,nstep,ntime,nxe,nye
 REAL(iwp)::det,dtim,part1,part2,pt2=0.2_iwp,penalty=1.0e20_iwp,theta,    &
   time,ux,uy,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::ans(:),conc(:),coord(:,:),copy(:,:),der(:,:),     &
   deriv(:,:),dtkd(:,:),fun(:),g_coord(:,:),jac(:,:),kb(:,:),kc(:,:),     &
   loads(:),ntn(:,:),pb(:,:),mm(:,:),points(:,:),prop(:,:),storpb(:),     &
   weights(:),work(:,:),x_coords(:),y_coords(:)
!-------------------------input and initialisation------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 neq=nn
 ALLOCATE(points(nip,ndim),weights(nip),coord(nod,ndim),fun(nod),         &
   jac(ndim,ndim),g_coord(ndim,nn),der(ndim,nod),deriv(ndim,nod),         &
   mm(nod,nod),g_num(nod,nels),kc(nod,nod),ntn(nod,nod),num(nod),         &
   dtkd(nod,nod),prop(ndim,np_types),x_coords(nxe+1),y_coords(nye+1),     &
   etype(nels),conc(nye+1))
 READ(10,*)prop
 etype=1
 if(np_types>1)read(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres,ntime,ux,uy
 nband=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'x')
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   IF(nband<bandwidth(num))nband=bandwidth(num)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 ALLOCATE(kb(neq,2*nband+1),pb(neq,2*nband+1),work(nband+1,neq),          &
          copy(nband+1,neq),loads(0:neq),ans(0:neq))
 WRITE(11,'(2(a,i5))')                                                    &
 " There are",neq," equations and the half-bandwidth is",nband
 CALL sample(element,points,weights)
 kb=zero
 pb=zero
!-----------------------global conductivity and "mass" matrix assembly----
 elements_2: DO iel=1,nels
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   kc=zero
   mm=zero
   gauss_pts: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     DO j=1,nod
     DO k=1,nod
         part1=prop(1,etype(iel))*deriv(1,j)*deriv(1,k)+                  &
         prop(2,etype(iel))*deriv(2,j)*deriv(2,k)
         part2=ux*fun(j)*deriv(1,k)+uy*fun(j)*deriv(2,k)
         dtkd(j,k)=(part1-part2)*det*weights(i)
     END DO
     END DO
     kc=kc+dtkd
     CALL cross_product(fun,fun,ntn)
     mm=mm+ntn*det*weights(i)
   END DO gauss_pts
   mm=mm/(theta*dtim)
   CALL formtb(kb,kc,num)
   CALL formtb(pb,mm,num)
 END DO elements_2
 pb=pb+kb
 kb=pb-kb/theta
!-----------------------boundary conditions-------------------------------
 READ(10,*)fixed_freedoms
 ALLOCATE(node(fixed_freedoms),storpb(fixed_freedoms))
 READ(10,*)node
 pb(node,nband+1)=pb(node,nband+1)+penalty
 storpb=pb(node,nband+1)
!-----------------------factorise equations-------------------------------
 work=zero
 CALL gauss_band(pb,work)
 WRITE(11,'(/a,i3,a)')"    Time      Concentration(node",nres,")"
 WRITE(11,'(2e12.4)')0.0,loads(nres)
 loads=zero
!-----------------------time stepping loop--------------------------------
 timesteps: DO j=1,nstep
   time=j*dtim
   copy=work
   CALL bantmul(kb,loads,ans)
   ans(0)=zero
   IF(time<=pt2)THEN
     ans(node)=storpb
   ELSE
     ans(node)=zero
   END IF
   CALL solve_band(pb,copy,ans)
   ans(0)=zero
   loads=ans
   IF(j==ntime)conc(:)=loads(2:neq:2)
   IF(j/npri*npri==j)WRITE(11,'(2e12.4)')time,loads(nres)
 END DO timesteps
 WRITE(11,'(/a,e10.4,a)')                                                 &
       "  Distance    Concentration(time=",nstep*dtim,")"
 DO i=1,nye+1
   WRITE(11,'(2e12.4)')y_coords(i),conc(i)
 END DO

END SUBROUTINE p810


      double complex function qlLi2omx(x1,x2,ieps1,ieps2)
C     Calculate Li[2](1-(x1+ieps1)*(x2+ieps2)) for real x1,x2
C     Using +Li2(1-x1*x2)                           for x1*x2<1
C     and   -Li2(1-1/(x1*x2))-1/2*(ln(x1)+ln(x2))^2 for x1*x2>1
      implicit none
      include 'qlconstants.f'
      double precision x1,x2,arg,ieps1,ieps2,ieps
      double complex ln,lnarg,lnomarg,prod,denspence
      arg=x1*x2
      ieps=sign(one,x2*ieps1+x1*ieps2)
      if (arg .le. 1d0) then
         if (arg.eq. 1d0 .or. arg .eq.0d0) then
            prod=0d0
         else
            lnarg=ln(x1,ieps1)+ln(x2,ieps2)
            lnomarg=dcmplx(log(1d0-arg),0d0)
            prod=lnarg*lnomarg
         endif
         qlLi2omx=dcmplx(pisqo6)-denspence(dcmplx(arg),ieps)-prod
      elseif (arg .gt. 1d0) then
         arg=1d0/(x1*x2)
         lnarg=-ln(x1,ieps1)-ln(x2,ieps2)
         lnomarg=dcmplx(log(1d0-arg),0d0)
         qlLi2omx=-dcmplx(pisqo6)+denspence(dcmplx(arg),ieps)
     .   +lnarg*lnomarg-0.5d0*lnarg**2
      endif
      return
      end


program demo_centertext
   use :: M_draw
   !! set up drawing environment
   call prefsize(600,600)
   call vinit(' ') ! start graphics using device $M_draw_DEVICE
   call ortho2(-300.0,300.0,-300.0,300.0)
   call textsize(8.0,8.0)
   call linewidth(30)
   call color(D_BLACK)
   call clear()

   x1=-150
   y1=-150
   do j=1,4
      select case(j)
       case(1);  call  xcentertext();        x1=-150;  y1=-150;  r=100
       case(2);  call  ycentertext();        x1=+150;  y1=-150;  r= 30
       case(3);  call  centertext(.true.);   x1=-150;  y1=+150;  r=100
       case(4);  call  centertext(.false.);  x1=+150;  y1=+150;  r= 30
      end select
      !! draw radial lines
      call color(D_RED)
      do i=1,80
         call move2(x1,y1)
         call draw2(x1+150.0*cosd(i*12.0), y1+150.0*sind(i*12.0))
      enddo

      !! draw rotated text
      call color(D_GREEN)
      do i=1,30
         ang=i*12.0
         xx=x1+r*cosd(ang)
         yy=y1+r*sind(ang)
         call move2(xx,yy)
         call textang(ang)
         call color(D_WHITE)
         call drawstr('This is angled text')
         call color(D_RED)
      enddo
   enddo

   ipaws=getkey()

   call vexit()
contains
   elemental real function sind(angle_in_degrees)
      doubleprecision,parameter :: PI= 3.14159265358979323846264338327950288419716939937510d0
      doubleprecision,parameter :: degrees_to_radians = PI / 180.0D+00
      real,intent(in) :: angle_in_degrees
      sind=sin(angle_in_degrees*degrees_to_radians)
   end function sind
   elemental real function cosd(angle_in_degrees)
      doubleprecision,parameter :: PI= 3.14159265358979323846264338327950288419716939937510d0
      doubleprecision,parameter :: degrees_to_radians = PI / 180.0D+00
      real,intent(in) :: angle_in_degrees
      cosd=cos(angle_in_degrees*degrees_to_radians)
   end function cosd

end program demo_centertext


program assertion_examples
  !! Demonstrate the use of assertions as runtime checks on the satisfaction of
  !! of two kinds of constraints:
  !! 1. Preconditions: requirements for correct execution at the start of a procedure and
  !! 2. Postconditions: requirements for correct execution at the end of a procedure.
  implicit none

  print *, reciprocal(2.)

contains

  pure real function reciprocal(x) result(reciprocal_of_x)
    !! Erroneous calculation of the reciprocal of the function's argument
    use assert_m, only : assert
    real, intent(in) :: x

    call assert(assertion = x /= 0., description = "reciprocal: x /= 0", diagnostic_data = x) ! Precondition passes

    reciprocal_of_x = 0. ! incorrect value for the reciprocal of x

    block
      real, parameter :: tolerance = 1.E-06

      associate(error => x*reciprocal_of_x - 1.)

        call assert(abs(error) < tolerance, "reciprocal: abs(error) < tolerance", error) ! Postcondition fails

      end associate
    end block

  end function

end program


*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION   A, B, C, D, P, Q
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLADIV performs complex division in  real arithmetic
*>
*>                       a + i*b
*>            p + i*q = ---------
*>                       c + i*d
*>
*> The algorithm is due to Robert L. Smith and can be found
*> in D. Knuth, The art of Computer Programming, Vol.2, p.195
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION
*>          The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*>          P is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is DOUBLE PRECISION
*>          The scalars p and q in the above expression.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, D, P, Q
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION   E, F
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      IF( ABS( D ).LT.ABS( C ) ) THEN
         E = D / C
         F = C + D*E
         P = ( A+B*E ) / F
         Q = ( B-A*E ) / F
      ELSE
         E = C / D
         F = D + C*E
         P = ( B+A*E ) / F
         Q = ( -A+B*E ) / F
      END IF
*
      RETURN
*
*     End of DLADIV
*
      END
c $Id$