diff options
Diffstat (limited to 'Dragon/src/FSDF.f90')
| -rw-r--r-- | Dragon/src/FSDF.f90 | 190 |
1 files changed, 190 insertions, 0 deletions
diff --git a/Dragon/src/FSDF.f90 b/Dragon/src/FSDF.f90 new file mode 100644 index 0000000..06f5b69 --- /dev/null +++ b/Dragon/src/FSDF.f90 @@ -0,0 +1,190 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for the NDAS C API. +! +!Copyright: +! Copyright (C) 2012 Atomic Energy of Canada Limited and Ecole +! Polytechnique de Montreal. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +module FSDF + private + public :: XSDOPN, XSDNAM, XSDBLD, XSDISO, XSDTHE, XSDRES, XSDTAB, XSDCL + interface XSDBLD + module procedure XSDBLD_I1, XSDBLD_R1 + end interface + interface XSDISO + module procedure XSDISO_I1, XSDISO_R1 + end interface +contains +subroutine XSDOPN(namfil, ierr) + ! open the NDAS file + use, intrinsic :: iso_c_binding + use LCMAUX + character(len=*) :: namfil + integer ierr + character(kind=c_char), dimension(73) :: name73 + interface + subroutine xsdopn_c(namp, ierr) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: ierr + end subroutine xsdopn_c + end interface + call STRCUT(name73, namfil) + call xsdopn_c(name73, ierr) +end subroutine XSDOPN +! +subroutine XSDNAM(iset, numericId, isonam, ierr) + ! recover an isotope name from NDAS file + use LCMAUX + use, intrinsic :: iso_c_binding + integer iset,numericId, ierr + character(len=*) :: isonam + character(kind=c_char), dimension(73) :: name73 + interface + subroutine xsdnam_c(iset, numericId, namp, ierr) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: iset,numericId,ierr + end subroutine xsdnam_c + end interface + call xsdnam_c(iset, numericId, name73, ierr) + call STRFIL(isonam, name73) +end subroutine XSDNAM +! +subroutine XSDBLD_I1(item, where, ierr) + ! recover a header or integer record from NDAS file + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer item,ierr + integer, target, dimension(*) :: where + integer, pointer :: where_p + interface + subroutine xsdbld_c(item, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) :: item, ierr + type(c_ptr), value :: where + end subroutine xsdbld_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdbld_c(item, pt_where, ierr) +end subroutine XSDBLD_I1 +! +subroutine XSDBLD_R1(item, where, ierr) + ! recover a header or real record from NDAS file + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer item,ierr + real, target, dimension(*) :: where + real, pointer :: where_p + interface + subroutine xsdbld_c(item, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) :: item, ierr + type(c_ptr), value :: where + end subroutine xsdbld_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdbld_c(item, pt_where, ierr) +end subroutine XSDBLD_R1 +! +subroutine XSDISO_I1(groupRange, item, nuclideIndex, where, ierr) + ! recover an integer header for an isotope + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer groupRange, item, nuclideIndex, ierr + integer, target, dimension(*) :: where + integer, pointer :: where_p + interface + subroutine xsdiso_c(groupRange, item, nuclideIndex, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) groupRange, item, nuclideIndex, ierr + type(c_ptr), value :: where + end subroutine xsdiso_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdiso_c(groupRange, item, nuclideIndex, pt_where, ierr) +end subroutine XSDISO_I1 +! +subroutine XSDISO_R1(groupRange, item, nuclideIndex, where, ierr) + ! recover a real header for an isotope + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer groupRange, item, nuclideIndex, ierr + real, target, dimension(*) :: where + real, pointer :: where_p + interface + subroutine xsdiso_c(groupRange, item, nuclideIndex, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) groupRange, item, nuclideIndex, ierr + type(c_ptr), value :: where + end subroutine xsdiso_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdiso_c(groupRange, item, nuclideIndex, pt_where, ierr) +end subroutine XSDISO_R1 +! +subroutine XSDTHE(groupRange, item, nuclideIndex, index, where, ierr) + ! recover a cross-section array + use, intrinsic :: iso_c_binding + integer groupRange, item, nuclideIndex, index, ierr + real, dimension(*) :: where + interface + subroutine xsdthe_c(groupRange, item, nuclideIndex, index, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) groupRange, item, nuclideIndex, index, ierr + real(c_float), dimension(*) :: where + end subroutine xsdthe_c + end interface + call xsdthe_c(groupRange, item, nuclideIndex, index, where, ierr) +end subroutine XSDTHE +! +subroutine XSDRES(nuclideIndex, where, ierr) + ! recover a resonance information array + use, intrinsic :: iso_c_binding + integer nuclideIndex, ierr + integer, dimension(*) :: where + interface + subroutine xsdres_c(nuclideIndex, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) nuclideIndex, ierr + integer(c_int), dimension(*) :: where + end subroutine xsdres_c + end interface + call xsdres_c(nuclideIndex, where, ierr) +end subroutine XSDRES +! +subroutine XSDTAB(item, nuclideIndex, resGroup, where, ierr) + ! recover a resonance cross-section array + use, intrinsic :: iso_c_binding + integer item, nuclideIndex, resGroup, ierr + real, dimension(*) :: where + interface + subroutine xsdtab_c(item, nuclideIndex, resGroup, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) item, nuclideIndex, resGroup, ierr + real(c_float), dimension(*) :: where + end subroutine xsdtab_c + end interface + call xsdtab_c(item, nuclideIndex, resGroup, where, ierr) +end subroutine XSDTAB +! +subroutine XSDCL() + ! close the NDAS file + interface + subroutine xsdcl_c() bind(c) + end subroutine xsdcl_c + end interface + call xsdcl_c() +end subroutine XSDCL +end module FSDF |