Actual source code: ex12f.F
petsc-3.12.1 2019-10-22
1: !
2: !
3: ! This example demonstrates basic use of the SNES Fortran interface.
4: !
5: !
6: module UserModule
7: #include <petsc/finclude/petscsnes.h>
8: use petscsnes
9: type User
10: DM da
11: Vec F
12: Vec xl
13: integer comm
14: PetscInt N
15: end type User
16: save
17: type monctx
18: PetscInt :: its,lag
19: end type monctx
20: end module
22: ! ---------------------------------------------------------------------
23: ! ---------------------------------------------------------------------
24: ! Subroutine FormMonitor
25: ! This function lets up keep track of the SNES progress at each step
26: ! In this routine, we determine when the Jacobian is rebuilt with the parameter 'jag'
27: !
28: ! Input Parameters:
29: ! snes - SNES nonlinear solver context
30: ! its - current nonlinear iteration, starting from a call of SNESSolve()
31: ! norm - 2-norm of current residual (may be approximate)
32: ! snesm - monctx designed module (included in Snesmmod)
33: ! ---------------------------------------------------------------------
34: subroutine FormMonitor(snes,its,norm,snesm,ierr)
35: use UserModule
36: implicit none
38: SNES :: snes
39: PetscInt :: its,one,mone
40: PetscScalar :: norm
41: type(monctx) :: snesm
42: PetscErrorCode :: ierr
44: ! write(6,*) ' '
45: ! write(6,*) ' its ',its,snesm%its,'lag',
46: ! & snesm%lag
47: ! call flush(6)
48: if (mod(snesm%its,snesm%lag).eq.0) then
49: one = 1
50: call SNESSetLagJacobian(snes,one,ierr) ! build jacobian
51: else
52: mone = -1
53: call SNESSetLagJacobian(snes,mone,ierr) ! do NOT build jacobian
54: endif
55: snesm%its = snesm%its + 1
56: end subroutine FormMonitor
58: ! Note: Any user-defined Fortran routines (such as FormJacobian)
59: ! MUST be declared as external.
60: !
61: !
62: ! Macros to make setting/getting values into vector clearer.
63: ! The element xx(ib) is the ibth element in the vector indicated by ctx%F
64: #define xx(ib) vxx(ixx + (ib))
65: #define ff(ib) vff(iff + (ib))
66: #define F2(ib) vF2(iF2 + (ib))
67: program main
68: use UserModule
69: implicit none
70: #if defined(PETSC_USING_F90) && !defined(PETSC_USE_FORTRANKIND)
71: external PETSC_NULL_FUNCTION
72: #endif
73: type(User) ctx
74: PetscMPIInt rank,size
75: PetscErrorCode ierr
76: PetscInt N,start,end,nn,i
77: PetscInt ii,its,i1,i0,i3
78: PetscBool flg
79: SNES snes
80: Mat J
81: Vec x,r,u
82: PetscScalar xp,FF,UU,h
83: character*(10) matrixname
84: external FormJacobian,FormFunction
85: external formmonitor
86: type(monctx) :: snesm
88: call PetscInitialize(PETSC_NULL_CHARACTER,ierr)
89: if (ierr .ne. 0) then
90: print*,'Unable to initialize PETSc'
91: stop
92: endif
93: i1 = 1
94: i0 = 0
95: i3 = 3
96: N = 10
97: call PetscOptionsGetInt(PETSC_NULL_OPTIONS,PETSC_NULL_CHARACTER, &
98: & '-n',N,flg,ierr)
99: h = 1.0/real(N-1)
100: ctx%N = N
101: ctx%comm = PETSC_COMM_WORLD
103: call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
104: call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)
106: ! Set up data structures
107: call DMDACreate1d(PETSC_COMM_WORLD,DM_BOUNDARY_NONE,N,i1,i1, &
108: & PETSC_NULL_INTEGER,ctx%da,ierr)
109: call DMSetFromOptions(ctx%da,ierr)
110: call DMSetUp(ctx%da,ierr)
111: call DMCreateGlobalVector(ctx%da,x,ierr)
112: call DMCreateLocalVector(ctx%da,ctx%xl,ierr)
114: call PetscObjectSetName(x,'Approximate Solution',ierr)
115: call VecDuplicate(x,r,ierr)
116: call VecDuplicate(x,ctx%F,ierr)
117: call VecDuplicate(x,U,ierr)
118: call PetscObjectSetName(U,'Exact Solution',ierr)
120: call MatCreateAIJ(PETSC_COMM_WORLD,PETSC_DECIDE,PETSC_DECIDE,N, &
121: & N,i3,PETSC_NULL_INTEGER,i0,PETSC_NULL_INTEGER,J,ierr)
122: call MatSetOption(J,MAT_NEW_NONZERO_LOCATION_ERR,PETSC_FALSE,ierr)
123: call MatGetType(J,matrixname,ierr)
125: ! Store right-hand-side of PDE and exact solution
126: call VecGetOwnershipRange(x,start,end,ierr)
127: xp = h*start
128: nn = end - start
129: ii = start
130: do 10, i=0,nn-1
131: FF = 6.0*xp + (xp+1.e-12)**6.e0
132: UU = xp*xp*xp
133: call VecSetValues(ctx%F,i1,ii,FF,INSERT_VALUES,ierr)
134: call VecSetValues(U,i1,ii,UU,INSERT_VALUES,ierr)
135: xp = xp + h
136: ii = ii + 1
137: 10 continue
138: call VecAssemblyBegin(ctx%F,ierr)
139: call VecAssemblyEnd(ctx%F,ierr)
140: call VecAssemblyBegin(U,ierr)
141: call VecAssemblyEnd(U,ierr)
143: ! Create nonlinear solver
144: call SNESCreate(PETSC_COMM_WORLD,snes,ierr)
146: ! Set various routines and options
147: call SNESSetFunction(snes,r,FormFunction,ctx,ierr)
148: call SNESSetJacobian(snes,J,J,FormJacobian,ctx,ierr)
150: snesm%its = 0
151: call SNESGetLagJacobian(snes,snesm%lag,ierr)
152: call SNESMonitorSet(snes,FormMonitor,snesm, &
153: & PETSC_NULL_FUNCTION,ierr)
154: call SNESSetFromOptions(snes,ierr)
156: ! Solve nonlinear system
157: call FormInitialGuess(snes,x,ierr)
158: call SNESSolve(snes,PETSC_NULL_VEC,x,ierr)
159: call SNESGetIterationNumber(snes,its,ierr);
161: ! Free work space. All PETSc objects should be destroyed when they
162: ! are no longer needed.
163: call VecDestroy(x,ierr)
164: call VecDestroy(ctx%xl,ierr)
165: call VecDestroy(r,ierr)
166: call VecDestroy(U,ierr)
167: call VecDestroy(ctx%F,ierr)
168: call MatDestroy(J,ierr)
169: call SNESDestroy(snes,ierr)
170: call DMDestroy(ctx%da,ierr)
171: call PetscFinalize(ierr)
172: end
175: ! -------------------- Evaluate Function F(x) ---------------------
177: subroutine FormFunction(snes,x,f,ctx,ierr)
178: use UserModule
179: implicit none
180: SNES snes
181: Vec x,f
182: type(User) ctx
183: PetscMPIInt rank,size
184: PetscInt i,s,n
185: PetscErrorCode ierr
186: PetscOffset ixx,iff,iF2
187: PetscScalar h,d,vf2(2),vxx(2),vff(2)
189: call MPI_Comm_rank(ctx%comm,rank,ierr)
190: call MPI_Comm_size(ctx%comm,size,ierr)
191: h = 1.0/(real(ctx%N) - 1.0)
192: call DMGlobalToLocalBegin(ctx%da,x,INSERT_VALUES,ctx%xl,ierr)
193: call DMGlobalToLocalEnd(ctx%da,x,INSERT_VALUES,ctx%xl,ierr)
195: call VecGetLocalSize(ctx%xl,n,ierr)
196: if (n .gt. 1000) then
197: print*, 'Local work array not big enough'
198: call MPI_Abort(PETSC_COMM_WORLD,0,ierr)
199: endif
201: !
202: ! This sets the index ixx so that vxx(ixx+1) is the first local
203: ! element in the vector indicated by ctx%xl.
204: !
205: call VecGetArrayRead(ctx%xl,vxx,ixx,ierr)
206: call VecGetArray(f,vff,iff,ierr)
207: call VecGetArray(ctx%F,vF2,iF2,ierr)
209: d = h*h
211: !
212: ! Note that the array vxx() was obtained from a ghosted local vector
213: ! ctx%xl while the array vff() was obtained from the non-ghosted parallel
214: ! vector F. This is why there is a need for shift variable s. Since vff()
215: ! does not have locations for the ghost variables we need to index in it
216: ! slightly different then indexing into vxx(). For example on processor
217: ! 1 (the second processor)
218: !
219: ! xx(1) xx(2) xx(3) .....
220: ! ^^^^^^^ ^^^^^ ^^^^^
221: ! ghost value 1st local value 2nd local value
222: !
223: ! ff(1) ff(2)
224: ! ^^^^^^^ ^^^^^^^
225: ! 1st local value 2nd local value
226: !
227: if (rank .eq. 0) then
228: s = 0
229: ff(1) = xx(1)
230: else
231: s = 1
232: endif
234: do 10 i=1,n-2
235: ff(i-s+1) = d*(xx(i) - 2.0*xx(i+1) &
236: & + xx(i+2)) + xx(i+1)*xx(i+1) &
237: & - F2(i-s+1)
238: 10 continue
240: if (rank .eq. size-1) then
241: ff(n-s) = xx(n) - 1.0
242: endif
244: call VecRestoreArray(f,vff,iff,ierr)
245: call VecRestoreArrayRead(ctx%xl,vxx,ixx,ierr)
246: call VecRestoreArray(ctx%F,vF2,iF2,ierr)
247: return
248: end
250: ! -------------------- Form initial approximation -----------------
252: subroutine FormInitialGuess(snes,x,ierr)
253: use UserModule
254: implicit none
256: PetscErrorCode ierr
257: Vec x
258: SNES snes
259: PetscScalar five
261: five = .5
262: call VecSet(x,five,ierr)
263: return
264: end
266: ! -------------------- Evaluate Jacobian --------------------
268: subroutine FormJacobian(snes,x,jac,B,ctx,ierr)
269: use UserModule
270: implicit none
272: SNES snes
273: Vec x
274: Mat jac,B
275: type(User) ctx
276: PetscInt ii,istart,iend
277: PetscInt i,j,n,end,start,i1
278: PetscErrorCode ierr
279: PetscMPIInt rank,size
280: PetscOffset ixx
281: PetscScalar d,A,h,vxx(2)
283: i1 = 1
284: h = 1.0/(real(ctx%N) - 1.0)
285: d = h*h
286: call MPI_Comm_rank(ctx%comm,rank,ierr)
287: call MPI_Comm_size(ctx%comm,size,ierr)
289: call VecGetArrayRead(x,vxx,ixx,ierr)
290: call VecGetOwnershipRange(x,start,end,ierr)
291: n = end - start
293: if (rank .eq. 0) then
294: A = 1.0
295: call MatSetValues(jac,i1,start,i1,start,A,INSERT_VALUES,ierr)
296: istart = 1
297: else
298: istart = 0
299: endif
300: if (rank .eq. size-1) then
301: i = INT(ctx%N-1)
302: A = 1.0
303: call MatSetValues(jac,i1,i,i1,i,A,INSERT_VALUES,ierr)
304: iend = n-1
305: else
306: iend = n
307: endif
308: do 10 i=istart,iend-1
309: ii = i + start
310: j = start + i - 1
311: call MatSetValues(jac,i1,ii,i1,j,d,INSERT_VALUES,ierr)
312: j = start + i + 1
313: call MatSetValues(jac,i1,ii,i1,j,d,INSERT_VALUES,ierr)
314: A = -2.0*d + 2.0*xx(i+1)
315: call MatSetValues(jac,i1,ii,i1,ii,A,INSERT_VALUES,ierr)
316: 10 continue
317: call VecRestoreArrayRead(x,vxx,ixx,ierr)
318: call MatAssemblyBegin(jac,MAT_FINAL_ASSEMBLY,ierr)
319: call MatAssemblyEnd(jac,MAT_FINAL_ASSEMBLY,ierr)
320: return
321: end
323: !/*TEST
324: !
325: ! test:
326: ! nsize: 2
327: ! args: -ksp_gmres_cgs_refinement_type refine_always -n 10 -snes_monitor_short
328: ! output_file: output/ex12_1.out
329: !
330: !TEST*/