1! _______________________________________________________________________ 2! 3! LHS (Latin Hypercube Sampling) wrappers for C clients. 4! Copyright (c) 2006, Sandia National Laboratories. 5! This software is distributed under the GNU Lesser General Public License. 6! For more information, see the README file in the LHS directory. 7! 8! NOTE: this "C wrapper layer" is NOT a part of the original LHS source 9! code. It was added by the DAKOTA team to allow C clients to easily 10! link with the LHS f90 routines without having to assume the burden 11! of managing the "mixed-language string translations" themselves. 12! 13! BMA (20160315): Changed to use Fortran 2003 ISO C bindings. Could 14! go further to process the null-terminated C string here in the 15! Fortran and allow variable-length input. 16! _______________________________________________________________________ 17! 18C These Fortran wrappers circumvent problems with implicit string sizes 19C in f90. 20 21C ----- 22C Convert a fixed-length C string to a fixed-length Fortran string 23C TODO: 24C * Could instead iterate until C_NULL_CHAR and allow variable length 25C * Could determine the length of the string from len(fort_str) 26C ----- 27 subroutine lhs_cstr_to_fortran( c_str, fort_str, num_char ) 28 29 use iso_c_binding, only: C_CHAR 30 integer, intent(in) :: num_char 31 character(C_CHAR), intent(in) :: c_str(num_char) 32 character fort_str(num_char) 33 34 loop_str: do i=1, num_char 35 fort_str(i:i) = c_str(i) 36 end do loop_str 37 38 end 39 40C --------------------------- 41C Wrapper for LHS lhs_options 42C --------------------------- 43!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::lhs_options2 44 subroutine lhs_options2( lhsreps, lhspval, lhsopts_in, ierror ) 45 1 bind(C) 46 47C Fix the string size and always call lhs_options2 from C++ with strings of 48C length 32 49 use iso_c_binding, only: C_CHAR 50 character (kind=C_CHAR, len=1), dimension (32) :: lhsopts_in 51 52 character*32 lhsopts 53 integer lhsreps, lhspval, ierror 54 55 call lhs_cstr_to_fortran(lhsopts_in, lhsopts, 32) 56 57C Since calling from F90 now, the implicit string size passing should work 58 call lhs_options( lhsreps, lhspval, lhsopts, ierror ) 59 60 end 61 62C ------------------------ 63C Wrapper for LHS lhs_dist 64C ------------------------ 65!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::lhs_dist2 66 subroutine lhs_dist2( namvar_in, iptflag, ptval, distype_in, 67 1 aprams, numprms, ierror, idistno, ipvno ) 68 2 bind(C) 69 70C Fix the string size and always call lhs_dist2 from C++ with strings of 71C length 32 72 use iso_c_binding, only: C_CHAR 73 character (kind=C_CHAR, len=1), dimension(16) :: namvar_in 74 character (kind=C_CHAR, len=1), dimension(32) :: distype_in 75 76 character*16 namvar 77 character*32 distype 78 integer iptflag, numprms, ierror, idistno, ipvno 79 double precision ptval, aprams(numprms) 80 81 call lhs_cstr_to_fortran(namvar_in, namvar, 16) 82 call lhs_cstr_to_fortran(distype_in, distype, 32) 83 84C Since calling from F90 now, the implicit string size passing should work 85 call lhs_dist( namvar, iptflag, ptval, distype, aprams, 86 1 numprms, ierror, idistno, ipvno ) 87 88 end 89 90C ------------------------- 91C Wrapper for LHS lhs_udist 92C ------------------------- 93!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::lhs_udist2 94 subroutine lhs_udist2( namvar_in, iptflag, ptval, distype_in, 95 1 numpts, xval, yval, ierror, idistno, 96 2 ipvno ) 97 3 bind(C) 98 99C Fix the string size and always call lhs_udist2 from C++ with strings of 100C length 32 101 use iso_c_binding, only: C_CHAR 102 character (kind=C_CHAR, len=1), dimension(16) :: namvar_in 103 character (kind=C_CHAR, len=1), dimension(32) :: distype_in 104 105 character*16 namvar 106 character*32 distype 107 integer iptflag, numpts, ierror, idistno, ipvno 108 double precision ptval, xval(1), yval(1) 109 110 call lhs_cstr_to_fortran(namvar_in, namvar, 16) 111 call lhs_cstr_to_fortran(distype_in, distype, 32) 112 113C Since calling from F90 now, the implicit string size passing should work 114 call lhs_udist( namvar, iptflag, ptval, distype, numpts, 115 1 xval, yval, ierror, idistno, ipvno ) 116 117 end 118 119C ------------------------- 120C Wrapper for LHS lhs_const 121C ------------------------- 122!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::lhs_const2 123 subroutine lhs_const2( namvar_in, ptval, ierror, ipvno ) 124 1 bind(C) 125 126C Fix the string size and always call lhs_const2 from C++ with strings of 127C length 32 128 use iso_c_binding, only: C_CHAR 129 character (kind=C_CHAR, len=1), dimension(16) :: namvar_in 130 131 character*16 namvar 132 integer ierror, ipvno 133 double precision ptval 134 135 call lhs_cstr_to_fortran(namvar_in, namvar, 16) 136 137C Since calling from F90 now, the implicit string size passing should work 138 call lhs_const( namvar, ptval, ierror, ipvno ) 139 140 end 141 142C ------------------------ 143C Wrapper for LHS lhs_corr 144C ------------------------ 145!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::lhs_corr2 146 subroutine lhs_corr2( nam1_in, nam2_in, corrval, ierror ) 147 1 bind(C) 148 149C Fix the string size and always call lhs_corr2 from C++ with strings of 150C length 32 151 use iso_c_binding, only: C_CHAR 152 character (kind=C_CHAR, len=1), dimension(16) :: nam1_in, nam2_in 153 154 character*16 nam1, nam2 155 integer ierror 156 double precision corrval 157 158 call lhs_cstr_to_fortran(nam1_in, nam1, 16) 159 call lhs_cstr_to_fortran(nam2_in, nam2, 16) 160 161C Since calling from F90 now, the implicit string size passing should work 162 call lhs_corr( nam1, nam2, corrval, ierror ) 163 164 end 165 166C ----------------------- 167C Wrapper for LHS lhs_run 168C ----------------------- 169!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::lhs_run2 170 subroutine lhs_run2( max_var, max_obs, max_names, ierror, 171 1 dist_names_in, name_order, pt_vals, 172 2 num_names, sample_matrix, num_vars, 173 3 rank_matrix, rflag ) 174 4 bind(C) 175 176 use iso_c_binding, only: C_CHAR 177 character (kind=C_CHAR, len=1), dimension(16) :: dist_names_in 178 179 integer max_var, max_obs, max_names, num_names, num_vars 180 integer rflag, ierror, name_order(1) 181 character*16 dist_names(1) 182 double precision pt_vals(1), sample_matrix(1),rank_matrix(1) 183 184! BMA: there may be an incorrect declaration of this above, or maybe 185! the following will fail, but this call isn't currently used 186 call lhs_cstr_to_fortran(dist_names_in, dist_names, 16) 187 188 call lhs_run( max_var, max_obs, max_names, ierror, 189 1 dist_names, name_order, pt_vals, num_names, 190 2 sample_matrix, num_vars, rank_matrix, rflag ) 191 192 end 193 194C ------------------------- 195C Wrapper for LHS lhs_files 196C ------------------------- 197!LHS_EXPORT_DEC ATTRIBUTES DLLEXPORT::lhs_files2 198 subroutine lhs_files2( lhsout_in, lhsmsg_in, lhstitl_in, 199 1 lhsopts_in, ierror ) 200 2 bind(C) 201 202C Fix the string size and always call lhs_files from C++ with strings of 203C length 32 204 use iso_c_binding, only: C_CHAR 205 character (kind=C_CHAR, len=1), dimension(32) :: 206 1 lhsout_in, lhsmsg_in, lhstitl_in, lhsopts_in 207 208 character*32 lhsout, lhsmsg, lhstitl, lhsopts 209 integer ierror 210 211 call lhs_cstr_to_fortran(lhsout_in, lhsout, 32) 212 call lhs_cstr_to_fortran(lhsmsg_in, lhsmsg, 32) 213 call lhs_cstr_to_fortran(lhstitl_in, lhstitl, 32) 214 call lhs_cstr_to_fortran(lhsopts_in, lhsopts, 32) 215 216C Since calling from F90 now, the implicit string size passing should work 217 call lhs_files( lhsout, lhsmsg, lhstitl, lhsopts, ierror ) 218 219 end 220