	include 'VICMAIN_FOR'
	subroutine main44
c
c
	implicit none
	real*4	inbuf(32768)
	real*4	sigma,x,y,u,ranx,rany,gain,pixel_rate
	integer*4 nl,ns,cnt,status,line,samp,i,j,bit_hit
	integer*4 inunit,outunit,seed,bits_per_pixel,rate
	integer*8 dseed
	logical*4 add_noise,shot_noise,bit_noise
	character*8 format
	character*80 msg
c
	pixel_rate = 0.0
	call ifmessage ('ADDNOISE version 2016-05-26')
c set parameters
	call xvp('GAIN',gain,cnt)
	if(cnt.eq.0)shot_noise=.false.
	if(cnt.eq.1)then
	  shot_noise=.true.
	  gain=sqrt(1.0/gain)
	endif
	call xvp('RATE',rate,cnt)
	if(cnt.eq.0)bit_noise=.false.
	if(cnt.eq.1)bit_noise=.true.
	call xvp('SIGMA',sigma,cnt)
	if(cnt.eq.0)add_noise=.false.
	if(cnt.eq.1)add_noise=.true.
	call xvp('bits',bits_per_pixel,cnt)
	call xvp('SEED',seed,cnt)
	dseed = seed			!convert to integer*8 (long int in randgen)
	if (cnt .eq. 0)  then
		call get_seconds(dseed)
	end if
	if(add_noise.or.shot_noise.or.bit_noise)then
	else
	  call xvmessage('??E - Must select a noise model',' ')
	  call abend
	endif

	if(bit_noise)then
	  pixel_rate=float(rate)/float(bits_per_pixel) ! pixel hit rate
	endif

c open input
	call xvunit(inunit,'INP',1,status,' ')
	call xvopen(inunit,status, 'IO_ACT','SA','OPEN_ACT','SA',
     +		'OP','READ',  'U_FORMAT','REAL',' ')
        call xvget(inunit,status,'NL',nl,'NS',ns,'FORMAT',format,' ')
        write (msg,10100) format
10100 format ('Input format is ',a8)
	call xvmessage(msg,' ')
c open output
	call xvunit(outunit,'OUT',1,status,' ')
	call xvopen(outunit,status, 'IO_ACT','SA','OPEN_ACT','SA',
     +		'OP','WRITE',  'U_FORMAT','REAL',' ')

c introduce noise
        cnt=0
	do line = 1,nl
	    call xvread(inunit,inbuf,status,' ')
	    do samp = 1,ns

	      if (shot_noise)then
		call rangen(dseed,ranx)
		call rangen(dseed,rany)
		x = max( ranx, 1.0e-10)
		y = rany
		u = sqrt(-2.*log(x)) * cos(2*3.1415927*y)
		x=max(inbuf(samp),0.0)
		inbuf(samp) = gain*sqrt(x)*u*0.7979 + inbuf(samp)
              endif

	      if (add_noise)then
		call rangen(dseed,ranx)
		call rangen(dseed,rany)
		x = max( ranx, 1.0e-10)
		y = rany
		u = sqrt(-2.*log(x)) * cos(2*3.1415927*y)
		inbuf(samp) = sigma*u + inbuf(samp)
              endif

	      if (bit_noise)then
	        call rangen(dseed,ranx)
	        if (ranx*pixel_rate.lt.1.0)then ! probability of pixel hit
	          call rangen(dseed,ranx)
	          bit_hit=nint(ranx*bits_per_pixel+0.5)-1 ! the bit # hit
	          i=nint(inbuf(samp))
	          call bits(i,bit_hit,bit_hit,j) ! j is the bit value
	          if (j.eq.0)then
	            inbuf(samp)=i+2**bit_hit
	          else
	            inbuf(samp)=i-2**bit_hit
	          endif
	          cnt=cnt+1
	        endif
              endif

	    enddo
	    if (format.eq.'BYTE')then
	      do samp=1,ns
	        if (inbuf(samp).lt.0.0)inbuf(samp)=0.0
	        if (inbuf(samp).gt.255.0)inbuf(samp)=255.0
	      enddo
	    endif
	    call xvwrit(outunit,inbuf,status,' ')
	enddo
	if (bit_noise) then
	    write (msg,10200) cnt
10200 format (i8,' pixels hit by bit errors')
	call xvmessage (msg,' ')
	endif
	call xvclose(inunit,status,' ')
	call xvclose(outunit,status,' ')
	return
	end


C  =====================================================================
C  pgm: DDGDJ2 .. Get frm da-sum, jul-dt (frm yr-1900)
C
C  use:     CALL DDGDJ2(DU1,J1,Y1)
C
C   in: DU1 ..... day-sum since Jan 1, 1900 - INT
C  out: J1 ...... day of year (001-366) - INT
C  out: Y1 ...... 4-digit year number - INT
C
C  lvl: DD1
C
C  cmt:   36890 is the day number for 31 Dec 2000.
C  cmt:    1461 is the number of days in a 4 year period.
C  cmt:   36524 is the number of days in a 100 year period.
C  cmt:  146097 is the number of days in a 400 year period.
C  =====================================================================
      SUBROUTINE DDGDJ2(DU1,J1,Y1)

      INTEGER    DU1,J1,Y1,DU1T,J1T,Y1T,PER,DLF,PYR,PER100,PER400
C
C    ================================= RCS keyword statements ==========
      CHARACTER*68     RCSKW1,RCSKW2
      DATA             RCSKW1,RCSKW2 /                                 '
     .$Source: /fs/hsmb5/hydro/CVS_root/gorms/snow17/ddgdj2.f,v $
     . $',                                                             '
     .$Id: ddgdj2.f,v 3.0 2009-12-30 16:49:06 zcui Exp $
     . $' /
C    ===================================================================
C

        DU1T = DU1

        IF ( DU1T .LE. 365 ) THEN

          J1T = DU1T
          Y1T = 1900

        ELSEIF ( DU1T .LE. 36890 ) THEN

          DU1T = DU1T - 365
          PER = (DU1T-1)/1461
          DLF = DU1T - 1461*PER
          PYR = (4*DLF - 1)/1461
          J1T = DLF - 365*PYR
          Y1T = 1900 + 4*PER + PYR + 1

        ELSE

          DU1T = DU1T - 36890
          PER400 = (DU1T-1)/146097
          DU1T = DU1T - 146097*PER400

          IF ( DU1T .LT. 146097 ) THEN
            PER100 = (DU1T-1)/36524
            DU1T = DU1T - 36524*PER100

            PER = (DU1T-1)/1461
            DLF = DU1T - 1461*PER
            PYR = (4*DLF - 1)/1461
            J1T = DLF - 365*PYR
            Y1T = 2000 + 400*PER400 + 100*PER100 + 4*PER + PYR + 1
          ELSE
            J1T = 366
            Y1T = 2000 + 400*(PER400+1)
          ENDIF

        ENDIF

        J1 = J1T
        Y1 = Y1T

      RETURN
      END


      subroutine clawpack46_qinit(maxmx,maxmy, meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux)
      implicit none

      integer meqn, mbc, mx, my, maux, maxmx, maxmy
      double precision xlower, ylower, dx, dy
      double precision q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, maux)

      integer i, j, mq, blockno, fc2d_clawpack46_get_block
      double precision xc,yc, xp, yp, zp, xlow, ylow, w, tol
      double precision dxc,xm,ym

      double precision q0_physical

      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      integer ii,jj

      integer initchoice
      common /initchoice_comm/ initchoice

      cont = get_context()

      blockno = fc2d_clawpack46_get_block()

      do i = 1-mbc,mx+mbc
          xc = xlower + (i-0.5d0)*dx
          do j = 1-mbc,my+mbc
              yc = ylower + (j-0.5d0)*dy

              if (initchoice .eq. 0) then
c                 # Discontinuous solution
                  xlow = xlower + (i-1)*dx
                  ylow = ylower + (j-1)*dy
                  call cellave2(blockno,xlow,ylow,dx,dy,w)
                  q(i,j,1) = w
              elseif (initchoice .eq. 1) then
                  call fclaw2d_map_c2m(cont,blockno,xc,yc,xp,yp,zp)
                  q(i,j,1) = q0_physical(xp,yp,zp)
              elseif (initchoice .eq. 2) then
                  q(i,j,1) = 1.d0
              elseif (initchoice .eq. 3) then
c                 # Not sure what this one is about
                  if (fclaw2d_map_is_used(cont)) then
                      call fclaw2d_map_c2m(cont,
     &                           blockno,xc,yc,xp,yp,zp)
                  else
                      xp = xc
                      yp = yc
                  endif
                  dxc = 1.d0/8.d0
                  xm = 0.25
                  ym = 0.25
                  w = dxc/2.d0
                  q(i,j,mq) = 0
                  if (blockno .eq.2) then
                      do jj=7,8
                          do ii=1,2
                              q(ii,jj,1) = 1.d0
                          enddo
                      enddo
                  endif
                  if (blockno .eq. 1) then
                      do ii=5,7
c                         q(ii,my,1) = 1.d0
                      enddo
                  endif
              endif
          enddo
      enddo

      return
      end


program operators
    use :: stats_mod
    implicit none
    type(descriptive_stats_t) :: stats1, stats2, stats_all, stats_offset, stats_mult
    real :: x
    integer :: i

    x = 1.0
    do i = 1, 5
        call stats1%add_value(x)
        x = x + 0.3
    end do
    print '(A20, dt)', 'stats 1: ', stats1

    x = -1.0
    do i = 1, 5
        call stats2%add_value(x)
        x = x - 0.3
    end do
    print '(A20, dt)', 'stats 2: ', stats2

    stats_all = stats1 + stats2
    print '(A20, dt)', 'stats all: ', stats_all

    stats_offset = stats1 + 5.0
    print '(A20, dt)', 'stats_offset: ', stats_offset

    stats_mult = 2.0*stats1
    print '(A20, dt)', 'stats_mult: ', stats_mult

end program operators


      subroutine pc1ev(xget,x,nx,ilinx,f,ict,fval,ier)
C
C  evaluate a 1d piecewise linear interpolant -- this is C0.
C    ...a derivative can be evaluated but it is not continuous.
C
C  this subroutine calls two subroutines:
C     herm1x   -- find cell containing (xget,yget)
C     pc1fcn -- evaluate interpolant function and (optionally) derivatives
C
C  input arguments:
C  ================
C
      real xget                         ! target of this interpolation
      real x(nx)                        ! ordered x grid
      integer ilinx                     ! ilinx=1 => assume x evenly spaced
C
      real f(nx)                        ! function data
C
C       contents of f:
C
C  f(i) = f @ x(i)
C
      integer ict(2)                    ! code specifying output desired
C
C  ict(1)=1 -- return f  (0, don't)
C  ict(2)=1 -- return df/dx  (0, don't)
C
C output arguments:
C =================
C
      real fval(*)                      ! output data
      integer ier                       ! error code =0 ==> no error
C
C  fval(1) receives the first output (depends on ict(...) spec)
C  fval(2) receives the second output (depends on ict(...) spec)
C
C  examples:
C    on input ict = [1,1]
C   on output fval= [f,df/dx]
C
C    on input ict = [1,0]
C   on output fval= [f] ... element 2 never referenced
C
C    on input ict = [0,1]
C   on output fval= [df/dx] ... element 2 never referenced
C
C  ier -- completion code:  0 means OK
C-------------------
C  local:
C
      integer, dimension(1) :: i=0                         ! cell index
C
C  normalized displacement from (x(i)) corner of cell.
C    xparam=0 @x(i)  xparam=1 @x(i+1)
C
      real, dimension(1) :: xparam
C
C  cell dimensions and
C  inverse cell dimensions hxi = 1/(x(i+1)-x(i))
C
      real, dimension(1) :: hx
      real, dimension(1) :: hxi
C
C  0 .le. xparam .le. 1
C
C---------------------------------------------------------------------
C
      call herm1x(xget,x,nx,ilinx,i,xparam,hx,hxi,ier)
      if(ier.ne.0) return
c
      call pc1fcn(ict,1,1,fval,i,xparam,hx,hxi,f,nx)
C
      return
      end
C---------------------------------------------------------------------
C  evaluate C0 piecewise linear function interpolation -- 1d fcn
C   --vectorized-- dmc 10 Feb 1999
C
      subroutine pc1fcn(ict,ivec,ivecd,
     >   fval,ii,xparam,hx,hxi,fin,nx)
C
C  input:
C
      integer ict(2)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec)                  ! target cells
      real xparam(ivec)
                                        ! normalized displacements in cells
C
      real hx(ivec)                     ! grid spacing, and
      real hxi(ivec)                    ! inverse grid spacing 1/(x(i+1)-x(i))
C
      real fin(nx)                      ! the data
C
C  output:
C
      real fval(ivecd,*)                ! interpolation results
C
C  for detailed description of fin, ict and fval see subroutine
C  pc1ev comments.  Note ict is not vectorized -- the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii, and parameter inputs
C     xparam,hx,hxi,are vectorized, and the
C
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument; ivecd.ge.ivec
C     expected!
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C
      integer v
C
      do v=1,ivec
         i=ii(v)
         xp=xparam(v)
         xpi=1.0-xp
C
         iadr=0
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            iadr=iadr+1
            fval(v,iadr)=xpi*fin(i)+xp*fin(i+1)
C
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
C
            fval(v,iadr)=(fin(i+1)-fin(i))*hxi(v)
         endif
C
      enddo                             ! vector loop
C
      return
      end


* Jacobi.f
* computes the variables for an elementary Jacobi rotation
* code adapted from the "Handbook" routines for complex M12
* (Wilkinson, Reinsch: Handbook for Automatic Computation, p. 202)
* this file is part of FormCalc
* last modified 15 Jun 04 th

	subroutine Jacobi(delta, s, tau, diff, M12, absM12)
	implicit none
	double precision delta, tau, diff, absM12
	double complex s, M12

	double precision h, invc

	h = 2/(diff + sign(sqrt(diff**2 + 4*absM12**2), diff))

* delta = dconjg(M12)*tan(phi) is the shift in the diagonal elements,
* i.e. M11 -> M11 + delta, M22 -> M22 - delta
	delta = h*absM12**2

* invc = 1/cos(phi)
	invc = sqrt(delta*h + 1)

* s = sin(phi)
	s = h/invc*M12

* tau = dconjg(sin(phi))*tan(phi/2) = 1 - cos(phi)
	tau = h*delta/(invc*(invc + 1))
	end


module mod_union_find
  use, intrinsic :: iso_fortran_env
  implicit none
  type union_find
    integer(int32) :: n = 0
    integer(int32), allocatable :: par(:), rnk(:), cnt(:)
  contains
    procedure :: find => find
    procedure :: same => same
    procedure :: unite => unite
    procedure :: size => size_of
  end type
  interface union_find
    module procedure :: newuf
  end interface
contains
  type(union_find) function newuf(n) result(res)
    integer(int32), intent(in) :: n
    integer(int32) :: i
    res%n = n
    allocate(res%par(n), res%rnk(n), res%cnt(n))
    res%par = [(i, i = 1, n)]
    res%rnk = 0
    res%cnt = 1
  end
  recursive integer function find(this, i) result(res)
    class(union_find), intent(inout) :: this
    integer(int32), intent(in) :: i
    if (this%par(i) /= i) this%par(i) = find(this, this%par(i))
    res = this%par(i)
  end
  logical function same(this, i, j) result(res)
    class(union_find), intent(inout) :: this
    integer(int32), intent(in) :: i, j
    res = find(this, i) == find(this, j)
  end
  subroutine unite(this, i, j)
    class(union_find), intent(inout) :: this
    integer(int32), intent(in) :: i, j
    integer(int32) :: x, y
    x = find(this, i)
    y = find(this, j)
    if (x == y) return
    if (this%rnk(x) < this%rnk(y)) then
      this%par(x) = y
      this%cnt(y) = this%cnt(y) + this%cnt(x)
    else
      this%par(y) = x
      this%cnt(x) = this%cnt(x) + this%cnt(y)
      if (this%rnk(x) == this%rnk(y)) this%rnk(x) = this%rnk(x) + 1
    end if
  end
  integer(int32) function size_of(this, i) result(res)
    class(union_find), intent(inout) :: this
    integer(int32), intent(in) :: i
    res = this%cnt(find(this, i))
  end
end module mod_union_find


program example_convection
    implicit none

    ! Number of cells
    integer, parameter :: nx=50, ny=50

    ! Variables
    real(kind=8),dimension(nx,ny) :: AE, AW, AN, AS, Su, Sp, AP ! Upwinding coefficients
    real(kind=8),dimension(nx,ny) :: A_E, A_W, A_N, A_S, S_u, S_p, A_P ! Second-order coefficients
    real(kind=8),dimension(0:nx+1,0:ny+1) :: phi
    real(kind=8) :: x_min, y_min, x_max, y_max, u, v, dx, dy, B, rho, m_e, m_w, m_n, m_s, phi_wbc, phi_sbc, EQ3, EQ2, phi_new
    real(kind=8) :: max_diff, new_diff, x, y
    integer :: i, j, iterations, max_iter
    character(100) :: filename

    ! Welcome message
    write(*,*)
    write(*,*) "Example Convection Problem"
    write(*,*) "--------------------------"

    ! Solver options
    B = 1.0
    max_iter = 10000000

    ! Domain
    x_min = 0.0
    x_max = 1.0
    y_min = 0.0
    y_max = 1.0

    ! Flow options
    u = 1.0
    v = 1.0
    rho = 1.0

    ! Boundary conditions
    phi_wbc = 1.0
    phi_sbc = 0.0

    ! Grid
    dx = (x_max-x_min)/nx
    dy = (y_max-y_min)/ny

    ! Initialize phi
    phi = 0.0
    phi(0,0:nx+1) = phi_sbc ! Southern boundary
    phi(0:ny+1,0) = phi_wbc ! Western boundary
    phi(0,0) = 0.5*(phi_sbc+phi_wbc) ! Southwest corner

    ! Mass flows
    m_e = rho*u*dy
    m_w = rho*u*dy
    m_n = rho*v*dx
    m_s = rho*v*dx

    ! Initialize all coefficients to interior values
    ! Upwind
    AE = 0.0
    AW = m_w
    AN = 0.0
    AS = m_s
    Su = 0.0
    Sp = 0.0

    ! Second-order
    A_E = -0.5*m_e
    A_W = 0.5*m_w
    A_N = -0.5*m_n
    A_S = 0.5*m_s
    S_u = 0.0
    S_p = 0.0

    ! West boundary; Dirichlet condition
    ! Upwind
    AE(2:ny-1,1) = 0.0
    AW(2:ny-1,1) = 0.0
    Sp(2:ny-1,1) = -m_e
    Su(2:ny-1,1) = m_w*phi_wbc

    ! Second-order
    A_E(2:ny-1,1) = -0.5*m_e
    A_W(2:ny-1,1) = 0.0
    S_p(2:ny-1,1) = -m_e
    S_u(2:ny-1,1) = m_w*phi_wbc

    ! East boundary; Neumann condition
    ! Upwind
    AE(2:ny-1,nx) = 0.0
    Aw(2:ny-1,nx) = m_w
    Sp(2:ny-1,nx) = -(m_e-m_w)

    ! Second-order
    A_E(2:ny-1,nx) = 0.0
    A_W(2:ny-1,nx) = 0.5*m_w
    S_p(2:ny-1,nx) = -(m_e-m_w)

    ! South boundary; Dirichlet condition
    ! Upwind
    AN(1,2:nx-1) = 0.0
    AS(1,2:nx-1) = 0.0
    Sp(1,2:nx-1) = -m_n
    Su(1,2:nx-1) = m_s*phi_sbc

    ! Second-order
    A_N(1,2:nx-1) = -0.5*m_n
    A_S(1,2:nx-1) = 0.0
    S_p(1,2:nx-1) = -m_n
    S_u(1,2:nx-1) = m_s*phi_sbc

    ! North boundary; Neumann condition
    ! Upwind
    AN(ny,2:nx-1) = 0.0
    AS(ny,2:nx-1) = m_s
    Sp(ny,2:nx-1) = -(m_n-m_s)

    ! Second-order
    A_N(ny,2:nx-1) = 0.0
    A_S(ny,2:nx-1) = 0.5*m_s
    S_p(ny,2:nx-1) = -(m_n-m_s)

    ! Northwest corner
    Su(ny,1) = m_w*phi_wbc
    Sp(ny,1) = -m_e-(m_n-m_s)
    AS(ny,1) = m_s
    AE(ny,1) = 0.0
    AW(ny,1) = 0.0
    AN(ny,1) = 0.0

    S_u(ny,1) = m_w*phi_wbc
    S_p(ny,1) = -m_e-(m_n-m_s)
    A_W(ny,1) = 0.0
    A_N(ny,1) = 0.0
    A_S(ny,1) = 0.5*m_s
    A_E(ny,1) = -0.5*m_e

    ! Southwest corner
    Su(1,1) = m_w*phi_wbc+m_s*phi_sbc
    Sp(1,1) = -m_e-m_n
    AE(1,1) = 0.0
    AW(1,1) = 0.0
    AN(1,1) = 0.0
    AS(1,1) = 0.0

    S_u(1,1) = m_w*phi_wbc+m_s*phi_sbc
    S_p(1,1) = -m_e-m_n
    A_W(1,1) = 0.0
    A_E(1,1) = -0.5*m_e
    A_S(1,1) = 0.0
    A_N(1,1) = -0.5*m_n

    ! Southeast corner
    Su(1,nx) = m_s*phi_sbc
    Sp(1,nx) = -m_n-(m_e-m_w)
    AW(1,nx) = m_w
    AN(1,nx) = 0.0
    AE(1,nx) = 0.0
    AS(1,nx) = 0.0

    S_u(1,nx) = m_s*phi_sbc
    S_p(1,nx) = -m_n-(m_e-m_w)
    A_E(1,nx) = 0.0
    A_W(1,nx) = 0.5*m_w
    A_S(1,nx) = 0.0
    A_N(1,nx) = -0.5*m_n

    ! Northeast corner
    Sp(ny,nx) = -(m_n-m_s)-(m_e-m_w)
    AN(ny,nx) = 0.0
    AE(ny,nx) = 0.0
    Aw(ny,nx) = m_w
    AS(ny,nx) = m_s

    S_p(ny,nx) = -(m_n-m_s)-(m_e-m_w)
    A_N(ny,nx) = 0.0
    A_S(ny,nx) = 0.5*m_s
    A_E(ny,nx) = 0.0
    A_W(ny,nx) = 0.5*m_w

    ! Calculate AP and A_P
    AP = AN+AE+AS+AW-SP+m_e-m_w+m_n-m_s
    A_P = A_N+A_E+A_S+A_W-S_P+m_e-m_w+m_n-m_s

    ! Iterate
    iterations = 0
    max_diff = 1.0
    write(*,*)
    write(*,*) "   Iteration      Max Correction"
    write(*,*) "--------------------------------"
    do while (.not. max_diff .eq. 0.0 .and. iterations<max_iter)

        ! Reset for iteration
        iterations = iterations+1
        max_diff = 0.0

        ! Loop through control points
        do i = 1,ny
            do j = 1,nx

                ! Upwind
                EQ3 = AE(i,j)*phi(i,j+1)+AW(i,j)*phi(i,j-1)+AN(i,j)*phi(i+1,j)+AS(i,j)*phi(i-1,j)+Su(i,j)

                ! Second order
                EQ2 = A_P(i,j)*phi(i,j)-A_E(i,j)*phi(i,j+1)-A_W(i,j)*phi(i,j-1)-A_N(i,j)*phi(i+1,j)-A_S(i,j)*phi(i-1,j)-S_u(i,j)

                ! Blend
                phi_new = EQ3/AP(i,j)-B/AP(i,j)*(EQ2-(AP(i,j)*phi(i,j)-EQ3))

                ! Check convergence
                new_diff = abs(phi_new-phi(i,j))
                if (new_diff > max_diff) then
                    max_diff = new_diff
                end if

                ! Assign
                phi(i,j) = phi_new

            end do
        end do
        write(*,*) iterations, max_diff
    end do

    ! Finalize north and east boundaries
    phi(ny+1,:) = phi(ny,:)
    phi(:,nx+1) = phi(:,nx)
    phi(ny+1,nx+1) = 0.5*(phi(ny+1,nx)+phi(ny,nx+1))

    ! Write results to file
    ! Open file
    filename = 'results.csv'
    open(1,file=filename)

        ! Header
        write(1,*) 'x,y,z,phi'

        ! Control points
        do i = 1,ny
            do j =1,nx
                x = x_min+0.5*dx*(2*j-1)
                y = y_min+0.5*dy*(2*i-1)
                write(1,*) x, ',', y, ',', 0.0, ',', phi(i,j)
            end do
        end do

        ! West and east boundaries
        do i = 1,ny
            y = y_min+0.5*dy*(2*i-1)
            write(1,*) x_min, ',', y, ',', 0.0, ',', phi(i,0) ! West
            write(1,*) x_max, ',', y, ',', 0.0, ',', phi(i,nx+1) ! East
        end do

        ! North and south boundaries
        do i = 1,nx
            x = x_min+0.5*dx*(2*i-1)
            write(1,*) x, ',', y_min, ',', 0.0, ',', phi(0,i) ! South
            write(1,*) x, ',', y_max, ',', 0.0, ',', phi(ny+1,i) ! North
        end do

        ! Corners
        write(1,*) x_min, ',', y_min, ',', 0.0, ',', phi(0,0) ! SW
        write(1,*) x_min, ',', y_max, ',', 0.0, ',', phi(ny+1,0) ! SE
        write(1,*) x_max, ',', y_min, ',', 0.0, ',', phi(0,nx+1) ! NW
        write(1,*) x_max, ',', y_max, ',', 0.0, ',', phi(ny+1,nx+1) ! NE

    close(1)

end program example_convection


module problem_data

  use mfe_constants, only: wp
  implicit none
  private

  real(kind=wp), public :: t_scale, x_scale, u_scale

end module problem_data

module problem_init

  use mfe_constants, only: wp
  use problem_data
  use common_io
  implicit none
  private

  public :: read_problem_data

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  READ_PROBLEM_DATA
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine read_problem_data ()

      call read_tagged_data (t_scale, "Time scale factor")
      call read_tagged_data (x_scale, "Space scale factor")
      call read_tagged_data (u_scale, "U scale factor")

    end subroutine read_problem_data

end module problem_init

module problem_pde

  use mfe_constants, only: wp
  use problem_data
  use local_arrays
  use local_laplacian
  implicit none
  private

  public  :: pde_rhs
  private :: diffusivity, conductivity

  real(kind=wp), parameter, private :: THETA_R = 0.075_wp
  real(kind=wp), parameter, private :: THETA_S = 0.287_wp
  real(kind=wp), parameter, private :: ALPHA   = 1.611e6_wp
  real(kind=wp), parameter, private :: BETA    = 3.96_wp

  real(kind=wp), parameter, private :: K_S     = 0.00944_wp
  real(kind=wp), parameter, private :: A       = 1.175e6_wp
  real(kind=wp), parameter, private :: GAMMA   = 4.74_wp

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  PDE_RHS --
   !!
   !!  RHS inner products for Richards' equation
   !!
   !!     ds/dt = d/dx (D(s) ds/dx + K(s)).
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine pde_rhs (t)

      real(kind=wp), intent(in) :: t

      real(kind=wp), dimension(2,ncell) :: visc

      real(kind=wp), parameter ::      & ! 3PT GAUSSIAN QUADRATURE PARAMETERS
          w1 = 5.0_wp / 18.0_wp,       & ! (5 / 18)
          w2 = 4.0_wp / 9.0_wp,        & ! (4 / 9)
          c1 = 0.8872983346207417_wp,  & ! (Sqrt[5] + Sqrt[3]) / (2 Sqrt[5])
          c2 = 0.1127016653792583_wp     ! (Sqrt[5] - Sqrt[3]) / (2 Sqrt[5])

      integer :: j
      real(kind=wp) :: u1, u2, u3, f_avg, f_1, f_2

      do j = 1, ncell

        u1 = c1 * u(1,j) % u + c2 * u(2,j) % u
        u2 = 0.5_wp * (u(1,j) % u + u(2,j) % u)
        u3 = c2 * u(1,j) % u + c1 * u(2,j) % u

        f_avg = w1 * (diffusivity(u1) * dudx(j) - conductivity(u1)) + &
                w2 * (diffusivity(u2) * dudx(j) - conductivity(u2)) + &
                w1 * (diffusivity(u3) * dudx(j) - conductivity(u3))

        f_1 = diffusivity(u(1,j) % u) * dudx(j) - conductivity(u(1,j) % u)
        f_2 = diffusivity(u(2,j) % u) * dudx(j) - conductivity(u(2,j) % u)

        ! Diffusion coefficients at the cell endpoints.
        visc(1,j) = diffusivity(u(1,j) % u)
        visc(2,j) = diffusivity(u(2,j) % u)

        r(1,j) % x = (f_avg - f_1) * n(j) % x
        r(1,j) % u = (f_avg - f_1) * n(j) % u

        r(2,j) % x = (f_2 - f_avg) * n(j) % x
        r(2,j) % u = (f_2 - f_avg) * n(j) % u

      end do

      call laplacian (coef=visc)

    end subroutine pde_rhs

    function conductivity (theta) result (value)

      real(kind=wp), intent(in) :: theta
      real(kind=wp) :: value
      real(kind=wp) :: p, uu

      uu = u_scale * theta
      p = - (ALPHA * (THETA_S - uu) / (uu - THETA_R)) ** (1.0_wp / BETA)

      value = (t_scale/ (x_scale * u_scale )) * (K_S * A) / (A + abs(p) ** GAMMA)

    end function conductivity

    function diffusivity (theta) result (value)

      real(kind=wp), intent(in) :: theta
      real(kind=wp) :: value
      real(kind=wp) :: p, uu

      uu = u_scale * theta

      p = - (ALPHA * (THETA_S - uu) / (uu - THETA_R)) ** (1.0_wp / BETA)

      value = (t_scale / x_scale**2) * (K_S * A * (THETA_S - THETA_R) * ALPHA / BETA) / &
              (((uu-THETA_R) ** 2) * (abs(p) ** (BETA-1.0_wp)) * (A + abs(p) ** GAMMA))

    end function diffusivity

end module problem_pde


    MODULE blas_dense_vec_op

      ! Fortran 95 Bindings Generic Interface Blocks
      ! .  for section 2.8.4 -- Vector Operations
      ! .  using external procedures.
      ! Written on 14 December 2000
      ! .  Zohair Maany and Sven Hammarling, NAG Central Office.

      PRIVATE
      PUBLIC :: rscale, axpby, waxpby, axpy_dot, apply_grot

      INTERFACE rscale
        ! x has shape (n)
        SUBROUTINE rscale_d(alpha,x)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: alpha
          REAL (wp), INTENT (INOUT) :: x(:)
        END SUBROUTINE rscale_d
        SUBROUTINE rscale_z(alpha,x)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: alpha
          COMPLEX (wp), INTENT (INOUT) :: x(:)
        END SUBROUTINE rscale_z
        SUBROUTINE rscale_s(alpha,x)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: alpha
          REAL (wp), INTENT (INOUT) :: x(:)
        END SUBROUTINE rscale_s
        SUBROUTINE rscale_c(alpha,x)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: alpha
          COMPLEX (wp), INTENT (INOUT) :: x(:)
        END SUBROUTINE rscale_c
      END INTERFACE

      INTERFACE axpby
        ! x and y have shape (n)
        SUBROUTINE axpby_d(x,y,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE axpby_d
        SUBROUTINE axpby_z(x,y,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE axpby_z
        SUBROUTINE axpby_s(x,y,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE axpby_s
        SUBROUTINE axpby_c(x,y,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE axpby_c
      END INTERFACE

      INTERFACE waxpby
        ! x, y and w have shape (n)
        SUBROUTINE waxpby_d(x,y,w,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (OUT) :: w(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE waxpby_d
        SUBROUTINE waxpby_z(x,y,w,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (OUT) :: w(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE waxpby_z
        SUBROUTINE waxpby_s(x,y,w,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (OUT) :: w(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE waxpby_s
        SUBROUTINE waxpby_c(x,y,w,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (OUT) :: w(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE waxpby_c
      END INTERFACE

      INTERFACE axpy_dot
        ! u, v and w have shape (n)
        SUBROUTINE axpy_dot_d(w,v,u,r,alpha)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: u(:), v(:)
          REAL (wp), INTENT (INOUT) :: w(:)
          REAL (wp), INTENT (OUT) :: r
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
        END SUBROUTINE axpy_dot_d
        SUBROUTINE axpy_dot_z(w,v,u,r,alpha)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: u(:), v(:)
          COMPLEX (wp), INTENT (INOUT) :: w(:)
          COMPLEX (wp), INTENT (OUT) :: r
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
        END SUBROUTINE axpy_dot_z
        SUBROUTINE axpy_dot_s(w,v,u,r,alpha)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: u(:), v(:)
          REAL (wp), INTENT (INOUT) :: w(:)
          REAL (wp), INTENT (OUT) :: r
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
        END SUBROUTINE axpy_dot_s
        SUBROUTINE axpy_dot_c(w,v,u,r,alpha)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: u(:), v(:)
          COMPLEX (wp), INTENT (INOUT) :: w(:)
          COMPLEX (wp), INTENT (OUT) :: r
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
        END SUBROUTINE axpy_dot_c
      END INTERFACE

      INTERFACE apply_grot
        ! x and y have shape (n)
        SUBROUTINE apply_grot_d(c,s,x,y)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: c, s
          REAL (wp), INTENT (INOUT) :: x(:), y(:)
        END SUBROUTINE apply_grot_d
        SUBROUTINE apply_grot_z(c,s,x,y)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: c
          COMPLEX (wp), INTENT (IN) :: s
          COMPLEX (wp), INTENT (INOUT) :: x(:), y(:)
        END SUBROUTINE apply_grot_z
        SUBROUTINE apply_grot_s(c,s,x,y)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: c, s
          REAL (wp), INTENT (INOUT) :: x(:), y(:)
        END SUBROUTINE apply_grot_s
        SUBROUTINE apply_grot_c(c,s,x,y)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: c
          COMPLEX (wp), INTENT (IN) :: s
          COMPLEX (wp), INTENT (INOUT) :: x(:), y(:)
        END SUBROUTINE apply_grot_c
      END INTERFACE
    END MODULE blas_dense_vec_op


subroutine integf(xbf,rthrea,f)
!完成单个环的引力积分
!xbf    土星固定系坐标
!rthrea 环的内径和外径(m)
!f		固定系坐标下的受力

!use para
implicit none
real*8,parameter:: pi=dacos(-1.d0)
real*8:: xbf(3),f(3),rthrea(2)
REAL*8:: X(3,2),Y(3,2),DATA(4500),RES,ERR,theta1,theta2
INTEGER IWORK(1000),NU,ND,NEVALS,IFLAG,ID(3),i,j,k
EXTERNAL Fx,fy,fz
!id(1)=i
!id(2)=j
!id(3)=k
!print*,id
theta1=0.d0
theta2=2.d0*pi
X(1,1)=rthrea(1)
Y(1,1)=theta1
X(2,1)=rthrea(2)
Y(2,1)=theta1
X(3,1)=rthrea(2)
Y(3,1)=theta2
X(1,2)=rthrea(1)
Y(1,2)=theta1
X(2,2)=rthrea(2)
Y(2,2)=theta2
X(3,2)=rthrea(1)
Y(3,2)=theta2
NU=0
ND=0
IFLAG=1

CALL TWODQ(intx,2,X,Y,1.E-08,1,200,32000,fx,ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK,id)
CALL TWODQ(inty,2,X,Y,1.E-08,1,200,32000,fy,ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK,id)
CALL TWODQ(intz,2,X,Y,1.E-08,1,200,32000,fz,ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK,id)
!PRINT*,u,ERR,NEVALS,IFLAG
end subroutine integf

real*8 FUNCTION intx(t,theta,id)
use para
implicit none
real*8 t,theta
intx=t/dsqrt(cyl(3,id(1),id(2),id(3))**2+t**2+cyl(1,id(1),id(2),id(3))**2-2.d0*cyl(1,id(1),id(2),id(3))*t*dcos(cyl(2,id(1),id(2),id(3))-theta))
RETURN
END FUNCTION intx

real*8 FUNCTION inty(t,theta,id)
use para
implicit none
real*8 t,theta
inty=t/dsqrt(cyl(3,id(1),id(2),id(3))**2+t**2+cyl(1,id(1),id(2),id(3))**2-2.d0*cyl(1,id(1),id(2),id(3))*t*dcos(cyl(2,id(1),id(2),id(3))-theta))
RETURN
END FUNCTION inty

real*8 FUNCTION intz(t,theta,id)
use para
implicit none
real*8 t,theta
intz=t/dsqrt(cyl(3,id(1),id(2),id(3))**2+t**2+cyl(1,id(1),id(2),id(3))**2-2.d0*cyl(1,id(1),id(2),id(3))*t*dcos(cyl(2,id(1),id(2),id(3))-theta))
RETURN
END FUNCTION intz


      DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,Al,Be,Ak,Bk,Ag,Bg,C,D,E,
     &   Es)
      IMPLICIT NONE
      DOUBLE PRECISION Ag , Ak , Al , Be , Bg , Bk , C , D , E , Es ,
     &                 lx , S , X
      SAVE
      lx = LOG(1./X)
      PHO_DOR92FW = (X**Ak*(Ag+X*(Bg+X*C))
     &              *lx**Bk+S**Al*EXP(-E+SQRT(Es*S**Be*lx)))*(1.-X)**D

      END FUNCTION


!
!     ------------------------------------------------------------------
!              Q U A D R
!     ------------------------------------------------------------------
!
!                                   kk
!       Evaluates the integral of  r   P (r) P (r) with respect to r
!                                       i     j
!
      DOUBLE PRECISION FUNCTION QUADR (I, J, KK)
      use param_C
      use radial_C
      use nel_C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!...Translated by Pacific-Sierra Research 77to90  4.3E  00:41:09  11/16/01
!...Switches:
!      PARAMETER(NOD=220)
!      COMMON/PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
!     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
!      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
!      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
!     :       (IQMAX,MAX_(1))
!      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7)
      DIMENSION :: G(NOD)
!
      K = KK + 2
      LI = L(I)
      LJ = L(J)
      DEN = LI + LJ + 1 + K
      ZR = Z*R(4)
      BI = (P(4,I)/(AZ(I)*R2(4)*R(4)**LI)-D1+ZR/(LI+1))/ZR**2
      BJ = (P(4,J)/(AZ(J)*R2(4)*R(4)**LJ)-D1+ZR/(LJ+1))/ZR**2
      ALPHA = (D1/(LI + 1) + D1/(LJ + 1))/(DEN + D1)
      ZR = Z*R(1)
      BETA = (DEN + D1)*ALPHA**2 - D2*(BI + BJ + D1/((LI + 1)*(LJ + 1)))/(DEN&
          + D2)
      D = P(1,I)*P(1,J)*R(1)**K*(((BETA*ZR + ALPHA)*ZR + D1)/(DEN*H1) + D5)
      DD = D0
      M = MIN0(MAX_(I),MAX_(J))
      DO JJ = 1, M
         G(JJ) = P(JJ,I)*P(JJ,J)*R(JJ)**K
      END DO
      DO JJ = 3, M, 2
         D = D + G(JJ)
      END DO
      DO JJ = 2, M, 2
         DD = DD + G(JJ)
      END DO
      QUADR = H1*(D + D2*DD)
      RETURN
      END FUNCTION QUADR


program simulation
  use subroutines
  use statistics
  implicit real*8 (a-h,o-z)

  integer,parameter::inum_stats = 4
  integer,parameter::inum_corrs = 4
  real         ::rng
  real*8       ::params(2)
  character*128::ifilename

  integer*1,allocatable::iconfig(:)
  real*8   ,allocatable::datum(:,:)
  real*8   ,allocatable::data(:,:)
  real*8   ,allocatable::corr(:,:)

  !call cpu_time(current_time)
  current_time =omp_get_wtime() ! openmp timing

  call read_args(N,isteps,isamples,params,ifilename)

  allocate(iconfig(0:N-1))
  allocate(datum(isteps,inum_stats))
  allocate( data(isteps,inum_stats+inum_corrs))
  data = 0d0
  allocate(    corr(isteps,inum_corrs))
  corr     = 0d0

  !$OMP PARALLEL DO PRIVATE(iconfig,datum,k,rng,corr_tmp)
  do isample = 1,isamples
     call initialize(iconfig)
     do k = 1, isteps
        ! seeds are private for each thread
        call random_number(rng) ! consider mersenne twister from mkl
        call update(N,iconfig,params,rng)
        call density(N,iconfig,datum(k,:))
     end do
     call correlation(N,datum(:,1),corr) ! density density corr
     !$OMP CRITICAL
     call update_mc_density(N,isamples,datum,data)
     !$OMP END CRITICAL
     !$OMP CRITICAL
     call update_mc_correlation(N,isamples,inum_stats + 1,corr,data)
     !$OMP END CRITICAL

     !call update_mc_correlation(N,isamples,corr_tmp,corr)

  end do
  !$OMP END PARALLEL DO

  !call cpu_time(elapsed_time)
  elapsed_time = omp_get_wtime() ! openmp timing

  elapsed_time = elapsed_time - current_time
  print *,'elapsed time :: ',elapsed_time
  1010 format (I8,2I12,ES20.12E2,ES20.12E2,ES20.12E2)
  open(9,file='log_performance.dat',access='append',status='unknown')
  write(9,1010) int(N),int(isteps),int(isamples),params(1)*N,params(2)*N*N,elapsed_time
  close(9)

  call save(trim(ifilename),data)

end program simulation


      DOUBLE PRECISION FUNCTION DGAUSS(F,A,B,EPS)
      DOUBLE PRECISION F,A,B,EPS
      DOUBLE PRECISION W(12),X(12),AA,BB,C1,C2,U,S8,S16,CONST
      save
      LOGICAL MFLAG,RFLAG
      EXTERNAL F
C
C     ******************************************************************
C
C     ADAPTIVE DOUBLE PRECISION GAUSSIAN QUADRATURE.
C
C     DGAUSS IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF
C     THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER
C     EPS.
C
C     ******************************************************************
C
      DATA W / 0.10122 85362 90376 259D0,
     1         0.22238 10344 53374 471D0,
     2         0.31370 66458 77887 287D0,
     3         0.36268 37833 78361 983D0,
     4         0.27152 45941 17540 949D-1,
     5         0.62253 52393 86478 929D-1,
     6         0.95158 51168 24927 848D-1,
     7         0.12462 89712 55533 872D0,
     8         0.14959 59888 16576 732D0,
     9         0.16915 65193 95002 538D0,
     A         0.18260 34150 44923 589D0,
     B         0.18945 06104 55068 496D0/

      DATA X / 0.96028 98564 97536 232D0,
     1         0.79666 64774 13626 740D0,
     2         0.52553 24099 16328 986D0,
     3         0.18343 46424 95649 805D0,
     4         0.98940 09349 91649 933D0,
     5         0.94457 50230 73232 576D0,
     6         0.86563 12023 87831 744D0,
     7         0.75540 44083 55003 034D0,
     8         0.61787 62444 02643 748D0,
     9         0.45801 67776 57227 386D0,
     A         0.28160 35507 79258 913D0,
     B         0.95012 50983 76374 402D-1/
C
C     ******************************************************************
C
C  START.
      DGAUSS=0.0D0
      IF(B.EQ.A) RETURN
      CONST=0.005D0/(B-A)
      BB=A
C
C  COMPUTATIONAL LOOP.
    1 AA=BB
      BB=B
    2    C1=0.5D0*(BB+AA)
         C2=0.5D0*(BB-AA)
         S8=0.0D0
         DO 3 I=1,4
            U=C2*X(I)
            S8=S8+W(I)*(F(C1+U)+F(C1-U))
    3    CONTINUE
         S8=C2*S8
         S16=0.0D0
         DO 4 I=5,12
            U=C2*X(I)
            S16=S16+W(I)*(F(C1+U)+F(C1-U))
    4    CONTINUE
         S16=C2*S16
         IF( ABS(S16-S8) .LE. EPS*(1.+ABS(S16)) ) GO TO 5
         BB=C1
         IF( 1.D0+ABS(CONST*C2) .NE. 1.D0) GO TO 2
      DGAUSS=0.0D0
      CALL KERMTR('D103.1',LGFILE,MFLAG,RFLAG)
      IF(MFLAG) THEN
         IF(LGFILE.EQ.0) THEN
            WRITE(*,6)
         ELSE
            WRITE(LGFILE,6)
         ENDIF
      ENDIF
      IF(.NOT. RFLAG) CALL ABEND
      RETURN
    5 DGAUSS=DGAUSS+S16
      IF(BB.NE.B) GO TO 1
      RETURN
C
    6 FORMAT( 4X, 'FUNCTION DGAUSS ... TOO HIGH ACCURACY REQUIRED')
      END

c -------------------------------------------------------------------

          SUBROUTINE KERSET(ERCODE,LGFILE,LIMITM,LIMITR)
          save
          PARAMETER(KOUNTE  =  27)
          CHARACTER*6         ERCODE,   CODE(KOUNTE)
          LOGICAL             MFLAG,    RFLAG
          INTEGER             KNTM(KOUNTE),       KNTR(KOUNTE)
          DATA      LOGF      /  0  /
          DATA      CODE(1), KNTM(1), KNTR(1)  / 'C204.1', 100, 100 /
          DATA      CODE(2), KNTM(2), KNTR(2)  / 'C204.2', 100, 100 /
          DATA      CODE(3), KNTM(3), KNTR(3)  / 'C204.3', 100, 100 /
          DATA      CODE(4), KNTM(4), KNTR(4)  / 'C205.1', 100, 100 /
          DATA      CODE(5), KNTM(5), KNTR(5)  / 'C205.2', 100, 100 /
          DATA      CODE(6), KNTM(6), KNTR(6)  / 'C305.1', 100, 100 /
          DATA      CODE(7), KNTM(7), KNTR(7)  / 'C308.1', 100, 100 /
          DATA      CODE(8), KNTM(8), KNTR(8)  / 'C312.1', 100, 100 /
          DATA      CODE(9), KNTM(9), KNTR(9)  / 'C313.1', 100, 100 /
          DATA      CODE(10),KNTM(10),KNTR(10) / 'C336.1', 100, 100 /
          DATA      CODE(11),KNTM(11),KNTR(11) / 'C337.1', 100, 100 /
          DATA      CODE(12),KNTM(12),KNTR(12) / 'C341.1', 100, 100 /
          DATA      CODE(13),KNTM(13),KNTR(13) / 'D103.1', 100, 100 /
          DATA      CODE(14),KNTM(14),KNTR(14) / 'D106.1', 100, 100 /
          DATA      CODE(15),KNTM(15),KNTR(15) / 'D209.1', 100, 100 /
          DATA      CODE(16),KNTM(16),KNTR(16) / 'D509.1', 100, 100 /
          DATA      CODE(17),KNTM(17),KNTR(17) / 'E100.1', 100, 100 /
          DATA      CODE(18),KNTM(18),KNTR(18) / 'E104.1', 100, 100 /
          DATA      CODE(19),KNTM(19),KNTR(19) / 'E105.1', 100, 100 /
          DATA      CODE(20),KNTM(20),KNTR(20) / 'E208.1', 100, 100 /
          DATA      CODE(21),KNTM(21),KNTR(21) / 'E208.2', 100, 100 /
          DATA      CODE(22),KNTM(22),KNTR(22) / 'F010.1', 100,   0 /
          DATA      CODE(23),KNTM(23),KNTR(23) / 'F011.1', 100,   0 /
          DATA      CODE(24),KNTM(24),KNTR(24) / 'F012.1', 100,   0 /
          DATA      CODE(25),KNTM(25),KNTR(25) / 'F406.1', 100,   0 /
          DATA      CODE(26),KNTM(26),KNTR(26) / 'G100.1', 100, 100 /
          DATA      CODE(27),KNTM(27),KNTR(27) / 'G100.2', 100, 100 /
          LOGF  =  LGFILE
          IF(ERCODE .EQ. ' ')  THEN
             L  =  0
          ELSE
             DO 10  L = 1, 6
                IF(ERCODE(1:L) .EQ. ERCODE)  GOTO 12
  10            CONTINUE
  12         CONTINUE
          ENDIF
          DO 14     I  =  1, KOUNTE
             IF(L .EQ. 0)  GOTO 13
             IF(CODE(I)(1:L) .NE. ERCODE(1:L))  GOTO 14
  13         KNTM(I)  =  LIMITM
             KNTR(I)  =  LIMITR
  14         CONTINUE
            RETURN
          ENTRY KERMTR(ERCODE,LOG,MFLAG,RFLAG)
          LOG  =  LOGF
          DO 20     I  =  1, KOUNTE
             IF(ERCODE .EQ. CODE(I))  GOTO 21
  20         CONTINUE
          WRITE(*,1000)  ERCODE
          CALL ABEND
          RETURN
  21      RFLAG  =  KNTR(I) .GE. 1
          IF(RFLAG  .AND.  (KNTR(I) .LT. 100))  KNTR(I)  =  KNTR(I) - 1
          MFLAG  =  KNTM(I) .GE. 1
          IF(MFLAG  .AND.  (KNTM(I) .LT. 100))  KNTM(I)  =  KNTM(I) - 1
          IF(.NOT. RFLAG)  THEN
             IF(LOGF .LT. 1)  THEN
                WRITE(*,1001)  CODE(I)
             ELSE
                WRITE(LOGF,1001)  CODE(I)
             ENDIF
          ENDIF
          IF(MFLAG .AND. RFLAG)  THEN
             IF(LOGF .LT. 1)  THEN
                WRITE(*,1002)  CODE(I)
             ELSE
                WRITE(LOGF,1002)  CODE(I)
             ENDIF
          ENDIF
          RETURN
1000      FORMAT(' KERNLIB LIBRARY ERROR. ' /
     +           ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR',
     +           ' ERROR MONITOR. RUN ABORTED.')
1001      FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ',
     +           'CONDITION ',A6)
1002      FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6)
          END
      SUBROUTINE ABEND
      save
C
C CERN PROGLIB# Z035    ABEND           .VERSION KERNVAX  1.10  811126

      STOP '*** ABEND ***'
      END


program sten

real (kind=8), dimension(0:imax,1:jmax) :: a
real (kind=8), dimension(0:imax,1:jmax) :: b
real gx, gy

do j=1, jmax-1
   do i=1, imax-1

      gx = -a(i-1,j-1) + a(i+1,j-1)  &
      &  + -2*a(i-1,j) + 2*a(i+1, j) &
      & - a(i-1,j+1) + a(i+1,j+1)

      gy = -a(i-1,j-1) - 2*a(i,j-1) &
        & - a(i+1,j-1)              &
        & + a(i-1,j+1) + 2*a(i,j+1) + a(i+1,j+1)

     != stencil centered(depth=1, dim=1, nonpointed)*centered(depth=1, dim=2) + centered(depth=1, dim=1)*centered(depth=1, dim=2, nonpointed) :: a
     b(i,j) = sqrt(gx*gx+gy*gy)
   enddo
enddo

end program


Subroutine SHMTVarOpt(l, tapers, taper_order, lwin, kmax, Sff, var_opt, var_unit, weight_opt, unweighted_covar, nocross)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given the first Kmax tapers of a matrix TAPERS, and an input global power spectrum
!	Sff, this subroutine will compute the variance of the multitaper spectral estimate
!	assuming that the weights are equal to 1/kmax, and by using the optimal weights that
!	minimize the variance. This routine only works using the tapers of the spherical cap
!	concentration problem.
!
!	Calling Parameters
!		IN
!			l		Spherical harmonic degree to compute variances.
!			tapers		An array of (lwin+1, kmax) tapers (arranged in columns).
!			taper_order	An array of dimension kmax containing the REAL angular order of the tapers.
!			lwin		Maximum spherical harmonic degree of the bandlimited tapers.
!			kmax 		Maximum number of tapers to be used in making the spectral estimate.
!			Sff		Known global power spectrum of the unwindowed field.
!		OUT
!			var_opt		Array of dimension kmax containing the variance computed using the
!					optimal weights when using the first 1 to kmax tapers.
!			var_unit	Array of dimension kmax containg the variance computed using
!					equal weights when using the first 1 to kmax tapers.
!		OPTIONAL(out)
!			weight_opt	Matrix of dimension (kmax, kmax) containing the numerical values of the
!					optimal weights to be applied to each spectral estimate (arranged by columns).
!			unweighted_covar	Unweighted covariance matrix, Fij
!		OPTIONAL(in)
!			nocross		If present and equal to 1, then the off-diagonal terms of the covariance
!					matrix will be assumed to be zero.
!
!	Dependencies: SHSjkPG, SSYSV (LAPACK)
!
!	Copyright (c) 2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	use SHTOOLS, only: SHSjkPG

	implicit none

	real*8, intent(in) ::	tapers(:,:), Sff(:)
	real*8, intent(out) ::	var_opt(:), var_unit(:)
	integer, intent(in) ::	l, lwin, kmax, taper_order(:)
	real*8, intent(out), optional ::	weight_opt(:,:), unweighted_covar(:,:)
	integer, intent(in), optional ::	nocross
	integer, parameter ::	nb = 64
	real*8 ::		Fij(kmax, kmax), ww(kmax), bb(kmax+1), MM(kmax+1, kmax+1), work((kmax+1)*nb)
	integer ::	i,j, m, mp, k, ipiv(kmax+1), info, lwork
	external :: 	DSYSV
	complex*16 ::	temp1

	if (size(Sff) < l+lwin + 1) then
		print*, "Error --- SHMTVarOpt"
		print*, "Sff must be dimensioned (L+LWIN+1) where L and LWIN are ", l, lwin
		print*, "Input array is dimensioned ", size(Sff)
		stop
	elseif (size(tapers(:,1)) < lwin+1 .or. size(tapers(1,:)) < kmax) then
		print*, "Error --- SHMTVarOpt"
		print*, "TAPERS must be dimensioned as (LWIN+1, KMAX) where LWIN and KMAX are ", lwin, kmax
		print*, "Input array is dimensioned ", size(tapers(:,1)), size(tapers(1,:))
		stop
	elseif ( size(var_opt) < kmax) then
		print*, "Error --- SHMTVarOpt"
		print*, "VAR_OPT must be dimensioned (KMAX) where KMAX is ",  kmax
		print*, "Input array is dimensioned ",  size(var_opt)
		stop
	elseif ( size(var_unit) < kmax) then
		print*, "Error --- SHMTVarOpt"
		print*, "VAR_UNIT must be dimensioned (KMAX) where KMAX is ",  kmax
		print*, "Input array is dimensioned ",  size(var_unit)
		stop
	elseif (size(taper_order) < kmax) then
		print*, "Error --- SHMTVarOpt"
		print*, "TAPER_ORDER must be dimensioned as (KMAX) where KMAX is ", kmax
		print*, "Input array is dimensioned ", size(taper_order)
		stop
	endif

	if (present(weight_opt)) then
		if (size(weight_opt(:,1)) < kmax .or. size(weight_opt(1,:)) < kmax) then
			print*, "Error --- SHMTVarOpt"
			print*, "WEIGHT_OPT must be dimensioned (KMAX, KMAX) where KMAX is ", kmax
			stop
		endif
	endif

	if (present(unweighted_covar)) then
		if (size(unweighted_covar(:,1)) < kmax .or. size(unweighted_covar(1,:)) < kmax) then
			print*, "Error --- SHMTVarOpt"
			print*, "UNWEIGHTED_COVAR must be dimensioned (KMAX, KMAX) where KMAX is ", kmax
			print*, "Input array is dimensioned ", size(unweighted_covar(:,1)), size(unweighted_covar(1,:))
			stop
		endif
	endif

	if (present(nocross)) then
		if (nocross .ne. 1 .and. nocross .ne. 0) then
			print*, "Error --- SHMTVarOpt0"
			print*, "NOCROSS must be either 0 (use all elements of covariance matrix) or"
			print*, "1 (set off-diagonal elements of covariance matrix to zero)."
			print*, "Input value is ", nocross
			stop
		endif
	endif

	Fij = 0.0d0

	lwork = (kmax+1)*nb

	var_opt = 0.0d0
	var_unit = 0.0d0
	if (present(weight_opt)) then
		weight_opt = 0.0d0
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate matrix Fij, bb
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(nocross)) then

		if (nocross==1) then

			do i=1, kmax, 1
				!print*, i
				do m=-l, l
					do mp = -l, l
						temp1 = SHSjkPG(Sff, l, m, mp, tapers(1:lwin+1,i), tapers(1:lwin+1,i),&
								taper_order(i), taper_order(i), lwin, 1)
						Fij(i,i) = Fij(i,i) + 2.0d0 * temp1*dconjg(temp1)
					enddo
				enddo
			enddo

		else

			do i=1, kmax, 1
				!print*, i
				do j=i, kmax, 1
					do m=-l, l
						do mp = -l, l
							temp1 = SHSjkPG(Sff, l, m, mp, tapers(1:lwin+1,i), tapers(1:lwin+1,j),&
									taper_order(i), taper_order(j), lwin, 1)
							Fij(i,j) = Fij(i,j) + 2.0d0 * temp1*dconjg(temp1)
						enddo
					enddo
					if (i/=j) Fij(j,i) = Fij(i,j)
				enddo
			enddo

		endif

	else

		do i=1, kmax, 1
			!print*, i
			do j=i, kmax, 1
				do m=-l, l
					do mp = -l, l
						temp1 = SHSjkPG(Sff, l, m, mp, tapers(1:lwin+1,i), tapers(1:lwin+1,j),&
								taper_order(i), taper_order(j), lwin, 1)
						Fij(i,j) = Fij(i,j) + 2.0d0 * temp1*dconjg(temp1)
					enddo
				enddo
				if (i/=j) Fij(j,i) = Fij(i,j)
			enddo
		enddo

	endif

	if (present(unweighted_covar)) then
		unweighted_covar = 0.0d0
		unweighted_covar(1:kmax, 1:kmax) = Fij(1:kmax,1:kmax)
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate variance using equal weights
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, kmax
		var_unit(k) = sum(Fij(1:k,1:k)) / dble(k)**2
	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate optimal weights and variance using optimal weights
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, kmax
		MM(1:k,1:k) = 2.0d0 * Fij(1:k,1:k)
		MM(k+1,1:k) = 1.0d0
		MM(1:k,k+1) = 1.0d0
		MM(k+1,k+1) = 0.0d0
		bb(1:k) = 0.0d0
		bb(k+1) = 1.0d0

		call DSYSV("u", k+1, 1, MM, kmax+1, ipiv,  bb,  kmax+1,  work,  lwork, info)

		if (info /=0) then
			print*, "Error --- SHMTVarOpt"
			print*, "Problem with call to DSYSV."
			print*, "DSYSV info = ", info
			stop
		endif

		if (work(1)/(k+1) > nb) then
			print*, "Warning --- SHMTVarOpt0"
			print*, "The optimal size of nb is ", work(1)/(k+1)
			print*, "Present size is ", nb
			print*, "Please consider changing this parameter and recompiling SHTOOLS"
		endif

		do i=1, k
			ww(i) = bb(i)
		enddo

		if (present(weight_opt)) then
			weight_opt(1:k,k) = ww(1:k)
		endif

		do i=1, k
			do j=1, k
				var_opt(k) = var_opt(k) + ww(i)*ww(j)*Fij(i,j)
			enddo
		enddo

	enddo

end subroutine SHMTVarOpt


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c
c ... file ivlapes.f
c
c     this file includes documentation and code for
c     subroutine ivlapes
c
c ... files which must be loaded with ivlapes.f
c
c     sphcom.f, hrfft.f, vhaes.f, vhses.f
c
c
c
c     subroutine ivlapes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +mdbc,ndbc,wvhses,lvhses,work,lwork,ierror)
c
c
c     subroutine ivlapes computes a the vector field (v,w) whose vector
c     laplacian is (vlap,wlap).  w and wlap are east longitudinal
C*PL*ERROR* Comment line too long
c     components of the vectors.  v and vlap are colatitudinal components
C*PL*ERROR* Comment line too long
c     of the vectors.  br,bi,cr, and ci are the vector harmonic coefficients
c     of (vlap,wlap).  these must be precomputed by vhaes and are input
c     parameters to ivlapes.  (v,w) have the same symmetry or lack of
c     symmetry about the about the equator as (vlap,wlap).  the input
c     parameters ityp,nt,mdbc,ndbc must have the same values used by
c     vhaes to compute br,bi,cr, and ci for (vlap,wlap).
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct longitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
C*PL*ERROR* Comment line too long
c     ityp   this parameter should have the same value input to subroutine
c            vhaes to compute the coefficients br,bi,cr, and ci for the
c            vector field (vlap,wlap).  ityp is set as follows:
c
C*PL*ERROR* Comment line too long
c            = 0  no symmetries exist in (vlap,wlap) about the equator. (v,w)
C*PL*ERROR* Comment line too long
c                 is computed and stored on the entire sphere in the arrays
C*PL*ERROR* Comment line too long
c                 arrays v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon.
c
C*PL*ERROR* Comment line too long
c            = 1  no symmetries exist in (vlap,wlap) about the equator. (v,w)
C*PL*ERROR* Comment line too long
c                 is computed and stored on the entire sphere in the arrays
C*PL*ERROR* Comment line too long
c                 v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon.  the
C*PL*ERROR* Comment line too long
c                 vorticity of (vlap,wlap) is zero so the coefficients cr and
C*PL*ERROR* Comment line too long
c                 ci are zero and are not used.  the vorticity of (v,w) is
c                 also zero.
c
c
C*PL*ERROR* Comment line too long
c            = 2  no symmetries exist in (vlap,wlap) about the equator. (v,w)
C*PL*ERROR* Comment line too long
c                 is computed and stored on the entire sphere in the arrays
C*PL*ERROR* Comment line too long
c                 w(i,j) and v(i,j) for i=1,...,nlat and j=1,...,nlon.  the
C*PL*ERROR* Comment line too long
c                 divergence of (vlap,wlap) is zero so the coefficients br and
C*PL*ERROR* Comment line too long
c                 bi are zero and are not used.  the divergence of (v,w) is
c                 also zero.
c
c            = 3  wlap is antisymmetric and vlap is symmetric about the
C*PL*ERROR* Comment line too long
c                 equator. consequently w is antisymmetric and v is symmetric.
C*PL*ERROR* Comment line too long
c                 (v,w) is computed and stored on the northern hemisphere
C*PL*ERROR* Comment line too long
c                 only.  if nlat is odd, storage is in the arrays v(i,j),
C*PL*ERROR* Comment line too long
c                 w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays v(i,j),w(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  wlap is antisymmetric and vlap is symmetric about the
C*PL*ERROR* Comment line too long
c                 equator. consequently w is antisymmetric and v is symmetric.
C*PL*ERROR* Comment line too long
c                 (v,w) is computed and stored on the northern hemisphere
C*PL*ERROR* Comment line too long
c                 only.  if nlat is odd, storage is in the arrays v(i,j),
C*PL*ERROR* Comment line too long
c                 w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays v(i,j),w(i,j) for
C*PL*ERROR* Comment line too long
c                 i=1,...,nlat/2 and j=1,...,nlon.  the vorticity of (vlap,
c                 wlap) is zero so the coefficients cr,ci are zero and
c                 are not used. the vorticity of (v,w) is also zero.
c
c            = 5  wlap is antisymmetric and vlap is symmetric about the
C*PL*ERROR* Comment line too long
c                 equator. consequently w is antisymmetric and v is symmetric.
C*PL*ERROR* Comment line too long
c                 (v,w) is computed and stored on the northern hemisphere
C*PL*ERROR* Comment line too long
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
C*PL*ERROR* Comment line too long
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
C*PL*ERROR* Comment line too long
c                 i=1,...,nlat/2 and j=1,...,nlon.  the divergence of (vlap,
c                 wlap) is zero so the coefficients br,bi are zero and
c                 are not used. the divergence of (v,w) is also zero.
c
c
c            = 6  wlap is symmetric and vlap is antisymmetric about the
C*PL*ERROR* Comment line too long
c                 equator. consequently w is symmetric and v is antisymmetric.
C*PL*ERROR* Comment line too long
c                 (v,w) is computed and stored on the northern hemisphere
C*PL*ERROR* Comment line too long
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
C*PL*ERROR* Comment line too long
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  wlap is symmetric and vlap is antisymmetric about the
C*PL*ERROR* Comment line too long
c                 equator. consequently w is symmetric and v is antisymmetric.
C*PL*ERROR* Comment line too long
c                 (v,w) is computed and stored on the northern hemisphere
C*PL*ERROR* Comment line too long
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
C*PL*ERROR* Comment line too long
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
C*PL*ERROR* Comment line too long
c                 i=1,...,nlat/2 and j=1,...,nlon.  the vorticity of (vlap,
c                 wlap) is zero so the coefficients cr,ci are zero and
c                 are not used. the vorticity of (v,w) is also zero.
c
c            = 8  wlap is symmetric and vlap is antisymmetric about the
C*PL*ERROR* Comment line too long
c                 equator. consequently w is symmetric and v is antisymmetric.
C*PL*ERROR* Comment line too long
c                 (v,w) is computed and stored on the northern hemisphere
C*PL*ERROR* Comment line too long
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
C*PL*ERROR* Comment line too long
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
C*PL*ERROR* Comment line too long
c                 i=1,...,nlat/2 and j=1,...,nlon.  the divergence of (vlap,
c                 wlap) is zero so the coefficients br,bi are zero and
c                 are not used. the divergence of (v,w) is also zero.
c
c
C*PL*ERROR* Comment line too long
c     nt     nt is the number of vector fields (vlap,wlap). some computational
c            efficiency is obtained for multiple fields.  in the program
c            that calls ivlapes, the arrays v,w,br,bi,cr and ci can be
C*PL*ERROR* Comment line too long
c            three dimensional corresponding to an indexed multiple vector
C*PL*ERROR* Comment line too long
c            field.  in this case multiple vector synthesis will be performed
c            to compute the (v,w) for each field (vlap,wlap).  the third
C*PL*ERROR* Comment line too long
c            index is the synthesis index which assumes the values k=1,...,nt.
c            for a single synthesis set nt=1.  the description of the
c            remaining parameters is simplified by assuming that nt=1 or
c            that all arrays are two dimensional.
c
c   idvw     the first dimension of the arrays w and v as it appears in
C*PL*ERROR* Comment line too long
c            the program that calls ivlapes.  if ityp=0,1, or 2  then idvw
C*PL*ERROR* Comment line too long
c            must be at least nlat.  if ityp > 2 and nlat is even then idvw
C*PL*ERROR* Comment line too long
c            must be at least nlat/2. if ityp > 2 and nlat is odd then idvw
c            must be at least (nlat+1)/2.
c
c   jdvw     the second dimension of the arrays w and v as it appears in
c            the program that calls ivlapes. jdvw must be at least nlon.
c
c
c   br,bi    two or three dimensional arrays (see input parameter nt)
c   cr,ci    that contain vector spherical harmonic coefficients of the
c            vector field (vlap,wlap) as computed by subroutine vhaes.
c            br,bi,cr and ci must be computed by vhaes prior to calling
c            ivlapes.  if ityp=1,4, or 7 then cr,ci are not used and can
c            be dummy arguments.  if ityp=2,5, or 8 then br,bi are not
c            used and can be dummy arguments.
c
c    mdbc    the first dimension of the arrays br,bi,cr and ci as it
c            appears in the program that calls ivlapes.  mdbc must be
c            at least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    ndbc    the second dimension of the arrays br,bi,cr and ci as it
c            appears in the program that calls ivlapes. ndbc must be at
c            least nlat.
c
c    wvhses  an array which must be initialized by subroutine vhsesi.
c            once initialized, wvhses
c            can be used repeatedly by ivlapes as long as nlat and nlon
c            remain unchanged.  wvhses must not be altered between calls
c            of ivlapes.
c
c    lvhses  the dimension of the array wvhses as it appears in the
c            program that calls ivlapes.  let
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c            let
c
c               lsavmin = (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
c
c            then lvhses must be greater than or equal to lsavmin
c            (see ierror=9 below).
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls ivlapes. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            if ityp .le. 2 then
c
c               (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1)
c
c            or if ityp .gt. 2 then
c
c               (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1)
c
c            will suffice as a length for lwork.
c
c     **************************************************************
c
c     output parameters
c
c
C*PL*ERROR* Comment line too long
c    v,w     two or three dimensional arrays (see input parameter nt) that
C*PL*ERROR* Comment line too long
c            contain a vector field whose vector laplacian is (vlap,wlap).
C*PL*ERROR* Comment line too long
c            w(i,j) is the east longitude and v(i,j) is the colatitudinal
c            component of the vector. v(i,j) and w(i,j) are given on the
c            sphere at the colatitude
c
c                 theta(i) = (i-1)*pi/(nlat-1)
c
c            for i=1,...,nlat and east longitude
c
c                 lambda(j) = (j-1)*2*pi/nlon
c
c            for j=1,...,nlon.
c
C*PL*ERROR* Comment line too long
c            let cost and sint be the cosine and sine at colatitude theta.
C*PL*ERROR* Comment line too long
c            let d( )/dlambda  and d( )/dtheta be the first order partial
C*PL*ERROR* Comment line too long
c            derivatives in longitude and colatitude.  let sf be either v
c            or w.  define:
c
c                 del2s(sf) = [d(sint*d(sf)/dtheta)/dtheta +
c                               2            2
c                              d (sf)/dlambda /sint]/sint
c
c            then the vector laplacian of (v,w) in (vlap,wlap) satisfies
c
c                 vlap = del2s(v) + (2*cost*dw/dlambda - v)/sint**2
c
c            and
c
c                 wlap = del2s(w) - (2*cost*dv/dlambda + w)/sint**2
c
c
C*PL*ERROR* Comment line too long
c  ierror    a parameter which flags errors in input parameters as follows:
c
c            = 0  no errors detected
c
c            = 1  error in the specification of nlat
c
c            = 2  error in the specification of nlon
c
c            = 3  error in the specification of ityp
c
c            = 4  error in the specification of nt
c
c            = 5  error in the specification of idvw
c
c            = 6  error in the specification of jdvw
c
c            = 7  error in the specification of mdbc
c
c            = 8  error in the specification of ndbc
c
c            = 9  error in the specification of lvhses
c
c            = 10 error in the specification of lwork
c
c
c **********************************************************************
c
c     end of documentation for ivlapes
c
c **********************************************************************
c
      SUBROUTINE DIVLAPES(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,
     +                   MDBC,NDBC,WVHSES,LVHSES,WORK,LWORK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WVHSES
      DOUBLE PRECISION WORK
      DIMENSION V(IDVW,JDVW,NT),W(IDVW,JDVW,NT)
      DIMENSION BR(MDBC,NDBC,NT),BI(MDBC,NDBC,NT)
      DIMENSION CR(MDBC,NDBC,NT),CI(MDBC,NDBC,NT)
      DIMENSION WVHSES(LVHSES),WORK(LWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IF (ITYP.LT.0 .OR. ITYP.GT.8) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ITYP.LE.2.AND.IDVW.LT.NLAT) .OR.
     +    (ITYP.GT.2.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDBC.LT.MMAX) RETURN
      IERROR = 8
      IF (NDBC.LT.NLAT) RETURN
      IERROR = 9
c
c     set minimum and verify saved workspace length
c
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      LSAVMIN = LZIMN + LZIMN + NLON + 15
      IF (LVHSES.LT.LSAVMIN) RETURN
c
c     set minimum and verify unsaved work space length
c
      MN = MMAX*NLAT*NT
      L2 = (NLAT+1)/2
      L1 = MIN0(NLAT, (NLON+1)/2)
      IF (ITYP.LE.2) THEN
          LWKMIN = (2*NT+1)*NLAT*NLON + NLAT* (4*NT*L1+1)
      ELSE
          LWKMIN = (2*NT+1)*L2*NLON + NLAT* (4*NT*L1+1)
      END IF
      IF (LWORK.LT.LWKMIN) RETURN
      IERROR = 0
c
c     set work space pointers for vector laplacian coefficients
c
      IF (ITYP.EQ.0 .OR. ITYP.EQ.3 .OR. ITYP.EQ.6) THEN
          IBR = 1
          IBI = IBR + MN
          ICR = IBI + MN
          ICI = ICR + MN
      ELSE IF (ITYP.EQ.1 .OR. ITYP.EQ.4 .OR. ITYP.EQ.7) THEN
          IBR = 1
          IBI = IBR + MN
          ICR = IBI + MN
          ICI = ICR
      ELSE
          IBR = 1
          IBI = 1
          ICR = IBI + MN
          ICI = ICR + MN
      END IF
      IFN = ICI + MN
      IWK = IFN + NLAT
      IF (ITYP.EQ.0 .OR. ITYP.EQ.3 .OR. ITYP.EQ.6) THEN
          LIWK = LWORK - 4*MN - NLAT
      ELSE
          LIWK = LWORK - 2*MN - NLAT
      END IF
      CALL DIVLAPES1(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,WORK(IBR),
     +               WORK(IBI),WORK(ICR),WORK(ICI),MMAX,WORK(IFN),MDBC,
     +               NDBC,BR,BI,CR,CI,WVHSES,LVHSES,WORK(IWK),LIWK,
     +               IERROR)
      RETURN
      END

      SUBROUTINE DIVLAPES1(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BRVW,BIVW,
     +                    CRVW,CIVW,MMAX,FNN,MDBC,NDBC,BR,BI,CR,CI,
     +                    WSAVE,LSAVE,WK,LWK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BRVW
      DOUBLE PRECISION BIVW
      DOUBLE PRECISION CRVW
      DOUBLE PRECISION CIVW
      DOUBLE PRECISION FNN
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WSAVE
      DOUBLE PRECISION WK
      DOUBLE PRECISION FN
      DIMENSION V(IDVW,JDVW,NT),W(IDVW,JDVW,NT)
      DIMENSION FNN(NLAT),BRVW(MMAX,NLAT,NT),BIVW(MMAX,NLAT,NT)
      DIMENSION CRVW(MMAX,NLAT,NT),CIVW(MMAX,NLAT,NT)
      DIMENSION BR(MDBC,NDBC,NT),BI(MDBC,NDBC,NT)
      DIMENSION CR(MDBC,NDBC,NT),CI(MDBC,NDBC,NT)
      DIMENSION WSAVE(LSAVE),WK(LWK)
c
c     preset coefficient multiplyers
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          FNN(N) = -1.0D0/ (FN* (FN+1.D0))
    1 CONTINUE
c
c     set (u,v) coefficients from br,bi,cr,ci
c
      IF (ITYP.EQ.0 .OR. ITYP.EQ.3 .OR. ITYP.EQ.6) THEN
c
c     all coefficients needed
c
          DO 2 K = 1,NT
              DO 3 N = 1,NLAT
                  DO 4 M = 1,MMAX
                      BRVW(M,N,K) = 0.0D0
                      BIVW(M,N,K) = 0.0D0
                      CRVW(M,N,K) = 0.0D0
                      CIVW(M,N,K) = 0.0D0
    4             CONTINUE
    3         CONTINUE
              DO 5 N = 2,NLAT
                  BRVW(1,N,K) = FNN(N)*BR(1,N,K)
                  BIVW(1,N,K) = FNN(N)*BI(1,N,K)
                  CRVW(1,N,K) = FNN(N)*CR(1,N,K)
                  CIVW(1,N,K) = FNN(N)*CI(1,N,K)
    5         CONTINUE
              DO 6 M = 2,MMAX
                  DO 7 N = M,NLAT
                      BRVW(M,N,K) = FNN(N)*BR(M,N,K)
                      BIVW(M,N,K) = FNN(N)*BI(M,N,K)
                      CRVW(M,N,K) = FNN(N)*CR(M,N,K)
                      CIVW(M,N,K) = FNN(N)*CI(M,N,K)
    7             CONTINUE
    6         CONTINUE
    2     CONTINUE
      ELSE IF (ITYP.EQ.1 .OR. ITYP.EQ.4 .OR. ITYP.EQ.7) THEN
c
c     vorticity is zero so cr,ci=0 not used
c
          DO 12 K = 1,NT
              DO 13 N = 1,NLAT
                  DO 14 M = 1,MMAX
                      BRVW(M,N,K) = 0.0D0
                      BIVW(M,N,K) = 0.0D0
   14             CONTINUE
   13         CONTINUE
              DO 15 N = 2,NLAT
                  BRVW(1,N,K) = FNN(N)*BR(1,N,K)
                  BIVW(1,N,K) = FNN(N)*BI(1,N,K)
   15         CONTINUE
              DO 16 M = 2,MMAX
                  DO 17 N = M,NLAT
                      BRVW(M,N,K) = FNN(N)*BR(M,N,K)
                      BIVW(M,N,K) = FNN(N)*BI(M,N,K)
   17             CONTINUE
   16         CONTINUE
   12     CONTINUE
      ELSE
c
c     divergence is zero so br,bi=0 not used
c
          DO 22 K = 1,NT
              DO 23 N = 1,NLAT
                  DO 24 M = 1,MMAX
                      CRVW(M,N,K) = 0.0D0
                      CIVW(M,N,K) = 0.0D0
   24             CONTINUE
   23         CONTINUE
              DO 25 N = 2,NLAT
                  CRVW(1,N,K) = FNN(N)*CR(1,N,K)
                  CIVW(1,N,K) = FNN(N)*CI(1,N,K)
   25         CONTINUE
              DO 26 M = 2,MMAX
                  DO 27 N = M,NLAT
                      CRVW(M,N,K) = FNN(N)*CR(M,N,K)
                      CIVW(M,N,K) = FNN(N)*CI(M,N,K)
   27             CONTINUE
   26         CONTINUE
   22     CONTINUE
      END IF
c
c     sythesize coefs into vector field (v,w)
c
      CALL DVHSES(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BRVW,BIVW,CRVW,CIVW,
     +           MMAX,NLAT,WSAVE,LSAVE,WK,LWK,IERROR)
      RETURN
      END


      subroutine eos_T(rho,cs,T,kappa,mu,gamma,cp)
!-----------------------------------------------------------------------
! Reads and interpolates the equation of state tables to give
! temperatures, opacities ***USING T***
! Updated to fortran 90 PJC 22/05/2008
! Extended to opacities DHF 01/09/2009
!-----------------------------------------------------------------------

	use unitdata

      implicit none

      integer :: i,j
	real :: rho, cs,kappa,mu,gamma, T,cp
      real :: mcs,mcs1,mcs2,ccs,ccs1,ccs2,cs1,cs2
      real :: mmu,mmu1,mmu2,cmu,cmu1,cmu2,mu1,mu2
      real :: mkap,mkap1,mkap2,ckap,ckap1,ckap2,kap1,kap2
      real :: mgamma,mgamma1,mgamma2,cgamma,cgamma1,cgamma2,gamma1,gamma2

! Find the relevant records in the table...
! ... for rho
         if (rho < eostable(1,1,1)) rho = 1.01*eostable(1,1,1)
         i = 1
         do
            if ((eostable(i,1,1) >= rho).or.(i == nrhopoints)) exit
            i = i + 1
         enddo

! ... and for internal energy
         if (T < eostable(1,1,2)) T = 1.01*eostable(1,1,2)
         j = 1
         do
            if ((eostable(i-1,j,2) >= T).or.(j==nUpoints)) exit
            j = j + 1
         enddo
!         if(j==1) j=2
! Interpolate over the j value at i-1
         mcs1 = (eostable(i-1,j-1,3) - eostable(i-1,j,3))/ &
              (eostable(i-1,j-1,2) - eostable(i-1,j,2))
         ccs1 = eostable(i-1,j,3) - mcs1*eostable(i-1,j,2)
         cs1 = mcs1*T + ccs1

         mmu1 = (eostable(i-1,j-1,4) - eostable(i-1,j,4))/ &
              (eostable(i-1,j-1,2) - eostable(i-1,j,2))
         cmu1 = eostable(i-1,j,4) - mmu1*eostable(i-1,j,2)
         mu1 = mmu1*T + cmu1

	 mkap1 = (eostable(i-1,j-1,6) - eostable(i-1,j,6))/ &
              (eostable(i-1,j-1,2) - eostable(i-1,j,2))
	 ckap1 = eostable(i-1,j,6) - mkap1*eostable(i-1,j,2)
	 kap1 = mkap1*T + ckap1

	 mgamma1 = (eostable(i-1,j-1,5) - eostable(i-1,j,5))/ &
              (eostable(i-1,j-1,2) - eostable(i-1,j,2))
	cgamma1 = eostable(i-1,j,5) - mgamma1*eostable(i-1,j,2)
	gamma1 = mgamma1*T + cgamma1

! Then interpolate over the j value at i
! Update j value as necessary
         j = 1
         do
            if ((eostable(i,j,2) >= T).or.(j==nUpoints)) exit
            j = j + 1
         enddo

 !        if(j==1) j=2
         mcs2 = (eostable(i,j-1,3) - eostable(i,j,3))/ &
              (eostable(i,j-1,2) - eostable(i,j,2))
         ccs2 = eostable(i,j,3) - mcs2*eostable(i,j,2)
         cs2 = mcs2*T + ccs2

         mmu2 = (eostable(i,j-1,4) - eostable(i,j,4))/ &
              (eostable(i,j-1,2) - eostable(i,j,2))
         cmu2 = eostable(i,j,4) - mmu2*eostable(i,j,2)
         mu2 = mmu2*T + cmu2

         mkap2 = (eostable(i,j-1,6) - eostable(i,j,6))/ &
              (eostable(i,j-1,2) - eostable(i,j,2))
         ckap2 = eostable(i,j,6) - mkap2*eostable(i,j,2)
         kap2 = mkap2*T + ckap2

	 mgamma2 = (eostable(i,j-1,5) - eostable(i,j,5))/ &
              (eostable(i,j-1,2) - eostable(i,j,2))
         cgamma2 = eostable(i,j,5) - mgamma2*eostable(i,j,2)
         gamma2 = mgamma2*T + cgamma2

! Finally interpolate over i at the fractional j value
         mcs = (cs2 - cs1) / (eostable(i,1,1)-eostable(i-1,1,1))
         ccs = cs2 - mcs*eostable(i,1,1)
         cs = mcs*rho + ccs

         mmu = (mu2 - mu1) / (eostable(i,1,1)-eostable(i-1,1,1))
         cmu = mu2 - mmu*eostable(i,1,1)
         mu = mmu*rho + cmu

	mkap = (kap2 - kap1) / (eostable(i,1,1)-eostable(i-1,1,1))
         ckap = kap2 - mkap*eostable(i,1,1)
         kappa = abs(mkap*rho + ckap)

	mgamma = (gamma2 - gamma1) / (eostable(i,1,1)-eostable(i-1,1,1))
         cgamma = gamma2 - mgamma*eostable(i,1,1)
         gamma = mgamma*rho + cgamma

         cp = cs*cs/(T*gamma*(gamma-1))

      end subroutine eos_T