Actual source code: ex6f.F

  1: !  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2: !  SLEPc - Scalable Library for Eigenvalue Problem Computations
  3: !  Copyright (c) 2002-2010, Universidad Politecnica de Valencia, Spain
  4: !
  5: !  This file is part of SLEPc.
  6: !
  7: !  SLEPc is free software: you can redistribute it and/or modify it under  the
  8: !  terms of version 3 of the GNU Lesser General Public License as published by
  9: !  the Free Software Foundation.
 10: !
 11: !  SLEPc  is  distributed in the hope that it will be useful, but WITHOUT  ANY
 12: !  WARRANTY;  without even the implied warranty of MERCHANTABILITY or  FITNESS
 13: !  FOR  A  PARTICULAR PURPOSE. See the GNU Lesser General Public  License  for
 14: !  more details.
 15: !
 16: !  You  should have received a copy of the GNU Lesser General  Public  License
 17: !  along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
 18: !  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 19: !
 20: !  Program usage: mpirun -np n ex6f [-help] [-m <m>] [all SLEPc options]
 21: !
 22: !  Description: This example solves the eigensystem arising in the Ising
 23: !  model for ferromagnetic materials. The file mvmisg.f must be linked
 24: !  together. Information about the model can be found at the following
 25: !  site http://math.nist.gov/MatrixMarket/data/NEP
 26: !
 27: !  The command line options are:
 28: !    -m <m>, where <m> is the number of 2x2 blocks, i.e. matrix size N=2*m
 29: !
 30: ! ----------------------------------------------------------------------
 31: !
 32:       program main
 33:       implicit none

 35: #include "finclude/petscsys.h"
 36: #include "finclude/petscvec.h"
 37: #include "finclude/petscmat.h"
 38:  #include finclude/slepcsys.h
 39:  #include finclude/slepceps.h

 41: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 42: !     Declarations
 43: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 44: !
 45: !  Variables:
 46: !     A     operator matrix
 47: !     eps   eigenproblem solver context

 49:       Mat            A
 50:       EPS            eps
 51:       EPSType        tname
 52:       PetscReal      tol, error
 53:       PetscScalar    kr, ki
 54:       PetscInt       N, m, i
 55:       PetscInt       nev, maxit, its, nconv
 56:       PetscMPIInt    sz, rank
 57:       PetscErrorCode ierr
 58:       PetscTruth     flg

 60: !     This is the routine to use for matrix-free approach
 61: !
 62:       external MatIsing_Mult

 64: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 65: !     Beginning of program
 66: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 68:       call SlepcInitialize(PETSC_NULL_CHARACTER,ierr)
 69: #if defined(PETSC_USE_COMPLEX)
 70:       write(*,*) 'This example requires real numbers.'
 71:       goto 999
 72: #endif
 73:       call MPI_Comm_size(PETSC_COMM_WORLD,sz,ierr)
 74:       call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
 75:       if (sz .ne. 1) then
 76:          if (rank .eq. 0) then
 77:             write(*,*) 'This is a uniprocessor example only!'
 78:          endif
 79:          SETERRQ(1,' ',ierr)
 80:       endif
 81:       m = 30
 82:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,'-m',m,flg,ierr)
 83:       N = 2*m

 85:       if (rank .eq. 0) then
 86:         write(*,*)
 87:         write(*,'(A,I6,A)') 'Ising Model Eigenproblem, m=',m,', (N=2*m)'
 88:         write(*,*)
 89:       endif

 91: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 92: !     Register the matrix-vector subroutine for the operator that defines
 93: !     the eigensystem, Ax=kx
 94: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 96:       call MatCreateShell(PETSC_COMM_WORLD,N,N,N,N,PETSC_NULL_OBJECT,A,
 97:      &                    ierr)
 98:       call MatShellSetOperation(A,MATOP_MULT,MatIsing_Mult,ierr)

100: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
101: !     Create the eigensolver and display info
102: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

104: !     ** Create eigensolver context
105:       call EPSCreate(PETSC_COMM_WORLD,eps,ierr)

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

111: !     ** Set solver parameters at runtime
112:       call EPSSetFromOptions(eps,ierr)

114: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
115: !     Solve the eigensystem
116: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

118:       call EPSSolve(eps,ierr)
119:       call EPSGetIterationNumber(eps,its,ierr)
120:       if (rank .eq. 0) then
121:         write(*,'(A,I4)') ' Number of iterations of the method: ', its
122:       endif

124: !     ** Optional: Get some information from the solver and display it
125:       call EPSGetType(eps,tname,ierr)
126:       if (rank .eq. 0) then
127:         write(*,'(A,A)') ' Solution method: ', tname
128:       endif
129:       call EPSGetDimensions(eps,nev,PETSC_NULL_INTEGER,
130:      +                      PETSC_NULL_INTEGER,ierr)
131:       if (rank .eq. 0) then
132:         write(*,'(A,I2)') ' Number of requested eigenvalues:', nev
133:       endif
134:       call EPSGetTolerances(eps,tol,maxit,ierr)
135:       if (rank .eq. 0) then
136:         write(*,'(A,1PE10.4,A,I6)') ' Stopping condition: tol=', tol,
137:      &                              ', maxit=', maxit
138:       endif

140: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
141: !     Display solution and clean up
142: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

144: !     ** Get number of converged eigenpairs
145:       call EPSGetConverged(eps,nconv,ierr)
146:       if (rank .eq. 0) then
147:         write(*,'(A,I2)') ' Number of converged eigenpairs:', nconv
148:       endif

150: !     ** Display eigenvalues and relative errors
151:       if (nconv.gt.0 .and. rank.eq.0) then
152:         write(*,*)
153:         write(*,*) '           k          ||Ax-kx||/||kx||'
154:         write(*,*) '   ----------------- ------------------'
155:         do i=0,nconv-1
156: !         ** Get converged eigenpairs: i-th eigenvalue is stored in kr
157: !         ** (real part) and ki (imaginary part)
158:           call EPSGetEigenpair(eps,i,kr,ki,PETSC_NULL_OBJECT,
159:      +                         PETSC_NULL_OBJECT,ierr)

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

164:           if (ki.ne.0.D0) then
165:             write(*,'(1P,E11.4,E11.4,A,E12.4)') kr, ki, ' j ', error
166:           else
167:             write(*,'(1P,A,E12.4,A,E12.4)') '   ', kr, '       ', error
168:           endif
169:         enddo
170:       endif
171:       write(*,*)

173: !     ** Free work space
174:       call EPSDestroy(eps,ierr)
175:       call MatDestroy(A,ierr)

177: #if defined(PETSC_USE_COMPLEX)
178:  999  continue
179: #endif
180:       call SlepcFinalize(ierr)
181:       end

183: ! -------------------------------------------------------------------
184: !
185: !   MatIsing_Mult - user provided matrix-vector multiply
186: !
187: !   Input Parameters:
188: !   A - matrix
189: !   x - input vector
190: !
191: !   Output Parameter:
192: !   y - output vector
193: !
194:       subroutine MatIsing_Mult(A,x,y,ierr)
195:       implicit none

197: #include "finclude/petscsys.h"
198: #include "finclude/petscvec.h"
199: #include "finclude/petscmat.h"

201:       Mat            A
202:       Vec            x,y
203:       integer        trans,one,N
204:       PetscScalar    x_array(1),y_array(1)
205:       PetscOffset    i_x,i_y
206:       PetscErrorCode ierr

208: !     The actual routine for the matrix-vector product
209:       external mvmisg

211:       call MatGetSize(A,N,PETSC_NULL_INTEGER,ierr)
212:       call VecGetArray(x,x_array,i_x,ierr)
213:       call VecGetArray(y,y_array,i_y,ierr)

215:       trans = 0
216:       one = 1
217:       call mvmisg(trans,N,one,x_array(i_x+1),N,y_array(i_y+1),N)

219:       call VecRestoreArray(x,x_array,i_x,ierr)
220:       call VecRestoreArray(y,y_array,i_y,ierr)

222:       return
223:       end