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: module ex18f90base_module
  6: #include <petsc/finclude/petscsys.h>
  7: #include "petsc/finclude/petscsnes.h"
  8:   use PetscSys
  9:   use PetscSnes
 10:   implicit none
 11:   private

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

 29: module ex18f90extended_module
 30:   use ex18f90base_module
 31: #include <petsc/finclude/petscsys.h>
 32:   use PetscSys
 33:   implicit none
 34:   private
 35:   type, public, extends(base_type) :: extended_type
 36:     PetscInt :: B  ! junk
 37:     PetscReal :: J ! junk
 38:   contains
 39:     procedure, public :: Print => ExtendedPrint
 40:   end type extended_type
 41: contains
 42:   subroutine ExtendedPrint(this)
 43:     implicit none
 44:     class(extended_type) :: this
 45:     print *
 46:     print *, 'Extended printout'
 47:     print *
 48:   end subroutine ExtendedPrint
 49: end module ex18f90extended_module

 51: module ex18f90function_module
 52:   use petscsnes
 53:   implicit none
 54:   public :: TestFunction
 55: contains
 56:   subroutine TestFunction(snes, xx, r, ctx, ierr)
 57:     use ex18f90base_module
 58:     implicit none
 59:     SNES :: snes
 60:     Vec :: xx
 61:     Vec :: r
 62:     class(base_type) :: ctx ! yes, this should be base_type in order to handle all
 63:     PetscErrorCode :: ierr  ! polymorphic extensions
 64:     call ctx%Print()
 65:   end subroutine TestFunction
 66: end module ex18f90function_module

 68: program ex18f90

 70:   use ex18f90base_module
 71:   use ex18f90extended_module
 72:   use ex18f90function_module
 73:   implicit none

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

 92:   PetscMPIInt :: size
 93:   PetscMPIInt :: rank

 95:   SNES :: snes_base, snes_extended
 96:   Vec :: x
 97:   class(base_type), pointer :: base
 98:   class(extended_type), pointer :: extended
 99:   PetscErrorCode :: ierr

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

103:   nullify (base)
104:   nullify (extended)
105:   allocate (base)
106:   allocate (extended)
107:   PetscCallA(PetscInitialize(ierr))
108:   PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr))
109:   PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr))

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

113:   ! use the base class as the context
114:   print *
115:   print *, 'the base class will succeed by printing out Base printout below'
116:   PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_base, ierr))
117:   PetscCallA(SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr))
118:   PetscCallA(SNESComputeFunction(snes_base, x, x, ierr))
119:   PetscCallA(SNESDestroy(snes_base, ierr))

121:   ! use the extended class as the context
122:   print *, 'the extended class will succeed by printing out Extended printout below'
123:   PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_extended, ierr))
124:   PetscCallA(SNESSetFunctionNoInterface(snes_extended, x, TestFunction, extended, ierr))
125:   PetscCallA(SNESComputeFunction(snes_extended, x, x, ierr))
126:   PetscCallA(VecDestroy(x, ierr))
127:   PetscCallA(SNESDestroy(snes_extended, ierr))
128:   if (associated(base)) deallocate (base)
129:   if (associated(extended)) deallocate (extended)
130:   PetscCallA(PetscFinalize(ierr))

132:   print *, 'End of Fortran2003 test program'
133: end program ex18f90

135: !/*TEST
136: !
137: !   build:
138: !      requires: defined(PETSC_USING_F2003) defined(PETSC_USING_F90FREEFORM)
139: !   test:
140: !     requires: !pgf90_compiler
141: !
142: !TEST*/