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! 5module ex18f90base_module 6#include "petsc/finclude/petscsnes.h" 7 implicit none 8 private 9 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 16contains 17subroutine BasePrint(this) 18 implicit none 19 class(base_type) :: this 20 print * 21 print *, 'Base printout' 22 print * 23end subroutine BasePrint 24end module ex18f90base_module 25 26module ex18f90extended_module 27 use ex18f90base_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 36contains 37subroutine ExtendedPrint(this) 38 implicit none 39 class(extended_type) :: this 40 print * 41 print *, 'Extended printout' 42 print * 43end subroutine ExtendedPrint 44end module ex18f90extended_module 45 46module ex18f90function_module 47 use petscsnes 48 implicit none 49 public :: TestFunction 50 contains 51subroutine TestFunction(snes,xx,r,ctx,ierr) 52 use ex18f90base_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() 60end subroutine TestFunction 61end module ex18f90function_module 62 63program ex18f90 64 65 use ex18f90base_module 66 use ex18f90extended_module 67 use ex18f90function_module 68 implicit none 69 70! 71! Since class(base_type) has a bound function (method), Print, one must 72! provide an interface definition as below and use SNESSetFunctionNoInterface() 73! instead of SNESSetFunction() 74! 75 interface 76 subroutine SNESSetFunctionNoInterface(snes_base,x,TestFunction,base,ierr) 77 use ex18f90base_module 78 use petscsnes 79 SNES snes_base 80 Vec x 81 external TestFunction 82 class(base_type) :: base 83 PetscErrorCode ierr 84 end subroutine 85 end interface 86 87 PetscMPIInt :: size 88 PetscMPIInt :: rank 89 90 SNES :: snes_base, snes_extended 91 Vec :: x 92 class(base_type), pointer :: base 93 class(extended_type), pointer :: extended 94 PetscErrorCode :: ierr 95 96 print *, 'Start of Fortran2003 test program' 97 98 nullify(base) 99 nullify(extended) 100 allocate(base) 101 allocate(extended) 102 PetscCallA(PetscInitialize(ierr)) 103 PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)) 104 PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)) 105 106 PetscCallA(VecCreate(PETSC_COMM_WORLD,x,ierr)) 107 108 ! use the base class as the context 109 print * 110 print *, 'the base class will succeed by printing out Base printout below' 111 PetscCallA(SNESCreate(PETSC_COMM_WORLD,snes_base,ierr)) 112 PetscCallA(SNESSetFunctionNoInterface(snes_base,x,TestFunction,base,ierr)) 113 PetscCallA(SNESComputeFunction(snes_base,x,x,ierr)) 114 PetscCallA(SNESDestroy(snes_base,ierr)) 115 116 ! use the extended class as the context 117 print *, 'the extended class will succeed by printing out Extended printout below' 118 PetscCallA(SNESCreate(PETSC_COMM_WORLD,snes_extended,ierr)) 119 PetscCallA(SNESSetFunctionNoInterface(snes_extended,x,TestFunction,extended,ierr)) 120 PetscCallA(SNESComputeFunction(snes_extended,x,x,ierr)) 121 PetscCallA(VecDestroy(x,ierr)) 122 PetscCallA(SNESDestroy(snes_extended,ierr)) 123 if (associated(base)) deallocate(base) 124 if (associated(extended)) deallocate(extended) 125 PetscCallA(PetscFinalize(ierr)) 126 127 print *, 'End of Fortran2003 test program' 128end program ex18f90 129 130!/*TEST 131! 132! build: 133! requires: defined(PETSC_USING_F2003) defined(PETSC_USING_F90FREEFORM) 134! test: 135! requires: !pgf90_compiler 136! 137!TEST*/ 138