! Relaxation with MPI.  Here we solve a Poisson problem in 2-d.  We do
! domain decomposition in the x-direction.
!
! M. Zingale (2013-04-15)

program relax

  use mpi

  implicit none

  integer, parameter :: nx = 512
  integer, parameter :: ny = 512
  integer, parameter :: ng = 1

  ! set the lo/hi boundary conditions in each coordinate direction
  double precision, parameter :: bc_lo_x = 0.d0
  double precision, parameter :: bc_hi_x = 0.d0
  double precision, parameter :: bc_lo_y = 0.d0
  double precision, parameter :: bc_hi_y = 0.d0

  ! domain info
  double precision, parameter :: xmin = 0.0d0
  double precision, parameter :: xmax = 1.0d0
  double precision, parameter :: ymin = 0.0d0
  double precision, parameter :: ymax = 1.0d0

  double precision :: dx, dy, xx, yy

  double precision :: err

  ! smoothing info
  integer, parameter :: nsmooth = 2500

  double precision, allocatable :: f(:,:), v(:,:), w(:,:)

  integer :: mype, nprocs, ierr
  integer :: ilo_global, ihi_global
  integer :: ilo, ihi, jlo, jhi, mywidth
  integer :: iwidth, iextra

  integer :: i, j

  double precision :: start, finish

  ! initialize MPI
  call MPI_Init(ierr)

  start = MPI_Wtime()

  ! do the domain decomposition
  call MPI_Comm_Size(MPI_COMM_WORLD, nprocs, ierr)
  call MPI_Comm_Rank(MPI_COMM_WORLD, mype, ierr)

  ! we could use the MPI_Cart_Create() stuff, but let's do it
  ! ourselves.  We will do a 1-d decomposition

  ! each processor will hold a slab with the j coordinates spanning
  ! the entire y-domain, and the i coordinates spanning their own
  ! respective subset.  We will refer to a global index space of nx x ny.
  iwidth = floor(real(nx/nprocs))
  iextra = mod(nx,nprocs)

  ! the first iwidth processors have a width of iwidth+1
  mywidth = iwidth
  if (mype < iextra) mywidth = mywidth + 1

  ! current processor's index space
  if (mype < iextra) then
     ilo = (iwidth+1)*mype
     ihi = ilo + mywidth - 1
  else
     ilo = (iwidth+1)*iextra + iwidth*(mype-iextra)
     ihi = ilo + mywidth - 1
  endif

  jlo = 0
  jhi = ny-1

  print *, mype, ilo, ihi, mywidth

  ! allocate our part of the domain (including ghost cells).  Note
  ! that the indices refer to the full global nx x ny index space
  allocate(v(ilo-ng:ihi+ng,jlo-ng:jhi+ng))
  allocate(f(ilo-ng:ihi+ng,jlo-ng:jhi+ng))
  allocate(w(ilo-ng:ihi+ng,jlo-ng:jhi+ng))

  v(:,:) = 0.0d0
  f(:,:) = 0.0d0

  dx = (xmax-xmin)/nx
  dy = (ymax-ymin)/ny

  ! fill the RHS
  do j = jlo, jhi
     yy = (dble(j) + 0.5d0)*dy + ymin

     do i = ilo, ihi
        xx = (dble(i) + 0.5d0)*dx + xmin

        f(i,j) = g(xx, yy)

     enddo
  enddo

  ! smooth
  call smooth(ilo, ihi, jlo, jhi, ng, &
              dx, dy, &
              bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y, &
              v, f, nsmooth)

  ! compute the error

  ! fill the true solution
  do j = jlo, jhi
     yy = (dble(j) + 0.5d0)*dy + ymin

     do i = ilo, ihi
        xx = (dble(i) + 0.5d0)*dx + xmin

        w(i,j) = true(xx, yy) - v(i,j)

     enddo
  enddo

  err = error(ilo, ihi, jlo, jhi, ng, dx, dy, w)

  if (mype == 0) print *, "ERROR = ", err

  finish = MPI_Wtime()

  if (mype == 0) print *, "wallclock time: ", finish-start

  ! end
  call MPI_Finalize(ierr)

contains

  !===========================================================================
  ! g
  !===========================================================================
  function g(x,y)

    ! the RHS of the Poisson equation we are solving

    implicit none

    double precision :: g, x, y
    double precision, parameter :: pi = 3.14159265358979323846d0

    g = -2.d0*(2.0*pi)**2 * sin(2.0*pi*x) * sin(2.0*pi*y)

    return
  end function g

  !===========================================================================
  ! true
  !===========================================================================
  function true(x,y)

    ! the analytic solution to our equation

    implicit none

    double precision true, x, y
    double precision, parameter :: pi = 3.14159265358979323846d0

    true = sin(2.0*pi*x) * sin(2.0*pi*y)

    return
  end function true

  !===========================================================================
  ! fillGC
  !===========================================================================
  subroutine fillGC(ilo, ihi, jlo, jhi, ng, &
                    bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y, &
                    v)

    implicit none

    integer :: ilo, ihi, jlo, jhi, ng
    double precision :: bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y
    double precision :: v(ilo-ng:ihi+ng,jlo-ng:jhi+ng)

    integer :: nprocs, mype, ierr
    integer :: status(MPI_STATUS_SIZE)

    integer :: sendto, recvfrom

    ! isr = 1 use blocking send/receive pairs, isr = 2 combine sendrecv
    integer, parameter :: isr = 2

    ! we are doing a 1-d domain decomposition

    call MPI_Comm_Size(MPI_COMM_WORLD, nprocs, ierr)
    call MPI_Comm_Rank(MPI_COMM_WORLD, mype, ierr)

    ! first fill any physical boundaries
    if (ilo == 0) then
       v(ilo-ng,:) = 2.0*bc_lo_x - v(ilo,:)
    endif

    if (jlo == 0) then
       v(:,jlo-ng) = 2.0*bc_lo_y - v(:,jlo)
    endif

    if (ihi == nx-1) then
       v(ihi+ng,:) = 2.0d0*bc_hi_x - v(ihi,:)
    endif

    if (jhi == ny-1) then
       v(:,jhi+ng) = 2.0d0*bc_hi_y - v(:,jhi)
    endif

    ! now fill the interior ghostcells

    if (isr == 1) then
       ! this is the slow method -- blocking sends and receives

       ! send first column of valid data to the left to fill left PE's
       ! right GCs
       if (mype > 0) then
          call MPI_Send(v(ilo,:), ny+2*ng, MPI_DOUBLE_PRECISION, &
                        mype-1, mype, MPI_COMM_WORLD, ierr)
       endif

       if (mype < nprocs-1) then
          call MPI_Recv(v(ihi+1,:), ny+2*ng, MPI_DOUBLE_PRECISION, &
                        mype+1, mype+1, MPI_COMM_WORLD, status, ierr)
       endif

       ! send last column of valid data to the right to fill right PE's
       ! left GCs
       if (mype < nprocs-1) then
          call MPI_Send(v(ihi,:), ny+2*ng, MPI_DOUBLE_PRECISION, &
                        mype+1, mype, MPI_COMM_WORLD, ierr)
       endif

       if (mype > 0) then
          call MPI_Recv(v(ilo-1,:), ny+2*ng, MPI_DOUBLE_PRECISION, &
                        mype-1, mype-1, MPI_COMM_WORLD, status, ierr)
       endif

    else if (isr == 2) then

       ! send first column of valid data to the left to fill left PE's
       ! right GCs and receive from the right PE
       if (mype == 0) then
          sendto = MPI_PROC_NULL
       else
          sendto = mype-1
       endif

       if (mype == nprocs-1) then
          recvfrom = MPI_PROC_NULL
       else
          recvfrom = mype+1
       endif

       call MPI_Sendrecv(v(ilo,:), ny+2*ng, MPI_DOUBLE_PRECISION, sendto, 0, &
                         v(ihi+1,:), ny+2*ng, MPI_DOUBLE_PRECISION, recvfrom, 0, &
                         MPI_COMM_WORLD, status, ierr)

       ! send last column of valid data to the right to fill right PE's
       ! left GCs and receive from the left PE
       if (mype == nprocs-1) then
          sendto = MPI_PROC_NULL
       else
          sendto = mype+1
       endif

       if (mype == 0) then
          recvfrom = MPI_PROC_NULL
       else
          recvfrom = mype-1
       endif

       call MPI_Sendrecv(v(ihi,:), ny+2*ng, MPI_DOUBLE_PRECISION, sendto, 0, &
                         v(ilo-1,:), ny+2*ng, MPI_DOUBLE_PRECISION, recvfrom, 0, &
                         MPI_COMM_WORLD, status, ierr)

    endif

    ! debugging
    !
    !do i = 0, nprocs-1
    !   if (i == mype) then
    !      print *, "mype = ", mype
    !      do j = jlo-1, jhi+1
    !         print *, real(v(:,j))
    !      enddo
    !      print *, " "
    !   endif
    !   call MPI_Barrier(MPI_COMM_WORLD, ierr)
    !enddo
    !
    !stop

  end subroutine fillGC

  !=============================================================================
  ! smooth
  !=============================================================================
  subroutine smooth(ilo, ihi, jlo, jhi, ng, &
                    dx, dy, &
                    bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y, &
                    v, f, nsmooth)

    ! given a solution vector, v, and a RHS vector, f, smooth v to
    ! better satisfy the equation.  This is done in place, using
    ! Red-Black Gauss-Seidel

    ! hi and lo Dirichlet boundary conditions are also passed.
    ! Because we are finite-volume, and therefore, cell-centered, we
    ! need to extrapolate to match the desired Dirichlet BC.

    implicit none

    integer :: ilo, ihi, jlo, jhi, ng
    integer :: nsmooth
    double precision :: dx, dy
    double precision :: bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y
    double precision, dimension(ilo-ng:ihi+ng,jlo-ng:jhi+ng) :: v, f

    integer :: i, j, m, ioff, color

    ! do some smoothing -- Red-Black Gauss-Seidel
    do m = 1, nsmooth

       do color = 0, 1

          ! set the guardcells to give the proper boundary condition, using
          ! extrapolation
          call fillGC(ilo, ihi, jlo, jhi, ng, &
                      bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y, &
                      v)

          do j = jlo, jhi

             if (color == 0) then
                ioff = mod(j,2)
             else
                ioff = 1 - mod(j,2)
             endif

             do i = ilo+ioff, ihi, 2
                v(i,j) = 0.25d0*(v(i-1,j) + v(i+1,j) + &
                                 v(i,j-1) + v(i,j+1) - dx*dx*f(i,j))
             enddo

          enddo
       enddo

    enddo

  end subroutine smooth

  !===========================================================================
  ! error
  !===========================================================================
  function error(ilo, ihi, jlo, jhi, ng, dx, dy, v)

    ! compute the L2 norm

    implicit none

    integer :: ilo, ihi, jlo, jhi, ng
    double precision :: dx, dy
    double precision :: v(ilo-ng:ihi+ng,jlo-ng:jhi+ng)

    integer :: i, j
    double precision :: error, errlocal
    integer :: ierr

    errlocal = 0.d0

    do j = jlo, jhi
       do i = ilo, ihi
          errlocal = errlocal + v(i,j)**2
       enddo
    enddo

    ! we now have the sum e**2 local on each processor.  Add this across processors
    call MPI_Allreduce(errlocal, error, 1, MPI_DOUBLE_PRECISION, &
                       MPI_SUM, MPI_COMM_WORLD, ierr)

    error = dx*dy*error    ! make it grid invariant
    error = sqrt(error)

    return
  end function error

end program relax


      subroutine nscore(nd,vr,tmin,tmax,iwt,wt,tmp,lout,vrg,ierror,disc)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c              Transform Univariate Data to Normal Scores
c              ******************************************
c
c This subroutibe takes "nd" data "vr(i),i=1,...,nd" possibly weighted
c by "wt(i),i=,...,nd" and returns the normal scores transform N(0,1)
c as "vrg(i),i=1,...,nd".  The extra storage array "tmp" is required
c so that the data can be returned in the same order (just in case
c there are associated arrays like the coordinate location).
c
c
c
c INPUT VARIABLES:
c
c   nd               Number of data (no missing values)
c   vr(nd)           Data values to be transformed
c   tmin,tmax        data trimming limits
c   iwt              =0, equal weighted; =1, then apply weight
c   wt(nd)           Weight for each data (don't have to sum to 1.0)
c   tmp(nd)          Temporary storage space for sorting
c   lout             if > 0 then transformation table will be written
c   disc             =0, wt(i) = dble(i)/nd - 1./(2*nd)
c                    =1, wt(i) = dble(i)/nd
c
c
c
c
c OUTPUT VARIABLES:
c
c   vrg(nd)          normal scores
c   ierror           error flag (0=error free,1=problem)
c
c
c
c EXTERNAL REFERENCES:
c
c   gauinv           Calculates the inverse of a Gaussian cdf
c   sortem           sorts a number of arrays according to a key array
c
c
c
c MODIFICATIONS
c   JAN 2010, TMH : added disc option in order to reproduce
c                   discrete distributions mor accurately
c
c
c
c-----------------------------------------------------------------------
      parameter(EPSLON=1.0e-20)
      real      vr(nd),wt(nd),vrg(nd),tmp(nd),wt2(nd)
      real*8    pd
      integer   disc
c
c Sort the data in ascending order and calculate total weight:
c
      ierror = 0
      twt    = 0.0
      do i=1,nd
            tmp(i) = real(i)
            if(vr(i).ge.tmin.and.vr(i).lt.tmax) then
                  if(iwt.eq.0) then
                        twt = twt + 1.
                  else
                        twt = twt + wt(i)
                  end if
            end if
      end do
      if(nd.lt.1.or.twt.lt.EPSLON) then
            ierror = 1
            return
      end if
      call sortem(1,nd,vr,2,wt,tmp,d,e,f,g,h)
c
c Compute the cumulative probabilities:
c
      oldcp = 0.0
      cp    = 0.0
      do i=1,nd
c ORIGINAL GSLIB IMPLEMENTATION WAS NOT PRECISE ENOUGH
c            cp     =  cp + wt(i) / twt
c            wt(i)  = (cp + oldcp)/ 2.0
c            oldcp  =  cp
c USING MORE PRCISE APPROACH :
         if (disc.eq.0) then
            wt(i) = dble(i)/nd - 1./(2*nd)
         else
            wt(i) = dble(i)/nd
         endif

         call gauinv(dble(wt(i)),vrg(i),ierr)
c      write(*,*) i,cp,wt(i),wt2(i),twt,vr(i),vrg(i),nd
         if(lout.gt.0) write(lout,'(f12.5,1x,f12.5,1x,f12.5)')
     1        wt(i),vr(i),vrg(i)
      end do

c
c Get the arrays back in original order:
c
      call sortem(1,nd,tmp,3,wt,vr,vrg,e,f,g,h)
c
c Finished:
c
      return
      end


*DECK RT
      SUBROUTINE RT (NM, N, A, W, MATZ, Z, FV1, IERR)
C***BEGIN PROLOGUE  RT
C***PURPOSE  Compute the eigenvalues and eigenvectors of a special real
C            tridiagonal matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5
C***TYPE      SINGLE PRECISION (RT-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of subroutines
C     from the eigensystem subroutine package (EISPACK) to find the
C     eigenvalues and eigenvectors (if desired) of a special REAL
C     TRIDIAGONAL matrix.  The property of the matrix required for use
C     of this subroutine is that the products of pairs of corresponding
C     off-diagonal elements be all non-negative.  If eigenvectors are
C     desired, no product can be zero unless both factors are zero.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the special real tridiagonal matrix in its first
C          three columns.  The subdiagonal elements are stored in the
C          last N-1 positions of the first column, the diagonal elements
C          in the second column, and the superdiagonal elements in the
C          first N-1 positions of the third column.  Elements A(1,1) and
C          A(N,3) are arbitrary.  A is a two-dimensional REAL array,
C          dimensioned A(NM,3).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  The eigen-
C          vectors are not normalized.  Z is a two-dimensional REAL
C          array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          N+J        if A(J,1)*A(J-1,3) is negative,
C          2*N+J      if the product is zero with one factor non-zero,
C                     and MATZ is non-zero;
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors in the W and Z
C                     arrays should be correct for indices
C                     1, 2, ..., IERR-1.
C
C        FV1 is a one-dimensional REAL array used for temporary storage,
C          dimensioned FV1(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  FIGI, FIGI2, IMTQL1, IMTQL2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RT
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,3),W(*),Z(NM,*),FV1(*)
C
C***FIRST EXECUTABLE STATEMENT  RT
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  FIGI(NM,N,A,W,FV1,FV1,IERR)
      IF (IERR .GT. 0) GO TO 50
      CALL  IMTQL1(N,W,FV1,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  FIGI2(NM,N,A,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  IMTQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
      END


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c    a program testing subroutines shpgi and shpg in file shpg.f
c    also requires files  shagc.f, shsgc.f, gaqd.f
c    sphcom.f and hrfft.f
c
c    shpg is the n**2 projection with complement, odd/even
c    factorization and zero truncation on a Gaussian distributed
c    grid. The projection is defined in the JCP paper "Generalized
c    discrete spherical harmonic transforms" by
c    Paul N. Swarztrauber and William F. Spotz
c    J. Comp. Phys., 159(2000) pp. 213-230.
c
c                     April 2002
c
      program tshpg
      parameter (idp=8)
      parameter (kdp=idp+idp-2)
      parameter (lwshp=2*(idp+1)**2+kdp+20,
     1    liwshp=4*(idp+1),lwrk=1.25*(idp+1)**2+7*idp+8)
      parameter (lwrk1=idp*kdp)
      parameter(lwork = 4*idp*(idp-1),
     1 lwsha=idp*(4*idp+1)+idp+idp+15)
c     1 lwsha=idp*(idp+1)+3*(idp-2)*(idp-1)/2+kdp+15)

      double precision work(lwrk)
      dimension sx(idp,kdp),sy(idp,kdp),
     1wshp(lwshp),iwshp(liwshp),wrk1(lwrk1)
      dimension g(idp,kdp,2),ga(idp,idp,2),gb(idp,idp,2),
     1 gh(idp,kdp,2),
     2 wrk2(lwork),wshagc(lwsha),wshsgc(lwsha)
      real*4 t1(2)
c
      iprint = 0
      nt = 1
      isym = 0
      mode = 0
c
      do 100 nlat=6,8
      do 200 mtr=1,2
      nlon = 2*(nlat-1)
      mtrunc = nlat-mtr
      mtrunc = min(mtrunc,nlat-1,nlon/2)
      idimg = idp
      jdimg = kdp
      call shagci(nlat,nlon,wshagc,lwsha,work,lwrk,ierror)
      if(ierror .ne. 0) write(6,70) ierror
   70 format('   ierror0' ,i5)
c
      lwshs = lwsha
      call shsgci(nlat,nlon,wshsgc,lwshs,work,lwrk,ierror)
      if(ierror .ne. 0) write(6,71) ierror
   71 format('   ierror1' ,i5)
c
c     initiate faster filter
c
      call shpgi(nlat,nlon,isym,mtrunc,wshp,lwshp,iwshp,liwshp,
     1 work,lwrk,ierror)
      if(ierror.ne.0) write(*,429) ierror
 429  format(' ierror2 =',i5,' at 429')
c
      if(iprint .ne. 0) write (6,5) mode,nlat,nlon
    5 format(' mode =' ,i5,'  nlat =',i5,'  nlon =',i5)
c
c     initialize with pseudo random field
c
      do 10 i=1,nlat
      do 10 j=1,nlon
      sx(i,j) =  cos(float(i*j))
      g(i,j,1) = sx(i,j)
   10 continue
c
      thold = etime(t1)
      thold = t1(1)
      call shagc(nlat,nlon,mode,nt,g,idimg,jdimg,ga,gb,idimg,idimg,
     1              wshagc,lwsha,wrk2,lwork,ierror)
      if(ierror .ne. 0) write(6,72) ierror
   72 format('   ierror2' ,i5)
c
      if(mtrunc.lt.nlat-1) then
      do np1=mtrunc+2,nlat
       do mp1=1,np1
        ga(mp1,np1,1) = 0.
        gb(mp1,np1,1) = 0.
       end do
      end do
      end if
      call shsgc(nlat,nlon,mode,nt,gh,idimg,jdimg,ga,gb,idimg,idimg,
     1              wshsgc,lwshs,wrk2,lwork,ierror)
      tusl = etime(t1)
      tusl = t1(1)-thold
      if(ierror .ne. 0) write(6,73) ierror
   73 format('   ierror3' ,i5)
c
      thold = etime(t1)
      toe = t1(1)
      call shpg(nlat,nlon,isym,mtrunc,sx,sy,idp,
     1  wshp,lwshp,iwshp,liwshp,wrk1,lwrk1,ierror)
      thold = etime(t1)
      toe = t1(1)-toe
      if(ierror.ne.0) write(*,428) ierror
 428  format(' ierror =',i5,' at 428')
      if(iprint.gt.0)write(*,431)
 431  format(/' approx and exact solution'/)
      do j=1,nlon
      if(iprint.gt.0)write(*,437) j,(sy(i,j),gh(i,j,1),i=1,nlat)
 437  format(' j=',i5,1p4e15.6/(8x,1p4e15.6))
      end do
      dmax1 = 0.
      do j=1,nlon
      do i=1,nlat
      dmax1 = max(dmax1,abs(sy(i,j)-gh(i,j,1)))
      end do
      end do
      write (6,134) nlat,mtrunc
 134  format(/'case nlat =',i5,' and mtrunc =',i5/)
      write(*,135) dmax1,tusl,toe
 135  format(/' error =',1pe15.6/
     1        ' tusl  =',1pe15.6/
     2        ' toe   =',1pe15.6)
c
  200 continue
  100 continue
      end


C/MEMBR ADD NAME=WNRM2,SSI=0
c     Copyright INRIA
      double precision function wnrm2(n,xr,xi,incx)
c!purpose
c
c     cette fonction wnrm2 determine la norme l2 d'un vecteur
c     complexe double precision x, dont les parties reelles
c     sont rangees dans le vecteur double precision xr et
c     les parties imaginaires sont rangees dans le vecteur
c     double precision xi.
c
c!calling sequence
c
c      double precision function wnrm2(n,xr,xi,incx)
c
c      n: entier, taille du vecteur traite.
c
c      xr, xi: vecteurs double precision, parties reelles et
c     imaginaires, respectivement du vecteur x.
c
c      incx: increment entre deux composantes consecutives du
c     vecteur x.
c
c!auxiliary routines
c
c     pythag
c
c!author
c
c     cleve moler.- mathlab.
c
c!
      double precision xr(*),xi(*),pythag,s
c     norm2(x)
      s = 0.0d+0
      if (n .le. 0) go to 20
      ix = 1
      do 10 i = 1, n
         s = pythag(s,xr(ix))
         s = pythag(s,xi(ix))
         ix = ix + incx
   10 continue
   20 wnrm2 = s
      return
      end


!
!
!
 FUNCTION SINDD(ALFA)
 implicit NONE
!
! --- Assuming that ALFA is given in DEGREES, it returns the SINE of ALFA
!     *********************** GS and FC 11-02-2009 **********************
!
 REAL*8,  PARAMETER :: PI=3.14159265358979323840D0
 REAL*8 SINDD, ALFA, ALFARAD
 ALFARAD=ALFA*PI/180D0
 SINDD=SIN(ALFARAD)
 END FUNCTION SINDD
!
!
!


program functions_03
implicit none
integer, parameter :: sp = 4
complex(4) :: i, j
i = 1
j = 1
print *, j
j = f(i)
print *, i
print *, j

j = 1
print *, j
j = f((3.0, 0.0))
print *, j

j = 1
print *, j
j = g((2.0, 0.0))
print *, j

j = 1
print *, j
j = g((2.0, 3.0))
print *, j

contains

    complex(4) function f(a) result(b)
    complex(4), intent(in) :: a
    b = a + 5
    end function

    complex(sp) function g(a) result(b)
    complex(sp), intent(in) :: a
    b = a + 5
    end function

end program


module test_fornberg

  use fornberg, only: populate_weights

  implicit none

  integer, parameter :: dp=kind(0.d0) ! double precision

  private
  public test_weights

contains

  subroutine test_weights()
    real(dp) :: z
    integer :: m, nd
    real(dp), allocatable :: c(:,:)
    real(dp), parameter :: x(0:2) = [-1.0_dp, 0.0_dp, 1.0_dp]
    real(dp), parameter :: c_ref(3,2) = reshape([0.0_dp, 1.0_dp, 0.0_dp, -0.5_dp, 0.0_dp, 0.5_dp, 1.0_dp, -2.0_dp, 1.0_dp], [3,2])
    nd = size(x)-1
    m = 2
    z = 0.0_dp
    allocate(c(0:nd, 0:m))
    call populate_weights(z, x, nd, m, c)
    if (sum(abs(c - c_ref)) > 1e-10) then
       stop "c not equal to c_ref"
    end if
  end subroutine

end module test_fornberg

program main
use test_fornberg, only: test_weights
call test_weights()
end program


      program main

c*********************************************************************72
c
cc MAIN is the main program for BLAS1_D_PRB.
c
c  Discussion:
c
c    BLAS1_D_PRB tests the BLAS1 library.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_D_PRB:'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test the BLAS1_D library.'

      call dasum_test ( )
      call daxpy_test ( )
      call dcopy_test ( )
      call ddot_test ( )
      call dnrm2_test ( )
      call drot_test ( )
      call drotg_test ( )
      call dscal_test ( )
      call dswap_test ( )
      call idamax_test ( )
!
!  Terminate.
!
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_D_PRB:'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ' '
      call timestamp ( )

      stop
      end
      subroutine dasum_test ( )

c*********************************************************************72
c
cc DASUM_TEST tests DASUM.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 March 2007
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer lda
      integer ma
      integer na
      integer nx

      parameter ( lda = 6 )
      parameter ( ma = 5 )
      parameter ( na = 4 )
      parameter ( nx = 10 )

      double precision a(lda,na)
      double precision dasum
      integer i
      integer j
      double precision x(nx)

      do i = 1, nx
        x(i) = (-1.0D+00)**i * dble ( 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DASUM_TEST'
      write ( *, '(a)' ) '  DASUM adds the absolute values of '
      write ( *, '(a)' ) '  elements of a double precision vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, nx
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  DASUM ( NX, X, 1 ) =   ',
     &  dasum ( nx, x, 1 )
      write ( *, '(a,g14.6)' ) '  DASUM ( NX/2, X, 2 ) = ',
     &  dasum ( nx/2, x, 2 )
      write ( *, '(a,g14.6)' ) '  DASUM ( 2, X, NX/2 ) = ',
     &  dasum ( 2, x, nx/2 )

      do i = 1, lda
        do j = 1, na
          a(i,j) = 0.0D+00
        end do
      end do

      do i = 1, ma
        do j = 1, na
          a(i,j) = (-1.0D+00)**(i+j) * dble ( 10 * i + j )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Demonstrate with a matrix A:'
      write ( *, '(a)' ) ' '
      do i = 1, ma
        write ( *, '(2x,5g14.6)' ) ( a(i,j), j = 1, na )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  DASUM(MA,A(1,2),1) =   ',
     &  dasum ( ma, a(1,2), 1 )
      write ( *, '(a,g14.6)' ) '  DASUM(NA,A(2,1),LDA) = ',
     &  dasum ( na, a(2,1), lda )

      return
      end
      subroutine daxpy_test ( )

c*********************************************************************72
c
cc DAXPY_TEST tests DAXPY.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      double precision da
      integer i
      double precision x(n)
      double precision y(n)

      do i = 1, n
        x(i) = dble ( i )
      end do

      do i = 1, n
        y(i) = dble ( 100 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DAXPY_TEST'
      write ( *, '(a)' ) '  DAXPY adds a double precision multiple of '
      write ( *, '(a)' ) '  vector X to vector Y.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      da = 1.0D+00
      call daxpy ( n, da, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DAXPY ( N, ', da, ', X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, n
        y(i) = dble ( 100 * i )
      end do

      da = -2.0D+00
      call daxpy ( n, da, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DAXPY ( N, ', da, ', X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, n
        y(i) = dble ( 100 * i )
      end do

      da = +3.0D+00
      call daxpy ( 3, da, x, 2, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DAXPY ( 3, ', da, ', X, 2, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, n
        y(i) = dble ( 100 * i )
      end do

      da = -4.0D+00
      call daxpy ( 3, da, x, 1, y, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DAXPY ( 3, ', da, ', X, 1, Y, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      return
      end
      subroutine dcopy_test ( )

c*********************************************************************72
c
cc DCOPY_TEST tests DCOPY.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double precision a(5,5)
      integer i
      integer j
      double precision x(10)
      double precision y(10)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DCOPY_TEST'
      write ( *, '(a)' ) '  DCOPY copies one double precision vector'
      write ( *, '(a)' ) '  into another.'

      do i = 1, 10
        x(i) = dble ( i )
      end do

      do i = 1, 10
        y(i) = dble ( 10 * i )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = dble ( 10 * i + j )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,5f8.2)' ) ( a(i,j), j = 1, 5 )
      end do

      call dcopy ( 5, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DCOPY ( 5, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, 10
        y(i) = dble ( 10 * i )
      end do

      call dcopy ( 3, x, 2, y, 3 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DCOPY ( 3, X, 2, Y, 3 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      call dcopy ( 5, x, 1, a, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DCOPY ( 5, X, 1, A, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,5f8.2)' ) ( a(i,j), j = 1, 5 )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = dble ( 10 * i + j )
        end do
      end do

      call dcopy ( 5, x, 2, a, 5 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DCOPY ( 5, X, 2, A, 5 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,5f8.2)' ) ( a(i,j), j = 1, 5 )
      end do

      return
      end
      subroutine ddot_test ( )

c*********************************************************************72
c
cc DDOT_TEST tests DDOT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      integer lda
      integer ldb
      integer ldc

      parameter ( n = 5 )
      parameter ( lda = 10 )
      parameter ( ldb = 7 )
      parameter ( ldc = 6 )

      double precision a(lda,lda)
      double precision b(ldb,ldb)
      double precision c(ldc,ldc)
      integer i
      integer j
      double precision ddot
      double precision sum1
      double precision x(n)
      double precision y(n)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DDOT_TEST'
      write ( *, '(a)' ) '  DDOT computes the dot product of '
      write ( *, '(a)' ) '  double precision vectors.'

      do i = 1, n
        x(i) = dble ( i )
      end do

      do i = 1, n
        y(i) = - dble ( i )
      end do

      do i = 1, n
        do j = 1, n
          a(i,j) = dble ( i + j )
        end do
      end do

      do i = 1, n
        do j = 1, n
          b(i,j) = dble ( i - j )
        end do
      end do
c
c  To compute a simple dot product of two vectors, use a
c  call like this:
c
      sum1 = ddot ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  Dot product of X and Y is ', sum1
c
c  To multiply a ROW of a matrix A times a vector X, we need to
c  specify the increment between successive entries of the row of A:
c
      sum1 = ddot ( n, a(2,1), lda, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  Product of row 2 of A and X is ', sum1
c
c  Product of a column of A and a vector is simpler:
c
      sum1 = ddot ( n, a(1,2), 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  Product of column 2 of A and X is ', sum1
c
c  Here's how matrix multiplication, c = a*b, could be done
c  with DDOT:
c
      do i = 1, n
        do j = 1, n
          c(i,j) = ddot ( n, a(i,1), lda, b(1,j), 1 )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Matrix product computed with DDOT:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,5g14.6)' ) ( c(i,j), j = 1, n )
      end do

      return
      end
      subroutine dnrm2_test ( )

c*********************************************************************72
c
cc DNRM2_TEST tests DNRM2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      integer lda

      parameter ( n = 5 )
      parameter ( lda = n + 5 )
c
c  These parameters illustrate the fact that matrices are typically
c  dimensioned with more space than the user requires.
c
      double precision a(lda,lda)
      integer i
      integer incx
      integer j
      double precision dnrm2
      double precision sum1
      double precision x(n)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DNRM2_TEST'
      write ( *, '(a)' ) '  DNRM2 computes the Euclidean norm of '
      write ( *, '(a)' ) '  a double precision vector.'
c
c  Compute the euclidean norm of a vector:
c
      do i = 1, n
        x(i) = dble ( i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The vector X:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,f8.4)' ) i, x(i)
      end do
      incx = 1

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  The 2-norm of X is ',
     &  dnrm2 ( n, x, incx )
c
c  Compute the euclidean norm of a row or column of a matrix:
c
      do i = 1, n
        do j = 1, n
          a(i,j) = dble ( i + j )
        end do
      end do

      incx = lda
      sum1 = dnrm2 ( n, a(2,1), incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  The 2-norm of row 2 of A is ', sum1

      incx = 1
      sum1 = dnrm2 ( n, a(1,2), incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  The 2-norm of column 2 of A is ', sum1

      return
      end
      subroutine drot_test ( )

c*********************************************************************72
c
cc DROT_TEST tests DROT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 6 )

      double precision c
      integer i
      double precision s
      double precision x(n)
      double precision y(n)

      do i = 1, n
        x(i) = dble ( i )
      end do

      do i = 1, n
        y(i) = dble ( i * i - 12 )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DROT_TEST'
      write ( *, '(a)' ) '  DROT carries out a double precision '
      write ( *, '(a)' ) '  Givens rotation.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      c = 0.5D+00
      s = sqrt ( 1.0D+00 - c * c )
      call drot ( n, x, 1, y, 1, c, s )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a,f8.4,a)' )
     &  '  DROT ( N, X, 1, Y, 1, ', c, ',', s, ' )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      do i = 1, n
        x(i) = dble ( i )
      end do

      do i = 1, n
        y(i) = dble ( i * i - 12 )
      end do

      c = x(1) / sqrt ( x(1) * x(1) + y(1) * y(1) )
      s = y(1) / sqrt ( x(1) * x(1) + y(1) * y(1) )
      call drot ( n, x, 1, y, 1, c, s )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a,f8.4,a)' )
     &  '  DROT ( N, X, 1, Y, 1, ', c, ',', s, ' )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      return
      end
      subroutine drotg_test ( )

c*********************************************************************72
c
cc DROTG_TEST tests DROTG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      double precision a
      double precision b
      double precision c
      double precision r8_uniform_01
      double precision r
      double precision s
      double precision sa
      double precision sb
      integer seed
      integer test
      integer test_num
      parameter ( test_num = 5 )
      double precision z

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST08'
      write ( *, '(a)' ) '  DROTG generates a real Givens rotation'
      write ( *, '(a)' ) '    (  C  S ) * ( A ) = ( R )'
      write ( *, '(a)' ) '    ( -S  C )   ( B )   ( 0 )'
      write ( *, '(a)' ) ' '

      seed = 123456789

      do test = 1, test_num

        a = r8_uniform_01 ( seed )
        b = r8_uniform_01 ( seed )

        sa = a
        sb = b

        call drotg ( sa, sb, c, s )

        r = sa
        z = sb

        write ( *, '(a)' ) ' '
        write ( *, '(a,g14.6,a,g14.6)' ) '  A =  ', a,  '  B =  ', b
        write ( *, '(a,g14.6,a,g14.6)' ) '  C =  ', c,  '  S =  ', s
        write ( *, '(a,g14.6,a,g14.6)' ) '  R =  ', r,  '  Z =  ', z
        write ( *, '(a,g14.6)' ) '   C*A+S*B = ',  c * a + s * b
        write ( *, '(a,g14.6)' ) '  -S*A+C*B = ', -s * a + c * b

      end do

      return
      end
      subroutine dscal_test ( )

c*********************************************************************72
c
cc DSCAL_TEST tests DSCAL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 6 )

      double precision da
      integer i
      double precision x(n)

      do i = 1, n
        x(i) = dble ( i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DSCAL_TEST'
      write ( *, '(a)' ) '  DSCAL multiplies a double precision scalar'
      write ( *, '(a)' ) '  times a vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      da = 5.0D+00
      call dscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DSCAL ( N, ', da, ', X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = dble ( i )
      end do

      da = -2.0D+00
      call dscal ( 3, da, x, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DSCAL ( 3, ', da, ', X, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      return
      end
      subroutine dswap_test ( )

c*********************************************************************72
c
cc DSWAP_TEST tests DSWAP.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 6 )

      integer i
      double precision x(n)
      double precision y(n)

      do i = 1, n
        x(i) = dble ( i )
      end do

      do i = 1, n
        y(i) = dble ( 100 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DSWAP_TEST'
      write ( *, '(a)' ) '  DSWAP swaps two vectors.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      call dswap ( n, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  DSWAP ( N, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      do i = 1, n
        x(i) = dble ( i )
      end do

      do i = 1, n
        y(i) = dble ( 100 * i )
      end do

      call dswap ( 3, x, 2, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  DSWAP ( 3, X, 2, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      return
      end
      subroutine idamax_test ( )

c*********************************************************************72
c
cc IDAMAX_TEST tests IDAMAX.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 11 )

      integer i
      integer i1
      integer incx
      integer idamax
      double precision x(n)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'IDAMAX_TEST'
      write ( *, '(a)' ) '  IDAMAX returns the index of maximum '
      write ( *, '(a)' ) '  magnitude;'

      do i = 1, n
        x(i) = dble ( mod ( 7 * i, 11 ) ) - dble ( n / 2 )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The vector X:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,f8.4)' ) i, x(i)
      end do

      incx = 1

      i1 = idamax ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,i6)' ) '  The index of maximum magnitude = ', i1

      return
      end


*> \brief \b DLAPY3 returns sqrt(x2+y2+z2).
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAPY3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION   X, Y, Z
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
*> unnecessary overflow.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] X
*> \verbatim
*>          X is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*>          Z is DOUBLE PRECISION
*>          X, Y and Z specify the values x, y and z.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
*  =====================================================================
      DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y, Z
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, ZABS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
      XABS = ABS( X )
      YABS = ABS( Y )
      ZABS = ABS( Z )
      W = MAX( XABS, YABS, ZABS )
      IF( W.EQ.ZERO ) THEN
*     W can be zero for max(0,nan,0)
*     adding all three entries together will make sure
*     NaN will not disappear.
         DLAPY3 =  XABS + YABS + ZABS
      ELSE
         DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
     $            ( ZABS / W )**2 )
      END IF
      RETURN
*
*     End of DLAPY3
*
      END


      MODULE PQ	!Plays with some integer arithmetic.
       INTEGER MSG	!Output unit number.
       CONTAINS		!One good routine.
        INTEGER FUNCTION GCD(I,J)	!Greatest common divisor.
         INTEGER I,J	!Of these two integers.
         INTEGER N,M,R	!Workers.
          N = MAX(I,J)	!Since I don't want to damage I or J,
          M = MIN(I,J)	!These copies might as well be the right way around.
    1     R = MOD(N,M)		!Divide N by M to get the remainder R.
          IF (R.GT.0) THEN	!Remainder zero?
            N = M			!No. Descend a level.
            M = R			!M-multiplicity has been removed from N.
            IF (R .GT. 1) GO TO 1	!No point dividing by one.
          END IF			!If R = 0, M divides N.
          GCD = M			!There we are.
        END FUNCTION GCD	!Euclid lives on!

        SUBROUTINE RATIONAL10(X)!By contrast, this is rather crude.
         DOUBLE PRECISION X	!The number.
         DOUBLE PRECISION R	!Its latest rational approach.
         INTEGER P,Q		!For R = P/Q.
         INTEGER F,WHACK	!Assistants.
         PARAMETER (WHACK = 10**8)	!The rescale...
          P = X*WHACK + 0.5	!Multiply by WHACK/WHACK = 1 and round to integer.
          Q = WHACK		!Thus compute X/1, sortof.
          F = GCD(P,Q)		!Perhaps there is a common factor.
          P = P/F		!Divide it out.
          Q = Q/F		!For a proper rational number.
          R = DBLE(P)/DBLE(Q)	!So, where did we end up?
          WRITE (MSG,1) P,Q,X - R,WHACK	!Details.
    1     FORMAT ("x - ",I0,"/",I0,T28," = ",F18.14,
     1     " via multiplication by ",I0)
        END SUBROUTINE RATIONAL10	!Enough of this.

        SUBROUTINE RATIONAL(X)	!Use brute force in a different way.
         DOUBLE PRECISION X	!The number.
         DOUBLE PRECISION R,E,BEST	!Assistants.
         INTEGER P,Q		!For R = P/Q.
         INTEGER TRY,F		!Floundering.
          P = 1 + X	!Prevent P = 0.
          Q = 1		!So, X/1, sortof.
          BEST = X*6	!A largeish value for the first try.
          DO TRY = 1,10000000	!Pound away.
            R = DBLE(P)/DBLE(Q)		!The current approximation.
            E = X - R			!Deviation.
            IF (ABS(E) .LE. BEST) THEN	!Significantly better than before?
              BEST = ABS(E)*0.125		!Yes. Demand eightfold improvement to notice.
              F = GCD(P,Q)			!We may land on a multiple.
              IF (BEST.LT.0.1D0) WRITE (MSG,1) P/F,Q/F,E	!Skip early floundering.
    1         FORMAT ("x - ",I0,"/",I0,T28," = ",F18.14)	!Try to align columns.
              IF (F.NE.1) WRITE (MSG,*) "Common factor!",F	!A surprise!
              IF (E.EQ.0) EXIT			!Perhaps we landed a direct hit?
            END IF			!So much for possible announcements.
            IF (E.GT.0) THEN	!Is R too small?
              P = P + CEILING(E*Q)	!Yes. Make P bigger by the shortfall.
            ELSE IF (E .LT. 0) THEN	!But perhaps R is too big?
              Q = Q + 1			!If so, use a smaller interval.
            END IF		!So much for adjustments.
          END DO		!Try again.
        END SUBROUTINE RATIONAL	!Limited integers, limited sense.

        SUBROUTINE RATIONALISE(X,WOT)	!Run the tests.
         DOUBLE PRECISION X	!The value.
         CHARACTER*(*) WOT	!Some blather.
          WRITE (MSG,*) X,WOT	!Explanations can help.
          CALL RATIONAL10(X)	!Try a crude method.
          CALL RATIONAL(X)	!Try a laborious method.
          WRITE (MSG,*)		!Space off.
        END SUBROUTINE RATIONALISE	!That wasn't much fun.
      END MODULE PQ	!But computer time is cheap.

      PROGRAM APPROX
      USE PQ
      DOUBLE PRECISION PI,E
      MSG = 6
      WRITE (MSG,*) "Rational numbers near to decimal values."
      WRITE (MSG,*)
      PI = 1		!Thus get a double precision conatant.
      PI = 4*ATAN(PI)	!That will determine the precision of ATAN.
      E = DEXP(1.0D0)	!Rather than blabber on about 1 in double precision.
      CALL RATIONALISE(0.1D0,"1/10 Repeating in binary..")
      CALL RATIONALISE(3.14159D0,"Pi approx.")
      CALL RATIONALISE(PI,"Pi approximated better.")
      CALL RATIONALISE(E,"e: rational approximations aren't much use.")
      CALL RATIONALISE(10.15D0,"Exact in decimal, recurring in binary.")
      WRITE (MSG,*)
      WRITE (MSG,*) "Variations on 67/74"
      CALL RATIONALISE(0.9054D0,"67/74 = 0·9(054) repeating in base 10")
      CALL RATIONALISE(0.9054054D0,"Two repeats.")
      CALL RATIONALISE(0.9054054054D0,"Three repeats.")
      WRITE (MSG,*)
      WRITE (MSG,*) "Variations on 14/27"
      CALL RATIONALISE(0.518D0,"14/27 = 0·(518) repeating in decimal.")
      CALL RATIONALISE(0.519D0,"Rounded.")
      CALL RATIONALISE(0.518518D0,"Two repeats, truncated.")
      CALL RATIONALISE(0.518519D0,"Two repeats, rounded.")
      END


!##############################################################################
! PROGRAM lineqsys
!
! ## Solves a linear equation system by LU-decomposition
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program lineqsys

    use toolbox

    implicit none
    integer :: i, j
    real*8 :: A(3, 3), b(3)
    real*8 :: L(3, 3), U(3, 3)

    ! set up matrix and vector
    A(1, :) = (/ 2d0,  0d0,  1d0/)
    A(2, :) = (/ 0d0,  4d0,  1d0/)
    A(3, :) = (/ 1d0,  1d0,  2d0/)
    b       = (/30d0, 40d0, 30d0/)

    ! solve the system
    call lu_solve(A, b)

    ! decompose matrix
    call lu_dec(A, L, U)

    ! output
    write(*,'(a,3f7.2/)')'    x = ', (b(j),j=1,3)
    write(*,'(a,3f7.2/,2(5x,3f7.2/))') &
        ' L = ',((L(i,j),j=1,3),i=1,3)
    write(*,'(a,3f7.2/,2(5x,3f7.2/))') &
        ' U = ',((U(i,j),j=1,3),i=1,3)

end program


Subroutine pibphi(srt, lb1, lb2, em1, em2, xphi, xphin)
  Parameter (maxstr=150001, maxr=1, amn=0.939457, amp=0.93828, ap1=0.13496, ap2=0.13957, am0=1.232, pi=3.1415926)
  Parameter (aka=0.498, ala=1.1157, pimass=0.140, aphi=1.02)
  Parameter (arho=0.77)
  Save
  xphi = 0.0
  xphin = 0.0
  xphid = 0.0
  If ((lb1>=3 .And. lb1<=5) .Or. (lb2>=3 .And. lb2<=5)) Then
    If ((iabs(lb1)>=1 .And. iabs(lb1)<=2) .Or. (iabs(lb2)>=1 .And. iabs(lb2)<=2)) Then
      If (srt>(aphi+amn)) Then
        srrt = srt - (aphi+amn)
        sig = 0.0235*srrt**(-0.519)
        xphin = sig*1.*(srt**2-(aphi+amn)**2)*(srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
      If (srt>(aphi+am0)) Then
        srrt = srt - (aphi+am0)
        sig = 0.0235*srrt**(-0.519)
        xphid = sig*4.*(srt**2-(aphi+am0)**2)*(srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
    Else
      If (srt>(aphi+amn)) Then
        srrt = srt - (aphi+amn)
        If (srrt<0.7) Then
          sig = 0.0119*srrt**(-0.534)
        Else
          sig = 0.0130*srrt**(-0.304)
        End If
        xphin = sig*(1./4.)*(srt**2-(aphi+amn)**2)*(srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
      If (srt>(aphi+am0)) Then
        srrt = srt - (aphi+am0)
        If (srrt<0.7) Then
          sig = 0.0119*srrt**(-0.534)
        Else
          sig = 0.0130*srrt**(-0.304)
        End If
        xphid = sig*1.*(srt**2-(aphi+am0)**2)*(srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
    End If
  Else
    If ((iabs(lb1)>=1 .And. iabs(lb1)<=2) .Or. (iabs(lb2)>=1 .And. iabs(lb2)<=2)) Then
      If (srt>(aphi+amn)) Then
        srrt = srt - (aphi+amn)
        If (srrt<0.7) Then
          sig = 0.0166*srrt**(-0.786)
        Else
          sig = 0.0189*srrt**(-0.277)
        End If
        xphin = sig*(1./3.)*(srt**2-(aphi+amn)**2)*(srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
      If (srt>(aphi+am0)) Then
        srrt = srt - (aphi+am0)
        If (srrt<0.7) Then
          sig = 0.0166*srrt**(-0.786)
        Else
          sig = 0.0189*srrt**(-0.277)
        End If
        xphid = sig*(4./3.)*(srt**2-(aphi+am0)**2)*(srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
    Else
      If (srt>(aphi+amn)) Then
        srrt = srt - (aphi+amn)
        If (srrt<0.7) Then
          sig = 0.0119*srrt**(-0.534)
        Else
          sig = 0.0130*srrt**(-0.304)
        End If
        xphin = sig*(1./12.)*(srt**2-(aphi+amn)**2)*(srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
      If (srt>(aphi+am0)) Then
        srrt = srt - (aphi+am0)
        If (srrt<0.7) Then
          sig = 0.0119*srrt**(-0.534)
        Else
          sig = 0.0130*srrt**(-0.304)
        End If
        xphid = sig*(1./3.)*(srt**2-(aphi+am0)**2)*(srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)
      End If
    End If
  End If
  xphin = xphin/10.
  xphid = xphid/10.
  xphi = xphin + xphid
  Return
End Subroutine pibphi