Actual source code: ex12f.F
petsc-3.4.2 2013-07-02

      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  = comm  - MPI communictor
     13: !          5  = unused
     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 <finclude/petscsys.h>
     29: #include <finclude/petscvec.h>
     30: #include <finclude/petscdmda.h>
     31: #include <finclude/petscmat.h>
     32: #include <finclude/petscsnes.h>

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

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

     57:       call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
     58:       call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)

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

     64:       call DMCreateGlobalVector(ctx(1),x,ierr)
     65:       call DMCreateLocalVector(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 MatCreateAIJ(PETSC_COMM_WORLD,PETSC_DECIDE,PETSC_DECIDE,N,           &
     74:      &     N,i3,PETSC_NULL_INTEGER,i0,PETSC_NULL_INTEGER,J,ierr)
     75:       call MatSetOption(J,MAT_NEW_NONZERO_LOCATION_ERR,PETSC_FALSE,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 SNES 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 DMDestroy(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 <finclude/petscsys.h>
    142: #include <finclude/petscvec.h>
    143: #include <finclude/petscdmda.h>
    144: #include <finclude/petscmat.h>
    145: #include <finclude/petscsnes.h>

    148:       call MPI_Comm_rank(ctx(4),rank,ierr)
    149:       call MPI_Comm_size(ctx(4),size,ierr)
    150:       h     = 1.d0/(ctx(6) - 1.d0)
    151:       call DMGlobalToLocalBegin(ctx(1),x,INSERT_VALUES,ctx(3),ierr)
    152:       call DMGlobalToLocalEnd(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 <finclude/petscsys.h>
    214: #include <finclude/petscvec.h>
    215: #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 <finclude/petscsys.h>
    231: #include <finclude/petscvec.h>
    232: #include <finclude/petscdmda.h>
    233: #include <finclude/petscmat.h>
    234: #include <finclude/petscsnes.h>
    235:       SNES             snes
    236:       Vec              x
    237:       Mat              jac,B
    238:       PetscFortranAddr ctx(*)
    239:       PetscBool        flag
    240:       PetscInt  ii,istart,iend
    241:       PetscInt  i,j,n,end,start,i1
    242:       PetscErrorCode ierr
    243:       PetscMPIInt rank,size
    244:       PetscOffset      ixx
    245:       PetscScalar      d,A,h,vxx(1)

    247:       i1 = 1
    248:       h = 1.d0/(ctx(6) - 1.d0)
    249:       d = h*h
    250:       call MPI_Comm_rank(ctx(4),rank,ierr)
    251:       call MPI_Comm_size(ctx(4),size,ierr)

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

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