!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!!  LowPassFilterModule -- A Fortran 90 module for low-pass filtering of
!!      discrete graph signals.
!!
!!  This module provides the core procedures that implement the low-pass
!!  filtering of discrete graph signals described in [1,2].  By generalizing
!!  classical discrete fourier analysis to discrete graph signals --
!!  functions defined on the nodes of an undirected graph -- the problem
!!  of smoothing is reduced to that of low-pass filtering.
!!
!!  Classical Fourier analysis decomposes a signal into the eigencomponents
!!  of the Laplacian, so to extend Fourier analysis to discrete graph signals,
!!  one merely needs to define a generalized laplacian on the graph.  The
!!  simplest definition, and the one used here, is to define the "laplacian"
!!  at a node to be the difference between the signal at that node and the
!!  mean of the signals at the neighboring nodes.
!!
!!  In the context of surface and mesh smoothing, the relevent discrete graph
!!  signal is the node coordinates on the graph associated with the simplicial
!!  mesh.  In this instance, we may desire that the filtering preserve
!!  certain intrinsic topological features of mesh as well as some extrinsic
!!  "geometric" features.  This is easily accomplished by modifying the
!!  neighbor structure of the graph (see CreateLaplacian below).
!!
!!  [1] Gabriel Taubin, "A signal processing approach to fair surface design".
!!      Computer Graphics, p351-358, August 1995 (Proceedings SIGGRAPH'95).
!!  [2] Taubin, Zhang, and Golub, "Optimal surface smoothing as filter design".
!!      IBM research report, RC-20404(#90237), Computer Sciences, 3/12/96.
!!
!!  PROGRAMMING INTERFACE
!!
!!    A integer parameter, r8, is provided that gives the kind value of all
!!        reals used in the module.  Typically this should correspond to
!!        8-byte reals.
!!
!!    An ADT, ASetType, is provided to facilitate the construction of the
!!        Laplacian (see CreateLaplacian below).  It has a single component
!!        which is a pointer to a rank-1 integer array.
!!
!!    call HammingFilterCoef (f, n, k_pb [,sigma]) returns the polynomial
!!        coefficients of the Nth degree Hamming filter.  The coefficients
!!        are normalized to sum to 1, which make them, strictly speaking,
!!        not the true Hamming coefficients.  F is an intent(out), rank-1,
!!        real array containing the filter coefficients.  Its length must be
!!        at least N+1.  K_PB is a real intent(in) variable that specifies
!!        the pass-band value, and should lie within the interval (0,2).
!!        The Hamming filter can be regarded as the convolution of the ideal
!!        low-pass filter with a mollification kernel that is a trig series
!!        defined by the filter coefficients.  If the real, intent(in)
!!        variable SIGMA is not present, the pass-band is shifted right by
!!        an amount equal to the radius of this mollification kernel.  This
!!        assures that the filter will be approximately 1 in the entire
!!        interval (0, K_PB).  If SIGMA is present, its value is used as the
!!        shift amount.
!!
!!    PolynomialFilter (x, f) returns the filtered "signal".  F is a rank-1,
!!        real, intent(in) array that contains the coefficients of a polynomial
!!        filter, such as is returned by HammingFilterCoef.  X is a rank-2,
!!        real, intent(in) array that contains the input "signal"; X(:,j) is
!!        the signal at node j.
!!
!!    GaussianFilter (x, lambda) returns the Gaussian filtered "signal".
!!        LAMBDA is a real, intent(in) variable, and X is a rank-2, real,
!!        intent(in) array that contains the input "signal".  The filtered
!!        signal is simply  X - LAMBDA * Laplacian(X).
!!
!!    call CreateLaplacian (mask, xset, aset, cvtx [,cnbr, cmat]) constructs
!!        the Laplacian that is central to the filtering algorithm.
!!
!!        Unless otherwise noted, all arguments are intent(in).
!!
!!        MASK is a rank-1, integer array.  Node j is ignored if MASK(j) == 0.
!!
!!        CVTX is a rank-2 integer array giving the vertices of the
!!            simplicial cells which form the mesh.  CVTX(:,j) are the
!!            vertices of cell j.
!!
!!        CNBR is a rank-2 integer array giving the neighbors of the cells.
!!            CNBR(:,j) are the neighbors of cell j encoded in the following
!!            manner.  If cells j and j' are adjacent, with face k of cell j
!!            and face k' of cell j' being the shared face then
!!            CNBR(k,j) = k' + n * (j'-1) and CNBR(k',j') = k + n * (j-1)
!!            where n is the number of vertices of the simplicial cell.
!!            If CNBR(k,j) = 0 then this face is a boundary face, and if
!!            CNBR(k,j) < 0 then this is a material interface face, with
!!            |CNBR(k,j)| giving the neighbor encoded as above.
!!
!!        CMAT is a rank-1, integer array giving the material numbers for
!!            the cells.  If adjacent cells have different material numbers
!!            then their shared face should be indicated as a material
!!            interface face in CNBR, and conversely.
!!
!!        The graph that defines the laplacian is derived from the simplicial
!!        mesh described by CVTX, CNBR, and CMAT.  There are two possible
!!        cases.  If CNBR and CMAT are present, then the mesh is a multi-
!!        material mesh and there is a distinguished hierarchy of topological
!!        features.  For a 3D mesh, there are the 3D material volumes, the
!!        2D material interface network, the 1D network of interface
!!        boundaries/singularities, and the isolated point set of singularity
!!        points of the 1D network.  The neighbors of a node in one class are
!!        restricted to those in the same or subsequent classes.  By
!!        modifying the graph in this way, the resulting filtering will respect
!!        these topological features; a material interface, for example, is
!!        smoothed as a unit without regard to connected volume nodes.  For
!!        a 2D mesh the situation is similar.
!!
!!        If CNBR and CMAT are absent, then the mesh is complex of simplicial
!!        cells described completely by CVTX.  It may be a simple 2D surface,
!!        for example, or a 2D surface network such as the material interface
!!        network of a multi-material 3D mesh.  In any case, there is also
!!        a (shorter) hierarchy of topological features, and the graph
!!        associated with the mesh is modified as above.
!!
!!        The remaining arguments describe the extrinsic "geometric" features
!!        of the mesh that the filtering should respect.  This is modeled in
!!        the following way.  Associated with each node is an integer set of
!!        "attributes" (possibly empty).  The neighbors of one node are
!!        restricted to those nodes whose attribute sets contain the attribute
!!        set of the first.
!!
!!        XSET is a rank-1 integer array giving the attribute set index for
!!            each node.  If XSET(j) == 0 the the attribute set for node j
!!            is empty.
!!
!!        ASET is a rank-1 array of ASetType values.  ASET(j) is the jth
!!            attribute set.
!!
!!    call DeleteLaplacian () deallocates all storage associated with the
!!        Laplacian.
!!
!!
!!    CHANGE HISTORY
!!
!!        $Log: LowPassFilterModule.f90,v $
!!        Revision 2.00  2007/11/05 19:45:45  spchu
!!        Import to CVS
!!
!PVCS
!PVCS   Rev 1.2   Sat May 01 22:08:50 1999   nnc
!PVCSMade argument MASK of CreateLaplacian intent(in).
!PVCS
!PVCS   Rev 1.1   Mon Nov 30 14:52:40 1998   nnc
!PVCSAdded documentation.
!PVCS
!PVCS   Rev 1.0   Mon Nov 16 14:19:00 1998   dcg
!PVCSInitial revision.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module LowPassFilterModule

  implicit none
  private

  public  :: HammingFilterCoef, PolynomialFilter, GaussianFilter, CreateLaplacian, DeleteLaplacian
  private :: laplacian

  ! This should give 8-byte reals (double precision)
  integer, parameter, public :: r8 = selected_real_kind (10, 50)

  type, public :: ASetType
    integer, dimension(:), pointer :: attr
  end type ASetType

  integer, dimension(:), pointer, private, save :: xnbrs, nbrs

  contains

  subroutine HammingFilterCoef( f, n, k_pb, sigma )

    real(kind=r8), dimension(0:), intent(out) :: f
    integer, intent(in) :: n
    real(kind=r8), intent(in) :: k_pb
    real(kind=r8), intent(in), optional :: sigma

    integer :: j
    real(kind=r8) :: pi, theta_pb
    real(kind=r8), dimension(0:size(f)-1) :: w

    pi = 4.0_r8 * atan(1.0_r8)

    theta_pb = acos( 1.0_r8 - 0.5_r8 * k_pb )

    if (present(sigma)) then
      theta_pb = theta_pb + sigma
    else
      theta_pb = theta_pb + 1.0_r8 / (0.2331592_r8 + 0.1592799_r8 * n)
    end if

    !! Truncated fourier series for ideal LP filter (rectangular window)
    f(0) = theta_pb / pi
    do j = 1, n
      f(j) = 2.0_r8 * sin( j * theta_pb ) / (j * pi)
    end do

    !! Hamming window coefficients.
    w(0) = 1.0_r8
    do j = 1, n
      w(j) = 0.54_r8 + 0.46_r8 * cos( j * pi / (n + 1) )
    end do

    f = f * w       !! The Hamming filter coefficients.
    f = f / sum(f)  !! Normalize (strictly speaking this shouldn't be done)

    end subroutine HammingFilterCoef

    function PolynomialFilter( x, f ) result( y )

      real(kind=r8), dimension(:,:), intent(inout) :: x
      real(kind=r8), dimension(0:),  intent(in)    :: f
      real(kind=r8), dimension(size(x,dim=1),size(x,dim=2)) :: y

      integer :: n, j
      real(kind=r8), dimension(:,:), pointer :: y0, y1, y2, yt
      real(kind=r8), dimension(size(x,dim=1),size(x,dim=2),3), target :: work

      y0 => work(:,:,1)
      y1 => work(:,:,2)
      y2 => work(:,:,3)

      n = size(f) - 1

      y2 = 0.0_r8
      y1 = f(n) * x

      do j = n-1, 1, -1
        y0 = 2.0_r8 * y1 - laplacian(y1) - y2 + f(j) * x
        yt => y2  !! Shift the sequence values
        y2 => y1
        y1 => y0
        y0 => yt
      end do

      y = y1 - 0.5_r8 * laplacian(y1) - y2 + f(0) * x

    end function PolynomialFilter

    function GaussianFilter( x, lambda ) result( y )

      real(kind=r8), dimension(:,:), intent(inout) :: x
      real(kind=r8),                 intent(in)    :: lambda
      real(kind=r8), dimension(size(x,dim=1),size(x,dim=2)) :: y

      y = x - lambda * laplacian(x)

    end function GaussianFilter

    subroutine CreateLaplacian( mask, xset, aset, cvtx, cnbr, cmat )

      use GraphModule

      integer, dimension(:), intent(in) :: mask              ! Node mask
      integer, dimension(:), intent(in) :: xset              ! Node attribute set index
      type(ASetType), dimension(:), intent(in) :: aset       ! Attribute sets
      integer, dimension(:,:), intent(in) :: cvtx            ! Cell vertices
      integer, dimension(:,:), intent(in), optional :: cnbr  ! Cell neighbors (encoded)
      integer, dimension(:), intent(in), optional :: cmat    ! Cell materials

      integer, dimension(size(mask)) :: tag
      integer, dimension(:), pointer :: nbr, index
      integer :: nnod, ncell, nvtx, i, j, k, jnbr, dimen
      logical :: multimaterial
      type(NGraphType) :: g

      integer, dimension(3,4), parameter :: tet_face_vtx = &
          reshape( source=(/ 2,3,4, 1,4,3, 1,2,4, 1,3,2 /), shape=(/3,4/) )
      integer, dimension(2,3), parameter :: tri_face_vtx = &
          reshape( source=(/ 2,3, 3,1, 1,2 /), shape=(/2,3/) )

      nnod  = size(mask)
      nvtx  = size(cvtx, dim=1)
      ncell = size(cvtx, dim=2)

      tag = mask

      if (present(cnbr) .and. present(cmat)) then
        multimaterial = .true.
      else
        multimaterial = .false.
      end if

      g = CreateGraph (nnod, directed=.true., mult_edge=.true.)

      !! Add the edges of the surface/line network to the graph.

      if (multimaterial) then

        !! Make an initial pass through the cells adding the edges of
        !! material interface faces and boundary faces only.

        do j = 1, ncell
          do k = 1, nvtx
            if (cnbr(k,j) > 0) cycle  ! This is an interior face
            if (cnbr(k,j) < 0) then   ! This is an interface face
              jnbr = 1 + (abs(cnbr(k,j)) - 1) / nvtx
              if (cmat(jnbr) <= cmat(j)) cycle  ! We'll do this one later.
            end if
            select case (nvtx)
            case (3)
              call AddClique (g, cvtx(tri_face_vtx(:,k),j))
            case (4)
              call AddClique (g, cvtx(tet_face_vtx(:,k),j))
            end select
          end do
        end do

        dimen = nvtx - 2

      else

        do j = 1, ncell
         call AddClique (g, cvtx(:,j))
        end do

        dimen = nvtx - 1

      end if

      !! Examine the surface edges to determine the topological hierarchy of
      !! point types: surface interior, surface boundary, and boundary of
      !! surface boundary.  Nodes of one type are blinded to those of the
      !! preceding types by dropping the relevent edges.

      do j = 1, nnod

        call GetNeighborList (g, j, nbr, index)
        if (size(index) == 0) cycle

        if (tag(j) == 0) then

          call DeleteEdge (g, j) !! Ignore this node; blind it to all other nodes.

        else

          tag(j) = 0  !! Ignore this node in the subsequent pass throught the cells.

          select case (dimen)

          case (1)  !! Line Network

            !! The degree of this node is SIZE(INDEX):
            !!   degree = 1 <==> line endpoint node
            !!   degree = 2 <==> line interior node
            !!   degree > 2 <==> line junction node

            if (size(index) /= 2) then  !! Blind this node to all other nodes.
              call DeleteEdge (g, j)
            end if

          case (2)  !! Surface Network

            !! index = 1 <==> surface boundary edge
            !! index = 2 <==> surface interior edge
            !! index > 2 <==> surface singularity edge (e.g. triple line edge)

            if (any(index /= 2)) then

              !! This node lies on a surface boundary or singularity.
              !! Blind it to all nodes but those connected by boundary or
              !! singularity edges by dropping all surface-interior edges.

              do i = 1, size(index)
                if (index(i) == 2) then
                  call DeleteEdge (g, j, nbr(i))
                end if
              end do

              !! The only edges remaining for this node are boundary or singularity
              !! edges which link it to other boundary or singularity nodes.
              !! COUNT(INDEX /= 2) is the resulting degree of this node:
              !!   degree = 1 <==> line endpoint node (very strange!)
              !!   degree = 2 <==> line interior node
              !!   degree > 2 <==> line junction node (e.g. a quadruple point)

              if (count(index /= 2) /= 2) then  !! Blind this node to all other nodes.
                call DeleteEdge (g, j)
              end if

            end if

          end select

        end if

        deallocate (nbr, index)

      end do

      if (multimaterial) then
        !! Make a second pass through the cells, adding the edges for the material
        !! nodes.  Note that the interface and boundary nodes have been masked off.
        do j = 1, ncell
          do k = 1, nvtx
            if (tag(cvtx(k,j)) == 0) cycle
            select case (nvtx)
            case (3)
              call AddEdge (g, cvtx(k,j), cvtx(tri_face_vtx(:,k),j))
            case (4)
              call AddEdge (g, cvtx(k,j), cvtx(tet_face_vtx(:,k),j))
            end select
          end do
        end do
      end if

      !! Finally we examine all edges, dropping those that don't respect the hierarchy
      !! of attributes: N is blind to M if there is an attribute of N not shared by M.

      do j = 1, nnod
       if (xset(j) == 0) cycle
        call GetNeighborList (g, j, nbr)
        if (size(nbr) == 0) cycle
        do k = 1, size(nbr)
          if (xset(j) == xset(nbr(k))) cycle
          if (xset(nbr(k)) == 0) then
            call DeleteEdge (g, j, nbr(k))
            cycle
          end if
          do i = 1, size(aset(xset(j)) % attr)
            if (any( aset(xset(j)) % attr(i) == aset(xset(nbr(k))) % attr)) cycle
            call DeleteEdge (g, j, nbr(k))
            exit
          end do
        end do
        deallocate (nbr)
      end do

      !! Generate the neighbor structure which defines the topological Laplacian.
      call GetNeighborStructure (g, xnbrs, nbrs)

      call DeleteGraph (g)

    end subroutine CreateLaplacian

    subroutine DeleteLaplacian( )

      deallocate (xnbrs, nbrs)

    end subroutine DeleteLaplacian

    function laplacian (x) result (y)

      real(kind=r8), dimension(:,:), intent(in) :: x
      real(kind=r8), dimension(size(x,dim=1),size(x,dim=2)) :: y

      integer :: j, degree

      do j = 1, size(x,dim=2)
        degree = xnbrs(j+1) - xnbrs(j)
        if (degree == 0) then
          y(:,j) = 0.0_r8
        else
          y(:,j) = x(:,j) - sum( x(:,nbrs(xnbrs(j):xnbrs(j+1)-1)), dim=2 ) / degree
        end if
      end do

    end function laplacian

end module LowPassFilterModule


program test

    use, intrinsic:: ieee_arithmetic
    use lineclip,only: Ccohensutherland, cohensutherland
    use assert, only: wp, errorstop, assert_isclose

    implicit none

    call test_lineclip()
    call test_array_lineclip()

contains

subroutine test_array_lineclip()

    integer, parameter :: Np=2
    real(wp), dimension(Np) :: length, x1,x2,y1,y2
    real(wp),parameter :: xmin=1., ymax=5.,xmax=4., ymin=3.
    real(wp),parameter :: truelength(Np) =[2.40370083, 3.]

    x1=[0.,0.]
    y1=[0.,4.]
    x2=[4.,5.]
    y2=[6.,4.]

    call Ccohensutherland(xmin,ymax,xmax,ymin,Np,x1,y1,x2,y2)

    length = hypot((x2-x1), (y2-y1))
    call assert_isclose(length, truelength)

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

    call cohensutherland(xmin,ymax,xmax,ymin,x1,y1,x2,y2)

    length = hypot((x2-x1), (y2-y1))
    call assert_isclose(length, truelength)

    print *, 'OK array_lineclip'

end subroutine test_array_lineclip

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

subroutine test_lineclip()

    real(wp), parameter :: xmin=1., ymax=5., xmax=4., ymin=3.
    real(wp) :: x1, y1, x2, y2  !not a parameter

!    make box with corners LL/UR (1,3) (4,5)
!    and line segment with ends (0,0) (4,6)

! LOWER to UPPER test
    x1=0.; y1=0.; x2=4.; y2=6.

    call cohensutherland(xmin,ymax,xmax,ymin,x1,y1,x2,y2)

    call assert_isclose(x1, 2._wp)
    call assert_isclose(y1, 3._wp)
    call assert_isclose(x2, 3.3333333_wp)
    call assert_isclose(y2, 5._wp)

! no intersection test
    x1=0.;y1=0.1;x2=0.;y2=0.1

    call cohensutherland(xmin,ymax,xmax,ymin,x1,y1,x2,y2)
    if (.not.all(ieee_is_nan([x1,y1,x2,y2]))) call errorstop() !'failed no intersection test'

    print *, 'OK lineclip'

end subroutine test_lineclip

end program


      program test_uniax_tens_ps
        use tensor_operations

        implicit none
        double precision::  sig, eps, H, C, ome,alp, gam, sig_0, epsp_b,
     &      epsp_bn, D_epsp_b,A_c, f, Teps
        !Parameters GTN mode
        double precision:: xE, xnu, sigy0, q1, q2, q3, f_0, f_n, s_n,
     &   f_f, E_n, NU, mu, q_el, kap
        double precision :: d_sig_0_d_epsp_b, dsig_deps, df_deps,
     &        depsp_b_deps
        double precision :: dp_deps_v, df_deps_v, depsp_b_deps_v, epsv_y
        double precision, dimension(13):: mat_param
        double precision:: l0, uf, Teps_f, D_u ,u, Teps1, D_eps, eps_fi,
     &   l, lsi,lf, l_y
        double precision:: pi, steps
        double precision:: ph, eps_vf, epsv, epsv1, D_epsv, eps_y
        integer :: i, stat

        mat_param(1)   = 300.0*200.0              ! xE
        mat_param(2)   = 0.33                 ! xnu
        mat_param(3)   = 200.0 !200           ! xsigy0
        mat_param(4)   = 50.0*mat_param(3);   ! 50   ! xH
        mat_param(5)   = 100.0*mat_param(3);  ! 10  ! xh
        mat_param(6)   = 1.5                  ! q1
        mat_param(7)   = 1.0                  ! q2
        mat_param(8)   = 1.5                  ! q1=q3 Aricle G.Vadillo
        mat_param(9)   = 0.0                ! f_0
        mat_param(10)  = 0.04                  ! f_n
        mat_param(11)  = 0.1                  ! s_n
        mat_param(12)  = 0.2025               ! f_f
        mat_param(13)  = 0.3                  ! E_n

        xE       = mat_param(1)
        xnu      = mat_param(2)
        sigy0    = mat_param(3)
        q1       = mat_param(6)
        q2       = mat_param(7)
        q3       = q1**2
        f        = mat_param(9)
        f_n      = mat_param(10)
        s_n      = mat_param(11)
        f_f      = mat_param(12)
        E_n      = mat_param(13)
        mu       = xE/(2.0*(1.0+xnu))
        kap      = xE/(3.0*(1.0-2.0*xnu))
        q_el     = -0.5*(kap-2.0/3.0*mu)/(kap+1.0/3.0*mu)
        NU       = 0.1

        pi       = 4.D0*DATAN(1.D0)
c        initial values

c=======================================================================
c                     Unixial tension Plane stress
c=======================================================================
c test on a plane stress element
c the direction of stressing is at 45” with the X-axis
c Test test is displacement controlled, with equal increments of 2.5 per cent the original length (I understand that this is the Abaqus job)

cThe set of non-linear equations (32)-(34) is integrated using a forward Euler scheme with equal
cstrain increments of 1/1000 of the yield strain

        D_u=0.2/10000.0

        l0=0.004
        Teps_f=0.38  !1.0 maximum true strain
        lf=(DEXP(Teps_f)-1)*l0+l0
        eps_fi=(lf-l0)/l0
        steps=(lf-l0)/D_u
        print*, "steps" , steps

        i=0
        eps_y=sigy0/xE !Strain at yield point
        l=0
        l=l+eps_y*l0+l0  !Length at yied point
        lsi=l !longitud od start of iteration
        Teps=dlog(1+eps_y)  !This must be the logarithmic strain defined as eps_t=ln (1+eps)
        print*, "eps_y", eps_y,"Teps_y",Teps , "Length at yied point",
     &       l, "Final lengt", lf, "eps max"
     &     ,eps_fi
        sig=sigy0 !This must be the macroscopic axial true stress defined as sig_t=sig*(1+eps)
        sig_0=sigy0
        epsp_b=0.0
        open(unit=1, iostat=stat, file='data_test_ut_ps.csv',
     $         status='old')
             if (stat == 0) close(1, status='delete')
        open(1, file = 'data_test_ut_ps.csv', status = 'new')
        !u=0.0
   10   if (l<lf) then
            i =i+ 1

            u=D_u*i
            l=lsi+u
            print*, "l",l
            Teps1=dlog(1+u/l0+eps_y)
            D_eps=Teps1-Teps
            ome=sig/sig_0
            alp=0.5*q1*q2*f*sinh(0.5*q2*ome)
            gam=q1*cosh(0.5*q2*ome)-q3*f
            !print*, "ome", ome, "alp", alp,"gam" , gam
            d_sig_0_d_epsp_b=3.0*mu*NU*(sig_0/sigy0+3.0*mu*epsp_b/sigy0)
     &              **(NU-1.0)/(1.0-NU*(sig_0/sigy0+
     &              3.0*mu*epsp_b/sigy0)**(NU-1))
            A_c=f_n/(s_n*(2.0*pi)**0.5)*DEXP(-1.0/2.0*((epsp_b-E_n)/
     &           s_n)**2)
            H=d_sig_0_d_epsp_b*(ome**2+alp*ome)*(ome**2+alp*ome-sig_0*
     &             A_c*gam)-3.0*sig_0*(1.0-f)*alp*gam
            C=1.0+alp/ome+H/(xE*ome*(ome+alp))
            !print*, d_sig_0_d_epsp_b, "A_c", A_c, "H", H, "C", A_c

            dsig_deps=H/(C*ome*(ome+alp))
            df_deps=3.0*alp*(1.0-f)/(C*ome)+A_c*(ome+alp)/(C*(1.0-f))
            depsp_b_deps=(ome+alp)/(C*(1.0-f))

            sig =sig+ dsig_deps*D_eps
            f =f+ df_deps*D_eps
            epsp_bn =epsp_b
            epsp_b =epsp_b+ depsp_b_deps*D_eps
            D_epsp_b=epsp_b-epsp_bn
            sig_0=sig_0+d_sig_0_d_epsp_b*D_epsp_b
            Teps=Teps1
c In Figure 4, the stress is plotted as a function of the logarithmic strain
c In Figure 5, The void volume fraction,f, is plotted as a function of strain
            !output data into a file as follow:
              !eps       = strain
              !sig/sigy0 = realtion stress
              !f         = void volume fraction
              !epsp_b    = equivalent plastic strain
            write(1,*) Teps, sig/sigy0, f, epsp_b
            goto 10
        end if
        close(1)

      end program test_uniax_tens_ps


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vhsgs.f
c
c     this file contains code and documentation for subroutines
c     vhsgs and vhsgsi
c
c ... files which must be loaded with vhsgs.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvhsgs,lvhsgs,work,lwork,ierror)
c
c
c     subroutine vhsgs performs the vector spherical harmonic synthesis
c     of the arrays br, bi, cr, and ci and stores the result in the
c     arrays v and w.  the synthesis is performed on an equally spaced
c     longitude grid and a gaussian colatitude grid (measured from
c     the north pole). v(i,j) and w(i,j) are the colatitudinal and
c     east longitudinal components respectively, located at the i(th)
c     colatitude gaussian point (see nlat below) and longitude
c     phi(j) = (j-1)*2*pi/nlon.  the spectral respresentation of (v,w)
c     is given below at output parameters v,w.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 2  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 3  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 5  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 6  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 8  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c
c     nt     the number of syntheses.  in the program that calls vhsgs,
c            the arrays v,w,br,bi,cr, and ci can be three dimensional
c            in which case multiple syntheses will be performed.
c            the third index is the synthesis index which assumes the
c            values k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls vhags. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls vhsgs. jdvw must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            in the spectral representation of v(i,j) and w(i,j) given
c            below at the discription of output parameters v and w.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhsgs. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhsgs. ndab must be at
c            least nlat.
c
c     wvhsgs an array which must be initialized by subroutine vhsgsi.
c            once initialized, wvhsgs can be used repeatedly by vhsgs
c            as long as nlon and nlat remain unchanged.  wvhsgs must
c            not be altered between calls of vhsgs.
c
c     lvhsgs the dimension of the array wvhsgs as it appears in the
c            program that calls vhsgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsgs must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhsgs. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c
c                       (2*nt+1)*nlat*nlon
c
c            if ityp .gt. 2 then lwork must be at least
c
c                        (2*nt+1)*l2*nlon
c
c     **************************************************************
c
c     output parameters
c
c     v,w    two or three dimensional arrays (see input parameter nt)
c            in which the synthesis is stored. v is the colatitudinal
c            component and w is the east longitudinal component.
c            v(i,j),w(i,j) contain the components at the guassian colatitude
c            point theta(i) and longitude phi(j) = (j-1)*2*pi/nlon.
c            the index ranges are defined above at the input parameter
c            ityp. v and w are computed from the formulas given below.
c
c
c     define
c
c     1.  theta is colatitude and phi is east longitude
c
c     2.  the normalized associated legendre funnctions
c
c         pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative
c                        of (x**2-1)**n with respect to x=cos(theta)
c
c     3.  vbar(m,n,theta) = the derivative of pbar(m,n,theta) with
c                           respect to theta divided by the square
c                           root of n(n+1).
c
c         vbar(m,n,theta) is more easily computed in the form
c
c         vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta)
c         -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1)))
c
c     4.  wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided
c                           by the square root of n(n+1).
c
c         wbar(m,n,theta) is more easily computed in the form
c
c         wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1))
c         *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta))
c         /(2*sqrt(n*(n+1)))
c
c
c    the colatitudnal dependence of the normalized surface vector
c                spherical harmonics are defined by
c
c     5.    bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta))
c
c     6.    cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta))
c
c
c    the coordinate to index mappings
c
c     7.   theta(i) = i(th) gaussian grid point and phi(j) = (j-1)*2*pi/nlon
c
c
c     the maximum (plus one) longitudinal wave number
c
c     8.     mmax = min0(nlat,nlon/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    if we further define the output vector as
c
c     9.    h(i,j) = (v(i,j),w(i,j))
c
c    and the complex coefficients
c
c     10.   b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1))
c
c     11.   c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1))
c
c
c    then for i=1,...,nlat and  j=1,...,nlon
c
c        the expansion for real h(i,j) takes the form
c
c     h(i,j) = the sum from n=1 to n=nlat-1 of the real part of
c
c         .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i)))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c              b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j))
c             +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j))
c
c   *************************************************************
c
c   in terms of real variables this expansion takes the form
c
c             for i=1,...,nlat and  j=1,...,nlon
c
c     v(i,j) = the sum from n=1 to n=nlat-1 of
c
c               .5*br(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c       (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c    and for i=1,...,nlat and  j=1,...,nlon
c
c     w(i,j) = the sum from n=1 to n=nlat-1 of
c
c              -.5*cr(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c      -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c
c      br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are
c      assumed zero for m even.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lvhsgs
c            = 10 error in the specification of lwork
c
c
c     subroutine vhsgsi(nlat,nlon,wvhsgs,lvhsgs,dwork,ldwork,ierror)
c
c     subroutine vhsgsi initializes the array wvhsgs which can then be
c     used repeatedly by subroutine vhsgs until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lvhsgs the dimension of the array wvhsgs as it appears in the
c            program that calls vhsgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsgs must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
c
c     dwork a double precision work array that does not need to be saved
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls vhsgsi. ldwork must be at least
c
c                 (3*nlat*(nlat+3)+2)/2

c
c     **************************************************************
c
c     output parameters
c
c     wvhsgs an array which is initialized for use by subroutine vhsgs.
c            once initialized, wvhsgs can be used repeatedly by vhsgs
c            as long as nlat and nlon remain unchanged.  wvhsgs must not
c            be altered between calls of vhsgs.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lvhsgs
c            = 4  error in the specification of lwork
c
      subroutine vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
     +                 mdab,ndab,wvhsgs,lvhsgs,work,lwork,ierror)
      dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          work(1),wvhsgs(1)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      if(ityp.lt.0 .or. ityp.gt.8) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((ityp.le.2 .and. idvw.lt.nlat) .or.
     1   (ityp.gt.2 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdab .lt. mmax) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
      idz = (mmax*(nlat+nlat-mmax+1))/2
      lzimn = idz*imid
      if(lvhsgs .lt. lzimn+lzimn+nlon+15) return
      ierror = 10
      idv = nlat
      if(ityp .gt. 2) idv = imid
      lnl = nt*idv*nlon
      if(lwork .lt. lnl+lnl+idv*nlon) return
      ierror = 0
      ist = 0
      if(ityp .le. 2) ist = imid
c
c     set wvhsgs pointers
c
      lmn = nlat*(nlat+1)/2
      jw1 = 1
      jw2 = jw1+imid*lmn
      jw3 = jw2+imid*lmn
c
c     set work pointers
c
      iw1 = ist+1
      iw2 = lnl+1
      iw3 = iw2+ist
      iw4 = iw2+lnl

      call vhsgs1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab,
     +           br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3),
     +          work(iw4),idz,wvhsgs(jw1),wvhsgs(jw2),wvhsgs(jw3))
      return
      end

      subroutine vhsgs1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,
     1   ndab,br,bi,cr,ci,idv,ve,vo,we,wo,work,idz,vb,wb,wrfft)
      dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1),
     3          wo(idv,nlon,1),work(1),wrfft(1),
     4          vb(imid,1),wb(imid,1)
      nlp1 = nlat+1
      mlat = mod(nlat,2)
      mlon = mod(nlon,2)
      mmax = min0(nlat,(nlon+1)/2)
      imm1 = imid
      if(mlat .ne. 0) imm1 = imid-1
      do 10 k=1,nt
      do 10 j=1,nlon
      do 10 i=1,idv
      ve(i,j,k) = 0.
      we(i,j,k) = 0.
   10 continue
      ndo1 = nlat
      ndo2 = nlat
      if(mlat .ne. 0) ndo1 = nlat-1
      if(mlat .eq. 0) ndo2 = nlat-1
   18 itypp = ityp+1
      go to (1,100,200,300,400,500,600,700,800),itypp
c
c     case ityp=0   no symmetries
c
c     case m = 0
c
    1 continue
      do 15 k=1,nt
      do 15 np1=2,ndo2,2
      do 15 i=1,imid
      ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1)
      we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1)
   15 continue
      do 16 k=1,nt
      do 16 np1=3,ndo1,2
      do 16 i=1,imm1
      vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1)
      wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1)
   16 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 30 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 26
      do 25 k=1,nt
      do 24 np1=mp1,ndo1,2
      mn = mb+np1
      do 23 i=1,imm1
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
   23 continue
      if(mlat .eq. 0) go to 24
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,mn)
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,mn)
   24 continue
   25 continue
   26 if(mp2 .gt. ndo2) go to 30
      do 29 k=1,nt
      do 28 np1=mp2,ndo2,2
      mn = mb+np1
      do 27 i=1,imm1
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
   27 continue
      if(mlat .eq. 0) go to 28
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,mn)
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,mn)
   28 continue
   29 continue
   30 continue
      go to 950
c
c     case ityp=1   no symmetries,  cr and ci equal zero
c
c     case m = 0
c
  100 continue
      do 115 k=1,nt
      do 115 np1=2,ndo2,2
      do 115 i=1,imid
      ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1)
  115 continue
      do 116 k=1,nt
      do 116 np1=3,ndo1,2
      do 116 i=1,imm1
      vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1)
  116 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 130 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 126
      do 125 k=1,nt
      do 124 np1=mp1,ndo1,2
      mn = mb+np1
      do 123 i=1,imm1
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
  123 continue
      if(mlat .eq. 0) go to 124
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,mn)
  124 continue
  125 continue
  126 if(mp2 .gt. ndo2) go to 130
      do 129 k=1,nt
      do 128 np1=mp2,ndo2,2
      mn = mb+np1
      do 127 i=1,imm1
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
  127 continue
      if(mlat .eq. 0) go to 128
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,mn)
  128 continue
  129 continue
  130 continue
      go to 950
c
c     case ityp=2   no symmetries,  br and bi are equal to zero
c
c     case m = 0
c
  200 do 215 k=1,nt
      do 215 np1=2,ndo2,2
      do 215 i=1,imid
      we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1)
  215 continue
      do 216 k=1,nt
      do 216 np1=3,ndo1,2
      do 216 i=1,imm1
      wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1)
  216 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 230 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 226
      do 225 k=1,nt
      do 224 np1=mp1,ndo1,2
      mn = mb+np1
      do 223 i=1,imm1
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
  223 continue
      if(mlat .eq. 0) go to 224
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,mn)
  224 continue
  225 continue
  226 if(mp2 .gt. ndo2) go to 230
      do 229 k=1,nt
      do 228 np1=mp2,ndo2,2
      mn = mb+np1
      do 227 i=1,imm1
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
  227 continue
      if(mlat .eq. 0) go to 228
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,mn)
  228 continue
  229 continue
  230 continue
      go to 950
c
c     case ityp=3   v even,  w odd
c
c     case m = 0
c
  300 do 315 k=1,nt
      do 315 np1=2,ndo2,2
      do 315 i=1,imid
      ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1)
  315 continue
      do 316 k=1,nt
      do 316 np1=3,ndo1,2
      do 316 i=1,imm1
      wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1)
  316 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 330 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 326
      do 325 k=1,nt
      do 324 np1=mp1,ndo1,2
      mn = mb+np1
      do 323 i=1,imm1
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
  323 continue
      if(mlat .eq. 0) go to 324
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,mn)
  324 continue
  325 continue
  326 if(mp2 .gt. ndo2) go to 330
      do 329 k=1,nt
      do 328 np1=mp2,ndo2,2
      mn = mb+np1
      do 327 i=1,imm1
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
  327 continue
      if(mlat .eq. 0) go to 328
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,mn)
  328 continue
  329 continue
  330 continue
      go to 950
c
c     case ityp=4   v even,  w odd, and both cr and ci equal zero
c
c     case m = 0
c
  400 do 415 k=1,nt
      do 415 np1=2,ndo2,2
      do 415 i=1,imid
      ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1)
  415 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 430 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp2 .gt. ndo2) go to 430
      do 429 k=1,nt
      do 428 np1=mp2,ndo2,2
      mn = mb+np1
      do 427 i=1,imm1
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
  427 continue
      if(mlat .eq. 0) go to 428
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,mn)
  428 continue
  429 continue
  430 continue
      go to 950
c
c     case ityp=5   v even,  w odd,     br and bi equal zero
c
c     case m = 0
c
  500 do 516 k=1,nt
      do 516 np1=3,ndo1,2
      do 516 i=1,imm1
      wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1)
  516 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 530 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 530
      do 525 k=1,nt
      do 524 np1=mp1,ndo1,2
      mn = mb+np1
      do 523 i=1,imm1
      ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
  523 continue
      if(mlat .eq. 0) go to 524
      ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,mn)
      ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,mn)
  524 continue
  525 continue
  530 continue
      go to 950
c
c     case ityp=6   v odd  ,  w even
c
c     case m = 0
c
  600 do 615 k=1,nt
      do 615 np1=2,ndo2,2
      do 615 i=1,imid
      we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1)
  615 continue
      do 616 k=1,nt
      do 616 np1=3,ndo1,2
      do 616 i=1,imm1
      vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1)
  616 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 630 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 626
      do 625 k=1,nt
      do 624 np1=mp1,ndo1,2
      mn = mb+np1
      do 623 i=1,imm1
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
  623 continue
      if(mlat .eq. 0) go to 624
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,mn)
  624 continue
  625 continue
  626 if(mp2 .gt. ndo2) go to 630
      do 629 k=1,nt
      do 628 np1=mp2,ndo2,2
      mn = mb+np1
      do 627 i=1,imm1
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
  627 continue
      if(mlat .eq. 0) go to 628
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,mn)
  628 continue
  629 continue
  630 continue
      go to 950
c
c     case ityp=7   v odd, w even   cr and ci equal zero
c
c     case m = 0
c
  700 do 716 k=1,nt
      do 716 np1=3,ndo1,2
      do 716 i=1,imm1
      vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1)
  716 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 730 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 730
      do 725 k=1,nt
      do 724 np1=mp1,ndo1,2
      mn = mb+np1
      do 723 i=1,imm1
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn)
  723 continue
      if(mlat .eq. 0) go to 724
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,mn)
  724 continue
  725 continue
  730 continue
      go to 950
c
c     case ityp=8   v odd,  w even   br and bi equal zero
c
c     case m = 0
c
  800 do 815 k=1,nt
      do 815 np1=2,ndo2,2
      do 815 i=1,imid
      we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1)
  815 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 830 mp1=2,mmax
      m = mp1-1
c     mb = m*(nlat-1)-(m*(m-1))/2
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp2 .gt. ndo2) go to 830
      do 829 k=1,nt
      do 828 np1=mp2,ndo2,2
      mn = mb+np1
      do 827 i=1,imm1
      vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn)
      vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn)
      we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn)
      we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn)
  827 continue
      if(mlat .eq. 0) go to 828
      we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,mn)
      we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,mn)
  828 continue
  829 continue
  830 continue
  950 continue
      do 14 k=1,nt
      call hrfftb(idv,nlon,ve(1,1,k),idv,wrfft,work)
      call hrfftb(idv,nlon,we(1,1,k),idv,wrfft,work)
   14 continue
      if(ityp .gt. 2) go to 12
      do 60 k=1,nt
      do 60 j=1,nlon
      do 60 i=1,imm1
      v(i,j,k) = .5*(ve(i,j,k)+vo(i,j,k))
      w(i,j,k) = .5*(we(i,j,k)+wo(i,j,k))
      v(nlp1-i,j,k) = .5*(ve(i,j,k)-vo(i,j,k))
      w(nlp1-i,j,k) = .5*(we(i,j,k)-wo(i,j,k))
   60 continue
      go to 13
   12 do 11 k=1,nt
      do 11 j=1,nlon
      do 11 i=1,imm1
      v(i,j,k) = .5*ve(i,j,k)
      w(i,j,k) = .5*we(i,j,k)
   11 continue
   13 if(mlat .eq. 0) return
      do 65 k=1,nt
      do 65 j=1,nlon
      v(imid,j,k) = .5*ve(imid,j,k)
      w(imid,j,k) = .5*we(imid,j,k)
   65 continue
      return
      end
      subroutine vhsgsi(nlat,nlon,wvhsgs,lvhsgs,dwork,ldwork,ierror)
c
c     subroutine vhsfsi computes the gaussian points theta, gauss
c     weights wts, and the components vb and wb of the vector
c     harmonics. all quantities are computed internally in double
c     precision but returned in single precision and are therfore
c     accurate to single precision.
c
c     set imid = (nlat+1)/2 and lmn=(nlat*(nlat+1))/2 then
c     wvhsgs must have 2*(imid*lmn+nlat)+nlon+15 locations
c
c     double precision array dwork must have
c       3*nlat*(nlat+1)+5*nlat+1 = nlat*(3*nlat+8)+1
c     locations which is determined by the size of dthet,
c     dwts, dwork, and dpbar in vhsgs1
c
      dimension wvhsgs(*)
      double precision dwork(*)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      imid = (nlat+1)/2
      lmn = (nlat*(nlat+1))/2
      if(lvhsgs .lt. 2*(imid*lmn)+nlon+15) return
      ierror = 4
      if (ldwork .lt. (nlat*3*(nlat+3)+2)/2) return
      ierror = 0
c
c     set saved work space pointers
c
      jw1 = 1
      jw2 = jw1+imid*lmn
      jw3 = jw2+imid*lmn
c
c     set unsaved work space pointers
c
      iw1 = 1
      iw2 = iw1+nlat
      iw3 = iw2+nlat
      iw4 = iw3+3*imid*nlat
c     iw2 = iw1+nlat+nlat
c     iw3 = iw2+nlat+nlat
c     iw4 = iw3+6*imid*nlat
      call vhgsi1(nlat,imid,wvhsgs(jw1),wvhsgs(jw2),
     +dwork(iw1),dwork(iw2),dwork(iw3),dwork(iw4))
      call hrffti(nlon,wvhsgs(jw3))
      return
      end
      subroutine vhgsi1(nlat,imid,vb,wb,dthet,dwts,dpbar,work)
      dimension vb(imid,*),wb(imid,*)
      double precision abel,bbel,cbel,ssqr2,dcf
      double precision dthet(*),dwts(*),dpbar(imid,nlat,3),work(*)
c
c     compute gauss points and weights
c     use dpbar (length 3*nnlat*(nnlat+1)) as work space for gaqd
c
      lwk = nlat*(nlat+2)
      call gaqd(nlat,dthet,dwts,dpbar,lwk,ierror)
c
c     compute associated legendre functions
c
c     compute m=n=0 legendre polynomials for all theta(i)
c
      ssqr2 = 1./dsqrt(2.d0)
      do 90 i=1,imid
      dpbar(i,1,1) = ssqr2
      vb(i,1) = 0.
      wb(i,1) = 0.
   90 continue
c
c     main loop for remaining vb, and wb
c
      do 100 n=1,nlat-1
      nm = mod(n-2,3)+1
      nz = mod(n-1,3)+1
      np = mod(n,3)+1
c
c     compute dpbar for m=0
c
      call dnlfk(0,n,work)
      mn = indx(0,n,nlat)
      do 105 i=1,imid
      call dnlft(0,n,dthet(i),work,dpbar(i,1,np))
c      pbar(i,mn) = dpbar(i,1,np)
  105 continue
c
c     compute dpbar for m=1
c
      call dnlfk(1,n,work)
      mn = indx(1,n,nlat)
      do 106 i=1,imid
      call dnlft(1,n,dthet(i),work,dpbar(i,2,np))
c      pbar(i,mn) = dpbar(i,2,np)
  106 continue
  104 continue
c
c     compute and store dpbar for m=2,n
c
      if(n.lt.2) go to 108
      do 107 m=2,n
      abel = dsqrt(dble(float((2*n+1)*(m+n-2)*(m+n-3)))/
     1                dble(float((2*n-3)*(m+n-1)*(m+n))))
      bbel = dsqrt(dble(float((2*n+1)*(n-m-1)*(n-m)))/
     1                dble(float((2*n-3)*(m+n-1)*(m+n))))
      cbel = dsqrt(dble(float((n-m+1)*(n-m+2)))/
     1                dble(float((m+n-1)*(m+n))))
      id = indx(m,n,nlat)
      if (m.ge.n-1) go to 102
      do 103 i=1,imid
      dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)+bbel*dpbar(i,m+1,nm)
     1                                         -cbel*dpbar(i,m-1,np)
c      pbar(i,id) = dpbar(i,m+1,np)
  103 continue
      go to 107
  102 do 101 i=1,imid
      dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)-cbel*dpbar(i,m-1,np)
c      pbar(i,id) = dpbar(i,m+1,np)
  101 continue
  107 continue
c
c     compute the derivative of the functions
c
  108 ix = indx(0,n,nlat)
      iy = indx(n,n,nlat)
      do 125 i=1,imid
      vb(i,ix) = -dpbar(i,2,np)
      vb(i,iy) = dpbar(i,n,np)/dsqrt(dble(float(2*(n+1))))
125   continue
c
      if(n.eq.1) go to 131
      dcf = dsqrt(dble(float(4*n*(n+1))))
      do 130 m=1,n-1
      ix = indx(m,n,nlat)
      abel = dsqrt(dble(float((n+m)*(n-m+1))))/dcf
      bbel = dsqrt(dble(float((n-m)*(n+m+1))))/dcf
      do 130 i=1,imid
      vb(i,ix) = abel*dpbar(i,m,np)-bbel*dpbar(i,m+2,np)
130   continue
c
c     compute the vector harmonic w(theta) = m*pbar/cos(theta)
c
c     set wb=0 for m=0
c
  131 ix = indx(0,n,nlat)
      do 220 i=1,imid
      wb(i,ix) = 0.d0
220   continue
c
c     compute wb for m=1,n
c
      dcf = dsqrt(dble(float(n+n+1))/dble(float(4*n*(n+1)*(n+n-1))))
      do 230 m=1,n
      ix = indx(m,n,nlat)
      abel = dcf*dsqrt(dble(float((n+m)*(n+m-1))))
      bbel = dcf*dsqrt(dble(float((n-m)*(n-m-1))))
      if(m.ge.n-1) go to 231
      do 229 i=1,imid
      wb(i,ix) = abel*dpbar(i,m,nz) + bbel*dpbar(i,m+2,nz)
  229 continue
      go to 230
  231 do 228 i=1,imid
      wb(i,ix) = abel*dpbar(i,m,nz)
  228 continue
  230 continue
  100 continue
      return
      end


function orbmodel(t,sol)
!returns impact parameter b.
use precision
implicit none
!import vars
real(double) :: t,sol(6),orbmodel
!local vars
real(double) :: Pi,tPi,pid2,G
real(double) :: per,bs2,b,ecw,esw,eccn,w,adrs,incl,epoch,Eanom,phi0
real(double) :: phi,Manom,Tanom,drs,x2,y2
real(double) :: trueanomaly,distance

Pi=acos(-1.d0)!define Pi and 2*Pi
tPi=2.0d0*Pi
pid2=Pi/2.0d0
G=6.674d-11 !N m^2 kg^-2  Gravitation constant

per=sol(3)        !Period (days)
bs2=sol(4)*sol(4) !impact parameter squared
b=sqrt(bs2)       !impact parameter

ecw=sol(6)
esw=sol(5)
eccn=(ecw*ecw+esw*esw) !eccentricity

if(eccn.ge.1.0) eccn=0.99 !force upper limit on eccentricity
if(eccn.eq.0.0d0)then
   w=0.0d0
else
   if(ecw.eq.0.0d0)then
       w=Pi/2.0d0
   else
       w=atan(esw/ecw)
   endif
   if((ecw.gt.0.0d0).and.(esw.lt.0.0d0))then
       w=tPi+w
   elseif((ecw.lt.0.0d0).and.(esw.ge.0.0d0))then
       w=Pi+w
   elseif((ecw.le.0.0d0).and.(esw.lt.0.0d0))then
       w=Pi+w
   endif
endif

!calculate the scaled semi-major axis a/R*
adrs=1000.0*sol(1)*G*(Per*86400.0d0)**2/(3.0d0*Pi)
adrs=adrs**(1.0d0/3.0d0)

epoch=sol(2)   !center of transit time (days)

Eanom=tan(w/2.0d0)/sqrt((1.0d0+eccn)/(1.0d0-eccn)) !mean anomaly
Eanom=2.0d0*atan(Eanom)
phi0=Eanom-eccn*sin(Eanom)

phi=t/per-floor(t/per)
phi=phi*tPi+phi0
Manom=phi
if(Manom.gt.tPi) Manom=Manom-tPi
if(Manom.lt.0.0d0) Manom=Manom+tPi
call kepler(Manom,Eanom,eccn)
Tanom=trueanomaly(eccn,Eanom)
if(phi.gt.Pi) phi=phi-tPi
drs=distance(adrs,eccn,Tanom)

incl=acos(b/drs)
x2=drs*Sin(Tanom-w)
y2=drs*Cos(Tanom-w)*cos(incl)
b=sqrt(x2*x2+y2*y2)

orbmodel=b !return impact parameter for function call.

return
end


module constants
use types, only: dp
implicit none
private
public pi, e_, i_, bohr2ang, ang2bohr, Ha2eV

! Constants contain more digits than double precision, so that
! they are rounded correctly. Single letter constants contain underscore so
! that they do not clash with user variables ("e" and "i" are frequently used as
! loop variables)
real(dp), parameter :: pi    = 3.1415926535897932384626433832795_dp
real(dp), parameter :: e_    = 2.7182818284590452353602874713527_dp
complex(dp), parameter :: i_ = (0, 1)

real(dp), parameter :: Na = 6.02214129e23_dp ! Avogadro constant
! Standard uncertainty      0.00000027 (Source: 2010 CODATA)
real(dp), parameter :: Ha2eV = 27.21138505_dp    ! 1 Ha = (1 * Ha2eV) eV
! Standard uncertainty is       0.00000060 eV (Source: 2010 CODATA)

real(dp), parameter :: J2Ha = 2.29371248e17_dp  ! 1 J = (1 * J2Ha) Ha
! Standard uncertainty is     0.00000010 eV (Source: 2010 CODATA)

! Covert Ha to cm^{-1} (energy equivalent)
! 1 Ha = (1 * Ha2invcm) cm^{-1}
real(dp), parameter :: Ha2invcm = 219474.6313708_dp
! Standard uncertainty is              0.0000011 cm^{-1} (Source: 2010 CODATA)

! Conversion between Bohr (Hartree atomic units) and Angstrom
real(dp), parameter :: bohr2ang = 0.529177249_dp
real(dp), parameter :: ang2bohr = 1 / bohr2ang

! Converts eV to kcal/mol, it is assumed, that the number in eV is given per
! molecule.  1 eV = (1 * eV2kcalmol) kcal/mol
real(dp), parameter :: kcalmol2kJmol = 4.184_dp
real(dp), parameter :: kJmol2Ha = 1000 * J2Ha / Na

end module


!
!
!
  SUBROUTINE PLMBAR_MOD (LMAX, LAT, PLM)
  USE SHTOOLS
  IMPLICIT NONE
  INTEGER, PARAMETER :: LLMAX=512, JJMAX=(LLMAX+1)*(LLMAX+2)/2
  INTEGER J, J_INDEX, MJ, JMAX, LMAX
  REAL*8 LAT
  REAL*8 Z, PLM(JJMAX)
  REAL*8 COSDD
!
! Given latitude LAT (in degrees), computes *all* the fully normalized
! associated Legendre functions \bar P_{lm}(x), with x=cos(colatitude),
! to degree LMAX. Uses the SHTOOLS Legendre functions by PlmBar, and
! rescales by sqrt(2-delta(0,m)).   Last modified by GS 10-9-2007 -
!
!
! ---- Tests the latitude bounds
!
  If(abs(lat).gt.90.) then
 	        Write(88,*) "Error in Sbr. PLMBAR_MOD: Latitude is out of range"
	 	Write(88,*) "The program will STOP ----------------"
 	        Write(* ,*) "Error in Sbr. PLMBAR_MOD: Latitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 1
  elseif(lmax>llmax) then
		Write(88,*) "Error in Sbr. PLMBAR_MOD: The degree exceeds 512", lmax
	 	Write(88,*) "The program will STOP ----------------"
 	        Write(* ,*) "Error in Sbr. PLMBAR_MOD: The degree exceeds 512", lmax
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 2
  Endif
!
!
!
! ---- "z" is cos(theta), theta is co-latitude
!
	z=cosdd(90.-lat)
!
! ---- Builds the SHTOOLS Legendre functions including the Condon-Shortley phase
!
  	call PlmBar(plm, lmax, z, -1)
!
!
! ---- Scales to obtain our Legendre functions, dividing by sqrt(2-delta(0,m))
!
  	do j=1, j_index(lmax,lmax)
     		if(mj(j)/=0) plm(j)=plm(j)/sqrt(2.)
  	enddo
!
  END SUBROUTINE PLMBAR_MOD
!
!
!


program problem34
  implicit none
  integer, dimension(10) :: factorials
  integer                :: i,limit,answer=0

  limit=9999999 ! seven nines > (9!)*7

  factorials(1)=1
  do i=1,9
     factorials(i+1)=factorials(i)*i
  end do

  do i=10,limit
     if (i == transmute(i)) answer=answer+i
  end do

  print *, answer

contains
  pure function transmute(n)
    implicit none
    integer, intent(in) :: n
    integer             :: transmute
    integer             :: temp

    transmute = 0
    temp=n
    do while (temp>0)
       transmute=transmute+factorials(mod(temp,10)+1)
       temp=temp/10
    end do
  end function transmute

end program problem34


!
! rhOver - a FORTRAN program to determine magnetic anisotropy and related
! properties for dysprosium(III) single-ion magnets by semi-empirical approaches
! Copyright (C) 2014-2019 Michael Böhme <boehme.mic@gmail.com>
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!

! *************************************************************************
! * spherical harmonics up to l = 15 with m = -l, ..., +l
! *************************************************************************
function SphericalHarmonicY(l, m, theta, phi) result(res)
	use global_c
	implicit none
!
	integer, intent(in) :: l, m
	double precision, intent(in) :: theta, phi
	double complex :: res
	double precision :: costheta, sintheta
	double complex :: prefac
!
	if ( l .ne. 0 ) then
		costheta = dcos(theta)
	end if

	if ( m .ne. 0 ) then

		sintheta = dsin(theta)
		prefac = cdexp( m * cmplx(0.0, 1.0) * phi )
		if ( m .gt. 0 ) then
			prefac = prefac * ( - 1 )**m
		end if

	end if

	select case ( l )

		case ( 0 )
			res = 0.5d0 / dsqrt( pi )
			return

		case ( 1 )

			select case ( m )
				case ( -1, 1)
					res = 0.5d0 * prefac * dsqrt( 3.0d0 / ( 2.0d0 * pi) ) * sintheta
					return
				case ( 0 )
					res = 0.5d0 * dsqrt( 3.0d0 / pi ) * costheta
					return
			end select

		case ( 2 )

			select case ( m )
				case ( -2, 2 )
					res = 0.25d0 * prefac * dsqrt( 15.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta**2
					return
				case ( -1, 1 )
					res = 0.50d0 * prefac * dsqrt( 15.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta * costheta
					return
				case ( 0 )
					res = 0.25d0 * dsqrt( 5.0d0 / pi ) * ( 3.d0 * costheta**2 - 1.0d0 )
					return
			end select

		case ( 3 )

			select case ( m )
				case ( -3, 3 )
					res = 0.125d0 * prefac * dsqrt( 35.0d0 / pi ) * &
						sintheta**3
					return
				case ( -2, 2 )
					res = 0.250d0 * prefac * dsqrt( 105.d0 / ( 2.0d0 * pi ) ) * &
						sintheta**2 * costheta
					return
				case ( -1, 1 )
					res = 0.125d0 * prefac * dsqrt( 21.d0 / pi ) * &
						sintheta * ( 5.0d0 * costheta**2 - 1.0d0 )
					return
				case ( 0 )
					res = 0.25d0 * dsqrt( 7.0d0 / pi ) * ( 5.d0 * costheta**3 - 3.0d0 * costheta )
					return
			end select

		case ( 4 )

			select case ( m )
				case ( -4, 4 )
					res = 3.0d0 / 16.0d0 * prefac * dsqrt( 35.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta**4
					return
				case ( -3, 3 )
					res = 3.0d0 / 8.0d0 * prefac * dsqrt( 35.0d0 / ( pi ) ) * &
						sintheta**3 * costheta
					return
				case ( -2, 2 )
					res = 3.0d0 / 8.0d0 * prefac * dsqrt( 5.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta**2 * ( 7.0d0 * costheta**2 - 1 )
					return
				case ( -1, 1 )
					res = 3.0d0 / 8.0d0 * prefac * dsqrt( 5.0d0 / ( pi ) ) * &
						costheta * sintheta * ( 7.0d0  * costheta**2  - 3.0d0 )
					return
				case ( 0 )
					res = 3.0d0 * ( 35d0*costheta**4 - 30d0*costheta**2 + 3d0) / ( 16d0 * dsqrt( pi ) )
					return
			end select

		case ( 5 )

			select case ( m )
				case ( -5, 5 )
					res = 3.0d0 / 32.d0 * prefac * dsqrt( 77.0d0 / ( pi ) ) * &
						sintheta**5
					return
				case ( -4, 4 )
					res = 3.0d0 / 16.d0 * prefac * dsqrt( 385.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta**4 * costheta
					return
				case ( -3, 3 )
					res = 1.0d0 / 32.d0 * prefac * dsqrt( 385.0d0 / ( pi ) ) * &
						sintheta**3 * ( 9.0d0 * costheta**2 - 1.0d0 )
					return
				case ( -2, 2 )
					res = 1.0d0 / 8.d0 * prefac * dsqrt( 1155.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta**2 * costheta * ( 3.0d0*costheta**2 - 1.0d0 )
					return
				case ( -1, 1 )
					res = 1.0d0 / 16.d0 * prefac * dsqrt( 165.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta * ( 21.0d0 * costheta**4 - 14.0d0 * costheta**2 + 1.0d0 )
					return
				case ( 0 )
					res = 1.0d0 / 16.d0 * dsqrt( 11.0d0 / pi ) * &
						( 63.0d0*costheta**5 - 70.0d0*costheta**3 + 15.0d0*costheta )
					return
			end select

		case ( 6 )

			select case ( m )
				case ( -6, 6 )
					res = prefac / 64.0d0 * dsqrt( 3003.0d0 / pi ) * &
						sintheta**6
					return
				case ( -5, 5 )
					res = 3.0d0 / 32.0d0 * prefac * dsqrt( 1001.0d0 / pi ) * &
						sintheta**5 * costheta
					return
				case ( -4, 4 )
					res = 3.0d0 / 32.0d0 * prefac * dsqrt( 91.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta**4 * ( 11.0d0 * costheta**2 - 1.d0 )
					return
				case ( -3, 3 )
					res = 1.0d0 / 32.0d0 * prefac * dsqrt( 1365.0d0 / pi ) * &
						sintheta**3 * costheta * ( 11.0d0 * costheta**2 - 3.d0 )
					return
				case ( -2, 2 )
					res = 1.0d0 / 64.0d0 * prefac * dsqrt( 1365.0d0 / pi ) * &
						sintheta**2 * ( 33.0d0 * costheta**4 - 18.d0 * costheta**2 + 1.d0 )
					return
				case ( -1, 1 )
					res = 1.0d0 / 16.0d0 * prefac * dsqrt( 273.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta * costheta * ( 33.0d0 * costheta**4 - 30.d0 * costheta**2 + 5.d0 )
					return
				case ( 0 )
					res = dsqrt(13.d0 / pi) / 32.d0 * ( &
						+ 231.d0 * costheta**6 - 315.0d0 * costheta**4 + 105.d0 * costheta**2 - 5.0d0 )
					return
			end select

		case ( 7 )

			select case ( m )
				case ( -7, 7 )
					res = 3.0d0 / 64.0d0 * prefac * dsqrt( 715d0 / ( 2d0*pi ) ) * &
						sintheta**7
					return
				case ( -6, 6 )
					res = 3.0d0 / 64.0d0 * prefac * dsqrt( 5005d0 / ( pi ) ) * &
						costheta * sintheta**6
					return
				case ( -5, 5 )
					res = 3.0d0 / 64.0d0 * prefac * dsqrt( 385d0 / ( 2d0*pi ) ) * &
						sintheta**5 * (13d0*costheta**2 - 1d0)
					return
				case ( -4, 4 )
					res = 3.0d0 / 32.0d0 * prefac * dsqrt( 385d0 / ( 2d0*pi ) ) * &
						costheta * sintheta**4 * (13d0*costheta**2 - 3d0)
					return
				case ( -3, 3 )
					res = 3.0d0 / 64.0d0 * prefac * dsqrt( 35.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta**3 * (143d0*costheta**4 - 66d0*costheta**2 + 3d0)
					return
				case ( -2, 2 )
					res = 3.0d0 / 64.0d0 * prefac * dsqrt( 35.0d0 / ( pi ) ) * &
						costheta * sintheta**2 * (143d0*costheta**4 - 110d0*costheta**2 + 15d0)
					return
				case ( -1, 1 )
					res = 1.0d0 / 64.0d0 * prefac * dsqrt( 105.0d0 / ( 2.0d0 * pi ) ) * &
						sintheta * (429d0*costheta**6 - 495d0*costheta**4 + 135d0*costheta**2 - 5d0)
					return
				case ( 0 )
					res = 1d0 / 32d0 * dsqrt(15.d0 / pi) * ( &
						429d0*costheta**7 - 693d0*costheta**5 + 315d0*costheta**3 - 35d0*costheta)
					return
			end select

		case ( 8 )

			select case ( m )
				case ( -8, 8 )
					res = 3d0 / 256d0 * prefac * dsqrt( 12155d0 / ( 2d0*pi ) ) * &
						sintheta**8
					return
				case ( -7, 7 )
					res = 3d0 / 64d0 * prefac * dsqrt( 12155d0 / ( 2d0*pi ) ) * &
						costheta * sintheta**7
					return
				case ( -6, 6 )
					res = 1d0 / 128d0 * prefac * dsqrt( 7293d0 / ( pi ) ) * &
						sintheta**6 * ( 15d0*costheta**2 - 1d0 )
					return
				case ( -5, 5 )
					res = 3d0 / 64d0 * prefac * dsqrt( 17017d0 / ( 2d0*pi ) ) * &
						costheta * sintheta**5 * ( 5d0*costheta**2 - 1d0 )
					return
				case ( -4, 4 )
					res = 3d0 / 128d0 * prefac * dsqrt( 1309d0 / ( 2d0*pi ) ) * &
						sintheta**4 * ( 65d0*costheta**4 - 26d0*costheta**2 + 1d0 )
					return
				case ( -3, 3 )
					res = 1d0 / 64d0 * prefac * dsqrt( 19635d0 / ( 2d0*pi ) ) * &
						costheta * sintheta**3 * ( 39d0*costheta**4 - 26d0*costheta**2 + 3d0 )
					return
				case ( -2, 2 )
					res = 3d0 / 128d0 * prefac * dsqrt( 595d0 / ( pi ) ) * &
						sintheta**2 * ( 143d0*costheta**6 - 143d0*costheta**4 + 33d0*costheta**2 - 1d0 )
					return
				case ( -1, 1 )
					res = 3d0 / 64d0 * prefac * dsqrt( 17d0 / ( 2d0*pi ) ) * &
						sintheta * costheta * ( 715d0*costheta**6 - 1001d0*costheta**4 + 385d0*costheta**2 - 35d0 )
					return
				case ( 0 )
					res = 1d0/256d0 * dsqrt(17d0/pi) * ( &
						6435d0*costheta**8 - 12012d0*costheta**6 + 6930d0*costheta**4 - 1260d0*costheta**2 + 35d0)
					return
			end select

		case ( 9 )

			select case ( m )
				case ( -9, 9 )
					res = 1d0 / 512d0 * prefac * dsqrt( 230945d0 / ( pi ) ) * &
						sintheta**9
					return
				case ( -8, 8 )
					res = 3d0 / 256d0 * prefac * dsqrt( 230945d0 / ( 2d0*pi ) ) * &
						sintheta**8 * costheta
					return
				case ( -7, 7 )
					res = 3d0 / 512d0 * prefac * dsqrt( 13585d0 / ( pi ) ) * &
						sintheta**7 * ( 17d0*costheta**2 - 1d0 )
					return
				case ( -6, 6 )
					res = 1d0 / 128d0 * prefac * dsqrt( 40755d0 / ( pi ) ) * &
						sintheta**6 * costheta * ( 17d0*costheta**2 - 3d0 )
					return
				case ( -5, 5 )
					res = 3d0 / 256d0 * prefac * dsqrt( 2717d0 / ( pi ) ) * &
						sintheta**5 * ( 85d0*costheta**4 - 30d0*costheta**2 + 1d0 )
					return
				case ( -4, 4 )
					res = 3d0 / 128d0 * prefac * dsqrt( 95095d0 / ( 2d0*pi ) ) * &
						sintheta**4 *costheta * ( 17d0*costheta**4 - 10d0*costheta**2 + 1d0 )
					return
				case ( -3, 3 )
					res = 1d0 / 256d0 * prefac * dsqrt( 21945d0 / ( pi ) ) * &
						sintheta**3 * ( 221d0*costheta**6 - 195d0*costheta**4 + 39d0*costheta**2 - 1d0 )
					return
				case ( -2, 2 )
					res = 3d0 / 128d0 * prefac * dsqrt( 1045d0 / ( pi ) ) * &
						sintheta**2 * costheta * ( 221d0*costheta**6 - 273d0*costheta**4 + 91d0*costheta**2 - 7d0 )
					return
				case ( -1, 1 )
					res = 3d0 / 256d0 * prefac * dsqrt( 95d0 / ( 2d0*pi ) ) * &
						sintheta * ( 2431d0*costheta**8 - 4004d0*costheta**6 + 2002d0*costheta**4 - 308d0*costheta**2 + 7d0 )
					return
				case ( 0 )
					res = 1d0/256d0 * dsqrt(19d0/pi) * ( &
						12155d0*costheta**9 - 25740d0*costheta**7 + 18018d0*costheta**5 - 4620d0*costheta**3 + 315d0*costheta)
					return
			end select

		case ( 10 )

			select case ( m )
				case ( -10, 10 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 969969d0 / ( pi ) ) * &
						sintheta**10
					return
				case ( -9, 9 )
					res = 1d0 / 512d0 * prefac * dsqrt( 4849845d0 / ( pi ) ) * &
						sintheta**9 * costheta
					return
				case ( -8, 8 )
					res = 1d0 / 512d0 * prefac * dsqrt( 255255d0 / ( 2d0*pi ) ) * &
						sintheta**8 * ( 19d0*costheta**2 - 1d0 )
					return
				case ( -7, 7 )
					res = 3d0 / 512d0 * prefac * dsqrt( 85085d0 / ( pi ) ) * &
						sintheta**7 * costheta * ( 19d0*costheta**2 - 3d0 )
					return
				case ( -6, 6 )
					res = 3d0 / 1024d0 * prefac * dsqrt( 5005d0 / ( pi ) ) * &
						sintheta**6 * ( 323d0*costheta**4 - 102d0*costheta**2 + 3d0 )
					return
				case ( -5, 5 )
					res = 3d0 / 256d0 * prefac * dsqrt( 1001d0 / ( pi ) ) * &
						sintheta**5 * costheta * ( 323d0*costheta**4 - 170d0*costheta**2 + 15d0 )
					return
				case ( -4, 4 )
					res = 3d0 / 256d0 * prefac * dsqrt( 5005d0 / ( 2d0*pi ) ) * &
						sintheta**4 * ( 323d0*costheta**6 - 255d0*costheta**4 + 45d0*costheta**2 - 1d0 )
					return
				case ( -3, 3 )
					res = 3d0 / 256d0 * prefac * dsqrt( 5005d0 / ( pi ) ) * &
						sintheta**3 * costheta * ( 323d0*costheta**6 - 357d0*costheta**4 + 105d0*costheta**2 - 7d0 )
					return
				case ( -2, 2 )
					res = 3d0 / 512d0 * prefac * dsqrt( 385d0 / ( 2d0*pi ) ) * &
						sintheta**2 * ( 4199d0*costheta**8 - 6188d0*costheta**6 + 2730d0*costheta**4 - 364d0*costheta**2 + 7d0 )
					return
				case ( -1, 1 )
					res = 1d0 / 256d0 * prefac * dsqrt( 1155d0 / ( 2d0*pi ) ) * &
						sintheta * costheta * ( 4199d0*costheta**8 - 7956d0*costheta**6 + 4914d0*costheta**4 - 1092d0*costheta**2 + 63d0 )
					return
				case ( 0 )
					res = 1d0/512d0 * dsqrt(21d0/pi) * ( &
						46189d0*costheta**10 - 109395d0*costheta**8 + 90090d0*costheta**6 - 30030d0*costheta**4 + 3465d0*costheta**2 - 63d0)
					return
			end select

		case ( 11 )

			select case ( m )
				case ( -11, 11 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 2028117d0 / ( 2d0*pi ) ) * &
						sintheta**11
					return
				case ( -10, 10 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 22309287d0 / ( pi ) ) * &
						sintheta**10 * costheta
					return
				case ( -9, 9 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 1062347d0 / ( 2d0*pi ) ) * &
						sintheta**9 * ( 21d0*costheta**2 - 1d0 )
					return
				case ( -8, 8 )
					res = 1d0 / 512d0 * prefac * dsqrt( 15935205d0 / ( 2d0*pi ) ) * &
						sintheta**8 * costheta * ( 7d0*costheta**2 - 1d0 )
					return
				case ( -7, 7 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 838695d0 / ( 2d0*pi ) ) * &
						sintheta**7 * ( 133d0*costheta**4 - 38d0*costheta**2 + 1d0 )
					return
				case ( -6, 6 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 167739d0 / ( pi ) ) * &
						sintheta**6 * costheta * ( 399d0*costheta**4 - 190d0*costheta**2 + 15d0 )
					return
				case ( -5, 5 )
					res = 3d0 / 1024d0 * prefac * dsqrt( 3289d0 / ( 2d0*pi ) ) * &
						sintheta**5 * ( 2261d0*costheta**6 - 1615d0*costheta**4 + 255d0*costheta**2 - 5d0 )
					return
				case ( -4, 4 )
					res = 3d0 / 256d0 * prefac * dsqrt( 23023d0 / ( 2d0*pi ) ) * &
						sintheta**4 * costheta * ( 323d0*costheta**6 - 323d0*costheta**4 + 85d0*costheta**2 - 5d0 )
					return
				case ( -3, 3 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 345345d0 / ( pi ) ) * &
						sintheta**3 * ( 969d0*costheta**8 - 1292d0*costheta**6 + 510d0*costheta**4 - 60d0*costheta**2 + 1d0 )
					return
				case ( -2, 2 )
					res = 1d0 / 512d0 * prefac * dsqrt( 49335d0 / ( 2d0*pi ) ) * &
						sintheta**2 * costheta * ( 2261d0*costheta**8 - 3876d0*costheta**6 + 2142d0*costheta**4 - 420d0*costheta**2 + 21d0 )
					return
				case ( -1, 1 )
					res = 1d0 / 1024d0 * prefac * dsqrt( 759d0 / ( pi ) ) * &
						sintheta * ( 29393d0*costheta**10 - 62985d0*costheta**8 + 46410d0*costheta**6 - 13650d0*costheta**4 + 1365d0*costheta**2 - 21d0 )
					return
				case ( 0 )
					res = 1d0/512d0 * dsqrt(23d0/pi) * ( &
						88179d0*costheta**11 - 230945d0*costheta**9 + 218790d0*costheta**7 - 90090d0*costheta**5 + 15015d0*costheta**3 - 693d0*costheta)
					return
			end select

		case ( 12 )

			select case ( m )
				case ( -12, 12 )
					res = 5d0 / 4096d0 * prefac * dsqrt( 676039d0 / ( pi ) ) * &
						sintheta**12
					return
				case ( -11, 11 )
					res = 5d0 / 1024d0 * prefac * dsqrt( 2028117d0 / ( 2d0*pi ) ) * &
						sintheta**11 * costheta
					return
				case ( -10, 10 )
					res = 5d0 / 2048d0 * prefac * dsqrt( 88179d0 / ( pi ) ) * &
						sintheta**10 * ( 23d0*costheta**2 - 1d0)
					return
				case ( -9, 9 )
					res = 5d0 / 1024d0 * prefac * dsqrt( 323323d0 / ( 2d0*pi ) ) * &
						sintheta**9 * costheta * ( 23d0*costheta**2 - 3d0)
					return
				case ( -8, 8 )
					res = 5d0 / 2048d0 * prefac * dsqrt( 138567d0 / ( 2d0*pi ) ) * &
						sintheta**8 * ( 161d0*costheta**4 - 42d0*costheta**2 + 1d0)
					return
				case ( -7, 7 )
					res = 5d0 / 1024d0 * prefac * dsqrt( 138567d0 / ( 2d0*pi ) ) * &
						sintheta**7 * costheta * ( 161d0*costheta**4 - 70d0*costheta**2 + 5d0)
					return
				case ( -6, 6 )
					res = 5d0 / 2048d0 * prefac * dsqrt( 2431d0 / ( pi ) ) * &
						sintheta**6 * ( 3059d0*costheta**6 - 1995d0*costheta**4 + 285d0*costheta**2 - 5d0)
					return
				case ( -5, 5 )
					res = 15d0 / 1024d0 * prefac * dsqrt( 17017d0 / ( 2d0*pi ) ) * &
						sintheta**5 * costheta * ( 437d0*costheta**6 - 399d0*costheta**4 + 95d0*costheta**2 - 5d0)
					return
				case ( -4, 4 )
					res = 15d0 / 4096d0 * prefac * dsqrt( 1001d0 / ( pi ) ) * &
						sintheta**4 * ( 7429d0*costheta**8 - 9044d0*costheta**6 + 3230d0*costheta**4 - 340d0*costheta**2 + 5d0)
					return
				case ( -3, 3 )
					res = 5d0 / 1024d0 * prefac * dsqrt( 1001d0 / ( pi ) ) * &
						sintheta**3 * costheta * ( 7429d0*costheta**8 - 11628d0*costheta**6 + 5814d0*costheta**4 - 1020d0*costheta**2 + 45d0)
					return
				case ( -2, 2 )
					res = 5d0 / 1024d0 * prefac * dsqrt( 3003d0 / ( 2d0*pi ) ) * &
						sintheta**2 * ( 7429d0*costheta**10 - 14535d0*costheta**8 + 9690d0*costheta**6 - 2550d0*costheta**4 + 225d0*costheta**2 - 3d0)
					return
				case ( -1, 1 )
					res = 5d0 / 1024d0 * prefac * dsqrt( 39d0 / ( pi ) ) * &
						sintheta * costheta * ( 52003d0*costheta**10 - 124355d0*costheta**8 + 106590d0*costheta**6 - 39270d0*costheta**4 + 5775d0*costheta**2 - 231d0)
					return
				case ( 0 )
					res = 5d0/2048d0 * dsqrt(1d0/pi) * ( &
						676039d0*costheta**12 - 1939938d0*costheta**10 + 2078505d0*costheta**8 - 1021020d0*costheta**6 + 225225d0*costheta**4 - 18018d0*costheta**2 + 231d0)
					return
			end select

		case ( 13 )

			select case ( m )
				case ( -13, 13 )
					res = 15d0 / 4096d0 * prefac * dsqrt( 156009d0 / ( 2d0*pi ) ) * &
						sintheta**13
					return
				case ( -12, 12 )
					res = 15d0 / 4096d0 * prefac * dsqrt( 2028117d0 / ( pi ) ) * &
						sintheta**12 * costheta
					return
				case ( -11, 11 )
					res = 3d0 / 4096d0 * prefac * dsqrt( 2028117d0 / ( 2d0*pi ) ) * &
						sintheta**11 * ( 25d0*costheta**2 - 1d0)
					return
				case ( -10, 10 )
					res = 3d0 / 2048d0 * prefac * dsqrt( 2028117d0 / ( pi ) ) * &
						sintheta**10 * costheta * ( 25d0*costheta**2 - 3d0)
					return
				case ( -9, 9 )
					res = 3d0 / 4096d0 * prefac * dsqrt( 88179d0 / ( pi ) ) * &
						sintheta**9 * ( 575d0*costheta**4 - 138d0*costheta**2 + 3d0)
					return
				case ( -8, 8 )
					res = 3d0 / 2048d0 * prefac * dsqrt( 4849845d0 / ( 2d0*pi ) ) * &
						sintheta**8 * costheta * ( 115d0*costheta**4 - 46d0*costheta**2 + 3d0)
					return
				case ( -7, 7 )
					res = 3d0 / 4096d0 * prefac * dsqrt( 692835d0 / ( pi ) ) * &
						sintheta**7 * ( 805d0*costheta**6 - 483d0*costheta**4 + 63d0*costheta**2 - 1d0)
					return
				case ( -6, 6 )
					res = 3d0 / 2048d0 * prefac * dsqrt( 969969d0 / ( pi ) ) * &
						sintheta**6 * costheta * ( 575d0*costheta**6 - 483d0*costheta**4 + 105d0*costheta**2 - 5d0)
					return
				case ( -5, 5 )
					res = 3d0 / 4096d0 * prefac * dsqrt( 51051d0 / ( 2d0*pi ) ) * &
						sintheta**5 * ( 10925d0*costheta**8 - 12236d0*costheta**6 + 3990d0*costheta**4 - 380d0*costheta**2 + 5d0)
					return
				case ( -4, 4 )
					res = 3d0 / 4096d0 * prefac * dsqrt( 51051d0 / ( pi ) ) * &
						sintheta**4 * costheta * ( 10925d0*costheta**8 - 15732d0*costheta**6 + 7182d0*costheta**4 - 1140d0*costheta**2 + 45d0)
					return
				case ( -3, 3 )
					res = 3d0 / 4096d0 * prefac * dsqrt( 15015d0 / ( 2d0*pi ) ) * &
						sintheta**3 * ( 37145d0*costheta**10 - 66861d0*costheta**8 + 40698d0*costheta**6 - 9690d0*costheta**4 + 765d0*costheta**2 - 9d0)
					return
				case ( -2, 2 )
					res = 3d0 / 1024d0 * prefac * dsqrt( 1365d0 / ( 2d0*pi ) ) * &
						sintheta**2 * costheta * ( 37145d0*costheta**10 - 81719d0*costheta**8 + 63954d0*costheta**6 - 21318d0*costheta**4 + 2805d0*costheta**2 - 99d0)
					return
				case ( -1, 1 )
					res = 3d0 / 2048d0 * prefac * dsqrt( 273d0 / ( 2d0*pi ) ) * &
						sintheta * ( 185725d0*costheta**12 - 490314d0*costheta**10 + 479655d0*costheta**8 - 213180d0*costheta**6 + 42075d0*costheta**4 - 2970d0*costheta**2 + 33d0)
					return
				case ( 0 )
					res = 3d0/2048d0 * dsqrt(3d0/pi) * ( &
						1300075d0*costheta**13 - 4056234d0*costheta**11 + 4849845d0*costheta**9 - 2771340d0*costheta**7 + 765765d0*costheta**5 - 90090d0*costheta**3 + 3003d0*costheta)
					return
			end select

		case ( 14 )

			select case ( m )
				case ( -14, 14 )
					res = 15d0 / 8192d0 * prefac * dsqrt( 646323d0 / ( 2d0*pi ) ) * &
						sintheta**14
					return
				case ( -13, 13 )
					res = 15d0 / 4096d0 * prefac * dsqrt( 4524261d0 / ( 2d0*pi ) ) * &
						sintheta**13 * costheta
					return
				case ( -12, 12 )
					res = 5d0 / 8192d0 * prefac * dsqrt( 1508087d0 / ( pi ) ) * &
						sintheta**12 * ( 27d0*costheta**2 - 1d0)
					return
				case ( -11, 11 )
					res = 5d0 / 4096d0 * prefac * dsqrt( 58815393d0 / ( 2d0*pi ) ) * &
						sintheta**11 * costheta * ( 9d0*costheta**2 - 1d0)
					return
				case ( -10, 10 )
					res = 1d0 / 8192d0 * prefac * dsqrt( 58815393d0 / ( 2d0*pi ) ) * &
						sintheta**10 * ( 225d0*costheta**4 - 50d0*costheta**2 + 1d0)
					return
				case ( -9, 9 )
					res = 1d0 / 4096d0 * prefac * dsqrt( 98025655d0 / ( pi ) ) * &
						sintheta**9 * costheta * ( 135d0*costheta**4 - 50d0*costheta**2 + 3d0)
					return
				case ( -8, 8 )
					res = 1d0 / 4096d0 * prefac * dsqrt( 12785955d0 / ( 2d0*pi ) ) * &
						sintheta**8 * ( 1035d0*costheta**6 - 575d0*costheta**4 + 69d0*costheta**2 - 1d0)
					return
				case ( -7, 7 )
					res = 1d0 / 4096d0 * prefac * dsqrt( 20092215d0 / ( pi ) ) * &
						sintheta**7 * costheta * ( 1035d0*costheta**6 - 805d0*costheta**4 + 161d0*costheta**2 - 7d0)
					return
				case ( -6, 6 )
					res = 1d0 / 8192d0 * prefac * dsqrt( 46881835d0 / ( 2d0*pi ) ) * &
						sintheta**6 * ( 3105d0*costheta**8 - 3220d0*costheta**6 + 966d0*costheta**4 - 84d0*costheta**2 + 1d0)
					return
				case ( -5, 5 )
					res = 3d0 / 4096d0 * prefac * dsqrt( 9376367d0 / ( 2d0*pi ) ) * &
						sintheta**5 * costheta * ( 1725d0*costheta**8 - 2300d0*costheta**6 + 966d0*costheta**4 - 140d0*costheta**2 + 5d0)
					return
				case ( -4, 4 )
					res = 3d0 / 8192d0 * prefac * dsqrt( 2467465d0 / ( pi ) ) * &
						sintheta**4 * ( 6555d0*costheta**10 - 10925d0*costheta**8 + 6118d0*costheta**6 - 1330d0*costheta**4 + 95d0*costheta**2 - 1d0)
					return
				case ( -3, 3 )
					res = 1d0 / 4096d0 * prefac * dsqrt( 224315d0 / ( 2d0*pi ) ) * &
						sintheta**3 * costheta * ( 58995d0*costheta**10 - 120175d0*costheta**8 + 86526d0*costheta**6 - 26334d0*costheta**4 + 3135d0*costheta**2 - 99d0)
					return
				case ( -2, 2 )
					res = 1d0 / 8192d0 * prefac * dsqrt( 39585d0 / ( 2d0*pi ) ) * &
						sintheta**2 * ( 334305d0*costheta**12 - 817190d0*costheta**10 + 735471d0*costheta**8 - 298452d0*costheta**6 + 53295d0*costheta**4 - 3366d0*costheta**2 + 33d0)
					return
				case ( -1, 1 )
					res = 1d0 / 2048d0 * prefac * dsqrt( 3045d0 / ( 2d0*pi ) ) * &
						sintheta * costheta * ( 334305d0*costheta**12 - 965770d0*costheta**10 + 1062347d0*costheta**8 - 554268d0*costheta**6 + 138567d0*costheta**4 - 14586d0*costheta**2 + 429d0)
					return
				case ( 0 )
					res = 1d0/4096d0 * dsqrt(29d0/pi) * ( &
						5014575d0*costheta**14 - 16900975d0*costheta**12 + 22309287d0*costheta**10 - 14549535d0*costheta**8 + 4849845d0*costheta**6 - 765765d0*costheta**4 + 45045d0*costheta**2 - 429d0)
					return
			end select

		case ( 15 )

			select case ( m )
				case ( -15, 15 )
					res = 3d0 / 16384d0 * prefac * dsqrt( 33393355d0 / ( pi ) ) * &
						sintheta**15
					return
				case ( -14, 14 )
					res = 15d0 / 8192d0 * prefac * dsqrt( 20036013d0 / ( 2d0*pi ) ) * &
						sintheta**14 * costheta
					return
				case ( -13, 13 )
					res = 15d0 / 16384d0 * prefac * dsqrt( 690897d0 / ( pi ) ) * &
						sintheta**13 * ( 29d0*costheta**2 - 1d0)
					return
				case ( -12, 12 )
					res = 15d0 / 8192d0 * prefac * dsqrt( 1612093d0 / ( pi ) ) * &
						sintheta**12 * costheta * ( 29d0*costheta**2 - 3d0)
					return
				case ( -11, 11 )
					res = 5d0 / 16384d0 * prefac * dsqrt( 4836279d0 / ( pi ) ) * &
						sintheta**11 * ( 261d0*costheta**4 - 54d0*costheta**2 + 1d0)
					return
				case ( -10, 10 )
					res = 1d0 / 8192d0 * prefac * dsqrt( 314358135d0 / ( 2d0*pi ) ) * &
						sintheta**10 * costheta * ( 261d0*costheta**4 - 90d0*costheta**2 + 5d0)
					return
				case ( -9, 9 )
					res = 1d0 / 16384d0 * prefac * dsqrt( 104786045d0 / ( pi ) ) * &
						sintheta**9 * ( 1305d0*costheta**6 - 675d0*costheta**4 + 75d0*costheta**2 - 1d0)
					return
				case ( -8, 8 )
					res = 1d0 / 4096d0 * prefac * dsqrt( 44908305d0 / ( 2d0*pi ) ) * &
						sintheta**8 * costheta * ( 1305d0*costheta**6 - 945d0*costheta**4 + 175d0*costheta**2 - 7d0)
					return
				case ( -7, 7 )
					res = 1d0 / 16384d0 * prefac * dsqrt( 1952535d0 / ( pi ) ) * &
						sintheta**7 * ( 30015d0*costheta**8 - 28980d0*costheta**6 + 8050d0*costheta**4 - 644d0*costheta**2 + 7d0)
					return
				case ( -6, 6 )
					res = 1d0 / 8192d0 * prefac * dsqrt( 21477885d0 / ( 2d0*pi ) ) * &
						sintheta**6 * costheta * ( 10005d0*costheta**8 - 12420d0*costheta**6 + 4830d0*costheta**4 - 644d0*costheta**2 + 21d0)
					return
				case ( -5, 5 )
					res = 3d0 / 16384d0 * prefac * dsqrt( 10023013d0 / ( pi ) ) * &
						sintheta**5 * ( 10005d0*costheta**10 - 15525d0*costheta**8 + 8050d0*costheta**6 - 1610d0*costheta**4 + 105d0*costheta**2 - 1d0)
					return
				case ( -4, 4 )
					res = 3d0 / 8192d0 * prefac * dsqrt( 4555915d0 / ( pi ) ) * &
						sintheta**4 * costheta * ( 10005d0*costheta**10 - 18975d0*costheta**8 + 12650d0*costheta**6 - 3542d0*costheta**4 + 385d0*costheta**2 - 11d0)
					return
				case ( -3, 3 )
					res = 1d0 / 16384d0 * prefac * dsqrt( 719355d0 / ( pi ) ) * &
						sintheta**3 * ( 190095d0*costheta**12 - 432630d0*costheta**10 + 360525d0*costheta**8 - 134596d0*costheta**6 + 21945d0*costheta**4 - 1254d0*costheta**2 + 11d0)
					return
				case ( -2, 2 )
					res = 1d0 / 8192d0 * prefac * dsqrt( 55335d0 / ( 2d0*pi ) ) * &
						sintheta**2 * costheta * ( 570285d0*costheta**12 - 1533870d0*costheta**10 + 1562275d0*costheta**8 - 749892d0*costheta**6 + 171171d0*costheta**4 - 16302d0*costheta**2 + 429d0)
					return
				case ( -1, 1 )
					res = 1d0 / 16384d0 * prefac * dsqrt( 465d0 / ( pi ) ) * &
						sintheta * ( 9694845d0*costheta**14 - 30421755d0*costheta**12 + 37182145d0*costheta**10 - 22309287d0*costheta**8 + 6789783d0*costheta**6 - 969969d0*costheta**4 + 51051d0*costheta**2 - 429d0)
					return
				case ( 0 )
					res = 1d0/4096d0 * dsqrt(31d0/pi) * ( &
						9694845d0*costheta**15 - 35102025d0*costheta**13 + 50702925d0*costheta**11 - 37182145d0*costheta**9 + 14549535d0*costheta**7 - 2909907d0*costheta**5 + 255255d0*costheta**3 - 6435d0*costheta**1)
					return
			end select

	end select

	if ( ( m .gt. l ) .OR. ( m .lt. -l ) ) then
		write(*,*) "ERROR! Invalid spherical harmonic!"
		write(*,*)
		stop
	end if

	write(*,*) "ERROR! Spherical harmonic not implemented!"
	write(*,*)
	stop

end function