Actual source code: ex14f.F
petsc-3.7.5 2017-01-01
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