TABLE OF CONTENTS


ABINIT/m_parser [ Modules ]

[ Top ] [ Modules ]

NAME

 m_parser

FUNCTION

 This module contains (low-level) procedures to parse and validate input files.

COPYRIGHT

 Copyright (C) 2008-2018 ABINIT group (XG, MJV, MT)
 This file is distributed under the terms of the
 GNU General Public License, see ~abinit/COPYING
 or http://www.gnu.org/copyleft/gpl.txt .

SOURCE

17 #if defined HAVE_CONFIG_H
18 #include "config.h"
19 #endif
20 
21 #include "abi_common.h"
22 
23 module m_parser
24 
25  use defs_basis
26  use m_abicore
27  use m_errors
28  use m_atomdata
29  use m_xmpi
30 
31  use m_io_tools,  only : open_file
32  use m_fstrings,  only : sjoin, itoa, inupper
33  use m_nctk,      only : write_var_netcdf    ! FIXME Deprecated
34 
35  implicit none
36 
37  private
38 
39  public :: parsefile
40  public :: inread
41  public :: instrng
42  public :: incomprs
43  public :: intagm
44  public :: importxyz
45 
46  public :: chkdpr         ! Checks the value of an input real(dp) variable.
47  public :: chkint         ! Checks the value of an input integer variable.
48  public :: chkint_eq      ! Checks the value of an input integer variable against a list.
49  public :: chkint_ge      ! Checks the value of an input integer variable, expected to be greater than some value.
50  public :: chkint_le      ! Checks the value of an input integer variable, expected to be lower than some value.
51  public :: chkint_ne      ! Checks the value of an input integer variable against a list.
52  !public :: chkint_prt
53 
54  public :: prttagm        ! Print the content of intarr or dprarr.
55  public :: prttagm_images ! Extension to prttagm to include the printing of images information.
56  public :: chkvars_in_string   !  Analyze variable names in string. Abort if name is not recognized.
57 
58 CONTAINS  !===========================================================

m_parser/append_xyz [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 append_xyz

FUNCTION

 Translate the data from a xyz file (xyz_fname),
 and add it at the end of the usual ABINIT input data string (string),
 taking into account the dtset (dtset_char)

INPUTS

  dtset_char*2=possible dtset label
  xyz_fname = name of the xyz file
  strln=maximal number of characters of string, as declared in the calling routine

OUTPUT

SIDE EFFECTS

  lenstr=actual number of characters in string
  string*(strln)=string of characters  (upper case) to which the xyz data are appended

PARENTS

      importxyz

CHILDREN

      atomdata_from_symbol,wrtout

SOURCE

1912 subroutine append_xyz(dtset_char,lenstr,string,xyz_fname,strln)
1913 
1914 
1915 !This section has been created automatically by the script Abilint (TD).
1916 !Do not modify the following lines by hand.
1917 #undef ABI_FUNC
1918 #define ABI_FUNC 'append_xyz'
1919 !End of the abilint section
1920 
1921  implicit none
1922 
1923 !Arguments ------------------------------------
1924 !scalars
1925  integer,intent(in) :: strln
1926  integer,intent(inout) :: lenstr
1927  character(len=2),intent(in) :: dtset_char
1928  character(len=fnlen),intent(in) :: xyz_fname
1929  character(len=strln),intent(inout) :: string
1930 
1931 !Local variables-------------------------------
1932  character :: blank=' '
1933 !scalars
1934  integer :: unitxyz, iatom, natom, mu
1935  integer :: lenstr_new
1936  integer :: lenstr_old
1937  integer :: ntypat
1938  real(dp) :: znucl
1939  character(len=5) :: string5
1940  character(len=20) :: string20
1941  character(len=500) :: message
1942  type(atomdata_t) :: atom
1943 !arrays
1944  real(dp),allocatable :: xangst(:,:)
1945  integer, save :: atomspecies(200) = 0
1946  character(len=500), save :: znuclstring = ""
1947  character(len=2),allocatable :: elementtype(:)
1948 
1949 !************************************************************************
1950 
1951  lenstr_new=lenstr
1952 
1953  if (dtset_char == "-1") then
1954 !  write znucl
1955    lenstr_old=lenstr_new
1956    lenstr_new=lenstr_new+7+len_trim(znuclstring)+1
1957    string(lenstr_old+1:lenstr_new)=" ZNUCL"//blank//trim(znuclstring)//blank
1958 
1959 !  write ntypat
1960    ntypat = sum(atomspecies)
1961    write(string20,'(i10)') ntypat
1962    lenstr_old=lenstr_new
1963    lenstr_new=lenstr_new+8+len_trim(string20)+1
1964    string(lenstr_old+1:lenstr_new)=" NTYPAT"//blank//trim(string20)//blank
1965 
1966    return
1967  end if
1968 
1969 !open file with xyz data
1970  if (open_file(xyz_fname, message, newunit=unitxyz, status="unknown") /= 0) then
1971    MSG_ERROR(message)
1972  end if
1973  write(message, '(3a)')' importxyz : Opened file ',trim(xyz_fname),'; content stored in string_xyz'
1974  call wrtout(std_out,message,'COLL')
1975 
1976 !check number of atoms is correct
1977  read(unitxyz,*) natom
1978 
1979  write(string5,'(i5)')natom
1980  lenstr_old=lenstr_new
1981  lenstr_new=lenstr_new+7+len_trim(dtset_char)+1+5
1982  string(lenstr_old+1:lenstr_new)=" _NATOM"//trim(dtset_char)//blank//string5
1983 
1984  ABI_ALLOCATE(xangst,(3,natom))
1985  ABI_ALLOCATE(elementtype,(natom))
1986 
1987 !read dummy line
1988  read(unitxyz,*)
1989 
1990 !read atomic types and positions
1991  do iatom = 1, natom
1992    read(unitxyz,*) elementtype(iatom), xangst(:,iatom)
1993 !  extract znucl for each atom type
1994    call atomdata_from_symbol(atom,elementtype(iatom))
1995    znucl = atom%znucl
1996    if (znucl > 200) then
1997      write (message,'(5a)')&
1998 &     'Error: found element beyond Z=200 ', ch10,&
1999 &     'Solution: increase size of atomspecies in append_xyz', ch10
2000      MSG_ERROR(message)
2001    end if
2002 !  found a new atom type
2003    if (atomspecies(int(znucl)) == 0) then
2004      write(string20,'(f10.2)') znucl
2005      znuclstring = trim(znuclstring) // " " // trim(string20) // " "
2006    end if
2007    atomspecies(int(znucl)) = 1
2008  end do
2009  close (unitxyz)
2010 
2011 
2012 !Write the element types
2013  lenstr_old=lenstr_new
2014  lenstr_new=lenstr_new+7+len_trim(dtset_char)+1
2015  string(lenstr_old+1:lenstr_new)=" _TYPAX"//trim(dtset_char)//blank
2016  do iatom=1,natom
2017    lenstr_old=lenstr_new
2018    lenstr_new=lenstr_new+3
2019    string(lenstr_old+1:lenstr_new)=elementtype(iatom)//blank
2020  end do
2021  lenstr_old=lenstr_new
2022  lenstr_new=lenstr_new+3
2023  string(lenstr_old+1:lenstr_new)="XX " ! end card for TYPAX
2024 
2025 !Write the coordinates
2026  lenstr_old=lenstr_new
2027  lenstr_new=lenstr_new+8+len_trim(dtset_char)+1
2028  string(lenstr_old+1:lenstr_new)=" _XANGST"//trim(dtset_char)//blank
2029 
2030  do iatom=1,natom
2031    do mu=1,3
2032      write(string20,'(f20.12)')xangst(mu,iatom)
2033      lenstr_old=lenstr_new
2034      lenstr_new=lenstr_new+20
2035      string(lenstr_old+1:lenstr_new)=string20
2036    end do
2037  end do
2038 
2039  ABI_DEALLOCATE(elementtype)
2040  ABI_DEALLOCATE(xangst)
2041 
2042 !Check the length of the string
2043  if(lenstr_new>strln)then
2044    write(message,'(3a)')&
2045 &   'The maximal size of the input variable string has been exceeded.',ch10,&
2046 &   'The use of a xyz file is more character-consuming than the usual input file. Sorry.'
2047    MSG_BUG(message)
2048  end if
2049 
2050 !Update the length of the string
2051  lenstr=lenstr_new
2052 
2053 end subroutine append_xyz

m_parser/chkdpr [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 chkdpr

FUNCTION

 Checks the value of an input real(dp) variable, and
 write a sophisticated error message when it is erroneous.
 A few conditions might have been checked before calling chkdpr,
 and these are mentioned in the error message.

INPUTS

 advice_change_cond= if 1, and if an error is detected, will
  advice to change the value of the conditions.
 cond_number= number of conditions checked before calling chkdpr.
 cond_string(cond_number)= name of the variables associated to the conditions.
 cond_values(cond_number)= value of the variables associated to the conditions.
 input_name=name of the input variable to be checked
 input_value=value of the input variable to be checked
 minimal_flag=if 0, the reference_value must be matched within 1.0d-10
              if 1, admit values larger or equal to reference_value
              if -1, admit values smaller or equal to reference_value
 reference_value=see the description of minimal_flag
 unit=unit number for clean output file

OUTPUT

  (only side effect)

SIDE EFFECTS

 ierr= switch it to 1 if an error was detected. No action otherwise.

NOTES

 cond_values(cond_number)
 must be between -99 and 999 to be printed correctly.
 for the time being, at most 3 conditions are allowed.

PARENTS

      chkinp

CHILDREN

      wrtout

SOURCE

2099 subroutine chkdpr(advice_change_cond,cond_number,cond_string,cond_values,&
2100 &  ierr,input_name,input_value,minimal_flag,reference_value,unit)
2101 
2102 
2103 !This section has been created automatically by the script Abilint (TD).
2104 !Do not modify the following lines by hand.
2105 #undef ABI_FUNC
2106 #define ABI_FUNC 'chkdpr'
2107 !End of the abilint section
2108 
2109  implicit none
2110 
2111 !Arguments ------------------------------------
2112 !scalars
2113  integer,intent(in) :: advice_change_cond,cond_number,minimal_flag,unit
2114  integer,intent(inout) :: ierr
2115  real(dp),intent(in) :: input_value,reference_value
2116  character(len=*),intent(in) :: input_name
2117 !arrays
2118  integer,intent(in) :: cond_values(4)
2119  character(len=*),intent(in) :: cond_string(4)
2120 
2121 !Local variables-------------------------------
2122 !scalars
2123  integer :: icond,ok
2124  character(len=500) :: message
2125 
2126 !******************************************************************
2127 
2128  if(cond_number<0 .or. cond_number>4)then
2129    write(message,'(a,i6,a)' )&
2130 &   'The value of cond_number is',cond_number,&
2131 &   'but it should be positive and < 5.'
2132    MSG_BUG(message)
2133  end if
2134 
2135 !Checks the allowed values
2136  ok=0
2137  if(minimal_flag==1 .and. input_value>=reference_value-tol10)              ok=1
2138  if(minimal_flag==-1 .and. input_value<=reference_value+tol10)             ok=1
2139  if(minimal_flag==0 .and. abs(input_value-reference_value)<=tol10) ok=1
2140 
2141 !If there is something wrong, compose the message, and print it
2142  if(ok==0)then
2143    ierr=1
2144    write(message, '(a,a)' ) ch10,' chkdpr: ERROR -'
2145    if(cond_number/=0)then
2146      do icond=1,cond_number
2147 !      The following format restricts cond_values(icond) to be between -99 and 999
2148        write(message, '(2a,a,a,a,i4,a)' ) trim(message),ch10,&
2149 &       '  Context : the value of the variable ',&
2150 &       trim(cond_string(icond)),' is',cond_values(icond),'.'
2151      end do
2152    end if
2153    write(message, '(2a,a,a,a,es20.12,a)' ) trim(message),ch10,&
2154 &   '  The value of the input variable ',trim(input_name),&
2155 &   ' is',input_value,','
2156    if(minimal_flag==0)then
2157      write(message, '(2a,a,es20.12,a)' ) trim(message),ch10,&
2158      '  while it must be equal to ',reference_value,'.'
2159    else if(minimal_flag==1)then
2160      write(message, '(2a,a,es20.12,a)' ) trim(message),ch10,&
2161 &     '  while it must be larger or equal to',reference_value,'.'
2162    else if(minimal_flag==-1)then
2163      write(message, '(2a,a,es20.12,a)' ) trim(message),ch10,&
2164 &     '  while it must be smaller or equal to',reference_value,'.'
2165    end if
2166 
2167    if(cond_number==0 .or. advice_change_cond==0)then
2168      write(message, '(2a,a,a,a)' ) trim(message),ch10,&
2169 &     '  Action: you should change the input variable ',trim(input_name),'.'
2170    else if(cond_number==1)then
2171      write(message, '(2a,a,a,a,a,a)' ) trim(message),ch10,&
2172 &     '  Action: you should change the input variables ',trim(input_name),&
2173 &     ' or ',trim(cond_string(1)),'.'
2174    else if(cond_number==2)then
2175      write(message, '(2a,a,a,a,a,a,a,a,a,a)' ) trim(message),ch10,&
2176 &     '  Action: you should change one of the input variables ',&
2177 &     trim(input_name),',',ch10,&
2178 &     '   ',trim(cond_string(1)),' or ',trim(cond_string(2)),'.'
2179    else if(cond_number==3)then
2180      write(message, '(2a,a,a,a,a,a,a,a,a,a,a,a)' ) trim(message),ch10,&
2181 &     '  Action: you should change one of the input variables ',&
2182 &     trim(input_name),',',ch10,&
2183 &     '   ',trim(cond_string(1)),', ',trim(cond_string(2)),&
2184 &     ' or ',trim(cond_string(3)),'.'
2185    end if
2186 
2187    call wrtout(unit,message,'COLL')
2188    !call wrtout(std_out,  message,'COLL')
2189    MSG_WARNING(message)
2190  end if
2191 
2192 end subroutine chkdpr

m_parser/chkint [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 chkint

FUNCTION

 Checks the value of an input integer variable, and
 write a sophisticated error message when it is erroneous.
 A few conditions might have been checked before calling chkint,
 and these are mentioned in the error message.

 See the examples in the NOTES

INPUTS

 advice_change_cond= if 1, and if an error is detected, will
  advice to change the value of the conditions.
 cond_number= number of conditions checked before calling chkint.
 cond_string(cond_number)= name of the variables associated to the conditions.
 cond_values(cond_number)= value of the variables associated to the conditions.
 input_name=name of the input variable to be checked
 input_value=value of the input variable to be checked
 list_number=number of allowed values (maximum 40).
 list_values=list of allowed values
 minmax_flag=if 0, only values in the list are allowed
              if 1, admit values larger or equal to minmax_value
              if -1, admit values smaller or equal to minmax_value
 minmax_value=see the description of minmax_flag
 unit=unit number for clean output file

OUTPUT

  (only side effect)

 SIDE EFFECT
 ierr= switch it to 1 if an error was detected. No action otherwise.

NOTES

 cond_values(cond_number) or list_values(list_number)
 must be between -99 and 999 to be printed correctly.

 for the time being, at most 3 conditions are allowed.

 in order to ask only for a minimal value, set list_number
 as well as minmax_flag to 1, and put the minimal value in both
 list_values and minmax_value.

 Examples :
  List of values - ionmov must be equal to 0, 1, 3, 8, or 9
   call chkint(0,0,cond_string,cond_values,ierr,&
  & 'ionmov',ionmov,5,(/0,1,3,8,9/),0,0,iout)

  Larger or equal to a given value - nberry >= limit
   call chkint(0,0,cond_string,cond_values,ierr,&
  & 'nberry',nberry,1,(/limit/),1,limit,iout)

  Smaller or equal to a given value - nberry <= limit
   call chkint(0,0,cond_string,cond_values,ierr,&
  & 'nberry',nberry,1,(/limit/),-1,limit,iout)

  Conditional cases (examples to be provided - see chkinp.f for the
  time being)

PARENTS

      chkinp

CHILDREN

      chkint_prt

SOURCE

2263 subroutine chkint(advice_change_cond,cond_number,cond_string,cond_values,&
2264 &  ierr,input_name,input_value,&
2265 &  list_number,list_values,minmax_flag,minmax_value,unit)
2266 
2267 
2268 !This section has been created automatically by the script Abilint (TD).
2269 !Do not modify the following lines by hand.
2270 #undef ABI_FUNC
2271 #define ABI_FUNC 'chkint'
2272 !End of the abilint section
2273 
2274  implicit none
2275 
2276 !Arguments ------------------------------------
2277 !scalars
2278  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2279  integer,intent(in) :: minmax_flag,minmax_value,unit
2280  integer,intent(inout) :: ierr
2281  character(len=*),intent(in) :: input_name
2282 !arrays
2283  integer,intent(in) :: cond_values(4),list_values(list_number)
2284  character(len=*),intent(inout) :: cond_string(4)
2285 
2286 !Local variables-------------------------------
2287 !scalars
2288  integer :: ilist,ok
2289 
2290 !******************************************************************
2291 
2292 !Checks the allowed values
2293  ok=0
2294  if(list_number>0)then
2295    do ilist=1,list_number
2296      if(input_value == list_values(ilist))ok=1
2297    end do
2298  end if
2299  if(minmax_flag==1 .and. input_value>=minmax_value)ok=1
2300  if(minmax_flag==-1 .and. input_value<=minmax_value)ok=1
2301 
2302 !If there is something wrong, compose the message, and print it
2303  if(ok==0)then
2304    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2305 &   ierr,input_name,input_value,&
2306 &   list_number,list_values,minmax_flag,minmax_value,unit)
2307  end if
2308 
2309 ! reset all cond_strings
2310  cond_string(:)='#####'
2311 
2312 end subroutine chkint

m_parser/chkint_eq [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 chkint_eq

FUNCTION

 Checks the value of an input integer variable against a list, and
 write a sophisticated error message when the value does not appear
 A few conditions might have been checked before calling chkint,
 and these are mentioned in the error message.

 See the examples in the NOTES

INPUTS

 advice_change_cond= if 1, and if an error is detected, will
  advice to change the value of the conditions.
 cond_number= number of conditions checked before calling chkint.
 cond_string(cond_number)= name of the variables associated to the conditions.
 cond_values(cond_number)= value of the variables associated to the conditions.
 input_name=name of the input variable to be checked
 input_value=value of the input variable to be checked
 list_number=number of allowed values (maximum 40).
 list_values=list of allowed values
 unit=unit number for clean output file

OUTPUT

  (only side effect)

 SIDE EFFECT
 ierr= switch it to 1 if an error was detected. No action otherwise.

NOTES

 cond_values(cond_number) or list_values(list_number)
 must be between -99 and 999 to be printed correctly.

 for the time being, at most 3 conditions are allowed.

PARENTS

      chkinp,m_psps

CHILDREN

      chkint_prt

SOURCE

2359 subroutine chkint_eq(advice_change_cond,cond_number,cond_string,cond_values,&
2360 &  ierr,input_name,input_value,list_number,list_values,unit)
2361 
2362 
2363 !This section has been created automatically by the script Abilint (TD).
2364 !Do not modify the following lines by hand.
2365 #undef ABI_FUNC
2366 #define ABI_FUNC 'chkint_eq'
2367 !End of the abilint section
2368 
2369  implicit none
2370 
2371 !Arguments ------------------------------------
2372 !scalars
2373  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2374  integer,intent(in) :: unit
2375  integer,intent(inout) :: ierr
2376  character(len=*),intent(in) :: input_name
2377 !arrays
2378  integer,intent(in) :: cond_values(4),list_values(list_number)
2379  character(len=*),intent(inout) :: cond_string(4)
2380 
2381 !Local variables-------------------------------
2382 !scalars
2383  integer :: ilist,minmax_flag,minmax_value,ok
2384 
2385 !******************************************************************
2386 
2387 !Checks the allowed values
2388  ok=0
2389  if(list_number>0)then
2390    do ilist=1,list_number
2391      if(input_value == list_values(ilist))ok=1
2392    end do
2393  end if
2394  minmax_flag=0
2395  minmax_value=0
2396 
2397 !If there is something wrong, compose the message, and print it
2398  if(ok==0)then
2399    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2400 &   ierr,input_name,input_value,&
2401 &   list_number,list_values,minmax_flag,minmax_value,unit)
2402  end if
2403 
2404 ! reset all cond_strings
2405  cond_string(:)='#####'
2406 
2407 end subroutine chkint_eq

m_parser/chkint_ge [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 chkint_ge

FUNCTION

 Checks the value of an input integer variable, expected to be greater than some value, and
 write a sophisticated error message when it is erroneous.
 A few conditions might have been checked before calling chkint_ge,
 and these are mentioned in the error message.

 See the examples in the NOTES

INPUTS

 advice_change_cond= if 1, and if an error is detected, will
  advice to change the value of the conditions.
 cond_number= number of conditions checked before calling chkint_ge.
 cond_string(cond_number)= name of the variables associated to the conditions.
 cond_values(cond_number)= value of the variables associated to the conditions.
 input_name=name of the input variable to be checked
 input_value=value of the input variable to be checked
 minmax_value=see the description of minmax_flag
 unit=unit number for clean output file

OUTPUT

  (only side effect)

 SIDE EFFECT
 ierr= switch it to 1 if an error was detected. No action otherwise.

NOTES

 cond_values(cond_number) or list_values(list_number)
 must be between -99 and 999 to be printed correctly.

 for the time being, at most 3 conditions are allowed.

PARENTS

      chkinp,invars1

CHILDREN

      chkint_prt

SOURCE

2453 subroutine chkint_ge(advice_change_cond,cond_number,cond_string,cond_values,&
2454 &  ierr,input_name,input_value,minmax_value,unit)
2455 
2456 
2457 !This section has been created automatically by the script Abilint (TD).
2458 !Do not modify the following lines by hand.
2459 #undef ABI_FUNC
2460 #define ABI_FUNC 'chkint_ge'
2461 !End of the abilint section
2462 
2463  implicit none
2464 
2465 !Arguments ------------------------------------
2466 !scalars
2467  integer,intent(in) :: advice_change_cond,cond_number,input_value
2468  integer,intent(in) :: minmax_value,unit
2469  integer,intent(inout) :: ierr
2470  character(len=*),intent(in) :: input_name
2471 !arrays
2472  integer,intent(in) :: cond_values(4)
2473  character(len=*),intent(inout) :: cond_string(4)
2474 
2475 !Local variables-------------------------------
2476 !scalars
2477  integer :: list_number,minmax_flag,ok
2478  integer, allocatable :: list_values(:)
2479 
2480 !******************************************************************
2481 
2482 !Checks the allowed values
2483  ok=0
2484  minmax_flag=1
2485  if(input_value>=minmax_value)ok=1
2486  list_number=1
2487  ABI_ALLOCATE(list_values,(1))
2488  list_values=minmax_value
2489 
2490 !If there is something wrong, compose the message, and print it
2491  if(ok==0)then
2492    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2493 &   ierr,input_name,input_value,&
2494 &   list_number,list_values,minmax_flag,minmax_value,unit)
2495  end if
2496 
2497  ABI_DEALLOCATE(list_values)
2498 
2499 ! reset all cond_strings
2500  cond_string(:)='#####'
2501 
2502 end subroutine chkint_ge

m_parser/chkint_le [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 chkint_le

FUNCTION

 Checks the value of an input integer variable, expected to be lower than some value, and
 write a sophisticated error message when it is erroneous.
 A few conditions might have been checked before calling chkint_le,
 and these are mentioned in the error message.

 See the examples in the NOTES

INPUTS

 advice_change_cond= if 1, and if an error is detected, will
  advice to change the value of the conditions.
 cond_number= number of conditions checked before calling chkint_le.
 cond_string(cond_number)= name of the variables associated to the conditions.
 cond_values(cond_number)= value of the variables associated to the conditions.
 input_name=name of the input variable to be checked
 input_value=value of the input variable to be checked
 minmax_value=see the description of minmax_flag
 unit=unit number for clean output file

OUTPUT

  (only side effect)

 SIDE EFFECT
 ierr= switch it to 1 if an error was detected. No action otherwise.

NOTES

 cond_values(cond_number) or list_values(list_number)
 must be between -99 and 999 to be printed correctly.

 for the time being, at most 3 conditions are allowed.

PARENTS

      chkinp

CHILDREN

      chkint_prt

SOURCE

2548 subroutine chkint_le(advice_change_cond,cond_number,cond_string,cond_values,&
2549 &  ierr,input_name,input_value,&
2550 &  minmax_value,unit)
2551 
2552 
2553 !This section has been created automatically by the script Abilint (TD).
2554 !Do not modify the following lines by hand.
2555 #undef ABI_FUNC
2556 #define ABI_FUNC 'chkint_le'
2557 !End of the abilint section
2558 
2559  implicit none
2560 
2561 !Arguments ------------------------------------
2562 !scalars
2563  integer,intent(in) :: advice_change_cond,cond_number,input_value
2564  integer,intent(in) :: minmax_value,unit
2565  integer,intent(inout) :: ierr
2566  character(len=*),intent(in) :: input_name
2567 !arrays
2568  integer,intent(in) :: cond_values(4)
2569  character(len=*),intent(inout) :: cond_string(4)
2570 
2571 !Local variables-------------------------------
2572 !scalars
2573  integer :: list_number,minmax_flag,ok
2574  integer, allocatable :: list_values(:)
2575 
2576 !******************************************************************
2577 
2578 !Checks the allowed values
2579  ok=0
2580  minmax_flag=-1
2581  if(input_value<=minmax_value)ok=1
2582 !write(std_out,*)' chkint_le : input_value,minmax_value=',input_value,minmax_value
2583 
2584  list_number=1
2585  ABI_ALLOCATE(list_values,(1))
2586  list_values=minmax_value
2587 
2588 !If there is something wrong, compose the message, and print it
2589  if(ok==0)then
2590    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2591 &   ierr,input_name,input_value,&
2592 &   list_number,list_values,minmax_flag,minmax_value,unit)
2593  end if
2594 
2595  ABI_DEALLOCATE(list_values)
2596 
2597 ! reset all cond_strings
2598  cond_string(:)='#####'
2599 
2600 end subroutine chkint_le

m_parser/chkint_ne [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 chkint_ne

FUNCTION

 Checks the value of an input integer variable against a list, and
 write a sophisticated error message when the value appears in the list.
 A few conditions might have been checked before calling chkint,
 and these are mentioned in the error message.

 See the examples in the NOTES

INPUTS

 advice_change_cond= if 1, and if an error is detected, will
  advice to change the value of the conditions.
 cond_number= number of conditions checked before calling chkint.
 cond_string(cond_number)= name of the variables associated to the conditions.
 cond_values(cond_number)= value of the variables associated to the conditions.
 input_name=name of the input variable to be checked
 input_value=value of the input variable to be checked
 list_number=number of NOT allowed values (maximum 40).
 list_values=list of allowed values
 unit=unit number for clean output file

OUTPUT

  (only side effect)

 SIDE EFFECT
 ierr= switch it to 1 if an error was detected. No action otherwise.

NOTES

 cond_values(cond_number) or list_values(list_number)
 must be between -99 and 999 to be printed correctly.

 for the time being, at most 3 conditions are allowed.

PARENTS

      chkinp

CHILDREN

      chkint_prt

SOURCE

2647 subroutine chkint_ne(advice_change_cond,cond_number,cond_string,cond_values,&
2648 &  ierr,input_name,input_value,&
2649 &  list_number,list_values,unit)
2650 
2651 
2652 !This section has been created automatically by the script Abilint (TD).
2653 !Do not modify the following lines by hand.
2654 #undef ABI_FUNC
2655 #define ABI_FUNC 'chkint_ne'
2656 !End of the abilint section
2657 
2658  implicit none
2659 
2660 !Arguments ------------------------------------
2661 !scalars
2662  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2663  integer,intent(in) :: unit
2664  integer,intent(inout) :: ierr
2665  character(len=*),intent(in) :: input_name
2666 !arrays
2667  integer,intent(in) :: cond_values(4),list_values(list_number)
2668  character(len=*),intent(inout) :: cond_string(4)
2669 
2670 !Local variables-------------------------------
2671 !scalars
2672  integer :: ilist,minmax_flag,minmax_value,ok
2673 
2674 !******************************************************************
2675 
2676 !Checks the allowed values
2677  ok=1
2678  if(list_number>0)then
2679    do ilist=1,list_number
2680      if(input_value == list_values(ilist))ok=0
2681    end do
2682  end if
2683  minmax_flag=2
2684  minmax_value=0
2685 
2686 !If there is something wrong, compose the message, and print it
2687  if(ok==0)then
2688    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2689 &   ierr,input_name,input_value,&
2690 &   list_number,list_values,minmax_flag,minmax_value,unit)
2691  end if
2692 
2693 ! reset all cond_strings
2694  cond_string(:)='#####'
2695 
2696 end subroutine chkint_ne

m_parser/chkint_prt [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 chkint_prt

FUNCTION

 During the checking of the value of a variable,
 write a sophisticated error message when it is erroneous.
 A few conditions might have been checked before calling chkval,
 and these are mentioned in the error message.

 See the examples in the NOTES

INPUTS

 advice_change_cond= if 1, and if an error is detected, will
  advice to change the value of the conditions.
 cond_number= number of conditions checked before calling chkint.
 cond_string(cond_number)= name of the variables associated to the conditions.
 cond_values(cond_number)= value of the variables associated to the conditions.
 input_name=name of the input variable to be checked
 input_value=value of the input variable to be checked
 list_number=number of allowed values (maximum 40).
 list_values=list of allowed values
 minmax_flag=if 0, only values in the list are allowed
              if 1, admit values larger or equal to minmax_value
              if -1, admit values smaller or equal to minmax_value
              if 2, values in the list are not allowed
 minmax_value=see the description of minmax_flag
 unit=unit number for clean output file

OUTPUT

  (only side effect)

 SIDE EFFECT
 ierr= switch it to 1 if an error was detected. No action otherwise.

NOTES

 cond_values(cond_number) or list_values(list_number)
 must be between -99 and 999 to be printed correctly.

 for the time being, at most 3 conditions are allowed.

 in order to ask only for a minimal value, set list_number
 as well as minmax_flag to 1, and put the minimal value in both
 list_values and minmax_value.

 Examples :
  List of values - ionmov must be equal to 0, 1, 3, 8, or 9
   call chkint_prt(0,0,cond_string,cond_values,ierr,&
  & 'ionmov',ionmov,5,(/0,1,3,8,9/),0,0,iout)

  Larger or equal to a given value - nberry >= limit
   call chkint_prt(0,0,cond_string,cond_values,ierr,&
  & 'nberry',nberry,1,(/limit/),1,limit,iout)

  Smaller or equal to a given value - nberry <= limit
   call chkint_prt(0,0,cond_string,cond_values,ierr,&
  & 'nberry',nberry,1,(/limit/),-1,limit,iout)

  Conditional cases (examples to be provided - see chkinp.f for the
  time being)

PARENTS

      chkint,chkint_eq,chkint_ge,chkint_le,chkint_ne

CHILDREN

      wrtout

SOURCE

2768 subroutine chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2769 &  ierr,input_name,input_value,&
2770 &  list_number,list_values,minmax_flag,minmax_value,unit)
2771 
2772 
2773 !This section has been created automatically by the script Abilint (TD).
2774 !Do not modify the following lines by hand.
2775 #undef ABI_FUNC
2776 #define ABI_FUNC 'chkint_prt'
2777 !End of the abilint section
2778 
2779  implicit none
2780 
2781 !Arguments ------------------------------------
2782 !scalars
2783  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2784  integer,intent(in) :: minmax_flag,minmax_value,unit
2785  integer,intent(inout) :: ierr
2786  character(len=*),intent(in) :: input_name
2787 !arrays
2788  integer,intent(in) :: cond_values(4),list_values(list_number)
2789  character(len=*),intent(in) :: cond_string(4)
2790 
2791 !Local variables-------------------------------
2792 !scalars
2793  integer :: icond
2794  character(len=500) :: message
2795 
2796 !******************************************************************
2797 
2798  if(cond_number<0 .or. cond_number>4)then
2799    write(message,'(a,i0,a)' )&
2800 &   'The value of cond_number is ',cond_number,' but it should be positive and < 5.'
2801    MSG_BUG(message)
2802  end if
2803 
2804  if(list_number<0 .or. list_number>40)then
2805    write(message,'(a,i0,a)' )&
2806 &   'The value of list_number is',list_number,' but it should be between 0 and 40.'
2807    MSG_BUG(messagE)
2808  end if
2809 
2810 !Compose the message, and print it
2811  ierr=1
2812  write(message, '(2a)' ) ch10,' chkint_prt: ERROR -'
2813  if(cond_number/=0)then
2814    do icond=1,cond_number
2815 !    The following format restricts cond_values(icond) to be between -99 and 999
2816      write(message, '(5a,i0,a)' ) trim(message),ch10,&
2817 &     ' Context: the value of the variable ',trim(cond_string(icond)),' is ',cond_values(icond),'.'
2818    end do
2819  end if
2820  write(message, '(5a,i0,a)' ) trim(message),ch10,&
2821 & '  The value of the input variable ',trim(input_name),' is ',input_value,', while it must be'
2822  if(minmax_flag==2)then
2823    write(message, '(3a,20(i0,1x))' ) trim(message),ch10,&
2824    '  different from one of the following:',list_values(1:list_number)
2825  else if(list_number>1 .or. &
2826 &   minmax_flag==0 .or. list_values(1)/=minmax_value )then
2827 !  The following format restricts list_values to be between -99 and 999
2828    if(list_number/=1)then
2829      write(message, '(3a,40(i0,1x))' ) trim(message),ch10,&
2830      '  equal to one of the following: ',list_values(1:list_number)
2831    else
2832      write(message, '(3a,40(i0,1x))' ) trim(message),ch10,&
2833      '  equal to ',list_values(1)
2834    end if
2835    if(minmax_flag==1)then
2836 !    The following format restricts minmax_value to be between -99 and 999
2837      write(message, '(3a,i0,a)' ) trim(message),ch10,&
2838 &     '  or it must be larger or equal to ',minmax_value,'.'
2839    else if(minmax_flag==-1)then
2840      write(message, '(3a,i0,a)' ) trim(message),ch10,&
2841 &     '  or it must be smaller or equal to ',minmax_value,'.'
2842    end if
2843  else if(minmax_flag==1)then
2844 !  The following format restricts minmax_value to be between -99 and 999
2845    write(message, '(3a,i0,a)' ) trim(message),ch10,&
2846 &   '  larger or equal to ',minmax_value,'.'
2847  else if(minmax_flag==-1)then
2848 !  The following format restricts minmax_value to be between -99 and 999
2849    write(message, '(3a,i0,a)' ) trim(message),ch10,&
2850 &   '  smaller or equal to ',minmax_value,'.'
2851  end if
2852  if(cond_number==0 .or. advice_change_cond==0)then
2853    write(message, '(5a)' ) trim(message),ch10,&
2854 &   '  Action: you should change the input variable ',trim(input_name),'.'
2855  else if(cond_number==1)then
2856    write(message, '(7a)' ) trim(message),ch10,&
2857 &   '  Action: you should change the input variables ',trim(input_name),' or ',trim(cond_string(1)),'.'
2858  else if(cond_number==2)then
2859    write(message, '(11a)' ) trim(message),ch10,&
2860 &   '  Action: you should change one of the input variables ',trim(input_name),',',ch10,&
2861 &   '   ',trim(cond_string(1)),' or ',trim(cond_string(2)),'.'
2862  else if(cond_number==3)then
2863    write(message, '(13a)' ) trim(message),ch10,&
2864 &   '  Action: you should change one of the input variables ',trim(input_name),',',ch10,&
2865 &   '   ',trim(cond_string(1)),', ',trim(cond_string(2)),' or ',trim(cond_string(3)),'.'
2866  end if
2867  call wrtout(unit   ,message,'COLL')
2868  call wrtout(std_out,message,'COLL')
2869 
2870 end subroutine chkint_prt

m_parser/chkvars_in_string [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  chkvars_in_string

FUNCTION

  Analyze variable names in string. Abort if name is not recognized.

INPUTS

  protocol=
    0 if parser does not accept multiple datasets and +* syntax (e.g. anaddb)
    1 if parser accepts multiple datasets and +* syntax (e.g. abinit)

  list_vars(len=*)=string with the (upper case) names of the variables (excluding logicals and chars).
  list_logicals(len=*)=string with the (upper case) names of the logical variables.
  list_strings(len=*)=string with the (upper case) names of the character variables.
  string(len=*)=string (with upper case) from the input file.

OUTPUT

  Abort if variable name is not recognized.

PARENTS

      chkvars,m_anaddb_dataset

CHILDREN

SOURCE

3494 subroutine chkvars_in_string(protocol, list_vars, list_logicals, list_strings, string)
3495 
3496  use defs_basis
3497  use m_errors
3498 
3499 !This section has been created automatically by the script Abilint (TD).
3500 !Do not modify the following lines by hand.
3501 #undef ABI_FUNC
3502 #define ABI_FUNC 'chkvars_in_string'
3503 !End of the abilint section
3504 
3505  implicit none
3506 
3507 !Arguments ------------------------------------
3508 !scalars
3509  integer,intent(in) :: protocol
3510  character(len=*),intent(in) :: string
3511  character(len=*),intent(in) :: list_logicals,list_strings,list_vars
3512 
3513 !Local variables-------------------------------
3514  character,parameter :: blank=' '
3515 !scalars
3516  integer :: index_blank,index_current,index_endword,index_endwordnow,index_list_vars
3517  character(len=500) :: message
3518 
3519 !************************************************************************
3520 
3521  index_current=1
3522  do ! Infinite do-loop, to identify the presence of each potential variable names
3523 
3524    if(len_trim(string)<=index_current)exit
3525    index_blank=index(string(index_current:),blank)+index_current-1
3526 
3527    if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_current:index_current))/=0)then
3528 
3529      index_endword = index_blank -1
3530      if (protocol == 1) then
3531        ! Skip characters like : + or the digits at the end of the word
3532        ! Start from the blank that follows the end of the word
3533        do index_endword=index_blank-1,index_current,-1
3534          if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_endword:index_endword))/=0)exit
3535        end do
3536      end if
3537      !write(std_out,*)"Will analyze:", string(index_current:index_endword)
3538 
3539      ! Find the index of the potential variable name in the list of variables
3540      index_list_vars=index(list_vars,blank//string(index_current:index_endword)//blank)
3541 
3542      ! Treat the complications due to the possibility of images
3543      if (index_list_vars==0 .and. protocol==1) then
3544 
3545        ! Treat possible LASTIMG appendix
3546        if(index_endword-6>=1)then
3547          if(string(index_endword-6:index_endword)=='LASTIMG')index_endword=index_endword-7
3548        end if
3549 
3550        ! Treat possible IMG appendix
3551        if(index_endword-2>=1)then
3552          if(string(index_endword-2:index_endword)=='IMG')index_endword=index_endword-3
3553        end if
3554 
3555        index_endwordnow=index_endword
3556 
3557        ! Again skip characters like : + or the digits before IMG
3558        ! Start from the blank that follows the end of the word
3559        do index_endword=index_endwordnow,index_current,-1
3560          if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_endword:index_endword))/=0)exit
3561        end do
3562 
3563        ! Find the index of the potential variable name in the list of variables
3564        index_list_vars=index(list_vars,blank//string(index_current:index_endword)//blank)
3565      end if
3566 
3567      if(index_list_vars==0)then
3568 
3569        ! Treat possible logical input variables
3570        if(index(list_logicals,blank//string(index_current:index_endword)//blank)/=0)then
3571          !write(std_out,*)"Found logical variable: ",string(index_current:index_endword)
3572          index_blank=index(string(index_current:),blank)+index_current-1
3573          if(index(' F T ',string(index_blank:index_blank+2))==0)then
3574            write(message, '(8a)' )&
3575 &           'Found the token ',string(index_current:index_endword),' in the input file.',ch10,&
3576 &           'This variable should be given a logical value (T or F), but the following string was found :',&
3577 &           string(index_blank:index_blank+2),ch10,&
3578 &           'Action: check your input file. You likely misused the input variable.'
3579            MSG_ERROR(message)
3580          else
3581            index_blank=index_blank+2
3582          end if
3583 !        Treat possible string input variables
3584        else if(index(list_strings,blank//string(index_current:index_endword)//blank)/=0)then
3585 !        Every following string is accepted
3586          !write(std_out,*)"Found string variable: ",string(index_current:index_endword)
3587          !write(std_out,*)"in string: ",trim(string(index_current:))
3588          index_current=index(string(index_current:),blank)+index_current
3589          index_blank=index(string(index_current:),blank)+index_current-1
3590          !write(std_out,*)"next:: ",string(index_current:index_endword)
3591 
3592 !        If still not admitted, then there is a problem
3593        else
3594          write(message, '(7a)' )&
3595 &         'Found the token ',string(index_current:index_endword),' in the input file.',ch10,&
3596 &         'This name is not one of the registered input variable names (see https://www.abinit.org/doc).',ch10,&
3597 &         'Action: check your input file. You likely mistyped the input variable.'
3598          MSG_ERROR(message)
3599        end if
3600      end if
3601    end if
3602 
3603    index_current=index_blank+1
3604  end do
3605 
3606 end subroutine chkvars_in_string

m_parser/importxyz [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 importxyz

FUNCTION

 Examine the input string, to see whether data from xyz
 file(s) has to be incorporated.
 For each such xyz file, translate the relevant
 information into intermediate input variables compatible
 with the usual ABINIT formatting, then append it
 to the input string.

INPUTS

  string_raw*(strln)=raw string of character from input file (with original case)
  strln=maximal number of character of string, as declared in the calling routine

OUTPUT

SIDE EFFECTS

  lenstr=actual number of character in string
  string_upper*(strln)=string of character
   the string (with upper case) from the input file, to which the xyz data are appended to it

PARENTS

      m_ab7_invars_f90,parsefile

CHILDREN

      append_xyz,incomprs,wrtout

SOURCE

1780 subroutine importxyz(lenstr,string_raw,string_upper,strln)
1781 
1782 
1783 !This section has been created automatically by the script Abilint (TD).
1784 !Do not modify the following lines by hand.
1785 #undef ABI_FUNC
1786 #define ABI_FUNC 'importxyz'
1787 !End of the abilint section
1788 
1789  implicit none
1790 
1791 !Arguments ------------------------------------
1792 !scalars
1793  integer,intent(in) :: strln
1794  integer,intent(inout) :: lenstr
1795  character(len=*),intent(in) :: string_raw
1796  character(len=*),intent(inout) :: string_upper
1797 
1798 !Local variables-------------------------------
1799  character :: blank=' '
1800 !scalars
1801  integer :: dtset_len,ixyz,ii,index_already_done,index_xyz_fname
1802  integer :: index_xyz_fname_end,index_xyz_token,kk
1803  character(len=2) :: dtset_char
1804  character(len=500) :: message
1805  character(len=fnlen) :: xyz_fname
1806 
1807 !************************************************************************
1808 
1809  index_already_done=1
1810  ixyz=0
1811 
1812  do    ! Infinite do-loop, to identify the presence of the xyzFILE token
1813 
1814    index_xyz_token=index(string_upper(index_already_done:lenstr),"XYZFILE")
1815    if(index_xyz_token==0)exit
1816 
1817    ixyz=ixyz+1
1818    if(ixyz==1)then
1819      write(message,'(80a)')('=',ii=1,80)
1820      call wrtout(ab_out,message,'COLL')
1821    end if
1822 
1823 !  The xyzFILE token has been identified
1824    index_xyz_token=index_already_done+index_xyz_token-1
1825 
1826 !  Find the related dataset tag, and length
1827    dtset_char=string_upper(index_xyz_token+7:index_xyz_token+8)
1828    if(dtset_char(1:1)==blank)dtset_char(2:2)=blank
1829    dtset_len=len_trim(dtset_char)
1830 
1831 !  Find the name of the xyz file
1832    index_xyz_fname=index_xyz_token+8+dtset_len
1833    index_xyz_fname_end=index(string_upper(index_xyz_fname:lenstr),blank)
1834 
1835    if(index_xyz_fname_end ==0 )then
1836      write(message, '(5a,i4,2a)' )&
1837 &     'Could not find the name of the xyz file.',ch10,&
1838 &     'index_xyz_fname_end should be non-zero, while it is :',ch10,&
1839 &     'index_xyz_fname_end=',index_xyz_fname_end,ch10,&
1840 &     'Action: check the filename that was provided after the XYZFILE input variable keyword.'
1841      MSG_ERROR(message)
1842    end if
1843 
1844    index_xyz_fname_end=index_xyz_fname_end+index_xyz_fname-1
1845 
1846    index_already_done=index_xyz_fname_end
1847 
1848    xyz_fname=repeat(blank,fnlen)                  ! Initialize xyz_fname to a blank line
1849    xyz_fname=string_raw(index_xyz_fname:index_xyz_fname_end-1)
1850 
1851    write(message, '(3a)') ch10,&
1852 &   ' importxyz : Identified token XYZFILE, referring to file ',trim(xyz_fname)
1853    call wrtout(std_out,message,'COLL')
1854    call wrtout(ab_out,message,'COLL')
1855 
1856 !  Append the data from the xyz file to the string, and update the length of the string
1857    call append_xyz(dtset_char,lenstr,string_upper,xyz_fname,strln)
1858 
1859 !  erase the file name from string_upper
1860    string_upper(index_xyz_fname:index_xyz_fname_end-1) = blank
1861 
1862  end do
1863 
1864  if (index_already_done > 1) then
1865    xyz_fname=repeat(blank,fnlen) ! Initialize xyz_fname to a blank line
1866    call append_xyz("-1",lenstr,string_upper,xyz_fname,strln)
1867  end if
1868 
1869  if(ixyz/=0)then
1870    call incomprs(string_upper,lenstr)
1871 !  A blank is needed at the beginning of the string
1872    do kk=lenstr,1,-1
1873      string_upper(kk+1:kk+1)=string_upper(kk:kk)
1874    end do
1875    string_upper(1:1)=blank
1876    lenstr=lenstr+1
1877    write(message,'(a,80a,a)')ch10,('=',ii=1,80),ch10
1878    call wrtout(ab_out,message,'COLL')
1879  end if
1880 
1881 end subroutine importxyz

m_parser/inarray [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 inarray

FUNCTION

 Read the array of narr numbers located immediately after
 a specified blank in a string of character.
 Might read instead one word, after the specified blank.
 Takes care of multipliers.

INPUTS

  cs=character token
  marr=dimension of the intarr and dprarr arrays, as declared in the
   calling subroutine.
  narr=actual size of array to be read in  (if typevarphys='KEY', only narr=1 is allowed)
  string=character string containing the data.
  typevarphys=variable type (might indicate the physical meaning of
   for dimensionality purposes)
   'INT'=>integer
   'DPR'=>real(dp) (no special treatment)
   'LEN'=>real(dp) (expect a "length", identify bohr, au or angstrom,
       and return in au -atomic units=bohr- )
   'ENE'=>real(dp) (expect a "energy", identify Ha, hartree, eV, Ry, Rydberg)
   'BFI'=>real(dp) (expect a "magnetic field", identify T, Tesla)
   'LOG'=>integer, but read logical variable T,F,.true., or .false.
   'KEY'=>character, returned in token cs

OUTPUT

  intarr(1:narr), dprarr(1:narr)
   integer or real(dp) arrays, respectively,
   into which data is read. Use these arrays even for scalars.
  errcod: if /=0, then something went wrong in subroutine "inread"

 SIDE EFFECT
   b1=absolute location in string of blank which follows the token
             (will be modified in the execution)
   cs=at input  : character token
      at output : chain of character replacing the token (only if typevarphys='KEY')

PARENTS

      intagm

CHILDREN

      inread,wrtout

SOURCE

1566 subroutine inarray(b1,cs,dprarr,intarr,marr,narr,string,typevarphys)
1567 
1568 
1569 !This section has been created automatically by the script Abilint (TD).
1570 !Do not modify the following lines by hand.
1571 #undef ABI_FUNC
1572 #define ABI_FUNC 'inarray'
1573 !End of the abilint section
1574 
1575  implicit none
1576 
1577 !Arguments ------------------------------------
1578 !scalars
1579  integer,intent(in) :: marr,narr
1580  integer,intent(inout) :: b1
1581  character(len=*),intent(in) :: string
1582  character(len=*),intent(in) :: typevarphys
1583  character(len=fnlen),intent(inout) :: cs
1584 !arrays
1585  integer,intent(inout) :: intarr(marr) !vz_i
1586  real(dp),intent(out) :: dprarr(marr)
1587 
1588 !Local variables-------------------------------
1589  character(len=1), parameter :: blank=' '
1590 !scalars
1591  integer :: asciichar,b2,errcod,ii,integ,istar,nrep,strln
1592  real(dp) :: factor,real8
1593  character(len=3) :: typevar
1594  character(len=500) :: message
1595 
1596 ! *************************************************************************
1597 
1598 !DEBUG
1599 !write(std_out,'(2a)' )' inarray : token=',trim(cs)
1600 !write(std_out,'(a,i4)' )' inarray : narr=',narr
1601 !write(std_out,'(2a)' )' inarray : typevarphys=',typevarphys
1602 !ENDDEBUG
1603 
1604  ii=0
1605  typevar='INT'
1606  if(typevarphys=='LOG')typevar='INT'
1607  if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI')typevar='DPR'
1608  strln=len_trim(string)
1609 
1610  do while (ii<narr)
1611 
1612 !  Relative location of next blank after data
1613    if(b1>=strln)exit   ! b1 is the last character of the string
1614    b2=index(string(b1+1:),blank)
1615 !  If no second blank is found put the second blank just beyond strln
1616    if(b2==0) b2=strln-b1+1
1617 
1618    if(typevarphys=='KEY')then
1619      cs=string(b1+1:b1+b2-1)
1620      errcod=0
1621      exit
1622    end if
1623 
1624 !  nrep tells how many times to repeat input in array:
1625    nrep=1
1626 
1627 !  Check for *, meaning repeated input (as in list-directed input):
1628    istar=index(string(b1+1:b1+b2-1),'*')
1629    if (istar/=0) then
1630      if (istar==1) then ! Simply fills the array with the data, repeated as many times as needed
1631        nrep=narr-ii
1632        errcod=0
1633      else
1634        call inread(string(b1+1:b1+istar-1),istar-1,'INT',nrep,real8,errcod)
1635      end if
1636      if (errcod/=0) exit
1637 !    Shift starting position of input field:
1638      b1=b1+istar
1639      b2=b2-istar
1640    end if
1641 
1642 !  Read data internally by calling inread at entry ini:
1643    call inread(string(b1+1:b1+b2-1),b2-1,typevarphys,integ,real8,errcod)
1644    if (errcod/=0) exit
1645 
1646 !  Allow for list-directed input with repeat number nrep:
1647    if(typevar=='INT')then
1648      intarr(1+ii:min(nrep+ii,narr))=integ
1649    else if(typevar=='DPR')then
1650      dprarr(1+ii:min(nrep+ii,narr))=real8
1651    else
1652      MSG_BUG('Disallowed typevar='//typevar)
1653    end if
1654    ii=min(ii+nrep,narr)
1655 
1656 !  Find new absolute location of next element of array:
1657    b1=b1+b2
1658 
1659 !  End do while (ii<narr). Note "exit" instructions within loop.
1660  end do
1661 
1662 !if (ii>narr) then
1663 !write(message, '(a,a,a,a,a,a,a,a,a,a,i4,a,i4,a,a,a,a,a,a,a,a)' ) ch10,&
1664 !' inarray : ERROR -',ch10,&
1665 !&  '  Too many data are provided in the input file for',ch10,&
1666 !&  '  the keyword "',cs,'" :',ch10,&
1667 !&  '  attempted to read',ii,' elements for array length',narr,ch10,&
1668 !&  '  This might be due to an erroneous value for the size ',ch10,&
1669 !&  '  of this array, in the input file.',ch10,&
1670 !&  '  Action: check the data provided for this keyword,',ch10,&
1671 !&  '  as well as its declared dimension. They do not match.'
1672 !call wrtout(std_out,message,'COLL')
1673 !end if
1674 
1675  if(errcod/=0)then
1676 
1677    write(message, '(8a,i0,a)' ) ch10,&
1678 &   ' inarray : ',ch10,&
1679 &   '  An error occurred reading data for keyword "',trim(cs),'",',ch10,&
1680 &   '  looking for ',narr,' array elements.'
1681    call wrtout(std_out,message,do_flush=.true.)
1682 
1683    write(message,'(8a)')&
1684 &   'There is a problem with the input file : maybe  ',ch10,&
1685 &   'a disagreement between the declared dimension of the array,',ch10,&
1686 &   'and the number of data actually provided. ',ch10,&
1687 &   'Action: correct your input file, and especially the keywork', trim(cs)
1688    MSG_ERROR(message)
1689  end if
1690 
1691 !In case of 'LEN', 'ENE', or 'BFI', try to identify the unit
1692  if(typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI')then
1693    do
1694 
1695 !    Relative location of next blank after data
1696      if(b1>=strln)exit   ! b1 is the last character of the string
1697      b2=index(string(b1+1:),blank)
1698 !    If no second blank is found put the second blank just beyond strln
1699      if(b2==0) b2=strln-b1+1
1700 
1701 !    DEBUG
1702 !    write(std_out,*)' inarray : string(b1+1:)=',string(b1+1:)
1703 !    write(std_out,*)' inarray : b2=',b2
1704 !    write(std_out,*)' typevarphys==',typevarphys
1705 !    ENDDEBUG
1706 
1707 !    Identify the presence of a non-digit character
1708      asciichar=iachar(string(b1+1:b1+1))
1709      if(asciichar<48 .or. asciichar>57)then
1710        factor=one
1711        if(typevarphys=='LEN' .and. b2>=7)then
1712          if(string(b1+1:b1+6)=='ANGSTR')then
1713            factor=one/Bohr_Ang
1714          end if
1715        else if(typevarphys=='ENE' .and. b2>=3)then
1716          if(string(b1+1:b1+3)=='RY ')then
1717            factor=half
1718          else if(string(b1+1:b1+3)=='EV ')then
1719            factor=one/Ha_eV
1720          end if
1721        else if(typevarphys=='ENE' .and. b2>=2)then
1722          if(string(b1+1:b1+2)=='K ')then
1723            factor=kb_HaK
1724          end if
1725        else if(typevarphys=='BFI' .and. b2>=2)then
1726          if(string(b1+1:b1+2)=='T ' .or. string(b1+1:b1+2)=='TE')then
1727            factor=BField_Tesla
1728          end if
1729        end if
1730        dprarr(1:narr)=dprarr(1:narr)*factor
1731        exit
1732      else
1733 !      A digit has been observed, go to the next sequence
1734        b1=b2
1735        cycle
1736      end if
1737 
1738    end do
1739  end if
1740 
1741 !DEBUG
1742 !write(std_out,*)' inarray : exit '
1743 !write(std_out,*)' dprarr(1:narr)==',dprarr(1:narr)
1744 !ENDDEBUG
1745 
1746 end subroutine inarray

m_parser/incomprs [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 incomprs

FUNCTION

 Compresses input character string into the following form:
 (1) Replaces tabs and all other characters lexically less than
 SP (blank) with SP (blank), where lexically less than refers to
 the ASCII collating sequence (SP is hex 20, dec 32).
 The use of llt is needed e.g. on the IBM 9000 because it does not
 handle tab characters sensibly in its AIX fortran.
 Also replace occurences of '=' by a SP.
 (2) Removes all repeated blanks, ignoring trailing blanks
 after first (returns nontrailing final length in arg 'length').
 (3) Makes first character in string NONBLANK.  This is done
 to prevent double blanks from occurring when compressed string
 is concatenated with other compressed strings.
 (4) Makes last character (string(length:length)) a blank.
 If input string is entirely blank or tabs, simply returns with length=0.

INPUTS

  (see side effects)

OUTPUT

  length=nonblank, nontab length of string as defined above

 SIDE EFFECT
  string=at input:  character string
         at output: repeated blanks and tabs have been removed and
                    remaining tabs have been replaced by blanks

PARENTS

      importxyz,instrng

CHILDREN

      inreplsp

SOURCE

751 subroutine incomprs(string,length)
752 
753 
754 !This section has been created automatically by the script Abilint (TD).
755 !Do not modify the following lines by hand.
756 #undef ABI_FUNC
757 #define ABI_FUNC 'incomprs'
758 !End of the abilint section
759 
760  implicit none
761 
762 !Arguments ------------------------------------
763 !scalars
764  integer,intent(out) :: length
765  character(len=*),intent(inout) :: string
766 
767 !Local variables-------------------------------
768  character(len=1) :: blank=' '
769 !scalars
770  integer :: bb,f1,ii,jj,kk,l1,lbef,lcut,lold,stringlen
771  character(len=500) :: message
772 
773 ! *************************************************************************
774 
775 !
776 !String length determined by calling program declaration of "string"
777  stringlen=len(string)
778  length=stringlen
779 !
780 !Only proceed if string has nonzero length
781  if (length>0) then
782 !  Find last nonblank character (i.e. nonblank and nontab length)
783    length=len_trim(string)
784    if (length==0) then
785 !    Line is all blanks or tabs so do not proceed
786 !    write(std_out,*)' incomprs: blank line encountered'
787    else
788 
789 !    Replace all characters lexically less than SP, and '=', by SP (blank)
790      call inreplsp(string(1:length))
791 
792 !    Continue with parsing
793 !    l1 is set to last nonblank, nontab character position
794      l1=length
795      do ii=1,l1
796        if (string(ii:ii)/=blank) exit
797      end do
798 
799 !    f1 is set to first nonblank, nontab character position
800      f1=ii
801 !    lbef is number of characters in string starting at
802 !    first nonblank, nontab and going to last
803      lbef=l1-f1+1
804 
805 !    Process characters one at a time from right to left:
806      bb=0
807      lcut=lbef
808      do ii=1,lbef
809        jj=lbef+f1-ii
810 !      set bb=position of next blank coming in from right
811        if (string(jj:jj)==blank) then
812          if (bb==0) then
813            bb=jj
814          end if
815        else
816          if (bb/=0) then
817 !          if several blanks in a row were found, cut from string
818            if (jj<bb-1) then
819 !            lold becomes string length before cutting blanks
820              lold=lcut
821 !            lcut will be new string length
822              lcut=lcut-(bb-1-jj)
823 !            redefine string with repeated blanks gone
824              do kk=1,f1+lcut-1-jj
825                string(jj+kk:jj+kk)=string(kk+bb-1:kk+bb-1)
826              end do
827            end if
828            bb=0
829          end if
830        end if
831      end do
832 !
833 !    Remove initial blanks in string if any
834      if (f1>1) then
835        string(1:lcut)=string(f1:f1+lcut-1)
836      end if
837 !
838 !    Add blank on end unless string had no extra space
839      if (lcut==stringlen) then
840        write(message,'(a,i7,a,a,a,a,a,a,a,a)')&
841 &       'For input file, with data forming a string of',stringlen,' characters,',ch10,&
842 &       'no double blanks or tabs were found.',ch10,&
843 &       'This is unusual for an input file (or any file),',ch10,&
844 &       'and may cause parsing trouble.  Is this a binary file?',ch10
845        MSG_WARNING(message)
846      else
847        length=lcut+1
848        string(length:length)=blank
849      end if
850    end if
851  end if
852 
853 end subroutine incomprs

m_parser/inread [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 inread

FUNCTION

 Carry out internal read from input character string, starting
 at first character in string, reading ndig digits (including possible
 sign, decimal, and exponent) by computing the appropriate format and
 performing a formatted read (list-directed read would be perfect for
 this application but is inconsistent with internal read according to
 Fortran90 standard).
 In case of a real number, this routine
 is also able to read SQRT(number): return the square root of the number.

INPUTS

  string=character string.
  ndig=length of field to be read (including signs, decimals, and exponents).
  typevarphys=variable type (might indicate the physical meaning of
   for dimensionality purposes)
   'INT'=>integer
   'DPR','LEN','ENE'=>real(dp) (no special treatment)
   'LOG'=>integer, but read logical variable T,F,.true., or .false.
   'KEY'=>character, returned in token

OUTPUT

  outi or outr (integer or real respectively)
  errcod, =0 for success, 1,2 for ini, inr failure resp.

PARENTS

      adini,inarray

CHILDREN

SOURCE

195 subroutine inread(string,ndig,typevarphys,outi,outr,errcod)
196 
197 
198 !This section has been created automatically by the script Abilint (TD).
199 !Do not modify the following lines by hand.
200 #undef ABI_FUNC
201 #define ABI_FUNC 'inread'
202 !End of the abilint section
203 
204  implicit none
205 
206 !Arguments ------------------------------------
207 !scalars
208  integer,intent(in) :: ndig
209  integer,intent(out) :: errcod,outi
210  real(dp),intent(out) :: outr
211  character(len=*),intent(in) :: string
212  character(len=*),intent(in) :: typevarphys
213 
214 !Local variables-------------------------------
215 !scalars
216  integer :: done,idig,index_slash,sign
217  real(dp) :: den,num
218  logical :: logi
219  character(len=500) :: msg
220 
221 ! *************************************************************************
222 
223 !write(std_out,*)'inread : enter '
224 !write(std_out,*)'string(1:ndig)=',string(1:ndig)
225 !write(std_out,*)'typevarphys=',typevarphys
226 
227  if (typevarphys=='INT') then
228 
229 !  integer input section
230    read (unit=string(1:ndig),fmt=*,iostat=errcod) outi
231    if(errcod/=0)then
232 !    integer reading error
233      write(std_out,'(/,a,/,a,i0,a)' ) &
234 &     ' inread : ERROR -',&
235 &     '  Attempted to read ndig=',ndig,' integer digits,'
236      write(std_out,'(a,a,a)' ) '   from string(1:ndig)= ',string(1:ndig),&
237 &     ', to initialize an integer variable'
238      errcod=1
239    end if
240 
241  else if (typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI') then
242 
243 !  real(dp) input section
244 
245 !  Special treatment of SQRT(xxx) or -SQRT(xxx) chains of characters, where xxx can be a fraction
246    done=0
247    if (ndig>5) then
248      if(string(1:5)=='SQRT(' .and. string(ndig:ndig)==')')then
249        done=1 ; sign=1
250      else if(string(1:6)=='-SQRT(' .and. string(ndig:ndig)==')')then
251        done=1 ; sign=2
252      end if
253      if(done==1)then
254        index_slash=index(string(5+sign:ndig-1),'/')
255        if(index_slash==0)then
256          read (unit=string(5+sign:ndig-1),fmt=*,iostat=errcod) outr
257        else if(index_slash/=0)then
258          read (unit=string(5+sign:5+sign+index_slash-2),fmt=*,iostat=errcod) num
259          if(errcod==0)then
260            read (unit=string(5+sign+index_slash:ndig-1),fmt=*,iostat=errcod) den
261            if(errcod==0)then
262              if(abs(den)<tol12)then
263                errcod=1
264              else
265                outr=num/den
266              end if
267            end if
268          end if
269        end if
270        if(outr<-tol12)then
271          errcod=1
272        else
273          outr=sqrt(outr)
274          if(sign==2)outr=-outr
275        end if
276      end if
277    end if
278 
279 !  Special treatment of fractions
280    if(done==0)then
281      index_slash=index(string(1:ndig),'/')
282      if(index_slash/=0)then
283        done=1
284        read (unit=string(1:index_slash-1),fmt=*,iostat=errcod) num
285        if(errcod==0)then
286          read (unit=string(index_slash+1:ndig),fmt=*,iostat=errcod) den
287          if(errcod==0)then
288            if(abs(den)<tol12)then
289              errcod=1
290            else
291              outr=num/den
292            end if
293          end if
294        end if
295      end if
296    end if
297 
298 !  Normal treatment of floats
299    if(done==0)then ! Normal treatment of float numbers
300      read (unit=string(1:ndig),fmt=*,iostat=errcod) outr
301    end if
302 
303 !  Treatment of errors
304    if(errcod/=0)then
305 !    real(dp) data reading error
306      write(std_out,'(/,a,/,a,i0,a)' ) &
307 &     'inread : ERROR -',&
308 &     'Attempted to read ndig=',ndig,' floating point digits,'
309      write(std_out,'(a,a,a)' ) '   from string(1:ndig) ',string(1:ndig),&
310 &     ', to initialize a floating variable.'
311      errcod=2
312    end if
313 
314  else if (typevarphys=='LOG') then
315 
316    read (unit=string(1:ndig),fmt=*,iostat=errcod) logi
317    if(errcod/=0)then
318 !    integer reading error
319      write(std_out,'(/,a,/,a,i0,a)' ) &
320 &     'inread : ERROR -',&
321 &     'Attempted to read ndig=',ndig,' integer digits,'
322      write(std_out,'(a,a,a)' ) '   from string(1:ndig)= ',string(1:ndig),', to initialize a logical variable.'
323      errcod=3
324    end if
325    if(logi)outi=1
326    if(.not.logi)outi=0
327 
328  else
329    write(msg,'(4a)' ) &
330 &   'Argument typevarphys must be INT,DPR,LEN,ENE,BFI or LOG ',ch10,&
331 &   'but input value was: ',trim(typevarphys)
332    MSG_ERROR(msg)
333  end if
334 
335  if(errcod /= 0)then
336    do idig=1,ndig
337      if( string(idig:idig) == 'O' )then
338        write(std_out,'(/,a,/,a,a,a)' ) &
339 &       'inread : WARNING -',&
340 &       'Note that this string contains the letter O. ',ch10,&
341 &       'It is likely that this letter should be replaced by the number 0.'
342        exit
343      end if
344    end do
345  end if
346 
347 end subroutine inread

m_parser/inreplsp [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 inreplsp

FUNCTION

 Replace all occurrences of characters lexically less than SP (blank)
 by SP in the input string, returning modified string of same length.
 Also replace a '=' by a SP.

INPUTS

  string=character string to be modified

OUTPUT

  (see side effects)

SIDE EFFECTS

  string=same character string with ASCII (decimal) 0-31 replaced by 32.

PARENTS

      incomprs

CHILDREN

SOURCE

669 subroutine inreplsp(string)
670 
671 
672 !This section has been created automatically by the script Abilint (TD).
673 !Do not modify the following lines by hand.
674 #undef ABI_FUNC
675 #define ABI_FUNC 'inreplsp'
676 !End of the abilint section
677 
678  implicit none
679 
680 !Arguments ------------------------------------
681 !scalars
682  character(len=*),intent(inout) :: string
683 
684 !Local variables-------------------------------
685 !scalars
686  integer :: ilenth,length
687 
688 ! *************************************************************************
689 
690 !Get length of string
691  length=len(string)
692 
693 !Proceed only if string has nonzero length
694  if (length>0) then
695 
696 !  Do replacement by going through input
697 !  character string one character at a time
698    do ilenth=1,length
699      if (llt(string(ilenth:ilenth),' ')) then
700        string(ilenth:ilenth)=' '
701      end if
702      if(string(ilenth:ilenth)=='=')then
703        string(ilenth:ilenth)=' '
704      end if
705    end do
706 
707  end if
708 
709 end subroutine inreplsp

m_parser/instrng [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 instrng

FUNCTION

 Read the input file, and product a string of character,
 with all data, to be analyzed in later routines. The length
 of this string is lenstr. This number is checked to be smaller
 than the dimension of the string of character, namely strln .

INPUTS

  filnam=name of the input file, to be read
  option= if 0, simple storing of the character string,
             no special treatment for ABINIT (comment delimiters, checks, include ...)
          if 1, suppresses text after an ABINIT comment delimiter (! or #),
             checks that a minus sign is followed by a number ...
                check for INCLUDE statement:
                if present, add string from included file
  strln=maximal number of character of string, as declared in the calling routine

OUTPUT

  lenstr=actual number of character in string
  string*(strln)=string of character

PARENTS

      anaddb,importcml,localorb_S,lwf,parsefile

CHILDREN

      incomprs,instrng,wrtout

SOURCE

382 recursive subroutine instrng(filnam,lenstr,option,strln,string)
383 
384 
385 !This section has been created automatically by the script Abilint (TD).
386 !Do not modify the following lines by hand.
387 #undef ABI_FUNC
388 #define ABI_FUNC 'instrng'
389 !End of the abilint section
390 
391  implicit none
392 
393 !Arguments ------------------------------------
394 !scalars
395  integer,intent(in) :: option,strln
396  integer,intent(out) :: lenstr
397  character(len=*),intent(in) :: filnam
398  character(len=*),intent(out) :: string
399 
400 !Local variables-------------------------------
401  character :: blank=' '
402 !scalars
403  integer,save :: include_level=-1
404  integer :: ii,ii1,ii2,ij,iline,ios,iost,lenc,lenstr_inc,mline,nline1,input_unit
405  logical :: include_found,ex
406  character(len=1) :: string1
407  character(len=3) :: string3
408  character(len=500) :: filnam_inc,msg
409  character(len=fnlen+20) :: line
410  character(len=strlen),pointer :: string_inc
411 
412 !************************************************************************
413 
414  DBG_ENTER("COLL")
415 
416 !%%%%%%%%%%%%%%%%%%%%%%%%
417 !read in string from file
418 !%%%%%%%%%%%%%%%%%%%%%%%%
419 
420 !The file can be included in another (prevent too many include levels)
421  include_level=include_level+1
422  if (include_level>2) then
423    write(msg, '(3a)' ) &
424 &   'At least 4 levels of included files are present in input file !',ch10,&
425 &   'This is not allowed. Action: change your input file.'
426    MSG_ERROR(msg)
427  end if
428 
429 !Open data file and read one line at a time, compressing data
430 !and concatenating into single string:
431  if (open_file(filnam,msg,newunit=input_unit,form="formatted",status="old",action="read") /= 0) then
432    MSG_ERROR(msg)
433  end if
434  rewind (unit=input_unit)
435 
436 !Initialize string to blanks
437  string=blank
438  lenstr=1
439 
440 !Set maximum number lines to be read to some large number
441  mline=50000
442  do iline=1,mline
443 
444 !  Keeps reading lines until end of input file
445    read (unit=input_unit,fmt= '(a)' ,iostat=ios) line(1:fnlen+20)
446 !  Hello ! This is a commentary. Please, do not remove me.
447 !  In fact, this commentary protect tests_v4 t47 for miscopying
448 !  the input file into the output string. It _is_ strange.
449 !  The number of lines in the commentary is also resulting from
450 !  a long tuning..
451 
452 !  DEBUG
453 !  write(std_out,*)' instrng, iline=',iline,' ios=',ios,' echo :',trim(line(1:fnlen+20))
454 !  ENDDEBUG
455 
456 !  Exit the reading loop when arrived at the end
457    if(ios/=0)then
458      backspace(input_unit)
459      read (unit=input_unit,fmt= '(a1)' ,iostat=ios) string1
460      if(ios/=0)exit
461      backspace(input_unit)
462      read (unit=input_unit,fmt= '(a3)' ,iostat=ios) string3
463      if(string3=='end')exit
464      write(msg, '(3a,i0,11a)' ) &
465 &     'It is observed in the input file: ',TRIM(filnam),', line number ',iline,',',ch10,&
466 &     'that there is a non-zero IO signal.',ch10,&
467 &     'This is normal when the file is completely read.',ch10,&
468 &     'However, it seems that the error appears while your file has not been completely read.',ch10,&
469 &     'Action: correct your file. If your file seems correct, then,',ch10,&
470 &     'add the keyword ''end'' at the very beginning of the last line of your input file.'
471      MSG_ERROR(msg)
472    end if
473 
474 !  Find length of input line ignoring delimiter characters (# or !)
475 !  and any characters beyond it (allows for comments beyond # or !)
476    ii1=index(line(1:fnlen+20),'#')
477    ii2=index(line(1:fnlen+20),'!')
478    if ( (ii1==0 .and. ii2==0) .or. option==0 ) then
479 !    delimiter character was not found on line so use full line
480      ii=fnlen+20
481    else if(ii1==0)then
482 !    ii will represent length of line up to but not including !
483      ii=ii2-1
484    else if(ii2==0)then
485 !    ii will represent length of line up to but not including #
486      ii=ii1-1
487    else
488      ii=min(ii1,ii2)-1
489    end if
490 
491 !  Checks that nothing is left beyond fnlen
492    if(ii>fnlen)then
493      do ij=fnlen+1,ii
494        if(line(ij:ij)/=' ')then
495          write(msg,'(3a,i0,3a,i0,3a)' ) &
496 &         'It is observed in the input file: ',TRIM(filnam),' line number ',iline,',',ch10,&
497 &         'that more than ',fnlen,' columns are used.',ch10,&
498 &         'This is not allowed. Change this line of your input file.'
499          MSG_ERROR(msg)
500        end if
501      end do
502    end if
503 
504    if (ii>0) then
505 !    Check for the occurence of a minus sign followed by a blank
506      ij=index(line(1:ii),'- ')
507      if (ij>0 .and. option==1) then
508        write(msg, '(3a,i0,11a)' ) &
509 &       'It is observed in the input file:, ',TRIM(filnam),' line number ',iline,',',ch10,&
510 &       'the occurence of a minus sign followed',ch10,&
511 &       'by a blank. This is forbidden.',ch10,&
512 &       'If the minus sign is meaningful, do not leave a blank',ch10,&
513 &       'between it and the number to which it applies.',ch10,&
514 &       'Otherwise, remove it.'
515        MSG_ERROR(msg)
516      end if
517 !    Check for the occurence of a tab
518      ij=index(line(1:ii),char(9))
519      if (ij>0 .and. option==1 ) then
520        write(msg, '(3a,i0,3a)' ) &
521 &       'The occurence of a tab, in the input file: ',TRIM(filnam),' line number ',iline,',',ch10,&
522 &       'is observed. This sign is confusing, and has been forbidden.'
523        MSG_ERROR(msg)
524      end if
525 
526 !    Check for the occurence of a include statement
527      include_found=.false.
528      if (option==1) then
529 !      Look for include statement
530        ii1=index(line(1:ii),"include");ii2=index(line(1:ii),"INCLUDE")
531        include_found=(ii1>0.or.ii2>0)
532        if (include_found) then
533          ij=max(ii1,ii2);ii1=0;ii2=0
534 !        Look for quotes (ascii 34)
535          ii1=index(line(ij+7:ii),char(34))
536          if (ii1>1) ii2=index(line(ij+7+ii1:ii),char(34))
537 !        Look for quotes (ascii 39)
538          if (ii1==0.and.ii2==0) then
539            ii1=index(line(ij+7:ii),char(39))
540            if (ii1>1) ii2=index(line(ij+7+ii1:ii),char(39))
541          end if
542 !        Check if quotes are correctly set
543          ex=(ii1<=1.or.ii2<=1)
544          if (.not.ex) then
545            msg=line(ij+7:ij+5+ii1)
546            call incomprs(msg(1:ii1-1),lenc)
547            ex=(len(trim(msg))/=0)
548          end if
549          if (ex) then
550            write(msg, '(6a)' ) &
551 &           'A "include" statement has been found in input file: ',TRIM(filnam),ch10,&
552 &           'but there must be a problem with the quotes.',ch10,&
553 &           'Action: change your input file.'
554            MSG_ERROR(msg)
555          end if
556 !        Store included file name
557          filnam_inc=line(ij+7+ii1:ij+5+ii1+ii2)
558 !        Extract include statement from line
559          lenc=ii1+ii2+7
560          msg(1:ii-lenc)=line(1:ij-1)//line(ij+lenc:ii)
561          ii=ii-lenc;line(1:ii)=msg(1:ii)
562        end if
563      end if
564 
565 !    Compress: remove repeated blanks, make all ASCII characters
566 !    less than a blank (and '=') to become a blank.
567      call incomprs(line(1:ii),lenc)
568 
569    else
570 !    ii=0 means line starts with #, is entirely a comment line
571      lenc=0;include_found=.false.
572    end if
573 
574 !  Check resulting total string length
575    if (lenstr+lenc>strln) then
576      write(msg, '(8a)' ) &
577 &     'The size of your input file: ',TRIM(filnam),' is such that the internal',ch10,&
578 &     'character string that should contain it is too small.',ch10,&
579 &     'Action: decrease the size of your input file,',ch10,&
580 &     'or contact the ABINIT group.'
581      MSG_ERROR(msg)
582    end if
583 
584    if (lenc>0) then
585 !    Concatenate new compressed characters
586 !    with previous part of compressed string (unless all blank)
587      string(lenstr+1:lenstr+lenc)=line(1:lenc)
588    end if
589 !  Keep track of total string length
590    lenstr=lenstr+lenc
591 
592 !  Eventually (recursively) read included file
593    if (include_found) then
594 !    Check file existence
595      inquire(file=filnam_inc ,iostat=iost,exist=ex)
596      if ((.not.ex).or.(iost/=0)) then
597        write(msg, '(5a)' ) &
598 &       'Input file: ',TRIM(filnam),' reading: the included file ',trim(filnam_inc),' cannot be found !'
599        MSG_ERROR(msg)
600      end if
601 !    Read included file (warning: recursive call !)
602      ABI_ALLOCATE(string_inc,)
603      call instrng(trim(filnam_inc),lenstr_inc,option,strln-lenstr,string_inc)
604 !    Check resulting total string length
605      if (lenstr+lenstr_inc>strln) then
606        write(msg, '(6a)' ) &
607 &       'The size of your input file: ',TRIM(filnam),' (including included files) is such that',ch10,&
608 &       'the internal character string that should contain it is too small !',ch10,&
609 &       'Action: decrease the size of your input file.'
610        MSG_ERROR(msg)
611      end if
612 !    Concatenate total string
613      string(lenstr+1:lenstr+lenstr_inc)=string_inc(1:lenstr_inc)
614      lenstr=lenstr+lenstr_inc
615      ABI_DEALLOCATE(string_inc)
616    end if
617 
618 !  If mline is reached, something is wrong
619    if (iline>=mline) then
620      write(msg, '(a,i0,2a,i0,4a)' ) &
621 &     'The number of lines already read from input file=',iline,ch10,&
622 &     'is equal or greater than maximum allowed mline=',mline,ch10,&
623 &     'Action: you could decrease the length of the input file, or',ch10,&
624 &     'contact the ABINIT group.'
625      MSG_ERROR(msg)
626    end if
627 
628 !  End loop on iline. Note that there is an "exit" instruction in the loop
629  end do
630 
631  nline1=iline-1
632  close (unit=input_unit)
633 
634  write(msg,'(a,i0,3a)')'-instrng: ',nline1,' lines of input have been read from file ',trim(filnam),ch10
635  call wrtout(std_out,msg,'COLL')
636 
637  include_level=include_level-1
638 
639  DBG_EXIT("COLL")
640 
641 end subroutine instrng

m_parser/intagm [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 intagm

FUNCTION

 Search input 'string' for specific 'token'. Search depends on
 input dataset through 'jdtset'. Then, return the information
 mentioned after 'token'.
 See the "notes" section

INPUTS

  jdtset=see the notes section
  marr=dimension of the intarr and dprarr arrays, as declared in the calling subroutine.
  narr=actual size of array to be read in.
  string=character string containing 'tags' and data.
  token=character string for 'tag'.
  typevarphys= variable type (might indicate the physical meaning of for dimensionality purposes)
   'INT'=>integer
   'DPR'=>real(dp) (no special treatment)
   'LEN'=>real(dp) (expect a "length", identify bohr, au or angstrom,
       and return in au -atomic units=bohr- )
   'ENE'=>real(dp) (expect a "energy", identify Ha, hartree, eV, Ry, Rydberg)
   'LOG'=>integer, but read logical variable T,F,.true., or .false.
   'KEY'=>character, returned in key_value

OUTPUT

  intarr(1:narr), dprarr(1:narr)
   integer or real(dp) arrays, respectively (see typevarphys),
   into which data is read if typevarphys/='KEY'. Use these arrays even for scalars.
  tread is an integer : tread = 0 => no data was read
                        tread = 1 => data was read
  ds_input is an optional integer flag:
           ds_input = 0 => value was found which is not specific to jdtset
           ds_input > 0 => value was found which is specific to jdtset
   one could add more information, eg whether a ? or a : was used, etc...
   [key_value]=Stores the value of key if typevarphys=="KEY"
               String of len fnlen

NOTES

 If jdtset==0:

  Search compressed 'string' for blank//'token'//blank and
  read input data beside 'token', to be read into appropriate variable.
  For this routine to find a given token, the token has to be preceded
  and followed by blanks--i.e. the first token should not start out as
  the first character in the input file.  This is checked in the calling
  subroutine 'input'. Calls inread which performs internal read from
  specified string.  Also calls upper which maps characters to all upper case.
  Also checks whether there is an occurence of blank//'token'//digit,
  in which case the input file might be erroneous, so stops.

 If jdtset is a positive number:

  (1) First search for modified string, blank//'token'//jdtset//blank

  (2a) if the occurence of (1) is not found,
       look for other modified strings,
       blank//'token'//'?'//unities//blank
       or
       blank//'token'//dozens//'?'//blank
       (issue an error message if more than one occurs)
       where jdtset=dozens*10+unities (decimal decomposition of jdtset)
       if one of them exists, just take the value
       Note that unities is a one-digit number, while dozens might be bigger than 9.

  (2b-2c) search for a series, with the following tokens :
       (issue an error message if more than one occurs, or
       goto (3) if none exist)

      blank//'token'//':'//blank
      if it exists, then a series might have been defined in the input file
      must thus find either the increment, blank//'token'//'+'//blank,
      or the multiplicative factor, blank//'token'//'*'//blank

      blank//'token'//'?'//':'//blank
      if it exists, then a series for the inner loop
      might have been defined in the input file
      must thus find either the increment, blank//'token'//'?'//'+'//blank,
      or the multiplicative factor, blank//'token'//'?'//'*'//blank

      blank//'token'//':'//'?'//blank
      if it exists, then a series for the outer loop
      might have been defined in the input file
      must thus find either the increment, blank//'token'//'+'//'?'//blank,
      or the multiplicative factor, blank//'token'//'*'//'?'//blank

  (3) if neither (1) nor (2) are found, search for the 'normal'
       string, blank//'token'//blank

PARENTS

      ingeo,ingeobld,inkpts,inqpt,invacuum,invars0,invars1,invars2
      m_ab7_invars_f90,m_anaddb_dataset,m_band2eps_dataset,m_intagm_img
      m_multibinit_dataset,macroin,mpi_setup,parsefile,ujdet

CHILDREN

      appdig,inarray,inupper,wrtout

SOURCE

 957 subroutine intagm(dprarr,intarr,jdtset,marr,narr,string,token,tread,typevarphys,ds_input,key_value)
 958 
 959 
 960 !This section has been created automatically by the script Abilint (TD).
 961 !Do not modify the following lines by hand.
 962 #undef ABI_FUNC
 963 #define ABI_FUNC 'intagm'
 964 !End of the abilint section
 965 
 966  implicit none
 967 
 968 !Arguments ------------------------------------
 969 !scalars
 970  integer,intent(in) :: jdtset,marr,narr
 971  integer,intent(out) :: tread
 972  integer,intent(out),optional :: ds_input
 973  character(len=*),intent(in) :: string
 974  character(len=*),intent(in) :: token
 975  character(len=*),intent(in) :: typevarphys
 976  character(len=fnlen),optional,intent(out) :: key_value
 977 !arrays
 978  integer,intent(inout) :: intarr(marr) !vz_i
 979  real(dp),intent(inout) :: dprarr(marr) !vz_i
 980 
 981 !Local variables-------------------------------
 982  character(len=1), parameter :: blank=' '
 983 !scalars
 984  integer :: b1,cs1len,cslen,dozens,ier,itoken,itoken1,itoken2,itoken2_1colon
 985  integer :: itoken2_1plus,itoken2_1times,itoken2_2colon,itoken2_2plus
 986  integer :: itoken2_2times,itoken2_colon,itoken2_plus,itoken2_times
 987  integer :: itoken_1colon,itoken_1plus,itoken_1times,itoken_2colon,itoken_2plus
 988  integer :: itoken_2times,itoken_colon,itoken_plus,itoken_times,number,opttoken
 989  integer :: sum_token,toklen,trial_cslen,trial_jdtset,unities
 990  integer :: ds_input_
 991  character(len=4) :: appen
 992  character(len=3) :: typevar
 993  character(len=500) :: message
 994  character(len=fnlen) :: cs,cs1,cs1colon,cs1plus,cs1times,cs2colon,cs2plus
 995  character(len=fnlen) :: cs2times,cscolon,csplus,cstimes,trial_cs
 996 !arrays
 997  integer,allocatable :: int1(:),int2(:)
 998  real(dp),allocatable :: dpr1(:),dpr2(:)
 999 
1000 ! *************************************************************************
1001 
1002  ABI_CHECK(marr >= narr, sjoin("marr", itoa(marr)," < narr ", itoa(narr)))
1003 
1004  ds_input_ = -1
1005 
1006  dozens=jdtset/10
1007  unities=jdtset-10*dozens
1008 
1009  if(jdtset<0)then
1010    write(message,'(a,i0,a)')' jdtset=',jdtset,', while it should be non-negative.'
1011    MSG_ERROR(message)
1012  end if
1013 
1014  if(jdtset>9999)then
1015    write(message,'(a,i0,a)')' jdtset=',jdtset,', while it must be lower than 10000.'
1016    MSG_ERROR(message)
1017  end if
1018 
1019 !Default values : nothing has been read
1020  itoken=0
1021  opttoken=0
1022 !Initialise flags in case of opttoken >= 2 later.
1023  itoken_times=0
1024  itoken_plus=0
1025  itoken_colon=0
1026  cslen=1
1027 
1028  if (narr/=0) then
1029 
1030    toklen=len_trim(token)
1031 
1032 !  --------------------------------------------------------------------------
1033 !  (1) try to find the token with dataset number appended
1034    if(jdtset>0)then
1035 
1036      call appdig(jdtset,'',appen)
1037      cs=blank//token(1:toklen)//trim(appen)//blank
1038      if(jdtset<10) then
1039        cslen=toklen+3
1040      else if(jdtset<100) then
1041        cslen=toklen+4
1042      else if(jdtset<1000) then
1043        cslen=toklen+5
1044      else if(jdtset<10000)then
1045        cslen=toklen+6
1046      end if
1047 !    Map token to all upper case (make case-insensitive):
1048      call inupper(cs)
1049 !    Absolute index of blank//token//blank in string:
1050      itoken=index(string,cs(1:cslen))
1051 !    Look for another occurence of the same token in string, if so, leaves:
1052      itoken2=index(string,cs(1:cslen), BACK=.true. )
1053      if(itoken/=itoken2)then
1054        write(message, '(7a)' )&
1055 &       'There are two occurences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1056 &       'This is confusing, so it has been forbidden.',ch10,&
1057 &       'Action: remove one of the two occurences.'
1058        MSG_ERROR(message)
1059      end if
1060 
1061      if(itoken/=0) then
1062        opttoken=1
1063        ds_input_=jdtset
1064      end if
1065    end if
1066 
1067 !  --------------------------------------------------------------------------
1068 !  (2a) try to find the token appended with a string that contains the metacharacter "?".
1069 
1070    if(jdtset>0 .and. opttoken==0)then
1071 
1072 !    Use the metacharacter for the dozens, and save in cs and itoken
1073      write(appen,'(i1)')unities
1074      cs=blank//token(1:toklen)//'?'//trim(appen)//blank
1075      cslen=toklen+4
1076 !    Map token to all upper case (make case-insensitive):
1077      call inupper(cs)
1078 !    Absolute index of blank//token//blank in string:
1079      itoken=index(string,cs(1:cslen))
1080 !    Look for another occurence of the same token in string, if so, leaves:
1081      itoken2=index(string,cs(1:cslen), BACK=.true. )
1082      if(itoken/=itoken2)then
1083        write(message, '(7a)' )&
1084 &       'There are two occurences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1085 &       'This is confusing, so it has been forbidden.',ch10,&
1086 &       'Action: remove one of the two occurences.'
1087        MSG_ERROR(message)
1088      end if
1089      if(itoken/=0) then
1090        opttoken=1
1091        ds_input_=jdtset
1092      end if
1093 
1094 !    Use the metacharacter for the unities, and save in cs1 and itoken1
1095      write(appen,'(i1)')dozens
1096      cs1=blank//token(1:toklen)//trim(appen)//'?'//blank
1097 !    Map token to all upper case (make case-insensitive):
1098      call inupper(cs1)
1099 !    Absolute index of blank//token//blank in string:
1100      itoken1=index(string,cs1(1:cslen))
1101 !    Look for another occurence of the same token in string, if so, leaves:
1102      itoken2=index(string,cs1(1:cslen), BACK=.true. )
1103      if(itoken1/=itoken2)then
1104        write(message, '(7a)' )&
1105 &       'There are two occurences of the keyword "',cs1(1:cslen),'" in the input file.',ch10,&
1106 &       'This is confusing, so it has been forbidden.',ch10,&
1107 &       'Action: remove one of the two occurences.'
1108        MSG_ERROR(message)
1109      end if
1110 
1111      if(itoken/=0 .and. itoken1/=0)then
1112        write(message, '(9a)' )&
1113 &       'The keywords "',cs(1:cslen),'" and "',cs1(1:cslen),'"',ch10,&
1114 &       'cannot be used together in the input file.',ch10,&
1115 &       'Action: remove one of the two keywords.'
1116        MSG_ERROR(message)
1117      end if
1118 
1119      if(itoken1/=0)then
1120        opttoken=1
1121        itoken=itoken1
1122        cs=cs1
1123        ds_input_=jdtset
1124      end if
1125 
1126    end if
1127 
1128 !  --------------------------------------------------------------------------
1129 !  (2b) try to find the tokens defining a series
1130    if(opttoken==0)then
1131 
1132      cs=token(1:toklen)
1133 
1134      cslen=toklen+3
1135      cs1len=toklen+4
1136 
1137      cscolon=blank//token(1:toklen)//':'//blank
1138      csplus=blank//token(1:toklen)//'+'//blank
1139      cstimes=blank//token(1:toklen)//'*'//blank
1140 
1141      cs1colon=blank//token(1:toklen)//'?'//':'//blank
1142      cs1plus=blank//token(1:toklen)//'?'//'+'//blank
1143      cs1times=blank//token(1:toklen)//'?'//'*'//blank
1144 
1145      cs2colon=blank//token(1:toklen)//':'//'?'//blank
1146      cs2plus=blank//token(1:toklen)//'+'//'?'//blank
1147      cs2times=blank//token(1:toklen)//'*'//'?'//blank
1148 
1149 !    Map token to all upper case (make case-insensitive):
1150      call inupper(cscolon)
1151      call inupper(csplus)
1152      call inupper(cstimes)
1153      call inupper(cs1colon)
1154      call inupper(cs1plus)
1155      call inupper(cs1times)
1156      call inupper(cs2colon)
1157      call inupper(cs2plus)
1158      call inupper(cs2times)
1159 
1160 !    Absolute index of tokens in string:
1161      itoken_colon=index(string,cscolon(1:cslen))
1162      itoken_plus=index(string,csplus(1:cslen))
1163      itoken_times=index(string,cstimes(1:cslen))
1164      itoken_1colon=index(string,cs1colon(1:cs1len))
1165      itoken_1plus=index(string,cs1plus(1:cs1len))
1166      itoken_1times=index(string,cs1times(1:cs1len))
1167      itoken_2colon=index(string,cs2colon(1:cs1len))
1168      itoken_2plus=index(string,cs2plus(1:cs1len))
1169      itoken_2times=index(string,cs2times(1:cs1len))
1170 
1171 !    Look for another occurence of the same tokens in string
1172      itoken2_colon=index(string,cscolon(1:cslen), BACK=.true. )
1173      itoken2_plus=index(string,csplus(1:cslen), BACK=.true. )
1174      itoken2_times=index(string,cstimes(1:cslen), BACK=.true. )
1175      itoken2_1colon=index(string,cs1colon(1:cs1len), BACK=.true. )
1176      itoken2_1plus=index(string,cs1plus(1:cs1len), BACK=.true. )
1177      itoken2_1times=index(string,cs1times(1:cs1len), BACK=.true. )
1178      itoken2_2colon=index(string,cs2colon(1:cs1len), BACK=.true. )
1179      itoken2_2plus=index(string,cs2plus(1:cs1len), BACK=.true. )
1180      itoken2_2times=index(string,cs2times(1:cs1len), BACK=.true. )
1181 
1182      if(jdtset==0)then
1183 
1184 !      If the multi-dataset mode is not used, no token should have been found
1185        if(itoken_colon+itoken_plus+itoken_times+&
1186 &       itoken_2colon+itoken_2plus+itoken_2times > 0 ) then
1187          write(message,'(a,a,a,a,a,a,a,a,a,a,a,a, a)' )&
1188 &         'Although the multi-dataset mode is not activated,',ch10,&
1189 &         'the keyword "',trim(cs),'" has been found',ch10,&
1190 &         'appended with  + * or :  .',ch10,&
1191 &         'This is not allowed.',ch10,&
1192 &         'Action: remove the appended keyword, or',ch10,&
1193 &         'use the multi-dataset mode (ndtset/=0).'
1194          MSG_ERROR(message)
1195        end if
1196        if(itoken_1colon+itoken_1plus+itoken_1times > 0 ) then
1197          write(message, '(a,a,a,a,a,a,a,a,a,a,a,a,a)' )&
1198 &         'Although the multi-dataset mode is not activated,',ch10,&
1199 &         'the keyword "',trim(cs),'" has been found',ch10,&
1200 &         'appended with ? , then + * or :  .',ch10,&
1201 &         'This is not allowed.',ch10,&
1202 &         'Action: remove the appended keyword, or',ch10,&
1203 &         'use the multi-dataset mode (ndtset/=0).'
1204          MSG_ERROR(message)
1205        end if
1206 
1207      else
1208 
1209 !      If the multi-dataset mode is used, exactly zero or two token must be found
1210        sum_token=0
1211        if(itoken_colon/=0)sum_token=sum_token+1
1212        if(itoken_plus /=0)sum_token=sum_token+1
1213        if(itoken_times/=0)sum_token=sum_token+1
1214        if(itoken_1colon/=0)sum_token=sum_token+1
1215        if(itoken_1plus /=0)sum_token=sum_token+1
1216        if(itoken_1times/=0)sum_token=sum_token+1
1217        if(itoken_2colon/=0)sum_token=sum_token+1
1218        if(itoken_2plus /=0)sum_token=sum_token+1
1219        if(itoken_2times/=0)sum_token=sum_token+1
1220 
1221        if(sum_token/=0 .and. sum_token/=2) then
1222          write(message, '(a,a,a,a,a,i3,a,a,a,a,a,a,a)' )&
1223 &         'The keyword "',trim(cs),'" has been found to take part',ch10,&
1224 &         'to series definition in the multi-dataset mode',sum_token,' times.',ch10,&
1225 &         'This is not allowed, since it should be used once with ":",',ch10,&
1226 &         'and once with "+" or "*".',ch10,&
1227 &         'Action: change the number of occurences of this keyword.'
1228          MSG_ERROR(message)
1229        end if
1230 
1231 !      If the multi-dataset mode is used, make sure that
1232 !      no twice the same combined keyword happens
1233        ier=0
1234        if(itoken_colon/=itoken2_colon)then
1235          ier=1 ; cs=cscolon
1236        end if
1237        if(itoken_plus/=itoken2_plus)then
1238          ier=1 ; cs=csplus
1239        end if
1240        if(itoken_times/=itoken2_times)then
1241          ier=1 ; cs=cstimes
1242        end if
1243        if(itoken_1colon/=itoken2_1colon)then
1244          ier=1 ; cs=cs1colon
1245        end if
1246        if(itoken_1plus/=itoken2_1plus)then
1247          ier=1 ; cs=cs1plus
1248        end if
1249        if(itoken_1times/=itoken2_1times)then
1250          ier=1 ; cs=cs1times
1251        end if
1252        if(itoken_2colon/=itoken2_2colon)then
1253          ier=1 ; cs=cs2colon
1254        end if
1255        if(itoken_2plus/=itoken2_2plus)then
1256          ier=1 ; cs=cs2plus
1257        end if
1258        if(itoken_2times/=itoken2_2times)then
1259          ier=1 ; cs=cs2times
1260        end if
1261        if(ier==1)then
1262          write(message, '(a,a,a,a,a,a,a)' )&
1263 &         'There are two occurences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1264 &         'This is confusing, so it has been forbidden.',ch10,&
1265 &         'Action: remove one of the two occurences.'
1266          MSG_ERROR(message)
1267        end if
1268 
1269 !      Select the series according to the presence of a colon flag
1270        if(itoken_colon>0)then
1271          opttoken=2
1272          ds_input_=jdtset
1273        else if(itoken_1colon>0)then
1274          opttoken=3
1275          cscolon=cs1colon ; csplus=cs1plus ; cstimes=cs1times
1276          itoken_colon=itoken_1colon
1277          itoken_plus=itoken_1plus ; itoken_times=itoken_1times
1278          cslen=cs1len
1279          ds_input_=jdtset
1280        else if(itoken_2colon>0)then
1281          opttoken=4
1282          cscolon=cs2colon ; csplus=cs2plus ; cstimes=cs2times
1283          itoken_colon=itoken_2colon
1284          itoken_plus=itoken_2plus ; itoken_times=itoken_2times
1285          cslen=cs1len
1286          ds_input_=jdtset
1287        end if
1288 
1289 !      Make sure that the proper combination of : + and * is found .
1290        if(itoken_colon > 0 .and. (itoken_plus==0 .and. itoken_times==0) )then
1291          write(message, '(13a)' )&
1292 &         'The keyword "',cscolon(1:cslen),'" initiate a series,',ch10,&
1293 &         'but there is no occurence of "',csplus(1:cslen),'" or "',cstimes(1:cslen),'".',ch10,&
1294 &         'Action: either suppress the series, or make the increment',ch10,&
1295 &         'or the factor available.'
1296          MSG_ERROR(message)
1297        end if
1298        if(itoken_plus/=0 .and. itoken_times/=0)then
1299          write(message, '(a,a, a,a,a,a,a)' )&
1300 &         'The combined occurence of keywords "',csplus(1:cslen),'" and "',cstimes(1:cslen),'" is not allowed.',ch10,&
1301 &         'Action: suppress one of them in your input file.'
1302          MSG_ERROR(message)
1303        end if
1304        if(itoken_colon==0 .and. (itoken_plus/=0 .or. itoken_times/=0) ) then
1305          cs=csplus
1306          if(itoken_times/=0)cs=cstimes
1307          write(message, '(a,a,a,a,a,a,a,a,a,a,a)' )&
1308 &         'The keyword "',cscolon(1:cslen),'" does not appear in the input file.',ch10,&
1309 &         'However, the keyword "',cs(1:cslen),'" appears.',ch10,&
1310 &         'This is forbidden.',ch10,&
1311 &         'Action: make the first appear, or suppress the second.'
1312          MSG_ERROR(message)
1313        end if
1314 
1315 !      At this stage, either
1316 !      - itoken_colon vanish as well as itoken_plus and itoken_times
1317 !      - itoken_colon does not vanish,
1318 !      as well as one of itoken_plus or itoken_times
1319 
1320 !      End the condition of multi-dataset mode
1321      end if
1322 
1323 !    End the check on existence of a series
1324    end if
1325 
1326 !  --------------------------------------------------------------------------
1327 !  (3) if not found, try to find the token with non-modified string
1328    if(opttoken==0)then
1329 
1330      cs=blank//token(1:toklen)//blank
1331      cslen=toklen+2
1332 
1333 !    Map token to all upper case (make case-insensitive):
1334      call inupper(cs)
1335 
1336 !    Absolute index of blank//token//blank in string:
1337      itoken=index(string,cs(1:cslen))
1338 
1339 !    Look for another occurence of the same token in string, if so, leaves:
1340      itoken2=index(string,cs(1:cslen), BACK=.true. )
1341      if(itoken/=itoken2)then
1342        write(message, '(a,a,a,a,a,a,a)' )&
1343 &       'There are two occurences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1344 &       'This is confusing, so it has been forbidden.',ch10,&
1345 &       'Action: remove one of the two occurences.'
1346        MSG_ERROR(message)
1347      end if
1348 
1349      if(itoken/=0) then
1350        opttoken=1
1351        ds_input_=0
1352      end if
1353 
1354    end if
1355 
1356 !  --------------------------------------------------------------------------
1357 !  If jdtset==0, means that the multi-dataset mode is not used, so
1358 !  checks whether the input file contains a multi-dataset keyword,
1359 !  and if this occurs, stop. Check also the forbidden occurence of
1360 !  use of 0 as a multi-dataset index.
1361 !  Note that the occurence of series initiators has already been checked.
1362 
1363    do trial_jdtset=0,9
1364      if(jdtset==0 .or. trial_jdtset==0)then
1365        write(appen,'(i1)')trial_jdtset
1366        trial_cs=blank//token(1:toklen)//trim(appen)
1367        trial_cslen=toklen+2
1368 !      Map token to all upper case (make case-insensitive):
1369        call inupper(trial_cs)
1370 !      Look for an occurence of this token in string, if so, leaves:
1371        itoken2=index(string,trial_cs(1:trial_cslen))
1372 !      If itoken2/=0
1373        if(itoken2/=0)then
1374          if(trial_jdtset==0)then
1375            write(message, '(a,a,a,a,a,a,a)' )&
1376 &           'There is an occurence of the keyword "',trim(token),'" appended with 0 in the input file.',ch10,&
1377 &           'This is forbidden.',ch10,&
1378 &           'Action: remove this occurence.'
1379            call wrtout(std_out,message,'COLL')
1380          else
1381            write(message, '(a,a,a,a,a,i1,a,a,a,a,a)' )&
1382 &           'In the input file, there is an occurence of the ',ch10,&
1383 &           'keyword "',trim(token),'", appended with the digit "',trial_jdtset,'".',ch10,&
1384 &           'This is forbidden when ndtset==0 .',ch10,&
1385 &           'Action: remove this occurence, or change ndtset.'
1386            call wrtout(std_out,message,'COLL')
1387          end if
1388          MSG_ERROR(message)
1389        end if
1390      end if
1391    end do
1392 
1393  end if
1394 
1395 !===========================================================================
1396 !At this stage, the location of the keyword string is known, as well
1397 !as its length. So, can read the data.
1398 !Usual reading if opttoken==1 (need itoken).
1399 !If opttoken>=2, the characteristics of a series must be read
1400 !(need itoken_colon and either itoken_plus or itoken_times)
1401 
1402  tread = 0
1403  typevar='INT'
1404  if(typevarphys=='LOG')typevar='INT'
1405  if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI')typevar='DPR'
1406  if(typevarphys=='KEY')then
1407    if(opttoken>=2)then
1408      write(message, '(9a)' )&
1409 &     'For the keyword "',cs(1:cslen),'", of KEY type,',ch10,&
1410 &     'a series has been defined in the input file.',ch10,&
1411 &     'This is forbidden.',ch10,&
1412 &     'Action: check your input file.'
1413      MSG_ERROR(message)
1414    end if
1415    if(narr>=2)then
1416      write(message, '(9a)' )&
1417 &     'For the keyword "',cs(1:cslen),'", of KEY type,',ch10,&
1418 &     'the number of data requested is larger than 1.',ch10,&
1419 &     'This is forbidden.',ch10,&
1420 &     'Action: check your input file.'
1421      MSG_ERROR(message)
1422    end if
1423    typevar='KEY'
1424 !  write(std_out,*)' intagm : will read cs=',trim(cs)
1425 !  stop
1426  end if
1427 
1428 !There is something to be read if opttoken>=1
1429  if(opttoken==1)then
1430 
1431 !  DEBUG
1432 !  write(std_out,*)' intagm : opttoken==1 , token has been found, will read '
1433 !  ENDDEBUG
1434 
1435 !  Absolute location in string of blank which follows token:
1436    b1=itoken+cslen-1
1437 
1438 !  Read the array (or eventual scalar) that follows the blank
1439 !  In case of typevarphys='KEY', the chain of character will be returned in cs.
1440    call inarray(b1,cs,dprarr,intarr,marr,narr,string,typevarphys)
1441 
1442    if(typevarphys=='KEY')then
1443      if (.not. PRESENT(key_value)) then
1444        MSG_ERROR("typevarphys == KEY requires the optional argument key_value")
1445      end if
1446      !token=trim(cs)
1447      !write(std_out,*)' intagm : after inarray, token=',trim(token)
1448      key_value = TRIM(cs)
1449    end if
1450 
1451 !  if this point is reached then data has been read in successfully
1452    tread = 1
1453 
1454  else if(opttoken>=2)then
1455 
1456 !  write(std_out,*)' intagm : opttoken>=2 , token has been found, will read '
1457    ABI_ALLOCATE(dpr1,(narr))
1458    ABI_ALLOCATE(dpr2,(narr))
1459    ABI_ALLOCATE(int1,(narr))
1460    ABI_ALLOCATE(int2,(narr))
1461 
1462 !  Absolute location in string of blank which follows token//':':
1463    b1=itoken_colon+cslen-1
1464    call inarray(b1,cscolon,dpr1,int1,narr,narr,string,typevarphys)
1465 
1466 !  Initialise number even if the if series treat all cases.
1467    number=1
1468 !  Define the number of the term in the series
1469    if(opttoken==2)number=jdtset-1
1470    if(opttoken==3)number=unities-1
1471    if(opttoken==4)number=dozens-1
1472 
1473 !  Distinguish additive and multiplicative series
1474    if(itoken_plus/=0)then
1475 
1476      b1=itoken_plus+cslen-1
1477      call inarray(b1,csplus,dpr2,int2,narr,narr,string,typevarphys)
1478 
1479      if(typevar=='INT')then
1480        intarr(1:narr)=int1(:)+int2(:)*number
1481      else if(typevar=='DPR')then
1482        dprarr(1:narr)=dpr1(:)+dpr2(:)*number
1483      end if
1484 
1485    else if(itoken_times/=0)then
1486 
1487      b1=itoken_times+cslen-1
1488      call inarray(b1,cstimes,dpr2,int2,narr,narr,string,typevarphys)
1489      if(typevar=='INT')then
1490        intarr(1:narr)=int1(:)*int2(:)**number
1491      else if(typevar=='DPR')then
1492        dprarr(1:narr)=dpr1(:)*dpr2(:)**number
1493      end if
1494 
1495    end if
1496 
1497    tread = 1
1498 
1499    ABI_DEALLOCATE(dpr1)
1500    ABI_DEALLOCATE(dpr2)
1501    ABI_DEALLOCATE(int1)
1502    ABI_DEALLOCATE(int2)
1503  end if
1504 
1505  if(present(ds_input)) then
1506    ds_input = ds_input_
1507  end if
1508 
1509 !DEBUG
1510 !write(std_out,*) ' intagm : exit value tread=',tread
1511 !write(std_out,*) ' intarr =',intarr(1:narr)
1512 !write(std_out,*) ' dprarr =',dprarr(1:narr)
1513 !stop
1514 !ENDDEBUG
1515 
1516 end subroutine intagm

m_parser/parsefile [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 parsefile

FUNCTION

  Glue function, to read the given file, put it into a string,
  change everything to uppercase, remove carriage returns and
  non significant blank characters. May also read a XYZ input
  file if specified. Finally read ndtset input variable.

INPUTS

  filnamin= the file to read
  comm=MPI communicator

OUTPUT

  lenstr= the length of the resulting string.
  ndtset= the number of declared datasets.
  string= contains on output the content of the file, ready for parsing.

PARENTS

      abinit,m_ab7_invars_f90,ujdet

CHILDREN

      importxyz,instrng,intagm,inupper,xmpi_bcast

SOURCE

 88 subroutine parsefile(filnamin,lenstr,ndtset,string,comm)
 89 
 90 
 91 !This section has been created automatically by the script Abilint (TD).
 92 !Do not modify the following lines by hand.
 93 #undef ABI_FUNC
 94 #define ABI_FUNC 'parsefile'
 95 !End of the abilint section
 96 
 97  implicit none
 98 
 99 !Arguments ------------------------------------
100  character(len=*),intent(in) :: filnamin
101  integer,intent(in) :: comm
102  integer,intent(out) :: ndtset,lenstr
103  character(len=strlen),intent(out) :: string
104 
105 !Local variables-------------------------------
106 !scalars
107  integer,parameter :: master=0
108  integer :: option,marr,tread,lenstr_noxyz,ierr
109  character(len=strlen) :: string_raw
110  character(len=500) :: message
111 !arrays
112  integer :: intarr(1)
113  real(dp) :: dprarr(1)
114 
115 ! *************************************************************************
116 
117  ! Read the input file, and store the information in a long string of characters
118  ! Note: this is done only by me=0, and then string and other output vars are BCASTED
119 
120  if (xmpi_comm_rank(comm) == master) then
121    !strlen from defs_basis module
122    option=1
123    call instrng (filnamin,lenstr,option,strlen,string)
124 
125    ! Copy original file, without change of case
126    string_raw=string
127 
128    ! To make case-insensitive, map characters of string to upper case:
129    call inupper(string(1:lenstr))
130 
131    ! Might import data from xyz file(s) into string
132    ! Need string_raw to deal properly with xyz filenames
133    lenstr_noxyz = lenstr
134    call importxyz(lenstr,string_raw,string,strlen)
135 
136    !6) Take ndtset from the input string
137    ndtset=0; marr=1
138    call intagm(dprarr,intarr,0,marr,1,string(1:lenstr),"ndtset",tread,'INT')
139    if (tread==1) ndtset=intarr(1)
140    ! Check that ndtset is not negative
141    if (ndtset<0 .or. ndtset>9999) then
142      write(message, '(a,i0,a,a,a,a)' )&
143 &     'Input ndtset must be non-negative and < 10000, but was ',ndtset,ch10,&
144 &     'This is not allowed.  ',ch10,&
145 &     'Action: modify ndtset in the input file.'
146      MSG_ERROR(message)
147    end if
148  end if ! master
149 
150  if (xmpi_comm_size(comm) > 1) then
151    ! Broadcast data.
152    call xmpi_bcast(lenstr,master,comm,ierr)
153    call xmpi_bcast(ndtset,master,comm,ierr)
154    call xmpi_bcast(string,master,comm,ierr)
155  end if
156 
157 end subroutine parsefile

m_parser/prttagm [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 prttagm

FUNCTION

 Eventually print the content of dprarr (if typevarphys='DPR','LEN', 'ENE' and 'BFI'),
 or intarr (if typevarphys='INT'), arrays of effective dimensions narr and 0:ndtset_alloc
 For the second dimension, the 0 index relates to a default.
 Print the array only if the content for at least one value of the second
 index is different from the default.
 Print a generic value if the non-default values are all equal.
 Print the detail of all values otherwise.
 The input variable 'length' controls the print format, and, in the case
 of the real(dp) variable, the way two numbers are determined to be
 different or not.

INPUTS

  intarr(1:marr,0:ndtset_alloc), dprarr(1:marr,0:ndtset_alloc)
   integer or real(dp) arrays, respectively,
   containing the data to be printed. Use these arrays even for scalars.
   For the first index, only the range 1:narr is relevant.
  iout=unit number for echoed output
  jdtset_(0:ndtset_alloc)=list of dataset indices.
  length= if 1, short format for printing, if 2, long format for printing
     special formats: if 3, INT : for symrel or kptrlatt
                      if 4, INT : for type
                      if 5, INT : for mkmem, mkqmem, mk1mem
                      if 6, INT : for kptrlatt
                      if 3, DPR : for tnons
                      if 4, DPR : for wtk and znucl
                      if 5, DPR : for atvshift
                      if 6, DPR : very short format for printing
     If the typevarphys is 'DPR', a negative value of 'length' will request that
        the equality of real(dp) numbers is determined by an ABSOLUTE
        difference criterion only. The absolute value of length is used
        to determine the format, as above.

  marr=first dimension of the intarr and dprarr arrays, as declared in the
   calling subroutine.
  narr=actual first dimension of intarr and dprarr.
  narrm=used when the effective first dimension of intarr is variable
        in this case narrm(0:ndtset_alloc)
  ncid= NETCDF id
  ndtset_alloc=govern second dimension of intarr and dprarr
  token=character string for 'tag'.  Assumed no longer than 9 characters
  typevarphys=physical variable type (might indicate the physical meaning of
   for dimensionality purposes)
   'INT'=>integer
   'DPR'=>real(dp) (no special treatment)
   'LEN'=>real(dp) (output in bohr and angstrom)
   'ENE'=>real(dp) (output in hartree and eV)
   'BFI'=>real(dp) (output in Tesla)
  use_narrm= if 0, use of scalar 'narr' instead of array 'narrm'
  [firstchar]= (optional) first character of the line (default=' ')
  [forceprint]= (optional) control if output is forced even if a variable is equal to its default value:
                0: not printed out if equal to default value
                1: output forced even if equal to default value in both TEXT and NETCDF file
                2: output forced even if equal to default value in NETCDF file only
                3: output forced even if equal to default value in TEXT file only

OUTPUT

  (only writing)

PARENTS

      outvar_a_h,outvar_i_n,outvar_o_z,pawuj_det,prttagm_images

CHILDREN

      appdig,write_var_netcdf

SOURCE

2945 subroutine prttagm(dprarr,intarr,iout,jdtset_,length,&
2946 & marr,narr,narrm,ncid,ndtset_alloc,token,typevarphys,use_narrm,&
2947   firstchar,forceprint)  ! optional
2948 
2949 
2950 !This section has been created automatically by the script Abilint (TD).
2951 !Do not modify the following lines by hand.
2952 #undef ABI_FUNC
2953 #define ABI_FUNC 'prttagm'
2954 !End of the abilint section
2955 
2956  implicit none
2957 
2958 !Arguments ------------------------------------
2959 !scalars
2960  integer,intent(in) :: iout,length,marr,narr,ndtset_alloc,ncid,use_narrm
2961  integer,intent(in),optional :: forceprint
2962  character(len=*),intent(in) :: token
2963  character(len=3),intent(in) :: typevarphys
2964  character(len=1),intent(in),optional :: firstchar
2965 !arrays
2966  integer,intent(in) :: intarr(marr,0:ndtset_alloc)
2967  integer,intent(in) :: jdtset_(0:ndtset_alloc)
2968  integer,intent(in) :: narrm(0:ndtset_alloc)
2969  real(dp),intent(in) :: dprarr(marr,0:ndtset_alloc)
2970 
2971 !Local variables-------------------------------
2972 !character(len=*), parameter :: long_beg     ='(a,a16,a,1x,(t22,'
2973  character(len=*), parameter :: format_1     ='",a16,a,t22,'
2974  character(len=*), parameter :: format_2     ='",t22,'
2975  character(len=*), parameter :: short_int    ='10i5)'
2976  character(len=*), parameter :: long_int     ='8i8)'
2977  character(len=*), parameter :: veryshort_dpr='f11.5)'
2978  character(len=*), parameter :: short_dpr    ='es16.8)'
2979  character(len=*), parameter :: long_dpr     ='es18.10)'
2980  character(len=*), parameter :: veryshort_dim='f11.5),a'
2981  character(len=*), parameter :: short_dim    ='es16.8),a'
2982  character(len=*), parameter :: long_dim     ='es18.10),a'
2983  character(len=*), parameter :: f_symrel     ='3(3i3,1x),4x,3(3i3,1x))'
2984  character(len=*), parameter :: f_type       ='20i3)'
2985  character(len=*), parameter :: f_mem        ='8i8)'
2986  character(len=*), parameter :: f_tnons      ='3f11.7,3x,3f11.7)'
2987  character(len=*), parameter :: f_wtk        ='6f11.5)'
2988  character(len=*), parameter :: f_atvshift   ='5f11.5)'
2989  character(len=*), parameter :: f_kptrlatt   ='3(3i5,2x))'
2990 !scalars
2991  integer :: iarr,idtset,jdtset,multi,ndtset_eff,narr_eff
2992  logical :: print_netcdf,print_out
2993  real(dp),parameter :: tol21=1.0d-21
2994  real(dp) :: diff,scale_factor,sumtol
2995  character(len=4) :: digit
2996  character(len=1) :: first_column
2997  character(len=4) :: appen
2998  character(len=8) :: out_unit
2999  character(len=50) :: format_dp,format_int,full_format
3000  character(len=500) :: message
3001 
3002 ! *************************************************************************
3003 
3004 !###########################################################
3005 !### 01. Check consistency of input
3006 
3007  if(len_trim(token)>16)then
3008    write(message, '(3a,i0,2a)' )&
3009 &   'The length of the name of the input variable ',trim(token),' is ',len_trim(token),ch10,&
3010 &   'This exceeds 16 characters, the present maximum in routine prttagm.'
3011    MSG_ERROR(message)
3012  end if
3013 
3014  if(ndtset_alloc<1)then
3015    write(message, '(a,i0,a,a,a,a,a)' )&
3016 &   'ndtset_alloc=',ndtset_alloc,', while it should be >= 1.',ch10,&
3017 &   'This happened for token=',token,'.'
3018    MSG_BUG(message)
3019  end if
3020 
3021  if(ndtset_alloc>9999)then
3022    write(message, '(a,i0,a,a,a,a,a)' )&
3023 &   'ndtset_alloc=',ndtset_alloc,', while it must be lower than 10000.',ch10,&
3024 &   'This happened for token=',token,'.'
3025    MSG_BUG(message)
3026  end if
3027 
3028  if(narr>99 .and. (typevarphys=='ENE'.or.typevarphys=='LEN'))then
3029    write(message, '(3a,i0,a)' )' typevarphys=',typevarphys,' with narr=',narr,'  is not allowed.'
3030    MSG_BUG(message)
3031  end if
3032 
3033  if ((narr>0).or.(use_narrm/=0)) then
3034 
3035    print_out=.true.;print_netcdf=.true.
3036    multi=0
3037 
3038 !  ###########################################################
3039 !  ### 02. Treatment of integer 'INT'
3040 
3041    if(typevarphys=='INT')then
3042 
3043 !    Determine whether the different non-default occurences are all equal
3044 
3045      if (use_narrm==0) then ! use of scalar 'narr' instead of array 'narrm'
3046        if(ndtset_alloc>1)then
3047          do idtset=1,ndtset_alloc
3048            do iarr=1,narr
3049              if(intarr(iarr,1)/=intarr(iarr,idtset))multi=1
3050            end do
3051          end do
3052        end if
3053      else
3054 !      If the sizes of the arrays are different we can not compare them
3055 !      So we have to assume they are different
3056        multi=1
3057      end if
3058 
3059 !    If they are all equal, then determine whether they are equal to the default
3060      if(multi==0)then
3061        print_out=.false.
3062        do iarr=1,narr
3063          if (intarr(iarr,1)/=intarr(iarr,0)) print_out=.true.
3064        end do
3065        print_netcdf=print_out
3066      end if
3067 
3068      if (present(forceprint)) then
3069        if (forceprint==1.or.forceprint==3) print_out=.true.
3070        if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3071      end if
3072 
3073 !    Print only if the values differ from the default
3074      if (print_out.or.print_netcdf.or.(ncid<0))then
3075        ndtset_eff=ndtset_alloc
3076        if((multi==0).or.(ncid<0)) ndtset_eff=1
3077        do idtset=1,ndtset_eff
3078 
3079 !        Initialize the character in the first column
3080          first_column=' ';if (present(firstchar)) first_column=firstchar
3081          if(abs(length)==5)first_column='P'
3082 !        Initialize the format
3083          if(abs(length)==1)format_int=trim(short_int)
3084          if(abs(length)==2)format_int=trim(long_int)
3085          if(abs(length)==3)format_int=trim(f_symrel)
3086          if(abs(length)==4)format_int=trim(f_type)
3087          if(abs(length)==5)format_int=trim(f_mem)
3088          if(abs(length)==6)format_int=trim(f_kptrlatt)
3089 !        Initialize the dataset number string, and print
3090          if((multi==0).or.(ncid<0))then
3091            appen=' '
3092          else
3093            jdtset=jdtset_(idtset)
3094            call appdig(jdtset,'',appen)
3095          end if
3096 !        full_format=trim(long_beg)//trim(format_int)
3097          full_format='("'//first_column//trim(format_1)//'("'// first_column//trim(format_2)//trim(format_int)//")"
3098 
3099 !        narr_eff could be narr or narrm(idtset)
3100 !        It depends if the size is variable for different datasets
3101          if (use_narrm==0)then
3102            narr_eff=narr
3103          else
3104            narr_eff=narrm(idtset)
3105          end if
3106 
3107          if (narr_eff/=0) then
3108 
3109            if (print_out) write(iout,full_format) token,trim(appen),intarr(1:narr_eff,idtset)
3110 #ifdef HAVE_NETCDF
3111            if (print_netcdf) then
3112              call write_var_netcdf(intarr(1:narr_eff,idtset),&
3113 &             dprarr(1:narr_eff,idtset),marr,narr_eff,abs(ncid),typevarphys,token//appen)
3114            end if
3115 #endif
3116          end if
3117 
3118        end do
3119      end if !(print==1)
3120 
3121 !    ###########################################################
3122 !    ### 03. Treatment of real 'DPR', 'LEN', 'ENE', 'BFI'
3123 
3124    else if (typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI') then
3125 
3126      if((ndtset_alloc>1).and.(use_narrm==0))then
3127        do idtset=1,ndtset_alloc
3128          do iarr=1,narr
3129 !          The determination of effective equality is more difficult than in the
3130 !          integer case :
3131 !          - if length > 0, ask for a relative accuracy, and also include
3132 !          the case of zero values, thanks to tol21.
3133 !          - if length < 0, ask for absolute accuracy.
3134            diff=abs( dprarr(iarr,1)-dprarr(iarr,idtset) )
3135            if(length>0)then
3136              sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,idtset))+10*tol21
3137              if(diff>sumtol*tol11)multi=1
3138            else
3139              if(diff>tol14)multi=1
3140            end if
3141          end do
3142        end do
3143      elseif (use_narrm/=0) then
3144        multi=1 ! Assume that values could not be compared between different datasets.
3145 !      Nevertheless, checks whether not all dataset might be equal to the default, despite varying dimensions (e.g. all zeroes)
3146        print_out=.false.
3147        do idtset=1,ndtset_alloc
3148          if(narrm(idtset)>narrm(0))then
3149            print_out=.true.
3150          else
3151            do iarr=1,narrm(idtset)
3152              diff=abs( dprarr(iarr,idtset)-dprarr(iarr,0) )
3153              if(length>0)then
3154                sumtol=abs(dprarr(iarr,idtset))+abs(dprarr(iarr,0))+10*tol21
3155                if(diff>sumtol*tol11)print_out=.true.
3156              else
3157                if(diff>tol14)print_out=.true.
3158              end if
3159            end do
3160          end if
3161        end do
3162        print_netcdf=print_out
3163      end if
3164 
3165      if(multi==0)then
3166        print_out=.false.
3167        do iarr=1,narr
3168          diff=abs( dprarr(iarr,1)-dprarr(iarr,0) )
3169          if(length>0)then
3170            sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,0))+10*tol21
3171            if(diff>sumtol*tol11)print_out=.true.
3172          else
3173            if(diff>tol14)print_out=.true.
3174          end if
3175        end do
3176        print_netcdf=print_out
3177      end if
3178 
3179      if (present(forceprint)) then
3180        if (forceprint==1.or.forceprint==3) print_out=.true.
3181        if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3182      end if
3183 
3184      if(print_out.or.print_netcdf.or.(ncid<0))then
3185 !      Select the proper format
3186        ndtset_eff=ndtset_alloc
3187        if((multi==0).or.(ncid<0))ndtset_eff=1
3188        narr_eff=narr
3189        if(use_narrm/=0)then
3190          narr_eff=maxval(narrm(1:ndtset_eff))
3191        end if
3192        if(abs(length)==1 .or. abs(length)==2 .or. abs(length)==6)then
3193          if(typevarphys=='DPR')then
3194            digit='3'
3195            if(abs(length)==1)format_dp=digit//short_dpr
3196            if(abs(length)==2)format_dp=digit//long_dpr
3197            if(abs(length)==6)format_dp=digit//veryshort_dpr
3198          else if(typevarphys=='ENE' .or. typevarphys=='LEN' .or. typevarphys=='BFI')then
3199            if (narr<10) write(digit,'(i1)')narr_eff
3200            if (narr> 9) write(digit,'(i2)')narr_eff
3201            if(abs(length)==1)format_dp=digit//short_dim
3202            if(abs(length)==2)format_dp=digit//long_dim
3203            if(abs(length)==6)format_dp=digit//veryshort_dim
3204          end if
3205        else
3206          if(abs(length)==3)format_dp=f_tnons
3207          if(abs(length)==4)format_dp=f_wtk
3208          if(abs(length)==5)format_dp=f_atvshift
3209        end if
3210        do idtset=1,ndtset_eff
3211 
3212 !        narr_eff could be narr or narrm(idtset)
3213 !        It depends if the size is variable for different datasets
3214          if (use_narrm==0)then
3215            narr_eff=narr
3216          else
3217            narr_eff=narrm(idtset)
3218          end if
3219 
3220          if (narr_eff/=0) then
3221 
3222 !          Initialize the character in the first column
3223            first_column=' ';if (present(firstchar)) first_column=firstchar
3224 !          Define scale_factor
3225            scale_factor=one !EB to what this is still usefull ???
3226 !          EB remove           if(typevarphys=='BFI')scale_factor=one/BField_Tesla
3227 !          Define out_unit
3228            if(typevarphys=='ENE')out_unit=' Hartree'
3229            if(typevarphys=='LEN')out_unit=' Bohr   '
3230            if(typevarphys=='BFI')out_unit='   ' !EB remove Tesla unit
3231 !          Format, according to the length of the dataset string
3232            if((multi==0).or.(ncid<0))then
3233              appen=' '
3234            else
3235              jdtset=jdtset_(idtset)
3236              call appdig(jdtset,'',appen)
3237            end if
3238 !          full_format=trim(long_beg)//trim(format_dp)
3239            full_format='("'//first_column//trim(format_1)//'("'// first_column//trim(format_2)//trim(format_dp)//")"
3240 !          DEBUG
3241 !          write(ab_out,*)' trim(long_beg)=',trim(long_beg)
3242 !          write(ab_out,*)' trim(format_dp)=',trim(format_dp)
3243 !          write(ab_out,*)' trim(full_format)=',trim(full_format)
3244 !          ENDDEBUG
3245            if(typevarphys=='DPR')then
3246              if (print_out) write(iout,full_format) token,trim(appen),dprarr(1:narr_eff,idtset)*scale_factor
3247            else
3248              if (print_out) write(iout,full_format) token,trim(appen),dprarr(1:narr_eff,idtset)*scale_factor,trim(out_unit)
3249            end if
3250 #ifdef HAVE_NETCDF
3251            if (print_netcdf) then
3252              call write_var_netcdf(intarr(1:narr_eff,idtset),dprarr(1:narr_eff,idtset),&
3253 &             marr,narr_eff,abs(ncid),'DPR',token//trim(appen))
3254            end if
3255 #endif
3256 
3257          end if
3258 
3259        end do
3260      end if
3261 
3262 !    ###########################################################
3263 !    ### 04. The type is neither 'INT' nor 'DPR','ENE','LEN','BFI'
3264    else
3265      MSG_BUG('Disallowed typevarphys = '//TRIM(typevarphys))
3266    end if
3267 
3268  end if ! End condition of narr>0
3269 
3270 end subroutine prttagm

m_parser/prttagm_images [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

 prttagm_images

FUNCTION

 Extension to prttagm to include the printing of
 images information, in those cases the same variable
 is printed several times for each dataset

 Cases where images information are relevant includes
 xcart, xred, acell, fcart.

 INPUT
 (see prttagm.F90)

OUTPUT

  (only writing)

PARENTS

      outvar_a_h,outvar_i_n,outvar_o_z

CHILDREN

      appdig,prttagm,write_var_netcdf

SOURCE

3300 subroutine prttagm_images(dprarr_images,iout,jdtset_,length,&
3301 & marr,narrm,ncid,ndtset_alloc,token,typevarphys,&
3302 & mxnimage,nimagem,ndtset,prtimg,strimg,firstchar,forceprint)
3303 
3304 
3305 !This section has been created automatically by the script Abilint (TD).
3306 !Do not modify the following lines by hand.
3307 #undef ABI_FUNC
3308 #define ABI_FUNC 'prttagm_images'
3309 !End of the abilint section
3310 
3311  implicit none
3312 
3313 !Arguments ------------------------------------
3314 !scalars
3315  integer,intent(in) :: iout,length,marr,ndtset_alloc,ncid
3316  integer,intent(in) :: mxnimage,ndtset
3317  integer,intent(in),optional :: forceprint
3318  character(len=*),intent(in) :: token
3319  character(len=3),intent(in) :: typevarphys
3320  character(len=1),intent(in),optional :: firstchar
3321 !arrays
3322  integer,intent(in) :: prtimg(mxnimage,0:ndtset_alloc)
3323  integer,intent(in) :: jdtset_(0:ndtset_alloc)
3324  integer,intent(in) :: nimagem(0:ndtset_alloc)
3325  character(len=8),intent(in) :: strimg(mxnimage)
3326  integer,intent(in) :: narrm(0:ndtset_alloc)
3327  real(dp),intent(in) :: dprarr_images(marr,mxnimage,0:ndtset_alloc)
3328 
3329 !Local variables-------------------------------
3330  integer :: iarr,idtset,iimage,jdtset,multi_narr,narr
3331  integer :: intarr_images(marr,mxnimage,0:ndtset_alloc)
3332  integer,allocatable :: intarr(:,:)
3333  real(dp), allocatable :: dprarr(:,:)
3334  logical :: print_out,print_netcdf,test_multiimages
3335  character(len=1) :: first_column
3336  character(len=4) :: appen
3337  character(len=16) :: keywd
3338  character(len=50) :: full_format
3339  character(len=*), parameter :: format_1  ='",a16,t22,'
3340  character(len=*), parameter :: format_1a ='",a16,a,t22,'
3341  character(len=*), parameter :: format_2  ='",t22,'
3342  character(len=*), parameter :: long_dpr  ='3es18.10)'
3343 !character(len=*), parameter :: format01160 ="(1x,a16,1x,(t22,3es18.10)) "
3344 !character(len=*), parameter :: format01160a="(1x,a16,a,1x,(t22,3es18.10)) "
3345 
3346 ! *************************************************************************
3347 
3348 !Test whether for this variable, the content of different images differ.
3349 !test_multiimages=.false. if, for all datasets, the content is identical.
3350  test_multiimages=.false.
3351  do idtset=1,ndtset_alloc
3352    if(nimagem(idtset)>1)then
3353      do iarr=1,narrm(idtset)
3354        if(sum(abs( dprarr_images(iarr,2:nimagem(idtset),idtset)- &
3355 &       dprarr_images(iarr,1              ,idtset)))>tol12)then
3356          test_multiimages=.true.
3357        end if
3358      end do
3359    end if
3360  end do
3361 
3362  if(nimagem(0)==0)test_multiimages=.true.
3363 
3364 !If there is no differences between images, one is back to the usual prttagm routine.
3365 !Note the treatment of firstchar and forceprint has to be transmitted to prttagm.
3366  if(.not.test_multiimages)then
3367 
3368    narr=narrm(1)
3369    ABI_ALLOCATE(intarr,(marr,0:ndtset_alloc))
3370    ABI_ALLOCATE(dprarr,(marr,0:ndtset_alloc))
3371    do idtset=0,ndtset_alloc
3372      dprarr(1:narrm(idtset),idtset)=dprarr_images(1:narrm(idtset),1,idtset)
3373    end do
3374    multi_narr=0
3375    if(ndtset_alloc>1)then
3376      do idtset=1,ndtset_alloc
3377        if(narrm(1)/=narrm(idtset))multi_narr=1
3378      end do
3379    end if
3380    if (present(firstchar).and.present(forceprint)) then
3381      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3382 &     narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3383 &     firstchar=firstchar,forceprint=forceprint)
3384    else if (present(firstchar)) then
3385      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3386 &     narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3387 &     firstchar=firstchar)
3388    else if (present(forceprint)) then
3389      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3390 &     narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3391 &     forceprint=forceprint)
3392    else
3393      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3394 &     narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr)
3395    end if
3396    ABI_DEALLOCATE(intarr)
3397    ABI_DEALLOCATE(dprarr)
3398 
3399  else
3400 
3401    first_column=' ';if (present(firstchar)) first_column=firstchar
3402 
3403    do idtset=1,ndtset_alloc
3404 
3405      if (narrm(idtset)>0)then
3406        do iimage=1,nimagem(idtset)
3407 
3408          print_out=.true.
3409          if (prtimg(iimage,idtset)==0) print_out=.false.
3410          if (nimagem(0)>=nimagem(idtset)) then
3411            if (sum(abs(dprarr_images(1:narrm(idtset),iimage,idtset) &
3412 &           -dprarr_images(1:narrm(idtset),iimage,0)))<tol12) print_out=.false.
3413          end if
3414          print_netcdf=print_out
3415 
3416          if (present(forceprint)) then
3417            if (forceprint==1.or.forceprint==3) print_out=.true.
3418            if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3419          end if
3420 
3421          if (print_out.or.print_netcdf.or.(ncid<0))then
3422            keywd=token//trim(strimg(iimage))
3423 
3424            if(ndtset>0)then
3425              jdtset=jdtset_(idtset)
3426              call appdig(jdtset,'',appen)
3427              if (print_out) then
3428                full_format='("'//first_column//trim(format_1a)//'("'// &
3429 &               first_column//trim(format_2)//trim(long_dpr)//")"
3430                write(iout,full_format) &
3431 &               trim(keywd),appen,dprarr_images(1:narrm(idtset),iimage,idtset)
3432              end if
3433 #ifdef HAVE_NETCDF
3434              if (print_netcdf) then
3435                call write_var_netcdf(intarr_images(1:narrm(idtset),iimage,idtset),&
3436 &               dprarr_images(1:narrm(idtset),iimage,idtset),&
3437 &               marr,narrm(idtset),ncid,'DPR',trim(keywd)//appen)
3438              end if
3439 #endif
3440            else
3441 
3442              if (print_out) then
3443                full_format='("'//first_column//trim(format_1)//'("'// &
3444 &               first_column//trim(format_2)//trim(long_dpr)//")"
3445                write(iout,full_format) &
3446 &               trim(keywd),dprarr_images(1:narrm(idtset),iimage,idtset)
3447              end if
3448 #ifdef HAVE_NETCDF
3449              if (print_netcdf) then
3450                call write_var_netcdf(intarr_images(1:narrm(idtset),iimage,idtset),&
3451 &               dprarr_images(1:narrm(idtset),iimage,idtset),&
3452 &               marr,narrm(idtset),abs(ncid),'DPR',trim(keywd))
3453              end if
3454 #endif
3455 
3456            end if
3457          end if
3458        end do
3459      end if
3460    end do
3461 
3462  end if
3463 
3464 end subroutine prttagm_images