module mod_diff
    implicit none
    PRIVATE
    PUBLIC :: diff_upwind, diff_centered

contains
    function diff_upwind(x) result(diff)
        real, INTENT(IN) :: x(:)
        real :: diff(size(x))
        integer :: grid_size
        grid_size = size(x)
        diff(1) = (x(1) - x(grid_size))
        diff(2:grid_size) = x(2:grid_size) - x(1:grid_size-1)
    end function diff_upwind

    function diff_centered(x) result(diff) ! Don't fully understand this function?
        real, INTENT(IN) :: x(:)
        real :: diff(size(x))
        integer :: grid_size
        grid_size = size(x)
        diff(1) = (x(2) - x(grid_size)) / 2
        diff(grid_size) = (x(1) - x(grid_size-1)) / 2
        diff(2:grid_size-1) = x(3:grid_size) - x(1:grid_size-2)
    end function diff_centered
end module mod_diff


!This subroutine calculates the auto-correlation in
!the entries of a vector spaced by a index difference, delta
!a vector of auto-correlations is generated, beginning with the auto-correlation
!at delta_min and ending with the autocorrelation at delta_max

subroutine auto_correlation(v, N, delta, auto)
   use params, only: dp

   !Input variables
   real(dp) v(N) !vector
   integer N             !length of vector
   integer I
   integer, intent(in) :: delta         !spacing between elements
   !Subroutine variables
   real(dp) v_avg  !average value of v
   real(dp) var    !variance in v
   real(dp) vv(N - delta)  !vector of products of fluctions

   !Output variables
   real(dp) auto   !autocorrelation

   ! allocate(vv(N-delta))

   v_avg = SUM(v)/N
   var = SUM((v - v_avg)**2)/N

   do I = 1, N - delta
      vv(I) = (v(I) - v_avg)*(v(I + delta) - v_avg)

   ENDdo

   auto = SUM(vv)/((N - delta)*var)

   RETURN
ENDsubroutine auto_correlation


program cold_front
  ! This program calculates temperature due to cold front
  ! passage for different times using an external elemental
  ! function.
  ! Listing 3.25 in the book.
  implicit none
  real :: nhours(8) = [6., 12., 18., 24., 30., 36., 42., 48.]
  real :: temp1(8) = 12
  real :: temp2(8) = 24
  real :: c(8) = 20
  real :: dx(8) = 960

  print *, cold_front_temperature(temp1, temp2, c, dx, nhours)

contains

  real pure elemental function cold_front_temperature( &
    temp1, temp2, c, dx, dt) result(res)
    ! Returns the temperature after dt hours, given initial
    ! temperatures at origin (temp1) and destination (temp2),
    ! front speed (c), and distance between the two locations (dx).
    ! Works with input scalars or arrays.
    real, intent(in) :: temp1, temp2, c, dx, dt
    res = temp2 - c * (temp2 - temp1) / dx * dt
  end function cold_front_temperature

end program cold_front


*dk volume_tet
      subroutine volume_tet(x1,y1,z1,
     *                      x2,y2,z2,
     *          x3,y3,z3,
     *                      x4,y4,z4,
     *                      voltet)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A TET-ELEMENT DEFINDED BY
C            4 COORDINATE NODES. THE VOLUME IS FOUND BY TAKING THE
C            DOT(CROSS) PRODUCT OF THREE VECTORS.
C
C      see also volume_tet_voronoi below
C
C     ******************************************************************
C
C     DEFINE THE STRUCTURE OF A GENERIC TETRAHEDRON.
C
C
C                     i4 [itet(4,it)]
C                            $
C                           **  *
C                          * *     *
C                         *  *       *
C                        *   *         *
C                       *    *           * b34
C                  b41 *     *             *
C                     *      *               *
C                    *       *                 *
C                   *        * b24               *
C                  *         *                     *
C                 *          *    b31     _   _   _  $
C            i1  $_   _  -   * -   -   -          *   i3 [itet(3,it)]
C    [itet(1,it)] *          *                *
C                   *        *             *
C                 b21 *      *         *    b23
C                       *    *     *
C                         *  *  *
C                            $
C                     i2 [itet(2,it)]
C
C     ******************************************************************
C
C      INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x4,y4,z4) - THE COORDINATES OF THE TET.
C
C     OUTPUT ARGUMENTS -
C
C        voltet - THE VOLUME OF THE TET.
C
C     CHANGE HISTORY -
C
C        $Log: volume_tet.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.7   08 Feb 2006 14:35:38   dcg
CPVCS    "enforce lower case - add external statements for shift routines
CPVCS    these changes needed to compile with absoft pro fortran"
CPVCS
CPVCS       Rev 1.6   Tue Oct 19 13:16:34 1999   jtg
CPVCS    added a few comments
CPVCS
CPVCS       Rev 1.5   Fri Jan 22 16:59:36 1999   dcg
CPVCS    initialize imedian to 0
CPVCS
CPVCS       Rev 1.4   Fri Aug 28 14:25:34 1998   dcg
CPVCS    remove single precision constants
CPVCS
CPVCS       Rev 1.3   Mon Apr 14 17:05:42 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.2   Thu Oct 10 08:44:22 1996   het
CPVCS    Calculate Voronoi volumes.
CPVCS
CPVCS       Rev 1.1   08/15/95 18:29:34   het
CPVCS    Modify some comment lines
C
C#######################################################################
C
C
      implicit none
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,voltet,dx,dy,dz
C
C#######################################################################
C
C
C     ..................................................................
C     TAKE THE CROSS PRODUCT OF THE 23 AND 43 VECTORS TO THE AN AREA
C        VECTOR.
C
      dx= ((y2-y3)*(z4-z3)-(y4-y3)*(z2-z3))
      dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
      dz= ((x2-x3)*(y4-y3)-(x4-x3)*(y2-y3))
C
C     ..................................................................
C     THEN DOT THIS AREA VECTOR WITH THE 31 VECTOR TO GET THE TET VOLUME
C
      voltet=-((x3-x1)*dx+(y3-y1)*dy+(z3-z1)*dz)/6.0d+00
C
      return
      end
C
C#######################################################################
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
C=======================================================================
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
C#######################################################################
C
*dk volume_tet_voronoi
      subroutine volume_tet_voronoi(xl1,yl1,zl1,
     *                              xl2,yl2,zl2,
     *                              xl3,yl3,zl3,
     *                              xl4,yl4,zl4,
     *                              voltet_vor, voledge_vor)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A TET-ELEMENT DEFINDED BY
C            4 COORDINATE NODES. THE VOLUME IS FOUND BY TAKING THE
C            DOT(CROSS) PRODUCT OF THREE VECTORS.
C
C         it also calculates the voronoi info voltet_vor, voledge_vor
C
C
C     ******************************************************************
C
C     DEFINE THE STRUCTURE OF A GENERIC TETRAHEDRON.
C
C
C                     i4 [itet(4,it)]
C                            $
C                           **  *
C                          * *     *
C                         *  *       *
C                        *   *         *
C                       *    *           * b34
C                  b41 *     *             *
C                     *      *               *
C                    *       *                 *
C                   *        * b24               *
C                  *         *                     *
C                 *          *    b31     _   _   _  $
C            i1  $_   _  -   * -   -   -          *   i3 [itet(3,it)]
C    [itet(1,it)] *          *                *
C                   *        *             *
C                 b21 *      *         *    b23
C                       *    *     *
C                         *  *  *
C                            $
C                     i2 [itet(2,it)]
C
C     ******************************************************************
C
C      INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x4,y4,z4) - THE COORDINATES OF THE TET.
C
C     OUTPUT ARGUMENTS -
C
C        voltet - THE VOLUME OF THE TET.
C
C     CHANGE HISTORY -
C
C        $Log: volume_tet.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
C
C#######################################################################
C
C
      implicit none
      real*8 alargenumber
      parameter (alargenumber=1.0d+20)
      real*8 a,b,c,d,e,f,crosx,crosy,crosz,xl1,yl1,zl1,
     *  xl2,yl2,zl2,xl3,yl3,zl3,xl4,yl4,zl4,dx,dy,dz,voltet,xa,ya,za,
     *  xfac,xb,yb,zb,xd,yd,zd,xn1,yn1,zn1,xn,yn,zn,rn,
     *  dotb3,dot3,rb3,ql,xl,yl,zl,ds11,ds21,ds31,xv1,yv1,zv1,
     *  ds12,ds22,ds32,xv2,yv2,zv2,ds13,ds23,ds33,xv3,yv3,zv3,ds14,ds24,
     *  xv4,yv4,zv4,x1,y1,z1,x2,y2,z2,x3,y3,z3,xm,ym,zm,
     *  ax1,ay1,az1,ax2,ay2,az2,ax3,ay3,az3,ax4,ay4,az4,voltot,x234,
     *  ds34, y234,z234,x143,y143,z143,x124,y124,z124,x132,y132,z132
      real*8 xtestmax,xtest,xc,yc,zc,q,dvor,qvor2,xvor,yvor,zvor,
     *  distsqa,distsqb,distsqc,distsqd,x4,y4,z4,x12,y12,z12,
     *  x13,y13,z13,x14,y14,z14,x23,y23,z23,xaa,y24,z24,x34,y34,z34,
     *  ax11,ay11,az11,vol11,vol13,ax12,ay12,az12,vol12,vol14,xdot1,
     *  ax21,ay21,az21,vol21,xdot2
      real*8 xdot6,ax6,ay6,az6,az62,ay62,ax62,vol63,vol61,ax61,ay61,
     *  az61,vol51,vol53,ax52,ay52,az52,vol52,vol54,xdot5,xdot4,
     *  vol44,ax5,ax51,ay51,az51,ax42,ay42,az42,vol41,vol43,
     *  vol23,ax22,ay22,az22,vol22,vol24,ax31,ay31,az31,vol31,
     *  vol33,ax32,ay32,az32,vol32,vol34,xdot3,ax41,ay41,az41,
     *  vol42,ay5,az5,vol62,vol64
      integer it,i1,i2,i3,i4,idebug,imedian
      real*8 vol1a,vol1b,vol2a,vol2b,vol3a,vol3b,vol4a,vol4b,vol5a,vol5b
     * ,vol6a,vol6b,voltet_vor1,volvortet1,volvortet2,volvortet3,
     *  volvortet4,voltot_vor1,voltet_vor2,voltot_vor2,voltetvor2
C
      real*8 voltet_vor(4), voledge_vor(6)
      data imedian /0/
C
      crosx(a,b,c,d,e,f)=b*f-c*e
      crosy(a,b,c,d,e,f)=c*d-a*f
      crosz(a,b,c,d,e,f)=a*e-b*d
C
      data idebug / 0 /
C
C
C#######################################################################
C
C
C     ..................................................................
C     TAKE THE CROSS PRODUCT OF THE 23 AND 43 VECTORS TO THE AN AREA
C        VECTOR.
C
      dx= ((yl2-yl3)*(zl4-zl3)-(yl4-yl3)*(zl2-zl3))
      dy=-((xl2-xl3)*(zl4-zl3)-(xl4-xl3)*(zl2-zl3))
      dz= ((xl2-xl3)*(yl4-yl3)-(xl4-xl3)*(yl2-yl3))
C
C     ..................................................................
C     THEN DOT THIS AREA VECTOR WITH THE 31 VECTOR TO GET THE TET VOLUME
C
      voltet=-((xl3-xl1)*dx+(yl3-yl1)*dy+(zl3-zl1)*dz)/6.0d+00
C
         xa=xl2
         ya=yl2
         za=zl2
         xfac=1.0d+00
         xb=xfac*(xl3-xa)
         yb=xfac*(yl3-ya)
         zb=xfac*(zl3-za)
         xd=xfac*(xl4-xa)
         yd=xfac*(yl4-ya)
         zd=xfac*(zl4-za)
         xn1=crosx(xb,yb,zb,xd,yd,zd)
         yn1=crosy(xb,yb,zb,xd,yd,zd)
         zn1=crosz(xb,yb,zb,xd,yd,zd)
         xn=crosx(xb,yb,zb,xn1,yn1,zn1)
         yn=crosy(xb,yb,zb,xn1,yn1,zn1)
         zn=crosz(xb,yb,zb,xn1,yn1,zn1)
         rn=1.0/sqrt(xn*xn+yn*yn+zn*zn)
         xn=xn*rn
         yn=yn*rn
         zn=zn*rn
         dotb3=xb*xd+yb*yd+zb*zd
         dot3=dotb3/(xd*xd+yd*yd+zd*zd)
         rb3=1.0/(xb*xb+yb*yb+zb*zb)
         ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3)
         xl=0.5*(ql*(xd-dotb3*rb3*xb)+xb)
         yl=0.5*(ql*(yd-dotb3*rb3*yb)+yb)
         zl=0.5*(ql*(zd-dotb3*rb3*zb)+zb)
         ds11=sqrt((xl)**2+(yl)**2+(zl)**2)
         ds21=sqrt((xl-xb)**2+(yl-yb)**2+(zl-zb)**2)
         ds31=sqrt((xl-xd)**2+(yl-yd)**2+(zl-zd)**2)
         xv1=xl+xa
         yv1=yl+ya
         zv1=zl+za
         xa=xl1
         ya=yl1
         za=zl1
         xfac=1.0d+00
         xb=xfac*(xl4-xa)
         yb=xfac*(yl4-ya)
         zb=xfac*(zl4-za)
         xd=xfac*(xl3-xa)
         yd=xfac*(yl3-ya)
         zd=xfac*(zl3-za)
         xn1=crosx(xb,yb,zb,xd,yd,zd)
         yn1=crosy(xb,yb,zb,xd,yd,zd)
         zn1=crosz(xb,yb,zb,xd,yd,zd)
         xn=crosx(xb,yb,zb,xn1,yn1,zn1)
         yn=crosy(xb,yb,zb,xn1,yn1,zn1)
         zn=crosz(xb,yb,zb,xn1,yn1,zn1)
         rn=1.0/sqrt(xn*xn+yn*yn+zn*zn)
         xn=xn*rn
         yn=yn*rn
         zn=zn*rn
         dotb3=xb*xd+yb*yd+zb*zd
         dot3=dotb3/(xd*xd+yd*yd+zd*zd)
         rb3=1.0/(xb*xb+yb*yb+zb*zb)
         ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3)
         xl=0.5*(ql*(xd-dotb3*rb3*xb)+xb)
         yl=0.5*(ql*(yd-dotb3*rb3*yb)+yb)
         zl=0.5*(ql*(zd-dotb3*rb3*zb)+zb)
         ds12=sqrt((xl)**2+(yl)**2+(zl)**2)
         ds22=sqrt((xl-xb)**2+(yl-yb)**2+(zl-zb)**2)
         ds32=sqrt((xl-xd)**2+(yl-yd)**2+(zl-zd)**2)
         xv2=xl+xa
         yv2=yl+ya
         zv2=zl+za
         xa=xl1
         ya=yl1
         za=zl1
         xfac=1.0d+00
         xb=xfac*(xl2-xa)
         yb=xfac*(yl2-ya)
         zb=xfac*(zl2-za)
         xd=xfac*(xl4-xa)
         yd=xfac*(yl4-ya)
         zd=xfac*(zl4-za)
         xn1=crosx(xb,yb,zb,xd,yd,zd)
         yn1=crosy(xb,yb,zb,xd,yd,zd)
         zn1=crosz(xb,yb,zb,xd,yd,zd)
         xn=crosx(xb,yb,zb,xn1,yn1,zn1)
         yn=crosy(xb,yb,zb,xn1,yn1,zn1)
         zn=crosz(xb,yb,zb,xn1,yn1,zn1)
         rn=1.0/sqrt(xn*xn+yn*yn+zn*zn)
         xn=xn*rn
         yn=yn*rn
         zn=zn*rn
         dotb3=xb*xd+yb*yd+zb*zd
         dot3=dotb3/(xd*xd+yd*yd+zd*zd)
         rb3=1.0/(xb*xb+yb*yb+zb*zb)
         ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3)
         xl=0.5*(ql*(xd-dotb3*rb3*xb)+xb)
         yl=0.5*(ql*(yd-dotb3*rb3*yb)+yb)
         zl=0.5*(ql*(zd-dotb3*rb3*zb)+zb)
         ds13=sqrt((xl)**2+(yl)**2+(zl)**2)
         ds23=sqrt((xl-xb)**2+(yl-yb)**2+(zl-zb)**2)
         ds33=sqrt((xl-xd)**2+(yl-yd)**2+(zl-zd)**2)
         xv3=xl+xa
         yv3=yl+ya
         zv3=zl+za
         xa=xl1
         ya=yl1
         za=zl1
         xfac=1.0d+00
         xb=xfac*(xl3-xa)
         yb=xfac*(yl3-ya)
         zb=xfac*(zl3-za)
         xd=xfac*(xl2-xa)
         yd=xfac*(yl2-ya)
         zd=xfac*(zl2-za)
         xn1=crosx(xb,yb,zb,xd,yd,zd)
         yn1=crosy(xb,yb,zb,xd,yd,zd)
         zn1=crosz(xb,yb,zb,xd,yd,zd)
         xn=crosx(xb,yb,zb,xn1,yn1,zn1)
         yn=crosy(xb,yb,zb,xn1,yn1,zn1)
         zn=crosz(xb,yb,zb,xn1,yn1,zn1)
         rn=1.0/sqrt(xn*xn+yn*yn+zn*zn)
         xn=xn*rn
         yn=yn*rn
         zn=zn*rn
         dotb3=xb*xd+yb*yd+zb*zd
         dot3=dotb3/(xd*xd+yd*yd+zd*zd)
         rb3=1.0/(xb*xb+yb*yb+zb*zb)
         ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3)
         xl=0.5*(ql*(xd-dotb3*rb3*xb)+xb)
         yl=0.5*(ql*(yd-dotb3*rb3*yb)+yb)
         zl=0.5*(ql*(zd-dotb3*rb3*zb)+zb)
         ds14=sqrt((xl)**2+(yl)**2+(zl)**2)
         ds24=sqrt((xl-xb)**2+(yl-yb)**2+(zl-zb)**2)
         ds34=sqrt((xl-xd)**2+(yl-yd)**2+(zl-zd)**2)
         xv4=xl+xa
         yv4=yl+ya
         zv4=zl+za
         x1=xl1
         y1=yl1
         z1=zl1
         x2=xl2
         y2=yl2
         z2=zl2
         x3=xl3
         y3=yl3
         z3=zl3
         xm=(xl1+xl2+xl3+xl4)/4.0
         ym=(yl1+yl2+yl3+yl4)/4.0
         zm=(zl1+zl2+zl3+zl4)/4.0
         xl1=xl1
         yl1=yl1
         zl1=zl1
         xl2=xl2
         yl2=yl2
         zl2=zl2
         xl3=xl3
         yl3=yl3
         zl3=zl3
         xl4=xl4
         yl4=yl4
         zl4=zl4
         ax1=  (yl3-yl2)*(zl4-zl2)-(zl3-zl2)*(yl4-yl2)
         ay1=-((xl3-xl2)*(zl4-zl2)-(zl3-zl2)*(xl4-xl2))
         az1=  (xl3-xl2)*(yl4-yl2)-(yl3-yl2)*(xl4-xl2)
         ax2=  (yl4-yl1)*(zl3-zl1)-(zl4-zl1)*(yl3-yl1)
         ay2=-((xl4-xl1)*(zl3-zl1)-(zl4-zl1)*(xl3-xl1))
         az2=  (xl4-xl1)*(yl3-yl1)-(yl4-yl1)*(xl3-xl1)
         ax3=  (yl2-yl1)*(zl4-zl1)-(zl2-zl1)*(yl4-yl1)
         ay3=-((xl2-xl1)*(zl4-zl1)-(zl2-zl1)*(xl4-xl1))
         az3=  (xl2-xl1)*(yl4-yl1)-(yl2-yl1)*(xl4-xl1)
         ax4=  (yl3-yl1)*(zl2-zl1)-(zl3-zl1)*(yl2-yl1)
         ay4=-((xl3-xl1)*(zl2-zl1)-(zl3-zl1)*(xl2-xl1))
         az4=  (xl3-xl1)*(yl2-yl1)-(yl3-yl1)*(xl2-xl1)
         voltet=-((xl4-xl1)*ax4+(yl4-yl1)*ay4+(zl4-zl1)*az4)
         voltot=voltot+voltet
         x234=(xl2+xl3+xl4)/3.0
         y234=(yl2+yl3+yl4)/3.0
         z234=(zl2+zl3+zl4)/3.0
         x143=(xl1+xl4+xl3)/3.0
         y143=(yl1+yl4+yl3)/3.0
         z143=(zl1+zl4+zl3)/3.0
         x124=(xl1+xl2+xl4)/3.0
         y124=(yl1+yl2+yl4)/3.0
         z124=(zl1+zl2+zl4)/3.0
         x132=(xl1+xl3+xl2)/3.0
         y132=(yl1+yl3+yl2)/3.0
         z132=(zl1+zl3+zl2)/3.0
         xtestmax=alargenumber
         xtest=xtestmax
         xa=xl2
         ya=yl2
         za=zl2
         xb=xl3-xa
         yb=yl3-ya
         zb=zl3-za
         xc=xl4-xa
         yc=yl4-ya
         zc=zl4-za
         xd=xl1-xa
         yd=yl1-ya
         zd=zl1-za
         xn=  yb*zc-yc*zb
         yn=-(xb*zc-xc*zb)
         zn=  xb*yc-xc*yb
         x2=  yn*zb-yb*zn
         y2=-(xn*zb-xb*zn)
         z2=  xn*yb-xb*yn
         q=-0.5*(xc*xb+yc*yb+zc*zb-xc*xc-yc*yc-zc*zc)/
     *          (x2*xc+y2*yc+z2*zc+1.0e-30)
         xl=q*x2+0.5*xb
         yl=q*y2+0.5*yb
         zl=q*z2+0.5*zb
         dvor=-0.5*(xd*xd+yd*yd+zd*zd)
         qvor2=-(xd*xl+yd*yl+zd*zl+dvor)/(xd*xn+yd*yn+zd*zn+1.0d-30)
         xvor=qvor2*xn+xl+xa
         yvor=qvor2*yn+yl+ya
         zvor=qvor2*zn+zl+za
         distsqa=(xvor-xl2)**2+(yvor-yl2)**2+(zvor-zl2)**2
         distsqb=(xvor-xl3)**2+(yvor-yl3)**2+(zvor-zl3)**2
         distsqc=(xvor-xl4)**2+(yvor-yl4)**2+(zvor-zl4)**2
         distsqd=(xvor-xl1)**2+(yvor-yl1)**2+(zvor-zl1)**2
         x1=xl1
         y1=yl1
         z1=zl1
         x2=xl2
         y2=yl2
         z2=zl2
         x3=xl3
         y3=yl3
         z3=zl3
         x4=xl4
         y4=yl4
         z4=zl4
         x12=0.5*(xl1+xl2)
         y12=0.5*(yl1+yl2)
         z12=0.5*(zl1+zl2)
         x13=0.5*(xl1+xl3)
         y13=0.5*(yl1+yl3)
         z13=0.5*(zl1+zl3)
         x14=0.5*(xl1+xl4)
         y14=0.5*(yl1+yl4)
         z14=0.5*(zl1+zl4)
         x23=0.5*(xl2+xl3)
         y23=0.5*(yl2+yl3)
         z23=0.5*(zl2+zl3)
c***         x24=0.5*(xl2+xl4)
         xaa=0.5*(xl2+xl4)
         y24=0.5*(yl2+yl4)
         z24=0.5*(zl2+zl4)
         x34=0.5*(xl3+xl4)
         y34=0.5*(yl3+yl4)
         z34=0.5*(zl3+zl4)
         if(imedian.eq.1) then
            xv1=(xl2+xl3+xl4)/3.0
            yv1=(yl2+yl3+yl4)/3.0
            zv1=(zl2+zl3+zl4)/3.0
            xv2=(xl1+xl3+xl4)/3.0
            yv2=(yl1+yl3+yl4)/3.0
            zv2=(zl1+zl3+zl4)/3.0
            xv3=(xl1+xl2+xl4)/3.0
            yv3=(yl1+yl2+yl4)/3.0
            zv3=(zl1+zl2+zl4)/3.0
            xv4=(xl1+xl2+xl3)/3.0
            yv4=(yl1+yl2+yl3)/3.0
            zv4=(zl1+zl2+zl3)/3.0
            xvor=xm
            yvor=ym
            zvor=zm
         endif
         ax11=  (yv4-y12)*(zvor-z12)-(yvor-y12)*(zv4-z12)
         ay11=-((xv4-x12)*(zvor-z12)-(xvor-x12)*(zv4-z12))
         az11=  (xv4-x12)*(yvor-y12)-(xvor-x12)*(yv4-y12)
         vol11=-((x1-x12)*ax11+(y1-y12)*ay11+(z1-z12)*az11)
         vol13= ((x2-x12)*ax11+(y2-y12)*ay11+(z2-z12)*az11)
         ax12=-((yv3-y12)*(zvor-z12)-(yvor-y12)*(zv3-z12))
         ay12=+((xv3-x12)*(zvor-z12)-(xvor-x12)*(zv3-z12))
         az12=-((xv3-x12)*(yvor-y12)-(xvor-x12)*(yv3-y12))
         vol12=-((x1-x12)*ax12+(y1-y12)*ay12+(z1-z12)*az12)
         vol14= ((x2-x12)*ax12+(y2-y12)*ay12+(z2-z12)*az12)
         ax1=ax11+ax12
         ay1=ay11+ay12
         az1=az11+az12
         xdot1=(x2-x1)*ax1+(y2-y1)*ay1+(z2-z1)*az1
         ax21=  (yv2-y13)*(zvor-z13)-(yvor-y13)*(zv2-z13)
         ay21=-((xv2-x13)*(zvor-z13)-(xvor-x13)*(zv2-z13))
         az21=  (xv2-x13)*(yvor-y13)-(xvor-x13)*(yv2-y13)
         vol21=-((x1-x13)*ax21+(y1-y13)*ay21+(z1-z13)*az21)
         vol23= ((x3-x13)*ax21+(y3-y13)*ay21+(z3-z13)*az21)
         ax22=-((yv4-y13)*(zvor-z13)-(yvor-y13)*(zv4-z13))
         ay22=+((xv4-x13)*(zvor-z13)-(xvor-x13)*(zv4-z13))
         az22=-((xv4-x13)*(yvor-y13)-(xvor-x13)*(yv4-y13))
         vol22=-((x1-x13)*ax22+(y1-y13)*ay22+(z1-z13)*az22)
         vol24= ((x3-x13)*ax22+(y3-y13)*ay22+(z3-z13)*az22)
         ax2=ax21+ax22
         ay2=ay21+ay22
         az2=az21+az22
         xdot2=(x3-x1)*ax2+(y3-y1)*ay2+(z3-z1)*az2
         ax31=  (yv3-y14)*(zvor-z14)-(yvor-y14)*(zv3-z14)
         ay31=-((xv3-x14)*(zvor-z14)-(xvor-x14)*(zv3-z14))
         az31=  (xv3-x14)*(yvor-y14)-(xvor-x14)*(yv3-y14)
         vol31=-((x1-x14)*ax31+(y1-y14)*ay31+(z1-z14)*az31)
         vol33= ((x4-x14)*ax31+(y4-y14)*ay31+(z4-z14)*az31)
         ax32=-((yv2-y14)*(zvor-z14)-(yvor-y14)*(zv2-z14))
         ay32=+((xv2-x14)*(zvor-z14)-(xvor-x14)*(zv2-z14))
         az32=-((xv2-x14)*(yvor-y14)-(xvor-x14)*(yv2-y14))
         vol32=-((x1-x14)*ax32+(y1-y14)*ay32+(z1-z14)*az32)
         vol34= ((x4-x14)*ax32+(y4-y14)*ay32+(z4-z14)*az32)
         ax3=ax31+ax32
         ay3=ay31+ay32
         az3=az31+az32
         xdot3=(x4-x1)*ax3+(y4-y1)*ay3+(z4-z1)*az3
         ax41=  (yv4-y23)*(zvor-z23)-(yvor-y23)*(zv4-z23)
         ay41=-((xv4-x23)*(zvor-z23)-(xvor-x23)*(zv4-z23))
         az41=  (xv4-x23)*(yvor-y23)-(xvor-x23)*(yv4-y23)
         vol41=-((x2-x23)*ax41+(y2-y23)*ay41+(z2-z23)*az41)
         vol43= ((x3-x23)*ax41+(y3-y23)*ay41+(z3-z23)*az41)
         ax42=-((yv1-y23)*(zvor-z23)-(yvor-y23)*(zv1-z23))
         ay42=+((xv1-x23)*(zvor-z23)-(xvor-x23)*(zv1-z23))
         az42=-((xv1-x23)*(yvor-y23)-(xvor-x23)*(yv1-y23))
         vol42=-((x2-x23)*ax42+(y2-y23)*ay42+(z2-z23)*az42)
         vol44= ((x3-x23)*ax42+(y3-y23)*ay42+(z3-z23)*az42)
         ax4=ax41+ax42
         ay4=ay41+ay42
         az4=az41+az42
         xdot4=(x3-x2)*ax5+(y3-y2)*ay4+(z3-z2)*az4
         ax51=  (yv1-y24)*(zvor-z24)-(yvor-y24)*(zv1-z24)
         ay51=-((xv1-xaa)*(zvor-z24)-(xvor-xaa)*(zv1-z24))
         az51=  (xv1-xaa)*(yvor-y24)-(xvor-xaa)*(yv1-y24)
         vol51=-((x2-xaa)*ax51+(y2-y24)*ay51+(z2-z24)*az51)
         vol53= ((x4-xaa)*ax51+(y4-y24)*ay51+(z4-z24)*az51)
         ax52=-((yv3-y24)*(zvor-z24)-(yvor-y24)*(zv3-z24))
         ay52=+((xv3-xaa)*(zvor-z24)-(xvor-xaa)*(zv3-z24))
         az52=-((xv3-xaa)*(yvor-y24)-(xvor-xaa)*(yv3-y24))
         vol52=-((x2-xaa)*ax52+(y2-y24)*ay52+(z2-z24)*az52)
         vol54= ((x4-xaa)*ax52+(y4-y24)*ay52+(z4-z24)*az52)
         ax5=ax51+ax52
         ay5=ay51+ay52
         az5=az51+az52
         xdot5=(x4-x2)*ax5+(y4-y2)*ay5+(z4-z2)*az5
         ax61=  (yv2-y34)*(zvor-z34)-(yvor-y34)*(zv2-z34)
         ay61=-((xv2-x34)*(zvor-z34)-(xvor-x34)*(zv2-z34))
         az61=  (xv2-x34)*(yvor-y34)-(xvor-x34)*(yv2-y34)
         vol61=-((x3-x34)*ax61+(y3-y34)*ay61+(z3-z34)*az61)
         vol63= ((x4-x34)*ax61+(y4-y34)*ay61+(z4-z34)*az61)
         ax62=-((yv1-y34)*(zvor-z34)-(yvor-y34)*(zv1-z34))
         ay62=+((xv1-x34)*(zvor-z34)-(xvor-x34)*(zv1-z34))
         az62=-((xv1-x34)*(yvor-y34)-(xvor-x34)*(yv1-y34))
         vol62=-((x3-x34)*ax62+(y3-y34)*ay62+(z3-z34)*az62)
         vol64= ((x4-x34)*ax62+(y4-y34)*ay62+(z4-z34)*az62)
         ax6=ax61+ax62
         ay6=ay61+ay62
         az6=az61+az62
         xdot6=(x4-x3)*ax6+(y4-y3)*ay6+(z4-z3)*az6
         vol1a=vol11+vol12
         vol1b=vol13+vol14
         vol2a=vol21+vol22
         vol2b=vol23+vol24
         vol3a=vol31+vol32
         vol3b=vol33+vol34
         vol4a=vol41+vol42
         vol4b=vol43+vol44
         vol5a=vol51+vol52
         vol5b=vol53+vol54
         vol6a=vol61+vol62
         vol6b=vol63+vol64
         voltet_vor1=abs(vol1a)+abs(vol1b)+
     *           abs(vol2a)+abs(vol2b)+
     *           abs(vol3a)+abs(vol3b)+
     *           abs(vol4a)+abs(vol4b)+
     *           abs(vol5a)+abs(vol5b)+
     *           abs(vol6a)+abs(vol6b)
         voltet_vor1=vol1a+vol1b+
     *           vol2a+vol2b+
     *           vol3a+vol3b+
     *           vol4a+vol4b+
     *           vol5a+vol5b+
     *           vol6a+vol6b
C
C        ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C        CALCULATE THE VOLUME OF THE TET USING THE VORONOI POINT AS THE
C           PIVOT POINT.
C
         x1=xvor
         y1=yvor
         z1=zvor
         x2=xl2
         y2=yl2
         z2=zl2
         x3=xl3
         y3=yl3
         z3=zl3
         x4=xl4
         y4=yl4
         z4=zl4
         dx=  (y2-y3)*(z4-z3)-(y4-y3)*(z2-z3)
         dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
         dz=  (x2-x3)*(y4-y3)-(x4-x3)*(y2-y3)
         volvortet1=-((x3-x1)*dx+(y3-y1)*dy+(z3-y1)*dz)
         x2=xl1
         y2=yl1
         z2=zl1
         x3=xl4
         y3=yl4
         z3=zl4
         x4=xl3
         y4=yl3
         z4=zl3
         dx=  (y2-y3)*(z4-z3)-(y4-y3)*(z2-z3)
         dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
         dz=  (x2-x3)*(y4-y3)-(x4-x3)*(y2-y3)
         volvortet2=-((x3-x1)*dx+(y3-y1)*dy+(z3-y1)*dz)
         x2=xl1
         y2=yl1
         z2=zl1
         x3=xl2
         y3=yl2
         z3=zl2
         x4=xl4
         y4=yl4
         z4=zl4
         dx=  (y2-y3)*(z4-z3)-(y4-y3)*(z2-z3)
         dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
         dz=  (x2-x3)*(y4-y3)-(x4-x3)*(y2-y3)
         volvortet3=-((x3-x1)*dx+(y3-y1)*dy+(z3-y1)*dz)
         x2=xl1
         y2=yl1
         z2=zl1
         x3=xl3
         y3=yl3
         z3=zl3
         x4=xl2
         y4=yl2
         z4=zl2
         dx=  (y2-y3)*(z4-z3)-(y4-y3)*(z2-z3)
         dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
         dz=  (x2-x3)*(y4-y3)-(x4-x3)*(y2-y3)
         volvortet4=-((x3-x1)*dx+(y3-y1)*dy+(z3-y1)*dz)
C
         voltot_vor1=voltot_vor1+voltet_vor1
         voltet_vor2=volvortet1+volvortet2+volvortet3+volvortet4
         voltot_vor2=voltot_vor2+voltet_vor2
C
         voledge_vor(1)=vol1a/6.0d+00
         voledge_vor(2)=vol2a/6.0d+00
         voledge_vor(3)=vol3a/6.0d+00
         voledge_vor(4)=vol4a/6.0d+00
         voledge_vor(5)=vol5a/6.0d+00
         voledge_vor(6)=vol6a/6.0d+00
C
         voltet_vor(1)=(vol1a+vol2a+vol3a)/6.0d+00
         voltet_vor(2)=(vol1b+vol4a+vol5a)/6.0d+00
         voltet_vor(3)=(vol2b+vol4b+vol6a)/6.0d+00
         voltet_vor(4)=(vol3b+vol5b+vol6b)/6.0d+00
C
         if(idebug.ge.2) then
            print *,voltet,voltet_vor1,voltetvor2
            print *,it,i1,i2,i3,i4,voltet_vor1,voltot_vor1
            print *,'   ',vol1a,vol1b,vol11,vol12,vol13,vol14
            print *,'   ',vol2a,vol2b,vol21,vol22,vol23,vol24
            print *,'   ',vol3a,vol3b,vol31,vol32,vol33,vol34
            print *,'   ',vol4a,vol4b,vol41,vol42,vol43,vol44
            print *,'   ',vol5a,vol5b,vol51,vol52,vol53,vol54
            print *,'   ',vol6a,vol6b,vol61,vol62,vol63,vol64
         endif
C
      return
      end


      subroutine resid_eqrpsi(n_a1,n_alpha,n_beta,n_rPHI,n_rPI,n_rpsi,np
     &1_a1,np1_alpha,np1_beta,np1_rPHI,np1_rPI,np1_rpsi,x,Nx,ht,myzero,z
     &epsdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 myzero
      real*8 zepsdis
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_rPHI(Nx)
      real*8 n_rPI(Nx)
      real*8 n_rpsi(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_rPHI(Nx)
      real*8 np1_rPI(Nx)
      real*8 np1_rpsi(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_rpsi(i) - 0.1333333333333333D1 * np1_rpsi(i + 1) + 0.3333
     #333333333333D0 * np1_rpsi(i + 2)
      res = res + qb**2
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = (-0.1D1 * n_rpsi(i) + np1_rpsi(i)) / ht - 0.5000000000000000D
     #0 * np1_alpha(i) / np1_a1(i) * np1_rPI(i) - 0.5000000000000000D0 *
     # np1_beta(i) * np1_rPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n
     #_a1(i) * n_rPI(i) - 0.5000000000000000D0 * n_beta(i) * n_rPHI(i) +
     # 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * np1_rpsi(i) + np1
     #_rpsi(i + 2) - 0.4D1 * np1_rpsi(i + 1) - 0.4D1 * np1_rpsi(i - 1))
     #+ 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * n_rpsi(i) + n_rp
     #si(i + 2) - 0.4D1 * n_rpsi(i + 1) - 0.4D1 * n_rpsi(i - 1))
      res = res + qb**2
      end do
      endif
      do i=3, Nx-2, 1
      qb = (-0.1D1 * n_rpsi(i) + np1_rpsi(i)) / ht - 0.5000000000000000D
     #0 * np1_alpha(i) / np1_a1(i) * np1_rPI(i) - 0.5000000000000000D0 *
     # np1_beta(i) * np1_rPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n
     #_a1(i) * n_rPI(i) - 0.5000000000000000D0 * n_beta(i) * n_rPHI(i) +
     # 0.3125000000000000D-1 * zepsdis / ht * (0.6D1 * np1_rpsi(i) + np1
     #_rpsi(i + 2) + np1_rpsi(i - 2) - 0.4D1 * np1_rpsi(i + 1) - 0.4D1 *
     # np1_rpsi(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.6D1
     #* n_rpsi(i) + n_rpsi(i + 2) + n_rpsi(i - 2) - 0.4D1 * n_rpsi(i + 1
     #) - 0.4D1 * n_rpsi(i - 1))
      res = res + qb**2
      end do
      do i=Nx-1, Nx-1, 1
      qb = (-0.1D1 * n_rpsi(i) + np1_rpsi(i)) / ht - 0.5000000000000000D
     #0 * np1_alpha(i) / np1_a1(i) * np1_rPI(i) - 0.5000000000000000D0 *
     # np1_beta(i) * np1_rPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n
     #_a1(i) * n_rPI(i) - 0.5000000000000000D0 * n_beta(i) * n_rPHI(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = (-0.1D1 * n_rpsi(i) + np1_rpsi(i)) / ht - 0.1D1 * myzero * x(
     #i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


      subroutine trig (x, y, z, ct, st, cp, sp)
      implicit double precision (a-h, o-z)
c     returns cos(theta), sin(theta), cos(phi), sin(ph) for (x,y,z)
c     convention - if x=y=0 and z>0, phi=0, cp=1, sp=0
c                  if x=y=0 and z<0, phi=180, cp=-1,sp=0
c                - if x=y=z=0, theta=0, ct=1, st=0
      parameter (eps = 1.0e-6)
      r = sqrt (x**2 + y**2 + z**2)
      rxy = sqrt (x**2 + y**2)
      if (r .lt. eps)  then
         ct = 1
         st = 0
      else
         ct = z/r
         st = rxy/r
      endif
      if (rxy .lt. eps)  then
         cp = 1
         if (ct .lt. 0) cp = -1
         sp = 0
      else
         cp = x / rxy
         sp = y / rxy
      endif
      return
      end

      subroutine arg(c,fi,th)
      implicit double precision (a-h, o-z)
      complex*16  c
      parameter (eps = 1.0e-6)
      x = dble(c)
      y = dimag(c)
      if (abs(x) .lt. eps) x = 0
      if (abs(y) .lt. eps) y = 0
      if (abs(x) .lt. eps  .and.  abs(y) .lt. eps) then
        th = fi
      else
        th = atan2(y,x)
      endif
      return
      end


!  *******************************************************************
!  *                                                                 *
!  *                     Real*8 Function dlavx1                      *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.62
!  Written by Gordon A. Fenton, 1989
!  Latest Update: Jul 10, 2002
!
!  PURPOSE  returns the covariance between two points along a 1-D Markov
!           process.
!
!  Returns the covariance between two points, separated by distance T, in
!  a 1-D Markov process. The covariance function is given by
!
!       B(T) = var * exp( -2|T|/dthx )
!
!  where var is the point variance and dthx is the scale of fluctuation.
!  var and dthx are brought into this routine through the common
!  block DPARAM.
!
!  If var < 0, then this function returns the variance of a local average
!  of the process, |var|*V(T), averaged over the distance T, where V(T) is
!  the variance function (see E.H. Vanmarcke, "Random Fields: Analysis and
!  Synthesis", MIT Press, 1984, Chapter 5).
!                                  T
!       V(T) = (2/T) * INT  (1-s/T)*r(s) ds
!                                  0
!  where r(s) is the correlation function: r(s) = B(s)/var. The integration
!  gives us
!
!       V(T) = (2/a*a) * [ a + exp(-a) - 1]
!
!  where a = 2*T/dthx. When dthx >> T, a third order Taylor's series expansion
!  gives the numerically improved approximation
!
!	V(T) = [1 - 2*|T|/(3*dthx) ],	dthx >> T
!
!  and when dthx << T, the exp(-a) term disappears because `a' becomes very
!  large, leaving us with
!
!	V(T) = (dthx/T) * [ 1 - (dthx/2T) ]
!
!
!  REVISION HISTORY:
!  1.1	explicitly accomodate the case when dthx = 0.
!  1.2	corrected bug introduced in 1.1 (missed multiplying by var)
!  1.3	improved limit handling
!  1.4	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (Apr 29/00)
!  1.5	eliminated lvarfn -- now return covariances only if var < 0 (Mar 2/01)
!  1.6	reversed default - now return covariances if var > 0 (Apr 11/01)
!  1.61	revised above documentation to reflect revision 1.6 (May 9/01)
!  1.62	corrected erroneous documentation above re variance func (Jul 10/02)
! =======================================================================
      real*8 function dlavx1( T )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, dpb, dthx, dthy, dthz
      data zero/0.d0/, half/0.5d0/, one/1.d0/, two/2.d0/, three/3.d0/
      data small/0.0067d0/, big/1.d6/
      abs(x) = dabs(x)
      exp(x) = dexp(x)

      aT = abs(T)
      if( var .lt. zero ) then			! return variance function
         if( dthx .ge. big*aT ) then
            if( dthx .eq. zero ) then
               dlavx1 = -var
            else
               dlavx1 = -var*(one - two*aT/(three*dthx))
            endif
         elseif( dthx .le. small*aT ) then
            rx = dthx/aT
            dlavx1 = -var*rx*(one - half*rx)
         else
            a = dthx/abs(T)
            b = half*a
            c = exp(-one/b) - one
            dlavx1 = -var*a*(one + b*c)
         endif
      else					! return covariance
         if( dthx .eq. zero ) then
            if( T .eq. zero ) then
               dlavx1 = var
            else
               dlavx1 = zero
            endif
         else
            dlavx1 = var*exp( -two*aT/dthx )
         endif
      endif

      return
      end


MODULE PE2D_NUM
 USE PE2D_TYPE
 IMPLICIT NONE
 CONTAINS
 !-----------------------------------------------------------
 INTEGER FUNCTION FCTL(N)
 IMPLICIT NONE
 INTEGER(I4B) :: I, N
 IF (N == 0) THEN
  FCTL = 1
 ELSE
  FCTL = 1
  DO I = 1,N
   FCTL = FCTL*I
  END DO
 END IF
 END FUNCTION FCTL
 !-----------------------------------------------------------
 INTEGER FUNCTION COMB(K,N) RESULT(KCN)
  IMPLICIT NONE
  INTEGER(I4B) :: K, N
  INTEGER(I4B) :: NUM, DENOM
  NUM = FCTL(N)
  DENOM = FCTL(K)*FCTL(N-K)
  KCN = NUM/DENOM
 END FUNCTION COMB
 !-----------------------------------------------------------
 ! FUNCTION POLEVAL(P,X,ND) RESULT(Y)
 !  INTEGER(I4B) :: N, I
 !  COMPLEX(DPC) :: P(0:N), X, Y
 !  Y(0) = P(N)
 !  Y(1:ND) = CMPLX(0.0_DP,0.0_DP,KIND=DPC)
 !  DO I = N-1,0,-1
 !   NND = MIN(ND,N+1-I)
 !   DO J = NND,1,-1
 !    Y(J) = Y(J)*X+Y(J-1)
 !   END DO
 !   Y(0) = Y(0)*X+P(I)
 !  END DO
 !  DO I = 0,ND
 !   Y(I)  = FCTL(I)*Y(I)
 !  END DO
 ! END FUNCTION
 !-----------------------------------------------------------
 FUNCTION POLMULT(P,Q) RESULT(R)
  INTEGER(I4B) :: N, M, I, J
  COMPLEX(DPC) :: P(:), Q(:)
  COMPLEX(DPC), ALLOCATABLE, DIMENSION(:) :: R
  N = SIZE(P,1)
  M = SIZE(Q,1)
  ALLOCATE(R(0:M+N))
  R = CMPLX(0.0_DP,0.0_DP,KIND=DPC)
  DO I = 0,N
    DO J = 0,M
      R(I+J) = R(I+J)+P(I)*Q(J)
    END DO
  END DO
 END FUNCTION
 !-----------------------------------------------------------
 !FUNCTION POLDIV(P,X,ND) RESULT(DP)
 !
 !END FUNCTION
 !-----------------------------------------------------------
 FUNCTION FDC(I) RESULT(C)
 IMPLICIT NONE
 INTEGER(I4B), INTENT(IN) :: I
 INTEGER(I4B) :: J, Q, R
 REAL(DP), DIMENSION(0:I) :: C
 R = MOD(I,2)
 IF (R == 0) THEN
  Q = I/2
 ELSE
  Q = (I-1)/2
 ENDIF
 DO J = 0,I
  C(J) = ((-1)**(Q-J))*REAL(COMB(J,I),KIND=DP)
 END DO
 END FUNCTION FDC
 !-----------------------------------------------------------
 FUNCTION FDW(M,N,X0,A) RESULT(D)
 IMPLICIT NONE
 INTEGER(I4B), INTENT(IN) :: M, N
 REAL(DP), DIMENSION(0:N), INTENT(IN) :: A
 REAL(DP), DIMENSION(0:M,0:N,0:N) :: D        !D(I,J,K) = d^i_{j,k}
 REAL(DP), INTENT(IN) :: X0
 REAL(DP) :: C1, C2, C3
 INTEGER(I4B) :: I, J, K
 D = 0.0_DP
 D(0,0,0) = 1
 C1 = 1
 DO J = 1,N
  C2 = 1
  DO K = 0,J-1
   C3 = A(J)-A(K)
   C2 = C2*C3
   D(0,J,K) = (A(J)-X0)*D(0,J-1,K)/C3
   DO I = 1,MIN(J,M)
    D(I,J,K) = ((A(J)-X0)*D(I,J-1,K)-I*D(I-1,J-1,K))/C3
   END DO
  END DO
  D(0,J,J) = (C1/C2)*(A(J-1)-X0)*D(0,J-1,J-1)
  DO I = 1,MIN(J,M)
   D(I,J,J) = (C1/C2)*(I*D(I-1,J-1,J-1)-(A(J-1)-X0)*D(I,J-1,J-1))
  END DO
  C1 = C2
 END DO
 END FUNCTION
 !-----------------------------------------------------------
END MODULE PE2D_NUM


      subroutine mapc2m_annulus(ac,bc,xp,yp,zp)
      implicit none

      double precision ac,bc, xc,yc,xp,yp,zp, r
      double precision l1(4)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      double precision t1, t2, t

      xc = ac
      yc = bc

      t1 = theta(1)
      t2 = theta(2)

      r = beta + (1-beta)*yc
      t = 2*pi*(t1 + (t2-t1)*xc)
      xp = r*cos(t)
      yp = r*sin(t)
      zp = 0

      end


      PROGRAM xamoeba
C     driver for routine amoeba
      INTEGER NP,MP
      REAL FTOL
      PARAMETER(NP=3,MP=4,FTOL=1.0E-6)
      INTEGER i,iter,j,ndim
      REAL famoeb,p(MP,NP),x(NP),y(MP)
      EXTERNAL famoeb
      DATA p/0.0,1.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0,1.0/
      ndim=NP
      do 12 i=1,MP
        do 11 j=1,NP
          x(j)=p(i,j)
11      continue
        y(i)=famoeb(x)
12    continue
      call amoeba(p,y,MP,NP,ndim,FTOL,famoeb,iter)
      write(*,'(/1x,a,i3)') 'Number of iterations: ',iter
      write(*,'(/1x,a)') 'Vertices of final 3-D simplex and'
      write(*,'(1x,a)') 'function values at the vertices:'
      write(*,'(/3x,a,t11,a,t23,a,t35,a,t45,a/)') 'I',
     *     'X(I)','Y(I)','Z(I)','FUNCTION'
      do 13 i=1,MP
        write(*,'(1x,i3,4f12.6)') i,(p(i,j),j=1,NP),y(i)
13    continue
      write(*,'(/1x,a)') 'True minimum is at (0.5,0.6,0.7)'
      END
      REAL FUNCTION famoeb(x)
      REAL bessj0,x(3)
      famoeb=0.6-bessj0((x(1)-0.5)**2+(x(2)-0.6)**2+(x(3)-0.7)**2)
      END

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


      real*8 function interp4 (a1, a2, av, b1, b2, bv, t1, t2, t3, t4)
!***********************************************************************
! $Id: interp4.f,v 1.1 2006/05/17 15:23:22 zvd Exp $
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!
! PURPOSE
!
! To calculate particle time delay using type curves.
!
!**********************************************************************
!
! Initial implementation: 05-MAY-99, Programmer: Zora Dash
!     for FEHM Version 2.10 [10086-STN-2.10-00]
!
!**********************************************************************
! Return the interpolated time value

      implicit none

      real*8 a1, a2, av, b1, b2, bv, t1, t2, t3, t4
      real*8 d1, d2, d3, d4, totald

      d1 = dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2)

      if (d1 .eq. 0) then
         interp4 = t1
         return
      end if

      d2 =  dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2)

      if (d2 .eq. 0) then
         interp4 = t2
         return
      end if

      d3 =  dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2)

      if (d3 .eq. 0) then
         interp4 = t3
         return
      end if

      d4 =  dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2)

      if (d4 .eq. 0) then
         interp4 = t4
         return
      end if

      d1 = 1./d1
      d2 = 1./d2
      d3 = 1./d3
      d4 = 1./d4

      totald = 1. /(d1 + d2 + d3 +d4)

      interp4 = totald * (d1*t1 + d2*t2 + d3*t3 + d4*t4)

      return
      end


use std
implicit None

type(random_) :: random
type(IO_) :: f
type(Math_) :: math
real(real64) :: width,length,r,x,y,alpha,lin_curve_ratio,y_
integer(int32) :: cases, i

call f%open("circle_model.txt")
do cases=1,100
    width  = random%random()
    lin_curve_ratio = 0.50d0
    length = 1.0d0
    alpha  = width/2.0d0
    r      = (alpha**2 + (length - alpha)**2)/(2*alpha)
    do i=1,1000
        x = dble(i-1)/1000.0d0
        if(x < width/2.0d0)then
            y = sqrt( alpha**2 - (x-alpha)**2 )
            y_ = x
            y = lin_curve_ratio*y + (1.0d0-lin_curve_ratio)*y_
        else
            y_ = alpha + (-alpha)/(length-alpha)*(x - alpha)
            y = alpha - r + sqrt(r**2 - (x - alpha)**2 )
            y = lin_curve_ratio*y + (1.0d0-lin_curve_ratio)*y_
        endif
        !if(y<0.0d0)cycle
        call f%write(x,y)
    enddo
    do i=1,1000
        x = dble(i-1)/1000.0d0

        if(x < width/2.0d0)then
            y = sqrt( alpha**2 - (x-alpha)**2 )
            y_ = x
            y = lin_curve_ratio*y + (1.0d0-lin_curve_ratio)*y_
        else
            y = alpha - r + sqrt(r**2 - (x - alpha)**2 )
            y_ = alpha + (-alpha)/(length-alpha)*(x - alpha)
            y = lin_curve_ratio*y + (1.0d0-lin_curve_ratio)*y_
        endif
        !if(y<0.0d0)cycle
        call f%write(x,-y)
    enddo

    call f%write(" ")
enddo
call f%close()

end


module mod_lagrange
    use mod_kinds,          only: rk,ik
    use mod_constants
    use mod_gauss_legendre, only: gl_nodes

    implicit none

contains

    !------------------------------------------------------------------
    !       polynomial values
    !------------------------------------------------------------------

    function LagrangeVal(space_dim,nterms,currentnode,xpos,ypos,zpos) result(polyval)
        integer(kind=ik), intent(in)        :: space_dim,nterms,currentnode
        real(kind=rk), intent(in)           :: xpos,ypos,zpos
        real(kind=rk)                       :: polyval

        select case (space_dim)
            case (1)    ! 1D
                polyval = LagrangeVal1D(nterms,currentnode,xpos)
            case (2)    ! 2D
                polyval = LagrangeVal2D(nterms,currentnode,xpos,ypos)
            case (3)    ! 3D
                polyval = LagrangeVal3D(nterms,currentnode,xpos,ypos,zpos)
            case default
                print*, "Error - lagrangeVal: valid space dimensions are (1,2,3)"
                stop
        end select
    end function

    function LagrangeVal1D(nterms,currentnode,pos) result(polyval)
    !   A set of 1D, Lagrange polynomials is associated with the coordinates
    !   in 'nodes'. This function computes the value of the Lagrange polynomial
    !   associated with the 'currentnode' at the coordinate 'pos'.
    !   Edit list:  Nathan A. Wukie - 2/15/2015
        integer(kind=ik), intent(in)                :: nterms,currentnode
        real(kind=rk), intent(in)                   :: pos
        real(kind=rk), dimension(nterms)            :: nodes
        real(kind=rk)                               :: polyval
        integer(kind=ik)                            :: j
        real(kind=rk)                               :: xi,xj

        ! Get Gauss-Legendre nodes
        nodes = gl_nodes(nterms)

        polyval = 1._rk
        xi = nodes(currentnode)
        select case (nterms)
            case (1)
                polyval = 1._rk
            case (2 :)
                do j=1,nterms
                    xj = nodes(j)
                    if (currentnode /= j) then
                        polyval = polyval*(pos-xj)/(xi-xj)
                    end if
                end do
        end select

    end function

    function LagrangeVal2D(nterms,currentmode,xi,eta) result(polyval)
    !   A set of 2D, Lagrange polynomials is associated with the coordinates
    !   in 'nodes'. This function computes the value of the Lagrange polynomial
    !   associated with the 'currentnode' at the coordinate '(xpos,ypos)'.
    !   Edit list:  Nathan A. Wukie - 2/15/2015
        use mod_ordering,   only: xi_order_2d,eta_order_2d

        integer(kind=ik), intent(in)                :: nterms,currentmode
        real(kind=rk),    intent(in)                :: xi,eta

        real(kind=rk)                               :: polyval,xi_polyval,eta_polyval
        integer(kind=ik)                            :: nterms1d,xi_mode,eta_mode

        ! compute the number of terms in the 1D polynomial
        ! really just finding the square root of nterms, but there isn't
        ! such a function for integers in fortran
        nterms1d = 0
        do while (nterms1d*nterms1d /= nterms)
            nterms1d = nterms1d+1
        end do

        ! compute current x/y-node indices of 1D tensor product polynomials
        ! Example: for a 2D lagrange polynomial L(x,y)=L(x)*L(y), compute the
        ! x and y indices
!        print*, currentmode
        xi_mode  = xi_order_2d( currentmode)
        eta_mode = eta_order_2d(currentmode)

        xi_polyval  = LagrangeVal1D(nterms1d,xi_mode,  xi)
        eta_polyval = LagrangeVal1D(nterms1d,eta_mode,eta)

        polyval = xi_polyval*eta_polyval
    end function

    function LagrangeVal3D(nterms,currentmode,xi,eta,zeta) result(polyval)
    !   A set of 3D, Lagrange polynomials is associated with the coordinates
    !   in 'nodes'. This function computes the value of the Lagrange polynomial
    !   associated with the 'currentnode' at the coordinate '(xpos,ypos,zpos)'.
    !   Edit list:  Nathan A. Wukie - 2/15/2015
        use mod_ordering,   only: xi_order_3d,eta_order_3d,zeta_order_3d

        integer(kind=ik), intent(in)                :: nterms,currentmode
        real(kind=rk),    intent(in)                :: xi,eta,zeta

        real(kind=rk)                               :: polyval,xi_polyval,eta_polyval,zeta_polyval
        integer(kind=ik)                            :: nterms1d,xi_mode,eta_mode,zeta_mode

        ! compute the number of terms in the 1D polynomial
        ! really just finding the cubed-root of nterms, but there isn't
        ! such a function for integers in fortran
        nterms1d = 0
        do while (nterms1d*nterms1d*nterms1d /= nterms)
            nterms1d = nterms1d+1
        end do

        ! compute current x/y-node indices of 1D tensor product polynomials
        ! Example: for a 2D lagrange polynomial L(x,y)=L(x)*L(y), compute the
        ! x and y indices
        xi_mode   = xi_order_3d(  currentmode)
        eta_mode  = eta_order_3d( currentmode)
        zeta_mode = zeta_order_3d(currentmode)

        xi_polyval   = LagrangeVal1D(nterms1d,xi_mode,  xi)
        eta_polyval  = LagrangeVal1D(nterms1d,eta_mode, eta)
        zeta_polyval = LagrangeVal1D(nterms1d,zeta_mode,zeta)

        polyval = xi_polyval*eta_polyval*zeta_polyval
    end function

    !------------------------------------------------------------------
    !       polynomial derivatives
    !------------------------------------------------------------------

    function DLagrangeVal(space_dim,nterms,currentmode,xi,eta,zeta,dir) result(dpolyval)
        integer(kind=ik),   intent(in)          :: space_dim,nterms,currentmode
        real(kind=rk),      intent(in)          :: xi,eta,zeta
        integer(kind=ik),   intent(in)          :: dir
!        character(len=*),   intent(in)          :: dir

        real(kind=rk)                           :: dpolyval

        select case (space_dim)
            case (1)    ! 1D
                dpolyval = DLagrangeVal1D(nterms,currentmode,xi)
            case (2)    ! 2D
                dpolyval = DLagrangeVal2D(nterms,currentmode,xi,eta,dir)
            case (3)    ! 3D
                dpolyval = DLagrangeVal3D(nterms,currentmode,xi,eta,zeta,dir)
            case default
                print*, "Error - DLagrangeVal: Valid space dimensions are (1,2,3)"
                stop
        end select
    end function

    function DLagrangeVal1D(nterms1d,currentmode,xi) result(dpolyval)
    !   A set of 1D-Lagrange polynomials is associated with the coordinates
    !   in 'nodes'. This function compute the derivative of the Lagrange polynomial
    !   associated with the 'currentnode' at the location 'pos'.
    !   Edit list:  Nathan A. Wukie - 2/21/2015

        integer(kind=ik), intent(in)            :: nterms1d,currentmode
        real(kind=rk),    intent(in)            :: xi

        real(kind=rk), dimension(nterms1d)      :: nodes
        integer(kind=ik)                        :: j,k
        real(kind=rk)                           :: dpolyval
        real(kind=rk)                           :: prod,xi_i,xi_j,xk

        nodes = gl_nodes(nterms1d)

        dpolyval = 0._rk
        xi_i = nodes(currentmode)
        do j=1,nterms1d
            xi_j = nodes(j)
            prod = 1._rk
            if (j /= currentmode) then
                do k=1,nterms1d
                    xk = nodes(k)
                    if ( k /= currentmode .and. k /= j) then
                        prod = prod*(xi-xk)/(xi_i-xk)
                    end if
                end do
                dpolyval = dpolyval + prod/(xi_i-xi_j)
            end if
        end do

    end function

    function DLagrangeVal2D(nterms,currentmode,xi,eta,dir) result(dpolyval)
    !   A set of 1D-Lagrange polynomials is associated with the coordinates
    !   in 'nodes'. This function compute the derivative of the Lagrange polynomial
    !   associated with the 'currentnode' at the location 'pos'.
    !   Edit list:  Nathan A. Wukie - 2/21/2015
        use mod_ordering,   only: xi_order_2d,eta_order_2d

        integer(kind=ik), intent(in)            :: nterms,currentmode
        real(kind=rk),    intent(in)            :: xi,eta
        integer(kind=ik), intent(in)            :: dir
!        character(len=*), intent(in)            :: dir

        integer(kind=ik)                        :: nterms1d,xi_mode,eta_mode
        real(kind=rk)                           :: dpolyval
        real(kind=rk)                           :: xi_val,eta_val,dxi_val,deta_val

        ! compute the number of terms in the 1d polynomial
        ! really just finding the square root of nterms, but there isn't
        ! such a function for integers in fortran
        nterms1d = 0
        do while (nterms1d*nterms1d /= nterms)
            nterms1d = nterms1d+1
        end do

        xi_mode  = xi_order_2d(currentmode)
        eta_mode = eta_order_2d(currentmode)

        select case (dir)
            case (XI_DIR)
                dxi_val = DLagrangeVal1D(nterms1d,xi_mode,xi)
                eta_val = LagrangeVal1D(nterms1d,eta_mode,eta)

                dpolyval = dxi_val*eta_val
            case (ETA_DIR)

                xi_val   = LagrangeVal1D(nterms1d,xi_mode,xi)
                deta_val = DLagrangeVal1D(nterms1d,eta_mode,eta)

                dpolyval = xi_val*deta_val
            case default
                write(*,*) "valid derivative directions are - 'xi', 'eta'"
                stop
        end select
    end function

    function DLagrangeVal3D(nterms,currentmode,xi,eta,zeta,dir) result(dpolyval)
    !   A set of 3D-Lagrange polynomials is associated with the coordinates
    !   in 'nodes'. This function computes the derivative of the Lagrange polynomial
    !   associated with the 'currentnode' at the location 'pos' my multiplying the
    !   1D derivatives, since the 3D modes are constructed from a tensor product of 1D modes
    !   Edit list:  Nathan A. Wukie - 4/13/2015
        use mod_ordering,   only: xi_order_3d,eta_order_3d,zeta_order_3d

        integer(kind=ik), intent(in)            :: nterms,currentmode
        real(kind=rk),    intent(in)            :: xi,eta,zeta
        integer(kind=ik), intent(in)            :: dir

        integer(kind=ik)                        :: nterms1d,xi_mode,eta_mode,zeta_mode
        real(kind=rk)                           :: dpolyval
        real(kind=rk)                           :: xi_val,eta_val,zeta_val,dxi_val,deta_val,dzeta_val

        ! compute the number of terms in the 1d polynomial
        ! really just finding the square root of nterms, but there isn't
        ! such a function for integers in fortran
        nterms1d = 0
        do while (nterms1d*nterms1d*nterms1d /= nterms)
            nterms1d = nterms1d+1
        end do

        xi_mode   = xi_order_3d(  currentmode)
        eta_mode  = eta_order_3d( currentmode)
        zeta_mode = zeta_order_3d(currentmode)

        select case (dir)
            case (XI_DIR)
                dxi_val   = DLagrangeVal1D(nterms1d,xi_mode,xi)
                eta_val   = LagrangeVal1D(nterms1d,eta_mode,eta)
                zeta_val  = LagrangeVal1D(nterms1d,zeta_mode,zeta)

                dpolyval  = dxi_val*eta_val*zeta_val
            case (ETA_DIR)
                xi_val    = LagrangeVal1D(nterms1d,xi_mode,xi)
                deta_val  = DLagrangeVal1D(nterms1d,eta_mode,eta)
                zeta_val  = LagrangeVal1D(nterms1d,zeta_mode,zeta)

                dpolyval  = xi_val*deta_val*zeta_val
            case (ZETA_DIR)
                xi_val    = LagrangeVal1D(nterms1d,xi_mode,xi)
                eta_val   = LagrangeVal1D(nterms1d,eta_mode,eta)
                dzeta_val = DLagrangeVal1D(nterms1d,zeta_mode,zeta)

                dpolyval  = xi_val*eta_val*dzeta_val
            case default
                write(*,*) "valid derivative directions are - 'xi', 'eta', 'zeta'"
                stop
        end select
    end function

end module mod_lagrange


module linear_solve

   implicit none

   public :: lu_decomposition
   public :: lu_back_substitution
   public :: lu_inverse
   public :: imaxloc

   interface lu_decomposition
      module procedure lu_decomposition_real
      module procedure lu_decomposition_complex
   end interface

   interface lu_back_substitution
      module procedure lu_back_substitution_real
      module procedure lu_back_substitution_real_complex
      module procedure lu_back_substitution_complex
      module procedure lu_back_substitution_matrix_real
      module procedure lu_back_substitution_matrix_complex
   end interface

   interface lu_inverse
      module procedure lu_inverse_real
      module procedure lu_inverse_complex
   end interface

contains

   subroutine lu_decomposition_real(lu, idx, d)

      implicit none

      real, dimension(:, :), intent(in out) :: lu
      integer, dimension(:), intent(out) :: idx
      real, intent(out) :: d

      real, parameter :: zero = 1.0e-20
      real, dimension(size(lu, 1)) :: vv
      real, dimension(size(lu, 2)) :: dum

      integer :: j, n, imax

      n = size(lu, 1)

      d = 1.0
      vv = maxval(abs(lu), dim=2)
      if (any(vv == 0.0)) &
         write (*, *) 'singular matrix in lu_decomposition'
      vv = 1.0 / vv
      do j = 1, n
         imax = (j - 1) + imaxloc(vv(j:n) * abs(lu(j:n, j)))
         if (j /= imax) then
            dum = lu(imax, :)
            lu(imax, :) = lu(j, :)
            lu(j, :) = dum
            d = -d
            vv(imax) = vv(j)
         end if
         idx(j) = imax
         if (lu(j, j) == 0.0) lu(j, j) = zero
         lu(j + 1:n, j) = lu(j + 1:n, j) / lu(j, j)
         lu(j + 1:n, j + 1:n) = lu(j + 1:n, j + 1:n) - spread(lu(j + 1:n, j), 2, n - j) &
                                * spread(lu(j, j + 1:n), 1, n - j)
      end do

   end subroutine lu_decomposition_real

   subroutine lu_decomposition_complex(lu, idx, d)

      implicit none

      complex, dimension(:, :), intent(in out) :: lu
      integer, dimension(:), intent(out) :: idx
      real, intent(out) :: d

      real, parameter :: zero = 1.0e-20
      real, dimension(size(lu, 1)) :: vv
      complex, dimension(size(lu, 2)) :: dum

      integer :: j, n, imax

      n = size(lu, 1)

      d = 1.0
      vv = maxval(cabs(lu), dim=2)
      if (any(vv == 0.0)) &
         write (*, *) 'singular matrix in lu_decomposition'
      vv = 1.0 / vv
      do j = 1, n
         imax = (j - 1) + imaxloc(vv(j:n) * cabs(lu(j:n, j)))
         if (j /= imax) then
            dum = lu(imax, :)
            lu(imax, :) = lu(j, :)
            lu(j, :) = dum
            d = -d
            vv(imax) = vv(j)
         end if
         idx(j) = imax
         if (lu(j, j) == 0.0) lu(j, j) = zero
         lu(j + 1:n, j) = lu(j + 1:n, j) / lu(j, j)
         lu(j + 1:n, j + 1:n) = lu(j + 1:n, j + 1:n) - spread(lu(j + 1:n, j), 2, n - j) &
                                * spread(lu(j, j + 1:n), 1, n - j)
      end do

   end subroutine lu_decomposition_complex

   subroutine lu_back_substitution_real(lu, idx, b)

      implicit none

      real, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      real, dimension(:), intent(in out) :: b

      integer :: i, n, ii, ll
      real :: summ

      n = size(lu, 1)
      ii = 0
      do i = 1, n
         ll = idx(i)
         summ = b(ll)
         b(ll) = b(i)
         if (ii /= 0) then
            summ = summ - dot_product(lu(i, ii:i - 1), b(ii:i - 1))
         else if (summ /= 0.0) then
            ii = i
         end if
         b(i) = summ
      end do
      do i = n, 1, -1
         b(i) = (b(i) - dot_product(lu(i, i + 1:n), b(i + 1:n))) / lu(i, i)
      end do

   end subroutine lu_back_substitution_real

   subroutine lu_back_substitution_real_complex(lu, idx, b)

      implicit none

      real, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      complex, dimension(:), intent(in out) :: b

      integer :: i, n, ii, ll
      complex :: summ

    !! The dot products we use below automatically take the complex conjugate of its
    !! first argument, which we do not want here. Hence the use of conjg to undo this

      n = size(lu, 1)
      ii = 0
      do i = 1, n
         ll = idx(i)
         summ = b(ll)
         b(ll) = b(i)
         if (ii /= 0) then
            summ = summ - dot_product(lu(i, ii:i - 1), b(ii:i - 1))
         else if (summ /= 0.0) then
            ii = i
         end if
         b(i) = summ
      end do
      do i = n, 1, -1
         b(i) = (b(i) - dot_product(lu(i, i + 1:n), b(i + 1:n))) / lu(i, i)
      end do

   end subroutine lu_back_substitution_real_complex

   subroutine lu_back_substitution_complex(lu, idx, b)

      implicit none

      complex, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      complex, dimension(:), intent(in out) :: b

      integer :: i, n, ii, ll
      complex :: summ

    !! The dot products we use below automatically take the complex conjugate of its
    !! first argument, which we do not want here. Hence the use of conjg to undo this

      n = size(lu, 1)
      ii = 0
      do i = 1, n
         ll = idx(i)
         summ = b(ll)
         b(ll) = b(i)
         if (ii /= 0) then
            summ = summ - dot_product(conjg(lu(i, ii:i - 1)), b(ii:i - 1))
         else if (summ /= 0.0) then
            ii = i
         end if
         b(i) = summ
      end do
      do i = n, 1, -1
         b(i) = (b(i) - dot_product(conjg(lu(i, i + 1:n)), b(i + 1:n))) / lu(i, i)
      end do

   end subroutine lu_back_substitution_complex

   subroutine lu_back_substitution_matrix_real(lu, idx, b)

      implicit none

      real, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      real, dimension(:, :), intent(in out) :: b

      integer :: i, j, n, ii, ll
      real :: summ

      n = size(lu, 1)
      ii = 0
      do j = 1, n
         do i = 1, n
            ll = idx(i)
            summ = b(ll, j)
            b(ll, j) = b(i, j)
            if (ii /= 0) then
               summ = summ - dot_product(lu(i, ii:i - 1), b(ii:i - 1, j))
            else if (summ /= 0.0) then
               ii = i
            end if
            b(i, j) = summ
         end do
         do i = n, 1, -1
            b(i, j) = (b(i, j) - dot_product(lu(i, i + 1:n), b(i + 1:n, j))) / lu(i, i)
         end do
      end do

   end subroutine lu_back_substitution_matrix_real

   subroutine lu_back_substitution_matrix_complex(lu, idx, b)

      implicit none

      complex, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      complex, dimension(:, :), intent(in out) :: b

      integer :: i, j, n, ii, ll
      complex :: summ

    !! The dot products we use below automatically take the complex conjugate of its
    !! first argument, which we do not want here. Hence the use of conjg to undo this

      n = size(lu, 1)
      ii = 0
      do j = 1, n
         do i = 1, n
            ll = idx(i)
            summ = b(ll, j)
            b(ll, j) = b(i, j)
            if (ii /= 0) then
               summ = summ - dot_product(conjg(lu(i, ii:i - 1)), b(ii:i - 1, j))
            else if (summ /= 0.0) then
               ii = i
            end if
            b(i, j) = summ
         end do
         do i = n, 1, -1
            b(i, j) = (b(i, j) - dot_product(conjg(lu(i, i + 1:n)), b(i + 1:n, j))) / lu(i, i)
         end do
      end do

   end subroutine lu_back_substitution_matrix_complex

  !!
  !! One shouldn't need to compute the inverse of a matrix if solving the linear equation A.x = y;
  !! a simple back substitution should suffice.
  !!
  !! Only compute the inverse of A when absolutely necessary!
  !!
   subroutine lu_inverse_real(lu, idx, inverse)

      implicit none

      real, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      real, dimension(:, :), intent(out) :: inverse

      integer :: i, n

      n = size(lu, 1)

      inverse = 0.0
      do i = 1, n
         inverse(i, i) = 1.0
      end do

      do i = 1, n
         call lu_back_substitution(lu, idx, inverse(:, i))
      end do

   end subroutine lu_inverse_real

   subroutine lu_inverse_complex(lu, idx, inverse)

      implicit none

      complex, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      complex, dimension(:, :), intent(out) :: inverse

      integer :: i, n

      n = size(lu, 1)

      inverse = 0.0
      do i = 1, n
         inverse(i, i) = 1.0
      end do

      do i = 1, n
         call lu_back_substitution(lu, idx, inverse(:, i))
      end do

   end subroutine lu_inverse_complex

   function imaxloc(array)
      real, dimension(:), intent(in) :: array
      integer :: imaxloc
      integer, dimension(1) :: imax
      imax = maxloc(array)
      imaxloc = imax(1)
   end function imaxloc

end module linear_solve


	FUNCTION PR_KNMS  ( sknt )
C************************************************************************
C* PR_KNMS								*
C*									*
C* This function computes SPED from SKNT.  The following equation is	*
C* used:								*
C*									*
C*               SPED = SKNT / 1.9425					*
C*									*
C* REAL PR_KNMS  ( SKNT )						*
C*									*
C* Input parameters:							*
C*	SKNT		REAL		Speed in knots			*
C*									*
C* Output parameters:							*
C*	PR_KNMS		REAL		Speed in meters/second		*
C**									*
C*Log:									*
C* I. Graffman/CSC	 8/83	Original source code			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 7/88	Documentation				*
C* L. Sager/NCEP	 4/96	Updated knots to m/sec conversion 	*
C*				factor to NCEP standard			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing data.
C
	IF  ( ERMISS ( sknt ) )  THEN
	    PR_KNMS = RMISSD
	  ELSE
	    PR_KNMS = sknt / 1.9425
	END IF
C*
	RETURN
	END


Program proj2
	Implicit none
	real*8 :: t, dt, v, theta0, theta, pi, offset, alpha
	real*8, dimension(2) :: x, y
	real*8, external :: f_x, g_x, g_y
	integer :: i
	character (len=10) :: filename

	pi = 4.0d0*atan(1.0d0)

	! read setting
	print *, "Initial angle in degree:"
	read *, theta0

	do i=1,2
		write(filename , '("res",i1,".dat")') i
		theta = theta0 /180.0d0 * pi
		alpha = 5.0d-2 / 30.0d0 * (i-1.d0) ! k/m

		! initial conditions
		v = 100.0D0
		t = 0.0d0
		dt = 0.02D0

		x(1) = 0.0D0
		x(2) = v * cos(theta)

		y(1) = EPSILON(0.0d0)
		y(2) = v * sin(theta)

		open(10, file=filename)

		! Runga-Kutta iteration
		do while( .true. )
			t = t + dt
			call rk4(dt, f_x, g_x, x, v, theta, alpha)
			call rk4(dt, f_x, g_y, y, v, theta, alpha)
			v = sqrt(x(2)**2 + y(2)**2)
			theta = atan(y(2)/x(2))
			if (y(1).gt.0) then
				write (10,*) t, x(1), y(1), x(2), y(2), v, theta / pi * 180
			else
				exit
			endif
		enddo

		offset = y(1) / y(2)
		t = t - offset
		x(1) = x(1) - offset * x(2)
		y(1) = y(1) - offset * y(2)
		write (10,*) t, x(1), y(1), x(2), y(2), v, theta / pi * 180
		close(10)
		print *, 'flying time:', t, 's; distance:', x(1), 'meter'
	enddo
End program proj2

! 4th-order Runge-Kutta subroutine
subroutine rk4(dt, df, dg, y, v, theta, alpha)
	implicit none
	real*8, external :: df, dg
	real*8, intent(in) :: dt, alpha
	real*8, intent(inout) :: v, theta
	real*8, intent(inout), dimension(2) :: y
	real*8 :: h, k0, k1, k2, k3, l0, l1, l2, l3

	h=dt/2.0D0

	k0 = dt * df(y(1),y(2))
	l0 = dt * dg(y(1),y(2),v,theta,alpha)
	k1 = dt * df(y(1)+h, y(2)+0.5d0*l0)
	l1 = dt * dg(y(1)+0.5d0*k0,y(2)+0.5d0*l0,v,theta,alpha)
	k2 = dt * df(y(1)+0.5d0*k1,y(2)+0.5d0*l1)
	l2 = dt * dg(y(1)+0.5d0*k1,y(2)+0.5d0*l1,v,theta,alpha)
	k3 = dt * df(y(1)+k2,y(2)+l2)
	l3 = dt * dg(y(1)+k2,y(2)+l2,v,theta,alpha)
	y(1) = y(1) + (k0+2*k1+2*k2+k3)/6.0d0
	y(2) = y(2) + (l0+2*l1+2*l2+l3)/6.0d0
	Return
End subroutine rk4

! function which returns the derivatives (RHS)
real*8 function f_x(a, b)
! dx/dt = v(t)
	Implicit none
	real*8 ,intent(in) :: a, b
	f_x = b
	Return
End function f_x

real*8 function g_x(a, b, v, theta, alpha)
	implicit none
	real*8, intent(in) :: a, b, v, theta, alpha
	g_x = - alpha * v**2 * cos(theta)
!	g_x = 0
	Return
End function g_x

real*8 function g_y(a, b, v, theta, alpha)
	implicit none
	real*8, intent(in) :: a, b, v, theta, alpha
	real*8 :: g
	g = 9.8d0
	g_y = -g - alpha * v**2 * sin(theta)
!	g_y = -g
	Return
End function g_y


! { dg-do run }
! Transformational intrinsic DOT_PRODUCT as initialization expression.

  INTEGER, PARAMETER :: n = 10
  INTEGER, PARAMETER :: a(n) = 1
  INTEGER, PARAMETER :: p = DOT_PRODUCT(a, a)
  INTEGER, PARAMETER :: e = DOT_PRODUCT(SHAPE(1), SHAPE(1))

  IF (p /= n) STOP 1
  IF (e /= 0) STOP 2
END


      program P0205
c>> 1997-06-20 Krogh Generate plots for ch02-05.tex
c Derived from an earlier code by Charles Lawson.  Working backwards
c from that code, the curve generated here for pl02-05c is the set of
c points (x,y) which satisfy:
c
c sqrt(2/pi y) [ 2 y / (e x) ] ** y = omega,
c
c where pi and e are the usual constants, and omega is the overflow limit.
c The plots are done for -.01 .le. x .le. .01.  The code avoids overflow
c and gets a smoother problem to solve by taking the base 10 logarithm of
c both side of this equation.
c
      integer MAXPT, MAXPTC
      real RMAXPT, XAC, XBC, XSIZE, YSIZE
      parameter (MAXPT=101, MAXPTC=41, RMAXPT=101.E0)
      parameter (XAC = .01E0, XBC = 100.0E0)
      parameter (XSIZE=3.3E0, YSIZE=3.0E0)
      real DX, OPTC(31), X(MAXPT), Y(MAXPT, 4)
      external SERF, SERFC, SERFCE
      real SERF, SERFC, SERFCE
      integer I, IV, MODE
      character COPTC*128
      real PLOUNI, PLOTXT, PLONY, PLOBOR, PLOYMX
      real             C1, C2, CC2, F1, F2, FCN, TOL, VALS(4),
     1   XX, Y1, Y2, ZZ
      parameter (TOL = 1.0E-5)

      parameter (PLOUNI=1.E0, PLOTXT=14.E0, PLONY=2.E0, PLOYMX=9.E0,
     1   PLOBOR=4.E0)
      data OPTC /0.E0, PLONY, RMAXPT, 4.E0, PLOTXT, .06E0, 12.5E0, 0.E0,
     1   PLOTXT, .015E0, 49.E0, 0.E0, PLOTXT, .2E0, 300.E0, 0.E0,
     2   PLOTXT, .03E0, 800.E0, 0.E0, PLOUNI, 3300.E0,
     3   PLOBOR, 34.E0, 0.E0, 0.E0, PLOBOR, 12.E0, 46.E0, 0.E0, 0.E0 /

      data COPTC /
     1'F{pl02-05c.tex}1[cr]{$x$}2[tc]{$\ \nu^*$}{IEEE SP, Unisys SP, VAX
     2 S2P \& DP}{IBM 30xx SP \& DP}{IEEE DP \& Unisys DP}{Cray J90}'/
      data VALS / 128.0E0, 252.0E0, 1024.0E0, 8190.0E0 /
c
      FCN(YY, C1, C2) = 0.5E0 * (C1 - YY) + 10.0E0**YY * (C2 + YY)
c
c        Plot the curves for Figure 3.

      C1 = log10(0.5E0 / atan(1.0E0))
      CC2 = log10(2.0E0 / exp(1.0E0))
      DX = 4.E0 / (MAXPTC-1)
      do 360 IV = 1, 4
         ZZ = VALS(IV) * log10(2.0E0)
         Y1 = 1.0E0
         do 340 I = 1, MAXPTC
            XX = DX*(I-1) - 2.0E0
            C2 = CC2 - XX
            if (I .eq. 1) then
               Y2 = log10(5000.0E0)
            else
               Y2 = Y1 + 0.5E0
            end if

            F1 = FCN(Y1, C1, C2) - ZZ
            F2 = FCN(Y2, C1, C2) - ZZ
            MODE = 0
c                    Loop to find the zero.
  320       continue
            call SZERO (Y1, F1, Y2, F2, MODE, TOL)
            if (MODE .eq. 1) then
               F1 = FCN(Y1, C1, C2) - ZZ
               go to 320
            end if
            Y(I, IV) = 10.E0 ** Y1
            X(I) = 10.E0 ** XX
  340    continue
  360 continue
      call SPLOT(XSIZE, YSIZE, X, MAXPTC, Y, OPTC, COPTC)
      end


      SUBROUTINE gauleg(x1,x2,x,w,n)
      INTEGER n
      REAL x1,x2,x(n),w(n)
      DOUBLE PRECISION EPS
      PARAMETER (EPS=3.d-14)
      INTEGER i,j,m
      DOUBLE PRECISION p1,p2,p3,pp,xl,xm,z,z1
      m=(n+1)/2
      xm=0.5d0*(x2+x1)
      xl=0.5d0*(x2-x1)
      do 12 i=1,m
        z=cos(3.141592654d0*(i-.25d0)/(n+.5d0))
1       continue
          p1=1.d0
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
11        continue
          pp=n*(z*p1-p2)/(z*z-1.d0)
          z1=z
          z=z1-p1/pp
        if(abs(z-z1).gt.EPS)goto 1
        x(i)=xm-xl*z
        x(n+1-i)=xm+xl*z
        w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
        w(n+1-i)=w(i)
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/gauleg.for


!
! Copyright (c) 2020 TECHNICAL UNIVERSITY OF MUNICH, DEPARTMENT OF MECHANICAL ENGINEERING, CHAIR OF APPLIED MECHANICS,
! BOLTZMANNSTRASSE 15, 85748 GARCHING/MUNICH, GERMANY, RIXEN@TUM.DE.
!
! Distributed under 3-Clause BSD license. See LICENSE file for more information.
!

module tools
    use, intrinsic:: iso_fortran_env, only: dp=>real64
    implicit none

    contains
        subroutine green_lagrange_strain_2d(F, Evout)
            real(dp), intent(in) :: F(2, 2)
            real(dp), intent(out) :: Evout(3)

            real(dp) :: eye(2, 2)
            real(dp) :: E(2, 2)

            eye = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 1.0_dp /), shape=(/2,2/))
            E = 0.5_dp*(matmul(transpose(F), F) - eye)
            Evout(1) = E(1,1)
            Evout(2) = E(2,2)
            Evout(3) = 2.0_dp * E(1,2)
        end subroutine green_lagrange_strain_2d

        subroutine green_lagrange_strain_3d(F, Evout)
            real(dp), intent(in) :: F(3,3)
            real(dp), intent(out) :: Evout(6)

            real(dp) :: eye(3,3)
            real(dp) :: E(3,3)

            eye = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp /), shape=(/3,3/))
            E = 0.5_dp*(matmul(transpose(F), F) - eye)

            Evout(1) = E(1, 1)
            Evout(2) = E(2, 2)
            Evout(3) = E(3, 3)
            Evout(4) = 2.0_dp * E(2, 3)
            Evout(5) = 2.0_dp * E(1, 3)
            Evout(6) = 2.0_dp * E(1, 2)
        end subroutine green_lagrange_strain_3d

        subroutine scatter_matrix(A, B, ndim, m, n)
            integer, intent(in) :: m
            integer, intent(in) :: n
            integer, intent(in) :: ndim
            real(dp), intent(in) :: A(m, n)
            real(dp), intent(inout) :: B(ndim*m, ndim*n)

            integer i, j, k

            !    Initialization to zero; otherwise random stuff is there...
            B(:,:) = 0.0_dp
            ! looping style like in Python:
            do j=0,n-1
                do i=0,m-1
                    do k=0,ndim-1
                        B(ndim*i+k+1,ndim*j+k+1) = A(i+1,j+1)
                    end do
                end do
            end do

        end subroutine scatter_matrix

        real(dp) function determinant_2d(mat)
            real(dp), intent(in) :: mat(2, 2)
            determinant_2d = mat(1, 1) * mat(2, 2) - mat(1, 2) * mat(2, 1)
        end function determinant_2d

        subroutine inverse_matrix_2d(mat, det, matout)
            real(dp), intent(in) :: mat(2, 2)
            real(dp), intent(in) :: det
            real(dp), intent(out) :: matout(2, 2)

            matout = reshape((/ mat(2, 2) / det, &
                                -mat(2, 1) / det, &
                                -mat(1, 2) / det, &
                                mat(1, 1) / det /), shape=(/2,2/))
        end subroutine inverse_matrix_2d

end module tools


c     program DRDGE2
c>> 2001-05-22 DRDGE2 Krogh Minor change for making .f90 version.
c>> 1994-10-19 DRDGE2 Krogh  Changes to use M77CON
c>> 1992-03-10 DRDGE2 Lawson
c
c     Demo driver for DGED, DGEFS, DGEI, DGESLT
c     ------------------------------------------------------------------
c--D replaces "?": ?RDGE2, ?GED, ?GEFS, ?GEI, ?GESLT, ?MATP
c     ------------------------------------------------------------------
      integer NMAX, INFO
      parameter (NMAX = 3)
      double precision A(3,3), B(3,1), C(3,1), DET(2), WORK(NMAX)
      integer I, J, IPVT(NMAX)
c
      data (A(1,J),J=1,3) / 0.579D0, -.394D0, 0.915D0 /
      data (A(2,J),J=1,3) / -0.795D0, 0.226D0, -0.868D0 /
      data (A(3,J),J=1,3) / 0.141D0, -0.329D0, -0.286D0 /
c
      data (B(I,1),I=1,3) / 5.873D0, -5.324D0, 1.069D0 /
      data (C(I,1),I=1,3) / -6.267d0, 4.951d0, -5.177d0 /
c     ------------------------------------------------------------------
      call DMATP(A,NMAX,NMAX,NMAX,' A(,) =')
      print*,' '
      call DMATP(B,NMAX,NMAX,1,' B(,) =')
      call DGEFS(A,NMAX,NMAX,B,NMAX,1,IPVT,INFO)
      print*,' '
      call DMATP(B,NMAX,NMAX,1,' Solution of A*x = b is:')
c
      print*,' '
      call DMATP(C,NMAX,NMAX,1,' C(,) =')
      call DGESLT(A, NMAX, NMAX, IPVT, C)
      print*,' '
      call DMATP(C,NMAX,NMAX,1,' Solution of (A**t)*x = c is:')
c
      call DGED(A, NMAX, NMAX, IPVT, DET)
      print'(/a,f10.6,a,f5.2,a/)',
     *   ' Determinant of A is:',DET(1),' * 10**(',DET(2),')'
c
      call DGEI(A, NMAX, NMAX, IPVT, WORK)
      call DMATP(A,NMAX,NMAX,NMAX,' Inverse of A =')
      end


program compute_gcd
    implicit none
    integer, parameter :: MAX_VALUE = 10
    integer :: a, b
    do a = 1, MAX_VALUE
        do b = 1, MAX_VALUE
            print '(3I10)', a, b, gcd(a, b)
        end do
    end do

contains

    integer function gcd(a, b)
        implicit none
        integer, value :: a, b

        do while (a /= b)
            if (a > b) then
                a = a - b
            else if (b > a) then
                b = b - a
            end if
        end do
        gcd = a
    end function gcd

end program compute_gcd


! Fortran 2008 Print Fibonacci
! This program prints a user specified number of numbers from the
!     fibonacci sequence, starting at 0. Uses iteration to determine
!     the fibonacci numbers

program fibo
	implicit none

	integer(16) :: k

	! Get input from user
	! (A$) format descriptor: A is for character, $ supresses carriage return
	!     Could be replaced by asterisk to let let computer format output
	write (*, '(A$)') "How many fibonacci numbers should be printed? "
	read *, k ! Asterisk indicates default format
	call printfibos(k)
end program fibo

subroutine printfibos(k)
	implicit none

	! Use 128-bit integers
	integer(16), intent(in) :: k ! intent(in) = k cannot be changed in function
	integer(16) :: temp, n
	integer(16) :: fibo0 = 0
	integer(16) :: fibo1 = 1

	if (k == 1) then
		print *, fibo0
	else if (k == 2) then
		print *, fibo0
		print *, fibo1
 	else
		print *, fibo0
		print *, fibo1
		do n=3, k, 1
			temp = fibo1 + fibo0
			fibo0 = fibo1
			fibo1 = temp
			print *, fibo1
		enddo
	end if
end


      subroutine foo
c     only parameter statement
      parameter (a = 10)

c     parameter statement first, declaration later
      parameter (b = 10)
      integer b

c     declaration first, parameter statement later
      real r
      parameter (r = 3.14)

c     integer arithmetics with variable
      integer c
      parameter (c = 10)
      parameter (d1 = c + 2)
      parameter (d2 = c - 2)
      parameter (d3 = c * 2)
      parameter (d4 = c / 3)
      parameter (d5 = -c )
      parameter (d6 = +c )

c     float arithmetics with variable
      real pi
      parameter (pi = 3.14)
      parameter (e1 = pi + pi)
      parameter (e2 = pi - pi)
      parameter (e3 = pi * 2.0)
      parameter (e4 = pi / 2.0)
      parameter (e5 = -pi)
      parameter (e6 = +pi)

c     double precision constant
      REAL*8 eps
      parameter (eps = 1.0D-12)

c     logical expressions :
c     TODO: .AND. .OR.
      parameter (f = .TRUE.)
      parameter (f1 = .NOT. f)

c     TODO: relational expressions

c     string expression
      CHARACTER*(*) RCSID
      parameter (RCSID = 'DEADBEEF')

c     intrinsics
      parameter (d7 = ior(1,8))

      parameter (d8 = max(50,60))
      parameter (d9 = max(40,50,60,70))
      parameter (e7 = max(1.2,1.1))
      parameter (e8 = max(1.2,2))

      character*1 c1
      parameter (c1 =  char(65)) !'A'
      character*2 eol
      parameter( eol = char(13)//char(10) )  !"\r\n"

      integer*4 i1, i2, i3, i4, i5, i6, i7, i8, i9
      parameter (i1  = not(1))      ! -2
      parameter (i2  = int(42))     ! 42
      parameter (i3  = int(-42))    ! -42
      parameter (i4  = int(0.1))    ! 0
      parameter (i5  = int(1.1))    ! 1
      parameter (i6  = int(1.9))    ! 1
      parameter (i7  = int(-1.1))   ! -1
      parameter (i8  = int(-1.9))   ! -1
      parameter (i9  = int(z'10', 4)) ! 16

      return
      end


      SUBROUTINE IFTE4(THA,RP,CP)
      DATA THAO,EPSI /.1,1.E-9 /
      IF(ABS(THA) .LT. THAO) GO TO 100
      D = THA**4/24.
      RP = ((.5*(THA*THA))-1.+ COS(THA))/D
      CP = ((THA**3/6.)-THA+SIN(THA))/D
      RETURN
C
C  EVALUATE SERIES
C
  100 CONTINUE
      RN = 1.0
      D = 1.0
      SIGN = -1.
      RPS = 1.
      TSQ = THA*THA
      T1 = 5.
      T2 = 6.
      IT = 1
  101 CONTINUE
      DO 110 I=1,50
      RN = RN*TSQ
      D = D*T1*T2
      TRM = RN/D*SIGN
      RPS = RPS + TRM
      IF(ABS(TRM) .LT. EPSI) GO TO 120
      SIGN = -SIGN
      T1 = T1+2.
      T2 = T2+2.
  110 CONTINUE
  120 CONTINUE
      IF(IT .EQ. 2) GO TO 125
      RP = RPS
      RN = THA
      D = 5.0
      SIGN = -1.
      RPS = THA/5.
      T1 = 6.
      T2 = 7.
      IT = 2
      GO TO 101
  125 CONTINUE
      CP = RPS
      RETURN
      END


REAL*8 function kern_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
kern_num = sin(sqrt((x_a - x_b)**2/lx**2))
end function
REAL*8 function dkdx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx_num = sqrt((x_a - x_b)**2/lx**2)*cos(sqrt((x_a - x_b)**2/lx**2))/( &
      x_a - x_b)
end function
INTEGER*4 function dkdy_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy_num = 0
end function
REAL*8 function dkdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx0_num = -sqrt((x_a - x_b)**2/lx**2)*cos(sqrt((x_a - x_b)**2/lx**2))/ &
      (x_a - x_b)
end function
INTEGER*4 function dkdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy0_num = 0
end function
REAL*8 function d2kdxdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdx0_num = sin(sqrt((x_a - x_b)**2/lx**2))/lx**2
end function
INTEGER*4 function d2kdydy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdydy0_num = 0
end function
INTEGER*4 function d2kdxdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdy0_num = 0
end function


SUBROUTINE CFFT( DATA, N, IFORW )

  ! complex FFT

  IMPLICIT NONE
  INTEGER I1, I2A, I2B, I3, I3Rev, IP1, IP2, N, ISign, IForw
  REAL    theta, sinth
  COMPLEX DATA( N ), TEMP, W, WSTP

  ISIGN = -IFORW
  I3REV = 1

  DO I3 = 1, N
     IF ( I3 < I3REV ) THEN   ! switch values
        TEMP          = DATA( I3 )
        DATA( I3 )    = DATA( I3REV )
        DATA( I3REV ) = TEMP
     ENDIF
     ! following loop is just to compute I3REV
     IP1 = N / 2
     DO WHILE (  I3REV > IP1 )
        IF ( IP1 <= 1 ) EXIT
        I3REV = I3REV - IP1
        IP1   = IP1 / 2
     END DO
     I3REV = I3REV + IP1
  END DO

  IP1 = 1

  DO WHILE  ( IP1 < N )
     IP2   = IP1 * 2
     THETA = 6.283185307 / FLOAT( ISIGN * IP2 )
     SINTH = SIN( THETA / 2.)
     WSTP  = CMPLX( -2. * SINTH * SINTH, SIN( THETA ) )
     W     = 1.

     DO I1 = 1, IP1
        DO I3 = I1, N, IP2
           I2A = I3
           I2B = I2A + IP1
           TEMP      = W * DATA( I2B )
           DATA( I2B ) = DATA( I2A ) - TEMP
           DATA( I2A ) = DATA( I2A ) + TEMP
        END DO

        W = W * WSTP + W
     END DO

     IP1 = IP2
  END DO

  RETURN
END SUBROUTINE CFFT


program main

    use random_util, only: init_random_seed
    use approx_norm, only: approx_norm1, nsamples

    implicit none
    real(kind=8), allocatable, dimension(:,:) :: a
    real(kind=8) :: colsum, colsum_max, anorm
    integer :: n, seed, i, j

    open(unit=21, file='input_data.txt', status='old')
    read(21,*) n
    read(21,*) seed
    read(21,*) nsamples

    call init_random_seed(seed)

    ! Create random matrix:
    allocate(a(n,n))
    call random_number(a)

    ! Compute 1-norm as max column sum:
    colsum_max = 0.d0
    do j=1,n
        colsum = 0.d0
        do i=1,n
            colsum = colsum + abs(a(i,j))
            enddo
        colsum_max = max(colsum_max, colsum)
        enddo

    ! Estimate 1-norm:
    call approx_norm1(a, anorm)

    print 600, n, colsum_max
600 format("Using matrix with n = ",i5,"   True 1-norm:   ",f16.6)
    print 601, nsamples, anorm
601 format("Based on ",i6," samples, Approximate 1-norm: ",f16.6)

end program main


function Ppvalu ( break, coef, l, k, x, jderiv )

!*****************************************************************************80
!
!! PPVALU evaluates a piecewise polynomial function or its derivative.
!
!  Discussion:
!
!    PPVALU calculates the value at X of the JDERIV-th derivative of
!    the piecewise polynomial function F from its piecewise
!    polynomial representation.
!
!    The interval index I, appropriate for X, is found through a
!    call to INTERV.  The formula for the JDERIV-th derivative
!    of F is then evaluated by nested multiplication.
!
!    The J-th derivative of F is given by:
!      (d^J) F(X) =
!        COEF(J+1,I) + H * (
!        COEF(J+2,I) + H * (
!        ...
!        COEF(K-1,I) + H * (
!        COEF(K,  I) / (K-J-1) ) / (K-J-2) ... ) / 2 ) / 1
!    with
!      H = X - BREAK(I)
!    and
!      I = max ( 1, max ( J, BREAK(J) <= X, 1 <= J <= L ) ).
!
!  Modified:
!
!    16 February 2007
!
!  Author:
!
!    Carl de Boor
!
!  Reference:
!
!    Carl de Boor,
!    A Practical Guide to Splines,
!    Springer, 2001,
!    ISBN: 0387953663,
!    LC: QA1.A647.v27.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) BREAK(L+1), real COEF(*), integer L, the
!    piecewise polynomial representation of the function F to be evaluated.
!
!    Input, integer ( kind = 4 ) K, the order of the polynomial pieces that
!    make up the function F.  The usual value for K is 4, signifying a
!    piecewise cubic polynomial.
!
!    Input, real ( kind = 8 ) X, the point at which to evaluate F or
!    of its derivatives.
!
!    Input, integer ( kind = 4 ) JDERIV, the order of the derivative to be
!    evaluated.  If JDERIV is 0, then F itself is evaluated,
!    which is actually the most common case.  It is assumed
!    that JDERIV is zero or positive.
!
!    Output, real ( kind = 8 ) PPVALU, the value of the JDERIV-th
!    derivative of F at X.
!
  implicit none

  integer ( kind = 4 ) k
  integer ( kind = 4 ) l

  real ( kind = 8 ) break(l+1)
  real ( kind = 8 ) coef(k,l)
  real ( kind = 8 ) fmmjdr
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) jderiv
  integer ( kind = 4 ) m
  integer ( kind = 4 ) ndummy
  real ( kind = 8 ) ppvalu
  real ( kind = 8 ) value
  real ( kind = 8 ) x

  value = 0.0D+00

  fmmjdr = k - jderiv
!
!  Derivatives of order K or higher are identically zero.
!
  if ( k <= jderiv ) then
    return
  end if
!
!  Find the index I of the largest breakpoint to the left of X.
!
  call interv ( break, l+1, x, i, ndummy )
!
!  Evaluate the JDERIV-th derivative of the I-th polynomial piece at X.
!
  h = x - break(i)
  m = k

  do

    value = ( value / fmmjdr ) * h + coef(m,i)
    m = m - 1
    fmmjdr = fmmjdr - 1.0D+00

    if ( fmmjdr <= 0.0D+00 ) then
      exit
    end if

  end do

  ppvalu = value

  return
end


module linear_solve

  implicit none

  public :: lu_decomposition
  public :: lu_back_substitution
  public :: lu_inverse
  public :: imaxloc

  interface lu_decomposition
     module procedure lu_decomposition_real
     module procedure lu_decomposition_complex
  end interface

  interface lu_back_substitution
     module procedure lu_back_substitution_real
     module procedure lu_back_substitution_real_complex
     module procedure lu_back_substitution_complex
  end interface

  interface lu_inverse
     module procedure lu_inverse_real
     module procedure lu_inverse_complex
  end interface

contains

  subroutine lu_decomposition_real (lu, idx, d)

    implicit none

    real, dimension (:,:), intent (in out) :: lu
    integer, dimension (:), intent (out) :: idx
    real, intent (out) :: d

    real, parameter :: zero = 1.0e-20
    real, dimension (size(lu,1)) :: vv
    real, dimension (size(lu,2)) :: dum

    integer :: j, n, imax

    n = size(lu,1)

    d = 1.0
    vv = maxval(abs(lu),dim=2)
    if (any(vv==0.0)) &
         write (*,*) 'singular matrix in lu_decomposition'
    vv = 1.0/vv
    do j = 1, n
       imax = (j-1) + imaxloc(vv(j:n)*abs(lu(j:n,j)))
       if (j /= imax) then
          dum = lu(imax,:)
          lu(imax,:) = lu(j,:)
          lu(j,:) = dum
          d = -d
          vv(imax) = vv(j)
       end if
       idx(j) = imax
       if (lu(j,j)==0.0) lu(j,j) = zero
       lu(j+1:n,j) = lu(j+1:n,j)/lu(j,j)
       lu(j+1:n,j+1:n) = lu(j+1:n,j+1:n) - spread(lu(j+1:n,j),2,n-j) &
            * spread(lu(j,j+1:n),1,n-j)
    end do

  end subroutine lu_decomposition_real

  subroutine lu_decomposition_complex (lu, idx, d)

    implicit none

    complex, dimension (:,:), intent (in out) :: lu
    integer, dimension (:), intent (out) :: idx
    real, intent (out) :: d

    real, parameter :: zero = 1.0e-20
    real, dimension (size(lu,1)) :: vv
    complex, dimension (size(lu,2)) :: dum

    integer :: j, n, imax

    n = size(lu,1)

    d = 1.0
    vv = maxval(cabs(lu),dim=2)
    if (any(vv==0.0)) &
         write (*,*) 'singular matrix in lu_decomposition'
    vv = 1.0/vv
    do j = 1, n
       imax = (j-1) + imaxloc(vv(j:n)*cabs(lu(j:n,j)))
       if (j /= imax) then
          dum = lu(imax,:)
          lu(imax,:) = lu(j,:)
          lu(j,:) = dum
          d = -d
          vv(imax) = vv(j)
       end if
       idx(j) = imax
       if (lu(j,j)==0.0) lu(j,j) = zero
       lu(j+1:n,j) = lu(j+1:n,j)/lu(j,j)
       lu(j+1:n,j+1:n) = lu(j+1:n,j+1:n) - spread(lu(j+1:n,j),2,n-j) &
            * spread(lu(j,j+1:n),1,n-j)
    end do

  end subroutine lu_decomposition_complex

  subroutine lu_back_substitution_real (lu, idx, b)

    implicit none

    real, dimension (:,:), intent (in) :: lu
    integer, dimension (:), intent (in) :: idx
    real, dimension (:), intent (in out) :: b

    integer :: i, n, ii, ll
    real :: summ

    n = size(lu,1)
    ii = 0
    do i = 1, n
       ll = idx(i)
       summ = b(ll)
       b(ll) = b(i)
       if (ii /= 0) then
          summ = summ - dot_product(lu(i,ii:i-1),b(ii:i-1))
       else if (summ /= 0.0) then
          ii = i
       end if
       b(i) = summ
    end do
    do i = n, 1, -1
       b(i) = (b(i) - dot_product(lu(i,i+1:n),b(i+1:n))) / lu(i,i)
    end do

  end subroutine lu_back_substitution_real

  subroutine lu_back_substitution_real_complex (lu, idx, b)

    implicit none

    real, dimension (:,:), intent (in) :: lu
    integer, dimension (:), intent (in) :: idx
    complex, dimension (:), intent (in out) :: b

    integer :: i, n, ii, ll
    complex :: summ

    !! The dot products we use below automatically take the complex conjugate of its
    !! first argument, which we do not want here. Hence the use of conjg to undo this

    n = size(lu,1)
    ii = 0
    do i = 1, n
       ll = idx(i)
       summ = b(ll)
       b(ll) = b(i)
       if (ii /= 0) then
          summ = summ - dot_product(lu(i,ii:i-1),b(ii:i-1))
       else if (summ /= 0.0) then
          ii = i
       end if
       b(i) = summ
    end do
    do i = n, 1, -1
       b(i) = (b(i) - dot_product(lu(i,i+1:n),b(i+1:n))) / lu(i,i)
    end do

  end subroutine lu_back_substitution_real_complex

  subroutine lu_back_substitution_complex (lu, idx, b)

    implicit none

    complex, dimension (:,:), intent (in) :: lu
    integer, dimension (:), intent (in) :: idx
    complex, dimension (:), intent (in out) :: b

    integer :: i, n, ii, ll
    complex :: summ

    !! The dot products we use below automatically take the complex conjugate of its
    !! first argument, which we do not want here. Hence the use of conjg to undo this

    n = size(lu,1)
    ii = 0
    do i = 1, n
       ll = idx(i)
       summ = b(ll)
       b(ll) = b(i)
       if (ii /= 0) then
          summ = summ - dot_product(conjg(lu(i,ii:i-1)),b(ii:i-1))
       else if (summ /= 0.0) then
          ii = i
       end if
       b(i) = summ
    end do
    do i = n, 1, -1
       b(i) = (b(i) - dot_product(conjg(lu(i,i+1:n)),b(i+1:n))) / lu(i,i)
    end do

  end subroutine lu_back_substitution_complex

  !!
  !! One shouldn't need to compute the inverse of a matrix if solving the linear equation A.x = y;
  !! a simply back substitution should suffice.
  !!
  !! Only compute the inverse of A when absolutely necessary!
  !!
  subroutine lu_inverse_real (lu,idx,inverse)

    implicit none

    real, dimension (:,:), intent (in) :: lu
    integer, dimension (:), intent (in) :: idx
    real, dimension (:,:), intent (out) :: inverse

    integer :: i, n

    n = size(lu,1)

    inverse = 0.0
    do i = 1, n
      inverse(i,i) = 1.0
    enddo

    do i = 1, n
      call lu_back_substitution(lu,idx,inverse(:,i))
    enddo

  end subroutine lu_inverse_real

  subroutine lu_inverse_complex (lu,idx,inverse)

    implicit none

    complex, dimension (:,:), intent (in) :: lu
    integer, dimension (:), intent (in) :: idx
    complex, dimension (:,:), intent (out) :: inverse

    integer :: i, n

    n = size(lu,1)

    inverse = 0.0
    do i = 1, n
      inverse(i,i) = 1.0
    enddo

    do i = 1, n
      call lu_back_substitution(lu,idx,inverse(:,i))
    enddo

  end subroutine lu_inverse_complex

  function imaxloc (array)
    real, dimension (:), intent (in) :: array
    integer :: imaxloc
    integer, dimension (1) :: imax
    imax = maxloc(array)
    imaxloc = imax(1)
  end function imaxloc

end module linear_solve


      FUNCTION pmass (xx)
      USE stel_kinds
      USE vmec_input, ONLY: am, bloat,ipmass
      USE vparams, ONLY: mu0
C-----------------------------------------------
      INTEGER     :: i
      REAL(rprec) :: xx, pmass, x
      REAL(rprec), parameter :: one=1
C-----------------------------------------------
!     NOTE: On entry, am is in pascals. pmass internal units are mu0*pascals (B**2 units)
      x = MIN (ABS(xx * bloat), 1._dp)

      pmass = 0

      SELECT CASE(ipmass)
      CASE(0)
       DO i = UBOUND(am,1), LBOUND(am,1), -1
        pmass = x*pmass + am(i)
       END DO
      CASE(1)
       pmass = am(0)*(am(1)*(one/(one+(  x/am(2)**2)**am(3))**am(4)
     >                      -one/(one+(one/am(2)**2)**am(3))**am(4))/
     >                  (one-one/(one+(one/am(2)**2)**am(3))**am(4))+
     >          (one-am(1))*(one/(one+(  x/am(5)**2)**am(6))**am(7)
     >                      -one/(one+(one/am(5)**2)**am(6))**am(7))/
     >                  (one-one/(one+(one/am(5)**2)**am(6))**am(7)))
      CASE DEFAULT
        stop 'pmass: Invalid mass profile selected'
      END SELECT
      pmass = mu0*pmass

      END FUNCTION pmass


MODULE m_legendre2

! ----------------------------------------------------------------------
! MODULE: m_legendre2.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the legendre_drv2 subroutine
!
! Subroutines contained within the module:
! - legendre_drv2
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	18 January 2018
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE legendre2 (phi, nmax, d2Pnm_norm)

! ---------------------------------------------------------------------------
! Subroutine:  legendre2
! ---------------------------------------------------------------------------
! Purpose:
! Computation of the second order derivatives of the Normalized Associated
! Legendre functions
!
! Evaluation of Legendre functions is based on Recurrence relations
! ---------------------------------------------------------------------------
! Input arguments:
! - phi:			Spherical latitude (radians)
! - nmax:			Maximum degree expansion
!
! Output arguments:
! - d2Pnm_norm: 	Second order derivatives of Normalized Associated Legendre
!   				functions up to degree n
! ---------------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	18 January 2018
! ----------------------------------------------------------------------

! Modules used
      USE mdl_precision
      USE mdl_num
      USE m_legendre
      USE m_legendre1

      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int8), INTENT(IN) :: nmax
      REAL (KIND = prec_q), INTENT(IN) :: phi
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: d2Pnm_norm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Pnm_norm, dPnm_norm
      INTEGER (KIND = prec_int8) :: n, m
      INTEGER (KIND = prec_int2) :: AllocateStatus
      REAL (KIND = prec_q) :: pi
      REAL (KIND = prec_q) :: theta, c, s
      REAL (KIND = prec_q) :: dPoo, dP10,dP11, dP_f1,dP_f2,dP_f3, SQRT_nm_prod
      REAL (KIND = prec_q) :: d2Poo, d2P10, d2P11, d2P_f1, d2P_sum, d2P_f2, d2P_f3
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Allocatable arrays
! ----------------------------------------------------------------------
      ALLOCATE (d2Pnm_norm(nmax+1,nmax+1), STAT = AllocateStatus)
!      print *,"dPnm_norm AllocateStatus=", AllocateStatus
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE legendre_drv1.f"
         PRINT *, "Error: Allocatable Array: Pnm_norm, Nmax =", nmax
!         STOP "*** Not enough memory ***"
      END IF
! ----------------------------------------------------------------------
d2Pnm_norm = 0.0D0

! Numerical Constants
pi = PI_global

! Normalized associated Legendre functions
CALL legendre (phi, nmax, Pnm_norm)

! First-order derivatives of the normalized associated Legendre functions
CALL legendre_drv1 (phi, nmax, dPnm_norm)

theta = pi/2D0 - phi
c = cos(theta)
s = sin(theta)

! Initial values
dPoo  = 0.D0
d2Poo = 0.D0

dP10  = - sqrt(3.D0) * s
d2P10 = - sqrt(3.D0) * c

dP11  =  sqrt(3.D0) * c
d2P11 = -sqrt(3.D0) * s

!%-------------------------------------------------------------------------
!% Second order Derivatives for order m=0 and variable degree n
Do n = 0 , nmax
    If (n==0) Then
        d2Pnm_norm(n+1,0+1) = d2Poo
    else if (n==1) Then
        d2Pnm_norm(n+1,0+1) = d2P10
    else
        d2P_f1 = sqrt(2.D0*n-1.D0) * ( c * d2Pnm_norm(n-1+1,0+1) - 2.D0 * s * dPnm_norm(n-1+1,0+1) - c * Pnm_norm(n-1+1,0+1) )
        d2Pnm_norm(n+1,0+1) = (sqrt(2.D0*n+1.D0) / n) * ( d2P_f1 - ( (n-1) / sqrt(2.D0*n-3.D0) ) * d2Pnm_norm(n-2+1,0+1) )
    end If
end Do

!% Second order Derivatives for equal degree n and order m
Do n = 1 , nmax
    if (n == 1) Then
        d2Pnm_norm(n+1,n+1) = d2P11      !%7777777777777777777777777777777777777777777777777777777777777777777
    else
        !% ATTENTION!  correction: sqrt(2*n+1) / sqrt(2*n)      %7777777777777777777777777777777777777777777777777777777777777777777
        d2P_sum = s * d2Pnm_norm(n-1+1,n-1+1) + 2.D0 * c * dPnm_norm(n-1+1,n-1+1) - s * Pnm_norm(n-1+1,n-1+1)
        d2Pnm_norm(n+1,n+1) = ( sqrt(2.D0*n+1.D0) / sqrt(2.D0*n) ) * d2P_sum
    end If
end Do

!% Second order erivatives for variable degree n and order m
Do n = 1 , nmax
    Do m = 1 , n
        if (n >= (m+1) ) Then
            d2P_f2 = c * d2Pnm_norm(n-1+1,m+1) - 2.D0 * s * dPnm_norm(n-1+1,m+1) - c * Pnm_norm(n-1+1,m+1)
            d2P_f3 = sqrt(  ( (n-1+m)*(n-1-m) ) / (2.D0*n-3.D0)  ) * d2Pnm_norm(n-2+1,m+1)
  !% ATTENTION! correction: sqrt(2*n+1) / sqrt( (n+m)*(n-m) )       %7777777777777777777777777777777777777777777777777777777777777777777
            d2Pnm_norm(n+1,m+1) = ( sqrt(2.D0*n+1) / sqrt(1.D0*(n+m)*(n-m)) ) * ( sqrt(2.D0*n-1) * d2P_f2 - d2P_f3 )
        end If
    end Do
end Do

END Subroutine

END MODULE