1!! Copyright (C) 2002-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch
2!!
3!! This program is free software; you can redistribute it and/or modify
4!! it under the terms of the GNU General Public License as published by
5!! the Free Software Foundation; either version 2, or (at your option)
6!! any later version.
7!!
8!! This program is distributed in the hope that it will be useful,
9!! but WITHOUT ANY WARRANTY; without even the implied warranty of
10!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11!! GNU General Public License for more details.
12!!
13!! You should have received a copy of the GNU General Public License
14!! along with this program; if not, write to the Free Software
15!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16!! 02110-1301, USA.
17!!
18
19#include "global.h"
20
21module varinfo_oct_m
22  use iso_c_binding
23  use string_oct_m
24
25  implicit none
26
27  private
28  public ::               &
29    varinfo_init,         &
30    varinfo_end,          &
31    varinfo_print,        &
32    varinfo_search,       &
33    varinfo_print_option, &
34    varinfo_valid_option, &
35    varinfo_option,       &
36    varinfo_exists
37
38  interface varinfo_valid_option
39    module procedure varinfo_valid_option_8
40    module procedure varinfo_valid_option_4
41  end interface varinfo_valid_option
42
43  interface
44    subroutine varinfo_init(filename)
45      implicit none
46      character(len=*), intent(in) :: filename
47    end subroutine varinfo_init
48
49    subroutine varinfo_getvar(name, var)
50      use iso_c_binding
51      implicit none
52      character(len=*), intent(in)    :: name
53      type(c_ptr),      intent(inout) :: var
54    end subroutine varinfo_getvar
55
56    subroutine varinfo_getinfo(var, name, type, default, section, desc)
57      use iso_c_binding
58      implicit none
59      type(c_ptr), intent(in)  :: var
60      type(c_ptr), intent(out) :: name
61      type(c_ptr), intent(out) :: type
62      type(c_ptr), intent(out) :: default
63      type(c_ptr), intent(out) :: section
64      type(c_ptr), intent(out) :: desc
65    end subroutine varinfo_getinfo
66
67    subroutine varinfo_getopt(var, opt)
68      use iso_c_binding
69      implicit none
70      type(c_ptr), intent(in)  :: var
71      type(c_ptr), intent(out) :: opt
72    end subroutine varinfo_getopt
73
74    subroutine varinfo_opt_getinfo(opt, name, val, desc)
75      use iso_c_binding
76      implicit none
77      type(c_ptr), intent(in)  :: opt
78      type(c_ptr), intent(out) :: name
79      integer(8),  intent(out) :: val
80      type(c_ptr), intent(out) :: desc
81    end subroutine varinfo_opt_getinfo
82
83    subroutine varinfo_search_var(name, var)
84      use iso_c_binding
85      implicit none
86      character(len=*), intent(in)    :: name
87      type(c_ptr),      intent(inout) :: var
88    end subroutine varinfo_search_var
89
90    subroutine varinfo_search_option(var, name, val, ierr)
91      use iso_c_binding
92      implicit none
93      type(c_ptr),      intent(in)  :: var
94      character(len=*), intent(in)  :: name
95      integer,          intent(out) :: val
96      integer,          intent(out) :: ierr
97    end subroutine varinfo_search_option
98
99    subroutine varinfo_end()
100      implicit none
101    end subroutine varinfo_end
102  end interface
103
104
105contains
106
107  ! ---------------------------------------------------------
108  subroutine varinfo_print(iunit, var, ierr)
109    integer,          intent(in) :: iunit
110    character(len=*), intent(in) :: var
111    integer,optional, intent(out):: ierr
112
113    type(c_ptr) :: handle, opt, name, type, default, section, desc
114    integer(8) :: val
115    logical :: first
116
117    call varinfo_getvar(var, handle)
118    if(.not. c_associated(handle)) then
119      if(present(ierr)) then
120        ierr = -1
121        return
122      else
123        write(iunit, '(3a)') 'ERROR: Could not find a variable named ', trim(var), '.'
124        stop
125      end if
126    end if
127
128    if(present(ierr)) ierr = 0
129    call varinfo_getinfo(handle, name, type, default, section, desc)
130
131    call print_C_string(iunit, name,    "Variable: ")
132    call print_C_string(iunit, type,    "Type:     ")
133    call print_C_string(iunit, default, "Default:  ")
134    call print_C_string(iunit, section, "Section:  ")
135    write(iunit, '(a)') "Description:"
136    call print_C_string(iunit, desc, "    ")
137
138    opt = c_null_ptr
139    first = .true.
140    do
141      call varinfo_getopt(handle, opt)
142      if(.not. c_associated(opt)) then
143        exit
144      else
145        if(first) then
146          write(iunit, '(a)') "Available options:"
147          first = .false.
148        end if
149        call varinfo_opt_getinfo(opt, name, val, desc)
150        call print_C_string(iunit, name, "  ")
151        call print_C_string(iunit, desc, "    ")
152      end if
153    end do
154
155  end subroutine varinfo_print
156
157
158  ! ---------------------------------------------------------
159  logical function varinfo_valid_option_8(var, option, is_flag) result(l)
160    character(len=*),  intent(in) :: var
161    integer(8),        intent(in) :: option
162    logical, optional, intent(in) :: is_flag
163
164    type(c_ptr) :: handle, opt, name, desc
165    integer(8) :: val, option_
166    logical :: is_flag_
167
168    is_flag_ = .false.
169    if(present(is_flag)) is_flag_ = is_flag
170    option_ = option ! copy that we can change
171
172    l = .false.
173
174    call varinfo_getvar(var, handle)
175    if(.not. c_associated(handle)) then
176      write(0, '(3a)') 'ERROR: Could not find a variable named ', trim(var), '.'
177      stop
178    endif
179
180    opt = c_null_ptr
181    do
182      call varinfo_getopt(handle, opt)
183      if(.not. c_associated(opt)) exit
184      call varinfo_opt_getinfo(opt, name, val, desc)
185
186      if(is_flag_) then
187        option_ = iand(option_, not(val))
188      else
189        if(val == option_) then
190          l = .true.
191          return
192        end if
193      end if
194
195    end do
196
197    if(is_flag_ .and. (option_ == 0)) l = .true.
198
199  end function varinfo_valid_option_8
200
201  ! ---------------------------------------------------------
202
203  logical function varinfo_valid_option_4(var, option, is_flag) result(l)
204    character(len=*),  intent(in) :: var
205    integer,           intent(in) :: option
206    logical, optional, intent(in) :: is_flag
207
208    l = varinfo_valid_option_8(var, int(option, 8), is_flag)
209
210  end function varinfo_valid_option_4
211
212  ! ---------------------------------------------------------
213  subroutine varinfo_print_option(iunit, var, option, pre)
214    integer,          intent(in) :: iunit
215    character(len=*), intent(in) :: var
216    integer,          intent(in) :: option
217    character(len=*), intent(in), optional :: pre
218
219    type(c_ptr) :: handle, opt, name, desc
220    integer(8) :: val
221    logical :: option_found
222
223    call varinfo_getvar(var, handle)
224    if(.not. c_associated(handle)) then
225      write(iunit, '(3a)') 'ERROR: Could not find a variable named ', trim(var), '.'
226      stop
227    endif
228
229    option_found = .false.
230    opt = c_null_ptr
231    do
232      call varinfo_getopt(handle, opt)
233      if(.not. c_associated(opt)) exit
234
235      call varinfo_opt_getinfo(opt, name, val, desc)
236
237      if(val == int(option, 8)) then
238        option_found = .true.
239        exit
240      endif
241    end do
242
243    write(iunit, '(4a)', advance='no') "Input:", ' [', var, ' = '
244
245    if(option_found) then
246      call print_C_string(iunit, name, advance='no')
247    else
248      write(iunit,'(i6,a)', advance='no') option, " (INVALID)"
249    endif
250    write(iunit, '(a)', advance='no') ']'
251    if(present(pre)) then
252      write(iunit, '(3a)') ' (', trim(pre), ')'
253    else
254      write(iunit, '(1x)')
255    end if
256    ! uncomment to print the description of the options
257    !call print_C_string(iunit, desc, pre='  > ')
258
259    if(.not. option_found) then
260      ! we cannot use messages here :-(
261      write(iunit,'(a,i6,2a)') "ERROR: invalid option ", option, " for variable ", trim(var)
262      stop
263    end if
264
265  end subroutine varinfo_print_option
266
267  ! ---------------------------------------------------------
268  subroutine varinfo_search(iunit, var, ierr)
269    integer,          intent(in) :: iunit
270    character(len=*), intent(in) :: var
271    integer,optional, intent(out):: ierr
272
273    type(c_ptr) :: handle, name, type, default, section, desc
274
275    handle = c_null_ptr
276    if(present(ierr)) ierr = -1
277    do
278      call varinfo_search_var(var, handle)
279
280      if(c_associated(handle)) then
281        if(present(ierr)) ierr = 0
282      else
283        exit
284      end if
285
286      call varinfo_getinfo(handle, name, type, default, section, desc)
287      call print_C_string(iunit, name)
288
289    end do
290
291  end subroutine varinfo_search
292
293  ! ---------------------------------------------------------
294  integer function varinfo_option(var, option) result(val)
295    character(len=*),  intent(in) :: var
296    character(len=*),  intent(in) :: option
297
298    type(c_ptr) :: handle
299    integer  :: ierr
300
301    call varinfo_getvar(var, handle)
302    call varinfo_search_option(handle, option, val, ierr)
303
304    if(ierr /= 0) then
305      ! we cannot use messages here :-(
306      write(0,'(4a)') "ERROR: invalid option ", trim(option), " for variable ", trim(var)
307      stop
308    end if
309
310  end function varinfo_option
311
312  ! ----------------------------------------------------------
313
314  logical function varinfo_exists(var) result(exists)
315    character(len=*),  intent(in) :: var
316
317    type(c_ptr) :: handle
318
319    handle = c_null_ptr
320
321    call varinfo_search_var(var, handle)
322
323    exists = c_associated(handle)
324
325  end function varinfo_exists
326
327
328end module varinfo_oct_m
329
330!! Local Variables:
331!! mode: f90
332!! coding: utf-8
333!! End:
334