Actual source code: bagenum.F
petsc-3.9.1 2018-04-29
2: #include "petsc/finclude/petscsys.h"
4: Subroutine PetscBagRegisterEnum(bag,addr,FArray,def,n,h,ierr)
5: use,intrinsic :: iso_c_binding
6: implicit none
8: PetscBag bag
9: character(*) n,h
10: character(*) FArray(*)
11: PetscEnum :: def
12: PetscErrorCode,intent(out) :: ierr
13: PetscReal addr(*)
15: Type(C_Ptr),Dimension(:),Pointer :: CArray
16: character(kind=c_char),pointer :: nullc => null()
17: PetscInt :: i,Len
18: Character(kind=C_char,len=256),Dimension(:),Pointer::list1
20: do i=1,256
21: if (len_trim(Farray(i)) .eq. 0) then
22: Len = i-1
23: goto 100
24: endif
25: if (len_trim(Farray(i)) .gt. 255) then
26: PETSC_ERR_ARG_OUTOFRANGE
27: return
28: endif
29: enddo
30: PETSC_ERR_ARG_OUTOFRANGE
31: return
33: 100 continue
35: Allocate(list1(Len),stat=ierr)
36: if (ierr .ne. 0) return
37: Allocate(CArray(Len+1),stat=ierr)
38: if (ierr .ne. 0) return
39:
40: do i=1,Len
41: list1(i) = trim(FArray(i))//C_NULL_CHAR
42: enddo
44: CArray = (/(c_loc(list1(i)),i=1,Len),c_loc(nullc)/)
45: call PetscBagRegisterEnumPrivate(bag,addr,CArray,def,n,h,ierr)
46: DeAllocate(CArray)
47: DeAllocate(list1)
48: End Subroutine