Actual source code: plate2f.F

petsc-dev 2014-02-02
Report Typos and Errors
  1: !  Program usage: mpirun -np <proc> plate2f [all TAO options]
  2: !
  3: !  This example demonstrates use of the TAO package to solve a bound constrained
  4: !  minimization problem.  This example is based on a problem from the
  5: !  MINPACK-2 test suite.  Given a rectangular 2-D domain and boundary values
  6: !  along the edges of the domain, the objective is to find the surface
  7: !  with the minimal area that satisfies the boundary conditions.
  8: !  The command line options are:
  9: !    -mx <xg>, where <xg> = number of grid points in the 1st coordinate direction
 10: !    -my <yg>, where <yg> = number of grid points in the 2nd coordinate direction
 11: !    -bmx <bxg>, where <bxg> = number of grid points under plate in 1st direction
 12: !    -bmy <byg>, where <byg> = number of grid points under plate in 2nd direction
 13: !    -bheight <ht>, where <ht> = height of the plate
 14: !
 15: !/*T
 16: !   Concepts: TAO^Solving a bound constrained minimization problem
 17: !   Routines: TaoCreate();
 18: !   Routines: TaoSetType(); TaoSetObjectiveAndGradientRoutine();
 19: !   Routines: TaoSetHessianRoutine();
 20: !   Routines: TaoSetVariableBoundsRoutine();
 21: !   Routines: TaoSetInitialVector();
 22: !   Routines: TaoSetFromOptions();
 23: !   Routines: TaoSolve();
 24: !   Routines: TaoDestroy();
 25: !   Processors: n
 26: !T*/



 30:       implicit none

 32: #include "plate2f.h"

 34: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 35: !                   Variable declarations
 36: ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 37: !
 38: !  Variables:
 39: !    (common from plate2f.h):
 40: !    Nx, Ny           number of processors in x- and y- directions
 41: !    mx, my           number of grid points in x,y directions
 42: !    N    global dimension of vector

 44:       PetscErrorCode   ierr          ! used to check for functions returning nonzeros
 45:       Vec              x             ! solution vector
 46:       Vec              xl, xu        ! lower and upper bounds vectorsp
 47:       PetscInt         m             ! number of local elements in vector
 48:       Tao              tao           ! Tao solver context
 49:       Mat              H             ! Hessian matrix
 50:       ISLocalToGlobalMapping isltog  ! local to global mapping object
 51:       PetscBool        flg
 52:       PetscInt         i1,i3,i7


 55:       external FormFunctionGradient
 56:       external FormHessian
 57:       external MSA_BoundaryConditions
 58:       external MSA_Plate
 59:       external MSA_InitialPoint
 60: ! Initialize Tao

 62:       i1=1
 63:       i3=3
 64:       i7=7


 67:       call PetscInitialize(PETSC_NULL_CHARACTER,ierr)

 69: ! Specify default dimensions of the problem
 70:       mx = 10
 71:       my = 10
 72:       bheight = 0.1

 74: ! Check for any command line arguments that override defaults

 76:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,"-mx",mx,flg,ierr)
 77:       CHKERRQ(ierr)
 78:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,"-my",my,flg,ierr)
 79:       CHKERRQ(ierr)

 81:       bmx = mx/2
 82:       bmy = my/2

 84:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,"-bmx",bmx,flg,ierr)
 85:       CHKERRQ(ierr)
 86:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,"-bmy",bmy,flg,ierr)
 87:       CHKERRQ(ierr)
 88:       call PetscOptionsGetReal(PETSC_NULL_CHARACTER,"-bheight",bheight,   &
 89:      &      flg,ierr)
 90:       CHKERRQ(ierr)


 93: ! Calculate any derived values from parameters
 94:       N = mx*my

 96: ! Let Petsc determine the dimensions of the local vectors
 97:       Nx = PETSC_DECIDE
 98:       NY = PETSC_DECIDE

100: ! A two dimensional distributed array will help define this problem, which
101: ! derives from an elliptic PDE on a two-dimensional domain.  From the
102: ! distributed array, create the vectors

104:       call DMDACreate2d(MPI_COMM_WORLD,DMDA_BOUNDARY_NONE,                    &
105:      &     DMDA_BOUNDARY_NONE, DMDA_STENCIL_BOX,                              &
106:      &     mx,my,Nx,Ny,i1,i1,PETSC_NULL_INTEGER,PETSC_NULL_INTEGER,           &
107:      &     dm,ierr)
108:       CHKERRQ(ierr)


111: ! Extract global and local vectors from DM; The local vectors are
112: ! used solely as work space for the evaluation of the function,
113: ! gradient, and Hessian.  Duplicate for remaining vectors that are
114: ! the same types.

116:       call DMCreateGlobalVector(dm,x,ierr)
117:       CHKERRQ(ierr)
118:       call DMCreateLocalVector(dm,localX,ierr)
119:       CHKERRQ(ierr)
120:       call VecDuplicate(localX,localV,ierr)
121:       CHKERRQ(ierr)

123: ! Create a matrix data structure to store the Hessian.
124: ! Here we (optionally) also associate the local numbering scheme
125: ! with the matrix so that later we can use local indices for matrix
126: ! assembly

128:       call VecGetLocalSize(x,m,ierr)
129:       CHKERRQ(ierr)
130:       call MatCreateAIJ(MPI_COMM_WORLD,m,m,N,N,i7,PETSC_NULL_INTEGER,   &
131:      &     i3,PETSC_NULL_INTEGER,H,ierr)
132:       CHKERRQ(ierr)

134:       call MatSetOption(H,MAT_SYMMETRIC,PETSC_TRUE,ierr)
135:       CHKERRQ(ierr)
136:       call DMGetLocalToGlobalMapping(dm,isltog,ierr)
137:       CHKERRQ(ierr)
138:       call MatSetLocalToGlobalMapping(H,isltog,isltog,ierr)
139:       CHKERRQ(ierr)


142: ! The Tao code begins here
143: ! Create TAO solver and set desired solution method.
144: ! This problems uses bounded variables, so the
145: ! method must either be 'tao_tron' or 'tao_blmvm'

147:       call TaoCreate(PETSC_COMM_WORLD,tao,ierr)
148:       CHKERRQ(ierr)
149:       call TaoSetType(tao,'tao_blmvm',ierr)
150:       CHKERRQ(ierr)

152: !     Set minimization function and gradient, hessian evaluation functions

154:       call TaoSetObjectiveAndGradientRoutine(tao,                       &
155:      &     FormFunctionGradient,PETSC_NULL_OBJECT,ierr)
156:       CHKERRQ(ierr)

158:       call TaoSetHessianRoutine(tao,H,H,FormHessian,                    &
159:      &     PETSC_NULL_OBJECT, ierr)
160:       CHKERRQ(ierr)

162: ! Set Variable bounds
163:       call MSA_BoundaryConditions(ierr)
164:       CHKERRQ(ierr)
165:       call TaoSetVariableBoundsRoutine(tao,MSA_Plate,                   &
166:      &     PETSC_NULL_OBJECT,ierr)
167:       CHKERRQ(ierr)

169: ! Set the initial solution guess
170:       call MSA_InitialPoint(x, ierr)
171:       CHKERRQ(ierr)
172:       call TaoSetInitialVector(tao,x,ierr)
173:       CHKERRQ(ierr)

175: ! Check for any tao command line options
176:       call TaoSetFromOptions(tao,ierr)
177:       CHKERRQ(ierr)

179: ! Solve the application
180:       call TaoSolve(tao,ierr)
181:       CHKERRQ(ierr)

183: ! Free TAO data structures
184:       call TaoDestroy(tao,ierr)
185:       CHKERRQ(ierr)

187: ! Free PETSc data structures
188:       call VecDestroy(x,ierr)
189:       call VecDestroy(Top,ierr)
190:       call VecDestroy(Bottom,ierr)
191:       call VecDestroy(Left,ierr)
192:       call VecDestroy(Right,ierr)
193:       call MatDestroy(H,ierr)
194:       call VecDestroy(localX,ierr)
195:       call VecDestroy(localV,ierr)
196:       call DMDestroy(dm,ierr)

198: ! Finalize TAO

200:       call PetscFinalize(ierr)

202:       end

204: ! ---------------------------------------------------------------------
205: !
206: !  FormFunctionGradient - Evaluates function f(X).
207: !
208: !  Input Parameters:
209: !  tao   - the Tao context
210: !  X     - the input vector
211: !  dummy - optional user-defined context, as set by TaoSetFunction()
212: !          (not used here)
213: !
214: !  Output Parameters:
215: !  fcn     - the newly evaluated function
216: !  G       - the gradient vector
217: !  info  - error code
218: !


221:       subroutine FormFunctionGradient(tao,X,fcn,G,dummy,ierr)
222:       implicit none

224: ! dm, localX, localG, Top, Bottom, Left, Right defined in plate2f.h
225: #include "plate2f.h"

227: ! Input/output variables

229:       Tao        tao
230:       PetscReal      fcn
231:       Vec              X, G
232:       PetscErrorCode   ierr
233:       PetscInt         dummy

235:       PetscInt         i,j,row
236:       PetscInt         xs, xm
237:       PetscInt         gxs, gxm
238:       PetscInt         ys, ym
239:       PetscInt         gys, gym
240:       PetscReal      ft,zero,hx,hy,hydhx,hxdhy
241:       PetscReal      area,rhx,rhy
242:       PetscReal      f1,f2,f3,f4,f5,f6,d1,d2,d3
243:       PetscReal      d4,d5,d6,d7,d8
244:       PetscReal      df1dxc,df2dxc,df3dxc,df4dxc
245:       PetscReal      df5dxc,df6dxc
246:       PetscReal      xc,xl,xr,xt,xb,xlt,xrb


249: ! PETSc's VecGetArray acts differently in Fortran than it does in C.
250: ! Calling VecGetArray((Vec) X, (PetscReal) x_array(0:1), (PetscOffset) x_index, ierr)
251: ! will return an array of doubles referenced by x_array offset by x_index.
252: !  i.e.,  to reference the kth element of X, use x_array(k + x_index).
253: ! Notice that by declaring the arrays with range (0:1), we are using the C 0-indexing practice.
254:       PetscReal      g_v(0:1),x_v(0:1)
255:       PetscReal      top_v(0:1),left_v(0:1)
256:       PetscReal      right_v(0:1),bottom_v(0:1)
257:       PetscOffset      g_i,left_i,right_i
258:       PetscOffset      bottom_i,top_i,x_i

260:       ft = 0.0d0
261:       zero = 0.0d0
262:       hx = 1.0d0/(mx + 1)
263:       hy = 1.0d0/(my + 1)
264:       hydhx = hy/hx
265:       hxdhy = hx/hy
266:       area = 0.5d0 * hx * hy
267:       rhx = mx + 1.0d0
268:       rhy = my + 1.0d0


271: ! Get local mesh boundaries
272:       call DMDAGetCorners(dm,xs,ys,PETSC_NULL_INTEGER,xm,ym,              &
273:      &                  PETSC_NULL_INTEGER,ierr)
274:       call DMDAGetGhostCorners(dm,gxs,gys,PETSC_NULL_INTEGER,             &
275:      &                       gxm,gym,PETSC_NULL_INTEGER,ierr)

277: ! Scatter ghost points to local vector
278:       call DMGlobalToLocalBegin(dm,X,INSERT_VALUES,localX,ierr)
279:       call DMGlobalToLocalEnd(dm,X,INSERT_VALUES,localX,ierr)

281: ! Initialize the vector to zero
282:       call VecSet(localV,zero,ierr)

284: ! Get arrays to vector data (See note above about using VecGetArray in Fortran)
285:       call VecGetArray(localX,x_v,x_i,ierr)
286:       call VecGetArray(localV,g_v,g_i,ierr)
287:       call VecGetArray(Top,top_v,top_i,ierr)
288:       call VecGetArray(Bottom,bottom_v,bottom_i,ierr)
289:       call VecGetArray(Left,left_v,left_i,ierr)
290:       call VecGetArray(Right,right_v,right_i,ierr)

292: ! Compute function over the locally owned part of the mesh
293:       do j = ys,ys+ym-1
294:          do i = xs,xs+xm-1
295:             row = (j-gys)*gxm + (i-gxs)
296:             xc = x_v(row+x_i)
297:             xt = xc
298:             xb = xc
299:             xr = xc
300:             xl = xc
301:             xrb = xc
302:             xlt = xc

304:             if (i .eq. 0) then !left side
305:                xl = left_v(j - ys + 1 + left_i)
306:                xlt = left_v(j - ys + 2 + left_i)
307:             else
308:                xl = x_v(row - 1 + x_i)
309:             endif

311:             if (j .eq. 0) then !bottom side
312:                xb = bottom_v(i - xs + 1 + bottom_i)
313:                xrb = bottom_v(i - xs + 2 + bottom_i)
314:             else
315:                xb = x_v(row - gxm + x_i)
316:             endif

318:             if (i + 1 .eq. gxs + gxm) then !right side
319:                xr = right_v(j - ys + 1 + right_i)
320:                xrb = right_v(j - ys + right_i)
321:             else
322:                xr = x_v(row + 1 + x_i)
323:             endif

325:             if (j + 1 .eq. gys + gym) then !top side
326:                xt = top_v(i - xs + 1 + top_i)
327:                xlt = top_v(i - xs + top_i)
328:             else
329:                xt = x_v(row + gxm + x_i)
330:             endif

332:             if ((i .gt. gxs ) .and. (j + 1 .lt. gys + gym)) then
333:                xlt = x_v(row - 1 + gxm + x_i)
334:             endif

336:             if ((j .gt. gys) .and. (i + 1 .lt. gxs + gxm)) then
337:                xrb = x_v(row + 1 - gxm + x_i)
338:             endif

340:             d1 = xc-xl
341:             d2 = xc-xr
342:             d3 = xc-xt
343:             d4 = xc-xb
344:             d5 = xr-xrb
345:             d6 = xrb-xb
346:             d7 = xlt-xl
347:             d8 = xt-xlt

349:             df1dxc = d1 * hydhx
350:             df2dxc = d1 * hydhx + d4 * hxdhy
351:             df3dxc = d3 * hxdhy
352:             df4dxc = d2 * hydhx + d3 * hxdhy
353:             df5dxc = d2 * hydhx
354:             df6dxc = d4 * hxdhy

356:             d1 = d1 * rhx
357:             d2 = d2 * rhx
358:             d3 = d3 * rhy
359:             d4 = d4 * rhy
360:             d5 = d5 * rhy
361:             d6 = d6 * rhx
362:             d7 = d7 * rhy
363:             d8 = d8 * rhx

365:             f1 = sqrt(1.0d0 + d1*d1 + d7*d7)
366:             f2 = sqrt(1.0d0 + d1*d1 + d4*d4)
367:             f3 = sqrt(1.0d0 + d3*d3 + d8*d8)
368:             f4 = sqrt(1.0d0 + d3*d3 + d2*d2)
369:             f5 = sqrt(1.0d0 + d2*d2 + d5*d5)
370:             f6 = sqrt(1.0d0 + d4*d4 + d6*d6)

372:             ft = ft + f2 + f4

374:             df1dxc = df1dxc / f1
375:             df2dxc = df2dxc / f2
376:             df3dxc = df3dxc / f3
377:             df4dxc = df4dxc / f4
378:             df5dxc = df5dxc / f5
379:             df6dxc = df6dxc / f6

381:             g_v(row + g_i) = 0.5 * (df1dxc + df2dxc + df3dxc + df4dxc +  &
382:      &                              df5dxc + df6dxc)
383:          enddo
384:       enddo

386: ! Compute triangular areas along the border of the domain.
387:       if (xs .eq. 0) then  ! left side
388:          do j=ys,ys+ym-1
389:             d3 = (left_v(j-ys+1+left_i) - left_v(j-ys+2+left_i))         &
390:      &                 * rhy
391:             d2 = (left_v(j-ys+1+left_i) - x_v((j-gys)*gxm + x_i))        &
392:      &                 * rhx
393:             ft = ft + sqrt(1.0d0 + d3*d3 + d2*d2)
394:          enddo
395:       endif


398:       if (ys .eq. 0) then !bottom side
399:          do i=xs,xs+xm-1
400:             d2 = (bottom_v(i+1-xs+bottom_i)-bottom_v(i-xs+2+bottom_i))    &
401:      &                    * rhx
402:             d3 = (bottom_v(i-xs+1+bottom_i)-x_v(i-gxs+x_i))*rhy
403:             ft = ft + sqrt(1.0 + d3*d3 + d2*d2)
404:          enddo
405:       endif


408:       if (xs + xm .eq. mx) then ! right side
409:          do j=ys,ys+ym-1
410:             d1 = (x_v((j+1-gys)*gxm-1+x_i)-right_v(j-ys+1+right_i))*rhx
411:             d4 = (right_v(j-ys+right_i) - right_v(j-ys+1+right_i))*rhy
412:             ft = ft + sqrt(1.0d0 + d1*d1 + d4*d4)
413:          enddo
414:       endif


417:       if (ys + ym .eq. my) then
418:          do i=xs,xs+xm-1
419:             d1 = (x_v((gym-1)*gxm+i-gxs+x_i) - top_v(i-xs+1+top_i))*rhy
420:             d4 = (top_v(i-xs+1+top_i) - top_v(i-xs+top_i))*rhx
421:             ft = ft + sqrt(1.0d0 + d1*d1 + d4*d4)
422:          enddo
423:       endif


426:       if ((ys .eq. 0) .and. (xs .eq. 0)) then
427:          d1 = (left_v(0 + left_i) - left_v(1 + left_i)) * rhy
428:          d2 = (bottom_v(0+bottom_i)-bottom_v(1+bottom_i))*rhx
429:          ft = ft + sqrt(1.0d0 + d1*d1 + d2*d2)
430:       endif

432:       if ((ys + ym .eq. my) .and. (xs + xm .eq. mx)) then
433:          d1 = (right_v(ym+1+right_i) - right_v(ym+right_i))*rhy
434:          d2 = (top_v(xm+1+top_i) - top_v(xm + top_i))*rhx
435:          ft = ft + sqrt(1.0d0 + d1*d1 + d2*d2)
436:       endif

438:       ft = ft * area
439:       call MPI_Allreduce(ft,fcn,1,MPIU_SCALAR,                            &
440:      &             MPI_SUM,MPI_COMM_WORLD,ierr)



444: ! Restore vectors
445:       call VecRestoreArray(localX,x_v,x_i,ierr)
446:       call VecRestoreArray(localV,g_v,g_i,ierr)
447:       call VecRestoreArray(Left,left_v,left_i,ierr)
448:       call VecRestoreArray(Top,top_v,top_i,ierr)
449:       call VecRestoreArray(Bottom,bottom_v,bottom_i,ierr)
450:       call VecRestoreArray(Right,right_v,right_i,ierr)

452: ! Scatter values to global vector
453:       call DMLocalToGlobalBegin(dm,localV,INSERT_VALUES,G,ierr)
454:       call DMLocalToGlobalEnd(dm,localV,INSERT_VALUES,G,ierr)

456:       call PetscLogFlops(70.0d0*xm*ym,ierr)

458:       return
459:       end  !FormFunctionGradient





465: ! ----------------------------------------------------------------------------
466: !
467: !
468: !   FormHessian - Evaluates Hessian matrix.
469: !
470: !   Input Parameters:
471: !.  tao  - the Tao context
472: !.  X    - input vector
473: !.  dummy  - not used
474: !
475: !   Output Parameters:
476: !.  Hessian    - Hessian matrix
477: !.  Hpc    - optionally different preconditioning matrix
478: !.  flag - flag indicating matrix structure
479: !
480: !   Notes:
481: !   Due to mesh point reordering with DMs, we must always work
482: !   with the local mesh points, and then transform them to the new
483: !   global numbering with the local-to-global mapping.  We cannot work
484: !   directly with the global numbers for the original uniprocessor mesh!
485: !
486: !   Two methods are available for imposing this transformation
487: !   when setting matrix entries:
488: !     (A) MatSetValuesLocal(), using the local ordering (including
489: !         ghost points!)
490: !         - Do the following two steps once, before calling TaoSolve()
491: !           - Use DMDAGetISLocalToGlobalMapping() to extract the
492: !             local-to-global map from the DM
493: !           - Associate this map with the matrix by calling
494: !             MatSetLocalToGlobalMapping()
495: !         - Then set matrix entries using the local ordering
496: !           by calling MatSetValuesLocal()
497: !     (B) MatSetValues(), using the global ordering
498: !         - Use DMDAGetGlobalIndices() to extract the local-to-global map
499: !         - Then apply this map explicitly yourself
500: !         - Set matrix entries using the global ordering by calling
501: !           MatSetValues()
502: !   Option (A) seems cleaner/easier in many cases, and is the procedure
503: !   used in this example.

505:       subroutine FormHessian(tao, X, Hessian, Hpc, flg, dummy, ierr)
506:       implicit none

508: ! dm,Top,Left,Right,Bottom,mx,my,localX defined in plate2f.h
509: #include "plate2f.h"

511:       Tao     tao
512:       Vec            X
513:       Mat            Hessian,Hpc
514:       MatStructure   flg
515:       PetscInt       dummy
516:       PetscErrorCode ierr

518:       PetscInt       i,j,k,row
519:       PetscInt       xs,xm,gxs,gxm
520:       PetscInt       ys,ym,gys,gym
521:       PetscInt       col(0:6)
522:       PetscReal    hx,hy,hydhx,hxdhy,rhx,rhy
523:       PetscReal    f1,f2,f3,f4,f5,f6,d1,d2,d3
524:       PetscReal    d4,d5,d6,d7,d8
525:       PetscReal    xc,xl,xr,xt,xb,xlt,xrb
526:       PetscReal    hl,hr,ht,hb,hc,htl,hbr

528: ! PETSc's VecGetArray acts differently in Fortran than it does in C.
529: ! Calling VecGetArray((Vec) X, (PetscReal) x_array(0:1), (PetscOffset) x_index, ierr)
530: ! will return an array of doubles referenced by x_array offset by x_index.
531: !  i.e.,  to reference the kth element of X, use x_array(k + x_index).
532: ! Notice that by declaring the arrays with range (0:1), we are using the C 0-indexing practice.
533:       PetscReal   right_v(0:1),left_v(0:1)
534:       PetscReal   bottom_v(0:1),top_v(0:1)
535:       PetscReal   x_v(0:1)
536:       PetscOffset   x_i,right_i,left_i
537:       PetscOffset   bottom_i,top_i
538:       PetscReal   v(0:6)
539:       PetscBool     assembled
540:       PetscInt      i1

542:       i1=1

544: ! Set various matrix options
545:       call MatSetOption(Hessian,MAT_IGNORE_OFF_PROC_ENTRIES,              &
546:      &                  PETSC_TRUE,ierr)

548: ! Get local mesh boundaries
549:       call DMDAGetCorners(dm,xs,ys,PETSC_NULL_INTEGER,xm,ym,              &
550:      &                  PETSC_NULL_INTEGER,ierr)
551:       call DMDAGetGhostCorners(dm,gxs,gys,PETSC_NULL_INTEGER,gxm,gym,     &
552:      &                       PETSC_NULL_INTEGER,ierr)

554: ! Scatter ghost points to local vectors
555:       call DMGlobalToLocalBegin(dm,X,INSERT_VALUES,localX,ierr)
556:       call DMGlobalToLocalEnd(dm,X,INSERT_VALUES,localX,ierr)

558: ! Get pointers to vector data (see note on Fortran arrays above)
559:       call VecGetArray(localX,x_v,x_i,ierr)
560:       call VecGetArray(Top,top_v,top_i,ierr)
561:       call VecGetArray(Bottom,bottom_v,bottom_i,ierr)
562:       call VecGetArray(Left,left_v,left_i,ierr)
563:       call VecGetArray(Right,right_v,right_i,ierr)

565: ! Initialize matrix entries to zero
566:       call MatAssembled(Hessian,assembled,ierr)
567:       if (assembled .eqv. PETSC_TRUE) call MatZeroEntries(Hessian,ierr)


570:       rhx = mx + 1.0
571:       rhy = my + 1.0
572:       hx = 1.0/rhx
573:       hy = 1.0/rhy
574:       hydhx = hy/hx
575:       hxdhy = hx/hy
576: ! compute Hessian over the locally owned part of the mesh

578:       do  i=xs,xs+xm-1
579:          do  j=ys,ys+ym-1
580:             row = (j-gys)*gxm + (i-gxs)

582:             xc = x_v(row + x_i)
583:             xt = xc
584:             xb = xc
585:             xr = xc
586:             xl = xc
587:             xrb = xc
588:             xlt = xc

590:             if (i .eq. gxs) then   ! Left side
591:                xl = left_v(left_i + j - ys + 1)
592:                xlt = left_v(left_i + j - ys + 2)
593:             else
594:                xl = x_v(x_i + row -1 )
595:             endif

597:             if (j .eq. gys) then ! bottom side
598:                xb = bottom_v(bottom_i + i - xs + 1)
599:                xrb = bottom_v(bottom_i + i - xs + 2)
600:             else
601:                xb = x_v(x_i + row - gxm)
602:             endif

604:             if (i+1 .eq. gxs + gxm) then !right side
605:                xr = right_v(right_i + j - ys + 1)
606:                xrb = right_v(right_i + j - ys)
607:             else
608:                xr = x_v(x_i + row + 1)
609:             endif

611:             if (j+1 .eq. gym+gys) then !top side
612:                xt = top_v(top_i +i - xs + 1)
613:                xlt = top_v(top_i + i - xs)
614:             else
615:                xt = x_v(x_i + row + gxm)
616:             endif

618:             if ((i .gt. gxs) .and. (j+1 .lt. gys+gym)) then
619:                xlt = x_v(x_i + row - 1 + gxm)
620:             endif

622:             if ((i+1 .lt. gxs+gxm) .and. (j .gt. gys)) then
623:                xrb = x_v(x_i + row + 1 - gxm)
624:             endif

626:             d1 = (xc-xl)*rhx
627:             d2 = (xc-xr)*rhx
628:             d3 = (xc-xt)*rhy
629:             d4 = (xc-xb)*rhy
630:             d5 = (xrb-xr)*rhy
631:             d6 = (xrb-xb)*rhx
632:             d7 = (xlt-xl)*rhy
633:             d8 = (xlt-xt)*rhx

635:             f1 = sqrt( 1.0d0 + d1*d1 + d7*d7)
636:             f2 = sqrt( 1.0d0 + d1*d1 + d4*d4)
637:             f3 = sqrt( 1.0d0 + d3*d3 + d8*d8)
638:             f4 = sqrt( 1.0d0 + d3*d3 + d2*d2)
639:             f5 = sqrt( 1.0d0 + d2*d2 + d5*d5)
640:             f6 = sqrt( 1.0d0 + d4*d4 + d6*d6)


643:             hl = (-hydhx*(1.0+d7*d7)+d1*d7)/(f1*f1*f1)+                 &
644:      &              (-hydhx*(1.0+d4*d4)+d1*d4)/(f2*f2*f2)

646:             hr = (-hydhx*(1.0+d5*d5)+d2*d5)/(f5*f5*f5)+                 &
647:      &            (-hydhx*(1.0+d3*d3)+d2*d3)/(f4*f4*f4)

649:             ht = (-hxdhy*(1.0+d8*d8)+d3*d8)/(f3*f3*f3)+                 &
650:      &                (-hxdhy*(1.0+d2*d2)+d2*d3)/(f4*f4*f4)

652:             hb = (-hxdhy*(1.0+d6*d6)+d4*d6)/(f6*f6*f6)+                 &
653:      &              (-hxdhy*(1.0+d1*d1)+d1*d4)/(f2*f2*f2)

655:             hbr = -d2*d5/(f5*f5*f5) - d4*d6/(f6*f6*f6)
656:             htl = -d1*d7/(f1*f1*f1) - d3*d8/(f3*f3*f3)

658:             hc = hydhx*(1.0+d7*d7)/(f1*f1*f1) +                         &
659:      &              hxdhy*(1.0+d8*d8)/(f3*f3*f3) +                      &
660:      &              hydhx*(1.0+d5*d5)/(f5*f5*f5) +                      &
661:      &              hxdhy*(1.0+d6*d6)/(f6*f6*f6) +                      &
662:      &              (hxdhy*(1.0+d1*d1)+hydhx*(1.0+d4*d4)-               &
663:      &              2*d1*d4)/(f2*f2*f2) +  (hxdhy*(1.0+d2*d2)+          &
664:      &              hydhx*(1.0+d3*d3)-2*d2*d3)/(f4*f4*f4)

666:             hl = hl * 0.5
667:             hr = hr * 0.5
668:             ht = ht * 0.5
669:             hb = hb * 0.5
670:             hbr = hbr * 0.5
671:             htl = htl * 0.5
672:             hc = hc * 0.5

674:             k = 0

676:             if (j .gt. 0) then
677:                v(k) = hb
678:                col(k) = row - gxm
679:                k=k+1
680:             endif

682:             if ((j .gt. 0) .and. (i .lt. mx-1)) then
683:                v(k) = hbr
684:                col(k) = row-gxm+1
685:                k=k+1
686:             endif

688:             if (i .gt. 0) then
689:                v(k) = hl
690:                col(k) = row - 1
691:                k = k+1
692:             endif

694:             v(k) = hc
695:             col(k) = row
696:             k=k+1

698:             if (i .lt. mx-1) then
699:                v(k) = hr
700:                col(k) = row + 1
701:                k=k+1
702:             endif

704:             if ((i .gt. 0) .and. (j .lt. my-1)) then
705:                v(k) = htl
706:                col(k) = row + gxm - 1
707:                k=k+1
708:             endif

710:             if (j .lt. my-1) then
711:                v(k) = ht
712:                col(k) = row + gxm
713:                k=k+1
714:             endif

716: ! Set matrix values using local numbering, defined earlier in main routine
717:             call MatSetValuesLocal(Hessian,i1,row,k,col,v,INSERT_VALUES,      &
718:      &                              ierr)



722:          enddo
723:       enddo

725: ! restore vectors
726:       call VecRestoreArray(localX,x_v,x_i,ierr)
727:       call VecRestoreArray(Left,left_v,left_i,ierr)
728:       call VecRestoreArray(Right,right_v,right_i,ierr)
729:       call VecRestoreArray(Top,top_v,top_i,ierr)
730:       call VecRestoreArray(Bottom,bottom_v,bottom_i,ierr)


733: ! Assemble the matrix
734:       call MatAssemblyBegin(Hessian,MAT_FINAL_ASSEMBLY,ierr)
735:       call MatAssemblyEnd(Hessian,MAT_FINAL_ASSEMBLY,ierr)

737:       call PetscLogFlops(199.0d0*xm*ym,ierr)

739:       return
740:       end





746: ! Top,Left,Right,Bottom,bheight,mx,my,bmx,bmy,H, defined in plate2f.h

748: ! ----------------------------------------------------------------------------
749: !
750: !/*
751: !     MSA_BoundaryConditions - calculates the boundary conditions for the region
752: !
753: !
754: !*/

756:       subroutine MSA_BoundaryConditions(ierr)
757:       implicit none

759: ! Top,Left,Right,Bottom,bheight,mx,my,bmx,bmy defined in plate2f.h
760: #include "plate2f.h"

762:       PetscErrorCode   ierr
763:       PetscInt         i,j,k,limit,maxits
764:       PetscInt         xs, xm, gxs, gxm
765:       PetscInt         ys, ym, gys, gym
766:       PetscInt         bsize, lsize
767:       PetscInt         tsize, rsize
768:       PetscReal      one,two,three,tol
769:       PetscReal      scl,fnorm,det,xt
770:       PetscReal      yt,hx,hy,u1,u2,nf1,nf2
771:       PetscReal      njac11,njac12,njac21,njac22
772:       PetscReal      b, t, l, r
773:       PetscReal      boundary_v(0:1)
774:       PetscOffset      boundary_i
775:       logical exitloop
776:       PetscBool flg

778:       limit=0
779:       maxits = 5
780:       tol=1e-10
781:       b=-0.5d0
782:       t= 0.5d0
783:       l=-0.5d0
784:       r= 0.5d0
785:       xt=0
786:       yt=0
787:       one=1.0d0
788:       two=2.0d0
789:       three=3.0d0


792:       call DMDAGetCorners(dm,xs,ys,PETSC_NULL_INTEGER,xm,ym,               &
793:      &                  PETSC_NULL_INTEGER,ierr)
794:       call DMDAGetGhostCorners(dm,gxs,gys,PETSC_NULL_INTEGER,              &
795:      &                       gxm,gym,PETSC_NULL_INTEGER,ierr)

797:       bsize = xm + 2
798:       lsize = ym + 2
799:       rsize = ym + 2
800:       tsize = xm + 2


803:       call VecCreateMPI(MPI_COMM_WORLD,bsize,PETSC_DECIDE,Bottom,ierr)
804:       call VecCreateMPI(MPI_COMM_WORLD,tsize,PETSC_DECIDE,Top,ierr)
805:       call VecCreateMPI(MPI_COMM_WORLD,lsize,PETSC_DECIDE,Left,ierr)
806:       call VecCreateMPI(MPI_COMM_WORLD,rsize,PETSC_DECIDE,Right,ierr)

808:       hx= (r-l)/(mx+1)
809:       hy= (t-b)/(my+1)

811:       do j=0,3

813:          if (j.eq.0) then
814:             yt=b
815:             xt=l+hx*xs
816:             limit=bsize
817:             call VecGetArray(Bottom,boundary_v,boundary_i,ierr)


820:          elseif (j.eq.1) then
821:             yt=t
822:             xt=l+hx*xs
823:             limit=tsize
824:             call VecGetArray(Top,boundary_v,boundary_i,ierr)

826:          elseif (j.eq.2) then
827:             yt=b+hy*ys
828:             xt=l
829:             limit=lsize
830:             call VecGetArray(Left,boundary_v,boundary_i,ierr)

832:          elseif (j.eq.3) then
833:             yt=b+hy*ys
834:             xt=r
835:             limit=rsize
836:             call VecGetArray(Right,boundary_v,boundary_i,ierr)
837:          endif


840:          do i=0,limit-1

842:             u1=xt
843:             u2=-yt
844:             k = 0
845:             exitloop = .false.
846:             do while (k .lt. maxits .and. (.not. exitloop) )

848:                nf1=u1 + u1*u2*u2 - u1*u1*u1/three-xt
849:                nf2=-u2 - u1*u1*u2 + u2*u2*u2/three-yt
850:                fnorm=sqrt(nf1*nf1+nf2*nf2)
851:                if (fnorm .gt. tol) then
852:                   njac11=one+u2*u2-u1*u1
853:                   njac12=two*u1*u2
854:                   njac21=-two*u1*u2
855:                   njac22=-one - u1*u1 + u2*u2
856:                   det = njac11*njac22-njac21*njac12
857:                   u1 = u1-(njac22*nf1-njac12*nf2)/det
858:                   u2 = u2-(njac11*nf2-njac21*nf1)/det
859:                else
860:                   exitloop = .true.
861:                endif
862:                k=k+1
863:             enddo

865:             boundary_v(i + boundary_i) = u1*u1-u2*u2
866:             if ((j .eq. 0) .or. (j .eq. 1)) then
867:                xt = xt + hx
868:             else
869:                yt = yt + hy
870:             endif

872:          enddo


875:          if (j.eq.0) then
876:             call VecRestoreArray(Bottom,boundary_v,boundary_i,ierr)
877:          elseif (j.eq.1) then
878:             call VecRestoreArray(Top,boundary_v,boundary_i,ierr)
879:          elseif (j.eq.2) then
880:             call VecRestoreArray(Left,boundary_v,boundary_i,ierr)
881:          elseif (j.eq.3) then
882:             call VecRestoreArray(Right,boundary_v,boundary_i,ierr)
883:          endif

885:       enddo


888: ! Scale the boundary if desired
889:       call PetscOptionsGetReal(PETSC_NULL_CHARACTER,"-bottom",            &
890:      &                         scl,flg,ierr)
891:       if (flg .eqv. PETSC_TRUE) then
892:          call VecScale(scl,Bottom,ierr)
893:       endif

895:       call PetscOptionsGetReal(PETSC_NULL_CHARACTER,"-top",               &
896:      &                         scl,flg,ierr)
897:       if (flg .eqv. PETSC_TRUE) then
898:          call VecScale(scl,Top,ierr)
899:       endif

901:       call PetscOptionsGetReal(PETSC_NULL_CHARACTER,"-right",             &
902:      &                         scl,flg,ierr)
903:       if (flg .eqv. PETSC_TRUE) then
904:          call VecScale(scl,Right,ierr)
905:       endif

907:       call PetscOptionsGetReal(PETSC_NULL_CHARACTER,"-left",              &
908:      &                         scl,flg,ierr)
909:       if (flg .eqv. PETSC_TRUE) then
910:          call VecScale(scl,Left,ierr)
911:       endif


914:       return
915:       end

917: ! ----------------------------------------------------------------------------
918: !
919: !/*
920: !     MSA_Plate - Calculates an obstacle for surface to stretch over
921: !
922: !     Output Parameter:
923: !.    xl - lower bound vector
924: !.    xu - upper bound vector
925: !
926: !*/

928:       subroutine MSA_Plate(tao,xl,xu,dummy,ierr)
929:       implicit none
930: ! mx,my,bmx,bmy,dm,bheight defined in plate2f.h
931: #include "plate2f.h"
932:       Tao        tao
933:       Vec              xl,xu
934:       PetscErrorCode   ierr
935:       PetscInt         i,j,row
936:       PetscInt         xs, xm, ys, ym
937:       PetscReal      lb,ub
938:       PetscInt         dummy

940: ! PETSc's VecGetArray acts differently in Fortran than it does in C.
941: ! Calling VecGetArray((Vec) X, (PetscReal) x_array(0:1), (PetscOffset) x_index, ierr)
942: ! will return an array of doubles referenced by x_array offset by x_index.
943: !  i.e.,  to reference the kth element of X, use x_array(k + x_index).
944: ! Notice that by declaring the arrays with range (0:1), we are using the C 0-indexing practice.
945:       PetscReal      xl_v(0:1)
946:       PetscOffset      xl_i

948:       print *,'msa_plate'

950:       lb = -1.0d300
951:       ub = 1.0d300

953:       if (bmy .lt. 0) bmy = 0
954:       if (bmy .gt. my) bmy = my
955:       if (bmx .lt. 0) bmx = 0
956:       if (bmx .gt. mx) bmx = mx


959:       call DMDAGetCorners(dm,xs,ys,PETSC_NULL_INTEGER,xm,ym,               &
960:      &             PETSC_NULL_INTEGER,ierr)

962:       call VecSet(xl,lb,ierr)
963:       call VecSet(xu,ub,ierr)

965:       call VecGetArray(xl,xl_v,xl_i,ierr)


968:       do i=xs,xs+xm-1

970:          do j=ys,ys+ym-1

972:             row=(j-ys)*xm + (i-xs)

974:             if (i.ge.((mx-bmx)/2) .and. i.lt.(mx-(mx-bmx)/2) .and.           &
975:      &          j.ge.((my-bmy)/2) .and. j.lt.(my-(my-bmy)/2)) then
976:                xl_v(xl_i+row) = bheight

978:             endif

980:          enddo
981:       enddo


984:       call VecRestoreArray(xl,xl_v,xl_i,ierr)

986:       return
987:       end





993: ! ----------------------------------------------------------------------------
994: !
995: !/*
996: !     MSA_InitialPoint - Calculates an obstacle for surface to stretch over
997: !
998: !     Output Parameter:
999: !.    X - vector for initial guess
1000: !
1001: !*/

1003:       subroutine MSA_InitialPoint(X, ierr)
1004:       implicit none

1006: ! mx,my,localX,dm,Top,Left,Bottom,Right defined in plate2f.h
1007: #include "plate2f.h"
1008:       Vec               X
1009:       PetscErrorCode    ierr
1010:       PetscInt          start,i,j
1011:       PetscInt          row
1012:       PetscInt          xs,xm,gxs,gxm
1013:       PetscInt          ys,ym,gys,gym
1014:       PetscReal       zero, np5

1016: ! PETSc's VecGetArray acts differently in Fortran than it does in C.
1017: ! Calling VecGetArray((Vec) X, (PetscReal) x_array(0:1), (integer) x_index, ierr)
1018: ! will return an array of doubles referenced by x_array offset by x_index.
1019: !  i.e.,  to reference the kth element of X, use x_array(k + x_index).
1020: ! Notice that by declaring the arrays with range (0:1), we are using the C 0-indexing practice.
1021:       PetscReal   left_v(0:1),right_v(0:1)
1022:       PetscReal   bottom_v(0:1),top_v(0:1)
1023:       PetscReal   x_v(0:1)
1024:       PetscOffset   left_i, right_i, top_i
1025:       PetscOffset   bottom_i,x_i
1026:       PetscBool     flg
1027:       PetscRandom   rctx

1029:       zero = 0.0d0
1030:       np5 = -0.5d0

1032:       call PetscOptionsGetInt(PETSC_NULL_CHARACTER,"-start",            &
1033:      &                        start,flg,ierr)

1035:       if ((flg .eqv. PETSC_TRUE) .and. (start .eq. 0)) then  ! the zero vector is reasonable
1036:          call VecSet(X,zero,ierr)

1038:       elseif ((flg .eqv. PETSC_TRUE) .and. (start .gt. 0)) then  ! random start -0.5 < xi < 0.5
1039:          call PetscRandomCreate(MPI_COMM_WORLD,rctx,ierr)
1040:          do i=0,start-1
1041:             call VecSetRandom(X,rctx,ierr)
1042:          enddo

1044:          call PetscRandomDestroy(rctx,ierr)
1045:          call VecShift(X,np5,ierr)

1047:       else   ! average of boundary conditions

1049: !        Get Local mesh boundaries
1050:          call DMDAGetCorners(dm,xs,ys,PETSC_NULL_INTEGER,xm,ym,             &
1051:      &                     PETSC_NULL_INTEGER,ierr)
1052:          call DMDAGetGhostCorners(dm,gxs,gys,PETSC_NULL_INTEGER,gxm,gym,    &
1053:      &                     PETSC_NULL_INTEGER,ierr)



1057: !        Get pointers to vector data
1058:          call VecGetArray(Top,top_v,top_i,ierr)
1059:          call VecGetArray(Bottom,bottom_v,bottom_i,ierr)
1060:          call VecGetArray(Left,left_v,left_i,ierr)
1061:          call VecGetArray(Right,right_v,right_i,ierr)

1063:          call VecGetArray(localX,x_v,x_i,ierr)

1065: !        Perform local computations
1066:          do  j=ys,ys+ym-1
1067:             do i=xs,xs+xm-1
1068:                row = (j-gys)*gxm  + (i-gxs)
1069:                x_v(x_i + row) = ((j+1)*bottom_v(bottom_i +i-xs+1)/my        &
1070:      &             + (my-j+1)*top_v(top_i+i-xs+1)/(my+2) +                  &
1071:      &              (i+1)*left_v(left_i+j-ys+1)/mx       +                  &
1072:      &              (mx-i+1)*right_v(right_i+j-ys+1)/(mx+2))*0.5
1073:             enddo
1074:          enddo

1076: !        Restore vectors
1077:          call VecRestoreArray(localX,x_v,x_i,ierr)

1079:          call VecRestoreArray(Left,left_v,left_i,ierr)
1080:          call VecRestoreArray(Top,top_v,top_i,ierr)
1081:          call VecRestoreArray(Bottom,bottom_v,bottom_i,ierr)
1082:          call VecRestoreArray(Right,right_v,right_i,ierr)

1084:          call DMLocalToGlobalBegin(dm,localX,INSERT_VALUES,X,ierr)
1085:          call DMLocalToGlobalEnd(dm,localX,INSERT_VALUES,X,ierr)

1087:       endif

1089:       return
1090:       end