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