1: !
  2: ! Example usage of Fortran 2003/2008 classes (extended derived types) as
  3: ! user-defined contexts in PETSc. Example contributed by Glenn Hammond.
  4: !
  5: #include "petsc/finclude/petscsnes.h"
  6: module ex18f90base_module
  7:   use petscsnes
  8:   implicit none
  9:   private

 11:   type, public :: base_type
 12:     PetscInt :: A  ! junk
 13:     PetscReal :: I ! junk
 14:   contains
 15:     procedure, public :: print => BasePrint
 16:   end type base_type
 17: contains
 18:   subroutine BasePrint(this)
 19:     class(base_type) :: this
 20:     print *
 21:     print *, 'Base printout'
 22:     print *
 23:   end subroutine BasePrint
 24: end module ex18f90base_module

 26: module ex18f90extended_module
 27:   use ex18f90base_module
 28:   use petscsys
 29:   implicit none
 30:   private
 31:   type, public, extends(base_type) :: extended_type
 32:     PetscInt :: B  ! junk
 33:     PetscReal :: J ! junk
 34:   contains
 35:     procedure, public :: print => ExtendedPrint
 36:   end type extended_type
 37: contains
 38:   subroutine ExtendedPrint(this)
 39:     class(extended_type) :: this
 40:     print *
 41:     print *, 'Extended printout'
 42:     print *
 43:   end subroutine ExtendedPrint
 44: end module ex18f90extended_module

 46: module ex18f90function_module
 47:   use petscsnes
 48:   use ex18f90base_module
 49:   implicit none
 50:   public :: TestFunction
 51: contains
 52:   subroutine TestFunction(snes, xx, r, ctx, ierr)
 53:     SNES :: snes
 54:     Vec :: xx
 55:     Vec :: r
 56:     class(base_type) :: ctx ! yes, this should be base_type in order to handle all
 57:     PetscErrorCode :: ierr  ! polymorphic extensions
 58:     call ctx%print()
 59:   end subroutine TestFunction
 60: end module ex18f90function_module

 62: program ex18f90

 64:   use ex18f90base_module
 65:   use ex18f90extended_module
 66:   use ex18f90function_module
 67:   implicit none

 69: !
 70: ! Since class(base_type) has a bound function (method), Print, one must
 71: ! provide an interface definition as below and use SNESSetFunctionNoInterface()
 72: ! instead of SNESSetFunction()
 73: !
 74:   interface
 75:     subroutine SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr)
 76:       use ex18f90base_module
 77:       use petscsnes
 78:       SNES snes_base
 79:       Vec x
 80:       external TestFunction
 81:       class(base_type) :: base
 82:       PetscErrorCode ierr
 83:     end subroutine
 84:   end interface

 86:   PetscMPIInt :: size
 87:   PetscMPIInt :: rank

 89:   SNES :: snes_base, snes_extended
 90:   Vec :: x
 91:   class(base_type), pointer :: base
 92:   class(extended_type), pointer :: extended
 93:   PetscErrorCode :: ierr

 95:   print *, 'Start of Fortran2003 test program'

 97:   nullify (base)
 98:   nullify (extended)
 99:   allocate (base)
100:   allocate (extended)
101:   PetscCallA(PetscInitialize(ierr))
102:   PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr))
103:   PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr))

105:   PetscCallA(VecCreate(PETSC_COMM_WORLD, x, ierr))

107:   ! use the base class as the context
108:   print *
109:   print *, 'the base class will succeed by printing out Base printout below'
110:   PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_base, ierr))
111:   PetscCallA(SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr))
112:   PetscCallA(SNESComputeFunction(snes_base, x, x, ierr))
113:   PetscCallA(SNESDestroy(snes_base, ierr))

115:   ! use the extended class as the context
116:   print *, 'the extended class will succeed by printing out Extended printout below'
117:   PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_extended, ierr))
118:   PetscCallA(SNESSetFunctionNoInterface(snes_extended, x, TestFunction, extended, ierr))
119:   PetscCallA(SNESComputeFunction(snes_extended, x, x, ierr))
120:   PetscCallA(VecDestroy(x, ierr))
121:   PetscCallA(SNESDestroy(snes_extended, ierr))
122:   if (associated(base)) deallocate (base)
123:   if (associated(extended)) deallocate (extended)
124:   PetscCallA(PetscFinalize(ierr))

126:   print *, 'End of Fortran2003 test program'
127: end program ex18f90

129: !/*TEST
130: !
131: !   test:
132: !     requires: !pgf90_compiler
133: !
134: !TEST*/