Actual source code: bagenum.F90

  1: #include "petsc/finclude/petscbag.h"

  3: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
  4: !DEC$ ATTRIBUTES DLLEXPORT::PetscBagRegisterEnum
  5: #endif
  6:       Subroutine PetscBagRegisterEnum(bag, addr, FArray, def, n, h, ierr)
  7:         use, intrinsic :: iso_c_binding
  8:         use petscbag
  9:         implicit none

 11:         PetscBag bag
 12:         character(*) n, h
 13:         character(*) FArray(*)
 14:         PetscEnum                   :: def
 15:         PetscErrorCode, intent(out)  :: ierr
 16:         PetscReal addr(*)

 18:         Type(C_Ptr), Dimension(:), Pointer :: CArray
 19:         character(kind=c_char), pointer   :: nullc => null()
 20:         PetscInt   :: i, Len
 21:         Character(kind=C_char, len=256), Dimension(:), Pointer::list1

 23:         do i = 1, 256
 24:           if (len_trim(Farray(i)) == 0) then
 25:             Len = i - 1
 26:             goto 100
 27:           end if
 28:           if (len_trim(Farray(i)) > 255) then
 29:             ierr = PETSC_ERR_ARG_OUTOFRANGE
 30:             return
 31:           end if
 32:         end do
 33:         ierr = PETSC_ERR_ARG_OUTOFRANGE
 34:         return

 36: 100     continue

 38:         Allocate (list1(Len), stat=ierr)
 39:         if (ierr /= 0) return
 40:         Allocate (CArray(Len + 1), stat=ierr)
 41:         if (ierr /= 0) return

 43:         do i = 1, Len
 44:           list1(i) = trim(FArray(i))//C_NULL_CHAR
 45:           CArray(i) = c_loc(list1(i))
 46:         end do

 48:         CArray(Len + 1) = c_loc(nullc)
 49:         call PetscBagRegisterEnumPrivate(bag, addr, CArray, def, n, h, ierr)
 50:         DeAllocate (CArray)
 51:         DeAllocate (list1)
 52:       End Subroutine