************************************************************************
*                         RANDOM.FOR                                   *
*                                                                      *
*                                                                      *
*  PROGRAMMER:                                                         *
*     RALPH F. MILES, JR.                                              *
*     SYSTEMS DIVISION                                                 *
*     JET PROPULSION LABORATORY                                        *
*     PASADENA, CA 91109                                               *
*                                                                      *
*  VERSION: 1.00X2                                                     *
*  DATE:    04/24/85                                                   *
*                                                                      *
*----------------------------------------------------------------------*
*  THE PROGRAM "RANDOM.FOR" GENERATES, DISPLAYS, AND TESTS RANDOM      *
*  NUMBER SEQUENCES COMPATIBLE WITH MICROSOFT FORTRAN-77 AND THE       *
*  8086/8088 MICROPROCESSOR WITH THE 8087 NUMERIC COPROCESSOR.         *
*                                                                      *
*----------------------------------------------------------------------*
*                      CONFIGURATION CHANGES                           *
*                                                                      *
*  VER.      DATE                   CHANGES                            *
*                                                                      *
*  1.00X1  01/19/85  * ORIGINAL.                                       *
*  1.00X2  04/24/85  * MODULE  1: DELETE KOUNT1. CYCLE CHECK IN        *
*                                 MODULE 5. DELETE LWRITE. ADD LIN.    *
*                    * MODULE  2: WRITE DEFAULT PARAMETERS WITH F11.1. *
*                    * MODULE  4: DELETE KOUNT1.                       *
*                    * MODULE  5: KOUNT1 = KOUNT IF CYCLE.             *
*                    * MODULE  8: IF STATEMENT FOR LIN.                *
*                    * MODULE  9: USE MOD FN TO TEST FOR WRITE.        *
*                                 DELETE IF (LWRITE) ... ENDIF.        *
*                    * MODULE 13: MINOR FORMAT CHANGE.                 *
*                    * MODULE 14: FLOAT(NCOUNT) -> FLOAT(NCOUNT)/2.    *
*                    * PROGRAM  : ICORR? -> ISER                       *
*                                                                      *
************************************************************************

$TITLE:'RANDOM.LST'
$NODEBUG
$NOFLOATCALLS
$STORAGE:4

************************************************************************

      PROGRAM RANDOM

************************************************************************

***** INITIALIZE PROGRAM.  {MODULE 1}

      CHARACTER*1      AFAULT,AREAD
      DOUBLE PRECISION RANA,RANC,RANM,RNSEED,RANX,RANDIV,RANT,RANSUB,
     *                 RANDOM
      LOGICAL          LRUNHI,LIN

      DIMENSION IRNHIS(100),ISER(10,10)

*     INITIALIZE HISTOGRAM FOR CHI SQUARE AND K-S TESTS.
      DO 100 I=1,100
         IRNHIS(I) = 0.0
100   CONTINUE

*     PARAMETERS FOR MEDIAN RUNS TEST.
      IRUNS  = 0
      IRUNHI = 0
      IRUNLO = 0

*     INITIALIZE LIN AND HISTOGRAM ARRAY FOR SERIAL TEST.
      LIN = .TRUE.
      DO 110 ISER1 = 1,10
         DO 110 ISER2 = 1,10
            ISER(ISER1,ISER2) = 0
110   CONTINUE

*     DEFAULT LINEAR CONGRUENTIAL GENERATOR PARAMETERS.
      RANA   =   671093.0
      RANC   =  7090885.0
      RANM   = 33554432.0

***  {END MODULE 1}

***** KEYBOARD INPUT.  {MODULE 2}

      WRITE  (*,120)
120   FORMAT (1X,'GENERATOR IS: (RANA*RANDOM + RANC) MOD RANM.')

      WRITE  (*,130) RANA,RANC,RANM
130   FORMAT (1X,'DEFAULT PARAMETERS FOR GENERATOR ARE:'/
     *        5X,     'RANA = ',F11.1/
     *        5X,     'RANC = ',F11.1/
     *        5X,     'RANM = ',F11.1//
     *        1X,'USE DEFAULT PARAMETERS FOR GENERATOR (Y/N): '\)
      READ   (*,140) AFAULT
140   FORMAT (A1)

      IF (AFAULT .NE. 'Y') THEN

         WRITE  (*,150)
150      FORMAT (1X,5X,'ENTER RANA: '\)
         READ   (*,160) RANA
160      FORMAT (BN,F10.0)

         WRITE  (*,170)
170      FORMAT (1X,5X,'ENTER RANC: '\)
         READ   (*,180) RANC
180      FORMAT (BN,F10.0)

         WRITE  (*,190)
190      FORMAT (1X,5X,'ENTER RANM: '\)
         READ   (*,200) RANM
200      FORMAT (BN,F10.0)

      ENDIF

      WRITE  (*,210)
210   FORMAT (/1X,'TOTAL NUMBER OF RANDOM NUMBERS TO GENERATE: '\)
      READ   (*,220) NKOUNT
220   FORMAT (BN,I10)

      WRITE  (*,230)
230   FORMAT (/1X,'INCLUDE INTERMEDIATE SCREEN OUTPUT (Y/N): '\)
      READ   (*,240) AREAD
240   FORMAT (A1)

      WRITE (*,250)
250   FORMAT (/1X,'ENTER RANDOM NUMBER SEED: '\)
      READ (*,260) RNSEED
260   FORMAT (BN,F10.0)

***  {END MODULE 2}

***** INITIAL DATUM FOR SERIAL TEST ARRAY.  {MODULE 3}

      RNFRAC = SNGL(RNSEED/RANM)

      ISER1  = AINT(RNFRAC*10) + 1

***  {END MODULE 3}

***** GENERATE RANDOM NUMBERS AND TEST DATA.  {MODULE 4}

      RANDOM = RNSEED

      DO 280 KOUNT = 1,NKOUNT

*****    GENERATE ONE RANDOM NUMBER.  {MODULE 5}

*        FOR ACCURACY, DO MODULO ARITHMETIC W/O MODULO FUNCTION.
         RANX   = RANA*RANDOM + RANC
         RANDIV = RANX/RANM
         RANT   = DINT(RANDIV)
         RANSUB = RANT*RANM
         RANDOM = RANX - RANSUB

*        TEST FOR CYCLING OF THE RANDOM NUMBER GENERATOR.
         IF (RANDOM .EQ. RNSEED) THEN
            KOUNT1 = KOUNT
            GO TO 410
         ENDIF

         RNFRAC = SNGL(RANDOM/RANM)

         IF (RNFRAC .GE. 1.0) RNFRAC = 0.9999

***      {END MODULE 5}

*****    DATA FOR CHI SQUARE TEST.  {MODULE 6}

         IRNBIN = AINT(100*RNFRAC) + 1

         IRNHIS(IRNBIN) = IRNHIS(IRNBIN) + 1

***      {END MODULE 6}

*****    DATA FOR MEDIAN RUNS TEST.  {MODULE 7}

         IF (RNFRAC .GE. 0.5) THEN
            IRUNHI = IRUNHI + 1
         ELSE
            IRUNLO = IRUNLO + 1
         ENDIF

         IF (KOUNT .EQ. 1) THEN

            IF (RNFRAC .GE. 0.5) THEN
               LRUNHI = .TRUE.
               IRUNS  = 1
            ELSE
               LRUNHI = .FALSE.
               IRUNS  = 1
            ENDIF

         ELSE

            IF (LRUNHI) THEN

               IF (RNFRAC .LT. 0.5) THEN
                  IRUNS  = IRUNS + 1
                  LRUNHI = .FALSE.
               ENDIF

            ELSE

               IF (RNFRAC .GE. 0.5) THEN
                  IRUNS  = IRUNS + 1
                  LRUNHI = .TRUE.
               ENDIF

            ENDIF

         ENDIF

***      {END MODULE 7}

*****    DATA FOR SERIAL TEST.  {MODULE 8}

*        INCLUDE ONLY EVERY OTHER PAIR FOR RANDOMNESS.

         ISER2 = AINT(RNFRAC*10) + 1

         IF (LIN) THEN

            ISER(ISER1,ISER2) = ISER(ISER1,ISER2) + 1
            LIN = .FALSE.

         ELSE

            LIN = .TRUE.

         ENDIF

***      {END MODULE 8}

*****    WRITE VARIABLES FOR ONE LOOP.  {MODULE 9}

         IF ((AREAD .EQ. 'Y') .OR. (MOD(KOUNT,10000) .EQ. 0)) THEN

            WRITE  (*,270) KOUNT,RANDOM,RNFRAC,IRUNS,IRUNHI,IRUNLO,
     *                     ISER1,ISER2,ISER(ISER1,ISER2)
270         FORMAT (1X,'COUNT:',I8,6X,'RANDOM NUMBER: ',F10.0,6X,
     *                 'RANDOM FRACTION: ',F6.4/
     *              1X,'MEDIAN RUNS TEST:   ',
     *                 'IRUNS: ',I8,6X,'IRUNHI:',I8,6X,'IRUNLO:',I8/
     *              1X,'SERIAL TEST:        ',
     *                 'ISER1: ',I8,6X,'ISER2: ',I8,6X,'ISER:  ',I8/)

         ENDIF

***      {END MODULE 9}

*        PREPARE FOR NEXT SERIAL DATA.
         ISER1 = ISER2

280   CONTINUE

***   END (KOUNT) DO LOOP.  {END MODULE 4}

***** WRITE RUN HISTOGRAM.  {MODULE 10}

      WRITE  (*,290)
290   FORMAT (/1X,'RUN HISTOGRAM FOR FRACTIONAL (0.0 - 1.0) ',
     *        'RANDOM NUMBERS')

      WRITE  (*,300) (IRNHIS(I),I=1,100)
300   FORMAT (1X,10I7)

***   {END MODULE 10}

***** CHI SQUARE TEST.  {MODULE 11}

      CHISQR = 0.0

      DO 310 I=1,100

         IHIS   = IRNHIS(I)
         DELTA  = FLOAT(IHIS) - FLOAT(NKOUNT)/100

         CHISQR = DELTA*DELTA/(FLOAT(NKOUNT)/100) + CHISQR

310   CONTINUE

      WRITE  (*,320) CHISQR
320   FORMAT (/1X,'CHI SQUARE:',F8.4)

***   {END MODULE 11}

***** KOLMOGOROV-SMIRNOV ONE-SAMPLE TEST.  {MODULE 12}

      IHIS = 0
      FKOL = 0.0

      DO 330 I=1,100

         IHIS = IHIS + IRNHIS(I)
         DEV  = ABS(FLOAT(IHIS)/NKOUNT - FLOAT(I)/100)

         IF (FKOL .LT. DEV) FKOL = DEV

330   CONTINUE

      WRITE  (*,340) FKOL
340   FORMAT (/1X,'KOLMOGOROV-SMIRNOV MAXIMUM DEVIATION:',F8.4)

***   {END MODULE 12}

***** MEDIAN RUNS TEST.  {MODULE 13}

      FRUNS  = FLOAT(IRUNS)
      FRUNHI = FLOAT(IRUNHI)
      FRUNLO = FLOAT(IRUNLO)

      FMRUNS = (2*FRUNHI*FRUNLO)/(FRUNHI + FRUNLO) + 1

      VRUNS  = ((2*FRUNHI*FRUNLO)*(2*FRUNHI*FRUNLO - FRUNHI - FRUNLO))/
     *         (((FRUNHI + FRUNLO)**2)*(FRUNHI + FRUNLO -1))

      SRUNS = SQRT(VRUNS)

      ZRUNS = (FRUNS - FMRUNS)/SRUNS

      WRITE  (*,350) FRUNS,FMRUNS,SRUNS,ZRUNS
350   FORMAT (/1X,'MEDIAN RUNS TEST:'/
     *         1X,'FRUNS:',F12.2,8X,'FMRUNS:',F12.2,8X,'SRUNS:',F12.2/
     *         1X,'Z-SCORE FOR THE RUNS:',F14.4)

***   {END MODULE 13}

***** SERIAL (CHI SQUARE) TEST.  {MODULE 14}

*     USE FLOAT(NCOUNT)/2 AS THE NUMBER OF PAIR OBSERVATIONS.

      CHISQR = 0.0

      DO 360 ISER1 = 1,10
         DO 360 ISER2 = 1,10

            IISER = ISER(ISER1,ISER2)
            DELTA  = FLOAT(IISER) - (FLOAT(NKOUNT)/2)/100

            CHISQR = DELTA*DELTA/((FLOAT(NKOUNT)/2)/100) + CHISQR

360   CONTINUE

      WRITE  (*,370) CHISQR
370   FORMAT (/1X,'SERIAL TEST VALUE (CHI SQUARE):',F10.4)

      WRITE  (*,380)
380   FORMAT (1X,'SERIAL TEST HISTOGRAM:')

      DO 400 ISER1 = 1,10
         ISERW = ISER1 - 1
         WRITE  (*,390) ISERW,(ISER(ISER1,ISER2),ISER2=1,10)
390      FORMAT (1X,I1,':',10I7)
400   CONTINUE

***   {END MODULE 14}

***** GENERATOR CYCLE MESSAGE.  {MODULE 15}

410   CONTINUE

      IF (RANDOM .EQ. RNSEED) THEN
         WRITE  (*,420) KOUNT1
420      FORMAT (//1X,'GENERATOR CYCLED AT COUNT = ',I10//)
      ENDIF

***   {END MODULE 15}

***** STOP PROGRAM.  {MODULE 16}

      STOP

      END

***   {END MODULE 16}

***************************** RANDOM.FOR *******************************


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

module eigen

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

!----------------------------------------------------
! This module contains routines for solve eigenproblems
!
! communication tags in this module are of the form 2xxx
!----------------------------------------------------

!----------------------------------------------------
! Other modules used:

use linsystype_mod
use global
use message_passing
use gridtype_mod
use petsc_interf
use mumps_interf
use hypre_interf
use superlu_interf
use linsys_util
use sort_mod
use krylov
use lapack_solve
use hbmg
use make_linsys
!----------------------------------------------------

implicit none
private
public eigen_arpack, eigen_blopex

contains

!          ------------
subroutine eigen_arpack(grid,procs,linsys,io_cntl,solver_cntl,still_sequential)
!          ------------

!----------------------------------------------------
! This routine solves the eigenvalue problem Ax = lambda*Mx where A is
! stiffness and M is mass.  It uses ARPACK to solve for the largest
! eigenvalue(s) and eigenvector(s) of
!
!                -1
! (A - lambda0*M)  M x = mu*x
!
! which gives lambda = 1/mu + lambda0 to give the eigenvalues closest to
! lambda0 (but they are computed by the Raleigh quotient rather than this
! formula).  If lambda0 == -huge(0), then rmin (the minimum value of the
! coefficient of u in the PDE, which should be smaller than the smallest
! eigenvalue) is used to get the smallest eigenvalues.
!
! This is the traditional "shift and invert" spectral transformation.  In
! ARPACK notation
!                      -1
!  OP = (A - lambda0*M)  M  and B = M
!
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

type(grid_type), intent(inout) :: grid
type(proc_info), intent(in) :: procs
type(linsys_type), intent(inout), target :: linsys
type(io_options), intent(in) :: io_cntl
type(solver_options), intent(in) :: solver_cntl
logical, intent(in) :: still_sequential

!----------------------------------------------------
! Local variables:

! choose between using the symmetric solvers and nonsymmetric solvers

logical, parameter :: symm = .false.

real(my_real), allocatable :: arnoldi_vec(:,:), arp_workd(:), arp_resid(:), &
                 arp_workl(:), dr(:), di(:), evec(:,:), workev(:)
integer :: nev, ncv, lworkl, kev
integer :: arp_param(11), arp_pntr(14)
integer, allocatable :: iperm(:)
real(my_real) :: tol, maxsoln, minsoln
real(my_real) :: l2resid, l2rhs, solnMnorm, soln2norm, sums(2)
integer :: ido, info, iter, nproc, comm, neqown, allocstat, neq_total, &
           ndirch, neq, neq_full, objtype,brank,srank,objlid,loc_neq, ii, jj, &
           nresid_comp, lev
character(len=1) :: bmat, howmany
character(len=2) :: which
logical :: rvec, select(solver_cntl%arpack_cntl%ncv)
integer :: i, j, ss, eq
real(my_real) :: tempvec(linsys%neq_vert+linsys%neq_edge+linsys%neq_face), &
                 Ax(linsys%neq_vert+linsys%neq_edge+linsys%neq_face), &
                 Mx(linsys%neq_vert+linsys%neq_edge+linsys%neq_face)
real(my_real), pointer :: tmpptr(:), block(:,:)
integer, pointer :: ipiv(:)
real(my_real) :: my_resid(linsys%neq)
real(my_real) :: numer, denom, lambda0
logical :: i_made_lapack, i_made_petsc, i_made_mumps, i_made_superlu, &
           i_made_hypre
type(linsys_type) :: full_matrix
integer :: ni, nr, proc
integer, pointer :: irecv(:)
real(my_real), pointer :: rrecv(:)

!----------------------------------------------------
! Begin executable code

! in case we abort early

grid%arpack_iter = 0
grid%arpack_nconv = 0
grid%arpack_numop = 0
grid%arpack_numopb = 0
grid%arpack_numreo = 0
grid%arpack_info = 0

! master hangs around just to see if it needs to print a warning

if (my_proc(procs) == MASTER) then
   do
      call phaml_recv(procs,proc,irecv,ni,rrecv,nr,2201)
      select case (irecv(1))
      case (1) ! all done
         deallocate(irecv,stat=allocstat)
         exit
      case (2) ! ARPACK eigenvalue does not agree with Raleigh quotient
         call warning("Eigenvalue returned by ARPACK is not close to Raleigh quotient; may be wrong", &
                      "Eigenvalue number, eigenvalue and Raleigh quotient are:", &
                      (/irecv(2)/),rrecv)
         deallocate(irecv,rrecv,stat=allocstat)
      end select
   end do
   return
endif

! use linsys for solving the (statically condensed) shifted linear systems,
! and full_matrix for operations that need the whole matrix.  full_matrix
! points to entries in linsys with the following pointers/values different:
!  linsys%end_row => end_row_edge
!  linsys%matrix_val => condensed => shifted
!  linsys%rhs => rhs_cond
!  linsys%neq = neq_vert+neq_edge

full_matrix = linsys

full_matrix%end_row => linsys%end_row_face
full_matrix%matrix_val => linsys%stiffness
full_matrix%rhs => linsys%rhs_nocond
full_matrix%neq = linsys%neq_vert + linsys%neq_edge + linsys%neq_face

! convenience variables

nproc = num_proc(procs)
comm = slaves_communicator(procs)
nev = solver_cntl%num_eval
neq = linsys%neq
neq_full = full_matrix%neq
ss = grid%system_size
if (solver_cntl%lambda0 == -huge(0.0_my_real)) then
   lambda0 = linsys%rmin
else
   lambda0 = solver_cntl%lambda0
endif

! Make sure there is space in grid for the requested number of eigenvalues

if (size(grid%eigenvalue) /= nev) then
   deallocate(grid%eigenvalue,grid%eigenprob_l2_resid, &
              grid%eigenprob_variance,stat=allocstat)
   allocate(grid%eigenvalue(nev),grid%eigenprob_l2_resid(nev), &
            grid%eigenprob_variance(nev),stat=allocstat)
   if (allocstat /= 0) then
      ierr = ALLOC_FAILED
      call fatal("memory allocation failed in eigen_arpack",procs=procs)
      return
   endif
   grid%eigenvalue = 0.0_my_real
   grid%eigenprob_l2_resid = 0.0_my_real
   grid%eigenprob_variance = 0.0_my_real
endif

! copy the solutions from the grid to the linear system to return the
! old solution if we abort

do i=1,neq_full
   call eq_to_grid(full_matrix,full_matrix%gid(i),objtype,brank,srank, &
                   objlid,grid)
   select case (objtype)
   case (VERTEX_ID)
      full_matrix%solution(i) = grid%vertex_solution(objlid,srank,1)
      if (nev > 1) then
         full_matrix%evecs(i,:) = grid%vertex_solution(objlid,srank,2:nev)
      endif
   case (EDGE_ID)
      full_matrix%solution(i) = grid%edge(objlid)%solution(brank,srank,1)
      if (nev > 1) then
         do j=1,nev-1
            full_matrix%evecs(i,j) = grid%edge(objlid)%solution(brank,srank,j)
         end do
      endif
   case (ELEMENT_ID)
      full_matrix%solution(i) = grid%element(objlid)%solution(brank,srank,1)
      if (nev > 1) then
         do j=1,nev-1
            full_matrix%evecs(i,j) = grid%element(objlid)%solution(brank,srank,j)
         end do
      endif
   end select
end do

! all processors must own an equation for ARPACK to work

if (phaml_global_min(procs,grid%nvert_own,2000) == 0) then
   call warning("Some processor owns no equations; ARPACK would fail.", &
                "Returning old solution.")
   return
endif

! if there aren't enough equations, reduce number of Arnoldi vectors

ncv = solver_cntl%arpack_cntl%ncv

neqown = 0
ndirch = 0
do i=1,neq_full
   if (full_matrix%iown(i)) then
      neqown = neqown + 1
      if (full_matrix%equation_type(i) == DIRICHLET) ndirch = ndirch + 1
   endif
end do
if (still_sequential) then
   neq_total = neqown - ndirch
else
   neq_total = phaml_global_sum(procs,neqown-ndirch,2001)
endif
if (neq_total < ncv) ncv = max(1,neq_total-1)

! if ncv is too small, reduce number of eigenvalues

if (ncv - nev < 2) then
   nev = ncv - 2
   call warning( &
     "Not enough equations or Arnoldi vectors for requested number of eigenvalues.", &
     "Computing", intlist=(/nev/))
endif

! allocate memory for ARPACK

lworkl = 3*ncv*ncv + 6*ncv
allocate(arnoldi_vec(neqown,ncv), arp_workd(3*neqown), arp_resid(neqown), &
         arp_workl(lworkl), dr(nev+1), di(nev+1), evec(neqown,nev+1), &
         workev(3*ncv), iperm(nev), stat=allocstat)
if (allocstat /= 0) then
   ierr = ALLOC_FAILED
   call fatal("memory allocation failed in eigen_arpack",procs=procs)
   return
endif

! initalize convergence information

grid%eigen_linsys_max_l2_resid = 0.0_my_real
grid%eigen_linsys_ave_l2_resid = 0.0_my_real
nresid_comp = 0
grid%eigenprob_l2_resid = 0.0_my_real
grid%eigenprob_variance = 0.0_my_real

! create any needed alternate storage formats for solution methods

i_made_lapack = .false.
i_made_petsc = .false.
i_made_mumps = .false.
i_made_superlu = .false.
i_made_hypre = .false.

select case (solver_cntl%solver)

case (LAPACK_INDEFINITE_SOLVER)
   if (linsys%lapack_symm_band_exists) then
      call destroy_lapack_band(linsys%lapack_mat)
      linsys%lapack_symm_band_exists = .false.
   endif
   if (.not. linsys%lapack_gen_band_exists) then
      call make_lapack_gen_band(linsys%nlev+1,linsys,linsys%lapack_mat)
      linsys%lapack_gen_band_exists = .true.
      i_made_lapack = .true.
   endif

case (LAPACK_SPD_SOLVER)
   if (linsys%lapack_gen_band_exists) then
      call destroy_lapack_band(linsys%lapack_mat)
      linsys%lapack_gen_band_exists = .false.
   endif
   if (.not. linsys%lapack_symm_band_exists) then
      call make_lapack_symm_band(linsys%nlev+1,linsys,linsys%lapack_mat)
      if (ierr /= NO_ERROR) return
      linsys%lapack_symm_band_exists = .true.
      i_made_lapack = .true.
   endif

case (MUMPS_SPD_SOLVER, MUMPS_GEN_SOLVER, MUMPS_NONSYM_SOLVER)
   if (.not. linsys%mumps_matrix_exists) then
      call create_mumps_linear_system(linsys%mumps_matrix,linsys,procs, &
                                      solver_cntl,still_sequential)
      linsys%mumps_matrix_exists = .true.
      i_made_mumps = .true.
   endif

case (SUPERLU_SOLVER)
   if (.not. linsys%superlu_matrix_exists) then
      call create_superlu_linear_system(linsys%superlu_matrix,linsys, &
                                        procs,still_sequential)
      linsys%superlu_matrix_exists = .true.
      i_made_superlu = .true.
   endif

case (PETSC_RICHARDSON_SOLVER, PETSC_CHEBYCHEV_SOLVER, PETSC_CG_SOLVER, &
      PETSC_GMRES_SOLVER,      PETSC_TCQMR_SOLVER,     PETSC_BCGS_SOLVER,&
      PETSC_CGS_SOLVER,        PETSC_TFQMR_SOLVER,     PETSC_CR_SOLVER, &
      PETSC_LSQR_SOLVER,       PETSC_BICG_SOLVER)
   if (.not. linsys%petsc_matrix_exists) then
      if (solver_cntl%petsc_matrix_free) then
         call create_petsc_linear_system_mf(linsys,linsys%petsc_matrix, &
                                         still_sequential)
      else
         call create_petsc_linear_system(linsys,linsys%petsc_matrix, &
                                         still_sequential,procs)
      endif
      linsys%petsc_matrix_exists = .true.
      i_made_petsc = .true.
   endif

case (HYPRE_BOOMERAMG_SOLVER, HYPRE_PCG_SOLVER, HYPRE_GMRES_SOLVER)
   if (.not. linsys%hypre_matrix_exists) then
      call create_hypre_linear_system(linsys%hypre_matrix,linsys,procs, &
                                      still_sequential)
      linsys%hypre_matrix_exists = .true.
      i_made_hypre = .true.
   endif

end select

! chose between closest to lambda0 (LM), larger than lambda0 (LR),
! and smaller than lambda0 (SR) (assumes symm=.false., different if true)

select case (solver_cntl%lambda0_side)
case (EIGEN_BOTH)
   which = "LM"                         ! compute largest magnitude eigenvalues
case (EIGEN_RIGHT)
   which = "LR"                         ! compute largest real part eigenvalues
case (EIGEN_LEFT)
   which = "SR"                         ! compute smallest real part e-values
case default
   ierr = USER_INPUT_ERROR
   call fatal("bad value for lambda0_side in eigen_arpack", &
              intlist=(/solver_cntl%lambda0_side/),procs=procs)
   stop
end select

! set parameters for ARPACK

ido = 0                                 ! indicates first call
bmat = "G"                              ! generalized eigenvalue problem
tol = solver_cntl%arpack_cntl%tol       ! stopping criteria
arp_param = 0                           ! set unused entries to 0
arp_param(1) = 1                        ! shifts are not provided by the user
arp_param(3) = solver_cntl%arpack_cntl%maxit ! maximum number of iterations
arp_param(7) = 3                        ! shift-invert mode

! set initial guess for eigenvector
! TEMP would it be better to use some combination of existing eigenvectors
! instead of the first one?

call all_to_mine(full_matrix,full_matrix%solution(1:),arp_resid)
if (maxval(abs(arp_resid)) < 10*epsilon(0.0_my_real)) then
   info = 0                                 ! random initial residual vector
else
   info = 1                                 ! nonrandom initial residual vector
endif

! main loop

iter = 0
do
   iter = iter + 1

! call ARPACK routine [p| ][s|d][s|n]aupd for
! [parallel|sequential][single|double] precision [symmetric|nonsymmetric]
! eigensolver

   if (my_real == kind(1.0e0)) then
      if (nproc > 1 .and. .not. still_sequential) then
       if (symm) then
         call pssaupd(comm,ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       else
         call psnaupd(comm,ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       endif
      else
       if (symm) then
         call ssaupd(ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       else
         call snaupd(ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       endif
      endif
   elseif (my_real == kind(1.0d0)) then
      if (nproc > 1 .and. .not. still_sequential) then
       if (symm) then
         call pdsaupd(comm,ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       else
         call pdnaupd(comm,ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       endif
      else
       if (symm) then
         call dsaupd(ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       else
         call dnaupd(ido,bmat,neqown,which,nev,tol,arp_resid,ncv, &
                     arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                     arp_workl,lworkl,info)
       endif
      endif
   else
      ierr = PHAML_INTERNAL_ERROR
      call fatal("my_real is neither single nor double precision. Can't call ARPACK",procs=procs)
      return
   endif

   if (info /= 0) then
      call warning("info from ARPACK *aupd is nonzero",intlist=(/info/))
   endif

! Determine which task to perform

   select case (ido)

   case (-1,1) ! multiply by (A-lambda0*M)^-1*M
               ! If ido==1, then leave off the multiplication by M

! Copy the vector from ARPACK into rhs

      if (ido == -1) then
         call mine_to_all(full_matrix,arp_workd(arp_pntr(1):arp_pntr(1)+neqown-1), &
                          full_matrix%rhs,0.0_my_real)
      else
         call mine_to_all(full_matrix,arp_workd(arp_pntr(3):arp_pntr(3)+neqown-1), &
                          full_matrix%rhs,0.0_my_real)
      endif

! For FuDoP multigrid, get rhs entries from other processors, making sure they
! match my level of the corresponding vertex

      if (solver_cntl%solver == MG_SOLVER .and. .not. still_sequential .and. &
          nproc > 1) then
         do lev=full_matrix%nlev+1,2,-1
            call basis_change(lev,TO_HIER,full_matrix,skip_matrix=.true.)
         end do
         call sum_fudop_vect(full_matrix%rhs,procs,full_matrix, &
                             2310+iter+1,2320+iter+1,2325+iter+1)
         do lev=2,full_matrix%nlev+1
            call basis_change(lev,TO_NODAL,full_matrix,skip_matrix=.true.)
         end do
! second mine_to_all to fix any changes at my points due to basis changes
         if (ido == -1) then
            call mine_to_all(full_matrix,arp_workd(arp_pntr(1):arp_pntr(1)+neqown-1), &
                             full_matrix%rhs)
         else
            call mine_to_all(full_matrix,arp_workd(arp_pntr(3):arp_pntr(3)+neqown-1), &
                             full_matrix%rhs)
         endif
      endif

! for ido==-1, multiply by M putting the result in rhs

      if (ido == -1) then
         tempvec = full_matrix%rhs
         full_matrix%matrix_val => full_matrix%mass
         call matrix_times_vector(tempvec,full_matrix%rhs,full_matrix,procs, &
                                  still_sequential,2100+iter,2110+iter, &
                                  2115+iter,2120+iter,2130+iter,2135+iter, &
                                  nocomm2=.true.)
! For FuDoP multigrid, get the product for equations owned by other processors,
! making sure it is converted to my level for that equation
         if (solver_cntl%solver == MG_SOLVER .and. &
             .not. still_sequential .and. nproc > 1) then
            do i=1,neq
               if (.not. full_matrix%iown(i)) &
                  full_matrix%rhs(i) = 0.0_my_real
            end do
            do lev=full_matrix%nlev+1,2,-1
               call basis_change(lev,TO_HIER,full_matrix,skip_matrix=.true.)
            end do
            call sum_fudop_vect(full_matrix%rhs,procs,full_matrix, &
                                2330+2*iter,2340+2*iter,2345+2*iter)
            do lev=2,full_matrix%nlev+1
               call basis_change(lev,TO_NODAL,full_matrix,skip_matrix=.true.)
            end do
         endif
      endif

! multiply by (A-lambda0*M)^-1, i.e., call a solver

! perform static condensation on the rhs of full_matrix, putting the
! result in the rhs of linsys; b1 - A21 A2^-1 b2 where 2 is face bases

      if (full_matrix%begin_level(full_matrix%nlev+2) /= &
          full_matrix%begin_level(full_matrix%nlev+3)) then

         linsys%rhs(1:neq) = full_matrix%rhs(1:neq)
         full_matrix%matrix_val => full_matrix%shifted
         eq = full_matrix%begin_level(full_matrix%nlev+2)
         do
            if (eq >= full_matrix%begin_level(full_matrix%nlev+3)) exit
            call eq_to_grid(full_matrix,full_matrix%gid(eq),objtype,brank, &
                            srank,objlid,grid)
            block => full_matrix%elem_block(objlid)%matrix
            ipiv => full_matrix%elem_block(objlid)%ipiv
            loc_neq = full_matrix%elem_block(objlid)%neq
            tempvec(1:loc_neq) = full_matrix%rhs(eq:eq+loc_neq-1)
            if (my_real == kind(0.0)) then
              call sgetrs("N",loc_neq,1,block,loc_neq,ipiv,tempvec,loc_neq,info)
            else
              call dgetrs("N",loc_neq,1,block,loc_neq,ipiv,tempvec,loc_neq,info)
            endif
            if (info /= 0) then
               ierr = PHAML_INTERNAL_ERROR
               call fatal("lapack sgetrs solution failed", &
                          intlist=(/info/),procs=procs)
               stop
            endif
            do i=1,loc_neq
               do j=full_matrix%begin_row(eq+i-1),full_matrix%end_row(eq+i-1)
                  if (full_matrix%column_index(j) == NO_ENTRY) cycle
                  if (full_matrix%column_index(j) >= eq .and. &
                      full_matrix%column_index(j) < eq+loc_neq) cycle
                  linsys%rhs(full_matrix%column_index(j)) = &
                                linsys%rhs(full_matrix%column_index(j)) - &
                                get_matval(full_matrix,full_matrix%matrix_val, &
                                full_matrix%column_index(j),eq+i-1)*tempvec(i)
               end do
            end do
            eq = eq + loc_neq
         end do

         if (.not. still_sequential .and. nproc > 1) then
            call sum_fudop_vect(linsys%rhs(1:neq),procs,linsys,2510+iter, &
                                2520+iter,2530+iter)
         endif

      endif

! solve the linear system by the chosen solver

      select case (solver_cntl%solver)
      case (MG_SOLVER)
         call multigrid(grid,procs,linsys,io_cntl,solver_cntl,still_sequential,&
                        no_master=.true.)
      case (CG_SOLVER)
         call phaml_cg(linsys,procs,grid,io_cntl,solver_cntl,still_sequential)
      case (GMRES_SOLVER)
         call phaml_gmres(linsys,procs,grid,io_cntl,solver_cntl, &
                          still_sequential)
      case (LAPACK_INDEFINITE_SOLVER)
         call lapack_indef(linsys%nlev+1,linsys,linsys%lapack_mat)
      case (LAPACK_SPD_SOLVER)
         call lapack_spd(linsys%nlev+1,linsys,linsys%lapack_mat)
      case (MUMPS_SPD_SOLVER, MUMPS_GEN_SOLVER, MUMPS_NONSYM_SOLVER)
         call change_mumps_rhs(linsys%mumps_matrix,linsys,linsys%rhs, &
                               procs,still_sequential)
         call mumps_solve(linsys%mumps_matrix,linsys,procs, &
                          still_sequential,noshadow=.true.)
      case (SUPERLU_SOLVER)
         call change_superlu_rhs(linsys%superlu_matrix,linsys,linsys%rhs, &
                                 procs,still_sequential)
         call superlu_solve(linsys%superlu_matrix,linsys,procs, &
                            still_sequential)
      case (PETSC_RICHARDSON_SOLVER, PETSC_CHEBYCHEV_SOLVER, PETSC_CG_SOLVER, &
            PETSC_GMRES_SOLVER,      PETSC_TCQMR_SOLVER,     PETSC_BCGS_SOLVER,&
            PETSC_CGS_SOLVER,        PETSC_TFQMR_SOLVER,     PETSC_CR_SOLVER, &
            PETSC_LSQR_SOLVER,       PETSC_BICG_SOLVER)
         where (linsys%equation_type == DIRICHLET) linsys%rhs = linsys%solution(1:)
         call change_petsc_rhs(linsys%rhs,linsys%petsc_matrix)
         call petsc_solve(linsys,linsys%petsc_matrix,solver_cntl,io_cntl, &
                          still_sequential,grid,procs)
      case (HYPRE_BOOMERAMG_SOLVER, HYPRE_PCG_SOLVER, HYPRE_GMRES_SOLVER)
         call change_hypre_rhs(linsys%hypre_matrix,linsys,linsys%rhs,procs, &
                               still_sequential)
         call zero_hypre_solution(linsys%hypre_matrix,procs,still_sequential)
         call hypre_solve(linsys%hypre_matrix,linsys,procs,solver_cntl, &
                          still_sequential)
      case default
         ierr = USER_INPUT_ERROR
         call fatal("illegal selection for solver",procs=procs)
         return
      end select

! get solution for unowned equations that neigbor an owned equation

      if (.not. still_sequential) then
         call exchange_neigh_vect(linsys%solution(1:neq),procs,linsys, &
                                  2360+iter,2370+iter,2380+iter)
      endif

! solve for the face bases; x2 = A2^-1 (b2 - A12 x1)
! note full_matrix%solution and linsys%solution point to the same place

      full_matrix%matrix_val => full_matrix%shifted
      eq = full_matrix%begin_level(full_matrix%nlev+2)
      do
         if (eq >= full_matrix%begin_level(full_matrix%nlev+3)) exit
         call eq_to_grid(full_matrix,full_matrix%gid(eq),objtype,brank, &
                         srank,objlid,grid)
         block => full_matrix%elem_block(objlid)%matrix
         ipiv => full_matrix%elem_block(objlid)%ipiv
         loc_neq = full_matrix%elem_block(objlid)%neq
         do i=1,loc_neq
            full_matrix%solution(eq+i-1) = full_matrix%rhs(eq+i-1)
            do j=full_matrix%begin_row(eq+i-1),full_matrix%end_row(eq+i-1)
               if (full_matrix%column_index(j) == NO_ENTRY) cycle
               if (full_matrix%column_index(j) >= eq .and. &
                   full_matrix%column_index(j) < eq+loc_neq) cycle
               full_matrix%solution(eq+i-1) = full_matrix%solution(eq+i-1)- &
                  full_matrix%matrix_val(j)*full_matrix%solution(full_matrix%column_index(j))
            end do
         end do
         if (my_real == kind(0.0)) then
            call sgetrs("N",loc_neq,1,block,loc_neq,ipiv, &
                        full_matrix%solution(eq:eq+loc_neq-1),loc_neq,info)
         else
            call dgetrs("N",loc_neq,1,block,loc_neq,ipiv, &
                        full_matrix%solution(eq:eq+loc_neq-1),loc_neq,info)
         endif
         if (info /= 0) then
            ierr = PHAML_INTERNAL_ERROR
            call fatal("lapack spotrs solution failed for solving for face bases", &
                       intlist=(/info/),procs=procs)
            stop
         endif
         eq = eq + loc_neq
      end do

! compute the residual from the linear system solver (does not include
! face bases)

      my_resid = 0.0_my_real
      call matrix_times_vector(linsys%solution(1:neq),my_resid,linsys, &
                               procs,still_sequential,2410+iter,2420+iter, &
                               2425+iter,2430+iter,2440+iter,2445+iter, &
                               nocomm2=.true.)
      my_resid = my_resid-linsys%rhs(1:neq)
      do i=1,neq
         if (.not. linsys%iown(i)) my_resid(i) = 0.0_my_real
         if (linsys%equation_type(i)==DIRICHLET) my_resid(i) = 0.0_my_real
      end do
      l2resid = sum(my_resid**2)
      l2rhs = sum(linsys%rhs(1:neq)**2, &
                  mask=linsys%equation_type(1:neq)/=DIRICHLET)
      sums = phaml_global_sum(procs,(/l2resid,l2rhs/),2450+iter)
      l2resid = sqrt(sums(1))
      l2rhs = sqrt(sums(2))
      if (l2rhs /= 0.0_my_real) l2resid = l2resid/l2rhs
      grid%eigen_linsys_max_l2_resid = max(grid%eigen_linsys_max_l2_resid, &
                                           l2resid)
      grid%eigen_linsys_ave_l2_resid = grid%eigen_linsys_max_l2_resid + l2resid
      nresid_comp = nresid_comp + 1

! copy the result into ARPACK's workspace

      call all_to_mine(full_matrix,full_matrix%solution(1:neq_full), &
                       arp_workd(arp_pntr(2):arp_pntr(2)+neqown-1))

   case (2) ! multiply by M

! Copy the vector from ARPACK into rhs

      call mine_to_all(full_matrix,arp_workd(arp_pntr(1):arp_pntr(1)+neqown-1), &
                       full_matrix%rhs,0.0_my_real)

! For FuDoP multigrid, get rhs entries from other processors, making sure they
! match my level of the corresponding vertex

      if (solver_cntl%solver == MG_SOLVER .and. .not. still_sequential .and. &
          nproc > 1) then
         do lev=full_matrix%nlev+1,2,-1
            call basis_change(lev,TO_HIER,full_matrix,skip_matrix=.true.)
         end do
         call sum_fudop_vect(full_matrix%rhs,procs,full_matrix, &
                             2350+iter+1,2360+iter+1,2365+iter+1)
         do lev=2,full_matrix%nlev+1
            call basis_change(lev,TO_NODAL,full_matrix,skip_matrix=.true.)
         end do
! second mine_to_all to fix any changes at my points due to basis changes
         call mine_to_all(full_matrix,arp_workd(arp_pntr(1):arp_pntr(1)+neqown-1), &
                          full_matrix%rhs)
      endif

! multiply by M putting the result in rhs

      tempvec = full_matrix%rhs
      full_matrix%matrix_val => full_matrix%mass
      call matrix_times_vector(tempvec,full_matrix%rhs,full_matrix,procs, &
                               still_sequential,2140+iter,2150+iter, &
                               2155+iter,2160+iter,2170+iter,2175+iter, &
                               nocomm2=.true.)

! copy the result into ARPACK's workspace

      call all_to_mine(full_matrix,full_matrix%rhs, &
                       arp_workd(arp_pntr(2):arp_pntr(2)+neqown-1))

   case default ! ARPACK done
      exit

   end select

end do

! finish computing the average residual

if (nresid_comp /= 0) then
   grid%eigen_linsys_ave_l2_resid = grid%eigen_linsys_ave_l2_resid/nresid_comp
endif

! gather some statistics from ARPACK

grid%arpack_iter = arp_param(3)
grid%arpack_nconv = arp_param(5)
grid%arpack_numop = arp_param(9)
grid%arpack_numopb = arp_param(10)
grid%arpack_numreo = arp_param(11)
grid%arpack_info = 0

! check for failure

if (info /= 0) then
   call warning("ARPACK *aupd failed. info and nconv are",&
                intlist=(/info,grid%arpack_nconv/))
   grid%arpack_info = info
endif

! extract eigenvalue and compute eigenvector

rvec = .true. ! compute eigenvector
howmany = "A" ! compute all eigenvectors

kev = nev
if (my_real == kind(1.0e0)) then
   if (nproc > 1 .and. .not. still_sequential) then
    if (symm) then
      call psseupd(comm,rvec,howmany,select,dr,evec,neqown,lambda0, &
                  bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    else
      call psneupd(comm,rvec,howmany,select,dr,di,evec,neqown,lambda0, &
                  0.0_my_real,workev,bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    endif
   else
    if (symm) then
      call sseupd(rvec,howmany,select,dr,evec,neqown,lambda0, &
                  bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    else
      call sneupd(rvec,howmany,select,dr,di,evec,neqown,lambda0, &
                  0.0_my_real,workev,bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    endif
   endif
elseif (my_real == kind(1.0d0)) then
   if (nproc > 1 .and. .not. still_sequential) then
    if (symm) then
      call pdseupd(comm,rvec,howmany,select,dr,evec,neqown,lambda0, &
                  bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    else
      call pdneupd(comm,rvec,howmany,select,dr,di,evec,neqown,lambda0, &
                  0.0_my_real,workev,bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    endif
   else
    if (symm) then
      call dseupd(rvec,howmany,select,dr,evec,neqown,lambda0, &
                  bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    else
      call dneupd(rvec,howmany,select,dr,di,evec,neqown,lambda0, &
                  0.0_my_real,workev,bmat,neqown,which,kev,tol,arp_resid, &
                  ncv,arnoldi_vec,neqown,arp_param,arp_pntr,arp_workd, &
                  arp_workl,lworkl,info)
    endif
   endif
else
   ierr = PHAML_INTERNAL_ERROR
   call fatal("my_real is neither single nor double precision. Can't call ARPACK",procs=procs)
   return
endif

! check for failure

if (info /= 0) then
   call warning("ARPACK *eupd failed.",&
                intlist=(/info/))
   grid%arpack_info = info
endif

! sort the eigenvalues

call sort(dr,nev,iperm,1,info)

! For each eigenvalue/eigenvector

do jj=1,nev
   ii = iperm(jj)

! use tmpptr to point to the solution vector in the linear system data struct

   if (jj == 1) then
      tmpptr => full_matrix%solution(1:neq_full)
   else
      tmpptr => full_matrix%evecs(:,jj-1)
   endif

! copy the eigenvectors into the solutions

   call mine_to_all(full_matrix,evec(:,ii),tmpptr,0.0_my_real)
   if (.not. still_sequential) then
      call exchange_fudop_vect(tmpptr,procs,full_matrix,2060+ii,2070+ii, &
                               2075+ii)
   endif

! find the min and max solution values

   maxsoln = -huge(0.0_my_real)
   minsoln = huge(0.0_my_real)
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      maxsoln = max(maxsoln,tmpptr(i))
      minsoln = min(minsoln,tmpptr(i))
   end do
   if (.not. still_sequential) then
      maxsoln = phaml_global_max(procs,maxsoln,2920+ii)
      minsoln = phaml_global_min(procs,minsoln,2930+ii)
   endif

! Scale the eigenvectors so the selected norm is 1.0 and so the maximum
! absolution value is in the positive direction

   select case (solver_cntl%scale_evec)

   case (SCALE_LINF)

! Scale eigenvectors to have L infinity norm 1.0

      if (abs(minsoln) > abs(maxsoln)) then
         if (minsoln /= 0.0_my_real) tmpptr = tmpptr/minsoln
      else
         if (maxsoln /= 0.0_my_real) tmpptr = tmpptr/maxsoln
      endif

   case (SCALE_L2)

! Scale eigenvectors to have L2 norm 1.0

      soln2norm = 0.0_my_real
      do i=1,neq_full
         if (full_matrix%equation_type(i) == DIRICHLET) cycle
         if (.not. full_matrix%iown(i)) cycle
         soln2norm = soln2norm + tmpptr(i)**2
      end do
      if (.not. still_sequential) then
         soln2norm = phaml_global_sum(procs,soln2norm,2810+ii)
      endif
      soln2norm = sqrt(soln2norm)
      if (abs(minsoln) > abs(maxsoln)) then
         soln2norm = -soln2norm
      endif
      if (soln2norm /= 0.0_my_real) tmpptr = tmpptr/soln2norm

   case (SCALE_M)

! Scale eigenvectors to have M-norm 1.0

      full_matrix%matrix_val => full_matrix%mass
      call matrix_times_vector(tmpptr,Mx,full_matrix,procs,still_sequential, &
                               2850+ii,2860+ii,2865+ii,2870+ii,2880+ii, &
                               2885+ii,nocomm2=.true.)
      solnMnorm = 0.0_my_real
      do i=1,neq_full
         if (full_matrix%equation_type(i) == DIRICHLET) cycle
         if (.not. full_matrix%iown(i)) cycle
         solnMnorm = solnMnorm + tmpptr(i)*Mx(i)
      end do
      if (.not. still_sequential) then
         solnMnorm = phaml_global_sum(procs,solnMnorm,2810+ii)
      endif
      solnMnorm = sqrt(solnMnorm)
      if (abs(minsoln) > abs(maxsoln)) then
         solnMnorm = -solnMnorm
      endif
      if (solnMnorm /= 0.0_my_real) tmpptr = tmpptr/solnMnorm

   end select

! Compute Ax and Mx

   Ax = 0.0_my_real
   Mx = 0.0_my_real
   full_matrix%matrix_val => full_matrix%stiffness
   call matrix_times_vector(tmpptr,Ax,full_matrix,procs,still_sequential, &
                            2210+ii,2220+ii,2225+ii,2230+ii,2240+ii, &
                            2245+ii,nocomm2=.true.)
   full_matrix%matrix_val => full_matrix%mass
   call matrix_times_vector(tmpptr,Mx,full_matrix,procs,still_sequential, &
                            2250+ii,2260+ii,2265+ii,2270+ii,2280+ii,2285+ii, &
                            nocomm2=.true.)

! Compute the Raleigh quotient x^T A x / x^T M x to use as eigenvalues

   numer = 0.0_my_real
   denom = 0.0_my_real
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      numer = tmpptr(i)*Ax(i) + numer
      denom = tmpptr(i)*Mx(i) + denom
   end do
   if (.not. still_sequential) then
      numer = phaml_global_sum(procs,numer,2020+ii)
      denom = phaml_global_sum(procs,denom,2030+ii)
   endif
   grid%eigenvalue(jj) = numer/denom

! If the Raleigh quotient is not close to the eigenvalue that ARPACK returned,
! it may be wrong.  Tell the master to print a warning.

   if (dr(ii) /= 0.0_my_real) then
      if (abs((dr(ii)-grid%eigenvalue(jj))/dr(ii)) > 1.0_my_real) then
         if (my_proc(procs) == 1) then
            call phaml_send(procs,MASTER,(/2,jj/),2, &
                            (/dr(ii),grid%eigenvalue(jj)/),2,2201)
         endif
      endif
   endif

! Compute the l2 norm of the residual || Ax - lambda Mx || / || lambda Mx ||

   l2resid = 0.0_my_real
   l2rhs = 0.0_my_real
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      l2resid = l2resid + (Ax(i)-grid%eigenvalue(jj)*Mx(i))**2
      l2rhs = l2rhs + Mx(i)**2
   end do
   if (.not. still_sequential) then
      l2resid = phaml_global_sum(procs,l2resid,2040+ii)
      l2rhs = phaml_global_sum(procs,l2rhs,2050+ii)
   endif
   l2resid = sqrt(l2resid)
   l2rhs = abs(grid%eigenvalue(jj))*sqrt(l2rhs)
   if (l2rhs /= 0.0_my_real) l2resid = l2resid/l2rhs
   grid%eigenprob_l2_resid(jj) = l2resid

! the variance x^T A^T M^-1 A x / x^T M x

   numer = 0.0_my_real
   denom = 0.0_my_real
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      numer = numer + Ax(i)**2
      denom = denom + Mx(i)**2
   end do
   if (.not. still_sequential) then
      numer = phaml_global_sum(procs,numer,2080+ii)
      denom = phaml_global_sum(procs,denom,2090+ii)
   endif
   if (denom /= 0.0_my_real) then
      grid%eigenprob_variance(jj) = numer/denom - grid%eigenvalue(jj)**2
   else
      grid%eigenprob_variance(jj) = 0.0_my_real
   endif

end do ! jj

! free workspace

deallocate(arnoldi_vec, arp_workd, arp_resid, arp_workl, dr, di, evec, &
           workev, iperm, stat=allocstat)
if (allocstat /= 0) then
   call warning("deallocation failed in eigen_arpack")
endif
if (i_made_lapack) then
   call destroy_lapack_band(linsys%lapack_mat)
   linsys%lapack_symm_band_exists = .false.
   linsys%lapack_gen_band_exists = .false.
endif
if (i_made_petsc) then
   call destroy_petsc_linear_system(linsys%petsc_matrix)
   linsys%petsc_matrix_exists = .false.
endif
if (i_made_mumps) then
   call destroy_mumps_linear_system(linsys%mumps_matrix,procs)
   linsys%mumps_matrix_exists = .false.
endif
if (i_made_superlu) then
   call destroy_superlu_linear_system(linsys%superlu_matrix,procs)
   linsys%superlu_matrix_exists = .false.
endif
if (i_made_hypre) then
   call destroy_hypre_linear_system(linsys%hypre_matrix,procs)
   linsys%hypre_matrix_exists = .false.
endif

! tell the master we're done

if (my_proc(procs) == 1) then
   call phaml_send(procs,MASTER,(/1/),1,(/0.0_my_real/),0,2201)
endif

end subroutine eigen_arpack

!        ----------
function get_matval(linear_system,matval,row,col)
!        ----------

!----------------------------------------------------
! This routine get the (row,col) matrix value in matval
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

type(linsys_type), intent(in) :: linear_system
real(my_real), intent(in) :: matval(:)
integer, intent(in) :: row,col
real(my_real) :: get_matval
!----------------------------------------------------
! Local variables:

integer :: i

!----------------------------------------------------
! Begin executable code

! TEMP this is used to build the transpose block in static condensation.
!      If that's all it is used for, this can be made more efficient when
!      the matrix is symmetric, and maybe other times, too

! seach row for column col to get the value; return 0 if col is not found

get_matval = 0.0_my_real
do i=linear_system%begin_row(row), linear_system%end_row(row)
   if (linear_system%column_index(i) == col) then
      get_matval = matval(i)
      exit
   endif
end do

end function get_matval

!          ------------
subroutine eigen_blopex(grid,procs,linsys,io_cntl,solver_cntl,still_sequential)
!          ------------

!----------------------------------------------------
! This routine solves the eigenvalue problem Ax = lambda*Mx where A is
! stiffness and M is mass.  It uses BLOPEX.
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

type(grid_type), intent(inout) :: grid
type(proc_info), intent(in) :: procs
type(linsys_type), intent(inout), target :: linsys
type(io_options), intent(in) :: io_cntl
type(solver_options), intent(in) :: solver_cntl
logical, intent(in) :: still_sequential

!----------------------------------------------------
! Local variables:

logical :: i_made_hypre, i_made_petsc
integer :: i, j, ii, nproc, nev, neq, neq_full, ss, comm, objtype, brank, &
           srank, objlid, allocstat, info, indx, istrt, indx0
real(my_real) :: maxsoln, minsoln, lambda0, soln2norm, solnMnorm, l2resid, &
                 l2rhs, numer, denom, temp, temp2, temp3
type(linsys_type) :: full_matrix
integer :: ni, nr, proc
integer, pointer :: irecv(:)
real(my_real), pointer :: rrecv(:)
real(my_real) :: Ax(linsys%neq_vert+linsys%neq_edge+linsys%neq_face), &
                 Mx(linsys%neq_vert+linsys%neq_edge+linsys%neq_face)
real(my_real), pointer :: tmpptr(:)
integer :: iperm(solver_cntl%num_eval)
!----------------------------------------------------
! Begin executable code

! master hangs around just to see if it needs to print a warning

if (my_proc(procs) == MASTER) then
   do
      call phaml_recv(procs,proc,irecv,ni,rrecv,nr,2201)
      select case (irecv(1))
      case (1) ! all done
         deallocate(irecv,stat=allocstat)
         exit
      case (2) ! lobpcg_solve returned an error code
         call warning("BLOPEX returned error code",intlist=(/irecv(2),irecv(3)/))
         deallocate(irecv,stat=allocstat)
         if (associated(rrecv)) deallocate(rrecv,stat=allocstat)
      end select
   end do
   return
endif

! TEMP101124 zero out Dirichlet columns -- only sequential and degree=1

do i=1,linsys%neq
   do j=linsys%begin_row(i),linsys%end_row(i)
      if (linsys%column_index(j) == NO_ENTRY) cycle
      if (linsys%equation_type(linsys%column_index(j)) == DIRICHLET .and. &
          linsys%column_index(j) /= i) then
         linsys%matrix_val(j) = 0
         linsys%stiffness(j) = 0
         linsys%mass(j) = 0
         linsys%shifted(j) = 0
         linsys%condensed(j) = 0
      endif
   end do
end do
! end TEMP101124

! use linsys for solving the (statically condensed) shifted linear systems,
! and full_matrix for operations that need the whole matrix.  full_matrix
! points to entries in linsys with the following pointers/values different:
!  linsys%end_row => end_row_edge
!  linsys%matrix_val => condensed => shifted
!  linsys%rhs => rhs_cond
!  linsys%neq = neq_vert+neq_edge

full_matrix = linsys

full_matrix%end_row => linsys%end_row_face
full_matrix%matrix_val => linsys%stiffness
full_matrix%rhs => linsys%rhs_nocond
full_matrix%neq = linsys%neq_vert + linsys%neq_edge + linsys%neq_face

! convenience variables

nproc = num_proc(procs)
comm = slaves_communicator(procs)
nev = solver_cntl%num_eval
neq = linsys%neq
neq_full = full_matrix%neq
ss = grid%system_size
if (solver_cntl%lambda0 == -huge(0.0_my_real)) then
   lambda0 = solver_cntl%lambda0
elseif (solver_cntl%lambda0_side == EIGEN_RIGHT) then
   lambda0 = -solver_cntl%lambda0
else
   lambda0 = solver_cntl%lambda0
endif

! Make sure there is space in grid for the requested number of eigenvalues

if (size(grid%eigenvalue) /= nev) then
   deallocate(grid%eigenvalue,grid%eigenprob_l2_resid, &
              grid%eigenprob_variance,stat=allocstat)
   allocate(grid%eigenvalue(nev),grid%eigenprob_l2_resid(nev), &
            grid%eigenprob_variance(nev),stat=allocstat)
   if (allocstat /= 0) then
      ierr = ALLOC_FAILED
      call fatal("memory allocation failed in eigen_blopex",procs=procs)
      return
   endif
   grid%eigenvalue = 0.0_my_real
   grid%eigenprob_l2_resid = 0.0_my_real
   grid%eigenprob_variance = 0.0_my_real
endif

! copy the solutions from the grid to the linear system to return the
! old solution if we abort

do i=1,neq_full
   call eq_to_grid(full_matrix,full_matrix%gid(i),objtype,brank,srank, &
                   objlid,grid)
   select case (objtype)
   case (VERTEX_ID)
      full_matrix%solution(i) = grid%vertex_solution(objlid,srank,1)
      if (nev > 1) then
         full_matrix%evecs(i,:) = grid%vertex_solution(objlid,srank,2:nev)
      endif
   case (EDGE_ID)
      full_matrix%solution(i) = grid%edge(objlid)%solution(brank,srank,1)
      if (nev > 1) then
         do j=1,nev-1
            full_matrix%evecs(i,j) = grid%edge(objlid)%solution(brank,srank,j)
         end do
      endif
   case (ELEMENT_ID)
      full_matrix%solution(i) = grid%element(objlid)%solution(brank,srank,1)
      if (nev > 1) then
         do j=1,nev-1
            full_matrix%evecs(i,j) = grid%element(objlid)%solution(brank,srank,j)
         end do
      endif
   end select
end do

! create any needed alternate storage formats for solution methods

i_made_hypre = .false.
i_made_petsc = .false.

select case (solver_cntl%solver)

! TEMP for later expansion
!case (HYPRE_BOOMERAMG_SOLVER, HYPRE_PCG_SOLVER, HYPRE_GMRES_SOLVER)
!   if (.not. linsys%hypre_matrix_exists) then
!      call create_hypre_linear_system(linsys%hypre_matrix,linsys,procs, &
!                                      still_sequential)
!      linsys%hypre_matrix_exists = .true.
!      i_made_hypre = .true.
!   endif

case (PETSC_RICHARDSON_SOLVER, PETSC_CHEBYCHEV_SOLVER, PETSC_CG_SOLVER, &
      PETSC_GMRES_SOLVER,      PETSC_TCQMR_SOLVER,     PETSC_BCGS_SOLVER,&
      PETSC_CGS_SOLVER,        PETSC_TFQMR_SOLVER,     PETSC_CR_SOLVER, &
      PETSC_LSQR_SOLVER,       PETSC_BICG_SOLVER)
   if (my_proc(procs) /= MASTER) then
      where (linsys%equation_type == DIRICHLET) linsys%rhs = linsys%solution(1:)
      if (.not. linsys%petsc_matrix_exists) then
         if (solver_cntl%petsc_matrix_free) then
            call create_petsc_linear_system_mf(linsys,linsys%petsc_matrix, &
                                               still_sequential)
         else
            call create_petsc_linear_system(linsys,linsys%petsc_matrix, &
                                            still_sequential,procs)
         endif
         linsys%petsc_matrix_exists = .true.
         i_made_petsc = .true.
      endif
   endif

case default
   call fatal("BLOPEX currently requires a petsc solver",procs=procs)
   stop

end select

! solve the eigenvalue problem

select case (solver_cntl%solver)

! TEMP for later expansion
!case (HYPRE_BOOMERAMG_SOLVER, HYPRE_PCG_SOLVER, HYPRE_GMRES_SOLVER)
!
!   if (my_proc(procs) /= MASTER) then
!      call hypre_lobpcg_solve_f(linsys,full_matrix,linsys%hypre_matrix, &
!                                solver_cntl,io_cntl,still_sequential,grid,procs)
!   endif

case (PETSC_RICHARDSON_SOLVER, PETSC_CHEBYCHEV_SOLVER, PETSC_CG_SOLVER, &
      PETSC_GMRES_SOLVER,      PETSC_TCQMR_SOLVER,     PETSC_BCGS_SOLVER,&
      PETSC_CGS_SOLVER,        PETSC_TFQMR_SOLVER,     PETSC_CR_SOLVER, &
      PETSC_LSQR_SOLVER,       PETSC_BICG_SOLVER)
   if (my_proc(procs) /= MASTER) then
      call petsc_lobpcg_solve_f(linsys,full_matrix,linsys%petsc_matrix, &
                                solver_cntl,io_cntl,still_sequential,grid,procs)
   endif

case default
   call fatal("BLOPEX currently requires a petsc solver",procs=procs)
   stop

end select

! For each eigenvalue/eigenvector

do ii=1,nev

! use tmpptr to point to the solution vector in the linear system data struct

   if (ii == 1) then
      tmpptr => full_matrix%solution(1:neq_full)
   else
      tmpptr => full_matrix%evecs(:,ii-1)
   endif

! find the min and max solution values

   maxsoln = -huge(0.0_my_real)
   minsoln = huge(0.0_my_real)
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      maxsoln = max(maxsoln,tmpptr(i))
      minsoln = min(minsoln,tmpptr(i))
   end do
   if (.not. still_sequential) then
      maxsoln = phaml_global_max(procs,maxsoln,2920+ii)
      minsoln = phaml_global_min(procs,minsoln,2930+ii)
   endif

! Scale the eigenvectors so the selected norm is 1.0 and so the maximum
! absolution value is in the positive direction

   select case (solver_cntl%scale_evec)

   case (SCALE_LINF)

! Scale eigenvectors to have L infinity norm 1.0

      if (abs(minsoln) > abs(maxsoln)) then
         if (minsoln /= 0.0_my_real) tmpptr = tmpptr/minsoln
      else
         if (maxsoln /= 0.0_my_real) tmpptr = tmpptr/maxsoln
      endif

   case (SCALE_L2)

! Scale eigenvectors to have L2 norm 1.0

      soln2norm = 0.0_my_real
      do i=1,neq_full
         if (full_matrix%equation_type(i) == DIRICHLET) cycle
         if (.not. full_matrix%iown(i)) cycle
         soln2norm = soln2norm + tmpptr(i)**2
      end do
      if (.not. still_sequential) then
         soln2norm = phaml_global_sum(procs,soln2norm,2810+ii)
      endif
      soln2norm = sqrt(soln2norm)
      if (abs(minsoln) > abs(maxsoln)) then
         soln2norm = -soln2norm
      endif
      if (soln2norm /= 0.0_my_real) tmpptr = tmpptr/soln2norm

   case (SCALE_M)

! Scale eigenvectors to have M-norm 1.0

      full_matrix%matrix_val => full_matrix%mass
      call matrix_times_vector(tmpptr,Mx,full_matrix,procs,still_sequential, &
                               2850+ii,2860+ii,2865+ii,2870+ii,2880+ii, &
                               2885+ii,nocomm2=.true.)
      solnMnorm = 0.0_my_real
      do i=1,neq_full
         if (full_matrix%equation_type(i) == DIRICHLET) cycle
         if (.not. full_matrix%iown(i)) cycle
         solnMnorm = solnMnorm + tmpptr(i)*Mx(i)
      end do
      if (.not. still_sequential) then
         solnMnorm = phaml_global_sum(procs,solnMnorm,2810+ii)
      endif
      solnMnorm = sqrt(solnMnorm)
      if (abs(minsoln) > abs(maxsoln)) then
         solnMnorm = -solnMnorm
      endif
      if (solnMnorm /= 0.0_my_real) tmpptr = tmpptr/solnMnorm

   end select

! Compute Ax and Mx

   Ax = 0.0_my_real
   Mx = 0.0_my_real
   full_matrix%matrix_val => full_matrix%stiffness
   call matrix_times_vector(tmpptr,Ax,full_matrix,procs,still_sequential, &
                            2210+ii,2220+ii,2225+ii,2230+ii,2240+ii, &
                            2245+ii,nodirch=.true.,nocomm2=.true.)
   if (lambda0 /= -huge(0.0_my_real) .and. &
       solver_cntl%lambda0_side == EIGEN_RIGHT) then
      Ax = -Ax
   endif
   full_matrix%matrix_val => full_matrix%mass
   call matrix_times_vector(tmpptr,Mx,full_matrix,procs,still_sequential, &
                            2250+ii,2260+ii,2265+ii,2270+ii,2280+ii,2285+ii, &
                            nodirch=.true.,nocomm2=.true.)

! Compute the Raleigh quotient x^T A x / x^T M x to use as eigenvalues
! This is necessary for SHIFT_SQUARE because we don't know which square root
! to use, but we could use the transformed eigenvalue for SHIFT_INVERT.

   numer = 0.0_my_real
   denom = 0.0_my_real
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      numer = tmpptr(i)*Ax(i) + numer
      denom = tmpptr(i)*Mx(i) + denom
   end do
   if (.not. still_sequential) then
      numer = phaml_global_sum(procs,numer,2020+ii)
      denom = phaml_global_sum(procs,denom,2030+ii)
   endif
   grid%eigenvalue(ii) = numer/denom

! Compute the l2 norm of the residual || Ax - lambda Mx || / || lambda Mx ||

   l2resid = 0.0_my_real
   l2rhs = 0.0_my_real
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      l2resid = l2resid + (Ax(i)-grid%eigenvalue(ii)*Mx(i))**2
      call eq_to_grid(full_matrix,full_matrix%gid(i),objtype,brank,srank, &
                      objlid,grid)
      l2rhs = l2rhs + Mx(i)**2
   end do
   if (.not. still_sequential) then
      l2resid = phaml_global_sum(procs,l2resid,2040+ii)
      l2rhs = phaml_global_sum(procs,l2rhs,2050+ii)
   endif
   l2resid = sqrt(l2resid)
   l2rhs = abs(grid%eigenvalue(ii))*sqrt(l2rhs)
   if (l2rhs /= 0.0_my_real) l2resid = l2resid/l2rhs
   grid%eigenprob_l2_resid(ii) = l2resid

! the variance x^T A^T M^-1 A x / x^T M x

   numer = 0.0_my_real
   denom = 0.0_my_real
   do i=1,neq_full
      if (full_matrix%equation_type(i) == DIRICHLET) cycle
      if (.not. full_matrix%iown(i)) cycle
      numer = numer + Ax(i)**2
      denom = denom + Mx(i)**2
   end do
   if (.not. still_sequential) then
      numer = phaml_global_sum(procs,numer,2080+ii)
      denom = phaml_global_sum(procs,denom,2090+ii)
   endif
   if (denom /= 0.0_my_real) then
      grid%eigenprob_variance(ii) = numer/denom - grid%eigenvalue(ii)**2
   else
      grid%eigenprob_variance(ii) = 0.0_my_real
   endif

end do ! ii

! sort the eigenvalues, if they are on the left or both sides of lambda0

if (nev > 1 .and. lambda0 /= -huge(0.0_my_real)) then
   allocate(tmpptr(neq_full),stat=allocstat)
   if (allocstat /= 0) then
      ierr = ALLOC_FAILED
      call fatal("memory allocation failed in eigen_blopex",procs=procs)
      return
   endif

   call sort(grid%eigenvalue,nev,iperm,1,info)

   do i=1,nev
      indx=abs(iperm(i))
      if (iperm(indx) > 0) iperm(indx) = -iperm(indx)
   end do
   do istrt = 1,nev
      if (iperm(istrt) > 0) cycle
      indx = istrt
      indx0 = indx
      temp = grid%eigenvalue(istrt)
      temp2 = grid%eigenprob_l2_resid(istrt)
      temp3 = grid%eigenprob_variance(istrt)
      if (istrt == 1) then
         tmpptr = full_matrix%solution(1:)
      else
         tmpptr = full_matrix%evecs(:,istrt-1)
      endif
      do while (iperm(indx) < 0)
         grid%eigenvalue(indx) = grid%eigenvalue(-iperm(indx))
         grid%eigenprob_l2_resid(indx) = grid%eigenprob_l2_resid(-iperm(indx))
         grid%eigenprob_variance(indx) = grid%eigenprob_variance(-iperm(indx))
         if (indx == 1) then
            full_matrix%solution(1:) = full_matrix%evecs(:,-iperm(indx)-1)
         elseif (-iperm(indx) == 1) then
            full_matrix%evecs(:,indx-1) = full_matrix%solution(1:)
         else
            full_matrix%evecs(:,indx-1) = full_matrix%evecs(:,-iperm(indx)-1)
         endif
         indx0 = indx
         iperm(indx) = -iperm(indx)
         indx = iperm(indx)
      end do
      grid%eigenvalue(indx0) = temp
      grid%eigenprob_l2_resid(indx0) = temp2
      grid%eigenprob_variance(indx0) = temp3
      if (indx0 == 1) then
         full_matrix%solution(1:) = tmpptr
      else
         full_matrix%evecs(:,indx0-1) = tmpptr
      endif
   end do

   deallocate(tmpptr)
endif

! get rid of any extra versions of the linear system

if (i_made_hypre) then
   call destroy_hypre_linear_system(linsys%hypre_matrix,procs)
   linsys%hypre_matrix_exists = .false.
endif
if (i_made_petsc) then
   call destroy_petsc_linear_system(linsys%petsc_matrix)
   linsys%petsc_matrix_exists = .false.
endif

! tell the master we're done

if (my_proc(procs) == 1) then
   call phaml_send(procs,MASTER,(/1/),1,(/0.0_my_real/),0,2201)
endif

end subroutine eigen_blopex

end module eigen


!----------------------------------------------------
!Program to determine the symmetry point
!group of a molecule.
!
!June 2014
!----------------------------------------------------
!
program symmetry
use symmetry_elements
use other_routines
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
integer :: i, j, k, l, h, p, gg, f !counters
!
!-------------------------------------------------------------
!Variables for specifying the molecular structure:
!-------------------------------------------------------------
!
real(dp), allocatable, dimension(:) :: mass, x, y, z
character(len=3), allocatable, dimension(:) :: labels
integer :: m !number of atoms in the molecule
character(len=20) :: title
!
!---------------------
!Periodic table:
!---------------------
!
character(len=3), dimension(118) :: atoms
real(dp), dimension(118) :: masses
!
!---------------------------------
!Center of mass calculation:
!---------------------------------
!
real(dp), dimension(3) :: center !center of mass
real(dp) :: sumxa, sumxb, sumya, sumyb, sumza, sumzb
            !sums for the calculation
!
!-------------------------------------------------------------
!Calculation of the inertia tensor and principal moments
!of inertia:
!-------------------------------------------------------------
!
real(dp), dimension(3,3) :: inert !inertia tensor
integer :: n, lda, info, lwork !for lapack dysyev routine
real(dp), dimension(3) :: w !eigenvalues
character :: jobz, uplo !for lapack dysyev routine
real(dp), allocatable, dimension(:,:) :: work !for lapack routine
real(dp) :: lwork1 !because the output for lwork is a real number
real(dp), dimension(3,1) :: eigenv1, eigenv2, eigenv3 !eigenvectors
!
!----------------------------------------------------------------
!For the determination of the symmetry of the entire molecule:
!------------------------------------------------------------------
!
real(dp), allocatable, dimension(:,:) :: molecule
real(dp), allocatable, dimension(:,:) :: mola, molb !molecule after alignment
real(dp), dimension(3) :: vec1 !eigenvectors after alignemnt
real(dp), dimension(3) :: main_axis !direction of the main rotational axis.
integer :: r, rr ! order of rotation axis
integer :: test ! 0 or 1
integer, dimension(3) :: rot_order !vector that contains the maximum
                                !order of the rotations around each of
                                !the axes corresponding to the three
                                !principal moments of inertia
integer :: order ! order of rotations
integer :: main_direction !main rotation order
reaL(dp) :: symdev !average deviation from perfect symmetry
real(dp), dimension(3) :: symmetry_dev_array
character(len=26) :: horisontal1, vertical1, rotation1, rotation2, rotoinv
character(len=26) :: inversion1
!
!-----------------------------
!distance matrix and SEAs:
!-----------------------------
!
real(dp), allocatable, dimension(:,:) :: distance_matrix
real(dp), dimension(3,1) :: SEA1, SEA2, midpoint, SEA11, SEA21, midpoint1
real(dp), allocatable, dimension(:) :: D1, D2 !columns of distance matrix
integer, allocatable, dimension(:) :: C, D, T, AA !working f-tions
integer :: prod1 !comparison
!
!------------------------------------------------
!For converting integers and doubles to strings:
!------------------------------------------------
!
character(len=50) :: doublestring
character(len=25) :: intstring
!
!-------------------------
!Cpu_time:
!-------------------------
!
real(dp) :: start, finish, cputime
!
!------------------------------
!Program starts here:
!------------------------------
!
call CPU_time(start)
!
!Some variables for printing the name of the
!symmetry element in question:
horisontal1 = 'horisontal reflection plane'
vertical1 = 'vertical reflection plane'
rotation1 = 'secondary rotation axis'
inversion1 = 'inversion center'
rotation2 = 'main rotation axis'
rotoinv = 'improper rotation axis'
!
!
!------------------------------------------------
!Construct a periodic table - two arrays, one
!containing the atomic symbols, the other,
!the atomic mass of the corresponding element:
!------------------------------------------------
!
call periodic (atoms, masses)
!
!----------------------------
!Open input/output files:
!----------------------------
!
open (unit=3, file='input', status='old', action='read')
open (unit=2, file='output', status='new', action='write')
!
!-----------------------------------------------------------------
!assigning the atoms and coordinates - user generated input:
!--------------------------------------------------------------
!
read(3,*) m
if (m == 1) then
    write(*,*) 'this is just one atom.'
    stop
end if
read(3,'(A20)') title
!
allocate (labels(m))
allocate (x(m))
allocate (y(m))
allocate (z(m))
allocate (mass(m))
!
do i = 1, m
    read(3,*) labels(i), x(i), y(i), z(i)
end do
!
write(2,*) 'input geometry for ' // trim(title) //  ':'
write(2,*) '-----------------------------------------------'
do i = 1, m
    write(2,*) labels(i), x(i), y(i), z(i)
end do
write(2,*)
!
!-------------------------------------
!Assigning the masses:
!
!(I.e. read the masses of the atoms
!from the periodic table)
!-------------------------------------
!
do i = 1, m
    do k = 1, 118
        if (labels(i) == atoms(k)) then
            mass(i) = masses(k)
        end if
    end do
end do
!
!-------------------------------
!Determine center of mass:
!-------------------------------
!
!x-coordinate:
!
sumxa = 0.0
do i = 1, m
    sumxa = sumxa + mass(i)*x(i)
end do
!
sumxb = 0.0
do i =1, m
    sumxb = sumxb + mass(i)
end do
!
center(1) = sumxa/sumxb
!
!y - coordinate:
!
sumya = 0.0
do i = 1, m
    sumya = sumya + mass(i)*y(i)
end do
!
sumyb = 0.0
do i = 1, m
    sumyb = sumyb + mass(i)
end do
!
center (2) = sumya/sumyb
!
!z - coordinate:
!
sumza = 0.0
do i = 1, m
    sumza = sumza + mass(i)*z(i)
end do
!
sumzb = 0.0
do i = 1, m
    sumzb = sumzb + mass(i)
end do
!
center(3) = sumza/sumzb
!
!---------------------------------------
!place the center of mass at (0,0,0):
!---------------------------------------
!
do i = 1, m
    x(i) = x(i) - center(1)
end do
!
do i = 1, m
    y(i) = y(i) - center(2)
end do
!
do i = 1, m
    z(i) = z(i) - center(3)
end do
!
!-----------------------------------
!Calculate the inertia tensor:
!-----------------------------------
!
inert(1,1) = 0.0
do i = 1, m
    inert(1,1) = inert(1,1) + mass(i)*( (y(i))**(2.) + (z(i))**(2.) )
end do
!
inert(1,2) = 0.0
do i = 1, m
    inert(1,2) = inert(1,2) - mass(i)*y(i)*x(i)
end do
!
inert(2,1) = inert(1,2)
!
inert(1,3) = 0.0
do i = 1, m
    inert(1,3) = inert(1,3) - mass(i)*x(i)*z(i)
end do
!
inert(3,1) = inert(1,3)
!
inert(2,2) = 0.0
do i = 1,m
    inert(2,2) = inert(2,2) + mass(i)*( (x(i))**(2.) + (z(i))**(2.) )
end do
!
inert(2,3) = 0.0
do i = 1, m
    inert(2,3) = inert(2,3) - mass(i)*y(i)*z(i)
end do
!
inert(3,2) = inert(2,3)
!
inert(3,3) = 0.0
do i = 1, m
    inert(3,3) = inert(3,3) + mass(i)*( (x(i))**(2.) + (y(i))**(2.) )
end do
!
!-----------------------------------------------------------------
!Diagonalize the inertia tensor - determine the three principal
!components of the inertia tensor.
!-----------------------------------------------------------------
!
n = 3
lda = 3
jobz = 'N'
uplo = 'U'
lwork = -1
!
allocate (work(1,3))
!
    call DSYEV(jobz, uplo, n, inert, lda, w, work, lwork, info)
    write(intstring,*)info
    write(doublestring,*) work(1,1)
    write(2,*) 'info: ' // adjustl(trim(intstring)), ' lwork1: ' // adjustl(trim(doublestring))
    lwork = int(work(1,1))
!
deallocate (work)
allocate (work(1,lwork))
!
    jobz = 'V'
    call DSYEV(jobz, uplo, n, inert, lda, w, work, lwork, info)
    write(2,*) 'eigenvalues of the inertia tensor:', w
    write(2,*)  'info', info
    write(2,*)
!
deallocate (work)
!
!on input, the DSYEV subroutine takes the matrix inert, which represents
!the inertia tensor. On output it gives the same matrix (inert), but now
!it contains the eigenvectors of the inertia tensor in its columns.
!
do i = 1, 3
    eigenv1(i,1) = inert(i,1)
    eigenv2(i,1) = inert(i,2)
    eigenv3(i,1) = inert(i,3)
end do

write(2,*) 'eigenvectors of the inertia tensor:'
write(2,*) '---------------------------------------'
write(2,*) 'eigenvector 1:', eigenv1
write(2,*) 'eigenvector 2:', eigenv2
write(2,*) 'eigenvector 3:', eigenv3
write(2,*)
!
!----------------------------
!Create molecule matrix:
!----------------------------
!
!the n - columns of this matrix represent the n - atoms
!
allocate (molecule(4,m))
!
do i = 1, m
    molecule(1,i) = mass(i) !row 1 contains the masses
    molecule(2,i) = x(i) !row 2 contains the x- coordinates
    molecule(3,i) = y(i) !row 3 contains the y - coordinates
    molecule(4,i) = z(i) !row 4 contains the z - coordinates
end do
!
!-------------------------------
!Print distance matrix:
!-------------------------------
!
allocate (distance_matrix(m,m))
!
do i = 1, m
    do j = 1, m
        distance_matrix(i,j) = sqrt( (molecule(2,i)-molecule(2,j))**(2) + &
            (molecule(3,i)-molecule(3,j))**(2) + &
            (molecule(4,i)-molecule(4,j))**(2) )
    end do
end do
!
write(2,*)'Distance matrix:'
write(2,*)'----------------------------------------'
write(2,'(A7,20A7)') 'DM', (labels(i), i = 1, m)
!
do i = 1, m
        write(2,'(A7,20F7.3)') labels(i), (distance_matrix(i,j), j=1,m)
end do
write(2,*)
!
!----------------------------
!cubic groups:
!----------------------------
!
if (dabs(w(1) - w(2)) .le. 0.1) then
    if (dabs(w(2) - w(3)) .le. 0.1) then
        if (dabs(w(1) - w(3)) .le. 0.1) then
            write (2,*) 'the molecule belongs to one of &
            the point groups with higher order (cubic) symmetry'
            write (2,*)
            call CPU (start)
            Stop
        end if
    end if
end if
!
!--------------------------------
!If the molecule is a diatiomic:
!--------------------------------
!
if (m==2) then
    if ( labels(1) == labels(2)) then
        write(2,*) 'the point group is Dh-inf'
        call CPU (Start)
        stop
    else if ( labels(1) /= labels(2)) then
        write(2,*) 'the point group is Cv-inf'
        call CPU (start)
        stop
    end if
end if
!
!-----------------------
!for linear molecules:
!-----------------------
!
If ( (w(1) .le. 0.01) .or. (w(2) .le. 0.01) .or. (w(3) .le. 0.01) ) then
    call inversion (molecule, m, test, symdev)
    if (test == 1) then
        write(2,*) 'the point group of the molecule is: D-inf-h'
        call average_dev (symdev, inversion1)
    else if (test /= 1) then
        write(2,*) 'the point group of the molecule is C-inf-v'
    end if
    call CPU (start)
    stop
end if
!
!-----------------------------------------------
!If the molecule is neither cubic, nor linear:
!-----------------------------------------------
!----------------------------------------------------------------
!Find the maximum order of rotation around every inertia vector
!----------------------------------------------------------------
!
allocate (mola(4,m), molb(4,m))
!
call align(eigenv1, molecule, m, vec1, mola) !align molecule with
                                             !inertia vector eigenv1
!
do i = 6, 1, -1
    r = i
    rot_order(1) = i
    call rotation(mola, m, r, molb)
    call compare(mola, molb, m, test, symdev)
    if (test == 1) exit !the maximum rotation order is recorded in
                        !the array rot_order
    symmetry_dev_array(1) = symdev
end do
!
call align(eigenv2, molecule, m, vec1, mola)
!
do i = 6, 1, -1
    r = i
    rot_order(2) = i
    call rotation(mola, m, r, molb)
    call compare(mola, molb, m, test, symdev)
    if (test == 1) exit
    symmetry_dev_array(2) = symdev
end do
!
call align(eigenv3, molecule, m, vec1, mola)
!
do i = 6, 1, -1
    r = i
    rot_order(3) = i
    call rotation(mola, m, r, molb)
    call compare(mola, molb, m, test, symdev)
    if (test == 1) exit
    symmetry_dev_array(3) = symdev
end do
!
order = maxval(rot_order)
write(doublestring,*) order
write(2,*) 'the order of the main rotation axis is: ' // &
   adjustl(trim(doublestring))
!
!-----------------------------------------------
!in case there is no rotational symmetry:
!------------------------------------------------
!
!search for a horisontal plane:
if (order == 1) then
    call align(eigenv1, molecule, m, vec1, mola)
    call horisontal (mola, m, test, symdev)
    if (test == 1) then
        write(2,*) 'the molecule belongs to the point group: Cs'
        call average_dev (symdev, horisontal1)
        call CPU (start)
        stop
    else if (test == 0) then
        call align (eigenv2, molecule, m, vec1, mola)
        call horisontal (mola, m, test, symdev)
        if (test == 1) then
            write(2,*) 'the molecule belongs to the point group: Cs'
            call average_dev (symdev, horisontal1)
            call CPU (start)
            stop
        else if(test == 0) then
            call align(eigenv3, molecule, m, vec1, mola)
            call horisontal (mola, m, test, symdev)
            if (test == 1) then
                write(2,*) 'the molecule belongs to the point group: Cs'
                call average_dev (symdev, horisontal1)
                call CPU (start)
                stop
            else if (test == 0) then
                !if there is no horisontal reflection plane, search for
                        !an inversion center:
                call inversion (molecule, m, test, symdev)
                if (test == 1) then
                    write(2,*) 'the molecule belongs to the point group: Ci'
                    call average_dev (symdev, inversion1)
                    call CPU (start)
                    stop
                    if (test == 0) then
                        write(2,*) 'the molecule belongs to the point &
                            group: C1'
                        call CPU (start)
                        stop
                    end if
                end if
            end if
        end if
    end if
end if
!
!---------------------------------------------------------------
!when there is rotational symmetry, determine the direction of the
!main axis of rotation.
!---------------------------------------------------------------
!
main_direction=maxloc(rot_order,1)!column of the inertia eigenvectors matrix
            !that corresponds to the main rotation axis. i.e. eigenvector
            !of the inertia matrix that corresponds to the main rotation
            !axis.
!
do i = 1, 3
    main_axis(i) = inert(i,main_direction)!the direction of the
        !main rotational axis and of the moment of inertia eigenvector
        !corresponding to it
end do
!
symdev = symmetry_dev_array(main_direction)
call average_dev (symdev, rotation2)
write(2,*)
!
!------------------------------------------------------------------
!Recompute distance matrix (just in case. Not sure if necessary.
!Probably not, because if you look at the routines, the order of
!the atoms is never changed) in order to find two symetrically
!equivalent atoms:
!------------------------------------------------------------------
!
call align(main_axis, molecule, m, vec1, mola) !From now on the molecule
                                    !will be aligned with the z-axis
!
do i = 1, m
    do j = 1, m
        distance_matrix(i,j) = sqrt( (mola(2,i)-mola(2,j))**(2.) + &
            (mola(3,i)-mola(3,j))**(2.) + (mola(4,i)-mola(4,j))**(2.) )
    end do
end do
!
!-----------------------------------------
!find two symetrically equivalent atoms:
!-----------------------------------------
!
do i = 1, 3
    SEA1(i,1) = 0.0
    SEA2(i,1) = 0.0
    midpoint(i,1) = 0.0
    SEA11(i,1) = 0.0
    SEA21(i,1) = 0.0
    midpoint1(i,1) = 0.0
end do

allocate (D1(m), D2(m), C(m), D(m), T(m), AA(m))

do i = 1, m
    D(i) = 0
    C(i) = 0
    T(i) = 0
    AA(i) = 0
end do

!First, select two columns (i and k) from the distance matrix:
determine_SEA: do i = 1, m
    AA(i) = i
    do k = 1, m
        if (i == k) cycle !because its the same atom
        if (k == AA(k)) cycle !so that I don't do the checking
            !twice (1 with 2 and then 2 with 1 again).
            do h = 1, m
            D(h) = 0 !return the D variable used for comparison to 0.
            T(h) = 0
            C(h) = 0
        end do
    !Now, fill the D1 and D2 vectors used for the comparison with elements
    !from the i and k columns:
        do j = 1, m
            do l = 1, m
                D1(j) = distance_matrix(i,j)
                D2(l) = distance_matrix(k,l)
            end do
        end do
    !Compare these two columns of the distance matrix
    !to see if they have the same elements
        do gg = 1, m
            do p = 1, m
                if (p == C(p)) cycle
                if (gg == T(gg)) cycle
                if ( dabs(D1(gg)-D2(p)) .LE. 0.01 ) then
                    D(gg) = 1
                    C(p) = p
                    T(gg) = gg
                end if
            end do
        end do
        prod1 = 1 !to see if for every element in D1 a corresponding equal
                    !element in D2 has been found.
        do f = 1, m
            prod1 = prod1 * D(f)
        end do
        if (prod1 == 1) then
            !meaning all the distances for atom i and atom k
            !are equal
            do h = 1, 3
                SEA1(h,1) = mola(h+1,i)
                SEA2(h,1) = mola(h+1,k)
                midpoint(h,1) = (SEA1(h,1)+SEA2(h,1))/(2.)
            end do
            !to check if these SEA can be used to determine the secondary
            !rotation axes:
            if ( (dabs(SEA1(3,1)) .le. 0.01) .or. (dabs(SEA2(3,1)) .le. &
                0.01) .or. (dabs(midpoint(3,1)) .le. 0.01) ) then
                                                     !meaining they are
                                                     !lying on the xy plane
                if ( (dabs(midpoint(2,1)) .ge.0.01) .or. &
                    (dabs(midpoint(1,1)) .ge. 0.01) ) then
                                        !meaning the midpoint is not
                                        !lying on the main rotational axis.
                                        !or in the center of
                                        !the coordinate system
                    midpoint1 = midpoint
                    SEA11=SEA1
                    SEA21=SEA2
                    exit determine_SEA
                end if
            end if
        end if
    end do
end do determine_SEA
!
write(2,*) 'Refference points:'
write(2,*) '--------------------------'
write(2,*) 'symmetrically equivalent atoms:'
write(2,*) SEA1
write(2,*) SEA2
write(2,*) 'midpoint between the two symmetrically equivalent atoms:'
write(2,*) midpoint1
write(2,*)
!
!---------------------------------------------------------------------
!when it is certain that the point group must be cyclic because we haven't
!found SEAs that fulfill the conditions at line 570:
!---------------------------------------------------------------------
!
if (midpoint1(1,1) == 0) then
    if (midpoint1(2,1) == 0) then
        if (midpoint1(3,1) == 0) then
            call horisontal(mola, m, test, symdev)
            if (test == 1) then
                write(2,*) 'The symmetry group of the molecule is C', &
                    order, 'h'
                call average_dev (symdev, horisontal1)
                call CPU(start)
                stop
            else if (test == 0) then
                call vertical(mola, midpoint, m, test, symdev)
                if (test == 1) then
                    write(2,*) 'The symmetry group is C', order, 'v'
                    call average_dev (symdev, vertical1)
                    call CPU (start)
                    stop
                else if (test == 0) then
                    call vertical(mola, SEA1, m, test, symdev)
                    if (test == 1) then
                        write(2,*) 'The symmetry group is C', order, 'v'
                        call average_dev (symdev, vertical1)
                        call CPU (start)
                        stop
                    else if (test == 0) then
                        call vertical(mola, SEA2, m, test, symdev)
                        if (test == 1) then
                            write(2,*) 'The symmetry group is C', order, 'v'
                            call average_dev (symdev, vertical1)
                            call CPU (start)
                            stop
                        else if (test == 0) then
                            rr = 2*order
                            call rotoinversion (mola, m, rr, test, symdev)
                            if (test == 1) then
                                write(2,*) 'the symmettry group is S', rr
                                call average_dev (symdev, rotoinv)
                                call CPU (start)
                            else if (test == 0) then
                                write(2,*) 'The symmetry group is C', order
                                call CPU(start)
                                stop
                            end if
                        end if
                    end if
                end if
            end if
        end if
    end if
end if
!
!----------------------------------------------
!Determine symmetry when there is a possibility that the point group is
!dihedral:
!-------------------------------------------
!
call secondary_rotation(mola, SEA11, m, test, symdev)
if (test == 1) then
    write(2,*) 'the molecule has a secondary rotation axis.'
    call average_dev (symdev, rotation1)
    call horisontal(mola, m, test, symdev)
    if (test == 1) then
        write(2,*) 'The symmetry group of the molecule is D', order, 'h'
        write(2,*) 'for the horisontal reflection plane:'
        call average_dev (symdev, horisontal1)
        call CPU (start)
        stop
    else if (test == 0) then
        call vertical(mola, midpoint1, m, test, symdev)
        if (test == 1) then
            write(2,*) 'The symmetry group is D', order, 'd'
            write(2,*) 'for the vertical reflection plane:'
            call average_dev (symdev, vertical1)
            call CPU(start)
            stop
        else if (test == 0) then
            write(2,*) 'The symmetry group is D', order
            call CPU (start)
            stop
        end if
    end if
else if (test == 0) then
    call secondary_rotation(mola, midpoint1, m, test, symdev)
    write(2,*) 'the molecule has a secondary rotation axis.'
    call average_dev (symdev, rotation1)
    if (test == 1) then
        call horisontal(mola, m, test, symdev)
        if (test == 1) then
            write(2,*) 'The symmetry group of the molecule is D', order, 'h'
            call average_dev (symdev, horisontal1)
            call CPU (start)
            stop
        else if (test == 0) then
            call vertical(mola, SEA11, m, test, symdev)
            if (test == 1) then
                write(2,*) 'The symmetry group is D', order, 'd'
                call average_dev (symdev, vertical1)
                call CPU (start)
                stop
            else if (test == 0) then
                call vertical(mola, SEA2, m, test, symdev)
                if (test == 1) then
                    write(2,*) 'The symmetry group is D', order, 'd'
                    call average_dev (symdev, vertical1)
                    call CPU (start)
                    stop
                else if (test == 0) then
                    write(2,*) 'The symmetry group is D', order
                    call CPU(start)
                    stop
                end if
            end if
        end if
    else if (test == 0) then
      call horisontal(mola, m, test, symdev)
         if (test == 1) then
             write(2,*) 'The symmetry group of the molecule is C', &
                 order, 'h'
             call average_dev (symdev, horisontal1)
             call CPU (start)
             stop
         else if (test == 0) then
            call vertical(mola, midpoint, m, test, symdev)
            if (test == 1) then
                write(2,*) 'The symmetry group is C', order, 'v'
                call average_dev (symdev, vertical1)
                call CPU (start)
            else if (test == 0) then
                call vertical(mola, SEA1, m, test, symdev)
                if (test == 1) then
                    write(2,*) 'The symmetry group is C', order, 'v'
                    call average_dev (symdev, vertical1)
                    call CPU (start)
                else if (test == 0) then
                    call vertical(mola, SEA2, m, test, symdev)
                    if (test == 1) then
                        write(2,*) 'The symmetry group is C', order, 'v'
                        call average_dev (symdev, vertical1)
                        call CPU (start)
                        stop
                    else if (test == 0) then
                        rr = 2*order
                        call rotoinversion (mola, m, rr, test, symdev)
                        if (test == 1) then
                            write(2,*) 'The symmetry group is S', rr
                            call CPU (start)
                            stop
                        else if (test == 0) then
                            write(2,*) 'The symmetry group is C', order
                            call CPU (start)
                            stop
                        end if
                    end if
                 end if
             end if
         end if
     end if
 end if

end program symmetry


program game_24
  implicit none
  real               :: vector(4), reals(11), result, a, b, c, d
  integer            :: numbers(4), ascii(11), i
  character(len=11)  :: expression
  character          :: syntax(11)
  ! patterns:
  character, parameter :: one(11)   = (/ '(','(','1','x','1',')','x','1',')','x','1' /)
  character, parameter :: two(11)   = (/ '(','1','x','(','1','x','1',')',')','x','1' /)
  character, parameter :: three(11) = (/ '1','x','(','(','1','x','1',')','x','1',')' /)
  character, parameter :: four(11)  = (/ '1','x','(','1','x','(','1','x','1',')',')' /)
  character, parameter :: five(11)  = (/ '(','1','x','1',')','x','(','1','x','1',')' /)

  do
    call random_number(vector)
    numbers = 9 * vector + 1
    write (*,*) 'Digits: ',numbers
    write (*,'(a)',advance='no') 'Your expression: '
    read (*,'(a11)') expression

    forall (i=1:11) syntax(i) = expression(i:i)
    ascii = iachar(syntax)
    where (syntax >= '0' .and. syntax <= '9')
      syntax = '1'  ! number
    elsewhere (syntax == '+' .or. syntax == '-' .or. syntax == '*' .or. syntax == '/')
      syntax = 'x'  ! op
    elsewhere (syntax /= '(' .and. syntax /= ')')
      syntax = '-'  ! error
    end where

    reals = real(ascii-48)
    if ( all(syntax == one) ) then
      a = reals(3); b = reals(5); c = reals(8); d = reals(11)
      call check_numbers(a,b,c,d)
      result = op(op(op(a,4,b),7,c),10,d)
    else if ( all(syntax == two) ) then
      a = reals(2); b = reals(5); c = reals(7); d = reals(11)
      call check_numbers(a,b,c,d)
      result = op(op(a,3,op(b,6,c)),10,d)
    else if ( all(syntax == three) ) then
      a = reals(1); b = reals(5); c = reals(7); d = reals(10)
      call check_numbers(a,b,c,d)
      result = op(a,2,op(op(b,6,c),9,d))
    else if ( all(syntax == four) ) then
      a = reals(1); b = reals(4); c = reals(7); d = reals(9)
      call check_numbers(a,b,c,d)
      result = op(a,2,op(b,5,op(c,8,d)))
    else if ( all(syntax == five) ) then
      a = reals(2); b = reals(4); c = reals(8); d = reals(10)
      call check_numbers(a,b,c,d)
      result = op(op(a,3,b),6,op(c,9,d))
    else
      stop 'Input string: incorrect syntax.'
    end if

    if ( abs(result-24.0) < epsilon(1.0) ) then
      write (*,*) 'You won!'
    else
      write (*,*) 'Your result (',result,') is incorrect!'
    end if

    write (*,'(a)',advance='no') 'Another one? [y/n] '
    read (*,'(a1)') expression
    if ( expression(1:1) == 'n' .or. expression(1:1) == 'N' ) then
      stop
    end if
  end do

contains

  pure real function op(x,c,y)
    integer, intent(in) :: c
    real, intent(in) :: x,y
    select case ( char(ascii(c)) )
      case ('+')
        op = x+y
      case ('-')
        op = x-y
      case ('*')
        op = x*y
      case ('/')
        op = x/y
    end select
  end function op

  subroutine check_numbers(a,b,c,d)
    real, intent(in) :: a,b,c,d
    integer          :: test(4)
    test = (/ nint(a),nint(b),nint(c),nint(d) /)
    call Insertion_Sort(numbers)
    call Insertion_Sort(test)
    if ( any(test /= numbers) ) then
      stop 'You cheat ;-) (Incorrect numbers)'
    end if
  end subroutine check_numbers

  pure subroutine Insertion_Sort(a)
    integer, intent(inout) :: a(:)
    integer                :: temp, i, j
    do i=2,size(a)
      j = i-1
      temp = a(i)
      do while ( j>=1 .and. a(j)>temp )
        a(j+1) = a(j)
        j = j - 1
      end do
      a(j+1) = temp
    end do
  end subroutine Insertion_Sort

end program game_24


MODULE m_relcor
!************************************************************************

! calculate the relativistic  corrections for exchange as formulated by
!              A.H. MacDonald and S.H. Vosko, J. Phys. C12, 2977 (1979)
! either phi (for xc-energy) or psi (for xc-potential) are calculated
!             (if l_psi=.true. we call from vxc.. and psi is evaluated)

!************************************************************************
CONTAINS
   SUBROUTINE relcor( &
      mgrid,ngrid,jspins,krla,l_psi,rh, &
      phsi)
      IMPLICIT NONE

!     .. Scalar Arguments ..
      INTEGER, INTENT (IN)  :: mgrid,krla,ngrid,jspins
      LOGICAL, INTENT (IN)  :: l_psi

!     .. Array Arguments ..
      REAL,    INTENT (IN)  :: rh(mgrid,jspins)
      REAL,    INTENT (OUT) :: phsi(ngrid)

!     .. Local Parameters ..
      REAL, PARAMETER :: betac = 2.2576918e-2  ! alpha * (3 * pi)^(1/3)
      REAL, PARAMETER :: d_15 = 1.e-15 , d_3 = 1.e-3
      REAL, PARAMETER :: one = 1.0 , three = 3.0 , half = 0.5
      REAL, PARAMETER :: thrhalf = three * half , thrd = one/three
      REAL, PARAMETER :: bs1 = 0.75 , bs2 = 0.45 ,  bf2 = 0.4
      REAL, PARAMETER :: bf1 = 2*thrd

!     .. Locals ..
      INTEGER :: ir
      REAL :: beta              ! Fermi velocity devided by speed of light
      REAL :: rho,eta,xi,betasq

      INTRINSIC max,sqrt

      IF (krla == 1) THEN      !  evaluate relativistic corrections for exchange

         DO ir = 1,ngrid
            IF (jspins == 1) THEN
               rho = max(d_15,rh(ir,1))
            ELSE
               rho = max(d_15,rh(ir,1))+max(d_15,rh(ir,jspins))
            ENDIF
            beta = betac * rho**thrd
            betasq = beta*beta
            eta = sqrt(one+betasq)
            xi = beta + eta

            !----->    If beta.LT.10**(-3) use taylor series of psi,phi with respect to
            !          beta, because of accuracy considerations. Taylor series
            !          implemented is exact up to  beta**5 (see notes S.B.)

            IF (l_psi) THEN
               IF (beta < d_3) THEN
                  phsi(ir) = one - betasq + bs1*beta*betasq - bs2*betasq**2
               ELSE
                  phsi(ir) = half* (-one+three*alog(xi)/ (beta*eta))
               END IF
            ELSE
               IF (beta < d_3) THEN
                  phsi(ir) = one - bf1*betasq + bf2*betasq*betasq
               ELSE
                  phsi(ir) = one - thrhalf*((beta*eta-alog(xi))/betasq)**2
               END IF
            ENDIF
         ENDDO

      ELSE
         DO ir = 1,ngrid
            phsi(ir) = one
         ENDDO
      ENDIF

      RETURN
   END SUBROUTINE relcor
END MODULE m_relcor