program barrier_breach ! (maux,mbc,mx,my,xlower,ylower,dx,dy,t,dt,aux)
implicit none

! Allocate variables
! Subroutine variables imported from b4step2.f90
integer :: mbc,maux ! , intent(inout)
integer :: mx, my !, intent(inout)
real(kind=8) ::  t, dt ! , intent(inout)
real(kind=8) :: xlower, ylower, dx, dy, db, depth !, intent(inout) ::
real(kind=8), allocatable, dimension(:) :: x, y, b, xx, yy, bb! , intent(out)

!real(kind=8) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc) ! , intent(inout)

! Local variables

real(kind=8),allocatable, dimension(:,:) :: X_mesh, Y_mesh, B_mesh, XXM, YYM, BBM, breach, bathy

CHARACTER(*), PARAMETER :: fileplace = "/home/claw/clawpack-v5.5.0/geoclaw/scratch/"

mbc = 2
my = 2880 ! number of columns of bathy
mx = 3480 ! number of rows of bathy
dx = 8.33622785689400e-03 ! increments of x
dy = 8.335728657656000e-03 ! increments of y
xlower = -99
ylower = 8
depth = -5000.0
db = abs(depth / (my - 1))
allocate(x(1-mbc:mx+mbc))
call create_bathy(xlower, ylower, mx, my, x, y, dx, dy, b, db, depth, mbc, xx, yy,bb)

!call test_bathy(x,y,b, xx, yy,bb)
call create_grid(X_mesh, Y_mesh, B_mesh, x, y, b, XXM, YYM, BBM)
call test_grid(X_mesh, Y_mesh, B_mesh, XXM, YYM, BBM)
!call create_island(B_mesh, Y_mesh, bathy)
!
!call test_island(bathy)
!call create_breach(X_mesh, Y_mesh, bathy, t)
!call test_breach(breach)

! Initialize breach to match the original bathymetry
!breach(:,:) = aux(1, :, :)

contains
    subroutine create_bathy(xlower, ylower, mx, my, x, y, dx, dy, b, db, depth, mbc, xx, yy,bb)
    implicit none
  ! Subroutine variables
  ! Subroutine variables imported from b4step2.f90
    integer, intent(inout) :: mx, my, mbc
    real(kind=8), intent(inout) :: xlower, ylower, dx, dy, db, depth
    real(kind=8), allocatable, dimension(:), intent(inout) :: y, b, xx, yy, bb
    real(kind=8), dimension(1-mbc:), intent(inout) :: x
    integer :: i, j
    real(kind=8) :: xll, yll, bll
    ! fill x and y like np.linspace
!    allocate(x(1-mbc:mx+mbc))
    allocate(y(1-mbc:my+mbc))
    allocate(b(1-mbc:my+mbc))
    allocate(xx(1-mbc:mx+mbc))
    allocate(yy(1-mbc:my+mbc))
    allocate(bb(1-mbc:my+mbc))
    x = (/((i-0.5d0)*dx + xlower, i=1-mbc,mx+mbc)/)
    y = (/((i-0.5d0)*dy + ylower, i=1-mbc,my+mbc)/)
    b = (/((i-0.5d0)*db + depth, i=1-mbc,my+mbc)/)
!    print *, db, depth
!     do i = 1, size(b)
!       print *, b(i)
!     end do

    do j=1-mbc,my+mbc
        yll = ylower + (j-0.5d0) * dy
        do i=1-mbc,mx+mbc
            xll = xlower + (i-0.5d0) * dx
            bll = depth + (j-0.5d0)*db
            ! Location logic
!            aux(1, i, j) = something
            xx(i) = xll
            yy(j) = yll
            bb(j) = bll
        end do
    end do
  end subroutine create_bathy

    subroutine test_bathy(x, y, b, xx, yy,bb)
        real(kind=8), intent(in), dimension(:) :: x, y, b
        real(kind=8), intent(in), dimension(:) :: xx, yy, bb
!        real, allocatable, dimension(:) ::  bb

        integer :: i, j

!        open(1, File='x_array.txt', form='unformatted')
!        open(2, File='y_array.txt', form='unformatted')
!        open(3, File='b_array.txt', form='unformatted')
!        allocate(xx(3480))
!        allocate(yy(2880))
!        allocate(bb(2880))
!        read(1) xx
!        read(2) yy
!        read(3) bb
!        close(1)
!        close(2)
!        close(3)
        if (all(abs(x - xx) < .01)) then
            print *, 'x is equal'
        end if
        if (all(abs(y - yy) < .01)) then
            print *, 'y is equal'
        end if
        if (all(abs(b - bb) < .01)) then
            print *, 'b is equal'
        end if
        do i=1, size(bb)
            print *, b(i), bb(i)
        end do

  end subroutine test_bathy
    subroutine create_grid(X_mesh, Y_mesh, B_mesh, x, y, b, XXM, YYM, BBM)
        real(kind=8), allocatable, intent(inout), dimension(:,:) :: X_mesh, Y_mesh, B_mesh, XXM, YYM, BBM
        real(kind=8), dimension(:), intent(inout) :: x, y, b
        real(kind=8) :: xll, yll, bll
        integer :: i,j
        ! fill x and y matrices a la np.meshgrid
        allocate(X_mesh(size(x), size(y)))
        allocate(Y_mesh(size(x), size(y)))
        allocate(B_mesh(size(b), size(y)))
        allocate(XXM(1-mbc:mx+mbc,1-mbc:my+mbc))
        allocate(YYM(1-mbc:mx+mbc,1-mbc:my+mbc))
        allocate(BBM(1-mbc:mx+mbc,1-mbc:my+mbc))
!        print *, shape(X_mesh), shape(Y_mesh), shape(B_mesh)
!        do i=1, size(y)
!            do j=1, size(x)
!                X_mesh(i,j) = x(j)
!                Y_mesh(i,j) = y(i)
!                B_mesh(i,j) = b(i)
!            end do
!        end do
        X_mesh = spread(x, 2, size(y))
        Y_mesh = spread(y, 1, size(x))
        B_mesh = spread(b, 1, size(x))
!        print *, X_mesh
        do j=1-mbc,my+mbc
            yll = ylower + (j-0.5d0) * dy
            do i=1-mbc,mx+mbc
                xll = xlower + (i-0.5d0) * dx
                bll = depth + (j-0.5d0)*db
                ! Location logic
                !            aux(1, i, j) = something
                XXM(i,j) = xll
                YYM(i,j) = yll
                BBM(i,j) = bll
            end do
        end do
    end subroutine create_grid
    subroutine test_grid(X_mesh, Y_mesh, B_mesh, XXM, YYM, BBM)
        real(kind=8), intent(in), dimension(:,:) :: X_mesh, Y_mesh, B_mesh
        real(kind=8), intent(in), dimension(:,:) :: XXM, YYM, BBM
        integer :: i,j
!        open(1, File='X_grid.txt', form='unformatted')
!        open(2, File='Y_grid.txt', form='unformatted')
!        open(3, File='B_grid.txt', form='unformatted')
!        read(1) xx_mesh
!        read(2) yy_mesh
!        read(3) bb_mesh
!        close(1)
!        close(2)
!        close(3)
        print *, shape(B_mesh), shape(Y_mesh), shape(X_mesh)
!        print *, B_mesh
        if (all(abs(X_mesh - XXM) < .01)) then
            print *, 'X is equal'
        end if
        if (all(abs(Y_mesh - YYM) < .01)) then
            print *, 'Y is equal'
        end if
        if (all(abs(B_mesh - BBM) < .01)) then
            print *, 'B is equal'
        end if
!        do j =1, size(XXM,2)
!            do i = 1, size(XXM,1)
!                print *, B_mesh(i,j), BBM(i,j)
!            end do
!        end do
        end subroutine test_grid
    subroutine create_island(B_mesh, Y_mesh, bathy)
        real(kind=8), intent(in), dimension(:,:) :: Y_mesh, B_mesh
        real(kind=8), allocatable, dimension(:,:), intent(inout) :: bathy
        real :: isle_loc, isle_width, slope, base, isle_start, isle_end, isle_height
        integer :: i, j
        allocate(bathy(size(B_mesh, 1), size(B_mesh, 2)))
        isle_loc = 25.6
        isle_width = 0.2
        slope = 500/600e3
        base = isle_width / cos(slope)
        isle_start = isle_loc - (base/2)
        isle_end = isle_loc + (base/2)
        isle_height = 2
        do i = 1, size(B_mesh, 1)
            do j = 1, size(B_mesh, 2)
                if (Y_mesh(i, j) < isle_start) then
!                    print *, 'no island yet'
                    bathy(i,j) = B_mesh(i, j)
                    elseif (Y_mesh(i, j) >= isle_start .and. Y_mesh(i, j) <= isle_end) then
!                        print *, i, j
                    bathy(i,j) = isle_height
!                    print *, 'island', bathy(i,j)
                    elseif (Y_mesh(i,j) > isle_end) then
                        bathy(i,j) = B_mesh(i,j)

                end if
            end do
        end do

    end subroutine create_island
    subroutine test_island(bathy)
        real(kind=8),  dimension(:,:), intent(in) :: bathy
        real, dimension(2880,3480) :: in_bathy

        open(1, File='Bathy.txt', form='unformatted')
        read(1) in_bathy
        close(1)
!        print *, bathy
        if (all(abs(bathy - in_bathy) < .01)) then
            print *, 'Bathy is equal'
        end if

    end subroutine test_island

    subroutine create_breach(X_mesh, Y_mesh, bathy, t)
        real(kind=8), intent(in), dimension(:,:) :: X_mesh, Y_mesh, bathy
        real(kind=8), intent(in) :: t
        integer :: rowidx, colidx
        real(kind=8) :: sigma, x1, x2, y1, y2, xcol, ycol, mu, amp, t1
        ! Add breach parameters
        x1 = -88.0 ! left side of breach
        x2 = -86.0 ! right side of breach
        mu = -87.0 ! center of breach (expected value)
        y1 = 25.5 ! bottom of breach
        y2 = 25.7 ! top of breach
        sigma = 1.0 ! variance

        allocate(breach(size(bathy, 1), size(bathy, 2)))
        t1 = -200000.0
        if (t<t1) then
            amp =0.0
        elseif (t>t1) then
            amp=10.0
        end if
        ! Breach the barrier island depending on time
        breach = bathy
        do rowidx = 1, size(X_mesh, 1)
            do colidx = 1, size(X_mesh, 2)
                xcol = X_mesh(rowidx, colidx)
                ycol = Y_mesh(rowidx, colidx)
                if ((xcol >= x1) .and. (xcol <= x2) .and. &
                        ( ycol >= y1) .and. (ycol <= y2)) then
                    breach(rowidx, colidx) = breach(rowidx, colidx) &
                            - (10.0 * exp(-0.5 * (X_mesh(rowidx, colidx) - mu)**2/(sigma**2)) * 0.55*breach(rowidx, colidx))
!                    if(breach(rowidx, colidx)< 0) then
!                        breach(rowidx, colidx) = 0

!                    end if
                end if
            end do
        end do

    end subroutine create_breach
    subroutine test_breach(breach)
        real(kind=8),  dimension(:,:), intent(in) :: breach
        real, dimension(2880,3480) :: py_breach

        open(1, File='breach.txt', form='unformatted')
        read(1) py_breach
        close(1)
        if (all(abs(breach - py_breach) < .01)) then
            print *, 'Breach is equal'
        end if

    end subroutine test_breach

end program barrier_breach


c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine makegij(lmaxi,kkri,lmaxj,kkrj,
     >                   lmax,kkrsz,ndlj,ndlm,
     >                   prel,rij,sinmp,cosmp,
     >                   clm,plm,cgnt,lmax_cg,lofk,mofk,
     >                   ilp1,illp,
     >                   hfn,dlm,gij,
     >                   pi4,iprint,istop)
c     ==============================================================
c
      implicit   none
c
      character  sname*32
      character  istop*32
c
      integer    lmaxi
      integer    lmaxj
      integer    lend
      integer    kkri
      integer    kkrj
      integer    lmax,lmax_cg
      integer    kkrsz
      integer    ndlj
      integer    ndlm,ndlm_local
      integer    lofk(ndlj)
      integer    mofk(ndlj)
      integer    l,ll
      integer    l1
      integer    l2
      integer    m
      integer    ma
      integer    m1
      integer    m2
      integer    lm1
      integer    lm2
      integer    l3,m3,llow
      integer    j
      integer    iprint
c
      real*8     rij(3)
      real*8     sinmp(0:lmaxi+lmaxj)
      real*8     cosmp(0:lmaxi+lmaxj)
      real*8     clm(ndlm)
      real*8     plm(ndlm)
!     original definition of cgnt in LSMS_1
!     real*8     cgnt(lmax+1,kkrsz,kkrsz)
      real*8     cgnt(lmax_cg+1,(lmax_cg+1)**2,(lmax_cg+1)**2)
      real*8     pi4
      real*8     rmag
      real*8     pmag
      real*8     costheta
      real*8     m1m
      real*8     ptol
      real*8     zero
      real*8     one
c
      complex*16 prel
      complex*16 ilp1(0:lmaxi+lmaxj)
!     original definition of illp in LSMS_1
!     complex*16 illp(kkrsz,kkrsz)
      complex*16 illp((lmax+1)**2,kkrsz)
      complex*16 hfn(0:lmaxi+lmaxj)
      complex*16 dlm(ndlj)
      complex*16 gij(kkri,kkrj)
      complex*16 z
      complex*16 fac
      complex*16 sqrtm1
      complex*16 czero
      complex*16 cone
c
      parameter (sqrtm1=(0.0d0,1.0d0))
      parameter (czero =(0.0d0,0.0d0))
      parameter (cone  =(1.0d0,0.0d0))
      parameter (ptol  =1.0d-06)
      parameter (zero  =0.0d0)
      parameter (one   =1.0d0)
      parameter (sname ='makegij')
c
c     *****************************************************************
c
c
c      ij         l+1                                m ->  *
c     D  [E]  = -i    * sqrt(E) * h [sqrt(E)*R  ] * Y [R  ]
c      L                           l          ij     l  ij
c
c
c                 -l+1                               m  ->  *
c             = -i    * sqrt(E) * h [sqrt(E)*R  ] * Y [-R  ]
c                                  l          ij     l   ij
c
c The extra factor (-1)^m removed by xgz July 97 from plm (plglmax_c.f)
c to make Ylm consistent with Numerical Recipes.
c
c      m       [ (2*l+1)*(l-|m|)!]  m
c     Y  = sqrt[-----------------]*P [cos(theta)]*exp(i*m*phi)
c      l       [   4*pi*(l+|m|)! ]  l
c
c     for m>=0
c
c      m                  m  -m           *
c     Y [theta,phi] = (-1)  Y  [theta,phi]      for m<0
c      l                     l
c
c     ->    ->   ->
c     R   = R  - R  ==> [theta,phi]
c      ij    j    i
c
c     cos(theta)=Rij(3)/sqrt(Rij(1)**2+Rij(2)**2+Rij(3)**2)
c
c     cos(phi)  =Rij(1)/sqrt(Rij(1)**2+Rij(2)**2)
c
c                m     m
c     Indexing: P  :  P(l*(l+1)/2+m+1)  only +m are calculated
c                l     l
c
c                m     m
c     Indexing: C  :  C(l*(l+1)/2+m+1)  only +m are calculated
c                l     l
c
c                m     m
c     Indexing: D  :  D(l*(l+1)+m+1)    all   m are calculated
c                l     l
c
c     Now for the real space structure contant we have :
c
c      ij             l-l'         L       ij
c     G   (E) = 4*pi*i    * SUM { C     * D  (E) }
c      L,L'                  L"    L',L"   L"
c
c     *****************************************************************
c
c     =================================================================
      if(lmax.lt.0) then
         write(6,'('' makegij:: bad arguments: lmax='',i5)') lmax
         call fstop(sname)
      endif
      lend=lmaxi+lmaxj
c     =================================================================
c     calculate the hankel function.[dangerous code if z is close to 0]
c     hankel function is hfn*exp(i*z)/z
      rmag=sqrt(rij(1)*rij(1)+rij(2)*rij(2)+rij(3)*rij(3))
      if(rmag.lt.ptol) stop 'Error in makegij: rmag = 0.'
      if(prel.eq.czero) then
c if prel is zero then we calculate Gij for multipole Coulomb interaction.
	hfn(0)=cone/rmag
	do l=1,lend
	  hfn(l)=sqrtm1*(2*l-1)*hfn(l-1)/rmag
	enddo
      else
      z=prel*rmag
      hfn(0)=-sqrtm1
      hfn(1)=-cone-sqrtm1/z
      do l=1,lend-1
         hfn(l+1)=(2*l+1)*hfn(l)/z - hfn(l-1)
      enddo
c     =================================================================
c             l+1
c     hfn = -i   *h (k*R  )*sqrt(E)
c                  l    ij
c     =================================================================
      z=exp(sqrtm1*z)/rmag
      do l=0,lend
         hfn(l)=-hfn(l)*z*ilp1(l)
      enddo
      endif
c
c     =================================================================
c     calculate p(l,m)'s...............................................
      costheta=rij(3)/rmag
c     -----------------------------------------------------------------
      call plglmax(lend,costheta,plm)
c     -----------------------------------------------------------------
c     =================================================================
c     multiply be the normalization constant...........................
      ndlm_local=(lend+1)*(lend+2)/2
      if(ndlm_local.gt.ndlm) then
	write(6,'(''MAKEGIJ:: ndlm incorrect!'')')
        write(6,*) 'ndlm=',ndlm
        write(6,*) 'ndlm_local=',ndlm_local
	call fstop(sname)
      endif
      do j=1,ndlm_local
         plm(j)=clm(j)*plm(j)
      enddo
c     =================================================================
c     calculate cos(phi) and sin(phi) .................................
      pmag=sqrt(rij(1)*rij(1)+rij(2)*rij(2))
      cosmp(0)=one
      sinmp(0)=zero
      if(pmag.ge.ptol) then
         cosmp(1)=rij(1)/pmag
         sinmp(1)=rij(2)/pmag
      else
         cosmp(1)=zero
         sinmp(1)=zero
      endif
      do m=2,lend
         cosmp(m)=cosmp(m-1)*cosmp(1)-sinmp(m-1)*sinmp(1)
         sinmp(m)=sinmp(m-1)*cosmp(1)+cosmp(m-1)*sinmp(1)
      enddo
c
      j=0
      do l=0,lend
	 ll=l*(l+1)
	 j=ll+1
	 ll=ll/2+1
	 m1m=one
         dlm(j)= hfn(l)*plm(ll)
         do m=1,l
	    m1m=-m1m
	    fac=plm(ll+m)*dcmplx(cosmp(m),sinmp(m))
            dlm(j-m)= hfn(l)*m1m*fac
            dlm(j+m)= hfn(l)*conjg(fac)
         enddo
      enddo
c     =================================================================
      if(iprint.ge.3) then
         write(6,'(/)')
         write(6,*) "Rij=",rij(1),rij(2),rij(3)
         write(6,*) "cos(theta)=",costheta
         write(6,'(/)')
         write(6,'('' makegij:: l,m,dlm(l,m):'')')
	 do j=1,ndlj
            write(6,'(2i3,2x,f10.5,1x,d16.8)')
     >      lofk(j),mofk(j),dlm(j)
         enddo
         write(6,*) "i, plm(i)"
         do j=1,ndlm
           write(6,*) j,plm(j)
         end do
      endif
c
c     ================================================================
c     calculate g(R_ij)...............................................
c     ----------------------------------------------------------------
!     call zeroout(gij,2*kkri*kkrj)
      gij=0.0d0
c     ----------------------------------------------------------------
c     ================================================================
c     loop over l1,m1............................................
      do lm1=1,kkrj
         l1=lofk(lm1)
         m1=mofk(lm1)
c        =============================================================
c        loop over l2,m2..............................................
         do lm2=1,kkri
            l2=lofk(lm2)
            m2=mofk(lm2)
c           ==========================================================
c                            l2-l1
c           illp(lm2,lm1) = i
c
c           perform sum over l3 with gaunt # ......................
c           ==========================================================
	    m3=m2-m1
	    llow=max(abs(m3),abs(l1-l2))
	    if(prel.eq.czero) llow=l1+l2
            do l3=l1+l2,llow,-2
               j=l3*(l3+1)+m3+1
               gij(lm2,lm1) = gij(lm2,lm1)+cgnt(l3/2+1,lm1,lm2)*dlm(j)
            enddo
            gij(lm2,lm1)=pi4*illp(lm2,lm1)*gij(lm2,lm1)
         enddo
      enddo
c
c     ================================================================
c     printout if needed..............................................
      if(iprint.ge.3) then
c        =============================================================
c        loop over l1,m1..............................................
         do lm1=1,kkrj
            l1=lofk(lm1)
            m1=mofk(lm1)
c           ==========================================================
c           loop over l2,m2...........................................
            do lm2=1,kkri
               l2=lofk(lm2)
               m2=mofk(lm2)
               write(6,'('' lm1,lm2,l1,m1,l2,m2:'',6i3,2d12.5)')
     >         lm1,lm2,l1,m1,l2,m2,gij(lm2,lm1)
            enddo
         enddo
      endif
c     =================================================================
      if (istop.eq.sname) then
         call fstop(sname)
      else
         return
      endif
c
      end


program geomag2geog_testdriver

use phys_consts, only: wp,Re,pi
use geomagnetic, only : geomag2geog,geog2geomag,r2alt,alt2r

implicit none (type, external)

integer, parameter :: lr=128,ltheta=192,lphi=96
integer :: ir,itheta,iphi
real(wp), dimension(2) :: rlims, thetalims, philims
real(wp), dimension(lr) :: rarr
real(wp), dimension(ltheta) :: thetaarr
real(wp), dimension(lphi) :: phiarr
real(wp), dimension(:,:,:), allocatable :: r,theta,phi,  glon,glat,alt, rtest,thetatest,phitest
real(wp) :: r0,theta0,phi0,glon0,glat0,alt0
real(wp) :: r0test,theta0test,phi0test
real(wp) :: maxerrr,maxerrtheta,maxerrphi

allocate(r(lr,ltheta,lphi))
allocate(theta, phi, glon, glat, alt, rtest, thetatest, phitest, mold=r)

!> define points of interest
r0=Re+80e3
theta0=pi/36
phi0=pi/36
rlims=[r0,r0+900e3]
thetalims=[theta0,pi-theta0]
philims=[phi0,2*pi-phi0]
rarr=[(r0 + (rlims(2)-rlims(1))/lr*(ir-1),ir=1,lr)]
thetaarr=[(theta0 + (thetalims(2)-thetalims(1))/ltheta*(itheta-1),itheta=1,ltheta)]
phiarr=[(phi0 + (philims(2)-philims(1))/lphi*(iphi-1),iphi=1,lphi)]
do ir=1,lr
  do itheta=1,ltheta
    do iphi=1,lphi
      r(ir,itheta,iphi)=rarr(ir)
      theta(ir,itheta,iphi)=thetaarr(itheta)
      phi(ir,itheta,iphi)=phiarr(iphi)
    end do
  end do
end do

!> test the conversion of a single point
call geomag2geog(phi0,theta0,glon0,glat0)
alt0=r2alt(r0)
call geog2geomag(glon0,glat0,phi0test,theta0test)
r0test=alt2r(alt0)
print*, ' r,theta,phi coordinate diff:  ',abs(r0-r0test),abs(theta0-theta0test),abs(phi0-phi0test)
if (abs(phi0-phi0test)>1e-6 .or. abs(theta0-theta0test)>1e-6 .or. abs(r0-r0test)>1e-6) then
  error stop ' excessive error in single point coordinate conversion'
end if

!> test a 3D array conversion
call geomag2geog(phi,theta,glon,glat)
alt=r2alt(r)
print*, minval(glon),maxval(glon),minval(glat),maxval(glat)
call geog2geomag(glon,glat,phitest,thetatest)
rtest=alt2r(alt)
maxerrr=maxval(abs(rtest-r))
maxerrtheta=maxval(abs(thetatest-theta))
maxerrphi=maxval(abs(phitest-phi))
print*, ' r,theta,phi array max diff:  ',maxerrr,maxerrtheta,maxerrphi
if ( any([maxerrr,maxerrtheta,maxerrphi]>1e-6) ) error stop ' Excessive error in array coordinate conversion!'

end program geomag2geog_testdriver


      subroutine dbeskg (x1, alpha, kode, n, y, nz,ierr)
c     Author Serge Steer, Copyright INRIA, 2005
c     extends dbesk for the case where alpha is negative
c     x is supposed to be positive (besselk,with x<0 is complex)
      double precision x1,alpha,y(n)
      integer kode,n,nz,ierr
c
      double precision inf,x,dlamch,a1,temp

      inf=dlamch('o')*2.0d0
      x=x1
      ierr=0
      if (x.ne.x.or.alpha.ne.alpha) then
c     .  NaN case
         call dset(n,inf-inf,y,1)
         ierr=4
      elseif (x .eq. 0.0d0) then
         call dset(n,-inf,y,1)
         ierr=2
      elseif (alpha.ge.0.0d0) then
         call dbesk(x,alpha,kode,n,y,nz,ierr)
         if (ierr.eq.2) call dset(n,inf,y,1)
      else
         if(alpha-1.0d0+n.ge.0.0d0) then
c     .     0 is between alpha and alpha+n
            nn=int(-alpha)+1
         else
            nn=n
         endif
         a1=-(alpha-1.0d0+nn)
         call dbesk(x,a1,kode,nn,y,nz,ierr)
         if (ierr.eq.2) call dset(nn,inf,y,1)
c     .  swap the result to have it in correct order
         if (nn.ge.2) then
            do i=1,nn/2
               temp=y(i)
               y(i)=y(nn+1-i)
               y(nn+1-i)=temp
            enddo
         endif
         if (n.gt.nn) then
            call dbesk(x,1.0d0-a1,kode,n-nn,y(nn+1),nz,ier)
            if (ier.eq.2) call dset(n-nn,inf,y(nn+1),1)
            ierr=max(ierr,ier)
         endif
      endif
      end

      subroutine dbeskv (x,nx,alpha,na, kode,y,w,ierr)
c     Author Serge Steer, Copyright INRIA, 2005
c     compute besseli function for x and alpha given by vectors
c     w : working array of size 2*na (used only if nz>0 and alpha contains negative
C         values
      double precision x(nx),alpha(na),y(*),w(*)
      integer kode,nx,na,ier
      double precision e,dlamch,eps
      eps=dlamch('p')
      ierr=0
      if (na.lt.0) then
c     .  element wise case x and alpha are supposed to have the same size
         do i=1,nx
            call  dbeskg (abs(x(i)), alpha(i),kode,1,y(i), nz,ier)
            ierr=max(ierr,ier)
         enddo
      elseif (na.eq.1) then
         do i=1,nx
            call  dbeskg (abs(x(i)), alpha(1),kode,1,y(i), nz,ier)
            ierr=max(ierr,ier)
         enddo
      else
c     .  compute besseli(x(i),y(j)), i=1,nx,j=1,na
         j0=1
 05      n=0
 10      n=n+1
         j=j0+n
         if (j.le.na.and.abs((1+alpha(j-1))-alpha(j)).le.eps) then
            goto 10
         endif
         do i=1,nx
            call dbeskg(abs(x(i)),alpha(j0),kode,n, w, nz,ier)
            ierr=max(ierr,ier)
            call dcopy(n,w,1,y(i+(j0-1)*nx),nx)
         enddo
         j0=j
         if (j0.le.na) goto 05
      endif
      end


*
*     -------------------------------------------------------------
*      S I X J 1
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
*                                                                  *
*     | I/2  J/2  K/2 |                                            *
*     | L/2  M/2   1  |               [B.M.X.  75].                *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vilnius,  Lithuania                             March 1995   *
*
      SUBROUTINE SIXJ1(I,J,K,L,M,ITIK,SI)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      SI=ZERO
      IF(ITIK.NE.0) THEN
C
C     CHESKED TRIANGULAR CONDITIONS
C
        IF(IXJTIK(I,J,K,L,M,2).EQ.0)RETURN
      ENDIF
      IFA=(I+J+K)/2
      AS=DBLE(IFA)
      AKA=ONE
      IF(MOD(IFA,2).NE.0)AKA=-AKA
      A=DBLE(K)
      B=DBLE(J)
      C=DBLE(I)
      IF(I.LT.M) THEN
        IF(J.LT.L) THEN
C              M > I,   L > J.
          SI=AKA*DSQRT((AS+TWO)*(AS+THREE)*(AS-A+ONE)*(AS-A+TWO)/
     *      ((B+ONE)*(B+TWO)*(B+THREE)*(C+ONE)*(C+TWO)*(C+THREE)))
        ELSEIF(J.EQ.L) THEN
C              M > I,  L = J.
          SI=(-AKA)*DSQRT(TWO*(AS+TWO)*(AS-C)*(AS-B+ONE)*(AS-A+ONE)/
     *      (B*(B+ONE)*(B+TWO)*(C+ONE)*(C+TWO)*(C+THREE)))
        ELSE
C              M > I,  L < J.
          SI=AKA*DSQRT((AS-C-ONE)*(AS-C)*(AS-B+ONE)*(AS-B+TWO)/
     *      ((B-ONE)*B*(B+ONE)*(C+ONE)*(C+TWO)*(C+THREE)))
        ENDIF
      ELSEIF(I.EQ.M) THEN
        IF(J.LT.L) THEN
C              M = L,  L > J.
          SI=(-AKA)*DSQRT((AS+TWO)*(AS-C+ONE)*(AS-B)*(AS-A+ONE)
     *      *TWO/((B+ONE)*(B+TWO)*(B+THREE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(J.EQ.L) THEN
C              M = I,  L = J.
          SI=(-AKA)*((B*B+C*C-A*A)*HALF+B+C-A)/
     *      DSQRT(B*(B+ONE)*(B+TWO)*C*(C+ONE)*(C+TWO))
        ELSE
C              M = I,  L < J.
          SI=AKA*DSQRT((AS+ONE)*(AS-C)*(AS-B+ONE)*(AS-A)*TWO/
     *      ((B-ONE)*B*(B+ONE)*C*(C+ONE)*(C+TWO)))
        ENDIF
      ELSE
        IF(J.LT.L) THEN
C              M < I,   L > J.
          SI=AKA*DSQRT((AS-C+ONE)*(AS-C+TWO)*(AS-B-ONE)*(AS-B)/
     *      ((B+ONE)*(B+TWO)*(B+THREE)*(C-ONE)*C*(C+ONE)))
        ELSEIF(J.EQ.L) THEN
C              M < I,   L = J.
          SI=AKA*DSQRT((AS+ONE)*(AS-C+ONE)*(AS-B)*(AS-A)*TWO/
     *      (B*(B+ONE)*(B+TWO)*(C-ONE)*C*(C+ONE)))
        ELSE
C              M < I,   L < J.
          SI=AKA*DSQRT(AS*(AS+ONE)*(AS-A-ONE)*(AS-A)/
     *      ((B-ONE)*B*(B+ONE)*(C-ONE)*C*(C+ONE)))
        ENDIF
      ENDIF
      RETURN
      END


      SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND,
     $                   IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs and outputs.  M >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state matrix A of the original system.
C             On exit, the leading N-by-N part of this array contains
C             the state matrix Ai of the inverse system.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B of the original system.
C             On exit, the leading N-by-M part of this array contains
C             the input matrix Bi of the inverse system.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the output matrix C of the original system.
C             On exit, the leading M-by-N part of this array contains
C             the output matrix Ci of the inverse system.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,M).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading M-by-M part of this array must
C             contain the feedthrough matrix D of the original system.
C             On exit, the leading M-by-M part of this array contains
C             the feedthrough matrix Di of the inverse system.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1,M).
C
C     RCOND   (output) DOUBLE PRECISION
C             The estimated reciprocal condition number of the
C             feedthrough matrix D of the original system.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*M)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or M+1, DWORK(1) returns the optimal
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,4*M).
C             For good performance, LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = i:  the matrix D is exactly singular; the (i,i) diagonal
C                   element is zero, i <= M; RCOND was set to zero;
C             = M+1:  the matrix D is numerically singular, i.e., RCOND
C                   is less than the relative machine precision, EPS
C                   (see LAPACK Library routine DLAMCH). The
C                   calculations have been completed, but the results
C                   could be very inaccurate.
C
C     METHOD
C
C     The matrices of the inverse system are computed with the formulas:
C                   -1              -1         -1           -1
C       Ai = A - B*D  *C,  Bi = -B*D  ,  Ci = D  *C,  Di = D  .
C
C     NUMERICAL ASPECTS
C
C     The accuracy depends mainly on the condition number of the matrix
C     D to be inverted. The estimated reciprocal condition number is
C     returned in RCOND.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000.
C     D. Sima, University of Bucharest, April 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C     Based on the routine SYSINV, A. Varga, 1992.
C
C     REVISIONS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2011.
C
C     KEYWORDS
C
C     Inverse system, state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   RCOND
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                   DWORK(*)
      INTEGER            IWORK(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   DNORM
      INTEGER            BL, CHUNK, I, IERR, J, MAXWRK, MINWRK
      LOGICAL            BLAS3, BLOCK, LQUERY
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGECON, DGEMM, DGEMV, DGETRF, DGETRI,
     $                   DLACPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE
         LQUERY = LDWORK.EQ.-1
         MINWRK = MAX( 1, 4*M )
         CALL DGETRI( M, D, LDD, IWORK, DWORK, -1, IERR )
         MAXWRK = MAX( MINWRK, INT( DWORK(1) ), N*M )
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $      INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB07ND', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 ) THEN
         RCOND    = ONE
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Factorize D.
C
      CALL DGETRF( M, M, D, LDD, IWORK, INFO )
      IF ( INFO.NE.0 ) THEN
         RCOND = ZERO
         RETURN
      END IF
C
C     Compute the reciprocal condition number of the matrix D.
C     Workspace: need   4*M.
C     (Note: Comments in the code beginning "Workspace:" describe the
C      minimal amount of workspace needed at that point in the code,
C      as well as the preferred amount for good performance.
C      NB refers to the optimal block size for the immediately
C      following subroutine, as returned by ILAENV.)
C
      DNORM = DLANGE( '1-norm', M, M, D, LDD, DWORK )
      CALL DGECON( '1-norm', M, D, LDD, DNORM, RCOND, DWORK, IWORK(M+1),
     $             IERR )
      IF ( RCOND.LT.DLAMCH( 'Epsilon' ) )
     $   INFO = M + 1
C                   -1
C     Compute Di = D  .
C     Workspace: need   M;
C                prefer M*NB.
C
      CALL DGETRI( M, D, LDD, IWORK, DWORK, LDWORK, IERR )
      IF ( N.GT.0 ) THEN
         CHUNK = LDWORK / M
         BLAS3 = CHUNK.GE.N .AND. M.GT.1
         BLOCK = MIN( CHUNK, M ).GT.1
C                          -1
C        Compute  Bi = -B*D  .
C
         IF ( BLAS3 ) THEN
C
C           Enough workspace for a fast BLAS 3 algorithm.
C
            CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N )
            CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, M, -ONE,
     $                  DWORK, N, D, LDD, ZERO, B, LDB )
C
         ELSE IF( BLOCK ) THEN
C
C           Use as many rows of B as possible.
C
            DO 10 I = 1, N, CHUNK
               BL = MIN( N-I+1, CHUNK )
               CALL DLACPY( 'Full', BL, M, B(I,1), LDB, DWORK, BL )
               CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, -ONE,
     $                     DWORK, BL, D, LDD, ZERO, B(I,1), LDB )
   10       CONTINUE
C
         ELSE
C
C           Use a BLAS 2 algorithm.
C
            DO 20 I = 1, N
               CALL DCOPY( M, B(I,1), LDB, DWORK, 1 )
               CALL DGEMV( 'Transpose', M, M, -ONE, D, LDD, DWORK, 1,
     $                     ZERO, B(I,1), LDB )
   20       CONTINUE
C
         END IF
C
C        Compute  Ai = A + Bi*C.
C
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, LDB,
     $               C, LDC, ONE, A, LDA )
C                        -1
C        Compute  C <-- D  *C.
C
         IF ( BLAS3 ) THEN
C
C           Enough workspace for a fast BLAS 3 algorithm.
C
            CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M )
            CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE,
     $                  D, LDD, DWORK, M, ZERO, C, LDC )
C
         ELSE IF( BLOCK ) THEN
C
C           Use as many columns of C as possible.
C
            DO 30 J = 1, N, CHUNK
               BL = MIN( N-J+1, CHUNK )
               CALL DLACPY( 'Full', M, BL, C(1,J), LDC, DWORK, M )
               CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE,
     $                     D, LDD, DWORK, M, ZERO, C(1,J), LDC )
   30       CONTINUE
C
         ELSE
C
C           Use a BLAS 2 algorithm.
C
            DO 40 J = 1, N
               CALL DCOPY( M, C(1,J), 1, DWORK, 1 )
               CALL DGEMV( 'NoTranspose', M, M, ONE, D, LDD, DWORK, 1,
     $                     ZERO, C(1,J), 1 )
   40       CONTINUE
C
         END IF
      END IF
C
C     Return optimal workspace in DWORK(1).
C
      DWORK(1) = MAXWRK
      RETURN
C
C *** Last line of AB07ND ***
      END


      subroutine runY_00l(k,l,Xtwiddle,Gtwiddle,Shat3,N0)
      implicit none
C---  Expression for Eq. 5.56a
C---  Calculates D00l
C---  Small terms of order Xtwiddle(0,k)*Dii,Xtwiddle(0,0)*Diii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat3(np,z2max,-2:0)

      do ep=-2,0
      Dv(dzzi(l)+N0,ep)=
     . (Gtwiddle(k,1)*Shat3(1,z2(l,l),ep)
     .  +Gtwiddle(k,2)*Shat3(2,z2(l,l),ep)
     .  +Gtwiddle(k,3)*Shat3(3,z2(l,l),ep)
     .  +Xtwiddle(0,k)*Dv(dii(z2(l,l))+N0,ep)
     .  -Xtwiddle(0,0)*Dv(diii(z3(k,l,l))+N0,ep))/(4*Gtwiddle(k,l))
      enddo

      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine  characteristic(node1,node2,nodem,nelem,lakon,
     &     kon,ipkon,
     &     nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &     nodef,idirf,df,cp,r,physcon,dvi,numf,set,
     &     mi,ttime,time,iaxial,iplausi)
!
!     This subroutine is used to enables the processing of empiric
!     given under the form
!     massflow*dsqrt(T1)/Pt1=f((Pt1-Pt2)/Pt1) and T1=T2
!     characteristics the subroutine proceeds using
!     linear interpolation to estimate the values for the whole characteristic
!     note that the characteristic is implicitely containing the point (0,0)
!
!     author: Yannick Muller
!
      implicit none
!
      logical identity
!
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,kon(*),ipkon(*),
     &     ielprop(*),nodef(*),idirf(*),index,iflag,
     &     inv,id,numf,npu,i,mi(*),iaxial,iplausi
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(*),cp,r,dvi,
     &     p1,p2,physcon(*),ttime,time,xmach,kappa,
     &     xpu(100),ypu(100),Qred,p1mp2zp1,T1,scal,T2
!
      intent(in) node1,node2,nodem,nelem,lakon,kon,ipkon,
     &     nactdog,ielprop,prop,iflag,v,cp,r,physcon,dvi,set,
     &     mi,ttime,time,iaxial
!
      intent(inout) identity,xflow,idirf,nodef,numf,f,df,iplausi
!
      if (iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif ((iflag.eq.1).or.(iflag.eq.2)) then
         if(iflag.eq.1) then
            if(v(1,nodem).ne.0.d0) then
               xflow=v(1,nodem)
               return
            endif
         endif
!
         index=ielprop(nelem)
!
         npu=nint(prop(index+2))
         scal=prop(index+1)

         do i=1, 100
            xpu(i)=0
            ypu(i)=0
         enddo
!
         do i=1,npu
            xpu(i)=prop(index+2*i+1)
            ypu(i)=prop(index+2*i+2)
         enddo
!
         p1=v(2,node1)
         p2=v(2,node2)
!
         if(p1.ge.p2) then
            inv=1
            T1=v(0,node1)-physcon(1)
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            T1=v(0,node2)-physcon(1)
         endif
!
         p1mp2zp1=(p1-p2)/p1
!
         if(iflag.eq.1) then

            call ident(xpu,p1mp2zp1,npu,id)
            if(id.eq.0) then
               Qred=scal*ypu(1)
               xflow=inv*Qred*p1/dsqrt(T1)
            elseif(id.ge.npu) then
               Qred=scal*ypu(npu)
               xflow=inv*Qred*p1/dsqrt(T1)
            else
               Qred=scal*(ypu(id)+(ypu(id+1)-ypu(id))
     &             *(p1mp2zp1-xpu(id))/(xpu(id+1)-xpu(id)))
               xflow=inv*Qred*p1/dsqrt(T1)
            endif
!
         elseif (iflag.eq.2) then
            numf=4
!
            p1=v(2,node1)
            p2=v(2,node2)
            xflow=v(1,nodem)*iaxial
!
            if (p1.ge.p2) then
!
               inv=1
               xflow=v(1,nodem)*iaxial
               T1=v(0,node1)-physcon(1)
               nodef(1)=node1
               nodef(2)=node1
               nodef(3)=nodem
               nodef(4)=node2
!
            else
!
               inv=-1
               p1=v(2,node2)
               p2=v(2,node1)
               T1=v(0,node2)-physcon(1)
               xflow=-v(1,nodem)*iaxial
               nodef(1)=node2
               nodef(2)=node2
               nodef(3)=nodem
               nodef(4)=node1
            endif
!
            idirf(1)=2
            idirf(2)=0
            idirf(3)=1
            idirf(4)=2
!
            df(2)=xflow/(2.d0*p1*dsqrt(T1))
            df(3)=inv*dsqrt(T1)/p1
!
            call ident(xpu,p1mp2zp1,npu,id)
!
            if(id.eq.0) then
               f=dabs(xflow)/p1*dsqrt(T1)-scal*ypu(1)
               df(4)=0.01d0
               df(1)=-xflow*dsqrt(T1)/p1**2
!
            elseif(id.ge.npu) then
               f=dabs(xflow)/p1*dsqrt(T1)-scal*ypu(npu)
               df(4)=0.01d0
               df(1)=-xflow*dsqrt(T1)/p1**2
!
            else
               f=dabs(xflow)/p1*dsqrt(T1)-(scal*ypu(id)
     &             +scal*(ypu(id+1)-ypu(id))
     &              *(p1mp2zp1-xpu(id))/(xpu(id+1)-xpu(id)))
!
               df(4)=scal*(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id))*1/p1
!
               df(1)=-xflow*dsqrt(T1)/p1**2-(p2/p1**2)
     &              *(scal*(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id)))
            endif
         endif

      elseif(iflag.eq.3)  then
         p1=v(2,node1)
         p2=v(2,node2)
         xflow=v(1,nodem)*iaxial
         kappa=(cp/(cp-r))
         xmach=dsqrt(((p1/p2)**((kappa-1.d0)/kappa)-1.d0)*2.d0/
     &          (kappa-1.d0))
!
         if (p1.ge.p2) then
!
            inv=1
            xflow=v(1,nodem)*iaxial
            T1=v(0,node1)-physcon(1)
            T2=v(0,node2)-physcon(1)
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
!
         else
!
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            T1=v(0,node2)-physcon(1)
            T2=v(0,node1)-physcon(1)
            xflow=-v(1,nodem)*iaxial
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
         endif
!
         write(1,*) ''
         write(1,55) ' from node',node1,
     &        ' to node', node2,':   air massflow rate=',xflow
!
 55      FORMAT(1X,A,I6,A,I6,A,e11.4,A,A,e11.4,A)
!
         if(inv.eq.1) then
            write(1,56)'       Inlet node ',node1,':   Tt1=',T1,
     &           ', Ts1=',T1,', Pt1=',p1

            write(1,*)'             Element ',nelem,lakon(nelem)
            write(1,57) 'M = ',xmach
!
            write(1,56)'      Outlet node ',node2,':   Tt2=',T2,
     &           ', Ts2=',T2,', Pt2=',p2
!
         else if(inv.eq.-1) then
            write(1,56)'       Inlet node ',node2,':    Tt1=',T1,
     &           ', Ts1=',T1,', Pt1=',p1
     &
            write(1,*)'             Element ',nelem,lakon(nelem)
            write(1,57) 'M = ',xmach
!
            write(1,56)'      Outlet node ',node1,':    Tt2=',T2,
     &           ', Ts2=',T2,', Pt2=',p2
!
         endif
!
 56      FORMAT(1X,A,I6,A,e11.4,A,e11.4,A,e11.4,A)
 57      format(40x,a,e11.4)
!
      endif
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
!
      return
      end


C$Procedure      SRFREC ( Surface to rectangular coordinates )

      SUBROUTINE SRFREC ( BODY, LONG, LAT, RECTAN )
      IMPLICIT NONE

C$ Abstract
C
C     Convert planetocentric latitude and longitude of a surface
C     point on a specified body to rectangular coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     KERNEL
C     NAIF_IDS
C
C$ Keywords
C
C     CONVERSION
C     COORDINATES
C     TRANSFORMATION
C
C$ Declarations

      INTEGER               BODY
      DOUBLE PRECISION      LONG
      DOUBLE PRECISION      LAT
      DOUBLE PRECISION      RECTAN ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     BODY       I   NAIF integer code of an extended body.
C     LONG       I   Longitude of point in radians.
C     LAT        I   Latitude of point in radians.
C     RECTAN     O   Rectangular coordinates of the point.
C
C$ Detailed_Input
C
C     BODY       is the NAIF integer code of an extended body on which
C                a surface point of interest is located. The body is
C                modeled as a triaxial ellipsoid.
C
C     LONG       Longitude of the input point.  This is the angle
C                between the prime meridian and the meridian
C                containing the point.  The direction of increasing
C                longitude is from the +X axis towards the +Y axis.
C
C                Longitude is measured in radians.  On input, the
C                range of longitude is unrestricted.
C
C     LAT        Latitude of the input point.  This is the angle from
C                the XY plane of the ray from the origin through the
C                point.
C
C                Latitude is measured in radians. On input, the range
C                of latitude is unrestricted.
C
C$ Detailed_Output
C
C      RECTAN    The rectangular coordinates of the input surface
C                point.  Units are the same as those used to define the
C                radii of BODY.  Normally, these units are km.
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     1)  If radii for BODY are not found in the kernel pool, the error
C         will be diagnosed by routines called by this routine.
C
C     2)  If radii for BODY are invalid, the error will be diagnosed by
C         routines called by this routine.  The radii should be
C         positive.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns the rectangular coordinates of a surface
C     point on an extended body with known radii, where the location
C     of the surface point is specified in planetocentric latitudinal
C     coordinates.
C
C     Latitudinal coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     above the equator of a sphere centered at the central reference
C     point.  In this case, the distance from the central reference
C     point is not required as an input because the fact that the
C     point is on the body's surface allows one to deduce this quantity.
C
C     Below are two tables that demonstrate by example the relationship
C     between rectangular and latitudinal coordinates.
C
C     Listed in the first table (under R, LONG and LAT ) are
C     latitudinal coordinate triples that approximately represent
C     points whose rectangular coordinates are taken from the set
C     {-1, 0, 1}.  (Angular quantities are given in degrees.)
C
C
C          R         LONG       LAT           X(1)       X(2)     X(3)
C         --------------------------         --------------------------
C         0.0000    0.0000    0.0000         0.0000     0.0000   0.0000
C         1.0000    0.0000    0.0000         1.0000     0.0000   0.0000
C         1.0000   90.0000    0.0000         0.0000     1.0000   0.0000
C         1.0000    0.0000   90.0000         0.0000     0.0000   1.0000
C         1.0000  180.0000    0.0000        -1.0000     0.0000   0.0000
C         1.0000  -90.0000    0.0000         0.0000    -1.0000   0.0000
C         1.0000    0.0000  -90.0000         0.0000     0.0000  -1.0000
C         1.4142   45.0000    0.0000         1.0000     1.0000   0.0000
C         1.4142    0.0000   45.0000         1.0000     0.0000   1.0000
C         1.4142   90.0000   45.0000         0.0000     1.0000   1.0000
C         1.7320   45.0000   35.2643         1.0000     1.0000   1.0000
C
C
C     This routine is related to the SPICELIB routine LATREC, which
C     accepts a radius, longitude, and latitude as inputs and produces
C     equivalent rectangular coordinates as outputs.
C
C$ Examples
C
C     1)  Find the rectangular coordinates of the point
C
C            100 degrees planetocentric longitude
C            -35 degrees planetocentric latitude
C
C         on the Earth; then convert these coordinates back to
C         latitudinal coordinates.  We should be able to recover
C         our original longitude and latitude values.
C
C
C                  PROGRAM TEST_SRFREC
C                  IMPLICIT NONE
C
C            C
C            C     SPICELIB functions
C            C
C                  DOUBLE PRECISION      DPR
C                  DOUBLE PRECISION      RPD
C
C            C
C            C     Local variables
C            C
C                  DOUBLE PRECISION      LAT
C                  DOUBLE PRECISION      LONG
C                  DOUBLE PRECISION      X     ( 3 )
C                  DOUBLE PRECISION      RADIUS
C
C            C
C            C     Load the kernel pool with a PCK file that contains
C            C     values for the radii of the Earth.
C            C
C                  CALL FURNSH ( 'pck00008.tpc' )
C
C            C
C            C     Find X, the rectangular coordinates of the
C            C     surface point defined by LAT and LONG.  The
C            C     NAIF integer code for the Earth is 399.
C            C     (See the NAIF_IDS required reading file for
C            C     the complete set of codes.)
C            C
C                  LONG  =  100.D0
C                  LAT   =  -35.D0
C
C                  WRITE (*,*) 'Original latitudinal coordinates'
C                  WRITE (*,*) ' '
C                  WRITE (*,*) 'Longitude  ', LONG
C                  WRITE (*,*) 'Latitude   ', LAT
C
C            C
C            C     Convert angles to radians on input to SRFREC.
C            C
C                  CALL SRFREC ( 399, LONG*RPD(), LAT*RPD(), X )
C
C                  WRITE (*,*) ' '
C                  WRITE (*,*) ' '
C                  WRITE (*,*) 'Rectangular coordinates '
C                  WRITE (*,*) ' '
C                  WRITE (*,*) X
C
C            C
C            C     Now try to recover the original latitudinal
C            C     coordinates from the rectangular coordinates
C            C     found by SRFREC.
C            C
C                  CALL RECLAT ( X, RADIUS, LONG, LAT )
C
C            C
C            C     Convert angles to degrees for display.
C            C
C                  WRITE (*,*) ' '
C                  WRITE (*,*) ' '
C                  WRITE (*,*) 'Latitudinal coordinates recovered '   //
C                 .            'from rectangular coordinates'
C                  WRITE (*,*) ' '
C                  WRITE (*,*) 'Longitude (deg) ', LONG * DPR()
C                  WRITE (*,*) 'Latitude  (deg) ', LAT  * DPR()
C                  WRITE (*,*) 'Radius    (km)  ', RADIUS
C
C                  END
C
C
C$ Restrictions
C
C     1)  A NAIF text kernel containing the body radius definitions
C         required by this routine must be loaded into the kernel
C         pool prior to any calls to this routine.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 19-APR-2016 (NJB)
C
C        Re-implemented ellipsoid surface point computation
C        using EDPNT.
C
C-    SPICELIB Version 1.1.0, 03-NOV-2005 (NJB)
C
C        Call to BODVAR was replaced with call to BODVCD.
C
C        Various header updates were made to clarify description
C        of routine's functionality.  Example program was updated
C        as well.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 03-SEP-1991 (NJB) (WLT)
C
C-&

C$ Index_Entries
C
C     convert body-fixed latitudinal coordinates to rectangular
C     convert surface latitudinal coordinates to rectangular
C     surface point latitudinal coordinates to rectangular
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      RADII  ( 3 )
      DOUBLE PRECISION      UVEC   ( 3 )

      INTEGER               N

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'SRFREC' )

C
C     Look up the body's radii.
C
      CALL BODVCD ( BODY, 'RADII', 3, N, RADII )

C
C     Find the unit vector pointing from the body center to the
C     input surface point.
C
      CALL LATREC ( 1.D0, LONG, LAT, UVEC )

C
C     Find out where the ray defined by this vector intersects the
C     surface.  This intercept is the point we're looking for.
C
      CALL EDPNT ( UVEC, RADII(1), RADII(2), RADII(3), RECTAN )

      CALL CHKOUT ( 'SRFREC' )
      RETURN
      END


C***********************************************************************
C***********************************************************************
C
C   Version:        0.3
C   Last modified:  February 13, 1995
C   Authors:        Esmond G. Ng and Barry W. Peyton
C
C   Mathematical Sciences Section, Oak Ridge National Laboratory
C
C***********************************************************************
C***********************************************************************
C
C       ****************************************************************
C       ****************************************************************
C
C       MAIN.F :  DRIVER THAT SOLVES A SPARSE, SYMMETRIC, NONSINGULAR
C       LINEAR SYSTEM VIA SPARSE LDL' FACTORIZATION.
C       THE MOST EFFICIENT KNOWN ALGORITHMS AND ROUTINES ARE INCLUDED:
C       THE MULTIPLE MINIMUM DEGREE ROUTINES COME FROM THE MOST RECENT
C       RELEASE OF SPARSPAK; MOST OF THE SYMBOLIC FACTORIZATION ROUTINES
C       AND ALL OF THE NUMERICAL FACTORIZATION ROUTINES WERE DEVELOPED
C       AT OAK RIDGE NATIONAL LABORATORY.
C
C       ****************************************************************
C       ****************************************************************
C
C       THIS DRIVER IS NOT A PRACTICAL INSTRUMENT FOR SOLVING A USER'S
C       SPARSE SYMMETRIC POSITIVE DEFINITE LINEAR SYSTEM.  IN
C       PARTICULAR, THE DRIVER DOES NOT ALLOCATE AND DEALLOCATE MEMORY
C       IN AN EFFICIENT MANNER.  WE EMPHASIZE, HOWEVER, THAT THE
C       ROUTINES THEMSELVES ARE DESIGNED TO ENABLE EFFICIENT MEMORY
C       MANAGEMENT, BY EITHER DYNAMIC ALLOCATION OR BY ``MANUAL'
C       ALLOCATION (AND DE-ALLOCATION) FROM A SINGLE WORKING ARRAY.
C
C       THIS DRIVER AND ITS COMMENTS
C
C       (1) INDICATE FOR EACH ROUTINE WHICH VARIABLES AND ARRAYS
C           CONSTITUTE ITS INPUT AND WHICH CONSTITUTE ITS OUTPUT,
C
C       (2) POINT OUT WHEN THE CONTENTS OF AN ARRAY ARE NO LONGER
C           NEEDED,
C
C       (3) DEMONSTRATE APPROPRIATE ERROR TRAPPING, AND
C
C       (4) GIVE ENOUGH INFORMATION TO ENABLE EFFICIENT MEMORY
C           MANAGEMENT:  PRIOR TO EACH SUBROUTINE CALL, THE AMOUNT OF
C           MEMORY REQUIRED FOR EACH ARRAY ARGUMENT IS KNOWN.
C
C       NOTE ALSO THAT THE ROUTINES USED TO CREATE THE GRAPH OF THE
C       COEFFCIENT MATRIX, TO INPUT THE NUMERICAL VALUES, AND TO
C       GENERATE THE RIGHT-HAND SIDE ARE NOT GENERAL-PURPOSE TOOLS FOR
C       THESE TASKS.  THEY ARE EXTREMELY SIMPLE ROUTINES THAT THE USER
C       WILL NEED TO REPLACE WITH ROUTINES OF HIS/HER OWN.  THE DRIVER
C       READS IN THE STRUCTURE OF THE MATRIX FROM AN INPUT FILE, WHICH
C       CONTAINS THE ENTIRE ADJACENCY STRUCTURE STORED IN AN EXTREMELY
C       SIMPLE FORMAT.
C
C       ****************************************************************
C       ****************************************************************
C
C       THE AMOUNT OF STORAGE REQUIRED TO SOLVE A LINEAR SYSTEM
C       DEPENDS ON THE FOLLOWING PARAMETERS, EACH OF WHICH IS EITHER
C       READ IN FROM A FILE OR COMPUTED DURING THE SOLUTION PROCESS.
C
C       (1) N      -- THE NUMBER OF ROWS (COLUMNS) IN A.
C
C       (2) NSUPER -- THE NUMBER OF SUPERODES (NSUPER <= N).
C
C       (3) NNZA   -- THE NUMBER OF NONZERO ENTRIES IN A, EXCLUDING
C                     ENTRIES ON THE MAIN DIAGONAL.
C
C       (4) NSUB   -- THE NUMBER OF ROW SUBSCRIPTS NEEDED TO
C                     REPRESENT THE ZERO-NONZERO STRUCTURE OF L.
C
C       (5) NNZL   -- THE NUMBER OF NONZERO ENTRIES IN L, INCLUDING
C                     ENTRIES ON THE MAIN DIAGONAL.
C
C       (6) TMPSIZ -- THE SIZE OF THE FLOATING POINT WORKING STORAGE
C                     REQUIRED BY THE FACTORIZATION ROUTINE (BLKFCT).
C
C       WITH THE EXCEPTION OF THE IWORK(*) ARRAY, THE LENGTH OF EACH
C       ARRAY SHOULD BE N+1, NSUPER+1, OR ONE OF THE PRECEDING SIX
C       PARAMETERS. IN THIS DRIVER THE LENGTH OF EACH ARRAYS IS
C       DECLARED AT RUN TIME, WHICH IS, OF COURSE, BEFORE THE
C       APPROPRIATE LENGTH IS KNOWN.  THE FOLLOWING PARAMETERS,
C       INITIALIZED IN THE CODE BELOW, ARE UPPER BOUNDS ON THE SIX
C       VARIABLES LISTED ABOVE AND ARE USED TO DECLARE THE LENGTH OF
C       ALL ARRAYS USED BY THE PROGRAM.
C
C       (1) NMAX    -   UPPER BOUND ON N AND NSUPER.
C       (2) ANZMAX  -   UPPER BOUND ON NNZA.
C       (3) SUBMAX  -   SIMULTANEOUSLY AN UPPER BOUND ON NSUB AND NNZA.
C       (4) LNZMAX  -   UPPER BOUND ON NNZL.
C       (5) TMPMAX  -   UPPER BOUND ON TMPSIZ.
C       (6) IWMAX   -   UPPER BOUND ON INTEGER WORK STORAGE.
C
C       THE AMOUNT OF INTEGER WORK SPACE (IWORK) REQUIRED BY EACH
C       ROUTINE VARIES FROM ONE ROUTINE TO ANOTHER.  THE MAXIMUM
C       REQUIRED IS 7*N+3.
C
C       ****************************************************************
C
C       --------------------------------------------------------------
C       PARAMETERS.
C
C       NOTE:
C           IF YOUR FORTRAN COMPILER COMPLAINS ABOUT THE DEFINITION OF
C           SUBMAX, THEN CHANGE IT TO
C                           SUBMAX      = 61648,
C       --------------------------------------------------------------
        INTEGER             IWMAX , LNZMAX, NMAX  , ANZMAX, SUBMAX,
     &                      TMPMAX
        PARAMETER       (   NMAX        = 18240,
     &                      ANZMAX      = 616480,
     &                      SUBMAX      = MAX(ANZMAX,616480),
     &                      LNZMAX      = 2737840,
     &                      TMPMAX      = 351560,
     &                      IWMAX       = 7*NMAX + 3    )
C
C       ****************************************************************
C
C       THE FOLLOWING DECLARATIONS GIVE A ROUGH OVERVIEW OF THE
C       LOGICAL FLOW THROUGH THE DRIVER AND THE KEY OUTPUT PRODUCED AT
C       EACH STEP.
C
C       ****************************************************************
C
C       ---------------------------------------------
C       ADJACENCY STRUCTURE READ IN FROM MATRIX FILE.
C       ---------------------------------------------
        INTEGER             N     , NNZA
        INTEGER             XADJ(NMAX+1),
     &                      ADJ(ANZMAX)
C
C       ---------------------------------------------
C       ADJACENCY STRUCTURE WITH DIAGONAL ENTRIES AND
C       NUMERICAL VALUES ADDED (CREATE).
C       ---------------------------------------------
        INTEGER             XADJD(NMAX+1),
     &                      ADJD(ANZMAX+NMAX)
        DOUBLE PRECISION    ANZ(ANZMAX+NMAX)
C
C       -------------------------------------------------
C       SOLUTION AND ASSOCIATED RIGHT-HAND SIDE (GETRHS).
C       -------------------------------------------------
        DOUBLE PRECISION    RHS(NMAX),
     &                      SOL(NMAX)
C
C       ---------------------------------------
C       PERMUTATION VECTORS (ORDNAT OR ORDMMD).
C       ---------------------------------------
        INTEGER             PERM(NMAX),
     &                      INVP(NMAX)
        LOGICAL             SFIFLG
C
C       ----------------------------------------------
C       SUPERNODE PARTITION AND ROW AND COLUMN NONZERO
C       COUNTS FOR L (SFINIT OR ORDERING ROUTINE).
C       ----------------------------------------------
        INTEGER             NNZL  , NSUB  , NSUPER
        INTEGER             COLCNT(NMAX),
     &                      SNODE(NMAX),
     &                      XSUPER(NMAX+1)
C
C       ---------------------------------------------
C       COMPRESSED (SUPERNODAL) REPRESENTATION OF THE
C       ZERO-NONZERO STRUCTURE OF L (SYMFCT).
C       ---------------------------------------------
        INTEGER             XLINDX(NMAX+1),
     &                      LINDX(SUBMAX),
     &                      XLNZ(NMAX+1)
C
C       ---------------------------------------------------------
C       SIZE OF FLOATING POINT WORKING STORAGE NEEDED BY BLKFCT;
C       SPLITTING OF SUPERNODES TO BETTER EXPLOIT CACHE (BFINIT).
C       ---------------------------------------------------------
        INTEGER             TMPSIZ
        INTEGER             SPLIT(NMAX)
C
C       -----------------------------------------------------------------
C       LNZ FIRST HAS SCATTERED INTO IT THE NONZERO ENTRIES OF A (INPNV);
C       THEN IT CONTAINS THE ENTRIES OF THE LDL' FACTOR (BLKFCT).
C       -----------------------------------------------------------------
        DOUBLE PRECISION    LNZ(LNZMAX)
        DOUBLE PRECISION    DIAG(NMAX)
        DOUBLE PRECISION    TMPVEC(TMPMAX)
C
C       ----------------------------------------
C       GENERAL PURPOSE INTEGER WORKING STORAGE.
C       ----------------------------------------
        INTEGER             IWORK(IWMAX)
C
C       ---------------------------------------------------
C       EXTRA WORK VECTOR FOR RIGHT-HAND SIDE AND SOLUTION.
C       ---------------------------------------------------
        DOUBLE PRECISION    NEWRHS(NMAX)
C
C       ------------------------------
C       MISCELLANEOUS LOCAL VARIABLES.
C       ------------------------------
        CHARACTER*60        STRING
        CHARACTER*60        MATFIL, OUTFIL
        CHARACTER*40        ORDRNG(2)
        INTEGER             CACHSZ, I     , ICASE , IFLAG , LEVEL ,
     &                      MATUNT, OUTUNT
        REAL                GTIMER, TIMBEG, TIMEND, TIME
        DOUBLE PRECISION    E     , ERROR
C
C       -----------------------------------
C       EXTERNAL ROUTINES PASSED TO BLKFCT.
C       -----------------------------------
        EXTERNAL            SMXPY1, SMXPY2, SMXPY4, SMXPY8
        EXTERNAL            MMPY1 , MMPY2 , MMPY4 , MMPY8
C
C       ---------------------------------------------------------
C       THE FOLLOWING STATEMENT IS NEEDED FOR THOSE MACHINES THAT
C       ALLOCATE STORAGE FROM A STACK AT RUN TIME.
C       ---------------------------------------------------------
        COMMON /BIGMEM/     ADJ   , ADJD  , COLCNT, INVP  , IWORK ,
     &                      LINDX , PERM  , SNODE , SPLIT , XADJ  ,
     &                      XADJD , XLINDX, XLNZ  , XSUPER, ANZ   ,
     &                      LNZ   , NEWRHS, RHS   , SOL   , TMPVEC
C
        DATA  ORDRNG(1)     / 'NATURAL' /,
     &        ORDRNG(2)     / 'MULTIPLE MINIMUM DEGREE' /
C
C       ****************************************************************
C       ****************************************************************
C
C       ---------------------
C       SET I/O UNIT NUMBERS.
C       ---------------------
        OUTUNT = 6
        MATUNT = 10
C
C       *****************************************
C       READ IN PROBLEM DATA FROM STANDARD INPUT.
C       *****************************************
C
C       -------------------------------------------
C       READ NAME OF OUTPUT FILE AND OPEN THE FILE.
C       -------------------------------------------
        READ *, OUTFIL
        OPEN  ( UNIT=OUTUNT, FILE=OUTFIL )
        WRITE (OUTUNT,*)  'OUTPUT IS IN ', OUTFIL
C
C       -------------------------------------------
C       READ NAME OF MATRIX FILE AND OPEN THE FILE.
C       -------------------------------------------
        READ *, MATFIL
        WRITE (OUTUNT,*)   ' '
        WRITE (OUTUNT,*)   '   MATRIX FILE: ', MATFIL
        OPEN ( UNIT=MATUNT, FILE=MATFIL )
C
C       -----------------------------------------------
C       READ CHOICE OF ORDERING AND CHECK ITS VALIDITY.
C       -----------------------------------------------
        READ *, ICASE
        IF  ( ICASE .LE. 0  .OR.  ICASE .GE. 3 )  THEN
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,11) ICASE
   11       FORMAT ( '*** ORDERING OPTION ICASE = ', I5,' ***' /,
     &               '*** SHOULD HAVE 1 <= ICASE <= 2 ***' )
            GO TO 1700
        ENDIF
        WRITE (OUTUNT,*)   ' '
        WRITE (OUTUNT,22) ICASE, ORDRNG(ICASE)
   22   FORMAT ( '   ORDERING OPTION: ', I2, ' - ', A40 )
C
C       ---------------------------------------------------------
C       READ MACHINE CACHE SIZE (IN KBYTES).
C
C       THE INPUT PARAMETER CACHSZ SHOULD BE SET TO THE SIZE OF
C       THE CACHE (IN KILOBYTES) ON THE TARGET MACHINE.  FOR MOST
C       MACHINES (SUCH AS SUN SPARCSTATIONS), IT IS PROBABLY 32
C       OR 64.  FOR CRAYS, CACHSZ SHOULD BE SET TO 0.
C       ---------------------------------------------------------
        READ *, CACHSZ
        IF  ( CACHSZ .LT. 0 )  THEN
            CACHSZ = 0
        ENDIF
        WRITE (OUTUNT,*)   ' '
        WRITE (OUTUNT,*)   '   CACHE SIZE (IN KBYTES): ', CACHSZ
C
C       ----------------------------------------------------
C       READ LEVEL OF LOOP UNROLLING AND CHECK ITS VALIDITY.
C       ----------------------------------------------------
        READ *, LEVEL
        IF  ( LEVEL .NE. 1  .AND.  LEVEL .NE. 2  .AND.
     &        LEVEL .NE. 4  .AND.  LEVEL .NE. 8        )  THEN
            WRITE (OUTUNT,*)   ' '
            WRITE (OUTUNT,23)  LEVEL
   23       FORMAT ('*** LOOP UNROLLING LEVEL = ', I5,' ***'/,
     &              '*** SHOULD HAVE LEVEL = 1, 2, 4, OR 8 ***' )
            GO TO 1700
        ENDIF
        WRITE (OUTUNT,*)  ' '
        WRITE (OUTUNT,24) LEVEL
   24   FORMAT ( '   LOOP UNROLLING LEVEL: ', I3 )
C
C       *****************
C       READ MATRIX FILE.
C       *****************
C
C       -----------------------
C       GET MATRIX DESCRIPTION.
C       -----------------------
        TIMBEG = GTIMER()
        READ (MATUNT,33) STRING
   33   FORMAT ( A60 )
C
C       -------------------------------------------
C       GET MATRIX SIZE ... N AND NNZA ARE READ IN.
C       -------------------------------------------
        READ (MATUNT,44)  N, NNZA
   44   FORMAT ( I6, I8 )
C
C       --------------------------------
C       STOP IF THE MATRIX IS TOO LARGE.
C       --------------------------------
        IF  ( N .GT. NMAX  .OR.  NNZA .GT. ANZMAX )  THEN
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,55) STRING
   55       FORMAT ( A60 )
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,66)
     &          'NUMBER OF EQUATIONS                   = ', N
   66       FORMAT ( A40, I10 )
            WRITE (OUTUNT,66)
     &          'NUMBER OF NONZEROS (INCLUDING DIAG.)  = ', N+NNZA
            WRITE (OUTUNT,66)
     &          'NUMBER OF NONZEROS (EXCLUDING DIAG.)  = ', NNZA
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,*) '*** MATRIX IS TOO LARGE ***'
            IF  ( N .GT. NMAX )  THEN
                WRITE (OUTUNT,*) ' '
                WRITE (OUTUNT,*) '*** NUMBER OF EQUATIONS = ', N
                WRITE (OUTUNT,*) '*** IS LARGER THAN NMAX = ', NMAX
            ENDIF
            IF  ( NNZA .GT. ANZMAX )  THEN
                WRITE (OUTUNT,*) ' '
                WRITE (OUTUNT,*)
     &              '*** NUMBER OF OFF-DIAGONAL NONZEROS (IN A) = ',
     &              NNZA
                WRITE (OUTUNT,*) '*** IS LARGER THAN ANZMAX = ',
     &                           ANZMAX
            ENDIF
            GO TO 1700
        ENDIF
C
C       --------------------------------------------------------
C       GET MATRIX STRUCTURE ... XADJ(*) AND ADJ(*) ARE READ IN.
C       --------------------------------------------------------
        READ (MATUNT,*) (XADJ(I),I=1,N+1)
        READ (MATUNT,*) (ADJ(I),I=1,NNZA)
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,55) STRING
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,66)
     &      'NUMBER OF EQUATIONS                   = ', N
        WRITE (OUTUNT,66)
     &      'NUMBER OF NONZEROS (INCLUDING DIAG.)  = ', N+NNZA
        WRITE (OUTUNT,66)
     &      'NUMBER OF NONZEROS (EXCLUDING DIAG.)  = ', NNZA
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,77)
     &      'TIME FOR READING THE MATRIX           = ', TIME
   77   FORMAT ( A40, F10.3 )
C
C       *****************************************************
C       COMPUTE NUMERICAL ENTRIES OF THE MATRIX;
C       COMPUTE TRUE SOLUTION AND ASSOCIATED RIGHT-HAND SIDE.
C       *****************************************************
C
C       --------------------------------------------------------
C       THE PURPOSE OF CREATE IS TO PREPARE A DATA STRUCTURE
C       FOR COMPUTING THE RIGHT-HAND SIDE FROM A GIVEN SOLUTION,
C       AND FROM WHICH IT IS VERY SIMPLE TO LOAD THE ENTRIES OF
C       A INTO L.
C
C       CREATE : ADD DIAGONAL ENTRIES TO THE STUCTURE
C                AND ADD ALL NONZERO ENTRIES, TOO.
C
C       INPUT  : N, XADJ, ADJ
C       OUTPUT : XADJD, ADJD, ANZ
C       --------------------------------------------------------
        TIMBEG = GTIMER()
        CALL  CREATE (  N     , XADJ  , ADJ   , XADJD , ADJD  ,
     &                  ANZ                                     )
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,77)
     &      'TIME FOR CREATING FULL REPRESENTATION = ', TIME
C
C       --------------------------------------------
C       GETRHS : CONSTRUCT RIGHT HAND SIDE VECTOR
C                ASSOCIATED WITH SOLUTION IN SOL(*).
C
C       INPUT  : N, XADJD, ADJD, ANZ, SOL
C       OUTPUT : RHS
C       --------------------------------------------
        TIMBEG = GTIMER()
        DO  100  I = 1, N
            SOL(I) = I
  100   CONTINUE
        CALL  GETRHS (  N     , XADJD , ADJD  , ANZ   , SOL   ,
     &                  RHS                                     )
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,77)
     &      'TIME FOR CONSTRUCTING RHS             = ', TIME
C
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,*)
     &      '------------------------------------------------'
C
C       *******************
C       REORDER THE MATRIX.
C       *******************
C
        IF  ( ICASE .EQ. 1 )  THEN
C
C           --------------------------------------------------------
C           ORDNAT : NATURAL ORDERING;
C                    I.E., COMPUTE AND USE THE IDENTITY PERMUTATION.
C
C           INPUT  : N
C           OUTPUT : INVP, PERM, SFIFLG
C           --------------------------------------------------------
            TIMBEG = GTIMER()
            CALL  ORDNAT  (  N     , PERM  , INVP  , SFIFLG )
            TIMEND = GTIMER()
            TIME = TIMEND - TIMBEG
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,77)
     &          '   TIME FOR ORDERING                  = ', TIME
C
        ELSEIF  ( ICASE .EQ. 2 )  THEN
C
C           -------------------------------------------------------
C           COPY MATRIX STRUCTURE FROM (XADJ,ADJ) TO (XLINDX,LINDX)
C           (BECAUSE MATRIX STRUCTURE IS DESTROYED BY THE MINIMUM
C           DEGREE ORDERING ROUTINE).
C           -------------------------------------------------------
            TIMBEG = GTIMER()
            DO  200  I = 1, N+1
                XLINDX(I) = XADJ(I)
  200       CONTINUE
            DO  300  I = 1, NNZA
                LINDX(I) = ADJ(I)
  300       CONTINUE
            TIMEND = GTIMER()
            TIME = TIMEND - TIMBEG
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,77)
     &          '   TIME FOR COPYING ADJACENCY STRUCT. = ', TIME
C
C           -------------------------------------------------------
C           ORDMMD : MULTIPLE MINIMUM DEGREE ORDERING.
C
C           INPUT  : N, XLINDX, LINDX, IWMAX
C           OUTPUT : PERM, INVP, NSUB, IFLAG, NNZL, COLCNT, NSUPER,
C                    XSUPER, SNODE, SFIFLG
C           WORK   : IWORK(4*N)
C           -------------------------------------------------------
            TIMBEG = GTIMER()
            CALL  ORDMMD (  OUTUNT, N     , XLINDX, LINDX , INVP  ,
     &                      PERM  , IWMAX , IWORK , NNZL  , NSUB  ,
     &                      COLCNT, NSUPER, XSUPER, SNODE , SFIFLG,
     &                      IFLAG                                   )
            TIMEND = GTIMER()
            TIME = TIMEND - TIMBEG
            IF  ( IFLAG .NE. 0 )  THEN
                WRITE (OUTUNT,*) '***** ERROR CODE ',IFLAG,
     &                           ' RETURNED FROM ORDMMD *****'
                GO TO 1700
            ENDIF
            WRITE (OUTUNT,77)
     &          '   TIME FOR ORDERING                  = ', TIME
C
        ENDIF
C
        IF  ( SFIFLG )  THEN
C
C           ---------------------------------------------------------------
C           SFINIT: SYMBOLIC FACTORIZATION INITIALIZATION.
C                   COMPUTE SUPERNODE PARTITION AND STORAGE REQUIREMENTS
C                   FOR SYMBOLIC FACTORIZATION.  NEW ORDERING IS A
C                   POSTORDERING OF THE NODAL ELIMINATION TREE.
C
C           INPUT  : N, NNZA, XADJ, ADJ, PERM, INVP, IWMAX
C           OUTPUT : PERM, INVP, COLCNT, NNZL, NSUB, NSUPER, SNODE, XSUPER,
C                    IFLAG
C           WORK   : IWORK(7*N+3) [MAXIMUM REQUIRED BY ANY ROUTINE.]
C           ---------------------------------------------------------------
            TIMBEG = GTIMER()
            CALL  SFINIT  ( OUTUNT, N     , NNZA  , XADJ  , ADJ   ,
     &                      PERM  , INVP  , COLCNT, NNZL  , NSUB  ,
     &                      NSUPER, SNODE , XSUPER, IWMAX , IWORK ,
     &                      IFLAG                                   )
            TIMEND = GTIMER()
            TIME = TIMEND - TIMBEG
            IF  ( IFLAG .NE. 0 )  THEN
                WRITE (OUTUNT,*) '***** ERROR CODE ',IFLAG,
     &                           ' RETURNED FROM SFINIT *****'
                GO TO 1700
            ENDIF
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,77)
     &          '   TIME FOR SYMBOLIC FACT. SETUP      = ', TIME
C
        ENDIF
C
C       ---------------------------
C       TESTS FOR ADEQUATE STORAGE.
C       ---------------------------
        IF  ( NNZL .GT. LNZMAX )  THEN
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,*) '*** NUMBER OF NONZEROS IN L = ',
     &                       NNZL
            WRITE (OUTUNT,*) '*** IS LARGER THAN LNZMAX = ',
     &                       LNZMAX
            GO TO 1700
        ENDIF
        IF  ( NSUB .GT. SUBMAX )  THEN
            WRITE (OUTUNT,*) '*** NUMBER OF FACTOR SUBSCRIPTS = ',
     &                       NSUB
            WRITE (OUTUNT,*) '*** IS LARGER THAN SUBMAX = ',
     &                       SUBMAX
            GO TO 1700
        ENDIF
C
C       ---------------------------------------------------------
C       SYMFCT : PERFORM SUPERNODAL SYMBOLIC FACTORIZATION.
C
C       INPUT  : N, NNZA, XADJ, ADJ, PERM, INVP, COLCNT, NSUPER,
C                XSUPER, SNODE , NSUB, IWMAX
C       OUTPUT : XLINDX, LINDX, XLNZ, IFLAG
C       WORK   : IWORK(NSUPER+2*N)
C       NO LONGER NEEDED: ADJ, COLCNT, XADJ
C       ---------------------------------------------------------
        TIMBEG = GTIMER()
        CALL  SYMFCT ( OUTUNT, N     , NNZA  , XADJ  , ADJ   ,
     &                 PERM  , INVP  , COLCNT, NSUPER, XSUPER,
     &                 SNODE , NSUB  , XLINDX, LINDX , XLNZ  ,
     &                 IWMAX , IWORK , IFLAG                   )
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        IF  ( IFLAG .NE. 0 )  THEN
            WRITE (OUTUNT,*) '***** ERROR CODE ',IFLAG,
     &                       ' RETURNED FROM SYMFCT *****'
            GO TO 1700
        ENDIF
        IF  ( .NOT. SFIFLG )  THEN
            WRITE (OUTUNT,*) ' '
        ENDIF
        WRITE (OUTUNT,77)
     &      '   TIME FOR SYMBOLIC FACTORIZATION    = ', TIME
C
C       ----------------------------------------------------
C       INPNV : INPUT NUMERICAL VALUES INTO DATA STRUCTURES.
C
C       INPUT  : XADJD, ADJD, ANZ, PERM, INVP, NSUPER,
C                XSUPER, XLINDX, LINDX, XLNZ, IWMAX
C       OUTPUT : LNZ, IFLAG
C       WORK   : IWORK(N)
C       ----------------------------------------------------
        TIMBEG = GTIMER()
        CALL  INPNV  (  OUTUNT, N     , XADJD , ADJD  , ANZ   ,
     &                  PERM  , INVP  , NSUPER, XSUPER, XLINDX,
     &                  LINDX , XLNZ  , LNZ   , IWMAX , IWORK ,
     &                  IFLAG                                   )
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        IF  ( IFLAG .NE. 0 )  THEN
            WRITE (OUTUNT,*) '***** ERROR CODE ',IFLAG,
     &                       ' RETURNED FROM INPNV *****'
            GO TO 1700
        ENDIF
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,77)
     &      '   TIME FOR NUMERICAL INPUT           = ', TIME
C
C       --------------------------------------------------------
C       BFINIT : INITIALIZATION FOR BLOCK FACTORIZATION
C
C       INPUT  : N, NSUPER, XSUPER, SNODE, XLINDX, LINDX, CACHSZ
C       OUTPUT : TMPSIZ, SPLIT
C       --------------------------------------------------------
        TIMBEG = GTIMER()
        CALL  BFINIT (  N     , NSUPER, XSUPER, SNODE , XLINDX,
     &                  LINDX , CACHSZ, TMPSIZ, SPLIT           )
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,77)
     &      '   TIME FOR FACTORIZATION INIT.       = ', TIME
C
C       -----------------------------------------------------------
C       INSUFFICIENT FLOATING POINT WORK STORAGE FOR FACTORIZATION?
C       -----------------------------------------------------------
        IF  ( TMPSIZ .GT. TMPMAX )  THEN
            WRITE (OUTUNT,*) ' '
            WRITE (OUTUNT,*) '*** WORKING SPACE REQUIREMENT = ',
     &                       TMPSIZ
            WRITE (OUTUNT,*) '*** IS LARGER THAN TMPMAX = ',
     &                       TMPMAX
            GO TO 1700
        ENDIF
C
C       -----------------------------------------------------------
C       BLKFCT : NUMERICAL FACTORIZATION.
C
C       INPUT  : NSUPER, XSUPER, SNODE, SPLIT, XLINDX, LINDX, XLNZ,
C                LNZ, IWMAX, TMPSIZ, MMPY[LVL], SMXPY[LVL]
C       OUTPUT : LNZ, DIAG, IFLAG
C       WORK   : IWORK(2*N+2*NSUPER), TMPVEC(TMPSIZ)
C       -----------------------------------------------------------
        TIMBEG = GTIMER()
        IF  ( LEVEL .EQ. 1 )  THEN
            CALL  BLKFCT (  OUTUNT, N     , NSUPER, XSUPER, SNODE ,
     &                      SPLIT , XLINDX, LINDX , XLNZ  , LNZ   ,
     &                      DIAG  , IWMAX , IWORK , TMPSIZ, TMPVEC,
     &                      IFLAG , MMPY1 , SMXPY1                  )
        ELSEIF  ( LEVEL .EQ. 2 )  THEN
            CALL  BLKFCT (  OUTUNT, N     , NSUPER, XSUPER, SNODE ,
     &                      SPLIT , XLINDX, LINDX , XLNZ  , LNZ   ,
     &                      DIAG  , IWMAX , IWORK , TMPSIZ, TMPVEC,
     &                      IFLAG , MMPY2 , SMXPY2                  )
        ELSEIF  ( LEVEL .EQ. 4 )  THEN
            CALL  BLKFCT (  OUTUNT, N     , NSUPER, XSUPER, SNODE ,
     &                      SPLIT , XLINDX, LINDX , XLNZ  , LNZ   ,
     &                      DIAG  , IWMAX , IWORK , TMPSIZ, TMPVEC,
     &                      IFLAG , MMPY4 , SMXPY4                  )
        ELSEIF  ( LEVEL .EQ. 8 )  THEN
            CALL  BLKFCT (  OUTUNT, N     , NSUPER, XSUPER, SNODE ,
     &                      SPLIT , XLINDX, LINDX , XLNZ  , LNZ   ,
     &                      DIAG  , IWMAX , IWORK , TMPSIZ, TMPVEC,
     &                      IFLAG , MMPY8 , SMXPY8                  )
        ENDIF
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        IF  ( IFLAG .NE. 0 )  THEN
            WRITE (OUTUNT,*) '***** ERROR CODE ',IFLAG,
     &                       ' RETURNED FROM BLKFCT *****'
            GO TO 1700
        ENDIF
        WRITE (OUTUNT,77)
     &      '   TIME FOR NUMERICAL FACTORIZATION   = ', TIME
C
C       ------------------------------------------------------
C       BLKSLV : NUMERICAL SOLUTION USING LDL' FACTORIZATION.
C
C       INPUT  : NSUPER, XSUPER, XLINDX, LINDX, XLNZ, LNZ, RHS
C       OUTPUT : RHS
C       ------------------------------------------------------
        TIMBEG = GTIMER()
        DO  1300  I = 1, N
            NEWRHS(I) = RHS(PERM(I))
 1300   CONTINUE
        CALL  BLKSLV (  NSUPER, XSUPER, XLINDX, LINDX , XLNZ  ,
     &                  LNZ   , NEWRHS                          )
        DO  1400  I = 1, N
            SOL(I) = NEWRHS(INVP(I))
 1400   CONTINUE
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,77)
     &      '   TIME FOR TRIANGULAR SOLUTIONS      = ', TIME
C
C       ------------------------------------
C       COMPUTE AND PRINT ERROR IN SOLUTION.
C       ------------------------------------
        TIMBEG = GTIMER()
        ERROR = 0.0
        DO  1500  I = 1, N
            E = ABS(SOL(I) - I)
            IF  ( E .GT. ERROR )  ERROR = E
 1500   CONTINUE
        TIMEND = GTIMER()
        TIME = TIMEND - TIMBEG
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,77)
     &      '   TIME FOR COMPUTING ERROR           = ', TIME
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,88)
     &      '   MAXIMUM ABSOLUTE ERROR             = ', ERROR
        WRITE (OUTUNT,88)
     &      '   MAXIMUM RELATIVE ERROR             = ',
     &      ERROR/N
   88   FORMAT ( A40, 1PD20.10 )
C
C       ------------------------------------------------------------
C       COMPUTE AND PRINT STATISTICS.
C
C       INPUT  : NSUPER, XSUPER, XLINDX, LINDX, XLNZ, TMPSIZ, OUTUNT
C       OUTPUT : PRINTED STATISTICS
C       ------------------------------------------------------------
        CALL  LSTATS (  NSUPER, XSUPER, XLINDX, LINDX , XLNZ  ,
     &                  TMPSIZ, OUTUNT                          )
C
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,*)
     &      '------------------------------------------------'
C
C       -------------------
C       NORMAL TERMINATION.
C       -------------------
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,*) 'NORMAL TERMINATION.'
        STOP
C
C       ---------------------
C       ABNORMAL TERMINATION.
C       ---------------------
 1700   CONTINUE
        WRITE (OUTUNT,*) ' '
        WRITE (OUTUNT,*) 'ABNORMAL TERMINATION.'
        STOP
C
      END


program SHMag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will read in a set of magnetic spherical harmonic coefficients
!	and make 2D equally spaced grid of the three vector components of the magnetic
!	field, the total magnetic field strength, and the magnetic potential. The field
!	is calculated on a speroid with mean radius r and flattening f.
!
!	The included spherical harmonic file FSU_mars90.sh is the martian magnetic
!	field model of Cain et al., 2003.
!
!	Dependencies:	SHRead, MakeMagGridDH
!
!	Written by Mark Wieczorek, February 2004
!
!	October 2012:	Modified to use the new routine MakeMagGridDH, instead of the old routine MakeMagGrid2D.
!
!	Copyright (c) 2012, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS

	implicit none

	character*200 ::	infile, radf, thetaf, phif, totalf, potf
	real*8 ::		header(4), interval, r0, a, f, mpr, z, timein, timeout, temp
	real*8, allocatable ::	glm(:,:,:), rad(:,:), phi(:,:), theta(:,:), total(:,:), pot(:,:)
	integer ::		lmax, lmaxp, n, n_out, nlong, nlat, i, j, astat(6), sampling

	infile = "../../ExampleDataFiles/FSU_mars90.sh"
	f = 1.0d0/169.864881d0	! Mars flattening = (R_eq - R_p)/R_eq
	mpr = 3389.508d3	! Mean radius of mars
	z = 145.d3		! mean altitude to calculate field at.

	lmax = 359	! Maximum spherical harmonic degree that is resolved in the output grids.
	N = 2*lmax+2	! Number of latitudinal samples in the output grids.
	interval = 180.0d0 / dble(n)	! Sampling interval in latitude.

	sampling = 2
	nlat = n
	nlong = 2*n

	print*, "LMAX of output grids = ", lmax
	print*, "N = ", n
	print*, "Latitudinal sampling interval = ", interval

	allocate(glm(2,lmax+1,lmax+1), stat = astat(1))
	allocate(rad(nlat,nlong), stat = astat(2))
	allocate(theta(nlat,nlong), stat = astat(3))
	allocate(phi(nlat,nlong), stat = astat(4))
	allocate(total(nlat,nlong), stat = astat(5))
	allocate(pot(nlat,nlong), stat = astat(6))

	if (sum(astat(1:6)) /= 0) then
		print*, "Problem allocating GLM, RAD, THETA, PHI, TOTAL, and POT", astat(1), astat(2), astat(3), astat(4), astat(5), astat(6)
		stop
	endif

	call SHRead(infile, glm, lmaxp, header=header(1:4), skip=1)
	r0 = header(1)*1.d3
	print*, "Reference radius of spherical harmonic coefficients R0 (km) = ", r0/1.d3
	print*, "Lmax of spherical harmonic model = ", lmaxp

	a = mpr + z
	print*, "Field calculated on a flattened ellipsoid with semi-major axis A (km) = ", a/1.d3
	print*, "Flattening of the ellipsoid = ", f

	radf = "radial_145f.dat"
	thetaf = "theta_145f.dat"
	phif = "phi_145f.dat"
	totalf = "total_145f.dat"
	potf = "pot_145f.dat"

	call cpu_time(timein)

	call MakeMagGridDH(glm, lmax, r0, a, f, rad, theta, phi, total, n_out, sampling = sampling, lmax_calc = lmaxp, pot_grid = pot)

	call cpu_time(timeout)

	print*, "Elapsed time (sec) = ", timeout-timein

	if (n /= n_out) then
		print*, "Problem. N is not equal to N_OUT."
		print*, "N_OUT = ", n_out
		stop
	endif

	print*, "Maximum and minimum field intensity (nT) = ", maxval(total(1:nlat,1:nlong)), minval(total(1:nlat,1:nlong))
	print*, "Maximum and minimum Br (nT) = ", maxval(rad(1:nlat,1:nlong)), minval(rad(1:nlat,1:nlong))
	print*, "Maximum and minimum Btheta (nT) = ", maxval(theta(1:nlat,1:nlong)), minval(theta(1:nlat,1:nlong))
	print*, "Maximum and minimum Bphi (nT) = ", maxval(phi(1:nlat,1:nlong)), minval(phi(1:nlat,1:nlong))
	print*, "Maximum and minimum potential (nT m) = ", maxval(pot(1:nlat,1:nlong)), minval(pot(1:nlat,1:nlong))

	open(12,file=radf)
	open(13,file=phif)
	open(14,file=thetaf)
	open(15,file=totalf)
	open(16,file=potf)

	write(12,*) nlat+1, nlong+1
	write(13,*) nlat+1, nlong+1
	write(14,*) nlat+1, nlong+1
	write(15,*) nlat+1, nlong+1
	write(16,*) nlat+1, nlong+1

	do i=1, nlat
		do j=1, nlong
			write(12,*) rad(i,j)
			write(13,*) phi(i,j)
			write(14,*) theta(i,j)
			write(15,*) total(i,j)
			write(16,*) pot(i,j)
		enddo
		! write out value at 360 degrees longitude, which is redundant
		write(12,*) rad(i,1)
		write(13,*) phi(i,1)
		write(14,*) theta(i,1)
		write(15,*) total(i,1)
		write(16,*) pot(i,1)
	enddo

	! write out values at 90 S, which are not calculated in the Driscoll and Healy routine, and which are just the average of the values
	! of the last row.
	temp = sum(rad(nlat,1:nlong)) / dble(nlong)
	do j=1, nlong+1
		write(12,*) temp
	enddo
	temp = sum(phi(nlat,1:nlong)) / dble(nlong)
	do j=1, nlong+1
		write(13,*) temp
	enddo
	temp = sum(theta(nlat,1:nlong)) / dble(nlong)
	do j=1, nlong+1
		write(14,*) temp
	enddo
	temp = sum(total(nlat,1:nlong)) / dble(nlong)
	do j=1, nlong+1
		write(15,*) temp
	enddo
	temp = sum(pot(nlat,1:nlong)) / dble(nlong)
	do j=1, nlong+1
		write(16,*) temp
	enddo

	close(12)
	close(13)
	close(14)
	close(15)
	close(16)

	deallocate(rad)
	deallocate(theta)
	deallocate(phi)
	deallocate(total)
	deallocate(pot)
	deallocate(glm)

end program SHMag


!==========================================================================
elemental subroutine gsw_entropy_first_derivatives (sa, ct, eta_sa, eta_ct)
! =========================================================================
!
!  Calculates the following two partial derivatives of specific entropy
!  (eta)
!   (1) eta_SA, the derivative with respect to Absolute Salinity at
!       constant Conservative Temperature, and
!   (2) eta_CT, the derivative with respect to Conservative Temperature at
!       constant Absolute Salinity.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!
!  eta_SA =  The derivative of specific entropy with respect to
!            Absolute Salinity (in units of g kg^-1) at constant
!            Conservative Temperature.
!            eta_SA has units of:         [ J/(kg K(g/kg))]  or [ J/(g K) ]
!  eta_CT =  The derivative of specific entropy with respect to
!            Conservative Temperature at constant Absolute Salinity.
!            eta_CT has units of:                            [ J/(kg K^2) ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_t0

use gsw_mod_toolbox, only : gsw_gibbs, gsw_pt_from_ct

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct
real (r8), intent(out), optional :: eta_sa, eta_ct

real (r8) :: pt

integer, parameter :: n0=0, n1=1
real (r8), parameter :: pr0 = 0.0_r8

pt = gsw_pt_from_ct(sa,ct)

if (present(eta_sa)) eta_sa = -(gsw_gibbs(n1,n0,n0,sa,pt,pr0))/(gsw_t0 + pt)

if (present(eta_ct)) eta_ct = gsw_cp0/(gsw_t0 + pt)

return
end subroutine

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


subroutine cloud

!  Condensation of cloud water/cloud ice.

use vars
use microphysics
use micro_params
use params

implicit none

integer i,j,k, kb, kc, kmax
real dtabs, tabs1
real fac1
real fff,dfff,qsatt,dqsat
real lstarn,lstarp
real coef,dqi,lat_heat,vt_cl, coef_cl
real qiu, qic, qid, tmp_theta, tmp_phi
real fz(nx,ny,nz)
integer niter

fac1 = fac_cond
kmax=0

call t_startf ('cloud')

do k = 1, nzm
 do j = 1, ny
  do i = 1, nx

    q(i,j,k)=max(0.,q(i,j,k))

! Initail guess for temperature assuming no cloud water/ice:

    tabs(i,j,k) = t(i,j,k)-gamaz(k)
    tabs1=tabs(i,j,k)+fac1*qp(i,j,k)

    tabs1=tabs(i,j,k)+fac_cond*qp(i,j,k)
    qsatt = qsatw(tabs1,pres(k))

!  Test if condensation is possible:

    if(q(i,j,k).gt.qsatt) then

      niter=0
      dtabs = 100.
      do while(abs(dtabs).gt.0.01.and.niter.lt.10)
	lstarn=fac_cond
	lstarp=fac_cond
	qsatt=qsatw(tabs1,pres(k))
	dqsat=dtqsatw(tabs1,pres(k))
	fff = tabs(i,j,k)-tabs1+lstarn*(q(i,j,k)-qsatt)+lstarp*qp(i,j,k)
	dfff=-lstarn*dqsat-1.
	dtabs=-fff/dfff
	niter=niter+1
	tabs1=tabs1+dtabs
      end do

      qsatt = qsatt + dqsat * dtabs
      qn(i,j,k) = max(0.,q(i,j,k)-qsatt)
      kmax = max(kmax,k)

    else

      qn(i,j,k) = 0.

    endif

    tabs(i,j,k) = tabs1
    qp(i,j,k) = max(0.,qp(i,j,k)) ! just in case

  end do
 end do
end do

!
! Take into account sedimentation of cloud water which may be important for stratocumulus case.
! Parameterization of sedimentation rate is taken from GCSS WG1 DYCOMS2_RF2 case, and base on
! Rogers and Yau, 1989

coef_cl = 1.19e8*(3./(4.*3.1415*rho_water*Nc0*1.e6))**(2./3.)*exp(5.*log(sigmag)**2)

fz = 0.

! Compute cloud ice flux (using flux limited advection scheme, as in
! chapter 6 of Finite Volume Methods for Hyperbolic Problems by R.J.
! LeVeque, Cambridge University Press, 2002).
do k = 1,kmax
   ! Set up indices for x-y planes above and below current plane.
   kc = min(nzm,k+1)
   kb = max(1,k-1)
   ! CFL number based on grid spacing interpolated to interface i,j,k-1/2
   coef = dtn/(0.5*(adz(kb)+adz(k))*dz)
   do j = 1,ny
      do i = 1,nx
         ! Compute cloud water density in this cell and the ones above/below.
         ! Since cloud ice is falling, the above cell is u (upwind),
         ! this cell is c (center) and the one below is d (downwind).

         qiu = rho(kc)*qn(i,j,kc)
         qic = rho(k) *qn(i,j,k)
         qid = rho(kb)*qn(i,j,kb)

         ! Ice sedimentation velocity depends on ice content. The fiting is
         ! based on the data by Heymsfield (JAS,2003). -Marat
         ! 0.1 m/s low bound was suggested by Chris Bretherton
         vt_cl = coef_cl*(qic+1.e-12)**(2./3.)

         ! Use MC flux limiter in computation of flux correction.
         ! (MC = monotonized centered difference).
         if (qic.eq.qid) then
            tmp_phi = 0.
         else
            tmp_theta = (qiu-qic)/(qic-qid)
            tmp_phi = max(0.,min(0.5*(1.+tmp_theta),2.,2.*tmp_theta))
         end if

         ! Compute limited flux.
         ! Since falling cloud ice is a 1D advection problem, this
         ! flux-limited advection scheme is monotonic.
         fz(i,j,k) = -vt_cl*(qic - 0.5*(1.-coef*vt_cl)*tmp_phi*(qic-qid))
      end do
   end do
end do
fz(:,:,nz) = 0.

do k=1,kmax
   coef=dtn/(dz*adz(k)*rho(k))
   do j=1,ny
      do i=1,nx
         ! The cloud ice increment is the difference of the fluxes.
         dqi=coef*(fz(i,j,k)-fz(i,j,k+1))
         ! Add this increment to both non-precipitating and total water.
         qn(i,j,k) = qn(i,j,k) + dqi
         q(i,j,k)  = q(i,j,k)  + dqi
         ! Include this effect in the total moisture budget.
         qifall(k) = qifall(k) + dqi

         ! The latent heat flux induced by the falling cloud water enters
         ! the liquid-ice static energy budget in the same way as the
         ! precipitation.
         lat_heat  = fac_cond*dqi
         ! Add divergence of latent heat flux to liquid-ice static energy.
         t(i,j,k)  = t(i,j,k)  - lat_heat
         ! Add divergence to liquid-ice static energy budget.
         tlatqi(k) = tlatqi(k) - lat_heat
      end do
   end do
end do

call t_stopf ('cloud')

end subroutine cloud