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