Actual source code: ex18f90.F90

petsc-3.12.0 2019-09-29
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

  7: #include "petsc/finclude/petscsnes.h"
  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:   implicit none
 20:   class(base_type) :: this
 21:   print *
 22:   print *, 'Base printout'
 23:   print *
 24: end subroutine BasePrint
 25: end module Base_module

 27: module Extended_module
 28:   use Base_module
 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:   implicit none
 40:   class(extended_type) :: this
 41:   print *
 42:   print *, 'Extended printout'
 43:   print *
 44: end subroutine ExtendedPrint
 45: end module Extended_module

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

 64: program ex18f90

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

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

 84:   PetscMPIInt :: size
 85:   PetscMPIInt :: rank

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

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

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

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

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

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

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

130: end program ex18f90

132: !/*TEST
133: !
134: !   test:
135: !     requires: !pgf90_compiler
136: !
137: !TEST*/