program tpslqm2

!   Test program for PSLQM2 -- a two-level implementation of the multi-pair
!   PSLQ algorithm for finding integer relations.  Fortran-90 OMP ARPREC version.

!   David H. Bailey     2004-11-23

!   These parameters are set in the parameter statement below.  Some other
!   parameters are set in other routines.

!     idb = Debug level (0 - 3).
!     itr = Number of trials when KQ = 1, 2 or 3.
!     gam = Gamma, the PSLQ algorithm parameter.  Must be set to at least
!           Sqrt (4/3) = 1.154700538d0.
!     n   = Integer relation vector length.
!     kq  = 0 for the algebraic case [1, al, al^2, ... al^(n-1)], where
!           al = 3^(1/kr) - 2^(1/ks).  Set n = kr * ks + 1 and itr = 1.
!         = 1 for testing algebraic relations of a number read from a file.
!         = 2 for testing additive relations of numbers read from a file.
!         = 3 for testing multiplicative relations of numbers read from a file.
!         = 4 for custom input.
!     kr  = Degree of root of 3 when kq = 0.
!     ks  = Degree of root of 2 when kq = 0.
!     ndp = No. digits of pecision.  Must not exceed mpipl in mpmod90.f.
!           It is recommended that this be set to at least 50 digits more
!           than the expected detection level of the relation.
!     nep = Log10 of epsilon for detections.  Normally set to 10 - ndp or so.
!           Must not exceed the accuracy of input data.
!     nsq = Size of duplicate table in iterdp and itermp.  Typically nsq = 8.
!     rb  = Log10 of max size (Euclidean norm) of acceptable relation.

use mpmodule
implicit none
double precision d1, d2, drand, gam, rb, second, tm, tm0, tm1
integer i, idb, iq, itr, j, k, kps, kcs, kq, kr, ks, kss, n, ndp, nep, nsq
parameter (gam = 1.154700538d0, idb = 2, itr = 1, kq = 0, kr = 7, ks = 8, &
  n = kr * ks + 1, nsq = 8, ndp = 660, nep = -650, rb = 100.d0)
integer lnm(n)
character*1 chr1(100)
character*40 nam(n), namx
double precision dr(n), r1(n)
type (mp_real) al, t1, t2, r(n), x(n)
external second

!   This is scratch space for pslqm2.  See below.

integer is0(3*n)
double precision s1(7*n*n+nsq*n+3*n)
type (mp_real) s2(3*n*n+nsq*n+2*n)
save

call mpinit (ndp)
mpoud = 100
mpeps = mpreal (10) ** nep
write (6, 1) itr, gam, n, nsq, kq, kr, ks, rb, ndp, nep
1 format ('PSLQM2 Test Program'/'No. trials = ',i3,3x,'Gamma =',f12.9, &
  3x,'n =',i4,3x,'nsq =',i3,3x,'kq =',i2/'kr =',i2,3x,'ks =',i2,3x, &
  'rb =',1p,d12.4/'Precision level ndp =',i6,' digits',3x, &
  'Epsilon level nep = ',i6)
tm = 0.d0
kps = 0
kcs = 0
if (kq .eq. 1 .or. kq .eq. 2 .or. kq .eq. 3) then
  open (11, file = 'pslq.inp')
  rewind 11
endif

do k = 1, itr
  write (6, 2) k
2 format (/'Start trial', i3)

  if (kq .eq. 0) then

!   This code generates al = 3^(1/kr) - 2^(1/ks).  al is algebraic of degree
!   kr * ks.  Set n = kr * ks + 1 to recover the polynomial satisfied by al.

    al = mpnrtf (mpreal (3.d0), kr) - mpnrtf (mpreal (2.d0), ks)
  elseif (kq .eq. 1) then

!   Read an algebraic constant from a file.

    call mpread (11, al)
  elseif (kq .eq. 2) then

!   Read constants from a file for additive test.

    do i = 1, n
      call mpread (11, al)
      x(i) = al
      write (namx, '(''con'',i3.3)') i
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  elseif (kq .eq. 3) then

!   Read constants from a file for multiplicative test.

    do i = 1, n
      call mpread (11, al)
      x(i) = log (al)
      write (namx, '(''log(con'',i3.3,'')'')') i
      nam(i) = namx(1:11)
      lnm(i) = 11
    enddo
  elseif (kq .eq. 4) then

!   Produce X vector by a custom scheme.

  endif

!   If kq is 0 or 1, generate x = [1, al, al^2, ..., al^(n-1)].

  if (kq .eq. 0 .or. kq .eq. 1) then
    x(1) = 1.d0
    nam(1) = '1'
    lnm(1) = 1

    do i = 2, n
      x(i) = al * x(i-1)
      write (namx, '(''al^'',i3)') i - 1
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  endif

!   Perform relation search.

  tm0 = second ()
  call pslqm2 (idb, gam, n, nsq, rb, x, is0, s1, s2, iq, r)
  tm1 = second ()

!   Output relation, if one was found.

  if (iq .ne. 0) then
    tm = tm + (tm1 - tm0)
    write (6, 4)
4   format ('Recovered relation: 0 =')

    do i = 1, n
      if (r(i) .ne. 0.d0) then
        call mpfform (r(i), 48, 0, chr1)
        write (6, '(''+'',48a1,'' * '',a)') (chr1(j), j = 1, 48), &
          nam(i)(1:lnm(i))
      endif
    enddo

!   Check if original relation was recovered.

    if (kq .eq. 1) then
      d1 = 0.d0
      d2 = 0.d0

      do i = 1, n
        d1 = d1 + abs (dble (r(i)) - r1(i))
        d2 = d2 + abs (dble (r(i)) + r1(i))
      enddo

      if (d1 .eq. 0.d0 .or. d2 .eq. 0.d0) then
        kcs = kcs + 1
        write (6, 5)
5       format ('Original relation recovered.')
      else
        kps = kps + 1
      endif
    endif
  endif
  write (6, 6) tm1 - tm0
6 format ('CPU Time =',f12.4)
enddo

if (itr .gt. 1) then
  write (6, 7) kps, kcs
7 format (/'No. partial successes =',i5/'No. complete successes =',i5)
  kss = kps + kcs
  if (kss .ne. 0) then
    tm = tm / kss
    write (6, 8) tm
8   format ('Ave. CPU time of PS or CS runs =',f10.4)
  endif
endif
stop
end

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

!   The following code performs the two-level, multi-pair PSLQ algorithm.
!   David H. Bailey     2004-06-10

subroutine pslqm2 (idb, gam, n, nsq, rb, x, is0, s1, s2, iq, r)

!   This routine allocates the scratch space arrays is0, s1 and s2.  Handling
!   scratch space in this manner is not really necessary in Fortran-90, but
!   this design facilitates straightforward translation to Fortran-77.

!   Arguments are as follows:
!     idb = Debug flag (0-3).
!     gam = PSLQ gamma parameter, normally set to sqrt(4/3).
!     n   = Dimension of input vector.
!     nsq = Size of tables used in iterdp and itermp.
!     rb  = Log10 of max size (Euclidean norm) of acceptable relation (type DP).
!     x   = Input real vector (type mp_real).
!     is0 = Scratch array (type integer -- see size below).
!     s1  = Scratch array (type double precision -- see size below).
!     s2  = Scratch array (type mp_real -- see size below).
!     iq  = Output flag: 0 (unsuccessful) or 1 (successful).
!     r   = Output integer coefficient vector (type mp_real).

use mpmodule
implicit none
integer idb, iq, n, nsq
double precision gam, rb
integer is0(3*n)
double precision s1(7*n*n+nsq*n+3*n)
type (mp_real) s2(3*n*n+nsq*n+2*n), x(n), r(n)

call pslqm2x (idb, gam, n, nsq, rb, x, is0(1), is0(n+1), is0(2*n+1), &
  s1(1), s1(n*n+1), s1(2*n*n+1), s1(3*n*n+1), s1(4*n*n+1), s1(5*n*n+1), &
  s1(6*n*n+1), s1(7*n*n+1), s1(7*n*n+nsq*n+1), s1(7*n*n+nsq*n+n+1), &
  s1(7*n*n+nsq*n+2*n+1), s2(1), s2(n*n+1), s2(2*n*n+1), s2(3*n*n+1), &
  s2(3*n*n+nsq*n+1), s2(3*n*n+nsq*n+n+1), iq, r)
return
end

subroutine pslqm2x (idb, gam, n, nsq, rb, x, ip, ir, is, da, db, dh, dsa, &
  dsb, dsh, dt, dsyq, dq, dy, dsy, b, h, t, syq, s, y, iq, r)

!   The following parameters are set in this routine:
!     ipi = Iteration print interval when idb >= 2.
!     ipm = Iteration check interval for MP iterations; also save interval.
!     itm = Maximum iteration count.  Run is aborted when this is exceeded.

use mpmodule
implicit none
integer i, idb, imq, ipi, ipm, iq, it, itm, its, izd, izm, j, j1, n, n1, n2, &
  n3, nsq
parameter (ipi = 100, ipm = 10, itm = 1000000)
double precision bounddp, d1, d2, d3, d4, gam, rb, rn, second, tm0, tm1, &
  times(4)
integer ip(n), ir(n), is(n)
double precision da(n,n), db(n,n), dh(n,n), dq(n), dsa(n,n), dsb(n,n), &
  dsh(n,n), dsyq(n,nsq), dt(n,n), dy(n), dsy(n)
type (mp_real) b(n,n), h(n,n), s(n), syq(n,nsq), t(n,n), r(n), x(n), &
  y(n), t1, t2, t3
external bounddp, second

!   Initialize.

if (idb .ge. 2) write (6, 1) n
1 format ('PSLQM2 integer relation detection: n =',i5)
iq = 0
it = 0
imq = 0
rn = 0.d0

do i = 1, 4
  times(i) = 0.d0
enddo

if (idb .ge. 2) write (6, 2) it
2 format ('Iteration',i7,3x,'MP initialization')
tm0 = second ()
call initmp (idb, n, nsq, ip, dt, b, h, s, syq, x, y)
tm1 = second ()
times(1) = tm1 - tm0

100 continue

!   Initialize DP arrays from MP arrays.

if (idb .ge. 3) write (6, 3) it
3 format ('Iteration',i7,3x,'Start DP iterations')
call initdp (idb, it, n, nsq, da, db, dh, dy, dsyq, h, y, izd)
call savedp (n, da, db, dh, dy, dsa, dsb, dsh, dsy)
its = it

if (izd .eq. 0) then

!   Perform an LQ decomposition on dh, prior to DP iterations.

  call lqdp (n, n - 1, dh)

!   Perform DP iterations.

110 continue

  it = it + 1
  if (idb .ge. 3 .or. idb .ge. 2 .and. mod (it, ipi) .eq. 0) write (6, 4) it
4 format ('Iteration',i7)
  tm0 = second ()
  call iterdp (idb, gam, it, n, nsq, ip, ir, is, da, db, dh, dq, dsyq, &
    dt, dy, imq, izd)
  tm1 = second ()
  times(2) = times(2) + (tm1 - tm0)

  if (izd .eq. 0) then
    if (mod (it - its, ipm) .eq. 0) then
      call savedp (n, da, db, dh, dy, dsa, dsb, dsh, dsy)
      its = it
    endif
    goto 110
  else

!   Update MP arrays from the DP arrays.

    if (izd .eq. 2) then

!   DP iteration was aborted -- revert to previous data.

      it = its
      call savedp (n, dsa, dsb, dsh, dsy, da, db, dh, dy)
    endif

    if (idb .ge. 3) write (6, 5) it
5   format ('Iteration',i7,3x,'MP update')
    tm0 = second ()
    call updtmp (idb, it, n, ip, dt, da, db, b, h, t, y, izm)
    tm1 = second ()
    times(3) = times(3) + (tm1 - tm0)

!   Compute norm bound.

    do j = 1, n - 1
      do i = 1, n
        dh(i,j) = h(i,j)
      enddo
    enddo

    call lqdp (n, n - 1, dh)
    d3 = bounddp (n, dh)
    if (d3 == -1.d0) goto 150
    rn = max (rn, d3)
    if (idb .ge. 2) then
      write (6, 6) it, d3, rn
6     format ('Iteration',i7,3x,'Norm bound =',1p,d15.6,4x,'Max. bound =', &
        1p,d15.6)
    endif
    if (it .gt. itm) then
      if (idb .ge. 1) write (6, 7) itm
7     format ('Iteration limit exceeded',i7)
      goto 150
    endif
    if (log10 (rn) .gt. rb) then
      if (idb .ge. 1) write (6, 8) rb
8     format ('Norm bound limit exceeded.',1p,d15.6)
      goto 150
    endif
    if (izm .eq. 0) then
      if (izd .eq. 2) then
        goto 120
      else
        goto 100
      endif
    elseif (izm .eq. 1) then
      goto 140
    elseif (izm .eq. 2) then
      goto 150
    endif
  endif
endif

120 continue

!   Perform an LQ decomposition on h, prior to MP iterations.

if (idb .ge. 2) write (6, 9) it
9 format ('Iteration',i7,3x,'Start MP iterations')
tm0 = second ()
call lqmp (n, n - 1, h)
tm1 = second ()
times(1) = times(1) + (tm1 - tm0)

!   Perform MP iterations.

130 continue

it = it + 1
if (idb .ge. 2) write (6, 10) it
10 format ('Iteration',i7)
tm0 = second ()
call itermp (idb, gam, it, n, nsq, ip, ir, is, dt, b, h, s, syq, t, y, &
  imq, izm)
tm1 = second ()
times(4) = times(4) + (tm1 - tm0)

if (izm .eq. 0) then
  if (mod (it - its, ipm) .eq. 0) then

!   Check to see if DP iterations can be resumed.

    call check (idb, it, n, h, y, izd)
    if (izd .eq. 0) then
      if (idb .ge. 2) write (6, 11) it
11    format ('Iteration',i7,3x,'Return to DP iterations')
      goto 100
    endif
  endif
  goto 130
elseif (izm .eq. 1) then
  goto 140
elseif (izm .eq. 2) then
  goto 150
endif

!   A relation has been detected.

140 continue

tm0 = second ()
t1 = 1.d300
t2 = 0.d0
t3 = 0.d0

!   Select the relation corresponding to the smallest y entry and compute norm.

do j = 1, n
  if (abs (y(j)) < t1) then
    j1 = j
    t1 = abs (y(j))
  endif
  t2 = max (t2, abs (y(j)))
enddo

do i = 1, n
  r(i) = b(j1,i)
  t3 = t3 + r(i) ** 2
enddo

t3 = sqrt (t3)
call decmd (t3, d3, n3)
d3 = d3 * 10.d0 ** n3

!   Output the final norm bound and other info.

if (idb .ge. 1) then
  do j = 1, n - 1
    do i = 1, n
      dh(i,j) = h(i,j)
    enddo
  enddo

  call lqdp (n, n - 1, dh)
  d4 = bounddp (n, dh)
  rn = max (rn, d4)
  call decmd (t1, d1, n1)
  call decmd (t2, d2, n2)
  write (6, 12) it, d1, n1, d2, n2, rn
12 format ('Iteration',i7,3x,'Relation detected'/ &
  'Min, max of y =',0p,f11.6,'D',i5,f11.6,'D',i5/'Max. bound =',1p,d15.6)
  write (6, 13) j1, d3, d1, n1
13 format ('Index of relation =',i4,3x,'Norm =',1p,d15.6,3x, &
  'Residual =',0p,f11.6,'D',i5)
endif

if (log10 (d3) .le. rb) then
  iq = 1
else
  if (idb .ge. 2) write (6, 14)
14 format ('Relation is too large.')
endif

150 continue

if (idb .ge. 2) write (6, 15) times
15 format ('CPU times:'/(4f12.2))

return
end

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

!   First-level subroutines.

subroutine check (idb, it, n, h, y, izd)

!   This checks h and y to see if DP iterations can be resumed.

use mpmodule
implicit none
integer i, idb, it, izd, n, n1, nws
double precision d1, deps
parameter (deps = 1d-10)
type (mp_real) h(n,n), y(n), t1, t2, t3, t4

call mpgetprecwords (nws)
call mpsetprecwords (5)
izd = 0
t1 = 1.d300
t2 = 0.d0

!   Find the min and max absolute value in the y vector.

do i = 1, n
  t1 = min (t1, abs (y(i)))
  t2 = max (t2, abs (y(i)))
enddo

t3 = t1 / t2
t4 = deps
if (t3 .lt. t4) then
  if (idb .ge. 2) then
    call decmd (t3, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'check: Small min/max ratio in y =',f11.6, &
    'D',i5)
  endif
  izd = 1
endif

call mpsetprecwords (nws)
return
end

subroutine initdp (idb, it, n, nsq, da, db, dh, dy, dsyq, h, y, izd)

!   This re-initializes the DP arrays from the MP arrays.

use mpmodule
implicit none
integer i, idb, it, izd, j, n, n1, nsq, nws
double precision da(n,n), db(n,n), dh(n,n), dy(n), dsyq(n,nsq), d1, deps
type (mp_real) h(n,n), y(n), t1, t2, t3, t4
parameter (deps = 1d-10)

call mpgetprecwords (nws)
call mpsetprecwords (5)
izd = 0
t1 = 1.d300
t2 = 0.d0

!   Find the min and max absolute value in the y vector.

do i = 1, n
  t1 = min (t1, abs (y(i)))
  t2 = max (t2, abs (y(i)))
enddo

!   If the dynamic range of the y vector is too great, set the izd flag and
!   abort this initialization.

t3 = t1 / t2
t4 = deps
if (t3 .lt. t4) then
  if (idb .ge. 3) then
    call decmd (t3, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'initdp: Small min/max ratio in y =',f11.6, &
    'D',i5)
  endif
  izd = 1
  goto 100
endif

!   Set dy to be the scaled y vector.

t1 = 1.d0 / t2

do i = 1, n
  dy(i) = t1 * y(i)
enddo

!   Find the maximum absolute value of the h matrix diagonals.

t2 = 0.d0

do j = 1, n - 1
  t2 = max (t2, abs (h(j,j)))
enddo

!   Set dh to be the scaled h matrix.

t1 = 1.d0 / t2

do j = 1, n - 1
  do i = 1, n
    dh(i,j) = t1 * h(i,j)
  enddo
enddo

!   Set da and db to the identity.

do j = 1, n
  do i = 1, n
    da(i,j) = 0.d0
    db(i,j) = 0.d0
  enddo

  da(j,j) = 1.d0
  db(j,j) = 1.d0
enddo

!   Zero the dsyq array.

do j = 1, nsq
  do i = 1, n
    dsyq(i,j) = 0.d0
  enddo
enddo

if (idb .ge. 3) then
  write (6, 2)
2 format ('initdp: Scaled dy vector:')
  call matoutdp (1, n, dy)
  write (6, 3)
3 format ('initdp: Scaled dh matrix:')
  call matoutdp (n, n - 1, dh)
endif

100 continue

call mpsetprecwords (nws)
return
end

subroutine initmp (idb, n, nsq, ix, dx, b, h, s, syq, x, y)

!   This initializes MP arrays at the beginning.

use mpmodule
implicit none
integer i, idb, j, n, nsq
double precision d1
integer ix(n)
double precision dx(n)
type (mp_real) b(n,n), h(n,n), s(n), syq(n,nsq), x(n), y(n), t1

if (idb .ge. 3) then
  write (6, 1)
1 format ('initmp: Input x vector:')
  call matoutmd (1, n, ix, dx, x)
endif

!   Set b to the identity matrix.

do j = 1, n
  do i = 1, n
    b(i,j) = 0.d0
  enddo

  b(j,j) = 1.d0
enddo

t1 = 0.d0

!   Compute the x vector, the square root of the partial sum of squares of x,
!   and the y vector, which is the normalized x vector.

do i = n, 1, -1
  t1 = t1 + x(i) ** 2
  s(i) = sqrt (t1)
enddo

t1 = 1.d0 / s(1)

do i = 1, n
  y(i) = t1 * x(i)
  s(i) = t1 * s(i)
enddo

!   Compute the initial h matrix.

!$omp parallel do private (i, j, t1) copyin (mp5)
do j = 1, n - 1
  do i = 1, j - 1
    h(i,j) = 0.d0
  enddo

  h(j,j) = s(j+1) / s(j)
  t1 = y(j) / (s(j) * s(j+1))

  do i = j + 1, n
    h(i,j) = - y(i) * t1
  enddo
enddo
!$omp end parallel do

!   Zero the syq array.

do j = 1, nsq
  do i = 1, n
    syq(i,j) = 0.d0
  enddo
enddo

if (idb .ge. 3) then
  write (6, 2)
2 format ('initmp: Initial y vector:')
  call matoutmd (1, n, ix, dx, y)
  write (6, 3)
3 format ('initmp: Initial h matrix:')
  call matoutmd (n, n - 1, ix, dx, h)
endif

return
end

subroutine iterdp (idb, gam, it, n, nsq, ip, ir, is, da, db, dh, dq, dsyq, &
  dt, dy, imq, izd)

!   This performs one iteration of the PSLQ algorithm using DP arithmetic.

use mpmodule
implicit none
integer i, idb, ii, ij, im, im1, imq, it, izd, j, j1, j2, k, mpr, mq, n, &
  n1, nsq
double precision deps, gam, t1, t2, t3, t4, tmx1, tmx2
integer ip(n), ir(n), is(n)
double precision da(n,n), db(n,n), dh(n,n), dq(n), dsyq(n,nsq), &
  dt(n,n), dy(n)
parameter (tmx1 = 1.d13, tmx2 = 2.d0**52, deps = 1.d-14)

izd = 0
mpr = nint (0.4d0 * n)

!   Compute dq vector = {gam^i * |dh(i,i)|}, then sort in ascending order.

do i = 1, n - 1
  dq(i) = gam ** i * abs (dh(i,i))
enddo

call qsortdp (n - 1, dq, ip)

!   Select up to mpr disjoint pairs of indices (m,m+1), where m is an index
!   from the list of the largest dq(i).

do i = 1, n
  is(i) = 0
enddo

if (imq .eq. 0) then
  mq = mpr
else
  mq = 1
  imq = 0
endif
ii = n

do i = 1, mq
100 continue
  ii = ii - 1
  if (ii .eq. 0) then
    mq = i - 1
    goto 110
  endif
  j1 = ip(ii)
  j2 = j1 + 1
  if (is(j1) .ne. 0 .or. is(j2) .ne. 0) goto 100
  ir(i) = j1
  is(j1) = 1
  is(j2) = 1
enddo

110 continue

!   Exchange the pairs of entries of dy, and rows of da, db and dh.

do j = 1, mq
  im = ir(j)
  im1 = im + 1
  t1 = dy(im)
  dy(im) = dy(im1)
  dy(im1) = t1

  do i = 1, n
    t1 = da(im,i)
    da(im,i) = da(im1,i)
    da(im1,i) = t1
    t1 = db(im,i)
    db(im,i) = db(im1,i)
    db(im1,i) = t1
  enddo

  do i = 1, n - 1
    t1 = dh(im,i)
    dh(im,i) = dh(im1,i)
    dh(im1,i) = t1
  enddo
enddo

!   Eliminate the "corners" produced by the above permutation in dh.

do j = 1, mq
  im = ir(j)
  im1 = im + 1
  if (im .le. n - 2) then
    t1 = dh(im,im)
    t2 = dh(im,im1)
    t3 = sqrt (t1 ** 2 + t2 ** 2)
    t1 = t1 / t3
    t2 = t2 / t3

    do i = im, n
      t3 = dh(i,im)
      t4 = dh(i,im1)
      dh(i,im) = t1 * t3 + t2 * t4
      dh(i,im1) = - t2 * t3 + t1 * t4
    enddo
  endif
enddo

!   Perform reduction on dh, using the diagonal scheme.  Multipliers are
!   saved in the dt array.

do i = 2, n
  do j = 1, n - i + 1
    ij = i + j - 1

    do k = j + 1, ij - 1
      dh(ij,j) = dh(ij,j) - dt(ij,k) * dh(k,j)
    enddo

    dt(ij,j) = anint (dh(ij,j) / dh(j,j))
    dh(ij,j) = dh(ij,j) - dt(ij,j) * dh(j,j)
  enddo
enddo

!   Update dy, using the dt array.  Find min absolute value of dy.

t1 = abs (dy(n))

do j = 1, n - 1
  do i = j + 1, n
    dy(j) = dy(j) + dt(i,j) * dy(i)
  enddo

  t1 = min (t1, abs (dy(j)))
enddo

!   Update da and db, using the dt array.  Find the max absolute value of
!   da and db entries as they are calculated (not merely at the end).

t2 = 0.d0

!$omp parallel do private (i, j, k, t3)
do k = 1, n
  t3 = 0.d0

  do j = 1, n - 1
    do i = j + 1, n
      da(i,k) = da(i,k) - dt(i,j) * da(j,k)
      db(j,k) = db(j,k) + dt(i,j) * db(i,k)
      t3 = max (t3, abs (da(i,k)), abs (db(j,k)))
    enddo
  enddo

  dq(k) = t3
enddo
!$omp end parallel do

do k = 1, n
  t2 = max (t2, dq(k))
enddo

if (t1 .le. deps) then
  if (idb .ge. 3) write (6, 1) it, t1
1 format ('Iteration',i7,3x,'iterdp: Small value in dy =',1pd15.6)
  izd = 1
endif

if (t2 .gt. tmx1 .and. t2 .le. tmx2) then
  if (idb .ge. 3) write (6, 2) it, t2
2 format ('Iteration',i7,3x,'iterdp: Large value in da or db =',1pd15.6)
  izd = 1
elseif (t2 .gt. tmx2) then
  if (idb .ge. 2) write (6, 3) it, t2
3 format ('Iteration',i7,3x,'iterdp: Very large value in da or db =',1pd15.6)
  izd = 2
  return
endif

!   Compare the dy vector with those of recent iterations.  If a duplicate is
!   found, then the next iteration must be performed with mq = 1.

do j = 1, nsq
  t1 = 0.d0

  do i = 1, n
    t1 = max (t1, abs (dy(i) - dsyq(i,j)))
  enddo

  if (t1 .le. deps) then
    if (idb .ge. 2) write (6, 4) it, j
4   format ('Iteration',i7,3x,'iterdp: Duplicate found, j =',i6)
    imq = 1
    goto 120
  endif
enddo

!   Place the vector dy in the table dsyq.

120   continue
k = 1 + mod (it, nsq)

do i = 1, n
  dsyq(i,k) = dy(i)
enddo

if (idb .ge. 3) then
  write (6, 5)
5 format ('iterdp: Updated dy:')
  call matoutdp (1, n, dy)
  write (6, 6)
6 format ('iterdp: Updated da matrix:')
  call matoutdp (n, n, da)
  write (6, 7)
7 format ('iterdp: Updated db matrix:')
  call matoutdp (n, n, db)
  write (6, 8)
8 format ('iterdp: Updated dh matrix:')
  call matoutdp (n, n - 1, dh)
endif

return
end

subroutine itermp (idb, gam, it, n, nsq, ip, ir, is, dx, b, h, q, syq, t, &
  y, imq, izm)

!   This performs one iteration of the PSLQM algorithm using MP arithmetic.

use mpmodule
implicit none
integer i, idb, ii, ij, im, im1, imq, it, izm, j, j1, j2, k, mpr, mq, n, n1, &
  nsq, ntl
parameter (ntl = 72)
double precision d1, d2, gam
type (mp_real) t1, t2, t3, t4, teps
integer ip(n), ir(n), is(n)
double precision dx(n)
type (mp_real) b(n,n), h(n,n), q(n), syq(n,nsq), t(n,n), y(n)

teps = 2.d0 ** ntl * mpeps
izm = 0
mpr = nint (0.4d0 * n)

!   Compute q vector = {gam^i * |h(i,i)|}, then sort in ascending order.

do i = 1, n - 1
  q(i) = gam ** i * abs (h(i,i))
enddo

call qsortmp (n - 1, q, ip)

!   Select up to mpr disjoint pairs of indices (m,m+1), where m is an index
!   from the list of the largest q(i).

do i = 1, n
  is(i) = 0
enddo

if (imq .eq. 0) then
  mq = mpr
else
  mq = 1
  imq = 0
endif
ii = n

do i = 1, mq
100 continue
  ii = ii - 1
  if (ii .eq. 0) then
    mq = i - 1
    goto 110
  endif
  j1 = ip(ii)
  j2 = j1 + 1
  if (is(j1) .ne. 0 .or. is(j2) .ne. 0) goto 100
  ir(i) = j1
  is(j1) = 1
  is(j2) = 1
enddo

110 continue

!   Exchange the pairs of entries of y, and rows of b and h.

do j = 1, mq
  im = ir(j)
  im1 = im + 1
  t1 = y(im)
  y(im) = y(im1)
  y(im1) = t1

  do i = 1, n
    t1 = b(im,i)
    b(im,i) = b(im1,i)
    b(im1,i) = t1
  enddo

  do i = 1, n - 1
    t1 = h(im,i)
    h(im,i) = h(im1,i)
    h(im1,i) = t1
  enddo
enddo

!   Eliminate the "corners" produced by the above permutation in h.

!$omp parallel do private (i, j, im, im1, t1, t2, t3, t4) copyin (mp5)
do j = 1, mq
  im = ir(j)
  im1 = im + 1
  if (im .le. n - 2) then
    t1 = h(im,im)
    t2 = h(im,im1)
    t3 = sqrt (t1 ** 2 + t2 ** 2)
    t1 = t1 / t3
    t2 = t2 / t3

    do i = im, n
      t3 = h(i,im)
      t4 = h(i,im1)
      h(i,im) = t1 * t3 + t2 * t4
      h(i,im1) = - t2 * t3 + t1 * t4
    enddo
  endif
enddo
!$omp end parallel do

!   Perform reduction on h, using the diagonal scheme.  Multipliers are
!   saved in the t array.

do i = 2, n
!$omp parallel do private (ij, j, k) copyin (mp5)
  do j = 1, n - i + 1
    ij = i + j - 1

    do k = j + 1, ij - 1
      h(ij,j) = h(ij,j) - t(ij,k) * h(k,j)
    enddo

    t(ij,j) = anint (h(ij,j) / h(j,j))
    h(ij,j) = h(ij,j) - t(ij,j) * h(j,j)
  enddo
!$omp end parallel do
enddo

!   Update y, using the t array.  Find min absolute value of y.

t1 = abs (y(n))
j1 = n

do j = 1, n - 1
  do i = j + 1, n
    y(j) = y(j) + t(i,j) * y(i)
  enddo

  if (abs (y(j)) < t1) then
    j1 = j
    t1 = abs (y(j))
  endif
enddo

!   Update b, using the t array.

!$omp parallel do private (i, j, k) copyin (mp5)
do k = 1, n
  do j = 1, n - 1
    do i = j + 1, n
      b(j,k) = b(j,k) + t(i,j) * b(i,k)
    enddo
  enddo
enddo
!$omp end parallel do

!  Find the largest entry of b in the same row as the smallest y.

t2 = 0.d0

do i = 1, n
  t2 = max (t2, abs (b(j1,i)))
enddo

if (t1 .le. t2 * teps) then
  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'itermp: Small value in y =',f11.6,'D',i5)
  endif
  if (t1 .le. t2 * mpeps) then
    izm = 1
  else
    if (idb .ge. 1) write (6, 2) it
 2  format ('Iteration',i7,3x,'itermp: Precision exhausted.')
    izm = 2
  endif
endif

!   Compare the y vector with those of recent iterations.  If a duplicate is
!   found, then the next iteration must be performed with mq = 1.

do j = 1, nsq
  t1 = 0.d0

  do i = 1, n
    t1 = max (t1, abs (y(i) - syq(i,j)))
  enddo

  if (t1 .le. t2 * teps) then
    if (idb .ge. 2) write (6, 3) it, j
3   format ('Iteration',i7,3x,'itermp: Duplicate found, j =',i6)
    imq = 1
    goto 120
  endif
enddo

!   Place the vector y in the table syq.

120   continue
k = 1 + mod (it, nsq)

do i = 1, n
  syq(i,k) = y(i)
enddo

if (idb .ge. 3) then
  write (6, 4)
4 format ('itermp: Updated y:')
  call matoutmd (1, n, ip, dx, y)
  write (6, 5)
5 format ('itermp: Updated b matrix:')
  call matoutmd (n, n, ip, dx, b)
  write (6, 6)
6 format ('itermp: Updated h matrix:')
  call matoutmd (n, n - 1, ip, dx, h)
endif

return
end

subroutine lqdp (n, m, dh)

!   This performs an LQ decomposition on the DP matrix dh.  It is a simplified
!   and transposed adaptation of the subroutine dqrdc from Linpack.

implicit none
integer i, j, jp, l, lup, m, ml, n
double precision dh(n,m), nrmxl, one, t, zero

zero = 0.d0
one = 1.d0
lup = min (m,n)

!   Perform the householder reduction of dh.

do l = 1, lup
  if (l .eq. m) go to 280

!   Compute the householder transformation for column l.

  ml = m - l
  t = zero

  do i = 0, ml
    t = t + dh(l,l+i) ** 2
  enddo

  nrmxl = sqrt (t)
  if (nrmxl .eq. zero) go to 270
  if (dh(l,l) .ne. zero) nrmxl = sign (nrmxl, dh(l,l))
  t = one / nrmxl

  do i = 0, ml
    dh(l,l+i) = t * dh(l,l+i)
  enddo

  dh(l,l) = one + dh(l,l)

!   Apply the transformation to the remaining columns, updating the norms.

  do j = l + 1, n
    t = zero

    do i = 0, ml
      t = t + dh(l,l+i) * dh(j,l+i)
    enddo

    t = - t / dh(l,l)

    do i = 0, ml
      dh(j,l+i) = dh(j,l+i) + t * dh(l,l+i)
    enddo
  enddo

!   Save the transformation.

  dh(l,l) = - nrmxl
270 continue
280 continue
enddo

!   Zero dh above the diagonal.

do j = 1, m
  do i = 1, j - 1
    dh(i,j) = 0.d0
  enddo
enddo

return
end

subroutine lqmp (n, m, h)

!   This performs an LQ decomposition on the MP matrix h.  It is a simplified
!   and transposed adaptation of the subroutine dqrdc from Linpack.

use mpmodule
implicit none
integer i, j, jp, l, lup, m, ml, n
type (mp_real) h(n,m), nrmxl, one, t, zero

zero = 0.d0
one = 1.d0
lup = min (m,n)

!   Perform the householder reduction of h.

do l = 1, lup
  if (l .eq. m) go to 280

!   Compute the householder transformation for column l.

  ml = m - l
  t = zero

  do i = 0, ml
    t = t + h(l,l+i) ** 2
  enddo

  nrmxl = sqrt (t)
  if (nrmxl .eq. zero) go to 270
  if (h(l,l) .ne. zero) nrmxl = sign (nrmxl, h(l,l))
  t = one / nrmxl

  do i = 0, ml
    h(l,l+i) = t * h(l,l+i)
  enddo

  h(l,l) = one + h(l,l)

!   Apply the transformation to the remaining columns, updating the norms.

!$omp parallel do private (i, j, t) copyin (mp5)
  do j = l + 1, n
    t = zero

    do i = 0, ml
      t = t + h(l,l+i) * h(j,l+i)
    enddo

    t = - t / h(l,l)

    do i = 0, ml
      h(j,l+i) = h(j,l+i) + t * h(l,l+i)
    enddo
  enddo
!$omp end parallel do

!   Save the transformation.

  h(l,l) = - nrmxl
270 continue
280 continue
enddo

!   Zero h above the diagonal.

do j = 1, m
  do i = 1, j - 1
    h(i,j) = 0.d0
  enddo
enddo

return
end

subroutine savedp (n, da, db, dh, dy, dsa, dsb, dsh, dsy)

!   This saves the arrays dy, da, db, dh in case dp iterations must be aborted.
!   A call to the same routine, with (da,db,dh,dy) and (dsa,dsb,dsh,dsy)
!   exchanged, serves to restore these arrays.

implicit none
integer i, j, n
double precision da(n,n), db(n,n), dh(n,n), dy(n), dsa(n,n), dsb(n,n), &
  dsh(n,n), dsy(n)

do i = 1, n
  dsy(i) = dy(i)
enddo

do j = 1, n
  do i = 1, n
    dsa(i,j) = da(i,j)
    dsb(i,j) = db(i,j)
  enddo
enddo

do j = 1, n - 1
  do i = 1, n
    dsh(i,j) = dh(i,j)
  enddo
enddo

return
end

subroutine updtmp (idb, it, n, ix, dx, da, db, b, h, t, y, izm)

!   This updates the MP arrays from the DP arrays.

use mpmodule
implicit none
integer i, i1, idb, it, izm, j, n, n1, n2, ntl
parameter (ntl = 72)
integer ix(n)
double precision da(n,n), db(n,n), dx(n), d1, d2
type (mp_real) b(n,n), h(n,n), t(n), y(n), t1, t2, teps

if (idb .ge. 3) write (6, 1) it
1 format ('Iteration',i7,3x,'updtmp: MP update from DP arrays.')
teps = 2.d0 ** ntl * mpeps
izm = 0
t1 = 1.d300
t2 = 0.d0

!   Update y with db.

call mxmdm (n, 1, db, y, t)

do i = 1, n
  if (abs (y(i)) < t1) then
    i1 = i
    t1 = abs (y(i))
  endif
  t2 = max (t2, abs (y(i)))
enddo

if (idb .ge. 2) then
  call decmd (t1, d1, n1)
  call decmd (t2, d2, n2)
  write (6, 2) it, d1, n1, d2, n2
2  format ('Iteration',i7,3x,'updtmp: Min, max of y =',f11.6,'D',i5, &
     f11.6,'D',i5)
endif

!   Update b with db.

call mxmdm (n, n, db, b, t)

!   Update h with da.  There is no need to perform a LQ decomposition on h.

call mxmdm (n, n - 1, da, h, t)

!   Find the largest entry of b in the same row as the smallest y.

t2 = 0.d0

do i = 1, n
  t2 = max (t2, abs (b(i1,i)))
enddo

if (t1 .le. t2 * teps) then
  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    write (6, 3) it, d1, n1
3   format ('Iteration',i7,3x,'updtmp: Small value in y =',f11.6,'D',i5)
  endif
  if (t1 .le. t2 * mpeps) then
    izm = 1
  else
    if (idb .ge. 1) write (6, 4) it
4   format ('Iteration',i7,3x,'updtmp: Precision exhausted.')
    izm = 2
  endif
endif

if (idb .ge. 3) then
  write (6, 5)
5 format ('updtmp: Updated y:')
  call matoutmd (1, n, ix, dx, y)
  write (6, 6)
6 format ('updtmp: Updated b matrix:')
  call matoutmd (n, n, ix, dx, b)
  write (6, 7)
7 format ('updtmp: Updated h matrix:')
  call matoutmd (n, n - 1, ix, dx, h)
endif

return
end

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

!   Second- and third-level subroutines.

function bounddp (n, dh)

!   This computes the norm bound using DP arithmetic.

implicit none
integer i, n
double precision bounddp, t1, t2
double precision dh(n,n)

t1 = 0.d0

do i = 1, n - 1
  t1 = max (t1, abs (dh(i,i)))
enddo

if (t1 < 1.d-300) then
  write (6, 1)
1 format ('bound: h matrix too small -- use 1-level or 3-level pslqm program.')
  bounddp = -1.d0
else
  bounddp = 1.d0 / t1
endif

return
end

subroutine decmd (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end

function drand ()

!   This routine returns a pseudorandom DP floating number nearly uniformly
!   distributed between 0 and 1 by means of a linear congruential scheme.
!   2^28 pseudorandom numbers with 30 bits each are returned before repeating.

implicit none
double precision drand, f7, r30, sd, t1, t2, t30
parameter (f7 = 78125.d0, r30 = 0.5d0 ** 30, t30 = 2.d0 ** 30)
save sd
data sd/314159265.d0/

t1 = f7 * sd
t2 = aint (r30 * t1)
sd = t1 - t30 * t2
drand = r30 * sd

return
end

subroutine matoutdp (n1, n2, a)

!   This outputs the DP matrix a.

implicit none
integer i, j, n1, n2
double precision a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)
  write (6, 2) (a(i,j), j = 1, n2)
2 format (1p5d15.5)
enddo

return
end

subroutine matoutmd (n1, n2, ix, dx, a)

!   This outputs the MP matrix a as a DP matrix.

use mpmodule
implicit none
integer i, j, n1, n2
integer ix(n2)
double precision dx(n2)
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call decmd (a(i,j), dx(j), ix(j))
  enddo

  write (6, 2) (dx(j), ix(j), j = 1, n2)
2 format (4(f13.8,'D',i5))
enddo

return
end

subroutine matoutmp (n1, n2, a)

!   This outputs the MP matrix a.  It may be used in place of calls to matoutmd
!   in the code above if greater accuracy is desired in debug output.

use mpmodule
implicit none
integer i, j, n1, n2
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call mpwrite (6, a(i,j))
  enddo
enddo

return
end

subroutine mxmdm (n1, n2, a, b, c)

!  This multiplies the DP square matrix a by the MP matrix b, and the result
!  is placed in b.  c is a MP scratch array with n1 cells.  n1, n2 are
!  the matrix dimensions as indicated below.

use mpmodule
implicit none
integer i, j, n1, n2
double precision a(n1,n1)
type (mp_real) b(n1,n2), c(n1), t1, t2

!$omp parallel do private (i, j, c, t1) copyin (mp5)
do j = 1, n2
  do i = 1, n1
    call mpdotd (n1, 1, b(1,j), n1, a(i,1), t1)
    c(i) = t1
  enddo

  do i = 1, n1
    b(i,j) = c(i)
  enddo
enddo
!$omp end parallel do

return
end

subroutine qsortdp (n, a, ip)

!   This routine sorts the entries of the N-long DP vector A into ascending
!   order using the quicksort algorithm.  The permutation vector that would
!   sort the vector is returned in IP.

implicit none
integer i, iq, it, j, jq, jz, k, l, n
integer ip(n), ik(50), jk(50)
double precision a(n), s0, s1, s2

do i = 1, n
  ip(i) = i
enddo

if (n .eq. 1) return

k = 1
ik(1) = 1
jk(1) = n

130 i = ik(k)
j = jk(k)
iq = i
jq = j
it = (i + j + 1) / 2
l = ip(j)
ip(j) = ip(it)
ip(it) = l
s0 = a(ip(j))
j = j - 1

140 continue

do l = i, j
  if (s0 .lt. a(ip(l))) goto 160
enddo

i = j
goto 190

160 i = l

do l = j, i, -1
  if (s0 .gt. a(ip(l))) goto 180
enddo

j = i
goto 190

180 j = l
if (i .ge. j) goto 190
l = ip(i)
ip(i) = ip(j)
ip(j) = l
goto 140

190 continue
if (s0 .ge. a(ip(i))) goto 200
l = ip(jq)
ip(jq) = ip(i)
ip(i) = l

200 k = k - 1
jz = 0
if (j .eq. iq) goto 210
k = k + 1
jk(k) = j
jz = 1

210 i = i + 1
if (i .eq. jq) goto 220
k = k + 1
ik(k) = i
jk(k) = jq
if (jz .eq. 0) goto 220
if (j - iq .ge. jq - i) goto 220
ik(k-1) = i
jk(k-1) = jq
ik(k) = iq
jk(k) = j

220 if (k .gt. 0) goto 130

return
end

subroutine qsortmp (n, a, ip)

!   This routine sorts the entries of the N-long MP vector A into ascending
!   order using the quicksort algorithm.  The permutation vector that would
!   sort the vector is returned in IP.

use mpmodule
implicit none
integer i, iq, it, j, jq, jz, k, l, n
type (mp_real) a(n), s0, s1, s2
integer ip(n), ik(50), jk(50)

do i = 1, n
  ip(i) = i
enddo

if (n .eq. 1) return

k = 1
ik(1) = 1
jk(1) = n

130 i = ik(k)
j = jk(k)
iq = i
jq = j
it = (i + j + 1) / 2
l = ip(j)
ip(j) = ip(it)
ip(it) = l
s0 = a(ip(j))
j = j - 1

140 continue

do l = i, j
  if (s0 .lt. a(ip(l))) goto 160
enddo

i = j
goto 190

160 i = l

do l = j, i, -1
  if (s0 .gt. a(ip(l))) goto 180
enddo

j = i
goto 190

180 j = l
if (i .ge. j) goto 190
l = ip(i)
ip(i) = ip(j)
ip(j) = l
goto 140

190 continue
if (s0 .ge. a(ip(i))) goto 200
l = ip(jq)
ip(jq) = ip(i)
ip(i) = l

200 k = k - 1
jz = 0
if (j .eq. iq) goto 210
k = k + 1
jk(k) = j
jz = 1

210 i = i + 1
if (i .eq. jq) goto 220
k = k + 1
ik(k) = i
jk(k) = jq
if (jz .eq. 0) goto 220
if (j - iq .ge. jq - i) goto 220
ik(k-1) = i
jk(k-1) = jq
ik(k) = iq
jk(k) = j

220 if (k .gt. 0) goto 130

return
end


      subroutine GSMCAMRPOP(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,icoloredboxlo0,icoloredboxlo1
     &           ,icoloredboxhi0,icoloredboxhi1
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1)
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1)
      integer icoloredboxlo0,icoloredboxlo1
      integer icoloredboxhi0,icoloredboxhi1
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 lambda, dxinv, sum_b, lphi
      integer i,j
      integer idir
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 2 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = (1.0d0)/(alpha - beta*sum_b)
      do j = icoloredBoxlo1,icoloredBoxhi1,2
      do i = icoloredBoxlo0,icoloredBoxhi0,2
        lphi =
     &     (    phi(i+1,j  )
     &     +    phi(i-1,j  )
     $     -(2.0d0)*phi(i  ,j  ))
     $     +(   phi(i  ,j+1)
     &     +    phi(i  ,j-1)
     $     -(2.0d0)*phi(i  ,j  ))
        lphi = lphi*dxinv
        phi(i,j) =
     $       phi(   i,j) +
     &       lambda*(   rhs(   i,j) - lphi)
      enddo
      enddo
      return
      end
      subroutine GSRBHELMHOLTZ(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           ,alpha
     &           ,beta
     &           ,redBlack
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      integer redBlack
      REAL*8 lambda, dxinv, sum_b, lphi, helmop
      integer i,j
      integer n,ncomp,idir,indtot,imin,imax
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 2 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/(alpha - beta*sum_b)
      ncomp = nphicomp
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lphi =   (phi(i+1,j,n)
     &             +    phi(i-1,j,n)
     &             +    phi(i,j+1,n)
     &             +    phi(i,j-1,n)
     &             -(2.0d0)*2*phi(i,j,n))*dxinv
              helmop = alpha*phi(i,j,n) + beta*lphi
              phi(i,j,n) = phi(i,j,n) +
     &             lambda*(helmop - rhs(i,j,n))
            enddo
          enddo
      enddo
      return
      end
      subroutine GSRBLAPLACIAN(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           ,redBlack
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      integer redBlack
      REAL*8 lambda, dxinv, sum_b, lphi, lap
      integer i,j
      integer n,ncomp,idir,indtot,imin,imax
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 2 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/sum_b
      ncomp = nphicomp
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lphi = (
     &                  phi(i+1,j,n)
     &             +    phi(i-1,j,n)
     &             +    phi(i,j+1,n)
     &             +    phi(i,j-1,n)
     &             ) * dxinv
              phi(i,j,n) = lambda*(rhs(i,j,n)-lphi)
            enddo
          enddo
      enddo
      return
      end
      subroutine GSRBLAZY(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,lphi
     &           ,ilphilo0,ilphilo1
     &           ,ilphihi0,ilphihi1
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,icoloredboxlo0,icoloredboxlo1
     &           ,icoloredboxhi0,icoloredboxhi1
     &           ,alpha
     &           ,beta
     &           ,dx
     &           )
      implicit none
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1)
      integer ilphilo0,ilphilo1
      integer ilphihi0,ilphihi1
      REAL*8 lphi(
     &           ilphilo0:ilphihi0,
     &           ilphilo1:ilphihi1)
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1)
      integer icoloredboxlo0,icoloredboxlo1
      integer icoloredboxhi0,icoloredboxhi1
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dx
      integer i,j, idir
      REAL*8 dxinv, sum_b, lambda
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 2 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/(alpha - beta*sum_b)
      do j = icoloredBoxlo1,icoloredBoxhi1,2
      do i = icoloredBoxlo0,icoloredBoxhi0,2
      phi(i,j) =
     $     phi(   i,j) -
     &     lambda*(
     $     rhs(   i,j) -
     $     lphi(  i,j))
      enddo
      enddo
      return
      end
      subroutine AMRPMULTICOLOR(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,weight
     &           ,alpha
     &           ,beta
     &           ,dx
     &           ,icoloredboxlo0,icoloredboxlo1
     &           ,icoloredboxhi0,icoloredboxhi1
     &           )
      implicit none
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1)
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1)
      REAL*8 weight
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dx(0:1)
      integer icoloredboxlo0,icoloredboxlo1
      integer icoloredboxhi0,icoloredboxhi1
      integer i,j
      REAL*8 laplphi, dx0,dx1
      dx0 = beta/(dx(0) * dx(0))
                dx1 = beta/(dx(1) * dx(1))
      do j = icoloredBoxlo1,icoloredBoxhi1,2
      do i = icoloredBoxlo0,icoloredBoxhi0,2
        laplphi =
     &     (    phi(i+1,j  )
     &     +    phi(i-1,j  )
     $     -(2.0d0)*phi(i  ,j  ))*dx0
     $     +(   phi(i  ,j+1)
     &     +    phi(i  ,j-1)
     $     -(2.0d0)*phi(i  ,j  ))*dx1
        laplphi = laplphi + alpha * phi(i,j)
        phi(i,j) = phi(i,j) +
     &     weight*(rhs(i,j) - laplphi)
      enddo
      enddo
      return
      end
      subroutine OPERATORLAP(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1
     &           ,ilofphihi0,ilofphihi1
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer nlofphicomp
      integer ilofphilo0,ilofphilo1
      integer ilofphihi0,ilofphihi1
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap
      integer n,ncomp
      integer i,j
      ncomp = nphicomp
      if (ncomp .ne. nlofphicomp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lap = (  phi(i+1,j  ,n)
     &                     + phi(i-1,j  ,n)
     &                     + phi(i  ,j+1,n)
     &                     + phi(i  ,j-1,n)
     &                     -(2*2)*phi(i,j,n) )
     &       * dxinv
          lofphi(i,j,n) = alpha*phi(i,j,n)+beta*lap
      enddo
      enddo
      enddo
      return
      end
      subroutine OPERATORLAPRES(
     &           r
     &           ,irlo0,irlo1
     &           ,irhi0,irhi1
     &           ,nrcomp
     &           ,phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer nrcomp
      integer irlo0,irlo1
      integer irhi0,irhi1
      REAL*8 r(
     &           irlo0:irhi0,
     &           irlo1:irhi1,
     &           0:nrcomp-1)
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap
      integer n,ncomp
      integer i,j
      ncomp = nphicomp
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lap = (  phi(i+1,j  ,n)
     &                     + phi(i-1,j  ,n)
     &                     + phi(i  ,j+1,n)
     &                     + phi(i  ,j-1,n)
     &                     -(2*2)*phi(i,j,n) )
     &       * dxinv
         r(i,j,n) = -alpha*phi(i,j,n) -beta*lap +
     &       rhs(i,j,n)
      enddo
      enddo
      enddo
      return
      end
      subroutine RESTRICTRES(
     &           res
     &           ,ireslo0,ireslo1
     &           ,ireshi0,ireshi1
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,nrhscomp
     &           ,alpha
     &           ,beta
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           )
      implicit none
      integer nrescomp
      integer ireslo0,ireslo1
      integer ireshi0,ireshi1
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           ireslo1:ireshi1,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           0:nrhscomp-1)
      REAL*8 alpha
      REAL*8 beta
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 denom,dxinv,lofphi
      integer n,ncomp
      integer i,j
      integer ii,jj
      ncomp = nphicomp
      dxinv = (1.0d0) / (dx*dx)
      denom = 2  *2
      do n = 0, ncomp-1
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          ii = i/2
          jj = j/2
          lofphi = alpha * phi(i,j,n)
     &           + beta  *
     &              ( phi(i+1,j  ,n)
     &                        + phi(i-1,j  ,n)
     &                        + phi(i  ,j+1,n)
     &                        + phi(i  ,j-1,n)
     &                        - phi(i  ,j  ,n) * 2 * 2
     &              ) * dxinv
          res(ii,jj,n) = res(ii,jj,n)
     &                            + (rhs(i,j,n) - lofphi) / denom
      enddo
      enddo
      enddo
      return
      end
      subroutine PROLONG(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,coarse
     &           ,icoarselo0,icoarselo1
     &           ,icoarsehi0,icoarsehi1
     &           ,ncoarsecomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,m
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer ncoarsecomp
      integer icoarselo0,icoarselo1
      integer icoarsehi0,icoarsehi1
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           icoarselo1:icoarsehi1,
     &           0:ncoarsecomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      integer m
      INTEGER ncomp, n
      integer i,j
      integer ii,jj
      ncomp = nphicomp
      do n = 0, ncomp-1
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          ii = i/m
          jj = j/m
          phi(i,j,n) =  phi(i,j,n) +
     &        coarse(ii,jj,n)
      enddo
      enddo
      enddo
      return
      end
      subroutine PROLONG_2(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,coarse
     &           ,icoarselo0,icoarselo1
     &           ,icoarsehi0,icoarsehi1
     &           ,ncoarsecomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,m
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer ncoarsecomp
      integer icoarselo0,icoarselo1
      integer icoarsehi0,icoarsehi1
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           icoarselo1:icoarsehi1,
     &           0:ncoarsecomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      integer m
      INTEGER ncomp, n
      integer i,j
      integer offs(2)
      integer ic,jc
      REAL*8 f0, den, fx(2)
      den = (1.0d0)/(4**2)
      fx(1) = (3.0d0)*den
      fx(2) = (3.0d0)**2*den
      f0 = (1.0d0)*den
      ncomp = nphicomp
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
        ic = i/m
        jc = j/m
        offs(1) = 2*mod(i,2) - 1
        offs(2) = 2*mod(j,2) - 1
        do n = 0, ncomp-1
          phi(i,j,n) = phi(i,j,n)
     $      + fx(2)*
     $        coarse(ic,jc,n)
     $      + f0*coarse(ic+offs(1),jc+offs(2),n)
          phi(i,j,n) = phi(i,j,n)
     $      + fx(2 -1)*
     $        (
     $         coarse(ic+offs(1),jc,n)
     $       + coarse(ic,jc+offs(2),n)  )
        enddo
      enddo
      enddo
      return
      end
      subroutine NEWGETFLUX(
     &           flux
     &           ,ifluxlo0,ifluxlo1
     &           ,ifluxhi0,ifluxhi1
     &           ,nfluxcomp
     &           ,phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,beta_dx
     &           ,a_idir
     &           )
      implicit none
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nfluxcomp
      integer ifluxlo0,ifluxlo1
      integer ifluxhi0,ifluxhi1
      REAL*8 flux(
     &           ifluxlo0:ifluxhi0,
     &           ifluxlo1:ifluxhi1,
     &           0:nfluxcomp-1)
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      REAL*8 beta_dx
      integer a_idir
      INTEGER ncomp,n
      integer ii, jj
      integer i , j
      ncomp = nphicomp
      ii = CHF_ID(a_idir, 0)
      jj = CHF_ID(a_idir, 1)
      do n = 0, ncomp-1
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          flux(i,j,n) =
     &        (phi(i,j,n)-
     &         phi(i-ii,j-jj,n))*beta_dx
      enddo
      enddo
      enddo
      return
      end


module da_control

   !--------------------------------------------------------------------------
   ! Purpose: Common reference point for WRFVAR control.
   !--------------------------------------------------------------------------

   use module_driver_constants, only : max_domains, max_eta, max_moves, max_bogus, &
                                       max_outer_iterations, max_instruments, max_plevs, &
                                       max_ocean, num_ob_indexes

   implicit none

#include "namelist_defines.inc"

   ! switches set from other namelist options
   logical :: use_obsgts
   logical :: use_rad

   !---------------------------------------------------------------------------
   ! [0.0] WRF hybrid coordinate variables
   !---------------------------------------------------------------------------
   real, allocatable :: c1f(:), c2f(:), c3f(:), c4f(:)
   real, allocatable :: c1h(:), c2h(:), c3h(:), c4h(:)

   !---------------------------------------------------------------------------
   ! [1.0] Physical parameter constants (all NIST standard values):
   !---------------------------------------------------------------------------

   ! Fundamental constants:
   real, parameter    :: pi = 3.1415926           ! Value used in WRF.
   real, parameter    :: radian = pi / 180.0
   real, parameter    :: gas_constant = 287.0     ! Value used in WRF.
   real, parameter    :: gas_constant_v = 461.6   ! Value used in WRF.
   real, parameter    :: cp = 7.0*gas_constant/2.0 ! Value used in WRF.
   real, parameter    :: t_kelvin = 273.15
   real, parameter    :: t_triple = 273.16 ! triple point of water
   ! The imported code for ssmi and radiance uses 273.0 in a way that suggests
   ! it may not be a lazy definition of the melting point of water, so keep the
   ! value separate for the moment
   real, parameter    :: t_roughem = 273.0
   real, parameter    :: t_landem = 273.0

   real, parameter    :: kappa = gas_constant / cp
   real, parameter    :: rd_over_rv = gas_constant / gas_constant_v
   real, parameter    :: rd_over_rv1 = 1.0 - rd_over_rv
   real, parameter    :: L_over_Rv = 5418.12

   real, parameter    :: gamma = 1.4

   ! Earth constants:
   real, parameter    :: gravity = 9.81        ! m/s - value used in WRF.
   ! real, parameter    :: earth_radius = 6378.15
   real, parameter    :: earth_radius      = 6370.0          ! Be consistant with WRF
   real, parameter    :: satellite_height  = 35800.0         ! used by da_get_satzen
   ! real, parameter    :: earth_omega  = 2.0*pi/86400.0  ! Omega
   real, parameter    :: earth_omega  = 0.000072921     ! Omega 7.2921*10**-5

   ! Saturation Vapour Pressure Constants(Rogers & Yau, 1989)
   real, parameter    :: es_alpha = 611.2
   real, parameter    :: es_beta = 17.67
   real, parameter    :: es_gamma = 243.5
   real, parameter    :: es_gammabeta = es_gamma * es_beta
   real, parameter    :: es_gammakelvin = es_gamma - t_kelvin

   ! Explicit moist constants:
   real, parameter    :: SVP1=0.6112, SVP2=17.67, SVP3=29.65
   real, parameter    :: SVPT0=t_kelvin, TO=t_kelvin
   real, parameter    :: N0R=8.0E6, N0S=2.0E7, RHOS=0.1
   real, parameter    :: AVT=841.99667, BVT=0.8, BVT2=2.5+0.5*BVT, BVT3=3.0+BVT
   real, parameter    :: PPI=1.0/(pi*N0R), PPIS=1.0/(pi*N0S*RHOS)
   real, parameter    :: XLV1=2370.0, XLF0=0.3337E6, XLV0=3.15E6
   real, parameter    :: XLS=XLV0-XLV1*t_triple+XLF0

   ! Planetary boundary physics constants
   real, parameter         :: k_kar = 0.4    ! Von Karman constant

   ! Zenith Total Delay:
   !  Hydrostatic delay:
   real, parameter    :: zdk1 = 2.2768e-5
   real, parameter    :: zdk2 = 2.66e-3
   real, parameter    :: zdk3 = 2.8e-7
   !  Wet delay:
   real, parameter    :: wdk1 = 2.21e-7
   real, parameter    :: wdk2 = 3.73e-3

   !  GPS Refractivity constant
   real, parameter    :: a_ew = 0.622
   real, parameter    :: b_ew = 0.378

   ! GPS Refractivity constant
   real, parameter    :: coeff = (wdk2*1.e8) / 77.6

   ! GPS Excess Phase parameter
   !hcl-note: is 5km a universal applicable setting?
   !hcl-note: should this be a namelist option?
   real, parameter    :: gps_ray_path_step = 5.0 !5km
   !hcl-note: 2000 is derived from 20km (50hPa) top with 0.01km interval
   !hcl-note: should the top and interval be namelist options?
   integer, parameter :: interpolate_level = 2000

#if RWORDSIZE==8
   real, parameter :: da_zero = 0D0
#else
   real, parameter :: da_zero = 0.0
#endif

   complex, parameter :: da_zero_complex = (da_zero,da_zero)

   !---------------------------------------------------------------------------
   ! [2.0] WRF-Var parameter constants:
   !---------------------------------------------------------------------------

   ! Missing values and the index number of the quality control

   integer, parameter ::  missing       = -888888
   real   , parameter ::  missing_r     = -888888.0
   real   , parameter ::  xmiss         = -88.0
!   real   , parameter ::  Max_StHeight_Diff = 100.0 !became a namelist variable

   integer, parameter :: cv_options_hum_specific_humidity = 1
   integer, parameter :: cv_options_hum_relative_humidity = 2

   ! No-one explains what these options means anywhere
   integer, parameter :: vert_corr_1 = 1
   integer, parameter :: vert_corr_2 = 2

   integer, parameter :: vertical_ip_0            = 0
   integer, parameter :: vertical_ip_sqrt_delta_p = 1
   integer, parameter :: vertical_ip_delta_p      = 2

   integer, parameter :: vert_evalue_global = 1
   integer, parameter :: vert_evalue_local  = 2

   integer, parameter :: alphacv_method_vp = 1
   integer, parameter :: alphacv_method_xa = 2

   integer, parameter :: sfc_assi_options_1 = 1
   integer, parameter :: sfc_assi_options_2 = 2

   integer, parameter :: check_rh_simple = 1
   integer, parameter :: check_rh_tpw    = 2

   logical :: anal_type_verify=.false.
   logical :: anal_type_randomcv=.false.
   logical :: anal_type_qcobs=.false.
   logical :: anal_type_hybrid_dual_res=.false.

   integer,parameter :: monitor_on  = 1
   integer,parameter :: monitor_off = 0

   integer,parameter :: qc_good       =  1
   integer,parameter :: qc_bad        = -1
   integer,parameter :: qc_varbc_bad  = -1

   integer, parameter :: bufr_satellite_id   = 1
   integer, parameter :: bufr_ifov           = 2
   integer, parameter :: bufr_year           = 3
   integer, parameter :: bufr_month          = 4
   integer, parameter :: bufr_day            = 5
   integer, parameter :: bufr_hour           = 6
   integer, parameter :: bufr_minute         = 7
   integer, parameter :: bufr_second         = 8
   integer, parameter :: bufr_lat            = 9
   integer, parameter :: bufr_lon            = 10
   integer, parameter :: bufr_satzen         = 11
   integer, parameter :: bufr_solzen         = 12
   integer, parameter :: bufr_station_height = 13
   integer, parameter :: bufr_landsea_mask   = 14
   integer, parameter :: bufr_solazi         = 15     !RTTOV9_3

   integer, parameter :: nchan_amsua = 15
   integer, parameter :: nchan_amsub = 5
   integer, parameter :: nchan_mhs   = 5
   integer, parameter :: nchan_msu   = 4
   integer, parameter :: nchan_hirs2 = 19
   integer, parameter :: nchan_hirs3 = 19
   integer, parameter :: nchan_hirs4 = 19
   integer, parameter :: nchan_ssmis = 24
   integer, parameter :: nchan_airs  = 281

   ! WRFVAR Minimisation:

   integer            :: iter
   integer            :: cv_size
   integer, parameter :: MP = 6
   integer, parameter :: LP = 6
   integer, parameter :: MAXFEV = 10
   real, parameter    :: FTOL = 1.0E-4
   real, parameter    :: GTOL = 0.9
   real, parameter    :: XTOL = 1.0E-17
   real, parameter    :: STPMIN = 1.0E-20
   real, parameter    :: STPMAX = 1.0E+20

   ! Background errors:
   real, parameter    :: pplow = 1.0e-8       ! Machine lowest number?
   real, parameter    :: pp_umin = 1.0e-2     ! Minimum u back. error (m/s).
   real, parameter    :: pp_vmin = 1.0e-2     ! Minimum v back. error (m/s).
   real, parameter    :: pp_tmin = 1.0e-2     ! Minimum t back. error (K).
   real, parameter    :: pp_qmin = 1.0e-6     ! Minimum q back. error (kg/kg)
   real, parameter    :: pp_pmin= 1.0e+1      ! Minimum pp back. error (Pa).

   ! FFTs:
   integer, parameter :: Forward_FFT     = -1 ! Grid to spectral
   integer, parameter :: Inverse_FFT     =  1 ! Spectral to grid.
   integer, parameter :: num_fft_factors = 10 ! Max number of factors.
   integer, parameter :: nrange          =1000! Range to search for efficient FFT.

   ! Balance:
   integer, parameter :: balance_geo = 1      ! Geostrophic balance.
   integer, parameter :: balance_cyc = 2      ! Cyclostrophic balance.
   integer, parameter :: balance_geocyc = 3   ! Geo/cyclostrophic balance.

   ! Adjoint tests:
   real, parameter    :: typical_u_rms = 2.0     ! m/s
   real, parameter    :: typical_v_rms = 2.0     ! m/s
   real, parameter    :: typical_speed_rms = 2.0 ! m/s
   real, parameter    :: typical_tb19v_rms = 1.0 ! K
   real, parameter    :: typical_tb19h_rms = 1.0 ! K
   real, parameter    :: typical_tb22v_rms = 1.0 ! K
   real, parameter    :: typical_tb37v_rms = 1.0 ! K
   real, parameter    :: typical_tb37h_rms = 1.0 ! K
   real, parameter    :: typical_tb85v_rms = 1.0 ! K
   real, parameter    :: typical_tb85h_rms = 1.0 ! K
   real, parameter    :: typical_t_rms = 1.0     ! K
   real, parameter    :: typical_p_rms = 100.0   ! Pa
   real, parameter    :: typical_q_rms = 0.00001 ! g/kg
   real, parameter    :: typical_rho_rms = 0.01  ! kg/m^3
   real, parameter    :: typical_tpw_rms = 0.2   ! cm
   real, parameter    :: typical_ref_rms = 5.0   ! N unit
   real, parameter    :: typical_eph_rms =1000.0 ! km
   real, parameter    :: typical_rh_rms = 20.0   ! %
   real, parameter    :: typical_thickness_rms = 50.0   ! m
   real, parameter    :: typical_qrn_rms = 0.00001 ! g/kg
   real, parameter    :: typical_qcw_rms = 0.00001 ! g/kg
   real, parameter    :: typical_qci_rms = 0.00001 ! g/kg
   real, parameter    :: typical_qsn_rms = 0.00001 ! g/kg
   real, parameter    :: typical_qgr_rms = 0.00001 ! g/kg
   real, parameter    :: typical_w_rms = 0.1     ! m/s
   real, parameter    :: typical_rv_rms = 1.0    ! m/s
   real, parameter    :: typical_rf_rms = 1.0    ! dBZ
   real, parameter    :: typical_rain_rms = 1.0   ! mm

   ! The following typical mean squared values depend on control variable. They
   ! are calculated in da_setup_background_errors and used in the VvToVp adjoint
   ! test:

   real, parameter    :: inv_typ_vp1_sumsq = 0.00001 ! 1/sum(psi**2)
   real, parameter    :: inv_typ_vp2_sumsq = 0.00001 ! 1/sum(chi**2)
   real, parameter    :: inv_typ_vp3_sumsq = 0.00001 ! 1/sum(phi_u**2)
   real, parameter    :: inv_typ_vp4_sumsq = 10000.0 ! 1/sum(q**2)
   real, parameter    :: inv_typ_vp5_sumsq = 0.00001 ! 1/sum(?**2)
   real, parameter    :: inv_typ_vpalpha_sumsq = 1.0 ! 1/sum(?**2)

#include "version_decl"

   integer, parameter :: fg_format_wrf_arw_regional = 1
   integer, parameter :: fg_format_wrf_nmm_regional = 2
   integer, parameter :: fg_format_wrf_arw_global   = 3
   integer, parameter :: fg_format_kma_global = 4

   integer, parameter :: ob_format_bufr = 1
   integer, parameter :: ob_format_ascii = 2
   integer, parameter :: ob_format_madis = 3

   integer, parameter :: convert_fd2uv = 1
   integer, parameter :: convert_uv2fd = -1

   ! Fortran unit  parameters:

   ! stdout, stderr, trace_unit all controlled from namelist

   ! Units 9,10 are used for reading and writing namelist.input/output in WRF

   ! Do not use get_unit/free_unit because tracing is too low level
   integer, parameter :: trace_csv_unit = 8

   integer :: y_unit, yp_unit, cost_unit, grad_unit, stats_unit, jo_unit
   integer :: check_max_iv_unit, check_buddy_unit, rand_unit, omb_unit, &
              filtered_obs_unit
   integer :: biasprep_unit, qcstat_conv_unit
   integer :: varbc_tamdar_unit

   integer,parameter :: filename_len = 200

   integer, parameter :: num_alpha_corr_types = 3

   integer, parameter :: alpha_corr_type_exp      = 1
   integer, parameter :: alpha_corr_type_soar     = 2
   integer, parameter :: alpha_corr_type_gaussian = 3

   integer :: alpha_corr_unit1(num_alpha_corr_types)
   integer :: alpha_corr_unit2(num_alpha_corr_types)

   integer, parameter :: max_num_of_var = 200 ! Maximum # of stored fields.

   integer, parameter :: unit_start = 20
   integer, parameter :: unit_end = 500
   logical :: unit_used(unit_start:unit_end) = .false.

   ! grid properties

   character(len=3), parameter :: grid_ordering = "xyz"
   character(len=3), parameter :: grid_stagger  = "xyz"

   !---------------------------------------------------------------------------
   ! [3.0] Variables used in MM5 part of code:
   !---------------------------------------------------------------------------

   integer            :: map_projection       !1=LamConf/2=PolarSte/3=Mercator
                                              !0=CylEqui/6=Cassini
   real               :: ycntr
   integer            :: coarse_ix            ! coarse domain dim in i direction.
   integer            :: coarse_jy            ! coarse domain dim in y direction.
   real               :: coarse_ds            ! Coarse domain gridlength (km)
   real               :: start_x              ! i posn. of (1,1) in coarse domain.
   real               :: start_y              ! j posn. of (1,1) in coarse domain.
   real               :: start_lat            ! Latitude coresponds to start_(x,y)
   real               :: start_lon            ! Longitude coresponds to start_(x,y)
   real               :: delt_lat             ! Latitude increments for global grids
   real               :: delt_lon             ! Longitude increments for global grids

   real               :: phic                 ! coarse domain central lat(degree)
   real               :: xlonc                ! coarse domain central lon(degree)
   real               :: cone_factor          ! Cone Factor
   real               :: truelat1_3dv         ! True latitude 1 (degrees)
   real               :: truelat2_3dv         ! True latitude 2 (degrees)
   real               :: pole                 ! Pole latitude (degrees)
   real               :: dsm                  ! Current domain gridlength (km)
   real               :: psi1                 ! ?
   real               :: c2                   ! earth_radius * COS(psi1)

   real               :: ptop
   real, parameter    :: t0 = 300.0

   !------------------------------------------------------------------------------
   ! 4.0 vertical interpolation options
   !------------------------------------------------------------------------------

   integer, parameter :: v_interp_not_specified = missing, &
                         v_interp_p             = 1, &
                         v_interp_h             = 2

   !------------------------------------------------------------------------------
   ! WRFVAR scalar constants:
   !------------------------------------------------------------------------------

   integer                :: Anal_Space  ! Space of analysis
                                         ! ( 1 = Full model,
                                         !   2 = Transformed grid,
                                         !   3 = Ob space (PSAS) )

   integer                :: mix         ! 1st dimension of analysis grid.
   integer                :: mjy         ! 2nd dimension of analysis grid.
   integer                :: mkz         ! 3rd dimension of analysis grid.

   ! Recursive filter:

   real, allocatable      :: rf_turnconds(:) ! RF turning conditions.

   integer, parameter     :: max_ob_levels = 1001 ! Maximum levels for single ob
   integer, parameter     :: max_fgat_time = 100  ! Maximum levels for FGAT.

   integer                :: time

   logical       :: gaussian_lats

   integer       :: cv_size_domain_jb    ! Total jb cv size.
   integer       :: cv_size_domain_je    ! Total je cv size.
   integer       :: cv_size_domain_jp    ! Total jp cv size.
   integer       :: cv_size_domain_js    ! Total js cv size.
   integer       :: cv_size_domain_jl    ! Total jl cv size.
   integer       :: cv_size_domain_jt    ! Total jt cv size.
   integer       :: cv_size_domain       ! Total cv size.

   ! Hybrid:
   real          :: sigma_alpha          ! Alpha standard deviation.
   real          :: jb_factor            ! Weighting for Background Error Cov.

   ! Namelist variables in future?:
   real, parameter :: maximum_rh = 100.0
   real, parameter :: minimum_rh =  10.0

   real, parameter :: qlimit = 1.0e-12   ! imposed minimum mixing ratio

   ! other

   integer, parameter :: jperr = 6

   ! NCEP errors (U in m/s, V in m/s, T in K, H in %, P in Pa)
   ! rh has been divided by 2

   real, parameter :: err_k(0:jperr+1) = &
                      (/200000.0, 100100.0,70000.0,50000.0,30000.0,10000.0,5000.0, 1.0/)
   real, parameter :: err_u(0:jperr+1) = &
                      (/ 1.4, 1.4,   2.4,   2.8,   3.4,   2.5,  2.7,  2.7/)
   real, parameter :: err_v(0:jperr+1) = &
                      (/ 1.4, 1.4,   2.4,   2.8,   3.4,   2.5,  2.7 , 2.7 /)
   real, parameter :: err_t(0:jperr+1) = &
                      (/ 1.8, 1.8,   1.3,   1.3,   2.0,   3.1,  4.0 , 4.0 /)
   real, parameter :: err_rh(0:jperr+1) = &
                      (/ 10.0, 10.0,  10.0,  10.0,  10.0,  10.0, 10.0,  10.0/)
   real, parameter :: err_p(0:jperr+1) = &
                      (/ 100.0,100.0, 100.0, 100.0, 100.0, 100.0,100.0,100.0 /)

   ! Buddy check parameters (YRG, 10/3/2008):

   real, parameter :: max_buddy_t             =     8.0, &
                      max_buddy_uv            =     8.0, &
                      max_buddy_z             =     8.0, &
                      max_buddy_rh            =    40.0, &
                      max_buddy_p             =   350.0, &
                      buddy_weight            =     1.0, &
                      bin_p_width             =  5000.0, &
                      bin_z_width             =   500.0

   ! Define various ways for bad data to be flagged.

   integer, parameter ::  &
      missing_data            = -88, &     ! Data is missing with the value of
                                           ! missing_r
      outside_of_domain       = -77, &     ! Data outside horizontal domain
                                           ! or time window, data set to missing_r
      fail_varbc_aircraft     = -55, &     ! Data fail VarBC of aircraft
                                           ! => no action
      wrong_direction         = -15, &     ! Wind vector direction <0 or> 360
                                           ! => direction set to missing_r
      negative_spd            = -14, &     ! Wind vector norm is negative
                                           ! => norm set to missing_r
      zero_spd                = -13, &     ! Wind vector norm is zero
                                           ! => norm set to missing_r
      wrong_wind_data         = -12, &     ! Spike in wind profile
                                           ! =>direction and norm set to missing_r
      zero_t_td               = -11, &     ! t or td = 0 => t or td, rh and qv
                                           ! are set to missing_r,
      t_fail_supa_inver       = -10, &     ! superadiabatic temperature
                                           !
      wrong_t_sign            = - 9, &     ! Spike in Temperature profile
                                           !
      above_model_lid         = - 8, &     ! heigh above model lid
                                           ! => no action
      far_below_model_surface = - 7, &     ! heigh far below model surface
                                           ! => no action
      below_model_surface     = - 6, &     ! height below model surface
                                           ! => no action
      standard_atmosphere     = - 5, &     ! Missing h, p or t
                                           ! =>Datum interpolated from standard atm
      from_background         = - 4, &     ! Missing h, p or t
                                           ! =>Datum interpolated from model
      fails_error_max         = - 3, &     ! Datum Fails error max check
                                           ! => no action
      fails_buddy_check       = - 2, &     ! Datum Fails buddy check
                                           ! => no action
      no_buddies              = - 1, &     ! Datum has no buddies
                                           ! => no action
      good_quality            =   0, &     ! OBS datum has good quality
                                           !
      convective_adjustment   =   1, &     ! convective adjustement check
                                           ! =>apply correction on t, td, rh and qv
      surface_correction      =   2, &     ! Surface datum
                                           ! => apply correction on datum
      Hydrostatic_recover     =   3, &     ! Height from hydrostaic assumption with
                                           ! the OBS data calibration
      Reference_OBS_recover   =   4, &     ! Height from reference state with OBS
                                           ! data calibration
      Other_check             =  88        ! passed other quality check

   ! Observations:

   integer                :: num_procs            ! Number of total processors.
   integer                :: myproc               ! My processor ID.
   integer, parameter     :: root = 0             ! Number of root processor
   logical                :: rootproc             ! Am I the root processor

   integer, parameter :: rtm_option_rttov = 1
   integer, parameter :: rtm_option_crtm = 2

   ! rtm_init setup parameter

   integer, parameter            :: maxsensor = 30

   integer, parameter :: npres_print = 12

   ! Tracing

   integer :: trace_start_points=0   ! Number of routines to initiate trace

   integer, parameter :: sound     = 1
   integer, parameter :: synop     = 2
   integer, parameter :: pilot     = 3
   integer, parameter :: satem     = 4
   integer, parameter :: geoamv    = 5
   integer, parameter :: polaramv  = 6
   integer, parameter :: airep     = 7
   integer, parameter :: gpspw     = 8
   integer, parameter :: gpsref    = 9
   integer, parameter :: metar     = 10
   integer, parameter :: ships     = 11
   integer, parameter :: ssmi_rv   = 12
   integer, parameter :: ssmi_tb   = 13
   integer, parameter :: ssmt1     = 14
   integer, parameter :: ssmt2     = 15
   integer, parameter :: qscat     = 16
   integer, parameter :: profiler  = 17
   integer, parameter :: buoy      = 18
   integer, parameter :: bogus     = 19
   integer, parameter :: pseudo    = 20
   integer, parameter :: radar     = 21
   integer, parameter :: radiance  = 22
   integer, parameter :: airsr     = 23
   integer, parameter :: sonde_sfc = 24
   integer, parameter :: mtgirs    = 25
   integer, parameter :: tamdar    = 26
   integer, parameter :: tamdar_sfc = 27
   integer, parameter :: rain      = 28
   integer, parameter :: gpseph    = 29

   character(len=14), parameter :: obs_names(num_ob_indexes) = (/ &
      "sound         ", &
      "synop         ", &
      "pilot         ", &
      "satem         ", &
      "geoamv        ", &
      "polaramv      ", &
      "airep         ", &
      "gpspw         ", &
      "gpsrf         ", &
      "metar         ", &
      "ships         ", &
      "ssmi_rv       ", &
      "ssmi_tb       ", &
      "ssmt1         ", &
      "ssmt2         ", &
      "qscat         ", &
      "profiler      ", &
      "buoy          ", &
      "bogus         ", &
      "pseudo        ", &
      "radar         ", &
      "radiance      ", &
      "airs retrieval", &
      "sonde_sfc     ", &
      "mtgirs        ", &
      "tamdar        ", &
      "tamdar_sfc    ", &
      "rain          ", &
      "gpseph        "  &
   /)

   logical :: pseudo_tpw
   logical :: pseudo_ztd
   logical :: pseudo_ref
   logical :: pseudo_uvtpq

   integer, parameter :: max_no_fm = 290

   integer, parameter :: num_ob_vars=10

   logical, parameter :: in_report(num_ob_vars,2) = reshape((/&
     .false.,.false.,.false.,.false.,.false.,.false.,.false.,.false.,.false., & ! sound
     .true.,.true.,.true.,.true.,.true.,.true.,.false.,.false.,.false.,.false.,.false./), &
     (/num_ob_vars,2/))

   integer, parameter :: report_h   = 1
   integer, parameter :: report_u   = 2
   integer, parameter :: report_v   = 3
   integer, parameter :: report_t   = 4
   integer, parameter :: report_q   = 5
   integer, parameter :: report_p   = 6
   integer, parameter :: report_rh  = 7
   integer, parameter :: report_slp = 8
   integer, parameter :: report_zk  = 9

   logical :: obs_use(num_ob_indexes) = .false.

   ! Special cases

   integer, parameter :: fm_satem = 86
   integer, parameter :: fm_amv   = 88

   integer, parameter :: fm_index(max_no_fm) = (/ &
      0,0,0,0,0,0,0,0,0,0,                                & ! 1-10
      0,Synop,Ships,0,Metar,            & ! 11-15
      Metar,Ships,buoy,buoy,0,    & ! 16-20
      0,0,0,0,0,0,0,0,0,0,                                & ! 21-30
      0,pilot,pilot,pilot,sound,  & ! 31-35
      sound,sound,sound,0,0,            & ! 36-40
      0,airep,0,0,0,0,0,0,0,0,                      & ! 41-50
      0,0,0,0,0,0,0,0,0,0,                                & ! 51-60
      0,0,0,0,0,0,0,0,0,0,                                & ! 61-70
      0,0,0,0,0,0,0,0,0,0,                                & ! 71-80
      0,0,0,0,0,satem,0,geoamv,0,0,           & ! 81-90
      0,0,0,0,0,airep,airep,0,0,0,            & ! 91-100
      tamdar,0,0,0,0,0,0,0,0,0,                                & ! 101-110
      gpspw,0,0,gpspw,0,gpsref,0,gpseph,0,0,  & ! 111-120
      ssmt1,ssmt2,0,0,ssmi_rv,0,0,0,0,0,            & ! 121-130
      0,profiler,airsr,0,bogus,0,0,0,0,0, & ! 131-140
      0,0,0,0,0,0,0,0,0,0,                                & ! 141-150
      0,0,0,0,0,0,0,0,0,0,                                & ! 151-160
      mtgirs,0,0,0,0,0,0,0,0,0,                            & ! 161-170
      0,0,0,0,0,0,0,0,0,0,                                & ! 171-180
      0,0,0,0,0,0,0,0,0,0,                                & ! 181-190
      0,0,0,0,0,0,0,0,0,0,                                & ! 191-200
      0,0,0,0,0,0,0,0,0,0,                                & ! 201-210
      0,0,0,0,0,0,0,0,0,0,                                & ! 211-220
      0,0,0,0,0,0,0,0,0,0,                                & ! 231-230
      0,0,0,0,0,0,0,0,0,0,                                & ! 231-240
      0,0,0,0,0,0,0,0,0,0,                                & ! 241-250
      0,0,0,0,0,0,0,0,0,0,                                & ! 251-260
      0,0,0,0,0,0,0,0,0,0,                                & ! 261-270
      0,0,0,0,0,0,0,0,0,0,                                & ! 271-280
      qscat,0,0,0,0,0,0,0,0,0 /)                      ! 281-290

   character(len=120)  :: fmt_info ='(a12,1x,a19,1x,a40,1x,i6,3(f12.3,11x),6x,a5)'
   character(len=120)  :: fmt_srfc = '(7(:,f12.3,i4,f7.2))'
!   character(len=120)  :: fmt_srfc = '(f12.3,i4,f7.2,F12.3,I4,F7.3)'
   character(len=120)  :: fmt_each = &
      '(3(f12.3,i4,f7.2),11x,3(f12.3,i4,f7.2),11x,3(f12.3,i4,f7.2))'

   ! lat/long information calculated in da_setup_firstguess_wrf

   real, parameter :: deg_to_rad = pi/180.0
   real, parameter :: rad_to_deg = 1.0/deg_to_rad

   real, allocatable :: cos_xls(:)
   real, allocatable :: sin_xls(:)
   real, allocatable :: cos_xle(:)
   real, allocatable :: sin_xle(:)

   integer :: ierr ! General error code
   integer :: comm ! MPI communicator

   integer :: ids,ide,jds,jde,kds,kde
   integer :: ims,ime,jms,jme,kms,kme
   integer :: its,ite,jts,jte,kts,kte
   integer :: ips,ipe,jps,jpe,kps,kpe
   integer :: itsy,itey,jtsy,jtey,ktsy,ktey
   integer :: itsx,itex,jtsx,jtex,ktsx,ktex

   integer :: ide_ens,jde_ens,kde_ens

   integer :: its_int,ite_int,jts_int,jte_int,kts_int,kte_int
   integer :: ids_int,ide_int,jds_int,jde_int,kds_int,kde_int
   integer :: ims_int,ime_int,jms_int,jme_int,kms_int,kme_int
   integer :: ips_int,ipe_int,jps_int,jpe_int,kps_int,kpe_int

   character (len=filename_len) :: input_file_ens = 'fg_ens'

   TYPE dual_res_type
         integer :: i
         integer :: j
         real    :: dx
         real    :: dy
         real    :: dxm
         real    :: dym
   END TYPE dual_res_type
   TYPE(dual_res_type), allocatable :: aens_locs(:,:)

   integer :: num_qcstat_conv(2,num_ob_indexes,num_ob_vars,npres_print+1)
   character*4, parameter :: ob_vars(num_ob_vars) = (/'U   ','V   ','T   ',&
                                                      'Q   ','Ps  ','Spd ',&
                                                      'Tpw ','GpsR','Thic','Rain'/)
   real, parameter :: pptop(1:npres_print) = (/ 1000.0, 900.0, 800.0, 600.0, 400.0, 300.0,  &
                      250.0,  200.0, 150.0, 100.0, 50.0, 0./)

   real, parameter :: ppbot(npres_print) = (/ 1200.0, 999.9, 899.9, 799.0, 599.9, 399.9,  &
                      299.9,  249.9, 199.9, 149.9, 99.9, 49.9/)

   real*8, allocatable :: time_slots(:)
   integer             :: ifgat_ana !index of First Guess at Appropriate Time of analysis

   logical :: global

   logical, allocatable :: fgat_rain_flags(:)

end module da_control


!##############################################################################
!# Tutorial 020b: Solve a pure Neumann Poisson problem with UMFPACK
!##############################################################################

module tutorial020b

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use triangulation
  use meshgeneration

  use derivatives
  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation

  use feevaluation2
  use blockmatassemblybase
  use blockmatassembly
  use blockmatassemblystdop

  use linearsolver
  use filtersupport
  use collection

  use lumping
  use matrixmodification
  use vectorfilters

  use ucd

  implicit none
  private

  public :: start_tutorial020b

contains

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

!<subroutine>

  subroutine frhs(rvectorData,rassemblyData,rvectorAssembly,&
      npointsPerElement,nelements,revalVectors,rcollection)

!<description>
    ! Calculates a right-hand side vector according to the right-hand
    ! side function f=dscale*32*y*(1-y)+32*x*(1-x) - 32/3.
    !
    ! This RHS fulfils the property having integral mean value =0 on [0,1]^2
    ! which is a necessary condition for a RHS in a pure Neumann problem.
!</description>

!<inputoutput>
    ! Vector data of all subvectors. The arrays p_Dentry of all subvectors
    ! have to be filled with data.
    type(t_bmaVectorData), dimension(:), intent(inout), target :: RvectorData
!</inputoutput>

!<input>
    ! Data necessary for the assembly. Contains determinants and
    ! cubature weights for the cubature,...
    type(t_bmaVectorAssemblyData), intent(in) :: rassemblyData

    ! Structure with all data about the assembly
    type(t_bmaVectorAssembly), intent(in) :: rvectorAssembly

    ! Number of points per element
    integer, intent(in) :: npointsPerElement

    ! Number of elements
    integer, intent(in) :: nelements

    ! Values of FEM functions automatically evaluated in the
    ! cubature points.
    type(t_fev2Vectors), intent(in) :: revalVectors

    ! User defined collection structure
    type(t_collection), intent(inout), target, optional :: rcollection
!</input>

!</subroutine>

    ! Local variables
    real(DP) :: dbasI, dval, dx, dy
    integer :: iel, icubp, idofe, idimfe, ndimfe
    real(DP), dimension(:,:), pointer :: p_DlocalVector
    real(DP), dimension(:,:,:,:), pointer :: p_DbasTest
    real(DP), dimension(:,:), pointer :: p_DcubWeight
    type(t_bmaVectorData), pointer :: p_rvectorData
    real(DP), dimension(:,:,:), pointer :: p_Dpoints

    ! Get cubature weights data
    p_DcubWeight => rassemblyData%p_DcubWeight

    ! Get the coordinates of the cubature points
    p_Dpoints => rassemblyData%revalElementSet%p_DpointsReal

    ! Get the data arrays of subvector 1
    p_rvectorData => RvectorData(1)
    p_DlocalVector => p_rvectorData%p_Dentry
    p_DbasTest => p_rvectorData%p_DbasTest

    ! FE space dimension
    ndimfe = p_rvectorData%ndimfe

    ! Loop over the elements in the current set.
    do iel = 1,nelements

      ! Loop over all cubature points on the current element
      do icubp = 1,npointsPerElement

        ! Get the coordinates of the cubature point.
        dx = p_Dpoints(1,icubp,iel)
        dy = p_Dpoints(2,icubp,iel)

        ! Calculate the values of the RHS using the coordinates
        ! of the cubature points.
        dval = 32.0_DP*dy*(1.0_DP-dy) + 32_DP*dx*(1.0_DP-dx) - 32.0_DP/3.0_DP

        ! Loop over the dimensions of the FE space
        do idimfe = 0,ndimfe-1

          ! Outer loop over the DOF's i=1..ndof on our current element,
          ! which corresponds to the (test) basis functions Psi_i:
          do idofe=1,p_rvectorData%ndofTest

            ! Fetch the contributions of the (test) basis functions Psi_i
            ! into dbasI
            dbasI = p_DbasTest(idofe+idimfe*p_rvectorData%ndofTest,DER_FUNC,icubp,iel)

            ! Multiply the values of the basis functions
            ! (1st derivatives) by the cubature weight and sum up
            ! into the local vectors.
            p_DlocalVector(idofe,iel) = p_DlocalVector(idofe,iel) + &
                p_DcubWeight(icubp,iel) * dval * dbasI

          end do ! idofe

        end do ! idimfe

      end do ! icubp

    end do ! iel

  end subroutine

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

  subroutine start_tutorial020b

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    type(t_matrixBlock) :: rmatrix,rmass
    type(t_matrixScalar) :: rtemplateFEM,rmassLumped
    type(t_vectorBlock) :: rrhs, rsolution, rtemp
    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_ucdExport) :: rexport
    character(LEN=SYS_STRLEN) :: spostdir

    type(t_filterChain), dimension(1), target :: RfilterChain
    integer :: nfilters
    type(t_linsolNode), pointer :: p_rsolverNode
    integer :: ierror

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 020b")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 11x11-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 10, 10)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rspatialDiscr
    ! which describes the discretisation.
    ! We generate a 1x1 system with Q1.
    ! =================================

    ! Create a spatial discretisation with Q1
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Create a block discretisation with 1 block Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Assemble a matrix, a RHS and create
    ! an empty solution vector.
    ! =================================

    ! Use a Gauss 3x3 formula for the discretisation.
    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! -----------------------------------------------------
    ! Create a template FEM matrix which provides the structure
    ! for all matrices.
    call bilf_createMatrixStructure (rspatialDiscr,LSYSSC_MATRIX9,rtemplateFEM)

    ! -----------------------------------------------------
    ! Enlarge the template FEM matrix such that the first row is full.
    ! Later, we will impose the lumped mass matrix into that row.
    call mmod_expandToFullRow (rtemplateFEM,1)

    ! -----------------------------------------------------
    ! Initialise a block matrix and block vectors
    ! corresponding to the block discretisation.
    call lsysbl_createVector (rblockDiscr,rrhs)
    call lsysbl_createVector (rblockDiscr,rsolution)
    call lsysbl_createVector (rblockDiscr,rtemp)

    ! -----------------------------------------------------
    ! Create an empty matrix in block (1,1) based on the template matrix
    call lsysbl_createMatrix (rblockDiscr,rmatrix)

    call lsysbl_duplicateMatrix (rtemplateFEM,rmatrix,1,1,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    ! Discretise a simple Laplace matrix into (1,1)
    call lsysbl_clearMatrix (rmatrix)
    call bma_buildMatrix (rmatrix,BMA_CALC_STANDARD,&
        bma_fcalc_laplace,rcubatureInfo=rcubatureInfo)

    ! -----------------------------------------------------
    ! Discretise a mass matrix. Take the structure of the
    ! Laplace matrix. Allocate new memory.
    call lsysbl_createMatrix (rblockDiscr,rmass)

    call lsysbl_duplicateMatrix (rtemplateFEM,rmass,1,1,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    ! Discretise into (1,1)
    call lsysbl_clearMatrix (rmass)
    call bma_buildMatrix (rmass,BMA_CALC_STANDARD,&
        bma_fcalc_mass,rcubatureInfo=rcubatureInfo)

    ! -----------------------------------------------------
    ! Create a lumped mass matrix by summing up the rows to the diagonal.
    call lsyssc_createDiagMatrixStruc (rspatialDiscr,LSYSSC_MATRIXD,rmassLumped)
    call lump_sumToDiagonal(rmass%RmatrixBlock(1,1),rmassLumped)

    ! -----------------------------------------------------
    ! Create a RHS vector into block (1)
    call lsysbl_clearVector (rrhs)
    call bma_buildVector (rrhs,BMA_CALC_STANDARD,&
        frhs,rcubatureInfo=rcubatureInfo)

    ! =================================
    ! Prepare imposing the side condition int(u(1)) = 0
    ! =================================

    ! -----------------------------------------------------
    ! Insert the lumped mass matrix as first row to the system matrix.
    ! Overwrite the first row, which is anyway linearly dependent on the
    ! other rows. This realises the calculation of the int(u(1)).
    call mmod_replaceLineByLumpedMass (rmatrix%RmatrixBlock(1,1),1,rmassLumped)

    ! Replace the first row in the first block of in the RHS vector, f[1](1)
    ! by zero. In combination with the first row of the matrix realising the
    ! integral, this imposes the condition int(u(1))=0.
    call vecfil_oneEntryZero (rrhs,1,1)

    ! =================================
    ! Solve the system with Gauss elimination
    ! =================================

    call output_line ("Solving linear system...")

    ! ----------------
    ! Solver preparation
    ! ----------------

    ! Create a CG solver with the filter chain attached.
    call linsol_initUMFPACK4 (p_rsolverNode)

    ! Attach the system matrix
    call linsol_setMatrix (p_rsolverNode, rmatrix)

    ! Symbolic factorisation
    call linsol_initStructure (p_rsolverNode, ierror)

    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line ("Error during symbolic factorisation.")
      call sys_halt()
    end if

    ! Numeric factorisation
    call linsol_initData (p_rsolverNode, ierror)

    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line ("Error during numeric factorisation.")
      call sys_halt()
    end if

    ! ----------------
    ! Solve the system
    ! ----------------

    ! Clear the solution
    call lsysbl_clearVector (rsolution)

    ! Solve
    call linsol_solveAdaptively (p_rsolverNode,rsolution,rrhs,rtemp)

    ! ----------------
    ! Cleanup
    ! ----------------

    ! Numeric data
    call linsol_doneData (p_rsolverNode)

    ! Symbolic data
    call linsol_doneStructure (p_rsolverNode)

    ! Remaining solver data
    call linsol_releaseSolver (p_rsolverNode)

    ! Filter chain
    call filter_doneFilterChain (RfilterChain,nfilters)

    ! =================================
    ! Create output files
    ! =================================

    call output_line ("Writing postprocessing files...")

    ! Open / write / close; write the solution to a VTK file.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       trim(spostdir)//"/tutorial020b.vtk")
    else
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       "post/tutorial020b.vtk")
    end if

    call ucd_addVectorByVertex (rexport, "solution", &
        UCD_VAR_STANDARD, rsolution%RvectorBlock(1))
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the matrix/vectors
    call lsysbl_releaseMatrix (rmass)
    call lsysbl_releaseMatrix (rmatrix)

    call lsyssc_releaseMatrix (rmassLumped)
    call lsyssc_releaseMatrix (rtemplateFEM)

    call lsysbl_releaseVector (rtemp)
    call lsysbl_releaseVector (rrhs)
    call lsysbl_releaseVector (rsolution)

    ! Release the discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Cubature done.
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module