*----------------------------------------------------------------------*
      subroutine perm2cycl(iperm,icycl,npgr)
*----------------------------------------------------------------------*
*     get cycle structure of permutation iperm, described by its
*     cycle structure (in icycl(1:npgr,1)) and its cycles (in
*     icycl(1:npgr,2))
*----------------------------------------------------------------------*

      implicit none

      integer, intent(in) ::
     &     npgr, iperm(npgr)

      integer, intent(out) ::
     &     icycl(npgr,2)

      integer ::
     &     idx, jdx, istart, icnt, ipos, ncyc, imax, imin, idxmax
      integer ::
     &     icycraw(npgr), ib2cyc(npgr), lencyc(npgr)

      ! int cycle structure
      icycl(1:npgr,1) = 0

      ! start with position of "1" in iperm
      do idx = 1, npgr
        if (iperm(idx).eq.1) then
          istart = idx
          exit
        end if
      end do

      idx = 1
      ncyc = 1
      ib2cyc(1:npgr) = 0 ! init "belongs to cycle" array

      ! loop through permutation
      loop1: do
        ! remember start value and follow cycle
        ipos = istart
        icnt = 1
        loop2: do
          icycraw(ipos) = icnt ! remember way through iperm
          ib2cyc(ipos) = ncyc  ! and to which cycle it belonged
          ipos = iperm(ipos)
          idx = idx+1
          if (ipos.eq.istart) exit loop2
          icnt = icnt+1
        end do loop2

        ! update cycle structure descriptor
        icycl(icnt,1) = icycl(icnt,1)+1
        ! remember length of this cycle
        lencyc(ncyc) = icnt

        ! no more cycles?
        if (idx.gt.npgr) exit loop1

        ! increment cycle counter
        ncyc = ncyc+1

        ! get lowest next start value (next unassigned element of iperm)
        imin = npgr+1
        loop3: do jdx = 1, npgr
          if (ib2cyc(jdx).eq.0.and.iperm(jdx).lt.imin
     &       .and.iperm(jdx).gt.0) then             ! ib2cyc knows it ...
            imin = iperm(jdx)
            istart = jdx
          end if
        end do loop3
        if (imin.gt.npgr) exit loop1

      end do loop1
c dbg
      print *,'iperm  : ',iperm(1:npgr)
      print *,'icycraw: ',icycraw(1:npgr)
      print *,'ib2cyc : ',ib2cyc(1:npgr)
      print *,'lencyc : ',lencyc(1:ncyc)
c dbg

      ! resort to standard sequence (descending cycle order)
      jdx = 0
      do
        ! find maximum cycle length in lencyc
        imax = 0
        do idx = 1, ncyc
          if (lencyc(idx).gt.imax) then
            imax = lencyc(idx)
            idxmax = idx
          end if
        end do
        if (imax.eq.0) exit

        lencyc(idxmax) = -imax

        do idx = 1, npgr
          if (ib2cyc(idx).eq.idxmax) then
            icycl(jdx+icycraw(idx),2) = iperm(idx)
          end if
        end do
        jdx = jdx+imax

      end do
c dbg
      print *,'->',icycl(1:npgr,1)
      print *,'  ',icycl(1:npgr,2)
c dbg

      end


program mod_vecsub_01
  !! Issue #322 reported by @reinh-bader
  !! https://github.com/sourceryinstitute/OpenCoarrays/issues/322
  !! Related to other vector indexing issues
  implicit none
  integer, parameter :: ndim = 5, vdim = 2
  real :: vec(ndim), res(ndim)[*]
  integer :: idx(vdim)
  integer :: i, me
  logical :: ok[*]

  res = [ (real(i), i=1, ndim) ]
  vec = 0.0
  idx = [ ndim, 1 ]
  ok = .true.
  sync all
  me = this_image()
  vec(idx) = res(1:2)[1]
  if (vec(1) /= 2.0 .or. vec(5) /= 1.0) then
    critical
      ok[1] = .false.
      write(*, *) 'FAIL on image ',me,vec(idx)
    end critical
  end if
  if (me == 1) then
     if (ok) then
       write(*, *) 'Test passed.'
     else
        error stop 1
     end if
  end if
end program


! Program to test WHERE on unknown size arrays
program where_3
   integer A(10, 2)

   A = 0
   call sub(A)

contains

subroutine sub(B)
   integer, dimension(:, :) :: B

   B(1:5, 1) = 0
   B(6:10, 1) = 5
   where (B(:,1)>0)
      B(:,1) = B(:,1) + 10
   endwhere
   if (any (B .ne. reshape ((/0, 0, 0, 0, 0, 15, 15, 15, 15, 15, &
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0/), (/10, 2/)))) call abort
end subroutine
end program


c
c     file tcud24.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the complex MUDPACK solver cud2
c
c ... required MUDPACK files
c
c     cud2.f, cudcom.f
c
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for cud2
c
c **********************************************************
c **********************************************************
c
c     a sample program/test driver for cud2 is below.  it can be
c     executed as an initial test.  the output is listed for the
c     test case described.
c
c     test the driver below by solving the complex linear elliptic pde
c
c        cmplx(1.+x*x,1.+y*y)*pxx +
c
c        cmplx(exp(-x),exp(-y))*(pyy - py) +
c
c        cmplx(y,x)*p(x,y) = r(x,y)
c
c     on a 49 X 65 grid superimposed on the unit square with
c     specified boundary conditions at xb=1.0, yc=1.0 and
c     mixed boundary conditions
c
c           dp/dx - cmplx(y,y)*p(xa,y) = g(y) at x = xa
c     and
c
c           dp/dy + cmplx(x,x)*p(x,yd) = h(x) at y = yd.
c
c     the exact solution
c
c          p(x,y) = cmplx(x**5,y**5) + 1.0
c
c     is used for testing.  three multigrid cycles (no initial guess)
c     with red/black gauss-seidel point relaxation and the default multigrid
c     options are used to compute the second-order approximation with cud2.
c     Then cud24 is called to produce a fourth order estimate.
c
c ******************************************************
c     output (64 bit floating point arithmetic)
c *******************************************************
c
c     cud2 test
c
c     integer input arguments
c     intl =  0 nxa =  2 nxb =  1 nyc =  1 nyd =  2
c     ixp =  3 jyq =  2 iex =  5 jey =  6
c     nx =  49 ny =  65 iguess =  0 maxcy =  3
c     method =  0 work space estimate =   34192
c
c     multigrid option arguments
c     kcycle =  2
c     iprer =  2
c     ipost =  1
c     intpol =  3
c
c     floating point input parameters
c     xa =  0.000 xb =  1.000 yc =  0.000 yd =  1.000
c     tolerance (error control) =    0.000E+00
c
c     discretization call to cud2 intl =  0
c     ierror =  0 minimum work space =   34192
c
c     approximation call to cud2
c     intl =  1 method =  0 iguess =  0 maxcy =  3
c     ierror =  0
c     maximum error  =   0.640E-03
c
c     cud24 test  ierror =  0
c     maximum error  =   0.346E-05
c
c ************************************************************
c     end of output
c ************************************************************
c
      program tcud24
      implicit none
      integer iixp,jjyq,iiex,jjey,nnx,nny,llw
c
c     set grid sizes with parameter statements
c
      parameter (iixp = 3 , jjyq = 2 , iiex =5, jjey = 6)
      parameter (nnx=iixp*2**(iiex-1)+1, nny=jjyq*2**(jjey-1)+1)
c
c     set exact minimal work space required (see tcud2.f)
c
      parameter (llw=34192)
c
c     dimension solution,right hand side, and work arrays
c
      complex p(nnx,nny),r(nnx,nny),w(llw)
c     put integer and floating point parameter names in contiguous
c     storeage for labelling purposes
c
      integer iprm(16),mgopt(4)
      real fprm(6)
      integer intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      common/itcud2/intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      real xa,xb,yc,yd,tolmax,relmax
      common/ftcud2/xa,xb,yc,yd,tolmax,relmax
      equivalence(intl,iprm)
      equivalence(xa,fprm)
      integer i,j,ierror
      complex cxx,cyy,cx,cy,ce,pxx,pyy,px,py,pe
      real dlx,dly,x,y,errmax
c
c     declare coefficient and boundary condition input subroutines external
c
      external cof,bndc
c
c
c     set input integer arguments
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 2
      nxb = 1
      nyc = 1
      nyd = 2
c
c     set grid sizes from parameter statements
c
      ixp = iixp
      jyq = jjyq
      iex = iiex
      jey = jjey
      nx = nnx
      ny = nny
c
c     set for three multigrid cycle
c
      maxcy = 3
c
c     set work space length approximation from parameter statement
c
      nwork = llw
c
c     set point relaxation
c
      method = 0
c
c     flag no initial guess (this sets full multigrid cycling)
c
      iguess = 0
c
c     set end points of solution rectangle in (x,y) space
c
      xa = 0.0
      xb = 1.0
      yc = 0.0
      yd = 1.0
c
c     set mesh increments
c
      dlx = (xb-xa)/float(nx-1)
      dly = (yd-yc)/float(ny-1)
c
c     set for no error control
c
      tolmax = 0.0
c
c     set right hand side in r
c     initialize p to zero
c
      do i=1,nx
	x = xa+float(i-1)*dlx
	do j=1,ny
	  y = yc+float(j-1)*dly
	  call cof(x,y,cxx,cyy,cx,cy,ce)
	  call exact(x,y,pxx,pyy,px,py,pe)
	  r(i,j) = cxx*pxx+cyy*pyy+cx*px+cy*py+ce*pe
	  p(i,j) = (0.0,0.0)
	end do
      end do
c
c     set specified boundaries in p
c
      x = xb
      do j=1,ny
	y = yc+float(j-1)*dly
	call exact(x,y,pxx,pyy,px,py,pe)
	p(nx,j) = pe
      end do
      y = yc
      do i=1,nx
	x = xa+float(i-1)*dlx
	call exact(x,y,pxx,pyy,px,py,pe)
	p(i,1) = pe
      end do
c
c     set default multigrid opitons
c
      mgopt(1) = 2
      mgopt(2) = 2
      mgopt(3) = 1
      mgopt(4) = 3
c
c     print input parameters (except multigrid options which are default)
c
      write(6,100)
  100 format(//' cud2 test ')
      write (*,101) (iprm(i),i=1,15)
  101 format(/' integer input arguments ',
     +/'intl = ',i2,' nxa = ',i2,' nxb = ',i2,' nyc = ',i2,' nyd = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' iex = ',i2,' jey = ',i2
     +/' nx = ',i3,' ny = ',i3,' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space estimate = ',i7)
      write (*,102) (mgopt(i),i=1,4)
  102 format(/' multigrid option arguments ',
     +/' kcycle = ',i2,
     +/' iprer = ',i2,
     +/' ipost = ',i2
     +/' intpol = ',i2)
      write(*,103) xa,xb,yc,yd,tolmax
  103 format(/' floating point input parameters ',
     +/' xa = ',f6.3,' xb = ',f6.3,' yc = ',f6.3,' yd = ',f6.3,
     +/' tolerance (error control) =   ',e10.3)
c
c     intiialization call
c
      write(*,104) intl
  104 format(/' discretization call to cud2', ' intl = ', i2)
      call cud2(iprm,fprm,w,cof,bndc,r,p,mgopt,ierror)
c
c     print error parameter and minimum work space requirement
c
      write (*,105) ierror,iprm(16)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     attempt solution
c
      intl = 1
      write(*,106) intl,method,iguess,maxcy
  106 format(/' approximation call to cud2',
     +/' intl = ',i2, ' method = ',i2,' iguess = ',i2, ' maxcy = ',i2)
      call cud2(iprm,fprm,w,cof,bndc,r,p,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2)
c
c     compute and print exact maximum error
c
      errmax = 0.0
      do j=1,ny
	y = yc+(j-1)*dly
	do i=1,nx
	  x = xa+(i-1)*dlx
	  call exact(x,y,pxx,pyy,px,py,pe)
	  errmax = amax1(errmax,cabs((p(i,j)-pe)))
	end do
      end do
      write(*,108) errmax
  108 format(' maximum error  =  ',e10.3)
c
c      attempt to improve approximation to fourth order
c
      call cud24(w,p,ierror)
      write (*,109) ierror
  109 format(/' cud24 test ', ' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
      errmax = 0.0
      do j=1,ny
	y = yc+(j-1)*dly
	do i=1,nx
	  x = xa+(i-1)*dlx
	  call exact(x,y,pxx,pyy,px,py,pe)
	  errmax = amax1(errmax,abs((p(i,j)-pe)))
	end do
      end do
      write(*,108) errmax
      end

      subroutine cof(x,y,cxx,cyy,cx,cy,ce)
c
c     input pde coefficients at any grid point (x,y) in the solution region
c     (xa.le.x.le.xb,yc.le.y.le.yd) to cud2
c
      implicit none
      real x,y
      complex cxx,cyy,cx,cy,ce
      cxx = cmplx(1.+x*x,1.+y*y)
      cyy = cmplx(exp(-x),exp(-y))
      cx = (0.,0.)
      cy = -cyy
      ce = -cmplx(y,x)
      return
      end

      subroutine bndc(kbdy,xory,alfa,gbdy)
c
c     input mixed derivative b.c. to cud2
c
      implicit none
      integer kbdy
      real xory,x,y
      complex alfa,gbdy
      real xa,xb,yc,yd,tolmax,relmax
      common/ftcud2/xa,xb,yc,yd,tolmax,relmax
      complex pe,px,py,pxx,pyy
      if (kbdy.eq.1) then
c
c     x=xa boundary (nxa must equal 2)
c     b.c. has the form px + alfxa(y)*pe = gbdxa(y)
c     alfa and gbdy corresponding to alfxa(y),gbdxa(y)
c     must be output
c
	y = xory
	x = xa
	call exact(x,y,pxx,pyy,px,py,pe)
	alfa = -cmplx(y,y)
	gbdy = px + alfa*pe
	return
      end if
      if (kbdy.eq.4) then
c
c     y = yd boundary (nyd must equal 2)
c     b.c. has the form py + alfyd(x)*pe = gbdyd(x)
c     alfa and gbdy corresponding to alfyd(x),gbdyd(x)
c     must be output
c
	y = yd
	x = xory
	call exact(x,y,pxx,pyy,px,py,pe)
	alfa = cmplx(x,x)
	gbdy = py + alfa*pe
      return
      end if
      end

      subroutine exact(x,y,pxx,pyy,px,py,pe)
c
c     this subroutine is used to set an exact solution for testing cud2
c
      implicit none
      real x,y
      complex pxx,pyy,px,py,pe
      pe = cmplx(x**5,y**5)+1.0
      px = cmplx(5*x**4,0.)
      py = cmplx(0.,5*y**4)
      pxx = cmplx(20.*x**3,0.)
      pyy = cmplx(0.,20.*y**3)
      return
      end


c=======================================================================
c
c     SNORM
c
c     Standard Normal distribution generator N(0,1).
c
c-----------------------------------------------------------------------
c
c     Copyright (c) 2012 NumX
c     515, route de Savoie, 38114 Allemont, France
c     All rights reserved.
c
c     This software is the confidential and proprietary information
c     of NumX. You shall not disclose such Confidential
c     Information and shall use it only in accordance with the terms
c     of the licence agreement you entered into with NumX.
c
c     Author : Yann Vernaz
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION snorm()
c-----------------------------------------------------------------------
c
c     For details see:
c
c               AHRENS, J.H. AND DIETER, U.
c               EXTENSIONS OF FORSYTHE'S METHOD FOR RANDOM
c               SAMPLING FROM THE NORMAL DISTRIBUTION.
c               MATH. COMPUT., 27,124 (OCT. 1973), 927 - 937.
c
c     ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM 'FL'
c     (M=5) IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION)
c
c-----------------------------------------------------------------------
c
c     THE DEFINITIONS OF THE CONSTANTS A(K), D(K), T(K) AND
c     H(K) ARE ACCORDING TO THE ABOVEMENTIONED ARTICLE
c
c     local scalars
      DOUBLE PRECISION aa,s,tt,u,ustar,w,y
      INTEGER i
c
c     local arrays
      DOUBLE PRECISION a(32),d(31),h(31),t(31)
c
c     external functions
      DOUBLE PRECISION ranf
      EXTERNAL ranf
c
c     intrinsic functions
      INTRINSIC float, int
c
c     save statement
      SAVE a,d,t,h
c
c     data statements
      DATA a/0.0,.3917609E-1,.7841241E-1,.1177699,.1573107,.1970991,
     +     .2372021,.2776904,.3186394,.3601299,.4022501,.4450965,
     +     .4887764,.5334097,.5791322,.6260990,.6744898,.7245144,
     +     .7764218,.8305109,.8871466,.9467818,1.009990,1.077516,
     +     1.150349,1.229859,1.318011,1.417797,1.534121,1.675940,
     +     1.862732,2.153875/
      DATA d/5*0.0,.2636843,.2425085,.2255674,.2116342,.1999243,
     +     .1899108,.1812252,.1736014,.1668419,.1607967,.1553497,
     +     .1504094,.1459026,.1417700,.1379632,.1344418,.1311722,
     +     .1281260,.1252791,.1226109,.1201036,.1177417,.1155119,
     +     .1134023,.1114027,.1095039/
      DATA t/.7673828E-3,.2306870E-2,.3860618E-2,.5438454E-2,
     +     .7050699E-2,.8708396E-2,.1042357E-1,.1220953E-1,.1408125E-1,
     +     .1605579E-1,.1815290E-1,.2039573E-1,.2281177E-1,.2543407E-1,
     +     .2830296E-1,.3146822E-1,.3499233E-1,.3895483E-1,.4345878E-1,
     +     .4864035E-1,.5468334E-1,.6184222E-1,.7047983E-1,.8113195E-1,
     +     .9462444E-1,.1123001,.1364980,.1716886,.2276241,.3304980,
     +     .5847031/
      DATA h/.3920617E-1,.3932705E-1,.3950999E-1,.3975703E-1,
     +     .4007093E-1,.4045533E-1,.4091481E-1,.4145507E-1,.4208311E-1,
     +     .4280748E-1,.4363863E-1,.4458932E-1,.4567523E-1,.4691571E-1,
     +     .4833487E-1,.4996298E-1,.5183859E-1,.5401138E-1,.5654656E-1,
     +     .5953130E-1,.6308489E-1,.6737503E-1,.7264544E-1,.7926471E-1,
     +     .8781922E-1,.9930398E-1,.1155599,.1404344,.1836142,.2790016,
     +     .7010474/
c
c     executable Statements
   10 u = ranf()
      s = 0.0
      IF (u.GT.0.5) s = 1.0
      u = u + u - s
   20 u = 32.0*u
      i = int(u)
      IF (i.EQ.32) i = 31
      IF (i.EQ.0) GO TO 100
c
c     START CENTER
   30 ustar = u - float(i)
      aa = a(i)
   40 IF (ustar.LE.t(i)) GO TO 60
      w = (ustar-t(i))*h(i)
c
c     EXIT   (BOTH CASES)
   50 y = aa + w
      snorm = y
      IF (s.EQ.1.0) snorm = -y
      RETURN
c
c     CENTER CONTINUED
   60 u = ranf()
      w = u* (a(i+1)-aa)
      tt = (0.5*w+aa)*w
      GO TO 80

   70 tt = u
      ustar = ranf()
   80 IF (ustar.GT.tt) GO TO 50
   90 u = ranf()
      IF (ustar.GE.u) GO TO 70
      ustar = ranf()
      GO TO 40
c
c     START TAIL
  100 i = 6
      aa = a(32)
      GO TO 120

  110 aa = aa + d(i)
      i = i + 1
  120 u = u + u
      IF (u.LT.1.0) GO TO 110
  130 u = u - 1.0
  140 w = u*d(i)
      tt = (0.5*w+aa)*w
      GO TO 160

  150 tt = u
  160 ustar = ranf()
      IF (ustar.GT.tt) GO TO 50
  170 u = ranf()
      IF (ustar.GE.u) GO TO 150
      u = ranf()
      GO TO 140

      END


      subroutine gsmdez(delxia,dzvc0,dzvc0s,kdim,kmax,nord,nrd1mx)
c
c     This subroutine computes smoothed or averaged derivatives of the
c     elements of the z vector. The actual derivatives (of various
c     orders) are averaged over the interval (-delxia,+delxia). The
c     base point (point 0) is at the center of this interval.
c
c     Subroutine gsmder.f performs the same function for elements of
c     the r vector.
c
c     This subroutine is called by:
c
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax,nrd1mx
c
      integer nord,kdim
c
      real(8) dzvc0(nrd1mx,kmax),dzvc0s(nrd1mx,kmax)
c
      real(8) delxia
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer k,kcol,n,nmax
c
      real(8) dx,dzx
c
c-----------------------------------------------------------------------
c
c     Zero the averaged derivative arrays.
c
      nmax = nrd1mx*kmax
      call initaz(dzvc0s,nmax)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     The averaged derivatives are calculated over the interval
c     (-delxia,+delxia), about the base point (point 0).
c
      dx = 2.*delxia
c
c     Calculate average derivatives for elements of the z vector.
c
      do kcol = 1,kdim
        do n = 1,nord
          dzx = dzvc0(nord,kcol)
          do k = nord - 1,n,-1
            dzx = dzvc0(k,kcol) + (dzx*dx/(nord - n + 1))
          enddo
          dzvc0s(n,kcol) = dzx
        enddo
      enddo
c
  999 continue
      end


*###[ ffxdb1:
	subroutine ffxdb1(cdb1, p, m1, m2, ier)
***#[*comment:***********************************************************
*									*
*	DB1 function (derivative of B1)					*
*									*
*	algorithm adapted from Ansgar Denner's bcanew.f			*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	DOUBLE COMPLEX cdb1
	DOUBLE PRECISION p, m1, m2
	integer ier

	DOUBLE COMPLEX ffpvf, ffypvf
	external ffpvf, ffypvf

	DOUBLE COMPLEX xp, xm, yp, ym, r

	include 'ff.h'

	logical initir
	save initir

	data initir /.FALSE./

	if(abs(p) .gt. precx*(m1 + m2)) then

*		IR divergent case
	  if(m2 .eq. 0 .and. p .eq. m1) then
	    if(.not. initir) then
	      initir = .TRUE.
	      print *, "ffxdb1: IR divergent B1', ",
     +          "using cutoff ", lambda2
	    endif
	    cdb1 = .5D0*(3 + log(lambda2/p))/p
	    return
	  endif

	  call ffroots(p, m1, m2, xp, xm, yp, ym, r)
	  if(abs(xp - xm) .gt. sqrt(precx)*abs(xp + xm)) then
	    cdb1 = (ffypvf(2, xp, yp) - ffypvf(2, xm, ym))/r
	  else if(abs(xp) .gt. 10) then
	    cdb1 = DBLE( (2/3D0 +
     +       (2 - 3*xp)*ffpvf(3, xp, yp))/xp**2 )/p
	  else if(abs(yp) .gt. precx) then
	    cdb1 = DBLE( (3/2D0 +
     +       (2 - 3*xp)*ffpvf(1, xp, yp)) )/p
	  else
	    call fferr(101, ier)
	    cdb1 = 999D300
	  endif

*		zero momentum case
	else if(abs(m1 - m2) .gt. precx*(m1 + m2)) then
	  xm = DCMPLX(1D0, -1D-5*precx)*m1/(m1 - m2)
	  ym = DCMPLX(1D0, -1D-5*precx)*m2/(m2 - m1)
	  if(abs(xm) .lt. 10) then
	    cdb1 = -(1/3D0 + ffypvf(2, xm, ym))/(m1 - m2)
	  else
	    cdb1 = -(1/3D0 + ffypvf(3, xm, ym))/m1
	  endif

	else
	  cdb1 = -1/12D0/m1

	endif

	end

*###[ ffxdb11:
	subroutine ffxdb11(cdb11, p, m1, m2, ier)
***#[*comment:***********************************************************
*									*
*	DB11 function (derivative of B11)                               *
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	DOUBLE COMPLEX cdb11
	DOUBLE PRECISION p, m1, m2
	integer ier

	DOUBLE COMPLEX ffpvf, ffypvf
	external ffpvf, ffypvf

	DOUBLE COMPLEX xp, xm, yp, ym, r

	include 'ff.h'

	if(abs(p) .gt. precx*(m1 + m2)) then

	  call ffroots(p, m1, m2, xp, xm, yp, ym, r)
	  if(abs(xp - xm) .gt. sqrt(precx)*abs(xp + xm)) then
	    cdb11 = (ffypvf(3, xm, ym) - ffypvf(3, xp, yp))/r
	  else if(abs(xp) .gt. 10) then
	    cdb11 = DBLE( (-3/4D0 +
     +       (4*xp - 3)*ffpvf(4, xp, yp))/xp**2 )/p
	  else if(abs(yp) .gt. precx) then
	    cdb11 = DBLE( (-4/3D0 +
     +       (4*xp - 3)*ffpvf(2, xp, yp))/p )
	  else
	    call fferr(102, ier)
	    cdb11 = 999D300
	  endif

*		zero momentum case
	else
	  call fferr(102, ier)
	  cdb11 = 999D300

	endif

	end

*###[ ffroots
	subroutine ffroots(p, m1, m2, xp, xm, yp, ym, r)
***#[*comment:***********************************************************
*									*
*	roots of quadratic equation					*
*	p*x^2 + (m2 - m1 - p)*x + m2 - eps =				*
*	  p*(x - xp)*(x - xm) = p*(x - 1 + yp)*(x - 1 + ym)		*
*	i.e. x[pm] = 1 - y[pm]						*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	DOUBLE PRECISION p, m1, m2
	DOUBLE COMPLEX xp, xm, yp, ym, r

	DOUBLE PRECISION q

	include 'ff.h'

	r = sqrt(dcmplx(p*(p - 2*(m1 + m2)) + (m1 - m2)**2))
	q = p + m1 - m2
	xp = (q + r)/2D0/p
	xm = (q - r)/2D0/p
	if(abs(xm) .gt. abs(xp)) then
	  xp = m1/p/xm
	else if(abs(xp) .gt. abs(xm)) then
	  xm = m1/p/xp
	endif
	xp = xp + DCMPLX(0D0, abs(p*xp)/p*1D-5*precx)
	xm = xm + DCMPLX(0D0, -abs(p*xm)/p*1D-5*precx)

	q = p - m1 + m2
	ym = (q + r)/2D0/p
	yp = (q - r)/2D0/p
	if(abs(ym) .gt. abs(yp)) then
	  yp = m2/p/ym
	else if(abs(yp) .gt. abs(ym)) then
	  ym = m2/p/yp
	endif
	yp = yp + DCMPLX(0D0, -abs(p*yp)/p*1D-5*precx)
	ym = ym + DCMPLX(0D0, abs(p*ym)/p*1D-5*precx)

	end

*###[ ffpvf
	DOUBLE COMPLEX function ffpvf(n, x, y)
***#[*comment:***********************************************************
*									*
*	Passarino-Veltman function f(n, x)				*
*	here third arg y = 1 - x					*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer n
	DOUBLE COMPLEX x, y

	integer m
	DOUBLE COMPLEX xm

	include 'ff.h'

	if(abs(x) .lt. 10) then
	  if(n .eq. 0) then
	    ffpvf = -log(-y/x)
	  else if(x .eq. 0) then
	    ffpvf = -1D0/n
	  else
	    ffpvf = 0
	    xm = 1
	    do 10 m = 0, n - 1
	      ffpvf = ffpvf - xm/(n - m)
	      xm = xm*x
10	    continue
	    ffpvf = ffpvf - xm*log(-y/x)
	  endif
	else
	  ffpvf = 0
	  xm = 1
	  do 20 m = 1, 30
	    xm = xm/x
	    ffpvf = ffpvf + xm/(m + n)
	    if(abs(xm/ffpvf) .lt. precx) return
20	  continue
	endif
	end

*###[ ffypvf
	DOUBLE COMPLEX function ffypvf(n, x, y)
***#[*comment:***********************************************************
*									*
*	y*ffpvf(n, x, y)						*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer n
	DOUBLE COMPLEX x, y

	DOUBLE COMPLEX ffpvf
	external ffpvf

	if(abs(y) .eq. 0) then
	  ffypvf = 0
	else
	  ffypvf = y*ffpvf(n, x, y)
	endif
	end


program test_free_energy
use types, only: dp
use ofdft_fe, only: free_energy2
use constants, only: Ha2eV, pi
use utils, only: loadtxt, assert
use splines, only: spline3pars, iixmin, poly3
use interp3d, only: trilinear
use feutils, only: quad_gauss
use converged_energies, only: one_gaussian
implicit none
real(dp) :: Eh, Een, Ts, Exc, Etot
integer :: p, DOF, Nq
real(dp) :: Z
real(dp) :: Rcut, L, T_eV, T_au

Z = 1
Rcut = 0.3_dp
p = 4
L = 2
T_eV = 0.0862_dp
T_au = T_ev / Ha2eV
Nq = 20
call free_energy2(1._dp, L, 8, 8, 8, p, T_au, nen, ne, &
        Nq, quad_gauss, &
        Eh, Een, Ts, Exc, DOF)
Etot = Ts + Een + Eh + Exc
print *, "p =", p
print *, "DOF =", DOF
print *, "Rcut =", Rcut
print *, "T_au =", T_au
print *, "Summary of energies [a.u.]:"
print "('    Ts   = ', f14.8)", Ts
print "('    Een  = ', f14.8)", Een
print "('    Eee  = ', f14.8)", Eh
print "('    Exc  = ', f14.8)", Exc
print *, "   ---------------------"
print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV

! The reference answers are converged to at least 1e-5:
print *, abs(Ts  - one_gaussian(1))
call assert(abs(Ts  - one_gaussian(1)) < 1e-4)
print *, abs(Een - (- 3.80769))
call assert(abs(Een - (- 3.80769)) < 1e-4)
print *, abs(Eh  - one_gaussian(3))
call assert(abs(Eh  - one_gaussian(3)) < 1e-4)
print *, abs(Exc  - one_gaussian(4))
call assert(abs(Exc  - one_gaussian(4)) < 1e-4)

contains

real(dp) function nen(x, y, z_) result(n)
real(dp), intent(in) :: x, y, z_
real(dp), parameter :: alpha = 12
real(dp) :: r
r = sqrt((x-L/2)**2+(y-L/2)**2+(z_-L/2)**2)
! This density:
n = -Z*alpha**3/pi**(3._dp/2)*exp(-alpha**2*R**2)
! Corresponds to the potential:
!V = -Z*erf(alpha*R)/R
end function

real(dp) function ne(x, y, z) result(n)
real(dp), intent(in) :: x, y, z
real(dp), parameter :: alpha = 5, Z_ = 1
real(dp) :: r
r = sqrt((x-L/2)**2+(y-L/2)**2+(z-L/2)**2)
n = Z_*alpha**3/pi**(3._dp/2)*exp(-alpha**2*R**2)
end function

end program


      SUBROUTINE iau_TPXES ( A, B, A0, B0, XI, ETA, J )
*+
*  - - - - - - - - - -
*   i a u _ T P X E S
*  - - - - - - - - - -
*
*  In the tangent plane projection, given celestial spherical
*  coordinates for a star and the tangent point, solve for the star's
*  rectangular coordinates in the tangent plane.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Given:
*     A,B       d       star's spherical coordinates
*     A0,B0     d       tangent point's spherical coordinates
*
*  Returned:
*     XI,ETA    d       rectangular coordinates of star image (Note 2)
*     J         i       status:  0 = OK
*                                1 = star too far from axis
*                                2 = antistar on tangent plane
*                                3 = antistar too far from axis
*
*  Notes:
*
*  1) The tangent plane projection is also called the "gnomonic
*     projection" and the "central projection".
*
*  2) The eta axis points due north in the adopted coordinate system.
*     If the spherical coordinates are observed (RA,Dec), the tangent
*     plane coordinates (xi,eta) are conventionally called the "standard
*     coordinates".  For right-handed spherical coordinates, (xi,eta)
*     are also right-handed.  The units of (xi,eta) are, effectively,
*     radians at the tangent point.
*
*  3) All angular arguments are in radians.
*
*  4) This routine is a member of the following set:
*
*         spherical       vector       solve for
*
*       > iau_TPXES <    iau_TPXEV       xi,eta
*         iau_TPSTS      iau_TPSTV        star
*         iau_TPORS      iau_TPORV       origin
*
*  References:
*
*     Calabretta M.R. & Greisen, E.W., 2002, "Representations of
*     celestial coordinates in FITS", Astron.Astrophys. 395, 1077
*
*     Green, R.M., "Spherical Astronomy", Cambridge University Press,
*     1987, Chapter 13.
*
*  This revision:   2018 January 2
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION A, B, A0, B0, XI, ETA
      INTEGER J

      DOUBLE PRECISION TINY
      PARAMETER ( TINY = 1D-6 )

      DOUBLE PRECISION SB0, SB, CB0, CB, DA, SDA, CDA, D

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

*  Functions of the spherical coordinates.
      SB0 = SIN(B0)
      SB = SIN(B)
      CB0 = COS(B0)
      CB = COS(B)
      DA = A - A0
      SDA = SIN(DA)
      CDA = COS(DA)

*  Reciprocal of star vector length to tangent plane.
      D = SB*SB0 + CB*CB0*CDA

*  Check for error cases.
      IF ( D .GT. TINY ) THEN
         J = 0
      ELSE IF ( D .GE. 0D0 ) THEN
         J = 1
         D = TINY
      ELSE IF ( D .GT. -TINY ) THEN
         J = 2
         D = -TINY
      ELSE
         J = 3
      END IF

*  Return the tangent plane coordinates (even in dubious cases).
      XI = CB*SDA / D
      ETA = ( SB*CB0 - CB*SB0*CDA ) / D

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2020
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


      program reftrg
c
c     routine to apply the reftek trigger algorithm
c     to a designated SAC file
c     LTA is initialized to STA after 2 STA time constants
c     Trigger detection begins after trgdly seconds
c
c     compile with: f77 reftrg.f $SACDIR/lib/sac.a -f68881
c
c     Written by T.J. Owens, August 16, 1988
c
      character*32 file
      real lta,sta,ratio,xmean
c
c    Dimension huge arrays for application to long time windows
c
      real x(120000),trig(120000)
      real ysta(120000),ylta(120000)
      real rat(120000)
c
c    get input info
c
      write(6,100)
  100 format('Enter SAC file: ',$)
      read(5,*) file

      write(6,102)
  102 format('Enter duration for STA (in secs): ',$)
      read(5,*) sta

      write(6,101)
  101 format('Enter duration for LTA (in secs): ',$)
      read(5,*) lta

      write(6,103)
  103 format('Enter STA/LTA ratio: ',$)
      read(5,*) ratio

      write(6,104)
  104 format('LTA will be initialized to STA after 2 STA times',
     *       /,'Enter time delay (in seconds from begining of',
     *         ' trace)',/,'before start of trigger detection: ',$)
      read(5,*) trgdly

      do 900 i=1,10000
  900 x(i) = 0.0
c
c    get the trace data
c
      call rsac1(file,x,npts,beg,dt,120000,nerr)
c
c   establish number of points in LTA and STA windows
c    as well as in trgdly
c
      nlta=int(lta/dt) + 1
      nsta=int(sta/dt) + 1
      ntdly=int(trgdly/dt) + 1
c
c  n100 is number of data points in 100 second window
c      (needed for data mean calculation)
c
      n100=int(100./dt) + 1
c
c     clta and csta are constants in trigger algoritms
c
      clta=1./real(nlta)
      csta=1./real(nsta)

      xmean=0.0
c
c    start the triggering process
c
      do 3 i=1,npts
         nmean=i
         xmean=xmean +x(i)
c
c    after 100 seconds, data mean is mean of previous 100 seconds only
c
         if(i.ge.n100) then
                xmean=xmean - x(i-n100)
                nmean=n100
         endif
c
c    LTA value calculated as per REFTEK algorithm
c
         ylta(i)= clta*abs(x(i) - xmean/real(nmean))
     *          + (1-clta)*ylta(i-1)
c
c    STA value calculated as per REFTEK algorithm
c
         ysta(i)= csta*abs(x(i) - xmean/real(nmean))
     *          + (1-csta)*ysta(i-1)
c
c   trig is array that logs trigger status at each time point
c        trig(i) = 0.0 ===> No trigger declared
c        trig(i) = 1.0 ===> A trigger has been declared
c
         trig(i)=0.0
c
c   fix LTA to STA value after 2 STA time constants
c   just to get the process started
c
         if(i.eq.2*nsta) ylta(i)=ysta(i)
c
c   rat(i) is STA/LTA at each time point
c          rat is not calculated until LTA is initialized
c
         if(i.ge.2*nsta) rat(i)=ysta(i)/ylta(i)
c
c   start triggering after trgdly seconds
c   trgdly should be more than 2 STA time constants
c
         if(i.ge.ntdly) then
              if(rat(i).ge.ratio) trig(i)=1.0
         endif
c
    3 continue
c
c      find blank in filename
c
      do 4 i=1,32
         if(file(i:i).eq.' ') then
            iblnk=i-1
            go to 5
          endif
    4 continue
      write(6,*) 'no blanks in filename???'
    5 continue
c
c     file.sta contains the STA vs. time trace
c
      file(1:iblnk+4)=file(1:iblnk)//'.sta'
      call wsac1(file,ysta,npts,beg,dt,nerr)
c
c     file.lta contains the LTA vs. time trace
c
      file(1:iblnk+4)=file(1:iblnk)//'.lta'
      call wsac1(file,ylta,npts,beg,dt,nerr)
c
c     file.trig contains the trigger flag vs. time trace
c
      file(1:iblnk+5)=file(1:iblnk)//'.trig'
      call wsac1(file,trig,npts,beg,dt,nerr)
c
c     file.ratio contains the STA/LTA ratio vs. time trace
c
      file(1:iblnk+6)=file(1:iblnk)//'.ratio'
      call wsac1(file,rat,npts,beg,dt,nerr)

      stop
      end


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_FUNC_VZWW

    USE MR_KINDS

    USE MR_DEF_CONSTS_N_REF_PARS

    USE MR_MOC_K_EPS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_FUNC_VZWW

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_VZWW( V0 , KI , DI ) RESULT( VZWW )

   !DIR$ ATTRIBUTES VECTOR : UNIFORM( V0 ) :: MR_FUNC_VZWW

    IMPLICIT NONE

    REAL(PARD_KIND) , INTENT(IN ) :: V0
    REAL(FDRD_KIND) , INTENT(IN ) :: KI , DI

    REAL(FDRD_KIND) :: VZWW

    VZWW = V0 / VZR + CV0 / EKZ * KI * KI / MAX( DI , EPSILON(DI) )

  END FUNCTION MR_FUNC_VZWW

  END MODULE MR_MOD_FUNC_VZWW


      subroutine dttime(p,vel,dep,nvel,dt,dx,ibottom)
c---------------------------------------------------------------------
c     this routine calculates incremental travel times assuming
c  a linear gradient between successive velocity grid points.
c  very small gradients are treated as constant velocities to
c  prevent overflow.
c
c  arguments-
c
c     p=(input)=ray parameter of this ray.
c
c     vel,dep,nvel-(inputs)-vel and dep are real arrays of length nvel.
c                  vel(i) is the velocity at depth dep(i).
c                  dep(1) can be arbitray but the routine assumes
c                  dep(i) is less than dep(i+1) for all i.
c                  nvel must be at least two or a mode  error will
c                  almost surely follow.
c
c     dt=(output)=array of incremental travel times.  dt(i) gives the
c                 travel time spent by the ray of ray parameter p in
c                 layer i.
c
c     dx=(output)=array of incremental distances.
c                 dx(i) gives the horizontal distance added to the
c                 ray as the ray passes through layer i.
c
c     ibottom=(output)=this ray was found to bottom between
c             depth(ibottom) and depth(ibottom+1).  if ibottom.eq.nvel
c             the ray did not bottom.
c
c  written-january 1980
c  author-gary l. pavlis
c  language-1977 ansi standard fortran
c  modified - november 1980
c       earlier version calculated travel times and distances
c    incorrectly for negative gradients.
c    also removed inefficiency of old version which explicitly
c    recalculated si1 and rad1 each time through the main loop
c    this is unnecessarily slow because square roots are fairly slow
c    to compute.
c
c--------------------------------------------------------------------
      real vel(nvel),dep(nvel)
      real dt(nvel),dx(nvel)
      double precision si1,si2,rad1,rad2
      parameter(gradmin=0.0001)
c--initialize
      do 100 i=1,nvel
      dx(i) = 0.
  100 dt(i)=0.
c--be careful of completely illegal values of p
      if((p*vel(1)).ge.1.0) then
          ibottom=0
          return

      endif
      si1 = p*vel(1)
      rad1=dsqrt(1.-si1)*dsqrt(1.+si1)
      do 200 i=1,nvel-1
          si2=p*vel(i+1)
          vgrad=(vel(i+1)-vel(i))/(dep(i+1)-dep(i))
c--return when the bottom of the ray is reached.
c--that point is special
          if(si2.ge.1) then
                 ibottom=i
                 if(p.eq.0.) then
                      dx(i) = 0.
                 else
                      dx(i) = rad1/(vgrad*p)
                 endif
                 dt(i)=(1./vgrad)*dlog((1.+rad1)/si1)
                 return
          endif
c--test for small gradients.  if the gradient is too small treat that
c--layer as a constant velocity to prevent overflow.
          if(abs(vgrad).lt.gradmin) then
                 ddep=dep(i+1)-dep(i)
                 dx(i) = p*vel(i)*ddep/rad1
                 dt(i)=ddep/(vel(i)*rad1)
                 rad2 = rad1
          else
                 rad2=dsqrt(1.-si2)*dsqrt(1.+si2)
c--now calculate dx and dt being careful with the p=0 case
                 if(p.le.0.) then
                       dx(i) = 0.
                 else
                       dx(i) = (rad1-rad2)/(vgrad*p)
                 endif
                 dt(i)=(1.0/vgrad)*dlog((dble(vel(i+1))/dble(vel(i)))*
     $                               ((1.+rad1)/(1.+rad2)))
          endif
          si1 = si2
          rad1 = rad2
  200 continue
      ibottom=nvel
      return
      end

c $Id$


c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
c     SUBROUTINE MSUWEIGHT3.F
c
c     Date:    24-JAN-2005.
c     Author:  Ben Santer and Charles Doutriaux, LLNL, Livermore.
c     Version: # 1.0 / Single precision.
c
c
c
c     This subroutine processes temperature data at discrete pressure levels,
c     and computes from this data an "equivalent MSU" temperature. The MSU
c     weighting function is assumed to be in pressure coordinates (with 5 mb
c     vertical resolution).
c
c
c
      subroutine msuweight3(nhp, nhm, indx, heightp, heightm, weightm,
     &wtnorm1, ta1, ta2, bogus, critwt, sumw)
c
c
c
      implicit real (o-z, a-h)
c
c     ** INPUT **
c     integer nhp                  No. of pressure layers (target data)
c     integer nhm                  No. of pressure layers (MSU wt funct)
c     integer indx                 Index .gt. 1 = no diagnostics
c     dimension heightp(nhp)       Pressure coordinates (target data)
c     dimension heightm(nhm)       Pressure coordinates (MSU wt funct)
c     dimension weightm(nhm)       Input MSU weighting function
c     dimension ta1(nhp)           Input temperature data
c     real bogus                   Missing data code
c     real critwt                  Threshold fraction wts
c
c     ** OUTPUT **
c     dimension wtnorm1(nhp)       Normalized weight (target data)
c     real ta2                     Output equivalent MSU temperature
c     real sumw                    Sum of valid weights
c
c     ** INTERNAL **
c     dimension boundp1(250)       Lower edge of pressure layer (target data)
c     dimension boundp2(250)       Upper edge of pressure layer (target data)
c     dimension boundm1(250)       Lower edge of pressure layer (MSU wt funct)
c     dimension boundm2(250)       Upper edge of pressure layer (MSU wt funct)
c     dimension pwt(250)           Pressure weights (target data)
c     dimension totwt(250)         MSU weight for layer of target data
c
c
c
      integer nhp, nhm, indx
      dimension heightp(nhp), heightm(nhm), weightm(nhm)
      dimension ta1(nhp), wtnorm1(nhp)
      dimension boundp1(250), boundp2(250), boundm1(250), boundm2(250)
      dimension pwt(250), totwt(250)
      real bogus, critwt, ta2
c
c
c
c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.0 **
c
c     First compute weights and boundaries for pressure levels of target data
c     set.
c-------------------------------------------------------------------------------
c
c
c
        if (indx .le. 1) then
           print*, 'nhp, nhm, indx',nhp, nhm, indx
        endif

      edge2 = heightp(1) - ((heightp(2) - heightp(1)) / 2.0)
c
      do 100 k = 2, nhp
        edge1 = edge2
        edge2 = heightp(k - 1) + ((heightp(k) - heightp(k - 1)) / 2.0)
        pwt(k - 1) = edge2 - edge1
c
        if (indx .le. 1) then
          write(*, 101) k - 1, edge1, edge2, heightp(k - 1), pwt(k - 1)
          print*, k,ta1(k)
        end if
c
        boundp1(k - 1) = edge1
        boundp2(k - 1) = edge2
  100 continue
c
      edge1 = edge2
      edge2 = heightp(nhp) + ((heightp(nhp) - heightp(nhp - 1)) / 2.0)
      pwt(nhp) = edge2 - edge1
c
      if (indx .le. 1) then
        write(*, 101) nhp, edge1, edge2, heightp(nhp), pwt(nhp)
      end if
c
      boundp1(nhp) = edge1
      boundp2(nhp) = edge2
c
  101 format('IN MSUWEIGHT3: DATA LAYER', i4, 2x, 'EDGE1 = ', f8.2, 2x,
     &'EDGE2 = ', f8.2, 2x, 'HEIGHT = ', f8.2, 2x, 'PWT = ', f8.2)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.1 **
c
c     Compute boundaries for MSU pressure levels (no pressure weight is
c     required, since layers are of equal thickness).
c-------------------------------------------------------------------------------
c
c
c
      edge2 = heightm(1) - ((heightm(2) - heightm(1)) / 2.0)
c
      do 110 k = 2, nhm
        edge1 = edge2
        edge2 = heightm(k - 1) + ((heightm(k) - heightm(k - 1)) / 2.0)
c
        if (indx .le. 1) then
          write(*, 111) k - 1, edge1, edge2, heightm(k - 1),
     &    weightm(k - 1)
        end if
c
        boundm1(k - 1) = edge1
        boundm2(k - 1) = edge2
  110 continue
c
      edge1 = edge2
      edge2 = heightm(nhm) + ((heightm(nhm) - heightm(nhm - 1)) / 2.0)
c
      if (indx .le. 1) then
        write(*, 111) nhm, edge1, edge2, heightm(nhm), weightm(nhm)
      end if
c
      boundm1(nhm) = edge1
      boundm2(nhm) = edge2
c
  111 format('IN MSUWEIGHT3: MSU LAYER', i4, 2x, 'EDGE1 = ', f8.2, 2x,
     &'EDGE2 = ', f8.2, 2x, 'HEIGHT = ', f8.2, 2x, 'WEIGHT = ', f8.5)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.2 **
c
c     Sum the total MSU weights over the layers of the target data set,
c     multiplying by the pressure weights for individual MSU layers (and for
c     fractions of individual layers) contained within each target layer.
c-------------------------------------------------------------------------------
c
c
c
      sum2 = 0.0
      do 121 k = 1, nhp
        s1     = boundp1(k)
        s2     = boundp2(k)
        sum1   = 0.0
        rcount = 0.0
        do 120 m = 1, nhm
          rm1 = boundm1(m)
          rm2 = boundm2(m)
c         print *, 's1, s2, rm1, rm2 = ', s1, s2, rm1, rm2
          if ((s1 .ge. rm1) .and. (s1 .le. rm2)) then
            wtemp = (min(s2, rm2) - s1) / (rm2 - rm1)
            sum1   = sum1 + wtemp * weightm(m)
            rcount = rcount + wtemp
          else if ((s2 .ge. rm1) .and. (s2 .le. rm2)) then
            wtemp = ((s2 - rm1) / (rm2 - rm1))
            sum1   = sum1 + wtemp * weightm(m)
            rcount = rcount + wtemp
          else if ((rm1 .ge. s1) .and. (rm2 .le. s2)) then
            sum1   = sum1 + weightm(m)
            rcount = rcount + 1
          end if
  120   continue
        totwt(k) = sum1
c
        if (indx .le. 1) then
          write(*, 122) k, s1, s2, heightp(k), totwt(k), rcount
        end if
c
        sum2 = sum2 + totwt(k)
  121 continue
c
  122 format('TARGET LAYER', i4, 2x, 'EDGE1 = ', f8.2, 2x,
     &'EDGE2 = ', f8.2, 2x, 'HEIGHT = ', f8.2, 2x,
     &'TOT. WT = ', f10.6, 2x, 'RCOUNT = ', f8.2)
c
      sum3 = 0.0
      do 123 k = 1, nhp
        wtnorm1(k) = totwt(k) / sum2
        if (indx .le. 1) then
          print *, 'HEIGHT = ', heightp(k), 'NORMALIZED WT = ',
     &    wtnorm1(k)
        end if
        sum3 = sum3 + wtnorm1(k)
  123 continue
      if (indx .le. 1) then
        print *, 'SUM OF WEIGHTS = ', sum3
      end if
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.3 **
c
c     Compute the product of the temperature at a discrete pressure level times
c     the MSU weight. Sum over all discrete pressure levels with valid data!
c-------------------------------------------------------------------------------
c
c
c
      sum1   = 0.0
      sumw   = 0.0
c
      do 130 k = 1, nhp
        term1 = ta1(k)
        if (term1 .ne. bogus) then
          sum1 = sum1 + (term1 * totwt(k))
          sumw = sumw + totwt(k)
        end if
  130 continue
c
      if (sumw .gt. critwt) then
        ta2 = sum1 / sumw
      else
        ta2 = bogus
      end if
c
      if (indx .le. 1) then
        print *, 'Equivalent MSU temp = ', ta2
      end if
c
      return
      end
c
      subroutine loop_thru_dims(nmsu,nlev,nic,nextra,
     &                          critw,
     &                          arrayin,weights,arrayout,
     &                          heightp,heightm,
     &                          temp,tempout,tempw)
      implicit none
      integer i,j,k,nmsu,nextra,nic,nlev
      real arrayin(nlev,nextra),arrayout(nic,nextra)
      real heightp(nlev),heightm(nmsu)
      real weights(nmsu,nic)
      real temp(nlev),tempw(nmsu),tempout(nlev)
      real equiv
      real bogus
      real critw
      real sumw,tempval

      bogus=1.e20

c$$$      print*, 'citeria:',critw,nic,bogus
      do i = 1, nextra
         do j = 1, nlev
            temp(j)=arrayin(j,i)
c$$$            if (i.le.2) then
c$$$               print *, i,j,' i-i ', temp(j)
c$$$            endif
         enddo
         do j = 1, nic
            do k = 1, nmsu
               tempw(k)=weights(k,j)
c$$$               if (i.le.2) then
c$$$                  print *, i,k,' w-w', tempw(k)
c$$$               endif

            enddo
c$$$      subroutine msuweight3(nhp, nhm, indx, heightp, heightm, weightm,
c$$$     &wtnorm1, ta1, ta2, bogus, critwt, sumw)

            call msuweight3(nlev, nmsu, i+1, heightp, heightm,
     &                      tempw,
     &                      tempout, temp,
     &                      tempval,
     &                      bogus, critw, sumw)
            arrayout(j,i)=tempval
         enddo
      enddo

      return
      end


! =================================================
!   Analytical solution, including explicit method
!     and implicit method
! =================================================

module numeric_solver

    use coordinates, only: Nx, Ny
    implicit none

    private

    real*8 :: T(Nx,Ny)
    real*8 :: T_(Nx,Ny), T0_(Nx,Ny)

    character(len=:), allocatable :: dir
    real*8                        :: tic, toc
    integer*4                     :: iter = 0

    real*8 :: Alpx, Alpy
    real*8 :: tau_ = 0
    real*8 :: steady_err

    public :: iterate

contains

    subroutine init()

        use physical_def, only: Ly, Tn, Ts
        use coordinates,  only: y

        ! Initalize temperature: linear distributed
        T  = (Tn - Ts)*y/Ly + Ts
        T_ = (T - Ts)/(Tn - Ts)

        ! Check if output directory exists
        call check_dir(dir)
        call save_tecplot_file(dir, iter, "Temperature", T)

    end subroutine init

    subroutine update_ex()

        use physical_def, only: qw_, qe_
        use coordinates,  only: Nx, Ny, dx_, dy_
        use time_config,  only: tau_step
        integer*4 :: I, J

        iter = iter + 1
        tau_ = tau_ + tau_step

        ! Interior
        do I = 2, Nx - 1
            do J = 2, Ny - 1
                T_(I,J) = (1 - 2*Alpx - 2*Alpy)*T0_(I,J)     &
                    &   + Alpx*T0_(I-1,J) + Alpx*T0_(I+1,J)  &
                    &   + Alpy*T0_(I,J-1) + Alpy*T0_(I,J+1)
            end do
        end do

        ! South
        do I = 2, Nx - 1
            T_(I,1)  = (1 - 2*Alpx - 3*Alpy)*T0_(I,1)        &
                &    + Alpx*T0_(I-1,1) + Alpx*T0_(I+1,1)     &
                &    + Alpy*T0_(I,2)
        end do

        ! North
        do I = 2, Nx - 1
            T_(I,Ny) = (1 - 2*Alpx - 3*Alpy)*T0_(I,Ny)       &
                &    + Alpx*T0_(I-1,Ny) + Alpx*T0_(I+1,Ny)   &
                &    + Alpy*T0_(I,Ny-1) + 2*Alpy
        end do

        ! West
        do J = 2, Ny - 1
            T_(1,J)  = (1 - Alpx - 2*Alpy)*T0_(1,J)          &
                &    + Alpx*dx_*qw_ + Alpx*T0_(2,J)          &
                &    + Alpy*T0_(1,J-1) + Alpy*T0_(1,J+1)
        end do

        ! East
        do J = 2, Ny - 1
            T_(Nx,J) = (1 - Alpx - 2*Alpy)*T0_(Nx,J)         &
                &    + Alpx*T0_(Nx-1,J) + Alpx*dx_*qe_       &
                &    + Alpy*T0_(Nx,J-1) + Alpy*T0_(Nx,J+1)
        end do

        ! Southwest
        T_(1,1)   = (1 - Alpx - 3*Alpy)*T0_(1,1)             &
            &     + Alpx*dx_*qw_ + Alpx*T0_(2,1)             &
            &     + Alpy*T0_(1,2)

        ! Northwest
        T_(1,Ny)  = (1 - Alpx - 3*Alpy)*T0_(1,Ny)            &
            &     + Alpx*dx_*qw_ + Alpx*T0_(2,Ny)            &
            &     + Alpy*T0_(1,Ny-1) + 2*Alpy

        ! Southeast
        T_(Nx,1)  = (1 - Alpx - 3*Alpy)*T0_(Nx,1)            &
            &     + Alpx*T0_(Nx-1,1) + Alpx*dx_*qe_          &
            &     + Alpy*T0_(Nx,2)

        ! Northeast
        T_(Nx,Ny) = (1 - Alpx - 3*Alpy)*T0_(Nx,Ny)           &
            &     + Alpx*T0_(Nx-1,Ny) + Alpx*dx_*qe_         &
            &     + Alpy*T0_(Nx,Ny-1) + 2*Alpy

    end subroutine update_ex

    subroutine update_im(mode)

        use physical_def, only: qw_, qe_
        use coordinates,  only: Nx, Ny, dx_, dy_
        use time_config,  only: tau_step
        use conv_config,  only: conv_cr, conv_max

        character(len=*), intent(in) :: mode

        real*8    :: A(Nx*Ny,Nx*Ny)
        real*8    :: b(Nx*Ny)
        real*8    :: T_vec(Nx*Ny)
        integer*4 :: I, J, P

        iter = iter + 1
        tau_ = tau_ + tau_step

        A = 0.
        b = 0.

        ! Interior
        do I = 2, Nx - 1
            do J = 2, Ny - 1
                P         = (I - 1)*Ny + J
                A(P,P)    = 1 + 2*Alpx + 2*Alpy
                A(P,P-Ny) = -Alpx
                A(P,P+Ny) = -Alpx
                A(P,P-1)  = -Alpy
                A(P,P+1)  = -Alpy
                b(P)      = T0_(I,J)
            end do
        end do

        ! South
        do I = 2, Nx - 1
            P         = (I - 1)*Ny + 1
            A(P,P)    = 1 + 2*Alpx + 3*Alpy
            A(P,P-Ny) = -Alpx
            A(P,P+Ny) = -Alpx
            A(P,P+1)  = -Alpy
            b(P)      = T0_(I,1)
        end do

        ! North
        do I = 2, Nx - 1
            P         = I*Ny
            A(P,P)    = 1 + 2*Alpx + 3*Alpy
            A(P,P-Ny) = -Alpx
            A(P,P+Ny) = -Alpx
            A(P,P-1)  = -Alpy
            b(P)      = T0_(I,Ny) + 2*Alpy
        end do

        ! West
        do J = 2, Ny - 1
            P         = J
            A(P,P)    = 1 + Alpx + 2*Alpy
            A(P,P+Ny) = -Alpx
            A(P,P-1)  = -Alpy
            A(P,P+1)  = -Alpy
            b(P)      = T0_(1,J) + Alpx*dx_*qw_
        end do

        ! East
        do J = 2, Ny - 1
            P         = (Nx - 1)*Ny + J
            A(P,P)    = 1 + Alpx + 2*Alpy
            A(P,P-Ny) = -Alpx
            A(P,P-1)  = -Alpy
            A(P,P+1)  = -Alpy
            b(P)      = T0_(Nx,J) + Alpx*dx_*qe_
        end do

        ! Southwest
        P         = 1
        A(P,P)    = 1 + Alpx + 3*Alpy
        A(P,P+Ny) = -Alpx
        A(P,P+1)  = -Alpy
        b(P)      = T0_(1,1) + Alpx*dx_*qw_

        ! Northwest
        P         = Ny
        A(P,P)    = 1 + Alpx + 3*Alpy
        A(P,P+Ny) = -Alpx
        A(P,P-1)  = -Alpy
        b(P)      = T0_(1,Ny) + Alpx*dx_*qw_ + 2*Alpy

        ! Southeast
        P         = (Nx - 1)*Ny + 1
        A(P,P)    = 1 + Alpx + 3*Alpy
        A(P,P-Ny) = -Alpx
        A(P,P+1)  = -Alpy
        b(P)      = T0_(Nx,1) + Alpx*dx_*qe_

        ! Northeast
        P         = Nx*Ny
        A(P,P)    = 1 + Alpx + 3*Alpy
        A(P,P-Ny) = -Alpx
        A(P,P-1)  = -Alpy
        b(P)      = T0_(Nx,Ny) + Alpx*dx_*qe_ + 2*Alpy

        ! Solute linear equation
        select case (mode)
            case ("iter_ja_p")
                call iter_ja_p(A, b, T_vec, conv_cr, conv_max)
            case ("iter_gs_p")
                call iter_gs_p(A, b, T_vec, conv_cr, conv_max)
            case ("iter_ja_l")
                call iter_ja_l(A, b, T_vec, conv_cr, conv_max)
        end select

        ! Vector -> Matrix
        P = 0
        do I = 1, Nx
            do J = 1, Ny
                P = P + 1
                T_(I,J) = T_vec(P)
            end do
        end do

    end subroutine update_im

    subroutine check_steady()

        use conv_config, only: steady_cr
        use log_config,  only: log_freq

        call max_deviation(T_, T0_, steady_err)
        if (mod(iter, log_freq) == 0 .or. steady_err < steady_cr) then
            print *, "Iter:", iter, "Err:", steady_err
        end if

    end subroutine check_steady

    subroutine iterate_ex()

        use physical_def, only: Tn, Ts
        use time_config,  only: tau_max
        use conv_config,  only: steady_cr

        if (Alpx + Alpy > 0.5) then
            print *, "Error: diffusion number exceeds:"
            print *, "Alpha=", Alpx + Alpy
            return
        end if

        call init()
        T0_ = T_

        do while (tau_ < tau_max)
            call update_ex()
            T = T_*(Tn - Ts) + Ts
            call save_tecplot_file(dir, iter, "Temperature", T)
            call check_steady()
            if (steady_err < steady_cr) exit
            T0_ = T_
        end do

    end subroutine iterate_ex

    subroutine iterate_im(mode)

        use physical_def, only: Tn, Ts
        use time_config,  only: tau_max
        use conv_config,  only: steady_cr

        character(len=*), intent(in) :: mode

        call init()
        T0_ = T_

        do while (tau_ < tau_max)
            call update_im(mode)
            T = T_*(Tn - Ts) + Ts
            call save_tecplot_file(dir, iter, "Temperature", T)
            call check_steady()
            if (steady_err < steady_cr) exit
            T0_ = T_
        end do

    end subroutine iterate_im

    subroutine iterate(res, res_, method)

        use coordinates, only: Nx, Ny, dx_, dy_
        use time_config, only: tau_step

        integer*4, intent(in)  :: method
        real*8,    intent(out) :: res(Nx,Ny), res_(Nx,Ny)

        call cpu_time(tic)

        Alpx = tau_step/dx_**2
        Alpy = tau_step/dy_**2

        select case (method)
            case (0)
                print *, "Method: explicit."
                dir = ".\\out\\explicit\\"
                call iterate_ex()
            case (1)
                print *, "Method: implicit, Jacobi."
                dir = ".\\out\\implicit_ja_p\\"
                call iterate_im("iter_ja_p")
            case (2)
                print *, "Method: implicit, Gauss-Seidel."
                dir = ".\\out\\implicit_gs_p\\"
                call iterate_im("iter_gs_p")
            case (3)
                print *, "Method: implicit, Jacobi (block) + TDMA."
                dir = ".\\out\\implicit_ja_l\\"
                call iterate_im("iter_ja_l")
            case default
                return
        end select

        call cpu_time(toc)
        print *, "Converged!"
        print *, "Time consumed:", toc - tic, "s."

        res  = T
        res_ = T_

    end subroutine iterate

end module


      SUBROUTINE LMREXP(PARA,XMOM,NMOM)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC17097, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE EXPONENTIAL DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 2. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA (LOCATION,
C                  SCALE).
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(2),XMOM(NMOM)
      DATA ZERO/0D0/,HALF/0.5D0/,TWO/2D0/
C
      A=PARA(2)
      IF(A.LE.ZERO)GOTO 1000
      IF(NMOM.GT.20)GOTO 1010
      XMOM(1)=PARA(1)+A
      IF(NMOM.EQ.1)RETURN
      XMOM(2)=HALF*A
      IF(NMOM.EQ.2)RETURN
      DO 10 J=3,NMOM
   10 XMOM(J)=TWO/DFLOAT(J*(J-1))
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE LMREXP : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE LMREXP : PARAMETER NMOM TOO LARGE')
      END


*> \brief \b ZDRVRFP
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL,
*      +              THRESH, A, ASAV, AFAC, AINV, B,
*      +              BSAV, XACT, X, ARF, ARFINV,
*      +              Z_WORK_ZLATMS, Z_WORK_ZPOT02,
*      +              Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE,
*      +              D_WORK_ZPOT01, D_WORK_ZPOT02, D_WORK_ZPOT03 )
*
*       .. Scalar Arguments ..
*       INTEGER            NN, NNS, NNT, NOUT
*       DOUBLE PRECISION   THRESH
*       ..
*       .. Array Arguments ..
*       INTEGER            NVAL( NN ), NSVAL( NNS ), NTVAL( NNT )
*       COMPLEX*16         A( * )
*       COMPLEX*16         AINV( * )
*       COMPLEX*16         ASAV( * )
*       COMPLEX*16         B( * )
*       COMPLEX*16         BSAV( * )
*       COMPLEX*16         AFAC( * )
*       COMPLEX*16         ARF( * )
*       COMPLEX*16         ARFINV( * )
*       COMPLEX*16         XACT( * )
*       COMPLEX*16         X( * )
*       COMPLEX*16         Z_WORK_ZLATMS( * )
*       COMPLEX*16         Z_WORK_ZPOT02( * )
*       COMPLEX*16         Z_WORK_ZPOT03( * )
*       DOUBLE PRECISION   D_WORK_ZLATMS( * )
*       DOUBLE PRECISION   D_WORK_ZLANHE( * )
*       DOUBLE PRECISION   D_WORK_ZPOT01( * )
*       DOUBLE PRECISION   D_WORK_ZPOT02( * )
*       DOUBLE PRECISION   D_WORK_ZPOT03( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZDRVRFP tests the LAPACK RFP routines:
*>     ZPFTRF, ZPFTRS, and ZPFTRI.
*>
*> This testing routine follow the same tests as ZDRVPO (test for the full
*> format Symmetric Positive Definite solver).
*>
*> The tests are performed in Full Format, conversion back and forth from
*> full format to RFP format are performed using the routines ZTRTTF and
*> ZTFTTR.
*>
*> First, a specific matrix A of size N is created. There is nine types of
*> different matrixes possible.
*>  1. Diagonal                        6. Random, CNDNUM = sqrt(0.1/EPS)
*>  2. Random, CNDNUM = 2              7. Random, CNDNUM = 0.1/EPS
*> *3. First row and column zero       8. Scaled near underflow
*> *4. Last row and column zero        9. Scaled near overflow
*> *5. Middle row and column zero
*> (* - tests error exits from ZPFTRF, no test ratios are computed)
*> A solution XACT of size N-by-NRHS is created and the associated right
*> hand side B as well. Then ZPFTRF is called to compute L (or U), the
*> Cholesky factor of A. Then L (or U) is used to solve the linear system
*> of equations AX = B. This gives X. Then L (or U) is used to compute the
*> inverse of A, AINV. The following four tests are then performed:
*> (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or
*>     norm( U'*U - A ) / ( N * norm(A) * EPS ),
*> (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
*> (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
*> (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
*> where EPS is the machine precision, RCOND the condition number of A, and
*> norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4).
*> Errors occur when INFO parameter is not as expected. Failures occur when
*> a test ratios is greater than THRES.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>                The unit number for output.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER
*>                The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NN)
*>                The values of the matrix dimension N.
*> \endverbatim
*>
*> \param[in] NNS
*> \verbatim
*>          NNS is INTEGER
*>                The number of values of NRHS contained in the vector NSVAL.
*> \endverbatim
*>
*> \param[in] NSVAL
*> \verbatim
*>          NSVAL is INTEGER array, dimension (NNS)
*>                The values of the number of right-hand sides NRHS.
*> \endverbatim
*>
*> \param[in] NNT
*> \verbatim
*>          NNT is INTEGER
*>                The number of values of MATRIX TYPE contained in the vector NTVAL.
*> \endverbatim
*>
*> \param[in] NTVAL
*> \verbatim
*>          NTVAL is INTEGER array, dimension (NNT)
*>                The values of matrix type (between 0 and 9 for PO/PP/PF matrices).
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is DOUBLE PRECISION
*>                The threshold value for the test ratios.  A result is
*>                included in the output file if RESULT >= THRESH.  To have
*>                every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] ASAV
*> \verbatim
*>          ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AFAC
*> \verbatim
*>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AINV
*> \verbatim
*>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is COMPLEX*16 array, dimension (NMAX*MAXRHS)
*> \endverbatim
*>
*> \param[out] BSAV
*> \verbatim
*>          BSAV is COMPLEX*16 array, dimension (NMAX*MAXRHS)
*> \endverbatim
*>
*> \param[out] XACT
*> \verbatim
*>          XACT is COMPLEX*16 array, dimension (NMAX*MAXRHS)
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is COMPLEX*16 array, dimension (NMAX*MAXRHS)
*> \endverbatim
*>
*> \param[out] ARF
*> \verbatim
*>          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2)
*> \endverbatim
*>
*> \param[out] ARFINV
*> \verbatim
*>          ARFINV is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2)
*> \endverbatim
*>
*> \param[out] Z_WORK_ZLATMS
*> \verbatim
*>          Z_WORK_ZLATMS is COMPLEX*16 array, dimension ( 3*NMAX )
*> \endverbatim
*>
*> \param[out] Z_WORK_ZPOT02
*> \verbatim
*>          Z_WORK_ZPOT02 is COMPLEX*16 array, dimension ( NMAX*MAXRHS )
*> \endverbatim
*>
*> \param[out] Z_WORK_ZPOT03
*> \verbatim
*>          Z_WORK_ZPOT03 is COMPLEX*16 array, dimension ( NMAX*NMAX )
*> \endverbatim
*>
*> \param[out] D_WORK_ZLATMS
*> \verbatim
*>          D_WORK_ZLATMS is DOUBLE PRECISION array, dimension ( NMAX )
*> \endverbatim
*>
*> \param[out] D_WORK_ZLANHE
*> \verbatim
*>          D_WORK_ZLANHE is DOUBLE PRECISION array, dimension ( NMAX )
*> \endverbatim
*>
*> \param[out] D_WORK_ZPOT01
*> \verbatim
*>          D_WORK_ZPOT01 is DOUBLE PRECISION array, dimension ( NMAX )
*> \endverbatim
*>
*> \param[out] D_WORK_ZPOT02
*> \verbatim
*>          D_WORK_ZPOT02 is DOUBLE PRECISION array, dimension ( NMAX )
*> \endverbatim
*>
*> \param[out] D_WORK_ZPOT03
*> \verbatim
*>          D_WORK_ZPOT03 is DOUBLE PRECISION array, dimension ( NMAX )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16_lin
*
*  =====================================================================
      SUBROUTINE ZDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL,
     +              THRESH, A, ASAV, AFAC, AINV, B,
     +              BSAV, XACT, X, ARF, ARFINV,
     +              Z_WORK_ZLATMS, Z_WORK_ZPOT02,
     +              Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE,
     +              D_WORK_ZPOT01, D_WORK_ZPOT02, D_WORK_ZPOT03 )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            NN, NNS, NNT, NOUT
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            NVAL( NN ), NSVAL( NNS ), NTVAL( NNT )
      COMPLEX*16         A( * )
      COMPLEX*16         AINV( * )
      COMPLEX*16         ASAV( * )
      COMPLEX*16         B( * )
      COMPLEX*16         BSAV( * )
      COMPLEX*16         AFAC( * )
      COMPLEX*16         ARF( * )
      COMPLEX*16         ARFINV( * )
      COMPLEX*16         XACT( * )
      COMPLEX*16         X( * )
      COMPLEX*16         Z_WORK_ZLATMS( * )
      COMPLEX*16         Z_WORK_ZPOT02( * )
      COMPLEX*16         Z_WORK_ZPOT03( * )
      DOUBLE PRECISION   D_WORK_ZLATMS( * )
      DOUBLE PRECISION   D_WORK_ZLANHE( * )
      DOUBLE PRECISION   D_WORK_ZPOT01( * )
      DOUBLE PRECISION   D_WORK_ZPOT02( * )
      DOUBLE PRECISION   D_WORK_ZPOT03( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            NTESTS
      PARAMETER          ( NTESTS = 4 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ZEROT
      INTEGER            I, INFO, IUPLO, LDA, LDB, IMAT, NERRS, NFAIL,
     +                   NRHS, NRUN, IZERO, IOFF, K, NT, N, IFORM, IIN,
     +                   IIT, IIS
      CHARACTER          DIST, CTYPE, UPLO, CFORM
      INTEGER            KL, KU, MODE
      DOUBLE PRECISION   ANORM, AINVNM, CNDNUM, RCONDC
*     ..
*     .. Local Arrays ..
      CHARACTER          UPLOS( 2 ), FORMS( 2 )
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
      DOUBLE PRECISION   RESULT( NTESTS )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   ZLANHE
      EXTERNAL           ZLANHE
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALADHD, ALAERH, ALASVM, ZGET04, ZTFTTR, ZLACPY,
     +                   ZLAIPD, ZLARHS, ZLATB4, ZLATMS, ZPFTRI, ZPFTRF,
     +                   ZPFTRS, ZPOT01, ZPOT02, ZPOT03, ZPOTRI, ZPOTRF,
     +                   ZTRTTF
*     ..
*     .. Scalars in Common ..
      CHARACTER*32       SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Data statements ..
      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
      DATA               UPLOS / 'U', 'L' /
      DATA               FORMS / 'N', 'C' /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      NRUN = 0
      NFAIL = 0
      NERRS = 0
      DO 10 I = 1, 4
         ISEED( I ) = ISEEDY( I )
   10 CONTINUE
*
      DO 130 IIN = 1, NN
*
         N = NVAL( IIN )
         LDA = MAX( N, 1 )
         LDB = MAX( N, 1 )
*
         DO 980 IIS = 1, NNS
*
            NRHS = NSVAL( IIS )
*
            DO 120 IIT = 1, NNT
*
               IMAT = NTVAL( IIT )
*
*              If N.EQ.0, only consider the first type
*
               IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120
*
*              Skip types 3, 4, or 5 if the matrix size is too small.
*
               IF( IMAT.EQ.4 .AND. N.LE.1 ) GO TO 120
               IF( IMAT.EQ.5 .AND. N.LE.2 ) GO TO 120
*
*              Do first for UPLO = 'U', then for UPLO = 'L'
*
               DO 110 IUPLO = 1, 2
                  UPLO = UPLOS( IUPLO )
*
*                 Do first for CFORM = 'N', then for CFORM = 'C'
*
                  DO 100 IFORM = 1, 2
                     CFORM = FORMS( IFORM )
*
*                    Set up parameters with ZLATB4 and generate a test
*                    matrix with ZLATMS.
*
                     CALL ZLATB4( 'ZPO', IMAT, N, N, CTYPE, KL, KU,
     +                            ANORM, MODE, CNDNUM, DIST )
*
                     SRNAMT = 'ZLATMS'
                     CALL ZLATMS( N, N, DIST, ISEED, CTYPE,
     +                            D_WORK_ZLATMS,
     +                            MODE, CNDNUM, ANORM, KL, KU, UPLO, A,
     +                            LDA, Z_WORK_ZLATMS, INFO )
*
*                    Check error code from ZLATMS.
*
                     IF( INFO.NE.0 ) THEN
                        CALL ALAERH( 'ZPF', 'ZLATMS', INFO, 0, UPLO, N,
     +                               N, -1, -1, -1, IIT, NFAIL, NERRS,
     +                               NOUT )
                        GO TO 100
                     END IF
*
*                    For types 3-5, zero one row and column of the matrix to
*                    test that INFO is returned correctly.
*
                     ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
                     IF( ZEROT ) THEN
                        IF( IIT.EQ.3 ) THEN
                           IZERO = 1
                        ELSE IF( IIT.EQ.4 ) THEN
                           IZERO = N
                        ELSE
                           IZERO = N / 2 + 1
                        END IF
                        IOFF = ( IZERO-1 )*LDA
*
*                       Set row and column IZERO of A to 0.
*
                        IF( IUPLO.EQ.1 ) THEN
                           DO 20 I = 1, IZERO - 1
                              A( IOFF+I ) = ZERO
   20                      CONTINUE
                           IOFF = IOFF + IZERO
                           DO 30 I = IZERO, N
                              A( IOFF ) = ZERO
                              IOFF = IOFF + LDA
   30                      CONTINUE
                        ELSE
                           IOFF = IZERO
                           DO 40 I = 1, IZERO - 1
                              A( IOFF ) = ZERO
                              IOFF = IOFF + LDA
   40                      CONTINUE
                           IOFF = IOFF - IZERO
                           DO 50 I = IZERO, N
                              A( IOFF+I ) = ZERO
   50                      CONTINUE
                        END IF
                     ELSE
                        IZERO = 0
                     END IF
*
*                    Set the imaginary part of the diagonals.
*
                     CALL ZLAIPD( N, A, LDA+1, 0 )
*
*                    Save a copy of the matrix A in ASAV.
*
                     CALL ZLACPY( UPLO, N, N, A, LDA, ASAV, LDA )
*
*                    Compute the condition number of A (RCONDC).
*
                     IF( ZEROT ) THEN
                        RCONDC = ZERO
                     ELSE
*
*                       Compute the 1-norm of A.
*
                        ANORM = ZLANHE( '1', UPLO, N, A, LDA,
     +                         D_WORK_ZLANHE )
*
*                       Factor the matrix A.
*
                        CALL ZPOTRF( UPLO, N, A, LDA, INFO )
*
*                       Form the inverse of A.
*
                        CALL ZPOTRI( UPLO, N, A, LDA, INFO )

                        IF ( N .NE. 0 ) THEN
*
*                          Compute the 1-norm condition number of A.
*
                           AINVNM = ZLANHE( '1', UPLO, N, A, LDA,
     +                           D_WORK_ZLANHE )
                           RCONDC = ( ONE / ANORM ) / AINVNM
*
*                          Restore the matrix A.
*
                           CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
                        END IF
*
                     END IF
*
*                    Form an exact solution and set the right hand side.
*
                     SRNAMT = 'ZLARHS'
                     CALL ZLARHS( 'ZPO', 'N', UPLO, ' ', N, N, KL, KU,
     +                            NRHS, A, LDA, XACT, LDA, B, LDA,
     +                            ISEED, INFO )
                     CALL ZLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
*
*                    Compute the L*L' or U'*U factorization of the
*                    matrix and solve the system.
*
                     CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
                     CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDB )
*
                     SRNAMT = 'ZTRTTF'
                     CALL ZTRTTF( CFORM, UPLO, N, AFAC, LDA, ARF, INFO )
                     SRNAMT = 'ZPFTRF'
                     CALL ZPFTRF( CFORM, UPLO, N, ARF, INFO )
*
*                    Check error code from ZPFTRF.
*
                     IF( INFO.NE.IZERO ) THEN
*
*                       LANGOU: there is a small hick here: IZERO should
*                       always be INFO however if INFO is ZERO, ALAERH does not
*                       complain.
*
                         CALL ALAERH( 'ZPF', 'ZPFSV ', INFO, IZERO,
     +                                UPLO, N, N, -1, -1, NRHS, IIT,
     +                                NFAIL, NERRS, NOUT )
                         GO TO 100
                      END IF
*
*                     Skip the tests if INFO is not 0.
*
                     IF( INFO.NE.0 ) THEN
                        GO TO 100
                     END IF
*
                     SRNAMT = 'ZPFTRS'
                     CALL ZPFTRS( CFORM, UPLO, N, NRHS, ARF, X, LDB,
     +                            INFO )
*
                     SRNAMT = 'ZTFTTR'
                     CALL ZTFTTR( CFORM, UPLO, N, ARF, AFAC, LDA, INFO )
*
*                    Reconstruct matrix from factors and compute
*                    residual.
*
                     CALL ZLACPY( UPLO, N, N, AFAC, LDA, ASAV, LDA )
                     CALL ZPOT01( UPLO, N, A, LDA, AFAC, LDA,
     +                             D_WORK_ZPOT01, RESULT( 1 ) )
                     CALL ZLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA )
*
*                    Form the inverse and compute the residual.
*
                    IF(MOD(N,2).EQ.0)THEN
                       CALL ZLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV,
     +                               N+1 )
                    ELSE
                       CALL ZLACPY( 'A', N, (N+1)/2, ARF, N, ARFINV,
     +                               N )
                    END IF
*
                     SRNAMT = 'ZPFTRI'
                     CALL ZPFTRI( CFORM, UPLO, N, ARFINV , INFO )
*
                     SRNAMT = 'ZTFTTR'
                     CALL ZTFTTR( CFORM, UPLO, N, ARFINV, AINV, LDA,
     +                            INFO )
*
*                    Check error code from ZPFTRI.
*
                     IF( INFO.NE.0 )
     +                  CALL ALAERH( 'ZPO', 'ZPFTRI', INFO, 0, UPLO, N,
     +                               N, -1, -1, -1, IMAT, NFAIL, NERRS,
     +                               NOUT )
*
                     CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA,
     +                            Z_WORK_ZPOT03, LDA, D_WORK_ZPOT03,
     +                            RCONDC, RESULT( 2 ) )
*
*                    Compute residual of the computed solution.
*
                     CALL ZLACPY( 'Full', N, NRHS, B, LDA,
     +                            Z_WORK_ZPOT02, LDA )
                     CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA,
     +                            Z_WORK_ZPOT02, LDA, D_WORK_ZPOT02,
     +                            RESULT( 3 ) )
*
*                    Check solution from generated exact solution.
*
                     CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
     +                         RESULT( 4 ) )
                     NT = 4
*
*                    Print information about the tests that did not
*                    pass the threshold.
*
                     DO 60 K = 1, NT
                        IF( RESULT( K ).GE.THRESH ) THEN
                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     +                        CALL ALADHD( NOUT, 'ZPF' )
                           WRITE( NOUT, FMT = 9999 )'ZPFSV ', UPLO,
     +                            N, IIT, K, RESULT( K )
                           NFAIL = NFAIL + 1
                        END IF
   60                CONTINUE
                     NRUN = NRUN + NT
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
  980    CONTINUE
  130 CONTINUE
*
*     Print a summary of the results.
*
      CALL ALASVM( 'ZPF', NOUT, NFAIL, NRUN, NERRS )
*
 9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,
     +      ', test(', I1, ')=', G12.5 )
*
      RETURN
*
*     End of ZDRVRFP
*
      END


      program hycom_month_day
      implicit none
c
c     input:  ddd (ordinal day)
c     output: ddd, months that span the day, and their weights (linear interpolation)
c
c     example: echo 360 | hycom_month_day
c     result:  360 12 01 0.6967211 0.3032789
c
      integer jday,mon0,mon1
      real*4  w0,w1,x
c
      read(5,*) jday
      x    = 1.0 + mod( jday+366.0-15.25,366.0)/30.5
      mon0 = x
      mon1 = mod(mon0,12)+1
      w1   = mod(x,1.0) !fraction
      w0   = 1.0-w1
      write(6,'(i3.3,2i3.2,2f10.7)') jday,mon0,mon1,w0,w1
      call exit(0)
      end


*
*     --------------------------------------------------------------
*        T R B A K 1
*     --------------------------------------------------------------
*
*
      SUBROUTINE TRBAK1(NM,N,A,E,M,Z)
*
      INTEGER I,J,K,L,M,N,NM
      DOUBLE PRECISION A(NM,N),E(N),Z(NM,M)
      DOUBLE PRECISION S
*
*     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1,
*     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
*     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
*
*     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
*     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
*     SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  TRED1.
*
*     ON INPUT:
*
*        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
*          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
*          DIMENSION STATEMENT;
*
*        N IS THE ORDER OF THE MATRIX;
*
*        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
*          FORMATIONS USED IN THE REDUCTION BY  TRED1
*          IN ITS STRICT LOWER TRIANGLE;
*
*        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
*          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY;
*
*        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED;
*
*        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
*          IN ITS FIRST M COLUMNS.
*
*     ON OUTPUT:
*
*        Z CONTAINS THE TRANSFORMED EIGENVECTORS
*          IN ITS FIRST M COLUMNS.
*
*     NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS.
*
*     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
*     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
*
*     ------------------------------------------------------------------
*
      IF (M .EQ. 0) GO TO 200
      IF (N .EQ. 1) GO TO 200
*
      DO 140 I = 2, N
         L = I - 1
         IF (E(I) .EQ. 0.0D0) GO TO 140
*
         DO 130 J = 1, M
            S = 0.0D0
*
            DO 110 K = 1, L
  110       S = S + A(I,K) * Z(K,J)
*     :::::::::: DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1.
*                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ::::::::::
            S = (S / A(I,L)) / E(I)
*
            DO 120 K = 1, L
  120       Z(K,J) = Z(K,J) + S * A(I,K)
*
  130    CONTINUE
*
  140 CONTINUE
*
  200 RETURN
*     :::::::::: LAST CARD OF TRBAK1 ::::::::::
      END


      subroutine cranknicholson(u,r,rk,n)

      integer n,NMAX
*     !i/o
      double precision a,b,c,rk,u(n),r(n)
*     !i/o
      PARAMETER (NMAX = 5000)
      integer j
      double precision bet,gam(NMAX)

      a = -rk
      b = 1.d0+2.d0*rk
      c = -rk

      bet = 1.d0 + rk!b
      u(1) = r(1)/bet

      do j = 2,n
         gam(j) = c/bet
         bet = b - a*gam(j)
         if (j.eq.n) bet = bet - rk
         if (bet.eq.0.) then
            write(*,*) 'tridiag failed'
            stop
         endif
         u(j) = (r(j)-a*u(j-1))/bet
      enddo

      do j = n-1,1,-1
         u(j) = u(j) - gam(j+1)*u(j+1)
      enddo

      return
      end


*     MB04YD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          MNMIN
      PARAMETER        ( MNMIN = MIN( MMAX, NMAX ) )
      INTEGER          LDU, LDV
      PARAMETER        ( LDU = MMAX, LDV = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 6*MNMIN - 5 )
*     .. Local Scalars ..
      DOUBLE PRECISION RELTOL, THETA, TOL
      INTEGER          I, INFO, IWARN, J, M, MINMN, N, RANK, RANK1
      CHARACTER*1      JOBU, JOBV
      LOGICAL          LJOBUU, LJOBVU
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), E(MNMIN-1), Q(MNMIN),
     $                 U(LDU,MNMIN), V(LDV,MNMIN)
      LOGICAL          INUL(MNMIN)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04YD
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, THETA, RANK, TOL, RELTOL, JOBU, JOBV
      MINMN = MIN( M, N )
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) N
      ELSE IF ( RANK.GT.MINMN ) THEN
         WRITE ( NOUT, FMT = 99986 ) RANK
      ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         WRITE ( NOUT, FMT = 99985 ) THETA
      ELSE
         READ ( NIN, FMT = * ) ( Q(I), I = 1,MINMN )
         READ ( NIN, FMT = * ) ( E(I), I = 1,MINMN-1 )
         RANK1 = RANK
         LJOBUU = LSAME( JOBU, 'U' )
         LJOBVU = LSAME( JOBV, 'U' )
         IF ( LJOBUU ) READ ( NIN, FMT = * )
     $                      ( ( U(I,J), J = 1,MINMN ), I = 1,M )
         IF ( LJOBVU ) READ ( NIN, FMT = * )
     $                      ( ( V(I,J), J = 1,MINMN ), I = 1,N )
*        Initialise the array INUL.
         DO 20 I = 1, MINMN
            INUL(I) = .FALSE.
   20    CONTINUE
         IF ( LJOBUU.OR.LJOBVU ) READ ( NIN, FMT = * )
     $                                ( INUL(I), I = 1,MINMN )
*        Compute the number of singular values of J > THETA.
         CALL MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V,
     $                LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99993 ) IWARN
               WRITE ( NOUT, FMT = 99984 ) RANK
            END IF
            WRITE ( NOUT, FMT = 99997 )
            DO 160 I = 1, MINMN - 1
               WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I)
  160       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) MINMN, MINMN, Q(MINMN)
            IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99994 ) RANK, THETA
            IF ( .NOT.LSAME( JOBV, 'N' ) ) THEN
               WRITE ( NOUT, FMT = 99992 )
               DO 180 I = 1, N
                  WRITE ( NOUT, FMT = 99991 ) ( V(I,J), J = 1,MINMN )
  180          CONTINUE
            END IF
            IF ( ( .NOT.LSAME( JOBU, 'N' ) ) .AND.
     $           ( .NOT.LSAME( JOBV, 'N' ) ) )
     $           WRITE ( NOUT, FMT = 99990 )
            IF ( .NOT.LSAME( JOBU, 'N' ) ) THEN
               WRITE ( NOUT, FMT = 99989 )
               DO 200 I = 1, M
                  WRITE ( NOUT, FMT = 99991 ) ( U(I,J), J = 1,MINMN )
  200          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04YD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04YD = ',I2)
99997 FORMAT (' The transformed bidiagonal matrix J is',/)
99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99995 FORMAT (' (',I1,',',I1,') = ',F7.4)
99994 FORMAT (/' J has ',I2,' singular values >',F7.4,/)
99993 FORMAT (' IWARN on exit from MB04YD = ',I2,/)
99992 FORMAT (' The product of the right-hand Givens rotation matrices',
     $       ' equals ')
99991 FORMAT (20(1X,F8.4))
99990 FORMAT (' ')
99989 FORMAT (' The product of the left-hand Givens rotation matrices ',
     $       'equals ')
99988 FORMAT (/' M is out of range.',/' M = ',I5)
99987 FORMAT (/' N is out of range.',/' N = ',I5)
99986 FORMAT (/' RANK is out of range.',/' RANK = ',I5)
99985 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4)
99984 FORMAT (/' The computed rank of matrix J = ',I3,/)
      END


module advection_module

  use riemann_module

  implicit none

contains

  subroutine get_advective_source(U, k)

    use grid_module
    use runtime_params_module

    implicit none

    real(dp_t), intent(in) :: U(a_lo:a_hi, NVAR)
    real(dp_t), intent(inout) :: k(a_lo:a_hi, NVAR)

    real(dp_t) :: q(a_lo:a_hi, NVAR), dq(a_lo:a_hi, NVAR)
    real(dp_t) :: flux(a_lo:a_hi, NVAR)

    integer :: i, n
    real(dp_t) :: dc, dl, dr, da, test
    real(dp_t) :: q_l(NVAR), q_r(NVAR)

    ! convert to primitive variables
    q(:, QRHO) = U(:, URHO)
    q(:, QU) = U(:, UMX)/q(:, QRHO)
    q(:, QP) = (U(:, UENER) - 0.5_dp_t * q(:, QRHO) * q(:, QU)**2)*(gamma - 1.0_dp_t)

    ! compute slopes
    do n = 1, NVAR
       do i = ilo-1, ihi+1
          dc = 0.5_dp_t * (q(i+1, n) - q(i-1, n))
          dl = q(i+1, n) - q(i, n)
          dr = q(i, n) - q(i-1, n)

          test = dl * dr

          if (test > 0.0_dp_t) then
             if (abs(dl) < abs(dr)) then
                da = dl
             else
                da = dr
             endif
          else
             da = 0.0
          endif

          dq(i, n) = da

       enddo
    enddo

    ! compute interface states -- this is a loop over interfaces
    do i = ilo, ihi+1

       do n = 1, NVAR
          q_l(n) = q(i-1, n) + 0.5_dp_t * dq(i-1, n)
          q_r(n) = q(i, n) - 0.5_dp_t * dq(i, n)
       enddo

       ! solve Riemann problem
       call riemann(gamma, &
                    q_l(QRHO), q_l(QU), q_l(QP), &
                    q_r(QRHO), q_r(QU), q_r(QP), &
                    flux(i, URHO), flux(i, UMX), flux(i, UENER))
    enddo

    ! compute the advective source
    do i = ilo, ihi
       do n = 1, NVAR
          k(i, n) = -(flux(i+1, n) - flux(i, n))/dx
       enddo
    enddo

  end subroutine get_advective_source

end module advection_module


      SUBROUTINE GMMATC( A,ROWA,COLA,MTA, B, ROWB,COLB,NTB, C )
C*****
C     GMMATC - G E N E R A L  M A T R I X  M U L T I P L Y
C                                 A N D
C                           T R A N S P O S E
C            S I N G L E  P R E C I S I O N  V E R S I O N
C     COMPLEX VERSION
C
C     PERFORMS                                     WHEN
C               A            *  B            =  C     MTA=0  NTB= 0
C               A            *  B TRANSPOSE  =  C          0       1
C               A TRANSPOSE  *  B            =  C          1       0
C               A TRANSPOSE  *  B TRANSPOSE  =  C          1       1
C*****
C     A -  IS A MATRIX (ROWA) ROWS BY (COLA) COLUMNS
C     B -  IS A MATRIX (ROWB) ROWS BY (COLB) COLUMNS
C     A,B AND C ARE STORED BY ROWS (EXAMPLE)
C              MATRIX                   STORED
C         A=   1    2              A=   1
C              3    4                   2
C              5    6                   3
C                                       4
C                                       5
C                                       6
C*****
C
C
C     IF MTA .LT. 0, C IS NOT ZEROED OUT.  HENCE THE ROUTINE, IN THIS
C     CASE, COMPUTES  A * B  +  D  =  C  WHERE THE MATRIX  D  HAS BEEN
C     STORED ROW-WISE AT  C  BY THE CALLING PROGRAM.  IF MTA = -1,  A
C     IS TRANSPOSED.  IF MTA = -2,  A  IS NOT TRANSPOSED.  NTB IS
C     DEFINED AS ABOVE AND IS INDEPENDENT OF MTA.
C
C
      INTEGER   ROWA,COLA,  ROWB,COLB
C
C
C
      INTEGER IPARM(2)
      COMPLEX A(1),B(1),C(1)
C
C
C
      NTA = IABS(MTA)
      IF (MTA .EQ. (-2)) NTA = 0
      IF ( NTA .NE. 0 ) GO TO 10
C
C A IS NOT TRANSPOSED
C
      NROWA = ROWA
      NCOLA = COLA
      INCRIK = 1
      IKN = COLA
      INCIK1 = COLA
      GO TO 20
C
C A IS TRANSPOSED
C
   10 NROWA = COLA
      NCOLA = ROWA
      INCRIK = COLA
      IKN = ( ROWA-1 )*COLA + 1
      INCIK1 = 1
   20 IF( NTB .NE. 0 ) GO TO 30
C
C B IS NOT TRANSPOSED
C
      NROWB = ROWB
      NCOLB = COLB
      INCRKJ = COLB
      INCKJ1 = 1
      GO TO 40
C
C B IS TRANSPOSED
C
   30 NROWB = COLB
      NCOLB = ROWB
      INCRKJ = 1
      INCKJ1 = COLB
C
C CHECK CONSISTANT DIMENSIONS AND ZERO C IF NO D MATRIX
C
   40 IF( NCOLA .NE. NROWB ) GO TO 80
      IF( MTA .LT. 0 ) GO TO 50
      NTERMS = NROWA*NCOLB
      DO 42 I=1,NTERMS
      C(I) = 0
   42 CONTINUE
C
C PERFORM MATRIX MULTIPLICATION
C
   50 IJ1 = 1
      IJN = NCOLB
      IK1 = 1
      DO 58 I=1,NROWA
      KJ1 = 1
      DO 56 IJ =IJ1,IJN
      KJ = KJ1
      DO 54 IK=IK1,IKN,INCRIK
      C(IJ) = C(IJ) + A(IK)*B(KJ)
      KJ = KJ + INCRKJ
   54 CONTINUE
      KJ1 = KJ1 + INCKJ1
   56 CONTINUE
      IJ1 = IJN + 1
      IJN = IJN + NCOLB
      IK1 = IK1 + INCIK1
      IKN = IKN + INCIK1
   58 CONTINUE
      RETURN
   80 IPARM(1) = NTA
      IPARM(2) = NTB
      CALL MESAGE (-30,21,IPARM(1))
      RETURN
      END