MODULE movmod
CONTAINS
  SUBROUTINE shape_function(phi,j,k,s)
    ! Returns the Hermite interpolating polynomials on [0,1] and their
    ! derivatives up to order 6
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: j, k
    REAL(kind=8), INTENT(IN) :: s
    REAL(kind=8), INTENT(OUT) :: phi

    if (j == 0) then
       if (k == 0) then
          phi = (1.0d0) - &
               (462.0d0)*(s**6.0d0) + &
               (1980.0d0)*(s**7.0d0) - &
               (3465.0d0)*(s**8.0d0) + &
               (3080.0d0)*(s**9.0d0) - &
               (1386.0d0)*(s**10.0d0) + &
               (252.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = -(2772.0d0)*(s**5.0d0) + &
               (13860.0d0)*(s**6.0d0) - &
               (27720.0d0)*(s**7.0d0) + &
               (27720.0d0)*(s**8.0d0) - &
               (13860.0d0)*(s**9.0d0) + &
               (2772.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = -(13860.0d0)*(s**4.0d0) + &
               (83160.0d0)*(s**5.0d0) - &
               (194040.0d0)*(s**6.0d0) + &
               (221760.0d0)*(s**7.0d0) - &
               (124740.0d0)*(s**8.0d0) + &
               (27720.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = -(55440.0d0)*(s**3.0d0) + &
               (415800.0d0)*(s**4.0d0) - &
               (1164240.0d0)*(s**5.0d0) + &
               (1552320.0d0)*(s**6.0d0) - &
               (997920.0d0)*(s**7.0d0) + &
               (249480.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = -(166320.0d0)*(s**2.0d0) + &
               (1663200.0d0)*(s**3.0d0) - &
               (5821200.0d0)*(s**4.0d0) + &
               (9313920.0d0)*(s**5.0d0) - &
               (6985440.0d0)*(s**6.0d0) + &
               (1995840.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(332640.0d0)*s + &
               (4989600.0d0)*(s**2.0d0) - &
               (23284800.0d0)*(s**3.0d0) + &
               (46569600.0d0)*(s**4.0d0) - &
               (41912640.0d0)*(s**5.0d0) + &
               (13970880.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(332640.0d0) + &
               (9979200.0d0)*s - &
               (69854400.0d0)*(s**2.0d0) + &
               (186278400.0d0)*(s**3.0d0) - &
               (209563200.0d0)*(s**4.0d0) + &
               (83825280.0d0)*(s**5.0d0)
       end if
    else if (j == 1) then
       if (k == 0) then
          phi = s - &
               (252.0d0)*(s**6.0d0) + &
               (1050.0d0)*(s**7.0d0) - &
               (1800.0d0)*(s**8.0d0) + &
               (1575.0d0)*(s**9.0d0) - &
               (700.0d0)*(s**10.0d0) + &
               (126.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = (1.0d0) - &
               (1512.0d0)*(s**5.0d0) + &
               (7350.0d0)*(s**6.0d0) - &
               (14400.0d0)*(s**7.0d0) + &
               (14175.0d0)*(s**8.0d0) - &
               (7000.0d0)*(s**9.0d0) + &
               (1386.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = -(7560.0d0)*(s**4.0d0) + &
               (44100.0d0)*(s**5.0d0) - &
               (100800.0d0)*(s**6.0d0) + &
               (113400.0d0)*(s**7.0d0) - &
               (63000.0d0)*(s**8.0d0) + &
               (13860.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = -(30240.0d0)*(s**3.0d0) + &
               (220500.0d0)*(s**4.0d0) - &
               (604800.0d0)*(s**5.0d0) + &
               (793800.0d0)*(s**6.0d0) - &
               (504000.0d0)*(s**7.0d0) + &
               (124740.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = -(90720.0d0)*(s**2.0d0) + &
               (882000.0d0)*(s**3.0d0) - &
               (3024000.0d0)*(s**4.0d0) + &
               (4762800.0d0)*(s**5.0d0) - &
               (3528000.0d0)*(s**6.0d0) + &
               (997920.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(181440.0d0)*s + &
               (2646000.0d0)*(s**2.0d0) - &
               (12096000.0d0)*(s**3.0d0) + &
               (23814000.0d0)*(s**4.0d0) - &
               (21168000.0d0)*(s**5.0d0) + &
               (6985440.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(181440.0d0) + &
               (5292000.0d0)*s - &
               (36288000.0d0)*(s**2.0d0) + &
               (95256000.0d0)*(s**3.0d0) - &
               (105840000.0d0)*(s**4.0d0) + &
               (41912640.0d0)*(s**5.0d0)
       end if
    else if (j == 2) then
       if (k == 0) then
          phi = (1.0d0/2.0d0)*(s**2.0d0) - &
               (63.0d0)*(s**6.0d0) + &
               (252.0d0)*(s**7.0d0) - &
               (420.0d0)*(s**8.0d0) + &
               (360.0d0)*(s**9.0d0) - &
               (315.0d0/2.0d0)*(s**10.0d0) + &
               (28.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = s - &
               (378.0d0)*(s**5.0d0) + &
               (1764.0d0)*(s**6.0d0) - &
               (3360.0d0)*(s**7.0d0) + &
               (3240.0d0)*(s**8.0d0) - &
               (1575.0d0)*(s**9.0d0) + &
               (308.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = (1.0d0) - &
               (1890.0d0)*(s**4.0d0) + &
               (10584.0d0)*(s**5.0d0) - &
               (23520.0d0)*(s**6.0d0) + &
               (25920.0d0)*(s**7.0d0) - &
               (14175.0d0)*(s**8.0d0) + &
               (3080.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = -(7560.0d0)*(s**3.0d0) + &
               (52920.0d0)*(s**4.0d0) - &
               (141120.0d0)*(s**5.0d0) + &
               (181440.0d0)*(s**6.0d0) - &
               (113400.0d0)*(s**7.0d0) + &
               (27720.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = -(22680.0d0)*(s**2.0d0) + &
               (211680.0d0)*(s**3.0d0) - &
               (705600.0d0)*(s**4.0d0) + &
               (1088640.0d0)*(s**5.0d0) - &
               (793800.0d0)*(s**6.0d0) + &
               (221760.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(45360.0d0)*s + &
               (635040.0d0)*(s**2.0d0) - &
               (2822400.0d0)*(s**3.0d0) + &
               (5443200.0d0)*(s**4.0d0) - &
               (4762800.0d0)*(s**5.0d0) + &
               (1552320.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(45360.0d0) + &
               (1270080.0d0)*s - &
               (8467200.0d0)*(s**2.0d0) + &
               (21772800.0d0)*(s**3.0d0) - &
               (23814000.0d0)*(s**4.0d0) + &
               (9313920.0d0)*(s**5.0d0)
       end if
    else if (j == 3) then
       if (k == 0) then
          phi = (1.0d0/6.0d0)*(s**3.0d0) - &
               (28.0d0/3.0d0)*(s**6.0d0) + &
               (35.0d0)*(s**7.0d0) - &
               (56.0d0)*(s**8.0d0) + &
               (140.0d0/3.0d0)*(s**9.0d0) - &
               (20.0d0)*(s**10.0d0) + &
               (7.0d0/2.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = (1.0d0/2.0d0)*(s**2.0d0) - &
               (56.0d0)*(s**5.0d0) + &
               (245.0d0)*(s**6.0d0) - &
               (448.0d0)*(s**7.0d0) + &
               (420.0d0)*(s**8.0d0) - &
               (200.0d0)*(s**9.0d0) + &
               (77.0d0/2.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = s - &
               (280.0d0)*(s**4.0d0) + &
               (1470.0d0)*(s**5.0d0) - &
               (3136.0d0)*(s**6.0d0) + &
               (3360.0d0)*(s**7.0d0) - &
               (1800.0d0)*(s**8.0d0) + &
               (385.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = (1.0d0) - &
               (1120.0d0)*(s**3.0d0) + &
               (7350.0d0)*(s**4.0d0) - &
               (18816.0d0)*(s**5.0d0) + &
               (23520.0d0)*(s**6.0d0) - &
               (14400.0d0)*(s**7.0d0) + &
               (3465.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = -(3360.0d0)*(s**2.0d0) + &
               (29400.0d0)*(s**3.0d0) - &
               (94080.0d0)*(s**4.0d0) + &
               (141120.0d0)*(s**5.0d0) - &
               (100800.0d0)*(s**6.0d0) + &
               (27720.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(6720.0d0)*s + &
               (88200.0d0)*(s**2.0d0) - &
               (376320.0d0)*(s**3.0d0) + &
               (705600.0d0)*(s**4.0d0) - &
               (604800.0d0)*(s**5.0d0) + &
               (194040.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(6720.0d0) + &
               (176400.0d0)*s - &
               (1128960.0d0)*(s**2.0d0) + &
               (2822400.0d0)*(s**3.0d0) - &
               (3024000.0d0)*(s**4.0d0) + &
               (1164240.0d0)*(s**5.0d0)
       end if
    else if (j == 4) then
       if (k == 0) then
          phi = (1.0d0/24.0d0)*(s**4.0d0) - &
               (7.0d0/8.0d0)*(s**6.0d0) + &
               (35.0d0/12.0d0)*(s**7.0d0) - &
               (35.0d0/8.0d0)*(s**8.0d0) + &
               (7.0d0/2.0d0)*(s**9.0d0) - &
               (35.0d0/24.0d0)*(s**10.0d0) + &
               (1.0d0/4.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = (1.0d0/6.0d0)*(s**3.0d0) - &
               (21.0d0/4.0d0)*(s**5.0d0) + &
               (245.0d0/12.0d0)*(s**6.0d0) - &
               (35.0d0)*(s**7.0d0) + &
               (63.0d0/2.0d0)*(s**8.0d0) - &
               (175.0d0/12.0d0)*(s**9.0d0) + &
               (11.0d0/4.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = (1.0d0/2.0d0)*(s**2.0d0) - &
               (105.0d0/4.0d0)*(s**4.0d0) + &
               (245.0d0/2.0d0)*(s**5.0d0) - &
               (245.0d0)*(s**6.0d0) + &
               (252.0d0)*(s**7.0d0) - &
               (525.0d0/4.0d0)*(s**8.0d0) + &
               (55.0d0/2.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = s - &
               (105.0d0)*(s**3.0d0) + &
               (1225.0d0/2.0d0)*(s**4.0d0) - &
               (1470.0d0)*(s**5.0d0) + &
               (1764.0d0)*(s**6.0d0) - &
               (1050.0d0)*(s**7.0d0) + &
               (495.0d0/2.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = (1.0d0) - &
               (315.0d0)*(s**2.0d0) + &
               (2450.0d0)*(s**3.0d0) - &
               (7350.0d0)*(s**4.0d0) + &
               (10584.0d0)*(s**5.0d0) - &
               (7350.0d0)*(s**6.0d0) + &
               (1980.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(630.0d0)*s + &
               (7350.0d0)*(s**2.0d0) - &
               (29400.0d0)*(s**3.0d0) + &
               (52920.0d0)*(s**4.0d0) - &
               (44100.0d0)*(s**5.0d0) + &
               (13860.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(630.0d0) + &
               (14700.0d0)*s - &
               (88200.0d0)*(s**2.0d0) + &
               (211680.0d0)*(s**3.0d0) - &
               (220500.0d0)*(s**4.0d0) + &
               (83160.0d0)*(s**5.0d0)
       end if
    else if (j == 5) then
       if (k == 0) then
          phi = (1.0d0/120.0d0)*(s**5.0d0) - &
               (1.0d0/20.0d0)*(s**6.0d0) + &
               (1.0d0/8.0d0)*(s**7.0d0) - &
               (1.0d0/6.0d0)*(s**8.0d0) + &
               (1.0d0/8.0d0)*(s**9.0d0) - &
               (1.0d0/20.0d0)*(s**10.0d0) + &
               (1.0d0/120.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = (1.0d0/24.0d0)*(s**4.0d0) - &
               (3.0d0/10.0d0)*(s**5.0d0) + &
               (7.0d0/8.0d0)*(s**6.0d0) - &
               (4.0d0/3.0d0)*(s**7.0d0) + &
               (9.0d0/8.0d0)*(s**8.0d0) - &
               (1.0d0/2.0d0)*(s**9.0d0) + &
               (11.0d0/120.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = (1.0d0/6.0d0)*(s**3.0d0) - &
               (3.0d0/2.0d0)*(s**4.0d0) + &
               (21.0d0/4.0d0)*(s**5.0d0) - &
               (28.0d0/3.0d0)*(s**6.0d0) + &
               (9.0d0)*(s**7.0d0) - &
               (9.0d0/2.0d0)*(s**8.0d0) + &
               (11.0d0/12.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = (1.0d0/2.0d0)*(s**2.0d0) - &
               (6.0d0)*(s**3.0d0) + &
               (105.0d0/4.0d0)*(s**4.0d0) - &
               (56.0d0)*(s**5.0d0) + &
               (63.0d0)*(s**6.0d0) - &
               (36.0d0)*(s**7.0d0) + &
               (33.0d0/4.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = s - &
               (18.0d0)*(s**2.0d0) + &
               (105.0d0)*(s**3.0d0) - &
               (280.0d0)*(s**4.0d0) + &
               (378.0d0)*(s**5.0d0) - &
               (252.0d0)*(s**6.0d0) + &
               (66.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = (1.0d0) - &
               (36.0d0)*s + &
               (315.0d0)*(s**2.0d0) - &
               (1120.0d0)*(s**3.0d0) + &
               (1890.0d0)*(s**4.0d0) - &
               (1512.0d0)*(s**5.0d0) + &
               (462.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(36.0d0) + &
               (630.0d0)*s - &
               (3360.0d0)*(s**2.0d0) + &
               (7560.0d0)*(s**3.0d0) - &
               (7560.0d0)*(s**4.0d0) + &
               (2772.0d0)*(s**5.0d0)
       end if
    else if (j == 6) then
       if (k == 0) then
          phi = (462.0d0)*(s**6.0d0) - &
               (1980.0d0)*(s**7.0d0) + &
               (3465.0d0)*(s**8.0d0) - &
               (3080.0d0)*(s**9.0d0) + &
               (1386.0d0)*(s**10.0d0) - &
               (252.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = (2772.0d0)*(s**5.0d0) - &
               (13860.0d0)*(s**6.0d0) + &
               (27720.0d0)*(s**7.0d0) - &
               (27720.0d0)*(s**8.0d0) + &
               (13860.0d0)*(s**9.0d0) - &
               (2772.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = (13860.0d0)*(s**4.0d0) - &
               (83160.0d0)*(s**5.0d0) + &
               (194040.0d0)*(s**6.0d0) - &
               (221760.0d0)*(s**7.0d0) + &
               (124740.0d0)*(s**8.0d0) - &
               (27720.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = (55440.0d0)*(s**3.0d0) - &
               (415800.0d0)*(s**4.0d0) + &
               (1164240.0d0)*(s**5.0d0) - &
               (1552320.0d0)*(s**6.0d0) + &
               (997920.0d0)*(s**7.0d0) - &
               (249480.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = (166320.0d0)*(s**2.0d0) - &
               (1663200.0d0)*(s**3.0d0) + &
               (5821200.0d0)*(s**4.0d0) - &
               (9313920.0d0)*(s**5.0d0) + &
               (6985440.0d0)*(s**6.0d0) - &
               (1995840.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = (332640.0d0)*s - &
               (4989600.0d0)*(s**2.0d0) + &
               (23284800.0d0)*(s**3.0d0) - &
               (46569600.0d0)*(s**4.0d0) + &
               (41912640.0d0)*(s**5.0d0) - &
               (13970880.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = (332640.0d0) - &
               (9979200.0d0)*s + &
               (69854400.0d0)*(s**2.0d0) - &
               (186278400.0d0)*(s**3.0d0) + &
               (209563200.0d0)*(s**4.0d0) - &
               (83825280.0d0)*(s**5.0d0)
       end if
    else if (j == 7) then
       if (k == 0) then
          phi = -(210.0d0)*(s**6.0d0) + &
               (930.0d0)*(s**7.0d0) - &
               (1665.0d0)*(s**8.0d0) + &
               (1505.0d0)*(s**9.0d0) - &
               (686.0d0)*(s**10.0d0) + &
               (126.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = -(1260.0d0)*(s**5.0d0) + &
               (6510.0d0)*(s**6.0d0) - &
               (13320.0d0)*(s**7.0d0) + &
               (13545.0d0)*(s**8.0d0) - &
               (6860.0d0)*(s**9.0d0) + &
               (1386.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = -(6300.0d0)*(s**4.0d0) + &
               (39060.0d0)*(s**5.0d0) - &
               (93240.0d0)*(s**6.0d0) + &
               (108360.0d0)*(s**7.0d0) - &
               (61740.0d0)*(s**8.0d0) + &
               (13860.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = -(25200.0d0)*(s**3.0d0) + &
               (195300.0d0)*(s**4.0d0) - &
               (559440.0d0)*(s**5.0d0) + &
               (758520.0d0)*(s**6.0d0) - &
               (493920.0d0)*(s**7.0d0) + &
               (124740.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = -(75600.0d0)*(s**2.0d0) + &
               (781200.0d0)*(s**3.0d0) - &
               (2797200.0d0)*(s**4.0d0) + &
               (4551120.0d0)*(s**5.0d0) - &
               (3457440.0d0)*(s**6.0d0) + &
               (997920.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(151200.0d0)*s + &
               (2343600.0d0)*(s**2.0d0) - &
               (11188800.0d0)*(s**3.0d0) + &
               (22755600.0d0)*(s**4.0d0) - &
               (20744640.0d0)*(s**5.0d0) + &
               (6985440.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(151200.0d0) + &
               (4687200.0d0)*s - &
               (33566400.0d0)*(s**2.0d0) + &
               (91022400.0d0)*(s**3.0d0) - &
               (103723200.0d0)*(s**4.0d0) + &
               (41912640.0d0)*(s**5.0d0)
       end if
    else if (j == 8) then
       if (k == 0) then
          phi = (42.0d0)*(s**6.0d0) - &
               (192.0d0)*(s**7.0d0) + &
               (705.0d0/2.0d0)*(s**8.0d0) - &
               (325.0d0)*(s**9.0d0) + &
               (301.0d0/2.0d0)*(s**10.0d0) - &
               (28.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = (252.0d0)*(s**5.0d0) - &
               (1344.0d0)*(s**6.0d0) + &
               (2820.0d0)*(s**7.0d0) - &
               (2925.0d0)*(s**8.0d0) + &
               (1505.0d0)*(s**9.0d0) - &
               (308.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = (1260.0d0)*(s**4.0d0) - &
               (8064.0d0)*(s**5.0d0) + &
               (19740.0d0)*(s**6.0d0) - &
               (23400.0d0)*(s**7.0d0) + &
               (13545.0d0)*(s**8.0d0) - &
               (3080.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = (5040.0d0)*(s**3.0d0) - &
               (40320.0d0)*(s**4.0d0) + &
               (118440.0d0)*(s**5.0d0) - &
               (163800.0d0)*(s**6.0d0) + &
               (108360.0d0)*(s**7.0d0) - &
               (27720.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = (15120.0d0)*(s**2.0d0) - &
               (161280.0d0)*(s**3.0d0) + &
               (592200.0d0)*(s**4.0d0) - &
               (982800.0d0)*(s**5.0d0) + &
               (758520.0d0)*(s**6.0d0) - &
               (221760.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = (30240.0d0)*s - &
               (483840.0d0)*(s**2.0d0) + &
               (2368800.0d0)*(s**3.0d0) - &
               (4914000.0d0)*(s**4.0d0) + &
               (4551120.0d0)*(s**5.0d0) - &
               (1552320.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = (30240.0d0) - &
               (967680.0d0)*s + &
               (7106400.0d0)*(s**2.0d0) - &
               (19656000.0d0)*(s**3.0d0) + &
               (22755600.0d0)*(s**4.0d0) - &
               (9313920.0d0)*(s**5.0d0)
       end if
    else if (j == 9) then
       if (k == 0) then
          phi = -(14.0d0/3.0d0)*(s**6.0d0) + &
               (22.0d0)*(s**7.0d0) - &
               (83.0d0/2.0d0)*(s**8.0d0) + &
               (235.0d0/6.0d0)*(s**9.0d0) - &
               (37.0d0/2.0d0)*(s**10.0d0) + &
               (7.0d0/2.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = -(28.0d0)*(s**5.0d0) + &
               (154.0d0)*(s**6.0d0) - &
               (332.0d0)*(s**7.0d0) + &
               (705.0d0/2.0d0)*(s**8.0d0) - &
               (185.0d0)*(s**9.0d0) + &
               (77.0d0/2.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = -(140.0d0)*(s**4.0d0) + &
               (924.0d0)*(s**5.0d0) - &
               (2324.0d0)*(s**6.0d0) + &
               (2820.0d0)*(s**7.0d0) - &
               (1665.0d0)*(s**8.0d0) + &
               (385.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = -(560.0d0)*(s**3.0d0) + &
               (4620.0d0)*(s**4.0d0) - &
               (13944.0d0)*(s**5.0d0) + &
               (19740.0d0)*(s**6.0d0) - &
               (13320.0d0)*(s**7.0d0) + &
               (3465.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = -(1680.0d0)*(s**2.0d0) + &
               (18480.0d0)*(s**3.0d0) - &
               (69720.0d0)*(s**4.0d0) + &
               (118440.0d0)*(s**5.0d0) - &
               (93240.0d0)*(s**6.0d0) + &
               (27720.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(3360.0d0)*s + &
               (55440.0d0)*(s**2.0d0) - &
               (278880.0d0)*(s**3.0d0) + &
               (592200.0d0)*(s**4.0d0) - &
               (559440.0d0)*(s**5.0d0) + &
               (194040.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(3360.0d0) + &
               (110880.0d0)*s - &
               (836640.0d0)*(s**2.0d0) + &
               (2368800.0d0)*(s**3.0d0) - &
               (2797200.0d0)*(s**4.0d0) + &
               (1164240.0d0)*(s**5.0d0)
       end if
    else if (j == 10) then
       if (k == 0) then
          phi = (7.0d0/24.0d0)*(s**6.0d0) - &
               (17.0d0/12.0d0)*(s**7.0d0) + &
               (11.0d0/4.0d0)*(s**8.0d0) - &
               (8.0d0/3.0d0)*(s**9.0d0) + &
               (31.0d0/24.0d0)*(s**10.0d0) - &
               (1.0d0/4.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = (7.0d0/4.0d0)*(s**5.0d0) - &
               (119.0d0/12.0d0)*(s**6.0d0) + &
               (22.0d0)*(s**7.0d0) - &
               (24.0d0)*(s**8.0d0) + &
               (155.0d0/12.0d0)*(s**9.0d0) - &
               (11.0d0/4.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = (35.0d0/4.0d0)*(s**4.0d0) - &
               (119.0d0/2.0d0)*(s**5.0d0) + &
               (154.0d0)*(s**6.0d0) - &
               (192.0d0)*(s**7.0d0) + &
               (465.0d0/4.0d0)*(s**8.0d0) - &
               (55.0d0/2.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = (35.0d0)*(s**3.0d0) - &
               (595.0d0/2.0d0)*(s**4.0d0) + &
               (924.0d0)*(s**5.0d0) - &
               (1344.0d0)*(s**6.0d0) + &
               (930.0d0)*(s**7.0d0) - &
               (495.0d0/2.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = (105.0d0)*(s**2.0d0) - &
               (1190.0d0)*(s**3.0d0) + &
               (4620.0d0)*(s**4.0d0) - &
               (8064.0d0)*(s**5.0d0) + &
               (6510.0d0)*(s**6.0d0) - &
               (1980.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = (210.0d0)*s - &
               (3570.0d0)*(s**2.0d0) + &
               (18480.0d0)*(s**3.0d0) - &
               (40320.0d0)*(s**4.0d0) + &
               (39060.0d0)*(s**5.0d0) - &
               (13860.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = (210.0d0) - &
               (7140.0d0)*s + &
               (55440.0d0)*(s**2.0d0) - &
               (161280.0d0)*(s**3.0d0) + &
               (195300.0d0)*(s**4.0d0) - &
               (83160.0d0)*(s**5.0d0)
       end if
    else if (j == 11) then
       if (k == 0) then
          phi = -(1.0d0/120.0d0)*(s**6.0d0) + &
               (1.0d0/24.0d0)*(s**7.0d0) - &
               (1.0d0/12.0d0)*(s**8.0d0) + &
               (1.0d0/12.0d0)*(s**9.0d0) - &
               (1.0d0/24.0d0)*(s**10.0d0) + &
               (1.0d0/120.0d0)*(s**11.0d0)
       else if (k == 1) then
          phi = -(1.0d0/20.0d0)*(s**5.0d0) + &
               (7.0d0/24.0d0)*(s**6.0d0) - &
               (2.0d0/3.0d0)*(s**7.0d0) + &
               (3.0d0/4.0d0)*(s**8.0d0) - &
               (5.0d0/12.0d0)*(s**9.0d0) + &
               (11.0d0/120.0d0)*(s**10.0d0)
       else if (k == 2) then
          phi = -(1.0d0/4.0d0)*(s**4.0d0) + &
               (7.0d0/4.0d0)*(s**5.0d0) - &
               (14.0d0/3.0d0)*(s**6.0d0) + &
               (6.0d0)*(s**7.0d0) - &
               (15.0d0/4.0d0)*(s**8.0d0) + &
               (11.0d0/12.0d0)*(s**9.0d0)
       else if (k == 3) then
          phi = -(s**3.0d0) + &
               (35.0d0/4.0d0)*(s**4.0d0) - &
               (28.0d0)*(s**5.0d0) + &
               (42.0d0)*(s**6.0d0) - &
               (30.0d0)*(s**7.0d0) + &
               (33.0d0/4.0d0)*(s**8.0d0)
       else if (k == 4) then
          phi = -(3.0d0)*(s**2.0d0) + &
               (35.0d0)*(s**3.0d0) - &
               (140.0d0)*(s**4.0d0) + &
               (252.0d0)*(s**5.0d0) - &
               (210.0d0)*(s**6.0d0) + &
               (66.0d0)*(s**7.0d0)
       else if (k == 5) then
          phi = -(6.0d0)*s + &
               (105.0d0)*(s**2.0d0) - &
               (560.0d0)*(s**3.0d0) + &
               (1260.0d0)*(s**4.0d0) - &
               (1260.0d0)*(s**5.0d0) + &
               (462.0d0)*(s**6.0d0)
       else if (k == 6) then
          phi = -(6.0d0) + &
               (210.0d0)*s - &
               (1680.0d0)*(s**2.0d0) + &
               (5040.0d0)*(s**3.0d0) - &
               (6300.0d0)*(s**4.0d0) + &
               (2772.0d0)*(s**5.0d0)
       end if
    end if

  END SUBROUTINE shape_function

  SUBROUTINE derivatives(neq,i,x,y,yprime,u,ux,uxx,uxxx,&
       uxxxx,uxxxxx,uxxxxxx,utau,rpar)
    ! return value of u and its spatio-termporal derivatives
    ! at a point x_i < x < x_i+1
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: i, neq, x
    REAL(kind=8), DIMENSION(neq), INTENT(IN) :: y, yprime
    REAL(kind=8), INTENT(OUT) :: u, ux, uxx, uxxx, uxxxx,&
         uxxxxx, uxxxxxx, utau
    REAL(kind=8), DIMENSION(4+7*12*13), INTENT(IN) :: rpar
    REAL(kind=8), PARAMETER :: sone = 0.03376524289842475d0,&
         stwo = 0.16939530676686765d0,&
         sthree = 0.3806904069584014d0,&
         sfour = 0.6193095930415986d0,&
         sfive = 0.8306046932331324d0,&
         ssix = 0.9662347571015759d0,&
         pone = 0.0d0, ptwo = 0.0848880518607158d0,&
         pthree = 0.265575603264643d0, pfour = 0.5d0,&
         pfive = 0.7344243967353573d0,&
         psix = 0.9151119481392833d0, pseven = 1.0d0
    REAL(kind=8), DIMENSION(13), PARAMETER :: points = &
         [sone, stwo, sthree, sfour, sfive, ssix, pone, ptwo, &
         pthree, pfour, pfive, psix, pseven]
    REAL(kind=8) :: h, htau

    h = y(7*(i+1)) - y(7*i)
    htau = yprime(7*(i+1)) - yprime(7*i)

    ! rpar set up so that rpar(4+1) = phi(0,0,sone), rpar(4+14) =
    ! phi(0,1,sone), rpar(4+92) = phi(1,0,sone). Use x now to contain
    ! an integer where 1 to 6 correspond to s's and 7 to 13
    ! correspond to p's

    u = y(7*(i-1)+1)*rpar(4+x) + &
         y(7*(i-1)+2)*rpar(4+91+x)*h +&
         y(7*(i-1)+3)*rpar(4+2*91+x)*(h**2.0d0) +&
         y(7*(i-1)+4)*rpar(4+3*91+x)*(h**3.0d0) +&
         y(7*(i-1)+5)*rpar(4+4*91+x)*(h**4.0d0) +&
         y(7*(i-1)+6)*rpar(4+5*91+x)*(h**5.0d0) +&
         y(7*i+1)*rpar(4+6*91+x) + &
         y(7*i+2)*rpar(4+7*91+x)*h +&
         y(7*i+3)*rpar(4+8*91+x)*(h**2.0d0) +&
         y(7*i+4)*rpar(4+9*91+x)*(h**3.0d0) +&
         y(7*i+5)*rpar(4+10*91+x)*(h**4.0d0) +&
         y(7*i+6)*rpar(4+11*91+x)*(h**5.0d0)

    ux = (y(7*(i-1)+1)*rpar(4+13+x) + &
         y(7*(i-1)+2)*rpar(4+91+13+x)*h +&
         y(7*(i-1)+3)*rpar(4+2*91+13+x)*(h**2.0d0) +&
         y(7*(i-1)+4)*rpar(4+3*91+13+x)*(h**3.0d0) +&
         y(7*(i-1)+5)*rpar(4+4*91+13+x)*(h**4.0d0) +&
         y(7*(i-1)+6)*rpar(4+5*91+13+x)*(h**5.0d0) +&
         y(7*i+1)*rpar(4+6*91+13+x) + &
         y(7*i+2)*rpar(4+7*91+13+x)*h +&
         y(7*i+3)*rpar(4+8*91+13+x)*(h**2.0d0) +&
         y(7*i+4)*rpar(4+9*91+13+x)*(h**3.0d0) +&
         y(7*i+5)*rpar(4+10*91+13+x)*(h**4.0d0) +&
         y(7*i+6)*rpar(4+11*91+13+x)*(h**5.0d0))/h

    uxx = (y(7*(i-1)+1)*rpar(4+2*13+x) + &
         y(7*(i-1)+2)*rpar(4+91+2*13+x)*h +&
         y(7*(i-1)+3)*rpar(4+2*91+2*13+x)*(h**2.0d0) +&
         y(7*(i-1)+4)*rpar(4+3*91+2*13+x)*(h**3.0d0) +&
         y(7*(i-1)+5)*rpar(4+4*91+2*13+x)*(h**4.0d0) +&
         y(7*(i-1)+6)*rpar(4+5*91+2*13+x)*(h**5.0d0) +&
         y(7*i+1)*rpar(4+6*91+2*13+x) + &
         y(7*i+2)*rpar(4+7*91+2*13+x)*h +&
         y(7*i+3)*rpar(4+8*91+2*13+x)*(h**2.0d0) +&
         y(7*i+4)*rpar(4+9*91+2*13+x)*(h**3.0d0) +&
         y(7*i+5)*rpar(4+10*91+2*13+x)*(h**4.0d0) +&
         y(7*i+6)*rpar(4+11*91+2*13+x)*(h**5.0d0))/(h**2.0d0)

    uxxx = (y(7*(i-1)+1)*rpar(4+3*13+x) + &
         y(7*(i-1)+2)*rpar(4+91+3*13+x)*h +&
         y(7*(i-1)+3)*rpar(4+2*91+3*13+x)*(h**2.0d0) +&
         y(7*(i-1)+4)*rpar(4+3*91+3*13+x)*(h**3.0d0) +&
         y(7*(i-1)+5)*rpar(4+4*91+3*13+x)*(h**4.0d0) +&
         y(7*(i-1)+6)*rpar(4+5*91+3*13+x)*(h**5.0d0) +&
         y(7*i+1)*rpar(4+6*91+3*13+x) + &
         y(7*i+2)*rpar(4+7*91+3*13+x)*h +&
         y(7*i+3)*rpar(4+8*91+3*13+x)*(h**2.0d0) +&
         y(7*i+4)*rpar(4+9*91+3*13+x)*(h**3.0d0) +&
         y(7*i+5)*rpar(4+10*91+3*13+x)*(h**4.0d0) +&
         y(7*i+6)*rpar(4+11*91+3*13+x)*(h**5.0d0))/(h**3.0d0)

    uxxxx = (y(7*(i-1)+1)*rpar(4+4*13+x) + &
         y(7*(i-1)+2)*rpar(4+91+4*13+x)*h +&
         y(7*(i-1)+3)*rpar(4+2*91+4*13+x)*(h**2.0d0) +&
         y(7*(i-1)+4)*rpar(4+3*91+4*13+x)*(h**3.0d0) +&
         y(7*(i-1)+5)*rpar(4+4*91+4*13+x)*(h**4.0d0) +&
         y(7*(i-1)+6)*rpar(4+5*91+4*13+x)*(h**5.0d0) +&
         y(7*i+1)*rpar(4+6*91+4*13+x) + &
         y(7*i+2)*rpar(4+7*91+4*13+x)*h +&
         y(7*i+3)*rpar(4+8*91+4*13+x)*(h**2.0d0) +&
         y(7*i+4)*rpar(4+9*91+4*13+x)*(h**3.0d0) +&
         y(7*i+5)*rpar(4+10*91+4*13+x)*(h**4.0d0) +&
         y(7*i+6)*rpar(4+11*91+4*13+x)*(h**5.0d0))/(h**4.0d0)

    uxxxxx = (y(7*(i-1)+1)*rpar(4+5*13+x) + &
         y(7*(i-1)+2)*rpar(4+91+5*13+x)*h +&
         y(7*(i-1)+3)*rpar(4+2*91+5*13+x)*(h**2.0d0) +&
         y(7*(i-1)+4)*rpar(4+3*91+5*13+x)*(h**3.0d0) +&
         y(7*(i-1)+5)*rpar(4+4*91+5*13+x)*(h**4.0d0) +&
         y(7*(i-1)+6)*rpar(4+5*91+5*13+x)*(h**5.0d0) +&
         y(7*i+1)*rpar(4+6*91+5*13+x) + &
         y(7*i+2)*rpar(4+7*91+5*13+x)*h +&
         y(7*i+3)*rpar(4+8*91+5*13+x)*(h**2.0d0) +&
         y(7*i+4)*rpar(4+9*91+5*13+x)*(h**3.0d0) +&
         y(7*i+5)*rpar(4+10*91+5*13+x)*(h**4.0d0) +&
         y(7*i+6)*rpar(4+11*91+5*13+x)*(h**5.0d0))/(h**5.0d0)

    uxxxxxx = (y(7*(i-1)+1)*rpar(4+6*13+x) + &
         y(7*(i-1)+2)*rpar(4+91+6*13+x)*h +&
         y(7*(i-1)+3)*rpar(4+2*91+6*13+x)*(h**2.0d0) +&
         y(7*(i-1)+4)*rpar(4+3*91+6*13+x)*(h**3.0d0) +&
         y(7*(i-1)+5)*rpar(4+4*91+6*13+x)*(h**4.0d0) +&
         y(7*(i-1)+6)*rpar(4+5*91+6*13+x)*(h**5.0d0) +&
         y(7*i+1)*rpar(4+6*91+6*13+x) + &
         y(7*i+2)*rpar(4+7*91+6*13+x)*h +&
         y(7*i+3)*rpar(4+8*91+6*13+x)*(h**2.0d0) +&
         y(7*i+4)*rpar(4+9*91+6*13+x)*(h**3.0d0) +&
         y(7*i+5)*rpar(4+10*91+6*13+x)*(h**4.0d0) +&
         y(7*i+6)*rpar(4+11*91+6*13+x)*(h**5.0d0))/(h**6.0d0)

    utau = yprime(7*(i-1)+1)*rpar(4+x) + &
         (yprime(7*(i-1)+2)*h)*rpar(4+91+x) + &
         (yprime(7*(i-1)+3)*(h**2.0d0))*rpar(4+2*91+x) + &
         (yprime(7*(i-1)+4)*(h**3.0d0))*rpar(4+3*91+x) +&
         (yprime(7*(i-1)+5)*(h**4.0d0))*rpar(4+4*91+x) +&
         (yprime(7*(i-1)+6)*(h**5.0d0))*rpar(4+5*91+x) +&
         yprime(7*i+1)*rpar(4+6*91+x) + &
         (yprime(7*i+2)*h)*rpar(4+7*91+x) +&
         (yprime(7*i+3)*(h**2.0d0))*rpar(4+8*91+x) +&
         (yprime(7*i+4)*(h**3.0d0))*rpar(4+9*91+x) +&
         (yprime(7*i+5)*(h**4.0d0))*rpar(4+10*91+x) +&
         (yprime(7*i+6)*(h**5.0d0))*rpar(4+11*91+x) -&
         ux*(yprime(7*i)+points(x)*htau)

  END SUBROUTINE derivatives

  SUBROUTINE residual_pde(neq,tau,y,yprime,delta,ires,rpar,ipar)
    ! Fill the entries of the residual corresponding to the solution and
    ! its derivatives with the collocation equation (non conservative)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: neq
    INTEGER :: npts, ii, jj, kk, ll, timetrans, cons, x
    REAL(kind=8) :: u, ux, uxx, uxxx, uxxxx, uxxxxx, uxxxxxx, &
         utau, vx, xtau, p, g
    INTEGER, INTENT(INOUT) :: ires
    INTEGER, DIMENSION(*), INTENT(IN) :: ipar
    REAL(kind=8) :: h, htau, sund, big
    REAL(kind=8), INTENT(IN) :: tau
    REAL(kind=8), DIMENSION(neq), INTENT(IN) :: y, yprime
    REAL(kind=8), DIMENSION(4+7*12*13), INTENT(IN) :: rpar
    REAL(kind=8), DIMENSION(neq), INTENT(INOUT) :: delta
    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: fmntr, fsmooth, prmtr
    REAL(kind=8), PARAMETER :: sone = 0.03376524289842475d0,&
         stwo = 0.16939530676686765d0,&
         sthree = 0.3806904069584014d0,&
         sfour = 0.6193095930415986d0,&
         sfive = 0.8306046932331324d0,&
         ssix = 0.9662347571015759d0
     REAL(kind=8), DIMENSION(6), PARAMETER :: points = &
         [sone, stwo, sthree, sfour, sfive, ssix]

    timetrans = ipar(6)
    cons = ipar(7)
    npts = ipar(4)
    p = rpar(1)

    ALLOCATE (fmntr(neq),fsmooth(neq),prmtr(neq))
    call monitor(neq,y,yprime,fmntr,prmtr,rpar,ipar)
    big = 0.0d0
    do kk = 1,npts
       if (fmntr(7*kk) > big) then
          big = fmntr(7*kk)
       end if
    end do
    if (timetrans==1) then
       sund = 1.0d0/big
    elseif (timetrans==0) then
       sund = 1.0d0
    end if
    if (cons == 0) then
       do ii = 1,npts-1
          h = y(7*(ii+1))-y(7*ii)
          htau = yprime(7*(ii+1)) - yprime(7*ii)
          do jj = 1,6
             call derivatives(neq,ii,jj,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                  uxxxxxx,rpar,ipar)
! one of these plus the two following lines should be uncommented
! to attempt to stabilize the problem
             ! call upwinder(neq,ii,jj,y,yprime,u,vx,rpar)
             ! call lower_order(neq,ii,jj,y,yprime,vx)
             xtau = yprime(7*ii) + points(jj)*htau
             utau = utau + (ux - vx)*xtau
             if (jj < 4) then
                delta(7*(ii-1)+3+jj) = utau - sund*g
             else
                delta(7*ii+jj-3) = utau - sund*g
             end if
          end do
       end do
    else if (cons == 1) then
       do ii = 1,npts-1
          h = y(7*(ii+1))-y(7*ii)
          do jj = 1,6
             call derivatives(neq,ii,jj,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                  uxxxxxx,rpar,ipar)
             if (jj < 4) then
                delta(7*(ii-1)+3+jj) = h*utau/sund
             else
                delta(7*ii+jj-3) = h*utau/sund
             end if
          end do
          do ll = 1,7
             if (ll == 1) then
                x = 7
                call derivatives(neq,ii,x,y,yprime,u,ux,&
                     uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
                call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                     uxxxxxx,rpar,ipar)
                delta(7*(ii-1)+4) = delta(7*(ii-1)+4) +&
                     0.128882066524507657D2*g
                delta(7*(ii-1)+5) = delta(7*(ii-1)+5) -&
                     0.732825716500196678D0*g
                delta(7*(ii-1)+6) = delta(7*(ii-1)+6) + &
                     0.164922049039696650D0*g
                delta(7*ii+1) = delta(7*ii+1) - &
                     0.623170625543232604D-1*g
                delta(7*ii+2) = delta(7*ii+2) + &
                     0.304799806699240471D-1*g
                delta(7*ii+3) = delta(7*ii+3) - &
                     0.157386303787899057D-1*g
             else if (ll == 2) then
                x = 8
                call derivatives(neq,ii,x,y,yprime,u,ux,&
                     uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
                call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                     uxxxxxx,rpar,ipar)
                delta(7*(ii-1)+4) = delta(7*(ii-1)+4) -&
                     0.135555128881389990D2*g
                delta(7*(ii-1)+5) = delta(7*(ii-1)+5) +&
                     0.709951339386726676D1*g
                delta(7*(ii-1)+6) = delta(7*(ii-1)+6) - &
                     0.658616272480538112D0*g
                delta(7*ii+1) = delta(7*ii+1) + &
                     0.201775206853726796D0*g
                delta(7*ii+2) = delta(7*ii+2) - &
                     0.911735577624964294D-1*g
                delta(7*ii+3) = delta(7*ii+3) + &
                     0.456091312690583006D-1*g
             else if (ll == 3) then
                x = 9
                call derivatives(neq,ii,x,y,yprime,u,ux,&
                     uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
                call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                     uxxxxxx,rpar,ipar)
                delta(7*(ii-1)+4) = delta(7*(ii-1)+4) +&
                     0.823360561753947895D0*g
                delta(7*(ii-1)+5) = delta(7*(ii-1)+5) -&
                     0.684470480798240999D1*g
                delta(7*(ii-1)+6) = delta(7*(ii-1)+6) + &
                     0.543104912697367581D1*g
                delta(7*ii+1) = delta(7*ii+1) - &
                     0.575165066473151465D0*g
                delta(7*ii+2) = delta(7*ii+2) + &
                     0.198328593004358011D0*g
                delta(7*ii+3) = delta(7*ii+3) - &
                     0.901243497969793084D-1*g
             else if (ll == 4) then
                x = 10
                call derivatives(neq,ii,x,y,yprime,u,ux,&
                     uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
                call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                     uxxxxxx,rpar,ipar)
                delta(7*(ii-1)+4) = delta(7*(ii-1)+4) - &
                     0.216308174972419803D0*g
                delta(7*(ii-1)+5) = delta(7*(ii-1)+5) +  &
                     0.615652146527092881D0*g
                delta(7*(ii-1)+6) = delta(7*(ii-1)+6) - &
                     0.537306182570658031D1*g
                delta(7*ii+1) = delta(7*ii+1) + &
                     0.537306182570662916D1*g
                delta(7*ii+2) = delta(7*ii+2) - &
                     0.615652146527116750D0*g
                delta(7*ii+3) = delta(7*ii+3) + &
                     0.216308174972481171D0*g
             else if (ll == 5) then
                x = 11
                call derivatives(neq,ii,x,y,yprime,u,ux,&
                     uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
                call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                     uxxxxxx,rpar,ipar)
                delta(7*(ii-1)+4) = delta(7*(ii-1)+4) + &
                     0.901243497969332896D-1*g
                delta(7*(ii-1)+5) = delta(7*(ii-1)+5) -  &
                     0.198328593004349574D0*g
                delta(7*(ii-1)+6) = delta(7*(ii-1)+6) + &
                     0.575165066473167785D0*g
                delta(7*ii+1) = delta(7*ii+1) - &
                     0.543104912697373088D1*g
                delta(7*ii+2) = delta(7*ii+2) + &
                     0.684470480798244640D1*g
                delta(7*ii+3) = delta(7*ii+3) - &
                     0.823360561754134634D0*g
             else if (ll == 6) then
                x = 12
                call derivatives(neq,ii,x,y,yprime,u,ux,&
                     uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
                call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                     uxxxxxx,rpar,ipar)
                delta(7*(ii-1)+4) = delta(7*(ii-1)+4) - &
                     0.456091312689924505D-1*g
                delta(7*(ii-1)+5) = delta(7*(ii-1)+5) +  &
                     0.911735577625287091D-1*g
                delta(7*(ii-1)+6) = delta(7*(ii-1)+6) - &
                     0.201775206853745059D0*g
                delta(7*ii+1) = delta(7*ii+1) + &
                     0.658616272480554432D0*g
                delta(7*ii+2) = delta(7*ii+2) - &
                     0.709951339386726943D1*g
                delta(7*ii+3) = delta(7*ii+3) + &
                     0.135555128881391269D2*g
             else if (ll == 7) then
                x = 13
                call derivatives(neq,ii,x,y,yprime,u,ux,&
                     uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
                call def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
                     uxxxxxx,rpar,ipar)
                delta(7*(ii-1)+4) = delta(7*(ii-1)+4) + &
                     0.157386303787635622D-1*g
                delta(7*(ii-1)+5) = delta(7*(ii-1)+5) -  &
                     0.304799806699315723D-1*g
                delta(7*(ii-1)+6) = delta(7*(ii-1)+6) + &
                     0.623170625543236212D-1*g
                delta(7*ii+1) = delta(7*ii+1) - &
                     0.164922049039704727D0*g
                delta(7*ii+2) = delta(7*ii+2) + &
                     0.732825716500154489D0*g
                delta(7*ii+3) = delta(7*ii+3) - &
                     0.128882066524507621D2*g
             end if
          end do
       end do
    end if
    ! Left Boundary Conditions
    x = 7
    call derivatives(neq,1,x,y,yprime,u,ux,uxx,uxxx,uxxxx,uxxxxx,&
         uxxxxxx,utau,rpar)
    delta(1) = ux
    delta(2) = uxxx
    delta(3) = uxxxxx

    ! Right Boundary Conditions
    x = 13
    call derivatives(neq,npts-1,x,y,yprime,u,ux,uxx,uxxx,uxxxx,&
         uxxxxx,uxxxxxx,utau,rpar)
    delta(7*npts-3) = ux
    delta(7*npts-2) = uxxx
    delta(7*npts-1) = uxxxxx
    ! last entry contains ode for time transformation dt/dtau = g(u)
    delta(neq) = yprime(neq) - sund
    DEALLOCATE(fmntr)
  END SUBROUTINE residual_pde

  SUBROUTINE residual_mesheq(neq,tau,y,yprime,delta,ires,rpar,ipar)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: neq
    INTEGER :: npts, j, kk,  timetrans
    REAL(kind=8) ::  epsilon, h, sund, big, p
    INTEGER, INTENT(INOUT) :: ires
    INTEGER, DIMENSION(*), INTENT(IN) :: ipar
    REAL(kind=8), INTENT(IN) :: tau
    REAL(kind=8), DIMENSION(neq), INTENT(IN) :: y, yprime
    REAL(kind=8), DIMENSION(4+7*12*13), INTENT(IN) :: rpar
    REAL(kind=8), DIMENSION(neq), INTENT(INOUT) :: delta
    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: fmntr, fsmooth, prmtr
    npts = ipar(4)
    h = rpar(2)
    p = rpar(1)
    epsilon = 1.0d-3
    ALLOCATE (fmntr(neq),fsmooth(neq),prmtr(neq))
    call monitor(neq,y,yprime,fmntr,prmtr,rpar,ipar)
    call smooth_monitor(neq,fmntr,fsmooth,rpar,ipar)
    big = 0.0d0
    do kk = 1,npts
       if (fmntr(7*kk) > big) then
          big = fmntr(7*kk)
       end if
    end do
    if (timetrans==1) then
       sund = 1.0d0/big
    elseif (timetrans==0) then
       sund = 1.0d0
    end if
    ! Fix left mesh point location by setting RHS of MEQ to zero
    delta(7) = yprime(7)/(h**2.0d0)
    do j = 2,npts-1
       delta(7*j) = (yprime(7*(j-1)) - 2.0d0*yprime(7*j) + &
            yprime(7*(j+1)))/(h**2.0d0) + &
            sund*((((fsmooth(7*(j+1)) + &
            fsmooth(7*j))*(y(7*(j+1)) - y(7*j))) - &
            (((fsmooth(7*j) + &
            fsmooth(7*(j-1)))*(y(7*j) - &
            y(7*(j-1))))))/(epsilon*(h**2.0d0)))
    end do
    ! Likewise right mesh point
    delta(7*npts) = yprime(7*npts)/(h**2.0d0)
    DEALLOCATE(fmntr,fsmooth,prmtr)
  END SUBROUTINE residual_mesheq

  SUBROUTINE monitor(neq,y,yprime,fmntr,prmtr,rpar,ipar)
    ! Calculates Monitor Function evaluated at mesh points (might be
    ! advantageous in future to figure out how to take weighted average
    ! over Gauss points)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: neq
    INTEGER :: npts, i, j, k, job, x
    REAL(kind=8) :: u, ux, uxx, uxxx, uxxxx, uxxxxx, uxxxxxx,&
         utau, p, add, weight, h, M, dummy, monalpha
    REAL(kind=8), PARAMETER :: wone = 0.08566224618958468d0,&
         wtwo = 0.18038078652407022d0,&
         wthree = 0.2339569672863451d0,&
         wfour = 0.23395696728634524d0,&
         wfive = 0.1803807865240697d0,&
         wsix = 0.08566224618958512d0
    INTEGER, DIMENSION(*), INTENT(IN) :: ipar
    REAL(kind=8), DIMENSION(neq), INTENT(IN) :: y, yprime
    REAL(kind=8), DIMENSION(4+7*12*13), INTENT(IN) :: rpar
    REAL(kind=8), DIMENSION(neq), INTENT(INOUT) :: fmntr, prmtr
    npts = ipar(4)
    p = rpar(1)
    monalpha = rpar(1097)
    add = 0.0d0
    dummy = 0.0d0
    do i = 1,npts-1
       h = y(7*(i+1)) - y(7*i)
       fmntr(7*i) = 0.0d0
       do j = 1,6
          if (j == 1) then
             x = 1
             weight = wone
             call derivatives(neq,i,x,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_monitor(M,dummy,u,ux,uxx,rpar,ipar)
             fmntr(7*i)  = fmntr(7*i) + (1.0d0/6.0d0)*M
             add = add + h*weight*M
          else if (j == 2) then
             x = 2
             weight = wtwo
             call derivatives(neq,i,x,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_monitor(M,dummy,u,ux,uxx,rpar,ipar)
             fmntr(7*i)  = fmntr(7*i) + (1.0d0/6.0d0)*M
             add = add + h*weight*M
          else if (j == 3) then
             x = 3
             weight = wthree
             call derivatives(neq,i,x,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_monitor(M,dummy,u,ux,uxx,rpar,ipar)
             fmntr(7*i)  = fmntr(7*i) + (1.0d0/6.0d0)*M
             add = add + h*weight*M
          else if (j == 4) then
             x = 4
             weight = wfour
             call derivatives(neq,i,x,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_monitor(M,dummy,u,ux,uxx,rpar,ipar)
             fmntr(7*i)  = fmntr(7*i) + (1.0d0/6.0d0)*M
             add = add + h*weight*M
          else if (j == 5) then
             x = 5
             weight = wfive
             call derivatives(neq,i,x,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_monitor(M,dummy,u,ux,uxx,rpar,ipar)
             fmntr(7*i)  = fmntr(7*i) + (1.0d0/6.0d0)*M
             add = add + h*weight*M
          else if (j == 6) then
             x = 6
             weight = wsix
             call derivatives(neq,i,x,y,yprime,u,ux,&
                  uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             call def_monitor(M,dummy,u,ux,uxx,rpar,ipar)
             fmntr(7*i)  = fmntr(7*i) + (1.0d0/6.0d0)*M
             add = add + h*weight*M
          end if
       end do
    end do
    fmntr(7*npts) = fmntr(7*(npts-1))
    prmtr = fmntr
    do k = 1,npts
       fmntr(7*k) = fmntr(7*k) + monalpha*add
    end do
  END SUBROUTINE monitor

  SUBROUTINE smooth_monitor(neq,fmntr,fsmooth,rpar,ipar)
    ! smooths the monitor function to reduce stiffness
    IMPLICIT NONE
    INTEGER :: npts, j, l, p
    INTEGER, INTENT(IN) :: neq
    INTEGER, DIMENSION(7) :: ipar
    REAL(kind=8) :: gamma, qgamma, divisor
    REAL(kind=8), DIMENSION(4) :: rpar
    REAL(kind=8), DIMENSION(*) :: fsmooth, fmntr
    npts = ipar(4)
    ! smoothing parameter
    gamma = 3.0d0
    qgamma = gamma/(1.0d0+gamma)
    ! smoothing index (currently only 1 and 2 are supported)
    p = 1
    do j = p,npts-p
       fsmooth(7*j) = 0.0d0
       divisor = 0.0d0
       do l = -p,p
          fsmooth(7*j) = fsmooth(7*j) + (fmntr(7*(j+l))**2.0d0)*(qgamma**(dble(abs(l))))
          divisor = divisor + (qgamma**(dble(abs(l))))
       end do
       fsmooth(7*j) = sqrt(fsmooth(7*j)/divisor)
    end do
    fsmooth(7) = sqrt(fmntr(7)**2.0d0 + fmntr(14)**2.0d0)
    fsmooth(7*npts) = sqrt(fmntr(7*(npts-1))**2.0d0 + &
         fmntr(7*npts)**2.0d0)
    if (p == 2) then
       fsmooth(14) = sqrt(((fmntr(7)**2.0d0)*qgamma + &
            (fmntr(14)**2.0d0) + &
            (fmntr(21)**2.0d0/qgamma))/(2.0d0*qgamma))
       fsmooth(7*(npts-1)) = sqrt(((fmntr(7*(npts-2))**2.0d0)*qgamma + (fmntr(7*(npts-1))**2.0d0) + &
            (fmntr(7*npts))**2.0d0/qgamma)/(2.0d0*qgamma))
    end if
  END SUBROUTINE smooth_monitor

  SUBROUTINE def_ic(x,u0)
    IMPLICIT NONE
    REAL(kind=8), INTENT(IN) :: x
    REAL(kind=8), INTENT(OUT) :: u0
    REAL(kind=8), PARAMETER :: pi = 4.0d0*datan(1.0d0)

    u0 = (8.0d0/(dsqrt(2.0d0*pi)))*dexp(-x**2.0/2.0)
  END SUBROUTINE def_ic

  SUBROUTINE def_pde(g,u,ux,uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,rpar,ipar)
    IMPLICIT NONE
    REAL(kind=8), INTENT(OUT) :: g
    REAL(kind=8), INTENT(IN) :: u, ux, uxx, uxxx, uxxxx, uxxxxx, uxxxxxx
    INTEGER, DIMENSION(*), INTENT(IN) :: ipar
    REAL(kind=8), DIMENSION(*), INTENT(IN) :: rpar
    REAL(kind=8) :: p, delta
    INTEGER :: cons

    p = rpar(1)
    delta = 1.0d-3 ! Regularizing parameter
    cons = ipar(7)

    if (cons == 0) then
       g = ux*uxxxxx + u*uxxxxxx - 30*(u**4.0d0)*(ux**2.0d0) - 6*(u**5.0d0)*uxx
    elseif (cons == 1) then
       g = u*uxxxxx - 6.0d0*(u**5.0d0)*ux
    endif
  END SUBROUTINE def_pde

  SUBROUTINE def_monitor(M,x,u,ux,uxx,rpar,ipar)
    IMPLICIT NONE
    REAL(kind=8), INTENT(OUT) :: M
    REAL(kind=8), INTENT(IN) :: x, u, ux, uxx
    INTEGER, DIMENSION(*), INTENT(IN) :: ipar
    REAL(kind=8), DIMENSION(*), INTENT(IN) :: rpar
    REAL(kind=8) :: p, nu, delta

    p = rpar(1)
    M = u**7.0d0 + abs((x**2.0d0)*uxx)**7.0d0
  END SUBROUTINE def_monitor

  SUBROUTINE solution_output(neq,y,yprime,rpar,ipar,mesh,soln)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: neq
    INTEGER, DIMENSION(*), INTENT(IN) :: ipar
    INTEGER :: i, j, npts, x
    REAL(kind=8), DIMENSION(neq), INTENT(IN) :: y, yprime
    REAL(kind=8), DIMENSION(4+7*12*13), INTENT(IN) :: rpar
    REAL(kind=8), DIMENSION(neq-6), INTENT(OUT) :: mesh,&
         soln
    REAL(kind=8) :: u, ux, uxx, uxxx, uxxxx, uxxxxx,&
         uxxxxxx, utau, h, coord
    REAL(kind=8), PARAMETER :: sone = 0.03376524289842475d0,&
         stwo = 0.16939530676686765d0,&
         sthree = 0.3806904069584014d0,&
         sfour = 0.6193095930415986d0,&
         sfive = 0.8306046932331324d0,&
         ssix = 0.9662347571015759d0

    npts = ipar(4)
    do i = 1, npts-1
       h = y(7*(i+1)) - y(7*i)
       mesh(7*i-6) = y(7*i)
       soln(7*i-6) = y(7*i-6)
       do j = 1,6
          if (j == 1) then
             x = 1
             coord = y(7*i) + sone*h
             mesh(7*i-5) = coord
             call derivatives(neq,i,x,y,yprime,u,ux,uxx,uxxx,&
                  uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             soln(7*i-5) = u
          else if (j == 2) then
             x = 2
             coord = y(7*i) + stwo*h
             mesh(7*i-4) = coord
             call derivatives(neq,i,x,y,yprime,u,ux,uxx,uxxx,&
                  uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             soln(7*i-4) = u
          else if (j == 3) then
             x = 3
             coord = y(7*i) + sthree*h
             mesh(7*i-3) = coord
             call derivatives(neq,i,x,y,yprime,u,ux,uxx,uxxx,&
                  uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             soln(7*i-3) = u
          else if (j == 4) then
             x = 4
             coord = y(7*i) + sfour*h
             mesh(7*i-2) = coord
             call derivatives(neq,i,x,y,yprime,u,ux,uxx,uxxx,&
                  uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             soln(7*i-2) = u
          else if (j == 5) then
             x = 5
             coord = y(7*i) + sfive*h
             mesh(7*i-1) = coord
             call derivatives(neq,i,x,y,yprime,u,ux,uxx,uxxx,&
                  uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             soln(7*i-1) = u
          else if (j == 6) then
             x = 6
             coord = y(7*i) + ssix*h
             mesh(7*i) = coord
             call derivatives(neq,i,x,y,yprime,u,ux,uxx,uxxx,&
                  uxxxx,uxxxxx,uxxxxxx,utau,rpar)
             soln(7*i) = u
          end if
       end do
    end do

    mesh(neq-7) = y(7*npts)
    mesh(neq-6) = y(7*npts)
    soln(neq-7) = y(7*npts-6)
    soln(neq-6) = y(neq)
  END SUBROUTINE solution_output

  SUBROUTINE residual_ic(neq,tau,y,yprime,delta,ires,rpar,ipar)
    ! set up the dummy problem for generating an equidistributed mesh for
    ! the initial conditions defined in def_ic
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: neq
    INTEGER, INTENT(INOUT) :: ires
    INTEGER, DIMENSION(*), INTENT(IN) :: ipar
    INTEGER :: i, j, npts
    REAL(kind=8), INTENT(IN) :: tau
    REAL(kind=8), DIMENSION(*), INTENT(IN) :: rpar
    REAL(kind=8), DIMENSION(neq), INTENT(IN) :: y, yprime
    REAL(kind=8), DIMENSION(neq), INTENT(INOUT) :: delta
    REAL(kind=8) :: u0
    REAL(kind=8) :: u, ux, uxx, uxxx, uxxxx, uxxxxx, uxxxxxx, utau, x, h
    REAL(kind=8), PARAMETER :: sone = 0.03376524289842475d0,&
         stwo = 0.16939530676686765d0,&
         sthree = 0.3806904069584014d0,&
         sfour = 0.6193095930415986d0,&
         sfive = 0.8306046932331324d0,&
         ssix = 0.9662347571015759d0
     REAL(kind=8), DIMENSION(6), PARAMETER :: points = &
         [sone, stwo, sthree, sfour, sfive, ssix]

    npts = ipar(4)

    ! put dummy equation in relevant res entries
    do i = 1,npts-1
       h = y(7*(i+1))-y(7*i)
       do j = 1,6

         x = y(7*i) + points(j)*h
         call derivatives(neq,i,j,y,yprime,u,ux,uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
         call def_ic(x,u0)
         delta(7*i+j-4+floor((dble(j-1))/3.0d0)) = utau-u0

       end do
    end do

    ! Fill in the two gaps on the left
    x = y(7)
    call derivatives(neq,1,7,y,yprime,u,ux,uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
    call def_ic(x,u0)
    delta(1)  = ux
    delta(2) = uxxx
    delta(3) = uxxxxx

    ! And the right
    x = y(7*npts)
    call derivatives(neq,npts-1,13,y,yprime,u,ux,uxx,uxxx,uxxxx,uxxxxx,uxxxxxx,utau,rpar)
    call def_ic(x,u0)
    delta(7*(npts-1)+4) = ux
    delta(7*(npts-1)+5) = uxxx
    delta(7*(npts-1)+6) = uxxxxx

    ! no time transformation in last entry
    delta(neq) = yprime(neq) - 1.0d0
  END SUBROUTINE residual_ic

END MODULE movmod


module arrCallback
contains
    elemental function cube( x )
        implicit none
        real :: cube
        real, intent(in) :: x
        cube = x * x * x
    end function cube
end module arrCallback


PROGRAM LA_DSYEVR_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_SYEVR
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, INFO, M, N
   CHARACTER(LEN = 1) :: UPLO
   REAL(WP) :: VL, VU
   INTEGER :: IL, IU
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:), W(:)
   REAL(WP), ALLOCATABLE :: Z(:,:)
   REAL(WP), ALLOCATABLE :: A(:,:)
   INTEGER, ALLOCATABLE :: ISUPPZ(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE(NOUT,*) 'DSYEVR ET_Example Program Results.'
   READ(NIN,*) ! SKIP HEADING IN DATA FILE
   READ(NIN,*) N
   ALLOCATE ( A(N,N), AA(N,N), W(N) )
   ALLOCATE (Z(N,N), ISUPPZ(N))
      DO I = 1, N
        READ(NIN,*) (AA(I, J), J = 1, N)
      ENDDO
   A=AA
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      ENDDO
!
   WRITE(NOUT,*) '---------------------------------------------------------'
   WRITE(NOUT,*)
   WRITE ( NOUT, * )'Details of LA_DSYEVR LAPACK Subroutine Results.'
   WRITE(NOUT,*)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SYEVR(A, W, INFO=INFO)'
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_SYEVR(A,W,INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_SYEVR(A,W)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_SYEVR:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, ABSTOL=0.01_WP)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   ABSTOL - the absolute error tolerance for the eigenvalues'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_SYEVR(A,W,  ABSTOL=0.01_WP)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_SYEVR:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, UPLO='L')"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   UPLO = 'L'
   CALL LA_SYEVR(A, W, UPLO='L')
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_SYEVR:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, UPLO='L')"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   UPLO = 'L'
   CALL LA_SYEVR(A,W,UPLO=UPLO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, INFO=INFO)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A   - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W   - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_SYEVR(A,W,INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_SYEVR:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, IL=2, IU=3)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   IL,IU - the indices of the smallest and largest'
   WRITE(NOUT,*) '           eigenvalues to be returned'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_SYEVR(A,W,IL=2,IU=3)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_SYEVR:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, IL=2)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   IL,IU - the indices of the smallest and largest'
   WRITE(NOUT,*) '           eigenvalues to be returned (IU = N is assumed).'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_SYEVR(A,W,IL=2)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_SYEVR:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, VL=0.1_WP, VU=4.0_WP, M=M)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   VL,VU - the lower and upper bounds of the interval'
   WRITE(NOUT,*) '           to be searched for eigenvalues'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   WRITE(NOUT,*) '   M - the total number of eigenvalues found'
   A=AA
   W=0
   CALL LA_SYEVR(A,W,VL=0.1_WP,VU=4.0_WP,M=M)
   WRITE(NOUT,*) 'The total number of eigenvalues found = ',M
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:M)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, VU=4.0_WP, M=M)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   VL,VU - the lower and upper bounds of the interval'
   WRITE(NOUT,*) '           to be searched for eigenvalues (VL = -infinity'
   WRITE(NOUT,*) '           is assumed)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   WRITE(NOUT,*) '   M - the total number of eigenvalues found'
   A=AA
   W=0
   CALL LA_SYEVR(A,W,VU=4.0_WP,M=M)
   WRITE(NOUT,*) 'The total number of eigenvalues found = ',M
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYEVR:'
   WRITE(NOUT,FMT) W(:M)
! STARTING THE ERROR TESTS:
! ERROR 1
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A(:,1:N-1), W, VL=0.1_WP, VU=4.0_WP, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A(:,1:N-1),W,VL=0.1_WP,VU=4.0_WP,M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 2
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W(1:N-1), VL=0.1_WP, VU=4.0_WP, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A,W(1:N-1),VL=0.1_WP,VU=4.0_WP,M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 3
   UPLO = 'T'; VL = 1; VU = 10
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, 'T', VL=VL, VU=VU, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, JOBZ='T', VL=VL, VU=VU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 4
   UPLO = 'U'; VL = 1; VU = 10
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, 'V', UPLO='U', VL=VL, VU=VU, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, 'V', UPLO='U', VL=VL, VU=VU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 4
   UPLO = 'U'; VL = 1; VU = 10
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, 'U', VL=VL, VU=VU, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, 'U', VL=VL, VU=VU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 5
   UPLO = 'U'; VL = 1; VU = 10
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, JOBZ='V', UPLO='U', VL=VL, VU=VU, M=M, ISUPPZ=ISUPPZ(1:N-1), INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, JOBZ='V', UPLO='U', VL=VL, VU=VU, M=M, ISUPPZ=ISUPPZ(1:N-1), INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 5
   UPLO = 'U'; VL = 1; VU = 10
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, 'U', VL=VL, VU=VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, 'U', VL=VL, VU=VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 6
   UPLO = 'U'; VL = 10; VU = 1
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, 'U', VL=VL, VU=VU, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, 'N', VL=VL, VU=VU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 7
   UPLO = 'U'; VL = 1; VU = 10; IL=1; IU=N
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, 'V', VL=VL, VU=VU, IL=IL, IU=IU, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, 'V', VL=VL, VU=VU, IL=IL, IU=IU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 8
   UPLO = 'U'; IL=-1; IU=N
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, 'N', IL=-1, IU=IU, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, 'N', IL=IL, IU=IU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 8
   UPLO = 'U'; IL=N; IU=N-1
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, '0', IL=N, IU=N-1, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, '0', IL=IL, IU=IU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 9
   UPLO = 'U'; IL=1; IU=N+1
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYEVR(A, W, UPLO='N', IL=1, IU=N+1, M=M, INFO=INFO)"
   A=AA; W=0
   CALL LA_SYEVR(A, W, UPLO='N', IL=IL, IU=IU, M=M, INFO=INFO)
   WRITE(NOUT,*) 'INFO = ', INFO

END PROGRAM LA_DSYEVR_ET_EXAMPLE


      PROGRAM LA_SGELS_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GELS
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, M, N, NRHS
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GELS Example Program Results'
      M=6; N = 4; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE( A(M,N), AA(M,N), B(M,NRHS), BB(M,NRHS) )

      OPEN(UNIT=21,FILE='gels.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,M
            READ(21,'(F2.0)') A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A :'
      DO I=1,M;
         WRITE(*,"(24(F9.5))") A(I,:);
      ENDDO

      AA=A

      OPEN(UNIT=22,FILE='gels.mb',STATUS='UNKNOWN')
      DO J=1,NRHS
         DO I=1,M
            READ(22,'(F3.0)') B(I,J)
         ENDDO
      ENDDO
      CLOSE(22)

      BB=B
      WRITE(*,*)'Matrix B :'
      DO I=1,M;
         WRITE(*,"(3(F9.5))") B(I,:);
      ENDDO

      WRITE(*,*) 'CALL LA_GELS( A, B )'
      CALL LA_GELS(  A, B )

      WRITE(*,*) 'The matrix B on exit :'
      DO I=1,M;
         WRITE(*,"(3(E13.6))") B(I,:);
      ENDDO
      WRITE(*,*)
      WRITE(*,*)' * EXAMPLE 2 * '

      WRITE(*,*)'Matrix A :'
      DO I=1,M;
         WRITE(*,"(24(F9.5))") AA(I,:);
      ENDDO

      WRITE(*,*)'Matrix B(:,1) :'
      WRITE(*,"(F9.5)") BB(:,1);

      WRITE(*,*) "CALL LA_GELS( A, B(:,1), 'T', INFO )"
      CALL LA_GELS( A, B(:,1), 'T', INFO )

      WRITE(*,*) 'The matrix B on exit :'
      WRITE(*,"(E13.6)") B(:,1);

      WRITE(*,*) 'INFO = ', INFO

      END PROGRAM LA_SGELS_EXAMPLE


      program circ

      implicit real*8 (a-h,o-z)

      pi  = 3.1415926535897932385d+0

      write(*,"('Enter Nx ==> ',$)")
      read(*,*) nx
      write(*,"('Enter Radius ==> ',$)")
      read(*,*) r

      dth = -2.0 * pi / float(nx-1)

      thmin = 2.0 * pi

      write(10,*) nx

      do i = 1, nx

         th = thmin + float(i-1) * dth

         x  = r * cos(th)
         y  = r * sin(th)

         write(10,10) x, y
 10      format(2(1pe20.13,1x))

      end do

      stop
      end


program smoothbump_generator
    implicit none

    integer(kind=4)                 :: npt_x, npt_y, npt_z, &
                                       nelem_quartic_x, nelem_quartic_y, nelem_quartic_z, &
                                       ierr, ncoords, i, j, k, n, &
                                       ipt_x, ipt_y, ipt_z
    real(kind=8), allocatable       :: coord(:,:,:,:)
    real(kind=8)                    :: x,y,z,alpha
    character(len=100)              :: buffer

    !
    ! Get grid dimensions from user-input arguments
    !
    print*, 'Enter number of elements in each coordinate direction: nelem_x, nelem_y, nelem_z'
    read(*,*) nelem_quartic_x, nelem_quartic_y, nelem_quartic_z

    !
    ! Define number of quartic elements in each direction
    !
    !nelem_quartic_x = 6
    !nelem_quartic_y = 2
    !nelem_quartic_z = 2

    !
    ! Compute number of points in each direction
    !
    npt_x = nelem_quartic_x*4 + 1
    npt_y = nelem_quartic_y*4 + 1
    npt_z = nelem_quartic_z*4 + 1

    !
    ! Allocate coordinate array
    !
    ncoords = 3
    allocate(coord(npt_x,npt_y,npt_z,ncoords),stat=ierr)
    if (ierr /= 0) stop "Allocation Error"

    !
    ! Create gridfile name
    !
    write(buffer,'( "smoothbump_",I0.0,"x",I0.0,"x",I0.0,".x")') nelem_quartic_x, nelem_quartic_y, nelem_quartic_z

    !
    ! Generate coordinates
    !
    do ipt_z = 1,npt_z

        do ipt_y = 1,npt_y

            do ipt_x = 1,npt_x

                x = -1.5_8 + real(ipt_x-1,kind=8)*(3._8 / real(npt_x-1,kind=8))
                alpha = 0.0625_8 * exp(-25._8 * (x**2._8))
                y = alpha + real(ipt_y-1,kind=8)*(0.8_8 - alpha)/real(npt_y-1,kind=8)
                z = 0._8 + real(ipt_z-1,kind=8)*(1._8 / real(npt_z-1,kind=8))

                coord(ipt_x,ipt_y,ipt_z,1) = x
                coord(ipt_x,ipt_y,ipt_z,2) = y
                coord(ipt_x,ipt_y,ipt_z,3) = z

            end do

        end do

    end do

    !
    ! Write coordinates to file
    !
    open(unit=7, file=trim(buffer), form='unformatted')

    write(7) 1
    write(7) npt_x, npt_y, npt_z
    write(7) (((( coord(i,j,k,n), i=1,npt_x), j=1,npt_y), k=1,npt_z), n=1,ncoords)

    close(7)

end program


*DECK DGAUS8
      SUBROUTINE DGAUS8 (FUN, A, B, ERR, ANS, IERR)
C***BEGIN PROLOGUE  DGAUS8
C***PURPOSE  Integrate a real function of one variable over a finite
C            interval using an adaptive 8-point Legendre-Gauss
C            algorithm.  Intended primarily for high accuracy
C            integration or integration of smooth functions.
C***LIBRARY   SLATEC
C***CATEGORY  H2A1A1
C***TYPE      DOUBLE PRECISION (GAUS8-S, DGAUS8-D)
C***KEYWORDS  ADAPTIVE QUADRATURE, AUTOMATIC INTEGRATOR,
C             GAUSS QUADRATURE, NUMERICAL INTEGRATION
C***AUTHOR  Jones, R. E., (SNLA)
C***DESCRIPTION
C
C     Abstract  *** a DOUBLE PRECISION routine ***
C        DGAUS8 integrates real functions of one variable over finite
C        intervals using an adaptive 8-point Legendre-Gauss algorithm.
C        DGAUS8 is intended primarily for high accuracy integration
C        or integration of smooth functions.
C
C        The maximum number of significant digits obtainable in ANS
C        is the smaller of 18 and the number of digits carried in
C        double precision arithmetic.
C
C     Description of Arguments
C
C        Input--* FUN, A, B, ERR are DOUBLE PRECISION *
C        FUN - name of external function to be integrated.  This name
C              must be in an EXTERNAL statement in the calling program.
C              FUN must be a DOUBLE PRECISION function of one DOUBLE
C              PRECISION argument.  The value of the argument to FUN
C              is the variable of integration which ranges from A to B.
C        A   - lower limit of integration
C        B   - upper limit of integration (may be less than A)
C        ERR - is a requested pseudorelative error tolerance.  Normally
C              pick a value of ABS(ERR) so that DTOL .LT. ABS(ERR) .LE.
C              1.0D-3 where DTOL is the larger of 1.0D-18 and the
C              double precision unit roundoff D1MACH(4).  ANS will
C              normally have no more error than ABS(ERR) times the
C              integral of the absolute value of FUN(X).  Usually,
C              smaller values of ERR yield more accuracy and require
C              more function evaluations.
C
C              A negative value for ERR causes an estimate of the
C              absolute error in ANS to be returned in ERR.  Note that
C              ERR must be a variable (not a constant) in this case.
C              Note also that the user must reset the value of ERR
C              before making any more calls that use the variable ERR.
C
C        Output--* ERR,ANS are double precision *
C        ERR - will be an estimate of the absolute error in ANS if the
C              input value of ERR was negative.  (ERR is unchanged if
C              the input value of ERR was non-negative.)  The estimated
C              error is solely for information to the user and should
C              not be used as a correction to the computed integral.
C        ANS - computed value of integral
C        IERR- a status code
C            --Normal codes
C               1 ANS most likely meets requested error tolerance,
C                 or A=B.
C              -1 A and B are too nearly equal to allow normal
C                 integration.  ANS is set to zero.
C            --Abnormal code
C               2 ANS probably does not meet requested error tolerance.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, I1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   810223  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  DGAUS8
      INTEGER IERR, K, KML, KMX, L, LMN, LMX, LR, MXL, NBITS,
     1 NIB, NLMN, NLMX
      INTEGER I1MACH
      DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,C,CE,EE,EF,
     1 EPS, ERR, EST, GL, GLR, GR, HH, SQ2, TOL, VL, VR, W1, W2, W3,
     2 W4, X1, X2, X3, X4, X, H
      DOUBLE PRECISION D1MACH, G8, FUN
      DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60)
      SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2,
     1 NLMN, KMX, KML
      DATA X1, X2, X3, X4/
     1     1.83434642495649805D-01,     5.25532409916328986D-01,
     2     7.96666477413626740D-01,     9.60289856497536232D-01/
      DATA W1, W2, W3, W4/
     1     3.62683783378361983D-01,     3.13706645877887287D-01,
     2     2.22381034453374471D-01,     1.01228536290376259D-01/
      DATA SQ2/1.41421356D0/
      DATA NLMN/1/,KMX/5000/,KML/6/
      G8(X,H)=H*((W1*(FUN(X-X1*H) + FUN(X+X1*H))
     1           +W2*(FUN(X-X2*H) + FUN(X+X2*H)))
     2          +(W3*(FUN(X-X3*H) + FUN(X+X3*H))
     3           +W4*(FUN(X-X4*H) + FUN(X+X4*H))))
C***FIRST EXECUTABLE STATEMENT  DGAUS8
C
C     Initialize
C
      K = I1MACH(14)
      ANIB = D1MACH(5)*K/0.30102000D0
      NBITS = ANIB
      NLMX = MIN(60,(NBITS*5)/8)
      ANS = 0.0D0
      IERR = 1
      CE = 0.0D0
      IF (A .EQ. B) GO TO 140
      LMX = NLMX
      LMN = NLMN
      IF (B .EQ. 0.0D0) GO TO 10
      IF (SIGN(1.0D0,B)*A .LE. 0.0D0) GO TO 10
      C = ABS(1.0D0-A/B)
      IF (C .GT. 0.1D0) GO TO 10
      IF (C .LE. 0.0D0) GO TO 140
      ANIB = 0.5D0 - LOG(C)/0.69314718D0
      NIB = ANIB
      LMX = MIN(NLMX,NBITS-NIB-7)
      IF (LMX .LT. 1) GO TO 130
      LMN = MIN(LMN,LMX)
   10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0
      IF (ERR .EQ. 0.0D0) TOL = SQRT(D1MACH(4))
      EPS = TOL
      HH(1) = (B-A)/4.0D0
      AA(1) = A
      LR(1) = 1
      L = 1
      EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L))
      K = 8
      AREA = ABS(EST)
      EF = 0.5D0
      MXL = 0
C
C     Compute refined estimates, estimate the error, etc.
C
   20 GL = G8(AA(L)+HH(L),HH(L))
      GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L))
      K = K + 16
      AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST))
C     IF (L .LT .LMN) GO TO 11
      GLR = GL + GR(L)
      EE = ABS(EST-GLR)*EF
      AE = MAX(EPS*AREA,TOL*ABS(GLR))
      IF (EE-AE) 40, 40, 50
   30 MXL = 1
   40 CE = CE + (EST-GLR)
      IF (LR(L)) 60, 60, 80
C
C     Consider the left half of this level
C
   50 IF (K .GT. KMX) LMX = KML
      IF (L .GE. LMX) GO TO 30
      L = L + 1
      EPS = EPS*0.5D0
      EF = EF/SQ2
      HH(L) = HH(L-1)*0.5D0
      LR(L) = -1
      AA(L) = AA(L-1)
      EST = GL
      GO TO 20
C
C     Proceed to right half at this level
C
   60 VL(L) = GLR
   70 EST = GR(L-1)
      LR(L) = 1
      AA(L) = AA(L) + 4.0D0*HH(L)
      GO TO 20
C
C     Return one level
C
   80 VR = GLR
   90 IF (L .LE. 1) GO TO 120
      L = L - 1
      EPS = EPS*2.0D0
      EF = EF*SQ2
      IF (LR(L)) 100, 100, 110
  100 VL(L) = VL(L+1) + VR
      GO TO 70
  110 VR = VL(L+1) + VR
      GO TO 90
C
C     Exit
C
  120 ANS = VR
      IF ((MXL.EQ.0) .OR. (ABS(CE).LE.2.0D0*TOL*AREA)) GO TO 140
      IERR = 2
      CALL XERMSG ('SLATEC', 'DGAUS8',
     +   'ANS is probably insufficiently accurate.', 3, 1)
      GO TO 140
  130 IERR = -1
      CALL XERMSG ('SLATEC', 'DGAUS8',
     +   'A and B are too nearly equal to allow normal integration. $$'
     +   // 'ANS is set to zero and IERR to -1.', 1, -1)
  140 IF (ERR .LT. 0.0D0) ERR = CE
      RETURN
      END


      SUBROUTINE MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V,
     $                   LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To partially diagonalize the bidiagonal matrix
C
C               |q(1) e(1)  0    ...       0      |
C               | 0   q(2) e(2)            .      |
C           J = | .                        .      |                  (1)
C               | .                  e(MIN(M,N)-1)|
C               | 0   ...        ...  q(MIN(M,N)) |
C
C     using QR or QL iterations in such a way that J is split into
C     unreduced bidiagonal submatrices whose singular values are either
C     all larger than a given bound or are all smaller than (or equal
C     to) this bound. The left- and right-hand Givens rotations
C     performed on J (corresponding to each QR or QL iteration step) may
C     be optionally accumulated in the arrays U and V.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBU    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix U the left-hand Givens rotations, as follows:
C             = 'N':  Do not form U;
C             = 'I':  U is initialized to the M-by-MIN(M,N) submatrix of
C                     the unit matrix and the left-hand Givens rotations
C                     are accumulated in U;
C             = 'U':  The given matrix U is updated by the left-hand
C                     Givens rotations used in the calculation.
C
C     JOBV    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix V the right-hand Givens rotations, as follows:
C             = 'N':  Do not form V;
C             = 'I':  V is initialized to the N-by-MIN(M,N) submatrix of
C                     the unit matrix and the right-hand Givens
C                     rotations are accumulated in V;
C             = 'U':  The given matrix V is updated by the right-hand
C                     Givens rotations used in the calculation.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows in matrix U.  M >= 0.
C
C     N       (input) INTEGER
C             The number of rows in matrix V.  N >= 0.
C
C     RANK    (input/output) INTEGER
C             On entry, if RANK < 0, then the rank of matrix J is
C             computed by the routine as the number of singular values
C             larger than THETA.
C             Otherwise, RANK must specify the rank of matrix J.
C             RANK <= MIN(M,N).
C             On exit, if RANK < 0 on entry, then RANK contains the
C             computed rank of J. That is, the number of singular
C             values of J larger than THETA.
C             Otherwise, the user-supplied value of RANK may be
C             changed by the routine on exit if the RANK-th and the
C             (RANK+1)-th singular values of J are considered to be
C             equal. See also the parameter TOL.
C
C     THETA   (input/output) DOUBLE PRECISION
C             On entry, if RANK < 0, then THETA must specify an upper
C             bound on the smallest singular values of J. THETA >= 0.0.
C             Otherwise, THETA must specify an initial estimate (t say)
C             for computing an upper bound such that precisely RANK
C             singular values are greater than this bound.
C             If THETA < 0.0, then t is computed by the routine.
C             On exit, if RANK >= 0 on entry, then THETA contains the
C             computed upper bound such that precisely RANK singular
C             values of J are greater than THETA + TOL.
C             Otherwise, THETA is unchanged.
C
C     Q       (input/output) DOUBLE PRECISION array, dimension
C             (MIN(M,N))
C             On entry, this array must contain the diagonal elements
C             q(1),q(2),...,q(MIN(M,N)) of the bidiagonal matrix J. That
C             is, Q(i) = J(i,i) for i = 1,2,...,MIN(M,N).
C             On exit, this array contains the leading diagonal of the
C             transformed bidiagonal matrix J.
C
C     E       (input/output) DOUBLE PRECISION array, dimension
C             (MIN(M,N)-1)
C             On entry, this array must contain the superdiagonal
C             elements e(1),e(2),...,e(MIN(M,N)-1) of the bidiagonal
C             matrix J. That is, E(k) = J(k,k+1) for k = 1,2,...,
C             MIN(M,N)-1.
C             On exit, this array contains the superdiagonal of the
C             transformed bidiagonal matrix J.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,*)
C             On entry, if JOBU = 'U', the leading M-by-MIN(M,N) part
C             of this array must contain a left transformation matrix
C             applied to the original matrix of the problem, and
C             on exit, the leading M-by-MIN(M,N) part of this array
C             contains the product of the input matrix U and the
C             left-hand Givens rotations.
C             On exit, if JOBU = 'I', then the leading M-by-MIN(M,N)
C             part of this array contains the matrix of accumulated
C             left-hand Givens rotations used.
C             If JOBU = 'N', the array U is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDU = 1 and
C             declare this array to be U(1,1) in the calling program).
C
C     LDU     INTEGER
C             The leading dimension of array U. If JOBU = 'U' or
C             JOBU = 'I', LDU >= MAX(1,M); if JOBU = 'N', LDU >= 1.
C
C     V       (input/output) DOUBLE PRECISION array, dimension (LDV,*)
C             On entry, if JOBV = 'U', the leading N-by-MIN(M,N) part
C             of this array must contain a right transformation matrix
C             applied to the original matrix of the problem, and
C             on exit, the leading N-by-MIN(M,N) part of this array
C             contains the product of the input matrix V and the
C             right-hand Givens rotations.
C             On exit, if JOBV = 'I', then the leading N-by-MIN(M,N)
C             part of this array contains the matrix of accumulated
C             right-hand Givens rotations used.
C             If JOBV = 'N', the array V is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDV = 1 and
C             declare this array to be V(1,1) in the calling program).
C
C     LDV     INTEGER
C             The leading dimension of array V. If JOBV = 'U' or
C             JOBV = 'I', LDV >= MAX(1,N); if JOBV = 'N', LDV >= 1.
C
C     INUL    (input/output) LOGICAL array, dimension (MIN(M,N))
C             On entry, the leading MIN(M,N) elements of this array must
C             be set to .FALSE. unless the i-th columns of U (if JOBU =
C             'U') and V (if JOBV = 'U') already contain a computed base
C             vector of the desired singular subspace of the original
C             matrix, in which case INUL(i) must be set to .TRUE.
C             for 1 <= i <= MIN(M,N).
C             On exit, the indices of the elements of this array with
C             value .TRUE. indicate the indices of the diagonal entries
C             of J which belong to those bidiagonal submatrices whose
C             singular values are all less than or equal to THETA.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             This parameter defines the multiplicity of singular values
C             by considering all singular values within an interval of
C             length TOL as coinciding. TOL is used in checking how many
C             singular values are less than or equal to THETA. Also in
C             computing an appropriate upper bound THETA by a bisection
C             method, TOL is used as a stopping criterion defining the
C             minimum (absolute) subinterval width. TOL is also taken
C             as an absolute tolerance for negligible elements in the
C             QR/QL iterations. If the user sets TOL to be less than or
C             equal to 0, then the tolerance is taken as
C             EPS * MAX(ABS(Q(i)), ABS(E(k))), where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH),
C             i = 1,2,...,MIN(M,N) and k = 1,2,...,MIN(M,N)-1.
C
C     RELTOL  DOUBLE PRECISION
C             This parameter specifies the minimum relative width of an
C             interval. When an interval is narrower than TOL, or than
C             RELTOL times the larger (in magnitude) endpoint, then it
C             is considered to be sufficiently small and bisection has
C             converged. If the user sets RELTOL to be less than
C             BASE * EPS, where BASE is machine radix and EPS is machine
C             precision (see LAPACK Library routine DLAMCH), then the
C             tolerance is taken as BASE * EPS.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,6*MIN(M,N)-5), if JOBU = 'I' or 'U', or
C                                               JOBV = 'I' or 'U';
C             LDWORK >= MAX(1,4*MIN(M,N)-3), if JOBU = 'N' and
C                                               JOBV = 'N'.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  if the rank of the bidiagonal matrix J (as specified
C                   by the user) has been lowered because a singular
C                   value of multiplicity larger than 1 was found.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value; this includes values like RANK > MIN(M,N), or
C                   THETA < 0.0 and RANK < 0;
C             = 1:  if the maximum number of QR/QL iteration steps
C                   (30*MIN(M,N)) has been exceeded.
C
C     METHOD
C
C     If the upper bound THETA is not specified by the user, then it is
C     computed by the routine (using a bisection method) such that
C     precisely (MIN(M,N) - RANK) singular values of J are less than or
C     equal to THETA + TOL.
C
C     The method used by the routine (see [1]) then proceeds as follows.
C
C     The unreduced bidiagonal submatrices of J(j), where J(j) is the
C     transformed bidiagonal matrix after the j-th iteration step, are
C     classified into the following three classes:
C
C     - C1 contains the bidiagonal submatrices with all singular values
C       > THETA,
C     - C2 contains the bidiagonal submatrices with all singular values
C       <= THETA and
C     - C3 contains the bidiagonal submatrices with singular values
C       > THETA and also singular values <= THETA.
C
C     If C3 is empty, then the partial diagonalization is complete, and
C     RANK is the sum of the dimensions of the bidiagonal submatrices of
C     C1.
C     Otherwise, QR or QL iterations are performed on each bidiagonal
C     submatrix of C3, until this bidiagonal submatrix has been split
C     into two bidiagonal submatrices. These two submatrices are then
C     classified and the iterations are restarted.
C     If the upper left diagonal element of the bidiagonal submatrix is
C     larger than its lower right diagonal element, then QR iterations
C     are performed, else QL iterations are used. The shift is taken as
C     the smallest diagonal element of the bidiagonal submatrix (in
C     magnitude) unless its value exceeds THETA, in which case it is
C     taken as zero.
C
C     REFERENCES
C
C     [1] Van Huffel, S., Vandewalle, J. and Haegemans, A.
C         An efficient and reliable algorithm for computing the
C         singular subspace of a matrix associated with its smallest
C         singular values.
C         J. Comput. and Appl. Math., 19, pp. 313-330, 1987.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     To avoid overflow, matrix J is scaled so that its largest element
C     is no greater than  overflow**(1/2) * underflow**(1/4) in absolute
C     value (and not much smaller than that, for maximal accuracy).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997.
C     Supersedes Release 2.0 routine MB04QD by S. Van Huffel, Katholieke
C     University Leuven, Belgium.
C
C     REVISIONS
C
C     July 10, 1997. V. Sima.
C     November 25, 1997. V. Sima: Setting INUL(K) = .TRUE. when handling
C                                 2-by-2 submatrix.
C
C     KEYWORDS
C
C     Bidiagonal matrix, orthogonal transformation, singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TEN, HNDRD
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0,
     $                    HNDRD = 100.0D0 )
      DOUBLE PRECISION  MEIGTH
      PARAMETER         ( MEIGTH = -0.125D0 )
      INTEGER           MAXITR
      PARAMETER         ( MAXITR = 30 )
C     .. Scalar Arguments ..
      CHARACTER         JOBU, JOBV
      INTEGER           INFO, IWARN, LDU, LDV, LDWORK, M, N, RANK
      DOUBLE PRECISION  RELTOL, THETA, TOL
C     .. Array Arguments ..
      LOGICAL           INUL(*)
      DOUBLE PRECISION  DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      LOGICAL           LJOBUA, LJOBUI, LJOBVA, LJOBVI, NOC12, QRIT
      INTEGER           I, I1, IASCL, INFO1, ITER, J, K, MAXIT, NUMEIG,
     $                  OLDI, OLDK, P, R
      DOUBLE PRECISION  COSL, COSR, EPS, PIVMIN, RMAX, RMIN, SAFEMN,
     $                  SHIFT, SIGMA, SIGMN, SIGMX, SINL, SINR, SMAX,
     $                  SMLNUM, THETAC, THRESH, TOLABS, TOLREL, X
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           MB03ND
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME, MB03ND
C     .. External Subroutines ..
      EXTERNAL          DLASET, DLASV2, DROT, DSCAL, MB02NY, MB03MD,
     $                  MB04YW, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      P = MIN( M, N )
      INFO = 0
      IWARN = 0
      LJOBUI = LSAME( JOBU, 'I' )
      LJOBVI = LSAME( JOBV, 'I' )
      LJOBUA = LJOBUI.OR.LSAME( JOBU, 'U' )
      LJOBVA = LJOBVI.OR.LSAME( JOBV, 'U' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBUA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LJOBVA .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( RANK.GT.P ) THEN
         INFO = -5
      ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( .NOT.LJOBUA .AND. LDU.LT.1 .OR.
     $              LJOBUA .AND. LDU.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( .NOT.LJOBVA .AND. LDV.LT.1 .OR.
     $              LJOBVA .AND. LDV.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( ( ( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 6*P-5 ) )
     $ .OR.(.NOT.( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 4*P-3 ) )
     $       ) THEN
         INFO = -17
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB04YD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( P.EQ.0 ) THEN
         IF ( RANK.GE.0 )
     $      THETA = ZERO
         RANK = 0
         RETURN
      END IF
C
C     Set tolerances and machine parameters.
C
      TOLABS = TOL
      TOLREL = RELTOL
      SMAX = ABS( Q(P) )
C
      DO 20 J = 1, P - 1
         SMAX = MAX( SMAX, ABS( Q(J) ), ABS( E(J) ) )
   20 CONTINUE
C
      SAFEMN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Epsilon' )
      IF ( TOLABS.LE.ZERO ) TOLABS = EPS*SMAX
      X = DLAMCH( 'Base' )*EPS
      IF ( TOLREL.LE.X ) TOLREL = X
      THRESH = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS
      SMLNUM = SAFEMN / EPS
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( ONE / RMIN, ONE / SQRT( SQRT( SAFEMN ) ) )
      THETAC = THETA
C
C     Scale the matrix to allowable range, if necessary, and set PIVMIN,
C     using the squares of Q and E (saved in DWORK).
C
      IASCL = 0
      IF( SMAX.GT.ZERO .AND. SMAX.LT.RMIN ) THEN
         IASCL = 1
         SIGMA = RMIN / SMAX
      ELSE IF( SMAX.GT.RMAX ) THEN
         IASCL = 1
         SIGMA = RMAX / SMAX
      END IF
      IF( IASCL.EQ.1 ) THEN
         CALL DSCAL( P, SIGMA, Q, 1 )
         CALL DSCAL( P-1, SIGMA, E, 1 )
         THETAC = SIGMA*THETA
         TOLABS = SIGMA*TOLABS
      END IF
C
      PIVMIN = Q(P)**2
      DWORK(P) = PIVMIN
C
      DO 40 J = 1, P - 1
         DWORK(J)   = Q(J)**2
         DWORK(P+J) = E(J)**2
         PIVMIN = MAX( PIVMIN, DWORK(J), DWORK(P+J) )
   40 CONTINUE
C
      PIVMIN = MAX( PIVMIN*SAFEMN, SAFEMN )
C
C     Initialize U and/or V to the identity matrix, if needed.
C
      IF ( LJOBUI )
     $   CALL DLASET( 'Full', M, P, ZERO, ONE, U, LDU )
      IF ( LJOBVI )
     $   CALL DLASET( 'Full', N, P, ZERO, ONE, V, LDV )
C
C     Estimate THETA (if not fixed by the user), and set R.
C
      IF ( RANK.GE.0 ) THEN
         J = P - RANK
         CALL MB03MD( P, J, THETAC, Q, E, DWORK(1), DWORK(P+1), PIVMIN,
     $                TOLABS, TOLREL, IWARN, INFO1 )
         THETA = THETAC
         IF ( IASCL.EQ.1 ) THETA = THETA / SIGMA
         IF ( J.LE.0 )
     $      RETURN
         R = P - J
      ELSE
         R = P - MB03ND( P, THETAC, DWORK, DWORK(P+1), PIVMIN, INFO1 )
      END IF
C
      RANK = P
C
      DO 60 I = 1, P
         IF ( INUL(I) ) RANK = RANK - 1
   60 CONTINUE
C
C     From now on K is the smallest known index such that the elements
C     of the bidiagonal matrix J with indices larger than K belong to C1
C     or C2.
C     RANK = P - SUM(dimensions of known bidiagonal matrices of C2).
C
      K = P
      OLDI = -1
      OLDK = -1
      ITER = 0
      MAXIT = MAXITR*P
C     WHILE ( C3 NOT EMPTY ) DO
   80 IF ( RANK.GT.R .AND. K.GT.0 ) THEN
C        WHILE ( K.GT.0 .AND. INUL(K) ) DO
C
C        Search for the rightmost index of a bidiagonal submatrix,
C        not yet classified.
C
  100    IF ( K.GT.0 ) THEN
            IF ( INUL(K) ) THEN
               K = K - 1
               GO TO 100
            END IF
         END IF
C        END WHILE 100
C
         IF ( K.EQ.0 )
     $      RETURN
C
         NOC12 = .TRUE.
C        WHILE ((ITER < MAXIT).AND.(No bidiagonal matrix of C1 or
C                C2 found)) DO
  120    IF ( ( ITER.LT.MAXIT ) .AND. NOC12 ) THEN
C
C           Search for negligible Q(I) or E(I-1) (for I > 1) and find
C           the shift.
C
            I = K
            X = ABS( Q(I) )
            SHIFT = X
C           WHILE ABS( Q(I) ) > TOLABS .AND. ABS( E(I-1) ) > TOLABS ) DO
  140       IF ( I.GT.1 ) THEN
               IF ( ( X.GT.TOLABS ).AND.( ABS( E(I-1) ).GT.TOLABS ) )
     $               THEN
                  I = I - 1
                  X = ABS( Q(I) )
                  IF ( X.LT.SHIFT ) SHIFT = X
                  GO TO 140
               END IF
            END IF
C           END WHILE 140
C
C           Classify the bidiagonal submatrix (of order J) found.
C
            J = K - I + 1
            IF ( ( X.LE.TOLABS ) .OR. ( K.EQ.I ) ) THEN
               NOC12 = .FALSE.
            ELSE
               NUMEIG = MB03ND( J, THETAC, DWORK(I), DWORK(P+I), PIVMIN,
     $                          INFO1 )
               IF ( NUMEIG.GE.J .OR. NUMEIG.LE.0 ) NOC12 = .FALSE.
            END IF
            IF ( NOC12 ) THEN
               IF ( J.EQ.2 ) THEN
C
C                 Handle separately the 2-by-2 submatrix.
C
                  CALL DLASV2( Q(I), E(I), Q(K), SIGMN, SIGMX, SINR,
     $                         COSR, SINL, COSL )
                  Q(I) = SIGMX
                  Q(K) = SIGMN
                  E(I) = ZERO
                  RANK = RANK - 1
                  INUL(K) = .TRUE.
                  NOC12 = .FALSE.
C
C                 Update U and/or V, if needed.
C
                  IF( LJOBUA )
     $               CALL DROT( M, U(1,I), 1, U(1,K), 1, COSL, SINL )
                  IF( LJOBVA )
     $               CALL DROT( N, V(1,I), 1, V(1,K), 1, COSR, SINR )
               ELSE
C
C                 If working on new submatrix, choose QR or
C                 QL iteration.
C
                  IF ( I.NE.OLDI .OR. K.NE.OLDK )
     $               QRIT = ABS( Q(I) ).GE.ABS( Q(K) )
                  OLDI = I
                  IF ( QRIT ) THEN
                     IF ( ABS( E(K-1) ).LE.THRESH*ABS( Q(K) ) )
     $                         E(K-1) = ZERO
                  ELSE
                     IF ( ABS( E(I) ).LE.THRESH*ABS( Q(I) ) )
     $                         E(I) = ZERO
                  END IF
C
                  CALL MB04YW( QRIT, LJOBUA, LJOBVA, M, N, I, K, SHIFT,
     $                         Q, E, U, LDU, V, LDV, DWORK(2*P) )
C
                  IF ( QRIT ) THEN
                     IF ( ABS( E(K-1) ).LE.TOLABS ) E(K-1) = ZERO
                  ELSE
                     IF ( ABS( E(I) ).LE.TOLABS ) E(I) = ZERO
                  END IF
                  DWORK(K) = Q(K)**2
C
                  DO 160 I1 = I, K - 1
                     DWORK(I1)   = Q(I1)**2
                     DWORK(P+I1) = E(I1)**2
  160             CONTINUE
C
                  ITER = ITER + 1
               END IF
            END IF
            GO TO 120
         END IF
C        END WHILE 120
C
         IF ( ITER.GE.MAXIT ) THEN
            INFO = 1
            GO TO 200
         END IF
C
         IF ( X.LE.TOLABS ) THEN
C
C           Split at negligible diagonal element ABS( Q(I) ) <= TOLABS.
C
            CALL MB02NY( LJOBUA, LJOBVA, M, N, I, K, Q, E, U, LDU, V,
     $                   LDV, DWORK(2*P) )
            INUL(I) = .TRUE.
            RANK = RANK - 1
         ELSE
C
C           A negligible superdiagonal element ABS( E(I-1) ) <= TOL
C           has been found, the corresponding bidiagonal submatrix
C           belongs to C1 or C2. Treat this bidiagonal submatrix.
C
            IF ( J.GE.2 ) THEN
               IF ( NUMEIG.EQ.J ) THEN
C
                  DO 180 I1 = I, K
                     INUL(I1) = .TRUE.
  180             CONTINUE
C
                  RANK = RANK - J
                  K = K - J
               ELSE
                  K = I - 1
               END IF
            ELSE
               IF ( X.LE.( THETAC + TOLABS ) ) THEN
                  INUL(I) = .TRUE.
                  RANK = RANK - 1
               END IF
               K = K - 1
            END IF
            OLDK = K
         END IF
         GO TO 80
      END IF
C     END WHILE 80
C
C     If matrix was scaled, then rescale Q and E appropriately.
C
  200 CONTINUE
      IF( IASCL.EQ.1 ) THEN
         CALL DSCAL( P,   ONE / SIGMA, Q, 1 )
         CALL DSCAL( P-1, ONE / SIGMA, E, 1 )
      END IF
C
      RETURN
C *** Last line of MB04YD ***
      END