Actual source code: ex14f.F

petsc-3.7.5 2017-01-01
Report Typos and Errors
  1: !
  2: !
  3: !  This example demonstrates use of the SNES Fortran interface.
  4: !
  5: !  Note:  The program is modified from ex12f.F
  6: !         Used for testing MUMPS interface, and control when the Jacobian is rebuilt
  7: !
  8: !  In this example the application context is a Fortran integer array:
  9: !      ctx(1) = da    - distributed array
 10: !          2  = F     - global vector where the function is stored
 11: !          3  = xl    - local work vector
 12: !          4  = rank  - processor rank
 13: !          5  = size  - number of processors
 14: !          6  = N     - system size
 15: !
 16: !  Note: Any user-defined Fortran routines (such as FormJacobian)
 17: !  MUST be declared as external.
 18: !
 19: !
 20: ! Macros to make setting/getting  values into vector clearer.
 21: ! The element xx(ib) is the ibth element in the vector indicated by ctx(3)

 23: #define xx(ib)  vxx(ixx + (ib))
 24: #define ff(ib)  vff(iff + (ib))
 25: #define F2(ib)  vF2(iF2 + (ib))

 27:       module Petscmod
 28:       implicit none
 29: #include <petsc/finclude/petscsys.h>
 30: #include <petsc/finclude/petscvec.h>
 31: #include <petsc/finclude/petscvec.h90>
 32: #include <petsc/finclude/petscmat.h>
 33: #include <petsc/finclude/petscmat.h90>
 34: #include <petsc/finclude/petscviewer.h>
 35: #include <petsc/finclude/petscksp.h>
 36: #include <petsc/finclude/petscpc.h>
 37: #include <petsc/finclude/petscsnes.h>
 38: #include <petsc/finclude/petscis.h>
 39: #include <petsc/finclude/petscdm.h>
 40: #include <petsc/finclude/petscdmda.h>
 41:       end module Petscmod

 43:       module Snesmonitormod
 44:       use Petscmod
 45:       implicit none
 46:       save
 47:       type monctx
 48:         PetscInt :: its,lag
 49:       end type monctx
 50:       end module Snesmonitormod

 52: ! ---------------------------------------------------------------------
 53: ! ---------------------------------------------------------------------
 54: !  Subroutine FormMonitor
 55: !  This function lets up keep track of the SNES progress at each step
 56: !  In this routine, we determine when the Jacobian is rebuilt with the parameter 'jag'
 57: !
 58: !  Input Parameters:
 59: !    snes    - SNES nonlinear solver context
 60: !    its     - current nonlinear iteration, starting from a call of SNESSolve()
 61: !    norm    - 2-norm of current residual (may be approximate)
 62: !    snesmonitor - monctx designed module (included in Snesmonitormod)
 63: ! ---------------------------------------------------------------------
 64:       subroutine FormMonitor(snes,its,norm,snesmonitor,ierr)

 66:       use Snesmonitormod
 67:       implicit none

 69:       SNES ::           snes
 70:       PetscInt ::       its
 71:       PetscScalar ::    norm
 72:       type(monctx) ::   snesmonitor
 73:       PetscErrorCode :: ierr

 75: c      write(6,*) ' '
 76: c      write(6,*) '    its ',its,snesmonitor%its,'lag',
 77: c     &            snesmonitor%lag
 78: c      call flush(6)
 79:       if (mod(snesmonitor%its,snesmonitor%lag).eq.0)
 80:      &      then
 81:         call SNESSetLagJacobian(snes,1,ierr)  ! build jacobian
 82:       else
 83:         call SNESSetLagJacobian(snes,-1,ierr) ! do NOT build jacobian
 84:       endif
 85:       snesmonitor%its = snesmonitor%its + 1
 86:       end subroutine FormMonitor

 88: ! ---------------------------------------------------------------------
 89: ! ---------------------------------------------------------------------
 90:       program main

 92:       use Petscmod
 93:       use Snesmonitormod

 95:       implicit none

 97:       type(monctx) :: snesmonitor
 98:       PetscFortranAddr ctx(6)
 99:       PetscMPIInt rank,size
100:       PetscErrorCode ierr
101:       PetscInt N,start,end,nn,i
102:       PetscInt ii,its,i1,i0,i3
103:       PetscBool  flg
104:       SNES             snes
105:       PC               pc
106:       KSP              ksp
107:       Mat              J,F
108:       Vec              x,r,u
109:       PetscScalar      xp,FF,UU,h
110:       character*(10)   matrixname
111:       external         FormJacobian,FormFunction
112:       external         FormMonitor

114:       call PetscInitialize(PETSC_NULL_CHARACTER,ierr)
115:       i1 = 1
116:       i0 = 0
117:       i3 = 3
118:       N  = 10
119:       call PetscOptionsGetInt(PETSC_NULL_OBJECT,PETSC_NULL_CHARACTER,        &
120:      &                        '-n',N,flg,ierr)
121:       h = 1.d0/(N-1.d0)
122:       ctx(6) = N

124:       call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
125:       call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)
126:       ctx(4) = rank
127:       ctx(5) = size

129: ! Set up data structures
130:       call DMDACreate1d(PETSC_COMM_WORLD,DM_BOUNDARY_NONE,N,i1,i1,            &
131:      &     PETSC_NULL_INTEGER,ctx(1),ierr)

133:       call DMCreateGlobalVector(ctx(1),x,ierr)
134:       call DMCreateLocalVector(ctx(1),ctx(3),ierr)

136:       call PetscObjectSetName(x,'Approximate Solution',ierr)
137:       call VecDuplicate(x,r,ierr)
138:       call VecDuplicate(x,ctx(2),ierr)
139:       call VecDuplicate(x,U,ierr)
140:       call PetscObjectSetName(U,'Exact Solution',ierr)

142:       call MatCreateAIJ(PETSC_COMM_WORLD,PETSC_DECIDE,PETSC_DECIDE,N,           &
143:      &     N,i3,PETSC_NULL_INTEGER,i0,PETSC_NULL_INTEGER,J,ierr)

145:       call MatGetType(J,matrixname,ierr)

147: ! Store right-hand-side of PDE and exact solution
148:       call VecGetOwnershipRange(x,start,end,ierr)
149:       xp = h*start
150:       nn = end - start
151:       ii = start
152:       do 10, i=0,nn-1
153:         FF = 6.0*xp + (xp+1.e-12)**6.e0
154:         UU = xp*xp*xp
155:         call VecSetValues(ctx(2),i1,ii,FF,INSERT_VALUES,ierr)
156:         call VecSetValues(U,i1,ii,UU,INSERT_VALUES,ierr)
157:         xp = xp + h
158:         ii = ii + 1
159:  10   continue
160:       call VecAssemblyBegin(ctx(2),ierr)
161:       call VecAssemblyEnd(ctx(2),ierr)
162:       call VecAssemblyBegin(U,ierr)
163:       call VecAssemblyEnd(U,ierr)

165: ! Create nonlinear solver
166:       call SNESCreate(PETSC_COMM_WORLD,snes,ierr)

168: ! Set various routines and options
169:       call SNESSetFunction(snes,r,FormFunction,ctx,ierr)
170:       call SNESSetJacobian(snes,J,J,FormJacobian,ctx,ierr)
171:       call SNESSetLagJacobian(snes,3,ierr)

173: ! Set linear solver defaults for this problem.
174:       call SNESGetKSP(snes,ksp,ierr)
175:       call KSPGetPC(ksp,pc,ierr)
176: #ifdef PETSC_HAVE_MUMPS
177:       call PCSetType(pc,PCLU,ierr)
178:       call PCFactorSetMatSolverPackage(pc,MATSOLVERMUMPS,ierr)
179: #endif

181:       snesmonitor%its = 0
182:       call SNESGetLagJacobian(snes,snesmonitor%lag,ierr)
183:       call SNESMonitorSet(snes,FormMonitor,snesmonitor,
184:      &                    PETSC_NULL_FUNCTION,ierr)
185:       call SNESSetFromOptions(snes,ierr)
186:       call FormInitialGuess(snes,x,ierr)

188: ! Setup nonlinear solver, and call SNESSolve() for first few iterations, which calls SNESSetUp() :-(
189: !--------------------------------------------------------------------------------------------------
190:       call SNESSetTolerances(snes,PETSC_DEFAULT_REAL,                     &
191:      &                            PETSC_DEFAULT_REAL,                     &
192:      &                            PETSC_DEFAULT_REAL,                     &
193:      &                          3,PETSC_DEFAULT_INTEGER,ierr)
194:       call SNESSolve(snes,PETSC_NULL_OBJECT,x,ierr)

196: #ifdef PETSC_HAVE_MUMPS
197: ! Get PCFactor to set MUMPS matrix ordering option
198:       call PCFactorGetMatrix(pc,F,ierr)
199:       call MatMumpsSetIcntl(F,7,2,ierr) ! must be called before next SNESSetUp? -- not being used!!!
200: #endif

202: ! Solve nonlinear system
203:        call SNESSetTolerances(snes,PETSC_DEFAULT_REAL,                     &
204:      &                            PETSC_DEFAULT_REAL,                      &
205:      &                            PETSC_DEFAULT_REAL,                      &
206:      &      1000,PETSC_DEFAULT_INTEGER,ierr)

208: ! Call SNESSolve() for next few iterations
209: !--------------------------------------------------
210:       snesmonitor%its = snesmonitor%its - 1 !do not count the 0-th iteration
211:       call SNESSolve(snes,PETSC_NULL_OBJECT,x,ierr)
212:       call SNESGetIterationNumber(snes,its,ierr);

214: ! Write results if first processor
215:       if (ctx(4) .eq. 0) then
216:         write(6,100) its
217:       endif
218:   100 format('Number of SNES iterations = ',i5)

220: !  Free work space.  All PETSc objects should be destroyed when they
221: !  are no longer needed.
222:       call VecDestroy(x,ierr)
223:       call VecDestroy(ctx(3),ierr)
224:       call VecDestroy(r,ierr)
225:       call VecDestroy(U,ierr)
226:       call VecDestroy(ctx(2),ierr)
227:       call MatDestroy(J,ierr)
228:       call SNESDestroy(snes,ierr)
229:       call DMDestroy(ctx(1),ierr)
230:       call PetscFinalize(ierr)
231:       end


234: ! --------------------  Evaluate Function F(x) ---------------------

236:       subroutine FormFunction(snes,x,f,ctx,ierr)
237:       implicit none
238:       SNES             snes
239:       Vec              x,f
240:       PetscFortranAddr ctx(*)
241:       PetscMPIInt  rank,size
242:       PetscInt i,s,n
243:       PetscErrorCode ierr
244:       PetscOffset      ixx,iff,iF2
245:       PetscScalar      h,d,vf2(1),vxx(1),vff(1)
246: #include <petsc/finclude/petscsys.h>
247: #include <petsc/finclude/petscvec.h>
248: #include <petsc/finclude/petscdm.h>
249: #include <petsc/finclude/petscdmda.h>
250: #include <petsc/finclude/petscmat.h>
251: #include <petsc/finclude/petscsnes.h>


254:       rank  = ctx(4)
255:       size  = ctx(5)
256:       h     = 1.d0/(ctx(6) - 1.d0)
257:       call DMGlobalToLocalBegin(ctx(1),x,INSERT_VALUES,ctx(3),ierr)
258:       call DMGlobalToLocalEnd(ctx(1),x,INSERT_VALUES,ctx(3),ierr)

260:       call VecGetLocalSize(ctx(3),n,ierr)
261:       if (n .gt. 1000) then
262:         print*, 'Local work array not big enough'
263:         call MPI_Abort(PETSC_COMM_WORLD,0,ierr)
264:       endif

266: !
267: ! This sets the index ixx so that vxx(ixx+1) is the first local
268: ! element in the vector indicated by ctx(3).
269: !
270:       call VecGetArray(ctx(3),vxx,ixx,ierr)
271:       call VecGetArray(f,vff,iff,ierr)
272:       call VecGetArray(ctx(2),vF2,iF2,ierr)

274:       d = h*h

276: !
277: !  Note that the array vxx() was obtained from a ghosted local vector
278: !  ctx(3) while the array vff() was obtained from the non-ghosted parallel
279: !  vector F. This is why there is a need for shift variable s. Since vff()
280: !  does not have locations for the ghost variables we need to index in it
281: !  slightly different then indexing into vxx(). For example on processor
282: !  1 (the second processor)
283: !
284: !        xx(1)        xx(2)             xx(3)             .....
285: !      ^^^^^^^        ^^^^^             ^^^^^
286: !      ghost value   1st local value   2nd local value
287: !
288: !                      ff(1)             ff(2)
289: !                     ^^^^^^^           ^^^^^^^
290: !                    1st local value   2nd local value
291: !
292:        if (rank .eq. 0) then
293:         s = 0
294:         ff(1) = xx(1)
295:       else
296:         s = 1
297:       endif

299:       do 10 i=1,n-2
300:        ff(i-s+1) = d*(xx(i) - 2.d0*xx(i+1)                              &
301:      &      + xx(i+2)) + xx(i+1)*xx(i+1)                                &
302:      &      - F2(i-s+1)
303:  10   continue

305:       if (rank .eq. size-1) then
306:         ff(n-s) = xx(n) - 1.d0
307:       endif

309:       call VecRestoreArray(f,vff,iff,ierr)
310:       call VecRestoreArray(ctx(3),vxx,ixx,ierr)
311:       call VecRestoreArray(ctx(2),vF2,iF2,ierr)
312:       return
313:       end

315: ! --------------------  Form initial approximation -----------------

317:       subroutine FormInitialGuess(snes,x,ierr)
318:       implicit none
319: #include <petsc/finclude/petscsys.h>
320: #include <petsc/finclude/petscvec.h>
321: #include <petsc/finclude/petscsnes.h>
322:       PetscErrorCode   ierr
323:       Vec              x
324:       SNES             snes
325:       PetscScalar      five

327:       five = 5.d-1
328:       call VecSet(x,five,ierr)
329:       return
330:       end

332: ! --------------------  Evaluate Jacobian --------------------

334:       subroutine FormJacobian(snes,x,jac,B,flag,ctx,ierr)

336:       use Petscmod
337:       implicit none

339:       SNES             snes
340:       Vec              x
341:       Mat              jac,B
342:       PetscFortranAddr ctx(*)
343:       PetscBool        flag
344:       PetscInt         ii,istart,iend
345:       PetscInt         i,j,n,end,start,i1
346:       PetscErrorCode   ierr
347:       PetscMPIInt      rank,size
348:       PetscOffset      ixx
349:       PetscScalar      d,A,h,vxx(1)

351:       rank = ctx(4)
352:       size = ctx(5)
353:       if (rank .eq. 0) then
354:         write(6,*)'   Jacobian is built ...'
355:         call flush(6)
356:       endif
357:       i1 = 1
358:       h = 1.d0/(ctx(6) - 1.d0)
359:       d = h*h
360:       rank = ctx(4)
361:       size = ctx(5)

363:       call VecGetArray(x,vxx,ixx,ierr)
364:       call VecGetOwnershipRange(x,start,end,ierr)
365:       n = end - start

367:       if (rank .eq. 0) then
368:         A = 1.0
369:         call MatSetValues(jac,i1,start,i1,start,A,INSERT_VALUES,ierr)
370:         istart = 1
371:       else
372:         istart = 0
373:       endif
374:       if (rank .eq. size-1) then
375:         i = ctx(6)-1
376:         A = 1.0
377:         call MatSetValues(jac,i1,i,i1,i,A,INSERT_VALUES,ierr)
378:         iend = n-1
379:       else
380:         iend = n
381:       endif
382:       do 10 i=istart,iend-1
383:         ii = i + start
384:         j = start + i - 1
385:         call MatSetValues(jac,i1,ii,i1,j,d,INSERT_VALUES,ierr)
386:         j = start + i + 1
387:         call MatSetValues(jac,i1,ii,i1,j,d,INSERT_VALUES,ierr)
388:         A = -2.0*d + 2.0*xx(i+1)
389:         call MatSetValues(jac,i1,ii,i1,ii,A,INSERT_VALUES,ierr)
390:  10   continue
391:       call VecRestoreArray(x,vxx,ixx,ierr)
392:       call MatAssemblyBegin(jac,MAT_FINAL_ASSEMBLY,ierr)
393:       call MatAssemblyEnd(jac,MAT_FINAL_ASSEMBLY,ierr)
394:       return
395:       end