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