Actual source code: ex6f.F

  1: !  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2: !     SLEPc - Scalable Library for Eigenvalue Problem Computations
  3: !     Copyright (c) 2002-2007, Universidad Politecnica de Valencia, Spain
  4: !
  5: !     This file is part of SLEPc. See the README file for conditions of use
  6: !     and additional information.
  7: !  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8: !
  9: !  Program usage: mpirun -np n ex6f [-help] [-m <m>] [all SLEPc options]
 10: !
 11: !  Description: This example solves the eigensystem arising in the Ising
 12: !  model for ferromagnetic materials. The file mvmisg.f must be linked
 13: !  together. Information about the model can be found at the following
 14: !  site http://math.nist.gov/MatrixMarket/data/NEP
 15: !
 16: !  The command line options are:
 17: !    -m <m>, where <m> is the number of 2x2 blocks, i.e. matrix size N=2*m
 18: !
 19: ! ----------------------------------------------------------------------
 20: !
 21:       program main
 22:       implicit none

 24: #include "finclude/petsc.h"
 25: #include "finclude/petscvec.h"
 26: #include "finclude/petscmat.h"
 27:  #include finclude/slepc.h
 28:  #include finclude/slepceps.h

 30: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 31: !     Declarations
 32: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 33: !
 34: !  Variables:
 35: !     A     operator matrix
 36: !     eps   eigenproblem solver context

 38:       Mat          A
 39:       EPS          eps
 40:       EPSType      type
 41:       PetscReal    tol, error
 42:       PetscScalar  kr, ki
 43:       integer      size, rank, N, m, nev, ierr, maxit, i, its, nconv
 44:       PetscTruth   flg

 46: !     This is the routine to use for matrix-free approach
 47: !
 48:       external MatIsing_Mult

 50: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 51: !     Beginning of program
 52: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 54:       call SlepcInitialize(PETSC_NULL_CHARACTER,ierr)
 55: #if defined(PETSC_USE_COMPLEX)
 56:       write(*,*) 'This example requires real numbers.'
 57:       goto 999
 58: #endif
 59:       call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)
 60:       call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
 61:       if (size .ne. 1) then
 62:          if (rank .eq. 0) then
 63:             write(*,*) 'This is a uniprocessor example only!'
 64:          endif
 65:          SETERRQ(1,' ',ierr)
 66:       endif
 67:       m = 30
 68:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,'-m',m,flg,ierr)
 69:       N = 2*m

 71:       if (rank .eq. 0) then
 72:         write(*,*)
 73:         write(*,'(A,I6,A)') 'Ising Model Eigenproblem, m=',m,', (N=2*m)'
 74:         write(*,*)
 75:       endif

 77: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 78: !     Register the matrix-vector subroutine for the operator that defines
 79: !     the eigensystem, Ax=kx
 80: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 82:       call MatCreateShell(PETSC_COMM_WORLD,N,N,N,N,PETSC_NULL_OBJECT,A,
 83:      &                    ierr)
 84:       call MatShellSetOperation(A,MATOP_MULT,MatIsing_Mult,ierr)

 86: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 87: !     Create the eigensolver and display info
 88: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 90: !     ** Create eigensolver context
 91:       call EPSCreate(PETSC_COMM_WORLD,eps,ierr)

 93: !     ** Set operators. In this case, it is a standard eigenvalue problem
 94:       call EPSSetOperators(eps,A,PETSC_NULL_OBJECT,ierr)
 95:       call EPSSetProblemType(eps,EPS_NHEP,ierr)

 97: !     ** Set solver parameters at runtime
 98:       call EPSSetFromOptions(eps,ierr)

100: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
101: !     Solve the eigensystem
102: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

104:       call EPSSolve(eps,ierr)
105:       call EPSGetIterationNumber(eps,its,ierr)
106:       if (rank .eq. 0) then
107:         write(*,'(A,I4)') ' Number of iterations of the method: ', its
108:       endif

110: !     ** Optional: Get some information from the solver and display it
111:       call EPSGetType(eps,type,ierr)
112:       if (rank .eq. 0) then
113:         write(*,'(A,A)') ' Solution method: ', type
114:       endif
115:       call EPSGetDimensions(eps,nev,PETSC_NULL_INTEGER,ierr)
116:       if (rank .eq. 0) then
117:         write(*,'(A,I2)') ' Number of requested eigenvalues:', nev
118:       endif
119:       call EPSGetTolerances(eps,tol,maxit,ierr)
120:       if (rank .eq. 0) then
121:         write(*,'(A,1PE10.4,A,I6)') ' Stopping condition: tol=', tol,
122:      &                              ', maxit=', maxit
123:       endif

125: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
126: !     Display solution and clean up
127: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

129: !     ** Get number of converged eigenpairs
130:       call EPSGetConverged(eps,nconv,ierr)
131:       if (rank .eq. 0) then
132:         write(*,'(A,I2)') ' Number of converged eigenpairs:', nconv
133:       endif

135: !     ** Display eigenvalues and relative errors
136:       if (nconv.gt.0 .and. rank.eq.0) then
137:         write(*,*)
138:         write(*,*) '           k          ||Ax-kx||/||kx||'
139:         write(*,*) '   ----------------- ------------------'
140:         do i=0,nconv-1
141: !         ** Get converged eigenpairs: i-th eigenvalue is stored in kr
142: !         ** (real part) and ki (imaginary part)
143:           call EPSGetEigenpair(eps,i,kr,ki,PETSC_NULL,PETSC_NULL,ierr)

145: !         ** Compute the relative error associated to each eigenpair
146:           call EPSComputeRelativeError(eps,i,error,ierr)

148:           if (ki.ne.0.D0) then
149:             write(*,'(1P,E11.4,E11.4,A,E12.4)') kr, ki, ' j ', error
150:           else
151:             write(*,'(1P,A,E12.4,A,E12.4)') '   ', kr, '       ', error
152:           endif
153:         enddo
154:       endif
155:       write(*,*)

157: !     ** Free work space
158:       call EPSDestroy(eps,ierr)
159:       call MatDestroy(A,ierr)

161: #if defined(PETSC_USE_COMPLEX)
162:  999  continue
163: #endif
164:       call SlepcFinalize(ierr)
165:       end

167: ! -------------------------------------------------------------------
168: !
169: !   MatIsing_Mult - user provided matrix-vector multiply
170: !
171: !   Input Parameters:
172: !   A - matrix
173: !   x - input vector
174: !
175: !   Output Parameter:
176: !   y - output vector
177: !
178:       subroutine MatIsing_Mult(A,x,y,ierr)
179:       implicit none

181: #include "finclude/petsc.h"

183:       Mat         A
184:       Vec         x,y
185:       integer     trans,one,ierr,N
186:       PetscScalar x_array(1),y_array(1)
187:       PetscOffset i_x,i_y

189: !     The actual routine for the matrix-vector product
190:       external mvmisg

192:       call MatGetSize(A,N,PETSC_NULL_INTEGER,ierr)
193:       call VecGetArray(x,x_array,i_x,ierr)
194:       call VecGetArray(y,y_array,i_y,ierr)

196:       trans = 0
197:       one = 1
198:       call mvmisg(trans,N,one,x_array(i_x+1),N,y_array(i_y+1),N)

200:       call VecRestoreArray(x,x_array,i_x,ierr)
201:       call VecRestoreArray(y,y_array,i_y,ierr)

203:       return
204:       end