Actual source code: ex18f90.F90

petsc-3.13.4 2020-08-01
Report Typos and Errors
  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 Base_module
  6: #include "petsc/finclude/petscsnes.h"
  7:       implicit none
  8:   private

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

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

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

 63: program ex18f90

 65:   use Base_module
 66:   use Extended_module
 67:   use Function_module
 68:   implicit none

 70: ! ifort on windows requires this interface definition
 71: interface
 72:   subroutine SNESSetFunction(snes_base,x,TestFunction,base,ierr)
 73:     use Base_module
 74:     use petscsnes  
 75:     SNES snes_base
 76:     Vec x
 77:     external TestFunction
 78:     class(base_type) :: base
 79:     PetscErrorCode ierr
 80:   end subroutine
 81: end interface

 83:   PetscMPIInt :: size
 84:   PetscMPIInt :: rank

 86:   SNES :: snes_base, snes_extended
 87:   Vec :: x
 88:   class(base_type), pointer :: base
 89:   class(extended_type), pointer :: extended
 90:   PetscErrorCode :: ierr

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

 94:   nullify(base)
 95:   nullify(extended)
 96:   allocate(base)
 97:   allocate(extended)
 98:   call PetscInitialize(PETSC_NULL_CHARACTER, ierr)
 99:   if (ierr .ne. 0) then
100:     print*,'Unable to initialize PETSc'
101:     stop
102:   endif
103:   call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr);CHKERRA(ierr)
104:   call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr);CHKERRA(ierr)

106:   call VecCreate(PETSC_COMM_WORLD,x,ierr);CHKERRA(ierr)

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

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

127:   print *, 'End of Fortran2003 test program'

129: end program ex18f90

131: !/*TEST
132: !
133: !   build:
134: !      requires: define(PETSC_USING_F2003) define(PETSC_USING_F90FREEFORM)
135: !   test:
136: !     requires: !pgf90_compiler
137: !
138: !TEST*/