! { dg-do  run }
program main
  implicit none
  integer :: i,n1, n2, n3
  integer, parameter :: a(3) = [1,2,3]
  integer, parameter :: b1(3) = eoshift(a,0)
  integer, parameter :: b2(3) = eoshift(a,1)
  integer, parameter :: b3(3) = eoshift(a,-2)
  integer, parameter :: b4(3) = eoshift(a,4,boundary=42)
  integer, parameter :: c(3,3) = reshape([(i,i=1,3*3)],shape(c))
  integer, parameter :: b5(3,3) = eoshift(c,shift=1,dim=1,boundary=33)
  integer, parameter :: b6(3,3) = eoshift(c,shift=2,dim=1)
  integer, parameter :: b7(3,3) = eoshift(c,shift=-1,dim=2)
  integer, parameter :: b8(3,3) = eoshift(c,shift=-1,dim=2,boundary=[-1,-2,-3])
  integer, parameter :: b9(3,3) = eoshift(c,shift=[-1,-1,-1])
  integer, parameter :: b10(3,3) = eoshift(c,shift=[-1,0,1]);
  integer, parameter :: b11(3,3) = eoshift(c,dim=2,shift=[-2,-1,1],boundary=42);
  integer, parameter :: b12(3,3) = eoshift(c,dim=1,shift=[-1,-2,0],boundary=[-3,-7,-9])
  real, parameter :: r(3,4,5) = reshape([(1.0*i**2,i=1,3*4*5)],shape(r))
  real, parameter :: q1(3,4,5) = eoshift(r,shift=1,dim=3)
  integer, parameter :: sh1(3,4) = reshape([-1,-2,0,3,2,5,6,-6,3,1,-1,-5],shape(sh1))
  real, parameter :: bnd1(3,4) = reshape([-1.,-2.,-3.,-4.,-5.,-6.,-7.,-8.,-9.,-10.,-11.,-12.],shape(bnd1))
  real, parameter :: q2(3,4,5) = eoshift(r,dim=3,shift=sh1)
  real, parameter :: q3(3,4,5) = eoshift(r,dim=3,shift=sh1,boundary=bnd1)
  complex(kind=8), parameter :: s(3,3) = reshape([(cmplx(i*i-5*i,-i+4,kind=8),i=1,9)],shape(s))
  complex(kind=8), parameter :: t(3,3) = eoshift(s,shift=4)
  character(len=3), parameter :: e(2,3,4) = reshape([(repeat(achar(i),3),i=iachar('a'),iachar('a')+2*3*4-1)], &
       shape(e))
  character(len=3) :: e2(2,3,4)
  character(len=3), parameter :: f1(2,3,4) = eoshift(e,1)
  character(len=3), parameter :: bnd2(2,4) = reshape([(repeat(achar(i),3),i=iachar('A'),iachar('A')+2*4-1)], &
       shape(bnd2))
  character(len=3), parameter :: f2(2,3,4) = eoshift(e,dim=2,shift=-1,boundary=bnd2);
  integer, parameter :: sh2(2,3) = reshape([1, -2, 0, 1, 2, -1, 2, 0],shape(sh2))
  character(len=3), parameter :: f3(2,3,4) = eoshift(e,dim=3,shift=sh2)
  integer, parameter :: empty(1:0) =[integer ::]
  integer, parameter :: empty2(1:0) = eoshift(empty,1)

  n1 = 1
  n2 = 2
  n3 = 3

  if (any(b1 /= a)) STOP 1
  if (any(b2 /= [2, 3, 0])) STOP 2
  if (any(b3 /= [0, 0, 1])) STOP 3
  if (any(b4 /= 42)) STOP 4
  if (any(eoshift(c,shift=1,dim=n1,boundary=33) /= b5)) STOP 5
  if (any(eoshift(c,shift=2,dim=1) /= b6)) STOP 6
  if (any(eoshift(c,shift=-1,dim=2) /= b7)) STOP 7
  if (any(eoshift(c,shift=-1,dim=n2,boundary=[-1,-2,-3]) /= b8)) STOP 8
  if (any(eoshift(c,shift=-1) /= b9)) STOP 9
  if (any(eoshift(r,shift=1,dim=n3) /= q1)) STOP 10
  if (any(b10 /= reshape([ 0, 1, 2, 4, 5, 6, 8, 9, 0],shape(b10)))) STOP 11
  if (any(b11 /= reshape([42, 42,  6, 42,  2,  9,  1,  5, 42],shape(b11)))) STOP 12
  if (any(b12 /= reshape([ -3,  1,  2, -7, -7,  4,  7,  8,  9],shape(b11)))) STOP 13
  if (any(q1 /= reshape([169.,196.,225.,256.,289.,324.,361.,400.,441.,484.,529.,576.,625.,&
          676.,729.,784.,841.,900.,961.,1024.,1089.,1156.,1225.,1296.,1369.,1444.,1521.,&
          1600.,1681.,1764.,1849.,1936.,2025.,2116.,2209.,2304.,2401.,2500.,2601.,2704.,&
          2809.,2916.,3025.,3136.,3249.,3364.,3481.,3600.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.],&
          shape(q1)))) STOP 14
  if (any(q2 /= reshape([0.,0.,9.,1600.,841.,0.,0.,0.,2025.,484.,0.,0.,1.,0.,225.,2704.,&
          1681.,0.,0.,0.,3249.,1156.,121.,0.,169.,4.,729.,0.,2809.,0.,0.,0.,0.,2116.,&
          529.,0.,625.,196.,1521.,0.,0.,0.,0.,0.,0.,3364.,1225.,0.,1369.,676.,2601.,&
          0.,0.,0.,0.,0.,0.,0.,2209.,0.],shape(q2)))) STOP 15
  if (any(q3 /= reshape([-1.,-2.,9.,1600.,841.,-6.,-7.,-8.,2025.,484.,-11.,-12.,1.,&
          -2.,225.,2704.,1681.,-6.,-7.,-8.,3249.,1156.,121.,-12.,169.,4.,729.,-4.,&
          2809.,-6.,-7.,-8.,-9.,2116.,529.,-12.,625.,196.,1521.,-4.,-5.,-6.,-7.,-8.,&
          -9.,3364.,1225.,-12.,1369.,676.,2601.,-4.,-5.,-6.,-7.,-8.,-9.,-10.,2209.,-12.],&
          shape(q3)))) STOP 16
  if (any(f1 /= reshape(["bbb","   ","ddd","   ","fff","   ","hhh","   ","jjj","   ","lll","   ",&
       "nnn","   ","ppp","   ","rrr","   ","ttt","   ","vvv","   ","xxx","   "], &
       shape(f1)))) STOP 17
  if (any(f2 /= reshape(["AAA","BBB","aaa","bbb","ccc","ddd","CCC","DDD","ggg","hhh","iii","jjj",&
       "EEE","FFF","mmm","nnn","ooo","ppp","GGG","HHH","sss","ttt","uuu","vvv"],shape(f2)))) STOP 18

  e2 = e
  if (any (f2 /= eoshift(e2,dim=2,shift=-1,boundary=bnd2))) STOP 19
  if (any (f3 /= reshape (["ggg","   ","ccc","jjj","qqq","   ","mmm","   ","iii","ppp",&
       "www","fff","sss","bbb","ooo","vvv","   ","lll","   ","hhh","uuu",&
       "   ","   ","rrr"], shape(f3)))) STOP 20
  if (size(empty) /=0) STOP 21
  if (any(t /= (0.0_8, 0.0_8))) STOP 22
end program main


PROGRAM NavierStokes

    ! Para usar o openmp
    USE OMP_LIB
    USE VariaveisGerais
    USE Inicializacoes
    USE MG_GS_U
    USE MG_GS_V

    IMPLICIT NONE

    INTEGER :: t, ite_ext, ite_s, ite_uvp, flag_invalido, ite_ud
    INTEGER :: thread, thread_unit
    CHARACTER(len=100) :: thread_str, ite_sol_str, ite_ext_str, Nx_str, threads_str

    ! Variaveis para benchmark
    ! Tempos inicial e final de processamento
    DOUBLE PRECISION :: t1, t2, tt1, tt2, ttt1, ttt2
    DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: normas_L2_mg_u, normas_L2_mg_v, normas_L2_mg_p

    INTEGER :: ciclo, level, Levels

    11 FORMAT( 1X, "Multigrid U => Ciclo:", 1X, I3, 3X, "Parada:", 1X, 1PE16.10, 3X, "Norma L2:", 1X,  1PE16.10, 3X, "(Norma L2)**(1/ciclo)", 1X, 1PE16.10)
    12 FORMAT( 1X, "Multigrid V => Ciclo:", 1X, I3, 3X, "Parada:", 1X, 1PE16.10, 3X, "Norma L2:", 1X,  1PE16.10, 3X, "(Norma L2)**(1/ciclo)", 1X, 1PE16.10)

    CALL inicializa_variaveis

    Levels = LOG( DBLE(Nx))/LOG( DBLE(2) ) - 1
    flag_invalido = 0
    ite_ud = 6

    WRITE(ite_ext_str, "(I12)") iteracoes_externas
    WRITE(ite_sol_str, "(I12)") ite_sol
    WRITE(Nx_str, "(I12)") Nx
    WRITE(threads_str, "(I12)") Threads

    ALLOCATE(normas_L2_u(iteracoes_externas), &
             normas_L2_v(iteracoes_externas), &
             normas_L2_p(iteracoes_externas))

    ALLOCATE(normas_L2_mg_u(ite_sol), &
             normas_L2_mg_v(ite_sol), &
             normas_L2_mg_p(ite_sol))

    ! Calculando a integral de p para garantir unicidade da solucao da pressao
    !CALL p % calcula_integral_da_pressao(1)

    ! Obtendo o tempo inicial
    t1 = OMP_GET_WTIME()

    ! Forcando o sistema a utilizar o numero de threads fornecido pelo usuario
    CALL OMP_SET_NUM_THREADS(Threads)

    !------------PARALELISMO COMECA AQUI---------------------------------------
    !$OMP PARALLEL PRIVATE(thread, ite_ext, t, thread_unit, thread_str, tt1, tt2, ttt1, ttt2, ite_s, ciclo, level)

       ! Descobrindo o numero id do processador (0-threads-1)
       thread = OMP_get_thread_num() + 1 ! +1 para que a id do processador 0 seja 1

       !WRITE(thread_str, "(I12)") thread
       !thread_unit = thread * 100
       !OPEN(UNIT=thread_unit, FILE="./resultados/log_thread_" // TRIM(ADJUSTL(thread_str)) // ".txt", STATUS='REPLACE', ACTION='WRITE' )

       DO ite_ext = 1, iteracoes_externas

           !WRITE(thread_unit,*) "##############################################################"
           !WRITE(thread_unit,*) "Iteracao Externa:", ite_ext
           !WRITE(thread_unit,*) "##############################################################"

           ttt1 = OMP_GET_WTIME()

           DO t = threads_if( thread, 1), threads_if( thread, 2)

               ! Tempo de processamento dos termos fontes
               tt1 = OMP_GET_WTIME()

               ! Calculando os termos fontes
               IF ( t .eq. 1 ) THEN
                   CALL u % calcula_termo_fonte(1, 1, v % v, p % p, p % q)
                   CALL v % calcula_termo_fonte(1, 1, u % u, p % p, p % q)
               ELSE
                   CALL u % calcula_termo_fonte(t, t-1, v % v, p % p, p % q)
                   CALL v % calcula_termo_fonte(t, t-1, u % u, p % p, p % q)
               END IF

               ! Tempo de processamento dos termos fontes
               tt2 = OMP_GET_WTIME()

               !WRITE(thread_unit,*) "t =", t, "Fontes UV:", tt2 - tt1

           END DO
           !$OMP BARRIER

           !---------------------- MULTIGRID U ----------------------
           DO t = threads_if( thread, 1), threads_if( thread, 2)
               CALL atualiza_uo( t, u % u(:, t) )
           END DO
           !$OMP BARRIER

           DO ciclo = 1, ite_sol
               DO t = threads_if( thread, 1), threads_if( thread, 2)
                   CALL atualiza_bp_u(t, u % u_bp(:, t))
               END DO
               !$OMP BARRIER

               DO t = threads_if( thread, 1), threads_if( thread, 2)
                   CALL calcula_residuo_u(t, 1)
               END DO
               !$OMP BARRIER

               DO t = threads_if( thread, 1), threads_if( thread, 2)
                   CALL calcula_norma_L2_u(ciclo, t+1)
               END DO
               !$OMP BARRIER

               !!$OMP SINGLE
               !! Somando o valor da norma L2
               !!CALL soma_norma_L2_u(ciclo, normas_L2_mg_u)
               !!WRITE(*, 11) ciclo, normas_L2_mg_u(ciclo)/normas_L2_mg_u(1), normas_L2_mg_u(ciclo), (normas_L2_mg_u(ciclo)/normas_L2_mg_u(1))**(1.0d0/ciclo)
               !!$OMP END SINGLE

               DO level = 1, Levels - 1

                   ! So atualiza bp = residuo, ou seja, apenas para level > 1 (o primeiro e bp = fonte)
                   IF ( level > 1 ) THEN

                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           CALL atualiza_bp_u2(t, level)
                       END DO
                       !$OMP BARRIER
                   END IF

                   ! Gauss-Seidel RB aqui
                   DO ite_s = 1, ite_ud
                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os reds do dominio
                           CALL GS_RB_U(t, level, 1)

                       END DO
                       !$OMP BARRIER

                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os blacks do dominio
                           CALL GS_RB_U(t, level, -1)
                       END DO
                       !$OMP BARRIER
                   END DO

                   DO t = threads_if( thread, 1), threads_if( thread, 2)
                       CALL calcula_residuo_u(t, level)
                   END DO
                   !$OMP BARRIER
                   DO t = threads_if( thread, 1), threads_if( thread, 2)
                       CALL restricao_u ( t+1, level )
                   END DO
                   !$OMP BARRIER
               END DO

               ! Falta conta no ultimo level

               DO level = Levels, 2, -1

                   DO t = threads_if( thread, 1), threads_if( thread, 2)
                       CALL prolongacao_u ( t+1, level )
                   END DO
                   !$OMP BARRIER

                   ! Limpando o vetor para evitar erros no proximo ciclo
                   !DO t = threads_if( thread, 1), threads_if( thread, 2)
                   !   CALL limpa_u( t, level )
                   !END DO
                   !$OMP BARRIER

                   ! Gauss-Seidel RB aqui
                   DO ite_s = 1, ite_ud
                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os reds do dominio
                           CALL GS_RB_U(t, level-1, 1)

                       END DO
                       !$OMP BARRIER

                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os blacks do dominio
                           CALL GS_RB_U(t, level-1, -1)
                       END DO
                       !$OMP BARRIER
                   END DO

               END DO

           END DO

           DO t = threads_if( thread, 1), threads_if( thread, 2)
               CALL atualiza_u2( t+1, u % u(:, t+1) )
           END DO
           !$OMP BARRIER
           !---------------------- MULTIGRID U ----------------------

           !!$OMP SINGLE
           !WRITE(*,*) ""
           !!$OMP END SINGLE

           !---------------------- MULTIGRID V ----------------------
           DO t = threads_if( thread, 1), threads_if( thread, 2)
               CALL atualiza_vo( t, v % v(:, t) )
           END DO
           !$OMP BARRIER

           DO ciclo = 1, ite_sol
               DO t = threads_if( thread, 1), threads_if( thread, 2)
                   CALL atualiza_bp_v(t, v % v_bp(:, t))
               END DO
               !$OMP BARRIER

               DO t = threads_if( thread, 1), threads_if( thread, 2)
                   CALL calcula_residuo_v(t, 1)
               END DO
               !$OMP BARRIER

               DO t = threads_if( thread, 1), threads_if( thread, 2)
                   CALL calcula_norma_L2_v(ciclo, t+1)
               END DO
               !$OMP BARRIER

               !!$OMP SINGLE
               !! Somando o valor da norma L2
               !!CALL soma_norma_L2_v(ciclo, normas_L2_mg_v)
               !!WRITE(*, 12) ciclo, normas_L2_mg_v(ciclo)/normas_L2_mg_v(1), normas_L2_mg_v(ciclo), (normas_L2_mg_v(ciclo)/normas_L2_mg_v(1))**(1.0d0/ciclo)
               !!$OMP END SINGLE

               DO level = 1, Levels - 1

                   ! So atualiza bp = residuo, ou seja, apenas para level > 1 (o primeiro e bp = fonte)
                   IF ( level > 1 ) THEN

                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           CALL atualiza_bp_v2(t, level)
                       END DO
                       !$OMP BARRIER
                   END IF

                   ! Gauss-Seidel RB aqui
                   DO ite_s = 1, ite_ud
                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os reds do dominio
                           CALL GS_RB_V(t, level, 1)

                       END DO
                       !$OMP BARRIER

                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os blacks do dominio
                           CALL GS_RB_V(t, level, -1)
                       END DO
                       !$OMP BARRIER
                   END DO

                   DO t = threads_if( thread, 1), threads_if( thread, 2)
                       CALL calcula_residuo_v(t, level)
                   END DO
                   !$OMP BARRIER
                   DO t = threads_if( thread, 1), threads_if( thread, 2)
                       CALL restricao_v ( t+1, level )
                   END DO
                   !$OMP BARRIER
               END DO

               ! Falta conta no ultimo level

               DO level = Levels, 2, -1

                   DO t = threads_if( thread, 1), threads_if( thread, 2)
                       CALL prolongacao_v ( t+1, level )
                   END DO
                   !$OMP BARRIER

                   ! Limpando o vetor para evitar erros no proximo ciclo
                   !DO t = threads_if( thread, 1), threads_if( thread, 2)
                   !   CALL limpa_u( t, level )
                   !END DO
                   !$OMP BARRIER

                   ! Gauss-Seidel RB aqui
                   DO ite_s = 1, ite_ud
                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os reds do dominio
                           CALL GS_RB_V(t, level-1, 1)

                       END DO
                       !$OMP BARRIER

                       DO t = threads_if( thread, 1), threads_if( thread, 2)
                           ! Resolvendo todos os blacks do dominio
                           CALL GS_RB_V(t, level-1, -1)
                       END DO
                       !$OMP BARRIER
                   END DO

               END DO

           END DO

           DO t = threads_if( thread, 1), threads_if( thread, 2)
               CALL atualiza_v2( t+1, v % v(:, t+1) )
           END DO
           !$OMP BARRIER
           !---------------------- MULTIGRID V ----------------------

           !write(*,*)  u % u(1:7, 2)
           !write(*,*)  u % u(8:14, 2)
           !write(*,*)  u % u(15:21, 2)
           !write(*,*)  u % u(22:28, 2)
           !write(*,*)  u % u(29:35, 2)
           !write(*,*)  u % u(36:42, 2)
           !write(*,*)  u % u(43:49, 2)
           !write(*,*)  u % u(50:56, 2)

           !write(*,*)  v % v(1:8, 2)
           !write(*,*)  v % v(9:16, 2)
           !write(*,*)  v % v(17:24, 2)
           !write(*,*)  v % v(25:32, 2)
           !write(*,*)  v % v(33:40, 2)
           !write(*,*)  v % v(41:48, 2)
           !write(*,*)  v % v(49:56, 2)

           !call exit()

           ! Calcula o Residuo
           !DO t = threads_if( thread, 1), threads_if( thread, 2)
           !    ! Calculando todos os residuos do dominio
           !    CALL u % calcula_residuo(t)
           !    CALL v % calcula_residuo(t)
           !    CALL u % calcula_norma_L2(t)
           !    CALL v % calcula_norma_L2(t)
           !END DO
           !$OMP BARRIER

           !$OMP SINGLE
           ! Somando o valor da norma L2
           !normas_L2_u(ite_ext) = DSQRT(SUM(u % normas_L2(:)))
           !normas_L2_v(ite_ext) = DSQRT(SUM(v % normas_L2(:)))
           !WRITE(*,*) "Parada U:", normas_L2_u(ite_ext)/normas_L2_u(1), "Norma L2 de U:", normas_L2_u(ite_ext), ite_ext, MAXVAL(ABS(u % u(:, :) - u % u_ex(:, :)))
           !WRITE(*,*) "Parada V:", normas_L2_v(ite_ext)/normas_L2_v(1), "Norma L2 de V:", normas_L2_v(ite_ext), ite_ext, MAXVAL(ABS(v % v(:, :) - v % v_ex(:, :)))
           normas_L2_u(ite_ext) = maxval(abs(u % u(:, Tn) - u % u_ref(:) ))
           normas_L2_v(ite_ext) = maxval(abs(v % v(:, Tn) - v % v_ref(:) ))
           u % u_ref(:) = u % u(:, Tn)
           v % v_ref(:) = v % v(:, Tn)

           !$OMP END SINGLE

           tt2 = OMP_GET_WTIME()
           !WRITE(thread_unit, *) "Solver UV:", tt2 - tt1

           DO t = threads_if( thread, 1), threads_if( thread, 2)

               tt1 = OMP_GET_WTIME()
               CALL p % calcula_termo_fonte(t+1, t, u % u, v % v)
               tt2 = OMP_GET_WTIME()
               !WRITE(thread_unit,*) "t = ", t, "Fontes P:", tt2 - tt1

               tt1 = OMP_GET_WTIME()
               !CALL p % single_grid(t+1, ite_sol*50)
               CALL p % multi_grid(t+1, ite_sol)
               tt2 = OMP_GET_WTIME()
               !WRITE(thread_unit,*) "t = ", t, "Solver P:", tt2 - tt1

               !CALL p % calcula_residuo(t)
               !CALL p % calcula_norma_L2(t)
               !write(*,*) DSQRT((p % normas_L2( t )))

               CALL p % corrige_pressao_com_a_integral(t+1)

           END DO
           !$OMP BARRIER

           !write(*,*)  p % p_bp(1:8, 2)
           !write(*,*)  p % p_bp(9:16, 2)
           !write(*,*)  p % p_bp(17:24, 2)
           !write(*,*)  p % p_bp(25:32, 2)
           !write(*,*)  p % p_bp(33:40, 2)
           !write(*,*)  p % p_bp(41:48, 2)
           !write(*,*)  p % p_bp(49:56, 2)
           !write(*,*)  p % p_bp(57:64, 2)
           !call exit()

           !write(*,*)  p % q(1:8, 2)
           !write(*,*)  p % q(9:16, 2)
           !write(*,*)  p % q(17:24, 2)
           !write(*,*)  p % q(25:32, 2)
           !write(*,*)  p % q(33:40, 2)
           !write(*,*)  p % q(41:48, 2)
           !write(*,*)  p % q(49:56, 2)
           !write(*,*)  p % q(57:64, 2)
           !call exit()

           tt1 = OMP_GET_WTIME()
           DO t = 1, Tn-1
               CALL p % atualiza_pressao(t+1, t, thread)
           END DO
           tt2 = OMP_GET_WTIME()
           !WRITE(thread_unit,*) "Atualizacao de P:", tt2 - tt1

           !write(*,*)  p % p(1:8, 2)
           !write(*,*)  p % p(9:16, 2)
           !write(*,*)  p % p(17:24, 2)
           !write(*,*)  p % p(25:32, 2)
           !write(*,*)  p % p(33:40, 2)
           !write(*,*)  p % p(41:48, 2)
           !write(*,*)  p % p(49:56, 2)
           !write(*,*)  p % p(57:64, 2)
           !call exit()

           !$OMP BARRIER

           !$OMP SINGLE
           ! Somando o valor da norma L2
           !normas_L2_p(ite_ext) = DSQRT((p % normas_L2( threads_if( Threads, 2) )))
           !WRITE(*,*) "Parada P:", normas_L2_p(ite_ext)/normas_L2_p(1), "Norma L2 de P:", normas_L2_p(ite_ext), ite_ext, maxval(abs(p % p(:, Tn) - p % p_ref(:)))
           normas_L2_p(ite_ext) = maxval(abs(p % p(:, Tn) - p % p_ref(:)))
           p % p_ref(:) = p % p(:, Tn)
           ite_uvp = ite_ext

           !$OMP END SINGLE

           !DO t = threads_if( thread, 1), threads_if( thread, 2)
           !    WRITE(thread_unit,*) "#---------------------------------------------------------"
           !    WRITE(thread_unit,*) "Pressao, t =", t, "Linf", MAXVAL(ABS(p % p(:, t+1) - p % p_ex(:, t+1)))
           !    WRITE(thread_unit,*) "Veloc u, t =", t, "Linf", MAXVAL(ABS(u % u(:, t+1) - u % u_ex(:, t+1)))
           !    WRITE(thread_unit,*) "Veloc v, t =", t, "Linf", MAXVAL(ABS(v % v(:, t+1) - v % v_ex(:, t+1)))
           !    WRITE(thread_unit,*) "#---------------------------------------------------------"
           !END DO

           ttt2 = OMP_GET_WTIME()
           !WRITE(thread_unit,*) "Processamento total da thread:", ttt2 - ttt1

           IF (normas_L2_u(ite_ext) < Tolerancia_U .and. &
               normas_L2_v(ite_ext) < Tolerancia_V) THEN !.and. normas_L2_p(ite_ext) < Tolerancia_P) THEN
               ite_uvp = ite_ext
               EXIT
           END IF

           ! Verificando os casos NaN
           IF (normas_L2_u(ite_ext)/normas_L2_u(1) .ne. normas_L2_u(ite_ext)/normas_L2_u(1) .or. &
               normas_L2_v(ite_ext)/normas_L2_v(1) .ne. normas_L2_v(ite_ext)/normas_L2_v(1) .or. &
               normas_L2_p(ite_ext)/normas_L2_p(1) .ne. normas_L2_p(ite_ext)/normas_L2_p(1)) THEN
               ite_uvp = ite_ext
               WRITE(*,*) "Caso NaN  Nx: " // TRIM(ADJUSTL(Nx_str)) // " ite_solver: " // TRIM(ADJUSTL(ite_sol_str))
               EXIT
           END IF

       END DO

       !CLOSE(thread_unit)

    !$OMP END PARALLEL

    ! Obtendo o tempo final
    t2 = OMP_GET_WTIME()
    IF (flag_invalido .eq. 0) THEN
        OPEN(UNIT=1, FILE="./resultados/convergencia_UVP_ite_ext_" // TRIM(ADJUSTL(ite_ext_str)) // &
                                                       "_ite_sol_" // TRIM(ADJUSTL(ite_sol_str)) // &
                                                       "_Nx_Ny_"   // TRIM(ADJUSTL(Nx_str)) // &
                                                       "_Threads_" // TRIM(ADJUSTL(Threads_str)) // &
                                                       ".txt", STATUS='REPLACE', ACTION='WRITE' )
    ELSE
       OPEN(UNIT=1, FILE="./resultados/INVALIDO_convergencia_UVP_ite_ext_" // TRIM(ADJUSTL(ite_ext_str)) // &
                                                               "_ite_sol_" // TRIM(ADJUSTL(ite_sol_str)) // &
                                                               "_Nx_Ny_"   // TRIM(ADJUSTL(Nx_str)) // &
                                                               "_Threads_" // TRIM(ADJUSTL(Threads_str)) // &
                                                               ".txt", STATUS='REPLACE', ACTION='WRITE' )
    END IF

    WRITE(1, *) "ite_ext, NormaL2(ite_uvp)/NormaL2(1): U, V, P e NormaL2(ite_uvp): U, V, P"
    DO ite_ext = 1, ite_uvp
        WRITE(1, *) ite_ext, &
                    normas_L2_u(ite_ext), &
                    normas_L2_v(ite_ext), &
                    normas_L2_p(ite_ext)
    END DO

    WRITE(1,*) "Tempo de processamento TOTAL", t2-t1

    CLOSE(1)

     CALL u % escreve_comparacao(Tn, "./resultados/resultados_U_ite_ext_" // TRIM(ADJUSTL(ite_ext_str)) // &
                                    "_ite_sol_" // TRIM(ADJUSTL(ite_sol_str)) // &
                                    "_Nx_Ny_"   // TRIM(ADJUSTL(Nx_str)) // &
                                    "_Threads_" // TRIM(ADJUSTL(Threads_str)) // &
                                    ".txt", u%u(:, Tn))
    CALL v % escreve_comparacao(Tn, "./resultados/resultados_V_ite_ext_" // TRIM(ADJUSTL(ite_ext_str)) // &
                                    "_ite_sol_" // TRIM(ADJUSTL(ite_sol_str)) // &
                                    "_Nx_Ny_"   // TRIM(ADJUSTL(Nx_str)) // &
                                    "_Threads_" // TRIM(ADJUSTL(Threads_str)) // &
                                    ".txt", v%v(:, Tn))
    CALL p % escreve_comparacao(Tn, "./resultados/resultados_P_ite_ext_" // TRIM(ADJUSTL(ite_ext_str)) // &
                                    "_ite_sol_" // TRIM(ADJUSTL(ite_sol_str)) // &
                                    "_Nx_Ny_"   // TRIM(ADJUSTL(Nx_str)) // &
                                    "_Threads_" // TRIM(ADJUSTL(Threads_str)) // &
                                    ".txt", p%p(:, Tn))

END PROGRAM NavierStokes


!==============================================================================!
  subroutine Grid_Mod_Correction_Periodicity(grid, s, corr_x, corr_y, corr_z)
!------------------------------------------------------------------------------!
!           Find corrections for periodic faces centorid location              !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  integer         :: s
  real            :: corr_x, corr_y, corr_z   ! corrections
!-----------------------------------[Locals]-----------------------------------!
  integer :: c1, c2                           ! counters
!==============================================================================!

  ! Initialize
  corr_x = 0.0; corr_y = 0.0; corr_z = 0.0

  c1 = grid % faces_c(1,s)
  c2 = grid % faces_c(2,s)

  ! In x direction
  if( (abs(grid % per_x) > NANO) .and.                             &
      Math_Mod_Approx_Real(   abs(grid % dx(s))                    &
                            + abs(grid % xc(c1) - grid % xc(c2)),  &
                              grid % per_x) ) then
      corr_x = grid % per_x
  end if

  ! In y direction
  if( (abs(grid % per_y) > NANO) .and.                             &
      Math_Mod_Approx_Real(   abs(grid % dy(s))                    &
                            + abs(grid % yc(c1) - grid % yc(c2)),  &
                              grid % per_y) ) then
      corr_y = grid % per_y
  end if

  ! In z direction
  if( (abs(grid % per_z) > NANO) .and.                             &
      Math_Mod_Approx_Real(   abs(grid % dz(s))                    &
                            + abs(grid % zc(c1) - grid % zc(c2)),  &
                              grid % per_z) ) then
      corr_z = grid % per_z
  end if

  end subroutine


 module gaussintegraldata

   use global_com,only: dp

   implicit none
   real(kind=dp),allocatable:: gammao(:),alphao(:),betao(:),wo(:)
   real(kind=dp),allocatable:: gammas(:),alphas(:),betas(:),ws(:)
   integer ngo,ngs

   !real(kind=dp),allocatable:: gammao11(:),alphao11(:),betao11(:),wo11(:)
   real(kind=dp),allocatable:: gammas11(:),alphas11(:),betas11(:),ws11(:)
   !integer ngo11,ngs11
   integer ngs11

    !real(kind=dp),allocatable:: gammao22(:),alphao22(:),betao22(:),wo22(:)
    real(kind=dp),allocatable:: gammas22(:),alphas22(:),betas22(:),ws22(:)
    !integer ngo22,ngs22
    integer ngs22

    real(kind=dp),allocatable:: gammao2(:),alphao2(:),betao2(:),wo2(:)
   real(kind=dp),allocatable:: gammas2(:),alphas2(:),betas2(:),ws2(:)
   integer ngo2,ngs2

   real(kind=dp),allocatable:: gammao3(:),alphao3(:),betao3(:),wo3(:)
   real(kind=dp),allocatable:: gammas3(:),alphas3(:),betas3(:),ws3(:)
   integer ngo3,ngs3

   integer nlg,nlgo,nlgs
   real(kind=dp),allocatable,dimension(:):: wwwl,xxxl,wwo,xxo,wws,xxs

 contains

   !****************************************************
   subroutine setgaussintpara(ng1,  ng2)
   !****************************************************
     implicit none
     integer::ng1,ng2

     if(allocated(wo).and.ngo.eq.ng1.and.ngs.eq.ng2) return;

     if(allocated(wo))	 then
        deallocate(wo,gammao,alphao,betao)
        deallocate(ws,gammas,alphas,betas)
     endif

     ngo = ng1
     ngs = ng2

     allocate(wo(ngo),gammao(ngo) , alphao(ngo),betao(ngo))
     allocate(ws(ngs),gammas(ngs) , alphas(ngs),betas(ngs))

     wo = 0.0_dp;  gammao = 0.0_dp;  alphao = 0.0_dp;  betao  = 0.0_dp
     ws = 0.0_dp;  gammas = 0.0_dp;  alphas = 0.0_dp;  betas  = 0.0_dp

     call ginttrg(ngo, alphao, betao, gammao, wo)
     call ginttrg(ngs, alphas, betas, gammas, ws)

   endsubroutine setgaussintpara
       !****************************************************
       !****************************************************

   subroutine setgaussintpara11(ng2)
       !****************************************************
     implicit none
     ! integer::ng1,ng2
     integer::ng2
    ! if(allocated(wo11).and.ngo11.eq.ng1.and.ngs11.eq.ng2) return;

     if(allocated(ws11))	 then
       ! deallocate(wo11,gammao11,alphao11,betao11)
        deallocate(ws11,gammas11,alphas11,betas11)
     endif

     !ngo11 = ng1
     ngs11 = ng2

     !allocate(wo11(ngo11),gammao11(ngo11) , alphao11(ngo11),betao11(ngo11))
     allocate(ws11(ngs11),gammas11(ngs11) , alphas11(ngs11),betas11(ngs11))

     !wo11 = 0.0_dp;  gammao11 = 0.0_dp;  alphao11 = 0.0_dp;  betao11  = 0.0_dp
     ws11 = 0.0_dp;  gammas11 = 0.0_dp;  alphas11 = 0.0_dp;  betas11  = 0.0_dp

     !call ginttrg(ngo11, alphao11, betao11, gammao11, wo11)
     call ginttrg(ngs11, alphas11, betas11, gammas11, ws11)

   endsubroutine setgaussintpara11
       !****************************************************
       !****************************************************

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

    subroutine setgaussintpara22(  ng2)
!****************************************************
    implicit none
    !integer::ng1,ng2
    integer::ng2
    !if(allocated(wo22).and.ngo22.eq.ng1.and.ngs22.eq.ng2) return;

    if(allocated(ws22))	 then
      !  deallocate(wo22,gammao22,alphao22,betao22)
        deallocate(ws22,gammas22,alphas22,betas22)
    endif

    !ngo22 = ng1
    ngs22 = ng2

    !allocate(wo22(ngo22),gammao22(ngo22) , alphao22(ngo22),betao22(ngo22))
    allocate(ws22(ngs22),gammas22(ngs22) , alphas22(ngs22),betas22(ngs22))

    !wo22 = 0.0_dp;  gammao22 = 0.0_dp;  alphao22 = 0.0_dp;  betao22  = 0.0_dp
    ws22 = 0.0_dp;  gammas22 = 0.0_dp;  alphas22 = 0.0_dp;  betas22  = 0.0_dp

    !call ginttrg(ngo22, alphao22, betao22, gammao22, wo22)
    call ginttrg(ngs22, alphas22, betas22, gammas22, ws22)

    endsubroutine setgaussintpara22
    !****************************************************
    !****************************************************

   subroutine setgaussintpara2(ng1,  ng2)
       !****************************************************
     implicit none
     integer::ng1,ng2

     if(allocated(wo2).and.ngo2.eq.ng1.and.ngs2.eq.ng2) return;

     if(allocated(wo2))	 then
        deallocate(wo2,gammao2,alphao2,betao2)
        deallocate(ws2,gammas2,alphas2,betas2)
     endif

     ngo2 = ng1
     ngs2 = ng2

     allocate(wo2(ngo2),gammao2(ngo2) , alphao2(ngo2),betao2(ngo2))
     allocate(ws2(ngs2),gammas2(ngs2) , alphas2(ngs2),betas2(ngs2))

     wo2 = 0.0_dp;  gammao2 = 0.0_dp;  alphao2 = 0.0_dp;  betao2  = 0.0_dp
     ws2 = 0.0_dp;  gammas2 = 0.0_dp;  alphas2 = 0.0_dp;  betas2  = 0.0_dp

     call ginttrg(ngo2, alphao2, betao2, gammao2, wo2)
     call ginttrg(ngs2, alphas2, betas2, gammas2, ws2)

   endsubroutine setgaussintpara2
       !****************************************************

   !****************************************************
   subroutine setgaussintpara3(ng1,  ng2)
   !****************************************************
     implicit none
     integer::ng1,ng2

     if(allocated(wo3).and.ngo3.eq.ng1.and.ngs3.eq.ng2) return;

     if(allocated(wo3))	 then
        deallocate(wo3,gammao3,alphao3,betao3)
        deallocate(ws3,gammas3,alphas3,betas3)
     endif

     ngo3 = ng1
     ngs3 = ng2

     allocate(wo3(ngo3),gammao3(ngo3) , alphao3(ngo3),betao3(ngo3))
     allocate(ws3(ngs3),gammas3(ngs3) , alphas3(ngs3),betas3(ngs3))

     wo3 = 0.0_dp;  gammao3 = 0.0_dp;  alphao3 = 0.0_dp;  betao3  = 0.0_dp
     ws3 = 0.0_dp;  gammas3 = 0.0_dp;  alphas3 = 0.0_dp;  betas3  = 0.0_dp

     call ginttrg(ngo3, alphao3, betao3, gammao3, wo3)
     call ginttrg(ngs3, alphas3, betas3, gammas3, ws3)

   endsubroutine setgaussintpara3
       !****************************************************

      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   subroutine setgaussintline(nlg1)
      !******************************************
     implicit none
     integer::nlg1
     logical b

     b = allocated(wwwl)
     if(b.and.nlg.eq.nlg1) return;
     if(b)	 deallocate(wwwl,xxxl)

     nlg = nlg1
     allocate(wwwl(nlg),xxxl(nlg))
     wwwl = 0.0_dp
     xxxl = 0.0_dp
!       call gauleg(-1.,1.,xxxl,wwwl,nlg)
     call gauleg(0.0_dp,1.0_dp,xxxl,wwwl,nlg)
   endsubroutine setgaussintline

      !******************************************
   subroutine setgaussintline_new(nlg1,nlg2)
      !******************************************
     implicit none
     integer::nlg1,nlg2
     logical b

     b = allocated(wwo)
     if(b.and.nlgo.eq.nlg1.and.nlgs.eq.nlg2) return;
     if(b)	 deallocate(wwo,xxo,wws,xxs)

     nlgo = nlg1
     nlgs = nlg2
     allocate(wwo(nlgo),xxo(nlgo))
     allocate(wws(nlgs),xxs(nlgs))
     wwo = 0.0_dp ; wws = 0.0_dp
     xxo = 0.0_dp ; xxs = 0.0_dp
     call gauleg(0.0_dp,1.0_dp,xxo,wwo,nlgo)
     call gauleg(0.0_dp,1.0_dp,xxs,wws,nlgs)
   endsubroutine setgaussintline_new

!****************************************************************************
   subroutine ginttrg(n,alpha,beta,gamma,ww)
!****************************************************************************
    implicit none
    integer::n
    real(kind=dp):: alpha(n), beta(n),gamma(n),ww(n)
    real(kind=dp)::v1,v2,v3,v4,v5,v6,v7,v8,v9

    alpha = 0.0_dp;	beta  = 0.0_dp
    gamma = 0.0_dp;	ww    = 0.0_dp

    if(n.eq.1) then ! p =1
       ww(1) = 1.d0
       v1 = 1.d0/3.d0
       alpha(1) = v1; beta(1) = v1;	gamma(1) = v1
    endif

    if(n.eq.3) then ! p =2
       ww(1:3) = 1.d0/3.d0
       v1 = 2.d0/3.d0;
       v2 = 1.d0/6.d0;

       alpha(1) = v1; alpha(2) = v2;  alpha(3) = v2;
       beta(1) = v2;  beta(2) = v1;   beta(3) = v2;
       gamma(1) = v2; gamma(2) = v2;  gamma(3) = v1;
    endif

    if(n.eq.4) then ! p = 3
       ww(1) = -0.5625d0
       v1 = 1.d0/3.d0
       alpha(1) = v1;
       beta(1) = v1;
       gamma(1) = v1
       ww(2:4) = 0.52083333333333333d0

       alpha(2) = 0.6d0; beta(2) = 0.2d0;   gamma(2) = 0.2d0;
       alpha(3) = 0.2d0; beta(3) = 0.6d0;   gamma(3) = 0.2d0;
       alpha(4) = 0.2d0; beta(4) = 0.2d0;   gamma(4) = 0.6d0;
    endif

    if(n.eq.6) then ! p =4
       ww(1:3)  = 0.223381589678011d0
       ww(4:6)  = 0.109951743655322d0
       v1= 0.108103018168070d0;
       v3= 0.816847572980459d0;
       v2= 0.445948490915965d0;
       v4= 0.091576213509771d0;
       alpha( 1)  =  v1;      beta( 1)  =  v2;   gamma(1)  = v2
       alpha( 2)  =  v2;      beta( 2)  =  v1;   gamma(2)  = v2
       alpha( 3)  =  v2;      beta( 3)  =  v2;   gamma(3)  = v1

       alpha( 4)  =  v3;      beta( 4)  =  v4;   gamma(4)  = v4
       alpha( 5)  =  v4;      beta( 5)  =  v3;   gamma(5)  = v4
       alpha( 6)  =  v4;      beta( 6)  =  v4;   gamma(6)  = v3

    endif

    if(n.eq.7) then ! p =5  !see in graglia paper

       ww(1) = 0.225d0
       alpha(1) = 1.d0/3.d0;beta(1) = 1.d0/3.d0;gamma(1) = 1.d0/3.d0;

       ww(2:4) = (155.d0+sqrt(15.0d0))/1200.0d0 !0.132394152788506 !
       ww(5:7) = (155.d0-sqrt(15.0d0))/1200.0d0 !0.125939180544827 !

       v1 = (9.0d0-2.0d0*sqrt(15.0d0))/21.0d0
       v2 = (6.0d0-   sqrt(15.0d0))/21.0d0
       v3 = (6.0d0+   sqrt(15.0d0))/21.0d0
       v4 = (9.0d0+2.0d0*sqrt(15.0d0))/21.0d0

       alpha(2) = v1;  alpha(3) = v3;  alpha(4) = v3;
       beta(2) = v3;   beta(3) = v1;   beta(4) = v3;
       gamma(2) = v3;  gamma(3) = v3;  gamma(4) = v1;

       alpha(5) = v4;  alpha(6) = v2;  alpha(7) = v2;
       beta(5) = v2;   beta(6) = v4;   beta(7) = v2;
       gamma(5) = v2;  gamma(6) = v2;  gamma(7) = v4;
    endif

    !      if(n.eq.9) then ! p =3  !see in graglia paper
    !
    !	   ww(1:9) = 1./9.
    !      v1 =  1./18.
    !	v2 =  2./9.
    !	v3 =  7./18.
    !	v4 = 13./18.
    !
    !	alpha(1) = v1;  beta(1) = v2;
    !      alpha(2) = v2;  beta(2) = v1;
    !	alpha(3) = v1;  beta(3) = v4;
    !	alpha(4) = v4;  beta(4) = v1;
    !      alpha(5) = v2;  beta(5) = v3;
    !	alpha(6) = v3;  beta(6) = v2;
    !	alpha(7) = v3;  beta(7) = v3;
    !	alpha(8) = v2;  beta(8) = v4;
    !	alpha(9) = v4;  beta(9) = v2;
    !	gamma = 1. - beta -alpha
    !
    !	endif

    if(n.eq.9) then ! p =3  !×ô¼ºíæµ¼£¬±íê¾½«ò»¸öèý½çðî·ö³éµèãæ»ýµä9¸öèý½çðî

       ww(1:9) = 1.0d0/9.0d0
       v1 =  1.0d0/9.0d0
       v2 =  2.0d0/9.0d0
       v3 =  4.0d0/9.0d0
       v4 =  5.0d0/9.0d0
       v5 =  7.0d0/9.0d0

       alpha(1) = v1;  beta(1) = v5;
       alpha(2) = v5;  beta(2) = v1;
       alpha(3) = v1;  beta(3) = v1;

       alpha(4) = v3;  beta(4) = v1;
       alpha(5) = v1;  beta(5) = v3;
       alpha(6) = v3;  beta(6) = v3;

       alpha(7) = v2;  beta(7) = v4;
       alpha(8) = v2;  beta(8) = v2;
       alpha(9) = v4;  beta(9) = v2;
       gamma = 1. - beta -alpha

    endif

    if(n.eq.12) then ! p = 6
       ww(1:3)   =    0.116786275726379d0
       ww(4:6)   =    0.050844906370207d0
       ww(7:12)  =    0.082851075618374d0   !¿éòô¿¼âçóãn0 n1 n2à´¿øöæ

       v1  = 0.501426509658179d0;  v2 = 0.249286745170910d0
       v4  = 0.873821971016996d0;  v5 = 0.063089014491502d0
       v7  = 0.053145049844817d0;  v8 = 0.310352451033784d0
       v9  = 1. - v7 - v8

       alpha( 1)  =  v1;  beta( 1)  =  v2;    gamma( 1)  =  v2;
       alpha( 2)  =  v2;  beta( 2)  =  v1;    gamma( 2)  =  v2;
       alpha( 3)  =  v2;  beta( 3)  =  v2;    gamma( 3)  =  v1;

       alpha( 4)  =  v4;  beta( 4)  =  v5;    gamma( 4)  =  v5;
       alpha( 5)  =  v5;  beta( 5)  =  v4;    gamma( 5)  =  v5;
       alpha( 6)  =  v5;  beta( 6)  =  v5;    gamma( 6)  =  v4;

       alpha( 7)  =  v7;  beta( 7)  =  v8;    gamma( 7)  =  v9;
       alpha( 8)  =  v7;  beta( 8)  =  v9;    gamma( 8)  =  v8;
       alpha( 9)  =  v8;  beta( 9)  =  v7;    gamma( 9)  =  v9;
       alpha(10)  =  v8;  beta(10)  =  v9;    gamma(10)  =  v7;
       alpha(11)  =  v9;  beta(11)  =  v8;    gamma(11)  =  v7;
       alpha(12)  =  v9;  beta(12)  =  v7;    gamma(12)  =  v8;

    endif

    if(n.eq.13) then ! p =7
       ww(1)     =   -0.149570044467682d0
       ww(2:4)   =    0.175615257433208d0
       ww(5:7)   =    0.053347235608838d0
       ww(8:13)  =    0.077113760890257d0   !¿éòô¿¼âçóãn0 n1 n2à´¿øöæ

       alpha(1)  = 0.333333333333333d0;  beta(1) = 0.333333333333333d0
       alpha(2)  = 0.479308067841920d0;	beta(2) = 0.260345966079040d0
       alpha(5)  = 0.869739794195568d0;  beta(5) = 0.065130102902216d0
       alpha(8)  = 0.048690315425316d0;	beta(8) = 0.312865496004874d0

       gamma(1)  = 1. - alpha(1) - beta(1)
       gamma(2)  = 1. - alpha(2) - beta(2)
       gamma(5)  = 1. - alpha(5) - beta(5)
       gamma(8)  = 1. - alpha(8) - beta(8)

       alpha( 3)  =  beta(2);         beta( 3)  = alpha(2)
       alpha( 4)  =  beta(2);         beta( 4)  =  beta(2)
       alpha( 6)  =  beta(5);         beta( 6)  = alpha(5)
       alpha( 7)  =  beta(5);         beta( 7)  =  beta(5)

       alpha( 9)  = alpha(8);         beta( 9)  = gamma(8)
       alpha(10)  =  beta(8);         beta(10)  = alpha(8)
       alpha(11)  =  beta(8);         beta(11)  = gamma(8)
       alpha(12)  = gamma(8);         beta(12)  =  beta(8)
       alpha(13)  = gamma(8);         beta(13)  = alpha(8)

       gamma(3)     = 1. - alpha(3) - beta(3)
       gamma(4)     = 1. - alpha(4) - beta(4)
       gamma(6)     = 1. - alpha(6) - beta(6)
       gamma(7)     = 1. - alpha(7) - beta(7)

       gamma(9 )    = 1. - alpha( 9) - beta( 9)
       gamma(10)    = 1. - alpha(10) - beta(10)
       gamma(11)    = 1. - alpha(11) - beta(11)
       gamma(12)    = 1. - alpha(12) - beta(12)
       gamma(13)    = 1. - alpha(13) - beta(13)
    endif

    if(n.eq.16) then ! p = 8
       ww(1:3)   =  0.095091634267285d0
       ww(4:6)   =  0.103217370534718d0
       ww(7:12)  =  0.027230314174435d0

       ww(13:15) =  0.032458497623198d0
       ww(16)    =  0.144315607677787d0

       v1  = 0.081414823414554d0;  v2 = 0.459292588292723d0
       v4  = 0.658861384496480d0;  v5 = 0.170569307751760d0
       v7  = 0.008394777409958d0;  v8 = 0.263112829634638d0;
       v9  = 1. - v7 - v8

       alpha( 1)  =  v1;  beta( 1)  =  v2;    gamma( 1)  =  v2;
       alpha( 2)  =  v2;  beta( 2)  =  v1;    gamma( 2)  =  v2;
       alpha( 3)  =  v2;  beta( 3)  =  v2;    gamma( 3)  =  v1;

       alpha( 4)  =  v4;  beta( 4)  =  v5;    gamma( 4)  =  v5;
       alpha( 5)  =  v5;  beta( 5)  =  v4;    gamma( 5)  =  v5;
       alpha( 6)  =  v5;  beta( 6)  =  v5;    gamma( 6)  =  v4;

       alpha( 7)  =  v7;  beta( 7)  =  v8;    gamma( 7)  =  v9;
       alpha( 8)  =  v7;  beta( 8)  =  v9;    gamma( 8)  =  v8;
       alpha( 9)  =  v8;  beta( 9)  =  v7;    gamma( 9)  =  v9;
       alpha(10)  =  v8;  beta(10)  =  v9;    gamma(10)  =  v7;
       alpha(11)  =  v9;  beta(11)  =  v8;    gamma(11)  =  v7;
       alpha(12)  =  v9;  beta(12)  =  v7;    gamma(12)  =  v8;

       v1  = 0.898905543365938d0;  v2 = 0.050547228317031d0

       alpha(13)  =  v1;  beta(13)  =  v2;    gamma(13)  =  v2;
       alpha(14)  =  v2;  beta(14)  =  v1;    gamma(14)  =  v2;
       alpha(15)  =  v2;  beta(15)  =  v2;    gamma(15)  =  v1;

       v1 = 1.0d0/3.0d0
       alpha(16)  =  v1;  beta(16)  =  v1;    gamma(16)  =  v1;

    endif

    if(n.eq.25) then ! p = 10
       ww(1:3)   =  0.036725957756467d0
       ww(4:6)   =  0.045321059435528d0
       ww(7:12)  =  0.072757916845420d0
       ww(13:18) =  0.028327242531057d0
       ww(19:24) =  0.009421666963733d0

       ww(25)    =  0.090817990382754d0

       v1  = 0.028844733232685d0;  v2 = 0.485577633383657d0
       v4  = 0.781036849029926d0;  v5 = 0.109481575485037d0
       v7  = 0.141707219414880d0;  v8 = 0.307939838764121d0;
       v9  = 1. - v7 - v8

       alpha( 1)  =  v1;  beta( 1)  =  v2;    gamma( 1)  =  v2;
       alpha( 2)  =  v2;  beta( 2)  =  v1;    gamma( 2)  =  v2;
       alpha( 3)  =  v2;  beta( 3)  =  v2;    gamma( 3)  =  v1;

       alpha( 4)  =  v4;  beta( 4)  =  v5;    gamma( 4)  =  v5;
       alpha( 5)  =  v5;  beta( 5)  =  v4;    gamma( 5)  =  v5;
       alpha( 6)  =  v5;  beta( 6)  =  v5;    gamma( 6)  =  v4;

       alpha( 7)  =  v7;  beta( 7)  =  v8;    gamma( 7)  =  v9;
       alpha( 8)  =  v7;  beta( 8)  =  v9;    gamma( 8)  =  v8;
       alpha( 9)  =  v8;  beta( 9)  =  v7;    gamma( 9)  =  v9;
       alpha(10)  =  v8;  beta(10)  =  v9;    gamma(10)  =  v7;
       alpha(11)  =  v9;  beta(11)  =  v8;    gamma(11)  =  v7;
       alpha(12)  =  v9;  beta(12)  =  v7;    gamma(12)  =  v8;

       v7  = 0.025003534762686d0;  v8 = 0.246672560639903d0;
       v9  = 1. - v7 - v8
       alpha(13)  =  v7;  beta(13)  =  v8;    gamma(13)  =  v9;
       alpha(14)  =  v7;  beta(14)  =  v9;    gamma(14)  =  v8;
       alpha(15)  =  v8;  beta(15)  =  v7;    gamma(15)  =  v9;
       alpha(16)  =  v8;  beta(16)  =  v9;    gamma(16)  =  v7;
       alpha(17)  =  v9;  beta(17)  =  v8;    gamma(17)  =  v7;
       alpha(18)  =  v9;  beta(18)  =  v7;    gamma(18)  =  v8;

       v7  = 0.009540815400299d0;  v8 = 0.066803251012200d0;
       v9  = 1. - v7 - v8
       alpha(19)  =  v7;  beta(19)  =  v8;    gamma(19)  =  v9;
       alpha(20)  =  v7;  beta(20)  =  v9;    gamma(20)  =  v8;
       alpha(21)  =  v8;  beta(21)  =  v7;    gamma(21)  =  v9;
       alpha(22)  =  v8;  beta(22)  =  v9;    gamma(22)  =  v7;
       alpha(23)  =  v9;  beta(23)  =  v8;    gamma(23)  =  v7;
       alpha(24)  =  v9;  beta(24)  =  v7;    gamma(24)  =  v8;

       v1 = 1.0d0/3.0d0
       alpha(25)  =  v1;  beta(25)  =  v1;    gamma(25)  =  v1;

    endif
    ! 0000000000000000000000000000000000000000000
    if(n.eq.42) then ! p =14

       ww( 1: 3) =    0.021883581369429d0
       ww( 4: 6) =    0.032788353544125d0
       ww( 7: 9) =    0.051774104507292d0   !¿éòô¿¼âçóãn0 n1 n2à´¿øöæ
       ww(10:12) =    0.042162588736993d0
       ww(13:15) =    0.014433699669777d0
       ww(16:18) =    0.004923403602400d0

       ww(19:24) =    0.024665753212564d0
       ww(25:30) =    0.038571510787061d0
       ww(31:36) =    0.014436308113534d0
       ww(37:42) =    0.005010228838501d0

       alpha( 1) = 0.022072179275643d0;  beta( 1) = (1.d0 - alpha( 1))/2.d0
       alpha( 4) = 0.164710561319092d0;  beta( 4) = (1.d0 - alpha( 4))/2.d0
       alpha( 7) = 0.453044943382323d0;  beta( 7) = (1.d0 - alpha( 7))/2.d0
       alpha(10) = 0.645588935174913d0;  beta(10) = (1.d0 - alpha(10))/2.d0
       alpha(13) = 0.876400233818255d0;  beta(13) = (1.d0 - alpha(13))/2.d0
       alpha(16) = 0.961218077502598d0;	beta(16) = (1.d0 - alpha(16))/2.d0

       alpha(19) = 0.057124757403648d0;  beta(19) = 0.172266687821356d0
       alpha(25) = 0.092916249356972d0;  beta(25) = 0.336861459796345d0
       alpha(31) = 0.014646950055654d0;  beta(31) = 0.298372882136258d0
       alpha(37) = 0.001268330932872d0;  beta(37) = 0.118974497696957d0

       gamma  = 1.d0 - alpha - beta

       alpha( 2)  =  beta( 1);         beta( 2)  = alpha( 1)
       alpha( 3)  =  beta( 1);         beta( 3)  = gamma( 1)

       alpha( 5)  =  beta( 4);         beta( 5)  = alpha( 4)
       alpha( 6)  =  beta( 4);         beta( 6)  = gamma( 4)

       alpha( 8)  =  beta( 7);         beta( 8)  = alpha( 7)
       alpha( 9)  =  beta( 7);         beta( 9)  = gamma( 7)

       alpha(11)  =  beta(10);         beta(11)  = alpha(10)
       alpha(12)  =  beta(10);         beta(12)  = gamma(10)

       alpha(14)  =  beta(13);         beta(14)  = alpha(13)
       alpha(15)  =  beta(13);         beta(15)  = gamma(13)

       alpha(17)  =  beta(16);         beta(17)  = alpha(16)
       alpha(18)  =  beta(16);         beta(18)  = gamma(16)

       alpha(20)  = alpha(19);         beta(20)  = gamma(19)
       alpha(21)  =  beta(19);         beta(21)  = alpha(19)
       alpha(22)  =  beta(19);         beta(22)  = gamma(19)
       alpha(23)  = gamma(19);         beta(23)  =  beta(19)
       alpha(24)  = gamma(19);         beta(24)  = alpha(19)

       alpha(26)  = alpha(25);         beta(26)  = gamma(25)
       alpha(27)  =  beta(25);         beta(27)  = alpha(25)
       alpha(28)  =  beta(25);         beta(28)  = gamma(25)
       alpha(29)  = gamma(25);         beta(29)  =  beta(25)
       alpha(30)  = gamma(25);         beta(30)  = alpha(25)

       alpha(32)  = alpha(31);         beta(32)  = gamma(31)
       alpha(33)  =  beta(31);         beta(33)  = alpha(31)
       alpha(34)  =  beta(31);         beta(34)  = gamma(31)
       alpha(35)  = gamma(31);         beta(35)  =  beta(31)
       alpha(36)  = gamma(31);         beta(36)  = alpha(31)

       alpha(38)  = alpha(37);         beta(38)  = gamma(37)
       alpha(39)  =  beta(37);         beta(39)  = alpha(37)
       alpha(40)  =  beta(37);         beta(40)  = gamma(37)
       alpha(41)  = gamma(37);         beta(41)  =  beta(37)
       alpha(42)  = gamma(37);         beta(42)  = alpha(37)

       gamma  = 1.d0 - alpha - beta

    endif
    ! 0000000000000000000000000000000000000000000000000
    if(ww(1).eq.0.0d0)  then
       print*,"error in ng and please use the ng numbers in this subroutine"
       stop
    endif

  end subroutine ginttrg

! ************************************************************
      subroutine gauleg(x1,x2,x,w,n)
! ************************************************************
      implicit none
      integer n
      real(kind=dp):: x1,x2,x(n),w(n)
      real(kind=dp),parameter:: eps=3.d-14
      integer i,j,m
      real(kind=dp):: p1,p2,p3,pp,xl,xm,z,z1
      m=(n+1)/2
      xm=0.5d0*(x2+x1)
      xl=0.5d0*(x2-x1)
      do 12 i=1,m
        z=dcos(3.141592654d0*(i-.25d0)/(n+.5d0))
1       continue
          p1=1.d0
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
11        continue
          pp=n*(z*p1-p2)/(z*z-1.d0)
          z1=z

          z=z1-p1/pp
        if(abs(z-z1).gt.eps)goto 1
        x(i)=xm-xl*z
        x(n+1-i)=xm+xl*z
        w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
        w(n+1-i)=w(i)
12    continue
      return
      end subroutine gauleg
! ************************************************************

 endmodule gaussintegraldata


! PR debug/43229
! { dg-do compile }
! { dg-options "-g -O3 -ffast-math" }
! { dg-options "-g -O3 -ffast-math -msse3" { target { i?86-*-* x86_64-*-* } } }

function foo (c, d)
  real(8) :: c(6), d(6), foo
  x = sum (c * d)
  foo = exp (-x)
end function foo


! libRQZ
! author: daan.camps@cs.kuleuven.be
! Description:
!   Implements the routines for selecting the shifts and poles during
!   the iteration.
! ___________________________________________________________________
module d_computepoles
  use u_parameters
  use u_activeparts
  use d_ctransformations
  use d_memorymgmt

  implicit none
  private
  public d_get_shift, d_get_pole, d_eigenvalues2x2, d_make_hess, &
         d_ccstdform, d_normalizeSchur

contains
  subroutine d_get_shift(A,B,idx,alpha,beta,isreal)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Computes the eigenvalues of the trailing two by two block.
  ! If these are real,
  !  alpha/beta is set equal to the one closest to the last
  !  diagonal element and isreal is set to true
  ! If this is a complex conjugate pair,
  !  alpha contains the real part and beta the imaginary part,
  !  isreal is set to false
  !
  ! The user can overwrite this function to use a different shift
  ! selection procedure.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [IN]
  !           Upper block-Hessenberg matrix A
  ! B       double array [IN]
  !           Upper block-Hessenberg matrix B
  ! idx     integer [IN]
  !           Index indicating the two-by-two block,
  !             idx-1:idx,idx-1:idx
  ! alpha   double [OUT]
  !           Defines the shift. If isreal is false: real
  !           part of the shift, else numerator
  ! beta    double [OUT]
  !           Defines the shift. If isreal is false: imaginary
  !           part of the shift, else denominator
  ! isreal  boolean [OUT]
  !           Defines if shift should be treated as a single
  !           real-valued shift or a pair of complex conjugate
  !           shifts.
  !___________________________________________________________________________
  ! last edit: September 5, 2018
    real(kind=dp),intent(in)     :: A(:,:), B(:,:)
    integer, intent(in)          :: idx
    real(kind=dp),intent(out)    :: alpha, beta
    logical, intent(out)         :: isreal

    call d_eigenvalues2x2(A,B,idx-1,idx-1,alpha,beta,isreal)

    ! Select best one if real
    if (isreal) then
      if (abs(B(idx,idx)*alpha-A(idx,idx)) .lt. &
          abs(B(idx,idx)*beta-A(idx,idx))) then
       beta = done
      else
       alpha = beta
       beta = done
      endif
    end if
  end subroutine

  subroutine d_get_pole(A,B,idx,alpha,beta,isreal)
  !
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Computes the eigenvalues of the leading two by two block.
  ! If these are real,
  !  alpha/beta is set equal to the one closest to the first
  !  diagonal element and isreal is set to true
  ! If this is a complex conjugate pair,
  !  alpha contains the real part and beta the imaginary part,
  !  isreal is set to false
  !
  ! The user can overwrite this function to use a different pole
  ! selection procedure.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [IN]
  !           Upper block-Hessenberg matrix A
  ! B       double array [IN]
  !           Upper block-Hessenberg matrix B
  ! idx     integer [IN]
  !           Index indicating the two-by-two block,
  !             idx:idx+1,idx:idx+1
  ! alpha   double [OUT]
  !           Defines the shift. If isreal is false: real
  !           part of the shift, else numerator
  ! beta    double [OUT]
  !           Defines the shift. If isreal is false: imaginary
  !           part of the shift, else denominator
  ! isreal  boolean [OUT]
  !           Defines if shift should be treated as a single
  !           real-valued shift or a pair of complex conjugate
  !           shifts.
  !___________________________________________________________________________
  ! last edit: September 5, 2018
    real(kind=dp),intent(in)     :: A(:,:), B(:,:)
    integer, intent(in)          :: idx
    real(kind=dp),intent(out)    :: alpha, beta
    logical, intent(out)         :: isreal

    call d_eigenvalues2x2(A,B,idx,idx,alpha,beta,isreal)

    ! Select best one if real
    if (isreal) then
      if (abs(B(idx,idx)*alpha-A(idx,idx)) .lt. &
          abs(B(idx,idx)*beta-A(idx,idx))) then
       beta = done
      else
       alpha = beta
       beta = done
      endif
    end if
  end subroutine

  subroutine d_eigenvalues2x2(A,B,i,j,l1,l2,isreal)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Computes the eigenvalues of a 2-by-2 block
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [IN]
  !           array block-Hessenberg
  ! B       double array [IN]
  !           array block-Hessenberg
  ! i       integer [IN]
  !           eigenvalues of range i:i+1, j:j+1 are computed
  ! j       integer [IN]
  !           eigenvalues of range i:i+1, j:j+1 are computed
  ! l1      double [OUT]
  !          If isreal is true, real eigenvalue of (A,B)
  !          If isreal is false, real part of eigenvalue
  ! l2      double [OUT]
  !          If isreal is true, real eigenvalue of (A,B)
  !          If isreal is false, imaginary part of eigenvalue
  ! isreal  boolean [OUT]
  !           Indicates if it are two real eigenvalues or
  !           a pair of complex conjugate eigenvalues
  !
  !___________________________________________________________________________
  ! last edit: September 7, 2018
  ! WRAPPER FOR LAPACK DLAG2
    real(kind=dp), intent(in)   :: A(:,:), B(:,:)
    integer, intent(in)         :: i,j
    real(kind=dp), intent(out)  :: l1, l2
    logical, intent(out)        :: isreal

    integer                     :: LDAB
    real(kind=dp)               :: S1, S2, WI, AC(2,2), BC(2,2), c, s, r
    external                    :: DLAG2

    call d_getLeadingDim(LDAB,A)

    if (abs(B(i+1,j)) .gt. dzero ) then
      AC = A(i:i+1,j:j+1)
      BC = B(i:i+1,j:j+1)
      call d_compute_ct(BC(1,1),BC(2,1),c,s,r)
      call d_apply_ct_l(AC(1,1:2),AC(2,1:2),c,s)
      call d_apply_ct_l(BC(1,1:2),BC(2,1:2),c,s)
      BC(2,1) = dzero
      call DLAG2(AC, 2, BC, 2,sfmin, S1,S2, l1, l2, WI )
    else
      call DLAG2(A(i,j), LDAB, B(i,j), LDAB,sfmin, S1,S2, l1, l2, WI )
    end if

    if (WI .gt. dzero) then
      isreal = .false.
      l1 = l1 /S1
      l2 = WI /S1
    else
      isreal = .true.
      l1 = l1 /S1
      l2 = l2 /S2
    endif

  end subroutine

  subroutine d_make_hess(l1,i,j,A,B,compAB,apC,apT,Q,compQ,qcol,Z,compZ,zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Restores the Hessenberg shape of a 2x2 block that has real eigenvalues,
  ! one of which is equal to l1
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  !
  ! l1         double [IN]
  !             One of two eigenvalues of the block i:i+1,j:j+1
  ! i       integer [IN]
  !           Row index of 2x2 block: i:i+1
  ! j       integer [IN]
  !           Column index of 2x2 block: j:j+1
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: January 11, 2019

    real(kind=dp), intent(inout)    :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    real(kind=dp), intent(in)       :: l1 ! eigenvalue
    integer, intent(in)             :: i,j, qcol, zcol
    logical, intent(in)             :: compAB, compQ, compZ
    type(tAp), pointer, intent(in)  :: apC, apT

    real(kind=dp)                   :: c,s,r
    integer,pointer                 :: cstrt, cstp, tstrt, tstp
    integer                         :: LDQ, LDZ

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDZ,Z)

    Z4(1:2,1:2) = A(i:i+1,j:j+1) - l1 * B(i:i+1,j:j+1)

    if (abs(Z4(1,2)) .gt. abs(Z4(2,2))) then
      call d_compute_ct(Z4(1,2),Z4(1,1),c,s,r)
    else
      call d_compute_ct(Z4(2,2),Z4(2,1),c,s,r)
    end if

    if (compAB) then
      call d_apply_ct_r(A(tstrt+1:i+1,j),A(tstrt+1:i+1,j+1),c,s)
      call d_apply_ct_r(B(tstrt+1:i+1,j),B(tstrt+1:i+1,j+1),c,s)
    else
      call d_apply_ct_r(A(cstrt+1:i+1,j),A(cstrt+1:i+1,j+1),c,s)
      call d_apply_ct_r(B(cstrt+1:i+1,j),B(cstrt+1:i+1,j+1),c,s)
    end if

    if (compZ) then
      call d_apply_ct_r(Z(1:LDZ,zcol),Z(1:LDZ,zcol+1),c,s)
    end if

    if (abs(B(i+1,j)) .ge. abs(A(i+1,j))) then
      call d_compute_ct(B(i,j),B(i+1,j),c,s,r)
    else
      call d_compute_ct(A(i,j),A(i+1,j),c,s,r)
    end if

    if (compAB) then
      call d_apply_ct_l(A(i,j:tstp),A(i+1,j:tstp),c,s)
      call d_apply_ct_l(B(i,j:tstp),B(i+1,j:tstp),c,s)
    else
      call d_apply_ct_l(A(i,j:cstp),A(i+1,j:cstp),c,s)
      call d_apply_ct_l(B(i,j:cstp),B(i+1,j:cstp),c,s)
    end if

    A(i+1,j) = dzero
    B(i+1,j) = dzero
    if (compQ) then
      call d_apply_ct_r(Q(1:LDQ,qcol),Q(1:LDQ,qcol+1),c,-s)
    end if

  end subroutine

  subroutine d_ccstdform(i,j,A,B,compAB,apC,apT,Q,compQ,qcol,Z,compZ,zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Restores the standard form of a 2x2 block
  ! containing complex conjugate eigenvalues:
  !     B will be made diagonal with positive elements
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  !
  ! i       integer [IN]
  !           Row index of 2x2 block: i:i+1
  ! j       integer [IN]
  !           Column index of 2x2 block: j:j+1
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: January 15, 2019

    real(kind=dp), intent(inout)    :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    integer, intent(in)             :: i,j, qcol, zcol
    logical, intent(in)             :: compAB, compQ, compZ
    type(tAp), pointer, intent(in)  :: apC, apT

    real(kind=dp)                   :: c,s,r,cl,sl,cr,sr,g,h,s1,s2
    integer,pointer                 :: cstrt, cstp, tstrt, tstp
    integer                         :: LDQ, LDZ

    external  ::  DLASV2

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDZ,Z)

    ! First rotate B if necessary
    if (abs(B(i+1,j)) .gt. dzero) then
      call d_compute_ct(B(i,j),B(i+1,j),c,s,r)
      g = c * B(i,j+1) + s * B(i+1,j+1)
      h = -s * B(i,j+1) + c *B(i+1,j+1)
      ! Then make it diagonal
      call DLASV2(r,g,h,s2,s1,sr,cr,sl,cl)
      sr = -sr
      ! Combine left rotations
      r = cl*c - sl*s
      sl = cl*s + sl*c
      cl = r
    else
      call DLASV2(B(i,j),B(i,j+1),B(i+1,j+1),s2,s1,sr,cr,sl,cl)
      sr = -sr
    end if

    ! Set B block
    B(i,j) = s1
    B(i+1,j) = dzero
    B(i,j+1) = dzero
    B(i+1,j+1) = s2

    ! Update everything
    if (compAB) then
      call d_apply_ct_l(A(i,j:tstp),A(i+1,j:tstp),cl,sl)
      call d_apply_ct_l(B(i,j+2:tstp),B(i+1,j+2:tstp),cl,sl)
      call d_apply_ct_r(A(tstrt+1:i+1,j),A(tstrt+1:i+1,j+1),cr,sr)
      call d_apply_ct_r(B(tstrt+1:i-1,j),B(tstrt+1:i-1,j+1),cr,sr)
    else
      call d_apply_ct_l(A(i,j:cstp),A(i+1,j:cstp),cl,sl)
      call d_apply_ct_l(B(i,j+2:cstp),B(i+1,j+2:cstp),cl,sl)
      call d_apply_ct_r(A(cstrt+1:i+1,j),A(cstrt+1:i+1,j+1),cr,sr)
      call d_apply_ct_r(B(cstrt+1:i-1,j),B(cstrt+1:i-1,j+1),cr,sr)
    end if

    if (compQ) then
      call d_apply_ct_r(Q(1:LDQ,qcol),Q(1:LDQ,qcol+1),cl,-sl)
    end if

    if (compZ) then
      call d_apply_ct_r(Z(1:LDZ,zcol),Z(1:LDZ,zcol+1),cr,sr)
    end if

  end subroutine

  subroutine d_normalizeSchur(A,B,compAB,apC,apT,Q,compQ,qcol,Z,compZ,zcol,sa)
  !
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Normalize all 2x2 blocks in the generalized real Schur form
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  !
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated
  ! sa      boolean [IN]
  !           Standalone usage: if true, all cc blocks are normalized,
  !           if false, all 2x2 blocks are tested for cc and corrected.
  !___________________________________________________________________________
  ! last edit: January 16, 2019
    real(kind=dp), intent(inout)    :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    integer, intent(in)             :: qcol, zcol
    logical, intent(in)             :: compAB, compQ, compZ, sa
    type(tAp), pointer, intent(in)  :: apC, apT

    integer,pointer                 :: cstrt, cstp, tstrt, tstp
    integer                         :: LDQ, LDZ
    real(kind=dp)                   :: mu, nu
    integer                         :: i
    logical                         :: isreal

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDZ,Z)

    i = tstrt+1
    do while (i .lt. tstp)
      if (abs(A(i+1,i)) .gt. dzero) then
        call d_eigenvalues2x2(A,B,i,i,mu,nu,isreal)
        if (isreal) then
          call d_make_hess(mu,i,i,A,B,compAB,apC,apT,&
                Q,compQ,qcol+i-1,Z,compZ,zcol+i-1)
        elseif (sa .and. (abs(B(i+1,i)) .gt. dzero) .or. (abs(B(i,i+1)) .gt. dzero)) then
          call d_ccstdform(i,i,A,B,compAB,apC,apT,&
                Q,compQ,qcol+i-1,Z,compZ,zcol+i-1)
        end if
        i = i + 2
      else
        i = i + 1
      end if
    end do
  end subroutine
end module


module fmod

use pnmio

implicit none

double precision, parameter :: e = exp(1.d0)

integer, parameter :: debug = 2

!********

abstract interface

  double complex function itr_func_interface(z, c)
  double complex :: z, c
  end function itr_func_interface

end interface

!********

contains

!=======================================================================

! h in [0, 360], s in [0, 1], v in [0, 1]

! rgb in [0, 255]

function hsv2rgb(hsv)

double precision :: rgb(3), hp, c, x, m, hsv(3)

integer :: hsv2rgb(3)

c = hsv(2) * hsv(3)
hp = hsv(1) / 60.d0
x = c * (1.d0 - abs(mod(hp, 2.d0) - 1.d0))

if      (0.d0 <= hp .and. hp < 1.d0) then
  rgb = [c, x, 0.d0]
else if (1.d0 <= hp .and. hp < 2.d0) then
  rgb = [x, c, 0.d0]
else if (2.d0 <= hp .and. hp < 3.d0) then
  rgb = [0.d0, c, x]
else if (3.d0 <= hp .and. hp < 4.d0) then
  rgb = [0.d0, x, c]
else if (4.d0 <= hp .and. hp < 5.d0) then
  rgb = [x, 0.d0, c]
else if (5.d0 <= hp .and. hp <= 6.d0) then
  rgb = [c, 0.d0, x]
else
  write(*,*)
  write(*,*) 'ERROR in hsv2rgb'
  write(*,*) 'Hue outside of range [0, 360]'
  write(*,*) 'Hue = ', hsv(1)
  write(*,*)
  stop
end if

m = hsv(3) - c
rgb = rgb + m

hsv2rgb = min(255, floor(rgb * 256.d0))

if (debug >= 3) print *, ''
if (debug >= 3) print *, 'rgb = ', rgb
if (debug >= 3) print *, 'hsv2rgb = ', hsv2rgb

end function hsv2rgb

!=======================================================================

double complex function fmandelbrot(z, c)

double complex :: z, c

!print *, 'mandelbrot'
fmandelbrot = z ** 2 + c

end function fmandelbrot

!=======================================================================

double complex function fship(z, c)

! Burning ship

double complex :: z, c

!print *, 'ship'
fship = complex(abs(realpart(z)), abs(imagpart(z))) ** 2 + c

end function fship

!=======================================================================

integer function nitrescape(c, maxitr, escape, f)

double complex, intent(in) :: c

integer, intent(in) :: maxitr

double precision, intent(in) :: escape

procedure(itr_func_interface), pointer :: f

double complex :: z

z = c
nitrescape = 0
do while (nitrescape < maxitr .and. abs(z) < escape)
  nitrescape = nitrescape + 1
  z = f(z, c)
end do

end function nitrescape

!=======================================================================

subroutine testpbm

!integer, allocatable :: b(:,:)
character, allocatable :: b(:,:)
integer :: ix, iy, io

allocate(b(900, 360))

do ix = 1, 300
  do iy = 1, 360
    b(3 * ix - 2: 3 * ix, iy) = achar(hsv2rgb([dble(iy), 1.d0, 1.d0]))
  end do
end do

io = writepnm(6, b, 'test')
if (io /= 0) stop

end subroutine testpbm

!=======================================================================

end module fmod

!=======================================================================

subroutine fractal

use fmod

implicit none

character :: fname*256, ct*6
character(len = :), allocatable :: fdir

double precision :: xmin, xmax, ymin, ymax, dx, dy, escape, h
double precision :: xmin0, ymin0, xmax0, ymax0, xc, yc, zoom, znt
double precision :: dxmax, dxmin, dymax, dymin, hm
double precision, allocatable :: x(:), y(:)

procedure(itr_func_interface), pointer :: fiterator

integer :: nx, ny, maxitr, i, ix, iy, nitr, t0, t, crate, frm, nt, it, io, &
    ifractal
!integer, allocatable :: b(:,:)
character, allocatable :: b(:,:)

logical :: fexist

!call testpbm
!stop

call system_clock(t0)
call system_clock(count_rate = crate)

write(*,*)
write(*,*) 'Enter file format (1 - 3):'
read(*,*) frm

write(*,*)
write(*,*) 'Enter escape radius:'
read(*,*) escape

write(*,*)
write(*,*) 'Enter maximum number of iterations:'
read(*,*) maxitr

write(*,*)
write(*,*) 'Enter initial min/max x bounds:'
read(*,*) xmin0, xmax0

write(*,*)
write(*,*) 'Enter initial min/max y bounds:'
read(*,*) ymin0, ymax0

write(*,*)
write(*,*) 'Enter zoom center x/y coordinates:'
read(*,*) xc, yc

write(*,*)
write(*,*) 'Enter final zoom magnification:'
read(*,*) zoom

write(*,*)
write(*,*) 'Enter number of frames:'
read(*,*) nt

write(*,*)
write(*,*) 'Enter number of x/y pixels:'
read(*,*) nx, ny

write(*,*)
write(*,*) 'Enter pre-modulo hue multiplier:'
read(*,*) hm

write(*,*)
write(*,*) 'Enter file name:'
read(*,*) fname

write(*,*)
write(*,*) 'Enter fractal iteration function (1 for Mandelbrot or' &
    //' 2 for burning ship):'
read(*,*) ifractal

write(*,*)
write(*,*) '====================================================='

write(*,*)
write(*,*) 'format             = ', frm
write(*,*) 'escape             = ', escape
write(*,*) 'maxitr             = ', maxitr
write(*,*) 'xbounds            = ', xmin0, xmax0
write(*,*) 'ybounds            = ', ymin0, ymax0
write(*,*) 'Zoom center        = ', xc, yc
write(*,*) 'Zoom magnification = ', zoom
write(*,*) 'Frames             = ', nt
write(*,*) 'Image size         = ', nx, ny
write(*,*) 'Hue multiplier     = ', hm
write(*,*) 'File name          = ', trim(fname)
write(*,*) 'Fractal iterator   = ', ifractal

write(*,*)
write(*,*) '====================================================='

allocate(x(nx))
allocate(y(ny))

if (frm == 1 .or. frm == 2) then
  allocate(b(nx, ny))
else
  allocate(b(3 * nx, ny))
end if

fdir = 'frames'

! TODO:  hide errors for all OSs
call system('mkdir "'//fdir//'"')

znt = zoom ** (1.d0 / dble(nt))

dxmax = xmax0 - xc
dxmin = xc - xmin0
dymax = ymax0 - yc
dymin = yc - ymin0

if (ifractal == 1) then
  fiterator => fmandelbrot
else
  fiterator => fship
end if

! "Time" loop which changes zoom level
do it = 0, nt

  write(*, '(a, i0)') 'frame = ', it

  write(ct, '(i0)') it
  !print *, 'ct = ', ct

  xmax = xc + dxmax * znt ** (-it)
  xmin = xc - dxmin * znt ** (-it)
  ymax = yc + dymax * znt ** (-it)
  ymin = yc - dymin * znt ** (-it)

  dx = (xmax - xmin) / dble(nx - 1)
  dy = (ymax - ymin) / dble(ny - 1)

  if (debug >= 1) print *, 'dx, dy = ', dx, dy
  if (debug >= 2) print *, 'xmin, xmax = ', xmin, xmax
  if (debug >= 2) print *, 'ymin, ymax = ', ymin, ymax

  x = [(xmin + dble(i) * dx, i = 0, nx - 1)]
  y = [(ymin + dble(i) * dy, i = 0, ny - 1)]

  ! Space loop over x/y pixel coordinates

!$OMP parallel private(nitr, h)
!$OMP do schedule(dynamic)
  do iy = 1, ny
    do ix = 1, nx

      nitr = nitrescape(complex(x(ix), y(iy)), maxitr, escape, fiterator)

      if (debug >= 3) print *, 'nitr = ', nitr

      if (frm == 1) then

        ! B & W
        if (nitr == maxitr) then
          !b(ix, iy) = 0
          b(ix, iy) = achar(0)
        else
          !b(ix, iy) = 1
          b(ix, iy) = achar(1)
        end if

      else if (frm == 2) then

        ! Grayscale
        !b(ix, iy) = mod(nitr, 256)
        b(ix, iy) = achar(mod(nitr, 256))

      else if (frm == 3) then

        ! RGB

        !! Red/black contour
        !b(ix, iy) = mod(nitr, 256), 0, 0

        ! HSV map
        if (nitr == maxitr) then
          !b(3 * ix - 2: 3 * ix, iy) = [0, 0, 0]
          b(3 * ix - 2: 3 * ix, iy) = achar([0, 0, 0])
        else

          !h = mod(180.d0 + 360.d0 * dble(nitr) / maxitr, 360.d0)
          h = 360.d0 * mod(hm * dble(nitr) / maxitr, 1.d0)

          !b(3 * ix - 2: 3 * ix, iy) = hsv2rgb([h, 1.d0, 1.d0])
          b(3 * ix - 2: 3 * ix, iy) = achar(hsv2rgb([h, 1.d0, 1.d0]))

        end if ! RGB color map style
      end if   ! frm

    end do     ! ix
  end do       ! iy

!$OMP end do
!$OMP end parallel

  io = writepnm(frm, b, fdir//'/'//trim(fname)//'_'//trim(ct))
  if (io /= 0) stop

end do         ! it

call system_clock(t)

write(*,*)
!print *, 't, t0, crate = ', t, t0, crate
write(*,*) 'Elapsed time = ', dble(t - t0) / dble(crate)
write(*,*)

end subroutine fractal

!=======================================================================

program main

  call fractal()

end program main

!=======================================================================


! test_traverse_grid.f90 --
!     Test program for the traverse_grid module
!
program test_traverse_grid
    use traverse_grid
    implicit none

    type(grid_traversing)         :: traverse
    type(grid_sampler)            :: sampler
    integer, dimension(3)         :: range, indices
    real(kind=wp), dimension(2)   :: coord
    real(kind=wp), dimension(2,2) :: coord_range
    real(kind=wp)                 :: sum

    integer                       :: i, j

    range = (/ 2, 3, 2 /)

    call init_grid_traversing( traverse, range )

    indices = indices_grid_traversing( traverse )
    write( *, '(a,3i5)' ) 'start', indices

    do i = 1, product(range)
        call next_point( traverse, indices )
        write( *, '(4i5)' ) i, indices
    enddo
    write(*,*) 'Reset:'
    do i = 1, 4
        call next_point( traverse )
    enddo
    indices = indices_grid_traversing( traverse )
    write( *, '(a,3i5)' ) 'Now:   ', indices
    call reset_grid_traversing( traverse )
    indices = indices_grid_traversing( traverse )
    write( *, '(a,3i5)' ) 'Reset: ', indices

    !
    ! Second part: grid sampler
    !
    coord_range = reshape( (/ 0.0, 1.0,   0.0, 1.0  /), (/2,2/) )
    call sampler%init( 100, coord_range )
    do i = 1,10
        call sampler%next( indices )
        coord = sampler%coords()
        write(*, '(2i5,2f12.8)' ) indices(1:2), coord
    enddo

    !
    ! Now let us see how this can be used for integration a la Monte Carlo
    !
    ! Note:
    ! If the sampler's cycle is completed, the steps are automatically
    ! adjusted. This way it is guaranteed that different points are
    ! sampled.
    !
    write(*,'(a)') 'Exact value:'
    write(*,'(f12.7)') (exp(1.0_wp)-1.0_wp) * sin(6.0_wp*1.0_wp) / 6.0_wp
    write(*,'(a)') 'Systematic sampling:'
   ! call sampler%init( (/1000, 1001 /), coord_range )
    call sampler%init( 1000, coord_range )
    do j = 1,10
        sum = 0.0_wp
        do i = 1,1000
            call sampler%next( indices )
            coord = sampler%coords()
            !if ( i < 10 ) then
            !    write(*,*) j, indices(1:2), coord
            !endif

            sum = sum + f(coord(1),coord(2))
        enddo
        write(*,'(i5,f12.8)') j, sum/1000.0_wp
    enddo

    write(*,'(a)') 'Random sampling (Monte Carlo): 1000 samples'
    do j = 1,10
        sum = 0.0_wp
        do i = 1,1000
            call random_number( coord )
            sum = sum + f(coord(1),coord(2))
        enddo
        write(*,'(i5,f10.5)') j, sum/1000.0_wp
    enddo
    write(*,'(a)') 'Random sampling (Monte Carlo): 10000 samples'
    do j = 1,10
        sum = 0.0_wp
        do i = 1,10000
            call random_number( coord )
            sum = sum + f(coord(1),coord(2))
        enddo
        write(*,'(i5,f10.5)') j, sum/10000.0_wp
    enddo

contains

real(kind=wp) function f( x, y )
    real(kind=wp) :: x, y

    f = exp(x)*cos(6.0_wp*y)
end function f
end program test_traverse_grid


      COMPLEX*16 FUNCTION BFF_Wdec(Q2,MU2,M12,M22)
*     ---------------------------------------
* general BFF;
*
      IMPLICIT NONE
      REAL*8 MU2,Q2,ABQ2,DRM12,DRM22,RU,RD,BFFEXP_Wdec,DREAL,DABS,DLOG
      COMPLEX*16 M12,M22,B,SQR,SQS,LOG,SQRT,B0F_Wdec
*
      ABQ2=DABS(Q2)
      SQR=SQRT(Q2**2+2D0*Q2*(M12+M22)+(M12-M22)**2)
      SQS=Q2+M12+M22
      DRM12=DREAL(M12)
      DRM22=DREAL(M22)
*
      IF(ABQ2.NE.0D0) THEN
*
* BFF(Q2;MU2,M12,0)
       IF(DRM22.LT.1D-14) THEN
        BFF_Wdec=1D0/3D0*LOG(M12/MU2)
     &          -5D0/9D0+2D0/3D0*(M12/Q2+M12**2/Q2**2)
     &   +(1D0-M12/Q2-2D0*M12**2/Q2**2)/3D0*(1D0+M12/Q2)*LOG(1D0+Q2/M12)
        RETURN
       ENDIF
*
* BFF(Q2;MU2,0,M22)
       IF(DRM12.LT.1D-14) THEN
         BFF_Wdec=1D0/3D0*LOG(M22/MU2)
     &           -5D0/9D0+2D0/3D0*(M22/Q2+M22**2/Q2**2)
     &   +(1D0-M22/Q2-2D0*M22**2/Q2**2)/3D0*(1D0+M22/Q2)*LOG(1D0+Q2/M22)
        RETURN
       ENDIF
*
* TAYLOR EXPANSIONS: TO STABILIZE BFF(-SMALL,MU2,SMALL,M22)
       IF((ABQ2/DRM12.LT.1D-3).AND.(DRM22/DRM12.LT.1D-3)) THEN
        RU=(-Q2)/DRM12
        RD=DRM22/DRM12
        BFF_Wdec=BFFEXP_Wdec(RU,RD)+1D0/3*DLOG(DRM12/MU2)
        RETURN
       ELSEIF((ABQ2/DRM22.LT.1D-3).AND.(DRM12/DRM22.LT.1D-3)) THEN
        RU=(-Q2)/DRM22
        RD=DRM12/DRM22
        BFF_Wdec=BFFEXP_Wdec(RU,RD)+1D0/3*DLOG(DRM22/MU2)
        RETURN
       ENDIF
*
* BFF(Q2;MU2,M12,M22)
       IF(DRM12.GT.1D-14.AND.DRM22.GT.1D-14) THEN
          BFF_Wdec=1d0/3/Q2*
     &   (Q2/3-2D0*(M12-M22)**2/Q2
     &   +(1D0+2D0*(M12-M22)/Q2)*M12*LOG(M12/MU2)
     &   +(1D0+2D0*(M22-M12)/Q2)*M22*LOG(M22/MU2)
     &   -(Q2-M12-M22-2D0*(M12-M22)**2/Q2)*B0F_Wdec(Q2,MU2,M12,M22))
       ELSEIF(DRM12.LE.1D-14.AND.DRM22.GT.1D-14) THEN
         BFF_Wdec=1D0/3D0*LOG(M22/MU2)
     &           -5D0/9D0+2D0/3D0*(M22/Q2+M22**2/Q2**2)
     &   +(1D0-M22/Q2-2D0*M22**2/Q2**2)/3D0*(1D0+M22/Q2)*LOG(1D0+Q2/M22)
       ELSEIF(DRM12.GT.1D-14.AND.DRM22.LE.1D-14) THEN
         BFF_Wdec=1D0/3D0*LOG(M12/MU2)
     &           -5D0/9D0+2D0/3D0*(M12/Q2+M12**2/Q2**2)
     &   +(1D0-M12/Q2-2D0*M12**2/Q2**2)/3D0*(1D0+M12/Q2)*LOG(1D0+Q2/M12)
       ELSEIF(DRM12.LE.1D-14.AND.DRM22.LE.1D-14) THEN
         BFF_Wdec=1D0/3D0*LOG(DCMPLX(Q2,-1D-20)/MU2)-5D0/9D0
       ELSE
        PRINT *,'NOT FORESEEN SET OF MASSES IN BFF: M12,M22=',M12,M22
        STOP
       ENDIF
*
      ELSEIF(ABQ2.EQ.0D0) THEN
*
* BFF(0;MU2,M12,M22)
       IF((DRM12.NE.DRM22).AND.DRM22.NE.0D0.AND.DRM12.NE.0D0) THEN
        B=M12/M22-1D0
        BFF_Wdec=1D0/3D0*LOG(M22/MU2)
     &     +(1D0/3D0-1D0/B**2-2D0/3D0/B**3)*LOG(M12/M22)
     &     -5D0/18D0+2D0/3D0/B+2D0/3D0/B**2
       ELSEIF(DRM12.EQ.0D0.AND.DRM22.NE.0D0) THEN
        BFF_Wdec=1D0/3D0*LOG(M22/MU2)-5D0/18D0
       ELSEIF(DRM12.NE.0D0.AND.DRM22.EQ.0D0) THEN
        BFF_Wdec=1D0/3D0*LOG(M12/MU2)-5D0/18D0
       ELSEIF(DRM12.EQ.DRM22) THEN
        BFF_Wdec=1D0/3D0*LOG(M12/MU2)
       ELSE
        PRINT*,'BFF(0;...) NOT FORESEEN SET OF MASSES: M12,M22=',M12,M22
        STOP
       ENDIF
      ELSE
       PRINT*,'B0F(Q2;...) NOT FORESEEN SET OF MASSES: M12,M22=',M12,M22
      ENDIF
*
      RETURN
      END

      REAL*8 FUNCTION BFFEXP_Wdec(RU,RD)
*
      IMPLICIT NONE
      REAL*8 RU,RD,LNRD
*
      LNRD=DLOG(RD)
*
      BFFEXP_Wdec=
     &  - 5D0/18 + 2D0/3*RD + 4D0/3*RD**2 + 2D0*RD**3 + 8D0/3*RD**4
     &  + 1760D0/3*RD**5
     &  + LNRD*RD**2*(1D0+8D0/3*RD+5D0*RD**2+792D0*RD**3)
     &  + RU*(-1D0/6+1D0/2*RD+25D0/6*RD**2+77D0/6*RD**3+17074D0/9*RD**4
     &  + LNRD*RD**2*(2D0+10D0*RD+4990D0/3*RD**2))
     &  + RU**2*(-1D0/20+2D0/5*RD+157D0/20*RD**2+98506D0/45*RD**3
     &  + LNRD*RD**2*(3D0+3992D0/3*RD))
     &  + RU**3*(-1D0/45+1D0/3*RD+13769D0/15*RD**2+396D0*LNRD*RD**2)
     &  + RU**4*(-1D0/84+4336D0/35*RD+112D0/3*LNRD*RD)
     &  + RU**5*(53D0/15+2D0/3*LNRD)
*
      RETURN
      END


      SUBROUTINE LATGEN2
        USE param
        USE struct
        USE rotmat
      IMPLICIT REAL*8 (A-H,O-Z)
!
!     LATGEN GENERATES TWO BRAVAIS MATRICES, DEFINES THE VOLUME OF
!     THE UNIT CELL AND CALLS ROTDEF
!     BR1(3,3)  : TRANSFORMS INTEGER RECIPROCAL LATTICE VECTORS AS
!                 GIVEN IN THE VECTORLIST OF LAPW1  ( GENERATED IN
!                 COORS, TRANSFORMED IN BASISO, AND WRITTEN OUT IN
!                 WFTAPE) INTO CARTESIAN SYSTEM
!     BR2(3,3) :  TRANSFORMS A RECIPROCAL LATTICE VECTOR OF A SPE-
!                 CIAL COORDINATE SYSTEM ( IN UNITS OF 2 PI / A )
!                 TO CARTESIAN SYSTEM
!
!*******************************************************************
      LOGICAL          ORTHO
!
      COMMON/ORTH/     ORTHO
      COMMON/GENER/    BR1(3,3),BR2(3,3)
!---------------------------------------------------------------------
!
      PI=ACOS(-1.0D0)
      SQRT3=SQRT(3.D0)
      ALPHA(1)=ALPHA(1)*PI/180.0D0
      ALPHA(2)=ALPHA(2)*PI/180.0D0
      ALPHA(3)=ALPHA(3)*PI/180.0D0
      PIA(1)=2.D0*PI/AA
      PIA(2)=2.D0*PI/BB
      PIA(3)=2.D0*PI/CC
      IF(LATTIC(1:1).EQ.'H') GOTO 10
      IF(LATTIC(1:1).EQ.'S') GOTO 20
      IF(LATTIC(1:1).EQ.'P') GOTO 20
      IF(LATTIC(1:1).EQ.'F') GOTO 30
      IF(LATTIC(1:1).EQ.'B') GOTO 40
      IF(LATTIC(1:1).EQ.'C') GOTO 50
      IF(LATTIC(1:1).EQ.'R') GOTO 60
!
!        Error: wrong lattice, stop execution
!
         GOTO 900
!
!.....HEXAGONAL LATTICE
 10   CONTINUE
      BR1(1,1)=2.D0/SQRT3*PIA(1)
      BR1(1,2)=1.D0/SQRT3*PIA(1)
      BR1(1,3)=0.0D0
      BR1(2,1)=0.0D0
      BR1(2,2)=PIA(2)
      BR1(2,3)=0.0D0
      BR1(3,1)=0.0D0
      BR1(3,2)=0.0D0
      BR1(3,3)=PIA(3)
!
      BR2(1,1)=2.D0/SQRT3*PIA(1)
      BR2(1,2)=1.D0/SQRT3*PIA(1)
      BR2(1,3)=0.0D0
      BR2(2,1)=0.0D0
      BR2(2,2)=PIA(2)
      BR2(2,3)=0.0D0
      BR2(3,1)=0.0D0
      BR2(3,2)=0.0D0
      BR2(3,3)=PIA(3)
!
      RVFAC=2.D0/SQRT(3.D0)
      ORTHO=.FALSE.
      GOTO 100
!
!.....RHOMBOHEDRAL CASE
 60   BR1(1,1)=1.D0/SQRT(3.D0)*PIA(1)
      BR1(1,2)=1.D0/SQRT(3.D0)*PIA(1)
      BR1(1,3)=-2.d0/sqrt(3.d0)*PIA(1)
      BR1(2,1)=-1.0d0*PIA(2)
      BR1(2,2)=1.0d0*PIA(2)
      BR1(2,3)=0.0d0*PIA(2)
      BR1(3,1)=1.0d0*PIA(3)
      BR1(3,2)=1.0d0*PIA(3)
      BR1(3,3)=1.0d0*PIA(3)
!
      BR2(1,1)=1.D0/SQRT(3.D0)*PIA(1)
      BR2(1,2)=1.D0/SQRT(3.D0)*PIA(1)
      BR2(1,3)=-2.d0/sqrt(3.d0)*PIA(1)
      BR2(2,1)=-1.0d0*PIA(2)
      BR2(2,2)=1.0d0*PIA(2)
      BR2(2,3)=0.0d0*PIA(2)
      BR2(3,1)=1.0d0*PIA(3)
      BR2(3,2)=1.0d0*PIA(3)
      BR2(3,3)=1.0d0*PIA(3)
      RVFAC=6.D0/SQRT(3.D0)
      ORTHO=.FALSE.
      GOTO 100
!
!.....PRIMITIVE LATTICE
 20   continue
      SINBC=SIN(ALPHA(1))
      COSAB=COS(ALPHA(3))
      COSAC=COS(ALPHA(2))
      COSBC=COS(ALPHA(1))
      WURZEL=SQRT(SINBC**2-COSAC**2-COSAB**2+2*COSBC*COSAC*COSAB)
      BR2(1,1)= SINBC/WURZEL*PIA(1)
      BR2(1,2)= (-COSAB+COSBC*COSAC)/(SINBC*WURZEL)*PIA(2)
      BR2(1,3)= (COSBC*COSAB-COSAC)/(SINBC*WURZEL)*PIA(3)
      BR2(2,1)= 0.0
      BR2(2,2)= PIA(2)/SINBC
      BR2(2,3)= -PIA(3)*COSBC/SINBC
      BR2(3,1)= 0.0
      BR2(3,2)= 0.0
      BR2(3,3)= PIA(3)
!
      BR1(1,1)= SINBC/WURZEL*PIA(1)
      BR1(1,2)= (-COSAB+COSBC*COSAC)/(SINBC*WURZEL)*PIA(2)
      BR1(1,3)= (COSBC*COSAB-COSAC)/(SINBC*WURZEL)*PIA(3)
      BR1(2,1)= 0.0
      BR1(2,2)= PIA(2)/SINBC
      BR1(2,3)= -PIA(3)*COSBC/SINBC
      BR1(3,1)= 0.0
      BR1(3,2)= 0.0
      BR1(3,3)= PIA(3)
!
      RVFAC= 1.d0/WURZEL
      ORTHO=.TRUE.
      if(abs(alpha(1)-pi/2.d0).gt.0.0001) ortho=.false.
      if(abs(alpha(2)-pi/2.d0).gt.0.0001) ortho=.false.
      if(abs(alpha(3)-pi/2.d0).gt.0.0001) ortho=.false.
      GOTO 100
!
!      IF(ABS(ALPHA(3)-PI/2.0D0).GT.0.0001) then
!      write(*,*) '  gamma not equal 90'
!      GOTO 21
!      endif
!      IF(ABS(ALPHA(2)-PI/2.0D0).GT.0.0001) then
!      write(*,*) '  beta not equal 90'
!      GOTO 22
!      endif
!      BR1(1,1)=PIA(1)
!      BR1(1,2)=0.0D0
!      BR1(1,3)=0.0D0
!      BR1(2,1)=0.0D0
!      BR1(2,2)=PIA(2)
!      BR1(2,3)=0.0D0
!      BR1(3,1)=0.0D0
!      BR1(3,2)=0.0D0
!      BR1(3,3)=PIA(3)
!!
!      BR2(1,1)=PIA(1)
!      BR2(1,2)=0.0D0
!      BR2(1,3)=0.0D0
!      BR2(2,1)=0.0D0
!      BR2(2,2)=PIA(2)
!      BR2(2,3)=0.0D0
!      BR2(3,1)=0.0D0
!      BR2(3,2)=0.0D0
!      BR2(3,3)=PIA(3)
!!
!      RVFAC=1.D0
!      ORTHO=.TRUE.
!      GOTO 100
!
!.....FC LATTICE
 30   CONTINUE
      BR1(1,1)=PIA(1)
      BR1(1,2)=0.0D0
      BR1(1,3)=0.0D0
      BR1(2,1)=0.0D0
      BR1(2,2)=PIA(2)
      BR1(2,3)=0.0D0
      BR1(3,2)=0.0D0
      BR1(3,1)=0.0D0
      BR1(3,3)=PIA(3)
!
!     definitions according to column, rows convention for BR2
!
      BR2(1,1)=-PIA(1)
      BR2(1,2)= PIA(1)
      BR2(1,3)= PIA(1)
      BR2(2,1)= PIA(2)
      BR2(2,2)=-PIA(2)
      BR2(2,3)= PIA(2)
      BR2(3,1)= PIA(3)
      BR2(3,2)= PIA(3)
      BR2(3,3)=-PIA(3)
!
      RVFAC=4.D0
      ORTHO=.TRUE.
      GOTO 100
!
!.....BC LATTICE
 40   CONTINUE
      BR1(1,1)=PIA(1)
      BR1(1,2)=0.0D0
      BR1(1,3)=0.0D0
      BR1(2,1)=0.0D0
      BR1(2,2)=PIA(2)
      BR1(2,3)=0.0D0
      BR1(3,1)=0.0D0
      BR1(3,2)=0.0D0
      BR1(3,3)=PIA(3)
!
      BR2(1,1)= 0.0D0
      BR2(1,2)= PIA(1)
      BR2(1,3)= PIA(1)
      BR2(2,1)= PIA(2)
      BR2(2,2)= 0.0D0
      BR2(2,3)= PIA(2)
      BR2(3,1)= PIA(3)
      BR2(3,2)= PIA(3)
      BR2(3,3)= 0.0D0
!
      RVFAC=2.D0
      ORTHO=.TRUE.
      GOTO 100
!
 50   CONTINUE
      IF(LATTIC(2:3).EQ.'XZ') GOTO 51
      IF(LATTIC(2:3).EQ.'YZ') GOTO 52
!.....CXY LATTICE
      BR1(1,1)=PIA(1)
      BR1(1,2)=0.0D0
      BR1(1,3)=0.0D0
      BR1(2,1)=0.0D0
      BR1(2,2)=PIA(2)
      BR1(2,3)=0.0D0
      BR1(3,1)=0.0D0
      BR1(3,2)=0.0D0
      BR1(3,3)=PIA(3)
!
      BR2(1,1)= PIA(1)
      BR2(1,2)= PIA(1)
      BR2(1,3)= 0.0D0
      BR2(2,1)=-PIA(2)
      BR2(2,2)= PIA(2)
      BR2(2,3)= 0.0D0
      BR2(3,1)= 0.0D0
      BR2(3,2)= 0.0D0
      BR2(3,3)= PIA(3)
!
      RVFAC=2.D0
      ORTHO=.TRUE.
      GOTO 100
!
!.....CXZ CASE (CXZ LATTICE BUILD UP)
 51   CONTINUE
!.....CXZ ORTHOROMBIC CASE
      IF(ABS(ALPHA(3)-PI/2.0D0).LT.0.0001) then
         BR1(1,1)=PIA(1)
         BR1(1,2)=0.0D0
         BR1(1,3)=0.0D0
         BR1(2,1)=0.0D0
         BR1(2,2)=PIA(2)
         BR1(2,3)=0.0D0
         BR1(3,1)=0.0D0
         BR1(3,2)=0.0D0
         BR1(3,3)=PIA(3)
!
         BR2(1,1)= PIA(1)
         BR2(1,2)= 0.0
         BR2(1,3)= PIA(1)
         BR2(2,1)= 0.0
         BR2(2,2)= PIA(2)
         BR2(2,3)= 0.0
         BR2(3,1)=-PIA(3)
         BR2(3,2)= 0.0
         BR2(3,3)= PIA(3)
!
         RVFAC=2.0
         ORTHO=.TRUE.
         GOTO 100
      ELSE
!.....CXZ MONOCLINIC CASE
         write(*,*) '  gamma not equal 90'
         SINAB=SIN(ALPHA(3))
         COSAB=COS(ALPHA(3))
!
         BR1(1,1)= PIA(1)/SINAB
         BR1(1,2)= -PIA(2)*COSAB/SINAB
         BR1(1,3)= 0.0
         BR1(2,1)= 0.0
         BR1(2,2)= PIA(2)
         BR1(2,3)= 0.0
         BR1(3,1)= 0.0
         BR1(3,2)= 0.0
         BR1(3,3)= PIA(3)
!
         BR2(1,1)= PIA(1)/SINAB
         BR2(1,2)= -PIA(2)*COSAB/SINAB
         BR2(1,3)= PIA(1)/SINAB
         BR2(2,1)= 0.0
         BR2(2,2)= PIA(2)
         BR2(2,3)= 0.0
         BR2(3,1)=-PIA(3)
         BR2(3,2)= 0.0
         BR2(3,3)= PIA(3)
!
         RVFAC=2.0/SINAB
         ORTHO=.FALSE.
         GOTO 100
      ENDIF
!
!.....CYZ CASE (CYZ LATTICE BUILD UP)
 52   CONTINUE
      BR1(1,1)=PIA(1)
      BR1(1,2)=0.0D0
      BR1(1,3)=0.0D0
      BR1(2,1)=0.0D0
      BR1(2,2)=PIA(2)
      BR1(2,3)=0.0D0
      BR1(3,1)=0.0D0
      BR1(3,2)=0.0D0
      BR1(3,3)=PIA(3)
!
      BR2(1,1)= PIA(1)
      BR2(1,2)= 0.0
      BR2(1,3)= 0.0
      BR2(2,1)= 0.0
      BR2(2,2)= PIA(2)
      BR2(2,3)= PIA(2)
      BR2(3,1)= 0.0
      BR2(3,2)=-PIA(3)
      BR2(3,3)= PIA(3)
!
      RVFAC=2.0
      ORTHO=.TRUE.
      GOTO 100
!
!.....M CASE (MONOCLINIC LATTICE BUILD UP)
 21   CONTINUE
!
!     IF(ABS(ALPHA(2)-PI/2.).GT.0.0001) GOTO 61
!     GAMMA NE 90
      SINAB=SIN(ALPHA(3))
      COSAB=COS(ALPHA(3))
      BR1(1,1)= PIA(1)/SINAB
      BR1(1,2)= -PIA(2)*COSAB/SINAB
      BR1(1,3)= 0.0
      BR1(2,1)= 0.0
      BR1(2,2)= PIA(2)
      BR1(2,3)= 0.0
      BR1(3,1)= 0.0
      BR1(3,2)= 0.0
      BR1(3,3)= PIA(3)
!
      BR2(1,1)= PIA(1)/SINAB
      BR2(1,2)= -PIA(2)*COSAB/SINAB
      BR2(1,3)= 0.0
      BR2(2,1)= 0.0
      BR2(2,2)= PIA(2)
      BR2(2,3)= 0.0
      BR2(3,1)= 0.0
      BR2(3,2)= 0.0
      BR2(3,3)= PIA(3)
!
      RVFAC=1.d0/SINAB
      ORTHO=.FALSE.
      GOTO 100
!
!.....M CASE (MONOCLINIC LATTICE BUILD UP)
!     BETA NE 90
 22   CONTINUE
      SINAC=SIN(ALPHA(2))
      COSAC=COS(ALPHA(2))
      BR2(1,1)= PIA(1)/SINAC
      BR2(1,2)= 0.0
      BR2(1,3)= -PIA(3)*COSAC/SINAC
      BR2(2,1)= 0.0
      BR2(2,2)= PIA(2)
      BR2(2,3)= 0.0
      BR2(3,1)= 0.0
      BR2(3,2)= 0.0
      BR2(3,3)= PIA(3)
!
      BR1(1,1)= PIA(1)/SINAC
      BR1(1,2)= 0.0
      BR1(1,3)= -PIA(3)*COSAC/SINAC
      BR1(2,1)= 0.0
      BR1(2,2)= PIA(2)
      BR1(2,3)= 0.0
      BR1(3,1)= 0.0
      BR1(3,2)= 0.0
      BR1(3,3)= PIA(3)
!
      RVFAC=1.d0/SINAC
      ORTHO=.FALSE.
      GOTO 100
!
!
!.....DEFINE VOLUME OF UNIT CELL
 100  CONTINUE
      VOL=AA*BB*CC/RVFAC
!      CALL ROTDEF
      CALL ROTDEF(iz,tau,iord,nat,pos,ndif,rotij,tauij,mult(1),lattic)

      RETURN
  900 STOP 'LATGEN - Error'
      END
!


      real function hdepth(t2,x)
c
c     + + + PURPOSE + + +
c     Finds depth H on an overland flow element by solving the
c     partial differential equation:
c
c       h1+alpha*m*h**(m-1)*h2=s ,t and x non-negative    (1)
c
c    where:
c
c      h1    =  partial of h with respect to t,
c      h2    =  partial of h with respect to x,
c      alpha =  chezy depth-discharge coefficient,
c      m     =  chezy depth-discharge exponent,
c      s     =  step function with ns initial non-zero steps that
c               is zero after the last step, and h is zero when
c               either t or x is zero.
c
c XXX -- I cannot determine the structure of the equation being
c        discussed, from these comments. -- CRM 6/3/91.
c    Let phi(t) be psi(t,0), where psi(t,u) is defined to be the
c    integral from u to t with respect to l of the m-1th power of
c    ***the integral of s from time u to l.***
c XXX -- With respect to what variable?  S? TIME? -- CRM 6/3/91.
c    Psi(t,u) strictly decreases from
c    phi(t) to 0 for fixed t and for u between 0 and ***am1n(t,tstar)***
c XXX -- What does this mean? -- CRM 6/3/91.
c    (s>0 before tstar,s=0 after);  let psiinv(t,-) be the inverse
c    of psi(t,-). Then the general solution to (1) is given by:
c
c    for x >= x1, h(t,x)=integral of s from 0 to t             (2)
c    for x <= x1, h(t,x)=integral of s from psiinv(t,x2) to t  (3)
c
c    where x1 = alpha*m*phi(t) and x2 = x/(alpha*m).
c
c    Subroutine phi(-) computes phi, subroutine psiinv(t,-)
c    computes the inverse of psi(t,-), and subroutine sint(t)
c    computes the integral of s from 0 to t.
c
c
c     Called from HDRIVE
c     Author(s): Shirley, Stone
c     Reference in User Guide:
c
c     Changes:
c          1) SAVE, which saves all applicable local variables,
c             deleted.
c          2) Common block PASS never used.  It was de-referenced.
c          3) No parameters were used.  Their include files were
c             dereferenced.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/24/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real t2, x
c
c     + + + ARGUMENT DEFINITIONS + + +
c     t2     - current time
c     x      - length of equivalent plane
c
c     + + + COMMON BLOCKS + + +
c
      include 'cconsts.inc'
c       read: a1
c
c     + + + LOCAL VARIABLES + + +
      real xx
c
c     + + + LOCAL DEFINITIONS + + +
c     xx     - X/A1
c
c     + + + FUNCTION DECLARATIONS + + +
c     real phi, sint, psiinv
      real phi, psiinv
      double precision sint
c
c     + + + END SPECIFICATIONS + + +
c
      xx = x / a1
c
      if (xx.lt.phi(t2)) then
        hdepth = sint(t2) - sint(psiinv(t2,xx))
      else
        hdepth = sint(t2)
      end if
c
c     Following line inserted 12/11/92 to prevent hdepth from becoming
c     a negative number for test data set 45     dcf
c
      if (hdepth.lt.0.0) hdepth = 0.0
c
      return
      end