module multigrid
  !====================================================================
  ! Main module for Multigrid method
  ! Marline I. Silva - Sept 2014
  !=====================================================================
  !Global constants
  use constants, only: &
       datadir, &
       i4, &
       pardir, &
       r4, &
       r8

  !Data structures
  use datastruct, only:  &
       grid_structure, &
       scalar_field

  use datastructmult, only: &
       interpolable_meshes, &
       multimesh, &
       multisol

  !Spherical mesh routines
  use smeshpack, only: &
       cart2sph, &
       error_norm_2, &
       error_norm_max, &
       getparameters, &
       getunit, &
       meshbuild

  !Interpolation pack
  use interpack, only: &
       plot_scalarfield

  implicit none

contains

  !=====================================================================
  !                     functions for tests
  !=====================================================================

  function func(p)
    real (r8)::p(1:3)
    real(r8)::func
    real(r8)::lat
    real(r8)::lon
    real(r8)::m
    real(r8)::n

    m=1
    n=1

    !TESTE 1
    !func=(1+2*p(1)+3*p(2)+4*p(3))/6._r8

    !TESTE 2
    !func = (exp(p(1))+ 2*(exp(p(2)+p(3))))/10

    call cart2sph (p(1), p(2), p(3), lon, lat)
    !TESTE 3
    !func=((dcos(lat))**3)*((dsin(lon))**2)

    !TESTE 4
    func=dcos(m*lon)*dcos(n*lat)**4

    !TESTE 5
    !func=dsin(lat)

    !TESTE 6
    !func=dsin(3*lon)*((dcos(3*lat)))**4

    !TESTE 7
    !func=-(1/2)*((dcos(lat))**3)*dcos(3*lon)

    !TESTE 8
    !func=dcos(lat)*dcos(lon)

    return
  end function func

  !----------------------------------------------------------------
  !     Exact Laplacian of the preceding functions
  !----------------------------------------------------------------

  function lap_ext(p)
    real (r8)::p(1:3)
    real (r8):: lat
    real (r8)::lon
    real (r8)::m
    real (r8)::n
    real(r8)::lap_ext

    m=1
    n=1

    !Converte para coordenadas esféricas
    call cart2sph (p(1), p(2), p(3), lon, lat)

    !TESTE 1
    !lap_ext= (((3*dsin(lon)+2*dcos(lon))*(1-dcos(lat)**2+dsin(lat)**2))/6._r8*dcos(lat)) &
    !- 4._r8*dsin(lat)/3._r8

    !TESTE 2
    !lap_ext=(1.0_r8/10.0_r8*dcos(lat))*(2.0_r8*exp(dcos(lat)*dsin(lon)+dsin(lat))*(dcos(lat) &
    !*((dcos(lon))**2)-dsin(lon))+exp(dcos(lat)*dcos(lon))*(dcos(lat)*((dsin(lon))**2) &
    !-dcos(lon))-2.0_r8*dsin(lat)*exp(dcos(lat)*dsin(lon)+dsin(lat))*(dcos(lat)-dsin(lon) &
    !*dsin(lat))+dcos(lon)*((dsin(lat))**2)*exp(dcos(lat)*dcos(lon))) +0.1*(exp(dcos(lat) &
    !*dcos(lon))*(((dcos(lon))**2)*((dsin(lat))**2)-dcos(lon)*dcos(lat))+2.0_r8*exp(dcos(lat) &
    !*dsin(lon)+dsin(lat))*((dcos(lat)-dsin(lon)*(dsin(lat)))**2)-(dsin(lon)*dcos(lat) &
    !+dsin(lat)))

    !TESTE 3 (-lap u + u=f)
    !lap_ext=-dcos(lat)*(-5.0_r8*dcos(lon)**2+7.0_r8-12.0_r8*dcos(lat)**2*dsin(lon)**2)  &
    !    +((dcos(lat))**3)*((dsin(lon))**2)

    !-------------------------------------------------------------
    !TESTE 4
    ! lap_ext = -dcos(m*lon)*dcos(n*lat)**2 * (m**2*dcos(n * lat) **2 &
    !    - 4._r8 * dsin(lat) * dcos(n*lat)*dsin(n*lat)*n*dcos(lat) &
    !  -12._r8 * dcos(lat)**2*n**2+16._r8*dcos(lat)**2 *dcos(n* lat)**2* n**2)&
    !/dcos(lat)**2

    !TESTE 4 (-lap u +u =f)
    lap_ext = -(-dcos(m*lon)*dcos(n*lat)**2 * (m**2*dcos(n * lat) **2 &
         - 4._r8 * dsin(lat) * dcos(n*lat)*dsin(n*lat)*n*dcos(lat) &
         -12._r8 * dcos(lat)**2*n**2+16._r8*dcos(lat)**2 *dcos(n* lat)**2* n**2)&
         /dcos(lat)**2)   +  dcos(m*lon)*dcos(n*lat)**4

    !------------------------------------------------------------
    !TESTE 5
    !lap_ext=-2*dsin(lat)

    !TESTE 5 (-lap u+u=f)
    !lap_ext=2*dsin(lat)+dsin(lat)
    !----------------------------------------------------

    !TESTE 6
    !lap_ext=(-9*dsin(3*lon)*((dcos(3*lat))**4)/dcos(lat)**2) &
    ! -6*dsin(3*lon)*(dcos(lat))**2*(1-2*dcos(2*lat))**2*(2*dcos(2*lat) &
    !-2*dcos(4*lat)+13*dcos(6*lat)-7)

    !TESTE 7
    !lap_ext=0!6*(dcos(lat)**3)*(dcos(3*lon))

    !TESTE 8
    !lap_ext=0.0

    return
  end function lap_ext

  !------------------------------------------------------------
  !    Initial condition
  !------------------------------------------------------------

  function inic(p)
    real (r8)::p(1:3)
    real(r8)::inic
    real(r8)::lat
    real(r8)::lon

    call cart2sph (p(1), p(2), p(3), lon, lat)

    inic=dsin(35*lat)+(dcos(10*lon))

    return
  end function inic

  subroutine mesh_generation(meshvet)
    !--------------------------------------------------------------------
    !  MESh_GENERATION
    !       Construction of meshes
    !--------------------------------------------------------------------

    !List of meshes
    type(multimesh)::meshvet

    !Couter
    integer(i4)::i

    !Finer grid level
    integer(r4)::levelmf

    character (len=300):: buffer    !Buffer for strings
    character(len=60)::filename     !Parameters file
    integer::fileunit               !Unit for input file

    !Standard mesh parameters file
    filename=trim(pardir)//"multigrid.par"
    call getunit(fileunit)

    !A parameters file already must exist
    open(fileunit,file=filename,status='old')

    read(fileunit,*)  buffer
    read(fileunit,*)  buffer
    read(fileunit,*)  levelmf

    close(fileunit)

    !Allocate meshes
    allocate(meshvet%mesh(0:levelmf))

    do i=0,levelmf
       !Get parameters from file mesh.par
       call getparameters(meshvet%mesh(i))

       if(trim(meshvet%mesh(i)%kind)=="icos")then
          !Overwrite number of nodes
          meshvet%mesh(i)%nv=10*(2**(2*(i)))+2

       elseif(trim(meshvet%mesh(i)%kind)=="read")then
          write(meshvet%mesh(i)%name(10:10),'(i1)')i
       end if
       print*, i,meshvet%mesh(i)%name

       !meshbuild from module smeshpack
       call meshbuild(meshvet%mesh(i))

    enddo

  end subroutine mesh_generation

  subroutine relation_meshes(meshvet)
    !----------------------------------------------------------
    !  RELATION_MESHES
    !
    !This subroutine relates cells of two consecutive levels
    !----------------------------------------------------------

    !List of meshes
    type(multimesh)::meshvet

    !meshe
    type(grid_structure)::mesh

    !grid level
    integer(i4)::niv

    !finer grid level
    integer(i4)::levelmf

    !levelmf-1
    integer(i4)::level

    !Counter
    integer(i4)::i
    integer(i4)::j
    integer(i4)::k

    !Index of fine mesh
    integer(i4)::indcel

    !The two endpoints of the edge of the triangle
    integer(i4)::i1
    integer(i4)::i2

    !neighboring cells the two endpoints of
    !the edge of the triangle
    integer(i4)::l1
    integer(i4)::l2

    character (len=300):: buffer  !Buffer for strings
    character(len=60)::filename   !Parameters file
    integer::fileunit             !Unit for input file

    !Standard mesh parameters file
    filename=trim(pardir)//"multigrid.par"
    call getunit(fileunit)
    !A parameters file must exist
    open(fileunit,file=filename,status='old')

    read(fileunit,*)  buffer
    read(fileunit,*)  buffer
    read(fileunit,*)  levelmf
    close(fileunit)

    level=levelmf-1

    !fine mesh
    allocate(meshvet%mf(0:levelmf))

    !coarse mesh
    allocate(meshvet%mg(0:levelmf))

    mesh=meshvet%mesh(levelmf)
    do i=0, levelmf-1
       allocate(meshvet%mf(i+1)%indmf(1:mesh%ne))
       allocate(meshvet%mf(i+1)%cf(1:mesh%nv))
       allocate(meshvet%mg(i)%cng(1:mesh%nv))
       allocate(meshvet%mg(i)%cg(1:mesh%nv))
    enddo

    !For each grid level
    do niv=0,levelmf-1
       mesh=meshvet%mesh(niv)

       !for each edge
       do i=1,mesh%ne

          !Two endpoints of the edge
          i1=mesh%ed(i)%v(1)
          i2=mesh%ed(i)%v(2)

          !for each neighbor of i1
          do k=1,mesh%v(i1)%nnb

             l1=meshvet%mesh(niv+1)%v(i1)%nb(k)

             !for each neighbor of i2
             do j=1, mesh%v(i2)%nnb

                l2=meshvet%mesh(niv+1)%v(i2)%nb(j)

                if(l1==l2) then

                   !index of fine cell between two neighboring cells
                   indcel=l2

                   meshvet%mf(niv+1)%indmf(i)%celm=indcel
                   meshvet%mf(niv+1)%indmf(i)%cel(1)=i1
                   meshvet%mf(niv+1)%indmf(i)%cel(2)=i2

                endif
             enddo
          enddo
       enddo
    enddo

    do niv=0,levelmf-1

       !for all cells in the coarse level
       do i=1, meshvet%mesh(niv)%nv

          meshvet%mg(niv)%cg(i)=i
       enddo

       !Given a cell in the fine mesh provides index in the coarse mesh

       !for all cells in the fine level
       do k=1, meshvet%mesh(niv+1)%nv
          if (k<=meshvet%mesh(niv)%nv) then
             meshvet%mf(niv+1)%cf(k)%cmg=meshvet%mg(niv)%cg(k)

          else if (k>meshvet%mesh(niv)%nv) then

             EXIT
          endif
       enddo

       !Given a cell in the coarse mesh provides index in the coarse fine
       do k=1, meshvet%mesh(niv)%nv
          meshvet%mg(niv)%cng(k)%cmf=meshvet%mg(niv)%cg(k)
       enddo
    enddo

  end subroutine relation_meshes

  subroutine laplacian(meshvet)
    !-------------------------------------------------------
    !LAPLACIAN
    !Test for laplacian for each point of the mesh
    ! For this test we use the subroutine "lap_cell"
    !-------------------------------------------------------
    !List of meshes
    type(multimesh), intent(in) :: meshvet
    !Mesh
    type(grid_structure)::mesh
    !Exact value of the laplacian on each grid point
    type(scalar_field)::lap_exact
    !Approximate value of the laplacian on each grid point
    type(scalar_field)::lap_ap
    !Function you want to calculate the Laplacian
    type(scalar_field)::fcalc
    !Error between the exact value and the approximate value of the Laplacian
    type(scalar_field)::erro

    integer(i4)::levelmf  !Finer grid level
    integer::niv          !Grid level
    integer::i            !Couter

    !Norm errors on each grid level
    real(r8),allocatable::nrm2(:)
    real(r8),allocatable::nrmmax(:)

    character (len=300):: buffer  !Buffer for strings
    character(len=60)::filename   !Parameters file
    integer::fileunit             !Unit for input file
    integer::iunit                !Aux variable

    !Standard mesh parameters file
    filename=trim(pardir)//"multigrid.par"
    call getunit(fileunit)

    !A parameters file must exist
    open(fileunit,file=filename,status='old')

    read(fileunit,*)  buffer
    read(fileunit,*)  buffer
    read(fileunit,*)  levelmf
    close(fileunit)

    !Allocate vectors
    allocate(nrm2(0:levelmf))
    allocate(nrmmax(0:levelmf))

    !For each grid level
    do niv=0,levelmf

       mesh=meshvet%mesh(niv)

       !Allocate exact value
       allocate(lap_exact%f(1:mesh%nv))

       !Allocate approximate value
       allocate(lap_ap%f(1:mesh%nv))

       !Allocate error
       allocate(erro%f(1:mesh%nv))

       !Allocation function to test
       allocate(fcalc%f(1:mesh%nv))

       !Calculate exact value of the laplacian on each grid point
       !Calculate function you want to calculate the Laplacian
       do i=1,mesh%nv
          lap_exact%f(i)=lap_ext(mesh%v(i)%p)
          fcalc%f(i)=func(mesh%v(i)%p)
       enddo

       !Calculate approximate value of the laplacian on each grid point
       call lap_cell(mesh,lap_ap,fcalc)

       !Calculate errors in laplacian estimatives
       nrm2(niv)=error_norm_2(lap_exact%f,lap_ap%f,mesh%nv)
       nrmmax(niv)=error_norm_max(lap_exact%f,lap_ap%f,mesh%nv)

       !Calculate error in laplacian estimative on each grid point
       do i=1,mesh%nv
          erro%f(i)=abs(lap_ap%f(i)-lap_exact%f(i))
       enddo

       !PLOTS

       !erro%name="ERRO_AP_LAP"
       !call plot_scalarfield(erro,meshvet%mesh(niv))

       !Deallocate
       deallocate(lap_exact%f,lap_ap%f,fcalc%f,erro%f)

    enddo

    !Write values on file
    filename=trim(datadir)//"NRM_ERRO_LAP.txt"

    call getunit ( iunit )
    open(iunit, file=filename, status='replace')
    write(iunit,*) "erro_nrm2, erro_nrm_max"
    do i=0,levelmf
       write(iunit,"(2f16.8)") nrm2(i),nrmmax(i)
    enddo
    close (iunit)

    !Deallocate
    deallocate(nrm2,nrmmax)

    return
  end subroutine laplacian

  subroutine relaxac(meshvet)
    !--------------------------------------------------------
    !RELAXAC
    !
    ! Test for relaxation of the problem using the
    !  method of Jacobi.
    ! For this test we use the subroutine "relaxac_mult_cell"
    !---------------------------------------------------------

    type(multimesh)::meshvet                 !List of meshes
    type(grid_structure)::mesh               !Mesh
    type(scalar_field)::fexact      !Exact value of the function on each grid point
    type(scalar_field)::fap         !Approximate value of the function on each grid point
    type(scalar_field)::resid       !Residue
    type(scalar_field)::faperro     !Error between the exact value and the approximate value of the function
    type(scalar_field)::g           !Independent term of equation
    type(scalar_field)::lap_ap      !Approximate value of the laplacian on each grid point
    type(interpolable_meshes)::fap_aux       !Auxiliary vector

    !Couter
    integer::i

    integer(i4)::levelmf  !Finer grid level
    integer::niv          !Grid level
    integer(i4)::numit    !Maximum number of iterations

    real (r8):: w         !Relaxation parameter
    real (r8)::nrm_res    !Norm residue
    real (r8)::TOL        !Tolerance

    !Norm errors on each grid level
    real(r8),allocatable::nrm2(:)
    real(r8),allocatable::nrmmax(:)
    real(r8),allocatable::nrmres(:)

    !A parameters file must exist
    character(len=60)::filename
    character (len=300):: buffer
    integer::fileunit
    integer::iunit

    !Standard mesh parameters file
    filename=trim(pardir)//"multigrid.par"
    call getunit(fileunit)
    !A parameters file must exist
    open(fileunit,file=filename,status='old')

    read(fileunit,*)  buffer
    read(fileunit,*)  buffer
    read(fileunit,*)  levelmf
    read(fileunit,*)  buffer
    read(fileunit,*)  w
    close(fileunit)

    !Allocate vectors
    allocate(nrm2(0:levelmf))
    allocate(nrmmax(0:levelmf))
    allocate(nrmres(0:levelmf))

    TOL=0.00000001             !Tolerance
    nrm_res=100                !Norm residue
    numit=4                   !Maximum number of iterations

    !For each grid level
    do niv=0,levelmf

       mesh=meshvet%mesh(niv)

       !Approximate value of the function on each grid point
       allocate(fap%f(1:mesh%nv))

       !Exact value of the function on each grid point
       allocate(fexact%f(1:mesh%nv))

       !Residue
       allocate(resid%f(1:mesh%nv))

       !Independent term of equation
       allocate(g%f(1:mesh%nv))

       !Auxiliary vector
       allocate(fap_aux%f(1:mesh%nv))

       !Approximate value of the laplacian on each grid point
       allocate(lap_ap%f(1:mesh%nv))

       !Error between the exact value and the approximate value of the function
       allocate(faperro%f(1:mesh%nv))

       !For each grid point
       do i=1,mesh%nv
          fap%f(i)=0!inic(mesh%v(i)%p)                        !initial condition
          !initial condition
          fexact%f(i)=func(mesh%v(i)%p)    !Exact value
          g%f(i)=lap_ext(mesh%v(i)%p)      !Independent term
       enddo

       !Calculate approximate value of the function on each grid point
       call relaxac_mult_cell_GS(mesh,g,fap,numit,w)

       !Calculation of the residue after each iteration
       call lap_cell(mesh,lap_ap,fap)
       resid%f=g%f-lap_ap%f

       !Norm residue
       nrm_res=error_nrm_max(resid%f,mesh%nv)

       !if(nrm_res<=TOL) then
       !  print*, 'Tolerance was achieved'

       !Norm errors on each grid level
       ! nrm2(niv)=error_norm_2(fexact%f,fap%f,mesh%nv)
       !nrmmax(niv)=error_norm_max(fexact%f,fap%f,mesh%nv)
       !nrmres(niv)=error_nrm_max(resid%f,mesh%nv)
       ! print*,nrm2(niv),nrmmax(niv),nrmres(niv)

       !EXIT
       !endif

       !Calculate error in funtion estimative on each grid point
       !do i=1,meshvet%mesh(niv)%nv
       !  faperro%f(i)=abs(fap%f(i)-fexact%f(i))
       !enddo

       !PLOTS
       !faperro%name="ERRO_RELAXAC"
       !call plot_scalarfield(faperro,meshvet%mesh(niv))

       !Norm errors on each grid level

       nrm2(niv)=error_norm_2(fexact%f,fap%f,mesh%nv)
       nrmmax(niv)=error_norm_max(fexact%f,fap%f,mesh%nv)
       nrmres(niv)=nrm_res

       !Deallocate
       deallocate(fap%f,fexact%f,faperro%f,g%f,fap_aux%f,resid%f,lap_ap%f)
    enddo

    !Write values on file
    filename=trim(datadir)//"NRM_ERRO_RELAXAC.txt"
    call getunit ( iunit )
    open(iunit, file=filename, status='replace')
    write(iunit,*) "nrm2, nrmmax"
    do niv=0,levelmf
       write(iunit,"(3f32.16)") nrm2(niv), nrmmax(niv)
    enddo
    close (iunit)

    !Deallocate
    deallocate(nrm2,nrmmax,nrmres)

    return
  end subroutine relaxac

  subroutine interpol_linear(meshvet)
    !--------------------------------------------------------------------
    !  INTERPOL_LINEAR
    ! Test for interpolation linear.
    ! For this test we use the subroutine "interpol_cell"
    !-------------------------------------------------------------------

    !List of meshes
    type(multimesh),intent(in)::meshvet
    !Exact value of the function on each grid point
    type(scalar_field)::fexact
    !Interpolate value
    type(scalar_field)::fap_interpol
    !Auxiliar scalar field for interpolation
    type(scalar_field)::fap
    !Error between the exact value and the interpolate value of the function
    type(scalar_field)::faperro

    !Couter
    integer(i4)::i

    integer(i4)::niv                  !Grid level
    integer(i4)::levelmf              !Finer grid level

    !Norm errors on each grid level
    real(r8),allocatable::nrm2(:)
    real(r8),allocatable::nrmmax(:)

    !A parameters file must exist
    character(len=60)::filename
    character (len=300):: buffer
    integer::fileunit
    integer::iunit

    !Standard mesh parameters file
    filename=trim(pardir)//"multigrid.par"
    call getunit(fileunit)
    !A parameters file must exist
    open(fileunit,file=filename,status='old')

    read(fileunit,*)  buffer
    read(fileunit,*)  buffer
    read(fileunit,*)  levelmf
    close(fileunit)

    !Allocate vectors
    allocate(nrm2(0:levelmf))
    allocate(nrmmax(0:levelmf))

    !For each grid level
    do niv=0,levelmf-1

       !Allocate
       allocate(fexact%f(1:meshvet%mesh(niv+1)%nv))
       allocate(fap_interpol%f(1:meshvet%mesh(niv+1)%nv))
       allocate(faperro%f(1:meshvet%mesh(niv+1)%nv))
       allocate(fap%f(1:meshvet%mesh(niv+1)%nv))

       !For each grid point
       do i=1, meshvet%mesh(niv)%nv
          !Exact value function
          fap%f(i)=func(meshvet%mesh(niv)%v(i)%p)
       enddo

       !Calculate interpolate value
       call interpol_cell(meshvet,niv,fap,fap_interpol)

       !For each grid point
       do i=1, meshvet%mesh(niv+1)%nv
          !Exact value
          fexact%f(i)=func(meshvet%mesh(niv+1)%v(i)%p)

          !Error between the exact value and the interpolate value
          faperro%f(i)=abs(fap%f(i)-fexact%f(i))
       enddo

       !Norm errors on each grid level
       nrm2(niv)=error_norm_2(fap_interpol%f,fexact%f,meshvet%mesh(niv+1)%nv)
       nrmmax(niv)=error_norm_max(fap_interpol%f,fexact%f,meshvet%mesh(niv+1)%nv)

       !PLOTS
       !faperro%name="PLOT_ERRO_INTERPOL"
       !call plot_scalarfield(faperro,meshvet%mesh(niv+1))

       !Deallocate
       deallocate(fap%f,fexact%f,faperro%f,fap_interpol%f)
    enddo

    !Write values on file
    filename=trim(datadir)//"NRM_ERRO_INTERPOL.txt"
    call getunit ( iunit )
    open(iunit, file=filename, status='replace')
    write(iunit,*) "erro_nrm2, erro_nrm_max"
    do i=0,levelmf-1
       write(iunit,"(2f16.8)") nrm2(i),nrmmax(i)
    enddo
    close (iunit)
  end subroutine interpol_linear

  subroutine multigrid_solver(meshvet)
    !=============================================================================
    ! multigrid_solver
    !
    ! For this multigrid solver we use the subroutines
    !
    ! "lap_cell" - for calculate laplacian
    ! "relaxac_mult_cell" - for relaxation
    ! "interpol_cell" - for interpolation
    ! "transfer_res" - for transfer residue
    ! "decomLU" - for resolution system coarse mesh
    !
    !=============================================================================
    type(multimesh)::meshvet                     !List of meshes
    type(grid_structure)::mesh                   !mesh
    type(multisol)::meshsol                      !approximate solution in each level
    type(interpolable_meshes)::fap_aux           !Auxiliary vector
    type(scalar_field)::fap             !Approximate value of the function on each grid point
    type(scalar_field)::residuoa        !Residue before the cycle
    type(scalar_field):: residuod       !Residue after the cycle
    type(scalar_field)::g               !Independent term of equation
    type(scalar_field)::lapc            !Approximate value of the laplacian on each grid point
    type(scalar_field)::fap_interpol    !Interpolate value
    type(scalar_field)::fap_exact       !Exact function
    type(scalar_field)::error           !error=fap_exact-fap

    integer::niv           !Grid level
    integer(i4)::levelmf   !Finer grid level

    !counters
    integer::i
    integer::j
    integer::k

    integer::contv       !Couter cycle
    integer(i4)::numvc   !Number cycle

    !number relaxation before the cycle
    integer(i4)::n1

    !number relaxation after the cycle
    integer(i4)::n2

    !gamma=1 v-ciclo/ gamma=2 W-ciclo
    integer::gamma

    !parameter of relaxation
    real(r8)::w

    !nrm residue before the cycle
    real(r8)::nrmg1

    !nrm residue after the cycle
    real(r8)::nrmg2

    !Smoothness factor - (nrmg2/nrmg1)**(1./(n1+n2))
    real(r8)::sfact

    real (r8)::Lchx      !Distance between two neighboring
    real(r8)::ledhx      !Edge length
    real(r8)::laptmp

    !Auxiliary vector
    real(r8), allocatable::c(:)

    !A parameters file must exist
    character (len=300):: buffer
    character(len=60)::filename
    integer::fileunit

    !Standard mesh parameters file
    filename=trim(pardir)//"multigrid.par"
    call getunit(fileunit)
    !A parameters file must exist
    open(fileunit,file=filename,status='old')

    read(fileunit,*)  buffer
    read(fileunit,*)  buffer
    read(fileunit,*)  levelmf
    read(fileunit,*)  buffer
    read(fileunit,*)  w
    read(fileunit,*)  buffer
    read(fileunit,*)  numvc
    read(fileunit,*)  buffer
    read(fileunit,*)  n1
    read(fileunit,*)  n2
    close(fileunit)

    allocate(meshsol%solm(0:levelmf))
    allocate(c(0:levelmf))

    do niv=0,levelmf

       !mesh level "niv"
       mesh=meshvet%mesh(niv)

       !value function each grid level
       allocate(meshsol%solm(niv)%valf(1:mesh%nv))

       !value residue each grid level
       allocate(meshsol%solm(niv)%resf(1:mesh%nv))
    enddo

    mesh=meshvet%mesh(levelmf)

    allocate(lapc%f(1:mesh%nv))
    allocate(g%f(1:mesh%nv))
    allocate(fap%f(1:mesh%nv))
    allocate(fap_aux%f(1:mesh%nv))
    allocate(fap_interpol%f(1:mesh%nv))
    allocate(fap_exact%f(1:mesh%nv))
    allocate(error%f(1:mesh%nv))

    allocate(residuoa%f(1:mesh%nv))
    allocate(residuod%f(1:mesh%nv))

    do i=1,mesh%nv

       !Independent term
       g%f(i)=lap_ext(mesh%v(i)%p)

       !initial condition
       fap%f(i)=inic(mesh%v(i)%p)

       !Exact value
       fap_exact%f(i)=func(mesh%v(i)%p)

    enddo

    !--------------------------------------------------
    !PLOTS

    !Exact function
    !fap_exact%name="PLOT_FUNC_EXACT"
    !call plot_scalarfield(fap_exact,meshvet%mesh(levelmf))

    !inicial condition
    !fap%name="PLOT_INIC_COND"
    !call plot_scalarfield(fap,meshvet%mesh(levelmf))
    !-------------------------------------------------------

    gamma=1 !gamma=1 vciclo,  gamma=2 wciclo
    contv=1

    !Begin V-ciclo

10  do while(contv<=numvc)

       do  k=0,levelmf
          c(k)=0
       enddo

       k=levelmf

       mesh=meshvet%mesh(levelmf)

       !residue before the cycle
       call lap_cell(mesh,lapc,fap)

       !For each grid point
       do i=1,mesh%nv
          residuoa%f(i)=g%f(i)-lapc%f(i)
       enddo

       !----------------------------------------------------------------------
       !                (I) relax the values in the fine mesh
       !----------------------------------------------------------------------
20     mesh=meshvet%mesh(k)

       !call relaxac_mult_cell(mesh,g,fap,fap_aux,n1,w)
       call relaxac_mult_cell_GS(mesh,g,fap,n1,w)

       c(k)=c(k)+1

       !Save the solution to use later
       meshsol%solm(k)%valf=fap%f

       !-----------------------------------------------------------------------
       !            (II) calculation of the residue
       !-----------------------------------------------------------------------

       call lap_cell(mesh,lapc,fap)
       do i=1,mesh%nv
          g%f(i)=g%f(i)-lapc%f(i)
       enddo

       !------------------------------------------------------------------------
       !  (III) Transference of the residue to the coarser grid
       !
       !Restriction by:
       !Guohua Zhou and Scoot R. Fulton, Fourier analysis of
       !multigrid methods on hexagonal grids,
       !Society for Industrial and Applied Mathematics. (31):1518-1538, 2009.
       !------------------------------------------------------------------------

       call transfer_res(meshvet,g,k)

       k=k-1

       mesh=meshvet%mesh(k)
       do i=1,mesh%nv
          meshsol%solm(k)%resf(i)=g%f(i)
       enddo

       if (k.NE.0) then
          do i=1,mesh%nv
             fap%f(i)=0.0
          enddo

          goto 20 !relax the values
       endif

       !--------------------------------------------------------
       !    (IV)   solve the problem in the coarse grid
       !-------------------------------------------------------

       ! matrix problem in coarser level of resolution

       if(k.EQ.0) then

          do i=1,mesh%nv
             fap%f(i)=0.0
          enddo

          !call relaxac_mult_cell(mesh,g,fap,fap_aux,15,w)
          call relaxac_mult_cell_GS(mesh,g,fap,15,w)
       endif

       !---------------------------------------------------------------------
       !            (V)nterpolate the correction for fine mesh
       !                 and add the solution obtained in the step I
       !---------------------------------------------------------------------

40     call interpol_cell(meshvet,k,fap,fap_interpol)

       k=k+1
       mesh=meshvet%mesh(k)
       do i=1,mesh%nv
          fap%f(i)=fap_interpol%f(i)+meshsol%solm(k)%valf(i)
       enddo

       !---------------------------------------------------------------------
       !             (VI) apply relaxations in the previous solution
       !---------------------------------------------------------------------

       if (k==levelmf) then
          do i=1,mesh%nv
             g%f(i)=lap_ext(mesh%v(i)%p)
          enddo
       else
          do i=1,mesh%nv
             g%f(i)=meshsol%solm(k)%resf(i)
          enddo
       endif

       !call relaxac_mult_cell(mesh,g,fap,fap_aux,n2,w)
       call relaxac_mult_cell_GS(mesh,g,fap,n2, w)

       if(k.NE.levelmf.AND.c(k)==gamma) then
          c(k)=0
          goto 40

       else if (k.NE.levelmf.AND.c(k).NE.gamma) then
          goto 20
       else if  (k.EQ.levelmf) then
          contv=contv+1

          !residue after the cycle V-CICLO
          call lap_cell(mesh,lapc,fap)

          !For each grid point
          do i=1,mesh%nv
             residuod%f(i)=g%f(i)-lapc%f(i)
          enddo

          !calculation of the convergence factor
          nrmg1=error_norm_g(residuoa%f,mesh%nv)
          nrmg2=error_norm_g(residuod%f,mesh%nv)

          sfact=(nrmg2/nrmg1)

          print*,'Ciclo',contv-1
          print*, 'convergence factor:', sfact

       endif

       if(contv==numvc) then
          goto 60
       endif

       goto 10

    enddo

60  print*,''

    do i=1,meshvet%mesh(levelmf)%nv
       error%f(i)=abs(fap%f(i)-fap_exact%f(i))
    enddo

    !PLOTS
    !Approximate solution
    !fap%name="PLOT_SOL"
    !call plot_scalarfield(fap,meshvet%mesh(levelmf))

    !Error
    !error%name="PLOT_ERRO"
    !call plot_scalarfield(error,meshvet%mesh(levelmf))

    print*,''
    print*,'nrm2, nrmmax'
    print*, error_norm_2(fap%f,fap_exact%f,meshvet%mesh(levelmf)%nv), error_norm_max(fap%f,fap_exact%f,meshvet%mesh(levelmf)%nv)

50  return

  end subroutine multigrid_solver

  !==========================================================================
  ! Subroutines for relaxation, interpolation and transfer residue
  !==========================================================================

  subroutine lap_cell(mesh,lapc,fap)
    !------------------------------------------------------------
    !LAP_CELL
    !calculation of the Laplacian each point of mesh.
    !------------------------------------------------------------

    type(grid_structure)::mesh            !mesh
    !value function
    type(scalar_field)::fap
    !Approximate value of the laplacian on each grid point
    type(scalar_field)::lapc

    !counter
    integer::i
    integer::j
    integer::k

    !number points of mesh
    integer::n

    real (r8):: ledhx    !Edge length
    real (r8)::Lchx      !Distance between two neighboring
    real (r8)::laptmp

    !number points of the mesh
    n=mesh%nv

    !For each grid point
    do  i=1,n

       laptmp=0_r8
       ledhx=0_r8
       Lchx=0_r8

       !For each grid neighboring of i
       do j=1, mesh%v(i)%nnb

          !Edge index
          k=mesh%v(i)%ed(j)

          !Edge length
          ledhx=mesh%edhx(k)%leng

          !Distance between two neighboring
          Lchx=mesh%ed(k)%leng

          laptmp=laptmp+(ledhx/Lchx)*(fap%f(mesh%v(i)%nb(j))-fap%f(i))

       enddo

       !para o problema -lap f+f =g
       lapc%f(i)=-(laptmp/mesh%hx(i)%areag)+fap%f(i)

       !para o problema lap f =g
       !lapc%f(i)=laptmp

    enddo
    return
  end subroutine lap_cell

  subroutine relaxac_mult_cell(mesh,g,fap,fap_aux,numit, w)
    !------------------------------------------------------------
    !RELAXAC_MULT_CELL
    ! Relaxation Scheme - Weighted Jacobi
    !------------------------------------------------------------
    type(grid_structure)::mesh             !Mesh
    type(interpolable_meshes)::fap_aux     !Auxiliary vector
    !Approximate value of the function on each grid point
    type(scalar_field)::fap
    !Independent term of equation
    type(scalar_field)::g

    !parameter of relaxation
    real(r8)::w

    !Conter
    integer::k
    integer::i
    integer::j

    !Number of Iterations
    integer::numit

    !number of grid points
    integer::n

    real (r8):: ledhx     !Edge length
    real (r8)::Lchx       !Distance between two neighboring
    real (r8)::laptmp
    real (r8)::laptmp1

    !number points of the mesh
    n=mesh%nv

    !For each iteration
    do k=1,numit

       !For each grid point
       do i=1,n

          laptmp=0_r8
          laptmp1=0_r8
          ledhx=0_r8
          Lchx=0_r8

          !For each grid neighboring of i
          do j=1,mesh%v(i)%nnb

             !Edge length
             ledhx=mesh%edhx(mesh%v(i)%ed(j))%leng

             !Distance between two neighboring
             !arclen(mesh%v(mesh%v(i)%nb(j))%p,mesh%v(i)%p)
             Lchx=mesh%ed(mesh%v(i)%ed(j))%leng

             laptmp1=laptmp1+(ledhx/Lchx)
             laptmp=laptmp+(ledhx/Lchx)*(fap%f(mesh%v(i)%nb(j)))

          enddo

          laptmp=laptmp/mesh%hx(i)%areag
          laptmp1=laptmp1/mesh%hx(i)%areag

          !problem -lap f+f =g
          fap_aux%f(i)=(1-w)*(fap%f(i))+w*((laptmp+g%f(i))/(laptmp1+1))

          !problem lap f =g
          !fap_aux%f(i)=(1-w)*fap%f(i)+w*((laptmp-g%f(i))/(laptmp1))

       enddo

       fap%f=fap_aux%f

    enddo

    return
  end subroutine relaxac_mult_cell

  subroutine relaxac_mult_cell_GS(mesh,g,fap,numit, w)
    !------------------------------------------------------------
    !RELAXAC_MULT_CELL
    ! Relaxation Scheme - Weighted Gauss-Seidel
    !------------------------------------------------------------
    type(grid_structure)::mesh  !Mesh
    type(scalar_field)::fap     !Approximate value of the function on each grid point
    type(scalar_field)::g       !Independent term of equation

    !parameter of relaxation
    real(r8)::w

    !Conter
    integer::k
    integer::i
    integer::j

    !Number of Iterations
    integer::numit

    !number of grid points
    integer::n

    real (r8):: ledhx     !Edge length
    real (r8)::Lchx       !Distance between two neighboring
    real (r8)::laptmp
    real (r8)::laptmp1

    !number points of the mesh
    n=mesh%nv

    !For each iteration
    do k=1,numit

       !For each grid point
       do i=1,n

          laptmp=0_r8
          laptmp1=0_r8
          ledhx=0_r8
          Lchx=0_r8

          !For each grid neighboring of i
          do j=1,mesh%v(i)%nnb

             !Edge length
             ledhx=mesh%edhx(mesh%v(i)%ed(j))%leng

             !Distance between two neighboring
             Lchx=mesh%ed(mesh%v(i)%ed(j))%leng
             laptmp1=laptmp1+(ledhx/Lchx)
             laptmp=laptmp+(ledhx/Lchx)*(fap%f(mesh%v(i)%nb(j)))
          enddo

          laptmp=laptmp/mesh%hx(i)%areag
          laptmp1=laptmp1/mesh%hx(i)%areag

          !para o problema lap f =g
          !fap%f(i)=(1-w)*fap%f(i)+w*((laptmp-g%f(i))/(laptmp1))

          !para o problema -lap f+f =g
          fap%f(i)=(1-w)*(fap%f(i))+w*((laptmp+g%f(i))/(laptmp1+1))

       enddo

    enddo

    return
  end subroutine relaxac_mult_cell_GS

  subroutine interpol_cell(meshvet,niv,fap,fap_interpol)
    !---------------------------------------------------------------------
    !INTERPOL_CELL
    ! Linear Interpolation
    !The center of cell on the fine grid coincide with centers of cell on
    !the coarser grid remain at the same value. For interpolated values
    !using linear interpolation between two cells neighboring.
    !----------------------------------------------------------------------

    type(multimesh)::meshvet            !list of meshes
    type(scalar_field)::fap_interpol    !Interpolate value
    !Auxiliar interlation field
    type(scalar_field)::fap

    !neighboring cells the two endpoints of
    !the edge of the triangle
    integer(i4)::l1
    integer(i4)::l2

    integer::i          !counter
    integer(i4)::niv    !Grid level

    integer::n          !Number of points
    integer::na         !number of edges of the triangle

    n=meshvet%mesh(niv)%nv
    na=meshvet%mesh(niv)%ne

    !values remain the same
    do i=1, n
       fap_interpol%f(i)=fap%f(i)
    enddo

    !interpolated values
    do i=1,na
       l1=meshvet%mf(niv+1)%indmf(i)%cel(1)
       l2=meshvet%mf(niv+1)%indmf(i)%cel(2)

       fap_interpol%f(meshvet%mf(niv+1)%indmf(i)%celm)=(fap%f(l1)+fap%f(l2))/2

    enddo

    return
  end subroutine interpol_cell

  subroutine transfer_res(meshvet,residuo,level)
    !-----------------------------------------------------------
    !TRANSFER_RES
    !Transfer the residue of the finer mesh to coarser grid
    !Full weighting
    !-----------------------------------------------------------

    type(multimesh)::meshvet                 !List of meshes
    type(scalar_field)::residuo     !Residue

    !counter
    integer::i
    integer::j
    integer::l

    integer::level        !lever grid

    !Auxiliary
    real(r8)::laptmp
    real(r8)::laptmp1

    integer::k

    do i=1,meshvet%mesh(level-1)%nv

       laptmp=0_r8
       laptmp1=0_r8

       !Injeção
       !residuo%f(i)=residuo%f(meshvet%mf(level)%cf(i)%cmg)

       !Full weighting
       do j=1, meshvet%mesh(level)%v(i)%nnb

          !neighbor index
          l=meshvet%mesh(level)%v(i)%nb(j)

          !k=meshvet%mg(level-1)%cng(l)%cmf

          laptmp=laptmp+(residuo%f(l)*meshvet%mesh(level)%hx(l)%areag)
          laptmp1= laptmp1+meshvet%mesh(level)%hx(l)%areag

       enddo

       residuo%f(i)=(meshvet%mesh(level)%hx(i)%areag*residuo%f(i)+0.5*laptmp) &
            /(meshvet%mesh(level)%hx(i)%areag+0.5*laptmp1)
    enddo

    return
  end subroutine transfer_res

  function error_nrm_max(f, n)
    !-------------------------------------------
    !Calcula o maximo valor absoluto
    !  do vetor f de tamanho n
    !-------------------------------------------
    integer (i4):: n
    real (r8), dimension(1:n), intent(in) :: f
    real (r8):: error_nrm_max

    error_nrm_max=maxval(abs(f(1:n)))

    return
  end function error_nrm_max

  function error_norm_g(f,n)
    !-------------------------------------------
    !Calcula a raiz quadrada da soma
    !  dos elementos do vetor f
    !-------------------------------------------
    integer (i4):: n
    real (r8), dimension(1:n), intent(in) :: f
    real (r8):: error_norm_g
    real (r8):: sum_sq
    integer::i

    sum_sq=0.0

    do i=1,n
       sum_sq=sum_sq+(f(i)**2)
    enddo

    error_norm_g=dsqrt(sum_sq)

    return
  end function error_norm_g

end module multigrid


SUBROUTINE gaussj(a, n, b, m)

!  Gauss-Jordan solution of linear equations in quadruple precision.
!  Adapted from the routine GAUSSJ in the Numerical Recipes package.
!  A is an NxN quadruple-precision matrix, declared as quadruple-precision
!  A(:,:).
!  B contains M right-hand side vectors, where M = 1 in many cases,
!  and is declared as quadruple-precision B(:,:).
!  On output, A has been overwritten by its inverse, and B has been
!  replaced with the solutions.

! Programmer : Alan Miller, CSIRO Mathematical Information Sciences
! e-mail: alan @ mel.dms.csiro.au   WWW: http://www.mel.dms.csiro.au/~alan
! Fax: (+61) 3-9545-8080

! Latest revision - 6 December 1996

USE quadruple_precision
IMPLICIT NONE

INTEGER, INTENT(IN)                         :: n, m
TYPE (quad), INTENT(IN OUT), DIMENSION(:,:) :: a, b

!       Local variables

INTEGER, PARAMETER :: nmax = 50
INTEGER            :: ipiv(nmax), indxr(nmax), indxc(nmax), j, i, irow,  &
                      icol, k, l, ll
TYPE (quad)        :: pivinv, dum, one, zero
REAL (dp)          :: big

one%hi = 1._dp
one%lo = 0._dp
zero%hi = 0._dp
zero%lo = 0._dp

ipiv(1:n) = 0

!       Start of the main loop

DO i = 1, n
  big = 0.
  DO j = 1, n
    IF(ipiv(j) /= 1) THEN
      DO k = 1, n
        IF (ipiv(k) == 0) THEN
          IF (ABS(a(j,k)%hi) >= big) THEN
            big = ABS(a(j,k)%hi)
            irow = j
            icol = k
          END IF
        ELSE IF (ipiv(k) > 1) THEN
          WRITE(*, *) 'Singular matrix'
          RETURN
        END IF
      END DO
    END IF
  END DO
  ipiv(icol) = ipiv(icol)+1

!       Pivot has been selected.   Interchange rows, if necessary, to
!       put the element on the diagonal.

  IF (irow /= icol) THEN
    DO l = 1, n
      dum = a(irow,l)
      a(irow,l) = a(icol,l)
      a(icol,l) = dum
    END DO
    DO l = 1, m
      dum = b(irow,l)
      b(irow,l) = b(icol,l)
      b(icol,l) = dum
    END DO
  END IF
  indxr(i) = irow
  indxc(i) = icol

!       Now do the pivoting

  IF (a(icol,icol)%hi == 0.) THEN
    WRITE(*, *) 'Singular matrix.'
    RETURN
  END IF
  pivinv = one / a(icol,icol)
  a(icol,icol) = one
  DO l = 1, n
    a(icol, l) = a(icol, l) * pivinv
  END DO
  DO l = 1, m
    b(icol, l) = b(icol, l) * pivinv
  END DO
  DO ll = 1, n
    IF(ll /= icol)THEN
    dum = a(ll,icol)
    a(ll,icol) = zero
    DO l = 1, n
      a(ll, l) = a(ll, l) - a(icol, l) * dum
    END DO
    DO l = 1, m
      b(ll, l) = b(ll, l) - b(icol, l) * dum
    END DO
    END IF
  END DO
END DO

!       Finally unscramble A by re-arranging the columns

DO l = n, 1, -1
  IF(indxr(l) /= indxc(l))THEN
    DO k = 1, n
      dum = a(k,indxr(l))
      a(k,indxr(l)) = a(k,indxc(l))
      a(k,indxc(l)) = dum
    END DO
  END IF
END DO

RETURN
END SUBROUTINE gaussj


function fak(k) result(fakultaet)
    implicit none
    integer, intent(in) :: k
    integer :: fakultaet
    integer :: m
    fakultaet = 1
    do m=1,k
        fakultaet = fakultaet*m
    end do
end function

program efunktion
    implicit none
    real :: x
    real :: taylorsum
    integer :: n    ! number of iterations
    integer :: i    ! iteration variable
    taylorsum = 0
    n = 10

    print *, 'Enter x: '
    read(*,*) x

    do i=1,n
        taylorsum = taylorsum + (x**i) / fak(i)
    end do

    print *, 'e^x =',taylorsum
end program efunktion


    Program dormhr_example

!     DORMHR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dnrm2
      Use lapack_example_aux, Only: nagf_blas_damax_val, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgehrd, dhsein, dhseqr, dormhr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: eig, eig1
      Real (Kind=dp) :: r, thresh
      Integer :: i, ifail, info, j, k, l, lda, ldc, ldh, ldvl, ldz, lwork, m, &
        n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), c(:, :), h(:, :), tau(:), &
        vl(:, :), wi(:), work(:), wr(:), z(:, :)
      Integer, Allocatable :: ifaill(:), ifailr(:)
      Logical, Allocatable :: select(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: aimag, cmplx, conjg, maxloc, real, sqrt, sum
!     .. Executable Statements ..
      Write (nout, *) 'DORMHR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = 1
      lda = n
      ldc = n
      ldh = n
      ldvl = n
      lwork = 64*n
      Allocate (a(lda,n), c(ldc,n), h(ldh,n), tau(n), vl(ldvl,n), wi(n), &
        work(lwork), wr(n), z(ldz,1), ifaill(n), ifailr(n), select(n))

!     Read A from data file

      Read (nin, *)(a(i,1:n), i=1, n)

      Read (nin, *) thresh

!     Reduce A to upper Hessenberg form H = (Q**T)*A*Q
      Call dgehrd(n, 1, n, a, lda, tau, work, lwork, info)

!     Copy A to H
      h(1:n, 1:n) = a(1:n, 1:n)

!     Calculate the eigenvalues of H (same as A)
      Call dhseqr('Eigenvalues', 'No vectors', n, 1, n, h, ldh, wr, wi, z, &
        ldz, work, lwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100)(' (', wr(i), ',', wi(i), ')', i=1, n)

        Do i = 1, n
          select(i) = wr(i) < thresh
        End Do

!       Calculate the eigenvectors of H (as specified by SELECT),
!       storing the result in C
        Call dhsein('Right', 'QR', 'No initial vectors', select, n, a, lda, &
          wr, wi, vl, ldvl, c, ldc, n, m, work, ifaill, ifailr, info)

!       Calculate the eigenvectors of A = Q * (eigenvectors of H)
        Call dormhr('Left', 'No transpose', n, m, 1, n, a, lda, tau, c, ldc, &
          work, lwork, info)

!       Print eigenvectors

        Write (nout, *)
        Flush (nout)

!       Normalize selected eigenvectors
        j = 0
        k = 1
        Do While (k<=n)
          If (select(k)) Then
            j = j + 1
            If (wi(k)==0.0_dp) Then
!             Normalize real eigenvector by making largest positive
              Call nagf_blas_damax_val(n, c(1,j), 1, l, r)
              r = dnrm2(n, c(1,j), 1)
              c(1:n, j) = c(1:n, j)/r
              If (c(l,j)<zero) Then
                c(1:n, j) = -c(1:n, j)
              End If
            Else
!             Normalize complex eigenvectors making largest element real
              work(1:n) = c(1:n, j)**2 + c(1:n, j+1)**2
              l = maxloc(work(1:n), 1)
              eig1 = cmplx(c(l,j), c(l,j+1), kind=dp)
              eig1 = conjg(eig1)/sqrt(work(l)*sum(work(1:n)))
              Do i = 1, n
                eig = cmplx(c(i,j), c(i,j+1), kind=dp)
                eig = eig*eig1
                c(i, j) = real(eig)
                c(i, j+1) = aimag(eig)
              End Do
              c(l, j+1) = 0.0_dp
              j = j + 1
              k = k + 1
            End If
          End If
          k = k + 1
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, m, c, ldc, &
          'Contents of array C', ifail)

      End If

100   Format (1X, A, F8.4, A, F8.4, A)
    End Program


!========================================================================
!@ The Module contains the routine to help construct the grid.
!
!@ polyfit: compute the coefficients for the construction of splines.
!  Max_point: compute the point on the sautration line with maximun e
!  corner_A, corner_B, corner_c: compute some points at the intersection
!  between domains.
!=======================================================================
!
!
MODULE grid_functions

     USE def_constants
     USE def_variables
     USE non_linear_solvers
     USE properties
!
      IMPLICIT NONE
!
     PRIVATE
!
     PUBLIC   polyfit, Max_point,&
&               corner_A, corner_B, corner_C, corner_D, corner_E
!
       CONTAINS
!
! ===================================================================
!
!                              polyfit
!
! ===================================================================
      SUBROUTINE polyfit(p,x,y,N)
!POLYFIT Fit polynomial to data.
!   P = POLYFIT(X,Y,N) finds the coefficients of a polynomial P(X) of
!   degree N that fits the data Y best in a least-squares sense. P is a
!   row vector of length N+1 containing the polynomial coefficients in
!   descending powers, P(1)*X^N + P(2)*X^(N-1) +...+ P(N)*X + P(N+1).
!
!   [P,S] = POLYFIT(X,Y,N) returns the polynomial coefficients P and a
!   structure S for use with POLYVAL to obtain error estimates for
!   predictions.  S contains fields for the triangular factor (R) from a
!   QR
!   decomposition of the Vandermonde matrix of X, the degrees of freedom
!   (df), and the norm of the residuals (normr).  If the data Y are
!   random,
!   an estimate of the covariance matrix of P is
!   (Rinv*Rinv')*normr^2/df,
!   where Rinv is the inverse of R.
!
!   [P,S,MU] = POLYFIT(X,Y,N) finds the coefficients of a polynomial in
!   XHAT = (X-MU(1))/MU(2) where MU(1) = MEAN(X) and MU(2) = STD(X).
!   This
!   centering and scaling transformation improves the numerical
!   properties
!   of both the polynomial and the fitting algorithm.
!
!   Warning messages result if N is >= length(X), if X has repeated, or
!   nearly repeated, points, or if X might need centering and scaling.
!
        INTEGER, INTENT(IN)  ::  N
        INTEGER           ::  i, j, INFO
        INTEGER,allocatable   ::  IPIV(:)
        REAL(pr), DIMENSION (N+1), INTENT(OUT)     ::  p
        REAL(pr), DIMENSION (N+1), INTENT(IN)      ::  x, y
        REAL(pr), DIMENSION (N+1)     ::  TAU, b
        REAL(pr), DIMENSION (N+1,N+1) ::  Q, WORK, V, QR, R

        IF (size(x) .NE. size(y)) THEN
            print*, 'polyfit: XYSizeMismatch'
        ENDIF

!if nargout > 2
!   mu = [mean(x); std(x)];
!   x = (x - mu(1))/mu(2);
!end

! Construct Vandermonde matrix.
        V         = 0_pr
        V(:, N+1) = 1_pr
        DO j = N,1,-1
           V(:,j) = x*V(:,j+1);
        ENDDO
!
! QR factorization
!
        QR = V
         CALL DGEQRF( N+1, N+1, QR, N+1, TAU, WORK, N+1, INFO)
        IF (INFO .NE. 0) STOP 'ERROR in DGEQRF'
! getting R from QR
        R = 0_pr
        DO I=1,N+1
            R(I,I:N+1) = QR(I,I:N+1)
        ENDDO
! getting Q from QR
        Q = 0_pr
        DO I=1,N+1
        Q(I,I) = 1_pr
        ENDDO
         CALL DORMQR('L','N', N+1, N+1, N+1, QR, N+1, TAU, Q, N+1, WORK, N+1,INFO)
        IF (INFO .NE. 0) STOP 'ERROR in DORMQR'
!
! solving linear system to get coefficients
!
        b = MATMUL(TRANSPOSE(Q),y)
!
! PLU factorization of matrix
!
        allocate(IPIV(N+1))
! maybe not needed because R is triangular
         CALL DGETRF(N+1, N+1, R, N+1, IPIV, INFO)
        IF (INFO .NE. 0) STOP 'ERROR in DGETRF'
!

! Solving the system factorized
!
        p = b
         CALL DGETRS('N' , N+1, 1, R, N+1, IPIV, p, N+1, INFO)
        deallocate(IPIV)
!
      END SUBROUTINE polyfit
!
!
!
!
!
!
!
!===============================================================================
      SUBROUTINE corner_A()
!===============================================================================
!
! It is necessary to evaluate the properties of the point A on the Pmax isobar
! line at the intersection between the LL and the LH domains;
!
!
!
! Declaration of variables
        INTEGER            :: N, flag
        REAL(pr) :: p_corner_A, T_guess, v_guess, u_corner_A, res
!
!
        p_corner_A   = p_max    ! MPa
        u_corner_A   = e_cr  ! kJ/kg
        T_guess      = 319_pr          ! K ???
        v_guess      = 1.9e-3_pr       ! m3/kg
!
!
        call New_Rap2D(2, T_corner_A, v_corner_A, res, N, flag, p_corner_A, u_corner_A, T_guess, v_guess)
        call New_Rap2D(2, T_corner_A, v_corner_A, res, N, flag, p_corner_A, u_corner_A, T_corner_A, v_corner_A)
        call New_Rap2D(2, T_corner_A, v_corner_A, res, N, flag, p_corner_A, u_corner_A, T_corner_A, v_corner_A)
!
      END SUBROUTINE corner_A
!
!
!
!===============================================================================
      SUBROUTINE corner_B()
!===============================================================================
!
! It is necessary to evaluate the properties of the point B on the Pmax isobar
! line at the intersection between the LH and HT domains;
!
! Declaration of variables
        INTEGER            :: N, flag
        REAL(pr)   :: p_corner_B, T_guess, v_guess, u_corner_B, res
!
!
        p_corner_B   = p_max        ! Pa
        u_corner_B   = e_umax       ! J/kg
        T_guess      = 336.94_pr    ! K
        v_guess      = 3.69e-3_pr   ! m3/kg
!
      CALL New_Rap2D(2, T_corner_B, v_corner_B, res, N, flag, p_corner_B,u_corner_B, T_guess, v_guess)
      CALL New_Rap2D(2, T_corner_B, v_corner_B, res, N, flag, p_corner_B,u_corner_B, T_corner_B, v_corner_B)
      CALL New_Rap2D(2, T_corner_B, v_corner_B, res, N, flag, p_corner_B,u_corner_B, T_corner_B, v_corner_B)
!
!
     END SUBROUTINE corner_B
!
!
!
!===============================================================================
      SUBROUTINE corner_C()
!===============================================================================
!
! It is necessary to evaluate the properties on the Pmin isobar line at the
! intersection between R and HT domains;
!
! Declaration of variables
        INTEGER   :: N, flag
        REAL(pr)   :: p_corner_C, T_guess, v_guess, u_corner_C, res
!
!
        p_corner_C   = p_tri  ! Pa
        u_corner_C   = e_umax  ! J/kg
        v_guess      = 7.6597e-2_pr  ! K
        T_guess      = 225.553  ! m3/kg
!
      CALL New_Rap2D(2, T_corner_C, v_corner_C, res, N, flag, p_corner_C,u_corner_C, T_guess, v_guess)
      CALL New_Rap2D(2, T_corner_C, v_corner_C, res, N, flag, p_corner_C,u_corner_C, T_corner_C, v_corner_C)
      CALL New_Rap2D(2, T_corner_C, v_corner_C, res, N, flag, p_corner_C,u_corner_C, T_corner_C, v_corner_C)

      END SUBROUTINE corner_C
!
!
!
!
!===============================================================================
      SUBROUTINE corner_D()
!===============================================================================
!
!         USE saturation, ONLY: saturation_curve
         REAL(8)   :: p_corner_D, v_corner_D, T_corner_D, u_corner_D
         REAL(8)   :: press,delta_p, e_l,e_v,v_v,v_l,temp,qual
         integer   :: i,j
!
         p_corner_D = P_tri
         u_corner_D = e_cr
!
!       CALL saturation_curve()
        press = p_corner_D
        delta_p = saturP(2) - saturP(1)
        i = INT((press - saturP(1))/delta_p) + 1
!
        print*, press,delta_p,i,p_corner_D,u_corner_D
        e_l = 0_pr
        e_v = 0_pr
        v_l = 0_pr
        v_v = 0_pr
        temp = 0_pr
!
        DO j = 1, ord_spline + 1
        e_l = e_l + uL_psat_spline(ord_spline+2-j,i) * press**(j-1)
        e_v = e_v + uV_psat_spline(ord_spline+2-j,i) * press**(j-1)
        v_l = v_l + vL_psat_spline(ord_spline+2-j,i) * press**(j-1)
        v_v = v_v + vV_psat_spline(ord_spline+2-j,i) * press**(j-1)
        temp = temp + Tsat_psat_spline(ord_spline+2-j,i) * press**(j-1)
!
        ENDDO
        print*, e_v,e_l,v_v,v_l
        qual = (u_corner_D - e_l)/(e_v - e_l)
        v_corner_D = qual*v_v + (1_pr-qual)*v_l
        print*, 'v',v_corner_D, 'x',qual,temp
!
      END SUBROUTINE corner_D
!
!
!
!===============================================================================
      SUBROUTINE corner_E()
!===============================================================================
!
!         USE saturation, ONLY: saturation_curve
         REAL(8)   :: p_corner_E, v_corner_E, T_corner_E, u_corner_E
         REAL(8)   :: pguess,vlguess,vvguess,Tguess,in_2,res
         REAL(8)   :: Tsat,vv,vl
         integer   :: Niter, flag
         REAL(8)   :: press,delta_p, e_l,e_v,v_v,v_l,temp,qual
         integer   :: i,j
!
         pguess = 6d6
         u_corner_E = e_tri_R
         vlguess    = 0.9d-3
         vvguess    = 1.0475d-2
         Tguess     = 255d0

         CALL New_Rap3D(4,vl,vv,Tsat,&
              & res, Niter, flag, u_corner_E,in_2,&
              & vlguess,vvguess,Tguess)

      print*,'RES', res
      print*, 'vv',vv,'vl',vl,'T',Tsat
      print*, 'vvguess',vvguess,'vlguess',vlguess,'Tguess',Tguess

!
       CALL pressure(Tsat,vv,press)
!       CALL saturation_curve()
      print*, 'pressure', press
        delta_p = saturP(2) - saturP(1)
        i = INT((press - saturP(1))/delta_p) + 1
!
!        print*, press,delta_p,i,p_corner_D,u_corner_D
        e_l = 0_pr
        e_v = 0_pr
        v_l = 0_pr
        v_v = 0_pr
        temp = 0_pr
!
        DO j = 1, ord_spline + 1
        e_l = e_l + uL_psat_spline(ord_spline+2-j,i) * press**(j-1)
        e_v = e_v + uV_psat_spline(ord_spline+2-j,i) * press**(j-1)
        v_l = v_l + vL_psat_spline(ord_spline+2-j,i) * press**(j-1)
        v_v = v_v + vV_psat_spline(ord_spline+2-j,i) * press**(j-1)
        temp = temp + Tsat_psat_spline(ord_spline+2-j,i) * press**(j-1)
!
        ENDDO
        print*,'spline', e_v,e_l,v_v,v_l,temp
!
      END SUBROUTINE corner_E

!
!===============================================================================
      SUBROUTINE Max_point(u_max, v_umax, T_umax, p_umax, c_umax)
!===============================================================================
! Compute the maximum internal enregy at the saturation line. The solutions
! are very sensible to the initial guesses, so the domaine of the computaion is
! limited from 236K to 268K at saturation line. Once the maximum is found, it is
! considered as a constant point as same as critial point and triple point.
!-------------------------------------------------------------------------------
!
! Global variables
        REAL(pr), INTENT(OUT)  :: T_umax, u_max, v_umax, p_umax, c_umax
!
! Local variables
        INTEGER  :: N_iter, Niter, exitflag
        REAL(pr)  :: TOL, tau, deltaK, T_right, T_left, &
        &   s, T_c, T_d, p, v, u_c, u_d, u_left, u_right, &
        &   guess_1_c, guess_2_c, v_l_c, v_v_c, resnorm_c, resnorm_d, in_2,&
        &   guess_1_d, guess_2_d, press, sound, energy, v_left,&
        &   v_right, v_l_d, v_v_d
!
!----------------------------------------------------------------------------
! EVALUATION OF THE MAXIMUM POINT USING GSS (Golden Section Search)
! ALGORITHM
!----------------------------------------------------------------------------
!
        tau = 2_pr/(1_pr + 5_pr**(0.5_pr)) ! Golden ratio for the GSS
!
!        guess_1_c = 1_pr / rho_cr - tau*(1_pr/rho_cr - 1_pr/rho_tri_L)
!        guess_2_c = 1_pr / rho_cr + tau*(1_pr/rho_tri_R - 1_pr/rho_cr)
!        guess_1_d = 1_pr / rho_tri_L + tau*(1_pr/rho_cr - 1_pr/rho_tri_L)
!        guess_1_d = 1_pr / rho_tri_L
!        guess_2_d = 1_pr / rho_cr + 0.2_pr*(1_pr/rho_tri_R - 1_pr/rho_cr)
!
!
!
        in_2 = 0_pr
!
!
!
        TOL = 1e-12_pr                 ! Tolerance
        N_iter = 0
!
        deltaK  = 1_pr               ! for the definition of the initial extremes
        T_right = 236_pr+ deltaK
        T_left  = 268_pr - deltaK
!
        guess_1_c = 1_pr/1105.12_pr
        guess_2_c = 1_pr/28.935_pr
        guess_1_d = 1_pr/957.04_pr
        guess_2_d = 1_pr/82.965_pr
!
        DO WHILE (abs(T_right - T_left) .GT. TOL)
!         do while (N_iter < 10)
          N_iter = N_iter + 1
          s      = tau * (T_right - T_left)
! Two additional points are necessary
          T_c = T_left + s
          T_d = T_right - s
! Evaluation of internal energy in c and d
! Iterative routine in the iterative routine, cost!!
!
        CALL New_Rap2D(1, v_l_c, v_v_c, resnorm_c, Niter, exitflag, T_c, in_2, guess_1_c, guess_2_c)
        CALL inter_energy(T_c,v_v_c,energy)
!
          u_c = energy
!print*, "temp",T_c,"vl_c",v_l_c,"vv_c",v_v_c,"res_c",resnorm_c,"N",Niter
!
        CALL New_Rap2D(1, v_l_d, v_v_d, resnorm_d, Niter, exitflag, T_d, in_2, guess_1_d, guess_2_d)
        CALL inter_energy(T_d,v_v_d,energy)
!print*, "temp",T_d,"vl_d",v_l_d,"vv_d",v_v_d,"res_d",resnorm_d,"N",Niter
!
          u_d = energy
!
          IF (u_d .LT. u_c) THEN
              T_left  = T_d
              v_left = v_v_d
              T_right = T_right
              guess_1_d = v_l_c
              guess_2_d = v_left
!              guess_1_c = v_l_d + tau*(1_pr/rho_tri_L - v_l_d)
!              guess_2_c = v_v_d + tau*(1_pr/rho_tri_R - v_v_d)
          ELSE
              T_left  = T_left
              T_right = T_c
              v_right = v_v_c
                guess_1_c = v_l_d
                guess_2_c = v_right
!              guess_1_d = v_l_c + tau*(1_pr/rho_cr - v_l_c)
!              guess_2_d = v_v_c + tau*(1_pr/rho_cr - v_v_c )
          ENDIF
!print*, N_iter,"res",resnorm_c,resnorm_d, abs(T_right-T_left)/TOL
!print*, "Tleft",T_left,"rho_left",1_pr/v_left
!print*, "Tright",T_right,"rho_right",1_pr/v_right
!print*,"-----------------------------------"
!print*," "
        ENDDO
! once that the loop ends, the range is sufficiently small; so it is possible to evaluate
! in which point the maximum is and what is the value of the maximum itself
!
     CALL inter_energy(T_left,v_left,energy)
        u_left = energy
!
     CALL inter_energy(T_right,v_right,energy)
        u_right = energy
!
        IF (u_left .LT. u_right) THEN
            T_umax = T_right      ! K
            u_max  = u_right      ! J/kg
            v_umax = v_right
        ELSE
            T_umax = T_left       ! K
            u_max  = u_left       ! J/kg
            v_umax = v_left
        ENDIF
!
!
        print*, v_l_c
        print*, v_l_d
        CALL pressure(T_umax, v_umax, press)
        p_umax = press   ! Pa
!
        CALL sound_speed(T_umax, v_umax, sound)
        c_umax = sound
!
      END SUBROUTINE Max_point
!
!
END MODULE grid_functions


program euler_151
   integer, parameter :: dp = selected_int_kind(14,40), int64=selected_int_kind(10)
   real(dp) :: res

   res = paper(1,1,1,1)
   print '(f0.6)', res
contains
   recursive function paper(a2,a3,a4,a5) result(p)
      integer(int64), intent(in) :: a2,a3,a4,a5
      real(dp) :: p
      real(dp) :: p2,p3,p4,p5
      if (a5==1 .and. (a2+a3+a4)==0) then
         p = 0.0
         return
      end if
      if (a4==1 .and. (a2+a3+a5)==0) then
         p = paper(0,0,0,1) + 1.0
         return
      end if
      if (a3==1 .and. (a2+a4+a5)==0) then
         p = paper(0,0,1,1) + 1.0
         return
      end if
      if (a2==1 .and. (a3+a4+a5)==0) then
         p = paper(0,1,1,1) + 1.0
         return
      end if

      p2 = 0; p3 = 0; p4 = 0; p5 = 0
      if (a2 > 0) p2 = a2*paper(a2-1,a3+1,a4+1,a5+1)
      if (a3 > 0) p3 = a3*paper(a2  ,a3-1,a4+1,a5+1)
      if (a4 > 0) p4 = a4*paper(a2  ,a3  ,a4-1,a5+1)
      if (a5 > 0) p5 = a5*paper(a2  ,a3  ,a4  ,a5-1)

      P = (p2+p3+p4+p5) / real(a2+a3+a4+a5,dp)
      return
   end function paper
end program euler_151


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_symtrid_factor
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine performs a Cayley transformation of the symmetric
! tridiagonal matrix to a unitary matrix (a descending and a
! ascending sequence of core transformations). The unitary matrix
! is transformed to upper Hessenberg form by core chasing.
!
! The Cayley (Moebius) transform -(z-i)/(z+i) maps the real line to
! the unit circle, in particular the interval [-1,1] is mapped to
! [-pi/2, pi/2].
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: compute schurvectors
!                    .FALSE.: no schurvectors
!
!  ID              LOGICAL
!                    .TRUE.: initialize to Z to identity
!                    .FALSE.: assume Z is already initialized
!
!  SCA             LOGICAL
!                    .TRUE.: scale the matrix to
!                            have eigenvalues in [-1,1]
!                    .FALSE.: do not scale the matrix
!                  !! CAUTION: Not scaling the matrix can
!                              result in inaccurate eigenvalues !!
!
!  N               INTEGER
!                    dimension of matrix
!
!  D               REAL(8) array of dimension (N)
!                    diagonal entries of T
!                    on exit: if SCA=.TRUE., D and E have been scaled
!
!  E               REAL(8) array of dimension (N-1)
!                    subdiagonal entries of T
!                    on exit: if SCA=.TRUE., D and E have been scaled
!
!  M               INTEGER
!                    leading dimension of Z
!
! OUTPUT VARIABLES:
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for Givens rotations
!
!  QD              REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
!  SCALE           REAL(8)
!                    scaling factor for back transform
!
!  Z               COMPLEX(8) array of dimension (M,N)
!                    similarity transformation of the reduction to
!                    unitary Hessenberg form
!                    if VEC = .FALSE. unused
!                    if VEC = .TRUE. and ID = .TRUE. initializes Z to I
!                    if VEC = .TRUE. and ID = .FALSE. assumes Z initialized
!
!  INFO            INTEGER
!                    INFO = 1 implies scaling failed
!                    INFO = 0 implies successful computation
!                    INFO = -4 implies N is invalid
!                    INFO = -5 implies D is invalid
!                    INFO = -6 implies E is invalid
!                    INFO = -10 implies M is invalid
!                    INFO = -11 implies Z is invalid
!                    INFO = -56 implies D and E are zero
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_symtrid_factor(VEC,ID,SCA,N,D,E,Q,QD,SCALE,M,Z,INFO)

  implicit none

  ! input variables
  logical, intent(in) :: VEC, ID, SCA
  integer, intent(in) :: N, M
  real(8), intent(inout) :: D(N), E(N-1), Q(3*N-3), QD(2*N), SCALE
  complex(8), intent(inout) :: Z(M,N)
  integer, intent(inout) :: INFO

  ! compute variables
  integer :: ii, jj, ind1, ind2
  logical :: flg
  real(8) :: cr, ci, s, nrm, bulge(3), a, b
  complex(8) :: eu, d1, t1(2,2)

  ! initialize INFO
  INFO = 0

  ! check N
  if (N < 1) then
    INFO = -4
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"N must be at least 1",INFO,INFO)
    end if
    return
  end if

  ! check D
  call d_1Darray_check(N,D,flg)
  if (.NOT.flg) then
    INFO = -5
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"D is invalid",INFO,INFO)
    end if
    return
  end if

  ! check E
  call d_1Darray_check(N-1,E,flg)
  if (.NOT.flg) then
    INFO = -6
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"E is invalid",INFO,INFO)
    end if
    return
  end if

  ! check M
  if (VEC.AND.(M < 1)) then
    INFO = -9
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"M must be at least 1",INFO,INFO)
    end if
    return
  end if

  ! check Z
  if (VEC.AND..NOT.ID) then
    call d_2Darray_check(M,N,Z,flg)
    if (.NOT.flg) then
      INFO = -10
      ! print error message in debug mode
      if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"Z is invalid",INFO,INFO)
      end if
      return
    end if
  end if

  ! initialize Z
  if (VEC.AND.ID) then
     Z = cmplx(0d0,0d0,kind=8)
     do ii=1,min(M,N)
        Z(ii,ii) = cmplx(1d0,0d0,kind=8)
     end do
  end if

  ! compute scale factor whether we use it or not
  ! .TRUE. : use Newton correction
  call d_symtrid_specint(.TRUE.,N,D,E,a,b,INFO)
  if (INFO.NE.0) then
     ! print error in debug mode
     if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"d_symtrid_specint failed",INFO,INFO)
     end if
     INFO = 1
  end if

  ! compute scale
  SCALE = max(abs(a),abs(b))

  ! return if scale == 0d0
  if (SCALE.EQ.0d0) then
     INFO = -56
     ! print error in debug mode
     if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"input matrices are 0",INFO,INFO)
     end if
     return
  end if

  ! scale D and E if SCA == .TRUE.
  if (SCA) then
     do ii=1,N
        D(ii) = D(ii)/SCALE
     end do
     do ii=1,N-1
        E(ii) = E(ii)/SCALE
     end do
  ! otherwise set scale to 1
  else
    scale = 1d0
  end if

  ! Cayley transform -(T-iI)(T+iI)
  ! implicitly form B = T - i I  and T + i I = conjg(B)
  eu = E(1)
  d1 = cmplx(D(1),-1d0,kind=8)

  ! QR decomposition QR = (T-iI)
  do ii=1,N-1
     ! compute new rotation
     call z_rot3_vec3gen(dble(d1),aimag(d1),E(ii),cr,ci,s,nrm)

     Q(3*ii-2) = cr
     Q(3*ii-1) = ci
     Q(3*ii)   = s

     ! update banded matrix (ignoring the second superdiagonal and the upper part of the matrix)
     d1 = -s*eu + cmplx(cr,ci,kind=8)*cmplx(D(ii+1),-1d0,kind=8)
     if (ii<N-1) then
        eu = cmplx(cr*E(ii+1),ci*E(ii+1),kind=8)
     end if
  end do

  ! form diagonal R conjg(R)^-1 (which is a diagonal matrix)
  do ii=1,N-1
     QD(2*ii-1) = -1d0
     QD(2*ii)   = 0d0
  end do
  call d_rot2_vec2gen(dble(d1),aimag(d1),cr,s,nrm)
  call d_rot2_vec2gen(-cr*cr+s*s,-2*cr*s,QD(2*N-1),QD(2*N),nrm)

  ! fuse Q^T into Q
  do jj=N-1,1,-1
     bulge(1) = Q(3*jj-2)
     bulge(2) = Q(3*jj-1)
     bulge(3) = -Q(3*jj)  ! the bulge is Q^T

     ! main chasing loop
     do ii=jj,(N-2)

        ! set indices
        ind1 = 2*(ii-1) + 1
        ind2 = ind1+3

        ! through diag
        call z_rot3_swapdiag(QD(ind1:ind2),bulge)

        ! set indices
        ind1 = 3*(ii-1) + 1
        ind2 = ind1+2

        ! through Q
        call z_rot3_turnover(Q(ind1:ind2),Q((ind1+3):(ind2+3)),bulge)

        ! update eigenvectors
        if (VEC) then
           t1(1,1) = cmplx(bulge(1),bulge(2),kind=8)
           t1(2,1) = cmplx(bulge(3),0d0,kind=8)
           t1(1,2) = -t1(2,1)
           t1(2,2) = conjg(t1(1,1))
           Z(:,(ii+1):(ii+2)) = matmul(Z(:,(ii+1):(ii+2)),t1)
        end if

     end do

     ! set indices
     ind1 = 2*(N-2) + 1
     ind2 = ind1+3

     ! through diag
     call z_rot3_swapdiag(QD(ind1:ind2),bulge)

     ! fusion at bottom
     call z_unifact_mergebulge(.FALSE.,Q((3*N-5):(3*N-3)),QD((2*N-3):(2*N)),bulge)

  end do

end subroutine d_symtrid_factor


!=======================================================================
!
!  Library to compute the Gauss-Lobatto-Legendre points and weights
!  Based on Gauss-Lobatto routines from M.I.T.
!  Department of Mechanical Engineering
!
!=======================================================================

MODULE gll_library

END MODULE

double precision function endw1(n,alpha,beta)

    implicit none

    integer n
    double precision alpha,beta

    double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
    double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
    double precision, external :: gammaf
    integer i

    f3 = zero
    apb   = alpha+beta
    if (n == 0) then
        endw1 = zero
        return
    endif
    f1   = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
    f1   = f1*(apb+two)*two**(apb+two)/two
    if (n == 1) then
        endw1 = f1
        return
    endif
    fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
    fint1 = fint1*two**(apb+two)
    fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
    fint2 = fint2*two**(apb+three)
    f2    = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
    if (n == 2) then
        endw1 = f2
        return
    endif
    do i=3,n
        di   = dble(i-1)
        abn  = alpha+beta+di
        abnn = abn+di
        a1   = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
        a2   =  (two*(alpha-beta))/(abnn*(abnn+two))
        a3   =  (two*(abn+one))/((abnn+two)*(abnn+one))
        f3   =  -(a2*f2+a1*f1)/a3
        f1   = f2
        f2   = f3
    enddo
    endw1  = f3

end function endw1

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

double precision function endw2(n,alpha,beta)

    implicit none

    integer n
    double precision alpha,beta

    double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
    double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
    double precision, external :: gammaf
    integer i

    apb   = alpha+beta
    f3 = zero
    if (n == 0) then
        endw2 = zero
        return
    endif
    f1   = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
    f1   = f1*(apb+two)*two**(apb+two)/two
    if (n == 1) then
        endw2 = f1
        return
    endif
    fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
    fint1 = fint1*two**(apb+two)
    fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
    fint2 = fint2*two**(apb+three)
    f2    = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
    if (n == 2) then
        endw2 = f2
        return
    endif
    do i=3,n
        di   = dble(i-1)
        abn  = alpha+beta+di
        abnn = abn+di
        a1   =  -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
        a2   =  (two*(alpha-beta))/(abnn*(abnn+two))
        a3   =  (two*(abn+one))/((abnn+two)*(abnn+one))
        f3   =  -(a2*f2+a1*f1)/a3
        f1   = f2
        f2   = f3
    enddo
    endw2  = f3

end function endw2

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

double precision function gammaf (x)

    implicit none

    double precision, parameter :: pi = 3.141592653589793d0

    double precision x

    double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0

    gammaf = one

    if (x == -half) gammaf = -two*dsqrt(pi)
    if (x ==  half) gammaf =  dsqrt(pi)
    if (x ==  one ) gammaf =  one
    if (x ==  two ) gammaf =  one
    if (x ==  1.5d0) gammaf =  dsqrt(pi)/2.d0
    if (x ==  2.5d0) gammaf =  1.5d0*dsqrt(pi)/2.d0
    if (x ==  3.5d0) gammaf =  2.5d0*1.5d0*dsqrt(pi)/2.d0
    if (x ==  3.d0 ) gammaf =  2.d0
    if (x ==  4.d0 ) gammaf = 6.d0
    if (x ==  5.d0 ) gammaf = 24.d0
    if (x ==  6.d0 ) gammaf = 120.d0

end function gammaf

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

subroutine jacg (xjac,np,alpha,beta)

    !=======================================================================
    !
    ! computes np Gauss points, which are the zeros of the
    ! Jacobi polynomial with parameters alpha and beta
    !
    !                  .alpha = beta =  0.0  ->  Legendre points
    !                  .alpha = beta = -0.5  ->  Chebyshev points
    !
    !=======================================================================

    implicit none

    integer np
    double precision alpha,beta
    double precision xjac(np)

    integer k,j,i,jmin,jm,n
    double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
    double precision p,pd,pm1,pdm1,pm2,pdm2

    integer, parameter :: K_MAX_ITER = 10
    double precision, parameter :: zero = 0.d0, eps = 1.0d-12

    pm1 = zero
    pm2 = zero
    pdm1 = zero
    pdm2 = zero

    xlast = 0.d0
    n   = np-1
    dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
    p = 0.d0
    pd = 0.d0
    jmin = 0
    do j=1,np
        if(j == 1) then
            x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
        else
            x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
            x2 = xlast
            x  = (x1+x2)/2.d0
        endif
        do k=1,K_MAX_ITER
            call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
            recsum = 0.d0
            jm = j-1
            do i=1,jm
                recsum = recsum+1.d0/(x-xjac(np-i+1))
            enddo
            delx = -p/(pd-recsum*p)
            x    = x+delx
            if(abs(delx) < eps) goto 31
        enddo
        31      continue
        xjac(np-j+1) = x
        xlast        = x
    enddo
    do i=1,np
        xmin = 2.d0
        do j=i,np
            if(xjac(j) < xmin) then
                xmin = xjac(j)
                jmin = j
            endif
        enddo
        if(jmin /= i) then
            swap = xjac(i)
            xjac(i) = xjac(jmin)
            xjac(jmin) = swap
        endif
    enddo

end subroutine jacg

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

subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)

    !=======================================================================
    !
    ! Computes the Jacobi polynomial of degree n and its derivative at x
    !
    !=======================================================================

    implicit none

    double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
    integer n

    double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
    integer k

    apb  = alp+bet
    poly = 1.d0
    pder = 0.d0
    psave = 0.d0
    pdsave = 0.d0

    if (n == 0) return

    polyl = poly
    pderl = pder
    poly  = (alp-bet+(apb+2.d0)*x)/2.d0
    pder  = (apb+2.d0)/2.d0
    if (n == 1) return

    do k=2,n
        dk = dble(k)
        a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
        a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
        b3 = (2.d0*dk+apb-2.d0)
        a3 = b3*(b3+1.d0)*(b3+2.d0)
        a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
        polyn  = ((a2+a3*x)*poly-a4*polyl)/a1
        pdern  = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
        psave  = polyl
        pdsave = pderl
        polyl  = poly
        poly   = polyn
        pderl  = pder
        pder   = pdern
    enddo

    polym1 = polyl
    pderm1 = pderl
    polym2 = psave
    pderm2 = pdsave

end subroutine jacobf

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

double precision FUNCTION PNDLEG (Z,N)

    !------------------------------------------------------------------------
    !
    !     Compute the derivative of the Nth order Legendre polynomial at Z.
    !     Based on the recursion formula for the Legendre polynomials.
    !
    !------------------------------------------------------------------------
    implicit none

    double precision z
    integer n

    double precision P1,P2,P1D,P2D,P3D,FK,P3
    integer k

    P1   = 1.d0
    P2   = Z
    P1D  = 0.d0
    P2D  = 1.d0
    P3D  = 1.d0

    do K = 1, N-1
        FK  = dble(K)
        P3  = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
        P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
        P1  = P2
        P2  = P3
        P1D = P2D
        P2D = P3D
    enddo

    PNDLEG = P3D

end function pndleg

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

double precision FUNCTION PNLEG (Z,N)

    !------------------------------------------------------------------------
    !
    !     Compute the value of the Nth order Legendre polynomial at Z.
    !     Based on the recursion formula for the Legendre polynomials.
    !
    !------------------------------------------------------------------------
    implicit none

    double precision z
    integer n

    double precision P1,P2,P3,FK
    integer k

    P1   = 1.d0
    P2   = Z
    P3   = P2

    do K = 1, N-1
        FK  = dble(K)
        P3  = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
        P1  = P2
        P2  = P3
    enddo

    PNLEG = P3

end function pnleg

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

double precision function pnormj (n,alpha,beta)

    implicit none

    double precision alpha,beta
    integer n

    double precision one,two,dn,const,prod,dindx,frac
    double precision, external :: gammaf
    integer i

    one   = 1.d0
    two   = 2.d0
    dn    = dble(n)
    const = alpha+beta+one

    if (n <= 1) then
        prod   = gammaf(dn+alpha)*gammaf(dn+beta)
        prod   = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
        pnormj = prod * two**const/(two*dn+const)
        return
    endif

    prod  = gammaf(alpha+one)*gammaf(beta+one)
    prod  = prod/(two*(one+const)*gammaf(const+one))
    prod  = prod*(one+alpha)*(two+alpha)
    prod  = prod*(one+beta)*(two+beta)

    do i=3,n
        dindx = dble(i)
        frac  = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
        prod  = prod*frac
    enddo

    pnormj = prod * two**const/(two*dn+const)

end function pnormj

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

subroutine zwgjd(z,w,np,alpha,beta)

    !=======================================================================
    !
    !     Z w g j d : Generate np Gauss-Jacobi points and weights
    !                 associated with Jacobi polynomial of degree n = np-1
    !
    !     Note : Coefficients alpha and beta must be greater than -1.
    !     ----
    !=======================================================================

    implicit none

    double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0

    integer np
    double precision z(np),w(np)
    double precision alpha,beta

    integer n,np1,np2,i
    double precision p,pd,pm1,pdm1,pm2,pdm2
    double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
    double precision, external :: gammaf,pnormj

    pd = zero
    pm1 = zero
    pm2 = zero
    pdm1 = zero
    pdm2 = zero

    n    = np-1
    apb  = alpha+beta
    p    = zero
    pdm1 = zero

    if (np <= 0) stop 'minimum number of Gauss points is 1'

    if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'

    if (np == 1) then
        z(1) = (beta-alpha)/(apb+two)
        w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
        return
    endif

    call jacg(z,np,alpha,beta)

    np1   = n+1
    np2   = n+2
    dnp1  = dble(np1)
    dnp2  = dble(np2)
    fac1  = dnp1+alpha+beta+one
    fac2  = fac1+dnp1
    fac3  = fac2+one
    fnorm = pnormj(np1,alpha,beta)
    rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
    do i=1,np
        call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
        w(i) = -rcoef/(p*pdm1)
    enddo

end subroutine zwgjd

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

subroutine zwgljd(z,w,np,alpha,beta)

    !=======================================================================
    !
    !     Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
    !     -----------   weights associated with Jacobi polynomials of degree
    !                   n = np-1.
    !
    !     Note : alpha and beta coefficients must be greater than -1.
    !            Legendre polynomials are special case of Jacobi polynomials
    !            just by setting alpha and beta to 0.
    !
    !=======================================================================

    implicit none

    double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0

    integer np
    double precision alpha,beta
    double precision z(np), w(np)

    integer n,nm1,i
    double precision p,pd,pm1,pdm1,pm2,pdm2
    double precision alpg,betg
    double precision, external :: endw1,endw2

    p = zero
    pm1 = zero
    pm2 = zero
    pdm1 = zero
    pdm2 = zero

    n   = np-1
    nm1 = n-1
    pd  = zero

    if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'

    ! with spectral elements, use at least 3 points
    if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'

    if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'

    if (nm1 > 0) then
        alpg  = alpha+one
        betg  = beta+one
        call zwgjd(z(2),w(2),nm1,alpg,betg)
    endif

    z(1)  = - one
    z(np) =  one

    do i=2,np-1
        w(i) = w(i)/(one-z(i)**2)
    enddo

    call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
    w(1)  = endw1(n,alpha,beta)/(two*pd)
    call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
    w(np) = endw2(n,alpha,beta)/(two*pd)

end subroutine zwgljd


program matmul_ans
  implicit none
  include "xmp_coarray.h"
  integer,parameter :: N = 1024
  real :: A(N,N)[*], B(N,N)[*], C(N,N)[*]  ! c = a x b
  integer :: t1, t2, t_rate, t_max, diff
  integer :: seedsize
  integer,allocatable:: seed(:)

  if (num_images() .ne. 4 ) then
     write(*,*) "This program must be executed by 4 nodes."
  end if

  call random_seed(size=seedsize)
  allocate(seed(seedsize))
  call random_seed(get=seed)

  ! Serial Implementation
  if (this_image() .eq. 1 ) then
     call init_dmat()          ! matrix initialization
     call system_clock(t1)
     call mul_dmat(1, N, 1, N) ! matrix multiply
     call system_clock(t2, t_rate, t_max)
     if ( t2 < t1 ) then
        diff = (t_max - t1) + t2 + 1
     else
        diff = t2 - t1
     endif

     write(*,*) "Serial:"
     print "(A, F10.3)", "  time it took was:", diff/dble(t_rate)
     print "(A, F10.3)", "  verify          :", sum(C)
  end if
  ! End Serial Implementation

  ! Parallel Implementation
  if (this_image() .eq. 1 ) then
     call init_dmat()        ! matrix initialization
  end if

  sync all
  call system_clock(t1)

  call move_data()  ! transports data
  sync all

  if (this_image() .eq. 1 ) then
     call mul_dmat(1, N/2, 1, N/2)
  else if (this_image() .eq. 2 ) then
     call mul_dmat(1, N/2, N/2+1, N)
  else if (this_image() .eq. 3 ) then
     call mul_dmat(N/2+1, N, 1, N/2)
  else if (this_image() .eq. 4 ) then
     call mul_dmat(N/2+1, N, N/2+1, N)
  endif
  sync all

  call gather_data()
  ! END Parallel Implementation

  sync all
  call system_clock(t2, t_rate, t_max)
  if ( t2 < t1 ) then
     diff = (t_max - t1) + t2 + 1
  else
     diff = t2 - t1
  endif

  if (this_image() .eq. 1 ) then
     write(*,*) "Parallel:"
     print "(A, F10.3)", "  time it took was:", diff/dble(t_rate)
     print "(A, F10.3)", "  verify          :", sum(C)
  end if

contains
  subroutine init_dmat()
    call random_seed(put=seed)
    call random_number(A)
    call random_number(B)
    A(:,:) = A(:,:) - 0.5  ! -0.5 <= A < 0.5
    B(:,:) = B(:,:) - 0.5  ! -0.5 <= B < 0.5
  end subroutine init_dmat

  subroutine mul_dmat(start_i, end_i, start_k, end_k)
    integer :: start_i, end_i, start_k, end_k
    integer :: i, j, k

    C(:,:) = 0.0

    do i=start_i, end_i
       do j=1, N
          do k=start_k, end_k
             C(k,i) = C(k,i) + A(j,i) * B(k,j)
          end do
       end do
    end do
  end subroutine mul_dmat

  subroutine gather_data()
    integer :: me
    me = this_image()
    if (me .eq. 1) then
       C(N/2+1:N,:N/2) = C(N/2+1:N,:N/2)[2]
       C(:N/2,N/2+1:N) = C(:N/2,N/2+1:N)[3]
       C(N/2+1:N,N/2+1:N) = C(N/2+1:N,N/2+1:N)[4]
    end if
  end subroutine gather_data

  subroutine move_data()
    if(this_image() .eq. 1) then
       ! Please implement THIS
    end if
  end subroutine move_data
end program matmul_ans


! $UWHPSC/codes/lapack/random/randomsys3.f90

program randomsys3
    implicit none
    real(kind=8), dimension(:),allocatable :: x,b,work
    real(kind=8), dimension(:,:),allocatable :: a
    real(kind=8) :: errnorm, xnorm, rcond, anorm, colsum
    integer :: i, info, lda, ldb, nrhs, n, j
    integer, dimension(:), allocatable :: ipiv
    integer, allocatable, dimension(:) :: iwork
    character, dimension(1) :: norm

    ! initialize random number generator seed
    ! if you remove this, the same numbers will be generated each
    ! time you run this code.
    call init_random_seed()

    print *, "Input n ... "
    read *, n

    allocate(a(n,n))
    allocate(b(n))
    allocate(x(n))
    allocate(ipiv(n))

    call random_number(a)
    call random_number(x)

    b = matmul(a,x)    ! compute RHS

    ! compute 1-norm needed for condition number

    anorm = 0.d0
    do j=1,n
        colsum = 0.d0
        do i=1,n
            colsum = colsum + abs(a(i,j))
            enddo
        anorm = max(anorm, colsum)
        enddo

    nrhs = 1 ! number of right hand sides in b
    lda = n  ! leading dimension of a
    ldb = n  ! leading dimension of b

    call dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)

    ! compute 1-norm of error
    errnorm = 0.d0
    xnorm = 0.d0
    do i=1,n
        errnorm = errnorm + abs(x(i)-b(i))
        xnorm = xnorm + abs(x(i))
        enddo

    ! relative error in 1-norm:
    errnorm = errnorm / xnorm

    ! compute condition number of matrix:
    ! note: uses A returned from dgesv with L,U factors:

    allocate(work(4*n))
    allocate(iwork(n))
    norm = '1'  ! use 1-norm
    call dgecon(norm,n,a,lda,anorm,rcond,work,iwork,info)

    if (info /= 0) then
        print *, "*** Error in dgecon: info = ",info
        endif

    print 201, n, 1.d0/rcond, errnorm
201 format("For n = ",i4," the approx. condition number is ",e10.3,/, &
           " and the relative error in 1-norm is ",e10.3)

    deallocate(a,b,ipiv)
    deallocate(work,iwork)

end program randomsys3


program cholfactest
  ! This program tests the modified cholesky factorization of form
  !
  !   A = C C^T
  !
  ! where A is a symmetric positive definite matrix and
  ! C is a upper triangular matrix.

  use flips

  implicit none

  real(4), dimension(4,4) :: amat, cmat
  complex(4), dimension(4,4) :: aamat,ccmat,tmat

  amat(1,:) = (/ 1.0,0.0,0.0,0.0 /)
  amat(2,:) = (/ 0.0,2.0,0.0,0.0 /)
  amat(3,:) = (/ 0.0,0.0,3.0,0.0 /)
  amat(4,:) = (/ 0.0,0.0,0.0,4.0 /)

  call modcholmat_s(4,amat,cmat)

  write(*,*) 'Test 1: real diagonal matrix'
  write(*,*) '-----------------------'

  write(*,*) amat(1,:)
  write(*,*) amat(2,:)
  write(*,*) amat(3,:)
  write(*,*) amat(4,:)

  write(*,*) '-----------------------'

  write(*,*) cmat(1,:)
  write(*,*) cmat(2,:)
  write(*,*) cmat(3,:)
  write(*,*) cmat(4,:)

  write(*,*) '-----------------------'

  amat(1,:) = (/ 4.0, 1.0, 0.0, 1.0 /)
  amat(2,:) = (/ 1.0, 5.0, 1.0, 1.0 /)
  amat(3,:) = (/ 0.0, 1.0, 6.0, 1.5 /)
  amat(4,:) = (/ 1.0, 1.0, 1.5, 7.0 /)

  call modcholmat_s(4,amat,cmat)

  write(*,*) 'Test 2: real general matrix'
  write(*,*) '-----------------------'

  write(*,*) amat(1,:)
  write(*,*) amat(2,:)
  write(*,*) amat(3,:)
  write(*,*) amat(4,:)

  write(*,*) '-----------------------'

  write(*,*) cmat(1,:)
  write(*,*) cmat(2,:)
  write(*,*) cmat(3,:)
  write(*,*) cmat(4,:)

  write(*,*) '-----------------------'

  cmat = matmul(cmat,transpose(cmat))

  write(*,*) cmat(1,:)
  write(*,*) cmat(2,:)
  write(*,*) cmat(3,:)
  write(*,*) cmat(4,:)

  write(*,*) '-----------------------'

  aamat(1,:) = (/ (1.0,1.0),(0.0,0.0),(0.0,0.0),(0.0,0.0) /)
  aamat(2,:) = (/ (0.0,0.0),(2.0,2.0),(0.0,0.0),(0.0,0.0) /)
  aamat(3,:) = (/ (0.0,0.0),(0.0,0.0),(3.0,3.0),(0.0,0.0) /)
  aamat(4,:) = (/ (0.0,0.0),(0.0,0.0),(0.0,0.0),(4.0,4.0) /)

  call modcholmat_c(4,aamat,ccmat)

!!$  write(*,*) 'Test 3: complex diagonal matrix'
!!$  write(*,*) '-----------------------'
!!$
!!$  write(*,*) aamat(1,:)
!!$  write(*,*) aamat(2,:)
!!$  write(*,*) aamat(3,:)
!!$  write(*,*) aamat(4,:)
!!$
!!$  write(*,*) '-----------------------'
!!$
!!$  write(*,*) ccmat(1,:)
!!$  write(*,*) ccmat(2,:)
!!$  write(*,*) ccmat(3,:)
!!$  write(*,*) ccmat(4,:)
!!$
!!$  write(*,*) '-----------------------'
!!$
!!$ccmat = matmul(ccmat,transpose(ccmat))
!!$
!!$  write(*,*) ccmat(1,:)
!!$  write(*,*) ccmat(2,:)
!!$  write(*,*) ccmat(3,:)
!!$  write(*,*) ccmat(4,:)
!!$
!!$  write(*,*) '-----------------------'
!!$

  aamat(1,:) = (/ (4.0,0.0), (1.0,1.0), (0.0,0.0), (1.0,1.0) /)
  aamat(2,:) = (/ (1.0,-1.0), (5.0,0.0), (1.0,1.0), (1.0,1.0) /)
  aamat(3,:) = (/ (0.0,0.0), (1.0,-1.0), (6.0,0.0), (1.5,1.5) /)
  aamat(4,:) = (/ (1.0,-1.0), (1.0,-1.0), (1.5,-1.5), (7.0,0.0) /)

  call modcholmat_c(4,aamat,ccmat)

  write(*,*) 'Test 4: complex general matrix'
  write(*,*) '-----------------------'

  write(*,*) aamat(1,:)
  write(*,*) aamat(2,:)
  write(*,*) aamat(3,:)
  write(*,*) aamat(4,:)

  write(*,*) '-----------------------'

  write(*,*) ccmat(1,:)
  write(*,*) ccmat(2,:)
  write(*,*) ccmat(3,:)
  write(*,*) ccmat(4,:)

  write(*,*) '-----------------------'

  ccmat = matmul(ccmat,transpose(conjg(ccmat)))

  write(*,*) ccmat(1,:)
  write(*,*) ccmat(2,:)
  write(*,*) ccmat(3,:)
  write(*,*) ccmat(4,:)

  write(*,*) '-----------------------'

!!$  tmat = transpose(ccmat)
!!$
!!$  write(*,*) tmat(1,:)
!!$  write(*,*) tmat(2,:)
!!$  write(*,*) tmat(3,:)
!!$  write(*,*) tmat(4,:)

end program cholfactest


MODULE m_meanstd

      IMPLICIT NONE
      !SAVE
Contains

SUBROUTINE meanstd(A, A_SumSQR, NUM, AVE_A, STD_A)

! ----------------------------------------------------------------------
! MODULE: m_meanstd.f90
! ----------------------------------------------------------------------
! Purpose:
! Compute the mean and std
!
! Input:
!       A  : Sum of a specific parameters
!  A_SumSQR: Sum of squares of  a specific parameters
!      NUM : number of the parameter measured
!
! Output:
!    AVE_A : the mean value
!    STD_A : the STD value
!
! ----------------------------------------------------------------------
! Author :      Dr. Tzupang Tseng, Geoscience  Australia
!
! Created:      21-08-2019
! ----------------------------------------------------------------------

USE mdl_precision
IMPLICIT  NONE

INTEGER(KIND=4)      :: NUM
REAL(KIND = prec_q)  :: A, A_SumSQR
REAL(KIND = prec_q)  :: AVE_A, Var, STD_A

AVE_A = A / NUM
Var   = (A_SumSQR - A*A/NUM)/(NUM-1)
STD_A = SQRT(Var)

END SUBROUTINE
END