cBHEADER**********************************************************************
c Copyright (c) 2008,  Lawrence Livermore National Security, LLC.
c Produced at the Lawrence Livermore National Laboratory.
c This file is part of HYPRE.  See file COPYRIGHT for details.
c
c HYPRE is free software; you can redistribute it and/or modify it under the
c terms of the GNU Lesser General Public License (as published by the Free
c Software Foundation) version 2.1 dated February 1999.
c
c $Revision: 1.5 $
cEHEADER**********************************************************************
c-----------------------------------------------------------------------
c Test driver for unstructured matrix interface (structured storage)
c-----------------------------------------------------------------------

c-----------------------------------------------------------------------
c Standard 7-point laplacian in 3D with grid and anisotropy determined
c as user settings.
c-----------------------------------------------------------------------

      program test

      implicit none

      include 'mpif.h'

      integer MAXZONS, MAXBLKS, MAXDIM, MAXLEVELS
      integer HYPRE_PARCSR

      parameter (MAXZONS=4194304)
      parameter (MAXBLKS=32)
      parameter (MAXDIM=3)
      parameter (MAXLEVELS=25)
      parameter (HYPRE_PARCSR=5555)

      integer             num_procs, myid

      integer             dim
      integer             nx, ny, nz
      integer             Px, Py, Pz
      integer             bx, by, bz
      double precision    cx, cy, cz
      integer             n_pre, n_post
      integer             solver_id
      integer             precond_id

      integer             setup_type
      integer             debug_flag, ioutdat, k_dim
      integer             nlevels

      integer             zero, one
      parameter           (zero = 0, one = 1)
      integer             maxiter, num_iterations
      integer             generate_matrix, generate_rhs
      character           matfile(32), vecfile(32)
      character*31        matfile_str, vecfile_str

      double precision    tol, pc_tol, convtol
      parameter           (pc_tol = 0.0)
      double precision    final_res_norm

c parameters for BoomerAMG
      integer             hybrid, coarsen_type, measure_type
      integer             cycle_type
      integer             smooth_num_sweep
      integer*8           num_grid_sweeps
      integer*8           num_grid_sweeps2(4)
      integer*8           grid_relax_type
      integer*8           grid_relax_points
      integer*8           relax_weights
      double precision    strong_threshold, trunc_factor, drop_tol
      double precision    max_row_sum
      data                max_row_sum /1.0/

c parameters for ParaSails
      double precision    sai_threshold
      double precision    sai_filter

      integer*8           A, A_storage
      integer*8           b, b_storage
      integer*8           x, x_storage

      integer*8           solver
      integer*8           precond
      integer*8           precond_gotten
      integer*8           row_starts

      double precision    values(4)

      integer             p, q, r

      integer             ierr

      integer             i
      integer             first_local_row, last_local_row
      integer             first_local_col, last_local_col
      integer             indices(MAXZONS)
      double precision    vals(MAXZONS)

      integer             dof_func(1000), j

c-----------------------------------------------------------------------
c     Initialize MPI
c-----------------------------------------------------------------------

      call MPI_INIT(ierr)

      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)

c-----------------------------------------------------------------------
c     Set defaults
c-----------------------------------------------------------------------

      dim = 3

      nx = 10
      ny = 10
      nz = 10

      Px  = num_procs
      Py  = 1
      Pz  = 1

      bx = 1
      by = 1
      bz = 1

      cx = 1.0
      cy = 1.0
      cz = 1.0

      n_pre  = 1
      n_post = 1

      solver_id = 3

c-----------------------------------------------------------------------
c     Read options
c-----------------------------------------------------------------------

c     open( 5, file='parcsr_linear_solver.in', status='old')
c
c     read( 5, *) dim
c
c     read( 5, *) nx
c     read( 5, *) ny
c     read( 5, *) nz
c
c     read( 5, *) Px
c     read( 5, *) Py
c     read( 5, *) Pz
c
c     read( 5, *) bx
c     read( 5, *) by
c     read( 5, *) bz
c
c     read( 5, *) cx
c     read( 5, *) cy
c     read( 5, *) cz
c
c     read( 5, *) n_pre
c     read( 5, *) n_post
c
c     write(6,*) 'Generate matrix? !0 yes, 0 no (from file)'
      read(5,*) generate_matrix

      if (generate_matrix .eq. 0) then
c       write(6,*) 'What file to use for matrix (<= 31 chars)?'
        read(5,*) matfile_str
        i = 1
  100   if (matfile_str(i:i) .ne. ' ') then
          matfile(i) = matfile_str(i:i)
        else
          goto 200
        endif
        i = i + 1
        goto 100
  200   matfile(i) = char(0)
      endif

c     write(6,*) 'Generate right-hand side? !0 yes, 0 no (from file)'
      read(5,*) generate_rhs

      if (generate_rhs .eq. 0) then
c       write(6,*)
c    &    'What file to use for right-hand side (<= 31 chars)?'
        read(5,*) vecfile_str
        i = 1
  300   if (vecfile_str(i:i) .ne. ' ') then
          vecfile(i) = vecfile_str(i:i)
        else
          goto 400
        endif
        i = i + 1
        goto 300
  400   vecfile(i) = char(0)
      endif

c     write(6,*) 'What solver_id?'
c     write(6,*) '0 AMG, 1 AMG-PCG, 2 DS-PCG, 3 AMG-GMRES, 4 DS-GMRES,'
c     write(6,*) '5 AMG-CGNR, 6 DS-CGNR, 7 PILUT-GMRES, 8 ParaSails-GMRES,'
c     write(6,*) '9 AMG-BiCGSTAB, 10 DS-BiCGSTAB'
      read(5,*) solver_id

      if (solver_id .eq. 7) then
c       write(6,*) 'What drop tolerance?  <0 do not drop'
        read(5,*) drop_tol
      endif

c     write(6,*) 'What relative residual norm tolerance?'
      read(5,*) tol

c     close( 5 )

c-----------------------------------------------------------------------
c     Check a few things
c-----------------------------------------------------------------------

      if ((Px*Py*Pz) .ne. num_procs) then
         print *, 'Error: Invalid number of processors or topology'
         stop
      endif

      if ((dim .lt. 1) .or. (dim .gt. 3)) then
         print *, 'Error: Invalid problem dimension'
         stop
      endif

      if ((nx*ny*nz) .gt. MAXZONS) then
         print *, 'Error: Invalid number of zones'
         stop
      endif

      if ((bx*by*bz) .gt. MAXBLKS) then
         print *, 'Error: Invalid number of blocks'
         stop
      endif

c-----------------------------------------------------------------------
c     Print driver parameters
c-----------------------------------------------------------------------

      if (myid .eq. 0) then
         print *, 'Running with these driver parameters:'
         print *, '  (nx, ny, nz)    = (', nx, ',', ny, ',', nz, ')'
         print *, '  (Px, Py, Pz)    = (',  Px, ',',  Py, ',',  Pz, ')'
         print *, '  (bx, by, bz)    = (', bx, ',', by, ',', bz, ')'
         print *, '  (cx, cy, cz)    = (', cx, ',', cy, ',', cz, ')'
         print *, '  (n_pre, n_post) = (', n_pre, ',', n_post, ')'
         print *, '  dim             = ', dim
      endif

c-----------------------------------------------------------------------
c     Compute some grid and processor information
c-----------------------------------------------------------------------

      if (dim .eq. 1) then

c        compute p from Px and myid
         p = mod(myid,Px)

      elseif (dim .eq. 2) then

c        compute p,q from Px, Py and myid
         p = mod(myid,Px)
         q = mod(((myid - p)/Px),Py)

      elseif (dim .eq. 3) then

c        compute p,q,r from Px,Py,Pz and myid
         p = mod(myid,Px)
         q = mod((( myid - p)/Px),Py)
         r = (myid - (p + Px*q))/(Px*Py)

      endif

c----------------------------------------------------------------------
c     Set up the matrix
c-----------------------------------------------------------------------

      values(2) = -cx
      values(3) = -cy
      values(4) = -cz

      values(1) = 0.0
      if (nx .gt. 1) values(1) = values(1) + 2d0*cx
      if (ny .gt. 1) values(1) = values(1) + 2d0*cy
      if (nz .gt. 1) values(1) = values(1) + 2d0*cz

c Generate a Dirichlet Laplacian
      if (generate_matrix .eq. 0) then

        call HYPRE_IJMatrixRead(matfile, MPI_COMM_WORLD,
     &                          HYPRE_PARCSR, A, ierr)

        call HYPRE_IJMatrixGetObject(A, A_storage, ierr)

        call HYPRE_ParCSRMatrixGetLocalRange(A_storage,
     &            first_local_row, last_local_row,
     &            first_local_col, last_local_col, ierr)

      else

        call HYPRE_GenerateLaplacian(MPI_COMM_WORLD, nx, ny, nz,
     &                               Px, Py, Pz, p, q, r, values,
     &                               A_storage, ierr)

        call HYPRE_ParCSRMatrixGetLocalRange(A_storage,
     &            first_local_row, last_local_row,
     &            first_local_col, last_local_col, ierr)

        call HYPRE_IJMatrixCreate(MPI_COMM_WORLD,
     &            first_local_row, last_local_row,
     &            first_local_col, last_local_col, A, ierr)

        call HYPRE_IJMatrixSetObject(A, A_storage, ierr)

        call HYPRE_IJMatrixSetObjectType(A, HYPRE_PARCSR, ierr)

      endif

      matfile(1)  = 'd'
      matfile(2)  = 'r'
      matfile(3)  = 'i'
      matfile(4)  = 'v'
      matfile(5)  = 'e'
      matfile(6)  = 'r'
      matfile(7)  = '.'
      matfile(8)  = 'o'
      matfile(9)  = 'u'
      matfile(10) = 't'
      matfile(11) = '.'
      matfile(12) = 'A'
      matfile(13) = char(0)

      call HYPRE_IJMatrixPrint(A, matfile, ierr)

      call hypre_ParCSRMatrixRowStarts(A_storage, row_starts, ierr)

c-----------------------------------------------------------------------
c     Set up the rhs and initial guess
c-----------------------------------------------------------------------

      if (generate_rhs .eq. 0) then

        call HYPRE_IJVectorRead(vecfile, MPI_COMM_WORLD,
     &                          HYPRE_PARCSR, b, ierr)

        call HYPRE_IJVectorGetObject(b, b_storage, ierr)

      else

        call HYPRE_IJVectorCreate(MPI_COMM_WORLD, first_local_col,
     &                            last_local_col, b, ierr)
        call HYPRE_IJVectorSetObjectType(b, HYPRE_PARCSR, ierr)
        call HYPRE_IJVectorInitialize(b, ierr)

c Set up a Dirichlet 0 problem
        do i = 1, last_local_col - first_local_col + 1
          indices(i) = first_local_col - 1 + i
          vals(i) = 1.
        enddo

        call HYPRE_IJVectorSetValues(b,
     &    last_local_col - first_local_col + 1, indices, vals, ierr)

        call HYPRE_IJVectorGetObject(b, b_storage, ierr)

        vecfile(1)  = 'd'
        vecfile(2)  = 'r'
        vecfile(3)  = 'i'
        vecfile(4)  = 'v'
        vecfile(5)  = 'e'
        vecfile(6)  = 'r'
        vecfile(7)  = '.'
        vecfile(8)  = 'o'
        vecfile(9)  = 'u'
        vecfile(10) = 't'
        vecfile(11) = '.'
        vecfile(12) = 'b'
        vecfile(13) = char(0)

        call HYPRE_IJVectorPrint(b, vecfile, ierr)

      endif

      call HYPRE_IJVectorCreate(MPI_COMM_WORLD, first_local_col,
     &                          last_local_col, x, ierr)
      call HYPRE_IJVectorSetObjectType(x, HYPRE_PARCSR, ierr)
      call HYPRE_IJVectorInitialize(x, ierr)
      do i = 1, last_local_col - first_local_col + 1
          indices(i) = first_local_col - 1 + i
          vals(i) = 0.
      enddo
      call HYPRE_IJVectorSetValues(x,
     &  last_local_col - first_local_col + 1, indices, vals, ierr)

c Choose a nonzero initial guess
      call HYPRE_IJVectorGetObject(x, x_storage, ierr)

      vecfile(1)  = 'd'
      vecfile(2)  = 'r'
      vecfile(3)  = 'i'
      vecfile(4)  = 'v'
      vecfile(5)  = 'e'
      vecfile(6)  = 'r'
      vecfile(7)  = '.'
      vecfile(8)  = 'o'
      vecfile(9)  = 'u'
      vecfile(10) = 't'
      vecfile(11) = '.'
      vecfile(12) = 'x'
      vecfile(13) = '0'
      vecfile(14) = char(0)

      call HYPRE_IJVectorPrint(x, vecfile, ierr)

c-----------------------------------------------------------------------
c     Solve the linear system
c-----------------------------------------------------------------------

c     General solver parameters, passing hard coded constants
c     will break the interface.

      maxiter = 100
      convtol = 0.9
      debug_flag = 0
      ioutdat = 1

      if (solver_id .eq. 0) then

c Set defaults for BoomerAMG
        maxiter = 500
        coarsen_type = 6
        hybrid = 1
        measure_type = 0
        strong_threshold = 0.25
        trunc_factor = 0.0
        cycle_type = 1
        smooth_num_sweep = 1

        print *, 'Solver: AMG'

        call HYPRE_BoomerAMGCreate(solver, ierr)
        call HYPRE_BoomerAMGSetCoarsenType(solver,
     &                                  (hybrid*coarsen_type), ierr)
        call HYPRE_BoomerAMGSetMeasureType(solver, measure_type, ierr)
        call HYPRE_BoomerAMGSetTol(solver, tol, ierr)
        call HYPRE_BoomerAMGSetStrongThrshld(solver,
     &                                      strong_threshold, ierr)
        call HYPRE_BoomerAMGSetTruncFactor(solver, trunc_factor, ierr)
        call HYPRE_BoomerAMGSetPrintLevel(solver, ioutdat,ierr)
        call HYPRE_BoomerAMGSetPrintFileName(solver,"test.out.log",ierr)
        call HYPRE_BoomerAMGSetMaxIter(solver, maxiter, ierr)
        call HYPRE_BoomerAMGSetCycleType(solver, cycle_type, ierr)

c RDF: Used this to test the fortran interface for SetDofFunc
c        do i = 1, 1000/2
c           j = 2*i-1
c           dof_func(j) = 0
c           j = j + 1
c           dof_func(j) = 1
c        enddo
c        call HYPRE_BoomerAMGSetNumFunctions(solver, 2, ierr)
c        call HYPRE_BoomerAMGSetDofFunc(solver, dof_func, ierr)

c        call HYPRE_BoomerAMGInitGridRelaxatn(num_grid_sweeps,
c     &                                      grid_relax_type,
c     &                                      grid_relax_points,
c     &                                      coarsen_type,
c     &                                      relax_weights,
c     &                                      MAXLEVELS,ierr)
c        num_grid_sweeps2(1) = 1
c        num_grid_sweeps2(2) = 1
c        num_grid_sweeps2(3) = 1
c        num_grid_sweeps2(4) = 1
c        call HYPRE_BoomerAMGSetNumGridSweeps(solver,
c     &                                       num_grid_sweeps2, ierr)
c        call HYPRE_BoomerAMGSetGridRelaxType(solver,
c     &                                       grid_relax_type, ierr)
c        call HYPRE_BoomerAMGSetRelaxWeight(solver,
c     &                                     relax_weights, ierr)
c       call HYPRE_BoomerAMGSetSmoothOption(solver, smooth_option,
c    &                                      ierr)
c       call HYPRE_BoomerAMGSetSmoothNumSwp(solver, smooth_num_sweep,
c    &                                      ierr)
c        call HYPRE_BoomerAMGSetGridRelaxPnts(solver,
c     &                                       grid_relax_points,
c     &                                       ierr)
        call HYPRE_BoomerAMGSetMaxLevels(solver, MAXLEVELS, ierr)
        call HYPRE_BoomerAMGSetMaxRowSum(solver, max_row_sum,
     &                                   ierr)
        call HYPRE_BoomerAMGSetDebugFlag(solver, debug_flag, ierr)
        call HYPRE_BoomerAMGSetup(solver, A_storage, b_storage,
     &                         x_storage, ierr)
        call HYPRE_BoomerAMGSolve(solver, A_storage, b_storage,
     &                         x_storage, ierr)
        call HYPRE_BoomerAMGGetNumIterations(solver, num_iterations,
     &						ierr)
        call HYPRE_BoomerAMGGetFinalReltvRes(solver, final_res_norm,
     &                                       ierr)
        call HYPRE_BoomerAMGDestroy(solver, ierr)

      endif

      if (solver_id .eq. 3 .or. solver_id .eq. 4 .or.
     &    solver_id .eq. 7 .or. solver_id .eq. 8) then

        maxiter = 100
        k_dim = 5

c       Solve the system using preconditioned GMRES

        call HYPRE_ParCSRGMRESCreate(MPI_COMM_WORLD, solver, ierr)
        call HYPRE_ParCSRGMRESSetKDim(solver, k_dim, ierr)
        call HYPRE_ParCSRGMRESSetMaxIter(solver, maxiter, ierr)
        call HYPRE_ParCSRGMRESSetTol(solver, tol, ierr)
        call HYPRE_ParCSRGMRESSetLogging(solver, one, ierr)

        if (solver_id .eq. 4) then

          print *, 'Solver: DS-GMRES'

          precond_id = 1
          precond = 0

          call HYPRE_ParCSRGMRESSetPrecond(solver, precond_id,
     &                                     precond, ierr)

        else if (solver_id .eq. 3) then

          print *, 'Solver: AMG-GMRES'

          precond_id = 2

c Set defaults for BoomerAMG
          maxiter = 1
          coarsen_type = 6
          hybrid = 1
          measure_type = 0
          setup_type = 1
          strong_threshold = 0.25
          trunc_factor = 0.0
          cycle_type = 1
          smooth_num_sweep = 1

          call HYPRE_BoomerAMGCreate(precond, ierr)
          call HYPRE_BoomerAMGSetTol(precond, pc_tol, ierr)
          call HYPRE_BoomerAMGSetCoarsenType(precond,
     &                                    (hybrid*coarsen_type), ierr)
          call HYPRE_BoomerAMGSetMeasureType(precond, measure_type,
     &						ierr)
          call HYPRE_BoomerAMGSetStrongThrshld(precond,
     &                                        strong_threshold, ierr)
          call HYPRE_BoomerAMGSetTruncFactor(precond, trunc_factor,
     &                                       ierr)
          call HYPRE_BoomerAMGSetPrintLevel(precond, ioutdat, ierr)
          call HYPRE_BoomerAMGSetPrintFileName(precond, "test.out.log",
     &                                         ierr)
          call HYPRE_BoomerAMGSetMaxIter(precond, maxiter, ierr)
          call HYPRE_BoomerAMGSetCycleType(precond, cycle_type, ierr)
          call HYPRE_BoomerAMGInitGridRelaxatn(num_grid_sweeps,
     &                                        grid_relax_type,
     &                                        grid_relax_points,
     &                                        coarsen_type,
     &                                        relax_weights,
     &                                        MAXLEVELS,ierr)
          call HYPRE_BoomerAMGSetNumGridSweeps(precond,
     &                                         num_grid_sweeps, ierr)
          call HYPRE_BoomerAMGSetGridRelaxType(precond,
     &                                         grid_relax_type, ierr)
          call HYPRE_BoomerAMGSetRelaxWeight(precond,
     &                                       relax_weights, ierr)
c         call HYPRE_BoomerAMGSetSmoothOption(precond, smooth_option,
c    &                                        ierr)
c         call HYPRE_BoomerAMGSetSmoothNumSwp(precond, smooth_num_sweep,
c    &                                        ierr)
          call HYPRE_BoomerAMGSetGridRelaxPnts(precond,
     &                                        grid_relax_points, ierr)
          call HYPRE_BoomerAMGSetMaxLevels(precond,
     &                                  MAXLEVELS, ierr)
          call HYPRE_BoomerAMGSetMaxRowSum(precond, max_row_sum,
     &                                     ierr)
          call HYPRE_ParCSRGMRESSetPrecond(solver, precond_id,
     &                                     precond, ierr)

          call HYPRE_BoomerAMGSetSetupType(precond,setup_type,ierr)

        else if (solver_id .eq. 7) then

          print *, 'Solver: Pilut-GMRES'

          precond_id = 3

          call HYPRE_ParCSRPilutCreate(MPI_COMM_WORLD,
     &                                 precond, ierr)

          if (ierr .ne. 0) write(6,*) 'ParCSRPilutCreate error'

          call HYPRE_ParCSRGMRESSetPrecond(solver, precond_id,
     &                                     precond, ierr)

          if (drop_tol .ge. 0.)
     &        call HYPRE_ParCSRPilutSetDropToleran(precond,
     &                                              drop_tol, ierr)

        else if (solver_id .eq. 8) then

          print *, 'Solver: ParaSails-GMRES'

          precond_id = 4

          call HYPRE_ParaSailsCreate(MPI_COMM_WORLD, precond,
     &                               ierr)
          call HYPRE_ParCSRGMRESSetPrecond(solver, precond_id,
     &                                     precond, ierr)

          sai_threshold = 0.1
          nlevels       = 1
          sai_filter    = 0.1

          call HYPRE_ParaSailsSetParams(precond, sai_threshold,
     &                                  nlevels, ierr)
          call HYPRE_ParaSailsSetFilter(precond, sai_filter, ierr)
          call HYPRE_ParaSailsSetLogging(precond, ioutdat, ierr)

        endif

        call HYPRE_ParCSRGMRESGetPrecond(solver, precond_gotten,
     &                                   ierr)

        if (precond_gotten .ne. precond) then
          print *, 'HYPRE_ParCSRGMRESGetPrecond got bad precond'
          stop
        else
          print *, 'HYPRE_ParCSRGMRESGetPrecond got good precond'
        endif

        call HYPRE_ParCSRGMRESSetup(solver, A_storage, b_storage,
     &                              x_storage, ierr)
        call HYPRE_ParCSRGMRESSolve(solver, A_storage, b_storage,
     &                              x_storage, ierr)
        call HYPRE_ParCSRGMRESGetNumIteratio(solver,
     &                                       num_iterations, ierr)
        call HYPRE_ParCSRGMRESGetFinalRelati(solver,
     &                                       final_res_norm, ierr)

        if (solver_id .eq. 3) then
           call HYPRE_BoomerAMGDestroy(precond, ierr)
        else if (solver_id .eq. 7) then
           call HYPRE_ParCSRPilutDestroy(precond, ierr)
        else if (solver_id .eq. 8) then
           call HYPRE_ParaSailsDestroy(precond, ierr)
        endif

        call HYPRE_ParCSRGMRESDestroy(solver, ierr)

      endif

      if (solver_id .eq. 1 .or. solver_id .eq. 2) then

        maxiter = 500

        call HYPRE_ParCSRPCGCreate(MPI_COMM_WORLD, solver, ierr)
        call HYPRE_ParCSRPCGSetMaxIter(solver, maxiter, ierr)
        call HYPRE_ParCSRPCGSetTol(solver, tol, ierr)
        call HYPRE_ParCSRPCGSetTwoNorm(solver, one, ierr)
        call HYPRE_ParCSRPCGSetRelChange(solver, zero, ierr)
        call HYPRE_ParCSRPCGSetPrintLevel(solver, one, ierr)

        if (solver_id .eq. 2) then

          print *, 'Solver: DS-PCG'

          precond_id = 1
          precond = 0

          call HYPRE_ParCSRPCGSetPrecond(solver, precond_id,
     &                                   precond, ierr)

        else if (solver_id .eq. 1) then

          print *, 'Solver: AMG-PCG'

          precond_id = 2

c Set defaults for BoomerAMG
          maxiter = 1
          coarsen_type = 6
          hybrid = 1
          measure_type = 0
          setup_type = 1
          strong_threshold = 0.25
          trunc_factor = 0.0
          cycle_type = 1
          smooth_num_sweep = 1

          call HYPRE_BoomerAMGCreate(precond, ierr)
          call HYPRE_BoomerAMGSetTol(precond, pc_tol, ierr)
          call HYPRE_BoomerAMGSetCoarsenType(precond,
     &                                       (hybrid*coarsen_type),
     &                                       ierr)
          call HYPRE_BoomerAMGSetMeasureType(precond, measure_type,
     &                                       ierr)
          call HYPRE_BoomerAMGSetStrongThrshld(precond,
     &                                         strong_threshold,
     &                                         ierr)
          call HYPRE_BoomerAMGSetTruncFactor(precond, trunc_factor,
     &                                       ierr)
          call HYPRE_BoomerAMGSetPrintLevel(precond, ioutdat,ierr)
          call HYPRE_BoomerAMGSetPrintFileName(precond, "test.out.log",
     &                                         ierr)
          call HYPRE_BoomerAMGSetMaxIter(precond, maxiter, ierr)
          call HYPRE_BoomerAMGSetCycleType(precond, cycle_type, ierr)
          call HYPRE_BoomerAMGInitGridRelaxatn(num_grid_sweeps,
     &                                         grid_relax_type,
     &                                         grid_relax_points,
     &                                         coarsen_type,
     &                                         relax_weights,
     &                                         MAXLEVELS, ierr)
          call HYPRE_BoomerAMGSetNumGridSweeps(precond,
     &                                         num_grid_sweeps, ierr)
          call HYPRE_BoomerAMGSetGridRelaxType(precond,
     &                                         grid_relax_type, ierr)
          call HYPRE_BoomerAMGSetRelaxWeight(precond,
     &                                       relax_weights, ierr)
c         call HYPRE_BoomerAMGSetSmoothOption(precond, smooth_option,
c    &                                        ierr)
c         call HYPRE_BoomerAMGSetSmoothNumSwp(precond,
c    &                                        smooth_num_sweep,
c    &                                        ierr)
          call HYPRE_BoomerAMGSetGridRelaxPnts(precond,
     &                                         grid_relax_points, ierr)
          call HYPRE_BoomerAMGSetMaxLevels(precond, MAXLEVELS, ierr)
          call HYPRE_BoomerAMGSetMaxRowSum(precond, max_row_sum,
     &                                     ierr)

          call HYPRE_ParCSRPCGSetPrecond(solver, precond_id,
     &                                   precond, ierr)

        endif

        call HYPRE_ParCSRPCGGetPrecond(solver,precond_gotten,ierr)

        if (precond_gotten .ne. precond) then
          print *, 'HYPRE_ParCSRPCGGetPrecond got bad precond'
          stop
        else
          print *, 'HYPRE_ParCSRPCGGetPrecond got good precond'
        endif

        call HYPRE_ParCSRPCGSetup(solver, A_storage, b_storage,
     &                            x_storage, ierr)
        call HYPRE_ParCSRPCGSolve(solver, A_storage, b_storage,
     &                            x_storage, ierr)
        call HYPRE_ParCSRPCGGetNumIterations(solver, num_iterations,
     &                                       ierr)
        call HYPRE_ParCSRPCGGetFinalRelative(solver, final_res_norm,
     &                                       ierr)

        if (solver_id .eq. 1) then
          call HYPRE_BoomerAMGDestroy(precond, ierr)
        endif

        call HYPRE_ParCSRPCGDestroy(solver, ierr)

      endif

      if (solver_id .eq. 5 .or. solver_id .eq. 6) then

        maxiter = 1000

        call HYPRE_ParCSRCGNRCreate(MPI_COMM_WORLD, solver, ierr)
        call HYPRE_ParCSRCGNRSetMaxIter(solver, maxiter, ierr)
        call HYPRE_ParCSRCGNRSetTol(solver, tol, ierr)
        call HYPRE_ParCSRCGNRSetLogging(solver, one, ierr)

        if (solver_id .eq. 6) then

          print *, 'Solver: DS-CGNR'

          precond_id = 1
          precond = 0

          call HYPRE_ParCSRCGNRSetPrecond(solver, precond_id,
     &                                    precond, ierr)

        else if (solver_id .eq. 5) then

          print *, 'Solver: AMG-CGNR'

          precond_id = 2

c Set defaults for BoomerAMG
          maxiter = 1
          coarsen_type = 6
          hybrid = 1
          measure_type = 0
          setup_type = 1
          strong_threshold = 0.25
          trunc_factor = 0.0
          cycle_type = 1
          smooth_num_sweep = 1

          call HYPRE_BoomerAMGCreate(precond, ierr)
          call HYPRE_BoomerAMGSetTol(precond, pc_tol, ierr)
          call HYPRE_BoomerAMGSetCoarsenType(precond,
     &                                       (hybrid*coarsen_type),
     &                                       ierr)
          call HYPRE_BoomerAMGSetMeasureType(precond, measure_type,
     &                                       ierr)
          call HYPRE_BoomerAMGSetStrongThrshld(precond,
     &                                         strong_threshold, ierr)
          call HYPRE_BoomerAMGSetTruncFactor(precond, trunc_factor,
     &                                       ierr)
          call HYPRE_BoomerAMGSetPrintLevel(precond, ioutdat,ierr)
          call HYPRE_BoomerAMGSetPrintFileName(precond, "test.out.log",
     &                                         ierr)
          call HYPRE_BoomerAMGSetMaxIter(precond, maxiter, ierr)
          call HYPRE_BoomerAMGSetCycleType(precond, cycle_type, ierr)
          call HYPRE_BoomerAMGInitGridRelaxatn(num_grid_sweeps,
     &                                         grid_relax_type,
     &                                         grid_relax_points,
     &                                         coarsen_type,
     &                                         relax_weights,
     &                                         MAXLEVELS,ierr)
          call HYPRE_BoomerAMGSetNumGridSweeps(precond,
     &                                         num_grid_sweeps, ierr)
          call HYPRE_BoomerAMGSetGridRelaxType(precond,
     &                                         grid_relax_type, ierr)
          call HYPRE_BoomerAMGSetRelaxWeight(precond,
     &                                       relax_weights, ierr)
c         call HYPRE_BoomerAMGSetSmoothOption(precond, smooth_option,
c    &                                        ierr)
c         call HYPRE_BoomerAMGSetSmoothNumSwp(precond, smooth_num_sweep,
c    &                                        ierr)
          call HYPRE_BoomerAMGSetGridRelaxPnts(precond,
     &                                         grid_relax_points,
     &                                         ierr)
          call HYPRE_BoomerAMGSetMaxLevels(precond, MAXLEVELS, ierr)
          call HYPRE_BoomerAMGSetMaxRowSum(precond, max_row_sum,
     &                                     ierr)

          call HYPRE_ParCSRCGNRSetPrecond(solver, precond_id, precond,
     &                                    ierr)
        endif

        call HYPRE_ParCSRCGNRGetPrecond(solver,precond_gotten,ierr)

        if (precond_gotten .ne. precond) then
          print *, 'HYPRE_ParCSRCGNRGetPrecond got bad precond'
          stop
        else
          print *, 'HYPRE_ParCSRCGNRGetPrecond got good precond'
        endif

        call HYPRE_ParCSRCGNRSetup(solver, A_storage, b_storage,
     &                             x_storage, ierr)
        call HYPRE_ParCSRCGNRSolve(solver, A_storage, b_storage,
     &                             x_storage, ierr)
        call HYPRE_ParCSRCGNRGetNumIteration(solver, num_iterations,
     &                                      ierr)
        call HYPRE_ParCSRCGNRGetFinalRelativ(solver, final_res_norm,
     &                                       ierr)

        if (solver_id .eq. 5) then
          call HYPRE_BoomerAMGDestroy(precond, ierr)
        endif

        call HYPRE_ParCSRCGNRDestroy(solver, ierr)

      endif

      if (solver_id .eq. 9 .or. solver_id .eq. 10) then

        maxiter = 1000

        call HYPRE_ParCSRBiCGSTABCreate(MPI_COMM_WORLD, solver, ierr)
        call HYPRE_ParCSRBiCGSTABSetMaxIter(solver, maxiter, ierr)
        call HYPRE_ParCSRBiCGSTABSetTol(solver, tol, ierr)
        call HYPRE_ParCSRBiCGSTABSetLogging(solver, one, ierr)

        if (solver_id .eq. 10) then

          print *, 'Solver: DS-BiCGSTAB'

          precond_id = 1
          precond = 0

          call HYPRE_ParCSRBiCGSTABSetPrecond(solver, precond_id,
     &                                        precond, ierr)

        else if (solver_id .eq. 9) then

          print *, 'Solver: AMG-BiCGSTAB'

          precond_id = 2

c Set defaults for BoomerAMG
          maxiter = 1
          coarsen_type = 6
          hybrid = 1
          measure_type = 0
          setup_type = 1
          strong_threshold = 0.25
          trunc_factor = 0.0
          cycle_type = 1
          smooth_num_sweep = 1

          call HYPRE_BoomerAMGCreate(precond, ierr)
          call HYPRE_BoomerAMGSetTol(precond, pc_tol, ierr)
          call HYPRE_BoomerAMGSetCoarsenType(precond,
     &                                       (hybrid*coarsen_type),
     &                                       ierr)
          call HYPRE_BoomerAMGSetMeasureType(precond, measure_type,
     &                                       ierr)
          call HYPRE_BoomerAMGSetStrongThrshld(precond,
     &                                         strong_threshold,
     &                                         ierr)
          call HYPRE_BoomerAMGSetTruncFactor(precond, trunc_factor,
     &                                       ierr)
          call HYPRE_BoomerAMGSetPrintLevel(precond, ioutdat,ierr)
          call HYPRE_BoomerAMGSetPrintFileName(precond, "test.out.log",
     &                                         ierr)
          call HYPRE_BoomerAMGSetMaxIter(precond, maxiter, ierr)
          call HYPRE_BoomerAMGSetCycleType(precond, cycle_type, ierr)
          call HYPRE_BoomerAMGInitGridRelaxatn(num_grid_sweeps,
     &                                         grid_relax_type,
     &                                         grid_relax_points,
     &                                         coarsen_type,
     &                                         relax_weights,
     &                                         MAXLEVELS, ierr)
          call HYPRE_BoomerAMGSetNumGridSweeps(precond,
     &                                         num_grid_sweeps, ierr)
          call HYPRE_BoomerAMGSetGridRelaxType(precond,
     &                                         grid_relax_type, ierr)
          call HYPRE_BoomerAMGSetRelaxWeight(precond,
     &                                       relax_weights, ierr)
c         call HYPRE_BoomerAMGSetSmoothOption(precond, smooth_option,
c    &                                        ierr)
c         call HYPRE_BoomerAMGSetSmoothNumSwp(precond, smooth_num_sweep,
c    &                                        ierr)
          call HYPRE_BoomerAMGSetGridRelaxPnts(precond,
     &                                         grid_relax_points, ierr)
          call HYPRE_BoomerAMGSetMaxLevels(precond, MAXLEVELS, ierr)
          call HYPRE_BoomerAMGSetMaxRowSum(precond, max_row_sum,
     &                                     ierr)

          call HYPRE_ParCSRBiCGSTABSetPrecond(solver, precond_id,
     &                                        precond,
     &                                        ierr)

        endif

        call HYPRE_ParCSRBiCGSTABGetPrecond(solver,precond_gotten,ierr)

        if (precond_gotten .ne. precond) then
          print *, 'HYPRE_ParCSRBiCGSTABGetPrecond got bad precond'
          stop
        else
          print *, 'HYPRE_ParCSRBiCGSTABGetPrecond got good precond'
        endif

        call HYPRE_ParCSRBiCGSTABSetup(solver, A_storage, b_storage,
     &                                 x_storage, ierr)
        call HYPRE_ParCSRBiCGSTABSolve(solver, A_storage, b_storage,
     &                                 x_storage, ierr)
        call HYPRE_ParCSRBiCGSTABGetNumIter(solver,
     &                                      num_iterations,
     &                                      ierr)
        call HYPRE_ParCSRBiCGSTABGetFinalRel(solver,
     &                                       final_res_norm,
     &                                       ierr)

        if (solver_id .eq. 9) then
          call HYPRE_BoomerAMGDestroy(precond, ierr)
        endif

        call HYPRE_ParCSRBiCGSTABDestroy(solver, ierr)

      endif

c-----------------------------------------------------------------------
c     Print the solution and other info
c-----------------------------------------------------------------------

      vecfile(1)  = 'd'
      vecfile(2)  = 'r'
      vecfile(3)  = 'i'
      vecfile(4)  = 'v'
      vecfile(5)  = 'e'
      vecfile(6)  = 'r'
      vecfile(7)  = '.'
      vecfile(8)  = 'o'
      vecfile(9)  = 'u'
      vecfile(10) = 't'
      vecfile(11) = '.'
      vecfile(12) = 'x'
      vecfile(13) = char(0)

      call HYPRE_IJVectorPrint(x, vecfile, ierr)

      if (myid .eq. 0) then
         print *, 'Iterations = ', num_iterations
         print *, 'Final Residual Norm = ', final_res_norm
      endif

c-----------------------------------------------------------------------
c     Finalize things
c-----------------------------------------------------------------------

      call HYPRE_ParCSRMatrixDestroy(A_storage, ierr)
      call HYPRE_IJVectorDestroy(b, ierr)
      call HYPRE_IJVectorDestroy(x, ierr)

c     Finalize MPI

      call MPI_FINALIZE(ierr)

      stop
      end


integer, parameter :: ikl = selected_int_kind(8)
integer, parameter :: ikh = selected_int_kind(18)
integer, parameter :: rkl = selected_real_kind(20)
integer, parameter :: rkh = selected_real_kind(50)

integer (kind = ikl) :: il1, il2
integer (kind = ikh) :: ih1, ih2
real (kind = rkl) :: rl1, rl2
real (kind = rkh) :: rh1, rh2
real (kind(1.0q0)) :: q1

integer :: id1, id2
real :: rd1, rd2

! kind conversion to different range
ih1 = il1
il1 = ih1
il1 = il1 + ih1
il1 = id1 + il1

! kind conversion to different precision
rd1 = rl1
rl1 = rh1
rh1 = rl1

rl1 = 1.0q5
q1 = 1.0q5
q1 = rl1

end


SUBROUTINE p83(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.3 One dimensional consolidation analysis using 2-node "rod"
!             elements. Explicit time integration. Element-by-element.
!             Lumped mass.
!-------------------------------------------------------------------------
 USE main
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,j,nels,neq,nlen,nod=2,npri,nprops=1,       &
   np_types,nres,nstep,ntime
 REAL(iwp)::at,a0,dtim,one=1.0_iwp,pt5=0.5_iwp,time,two=2.0_iwp,          &
   zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::ell(:),globma(:),kc(:,:),loads(:),mass(:),mm(:,:),&
   newlo(:),press(:),prop(:,:),store_mm(:,:,:),value(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,np_types
 neq=nels+1
 ALLOCATE(num(nod),etype(nels),kc(nod,nod),mm(nod,nod),press(0:neq),      &
   prop(nprops,np_types),ell(nels),loads(0:neq),newlo(0:neq),mass(nod),   &
   globma(0:neq),store_mm(nod,nod,nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell,dtim,nstep,npri,nres,ntime
 globma=zero
 WRITE(11,'(2(A,I5))')" There are",neq," equations"
!-----------------------global conductivity and "mass" matrix assembly----
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL rod_km(kc,prop(1,etype(iel)),ell(iel))
   mm=zero
   DO i=1,nod
     mm(i,i)=ell(iel)/two
     mass(i)=ell(iel)/two
   END DO
   store_mm(:,:,iel)=mm-kc*dtim
   globma(num)=globma(num)+mass
 END DO elements_1
!-----------------------specify initial and boundary values---------------
 READ(10,*)loads(1:)
 loads(0)=zero
 READ(10,*)fixed_freedoms
 globma(1:)=one/globma(1:)
 IF(fixed_freedoms/=0)then
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
 END IF
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/A,I3,A)')"    Time         Uav     Pressure (node",nres,")"
 WRITE(11,'(3E12.4)')0.0,0.0,loads(nres)
 a0=zero
 DO iel=1,nels
   a0=a0+pt5*ell(iel)*(loads(iel)+loads(iel+1))
 END DO
 timesteps: DO j=1,nstep
   time=j*dtim
   newlo=zero
   elements_2: DO iel=1,nels
     num=(/iel,iel+1/)
     mm=store_mm(:,:,iel)
     newlo(num)=newlo(num)+MATMUL(mm,loads(num))
   END DO elements_2
   newlo(0)=zero
   loads=newlo*globma
   IF(fixed_freedoms/=0)loads(node)=value
   at=zero
   DO iel=1,nels
     at=at+pt5*ell(iel)*(loads(iel)+loads(iel+1))
   END DO
   IF(j==ntime)press(1:)=loads(1:)
   IF(j/npri*npri==j)WRITE(11,'(3E12.4)')time,(a0-at)/a0,loads(nres)
 END DO timesteps
 WRITE(11,'(/A,E10.4,A)')"    Depth     Pressure (time=",ntime*dtim,")"
 WRITE(11,'(3E12.4)')0.0,press(1)
 WRITE(11,'(2E12.4)')(SUM(ell(1:i)),press(i+1),i=1,nels)

END SUBROUTINE p83


      subroutine setaux_sphere(mx,my,mbc,xlower,ylower,
     &      dx,dy,maux,aux,xnormals,ynormals,
     &      xtangents,ytangents,surfnormals)
      implicit none

      integer mbc, mx,my, maux
      integer level, maxlevel, refratio
      double precision xlower, ylower, dx,dy
      double precision aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

      integer i,j,m
      double precision xc,yc

      include 'metric_terms.i'

c     The aux array has the following elements:
c     1  kappa = ratio of cell area to dxc*dyc
c     2  enx = x-component of normal vector to left edge in tangent plane
c     3  eny = y-component of normal vector to left edge in tangent plane
c     4  enz = z-component of normal vector to left edge in tangent plane
c     5  etx = x-component of tangent vector to left edge in tangent plane
c     6  ety = y-component of tangent vector to left edge in tangent plane
c     7  etz = z-component of tangent vector to left edge in tangent plane
c     8  enx = x-component of normal vector to bottom edge in tangent plane
c     9  eny = y-component of normal vector to bottom edge in tangent plane
c     10  enz = z-component of normal vector to bottom edge in tangent plane
c     11  etx = x-component of tangent vector to bottom edge in tangent plane
c     12  ety = y-component of tangent vector to bottom edge in tangent plane
c     13  etz = z-component of tangent vector to bottom edge in tangent plane
c     14  erx = x-component of unit vector in radial direction at cell ctr
c     15  ery = y-component of unit vector in radial direction at cell ctr
c     16  erz = z-component of unit vector in radial direction at cell ctr
c     17  xc at cell center
c     18  yc at cell center
c     19  bathymetry - averaged over all possible finer cells

      do i = 1-mbc,mx+mbc
         do j = 1-mbc,my+mbc
            do m = 1,3
               aux(i,j,1+m) = xnormals(i,j,m)
               aux(i,j,4+m) = xtangents(i,j,m)
            enddo
         enddo
      enddo

      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            do m = 1,3
               aux(i,j,7+m) = ynormals(i,j,m)
               aux(i,j,10+m) = ytangents(i,j,m)
            enddo
         enddo
      enddo

      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            do m = 1,3
               aux(i,j,13+m) = surfnormals(i,j,m)
            enddo
         enddo
      enddo

      end


*deck xyznorm
      subroutine xyznorm(x1,y1,z1,x2,y2,z2)
C
C#######################################################################
C
C     PURPOSE -
C
C     THIS ROUTINE TRANSLATES POINTS FROM THE CURRENT LOCAL COORDINATE
C     SYSTEM TO THE NORMAL COORDINATE SYSTEM.  THE CURRENT ORIGIN AND
C     ROTATION MATRIX ARE USED FOR THE TRANSALTION.
C
C
C     INPUT ARGUMENTS -
C
C        x1 - CURRENT X COORDINATE
C        y1 - CURRENT Y COORDINATE
C        z1 - CURRENT Z COORDINATE
C
C
C     OUTPUT ARGUMENTS -
C
C        x2 - NORMAL X COORDINATE
C        y2 - NORMAL Y COORDINATE
C        z2 - NORMAL Z COORDINATE
C
C
C     CHANGE HISTORY -
C
C        $Log: xyznorm.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.2   Mon Apr 14 17:06:16 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.1   05/11/95 13:14:44   het
CPVCS    Add diffusion solver
CPVCS
CPVCS       Rev 1.0   11/10/94 12:20:42   pvcs
CPVCS    Original version.
C
C
C
C
C#######################################################################
C
      implicit none

      include "chydro.h"

C arguments
      real*8 x1,y1,z1,x2,y2,z2
C variables
      real*8 x0,y0,z0,ax,bx,cx,ay,by,cy,az,bz,cz
C
C#######################################################################
C
C
C     ******************************************************************
C
C     GET THE CURRENT ORIGIN
C
      x0=origc(1)
      y0=origc(2)
      z0=origc(3)
C
C     ******************************************************************
C
C     GET THE CURRENT ROTATION MATRIX
C
      ax=rotatc(1,1)
      bx=rotatc(1,2)
      cx=rotatc(1,3)
      ay=rotatc(2,1)
      by=rotatc(2,2)
      cy=rotatc(2,3)
      az=rotatc(3,1)
      bz=rotatc(3,2)
      cz=rotatc(3,3)
C
C     ******************************************************************
C     TRANSPOSE AND ROTATE THE POINT TO THE REAL ORIGIN AND AXIS
C
      x2=ax*x1 + ay*y1 + az*z1 + x0
      y2=bx*x1 + by*y1 + bz*z1 + y0
      z2=cx*x1 + cy*y1 + cz*z1 + z0
C
C
C     ******************************************************************
C     SET UP THE CFT IMMUNE STATEMENT FOR DDT
C
      goto 9999
 9999 continue
C
      return
      end


program ch0701
    ! Allocatable Arrays
    implicit none

    integer :: number_of_people
    real :: total = 0., average = 0.
    integer :: person
    real, allocatable, dimension(:) :: weight

    print *, ' How many people?'
    read *, number_of_people
    allocate(weight(1:number_of_people))
    do person = 1, number_of_people
        print *, ' type in the weight for person', &
            person
        read *, weight(person)
        total = total+weight(person)
    end do
    average = total/number_of_people
    print *, ' The total of the weights is ', &
        total
    print *, ' Average weight is ', average
    print *, ' ', number_of_people, &
        ' Weights were '
    do person = 1, number_of_people
        print *, weight(person)
    end do
end program


module serv_xnl4v5
contains
SUBROUTINE y_gauleg(x1,x2,x,w,n)
!-------------------------------------------------------------------
INTEGER, intent(in) ::  n    ! Number of intervals
real, intent(in)    ::  x1   ! lower limit of integration interval
real, intent(in)    ::  x2   ! upper limit of integration interval
real, intent(out)   ::  x(n) ! Positions for function evaluations
real, intent(out)   ::  w(n) ! Weights
!
!-----------------------------------------------------------------------
DOUBLE PRECISION EPS
PARAMETER (EPS=3.d-14)
INTEGER i,j,m
DOUBLE PRECISION 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=cos(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

!-----------------------------------------------------------------------------!
subroutine z_cmpcg(sigma,depth,grav,cg)
!-----------------------------------------------------------------------------!
!
!   +-------+    ALKYON Hydraulic Consultancy & Research
!   |       |    Gerbrant van Vledder
!   |   +---+
!   |   | +---+
!   +---+ |   |
!         +---+
!
implicit none
!
!  0. Update history
!
!     12/01/2001  Initial version
!     11/04/2001  Check included for the cases tat sigma < 0 or depth <0
!                 Result is cg = -10
!
!  1. Purpose:
!
!     Compute group velocity for a given radian frequency and depth
!
!  2. Method
!
!     Linear wave theory
!
!  3. Parameter list:
!
!Type   I/O           Name    Description
!------------------------------------------------------------------------------
real, intent(in)  :: sigma  !  radian frequency (rad)
real, intent(in)  :: depth  !  water depth (m)
real, intent(in)  :: grav   !  gravitational acceleration (m/s^2)
real, intent(out) :: cg     !  group velocity (m/s)
!
real k                      !  wave number
!/A
!!real z_wnumb                !  compute wave number
!/Z
!-----------------------------------------------------------------------------
k = z_wnumb(sigma,depth,grav)
!
if(depth <= 0. .or. sigma <= 0.) then
  cg = -10.
else
  if(depth*k > 30.) then
    cg = grav/(2.*sigma)
  else
    cg = sigma/k*(0.5+depth*k/sinh(2.*depth*k))
  end if
end if
!
return
end subroutine
!
!-----------------------------------------------------------------------------!
subroutine z_intp1(x1,y1,x2,y2,n1,n2,ierr)                                    !
!-----------------------------------------------------------------------------!
!
!   +-------+    ALKYON Hydraulic Consultancy & Research
!   |       |    Gerbrant van Vledder
!   |   +---+
!   |   | +---+
!   +---+ |   |
!         +---+
!
implicit none
!
!  0. Update history
!
!     30/03/1999 Initical version
!      9/04/1999 Check included for monotonicity of x-data
!     11/10/1999 Error messages added and updated
!     18/01/2001 Check include if n1==1
!     24/01/2001 Check for equality of y2 data loosened if n2==1
!     13/09/2001 Documentation updated
!
!  1. Purpose
!
!     Interpolate function values
!
!  2. Method
!
!     Linear interpolation

!     If a requested point falls outside the input domain, then
!     the nearest point is used (viz. begin or end point of x1/y1 array
!
!     If the input array has only one point. A constant value is assumed
!
!  3. Parameter list
!
!     Name    I/O  Type  Description
!
integer, intent(in) ::  n1   !   number of data points in x1-y1 arrays
integer, intent(in) ::  n2   !   number of data points in x2-y2 arrays
real, intent(in) ::  x1(n1)  !   x-values of input data
real, intent(in) ::  y1(n1)  !   y-values of input data
real, intent(in) ::  x2(n2)  !   x-values of output data
real, intent(out) :: y2(n2)  !   y-values of output data
integer, intent(out) :: ierr !   Error indicator
!
!  4. Subroutines used
!
!  5. Error messages
!
!     ierr = 0    No errors detected
!          = 1    x1-data not monotonic increasing
!          = 10   x2-data not monotonic increasing
!          = 11   x1- and x2 data not monotonic increasing
!          = 2    x1-data not monotonic decreasing
!          = 20   x1-data not monotonic decreasing
!          = 22   x1- and x2 data not monotonic decreasing
!
!          = 2    No variation in x1-data
!          = 3    No variation in x2-data is allowed if n2=1
!
!  6. Remarks
!
!     It is assumed that the x1- and x2-data are either
!     monotonic increasing or decreasing
!
!     If a requested x2-value falls outside the range of x1-values
!     it is assumed that the corresponding y2-value is equal to
!     the nearest boundary value of the y1-values
!
!     Example: x1 = [0 1 2 3]
!              y1 = [1 2 1 0]
!
!              x2 = -1,  y2 = 1
!              x2 =  5,  y2 = 0
!
!------------------------------------------------------------------------------
integer i1,i2        ! counters
!
real ds            ! step size
real fac           ! factor in linear interpolation
real s1,s2         ! search values
real xmin1,xmax1   ! minimum and maximum of x1-data
real xmin2,xmax2   ! minimum and maximum of x2-data
!
real, parameter :: eps=1.e-20
!------------------------------------------------------------------------------
!   initialisation
!
ierr = 0
!
!  check number of points of input array
!
if(n1==1) then
  y2 = y1(1)
  goto 9999
end if
!
!  check minimum and maximum data values
!
xmin1 = minval(x1)
xmax1 = maxval(x1)
xmin2 = minval(x2)
xmax2 = maxval(x2)
!
if (abs(xmin1-xmax1) < eps .or. abs(x1(1)-x1(n1)) < eps) then
  ierr = 2
  goto 9999
end if
!
if ((abs(xmin2-xmax2) < eps .or. abs(x2(1)-x2(n2)) < eps) .and. n2 > 1) then
  ierr = 3
  goto 9999
end if
!
! check input data for monotonicity
!
if(x1(1) < x1(n1)) then             ! data increasing
  do i1=1,n1-1
    if(x1(i1) > x1(i1+1)) then
      ierr=1
      write(*,*) 'z_intp1: i1 x1(i1) x1(i1+1):',i1,x1(i1),x1(i1+1)
      goto 9999
    end if
  end do
!
  do i2=1,n2-1
    if(x2(i2) > x2(i2+1)) then
      ierr=ierr+10
      write(*,*) 'z_intp1: i2 x2(i2) x2(i2+1):',i2,x2(i2),x2(i2+1)
      goto 9999
    end if
  end do
!
else                                 ! data decreasing
  do i1=1,n1-1
    if(x1(i1) < x1(i1+1)) then
      ierr=2
      write(*,*) 'z_intp1: i1 x1(i1) x1(i1+1):',i1,x1(i1),x1(i1+1)
      goto 9999
    end if
  end do
!
  do i2=1,n2-1
    if(x2(i2) < x2(i2+1)) then
      ierr=ierr + 20
      write(*,*) 'z_intp1: i2 x2(i2) x2(i2+1):',i2,x2(i2),x2(i2+1)
      goto 9999
    end if
  end do
end if
!
!------------------------------------------------------------------------------
! initialize
!------------------------------------------------------------------------------
if(ierr==0) then
  i1 = 1
  s1 = x1(i1)
!
  do i2 = 1,n2
    s2 = x2(i2)
    do while (s1 <= s2 .and. i1 < n1)
      i1 = i1 + 1
      s1 = x1(i1)
    end do
!
!  special point
!  choose lowest s1-value if x2(:) < x1(1)
!
    if(i1 ==1) then
      y2(i2) = y1(i1)
    else
      ds = s2 - x1(i1-1)
      fac = ds/(x1(i1)-x1(i1-1))
      y2(i2) = y1(i1-1) + fac*(y1(i1)-y1(i1-1))
    end if
!
! special case at end: choose s2(n2) > s1(n1), choose last value of y1(1)
!
    if(i2==n2 .and. s2>s1) y2(n2) = y1(n1)
  end do
end if
!
9999 continue
!
return
end subroutine
!
!-----------------------------------------------------------------------------!
subroutine z_polyarea(xpol,ypol,npol,area)
!-----------------------------------------------------------------------------!
!
!   +-------+    ALKYON Hydraulic Consultancy & Research
!   |       |    P.O. Box 248
!   |   +---+    8300 AE Emmeloord
!   |   | +---+  Tel: +31 527 620909
!   +---+ |   |  Fax: +31 527 610020
!         +---+  http://www.alkyon.nl
!
!         Gerbrant van Vledder
!
!  0. Update history
!
!     0.01  12/06/2003  Initial version
!
!  1. Purpose
!
!     Computes area of a closed polygon
!
!  2. Method
!
!     The area of the polygon
!
!  3. Parameter list
!
!     Name    I/O  Type  Description
!
integer, intent(in)  ::  npol       ! Number of points of polygon
real, intent(in)     ::  xpol(npol) ! x-coodinates of polygon
real, intent(in)     ::  ypol(npol) ! y-coordinates of polygon
real, intent(out)    ::  area       ! area of polygon
!
!  4. Subroutines used
!
!  5. Error messages
!
!  6. Remarks
!
integer ipol,ipol1         ! counters
real xmin,xmax,ymin,ymax   ! minima and maxima of polygon
real xmean,ymean           ! mean values
real xa,ya,xb,yb           ! temporary variables
real sumx,sumy             ! sums
real darea                 ! piece of area
!-------------------------------------------------------------------------------
if(npol<=1) then
  crf  = 0.
  xz   = 0.
  yz   = 0.
  area = 0.
  return
end if
!
! compute minimum and maximum coordinates
!
xmin = minval(xpol)
xmax = maxval(xpol)
ymin = minval(ypol)
ymax = maxval(ypol)
!
!  compute mean of range of x- and y-coordinates
!
xmean = 0.5*(xmin + xmax)
ymean = 0.5*(ymin + ymax)
!
! compute area and center of gravity
! do loop over all line pieces of polygon
!
area = 0.
sumx = 0.
sumy = 0.
!
do ipol=1,npol
  ipol1 = ipol + 1
  if(ipol==npol) ipol1 = 1
  xa = xpol(ipol)
  ya = ypol(ipol)
  xb = xpol(ipol1)
  yb = ypol(ipol1)
!
  darea = 0.5*((xa-xmean)*(yb-ymean) - (xb-xmean)*(ya-ymean))
  area  = area + darea
  sumx  = sumx + darea*(xa+xb+xmean)/3.
  sumy  = sumy + darea*(ya+yb+ymean)/3.
end do
!
return
end subroutine
!
!-----------------------------------------------------------------------------!
subroutine z_steps(x,dx,nx)
!-----------------------------------------------------------------------------!
!
!
!   +-------+    ALKYON Hydraulic Consultancy & Research
!   |       |    Gerbrant van Vledder
!   |   +---+
!   |   | +---+  Creation date:  September 28, 1998
!   +---+ |   |  Last Update:    march 19, 2003
!         +---+
!
!  0. Update history
!
!     19/03/2003   Input argument defined using intent option
!                  check included nx > 0
!
!  1. Purpose
!
!     Compute bandwidth of spectral discretization
!
implicit none
!
integer, intent(in) :: nx     ! Number of elements in array
real, intent(in)    :: x(nx)  ! Input data array with elements
real, intent(out)   :: dx(nx) ! Output array with step sizes
!
integer ix                    ! counter
!------------------------------------------------------------------------------
if (nx<1) then
  return
!
elseif (nx==1) then
  dx = 0
else
  do ix=2,nx-1
    dx(ix) = 0.5 * (x(ix+1) - x(ix-1))
  end do
!
  if (nx >= 4) then
    dx(1)  = dx(2)*dx(2)/dx(3)
    dx(nx) = dx(nx-1)*dx(nx-1)/dx(nx-2)
  else
    dx(1)  = dx(2)
    dx(nx) = dx(nx-1)
  end if
end if
!
return
end subroutine
!-----------------------------------------------------------------------------!
real function z_root2(func,x1,x2,xacc,iprint,ierr)
!-----------------------------------------------------------------------------!
!
!   +-------+    ALKYON Hydraulic Consultancy & Research
!   |       |
!   |   +---+
!   |   | +---+
!   +---+ |   |
!         +---+
!
!  0. Update history
!
!     Version Date       Modification
!
!     0.01    29/11/1999 Initial version
!     0.02    07/11/1999 Test added to check boundaries, and reverse if necessary
!                        Bug fixed in assigning answer
!     0.03    02/09/2002 Maximum number of iterations set to 20, instead of 10
!
!  1. Purpose
!
!     Find zero crossing point of function FUNC between the
!     initial values on either side of zero crossing
!
!  2. Method
!
!     Ridders method of root finding
!
!     adapted from routine zridddr
!     Numerical Recipes
!     The art if scientific computing, second edition, 1992
!     W.H. Press, S.A. Teukolsky, W.T. Vetterling and B.P. Flannery
!
!  3. Parameter list
!
!     Name    I/O  Type  Description
!
!     func     i    r    real function
!     x1       i    r    initial x-value on left/right side of zero-crossing
!     x2       i    r    initial x-value on right/left side of zero-crossing
!     xacc     i    r    accuracy, used as |x1(i)-x2(i)|< xacc
!     iprint   i    i    Output channel and test level
!     ierr     o    i    Error indicator
!
!  4. Subroutines used
!
!     Func      user supplied real function
!
!  5. Error messages
!
!     ierr = 0   No errors occured during iteration process
!            1   Iteration halted in dead end, this combination may NEVER occur
!            2   Maximum number of iterations exceeded
!            3   Solution jumped outside interval
!
!  6. Remarks
!
!     It is assumed that the x1- and x2-coordinate lie
!     on different sides of the actual zero crossing
!
!     The input parameter IPRINT is used to generate test output.
!     If IPRINT==0, no test output is created
!              > 0, test output is directed to the file connected to unit LUPRINT=IPRINT
!                   if no file is connected to this unit, no output is written
!
!
implicit none
!
real func                         ! external function
real, intent (in) :: x1           ! x-value at one side of interval
real, intent (in) :: x2           ! x-value at other side of interval
real, intent (in) :: xacc         ! requested accuracy
integer, intent (in) :: iprint    ! number of output channel, only used when
integer, intent (out) :: ierr     ! error indicator
!
real unused                       ! default value
real zriddr                       ! intermediate function value
real xx1,xx2,xx                   ! local boundaries during iteration
integer maxit                     ! maximum number of iteration
integer luprint                   ! unit of test output
logical lopen                     ! check if a file is opened

parameter (maxit = 20)
external func
!
integer iter      ! counter for number of iterations
real fh           ! function value FUNC(xh)
real fl           ! function value FUNC(xl)
real fm           ! function value FUNC(xm)
real fnew         ! function value FUNC(xnew)
real s            ! temp. function value, used for inverse quadratic interpolation
real xh           ! upper (high) boundary of interval
real xl           ! lower boundary of interval
real xm           ! middle point of interval
real xnew         ! new estimate according to Ridders method
!
ierr   = 0        ! set error level
unused =-1.11e30  ! set start value
!
xx1 = x1          ! copy boundaries of interval to local variables
xx2 = x2
!
luprint = iprint
!
if(luprint > 0) then
  inquire(unit=luprint,opened=lopen)
  if(.not.lopen) then
    luprint = 0
    write(*,'(a,i4)') 'Z_ROOT2: invalid unit number:',iprint
  end if
end if
!
! check boundaries on requirement x2 > x1
!
if(xx1 > xx2) then
  xx  = xx1
  xx1 = xx2
  xx2 = xx
end if
!
fl = func(xx1)
fh = func(xx2)
!
!if(luprint > 0) write(luprint,'(a,4e13.5)') &
!&  'Z_ROOT2: xx1 xx2 fl fh:',xx1,xx2,fl,fh
!
if((fl > 0. .and. fh < 0.) .or. (fl < 0. .and. fh > 0.))then
   xl = xx1
   xh = xx2
   zriddr = unused
!
   do iter=1,maxit
      xm = 0.5*(xl+xh)
      fm = func(xm)
      s = sqrt(fm**2-fl*fh)
      if(s == 0.) goto 9000
      xnew = xm+(xm-xl)*(sign(1.,fl-fh)*fm/s)
!
!      if(luprint>0) write(luprint,'(a,4e13.5)') &
!&       'Z_ROOT2: xm,fm,s,xnew:',xm,fm,s,xnew
!
      if (abs(xnew-zriddr) <= xacc) then
!        if(luprint>0) write(luprint,'(a)') 'Z_ROOT2: xnew=zriddr'
        goto 9000
      end if
!
      zriddr = xnew
      fnew = func(zriddr)
      if (fnew == 0.) goto 9000
!
      if(sign(fm,fnew) /= fm) then
         xl = xm
         fl = fm
         xh = zriddr
         fh = fnew
      elseif(sign(fl,fnew) /= fl) then
         xh = zriddr
         fh = fnew
      elseif(sign(fh,fnew) /= fh) then
         xl = zriddr
         fl = fnew
      else
         ierr = 1
         goto 9000
      endif
!
      if(abs(xh-xl) <= xacc) goto 9000
!
      if(luprint > 0) write(luprint,'(a,i4,5e14.6)') &
&     'Z_ROOT2: iter,x1,x2,|x1-x2|,xacc,z:', iter,xl,xh,abs(xl-xh),xacc,fnew
!
   end do
   ierr = 2
   if(luprint > 0) write(luprint,'(a)') 'Z_ROOT2: -> ierr=2'
   goto 9000
else if (fl == 0.) then
  zriddr = xx1
else if (fh == 0.) then
  zriddr = xx2
else
  ierr = 3
  goto 9999
! 'root must be bracketed in zriddr'
endif
!
9000 continue
!
z_root2 = zriddr
!
if(luprint > 0) write(luprint,'(a,2i3,5e13.5)') &
&     'Z_ROOT2: ierr,iter,xl,xh,acc,x0,z0:', ierr,iter,xl,xh,xacc,z_root2,func(z_root2)
!
9999 continue
!
return
end function
!
!-----------------------------------------------------------------------------!
subroutine z_upper(str)
!-----------------------------------------------------------------------------!
!
!   +-------+    ALKYON Hydraulic Consultancy & Research
!   |       |    Gerbrant van Vledder
!   |   +---+
!   |   | +---+  Creation date:  July 3,1998
!   +---+ |   |  Last Update:
!         +---+
!
!  0. Update history
!
!  1. Purpose
!
!     Transform all lower capitals to UPPER CAPITALS in string STR
!
!  2. Method
!
!  3. Parameter list
!
!     Name    I/O  Type  Description
!
implicit none
character(len=*), intent(inout) :: str  ! Character string to be converted
!
!  4. Subroutines used
!
!  5. Error messages
!
!  6. Remarks
!
integer nlen
integer i,ial,iau,izl
!
nlen = len(str)
!
ial = ichar('a')
iau = ichar('A')
izl = ichar('z')
!
do i=1,nlen
  if(ichar(str(i:i)) >= ial.and. ichar(str(i:i)) <= izl) then
    str(i:i) = char(ichar(str(i:i))-ial+iau)
  end if
end do
!
return
end subroutine
!
!-----------------------------------------------------------------------------!
real function z_wnumb(w,d,grav)
!-----------------------------------------------------------------------------!
!
!   +-------+    ALKYON Hydraulic Consultancy & Research
!   |       |    Gerbrant van Vledder
!   |   +---+
!   |   | +---+
!   +---+ |   |
!         +---+
!
implicit none
!
!  0. Update history
!
!     01/04/1999  Initial version
!     12/01/2001  grav added as input parameter
!     11/04/2001  Check included for the case w < 0 or d < 0
!
!  1. Purpose:
!
!     Compute wave number k for a given radian frequency and water depth
!
!  2. Method
!
!     finite depth linear dispersion relation, using a Pade approximation
!
!  3. Parameter list:
!
!Type   I/O           Name     Description
!------------------------------------------------------------------------------
real, intent(in)  ::  w      ! radian frequency (rad)
real, intent(in)  ::  d      ! water depth (m)
real, intent(in)  ::  grav   ! graviational acceleration (m/s^2)
!
!  4. Subroutines used
!
!  5. Error messages
!
!  6. Remarks
!
!     The Pade approximation has been described in Hunt, 198.
!
!
real x,xx,y,omega
!
if(d<=0 .or. w<= 0.) then
  z_wnumb = -10.
else
  omega   = w**2/grav
  y       = omega*d
  xx      = y*(y+1./(1.+y*(0.66667+y*(0.35550+y*(0.16084+y*(0.06320+y* &
&           (0.02174+y*(0.00654+y*(0.00171+y*(0.00039+y*0.00011))))))))))
  x       = sqrt(xx)
  z_wnumb = x/d
end if
!
return
end function
end module


C----------------------------------------------------------------------
C----------------------------------------------------------------------
C   ab :            The A --> B reaction
C----------------------------------------------------------------------
C----------------------------------------------------------------------
C
      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
C     ---------- ----
C
C Evaluates the algebraic equations or ODE right hand side
C
C Input arguments :
C      NDIM   :   Dimension of the ODE system
C      U      :   State variables
C      ICP    :   Array indicating the free parameter(s)
C      PAR    :   Equation parameters
C
C Values to be returned :
C      F      :   ODE right hand side values
C
C Normally unused Jacobian arguments : IJAC, DFDU, DFDP (see manual)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(NDIM), PAR(*), F(NDIM), ICP(*)
C
       U1=U(1)
       U2=U(2)
       E=DEXP(U2)
C
       F(1)=-U1 + PAR(1)*(1-U1)*E
       F(2)=-U2 + PAR(1)*PAR(2)*(1-U1)*E - PAR(3)*U2
C
      RETURN
      END
C----------------------------------------------------------------------
C----------------------------------------------------------------------
C
      SUBROUTINE STPNT(NDIM,U,PAR)
C     ---------- -----
C
C Input arguments :
C      NDIM   :   Dimension of the ODE system
C
C Values to be returned :
C      U      :   A starting solution vector
C      PAR    :   The corresponding equation-parameter values
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(NDIM), PAR(*)
C
C Initialize the equation parameters
       PAR(1)=0.
       PAR(2)=14.
       PAR(3)=2.
C
C Initialize the solution
       U(1)=0.
       U(2)=0.
C
      RETURN
      END
C----------------------------------------------------------------------
C----------------------------------------------------------------------
C The following subroutines are not used here,
C but they must be supplied as dummy routines
C
      SUBROUTINE BCND
      RETURN
      END
C
      SUBROUTINE ICND
      RETURN
      END
C
      SUBROUTINE FOPT
      RETURN
      END
C
      SUBROUTINE PVLS
      RETURN
      END
C----------------------------------------------------------------------
C----------------------------------------------------------------------


!//////////////////////////////////////////////////////////
! Exercise : 3-D Diffusion Program
!            Parallelization optimized as:
!            1)  Covert the blocking send/receives to isends/irecvs
PROGRAM MAIN
    USE MPI
    USE TIMING
    USE ISO_FORTRAN_ENV, ONLY : output_unit,real64
    IMPLICIT NONE
    ! We use some objects of the Timer class defined in Timing.f90
    ! to profile our code.
    TYPE(Timer) :: calc_time, comm_time, init_time, wall_time
    REAL*8 :: calc_ratio, comm_ratio, init_ratio
    REAL*8, ALLOCATABLE :: var(:,:,:), wrk(:,:,:)
    ! Here are some additional work arrays for transmitting boundary values
    REAL*8, ALLOCATABLE :: ubvals_send(:), ubvals_recv(:)
    REAL*8, ALLOCATABLE :: bbvals_send(:), bbvals_recv(:)
    REAL*8, ALLOCATABLE :: lbvals_send(:), lbvals_recv(:)
    REAL*8, ALLOCATABLE :: rbvals_send(:), rbvals_recv(:)
    INTEGER ::  nx,ny,nz,nt
    INTEGER :: i,j,k,n, ierr
    CHARACTER*120 :: msg
    !/////////////////////////////////////////////////////////////////////////
    !  MPI Process-Grid Variables
    INTEGER :: my_rank, ncpu ! global rank and number of MPI processes

    INTEGER :: my_row_rank, my_col_rank ! The rank within a row and column for each process respectively

    INTEGER :: nprow, npcol ! Number of process rows and columns respectively
                               ! 0 <= my_row_rank <= npcol
                               ! 0 <= my_col_rank <= nprow

    INTEGER :: col_comm, row_comm ! subcommunicators for rows and columns
                                   ! row_comm connects all processes in the same row
                                   ! col_comm connects all processes in the same column

    !/////////////////////////////////////////
    ! Variables related to load-balancing in x-direction.
    INTEGER :: my_imin, my_imax ! the range of x-indices that this rank owns
    INTEGER :: my_numx

    !/////////////////////////////////////////
    ! Variables related to load-balancing in y-direction.
    INTEGER :: my_jmin, my_jmax ! the range of y-indices that this column owns
    INTEGER :: my_numy

    !////////////////////////////////////////////////////
    ! Set some default values for the problem parameters.
    nx = 256   ! x-dimension of our 3-D array (global)
    ny = 256   ! y-dimension of our 3-D array (global)
    nz = 1     ! z-dimension of our 3-D array
    nt = 100   ! number of time steps to integrate over
    nprow = 2  ! number of process rows/number of ranks within a column
    npcol = 2  ! number of process columns/number of ranks within a row

    !////////////////////////////////////////////////////
    ! Check to see if the user has overridden
    ! these defaults at the command line.
    ! Command line calling syntax:
    ! ./ex5.gpu -nx 256 -ny 256 -nz 256 -nt 100 -nprow 2 -npcol 2

    !/////////////////////// Initialization
    CALL GRAB_ARGS()
    CALL INIT_COMM()
    nz = MAX(nz,3)  ! Need at least 3 points in z to evaluate a derivative

    CALL calc_time%init()
    CALL comm_time%init()
    CALL init_time%init()
    CALL wall_time%init()

    CALL wall_time%startclock()
    CALL init_time%startclock()

    CALL LOAD_BALANCE()

    IF (my_rank .eq. 0) THEN
        WRITE(output_unit,'(a)')   ' ///////////////////////////'
        WRITE(output_unit,'(a)')   '  3-D Diffusion Equation   '
        WRITE(output_unit,'(a)')   '  --Problem Parameters-- '
        WRITE(output_unit,'(a,i0)')'    nx = ', nx
        WRITE(output_unit,'(a,i0)')'    ny = ', ny
        WRITE(output_unit,'(a,i0)')'    nz = ', nz
        WRITE(output_unit,'(a,i0)')'    nt = ', nt
        WRITE(output_unit,'(a,i0)')'  ncpu = ', ncpu
        WRITE(output_unit,'(a,i0)')' nprow = ', nprow
        WRITE(output_unit,'(a,i0)')' npcol = ', npcol
        WRITE(output_unit,'(a)')   ' ///////////////////////////'
        WRITE(output_unit,'(a)')   ' '
        WRITE(output_unit,'(a)')   ' Proccess Grid Layout: '
    ENDIF

    WRITE(msg,'(a,i0,a,i0,a,i0)') &
       ' row = ', my_col_rank, ' column = ', my_row_rank, ' rank = ', my_rank
    CALL ORDERED_PRINT(msg)

    !/////////////////////////////////////////////////////
    ! Initialize var and the work array
    CALL ALLOCATE_WORKSPACE()  ! all variables allocated here

    var(:,:,:) = 0.0d0
    wrk(:,:,:)   = 0.0d0
    CALL INIT_ARR(var, 1.0d0, 2, 2, 2) ! product of single sine waves in each dimension

    CALL init_time%increment()

    !/////////////////////////////////////////////////////
    ! Evolve the system

    DO n = 1, nt
        IF (my_rank .eq. 0) THEN
            IF (MOD(n,100) .eq. 0) Write(output_unit,'(a,i5)')' Timestep: ',n
        ENDIF

        !* EDIT GHOST_ZONE_COMM to communicate ghost zones
        !  to left and right neighbor ranks.

        ! Communication
        CALL comm_time%startclock()
        IF (ncpu .gt. 1) CALL GHOST_ZONE_COMM()
        CALL comm_time%increment()

        ! Calculation
        CALL calc_time%startclock()
        CALL Laplacian3D()
        CALL calc_time%increment()

    ENDDO

    CALL wall_time%increment

    init_ratio = init_time%elapsed/wall_time%elapsed*100
    calc_ratio = calc_time%elapsed/wall_time%elapsed*100
    comm_ratio = comm_time%elapsed/wall_time%elapsed*100

    IF (my_rank .eq. 0) THEN
        WRITE(output_unit,'(a)')' '
        WRITE(output_unit,'(a)')' Complete!'
        WRITE(output_unit,'(a)')' '
        WRITE(output_unit,'(a)')' Measured Timings (from rank 0):'
        WRITE(output_unit,'(a)')' ...............................'
        WRITE(output_unit,'( a, ES14.4, a)') &
            '         Elapsed time: ', wall_time%elapsed, ' seconds.'
        WRITE(output_unit, fmt= '( a, ES14.4, a, F6.3,a)') &
            '  Initialization time: ', init_time%elapsed, ' seconds (',init_ratio,' %).'
        WRITE(output_unit, fmt= '( a, ES14.4, a, F6.3,a)') &
            '     Calculation time: ', calc_time%elapsed, ' seconds (',calc_ratio,' %).'
        WRITE(output_unit, fmt= '( a, ES14.4, a, F6.3,a)') &
            '   Communication time: ', comm_time%elapsed, ' seconds (',comm_ratio,' %).'
    ENDIF

    CALL MPI_FINALIZE(ierr)

CONTAINS

    SUBROUTINE GHOST_ZONE_COMM()
        IMPLICIT NONE
        INTEGER :: ierr, dest, source
        INTEGER :: rbtag=1, lbtag=2 ! MPI tags for the right/left boundary communication
        INTEGER :: ubtag=1, bbtag=2 ! MPI tags for the upper/bottom boundary communication
        INTEGER :: reqs(8), rcount
        INTEGER :: mstat(MPI_STATUS_SIZE, 8)
        ! The naive way to handle communication in the 3-D case is to wrap a loop around
        ! our earlier communication pattern.  We skip the z-boundaries when looping.

        DO k = 2, nz-1
            rcount = 0
            !////////////////////////////////////////////////////////
            ! First, we communicate the right boundary values
            ! We receive from the left and send to the right

            ! Copy ghost-zone values into their respective send buffers
            rbvals_send(my_jmin:my_jmax) = var(my_imax, my_jmin:my_jmax, k)
            lbvals_send(my_jmin:my_jmax) = var(my_imin, my_jmin:my_jmax, k)

            IF (my_row_rank .gt. 0) THEN  ! rank zero does not receive
                ! Receive from the left
                source = my_row_rank-1
                rcount = rcount+1
                Call MPI_IRecv(lbvals_recv, my_numy, MPI_DOUBLE_PRECISION, source, &
                    rbtag, row_comm, reqs(rcount),ierr)
                var(my_imin-1,my_jmin:my_jmax,k) = lbvals_recv(my_jmin:my_jmax)
            ENDIF
            IF (my_row_rank .lt. (npcol-1)) THEN ! highest rank does not send
                ! Send to the right
                dest = my_row_rank+1
                rcount = rcount+1
                Call MPI_ISend(rbvals_send, my_numy, MPI_DOUBLE_PRECISION, dest,rbtag, &
                    & row_comm,reqs(rcount),ierr)
            ENDIF

            !////////////////////////////////////////////////////////
            ! Next, we communicate the left boundary values
            ! We receive from the right and send to the left
            IF (my_row_rank .lt. (npcol-1)) THEN ! highest rank does not receive
                ! Receive from the right
                source = my_row_rank+1
                rcount = rcount+1
                Call MPI_IRecv(rbvals_recv, my_numy, MPI_DOUBLE_PRECISION, source, &
                    lbtag, row_comm, reqs(rcount),ierr)
                var(my_imax+1,my_jmin:my_jmax,k) = rbvals_recv(my_jmin:my_jmax)
            ENDIF
            IF (my_row_rank .gt. 0) THEN ! rank zero does not send
                ! Send to the left
                dest = my_row_rank-1
                rcount = rcount+1
                Call MPI_ISend(lbvals_send, my_numy, MPI_DOUBLE_PRECISION, dest,lbtag, &
                    & row_comm,reqs(rcount),ierr)
            ENDIF

            !////////////////////////////////////////////////////////
            ! Now, we communicate the upper/lower boundary values

            ! Copy ghost-zone values into their respective send buffers
            ubvals_send(my_imin:my_imax) = var(my_imin:my_imax,my_jmax,k)
            bbvals_send(my_imin:my_imax) = var(my_imin:my_imax,my_jmin,k)

            IF (my_col_rank .gt. 0) THEN  ! rank zero does not receive
                ! Receive from below
                source = my_col_rank-1
                rcount = rcount+1
                Call MPI_IRecv(bbvals_recv, my_numx, MPI_DOUBLE_PRECISION, source, &
                    bbtag, col_comm, reqs(rcount),ierr)
                var(my_imin:my_imax,my_jmin-1,k) = bbvals_recv(my_imin:my_imax)
            ENDIF
            IF (my_col_rank .lt. (nprow-1)) THEN ! highest rank does not send
                ! Send above
                dest = my_col_rank+1
                rcount = rcount+1
                Call MPI_ISend(ubvals_send, my_numx, MPI_DOUBLE_PRECISION, dest,bbtag, &
                    & col_comm,reqs(rcount),ierr)
            ENDIF

            !////////////////////////////////////////////////////////
            ! Next, we communicate the left boundary values
            ! We receive from the right and send to the left
            IF (my_col_rank .lt. (nprow-1)) THEN ! highest rank does not receive
                ! Receive from above
                source = my_col_rank+1
                rcount = rcount+1
                Call MPI_IRecv(ubvals_recv, my_numx, MPI_DOUBLE_PRECISION, source, &
                    lbtag, col_comm, reqs(rcount),ierr)
                var(my_imin:my_imax,my_jmin+1,k) = ubvals_recv(my_imin:my_imax)
            ENDIF
            IF (my_col_rank .gt. 0) THEN ! rank zero does not send
                ! Send to below
                dest = my_col_rank-1
                rcount = rcount+1
                Call MPI_ISend(bbvals_send, my_numx, MPI_DOUBLE_PRECISION, dest,lbtag, &
                    & col_comm,reqs(rcount),ierr)
            ENDIF
            CALL MPI_Waitall(rcount, reqs(1:rcount), mstat, ierr)
        ENDDO
    END SUBROUTINE GHOST_ZONE_COMM

    SUBROUTINE ALLOCATE_WORKSPACE()

        IMPLICIT NONE

        ALLOCATE(var(my_imin-1:my_imax+1,my_jmin-1:my_jmax+1,1:nz))
        ALLOCATE(wrk(1:nx,1:ny,1:nz))

        ALLOCATE(lbvals_send(my_jmin:my_jmax),lbvals_recv(my_jmin:my_jmax))
        ALLOCATE(rbvals_send(my_jmin:my_jmax),rbvals_recv(my_jmin:my_jmax))

        ALLOCATE(bbvals_send(my_imin:my_imax), bbvals_recv(my_imin:my_imax))
        ALLOCATE(ubvals_send(my_imin:my_imax), ubvals_recv(my_imin:my_imax))

    END SUBROUTINE ALLOCATE_WORKSPACE

    SUBROUTINE ORDERED_PRINT(message)
        IMPLICIT NONE
        INTEGER :: i,j, ierr
        CHARACTER(*), INTENT(IN) :: message
        DO j = 0, nprow-1    ! Loop over each row
            DO i = 0, npcol-1 ! Loop over each column
                IF ((my_row_rank .eq. i) .and. (my_col_rank .eq. j) ) THEN
                    WRITE(output_unit,*) TRIM(msg)
                ENDIF
                CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
            ENDDO
        ENDDO
    END SUBROUTINE ORDERED_PRINT

    SUBROUTINE INIT_COMM()
        IMPLICIT NONE
        INTEGER :: ierr
        !Initialize MPI  (ierr is an error flag with nonzero value if there's a problem)
        Call MPI_INIT( ierr )
        IF (ierr .ne. 0) STOP 'Error intializing MPI'

        !Find number of MPI processes executing this program (ncpu)
        Call MPI_Comm_size(MPI_COMM_WORLD, ncpu,ierr)
        IF (ierr .ne. 0) STOP 'Error finding ncpu'
        IF (ncpu .ne. (nprow*npcol)) THEN
            STOP 'Error!  ncpu MUST EQUAL nprow*npcol'
        ENDIF

        !Find this process's rank (my_rank; unique numeric identifier for each MPI process)
        Call MPI_Comm_rank(MPI_COMM_WORLD, my_rank,ierr)
        IF (ierr .ne. 0) STOP 'Error finding my_rank'

        Call ROW_COLUMN_INIT()

        !WRITE(output_unit,'(a,i0,a,i0,a)')'Rank ',my_rank,' of ', ncpu, ' is active.'
        CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)

    END SUBROUTINE INIT_COMM

    SUBROUTINE ROW_COLUMN_INIT()
        IMPLICIT NONE
        INTEGER :: test, ierr
        my_row_rank = MOD(my_rank,npcol)
        my_col_rank = my_rank/npcol

        CALL MPI_COMM_SPLIT(MPI_COMM_WORLD, my_col_rank, my_rank, row_comm, ierr)

        CALL MPI_COMM_SPLIT(MPI_COMM_WORLD, my_row_rank, my_rank, col_comm, ierr)
    END SUBROUTINE ROW_COLUMN_INIT

    SUBROUTINE grab_args()
            IMPLICIT NONE
            INTEGER :: n                    ! Number of command-line arguments
            INTEGER :: i
            CHARACTER(len=1024) :: argname  ! Argument key
            CHARACTER(len=1024) :: val      ! Argument value

            n = command_argument_count()
            DO i=1,n,2
                    CALL get_command_argument(i, argname)
                    CALL get_command_argument(i+1, val)
                    SELECT CASE(argname)
                            CASE('-nprow')
                                    read(val, '(I8)') nprow
                            CASE('-npcol')
                                    read(val, '(I8)') npcol
                            CASE('-nx')
                                    read(val, '(I8)') nx
                            CASE('-ny')
                                    read(val, '(I8)') ny
                            CASE('-nz')
                                    read(val, '(I8)') nz
                            CASE('-nt')
                                    read(val, '(I8)') nt
                            CASE DEFAULT
                                    WRITE(output_unit,'(a)') ' '
                                    WRITE(output_unit,'(a)') &
                                    ' Unrecognized option: '// trim(argname)
                    END SELECT
            ENDDO

    END SUBROUTINE grab_args

    SUBROUTINE Laplacian2D()
        IMPLICIT NONE
        Real*8 :: one_fourth = 0.25d0
        INTEGER :: dims(3), ni, nj, nk
        INTEGER :: imin,imax, jmin,jmax

        imin = max(my_imin,2)    ! Avoid the boundaries, which are held fixed at zero
        imax = min(my_imax,nx-1)

        jmin = max(my_jmin,2)    ! Avoid the boundaries, which are held fixed at zero
        jmax = min(my_jmax,ny-1)

        DO j = jmin,jmax
            DO i = imin,imax
                wrk(i,j,1) =  &
                        var(i-1,j,1) + var(i+1,j,1) + &
                        var(i,j-1,1) + var(i,j+1,1)
            ENDDO
        ENDDO

        DO j = jmin,jmax
            DO i = imin,imax
                var(i,j,1) = wrk(i,j,1)*one_fourth
            ENDDO
        ENDDO

    END SUBROUTINE Laplacian2D

    SUBROUTINE Laplacian3D()
        IMPLICIT NONE
        Real*8 :: one_sixth
        INTEGER :: imin,imax,jmin,jmax

        one_sixth = 1.0d0/6.0d0

        imin = max(my_imin,2)    ! Avoid the boundaries, which are held fixed at zero
        imax = min(my_imax,nx-1)

        jmin = max(my_jmin,2)    ! Avoid the boundaries, which are held fixed at zero
        jmax = min(my_jmax,ny-1)

        DO k = 2, nz-1
            DO j = jmin,jmax
                DO i = imin,imax
                    wrk(i,j,k) =  &
                            var(i-1,j,k) + var(i+1,j,k) + &
                            var(i,j-1,k) + var(i,j+1,k) + &
                            var(i,j,k-1) + var(i,j,k+1)
                ENDDO
            ENDDO
        ENDDO

        DO k = 2, nz-1
            DO j = jmin,jmax
                DO i = imin,imax
                    var(i,j,k) = wrk(i,j,k)*one_sixth
                ENDDO
            ENDDO
        ENDDO

    END SUBROUTINE Laplacian3D

    SUBROUTINE LOAD_BALANCE()
        IMPLICIT NONE
        INTEGER :: modcheck
        !FIND (imin,imax) & (jmin,jmax) for this process

        ! X-direction first
        my_numx = nx/npcol
        modcheck = MOD(nx,npcol)
        IF (my_row_rank .lt. modcheck) my_numx = my_numx+1
        my_imin = 1 + my_row_rank*my_numx
        IF (modcheck .le. my_row_rank) my_imin = my_imin+modcheck
        my_imax = my_imin+my_numx-1

        ! Y-direction first
        my_numy = ny/nprow
        modcheck = MOD(ny,nprow)
        IF (my_col_rank .lt. modcheck) my_numy = my_numy+1
        my_jmin = 1 + my_col_rank*my_numy
        IF (modcheck .le. my_col_rank) my_jmin = my_jmin+modcheck
        my_jmax = my_jmin+my_numy-1

    END SUBROUTINE LOAD_BALANCE

    SUBROUTINE INIT_ARR(arr, amp, orderx, ordery, orderz)
        IMPLICIT NONE
        ! FORTRAN will assume arr is indexed beginning with 1 by default
        ! We can alter this for the x and y dimension in the declaration as follows
        REAL*8, INTENT(INOUT) :: arr(my_imin-1:,my_jmin-1:,:)
        REAL*8, INTENT(IN) :: amp
        INTEGER, INTENT(IN) :: orderx, ordery, orderz
        REAL*8 :: sinkx, sinky, sinkz
        REAL*8 :: kx, ky, kz
        REAL*8, PARAMETER :: pi = 3.1415926535897932384626433832795028841972d0
        INTEGER :: i,j,k, dims(3), ni,nj,nk
        dims = shape(arr)

        kx = orderx*(pi/(nx-1))
        ky = ordery*(pi/(ny-1))
        kz = orderz*(pi/(nz-1))

        DO k = 1, nz
            sinkz = 1.0d0 !sin(kz*(k-1)) We will expand to 3-D later
            DO j = my_jmin, my_jmax
                sinky = sin(ky*(j-1))
                DO i = my_imin,my_imax
                    sinkx = sin(kx*(i-1))
                    arr(i,j,k) = arr(i,j,k)+amp*sinkx*sinky*sinkz
                ENDDO
            ENDDO
        ENDDO

    END SUBROUTINE INIT_ARR
END PROGRAM MAIN


subroutine sistl(a, b, w)

implicit none

real, dimension(:,:), intent(in) :: a
real, dimension(:), intent(in) :: b
real, dimension(:), intent(out) :: w

integer :: n, i, j

n = size(b)

print*, 'O termo independente b e: '
print*, b
print*,

w(1) = b(1)/a(1,1)

do i = 2,n
  w(i) = b(i)
  do j = 1,i-1
    w(i) = w(i) - a(i,j)*w(j)
  enddo

  w(i) = w(i)/a(i,i)
enddo

end subroutine


      PROGRAM CCPRWC
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)

      PARAMETER (K=400,N=400,LRWK=2000,LIWK=2000)
      REAL Z(K,N), RWRK(LRWK)
      INTEGER M, IWRK(LIWK)

      CALL GETDAT (Z, K, M, N)
C
C Open GKS
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C Initialize Conpack
C
      CALL CPRECT(Z,K,M,N,RWRK,LRWK,IWRK,LIWK)
C
C Draw perimeter
C
      CALL CPBACK(Z, RWRK, IWRK)
C
C Turn on line labels for every line
C
      CALL CPPKCL(Z, RWRK, IWRK)
      CALL CPGETI('NCL - NUMBER OF CONTOUR LEVELS',NCL)
      DO 10, I=1,NCL
         CALL CPSETI('PAI - PARAMETER ARRAY INDEX',I)
         CALL CPSETI('CLU - CONTOUR LEVEL USE FLAG',3)
 10   CONTINUE
C
C Set RWC so that labels come out on some lines
C
      CALL CPSETI('RWC - REAL WORKSPACE FOR CONTOURS',125)
C
C Draw Contours
C
      CALL CPCLDR(Z,RWRK,IWRK)
C
C Close frame and close GKS
C
      CALL FRAME
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS

      STOP
      END

      SUBROUTINE GETDAT (Z, K, M, N)
      INTEGER I,J,K,M,N
      REAL Z(K,N)

      M=K
      DO 10, I=1,M
         DO 20, J=1,N
            Z(I,J)= 10.E-8*(-16.*REAL(I**2*J) +
     +            34*REAL(I*J**2) - REAL(6*I) + 93.)
 20      CONTINUE
 10   CONTINUE

      RETURN
      END