Actual source code: ex12f.F

petsc-3.12.1 2019-10-22
Report Typos and Errors
  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*/