***********************************************************************
* KMPP - K-Means++ - Traditional data clustering with a special initialization
* Public Domain - This program may be used by any person for any purpose.
*
* Origin:
*    Hugo Steinhaus, 1956
*
* Refer to:
*    "kmeans++: the advantages of careful seeding"
*    David Arthur and Sergei Vassilvitskii
*    Proceedings of the eighteenth annual ACM-SIAM symposium
*      on Discrete algorithms, 2007
*
*____Variable_______I/O_______Description___________________Type_______
*    X(P,N)         In        Data points                   Real
*    P              In        Dimension of the data         Integer
*    N              In        Number of points              Integer
*    K              In        # clusters                    Integer
*    C(P,K)         Out       Center points of clusters     Real
*    Z(N)           Out       What cluster a point is in    Integer
*    WORK(N)        Neither                                 Real
*    IFAULT         Out       Error code                    Integer
************************************************************************
      SUBROUTINE KMPP (X, P, N, K, C, Z, WORK, IFAULT)

       IMPLICIT NONE
       INTEGER P, N, K, Z, IFAULT
       REAL X, C, WORK
       DIMENSION X(P,N), C(P,K), Z(N), WORK(N)

*               constants
       INTEGER ITER                 ! maximum iterations
       REAL BIG                     ! arbitrary large number
       PARAMETER (ITER = 1000,
     $            BIG = 1E33)

*                local variables
       INTEGER
     $         H,          ! count iterations
     $         I,          ! count points
     $         I1,         ! point marked as initial center
     $         J,          ! count dimensions
     $         L,          ! count clusters
     $         L0,         ! present cluster ID
     $         L1          ! new cluster ID

       REAL
     $      BEST,                 ! shortest distance to a center
     $      D2,                   ! squared distance
     $      TOT,                  ! a total
     $      W                     ! temp scalar

       LOGICAL CHANGE             ! whether any points have been reassigned

************************************************************************
*           Begin.
************************************************************************
       IFAULT = 0
       IF (K < 1 .OR. K > N) THEN       ! K out of bounds
         IFAULT = 3
         RETURN
       END IF
       DO I = 1, N                       ! clear Z
         Z(I) = 0
       END DO

************************************************************************
*        initial centers
************************************************************************
       DO I = 1, N
         WORK(I) = BIG
       END DO

       CALL RANDOM_NUMBER (W)
       I1 = MIN(INT(W * FLOAT(N)) + 1, N)  ! choose first center at random
       DO J = 1, P
         C(J,1) = X(J,I1)
       END DO

       DO L = 2, K                    ! initialize other centers
         TOT = 0.
         DO I = 1, N                     ! measure from each point
           BEST = WORK(I)
           D2 = 0.                         ! to prior center
           DO J = 1, P
             D2 = D2 + (X(J,I) - C(J,L-1)) **2  ! Squared Euclidean distance
             IF (D2 .GE. BEST) GO TO 10               ! needless to add to D2
           END DO                          ! next J
           IF (D2 < BEST) BEST = D2          ! shortest squared distance
           WORK(I) = BEST
  10       TOT = TOT + BEST             ! cumulative squared distance
         END DO                      ! next data point

************************************************************************
* Choose center with probability proportional to its squared distance
*     from existing centers.
************************************************************************
         CALL RANDOM_NUMBER (W)
         W = W * TOT    ! uniform at random over cumulative distance
         TOT = 0.
         DO I = 1, N
           I1 = I
           TOT = TOT + WORK(I)
           IF (TOT > W) GO TO 20
         END DO                ! next I
  20     CONTINUE
         DO J = 1, P         ! assign center
           C(J,L) = X(J,I1)
         END DO
       END DO               ! next center to initialize

************************************************************************
*                      main loop
************************************************************************
       DO H = 1, ITER
         CHANGE = .FALSE.

*             find nearest center for each point
         DO I = 1, N
           L0 = Z(I)
           L1 = 0
           BEST = BIG
           DO L = 1, K
             D2 = 0.
             DO J = 1, P
               D2 = D2 + (X(J,I) - C(J,L)) **2
               IF (D2 .GE. BEST) GO TO 30
             END DO
  30         CONTINUE
             IF (D2 < BEST) THEN           ! new nearest center
               BEST = D2
               L1 = L
             END IF
           END DO        ! next L

           IF (L0 .NE. L1) THEN
             Z(I) = L1                   !  reassign point
             CHANGE = .TRUE.
           END IF
         END DO         ! next I
         IF (.NOT. CHANGE) RETURN      ! success

************************************************************************
*           find cluster centers
************************************************************************
         DO L = 1, K              ! zero population
           WORK(L) = 0.
         END DO
         DO L = 1, K               ! zero centers
           DO J = 1, P
             C(J,L) = 0.
           END DO
         END DO

         DO I = 1, N
           L = Z(I)
           WORK(L) = WORK(L) + 1.             ! count
           DO J = 1, P
             C(J,L) = C(J,L) + X(J,I)         ! add
           END DO
         END DO

         DO L = 1, K
           IF (WORK(L) < 0.5) THEN          ! empty cluster check
             IFAULT = 1                     ! fatal error
             RETURN
           END IF
           W = 1. / WORK(L)
           DO J = 1, P
             C(J,L) = C(J,L) * W     ! multiplication is faster than division
           END DO
         END DO

       END DO                   ! next H
       IFAULT = 2                ! too many iterations
       RETURN

      END  ! of KMPP

************************************************************************
*             test program (extra credit #1)
************************************************************************
      PROGRAM TPEC1
       IMPLICIT NONE
       INTEGER N, P, K
       REAL TWOPI
       PARAMETER (N = 30 000,
     $            P = 2,
     $            K = 6,
     $            TWOPI = 6.2831853)
       INTEGER I, L, Z(N), IFAULT
       REAL X(P,N), C(P,K), R, THETA, W, WORK(N)

*             Begin
       CALL RANDOM_SEED()
       DO I = 1, N                      ! random points over unit circle
         CALL RANDOM_NUMBER (W)
         R = SQRT(W)                      ! radius
         CALL RANDOM_NUMBER (W)
         THETA = W * TWOPI                ! angle
         X(1,I) = R * COS(THETA)          ! Cartesian coordinates
         X(2,I) = R * SIN(THETA)
       END DO

*             Call subroutine
       CALL KMPP (X, P, N, K, C, Z, WORK, IFAULT)
       PRINT *, 'kmpp returns with error code ', IFAULT

*            Print lists of points in each cluster
       DO L = 1, K
         PRINT *, 'Cluster ', L, ' contains points: '
  10     FORMAT (I6, $)
  20     FORMAT ()
         DO I = 1, N
           IF (Z(I) .EQ. L) PRINT 10, I
         END DO
         PRINT 20
       END DO

*         Write CSV file with Y-coordinates in different columns by cluster
       OPEN (UNIT=1, FILE='tpec1.csv', STATUS='NEW', IOSTAT=IFAULT)
       IF (IFAULT .NE. 0) PRINT *, 'tpec1: trouble opening file'
  30   FORMAT (F8.4, $)
  40   FORMAT (',', $)
  50   FORMAT (F8.4)
       DO I = 1, N
         WRITE (UNIT=1, FMT=30, IOSTAT=IFAULT) X(1,I)
         IF (IFAULT .NE. 0) PRINT *, 'tpec1: trouble writing X-coord'
         DO L = 1, Z(I)                     ! one comma per cluster ID
           WRITE (UNIT=1, FMT=40, IOSTAT=IFAULT)
           IF (IFAULT .NE. 0) PRINT *, 'tpec1: trouble writing comma'
         END DO
         WRITE (UNIT=1, FMT=50, IOSTAT=IFAULT) X(2,I)
         IF (IFAULT .NE. 0) PRINT *, 'tpec1: trouble writing Y-coord'
       END DO

*           Write the centroids in the far column
       DO L = 1, K
         WRITE (UNIT=1, FMT=30, IOSTAT=IFAULT) C(1,L)
         IF (IFAULT .NE. 0) PRINT *, 'tpec1: trouble writing X-coord'
         DO I = 1, K+1
           WRITE (UNIT=1, FMT=40, IOSTAT=IFAULT)
           IF (IFAULT .NE. 0) PRINT *, 'tpec1: trouble writing comma'
         END DO
         WRITE (UNIT=1, FMT=50, IOSTAT=IFAULT) C(2,L)
         IF (IFAULT .NE. 0) PRINT *, 'tpec1: trouble writing Y-coord'
       END DO
       CLOSE (UNIT=1)

      END  ! of test program


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 4 node
!!   qudrilateral element (Langrange  interpolation)
module shape_quad4n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_quad4n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(2)
    real(kind=kreal) :: func(4)
    func(1) = 0.25d0*(1.d0-lcoord(1))*(1.d0-lcoord(2))
    func(2) = 0.25d0*(1.d0+lcoord(1))*(1.d0-lcoord(2))
    func(3) = 0.25d0*(1.d0+lcoord(1))*(1.d0+lcoord(2))
    func(4) = 0.25d0*(1.d0-lcoord(1))*(1.d0+lcoord(2))
  end subroutine

  subroutine ShapeDeriv_quad4n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(2)
    real(kind=kreal) :: func(4,2)
    func(1,1) = -0.25d0*(1.d0-lcoord(2))
    func(2,1) =  0.25d0*(1.d0-lcoord(2))
    func(3,1) =  0.25d0*(1.d0+lcoord(2))
    func(4,1) = -0.25d0*(1.d0+lcoord(2))

    func(1,2) = -0.25d0*(1.d0-lcoord(1))
    func(2,2) = -0.25d0*(1.d0+lcoord(1))
    func(3,2) =  0.25d0*(1.d0+lcoord(1))
    func(4,2) =  0.25d0*(1.d0-lcoord(1))
  end subroutine

  subroutine Shape2ndDeriv_quad4n(func)
    real(kind=kreal) :: func(4,2,2)
    func(:,1,1) = 0.d0
    func(1,1,2) = 0.25d0
    func(2,1,2) = -0.25d0
    func(3,1,2) = 0.25d0
    func(4,1,2) = -0.25d0

    func(1,2,1) = 0.25d0
    func(2,2,1) = -0.25d0
    func(3,2,1) = 0.25d0
    func(4,2,1) = -0.25d0
    func(:,2,2) = 0.d0
  end subroutine

  ! (Gaku Hashimoto, The University of Tokyo, 2012/11/15) <
  !####################################################################
  subroutine NodalNaturalCoord_quad4n(nncoord)
    !####################################################################

    implicit none

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

    real(kind = kreal), intent(out) :: nncoord(4, 2)

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

    ! xi-coordinate at a node in a local element
    nncoord(1, 1) = -1.0D0
    nncoord(2, 1) =  1.0D0
    nncoord(3, 1) =  1.0D0
    nncoord(4, 1) = -1.0D0
    ! eta-coordinate at a node in a local element
    nncoord(1, 2) = -1.0D0
    nncoord(2, 2) = -1.0D0
    nncoord(3, 2) =  1.0D0
    nncoord(4, 2) =  1.0D0

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

    return

    !####################################################################
  end subroutine NodalNaturalCoord_quad4n
  !####################################################################
  ! > (Gaku Hashimoto, The University of Tokyo, 2012/11/15)

end module


subroutine LeastSquaresBuildSystem(msamp,ndof,X,y,systemMat,systemRHS)
   use typre
   implicit none
   !See http://en.wikipedia.org/wiki/Linear_least_squares_(mathematics) for notation

   integer(ip) :: ndof,msamp

   real(rp) :: X(msamp,ndof), y(msamp)
   real(rp) :: systemMAT(ndof,ndof), systemRHS(ndof)

   write(*,*) 'before leastsquresbuild'
   systemMat = 0.0_rp
   systemRHS = 0.0_rp
   write(*,*) 'before leastsquresbuild2'
   call LeastSquaresAddToSystem(msamp,ndof,X,y,systemMat,systemRHS)
   write(*,*) 'after leastsquresbuild'
end subroutine

subroutine LeastSquaresAddToSystem(msamp,ndof,X,y,systemMat,systemRHS)
   use typre
   implicit none
   !See http://en.wikipedia.org/wiki/Linear_least_squares_(mathematics) for notation

   integer(ip) :: ndof,msamp

   real(rp) :: X(msamp,ndof), y(msamp)
   real(rp) :: systemMAT(ndof,ndof), systemRHS(ndof)

   real(rp) :: XT(ndof,msamp)

   XT = transpose(X)

   systemMat = matmul(XT,X)
   systemRHS = matmul(XT,y)
end subroutine


	subroutine euler(angles,v)

*	Rotates vector given wrt (i,j,k) through Euler angles (i,w,Omega).

	implicit real*8 (a-h,o-z)
	real*8 v(3),angles(3),B(3,3),temp(3)

	cosi=cos(angles(1))
	sini=sin(angles(1))
	cosw=cos(angles(2))
	sinw=sin(angles(2))
	cosOm=cos(angles(3))
	sinOm=sin(angles(3))

        B(1,1) = cosw*cosOm - sinw*cosi*sinOm
        B(1,2) = cosw*sinOm + sinw*cosi*cosOm
        B(1,3) = sinw*sini
        B(2,1) = -sinw*cosOm - cosw*cosi*sinOm
        B(2,2) = -sinw*sinOm + cosw*cosi*cosOm
        B(2,3) = cosw*sini
        B(3,1) = sini*sinOm
        B(3,2) = -sini*cosOm
        B(3,3) = cosi

	do i=1,3
	   sum=0
	   sum2=0
	   do j=1,3
	      sum=sum + B(j,i)*v(j)
	   enddo
	   temp(i)=sum
	enddo
	do i=1,3
	   v(i)=temp(i)
	enddo

	end


      program fortran_newtons

      REAL :: x,v2,Psi,phi0
      REAL functionPhi
      REAL functionPhiDeri
      REAL functionNewtonsMethod

      x = 0.3
      v2 = 0.1
      Psi = 1.5
      phi0 = 3.0

      print *, 'function : ', functionPhi(x, v2, Psi, phi0)
      print *, 'functionDeri : ', functionPhiDeri(x, v2, Psi)

      ! need to implement the better guess here

      print *, 'newtonsMethod : ', functionNewtonsMethod(x, v2,
     *                             Psi, phi0)
      end

      ! phi = phi0 - v2 * sin[2(phi-Psi)]
      ! we need y = x + v2 * sin[2(x-Psi)] - phi0 = 0, where x is phi.
      FUNCTION functionPhi(x, v2, Psi, phi0)
      REAL x, v2, Psi, phi0
      functionPhi = ( x + v2*SIN(2*(x-Psi)) - phi0 )
      RETURN
      END FUNCTION

      ! y' = 1 + v2 * cos[2(x-Psi)]*2
      FUNCTION functionPhiDeri(x, v2, Psi)
      REAL x, v2, Psi
      functionPhiDeri = ( 1 + v2*COS(2*(x-Psi))*2 )
      RETURN
      END FUNCTION

      FUNCTION functionNewtonsMethod(x, v2, Psi, phi0)
      REAL x, v2, Psi, phi0
      REAL ratioFuncDeri
      ratioFuncDeri = functionPhi(x, v2, Psi, phi0)
     *                / functionPhiDeri(x, v2, Psi)
      DO WHILE (ABS(ratioFuncDeri) > 0.0000001)
         ratioFuncDeri = functionPhi(x, v2, Psi, phi0)
     *                   / functionPhiDeri(x, v2, Psi)
         x = x - ratioFuncDeri
      END DO

      functionNewtonsMethod = x
      RETURN
      END FUNCTION


program euler_169
    integer, parameter :: int64 = selected_int_kind(15)
    integer, dimension(26) :: twos=0  ! use an array of length 26 to represent 10**25
    integer(int64) :: a, b, i=0
    twos(1)  = 1
    twos(26) = 1  ! this is needed due to algorithm

    a = 1
    b = 0
    i = 0
    do
       if (mod(twos(26),2)==1) then
          b = a + b
       else
          a = a + b
       endif
       call divide_by_two(twos)
       i = i + 1
       print '(3(i0,2x),26(i0))',i,a,b,twos
       if (sum(twos)==0) exit
    end do
    print '("The hyperbinary representation of 10**25 = ",i0)',b

contains
   subroutine divide_by_two(twos)
      integer, dimension(26), intent(inout) :: twos
      integer :: i, tmp(26)
      tmp = 0
      ! do first round of integer division
      do i=1,26
         tmp(i) = twos(i)/2
      end do !- i
      ! add "0.5" term to odd terms
      do i=2,26
         if (mod(twos(i-1),2)==1) then
            tmp(i) = tmp(i) + 5
         end if
      end do ! -i
      twos(:) = tmp(:)
   end subroutine divide_by_two
end program euler_169


C NCLFORTSTART
      subroutine spareapolyi(vlat,vlon,nv,rad,area)
      implicit none
c input
      integer nv
      double precision  vlat(nv), vlon(nv), rad
c output
      double precision  area
C NCLEND
c local
      integer npts

c Are beginning and end pts the same?
c If so, pass one less value. spareapoly wants no duplicate pts.

      npts = nv
      if (vlat(1).eq.vlat(nv) .and. vlon(1).eq.vlon(nv)) then
          npts = nv-1
      end if
      call spareapoly(vlat,vlon,npts,rad,area)

      return
      end

c --------------
      subroutine spareapoly(vlat,vlon,nv,rad,area)
      implicit none
c input
      integer nv
      double precision  vlat(nv), vlon(nv), rad
c output
      double precision  area

C*************************************************************
C Computing the Area of a Spherical Polygon of Arbitrary Shape
C     Bevis and Cambareri (1987)
C     Mathematical Geology, vol.19, Issue 4, pp 335-346
C*************************************************************
c Computes the area of a spherical polygon with nv vertices and sides.

c ARGUMENTS:
c vlat,vlon ...  vectors containing the latitude and longitude
c                of each vertex.  The ith.  vertex is located at
c                [vlat(i),vlon(i)].
c nv        ...  the number of vertices and sides in the spherical
c                polygon
c rad       ...  the radius of the sphere

c area      ...  the area of the spherical polygon

c UNITS:
c   Latitudes and longitudes are specified in degrees.  The user selects
c   the units of length in which to specify the radius, and the polygon
c   area will be returned in the square of these units.
c SIGN CONVENTION:
c   Latitudes are positive to the north and negative to the south.
c   Longitudes are positive to the east and negative to the west.
c VERTEX ENUMERATION:
c   The vertices are numbered sequentially around the border of the
c   spherical polygon.  Vertex 1 lies between vertex nv and vertex 2.
c   The user must follow the convention whereby in moving around the
c   polygon border in the direction of increasing vertex number clockwise
c   bends occur at salient vertices.  A vertex is salient if the interior
c   angle'is less than 180 degrees.  (In the case of a convex polygon
c   this convention implies that the vertices are numbered in clockwise
c   sequence).
c
c   Two adjacent vertices may never be exactly 180 degrees apart
c   because they could be connected by infinitely many different
c   great circle arcs, and thus the border of the spherical
c   polygon would not be uniquely defined.

c local
      integer iv
      double precision  pi, twopi, suma
      double precision  flat, flon, blat, blon, fang, bang, fvb
      parameter (pi=3.141592654d0, twopi=2.0d0*pi)

      suma = 0.0d0
      do iv=1,nv
         if (iv.eq.1) then
             flat=vlat(2)
             flon=vlon(2)
             blat=vlat(nv)
             blon=vlon(nv)
         elseif (iv.lt.nv) then
             flat=vlat(iv+1)
             flon=vlon(iv+1)
             blat=vlat(iv-1)
             blon=vlon(iv-1)
         else
             flat=vlat(1)
             flon=vlon(1)
             blat=vlat(nv-1)
             blon=vlon(nv-1)
         end if

         call trnsfrmlon (vlat(iv),vlon(iv),flat,flon,fang)
         call trnsfrmlon (vlat(iv),vlon(iv),blat,blon,bang)

         fvb = bang-fang
         if (fvb.lt. 0.0d0) fvb = fvb+twopi
         suma = suma+fvb
      end do

      area = (suma-pi*(nv-2))*rad**2

      return
      end
c ---
      subroutine trnsfrmlon(plat,plon,qlat,qlon,tranlon)
      implicit none
c Finds the "longitude" of point Q in a geographic coordinate system
c  for which point P acts as a "north pole'.
c input
c   plat,plon,qlat,qlon ....  degrees
c output
c   tranlon ... radians
c input
      double precision plat,plon,qlat,qlon
c output
      double precision tranlon
c local
      double precision pi, dtr, tt, bb
      parameter (pi=3.141592654d0,dtr=pi/180.0d0)

      tt = sin((qlon-plon)*dtr)*cos(qlat*dtr)

      bb = sin(qlat*dtr)*cos(plat*dtr)-cos(qlat*dtr)*sin(plat*dtr)
     &    *cos((qlon-plon)*dtr)

      tranlon = atan2(tt,bb)

      return
      end


PURE FUNCTION func_var(arr, dof) RESULT(ans)
    ! NOTE: See https://numpy.org/doc/stable/reference/generated/numpy.var.html

    ! NOTE: In standard statistical practice:
    !         * dof=1 provides an unbiased estimator of the variance of a
    !           hypothetical infinite population
    !         * dof=0 provides a maximum likelihood estimate of the variance for
    !           normally distributed variables

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = INT64), INTENT(in), OPTIONAL                                 :: dof
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: arr

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: n
    REAL(kind = REAL64), ALLOCATABLE, DIMENSION(:)                              :: tmp

    ! Find size of array ...
    n = SIZE(arr, kind = INT64)

    ! Allocate array ...
    ALLOCATE(tmp(n))

    ! Calculate the squared deviations from the mean ...
    tmp = ABS(arr - func_mean(arr)) ** 2

    ! Calculate the variance ...
    IF(PRESENT(dof))THEN
        ans = func_mean(tmp, dof)
    ELSE
        ans = func_mean(tmp, 0_INT64)
    END IF

    ! Clean up ...
    DEALLOCATE(tmp)
END FUNCTION func_var


program outputdata
implicit none

   real, dimension(100) :: x, y
   real, dimension(100) :: p, q
   integer :: i

   ! data
   do i = 1,100
      x(i) = i * 0.1
      y(i) = sin(x(i)) * (1-cos(x(i)/3.0))
   end do

   ! output data into a file
   open(1, file = 'data1.dat', status='new')
   do i = 1,100
      write(1,*) x(i), y(i)
   end do
   close(1)

   ! opening the file for reading
   open (2, file = 'data1.dat', status = 'old')

   do i = 1,100
      read(2,*) p(i), q(i)
   end do

   close(2)

   do i = 1,100
      write(*,*) p(i), q(i)
   end do

end program outputdata


      program power01

C     Check the interpretation of the power operator

      read *, n, m3, m4, m5

      i = 2**3

      j = 2**n

      j1 = 1**n

      j2 = 4**n

      k = (-2)**n

      k2 = (-1)**n

      l = n**2

      l3 = n**3

      l4 = n**4

      m = 0**n

      m2 = n**0

      m3 = m3**2

      m4 = m4**3

      m5 = m5**(-1)

      m6 = n**1

      print *, i, j, j1, j2, k, k2, l, l3, l4, m, m2, m3, m4, m5, m6

      end


! from QE-6.0

subroutine ylmr2 (lmax2, ng, g, gg, ylm)
  !
  !     Real spherical harmonics ylm(G) up to l=lmax
  !     lmax2 = (lmax+1)^2 is the total number of spherical harmonics
  !     Numerical recursive algorithm based on the one given in Numerical
  !     Recipes but avoiding the calculation of factorials that generate
  !     overflow for lmax > 11
  !
  implicit none
  integer, parameter :: DP = 8
  real(DP), parameter :: PI = 4.d0*atan(1.d0)
  real(DP), parameter :: FPI = 4.d0*PI
  !
  integer, intent(in) :: lmax2, ng
  real(DP), intent(in) :: g (3, ng), gg (ng)
  !
  ! BEWARE: gg = g(1)^2 + g(2)^2 +g(3)^2  is not checked on input
  !         incorrect results will ensue if the above does not hold
  !
  real(DP), intent(out) :: ylm (ng,lmax2)
  !
  ! local variables
  !
  real(DP), parameter :: eps = 1.0d-9
  real(DP), allocatable :: cost (:), sent(:), phi (:), Q(:,:,:)
  real(DP) :: c, gmod
  integer :: lmax, ig, l, m, lm
  !

  WRITE(*,*) 'PI = ', PI

  IF (ng < 1 .or. lmax2 < 1) RETURN

  DO lmax = 0, 25
    WRITE(*,*) 'lmax = ', lmax
    IF ((lmax+1)**2 == lmax2) go to 10
  ENDDO
  WRITE(*,*) 'Error ylmr: l > 25 or wrong number of Ylm required, lmax, lmax2 = ', lmax, lmax2
  STOP

10 CONTINUE
  WRITE(*,*) 'JUMPED !!!', lmax
  !
  IF (lmax == 0) THEN
     ylm(:,1) =  sqrt (1.d0 / fpi)
     RETURN
  ENDIF

  !
  !  theta and phi are polar angles, cost = cos(theta)
  !
  allocate(cost(ng), sent(ng), phi(ng), Q(ng,0:lmax,0:lmax) )
  Q(:,:,:) = 0.d0 ! ffr
  !

  do ig = 1, ng
     gmod = sqrt (gg (ig) )
     if (gmod < eps) then
        cost(ig) = 0.d0
     else
        cost(ig) = g(3,ig)/gmod
     endif
     !
     !  beware the arc tan, it is defined modulo pi
     !
     if (g(1,ig) > eps) then
        phi (ig) = atan( g(2,ig)/g(1,ig) )
     else if (g(1,ig) < -eps) THEN
        WRITE(*,*) 'Pass here -eps ...'
        phi (ig) = atan( g(2,ig)/g(1,ig) ) + pi
     else
        phi (ig) = sign( pi/2.d0,g(2,ig) )
     end if
     sent(ig) = sqrt(max(0d0,1.d0-cost(ig)**2))
     write(*,'(1x,I5,3F18.10)') ig, phi(ig), cost(ig), sent(ig)
  enddo
  !
  !  Q(:,l,m) are defined as sqrt ((l-m)!/(l+m)!) * P(:,l,m) where
  !  P(:,l,m) are the Legendre Polynomials (0 <= m <= l)
  !
  lm = 0
  do l = 0, lmax
     WRITE(*,*) 'l = ', l
     c = sqrt (DBLE(2*l+1) / fpi)
     if ( l == 0 ) then
        do ig = 1, ng
           Q (ig,0,0) = 1.d0
        end do
     else if ( l == 1 ) then
        do ig = 1, ng
           Q (ig,1,0) = cost(ig)
           Q (ig,1,1) =-sent(ig)/sqrt(2.d0)
        end do
     else
        !
        !  recursion on l for Q(:,l,m)
        !
        do m = 0, l - 2
           write(*,*) 'Enter this ....'
           do ig = 1, ng
              Q(ig,l,m) = cost(ig)*(2*l-1)/sqrt(DBLE(l*l-m*m))*Q(ig,l-1,m) &
                       - sqrt(DBLE((l-1)*(l-1)-m*m))/sqrt(DBLE(l*l-m*m))*Q(ig,l-2,m)
           end do
           write(*,*) 'sum(Q) = ', sum(Q(:,l,m))
        end do
        do ig = 1, ng
           Q(ig,l,l-1) = cost(ig) * sqrt(DBLE(2*l-1)) * Q(ig,l-1,l-1)
        end do
        do ig = 1, ng
           Q(ig,l,l)   = - sqrt(DBLE(2*l-1))/sqrt(DBLE(2*l))*sent(ig)*Q(ig,l-1,l-1)
        end do
     end if
     !
     ! Y_lm, m = 0
     !
     lm = lm + 1
     WRITE(*,*) 'm = 0: lm = ', lm
     do ig = 1, ng
        ylm(ig, lm) = c * Q(ig,l,0)
     end do
     !
     do m = 1, l
        !
        ! Y_lm, m > 0
        !
        lm = lm + 1
        WRITE(*,*) 'm > 0: lm = ', lm
        do ig = 1, ng
           ylm(ig, lm) = c * sqrt(2.d0) * Q(ig,l,m) * cos (m*phi(ig))
        end do
        !
        ! Y_lm, m < 0
        !
        lm = lm + 1
        WRITE(*,*) 'm < 0: lm = ', lm
        DO ig = 1, ng
           ylm(ig, lm) = c * sqrt(2.d0) * Q(ig,l,m) * sin (m*phi(ig))
        ENDDO
     ENDDO
  ENDDO
  !
  DEALLOCATE(cost, sent, phi, Q)
  !
  RETURN
end subroutine ylmr2


!-----------------------------------------------------------------------
subroutine tridiagonal(N,au,bu,cu,du,fi,lt,value)
!
! !DESCRIPTION:
! A linear equation with tridiagonal matrix structure is solved here. The main
! diagonal is stored on {\tt bu}, the upper diagonal on {\tt au}, and the
! lower diagonal on {\tt cu}, the right hand side is stored on {\tt du}.
! The method used here is the simplified Gauss elimination, also called
! \emph{Thomas algorithm}.
!
! !USES:
   IMPLICIT NONE
!
! !INPUT PARAMETERS:
   integer, intent(in)                 :: N,fi,lt
   real(8), dimension(N), intent(in)   :: au, bu, cu, du
!
! !OUTPUT PARAMETERS:
   real(8), intent(out)                :: value(N)
!
!EOP
!
! !LOCAL VARIABLES:
   integer                             :: i
   real(8), dimension(N)               :: ru, qu
!
!-----------------------------------------------------------------------
!BOC
   ru(lt)=au(lt)/bu(lt)
   qu(lt)=du(lt)/bu(lt)

   do i=lt-1,fi+1,-1
      ru(i)=au(i)/(bu(i)-cu(i)*ru(i+1))
      qu(i)=(du(i)-cu(i)*qu(i+1))/(bu(i)-cu(i)*ru(i+1))
   end do

   qu(fi)=(du(fi)-cu(fi)*qu(fi+1))/(bu(fi)-cu(fi)*ru(fi+1))

   value(fi)=qu(fi)

!   write(6,*) 'fi = ',fi
!   write(6,*) 'value(fi) = ',value(fi)

   do i=fi+1,lt
      value(i)=qu(i)-ru(i)*value(i-1)
   end do

!   write(6,*) 'value(lt) = ',value(lt)

   return
end subroutine tridiagonal


subroutine givens(h,M,beta)
! Solve the least square problem M * x = beta
! with Givens rotation and Back substitution
! h is a hessenberg matrix
! M is dimension of h, h=dim(M+1,M)
! use beta as the out puts beta=x

integer M
real(8) h(M+1,M)
real(8) beta(M+1)
real(8) x(M+1)

integer i,j,k
real(8) tmp,tmp1,tmp2
real(8) s1,c1
real(8) tmph(2,M)

! Givens rotation to get up-triangle matrix
do i=1,M
	tmp=sqrt(h(i,i)**2 + h(i+1,i)**2)
	s1=h(i+1,i)/tmp
	c1=h(i,i)/tmp
	tmp1=c1*beta(i)
	tmp2=-s1*beta(i)
	beta(i)=tmp1
	beta(i+1)=tmp2;

	do j=i,M
		tmph(1,j)=c1*h(i,j)+s1*h(i+1,j)
		tmph(2,j)=-s1*h(i,j)+c1*h(i+1,j)
	end do
	h(i:i+1,:)=tmph(1:2,:)
	tmph(:,:)=0.0d0
end do
!do i=1,M+1
!write(*,*) ' h up-tri', h(i,:)
!end do

!write(*,*) 'beta', beta(:)
! Back substitution used to solve a up-triangle system
x(M)=beta(M)/h(M,M)

do j=M-1,1,-1
	tmp=0.0d0
	do k=j+1,M
		tmp=tmp+x(k)*h(j,k)
	end do
	x(j)=(beta(j)-tmp)/h(j,j);
end do

beta(:)=x(:)

return
end


FUNCTION norm(x)RESULT(l2n)
!
! THis function calculates the l2 norm of vector x
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x(:)
 REAL(iwp)::l2n
 l2n=SQRT(SUM(x**2))
RETURN
END FUNCTION norm