Actual source code: ex12f.F

  1: !
  2: !
  3: !  This example demonstrates basic use of the SNES Fortran interface.
  4: !
  5: !  Note:  The program ex10.f is the same as this example, except that it
  6: !         uses the Fortran .f suffix rather than the .F suffix.
  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)
 22: #define xx(ib)  vxx(ixx + (ib))
 23: #define ff(ib)  vff(iff + (ib))
 24: #define F2(ib)  vF2(iF2 + (ib))
 25:       program main
 26:       implicit none

 28:  #include include/finclude/petsc.h
 29:  #include include/finclude/petscvec.h
 30:  #include include/finclude/petscda.h
 31:  #include include/finclude/petscmat.h
 32:  #include include/finclude/petscsnes.h

 34:       PetscFortranAddr ctx(6)
 35:       PetscMPIInt rank,size
 36:       PetscErrorCode ierr
 37:       PetscInt N,start,end,nn,i,ii,its,i1,i0,i3
 38:       PetscTruth flg
 39:       SNES             snes
 40:       Mat              J
 41:       Vec              x,r,u
 42:       PetscScalar      xp,FF,UU,h
 43:       character*(10)   matrixname
 44:       external         FormJacobian,FormFunction

 46:       call PetscInitialize(PETSC_NULL_CHARACTER,ierr)
 47:       i1 = 1
 48:       i0 = 0
 49:       i3 = 3
 50:       N  = 10
 51:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,'-n',N,flg,ierr)
 52:       h = 1.d0/(N-1.d0)
 53:       ctx(6) = N

 55:       call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
 56:       call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)
 57:       ctx(4) = rank
 58:       ctx(5) = size

 60: ! Set up data structures
 61:       call DACreate1d(PETSC_COMM_WORLD,DA_NONPERIODIC,N,i1,i1,            &
 62:      &     PETSC_NULL_INTEGER,ctx(1),ierr)

 64:       call DACreateGlobalVector(ctx(1),x,ierr)
 65:       call DACreateLocalVector(ctx(1),ctx(3),ierr)

 67:       call PetscObjectSetName(x,'Approximate Solution',ierr)
 68:       call VecDuplicate(x,r,ierr)
 69:       call VecDuplicate(x,ctx(2),ierr)
 70:       call VecDuplicate(x,U,ierr)
 71:       call PetscObjectSetName(U,'Exact Solution',ierr)

 73:       call MatCreateMPIAIJ(PETSC_COMM_WORLD,PETSC_DECIDE,PETSC_DECIDE,N, &
 74:      &     N,i3,PETSC_NULL_INTEGER,i0,PETSC_NULL_INTEGER,J,ierr)

 76:       call MatGetType(J,matrixname,ierr)

 78: ! Store right-hand-side of PDE and exact solution
 79:       call VecGetOwnershipRange(x,start,end,ierr)
 80:       xp = h*start
 81:       nn = end - start
 82:       ii = start
 83:       do 10, i=0,nn-1
 84:         FF = 6.0*xp + (xp+1.e-12)**6.e0
 85:         UU = xp*xp*xp
 86:         call VecSetValues(ctx(2),i1,ii,FF,INSERT_VALUES,ierr)
 87:         call VecSetValues(U,i1,ii,UU,INSERT_VALUES,ierr)
 88:         xp = xp + h
 89:         ii = ii + 1
 90:  10   continue
 91:       call VecAssemblyBegin(ctx(2),ierr)
 92:       call VecAssemblyEnd(ctx(2),ierr)
 93:       call VecAssemblyBegin(U,ierr)
 94:       call VecAssemblyEnd(U,ierr)

 96: ! Create nonlinear solver
 97:       call SNESCreate(PETSC_COMM_WORLD,snes,ierr)

 99: ! Set various routines and options
100:       call SNESSetFunction(snes,r,FormFunction,ctx,ierr)
101:       call SNESSetJacobian(snes,J,J,FormJacobian,ctx,ierr)
102:       call SNESSetFromOptions(snes,ierr)

104: ! Solve nonlinear system
105:       call FormInitialGuess(snes,x,ierr)
106:       call SNESSolve(snes,PETSC_NULL_OBJECT,x,ierr)
107:       call SNESGetIterationNumber(snes,its,ierr);

109: ! Write results if first processor
110:       if (ctx(4) .eq. 0) then
111:         write(6,100) its
112:       endif
113:   100 format('Number of Newton iterations = ',i5)

115: !  Free work space.  All PETSc objects should be destroyed when they
116: !  are no longer needed.
117:       call VecDestroy(x,ierr)
118:       call VecDestroy(ctx(3),ierr)
119:       call VecDestroy(r,ierr)
120:       call VecDestroy(U,ierr)
121:       call VecDestroy(ctx(2),ierr)
122:       call MatDestroy(J,ierr)
123:       call SNESDestroy(snes,ierr)
124:       call DADestroy(ctx(1),ierr)
125:       call PetscFinalize(ierr)
126:       end


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

131:       subroutine FormFunction(snes,x,f,ctx,ierr)
132:       implicit none
133:       SNES             snes
134:       Vec              x,f
135:       PetscFortranAddr ctx(*)
136:       PetscMPIInt  rank,size
137:       PetscInt i,s,n
138:       PetscErrorCode ierr
139:       PetscOffset      ixx,iff,iF2
140:       PetscScalar      h,d,vf2(1),vxx(1),vff(1)
141:  #include include/finclude/petsc.h
142:  #include include/finclude/petscvec.h
143:  #include include/finclude/petscda.h
144:  #include include/finclude/petscmat.h
145:  #include include/finclude/petscsnes.h


148:       rank  = ctx(4)
149:       size  = ctx(5)
150:       h     = 1.d0/(ctx(6) - 1.d0)
151:       call DAGlobalToLocalBegin(ctx(1),x,INSERT_VALUES,ctx(3),ierr)
152:       call DAGlobalToLocalEnd(ctx(1),x,INSERT_VALUES,ctx(3),ierr)

154:       call VecGetLocalSize(ctx(3),n,ierr)
155:       if (n .gt. 1000) then
156:         print*, 'Local work array not big enough'
157:         call MPI_Abort(PETSC_COMM_WORLD,0,ierr)
158:       endif

160: !
161: ! This sets the index ixx so that vxx(ixx+1) is the first local
162: ! element in the vector indicated by ctx(3).
163: !
164:       call VecGetArray(ctx(3),vxx,ixx,ierr)
165:       call VecGetArray(f,vff,iff,ierr)
166:       call VecGetArray(ctx(2),vF2,iF2,ierr)

168:       d = h*h

170: !
171: !  Note that the array vxx() was obtained from a ghosted local vector
172: !  ctx(3) while the array vff() was obtained from the non-ghosted parallel
173: !  vector F. This is why there is a need for shift variable s. Since vff()
174: !  does not have locations for the ghost variables we need to index in it
175: !  slightly different then indexing into vxx(). For example on processor
176: !  1 (the second processor)
177: !
178: !        xx(1)        xx(2)             xx(3)             .....
179: !      ^^^^^^^        ^^^^^             ^^^^^
180: !      ghost value   1st local value   2nd local value
181: !
182: !                      ff(1)             ff(2)
183: !                     ^^^^^^^           ^^^^^^^
184: !                    1st local value   2nd local value
185: !
186:        if (rank .eq. 0) then
187:         s = 0
188:         ff(1) = xx(1)
189:       else
190:         s = 1
191:       endif

193:       do 10 i=1,n-2
194:        ff(i-s+1) = d*(xx(i) - 2.d0*xx(i+1)                              &
195:      &      + xx(i+2)) + xx(i+1)*xx(i+1)                                &
196:      &      - F2(i-s+1)
197:  10   continue

199:       if (rank .eq. size-1) then
200:         ff(n-s) = xx(n) - 1.d0
201:       endif

203:       call VecRestoreArray(f,vff,iff,ierr)
204:       call VecRestoreArray(ctx(3),vxx,ixx,ierr)
205:       call VecRestoreArray(ctx(2),vF2,iF2,ierr)
206:       return
207:       end

209: ! --------------------  Form initial approximation -----------------

211:       subroutine FormInitialGuess(snes,x,ierr)
212:       implicit none
213:  #include include/finclude/petsc.h
214:  #include include/finclude/petscvec.h
215:  #include include/finclude/petscsnes.h
216:       PetscErrorCode   ierr
217:       Vec              x
218:       SNES             snes
219:       PetscScalar      five

221:       five = 5.d-1
222:       call VecSet(x,five,ierr)
223:       return
224:       end

226: ! --------------------  Evaluate Jacobian --------------------

228:       subroutine FormJacobian(snes,x,jac,B,flag,ctx,ierr)
229:       implicit none
230:  #include include/finclude/petsc.h
231:  #include include/finclude/petscvec.h
232:  #include include/finclude/petscda.h
233:  #include include/finclude/petscmat.h
234:  #include include/finclude/petscsnes.h
235:       SNES             snes
236:       Vec              x
237:       Mat              jac,B
238:       PetscFortranAddr ctx(*)
239:       PetscTruth       flag
240:       PetscInt         ii,istart,iend,i,j,n,end,start,i1
241:       PetscErrorCode ierr
242:       PetscMPIInt rank,size
243:       PetscOffset      ixx
244:       PetscScalar      d,A,h,vxx(1)

246:       i1 = 1
247:       h = 1.d0/(ctx(6) - 1.d0)
248:       d = h*h
249:       rank = ctx(4)
250:       size = ctx(5)

252:       call VecGetArray(x,vxx,ixx,ierr)
253:       call VecGetOwnershipRange(x,start,end,ierr)
254:       n = end - start

256:       if (rank .eq. 0) then
257:         A = 1.0
258:         call MatSetValues(jac,i1,start,i1,start,A,INSERT_VALUES,ierr)
259:         istart = 1
260:       else
261:         istart = 0
262:       endif
263:       if (rank .eq. size-1) then
264:         i = ctx(6)-1
265:         A = 1.0
266:         call MatSetValues(jac,i1,i,i1,i,A,INSERT_VALUES,ierr)
267:         iend = n-1
268:       else
269:         iend = n
270:       endif
271:       do 10 i=istart,iend-1
272:         ii = i + start
273:         j = start + i - 1
274:         call MatSetValues(jac,i1,ii,i1,j,d,INSERT_VALUES,ierr)
275:         j = start + i + 1
276:         call MatSetValues(jac,i1,ii,i1,j,d,INSERT_VALUES,ierr)
277:         A = -2.0*d + 2.0*xx(i+1)
278:         call MatSetValues(jac,i1,ii,i1,ii,A,INSERT_VALUES,ierr)
279:  10   continue
280:       call VecRestoreArray(x,vxx,ixx,ierr)
281:       call MatAssemblyBegin(jac,MAT_FINAL_ASSEMBLY,ierr)
282:       call MatAssemblyEnd(jac,MAT_FINAL_ASSEMBLY,ierr)
283:       return
284:       end