1c4762a1bSJed Brown! 2c4762a1bSJed Brown! Example usage of Fortran 2003/2008 classes (extended derived types) as 3c4762a1bSJed Brown! user-defined contexts in PETSc. Example contributed by Glenn Hammond. 4c4762a1bSJed Brown! 5c4762a1bSJed Brownmodule Base_module 6c4762a1bSJed Brown#include "petsc/finclude/petscsnes.h" 7c4762a1bSJed Brown implicit none 8c4762a1bSJed Brown private 9c4762a1bSJed Brown 10c4762a1bSJed Brown type, public :: base_type 11c4762a1bSJed Brown PetscInt :: A ! junk 12c4762a1bSJed Brown PetscReal :: I ! junk 13c4762a1bSJed Brown contains 14c4762a1bSJed Brown procedure, public :: Print => BasePrint 15c4762a1bSJed Brown end type base_type 16c4762a1bSJed Browncontains 17c4762a1bSJed Brownsubroutine BasePrint(this) 18c4762a1bSJed Brown implicit none 19c4762a1bSJed Brown class(base_type) :: this 20c4762a1bSJed Brown print * 21c4762a1bSJed Brown print *, 'Base printout' 22c4762a1bSJed Brown print * 23c4762a1bSJed Brownend subroutine BasePrint 24c4762a1bSJed Brownend module Base_module 25c4762a1bSJed Brown 26c4762a1bSJed Brownmodule Extended_module 27c4762a1bSJed Brown use Base_module 28c4762a1bSJed Brown implicit none 29c4762a1bSJed Brown private 30c4762a1bSJed Brown type, public, extends(base_type) :: extended_type 31c4762a1bSJed Brown PetscInt :: B ! junk 32c4762a1bSJed Brown PetscReal :: J ! junk 33c4762a1bSJed Brown contains 34c4762a1bSJed Brown procedure, public :: Print => ExtendedPrint 35c4762a1bSJed Brown end type extended_type 36c4762a1bSJed Browncontains 37c4762a1bSJed Brownsubroutine ExtendedPrint(this) 38c4762a1bSJed Brown implicit none 39c4762a1bSJed Brown class(extended_type) :: this 40c4762a1bSJed Brown print * 41c4762a1bSJed Brown print *, 'Extended printout' 42c4762a1bSJed Brown print * 43c4762a1bSJed Brownend subroutine ExtendedPrint 44c4762a1bSJed Brownend module Extended_module 45c4762a1bSJed Brown 46c4762a1bSJed Brownmodule Function_module 47c4762a1bSJed Brown use petscsnes 48c4762a1bSJed Brown implicit none 49c4762a1bSJed Brown public :: TestFunction 50c4762a1bSJed Brown contains 51c4762a1bSJed Brownsubroutine TestFunction(snes,xx,r,ctx,ierr) 52c4762a1bSJed Brown use Base_module 53c4762a1bSJed Brown implicit none 54c4762a1bSJed Brown SNES :: snes 55c4762a1bSJed Brown Vec :: xx 56c4762a1bSJed Brown Vec :: r 57c4762a1bSJed Brown class(base_type) :: ctx ! yes, this should be base_type in order to handle all 58c4762a1bSJed Brown PetscErrorCode :: ierr ! polymorphic extensions 59c4762a1bSJed Brown call ctx%Print() 60c4762a1bSJed Brownend subroutine TestFunction 61c4762a1bSJed Brownend module Function_module 62c4762a1bSJed Brown 63c4762a1bSJed Brownprogram ex18f90 64c4762a1bSJed Brown 65c4762a1bSJed Brown use Base_module 66c4762a1bSJed Brown use Extended_module 67c4762a1bSJed Brown use Function_module 68c4762a1bSJed Brown implicit none 69c4762a1bSJed Brown 70c4762a1bSJed Brown! ifort on windows requires this interface definition 71c4762a1bSJed Browninterface 72c4762a1bSJed Brown subroutine SNESSetFunction(snes_base,x,TestFunction,base,ierr) 73c4762a1bSJed Brown use Base_module 74c4762a1bSJed Brown use petscsnes 75c4762a1bSJed Brown SNES snes_base 76c4762a1bSJed Brown Vec x 77c4762a1bSJed Brown external TestFunction 78c4762a1bSJed Brown class(base_type) :: base 79c4762a1bSJed Brown PetscErrorCode ierr 80c4762a1bSJed Brown end subroutine 81c4762a1bSJed Brownend interface 82c4762a1bSJed Brown 83c4762a1bSJed Brown PetscMPIInt :: size 84c4762a1bSJed Brown PetscMPIInt :: rank 85c4762a1bSJed Brown 86c4762a1bSJed Brown SNES :: snes_base, snes_extended 87c4762a1bSJed Brown Vec :: x 88c4762a1bSJed Brown class(base_type), pointer :: base 89c4762a1bSJed Brown class(extended_type), pointer :: extended 90c4762a1bSJed Brown PetscErrorCode :: ierr 91c4762a1bSJed Brown 92c4762a1bSJed Brown print *, 'Start of Fortran2003 test program' 93c4762a1bSJed Brown 94c4762a1bSJed Brown nullify(base) 95c4762a1bSJed Brown nullify(extended) 96c4762a1bSJed Brown allocate(base) 97c4762a1bSJed Brown allocate(extended) 98c4762a1bSJed Brown call PetscInitialize(PETSC_NULL_CHARACTER, ierr) 99c4762a1bSJed Brown if (ierr .ne. 0) then 100c4762a1bSJed Brown print*,'Unable to initialize PETSc' 101c4762a1bSJed Brown stop 102c4762a1bSJed Brown endif 103c4762a1bSJed Brown call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr);CHKERRA(ierr) 104c4762a1bSJed Brown call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr);CHKERRA(ierr) 105c4762a1bSJed Brown 106c4762a1bSJed Brown call VecCreate(PETSC_COMM_WORLD,x,ierr);CHKERRA(ierr) 107c4762a1bSJed Brown 108c4762a1bSJed Brown ! use the base class as the context 109c4762a1bSJed Brown print * 110c4762a1bSJed Brown print *, 'the base class will succeed by printing out Base printout below' 111c4762a1bSJed Brown call SNESCreate(PETSC_COMM_WORLD,snes_base,ierr);CHKERRA(ierr) 112c4762a1bSJed Brown call SNESSetFunction(snes_base,x,TestFunction,base,ierr);CHKERRA(ierr) 113c4762a1bSJed Brown call SNESComputeFunction(snes_base,x,x,ierr);CHKERRA(ierr) 114c4762a1bSJed Brown call SNESDestroy(snes_base,ierr);CHKERRA(ierr) 115c4762a1bSJed Brown 116c4762a1bSJed Brown ! use the extended class as the context 117c4762a1bSJed Brown print *, 'the extended class will succeed by printing out Extended printout below' 118c4762a1bSJed Brown call SNESCreate(PETSC_COMM_WORLD,snes_extended,ierr);CHKERRA(ierr) 119c4762a1bSJed Brown call SNESSetFunction(snes_extended,x,TestFunction,extended,ierr);CHKERRA(ierr) 120c4762a1bSJed Brown call SNESComputeFunction(snes_extended,x,x,ierr);CHKERRA(ierr) 121c4762a1bSJed Brown call VecDestroy(x,ierr);CHKERRA(ierr) 122c4762a1bSJed Brown call SNESDestroy(snes_extended,ierr);CHKERRA(ierr) 123c4762a1bSJed Brown if (associated(base)) deallocate(base) 124c4762a1bSJed Brown if (associated(extended)) deallocate(extended) 125c4762a1bSJed Brown call PetscFinalize(ierr) 126c4762a1bSJed Brown 127c4762a1bSJed Brown print *, 'End of Fortran2003 test program' 128c4762a1bSJed Brown 129c4762a1bSJed Brownend program ex18f90 130c4762a1bSJed Brown 131c4762a1bSJed Brown!/*TEST 132c4762a1bSJed Brown! 133c4762a1bSJed Brown! build: 134*dfd57a17SPierre Jolivet! requires: defined(PETSC_USING_F2003) defined(PETSC_USING_F90FREEFORM) 135c4762a1bSJed Brown! test: 136c4762a1bSJed Brown! requires: !pgf90_compiler 137c4762a1bSJed Brown! 138c4762a1bSJed Brown!TEST*/ 139