C++***************************************************************
C	POLY
C Program to fit a Polynomial to a list of data points
C
C Version of 25-02-88
C--**************************************************************
	PROGRAM POLY
	IMPLICIT REAL*8 (A-H,O-Z)
	PARAMETER (IDIM=600)
	REAL*8 XX(IDIM),YY(IDIM),YY1(IDIM),CHEBY(20)
	REAL*8 XC(20),SDEV(20),ERR
        REAL*8 XMIN,XMAX,DELTA,OX,OY
	LOGICAL CHEBYCHEFF
        INTEGER IOPTION,IFORMAT
	CHARACTER ANS*1,IN_FILE*40,IN_COMMENTS*80

	COMMON /CHEBYFIT1/CHEBY,XMIN,XMAX,DELTA
10	FORMAT(A)

	PRINT 88
88	FORMAT(' Program POLY to fit a polynomial to a',
     1	' list of data points',/,
     1	' Version of 25-02-97',/)

C Reading the input file :
	IFORMAT=0
	CALL DREADFILE(XX,YY,NPTS,WORK1,WORK2,NWORK,IDIM,
     1                 IN_FILE,IN_COMMENTS,IFORMAT)

	PRINT *,' Nunmber of input points:',NPTS
	PRINT 90
90	FORMAT(' Two possibilities : Chebycheff or not ',/,
     1	' Do you want Chebycheff ?(Y)')
	READ(5,10) ANS
	CHEBYCHEFF=(ANS.NE.'N'.AND.ANS.NE.'n')

	PRINT *,' Order of the polynomial?'
	READ(5,*) KK

	PRINT 89
89	FORMAT(' Do you want to fit the polynomial',/,
     1	' 1. without transformations',/,
     1  ' 2. in LOG/LOG plane',/,
     1  ' 3. in log-polar coordinates (log spiral?)',/,
     1  ' 4. in polar coordinates (linear spiral?)',/,
     1  ' Enter your choice:')
	READ(5,*) IOPTION

C Taking the logarithm of the input values:

	IF(IOPTION.EQ.3)THEN
          WRITE(6,91)
91        FORMAT('Enter coordinates of center OX, OY:')
          READ(5,*) OX,OY
	  DO I=1,NPTS
           CALL DOUBLE_LOGPOLAR_DEG(XX(I),YY(I),XX(I),YY(I),OX,OY)
          END DO
	ELSEIF(IOPTION.EQ.4)THEN
          WRITE(6,92)
92        FORMAT('Enter coordinates of center OX, OY:')
          READ(5,*) OX,OY
	  DO I=1,NPTS
           CALL DOUBLE_POLAR_DEG(XX(I),YY(I),XX(I),YY(I),OX,OY)
          END DO
	ELSEIF(IOPTION.EQ.2)THEN
	  DO I=1,NPTS
	    XX(I)=DLOG(XX(I))
	    IF(YY(I).LE.0.)THEN
	      NPTS=I-1
	      PRINT *,' Warning: negative values !!!'
	      XXMAX=XX(NPTS)
	      PRINT *,' NPTS=',NPTS,' XXMAX=',XXMAX
	      GO TO 100
	    ELSE
	      YY(I)=DLOG(YY(I))
	    ENDIF
	  END DO
100	ENDIF

C Fitting a polynomial :
	IF(CHEBYCHEFF)THEN

C When ISORTED=1 CHEBYFIT sort the input data into increasing order:
	  ISORTED=1
	  PRINT *,' Fitting a Chebycheff polynomial...'
	  CALL CHEBYFIT(XX,YY,NPTS,KK,ISORTED)

	ELSE

	  PRINT *,' Fitting the Polynomial now ...'
	  CALL POLYFIT(XX,YY,NPTS,KK,XC,SDEV,ERR)

          PRINT *,' rms error: ',ERR
	  DO I=1,KK+1
	  PRINT *,' K:',I,' XC(K):',XC(I),' SDEV(K)',SDEV(I)
          END DO
	ENDIF

	PRINT *,' Number of output points:',NPTS
C Computing the model:
	  IF(CHEBYCHEFF)THEN
	    DO I=1,NPTS
	      CALL CALCHEBY(XX(I),YY1(I),KK)
	    END DO
	  ELSE
	    DO I=1,NPTS
	      CALL CALPOLY(XX(I),YY1(I),XC,KK)
	    END DO
	  ENDIF

C Logarithm:
	  IF(IOPTION.EQ.2)THEN
	    DO I=1,NPTS
	      XX(I)=DEXP(XX(I))
	      YY1(I)=DEXP(YY1(I))
	    END DO
	  ENDIF

C Storing the output in a file :
	OPEN(2,FILE='poly.dat',STATUS='new')
	  DO I=1,NPTS
	   WRITE(2,*)XX(I),YY(I),YY1(I)
	  END DO
	CLOSE(2)
	PRINT *,' Output profile in poly.dat'

	END
C----------------------------------------------------------------------
	include 'jlpsub:chebyfit.for'
	include 'jlpsub:polyfit.for'
	include 'jlpsub:polar_deg.for'


       ! Exponential Map of Tensor Arguments
       ! --------------------------------------------------------
       ! Algorithmic Sources
       ! Miehe(2002): Homogenization of inelastic solid materials
       !    at (nite strains based on incremental minimization
       !    principles. Application
       !    to the texture analysis of polycrystals

       ! --------------------------------------------------------
       ! Author: A. Dutzler, Graz University of Technology
       ! Date:   2018-04-06

       function exp_2(T)
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: exp_2,Eye,N_i
        real(kind=8)  :: tol,I1,I2,I3
        integer :: i

        tol = 1.0d-8
        i = 3

        Eye = identity2(Eye)
        exp_2 = Eye + T + 0.5 * (T*T)

        I1 = T**Eye
        I2 = 0.5*(I1**2-T**T)
        I3 = det(T)

        N_i = Eye
        do while (norm(N_i)/fact(i) .gt. tol)
         ! Cayley-Hamilton recursive formula
         N_i = I1 * T**(i-1) - I2 * T**(i-2) + I3 * T**(i-3)
         exp_2 = exp_2 + 1./fact(i) * N_i

         i = i+1
        end do

       end function exp_2

       function exp_2s(T)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: exp_2s,Eye,N_i
        real(kind=8)  :: tol,I1,I2,I3
        integer :: i

        tol = 1.0d-8
        i = 3

        Eye = identity2(Eye)
        exp_2s = Eye + T + 0.5 * (T*T)

        I1 = T**Eye
        I2 = 0.5*(I1**2-T**T)
        I3 = det(T)

        N_i = Eye
        do while (norm(N_i)/fact(i) .gt. tol)
         ! Cayley-Hamilton recursive formula
         N_i = I1 * T**(i-1) - I2 * T**(i-2) + I3 * T**(i-3)
         exp_2s = exp_2s + 1./fact(i) * N_i

         i = i+1
        end do

       end function exp_2s


*DECK BESI0
      FUNCTION BESI0 (X)
C***BEGIN PROLOGUE  BESI0
C***PURPOSE  Compute the hyperbolic Bessel function of the first kind
C            of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI0-S, DBESI0-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI0(X) computes the modified (hyperbolic) Bessel function
C of the first kind of order zero and real argument X.
C
C Series for BI0        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.46E-18
C                                         log weighted error  17.61
C                               significant figures required  17.90
C                                    decimal places required  18.15
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESI0
      DIMENSION BI0CS(12)
      LOGICAL FIRST
      SAVE BI0CS, NTI0, XSML, XMAX, FIRST
      DATA BI0CS( 1) /   -.0766054725 2839144951E0 /
      DATA BI0CS( 2) /   1.9273379539 93808270E0 /
      DATA BI0CS( 3) /    .2282644586 920301339E0 /
      DATA BI0CS( 4) /    .0130489146 6707290428E0 /
      DATA BI0CS( 5) /    .0004344270 9008164874E0 /
      DATA BI0CS( 6) /    .0000094226 5768600193E0 /
      DATA BI0CS( 7) /    .0000001434 0062895106E0 /
      DATA BI0CS( 8) /    .0000000016 1384906966E0 /
      DATA BI0CS( 9) /    .0000000000 1396650044E0 /
      DATA BI0CS(10) /    .0000000000 0009579451E0 /
      DATA BI0CS(11) /    .0000000000 0000053339E0 /
      DATA BI0CS(12) /    .0000000000 0000000245E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI0
      IF (FIRST) THEN
         NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3))
         XSML = SQRT (4.5*R1MACH(3))
         XMAX = LOG (R1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI0 = 1.0
      IF (Y.GT.XSML) BESI0 = 2.75 + CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0)
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI0',
     +   'ABS(X) SO BIG I0 OVERFLOWS', 1, 2)
C
      BESI0 = EXP(Y) * BESI0E(X)
C
      RETURN
      END


subroutine insertKnot(u, r, t, k, coef, nctl, ndim, t_new, coef_new, ileft)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract insertKnot inserts a knot u into the curve, r times
  !     Adapted from "The NURBS Book" Algorithm 5.1
  !     Description of Arguments
  !     Input
  !     u       - Real, location of knot to insert
  !     r       - Integer, Insert r times
  !     t       - Real,Knot vector. Length nctl+k
  !     k       - Integer,order of B-spline
  !     coef    - Real,Array of B-spline coefficients  Size (ndim,nctl)
  !     nctl    - Integer,Number of control points
  !     ndim    - Integer, dimension of curve

  !     Ouput
  !     t_new    - Real, vector of lenght(nctl+k+r)
  !     coef_new - Real, Array of new cofficients size(ndim,nctl+r)
  !     ileft    - Integer of position of knot insertion

  use precision
  implicit none

  ! Input
  integer            , intent(inout)  :: r
  integer            , intent(in)     :: k, nctl, ndim
  real(kind=realType), intent(in)     :: u
  real(kind=realType), intent(in)     :: t(nctl+k)
  real(kind=realType), intent(in)     :: coef(ndim, nctl)

  ! Output
  real(kind=realType), intent(out)    :: t_new(nctl+k+r)
  real(kind=realType), intent(out)    :: coef_new(ndim, nctl+r)
  integer            , intent(out)    :: ileft

  ! Working
  integer                             :: s, i, j, L
  real(kind=realType)                 :: alpha, temp(ndim, k)

  call findSpan(u, k, t, nctl, ileft)

  ! Compute its multiplicity
  s = 0 ! Knot multiplicity
  mult: do i=0,k-1
     if (abs(t(ileft-i) -u ) < 1e-12) then
        s = s + 1
     else
        exit mult
     end if
  end do mult

  ! We need to make sure that the requested multipliity r, plus
  ! the actual multiplicity of this know is less than (k-1)

  if (s + r + 1 > k) then
     r = k-1-s
  end if

  ! If we *can't* insert the knot, we MUST copy t and coef to t_new
  ! and coef_new and return
  if (r == 0) then
     coef_new(:,1:nctl) = coef(:,1:nctl)
     t_new(1:nctl+k) = t(1:nctl+k)
     return
  end if

  ! --------- Load New Knot Vector -------
  do i=1,ileft
     t_new(i) = t(i)
  end do

  do i=1,r
     t_new(ileft+i) = u
  end do

  do i=ileft+1,nctl+k
     t_new(i+r) = t(i)
  end do

  ! -------- Save unaltered Control Points
  do i=1,ileft-(k-1)
     coef_new(:,i) = coef(:,i)
  end do

  do i=ileft-s,nctl
     coef_new(:,i+r) = coef(:,i)
  end do

  do i=0,k-1-s
     temp(:,i+1) = coef(:,ileft-(k-1)+i)
  end do

  do j=1,r
     L = ileft-(k-1) + j
     do i=0,k-1-j-s
        alpha = (u-t(L+i))/(t(i+ileft+1)-t(L+i))
        temp(:,i+1) = alpha*temp(:,i+2) + (1.0-alpha)*temp(:,i+1)
     end do
     coef_new(:,L) = temp(:,1)
     coef_new(:,ileft+r-j-s) = temp(:,k-j-s)
  end do

  do i=L+1,ileft-s-1
     coef_new(:,i) = temp(:,i-L+1)
  end do

  call findSpan(u, k, t_new, nctl+r, ileft)
end subroutine insertKnot


module harmonics

  use funclib, only: P_lgndr

  implicit none

  public  :: K_cubharm,    &
             K_cubharm1,   &
             K_cubharm2,   &
             rot_init,     &
             rot_final,    &
             rot_integral, &
             plot3d_open,  &
             plot3d_iter,  &
             plot3d_write, &
             rot_wigner_d

  private :: K_prefac

  double precision, parameter, public :: pi          = 3.141592653589793d0
  double precision, parameter, public :: sqrt_pi     = 1.772453850905516d0
  double precision, parameter, public :: pi_inv      = 1.0d0 / pi
  double precision, parameter, public :: sqrt_pi_inv = 1.0d0 / sqrt_pi
  double precision, parameter, public :: pi2         = 2.0d0 * pi
  double precision, parameter, public :: sqrt2       = 1.4142135623731d0
  double precision, parameter, public :: sqrt2_inv   = 1.0d0/sqrt2
  double precision, parameter, public :: EPS         = 1.0d-15

  !--------------------------------------------------------------------!
  !                          cubic harmonics                           !
  !--------------------------------------------------------------------!

  interface K_cubharm
     module procedure K_cubharm1, K_cubharm2
  end interface

  !--------------------------------------------------------------------!
  !                         integeral rotation                         !
  !--------------------------------------------------------------------!

  logical,                                     private :: rot_is_init = .false.
  integer,                                     private :: rot_l_max
  integer,          dimension(:), allocatable, private :: rot_fact

  !--------------------------------------------------------------------!
  !                           visualization                            !
  !--------------------------------------------------------------------!

  logical,                                     private :: p3d_open = .false.
  integer,                                     private :: p3d_nx, p3d_ny, p3d_nz
  integer,                                     private :: p3d_ix, p3d_iy, p3d_iz
  double precision, dimension(:), allocatable, private :: p3d_cx, p3d_cy, p3d_cz
  integer, parameter,                          private :: p3d_unit = 97

contains

  !--------------------------------------------------------------------!
  !                          cubic harmonics                           !
  !                                                                    !
  ! K_{l,m}(\theta,\phi) = C \cdot P_l^{|m|}(cos\theta) \cdot f(m\phi) !
  !                                                                    !
  !   for m >= 0 : f(m\phi) =  \cos(m\phi)                             !
  !       m <  0 : f(m\phi) = -\sin(m\phi)                             !
  !                                                                    !
  !   C = \sqrt{ \frac{2l + 1}{2\pi(1 + \delta_{m,0})}                 !
  !              \cdot \frac{(l - |m|)!}{(l + |m|)!}    }              !
  !                                                                    !
  !--------------------------------------------------------------------!

  function K_cubharm1(l, m, theta, phi) result(K_lm)

    implicit none

    integer,          intent(in) :: l, m
    double precision, intent(in) :: theta, phi
    double precision             :: K_lm

    if ( (theta < 0) .or.(theta > pi) .or. &
         (phi < 0) .or. (phi > pi2) ) then
       write(0,*) 'Error: invalid coordinates in K_cubharm1'
       stop
    end if

    if ( (l<0) .or. (abs(m) > l)) then
       write(0,*) 'Error: invalid parameters in K_cubharm1'
       stop
    end if

    K_lm = K_prefac(l, abs(m)) * P_lgndr(l,abs(m),cos(theta))
    if (m < 0) then
       K_lm = K_lm * sin(abs(m)*phi)
    else
       K_lm = K_lm * cos(m*phi)
    end if

  end function K_cubharm1

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

  function K_cubharm2(l, m, er) result(K_lm)

    implicit none

    integer,                        intent(in) :: l, m
    double precision, dimension(3), intent(in) :: er
    double precision             :: K_lm
    double precision             :: theta, phi

    if (abs(er(1)*er(1)+er(2)*er(2)+er(3)*er(3) - 1.0d0) > EPS) then
       write(0,*) 'Error: K_cubharm2 expects nomalized vector (ex,ey,ez).'
       stop
    end if

    theta = acos(er(3))
    phi   = atan2(er(2),er(1))
    if (phi < 0.0d0) phi = phi + pi2

    K_lm  = K_cubharm1(l, m, theta, phi)

  end function K_cubharm2

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

  function K_prefac(l, m) result(pref)

    implicit none

    integer, intent(in) :: l, m
    double precision    :: pref

    double precision    :: tmp
    integer             :: im, fact

    if ((m<0) .or. (m>l)) then
       write(0,*) 'Error: invalid parameters in K_prefac.'
       stop
    end if

    tmp = 2.0d0*l + 1.0d0
    if (m == 0) then
       pref = sqrt_pi_inv*sqrt(tmp/(tmp+1.0d0))
    else if (m == l) then
       pref = sqrt_pi_inv*sqrt(tmp/(tmp-1.0d0))
       fact = 1
       do im = 2, l+m
          fact = fact * im
       end do
       pref = pref / dble(fact)
    else
       pref = sqrt_pi_inv*sqrt(tmp/(tmp-1.0d0))
       fact = 1
       do im = l-m, l+m
          fact = fact * im
       end do
       pref = pref / dble(fact)
    end if

  end function K_prefac

  !--------------------------------------------------------------------!
  !                Rotation of Slater-Koster integrals                 !
  !--------------------------------------------------------------------!

  subroutine rot_init(l_max)
    !! tabulate factorials

    implicit none

    integer, intent(in) :: l_max
    integer             :: l

    if (rot_is_init) then
       write(0,*) 'Error: double call of rot_init.'
       return
    end if

    ! remember max. l:
    rot_l_max = l_max

    ! tabulate necessary factorials:
    allocate(rot_fact(0:2*l_max))
    rot_fact(0) = 1
    do l = 1, 2*l_max
       rot_fact(l) = rot_fact(l-1)*l
    end do

    rot_is_init = .true.

  end subroutine rot_init

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

  subroutine rot_final()

    implicit none

    if (.not. rot_is_init) then
       write(0,*) 'Warning: nothing to finalize in rot_final.'
       return
    end if

    deallocate( rot_fact )

    rot_is_init = .false.

  end subroutine rot_final

  !--------------------------------------------------------------------!
  ! <l1m1|H|l2m2> = sum_{m=1}^{min(l1,l2)} c_m * (l1,l2,|m|)           !
  !                                                                    !
  ! Ref.: PRB 72 (2005) 165107 and PRB 69 (2004) 233101                !
  !--------------------------------------------------------------------!

  subroutine rot_integral(alpha, cosbeta, l1, m1, l2, m2, n_m, c_m)

    implicit none

    double precision,                   parameter :: EPS_here = 1.0d-6

    double precision,                 intent(in)  :: alpha, cosbeta
    integer,                          intent(in)  :: l1, l2, m1, m2
    integer,                          intent(in)  :: n_m
    double precision, dimension(n_m), intent(out) :: c_m

    integer :: l_min, mp

    if ( (abs(m1)>l1) .or. (abs(m2)>l2) .or. (n_m /= min(l1,l2)+1) &
       .or. (alpha<0.0d0) .or. (alpha>=pi2) .or. (abs(cosbeta)>1.0d0) ) then
       write(0,*) 'Error: inadequate parameters in rot_integral.'
       write(0,*) 'alpha   = ', alpha, alpha-pi2
       write(0,*) 'cosbeta = ', cosbeta
       write(0,*) 'l1, m1  = ', l1, m1
       write(0,*) 'l2, m2  = ', l2, m2
       write(0,*) 'n_m     = ', n_m
       stop
    end if

    l_min = min(l1,l2)
    c_m(1:l_min+1) = 0.0d0

    ! mp == 0
    c_m(1) = 2.0d0*rot_A(m1,alpha)*rot_A(m2,alpha)    &
                  *rot_wigner_d(l1,abs(m1),0,cosbeta) &
                  *rot_wigner_d(l2,abs(m2),0,cosbeta)
    ! mb > 0
    do mp = 1, l_min
       c_m(mp+1) = rot_S(l1,m1,mp,alpha,cosbeta) &
                 * rot_S(l2,m2,mp,alpha,cosbeta) &
                 + rot_T(l1,m1,mp,alpha,cosbeta) &
                 * rot_T(l2,m2,mp,alpha,cosbeta)
    end do

  end subroutine rot_integral

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

  function rot_S(l, m, mp, alpha, cosbeta) result(S)

    implicit none

    integer,          intent(in) :: l, m, mp
    double precision, intent(in) :: alpha, cosbeta
    double precision             :: S

    S = rot_wigner_d(l, abs(m), mp, cosbeta)
    if (mod(mp,2) == 1) S = -S
    S = S + rot_wigner_d(l, abs(m), -mp, cosbeta)
    S = S*rot_A(m,alpha)

  end function rot_S

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

  function rot_T(l, m, mp, alpha, cosbeta) result(T)

    implicit none

    integer,          intent(in) :: l, m, mp
    double precision, intent(in) :: alpha, cosbeta
    double precision             :: T

    T = rot_wigner_d(l, abs(m), mp, cosbeta)
    if (mod(mp,2) == 1) T = -T
    T = T - rot_wigner_d(l, abs(m), -mp, cosbeta)
    T = T*rot_B(m,alpha)

  end function rot_T

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

  function rot_A(m, alpha) result(A)

    implicit none

    integer,          intent(in) :: m
    double precision, intent(in) :: alpha
    double precision             :: A

    double precision, parameter  :: SQRT2_inv = 0.707106781186547d0

    if (m < 0) then
       A = sin(dble(m)*alpha)
       if (abs(mod(m,2)) == 0) A = -A
    else if (m > 0) then
       A = cos(dble(m)*alpha)
       if (abs(mod(m,2)) == 1) A = -A
    else
       A = SQRT2_inv
    end if

  end function rot_A

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

  function rot_B(m, alpha) result(B)

    implicit none

    integer,          intent(in) :: m
    double precision, intent(in) :: alpha
    double precision             :: B

    if (m < 0) then
       B = cos(dble(m)*alpha)
       if (abs(mod(m,2)) == 1) B = -B
    else if (m > 0) then
       B = sin(dble(m)*alpha)
       if (abs(mod(m,2)) == 0) B = -B
    else
       B = 0.0d0
    end if

  end function rot_B

  !--------------------------------------------------------------------!
  ! Call this procedure for values of the Wigner small d function.     !
  ! Tabulated values will be used where available; an analytic         !
  ! function is called else.                                           !
  !--------------------------------------------------------------------!

  function rot_wigner_d(l, m1_in, m2_in, cosbeta) result(d_wigner)

    implicit none

    integer,          intent(in) :: l, m1_in, m2_in
    double precision, intent(in) :: cosbeta
    double precision             :: d_wigner

    integer                      :: m1, m2
    double precision             :: pre, rtmp

    ! if cos(beta) == 1
    if (abs(cosbeta - 1.0d0) < EPS) then
       if (m1_in == m2_in) then
          d_wigner = 1.0d0
       else
          d_wigner = 0.0d0
       end if
       return
    end if

    ! (1)  d(l,m2,m1) = (-1)**(m2-m1) * d(l,m1,m2)
    pre = 1.0d0
    if (abs(m2_in) > abs(m1_in)) then
       m1 = m2_in
       m2 = m1_in
       if (mod(m2-m1, 2) /= 0) pre = -pre
    else
       m1 = m1_in
       m2 = m2_in
    end if

    ! (2)  d(l,-m1,-m2) = (-1)**(m2-m1) * d(l,m1,m2)
    if (m1 < 0) then
       m1 = -m1
       m2 = -m2
       if (mod(m2-m1, 2) /= 0) pre = -pre
    end if

    if ( (l < 0) .or. (m1 < 0) .or. (m1 > l) .or. (abs(m2) > abs(m1)) &
         .or. (abs(cosbeta) > 1.0d0) ) then
       write(0,*) "Error: invalid query in wigner_d table:"
       write(0,*) "       l,m,m'    = ", l, m1, m2
       write(0,*) "       cos(beta) = ", cosbeta
       stop
    end if

                   !  l m1 m2
    l_sel : select case(l)
    case(0)        !  0  0  0
       d_wigner = 1.0d0
    case(1)
       select case(m1)
       case(0)     !  1  0  0
          d_wigner = cosbeta
       case(1)
          select case(m2)
          case(0)  !  1  1  0
             ! note: beta in [0, pi] --> sin(beta) > 0
             d_wigner = -sqrt(0.5d0*(1.0d0 - cosbeta*cosbeta))
          case(-1) !  1  1 -1
             d_wigner = 0.5d0*(1.0d0 - cosbeta)
          case(1)  !  1  1  1
             d_wigner = 0.5d0*(1.0d0 + cosbeta)
          case default
             d_wigner = 0.0d0
             write(0,*) l, m1, m2
             stop 999
          end select ! m2
       case default
          d_wigner = 0.0d0
          write(0,*) l, m1, m2
          stop 998
       end select ! m1
    case(2)
       select case(m1)
       case(0)     !  2  0  0
          d_wigner = 1.5d0*cosbeta*cosbeta - 0.5d0
       case(1)
          select case(m2)
          case(0)  !  2  1  0
             d_wigner = -sqrt(1.5d0*(1.0d0 - cosbeta*cosbeta))*cosbeta
          case(-1) !  2  1 -1
             d_wigner = 0.5d0*(1.0d0 - cosbeta)*(2.0d0*cosbeta + 1.0d0)
          case(1)  !  2  1  1
             d_wigner = 0.5d0*(1.0d0 + cosbeta)*(2.0d0*cosbeta - 1.0d0)
          case default
             d_wigner = 0.0d0
             write(0,*) l, m1, m2
             stop 997
          end select ! m2
       case(2)
          select case(m2)
          case(0)  !  2  2  0
             d_wigner = sqrt(0.375d0)*(1.0d0 - cosbeta*cosbeta)
          case(-1) !  2  2 -1
             d_wigner = -0.5d0*sqrt(1.0d0 - cosbeta*cosbeta)*(1.0d0 - cosbeta)
          case(1)  !  2  2  1
             d_wigner = -0.5d0*sqrt(1.0d0 - cosbeta*cosbeta)*(1.0d0 + cosbeta)
          case(-2) !  2  2 -2
             rtmp     = 0.5d0*(1.0d0 - cosbeta)
             d_wigner = rtmp*rtmp
          case(2)  !  2  2  2
             rtmp     = 0.5d0*(1.0d0 + cosbeta)
             d_wigner = rtmp*rtmp
          case default
             d_wigner = 0.0d0
             write(0,*) l, m1, m2
             stop 996
          end select ! m2
       case default
          d_wigner = 0.0d0
          write(0,*) l, m1, m2
          stop 995
       end select ! m1
    case default
       d_wigner = rot_wigner_d_func(l,m1,m2,cosbeta)
    end select l_sel

    if (abs(d_wigner) > EPS) then
       d_wigner = pre*d_wigner
    else
       d_wigner = 0.0d0
    end if

  end function rot_wigner_d

  !--------------------------------------------------------------------!
  ! implementation of an analytic form of the Wigner small d function  !
  !--------------------------------------------------------------------!

  function rot_wigner_d_func(l, m1_in, m2_in, cosbeta) result(d_wigner)

    ! FIXME !!!
    ! carefully check this function for l > 1 !!!
    ! --> maybe better implement a recursion based function anyway:
    !     see e.g. Blanco et al., J. Mol. Struc. 419 (1997) 19-27
    ! FIXME !!!

    implicit none

    integer,          intent(in) :: l, m1_in, m2_in
    double precision, intent(in) :: cosbeta
    double precision             :: d_wigner

    double precision :: d_pre
    integer          :: itmp, m1, m2
    integer          :: k, k_i, k_f
    double precision :: cos_bo2
    double precision :: sin_bo2

    d_pre = 1.0d0
    if (m1_in < 0) then
       m1 = -m1_in
       m2 = -m2_in
       if (mod(m1-m2, 2) /= 0) d_pre = -d_pre
    else
       m1 = m1_in
       m2 = m2_in
    end if

    if ( (l<0) .or. (m1<0) .or. (m1>l) .or. (abs(m2)>l) &
         .or. (abs(cosbeta)>1.0d0) ) then
       write(0,*) 'Error: invalid arguments in rot_wigner_d'
       print *, 'l,m1,m2', l, m1, m2
       stop
    end if

    ! if cos(beta) == 1
    if (abs(cosbeta - 1.0d0) < EPS) then
       if (m1 == m2) then
          d_wigner = 1.0d0
       else
          d_wigner = 0.0d0
       end if
       return
    end if

    cos_bo2 = 0.5d0*(cosbeta + 1.0d0)
    sin_bo2 = sqrt(1.0d0 - cos_bo2)
    cos_bo2 = sqrt(cos_bo2)

    ! prefactor:
    itmp = rot_fact(l+m1)*rot_fact(l-m1)*rot_fact(l+m2)*rot_fact(l-m2)
    d_pre = d_pre*sqrt(dble(itmp))

    ! TODO:
    ! optimize the following piece of code!!!

    k_i = max(0, m2-m1)
    k_f = min(l-m1, l+m2)
    d_wigner = 0.0d0
    do k = k_i, k_f
       itmp = rot_fact(k)*rot_fact(l+m2-k)*rot_fact(m1-m2+k)*rot_fact(l-m1-k)
       if (mod(m1-m2+k,2)/=0) then
          itmp = -itmp
       end if

       d_wigner = d_wigner + ( cos_bo2**(2*l+m2-m1-2*k) &
                             * sin_bo2**(m1-m2+2*k)     &
                            ) / dble(itmp)

    end do
    if (k_f >= k_i) then
       d_wigner = d_pre * d_wigner
    else
       d_wigner = d_pre
    end if

  end function rot_wigner_d_func

  !--------------------------------------------------------------------!
  !                          3D visualization                          !
  !                                                                    !
  ! usage:    call plot3d_open(...)                                    !
  !           do                                                       !
  !              call plot3d_iter(x, y, z, stat)                       !
  !              call plot3d_write(f(x,y,z), stat)                     !
  !              if (stat == 1) exit                                   !
  !           end do                                                   !
  !                                                                    !
  ! Will create a cube file with a grid of function values of function !
  ! f.  The grid is specified when calling plot3d_open().              !
  !--------------------------------------------------------------------!

  subroutine plot3d_open(outfile, xmin, xmax, ymin, ymax, zmin, zmax, dr)

    implicit none

    character(len=*),   intent(in)  :: outfile
    double precision,   intent(in)  :: xmin, xmax, ymin, ymax, zmin, zmax
    double precision,   intent(in)  :: dr
    integer                         :: i
    double precision                :: x0, y0, z0

    if (p3d_open) then
       write(0,*) 'Error: plot stream already open in plot3d_open.'
       stop
    end if

    p3d_nx = ceiling((xmax-xmin)/dr) + 1
    p3d_ny = ceiling((ymax-ymin)/dr) + 1
    p3d_nz = ceiling((zmax-zmin)/dr) + 1

    x0 = 0.5d0*( xmax + xmin - p3d_nx*dr )
    y0 = 0.5d0*( ymax + ymin - p3d_ny*dr )
    z0 = 0.5d0*( zmax + zmin - p3d_nz*dr )

    open(p3d_unit, file=trim(adjustl(outfile)), action="write", &
         status="replace")

    ! write cube file header:
    write(p3d_unit, *) 'cube file with volumetric data'
    write(p3d_unit, *)
    write(p3d_unit, '(I5,3F12.6)') 1, x0, y0, z0
    write(p3d_unit, '(I5,3F12.6)') p3d_nx, dr, 0.0, 0.0
    write(p3d_unit, '(I5,3F12.6)') p3d_ny, 0.0, dr, 0.0
    write(p3d_unit, '(I5,3F12.6)') p3d_nz, 0.0, 0.0, dr
    write(p3d_unit, '(I5,4F12.6)') 1, 0.0, 0.0, 0.0, 0.0

    ! calculate x,y,z coordinates:
    allocate(p3d_cx(p3d_nx),p3d_cy(p3d_ny),p3d_cz(p3d_nz))
    p3d_cx(1) = xmin
    do i = 2, p3d_nx
       p3d_cx(i) = p3d_cx(i-1) + dr
    end do
    p3d_cy(1) = ymin
    do i = 2, p3d_ny
       p3d_cy(i) = p3d_cy(i-1) + dr
    end do
    p3d_cz(1) = xmin
    do i = 2, p3d_nz
       p3d_cz(i) = p3d_cz(i-1) + dr
    end do

    p3d_open = .true.
    p3d_ix   = 1
    p3d_iy   = 1
    p3d_iz   = 1

  end subroutine plot3d_open

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

  subroutine plot3d_iter(x, y, z, stat)
    ! stat = 0 --- continue
    !        1 --- finish
    !        2 --- insert line break

    implicit none

    double precision, intent(out) :: x, y, z
    integer,          intent(out) :: stat

    if (.not. p3d_open) then
       write(0,*) 'Error: no plot stream open in plot3d_iter.'
       stop
    end if

    stat = 0

    x = p3d_cx(p3d_ix)
    y = p3d_cy(p3d_iy)
    z = p3d_cz(p3d_iz)

    if (mod(p3d_iz,6) == 0) stat = 2

    p3d_iz = mod(p3d_iz, p3d_nz) + 1
    if (p3d_iz == 1) then
       stat = 2
       p3d_iy = mod(p3d_iy, p3d_ny) + 1
       if (p3d_iy == 1) then
          p3d_ix = mod(p3d_ix, p3d_nx) + 1
       end if
    end if

    if ((p3d_ix == 1) .and. (p3d_iy == 1) .and. (p3d_iz == 1)) then
       stat = 1
    end if

  end subroutine plot3d_iter

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

  subroutine plot3d_write(val, stat)

    implicit none

    double precision, intent(in) :: val
    integer,          intent(in) :: stat

    if (.not. p3d_open) then
       write(0,*) 'Error: no plot stream open in plot3d_iter.'
       stop
    end if

    if (stat == 1) then
       write(p3d_unit, '(E12.5,1x)') val
       deallocate(p3d_cx, p3d_cy, p3d_cz)
       p3d_open = .false.
    else
       write(p3d_unit, '(E12.5,1x)', advance='no') val
       if (stat == 2) write(p3d_unit, *)
    end if

  end subroutine plot3d_write

end module harmonics

!!$  subroutine rot_integral_old(alpha, cosbeta, l1, m1, l2, m2, n_m, c_m)
!!$
!!$    implicit none
!!$
!!$    double precision, parameter :: eps_here = 1.0d-6
!!$
!!$    double precision,                 intent(in)  :: alpha, cosbeta
!!$    integer,                          intent(in)  :: l1, l2, m1, m2
!!$    integer,                          intent(in)  :: n_m
!!$    double precision, dimension(n_m), intent(out) :: c_m
!!$
!!$    double precision :: Am1, Am2, Bm1, Bm2, S1, S2, T1, T2
!!$    double precision :: m_alpha, d_wigner
!!$    integer          :: mp
!!$
!!$    if ( (abs(m1)>l1) .or. (abs(m2)>l2) .or. (n_m /= min(l1,l2)+1) &
!!$       .or. (alpha<0.0d0) .or. (alpha>=pi2) .or. (abs(cosbeta)>1.0d0) ) then
!!$       write(0,*) 'Error: inadequate parameters in rot_integral.'
!!$       write(0,*) 'alpha   = ', alpha, alpha-pi2
!!$       write(0,*) 'cosbeta = ', cosbeta
!!$       write(0,*) 'l1, m1  = ', l1, m1
!!$       write(0,*) 'l2, m2  = ', l2, m2
!!$       write(0,*) 'n_m     = ', n_m
!!$       stop
!!$    end if
!!$
!!$    if (.not. rot_is_init) then
!!$       write(0,*) 'Error: rotation procedures not initialized!'
!!$       stop
!!$    end if
!!$
!!$    !-----------------------------------------------!
!!$    ! A and B factors for (m1,alpha) and (m2,alpha) !
!!$    !-----------------------------------------------!
!!$
!!$    if (abs(alpha) < eps_here) then
!!$
!!$       ! m1:
!!$       if (m1 == 0) then
!!$          Am1 = sqrt2_inv
!!$          Bm1 = 0.0d0
!!$       else if (m1 > 0) then
!!$          Am1      = 1.0d0
!!$          Bm1      = 0.0d0
!!$          if (mod(m1,2) /= 0) Am1 = -Am1
!!$       else ! m1 < 0
!!$          Am1      = 0.0d0
!!$          Bm1      = 1.0d0
!!$          if (mod(m1,2) /= 0) Bm1 = -Bm1
!!$       end if
!!$
!!$       ! m2:
!!$       if (m2 == 0) then
!!$          Am2 = sqrt2_inv
!!$          Bm2 = 0.0d0
!!$       else if (m2 > 0) then
!!$          Am2      = 1.0d0
!!$          Bm2      = 0.0d0
!!$          if (mod(m2,2) /= 0) Am2 = -Am2
!!$       else ! m2 < 0
!!$          Am2      = 0.0d0
!!$          Bm2      = 1.0d0
!!$          if (mod(m2,2) /= 0) Bm2 = -Bm2
!!$       end if
!!$
!!$    else ! if alpha > 0
!!$
!!$       ! m1:
!!$       if (m1 == 0) then
!!$          Am1 = sqrt2_inv
!!$          Bm1 = 0.0d0
!!$       else if (m1 > 0) then
!!$          m_alpha = dble(m1)*alpha
!!$          Am1      = cos(m_alpha)
!!$          Bm1      = sin(m_alpha)
!!$          if (mod(m1,2) /= 0) then
!!$             Am1 = -Am1
!!$             Bm1 = -Bm1
!!$          end if
!!$       else ! m1 < 0
!!$          m_alpha = dble(m1)*alpha
!!$          Am1      = sin(m_alpha)
!!$          Bm1      = cos(m_alpha)
!!$          if (mod(m1,2) /= 0) then
!!$             Am1 = -Am1
!!$             Bm1 = -Bm1
!!$          end if
!!$       end if
!!$
!!$       ! m2:
!!$       if (m2 == 0) then
!!$          Am2 = sqrt2_inv
!!$          Bm2 = 0.0d0
!!$       else if (m2 > 0) then
!!$          m_alpha = dble(m2)*alpha
!!$          Am2      = cos(m_alpha)
!!$          Bm2      = sin(m_alpha)
!!$          if (mod(m2,2) /= 0) then
!!$             Am2 = -Am2
!!$             Bm2 = -Bm2
!!$          end if
!!$       else ! m2 < 0
!!$          m_alpha = dble(m2)*alpha
!!$          Am2      = sin(m_alpha)
!!$          Bm2      = cos(m_alpha)
!!$          if (mod(m2,2) /= 0) then
!!$             Am2 = -Am2
!!$             Bm2 = -Bm2
!!$          end if
!!$       end if
!!$
!!$    end if
!!$
!!$    !---------------------------!
!!$    ! coefficient for (l1,l2,0) !
!!$    !---------------------------!
!!$
!!$    c_m(1) = 2.0d0*Am1*Am2*rot_wigner_d(l1,abs(m1),0,cosbeta) &
!!$           * rot_wigner_d(l2,abs(m2),0,cosbeta)
!!$
!!$    ! loop over `m prime' mp:
!!$    mprime : do mp = 1, min(l1, l2)
!!$
!!$       !---------------------------------------------------!
!!$       ! S and T factors for (l1,m1,mp) and for (l2,m2,mp) !
!!$       !---------------------------------------------------!
!!$
!!$       ! l1, m1:
!!$       d_wigner = rot_wigner_d(l1,abs(m1),mp,cosbeta)
!!$       if (mod(mp,2) == 0) then
!!$          S1 = d_wigner
!!$       else
!!$          S1 = -d_wigner
!!$       end if
!!$       d_wigner = rot_wigner_d(l1,abs(m1),-mp,cosbeta)
!!$       if (m1 == 0) then
!!$          T1 = 0.0d0
!!$       else
!!$          T1 = Bm1 * (S1 - d_wigner)
!!$       end if
!!$       S1 = Am1 * (S1 + d_wigner)
!!$
!!$       ! l2, m2:
!!$       d_wigner = rot_wigner_d(l2,abs(m2),mp,cosbeta)
!!$       if (mod(mp,2) == 0) then
!!$          S2 = d_wigner
!!$       else
!!$          S2 = -d_wigner
!!$       end if
!!$       d_wigner = rot_wigner_d(l2,abs(m2),-mp,cosbeta)
!!$       if (m2 == 0) then
!!$          T2 = 0.0d0
!!$       else
!!$          T2 = Bm2 * (S2 - d_wigner)
!!$       end if
!!$       S2 = Am2 * (S2 + d_wigner)
!!$
!!$       !-------------------------------------------!
!!$       ! calculate coefficient for current m prime !
!!$       !-------------------------------------------!
!!$
!!$       c_m(mp+1) = (S1*S2 + T1*T2)
!!$
!!$    end do mprime
!!$
!!$  end subroutine rot_integral_old


module mod_chkdiv
  use mpi
  use mod_common_mpi, only: myid,coord,ierr
  use mod_types
  implicit none
  private
  public chkdiv
  contains
  subroutine chkdiv(n,dli,dzfi,u,v,w,divtot,divmax)
    !
    ! checks the divergence of the velocity field
    !
    implicit none
    integer , intent(in), dimension(3) :: n
    real(rp), intent(in), dimension(3) :: dli
    real(rp), intent(in), dimension(0:) :: dzfi
    real(rp), intent(in), dimension(0:,0:,0:) :: u,v,w
    real(rp), intent(out) :: divtot,divmax
    real(rp) :: dxi,dyi,div!,dzi,div
    integer :: i,j,k,im,jm,km
    !integer :: ii,jj
    !
    dxi = dli(1)
    dyi = dli(2)
    !dzi = dli(3)
    divtot = 0.
    divmax = 0.
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(n,u,v,w,dxi,dyi,dzfi) &
    !$OMP PRIVATE(i,j,k,im,jm,km,div) &
    !$OMP REDUCTION(+:divtot) &
    !$OMP REDUCTION(max:divmax)
    do k=1,n(3)
       km = k-1
       do j=1,n(2)
          jm = j-1
          do i=1,n(1)
             im = i-1
             div = (w(i,j,k)-w(i,j,km))*dzfi(k) + &
                   (v(i,j,k)-v(i,jm,k))*dyi     + &
                   (u(i,j,k)-u(im,j,k))*dxi
             divmax = max(divmax,abs(div))
             divtot = divtot + div
             !ii = coord(1)*n(1)+i
             !jj = coord(2)*n(2)+j
             !if(abs(div).ge.1.e-12) print*,div,'Large divergence at grid cell: ',ii,jj,k,div
          enddo
       enddo
    enddo
    !$OMP END PARALLEL DO
    call mpi_allreduce(MPI_IN_PLACE,divtot,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    call mpi_allreduce(MPI_IN_PLACE,divmax,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
    if(myid.eq.0) print*, 'Total divergence = ', divtot, '| Maximum divergence = ', divmax
    return
  end subroutine chkdiv
end module mod_chkdiv


      SUBROUTINE DTRC2C (B,NB,C1,YTAB, YPTAB)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 DTRC2C Krogh   Declared all vars.
C>> 1994-10-20 DTRC2C Krogh  Changes to use M77CON
C>> 1987-12-09 DTRC2C Lawson  Initial code.
c--D replaces "?": ?TRC2C, ?C2BAS
c          Given C1() containing coefficients relative to a
c     cubic B-spline basis, this subr computes and stores into
c     YTAB() and YPTAB()  respectively, the value and first derivative
c     of the spline curve at each nodal point given in B().
C     INPUT..
C     (B(I),I=1,NB)     PARTITION POINTS,INCLUDING ENDPOINTS
C     NB                NO. OF POINTS IN B().
C                       NO. OF SEGMENTS IS NSEG = NB-1
c     (C1(I),I=1,NB+2)   Coefficients relative to a cubic B-spline basis
C
C     OUTPUT..
c     (YTAB(i),i=1,NB) and (YPTAB(i),i=1,NB)
c                    Values of spline function and its first
c                    derivative at the points given in B().
c                    YTAB(2*j-1) = f(B(j),   YPTAB(2*j) = fprime(B(j)).
c     ------------------------------------------------------------------
c     Based on code written by Lawson, Hanson, Lang, and Campbell, JPL,
c     1968-1974.
c     Modified July 1984 and July 1987 by C. L. Lawson, JPL, for
c     inclusion in the MATH 77 library.
c     ------------------------------------------------------------------
c     Subprogram referenced:  DC2BAS
c     ------------------------------------------------------------------
      integer NB, MB, NSEG, IB, ISEG, ISEGM1, IDERIV, I
      double precision B(NB), C1(NB+2), YTAB(NB), YPTAB(NB), P(4)
      double precision SUM, ZERO
      logical NEWSEG
      parameter( ZERO = 0.0D0)
c     ------------------------------------------------------------------
      MB=NB
      NSEG=MB-1
      do 30  IB=1,MB
         ISEG=min(NSEG,IB)
         ISEGM1=ISEG-1
         NEWSEG = .TRUE.
         do 20  IDERIV=0,1
            call DC2BAS(B(IB), IDERIV, ISEG, NEWSEG, B, NB, P)
            SUM=ZERO
            do 10  I=1,4
               SUM = SUM + C1(ISEGM1+I)*P(I)
   10       continue
            if(IDERIV .eq. 0) then
               YTAB(IB) = SUM
            else
               YPTAB(IB) = SUM
            endif
   20    continue
   30 continue
      return
      end


Module GRID
integer, parameter :: nlev = 100  !Number of vertical layers

real,    parameter :: hmax = 250d0  !Maximal depth (positive)

!Grid position (m, negative) at r points
real               :: Z_r(nlev)  = 0.d0

!Grid position (m, negative) at w points
real               :: Z_w(0:nlev)= 0.d0

!Grid height (m, positive)
real               :: Hz(nlev)   = 0.d0

contains

subroutine setup_grid
implicit none

real,    parameter  :: thetaS = 2.d0!Surface stretching parameter

! Local scratch variable:
integer                :: i
real                   :: sc_r, C_sig

Z_w(0) = -hmax

!Following Song and Haidvogel (1994). sinh is the hyperbolic sin function
do i   = 1,nlev
    sc_r  = (float(i-nlev) - 0.5)/float(nlev)
   C_sig  = sinh(thetaS*sc_r)/sinh(thetaS)      ! -1 < C_sig < 0
   Z_r(i) = C_sig*hmax
    sc_r  = (float(i-nlev))/float(nlev)
   C_sig  = sinh(thetaS*sc_r)/sinh(thetaS)      ! -1 < C_sig < 0
   Z_w(i) = C_sig*hmax
    Hz(i) = Z_w(i) - Z_w(i-1)
enddo
end subroutine setup_grid
end module GRID


Function fdbel(s)
  Parameter (srt0=2.012)
  If (s<=srt0**2) Then
    fdbel = 0.
  Else
    fdbel = 2500.*exp(-(s-7.93)**2/0.003) + 300.*exp(-(s-7.93)**2/0.1) + 10.
  End If
  Return
End Function fdbel


module test2008_37_convert_mod
implicit none
contains
function cels_from_fahr(degrees_fahr) result(degrees_cels)
real, intent(in) :: degrees_fahr
real             :: degrees_cels
degrees_cels = (degrees_fahr-32)/1.8
end function cels_from_fahr
end module test2008_37_convert_mod

program xtemperature
use test2008_37_convert_mod, only: cels_from_fahr
real    :: deg
integer :: i
write (*,"(2a10)") "degrees_F","degrees_C"
do i=12,100,20
   deg = real(i)
   write (*,"(2f10.1)") deg,cels_from_fahr(deg)
end do
end program xtemperature


subroutine diff(x,n,v)
implicit none;
 integer ::i,n ;
 double precision,dimension(n)::x,v;
 do i=1,(n+2)/2
v(i)=x(i+1)-x(i);
v(n-i+1)=x(n-i+1)-x(n-i);
end do;
v(n/2+1)=0.5*(v(n/2)+v(n/2+2));
return;
end subroutine


module search
  use statistics

contains

  pure recursive integer function binary_search(A, key) result(imid)
    !! Returns the index of the key if it is found in the array A. If the key is not found, -1 is returned.
    integer, intent(in) :: A(:)
    integer, intent(in) :: key

    integer :: imin, imax

    imin = lbound(A,1)
    imax = ubound(A,1)
    imid = -1

    if (imax < imin) then
       ! No match found
       return
    else
       imid = median(A)

       if (A(imid) > key) then
          ! Search left
          imid = binary_search(A(imin:imid-1), key)
       else if (A(imid) < key) then
          ! Search right
          imid = binary_search(A(imid+1:imax), key)
       else
          ! Match found
          return
       end if
    end if

  end function binary_search

end module search


subroutine fine_to_coarse_res(r_h, nx, ny, xi_h, xf_h, xi_2h, xf_2h, r_2h)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi_h, xf_h, xi_2h, xf_2h
real(kind=dp), intent(in), dimension(nx,xi_h-1:xf_h+1):: r_h
real(kind=dp), intent(out), dimension(nx/2+1,xi_2h-1:xf_2h+1):: r_2h
integer:: i,j, imax

imax = nx/2+1

! Apply full weighting to get interpolated values from fine to coarse grid
! Input
! r_h   Variable in fine grid
! f     Right Hand Side
! hx, hy     grid spacing
!
! Output
! r_2h     Variable in coarse grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Indices Rechecked on Jan 13, 2013

do j = xi_2h,xf_2h

    do i = 2,nx/2

        r_2h(i,j) = (r_h(2*i-2,2*j-2) + r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-2) + r_h(2*i-1,2*j-1))

     end do

end do

call exchange_data(r_2h, imax, xi_2h, xf_2h)

end subroutine


 PROGRAM LIFE_2D
   IMPLICIT NONE

   INTEGER, PARAMETER :: gridsize = 10
   LOGICAL :: cells(0:gridsize+1,0:gridsize+1) = .FALSE.
   INTEGER :: i, j, generation=0
   REAL :: rnums(gridsize,gridsize)

 !  Start patterns
 !  **************
 !  cells(2,1:3) = .TRUE.                                                  ! Blinker
 !  cells(3,4:6) = .TRUE. ; cells(4,3:5) = .TRUE.                          ! Toad
 !  cells(1,2) = .TRUE. ; cells(2,3) = .TRUE. ; cells(3,1:3) = .TRUE.      ! Glider
    cells(3:5,3:5) = .TRUE. ; cells(6:8,6:8) = .TRUE.                      ! Figure of Eight
 !  CALL RANDOM_SEED
 !  CALL RANDOM_NUMBER(rnums)
 !  WHERE (rnums>0.6) cells(1:gridsize,1:gridsize) = .TRUE.                ! Random universe

   CALL Drawgen(cells(1:gridsize, 1:gridsize), generation)
   DO generation = 1, 8
      CALL Nextgen(cells)
      CALL Drawgen(cells(1:gridsize, 1:gridsize), generation)
   END DO

 CONTAINS

   SUBROUTINE Drawgen(cells, gen)
     LOGICAL, INTENT(IN OUT) :: cells(:,:)
     INTEGER, INTENT(IN) :: gen

     WRITE(*, "(A,I0)") "Generation ", gen
     DO i = 1, SIZE(cells,1)
        DO j = 1, SIZE(cells,2)
           IF (cells(i,j)) THEN
              WRITE(*, "(A)", ADVANCE = "NO") "#"
           ELSE
              WRITE(*, "(A)", ADVANCE = "NO") " "
           END IF
        END DO
        WRITE(*,*)
     END DO
     WRITE(*,*)
   END SUBROUTINE Drawgen

  SUBROUTINE Nextgen(cells)
     LOGICAL, INTENT(IN OUT) :: cells(0:,0:)
     LOGICAL :: buffer(0:SIZE(cells, 1)-1, 0:SIZE(cells, 2)-1)
     INTEGER :: neighbours, i, j

     buffer = cells   ! Store current status
     DO i = 1, SIZE(cells, 1)-2
        DO j = 1, SIZE(cells, 2)-2
          if(buffer(i, j)) then
            neighbours = sum(count(buffer(i-1:i+1, j-1:j+1), 1)) - 1
          else
            neighbours = sum(count(buffer(i-1:i+1, j-1:j+1), 1))
          end if

          SELECT CASE(neighbours)
            CASE (0:1, 4:8)
               cells(i,j) = .FALSE.

            CASE (2)
               ! No change

            CASE (3)
               cells(i,j) = .TRUE.
          END SELECT

        END DO
     END DO
  END SUBROUTINE Nextgen

 END PROGRAM LIFE_2D


      SUBROUTINE DRMVMEAN(X,NPTS,XMSG,IER)
      IMPLICIT NONE

c remove the series mean from a series
c NCL:  xNew = rmv_mean (x)

C input
      INTEGER NPTS,IER
      DOUBLE PRECISION XMSG
C input/output
      DOUBLE PRECISION X(NPTS)

C local
      INTEGER NPTUSE,N
      DOUBLE PRECISION XMEAN,XVAR,XSD

      CALL DSTAT2(X,NPTS,XMSG,XMEAN,XVAR,XSD,NPTUSE,IER)

      IF (IER.EQ.0) THEN
          DO N = 1,NPTS
              IF (X(N).NE.XMSG) X(N) = X(N) - XMEAN
          END DO
      END IF

      RETURN
      END
c -------------------------------------------------------------
      SUBROUTINE DRMVMED(X,WORK,NPTS,XMSG,IER)
      IMPLICIT NONE

c remove the series median from a series
c NCL:  xNew = rmv_median (x)

C input
      INTEGER NPTS,IER
      DOUBLE PRECISION XMSG
C input/output
      DOUBLE PRECISION X(NPTS)
      DOUBLE PRECISION WORK(NPTS)

C local
      INTEGER NPTUSE,N
      DOUBLE PRECISION XMEDIAN,XMRANGE,XRANGE

      CALL DMEDMRNG(X,WORK,NPTS,XMSG,XMEDIAN,XMRANGE,XRANGE,NPTUSE,IER)

      IF (IER.EQ.0) THEN
          DO N = 1,NPTS
              IF (X(N).NE.XMSG) X(N) = X(N) - XMEDIAN
          END DO
      END IF

      RETURN
      END
c -------------------------------------------------------------
      SUBROUTINE DXSTND(X,NPTS,XMSG,IOPT,IER)
      IMPLICIT NONE

c remove the mean from a series and standardize by the
c .   standardize by the standard deviation (sample or pop)

c NCL:  xNew = standardize(x,iopt)

C input
      INTEGER NPTS,IOPT,IER
      DOUBLE PRECISION XMSG
C input/output
      DOUBLE PRECISION X(NPTS)

C local
      INTEGER NPTUSE,N
      DOUBLE PRECISION XMEAN,XVAR,XSD,RN

      CALL DSTAT2(X,NPTS,XMSG,XMEAN,XVAR,XSD,NPTUSE,IER)

      IF (IOPT.EQ.1 .AND. NPTUSE.GT.1) THEN
          RN = NPTUSE
C population std deviation
          XSD = SQRT(((RN-1.D0)*XVAR)/RN)
      END IF

      IF (IER.EQ.0 .AND. XSD.GT.0.) THEN
          DO N = 1,NPTS
              IF (X(N).NE.XMSG) X(N) = (X(N)-XMEAN)/XSD
          END DO
      END IF

      RETURN
      END


! Program to test MOD and MODULO intrinsics
subroutine integertest (ops, res)
   implicit none
   integer, dimension(2) :: ops
   integer, dimension(2) :: res

   if ((mod(ops(1), ops(2)) .ne. res(1)) .or. &
       (modulo(ops(1), ops(2)) .ne. res(2))) call abort
end subroutine

subroutine real4test (ops, res)
   implicit none
   real(kind=4), dimension(2) :: ops
   real(kind=4), dimension(2) :: res

   if (diff(mod(ops(1), ops(2)), res(1)) .or. &
       diff(modulo(ops(1), ops(2)), res(2))) call abort
contains
function diff(a, b)
  real(kind=4) :: a, b
  logical diff

  diff = (abs (a - b) .gt. abs(a * 1e-6))
end function
end subroutine

subroutine real8test (ops, res)
   implicit none
   real(kind=8), dimension(2) :: ops
   real(kind=8), dimension(2) :: res

   if (diff(mod(ops(1), ops(2)), res(1)) .or. &
       diff(modulo(ops(1), ops(2)), res(2))) call abort
contains
function diff(a, b)
  real(kind=8) :: a, b
  logical diff

  diff = (abs(a - b) .gt. abs(a * 1e-6))
end function
end subroutine

program mod_modulotest
   implicit none

   call integertest ((/8, 5/), (/3, 3/))
   call integertest ((/-8, 5/), (/-3, 2/))
   call integertest ((/8, -5/), (/3, -2/))
   call integertest ((/-8, -5/), (/-3, -3/))
   call integertest ((/ 2, -1/), (/0, 0/))

   call real4test ((/3.0, 2.5/), (/0.5, 0.5/))
   call real4test ((/-3.0, 2.5/), (/-0.5, 2.0/))
   call real4test ((/3.0, -2.5/), (/0.5, -2.0/))
   call real4test ((/-3.0, -2.5/), (/-0.5, -0.5/))
   call real4test ((/ 2.0, -1.0/), (/ 0.0, 0.0 /))

   call real8test ((/3.0_8, 2.5_8/), (/0.5_8, 0.5_8/))
   call real8test ((/-3.0_8, 2.5_8/), (/-0.5_8, 2.0_8/))
   call real8test ((/3.0_8, -2.5_8/), (/0.5_8, -2.0_8/))
   call real8test ((/-3.0_8, -2.5_8/), (/-0.5_8, -0.5_8/))
   call real8test ((/ 2.0_8, -1.0_8/), (/ 0.0_8, 0.0_8 /))

   ! Check large numbers
   call real4test ((/2e34, 1.0/), (/0.0, 0.0/))
   call real4test ((/2e34, 1.5e34/), (/0.5e34, 0.5e34/))
end program


	SUBROUTINE GDXLEN ( np, rlat, rlon, rlen, iret )
C************************************************************************
C* GDXLEN								*
C*									*
C* This subroutine computes the length of a line joining the input	*
C* points.								*
C*									*
C* GDXLEN  ( NP, RLAT, RLON, RLEN, IRET )				*
C*									*
C* Input parameters:							*
C*									*
C*	NP           INTEGER	Number of points			*
C*      RLAT (NP)    REAL	Array of latitudes of the points	*
C*	RLON (NP)    REAL	Array of longitudes of the points	*
C*									*
C* Output parameters:							*
C*	RLEN	     REAL	Length (m) of the line segment		*
C*	IRET	     INTEGER	Return code				*
C*				  0 = normal return			*
C*			         -9 = no points				*
C**									*
C* Log:									*
C* K. F. Brill/GSC       7/89						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		rlat ( np ), rlon ( np )
C------------------------------------------------------------------------
	iret = 0
C*
	IF ( np .le. 1 ) THEN
	  iret = -9
	  RETURN
	END IF
C*
	rlen = 0.0
	DO k = 2, np
	  avgphi = .5 * ( rlat ( k-1 ) + rlat ( k ) ) * DTR
	  cosphi = COS ( avgphi )
	  dlam = ( rlon ( k ) - rlon ( k-1 ) ) * cosphi
	  dphi = rlat ( k ) - rlat ( k-1 )
	  dd = sqrt ( dlam * dlam + dphi * dphi )
	  rlen = rlen + dd
	END DO
C*
	rlen = rlen * RADIUS * DTR
C*
	RETURN
	END


      DOUBLE PRECISION FUNCTION slGMSA (DATE, UT)
*+
*     - - - - - -
*      G M S A
*     - - - - - -
*
*  Conversion from Universal Time to Greenwich mean sidereal time,
*  with rounding errors minimized.
*
*  double precision
*
*  Given:
*    DATE    d      UT1 date (MJD: integer part of JD-2400000.5))
*    UT      d      UT1 time (fraction of a day)
*
*  The result is the Greenwich mean sidereal time (double precision,
*  radians, in the range 0 to 2pi).
*
*  There is no restriction on how the UT is apportioned between the
*  DATE and UT arguments.  Either of the two arguments could, for
*  example, be zero and the entire date+time supplied in the other.
*  However, the routine is designed to deliver maximum accuracy when
*  the DATE argument is a whole number and the UT lies in the range
*  0 to 1 (or vice versa).
*
*  The algorithm is based on the IAU 1982 expression (see page S15 of
*  the 1984 Astronomical Almanac).  This is always described as giving
*  the GMST at 0 hours UT1.  In fact, it gives the difference between
*  the GMST and the UT, the steady 4-minutes-per-day drawing-ahead of
*  ST with respect to UT.  When whole days are ignored, the expression
*  happens to equal the GMST at 0 hours UT1 each day.  Note that the
*  factor 1.0027379... does not appear explicitly but in the form of
*  the coefficient 8640184.812866, which is 86400x36525x0.0027379...
*
*  In this routine, the entire UT1 (the sum of the two arguments DATE
*  and UT) is used directly as the argument for the standard formula.
*  The UT1 is then added, but omitting whole days to conserve accuracy.
*
*  See also the routine slGMST, which accepts the UT as a single
*  argument.  Compared with slGMST, the extra numerical precision
*  delivered by the present routine is unlikely to be important in
*  an absolute sense, but may be useful when critically comparing
*  algorithms and in applications where two sidereal times close
*  together are differenced.
*
*  Called:  slDA2P
*
*  P.T.Wallace   Starlink   14 October 2001
*
*  Copyright (C) 2001 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE,UT

*  Seconds of time to radians
      DOUBLE PRECISION S2R
      PARAMETER (S2R=7.272205216643039903848712D-5)

      DOUBLE PRECISION D1,D2,T
      DOUBLE PRECISION slDA2P

*  Julian centuries since J2000.
      IF (DATE.LT.UT) THEN
         D1=DATE
         D2=UT
      ELSE
         D1=UT
         D2=DATE
      END IF
      T=(D1+(D2-51544.5D0))/36525D0

*  GMST at this UT1.
      slGMSA=slDA2P(S2R*(24110.54841D0+
     :                         (8640184.812866D0+
     :                         (0.093104D0
     :                         -6.2D-6*T)*T)*T
     :                         +86400D0*(MOD(D1,1D0)+MOD(D2,1D0))))

      END


c     program DRDRANR
c>> 2001-05-22 DRDRANR Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRDRANR  Krogh Added external statement.
c>> 1994-10-19 DRDRANR  Krogh  Changes to use M77CON
c>> 1987-12-09 DRDRANR  Lawson  Initial Code.
c--D replaces "?": DR?RANR, ?RANR, ?STAT1, ?STAT2
c
c     Driver to demonstrate use of  DRANR to generate random numbers
c     from the Rayleigh distribution with parameter, ALPHA.
c     Program computes histogram for N numbers
c
      integer NCELLS
      parameter(NCELLS = 13+2)
      external DRANR
      double precision  ALPHA, DRANR, ONE, PIOV2
      double precision  STATS(5), TWO, Y1, Y2, YTAB(1), ZERO
      integer  I, IHIST(NCELLS), N
c
      parameter(ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0)
      data       N / 10000/
      data  Y1, Y2 /  0.0D0,  4.33333D0/
      data   ALPHA / 1.0D0 /
c     ------------------------------------------------------------------
      PIOV2 = TWO * atan(ONE)
      STATS(1) = ZERO
      do 20 I=1,N
c                             Get random number
         YTAB(1) =  DRANR(ALPHA)
c
c                          Accumulate statistics and histogram.
c
        call DSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
   20 continue
c                          Print the statistics and histogram.
c
      print '(13x,a)', 'Rayleigh random numbers from DRANR'
      print '(13x,a,g12.4)','with ALPHA = ',ALPHA
      print '(1x,a/13x,g13.5,a,g13.5/1x)',
     * 'The Mean and Std. Dev. of the theoretical distribution are',
     * ALPHA * sqrt(PIOV2), ' and ',ALPHA * sqrt(TWO - PIOV2)
      call DSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
module gaussian_latitudes_and_weights_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        MACHINE_EPSILON, &
        PI, HALF_PI, &
        even

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: compute_gaussian_latitudes_and_weights, gaqd

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: HALF = 0.5_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp
    real(wp), parameter :: THREE = 3.0_wp

    interface gaqd
        module procedure compute_gaussian_latitudes_and_weights
    end interface

contains

    !     This version of compute_gaussian_latitudes_and_weights implements
    !     the method presented in:
    !
    !     P. N. Swarztrauber, Computing the points and weights for
    !     Gauss-Legendre quadrature, SIAM J. Sci. Comput.,
    !     24(2002) pp. 945-954.
    !
    !     The w and lwork arrays are dummy and included only to
    !     permit a simple pluggable exchange with the
    !     old compute_gaussian_latitudes_and_weights in previous versions of SPHEREPACK
    !
    !
    !     gauss points and weights are computed using the fourier-newton
    !     described in "on computing the points and weights for
    !     gauss-legendre quadrature", paul n. swarztrauber, siam journal
    !     on scientific computing that has been accepted for publication.
    !     This routine is faster and more accurate than older program
    !     with the same name.
    !
    !     subroutine compute_gaussian_latitudes_and_weights
    !     computes the nlat gaussian colatitudes and weights.
    !     The colatitudes are in radians and lie in the
    !     in the interval (0, pi).
    !
    !     input parameters
    !
    !     nlat    the number of gaussian colatitudes in the interval (0, pi)
    !             (between the two poles).  nlat must be greater than zero.
    !
    !     output parameters
    !
    !     theta   a real array with length nlat
    !             containing the gaussian colatitudes in
    !             increasing radians on the interval (0, pi).
    !
    !     wts     a real array with lenght nlat
    !             containing the gaussian weights.
    !
    !     ierror = 0 no errors
    !            = 1 if nlat <= 0
    !
    pure subroutine compute_gaussian_latitudes_and_weights(nlat, theta, wts, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        real(wp),    intent(out) :: theta(nlat)
        real(wp),    intent(out) :: wts(nlat)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)         :: i, it, nix, start_index
        integer(ip)         :: nhalf, half_nlat
        real(wp), parameter :: SQRT3 = sqrt(THREE)
        real(wp)            :: dt, half_dt
        real(wp)            :: zprev, zlast, eff_zero
        real(wp)            :: zhold, pb, dpb, dcor, cz
        real(wp)            :: eps, sgnd

        !  Check calling arguments
        if (nlat <= 0) then
            ierror = 1
        else
            ierror = 0
        end if

        ! Check error flag
        if (ierror /= 0) return

        !  compute weights and points analytically when nlat=1, 2
        select case (nlat)
            case(1)
                theta = HALF_PI
                wts = TWO
            case(2)
                theta(1) = acos(SQRT3/3)
                theta(2) = acos(-SQRT3/3)
                wts = ONE
            case default
                eps = sqrt(MACHINE_EPSILON)
                eps = eps * sqrt(eps)
                half_nlat = nlat/2
                nhalf = (nlat + 1)/2
                start_index = half_nlat + 1

                call compute_fourier_coefficients(nlat, cz, theta(start_index:), wts(start_index:))

                dt = HALF_PI/nhalf
                half_dt = dt/2

                !  Estimate first point next to theta = pi/2
                if (even(nlat)) then

                    ! nlat even
                    eff_zero = HALF_PI-half_dt
                    nix = nhalf

                else

                    ! nlat odd
                    eff_zero = HALF_PI-dt
                    zprev = HALF_PI
                    nix = nhalf-1
                end if

                start_iteration: do
                    it = 0
                    newton_iteration: do
                        it = it+1
                        zlast = eff_zero

                        !  Newton iterations
                        call compute_legendre_poly_and_deriv(nlat, eff_zero, cz, theta(start_index:), wts(start_index:), pb, dpb)

                        dcor = pb/dpb
                        sgnd = ONE

                        if (dcor /= ZERO) sgnd = dcor/abs(dcor)

                        dcor = sgnd * min(abs(dcor), 0.2_wp * dt)
                        eff_zero = eff_zero-dcor

                        !  Repeat iteration
                        if (abs(eff_zero-zlast) - eps*abs(eff_zero) > ZERO) cycle newton_iteration

                        theta(nix) = eff_zero
                        zhold = eff_zero

                        ! yakimiw's formula permits using old pb and dpb
                        wts(nix) = (2*nlat+1)/(dpb+pb*cos(zlast)/sin(zlast))**2
                        nix = nix-1

                        if (nix /= 0) then

                            if (nix == nhalf-1)  then
                                eff_zero = THREE * eff_zero - PI
                            else if (nix < nhalf-1)  then
                                eff_zero = TWO * eff_zero-zprev
                            end if

                            zprev = zhold

                            !  Re-initialize loop
                            cycle start_iteration
                        end if
                        exit newton_iteration
                    end do newton_iteration
                    exit start_iteration
                end do start_iteration

                !  Extend points and weights via symmetries
                if (mod(nlat, 2) /= 0) then

                    theta(nhalf) = HALF_PI

                    call compute_legendre_poly_and_deriv(nlat, HALF_PI, cz, theta(start_index:), wts(start_index:), pb, dpb)

                    wts(nhalf) = real(2*nlat+1, kind=wp)/(dpb**2)

                end if

                do i=1, half_nlat
                    wts(nlat-i+1) = wts(i)
                    theta(nlat-i+1) = PI-theta(i)
                end do

                ! Set weights
                wts = TWO * wts/sum(wts)
        end select

    end subroutine compute_gaussian_latitudes_and_weights

    ! Purpose:
    !
    ! Computes the fourier coefficients of the legendre
    ! polynomial p_n^0 and its derivative.
    ! n is the degree and n/2 or (n+1)/2
    ! coefficients are returned in cp depending on whether
    ! n is even or odd. The same number of coefficients
    ! are returned in dcp. For n even the constant
    ! coefficient is returned in cz.
    !
    pure subroutine compute_fourier_coefficients( &
        n, cz, legendre_poly_coeff, legendre_deriv_coeff)

        ! Dummy arguments
        integer(ip), intent(in)  :: n
        real(wp),    intent(out) :: cz
        real(wp),    intent(out) :: legendre_poly_coeff(n/2+1)
        real(wp),    intent(out) :: legendre_deriv_coeff(n/2+1)

        ! Local variables
        integer(ip) :: j
        real(wp)    :: t1, t2, t3, t4

        associate (&
            ncp => (n+1)/2, &
            cp => legendre_poly_coeff, &
            dcp => legendre_deriv_coeff &
            )

            t1 = -ONE
            t2 = real(n + 1, kind=wp)
            t3 = ZERO
            t4 = real(2*n + 1, kind=wp)

            select case (mod(n, 2))
                case (0)
                    !
                    !  n even
                    !
                    cp(ncp) = ONE

                    do j = ncp, 2, -1
                        t1 = t1+TWO
                        t2 = t2-ONE
                        t3 = t3+ONE
                        t4 = t4-TWO
                        cp(j-1) = (t1*t2)/(t3*t4)*cp(j)
                    end do

                    t1 = t1+TWO
                    t2 = t2-ONE
                    t3 = t3+ONE
                    t4 = t4-TWO
                    cz = (t1*t2)/(t3*t4)*cp(1)

                    do j=1, ncp
                        dcp(j) = real(2*j, kind=wp)*cp(j)
                    end do

                case default
                    !
                    !  odd
                    !
                    cp(ncp) = ONE
                    do j = ncp-1, 1, -1
                        t1 = t1+TWO
                        t2 = t2-ONE
                        t3 = t3+ONE
                        t4 = t4-TWO
                        cp(j) = (t1*t2)/(t3*t4)*cp(j+1)
                    end do

                    do j=1, ncp
                        dcp(j) = real(2*j-1, kind=wp)*cp(j)
                    end do

            end select
        end associate

    end subroutine compute_fourier_coefficients

    ! Purpose:
    !
    ! Computes pn(theta) and its derivative dpb(theta) with
    ! respect to theta
    !
    pure subroutine compute_legendre_poly_and_deriv( &
        n, theta, cz, legendre_poly_coeff, legendre_deriv_coeff, &
        legendre_poly, legendre_deriv)

        ! Dummy arguments
        integer(ip), intent(in)  :: n
        real(wp),    intent(in)  :: theta
        real(wp),    intent(in)  :: cz
        real(wp),    intent(in)  :: legendre_poly_coeff(n/2+1)
        real(wp),    intent(in)  :: legendre_deriv_coeff(n/2+1)
        real(wp),    intent(out) :: legendre_poly
        real(wp),    intent(out) :: legendre_deriv

        ! Local variables
        integer(ip) :: k, kdo
        real(wp)    :: cost, sint, temp

        associate (&
            cos2t => cos(TWO * theta), &
            sin2t => sin(TWO * theta), &
            cp => legendre_poly_coeff, &
            dcp => legendre_deriv_coeff, &
            pb => legendre_poly, &
            dpb => legendre_deriv &
            )

            select case (mod(n, 2))
                case (0)
                    !
                    !  n even
                    !
                    kdo = n/2
                    pb = HALF * cz
                    dpb = ZERO

                    if (n <= 0) return

                    cost = cos2t
                    sint = sin2t

                    do k=1, kdo
                        pb = pb+cp(k)*cost
                        dpb = dpb-dcp(k)*sint
                        temp = cos2t*cost-sin2t*sint
                        sint = sin2t*cost+cos2t*sint
                        cost = temp
                    end do

                case default

                    !  n odd
                    kdo = (n + 1)/2
                    pb = ZERO
                    dpb = ZERO
                    cost = cos(theta)
                    sint = sin(theta)
                    do k=1, kdo
                        pb = pb+cp(k)*cost
                        dpb = dpb-dcp(k)*sint
                        temp = cos2t*cost-sin2t*sint
                        sint = sin2t*cost+cos2t*sint
                        cost = temp
                    end do
            end select
        end associate

    end subroutine compute_legendre_poly_and_deriv

end module gaussian_latitudes_and_weights_routines