! { dg-do run }
! PR83811 fortran 'e' format broken for single digit exponents
program test
  character(25) :: s
  write(s, '(1pe5.0e1)') 1.e-4
  if (s.ne."1.E-4") call abort
  write(s, '(e5.1e1)') 1.e12
  if (s.ne."*****") call abort
end


module grav
use param
!use utilmod
!use coordsys
!integer,parameter::grv_order=100
real(dp),allocatable::c(:,:),s(:,:)
real(dp)::gm ,a
character*150::grv_file
integer:: grv_order,grv_file_id,grv_body_id
private
public getgrvp,getgrvp1,gravity,gforcebf,grv_order,grv_file,grv_file_id,grv_body_id
contains
!public
!getgrvp		read grv file
!getgrvp1
!gravity		compute gravity force in J2000 frame
!gforcebf		compute gravity force in body-fixed frame
!grv_order		order of gravity
!grv_file		name of grv file
!grv_file_id	file number of
!grv_body_id	central body id

subroutine gravity(et,r,f)
! et:time wrt. spacecraft
!  r:inertial coord m
!  f:force wrt. inertial      m/s^2
implicit none
real(dp):: et,f(3),accbf(3),r(3),xbf(3),mf2i(3,3),mi2f(3,3)
select case (grv_body_id)
	case(499)
    	call f2i_mars(et,mf2i)    !body fixed to J2000
	case(699)
  	 	call pXFORM ( 'IAU_SATURN', 'J2000', ET, Mf2i )
case default
		write(*,*)'wrong body id'
		stop
endselect
!    call pXFORM ( 'IAU_MARS', 'J2000', ET, Mf2i )
    call INVert ( mf2i, mi2f )
    call MXV ( Mi2f, r, xbf )
!    xbf=1000.d0*xbf
   call gforcebf(xbf,accbf)
!   write(*,*)accbf
    call MXV ( Mf2i, accbf, f )
endsubroutine gravity

subroutine gforcebf(xbf,accbf)
implicit none
real(dp)::xbf(3),k,x,y,z,r,rx,ry,rz,px,py,pz,lx,ly,lz,x2y,&
	&ur,up,ul,fnm,cosp,sinp,normp(0:grv_order,0:grv_order),cltemp,sltemp,dpnm(0:grv_order,0:grv_order),&
	&cl(0:grv_order),sl(0:grv_order),q,h,kk,g,accbf(3)
integer:: n,m,i

x=xbf(1)
y=xbf(2)
z=xbf(3)
r=dsqrt(x*x+y*y+z*z)
x2y=x*x+y*y
rx=x/r
ry=y/r
rz=z/r
px=-x*z/(dsqrt(x2y)*r**2)
py=-y*z/(dsqrt(x2y)*r**2)
pz=dsqrt(x2y)/r**2
lx=-y/x2y
ly=x/x2y
lz=0.d0
sinp=z/r
cosp=dsqrt(x2y)/r
cltemp=x/dsqrt(x2y)
sltemp=y/dsqrt(x2y)
!initial
cl=0.d0
sl=0.d0
normp=0.d0
dpnm=0.d0
ur=0.d0
up=0.d0
ul=0.d0
accbf=0.d0

cl(0)=1.d0
sl(0)=0.d0
do i=1,grv_order
!	call legendre_associated ( grv_order, i, sinp,normp(:,i) )
	if (i.ne.0) then
		cl(i)=cl(i-1)*cltemp-sl(i-1)*sltemp
		sl(i)=sl(i-1)*cltemp+cl(i-1)*sltemp
	endif
enddo
!write(*,'(7f10.3)')(normp(m,:),m=0,grv_order)
!write(*,'(2f)')(cl(i),sl(i),i=1,grv_order)
!stop
dpnm(0,0)=0.d0
dpnm(1,0)= dsqrt(3.d0)*cosp
dpnm(1,1)=-dsqrt(3.d0)*sinp
normp(0,0)=1.d0
normp(1,0)= dsqrt(3.d0)*sinp
normp(1,1)= dsqrt(3.d0)*cosp
!write(*,*)cosp,sinp

do n=2,grv_order
	q=dsqrt((2.d0*n+1.d0)/(2.d0*n))
	g=dsqrt(2.d0*n+1.d0)
	do m=0,n
		h=dsqrt((2.d0*n-1.d0)*(2.d0*n+1.d0)/((n+m)*(n-m)))
		kk=dsqrt((n+m-1.0)*(n-m-1.0)*(2.d0*n+1.d0)/((n+m)*(n-m)*(2.d0*n-3.d0)))
		if(m.eq.n) then
			dpnm(n,m)=-q*sinp*normp(n-1,n-1)+q*cosp*dpnm(n-1,n-1)
			normp(n,m)=normp(n-1,n-1)*q*cosp
		elseif(m.eq.n-1) then
			 dpnm(n,m)=g*cosp*normp(n-1,n-1)+g*sinp*dpnm(n-1,n-1)
			normp(n,m)=normp(n-1,n-1)*g*sinp
		else
			dpnm(n,m)=h*cosp*normp(n-1,m)+h*sinp*dpnm(n-1,m)-kk*dpnm(n-2,m)
			normp(n,m)=normp(n-1,m)*h*sinp-normp(n-2,m)*kk
		endif

		ur=-(n+1.d0)*(gm/r**2)*(a/r)**n*normp(n,m)*(c(n,m)*cl(m)+s(n,m)*sl(m))
		up= (gm/r)*(a/r)**n*dpnm(n,m)*(c(n,m)*cl(m)+s(n,m)*sl(m))
		ul=(gm/r)*m*(a/r)**n*normp(n,m)*(-c(n,m)*sl(m)+s(n,m)*cl(m))
		accbf(1)=accbf(1)+ur*rx+up*px+ul*lx
		accbf(2)=accbf(2)+ur*ry+up*py+ul*ly
		accbf(3)=accbf(3)+ur*rz+up*pz+ul*lz
	enddo
enddo
endsubroutine gforcebf

!gravity file of jpl
subroutine getgrvp
implicit none
integer::n,m,rn,rm
allocate(c(2:grv_order,0:grv_order),s(2:grv_order,0:grv_order))
OPEN(grv_file_id,FILE=grv_file,STATUS='old')
read(grv_file_id,*)a,gm
a=a*1.d3
gm=gm*1.d9
do n=2,grv_order
	do m=0,n
	read(grv_file_id,'(I5,1x,I5,1x,d23.16,1x,d23.16)',end=112)rn,rm,c(n,m),s(n,m)
	if (rn.ne.n.or.rm.ne.m) then
		write(*,*)'read grv error!'
		stop
	endif
	enddo
enddo
112 continue
close(grv_file_id)
endsubroutine getgrvp

!gravity file of gsfc
subroutine getgrvp1
implicit none
integer::n,m,rn,rm
allocate(c(2:grv_order,0:grv_order),s(2:grv_order,0:grv_order))
OPEN(22,FILE='/home/jnc/work/spice/src/trsim/gravtest/geok',STATUS='old')
read(22,*)ctemp
read(22,'(A20,2E20.10)')ctemp,gm,a
read(22,*)ctemp
write(*,*)gm,a
!a=a*1.d3
!gm=gm*1.d9
do n=2,grv_order
    do m=0,n
    read(22,'(A6,2I3,2D21.14)',end=112)ctemp,rn,rm,c(n,m),s(n,m)
	if (rn.ne.n.or.rm.ne.m) then
        write(*,*)'read grv error!'
        stop
    endif
!   write(*,*)c(n,m),s(n,m)
    enddo
enddo
112 continue
close(22)
endsubroutine getgrvp1

subroutine f2i_mars(et,m)
!fixed system to J2000 inertial system matrix
real(dp)::et,m(3,3),spd,rpd,day,N,J,psi,I,PHI
M=0.d0
M(1,1)=1.d0
M(2,2)=1.d0
M(3,3)=1.d0
day=et/spd()
N = 3.37919183d0 !deg
J = 24.67682669d0 !deg
psi=81.9684072598d0+day*(-0.0000057901d0)
I=25.1893863984d0+day*(-0.000000003d0)
phi=133.38462d0+day*350.891985305d0
!call ROTMAT ( M, -N*rpd(), 3, Mtemp1 ) !R_z(-N)
!call ROTMAT ( Mtemp1, -J*rpd(), 1, Mtemp2 )
!call ROTMAT ( Mtemp2, -psi*rpd(), 3, Mtemp1 )
!call ROTMAT ( Mtemp1, -I*rpd(), 1, Mtemp2 )
!call ROTMAT ( Mtemp2, -phi*rpd(), 3, M )
call ROTMAT ( M, -phi*rpd(), 3, Mtemp1 ) !R_z(-N)
call ROTMAT ( Mtemp1, -I*rpd(), 1, Mtemp2 )
call ROTMAT ( Mtemp2, -psi*rpd(), 3, Mtemp1 )
call ROTMAT ( Mtemp1, -J*rpd(), 1, Mtemp2 )
call ROTMAT ( Mtemp2, -N*rpd(), 3, M )
end subroutine f2i_mars

endmodule grav


module physics
implicit none
contains

!this turns the position vectors into an absolute distance by poop
pure function distance(particle_here,particle_there) result(dist)
implicit none

real,dimension(*),intent(in) :: particle_here(:),particle_there(:)
real :: dist,distance_squared,part_here,part_there
integer :: pos

distance_squared=0.

do concurrent (pos=1:size(particle_here(:)))
	part_here=particle_here(pos)
	part_there=particle_there(pos)
	distance_squared=distance_squared+(part_there-part_here)**2
	if (pos==size(particle_here(:))) then
		dist=sqrt(distance_squared)
	end if
end do

end function distance

subroutine gravity(particles_here,particles_everywhere)
real,dimension(*) :: particles_everywhere(:,:,:)
real,dimension(3) ::  distance_vector
real :: separation,gravitation !this defines the absolute separation and the gravitation
integer :: pos,particles,particles_here
real :: dist,distance_squared,part_here,part_there

particles_everywhere(:,3,particles_here)=[0.,0.,0.]

!calculate effect for every single particle on this particle
do concurrent (particles=1:size(particles_everywhere(1,1,:)))

	!ensure particle does not gravitate itself
	if (particles/=particles_here) then

		!this defines the vector from here to there, and the co-ordinate system
		distance_vector=particles_everywhere(:,1,particles)-particles_everywhere(:,1,particles_here)

		!this turns the position vectors into an absolute distance by poop
		distance_squared=0.

		do pos=1,size(particles_everywhere(:,1,particles_here))
			part_here=particles_everywhere(pos,1,particles_here)
			part_there=particles_everywhere(pos,1,particles)
			distance_squared=distance_squared+(part_there-part_here)**2
			if (pos==size(particles_everywhere(:,1,particles_here))) then
				dist=sqrt(distance_squared)
			end if
		end do

		separation=dist
		gravitation=1./(separation**2)

		!this is where the acceleration vector from the gravitation of each particle is added to particles_here
		particles_everywhere(:,3,particles_here)=particles_everywhere(:,3,particles_here)+gravitation*(distance_vector/separation)

	end if

end do

end subroutine gravity

!feed in a start and finish time for a time interval printout in hrs, mins, sec
subroutine print_interval(start,finish)
	real,intent(in) :: start, finish
	real :: t_sec, total_time
	integer :: t_hr, t_min

	total_time=finish-start
	t_hr = floor(total_time/3600)
	t_min = (total_time-t_hr*3600)/60
	t_sec = total_time-t_hr*3600-t_min*60
	print'(A24,I2,A5,I2,A7,F5.2,A4)',"simulator time elapsed =",t_hr,' hrs, ',t_min,' mins, ',t_sec,' sec'

end subroutine print_interval

end module physics


c=============================================================================c
        program pc2
c=============================================================================c
c
c  Purpose:  make a body-fitted parabolic-cylinder mesh
c
c  Inputs:   This uses Mahesh mapping in x and y
c
c  Author:   S. Scott Collis
c
c  Revised:  10-1-96
c
c=============================================================================c
        implicit double precision (a-h,o-z)

        logical IRIS, DIAG
        parameter (IRIS = .false.)
        parameter (DIAG = .false.)

        parameter (zero=0.0d0,    pt5=0.5d0,  one=1.0d0,
     &             onept5=1.5d0,  two=2.0d0,  twopt5=2.5d0,
     &             three=3.0d0)
c
c.... must use a large mpts to make error in spline very small
c
        parameter (mpts=5000)
        dimension zz(mpts), s1(mpts), s2(mpts), ds1(mpts), ds2(mpts),
     &            dss1(mpts), dss2(mpts)

        parameter (mx=1024,my=127)

        dimension xb(mx), yb(mx), cur(mx)
        dimension bn1(mx), bn2(mx)

        dimension xi(mx),  eta(my)

        dimension ss(mx), rr(my), dss(mx), drr(my), d2ss(mx), d2rr(my)

        dimension x(mx,my),    y(mx,my)
        dimension rm1(mx,my),  rm2(mx,my)
        dimension rn1(mx,my),  rn2(mx,my),  rjac(mx,my)
        dimension rm11(mx,my), rm12(mx,my), rm21(mx,my), rm22(mx,my)
        dimension rn11(mx,my), rn12(mx,my), rn21(mx,my), rn22(mx,my)
        dimension g11x(mx,my), g11y(mx,my), g12x(mx,my), g12y(mx,my)
        dimension g22x(mx,my), g22y(mx,my)

        dimension d(10), e(10), f1(10), f2(10), g0(10)

        common /stuff/ AR, rm, rn, xmin, xmax

        external xloc, yloc

c.... argument parameters

        integer iarg, narg
        character*80  arg
        integer yflag, xflag
        logical plot3d, debug
#ifndef __GFORTRAN__
        integer, external iargc
#endif
c=============================================================================c
        yflag = 1
        xflag = 0
        plot3d = .false.
        debug = .false.
c
c.... parse the argument list
c
        narg = iargc()
        do iarg = 1, narg
          call getarg(iarg,arg)
          if (arg(1:2) .eq. '-y') then
            if (arg(1:3) .eq. '-y1') then               ! exponential
              yflag = 1
            else if (arg(1:3) .eq. '-y2') then          ! hyperbolic tangent
              yflag = 2
            else if (arg(1:3) .eq. '-y3') then          ! Mahesh
              yflag = 3
            else                                        ! uniform
              yflag = 0
            end if
          else if (arg(1:2) .eq. '-x') then
            if (arg(1:3) .eq. '-x1') then               ! exponential
              xflag = 1
            else if (arg(1:3) .eq. '-x2') then          ! hyperbolic tangent
              xflag = 2
            else if (arg(1:3) .eq. '-x3') then          ! Mahesh in xi
              xflag = 3
            else if (arg(1:3) .eq. '-x4') then          ! Mahesh in s
              xflag = 4
            else                                        ! uniform in xi
              xflag = 0
            end if
          else if (arg(1:2) .eq. '-p') then
            plot3d = .true.
          else if (arg(1:2) .eq. '-d') then
            debug = .true.
          else if (arg(1:2) .eq. '-h') then
            write(*,"('Usage:  pc [options]')")
            write(*,"('   -h:  this help')")
            write(*,"('   -d:  debug output')")
            write(*,"('  -x1:  exponential stretching in x')")
            write(*,"('  -x2:  hyperbolic tangent stretching in x')")
            write(*,"('  -x3:  Mahesh''s mapping in x')")
            write(*,"('  -x4:  Mahesh''s mapping in s')")
            write(*,"('  -y1:  exponential stretching in y')")
            write(*,"('  -y2:  hyperbolic tangent stretching in y')")
            write(*,"('  -y3:  Mahesh''s mapping in y')")
            call exit(0)
          else
            write(*,"('Argument ',i2,' ignored.')") iarg
          end if
        end do
c
c.... get user input
c
        write(*,"('Enter (Nx, Ny) ==> ',$)")
        read(*,*) nx, ny
        if (nx.gt.mx) stop 'nx > mx'
        if (ny.gt.my) stop 'ny > my'

        write(*,*) 'Discretize in the wall tangent direction'

        write(*,"('Enter xmin, xmax ==> ',$)")
        read(*,*) xmin, xmax
c
c.... discretize in the body tangent direction
c
        smin = arc(zero,xmin)
        smax = arc(zero,xmax)
        savg = (smin + smax) * pt5
        write(*,10) xmin, xmax, smin, smax, smax-smin

        dxi  = one / dble(nx-1)
        ds   = (smax-smin) / dble(nx-1)

        write(*,"('ds uniform = ',1pe20.13)") ds
c
c.... Uniform arc-length
c
        if (xflag.eq.0) then
          do i = 1, nx
            xi(i)   = dble(i-1) * dxi
            ss(i)   = smin + float(i-1) * ds
            dss(i)  = ds / dxi
            d2ss(i) = zero
          end do
        end if

        if (xflag.eq.1) then
           write(*,"('ERROR:  xflag = 1 is not supported')")
           call exit(1)
        end if

        if (xflag.eq.2) then
           write(*,"('ERROR:  xflag = 2 is not supported')")
           call exit(1)
        end if

        if (xflag.eq.3) then
           write(*,"('ERROR:  xflag = 3 is not supported')")
           call exit(1)
        end if
c
c.... Uniform arc-length + mapping
c
        if (xflag.eq.4) then
        write(*,"('Enter dsmin, b, sc ==> ',$)")
        read(*,*) dsmin, b, sc

        cm = ( two * b * tanh(b*sc) + real(nx-1)*dsmin/smax *
     &         log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) ) /
     &       ( one - real(nx-1)*dsmin/smax )

        do i = 1, nx
           xi(i)   = dble(i-1) * dxi
           ss(i)   = smax*( cm * xi(i) + log( cosh(b*(xi(i)-sc)) /
     &               cosh(b*(xi(i)+sc)) ) ) /
     &               (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
           dss(i)  = smax*(cm - b*(1.0/Cosh(b*(xi(i) - sc)))*
     &               (1.0/Cosh(b*(xi(i) + sc)))*Sinh(2.0*b*sc)) /
     &               (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
           d2ss(i) = smax*(-b**2*(tanh(b*(xi(i)-sc)))**2 +
     &               b**2*(tanh(b*(xi(i)+sc)))**2)/
     &               (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
        end do
        do i = 1, nx
           if (i.eq.1) then
             write(10,30) xi(i), ss(i), dss(i), d2ss(i),
     &                    (dss(i+1)-dss(i))/dxi
           else if (i.eq.nx) then
             write(10,30) xi(i), ss(i), dss(i), d2ss(i),
     &                    (dss(i)-dss(i-1))/dxi
           else
             write(10,30) xi(i), ss(i), dss(i), d2ss(i),
     &                    (dss(i+1)-dss(i-1))/dxi*pt5
           end if
        end do
        end if
c
c.... discretize in the body normal direction
c
        write(*,*) 'Discretize in the wall normal direction'

        deta = one / dble(ny-1)
        rmin = zero
        write(*,"('Enter Rmax ==> ',$)")
        read(*,*) rmax
        dr = (rmax-rmin) / real(ny-1)
c
c.... uniform mesh in the wall normal direction
c
        if (yflag.eq.0) then
          do j = 1, ny
             eta(j)  = dble(j-1) * deta
             rr(j)   = rmin + dble(j-1) * dr
             drr(i)  = dr / deta
             d2rr(i) = zero
          end do
        end if
c
c.... exponential map in the wall normal direction
c
        if (yflag.eq.1) then
        deta2 = one / real(128-1)
        dymin = 5.0d-5
        sy = 1.088d0
        c2 = log( dymin / deta2 )
        c1 = (log( sy*dymin / deta2) - c2) / deta2
        do j = 1, ny
          eta(j)  = dble(j-1) * deta
          rr(j)   = one / c1 * ( exp(c1 * eta(j) + c2) - exp(c2) )
          drr(j)  = exp(c1 * eta(j) + c2)
          d2rr(j) = c1 * exp(c1 * eta(j) + c2)
          write(20,30) eta(j), rr(j), drr(j), d2rr(j)
        end do
        end if
c
c.... Hyperbolic tangent stretching
c
        if (yflag.eq.2) then

        rd1 = 0.00028d0                 ! set for R=1000 PCYL, r=500
        rd2 = 5.5d0
        dd  = 5.665549493763092d0

        do j = 1, ny
          eta(j) = dble(j-1) * deta
          rr(j) =  rmax*(pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             eta(j)))*pt5)/(Sqrt(rd2/rd1) +
     &             (one - Sqrt(rd2/rd1))*
     &             (pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             eta(j)))*pt5))
          drr(j) = dd*Sqrt(rd2/rd1)*rmax*Cosh(dd*pt5)*
     &             one/Cosh(dd*(-pt5 + eta(j)))*
     &             (Sinh(dd*(one - eta(j))) + Sinh(dd*eta(j)))/
     &             (Sqrt(rd2/rd1)*Sinh(dd*(one - eta(j))) +
     &             Sinh(dd*eta(j)))**2
          d2rr(j) = dd**2*Sqrt(rd2/rd1)*rmax*
     &              (-Cosh(dd*(one - three*eta(j))) +
     &              Sqrt(rd2/rd1)*Cosh(dd*(two - three*eta(j))) -
     &              Cosh(dd*(one - eta(j))) +
     &              two*Sqrt(rd2/rd1)*Cosh(dd*(one - eta(j))) -
     &              two*Cosh(dd*eta(j)) +
     &              Sqrt(rd2/rd1)*Cosh(dd*eta(j)))*
     &              (one/Cosh(dd*(-pt5 + eta(j))))**2*(Sinh(dd))/
     &              (two*(Sqrt(rd2/rd1)*(Sinh(dd*(one - eta(j)))) +
     &              (Sinh(dd*eta(j))))**3)
          write(20,30) eta(j), rr(j), drr(j), d2rr(j), d2rr(j)/drr(j)
        end do
        end if
c
c.... Mahesh mapping, personal communication (6-5-96)
c
        if (yflag.eq.3) then
          write(*,"('Enter drmin, b, rc ==> ',$)")
          read(*,*) drmin, b, rc
          cm = ( two * b * tanh(b*rc) + (ny-1)*drmin/rmax *
     &           log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) ) /
     &         ( one - (ny-1)*drmin/rmax )
          do j = 1, ny
            eta(j)  = dble(j-1) * deta
            rr(j)   = rmax*( cm * eta(j) + log( cosh(b*(eta(j)-rc)) /
     &                cosh(b*(eta(j)+rc)) ) ) /
     &                (cm + log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) )
            drr(j)  = rmax*(cm + b*tanh(b*(eta(j)-rc)) -
     &                b*tanh(b*(eta(j)+rc))) /
     &                (cm + log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) )
            d2rr(j) = rmax*(-b**2*(tanh(b*(eta(j)-rc)))**2 +
     &                b**2*(tanh(b*(eta(j)+rc)))**2)/
     &                (cm + log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) )
            write(20,30) eta(j), rr(j), drr(j), d2rr(j)
          end do
        end if
c
c.... Compute the boundary and outward normal
c
        j = 1
        do i = 1, nx
          if (i.eq.1) then
!            xl = xloc( xmin, ss(i) )
             xl = xmin
          else
             xl = xloc( xold, ss(i) - ss(i-1) )
          end if
          yl = yloc( xl )
          th = atan2( one, yl )
          bn1(i) = -sin(th)
          bn2(i) =  cos(th)

          xb(i) = xl
          yb(i) = yl

          write(30,30) xl, yl, th, bn1(i), bn2(i)
          xold = xl
        end do
        write(*,*) 'Making the mesh'
c
c.... Make the mesh
c
        do j = 1, ny
          do i = 1, nx
            x(i,j) = xb(i) + rr(j) * bn1(i)
            y(i,j) = yb(i) + rr(j) * bn2(i)
          end do
        end do
        write(*,*) 'Making the metrics'
c
c.... write out the body.dat file
c.... rk is the curvature for a parabolic cylinder
c
        open(9,file='body.dat',status='unknown')
        j = 1
        do i = 1, nx
           rk = (two * xb(i) + one)**(-onept5)
           write(9,"(1(i5,1x),6(1pe20.13,1x))") i, ss(i), xb(i), yb(i),
     &                                          bn1(i), bn2(i), rk
        end do
        close(9)
c
c.... write out a coord.dat file for the output plane
c
        open(9,file='coord.dat',status='unknown')
        i = nx
        do j = 1, ny
           write(9,"(2(i5,1x),2(1pe13.6,1x))") 0, 0, x(i,j), y(i,j)
        end do
        close(9)
c
c.... write out a top file
c
        open(9,file='top.dat',status='unknown')
        j = ny
        do i = 1, nx
           write(9,"(1(i5,1x),2(1pe13.6,1x))") i, x(i,j), y(i,j)
        end do
        close(9)
c
c.... write out the nose element spacing
c
        dr = sqrt( (x(1,1) - x(1,2))**2 + (y(1,1) - y(1,2))**2 )
        yl = y(2,1)
        ds = yl * 0.5 * sqrt( 1.0 + yl**2) +
     &       0.5 * log( abs( yl + sqrt(1.0 + yl**2)))

        write(*,11) ds, dr, sqrt( (x(1,2)-x(1,3))**2 + (y(1,2)-y(1,3))**2 )/dr
 11     format('ds_min = ',1pe20.13,' dr_min = ',1pe20.13,
     &         ' dr(2)/dr(1)     = ',1pe20.13)
c
c.... write out the maximum spacing
c
        dr = x(1,ny-1) - x(1,ny)
        yl = y(nx,1)
        ds = yl * 0.5 * sqrt( 1.0 + yl**2) +
     &       0.5 * log( abs( yl + sqrt(1.0 + yl**2)))
        yl = y(nx-1,1)
        ds = ds - (yl * 0.5 * sqrt( 1.0 + yl**2) +
     &       0.5 * log( abs( yl + sqrt(1.0 + yl**2))))
        write(*,21) ds, dr, (x(1,ny-2)-x(1,ny-1))/dr
 21     format('ds_max = ',1pe20.13,' dr_max = ',1pe20.13,
     &         ' dr(ny)/dr(ny-1) = ',1pe20.13)
c
c.... Make the metrics
c
        do j = 1, ny
c         write(*,*) 'j = ',j
          do i = 1, nx
c==============================================================================
c.... first derivative metrics
c==============================================================================
            xl = xb(i)
            yl = yb(i)
            xtmp = one

            if (xl .eq. zero) then
              dydx = 1.0d30
            else
              dydx = one / sqrt( two * xl )
            end if
            dxbds  = one / sqrt(one + dydx**2)

            if (xl .eq. zero) then
              dxdy = zero
            else
              dxdy = sqrt( two * xl )
            end if
            dybds = one / sqrt( dxdy**2 + one )

            if (xl .eq. zero) then
              dx = zero
              dy = one

              ddxdx = 1.0d30
              ddydx = zero

              ddxdy = one
              ddydy = zero

              d2dxdx2 = 1.0d30
              d2dydx2 = zero

              d2dxdy2 = zero
              d2dydy2 = zero
            else
              dx = yl
              dy = one

              ddxdx = one / yl
              ddydx = zero

              ddxdy = one
              ddydy = zero

              d2dxdx2 = -sqrt(two)/(two**2 * xl**onept5)
              d2dydx2 = zero

              d2dxdy2 = zero
              d2dydy2 = zero
            end if

            if ( abs(bn1(i)) .gt. abs(bn2(i)) ) then
              dbn1 = ( -ddydy/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdy +
     &                  two*dy*ddydy)/(dx**2 + dy**2)**onept5 ) * dybds
              dbn2 = ( ddxdy/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdy +
     &                 two*dy*ddydy)/(dx**2 + dy**2)**onept5 ) * dybds
            else
              dbn1  = ( -ddydx/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdx +
     &                   two*dy*ddydx)/(dx**2 + dy**2)**onept5 ) * dxbds
              dbn2  = ( ddxdx/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdx +
     &                  two*dy*ddydx)/(dx**2 + dy**2)**onept5 ) * dxbds
            end if

            dsdxi  = dss(i)
            drdxi  = zero

            dsdeta = zero
            drdeta = drr(j)

            dxds  = dxbds + rr(j) * dbn1
            dxdr  = bn1(i)

            dyds  = dybds + rr(j) * dbn2
            dydr  = bn2(i)

            dxdxi  = dxds * dsdxi  + dxdr * drdxi
            dxdeta = dxds * dsdeta + dxdr * drdeta

            dydxi  = dyds * dsdxi  + dydr * drdxi
            dydeta = dyds * dsdeta + dydr * drdeta

            rjac(i,j) = one / ( dxdxi * dydeta - dxdeta * dydxi )

            rm1(i,j) =  dydeta * rjac(i,j)
            rm2(i,j) = -dxdeta * rjac(i,j)

            rn1(i,j) = -dydxi * rjac(i,j)
            rn2(i,j) =  dxdxi * rjac(i,j)

            if (j .eq. 1)  write(60,30) ss(i), bn1(i), dbn1, bn2(i), dbn2,
     &                     sqrt(dbn1**2 + dbn2**2)

            if (DIAG) then
              if (j .eq. 1)  write(40,30) ss(i), x(i,j), dxds,
     &                       (x(i+1,j)-x(i-1,j))/(ss(i+1)-ss(i-1))
              if (j .eq. 1)  write(50,30) ss(i), y(i,j), dyds,
     &                       (y(i+1,j)-y(i-1,j))/(ss(i+1)-ss(i-1))
              if (j .eq. 1)  write(60,30) ss(i), bn1(i), dbn1, bn2(i), dbn2,
     &                       sqrt(dbn1**2 + dbn2**2)
              if (j .eq. ny) write(65,30) ss(i), rm1(i,j), rn1(i,j), rm2(i,j),
     &                       rn2(i,j), rjac(i,j)
              if (j .eq. ny) write(66,30) ss(i), dxds, dsdxi, dxbds, dbn1
              if (j .eq. ny) write(67,30) ss(i), dydeta, dxdeta, dydxi, dxdxi
            end if

            if (j.eq.1) then
               cur(i) = sqrt(dbn1**2+dbn2**2)
               write(35,30) ss(i), sqrt(dbn1**2+dbn2**2)
            end if
c==============================================================================
c.... second derivative metrics
c==============================================================================
            if ( abs(bn1(i)) .gt. abs(bn2(i)) ) then
              d2xdy2  = one
              d2ybds2 = -(one + dxdy**2)**(-onept5) * dxdy * d2xdy2 * dybds
              d2xbds2 = d2xdy2*(dybds)**2 + dxdy*d2ybds2
            else
              d2ydx2  = -one / ( two * sqrt(two) * xl**onept5 )
              d2xbds2 = -(one + dydx**2)**(-onept5) * dydx * d2ydx2 * dxbds
              d2ybds2 = d2ydx2*(dxbds)**2 + dydx*d2xbds2
            end if

            if ( abs(bn1(i)) .gt. abs(bn2(i)) ) then
              d2bn1 = ((ddxdy*(dy*ddxdy-dx*ddydy)+dx*(dy*d2dxdy2-dx*d2dydy2))/
     &                (dx**2+dy**2)**(onept5) -
     &                (three*dx*(dy*ddxdy-dx*ddydy)*(dx*ddxdy+dy*ddydy))/
     &                (dx**2+dy**2)**(twopt5))*(dybds)**2 +
     &                (-ddydy/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdy +
     &                  two*dy*ddydy)/(dx**2 + dy**2)**onept5) * d2ybds2
              d2bn2 = ((ddydy*(dy*ddxdy-dx*ddydy)+dy*(dy*d2dxdy2-dx*d2dydy2))/
     &                (dx**2+dy**2)**(onept5) -
     &                (three*dy*(dy*ddxdy-dx*ddydy)*(dx*ddxdy+dy*ddydy))/
     &                (dx**2+dy**2)**(twopt5))*(dybds)**2 +
     &                (ddxdy/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdy +
     &                 two*dy*ddydy)/(dx**2 + dy**2)**onept5) * d2ybds2
            else
              d2bn1 = ((ddxdx*(dy*ddxdx-dx*ddydx)+dx*(dy*d2dxdx2-dx*d2dydx2))/
     &                (dx**2+dy**2)**(onept5) -
     &                (three*dx*(dy*ddxdx-dx*ddydx)*(dx*ddxdx+dy*ddydx))/
     &                (dx**2+dy**2)**(twopt5))*(dxbds)**2 +
     &                (-ddydx/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdx +
     &                  two*dy*ddydx)/(dx**2 + dy**2)**onept5) * d2xbds2
              d2bn2 = ((ddydx*(dy*ddxdx-dx*ddydx)+dy*(dy*d2dxdx2-dx*d2dydx2))/
     &                (dx**2+dy**2)**(onept5) -
     &                (three*dy*(dy*ddxdx-dx*ddydx)*(dx*ddxdx+dy*ddydx))/
     &                (dx**2+dy**2)**(twopt5))*(dxbds)**2 +
     &                (ddxdx/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdx +
     &                 two*dy*ddydx)/(dx**2 + dy**2)**onept5) * d2xbds2
            end if

            d2sdxi2    = d2ss(i)
            d2sdxideta = zero
            d2sdeta2   = zero

            d2rdxi2    = zero
            d2rdxideta = zero
            d2rdeta2   = d2rr(j)

            d2xds2  = d2xbds2 + rr(j) * d2bn1
            d2xdsdr = dbn1
            d2xdr2  = zero

            d2yds2  = d2ybds2 + rr(j) * d2bn2
            d2ydsdr = dbn2
            d2ydr2  = zero

            d2xdxi2 = d2xds2 * dsdxi**2 + dxds * d2sdxi2 +
     &                d2xdsdr * drdxi * dsdxi + d2xdsdr * drdxi * dsdxi +
     &                d2xdr2 * drdxi**2 + dxdr * d2rdxi2

            d2xdxideta = d2xds2 * dsdeta * dsdxi + dxds * d2sdxideta +
     &                   d2xdsdr * drdeta * dsdxi + d2xdsdr * drdxi * dsdeta +
     &                   d2xdr2 * drdeta * drdxi + dxdr * d2rdxideta

            d2xdeta2 = d2xds2 * dsdeta**2 + dxds * d2sdeta2 +
     &                 d2xdsdr * drdeta * dsdeta + d2xdsdr * drdeta * dsdeta +
     &                 d2xdr2 * drdeta**2 + dxdr * d2rdeta2

            d2ydxi2 = d2yds2 * dsdxi**2 + dyds * d2sdxi2 +
     &                d2ydsdr * drdxi * dsdxi + d2ydsdr * drdxi * dsdxi +
     &                d2ydr2 * drdxi**2 + dydr * d2rdxi2

            d2ydxideta = d2yds2 * dsdeta * dsdxi + dyds * d2sdxideta +
     &                   d2ydsdr * drdeta * dsdxi + d2ydsdr * drdxi * dsdeta +
     &                   d2ydr2 * drdeta * drdxi + dydr * d2rdxideta

            d2ydeta2 = d2yds2 * dsdeta**2 + dyds * d2sdeta2 +
     &                 d2ydsdr * drdeta * dsdeta + d2ydsdr * drdeta * dsdeta +
     &                 d2ydr2 * drdeta**2 + dydr * d2rdeta2

            drjacdxi = -(d2xdxi2*dydeta + dxdxi*d2ydxideta - d2xdxideta*dydxi -
     &                   dxdeta*d2ydxi2) * rjac(i,j)**2

            drjacdeta = -(d2xdxideta*dydeta + dxdxi*d2ydeta2 - d2xdeta2*dydxi -
     &                    dxdeta*d2ydxideta) * rjac(i,j)**2

            rm11(i,j) = drjacdxi * dydeta * rm1(i,j) +
     &                  d2ydxideta * rjac(i,j) * rm1(i,j) +
     &                  drjacdeta * dydeta * rn1(i,j) +
     &                  d2ydeta2 * rjac(i,j) * rn1(i,j)

            rm12(i,j) = drjacdxi * dydeta * rm2(i,j) +
     &                  d2ydxideta * rjac(i,j) * rm2(i,j) +
     &                  drjacdeta * dydeta * rn2(i,j) +
     &                  d2ydeta2 * rjac(i,j) * rn2(i,j)

            rm21(i,j) = -( drjacdxi * dxdeta * rm1(i,j) +
     &                     d2xdxideta * rjac(i,j) * rm1(i,j) +
     &                     drjacdeta * dxdeta * rn1(i,j) +
     &                     d2xdeta2 * rjac(i,j) * rn1(i,j) )

            rm22(i,j) = -( drjacdxi * dxdeta * rm2(i,j) +
     &                     d2xdxideta * rjac(i,j) * rm2(i,j) +
     &                     drjacdeta * dxdeta * rn2(i,j) +
     &                     d2xdeta2 * rjac(i,j) * rn2(i,j) )

            rn11(i,j) = -( drjacdxi * dydxi * rm1(i,j) +
     &                     d2ydxi2 * rjac(i,j) * rm1(i,j) +
     &                     drjacdeta * dydxi * rn1(i,j) +
     &                     d2ydxideta * rjac(i,j) * rn1(i,j) )

            rn12(i,j) = -( drjacdxi * dydxi * rm2(i,j) +
     &                     d2ydxi2 * rjac(i,j) * rm2(i,j) +
     &                     drjacdeta * dydxi * rn2(i,j) +
     &                     d2ydxideta * rjac(i,j) * rn2(i,j) )

            rn21(i,j) = drjacdxi * dxdxi * rm1(i,j) +
     &                  d2xdxi2 * rjac(i,j) * rm1(i,j) +
     &                  drjacdeta * dxdxi * rn1(i,j) +
     &                  d2xdxideta * rjac(i,j) * rn1(i,j)

            rn22(i,j) = drjacdxi * dxdxi * rm2(i,j) +
     &                  d2xdxi2 * rjac(i,j) * rm2(i,j) +
     &                  drjacdeta * dxdxi * rn2(i,j) +
     &                  d2xdxideta * rjac(i,j) * rn2(i,j)

            if (j .eq. 1) then
              a = dxbds + one * dbn1
              b = dybds + one * dbn2
              h = sqrt( a**2 + b**2 )
              dads = d2xbds2 + one * d2bn1
              dbds = d2ybds2 + one * d2bn2
              dhds = ( a * dads + b * dbds ) / h
              write(44,30) ss(i), h, a, b, dads, dbds, dhds
            end if

            if (DIAG) then
            if (j .eq. 1) write(70,30) ss(i), dxbds, d2xbds2, dybds, d2ybds2
            if (j .eq. 1) write(71,30) ss(i), bn1(i), dbn1, d2bn1
            if (j .eq. 1) write(72,30) ss(i), bn2(i), dbn2, d2bn2
            end if

            if (j .eq. ny) write(74,30) x(i,j), rm1(i,j), rn1(i,j), rm2(i,j),
     &                                  rn2(i,j), rjac(i,j)
            if (j .eq. ny) write(75,30) x(i,j), rm11(i,j), rm12(i,j),
     &                                  rm21(i,j), rm22(i,j)
            if (j .eq. ny) write(76,30) x(i,j), rn11(i,j), rn12(i,j),
     &                                  rn21(i,j), rn22(i,j)
            if (j .eq. ny) write(77,30) ss(i), d2xds2, d2xbds2, d2bn1
            if (j .eq. ny) write(78,30) ss(i), d2yds2, d2ybds2, d2bn2

            g11x(i,j) = d2xdxi2
            g11y(i,j) = d2ydxi2
            g12x(i,j) = d2xdxideta
            g12y(i,j) = d2ydxideta
            g22x(i,j) = d2xdeta2
            g22y(i,j) = d2ydeta2
          end do
        end do
c
c.... compute the error in the cross derivatives
c
        errn = zero
        errm = zero
        do i = 1, nx
          do j = 1, ny
            errm = errm + ( rm12(i,j) - rm21(i,j) )**2
            errn = errn + ( rn12(i,j) - rn21(i,j) )**2
          end do
        end do
        write(*,*) 'Error in m ',sqrt(errm)/dble(nx*ny)
        write(*,*) 'Error in n ',sqrt(errn)/dble(nx*ny)
c
c..... diagnostic
c
        if (debug) then
        j = 1
        do i = 1, nx
          write(80,30) ss(i),
     &               (-rm1(i,j)*rm2(i,j)*rm11(i,j) + rm1(i,j)**2*rm12(i,j) -
     &               rm2(i,j)**2*rm12(i,j) + rm1(i,j)*rm2(i,j)*rm22(i,j) ) *
     &               sqrt(rn1(i,j)**2 + rn2(i,j)**2) /
     &               sqrt(rm1(i,j)**2 + rm2(i,j)**2) /
     &               (rm1(i,j)*rn2(i,j)-rm2(i,j)*rn1(i,j)),
     &               (rn1(i,j)*rn2(i,j)*rn11(i,j) - rn1(i,j)**2*rn12(i,j) +
     &               rn2(i,j)**2*rn12(i,j) - rn1(i,j)*rn2(i,j)*rn22(i,j) ) *
     &               sqrt(rm1(i,j)**2 + rm2(i,j)**2) /
     &               sqrt(rn1(i,j)**2 + rn2(i,j)**2) /
     &               (rm1(i,j)*rn2(i,j)-rm2(i,j)*rn1(i,j))
        end do
        end if

c=============================================================================
c       O u t p u t   R e s u l t s
c=============================================================================
c
c.... output in Streett format
c
        open(10,file='field.mean',form='unformatted')
        write(10) nx, ny
        write(10) (((0.0, j=1, ny), i=1,nx), k=1,4)
        write(10) (sngl(ss(i)), i=1,nx)
        write(10) (sngl(rr(j)), j=1,ny)
        write(10) (sngl(cur(i)), i=1,nx)
        close(10)
c
c.... write out some Plot3d files
c
        nz = 1
        write(*,*) 'Writing plot3d files for ',nx, ny, nz
c
c.... write out binary if on an IRIS
c
        if (IRIS) then
          call wgrid(x, y, nx, ny, nz, mx, my, 'grid.bin'//char(0))
          call wdata(rm1, rn1, rm2, rn2, rjac, nx, ny, nz, mx, my,
     &               'm1.bin'//char(0))
          call wdata(rm11, rm12, rm21, rm22, rjac, nx, ny, nz, mx, my,
     &               'm11.bin'//char(0))
          call wdata(rn11, rn12, rn21, rn22, rjac, nx, ny, nz, mx, my,
     &               'n11.bin'//char(0))
          call wdata(g11x, g11y, g12x, g12y, g22x, nx, ny, nz, mx, my,
     &               'grad.bin'//char(0))
        else
c
c.... write out unformatted if on a CRAY
c
          open(unit=10,file='grid.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) (((sngl(x(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(y(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(zero),   i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          if (plot3d) then

          open(unit=10,file='m1.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((sngl( rm1(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl( rn1(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl( rm2(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl( rn2(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rjac(i,j)), i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          open(unit=10,file='m11.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((sngl(rm11(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm12(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm21(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm22(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm1(i,j)*rn1(i,j)+rm2(i,j)*rn2(i,j)),
     &              i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          open(unit=10,file='n11.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((sngl(rn11(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rn12(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rn21(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rn22(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rjac(i,j)), i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          end if
c
c.... write out the metric file (Note the order of i and j are reversed)
c
          open (unit=10, file='metric.dat', form='unformatted',
     &          status='unknown')
          write(10) (( sngl( rm1(i,j)), j=1,ny), i=1,nx),
     &              (( sngl( rm2(i,j)), j=1,ny), i=1,nx),
     &              (( sngl( rn1(i,j)), j=1,ny), i=1,nx),
     &              (( sngl( rn2(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rm11(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rm12(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rm22(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rn11(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rn12(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rn22(i,j)), j=1,ny), i=1,nx)
          close(10)
        end if

        stop
 10     format('Xmin = ',1pe13.6,' Xmax = ',1pe13.6,
     &         ' Smin = ',1pe13.6,' Smax = ',1pe13.6,' S = ',1pe13.6)
 20     format(i5,6(1x,1pe13.6))
 30     format(7(1x,1pe20.13))
        end

c=============================================================================c
        function yloc(x)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
        yloc = sqrt( two * x )

        return
        end

c=============================================================================c
        function xloc(x,ds)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        external rtsec, rtflsp, func

        common /stuff/ AR, rm, rn, xmin, xmax
        common /distance/ darc, x1
c=============================================================================c
        darc = ds
        x1   = x

c       xloc = rtsec(func,x1,xmax,1.0d-8)

        xloc = rtflsp(func,x1,x1+two*ds,1.0d-8)

c       xloc = zbrent(func,x1,x1+two*ds,1.0d-8)

        return
        end

c=============================================================================c
        function func(x)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        external arc

        common /distance/ darc, x1
c=============================================================================c
        func = darc - arc(x1,x)

        return
        end

c=============================================================================c
        function arc(x1,x2)
c=============================================================================c
        implicit double precision (a-h,o-z)
c=============================================================================c
        xi1 = sqrt(x1)
        xi2 = sqrt(x2)

        arc = sqrt(2.0)*0.5*xi2*sqrt(1.0+2.0*xi2**2) +
     &        0.5*log(sqrt(2.0)*xi2 + sqrt(1.0+2.0*xi2**2))

        arc = arc - ( sqrt(2.0)*0.5*xi1*sqrt(1.0+2.0*xi1**2) +
     &        0.5*log(sqrt(2.0)*xi1 + sqrt(1.0+2.0*xi1**2)) )

        return
        end

c=============================================================================c
c       function arc(x1,x2)
c=============================================================================c
c       implicit double precision (a-h,o-z)
c       parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)
c
c       external derivs1, derivs2, RKQCR
c
c       common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
c       s = zero
c       xtmp = one
c
c       if (x1 .eq. x2 ) then
c          arc = zero
c          return
c       end if
c
c       if (x1 .gt. x2) then
c          write(*,*) x1, x2
c          stop 'Error in arc:  x1 > x2'
c       end if
c       if (x1 .lt. xmin) stop 'Error in arc:  x1 < xmin'
c       if (x2 .gt. xmax) stop 'Error in arc:  x2 > xmax'
c
c       if (x1 .le. xtmp) then
c           y1 = sqrt( two * x1 )
c          if (x2 .le. xtmp) then
c             y2 = sqrt( two * x2 )
c          else
c             y2 = sqrt( two * xtmp )
c          end if
c           call ODEINTR(s,1,y1,y2,1.0d-15,(y2-y1)*pt5,
c     &                  1.d-15,nok,nbad,derivs2,RKQCR)
c          if (x2 .gt. xtmp) then
c             call ODEINTR(s,1,xtmp,x2,1.0d-15,(x2-x1)*pt5,
c     &                    1.d-15,nok,nbad,derivs1,RKQCR)
c          end if
c       else
c          call ODEINTR(s,1,x1,x2,1.0d-15,(x2-x1)*pt5,
c     &                 1.d-15,nok,nbad,derivs1,RKQCR)
c       end if
c
c       arc = s
c
c       return
c       end
c
c=============================================================================c
        subroutine derivs1(n,s,x,ds)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
        dydx = one / sqrt( two * x )

        ds = sqrt( one + dydx**2 )

        return
        end

c=============================================================================c
        subroutine derivs2(n,s,y,ds)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
        x = pt5 * y**2

        dxdy = y

        ds = sqrt( dxdy**2 + one )

        return
        end


module sparse_ir_io
    use sparse_ir
    implicit none

    contains

    ! Read sampling points, basis functions
    function read_ir(unit, beta) result(obj)
        integer, intent (in) :: unit
        double precision, intent (in) :: beta

        type(IR) :: obj
        integer :: version
        character(len=100) :: tmp_str

        read(unit,*) tmp_str, version
        if (version == 1) then
            obj = read_v1(unit, beta)
        else
            write(*, *) "Invalid version number", version
            stop "Stopping..."
        end if
    end function

    ! Read sampling points, basis functions (version 1)
    function read_v1(unit, beta) result(obj)
        integer, intent (in) :: unit
        double precision, intent (in) :: beta

        type(IR) :: obj

        character(len=100) :: tmp_str
        integer :: i, l, t, n
        double precision :: rtmp, rtmp2

        double precision :: lambda, eps
        double precision, parameter :: rtol = 1e-20
        integer :: size, ntau, nfreq_f, nfreq_b
        double precision, allocatable :: s(:), tau(:)
        integer, allocatable :: freq_f(:), freq_b(:)
        complex(kind(0d0)), allocatable :: u(:, :)
        complex(kind(0d0)), allocatable :: uhat_f(:, :), uhat_b(:, :)

        read(unit,*) tmp_str, lambda
        read(unit,*) tmp_str, eps

        ! Singular values
        read(unit,*)
        read(unit,*) size
        allocate(s(size))
        do i=1, size
            read(unit, *) s(i)
        end do

        ! Sampling times
        read(unit,*)
        read(unit,*) ntau
        allocate(tau(ntau))
        do i=1, ntau
            read(unit, *) tau(i)
        end do

        ! Basis functions on sampling times
        read(unit,*)
        allocate(u(ntau, size))
        do l = 1, size
            do t = 1, ntau
                read(unit, *) rtmp
                u(t, l) = rtmp
            end do
        end do

        ! Sampling frequencies (F)
        read(unit,*)
        read(unit,*) nfreq_f
        allocate(freq_f(nfreq_f))
        do i=1, nfreq_f
            read(unit, *) freq_f(i)
        end do

        read(unit,*)
        allocate(uhat_f(nfreq_f, size))
        do l = 1, size
            do n = 1, nfreq_f
                read(unit, *) rtmp, rtmp2
                uhat_f(n, l) = cmplx(rtmp, rtmp2, kind(0d0))
            end do
        end do

        ! Sampling frequencies (B)
        read(unit,*)
        read(unit,*) nfreq_b
        allocate(freq_b(nfreq_b))
        do i=1, nfreq_b
            read(unit, *) freq_b(i)
        end do

        read(unit,*)
        allocate(uhat_b(nfreq_b, size))
        do l = 1, size
            do n = 1, nfreq_b
                read(unit, *) rtmp, rtmp2
                uhat_b(n, l) = cmplx(rtmp, rtmp2, kind(0d0))
            end do
        end do

        call init_ir(obj, beta, lambda, eps, s, tau, freq_f, freq_b, u, uhat_f, uhat_b, 1d-16)

        deallocate(u, uhat_f, uhat_b)
    end function

end module


      SUBROUTINE STRM61
C
C
C   PHASE I OF  STRESS DATA RECOVERY FOR TRIANGULAR MEMBRANE ELEMENT TRI
C
C   OUTPUTS FROM THIS PHASE FOR USE IN PHASE II ARE THE FOLLOWING
C
C   1) ELEMENT ID             WORDS    1    STORAGE IN PH1OUT   1
C   2) SIX SILS               WORDS    6                        2-7
C   3) THICKNESS T1           WORDS    1                        8
C   4) THICKNESS T2           WORDS    1                        9
C   5) THICKNESS T3           WORDS    1                       10
C   6) REFERENCE TEMP T0      WORDS    1                       11
C   7) S SUB I MATRICES       WORDS    216                     12-227
C   8) THERMAL VECTOR G ALF   WORDS    3                      228-230
C
C    EST ENTRIES SAME AS IN SUBROUTINE KTRM6S
C
C
      REAL NSM,IVECT,JVECT,KVECT
C
      DIMENSION IEST(45),IND(6,3),EE1(6),NPH1OU(990),XC(6),YC(6),ZC(6)
     1,   Q(6,6),QQ(36),IVECT(3),JVECT(3),KVECT(3),E( 6 ),EPH1(6)
     2,   NAME(2),ICS(6),NL(6),TRANS(9),BALOTR(9),EMOD(9),TM(3,12)
     3,   TMM(36)
C
      COMMON /SDR2X5/ EST(100),PH1OUT(250)
      COMMON /MATIN / MATID,MATFLG,ELTEMP,PLA34,SINTH,COSTH
      COMMON /MATOUT/ EM(6),RHOY,ALF(3),TREF,GSUBE,SIGTY,SIGCY,SIGSY
C
      EQUIVALENCE (NPH1OU(1),PH1OUT(1)),(IEST(1),EST(1))
      EQUIVALENCE (TM(1,1),TMM(1))
C
      DATA NAME /4HSTRM,4H61  / , BLANK  /4H    /
      DATA DEGRA /0.0174532925/
C
      IDELE=IEST(1)
      DO 109 I=1,6
      NL(I)=IEST(I+1)
  109 CONTINUE
      THETAM=EST(8)
      MATID1=IEST(9)
      TMEM1 =EST(10)
      TMEM3 =EST(11)
      TMEM5 =EST(12)
C
C   IF TMEM3 OR TMEM5 IS 0.0 OR BLANK , IT WILL BE SET EQUAL TO TMEM1
C
      IF (TMEM3.EQ.0.0. OR .TMEM3.EQ.BLANK)  TMEM3 = TMEM1
C
      IF (TMEM5.EQ.0.0. OR .TMEM5.EQ.BLANK)  TMEM5 = TMEM1
C
      NSM = EST(13)
C
      J=0
      DO 120 I=14,34,4
      J=J+1
      ICS(J)=IEST(I)
      XC(J) = EST(I+1)
      YC(J) = EST(I+2)
      ZC(J)=EST(I+3)
  120 CONTINUE
      ELTEMP=(EST(38)+EST(39)+EST(40)+EST(41)+EST(42)+EST(43))/6.0
      THETA1=THETAM*DEGRA
      SINTH=SIN(THETA1)
      COSTH=COS(THETA1)
      IF (ABS(SINTH).LE.1.0E-06) SINTH=0.0
C
C
C   EVALUATE MATERIAL PROPERTIES
C
      MATFLG = 2
      MATID  = MATID1
      CALL MAT (IDELE)
      TO=TREF
C
C   CALCULATIONS FOR THE TRIANGLE
C
      CALL TRIF (XC,YC,ZC,IVECT,JVECT,KVECT,DISTA,DISTB,DISTC,IEST(1),
     1           NAME)
C
C   TRANSFORMATION MATRIX BETWEEN ELEMENT AND BASIC CO-ORDINATES
C
      E(1)=IVECT(1)
      E(2)=JVECT(1)
      E(3)=IVECT(2)
      E(4)=JVECT(2)
      E(5)=IVECT(3)
      E(6)=JVECT(3)
C
C   CALCULATIONS FOR  Q MATRIX AND ITS INVERSE
C
      DO 110 I=1,6
      DO 110 J=1,6
      Q(I,J)=0.0
  110 CONTINUE
      DO 115 I=1,6
      Q(I,1)=1.0
      Q(I,2)=XC(I)
      Q(I,3)=YC(I)
      Q(I,4)=XC(I)*XC(I)
      Q(I,5)=XC(I)*YC(I)
      Q(I,6)=YC(I)*YC(I)
  115 CONTINUE
C
C     FIND INVERSE OF Q  MATRIX
C
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
      ISING = -1
      CALL INVERS (6,Q,6,QQ(1),0,DETERM,ISING,IND)
C
C   ISING EQUAL TO 2 IMPLIES THAT Q MATRIX IS SINGULAR
C
      DO 152 I=1,6
      DO 152 J=1,6
      IJ=(I-1)*6+J
      QQ(IJ)=Q(I,J)
  152 CONTINUE
      DO 154 I=1,9
      BALOTR(I)=0.0
  154 CONTINUE
C
      DO 102 I=1,7
      PH1OUT(I)=EST(I)
  102 CONTINUE
      PH1OUT(8)=EST(10)
      PH1OUT(9)=EST(11)
      PH1OUT(10)=EST(12)
      PH1OUT(11)=TO
      EMOD(1)=EM(1)
      EMOD(2)=EM(2)
      EMOD(3)=EM(3)
      EMOD(4)=EM(2)
      EMOD(5)=EM(4)
      EMOD(6)=EM(5)
      EMOD(7)=EM(3)
      EMOD(8)=EM(5)
      EMOD(9)=EM(6)
C
C   STRESSES AND STRAINS ARE EVALUATED AT FOUR POINTS ,VIZ., THE THREE
C   CORNER GRID POINTS AND THE CENTROID
C
      DO 700 JJ=1,4
      J=2*(JJ-1)+1
      IF (J.EQ.7) GO TO 103
      X=XC(J)
      Y=YC(J)
      GO TO 104
  103 X=(XC(1)+XC(3)+XC(5))/3.0
      Y=(YC(1)+YC(3)+YC(5))/3.0
  104 CONTINUE
      DO 105 I=1,36
      TMM(I)=0.0E0
  105 CONTINUE
C
C   TM MATRIX IS THE PRODUCT OF B AND QINVERSE MATRICES
C
      DO 258 J=1,6
      J1=(J-1)*2+1
      J2=J1+1
      TM(1,J1)=Q(2,J)+2.0*X*Q(4,J)+Y*Q(5,J)
      TM(2,J2)=Q(3,J)+X*Q(5,J)+2.0*Y*Q(6,J)
      TM(3,J1)=TM(2,J2)
      TM(3,J2)=TM(1,J1)
  258 CONTINUE
      DO 600 II=1,6
      IF (ICS(II).EQ.0) GO TO 130
      CALL TRANSS (IEST(4*II+10),TRANS)
      CALL GMMATS (E,3,2,+1,TRANS,3,3,0,EE1)
      GO TO 133
  130 CONTINUE
      DO 132 I=1,3
      DO 132 J=1,2
      I1=(I-1)*2+J
      J1=(J-1)*3+I
      EE1(J1)=E(I1)
  132 CONTINUE
  133 CONTINUE
      IJ1=(JJ-1)*54+(II-1)*9+12
      MZ=(II-1)*6+1
      CALL GMMATS (EMOD,3,3,0,TMM(MZ),2,3,+1,EPH1)
      CALL GMMATS (EPH1,3,2,0,EE1,2,3,0,PH1OUT(IJ1))
  600 CONTINUE
  700 CONTINUE
      CALL GMMATS (EMOD,3,3,0,ALF,3,1,0,PH1OUT(228))
      RETURN
      END


! ------------------------
! Thermodynamic Properties
! ------------------------
Module thermo_props  !
   Implicit None

Contains
        Subroutine mean_molecular_weight(X, M, MM)
                real(8), intent(in) :: X(21), M(21)
                real(8), intent(out) :: MM
                integer :: i

                MM = 0
                do i = 1, size(X)
                MM = MM + X(i) * M(i)
                end do
                MM = MM / 1000 ! Translate to Kilograms
        End Subroutine mean_molecular_weight

   Subroutine zeta(delta, Ar, z)
      real(8), intent(in) :: delta, Ar(3, 3)
      real(8), intent(out) :: z
      z = 1.d0 + delta * Ar(2, 1)
   End Subroutine zeta

   Subroutine isochoric_heat(tau, R, Ao, Ar, cv)
      real(8), intent(in) :: tau, R, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: cv

      cv = - tau ** 2.d0 * (Ao(3, 2) + Ar(3, 2))
      cv = cv * R
   End Subroutine isochoric_heat

   Subroutine isobaric_heat(delta, tau, R, Ao, Ar, cp)
      real(8), intent(in) :: delta, tau, R, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: cp
      real(8) :: up, down

      up = (1.d0 + delta * Ar(2, 1) - delta * tau * Ar(3, 3)) ** 2.d0
      down = 1.d0 + 2.d0 * delta * Ar(2, 1) + delta ** 2.d0 * Ar(3, 1)

      cp = - tau ** 2.d0 * (Ao(3, 2) + Ar(3, 2)) + up / down
      cp = cp * R
   End Subroutine isobaric_heat

   Subroutine sound_speed(delta, tau, R, T, M, Ao, Ar, w)
      real(8), intent(in) :: delta, tau, R, T, M, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: w
      real(8) :: up, down

      up = (1.d0 + delta * Ar(2, 1) - delta * tau * Ar(3, 3)) ** 2
      down = (tau ** 2 * (Ao(3, 2) + Ar(3, 2)))

      w = 1.d0 + 2.d0 * delta * Ar(2, 1) + delta ** 2 * Ar(3, 1) - up / down
      w = sqrt(w * R * T / M)
   End Subroutine sound_speed

   Subroutine isothermal_thermal_coefficent(delta, tau, rho, Ar, delta_t)
      real(8), intent(in) :: delta, Ar(3, 3), tau, rho
      real(8), intent(out) :: delta_t
      real(8) :: up, down

      up = 1.d0 + delta * Ar(2, 1) - delta * tau * Ar(3, 3)
      down = 1.d0 + 2.d0 * delta * Ar(2, 1) + delta ** 2 * Ar(3, 1)

      delta_t = (1.d0 - up / down) / rho
   End Subroutine isothermal_thermal_coefficent

   Subroutine dp_dt(rho, delta, tau, R, Ar, dpdt)
      real(8), intent(in) :: delta, R, rho, tau
      real(8), intent(out) :: dpdt
      real(8), dimension(3, 3), intent(in) :: Ar

      dpdt = rho * R * (1.d0 + delta * Ar(2, 1) - delta * tau * Ar(3, 3))

   End Subroutine dp_dt

   Subroutine dp_drho(T, delta, R, Ar, dpdrho)
      real(8), intent(in) :: delta, R, T
      real(8), intent(out) :: dpdrho
      real(8), dimension(3, 3), intent(in) :: Ar

      dpdrho = R * T * (1.d0 + 2.d0 * delta * Ar(2, 1) + (delta ** 2) * Ar(3, 1))

   End Subroutine dp_drho

   Subroutine dp_dv(rho, delta, T, R, Ar, dpdv) ! !Recordar que acá hablamos de volumen molar!!
      real(8), intent(in) :: delta, R, rho, T
      real(8), intent(out) :: dpdv
      real(8), dimension(3, 3), intent(in) :: Ar

      dpdv = - (rho ** 2) * R * T * (1.d0 + 2.d0 * delta * Ar(2, 1) + (delta ** 2) * Ar(3, 1))

   End Subroutine dp_dv

   Subroutine pressure(delta, rho, R, T, Ar, p)
      real(8), intent(in) :: delta, rho, R, T, Ar(3, 3)
      real(8), intent(out) :: p
      real(8) :: z

      call zeta(delta, Ar, z)
      p = z * (rho * 1000.d0) * R * T
   End Subroutine pressure

   Subroutine entropy(tau, R, Ao, Ar, s)
      real(8), intent(in) :: tau, R, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: s

      s = (tau * (Ao(2, 2) + Ar(2, 2)) - Ao(1, 1) - Ar(1, 1)) * R
   End Subroutine entropy

   Subroutine internal_energy(tau, R, T, Ao, Ar, u)
      real(8), intent(in) :: tau, R, T, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: u

      u = tau * (Ao(2, 2) + Ar(2, 2)) * R * T
   End Subroutine internal_energy

   Subroutine enthalpy(delta, tau, R, T, Ao, Ar, h)
      real(8), intent(in) :: delta, tau, R, T, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: h

      h = ((1.d0 + tau * (Ao(2, 2) + Ar(2, 2)) + delta * Ar(2, 1))) * R * T
   End Subroutine enthalpy

   Subroutine gibbs_free_energy(delta, R, T, Ao, Ar, g)
      real(8), intent(in) :: delta, R, T, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: g

      g = (1.d0 + Ao(1, 1) + Ar(1, 1) + delta * Ar(2, 1)) * R * T
   End Subroutine gibbs_free_energy

   Subroutine joule_thomson_coeff(delta, tau, rho, R, Ao, Ar, JT)
      real(8), intent(in) :: delta, tau, rho, R, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: JT
      real(8) :: up, down_1, down_2

      up = - (delta * Ar(2, 1) + delta ** 2 * Ar(3, 1) + delta * tau * Ar(3, 3))
      down_1 = (1.d0 + delta * Ar(2, 1) - delta * tau * Ar (3, 3)) ** 2
      down_2 = - tau ** 2 * (Ao(3, 2) + Ar(3, 2)) * (1.d0 + 2.d0 * delta * Ar(2, 1) + delta ** 2 * Ar(3, 1))

      JT = up / (down_1 + down_2) / (R * rho * 1000)

   End Subroutine joule_thomson_coeff

   Subroutine isentropic_exponent(delta, tau, Ao, Ar, k)
      real(8), intent(in) :: delta, tau, Ao(3, 3), Ar(3, 3)
      real(8), intent(out) :: k
      real(8) :: up1, down1, up2, down2

      up1 = 1.d0 + 2 * delta * Ar(2, 1) + delta ** 2 * Ar(3, 1)
      down1 = 1.d0 + delta * Ar(2, 1)
      up2 = (1.d0 + delta * Ar(2, 1) - delta * tau * Ar(2, 3)) ** 2
      down2 = tau ** 2 * (Ao(3, 2) + Ar(2, 2)) * (1.d0 + 2.d0 * delta * Ar(2, 1) + delta ** 2 * Ar(3, 2))

      k = (up1 / down1) * (1.d0 - up2 / down2)
   End Subroutine isentropic_exponent

   Subroutine second_thermal_virial_coeff(rho_r, Ar, B)
      real(8), intent(in) :: rho_r, Ar(3, 3)
      real(8), intent(out) :: B
      real(8) :: delta

      delta = 1d-15
      B = Ar(2, 1) / rho_r
   End Subroutine second_thermal_virial_coeff

   Subroutine third_thermal_virial_coeff(rho_r, Ar, C)
      real(8), intent(in) :: rho_r, Ar(3, 3)
      real(8), intent(out) :: C
      real(8) :: delta

      delta = 1d-15
      C = Ar(3, 1) / (rho_r ** 2)
   End Subroutine third_thermal_virial_coeff

   Subroutine helmholtz_per_mol(x, delta, tau, rho_r, T_r, ar, ar_x, ar_dx, &
                                v_r_x, T_r_x, dar_dn, dadr_dn)
           real(8), intent(in) :: x(21), delta, tau, rho_r, T_r, &
                   ar(3, 3), ar_x(21), ar_dx(21), v_r_x(21), T_r_x(21)
           real(8), dimension(21), intent(out) :: dar_dn, dadr_dn
           real(8), dimension(21) :: drhor_dn, dtr_dn
           integer :: i

           dar_dn = 0.d0
           dadr_dn = 0.d0

           drhor_dn = - rho_r ** 2 * v_r_x
           dtr_dn = v_r_x

           do i = 1, size(dtr_dn)
                drhor_dn = drhor_dn - (- x(i) * (- rho_r ** 2 * v_r_x(i)))
                dtr_dn = dtr_dn - x(i) * t_r_x(i)
           end do

           dar_dn = delta * ar(2, 1) * (1.d0 - 1.d0 / rho_r * dtr_dn)
           dar_dn = dar_dn + tau * ar(2, 2) / T_r * dtr_dn + ar_x

           dadr_dn = delta * ar(3, 1) * (1.d0 - 1.d0 / rho_r * dtr_dn)
           dadr_dn = dadr_dn + tau * ar(3, 3) / T_r * dtr_dn + ar_dx

           do i = 1, size(dtr_dn)
                   dar_dn = dar_dn - X(i) * ar_x(i)
                   dadr_dn = dadr_dn - X(i) * ar_dx(i)
           end do
   End Subroutine helmholtz_per_mol

End Module thermo_props


subroutine Poisson_2D_double_precision(Lx,Ly,Nnx,Nny,lambda,f,chii)

! Include modules defined by mkl_poisson.f90 and mkl_dfti.f90 header files
! use mkl_poisson

implicit none
integer, intent(in) :: Nnx,Nny
real(8), intent(in) :: Lx,Ly,lambda
real(8), dimension(Nnx,Nny), intent(inout)  :: f
real(8), dimension(Nnx,Nny), intent(out) :: chii

double precision pi
parameter(pi=3.14159265358979324D0)

integer nx, ny, stat
integer AA
DOUBLE PRECISION ptrb
double precision ax, bx, ay, by, q
double precision bd_ax(Nny), bd_bx(Nny), bd_ay(Nnx), bd_by(Nnx)
!double precision dpar(13*(Nnx-1)/2+7)
DOUBLE PRECISION, allocatable,dimension (:) :: workarea
!type(DFTI_DESCRIPTOR), pointer :: xhandle
character(4) BCtype

nx=Nnx-1
ny=Nny-1
AA = (1./log(2.))*log(1.0 * Nnx)
ALLOCATE(workarea(4*(Nnx) + (13 + nx)*(Nny)))
! Defining the rectangular domain 0<x<Lx, 0<y<Ly for 2D Poisson Solver
ax=0.0D0
bx=Lx
ay=0.0D0
by=Ly

!*******************************************************************************
! Setting the coefficient q to 0.
! Note that this is the way to use Helmholtz Solver to solve Poisson problem!
!*******************************************************************************
q=-(lambda*lambda)

!******************************************************************************
! NOTE THE SIGN CONVENTION USED FOR THE POISSON EQUATION!!!!!!!!!!!!!!!!!!!!!!!
!******************************************************************************

!******************************************************************************
! BOUNDARY CONDITIONS
!******************************************************************************
BCtype = 'DDDD'
bd_ax(:) = 0.0D0
bd_bx(:) = 0.0D0
bd_ay(:) = 0.0D0
bd_by(:) = 0.0D0

f(1,:) = -chii(1,:)
f(Nnx,:) = -chii(Nnx,:)
f(:,1) = -chii(:,1)
f(:,Nny) = -chii(:,Nny)
! NOTE:
!print *, ' The SOLUTION depends NOT on boundary values of the rhs for Dirichlet !!!!!!!!!!!!!!'
!f(1,:) = 1.d10
!write(*,*) f(1,:)
!print *, ' The SOLUTION depends on boundary values of the rhs for Neumann !!!!!!!!!!!!!!!!!!!!'
!f(:,1) = 1.d10
!write(*,*) f(:,1)
f = -1.0d0 * f

ptrb = 0.0d0
CALL HWSCRT(&
&    ax, bx, nx, 1, bd_ax, bd_bx, &
&    ay, by, ny, 1, bd_ay, bd_by, &
&    q, &
&    f, nx+1,&
&    ptrb, stat, workarea &
&)

!print *, f
DEALLOCATE(workarea)
! Now we can use xhandle to solve another 2D Poisson problem
chii = f

! Free MKL memory if any was allocated
!call mkl_free_buffers

end

subroutine mkl_set_dynamic(input)
implicit none
integer, intent(in) :: input

end subroutine

subroutine mkl_set_num_threads(input)
implicit none
integer, intent(in) :: input

end subroutine


CU    SUBROUTINE shootf(n,v,f) is named "funcv" for use with "newt"
      SUBROUTINE funcv(n,v,f)
      INTEGER n,nvar,nn2,kmax,kount,KMAXX,NMAX
      REAL f(n),v(n),x1,x2,xf,dxsav,xp,yp,EPS
      PARAMETER (NMAX=50,KMAXX=200,EPS=1.e-6)
      COMMON /caller/ x1,x2,xf,nvar,nn2
      COMMON /path/ kmax,kount,dxsav,xp(KMAXX),yp(NMAX,KMAXX)
CU    USES derivs,load1,load2,odeint,rkqs,score
      INTEGER i,nbad,nok
      REAL h1,hmin,f1(NMAX),f2(NMAX),y(NMAX)
      EXTERNAL derivs,rkqs
      kmax=0
      h1=(x2-x1)/100.
      hmin=0.
      call load1(x1,v,y)
      call odeint(y,nvar,x1,xf,EPS,h1,hmin,nok,nbad,derivs,rkqs)
      call score(xf,y,f1)
      call load2(x2,v(nn2+1),y)
      call odeint(y,nvar,x2,xf,EPS,h1,hmin,nok,nbad,derivs,rkqs)
      call score(xf,y,f2)
      do 11 i=1,n
        f(i)=f1(i)-f2(i)
11    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/shootf.for


module name0
      use stel_kinds, only: dp
      implicit none

      real(kind=dp), parameter :: zerod  = 0.0e+00_dp
      real(kind=dp), parameter :: oned   = 1.0e+00_dp

      real(kind=dp), parameter :: czero  = zerod
      real(kind=dp), parameter :: c1pm13 = 1.0e-13_dp
      real(kind=dp), parameter :: c1pm10 = 1.0e-10_dp
      real(kind=dp), parameter :: c2pm8  = 2.0e-08_dp
      real(kind=dp), parameter :: cp15   = 1.5e-01_dp
      real(kind=dp), parameter :: cp25   = 2.5e-01_dp
      real(kind=dp), parameter :: cp5    = 5.0e-01_dp
      real(kind=dp), parameter :: cp707d = 7.071e-01_dp ! TODO: should be 1/sqrt(2)
      real(kind=dp), parameter :: cp9    = 9.0e-01_dp
      real(kind=dp), parameter :: cp96   = 9.6e-01_dp
      real(kind=dp), parameter :: c1p0   = oned
      real(kind=dp), parameter :: c1p1   = 1.1e+00_dp
      real(kind=dp), parameter :: c1p4   = 1.4e+00_dp
      real(kind=dp), parameter :: c1p5   = 1.5e+00_dp
      real(kind=dp), parameter :: c2p0   = 2.0e+00_dp
      real(kind=dp), parameter :: c3p0   = 3.0e+00_dp
      real(kind=dp), parameter :: c8p0   = 8.0e+00_dp
      real(kind=dp), parameter :: c100p  = 1.0e+02_dp
end module name0


      subroutine cfft(n1,n2,n3,chdr,chdi,wrk,lwrk,mode)
c
c     computes complex 3d fft of chd
c     $Id: cfft.f,v 1.1.1.1 1992/05/08 19:44:47 jimb Exp $
c
c     $Log: cfft.f,v $
c Revision 1.1.1.1  1992/05/08  19:44:47  jimb
c
c     Revision 1.1  89/03/11  19:09:31  sverre
c     Initial revision
c
c
      implicit DOUBLE PRECISION(a-h,o-z)
      dimension chdr(n1,n2,n3),chdi(n1,n2,n3),wrk(1)
c     level 2, chdr,chdi
c
c I   n1,n2,n3            grid size
c IO  chd(r,i)(i,j,k)     i=1,n1,j=1,n2,k=1,n3.
c     .                   array to be fourier transformed
c     wrk(i)              i=1,6*max(n1,n2,n3)+15
c     .                   work array
c     lwrk                length of wrk
c I   mode                determines transform mode
c     .                   mode > 0   forward
c     .                   mode < 0   backward
c
c     rcs id string - allows use of ident to identify binaries
c
      character rcsid*50
      rcsid = '$RCSfile: cfft.f,v $$Revision: 1.1.1.1 $'
c
      np = 2 * max0(n1,n2,n3) + 1
      if (lwrk .lt. 3 * np + 12) then
	write (*,*) 'work array in cfft is too short'
	stop
      end if

      call dcffti(n3,wrk(np))
      do 130 i=1,n1
         do 120 j=1,n2
cdir$       ivdep
            do 100 k=1,n3
               wrk(2*k-1) = chdr(i,j,k)
               wrk(2*k)   = chdi(i,j,k)
  100       continue
            if (mode .gt. 0) call dcfftf(n3,wrk,wrk(np))
            if (mode .lt. 0) call dcfftb(n3,wrk,wrk(np))
            do 110 k=1,n3
               chdr(i,j,k) = wrk(2*k-1)
               chdi(i,j,k) = wrk(2*k)
  110       continue
  120    continue
  130 continue
      if (n2 .ne. n3) call dcffti(n2,wrk(np))
      do 170 i=1,n3
         do 160 j=1,n1
cdir$       ivdep
            do 140 k=1,n2
               wrk(2*k-1) = chdr(j,k,i)
               wrk(2*k)   = chdi(j,k,i)
  140       continue
            if (mode .gt. 0) call dcfftf(n2,wrk,wrk(np))
            if (mode .lt. 0) call dcfftb(n2,wrk,wrk(np))
            do 150 k=1,n2
               chdr(j,k,i) = wrk(2*k-1)
               chdi(j,k,i) = wrk(2*k)
  150       continue
  160    continue
  170 continue
      if (n1 .ne. n2) call dcffti(n1,wrk(np))
      do 210 i=1,n2
         do 200 j=1,n3
cdir$       ivdep
            do 180 k=1,n1
               wrk(2*k-1) = chdr(k,i,j)
               wrk(2*k)   = chdi(k,i,j)
  180       continue
            if (mode .gt. 0) call dcfftf(n1,wrk,wrk(np))
            if (mode .lt. 0) call dcfftb(n1,wrk,wrk(np))
            do 190 k=1,n1
               chdr(k,i,j) = wrk(2*k-1)
               chdi(k,i,j) = wrk(2*k)
  190       continue
  200    continue
  210 continue
c
c     normalize
c
ccc      if (mode .lt. 0) return
      if (mode .gt. 0) return
      factor = 1.D0 / DBLE(n1*n2*n3)
      do 240 i=1,n1
         do 230 j=1,n2
            do 220 k=1,n3
               chdr(i,j,k) = factor * chdr(i,j,k)
               chdi(i,j,k) = factor * chdi(i,j,k)
  220       continue
  230    continue
  240 continue
      return
      end


!*==zgesvxx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGESVXX computes the solution to system of linear equations A * X = B for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGESVXX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
!                           EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW,
!                           BERR, N_ERR_BNDS, ERR_BNDS_NORM,
!                           ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK,
!                           INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          EQUED, FACT, TRANS
!       INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
!      $                   N_ERR_BNDS
!       DOUBLE PRECISION   RCOND, RPVGRW
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
!      $                   X( LDX , * ),WORK( * )
!       DOUBLE PRECISION   R( * ), C( * ), PARAMS( * ), BERR( * ),
!      $                   ERR_BNDS_NORM( NRHS, * ),
!      $                   ERR_BNDS_COMP( NRHS, * ), RWORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    ZGESVXX uses the LU factorization to compute the solution to a
!>    complex*16 system of linear equations  A * X = B,  where A is an
!>    N-by-N matrix and X and B are N-by-NRHS matrices.
!>
!>    If requested, both normwise and maximum componentwise error bounds
!>    are returned. ZGESVXX will return a solution with a tiny
!>    guaranteed error (O(eps) where eps is the working machine
!>    precision) unless the matrix is very ill-conditioned, in which
!>    case a warning is returned. Relevant condition numbers also are
!>    calculated and returned.
!>
!>    ZGESVXX accepts user-provided factorizations and equilibration
!>    factors; see the definitions of the FACT and EQUED options.
!>    Solving with refinement and using a factorization from a previous
!>    ZGESVXX call will also produce a solution with either O(eps)
!>    errors or warnings, but we cannot make that claim for general
!>    user-provided factorizations and equilibration factors if they
!>    differ from what ZGESVXX would itself produce.
!> \endverbatim
!
!> \par Description:
!  =================
!>
!> \verbatim
!>
!>    The following steps are performed:
!>
!>    1. If FACT = 'E', double precision scaling factors are computed to equilibrate
!>    the system:
!>
!>      TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
!>      TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
!>      TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
!>
!>    Whether or not the system will be equilibrated depends on the
!>    scaling of the matrix A, but if equilibration is used, A is
!>    overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
!>    or diag(C)*B (if TRANS = 'T' or 'C').
!>
!>    2. If FACT = 'N' or 'E', the LU decomposition is used to factor
!>    the matrix A (after equilibration if FACT = 'E') as
!>
!>      A = P * L * U,
!>
!>    where P is a permutation matrix, L is a unit lower triangular
!>    matrix, and U is upper triangular.
!>
!>    3. If some U(i,i)=0, so that U is exactly singular, then the
!>    routine returns with INFO = i. Otherwise, the factored form of A
!>    is used to estimate the condition number of the matrix A (see
!>    argument RCOND). If the reciprocal of the condition number is less
!>    than machine precision, the routine still goes on to solve for X
!>    and compute error bounds as described below.
!>
!>    4. The system of equations is solved for X using the factored form
!>    of A.
!>
!>    5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
!>    the routine will use iterative refinement to try to get a small
!>    error and error bounds.  Refinement calculates the residual to at
!>    least twice the working precision.
!>
!>    6. If equilibration was used, the matrix X is premultiplied by
!>    diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
!>    that it solves the original system before equilibration.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \verbatim
!>     Some optional parameters are bundled in the PARAMS array.  These
!>     settings determine how refinement is performed, but often the
!>     defaults are acceptable.  If the defaults are acceptable, users
!>     can pass NPARAMS = 0 which prevents the source code from accessing
!>     the PARAMS argument.
!> \endverbatim
!>
!> \param[in] FACT
!> \verbatim
!>          FACT is CHARACTER*1
!>     Specifies whether or not the factored form of the matrix A is
!>     supplied on entry, and if not, whether the matrix A should be
!>     equilibrated before it is factored.
!>       = 'F':  On entry, AF and IPIV contain the factored form of A.
!>               If EQUED is not 'N', the matrix A has been
!>               equilibrated with scaling factors given by R and C.
!>               A, AF, and IPIV are not modified.
!>       = 'N':  The matrix A will be copied to AF and factored.
!>       = 'E':  The matrix A will be equilibrated if necessary, then
!>               copied to AF and factored.
!> \endverbatim
!>
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>     Specifies the form of the system of equations:
!>       = 'N':  A * X = B     (No transpose)
!>       = 'T':  A**T * X = B  (Transpose)
!>       = 'C':  A**H * X = B  (Conjugate Transpose)
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>     The number of right hand sides, i.e., the number of columns
!>     of the matrices B and X.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is
!>     not 'N', then A must have been equilibrated by the scaling
!>     factors in R and/or C.  A is not modified if FACT = 'F' or
!>     'N', or if FACT = 'E' and EQUED = 'N' on exit.
!>
!>     On exit, if EQUED .ne. 'N', A is scaled as follows:
!>     EQUED = 'R':  A := diag(R) * A
!>     EQUED = 'C':  A := A * diag(C)
!>     EQUED = 'B':  A := diag(R) * A * diag(C).
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] AF
!> \verbatim
!>          AF is COMPLEX*16 array, dimension (LDAF,N)
!>     If FACT = 'F', then AF is an input argument and on entry
!>     contains the factors L and U from the factorization
!>     A = P*L*U as computed by ZGETRF.  If EQUED .ne. 'N', then
!>     AF is the factored form of the equilibrated matrix A.
!>
!>     If FACT = 'N', then AF is an output argument and on exit
!>     returns the factors L and U from the factorization A = P*L*U
!>     of the original matrix A.
!>
!>     If FACT = 'E', then AF is an output argument and on exit
!>     returns the factors L and U from the factorization A = P*L*U
!>     of the equilibrated matrix A (see the description of A for
!>     the form of the equilibrated matrix).
!> \endverbatim
!>
!> \param[in] LDAF
!> \verbatim
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>     If FACT = 'F', then IPIV is an input argument and on entry
!>     contains the pivot indices from the factorization A = P*L*U
!>     as computed by ZGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
!>     If FACT = 'N', then IPIV is an output argument and on exit
!>     contains the pivot indices from the factorization A = P*L*U
!>     of the original matrix A.
!>
!>     If FACT = 'E', then IPIV is an output argument and on exit
!>     contains the pivot indices from the factorization A = P*L*U
!>     of the equilibrated matrix A.
!> \endverbatim
!>
!> \param[in,out] EQUED
!> \verbatim
!>          EQUED is CHARACTER*1
!>     Specifies the form of equilibration that was done.
!>       = 'N':  No equilibration (always true if FACT = 'N').
!>       = 'R':  Row equilibration, i.e., A has been premultiplied by
!>               diag(R).
!>       = 'C':  Column equilibration, i.e., A has been postmultiplied
!>               by diag(C).
!>       = 'B':  Both row and column equilibration, i.e., A has been
!>               replaced by diag(R) * A * diag(C).
!>     EQUED is an input argument if FACT = 'F'; otherwise, it is an
!>     output argument.
!> \endverbatim
!>
!> \param[in,out] R
!> \verbatim
!>          R is DOUBLE PRECISION array, dimension (N)
!>     The row scale factors for A.  If EQUED = 'R' or 'B', A is
!>     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
!>     is not accessed.  R is an input argument if FACT = 'F';
!>     otherwise, R is an output argument.  If FACT = 'F' and
!>     EQUED = 'R' or 'B', each element of R must be positive.
!>     If R is output, each element of R is a power of the radix.
!>     If R is input, each element of R should be a power of the radix
!>     to ensure a reliable solution and error estimates. Scaling by
!>     powers of the radix does not cause rounding errors unless the
!>     result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is DOUBLE PRECISION array, dimension (N)
!>     The column scale factors for A.  If EQUED = 'C' or 'B', A is
!>     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
!>     is not accessed.  C is an input argument if FACT = 'F';
!>     otherwise, C is an output argument.  If FACT = 'F' and
!>     EQUED = 'C' or 'B', each element of C must be positive.
!>     If C is output, each element of C is a power of the radix.
!>     If C is input, each element of C should be a power of the radix
!>     to ensure a reliable solution and error estimates. Scaling by
!>     powers of the radix does not cause rounding errors unless the
!>     result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>     On entry, the N-by-NRHS right hand side matrix B.
!>     On exit,
!>     if EQUED = 'N', B is not modified;
!>     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
!>        diag(R)*B;
!>     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
!>        overwritten by diag(C)*B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>     The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] X
!> \verbatim
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>     If INFO = 0, the N-by-NRHS solution matrix X to the original
!>     system of equations.  Note that A and B are modified on exit
!>     if EQUED .ne. 'N', and the solution to the equilibrated system is
!>     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
!>     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
!> \endverbatim
!>
!> \param[in] LDX
!> \verbatim
!>          LDX is INTEGER
!>     The leading dimension of the array X.  LDX >= max(1,N).
!> \endverbatim
!>
!> \param[out] RCOND
!> \verbatim
!>          RCOND is DOUBLE PRECISION
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!> \endverbatim
!>
!> \param[out] RPVGRW
!> \verbatim
!>          RPVGRW is DOUBLE PRECISION
!>     Reciprocal pivot growth.  On exit, this contains the reciprocal
!>     pivot growth factor norm(A)/norm(U). The "max absolute element"
!>     norm is used.  If this is much less than 1, then the stability of
!>     the LU factorization of the (equilibrated) matrix A could be poor.
!>     This also means that the solution X, estimated condition numbers,
!>     and error bounds could be unreliable. If factorization fails with
!>     0<INFO<=N, then this contains the reciprocal pivot growth factor
!>     for the leading INFO columns of A.  In ZGESVX, this quantity is
!>     returned in WORK(1).
!> \endverbatim
!>
!> \param[out] BERR
!> \verbatim
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>     Componentwise relative backward error.  This is the
!>     componentwise relative backward error of each solution vector X(j)
!>     (i.e., the smallest relative change in any element of A or B that
!>     makes X(j) an exact solution).
!> \endverbatim
!>
!> \param[in] N_ERR_BNDS
!> \verbatim
!>          N_ERR_BNDS is INTEGER
!>     Number of error bounds to return for each right hand side
!>     and each type (normwise or componentwise).  See ERR_BNDS_NORM and
!>     ERR_BNDS_COMP below.
!> \endverbatim
!>
!> \param[out] ERR_BNDS_NORM
!> \verbatim
!>          ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_NORM(:,err) contains the following
!>     three fields:
!>     err = 1 "Trust/don't trust" boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * dlamch('Epsilon').
!>
!>     err = 2 "Guaranteed" error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * dlamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * dlamch('Epsilon') to determine if the error
!>              estimate is "guaranteed". These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!> \endverbatim
!>
!> \param[out] ERR_BNDS_COMP
!> \verbatim
!>          ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_COMP(:,err) contains the following
!>     three fields:
!>     err = 1 "Trust/don't trust" boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * dlamch('Epsilon').
!>
!>     err = 2 "Guaranteed" error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * dlamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * dlamch('Epsilon') to determine if the error
!>              estimate is "guaranteed". These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!> \endverbatim
!>
!> \param[in] NPARAMS
!> \verbatim
!>          NPARAMS is INTEGER
!>     Specifies the number of parameters set in PARAMS.  If <= 0, the
!>     PARAMS array is never referenced and default values are used.
!> \endverbatim
!>
!> \param[in,out] PARAMS
!> \verbatim
!>          PARAMS is DOUBLE PRECISION array, dimension NPARAMS
!>     Specifies algorithm parameters.  If an entry is < 0.0, then
!>     that entry will be filled with default value used for that
!>     parameter.  Only positions up to NPARAMS are accessed; defaults
!>     are used for higher-numbered parameters.
!>
!>       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
!>            refinement or not.
!>         Default: 1.0D+0
!>            = 0.0:  No refinement is performed, and no error bounds are
!>                    computed.
!>            = 1.0:  Use the extra-precise refinement algorithm.
!>              (other values are reserved for future use)
!>
!>       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
!>            computations allowed for refinement.
!>         Default: 10
!>         Aggressive: Set to 100 to permit convergence using approximate
!>                     factorizations or factorizations other than LU. If
!>                     the factorization uses a technique other than
!>                     Gaussian elimination, the guarantees in
!>                     err_bnds_norm and err_bnds_comp may no longer be
!>                     trustworthy.
!>
!>       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
!>            will attempt to find a solution with small componentwise
!>            relative error in the double-precision algorithm.  Positive
!>            is true, 0.0 is false.
!>         Default: 1.0 (attempt componentwise convergence)
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>       = 0:  Successful exit. The solution to every right-hand side is
!>         guaranteed.
!>       < 0:  If INFO = -i, the i-th argument had an illegal value
!>       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization
!>         has been completed, but the factor U is exactly singular, so
!>         the solution and error bounds could not be computed. RCOND = 0
!>         is returned.
!>       = N+J: The solution corresponding to the Jth right-hand side is
!>         not guaranteed. The solutions corresponding to other right-
!>         hand sides K with K > J may not be guaranteed as well, but
!>         only the first such right-hand side is reported. If a small
!>         componentwise error is not requested (PARAMS(3) = 0.0) then
!>         the Jth right-hand side is the first with a normwise error
!>         bound that is not guaranteed (the smallest J such
!>         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
!>         the Jth right-hand side is the first with either a normwise or
!>         componentwise error bound that is not guaranteed (the smallest
!>         J such that either ERR_BNDS_NORM(J,1) = 0.0 or
!>         ERR_BNDS_COMP(J,1) = 0.0). See the definition of
!>         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
!>         about all of the right-hand sides check ERR_BNDS_NORM or
!>         ERR_BNDS_COMP.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date April 2012
!
!> \ingroup complex16GEsolve
!
!  =====================================================================
      SUBROUTINE ZGESVXX(Fact,Trans,N,Nrhs,A,Lda,Af,Ldaf,Ipiv,Equed,R,C,&
     &                   B,Ldb,X,Ldx,Rcond,Rpvgrw,Berr,N_err_bnds,      &
     &                   Err_bnds_norm,Err_bnds_comp,Nparams,Params,    &
     &                   Work,Rwork,Info)
      IMPLICIT NONE
!*--ZGESVXX543
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     April 2012
!
!     .. Scalar Arguments ..
      CHARACTER Equed , Fact , Trans
      INTEGER Info , Lda , Ldaf , Ldb , Ldx , N , Nrhs , Nparams ,      &
     &        N_err_bnds
      DOUBLE PRECISION Rcond , Rpvgrw
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      COMPLEX*16 A(Lda,*) , Af(Ldaf,*) , B(Ldb,*) , X(Ldx,*) , Work(*)
      DOUBLE PRECISION R(*) , C(*) , Params(*) , Berr(*) ,              &
     &                 Err_bnds_norm(Nrhs,*) , Err_bnds_comp(Nrhs,*) ,  &
     &                 Rwork(*)
!     ..
!
!  ==================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL colequ , equil , nofact , notran , rowequ
      INTEGER infequ , j
      DOUBLE PRECISION amax , bignum , colcnd , rcmax , rcmin , rowcnd ,&
     &                 smlnum
!     ..
!     .. External Functions ..
      EXTERNAL LSAME , DLAMCH , ZLA_GERPVGRW
      LOGICAL LSAME
      DOUBLE PRECISION DLAMCH , ZLA_GERPVGRW
!     ..
!     .. External Subroutines ..
      EXTERNAL ZGEEQUB , ZGETRF , ZGETRS , ZLACPY , ZLAQGE , XERBLA ,   &
     &         ZLASCL2 , ZGERFSX
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
      Info = 0
      nofact = LSAME(Fact,'N')
      equil = LSAME(Fact,'E')
      notran = LSAME(Trans,'N')
      smlnum = DLAMCH('Safe minimum')
      bignum = ONE/smlnum
      IF ( nofact .OR. equil ) THEN
         Equed = 'N'
         rowequ = .FALSE.
         colequ = .FALSE.
      ELSE
         rowequ = LSAME(Equed,'R') .OR. LSAME(Equed,'B')
         colequ = LSAME(Equed,'C') .OR. LSAME(Equed,'B')
      ENDIF
!
!     Default is failure.  If an input parameter is wrong or
!     factorization fails, make everything look horrible.  Only the
!     pivot growth is set here, the rest is initialized in ZGERFSX.
!
      Rpvgrw = ZERO
!
!     Test the input parameters.  PARAMS is not tested until ZGERFSX.
!
      IF ( .NOT.nofact .AND. .NOT.equil .AND. .NOT.LSAME(Fact,'F') )    &
     &     THEN
         Info = -1
      ELSEIF ( .NOT.notran .AND. .NOT.LSAME(Trans,'T') .AND.            &
     &         .NOT.LSAME(Trans,'C') ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Nrhs<0 ) THEN
         Info = -4
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -6
      ELSEIF ( Ldaf<MAX(1,N) ) THEN
         Info = -8
      ELSEIF ( LSAME(Fact,'F') .AND.                                    &
     &         .NOT.(rowequ .OR. colequ .OR. LSAME(Equed,'N')) ) THEN
         Info = -10
      ELSE
         IF ( rowequ ) THEN
            rcmin = bignum
            rcmax = ZERO
            DO j = 1 , N
               rcmin = MIN(rcmin,R(j))
               rcmax = MAX(rcmax,R(j))
            ENDDO
            IF ( rcmin<=ZERO ) THEN
               Info = -11
            ELSEIF ( N>0 ) THEN
               rowcnd = MAX(rcmin,smlnum)/MIN(rcmax,bignum)
            ELSE
               rowcnd = ONE
            ENDIF
         ENDIF
         IF ( colequ .AND. Info==0 ) THEN
            rcmin = bignum
            rcmax = ZERO
            DO j = 1 , N
               rcmin = MIN(rcmin,C(j))
               rcmax = MAX(rcmax,C(j))
            ENDDO
            IF ( rcmin<=ZERO ) THEN
               Info = -12
            ELSEIF ( N>0 ) THEN
               colcnd = MAX(rcmin,smlnum)/MIN(rcmax,bignum)
            ELSE
               colcnd = ONE
            ENDIF
         ENDIF
         IF ( Info==0 ) THEN
            IF ( Ldb<MAX(1,N) ) THEN
               Info = -14
            ELSEIF ( Ldx<MAX(1,N) ) THEN
               Info = -16
            ENDIF
         ENDIF
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGESVXX',-Info)
         RETURN
      ENDIF
!
      IF ( equil ) THEN
!
!     Compute row and column scalings to equilibrate the matrix A.
!
         CALL ZGEEQUB(N,N,A,Lda,R,C,rowcnd,colcnd,amax,infequ)
         IF ( infequ==0 ) THEN
!
!     Equilibrate the matrix.
!
            CALL ZLAQGE(N,N,A,Lda,R,C,rowcnd,colcnd,amax,Equed)
            rowequ = LSAME(Equed,'R') .OR. LSAME(Equed,'B')
            colequ = LSAME(Equed,'C') .OR. LSAME(Equed,'B')
         ENDIF
!
!     If the scaling factors are not applied, set them to 1.0.
!
         IF ( .NOT.rowequ ) THEN
            DO j = 1 , N
               R(j) = 1.0D+0
            ENDDO
         ENDIF
         IF ( .NOT.colequ ) THEN
            DO j = 1 , N
               C(j) = 1.0D+0
            ENDDO
         ENDIF
      ENDIF
!
!     Scale the right-hand side.
!
      IF ( notran ) THEN
         IF ( rowequ ) CALL ZLASCL2(N,Nrhs,R,B,Ldb)
      ELSE
         IF ( colequ ) CALL ZLASCL2(N,Nrhs,C,B,Ldb)
      ENDIF
!
      IF ( nofact .OR. equil ) THEN
!
!        Compute the LU factorization of A.
!
         CALL ZLACPY('Full',N,N,A,Lda,Af,Ldaf)
         CALL ZGETRF(N,N,Af,Ldaf,Ipiv,Info)
!
!        Return if INFO is non-zero.
!
         IF ( Info>0 ) THEN
!
!           Pivot in column INFO is exactly 0
!           Compute the reciprocal pivot growth factor of the
!           leading rank-deficient INFO columns of A.
!
            Rpvgrw = ZLA_GERPVGRW(N,Info,A,Lda,Af,Ldaf)
            RETURN
         ENDIF
      ENDIF
!
!     Compute the reciprocal pivot growth factor RPVGRW.
!
      Rpvgrw = ZLA_GERPVGRW(N,N,A,Lda,Af,Ldaf)
!
!     Compute the solution matrix X.
!
      CALL ZLACPY('Full',N,Nrhs,B,Ldb,X,Ldx)
      CALL ZGETRS(Trans,N,Nrhs,Af,Ldaf,Ipiv,X,Ldx,Info)
!
!     Use iterative refinement to improve the computed solution and
!     compute error bounds and backward error estimates for it.
!
      CALL ZGERFSX(Trans,Equed,N,Nrhs,A,Lda,Af,Ldaf,Ipiv,R,C,B,Ldb,X,   &
     &             Ldx,Rcond,Berr,N_err_bnds,Err_bnds_norm,             &
     &             Err_bnds_comp,Nparams,Params,Work,Rwork,Info)
!
!     Scale solutions.
!
      IF ( colequ .AND. notran ) THEN
         CALL ZLASCL2(N,Nrhs,C,X,Ldx)
      ELSEIF ( rowequ .AND. .NOT.notran ) THEN
         CALL ZLASCL2(N,Nrhs,R,X,Ldx)
      ENDIF
!
!
!     End of ZGESVXX
!
      END SUBROUTINE ZGESVXX


module unitdata
!-------------------------------------------------
! Module stores all physical constants, EOS table,
! and other parameters relating to file storage
!--------------------------------------------------

  integer,parameter :: itime = 80
  integer, parameter :: iprof = 83
  integer, parameter :: ispec = 78
  integer :: nrhopoints,nUpoints,snapshotcounter
  real :: tdump, trun, tslice,nfiles

  real(kind=8), parameter :: G = 6.67d-8           ! cgs
  real(kind=8), parameter :: AU = 1.496e13	   ! AU in cm
  real(kind=8), parameter :: yr = 3.15e7	   ! year in s
  real(kind=8), parameter :: solarmass = 1.99e33   ! solar mass
  real(kind=8), parameter :: mearth = 5.972e27     ! Earth mass
  real(kind=8), parameter :: mjup = 1.898e30       ! Jupiter mass
  real(kind=8), parameter :: msolyr = solarmass/yr

  real(kind=8), parameter :: Qcrit = 1.5	! Critical Toomre Parameter

  real(kind=8), parameter :: pi =3.1415926535
  real(kind=8), parameter :: twopi = 2.0*pi
  real(kind=8), parameter :: pibytwo = 0.5*pi
  real(kind=8), parameter :: stefan = 5.67d-5    ! Stefan-Boltzmann constant
  real(kind=8), parameter :: planck = 6.626d-27  ! Planck's constant
  real(kind=8), parameter :: pc = 3.08d18        ! parsec
  real(kind=8), parameter :: k_B = 1.38d-16  	 ! Boltzmann constant
  real(kind=8), parameter :: m_H = 1.67d-24	 ! mass of hydrogen atom

  real(kind=8), allocatable, dimension(:,:,:) :: eostable

character(len=1) :: runmode, layerchoice, tempchoice, zerostring
character(len=6) :: snapshotformat
  character(len=100) :: fileno,prefix
  character(len=25), parameter :: paramfile = 'visag.params'

end module unitdata