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-2022 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

16 #if defined HAVE_CONFIG_H
17 #include "config.h"
18 #endif
19 
20 #include "abi_common.h"
21 
22 module m_parser
23 
24  use defs_basis
25  use m_abicore
26  use m_errors
27  use m_atomdata
28  use m_xmpi
29 #ifdef HAVE_NETCDF
30  use netcdf
31 #endif
32  use m_nctk
33  !use m_nctk,      only : write_var_netcdf    ! FIXME Deprecated
34 
35  use m_io_tools,  only : open_file
36  use m_fstrings,  only : sjoin, strcat, itoa, inupper, ftoa, tolower, toupper, next_token, &
37                          endswith, char_count, find_digit !, startswith,
38  use m_geometry,  only : xcart2xred, det3r, mkrdim
39 
40  implicit none
41 
42  private

defs_abitypes/ab_dimensions [ Types ]

[ Top ] [ defs_abitypes ] [ Types ]

NAME

 ab_dimensions

FUNCTION

 One record for each dimension of arrays used in ABINIT.
 Will be used to e.g.:
 - contain the maximum size attained over all datasets (mxvals)
 - indicate whether this dimension is the same for all datasets or not (multivals).
 Used for example inside outvars

SOURCE

60  type,public :: ab_dimensions
61 
62     integer :: ga_n_rules   ! maximal value of input ga_n_rules for all the datasets
63     integer :: gw_nqlwl     ! maximal value of input gw_nqlwl for all the datasets
64     integer :: lpawu        ! maximal value of input lpawu for all the datasets
65     integer :: mband
66     integer :: mband_upper ! maximal value of input nband for all the datasets
67                            ! Maybe this one could be removed
68     integer :: natom
69     integer :: natpawu     ! maximal value of number of atoms on which +U is applied for all the datasets
70     integer :: natsph      ! maximal value of input natsph for all the datasets
71     integer :: natsph_extra  ! maximal value of input natsph_extra for all the datasets
72     integer :: natvshift   ! maximal value of input natvshift for all the datasets
73     integer :: nberry = 20 ! This is presently a fixed value. Should be changed.
74     integer :: nbandhf
75     integer :: nconeq      ! maximal value of input nconeq for all the datasets
76     integer :: n_efmas_dirs
77     integer :: nfreqsp
78     integer :: n_projection_frequencies
79     integer :: nimage
80     integer :: nimfrqs
81     integer :: nkpt       ! maximal value of input nkpt for all the datasets
82     integer :: nkptgw     ! maximal value of input nkptgw for all the datasets
83     integer :: nkpthf     ! maximal value of input nkpthf for all the datasets
84     integer :: nnos       ! maximal value of input nnos for all the datasets
85     integer :: nqptdm     ! maximal value of input nqptdm for all the datasets
86     integer :: nshiftk
87     integer :: nsp
88     integer :: nspinor    ! maximal value of input nspinor for all the datasets
89     integer :: nsppol     ! maximal value of input nsppol for all the datasets
90     integer :: nsym       ! maximum number of symmetries
91     integer :: ntypalch
92     integer :: ntypat     ! maximum number of types of atoms
93     integer :: nzchempot  ! maximal value of input nzchempot for all the datasets
94 
95  end type ab_dimensions

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

SOURCE

2268 subroutine append_xyz(dtset_char,lenstr,string,xyz_fname,strln)
2269 
2270 !Arguments ------------------------------------
2271 !scalars
2272  integer,intent(in) :: strln
2273  integer,intent(inout) :: lenstr
2274  character(len=2),intent(in) :: dtset_char
2275  character(len=fnlen),intent(in) :: xyz_fname
2276  character(len=strln),intent(inout) :: string
2277 
2278 !Local variables-------------------------------
2279  character :: blank=' '
2280 !scalars
2281  integer :: unitxyz, iatom, natom, mu
2282  integer :: lenstr_new
2283  integer :: lenstr_old
2284  integer :: ntypat
2285  real(dp) :: znucl
2286  character(len=5) :: string5
2287  character(len=20) :: string20
2288  character(len=500) :: msg
2289  type(atomdata_t) :: atom
2290 !arrays
2291  real(dp),allocatable :: xcart(:,:)
2292  integer, save :: atomspecies(200) = 0
2293  character(len=500), save :: znuclstring = ""
2294  character(len=2),allocatable :: elementtype(:)
2295 
2296 !************************************************************************
2297 
2298  lenstr_new=lenstr
2299 
2300  if (dtset_char == "-1") then
2301    ! write znucl
2302    lenstr_old=lenstr_new
2303    lenstr_new=lenstr_new+7+len_trim(znuclstring)+1
2304    string(lenstr_old+1:lenstr_new)=" ZNUCL"//blank//trim(znuclstring)//blank
2305 
2306    ! write ntypat
2307    ntypat = sum(atomspecies)
2308    write(string20,'(i10)') ntypat
2309    lenstr_old=lenstr_new
2310    lenstr_new=lenstr_new+8+len_trim(string20)+1
2311    string(lenstr_old+1:lenstr_new)=" NTYPAT"//blank//trim(string20)//blank
2312 
2313    return
2314  end if
2315 
2316  ! open file with xyz data
2317  if (open_file(xyz_fname, msg, newunit=unitxyz, status="unknown") /= 0) then
2318    ABI_ERROR(msg)
2319  end if
2320  write(msg, '(3a)')' importxyz : Opened file ',trim(xyz_fname),'; content stored in string_xyz'
2321  call wrtout(std_out,msg)
2322 
2323  ! check number of atoms is correct
2324  read(unitxyz,*) natom
2325 
2326  write(string5,'(i5)')natom
2327  lenstr_old=lenstr_new
2328  lenstr_new=lenstr_new+7+len_trim(dtset_char)+1+5
2329  string(lenstr_old+1:lenstr_new)=" _NATOM"//trim(dtset_char)//blank//string5
2330 
2331  ABI_MALLOC(xcart,(3,natom))
2332  ABI_MALLOC(elementtype,(natom))
2333 
2334  ! read dummy line
2335  read(unitxyz,*)
2336 
2337  ! read atomic types and positions
2338  do iatom = 1, natom
2339    read(unitxyz,*) elementtype(iatom), xcart(:,iatom)
2340    xcart(:,iatom)=xcart(:,iatom)/Bohr_Ang
2341    ! extract znucl for each atom type
2342    call atomdata_from_symbol(atom,elementtype(iatom))
2343    znucl = atom%znucl
2344    if (znucl > 200) then
2345      write (msg,'(5a)')&
2346      'found element beyond Z=200 ', ch10,&
2347      'Solution: increase size of atomspecies in append_xyz', ch10
2348      ABI_ERROR(msg)
2349    end if
2350    ! found a new atom type
2351    if (atomspecies(int(znucl)) == 0) then
2352      write(string20,'(f10.2)') znucl
2353      znuclstring = trim(znuclstring) // " " // trim(string20) // " "
2354    end if
2355    atomspecies(int(znucl)) = 1
2356  end do
2357  close (unitxyz)
2358 
2359 
2360  !Write the element types
2361  lenstr_old=lenstr_new
2362  lenstr_new=lenstr_new+7+len_trim(dtset_char)+1
2363  string(lenstr_old+1:lenstr_new)=" _TYPAX"//trim(dtset_char)//blank
2364  do iatom=1,natom
2365    lenstr_old=lenstr_new
2366    lenstr_new=lenstr_new+3
2367    string(lenstr_old+1:lenstr_new)=elementtype(iatom)//blank
2368  end do
2369  lenstr_old=lenstr_new
2370  lenstr_new=lenstr_new+3
2371  string(lenstr_old+1:lenstr_new)="XX " ! end card for TYPAX
2372 
2373  !Write the coordinates
2374  lenstr_old=lenstr_new
2375  lenstr_new=lenstr_new+8+len_trim(dtset_char)+1
2376  string(lenstr_old+1:lenstr_new)=" _XCART"//trim(dtset_char)//blank
2377 
2378  do iatom=1,natom
2379    do mu=1,3
2380      write(string20,'(f20.12)')xcart(mu,iatom)
2381      lenstr_old=lenstr_new
2382      lenstr_new=lenstr_new+20
2383      string(lenstr_old+1:lenstr_new)=string20
2384    end do
2385  end do
2386 
2387  ABI_FREE(elementtype)
2388  ABI_FREE(xcart)
2389 
2390  !Check the length of the string
2391  if(lenstr_new>strln)then
2392    write(msg,'(3a)')&
2393    'The maximal size of the input variable string has been exceeded.',ch10,&
2394    'The use of a xyz file is more character-consuming than the usual input file. Sorry.'
2395    ABI_BUG(msg)
2396  end if
2397 
2398  !Update the length of the string
2399  lenstr=lenstr_new
2400 
2401 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. WARNING : only integers are allowed !
 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.

SOURCE

2441 subroutine chkdpr(advice_change_cond,cond_number,cond_string,cond_values,&
2442 &  ierr,input_name,input_value,minimal_flag,reference_value,unit)
2443 
2444 !Arguments ------------------------------------
2445 !scalars
2446  integer,intent(in) :: advice_change_cond,cond_number,minimal_flag,unit
2447  integer,intent(inout) :: ierr
2448  real(dp),intent(in) :: input_value,reference_value
2449  character(len=*),intent(in) :: input_name
2450 !arrays
2451  integer,intent(in) :: cond_values(4)
2452  character(len=*),intent(in) :: cond_string(4)
2453 
2454 !Local variables-------------------------------
2455 !scalars
2456  integer :: icond,ok
2457  character(len=500) :: msg
2458 
2459 !******************************************************************
2460 
2461  if(cond_number<0 .or. cond_number>4)then
2462    write(msg,'(a,i0,a)' )'The value of cond_number is ',cond_number,'but it should be positive and < 5.'
2463    ABI_BUG(msg)
2464  end if
2465 
2466 !Checks the allowed values
2467  ok=0
2468  if(minimal_flag==1 .and. input_value>=reference_value-tol10)      ok=1
2469  if(minimal_flag==-1 .and. input_value<=reference_value+tol10)     ok=1
2470  if(minimal_flag==0 .and. abs(input_value-reference_value)<=tol10) ok=1
2471 
2472  ! If there is something wrong, compose the message, and print it
2473  if(ok==0)then
2474    ierr=1
2475    write(msg, '(a,a)' ) ch10,' chkdpr: ERROR -'
2476    if(cond_number/=0)then
2477      do icond=1,cond_number
2478        ! The following format restricts cond_values(icond) to be between -99 and 999
2479        write(msg, '(2a,a,a,a,i4,a)' ) trim(msg),ch10,&
2480        '  Context : the value of the variable ',trim(cond_string(icond)),' is',cond_values(icond),'.'
2481      end do
2482    end if
2483    write(msg, '(2a,a,a,a,es20.12,a)' ) trim(msg),ch10,&
2484     '  The value of the input variable ',trim(input_name),' is',input_value,','
2485    if(minimal_flag==0)then
2486      write(msg, '(2a,a,es20.12,a)' ) trim(msg),ch10,'  while it must be equal to ',reference_value,'.'
2487    else if(minimal_flag==1)then
2488      write(msg, '(2a,a,es20.12,a)' ) trim(msg),ch10,'  while it must be larger or equal to',reference_value,'.'
2489    else if(minimal_flag==-1)then
2490      write(msg, '(2a,a,es20.12,a)' ) trim(msg),ch10,'  while it must be smaller or equal to',reference_value,'.'
2491    end if
2492 
2493    if(cond_number==0 .or. advice_change_cond==0)then
2494      write(msg, '(2a,a,a,a)' ) trim(msg),ch10,&
2495      '  Action: you should change the input variable ',trim(input_name),'.'
2496    else if(cond_number==1)then
2497      write(msg, '(2a,a,a,a,a,a)' ) trim(msg),ch10,&
2498      '  Action: you should change the input variables ',trim(input_name),' or ',trim(cond_string(1)),'.'
2499    else if(cond_number==2)then
2500      write(msg, '(2a,a,a,a,a,a,a,a,a,a)' ) trim(msg),ch10,&
2501      '  Action: you should change one of the input variables ',trim(input_name),',',ch10,&
2502      '   ',trim(cond_string(1)),' or ',trim(cond_string(2)),'.'
2503    else if(cond_number==3)then
2504      write(msg, '(2a,a,a,a,a,a,a,a,a,a,a,a)' ) trim(msg),ch10,&
2505      '  Action: you should change one of the input variables ',trim(input_name),',',ch10,&
2506      '   ',trim(cond_string(1)),', ',trim(cond_string(2)),' or ',trim(cond_string(3)),'.'
2507    end if
2508 
2509    call wrtout(unit,msg)
2510    ABI_WARNING(msg)
2511  end if
2512 
2513 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. WARNING : only integers are allowed !
 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)

SOURCE

2573 subroutine chkint(advice_change_cond,cond_number,cond_string,cond_values,&
2574                   ierr,input_name,input_value,list_number,list_values,minmax_flag,minmax_value,unit)
2575 
2576 !Arguments ------------------------------------
2577 !scalars
2578  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2579  integer,intent(in) :: minmax_flag,minmax_value,unit
2580  integer,intent(inout) :: ierr
2581  character(len=*),intent(in) :: input_name
2582 !arrays
2583  integer,intent(in) :: cond_values(4),list_values(list_number)
2584  character(len=*),intent(inout) :: cond_string(4)
2585 
2586 !Local variables-------------------------------
2587 !scalars
2588  integer :: ilist,ok
2589 
2590 !******************************************************************
2591 
2592  ! Checks the allowed values
2593  ok=0
2594  if(list_number>0)then
2595    do ilist=1,list_number
2596      if(input_value == list_values(ilist))ok=1
2597    end do
2598  end if
2599  if(minmax_flag==1 .and. input_value>=minmax_value)ok=1
2600  if(minmax_flag==-1 .and. input_value<=minmax_value)ok=1
2601 
2602  ! If there is something wrong, compose the message, and print it
2603  if(ok==0)then
2604    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2605     ierr,input_name,input_value,&
2606     list_number,list_values,minmax_flag,minmax_value,unit)
2607  end if
2608 
2609  ! reset all cond_strings
2610  cond_string(:)='#####'
2611 
2612 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. WARNING : only integers are allowed !
 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.

SOURCE

2653 subroutine chkint_eq(advice_change_cond,cond_number,cond_string,cond_values,&
2654                      ierr,input_name,input_value,list_number,list_values,unit)
2655 
2656 !Arguments ------------------------------------
2657 !scalars
2658  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2659  integer,intent(in) :: unit
2660  integer,intent(inout) :: ierr
2661  character(len=*),intent(in) :: input_name
2662 !arrays
2663  integer,intent(in) :: cond_values(4),list_values(list_number)
2664  character(len=*),intent(inout) :: cond_string(4)
2665 
2666 !Local variables-------------------------------
2667 !scalars
2668  integer :: ilist,minmax_flag,minmax_value,ok
2669 
2670 !******************************************************************
2671 
2672  !Checks the allowed values
2673  ok=0
2674  if(list_number>0)then
2675    do ilist=1,list_number
2676      if(input_value == list_values(ilist))ok=1
2677    end do
2678  end if
2679  minmax_flag=0
2680  minmax_value=0
2681 
2682  !If there is something wrong, compose the message, and print it
2683  if(ok==0)then
2684    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2685      ierr,input_name,input_value,&
2686      list_number,list_values,minmax_flag,minmax_value,unit)
2687  end if
2688 
2689 ! reset all cond_strings
2690  cond_string(:)='#####'
2691 
2692 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. WARNING : only integers are allowed !
 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.

SOURCE

2732 subroutine chkint_ge(advice_change_cond,cond_number,cond_string,cond_values,&
2733                      ierr,input_name,input_value,minmax_value,unit)
2734 
2735 !Arguments ------------------------------------
2736 !scalars
2737  integer,intent(in) :: advice_change_cond,cond_number,input_value
2738  integer,intent(in) :: minmax_value,unit
2739  integer,intent(inout) :: ierr
2740  character(len=*),intent(in) :: input_name
2741 !arrays
2742  integer,intent(in) :: cond_values(4)
2743  character(len=*),intent(inout) :: cond_string(4)
2744 
2745 !Local variables-------------------------------
2746 !scalars
2747  integer :: list_number,minmax_flag,ok
2748  integer, allocatable :: list_values(:)
2749 
2750 !******************************************************************
2751 
2752  !Checks the allowed values
2753  ok=0
2754  minmax_flag=1
2755  if(input_value>=minmax_value)ok=1
2756  list_number=1
2757  ABI_MALLOC(list_values,(1))
2758  list_values=minmax_value
2759 
2760  !If there is something wrong, compose the message, and print it
2761  if(ok==0)then
2762    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2763      ierr,input_name,input_value,&
2764      list_number,list_values,minmax_flag,minmax_value,unit)
2765  end if
2766 
2767  ABI_FREE(list_values)
2768 
2769  ! reset all cond_strings
2770  cond_string(:)='#####'
2771 
2772 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. WARNING : only integers are allowed !
 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.

SOURCE

2812 subroutine chkint_le(advice_change_cond,cond_number,cond_string,cond_values,&
2813                      ierr,input_name,input_value,minmax_value,unit)
2814 
2815 !Arguments ------------------------------------
2816 !scalars
2817  integer,intent(in) :: advice_change_cond,cond_number,input_value
2818  integer,intent(in) :: minmax_value,unit
2819  integer,intent(inout) :: ierr
2820  character(len=*),intent(in) :: input_name
2821 !arrays
2822  integer,intent(in) :: cond_values(4)
2823  character(len=*),intent(inout) :: cond_string(4)
2824 
2825 !Local variables-------------------------------
2826 !scalars
2827  integer :: list_number,minmax_flag,ok
2828  integer, allocatable :: list_values(:)
2829 
2830 !******************************************************************
2831 
2832  !Checks the allowed values
2833  ok=0
2834  minmax_flag=-1
2835  if(input_value<=minmax_value)ok=1
2836  !write(std_out,*)' chkint_le : input_value,minmax_value=',input_value,minmax_value
2837 
2838  list_number=1
2839  ABI_MALLOC(list_values,(1))
2840  list_values=minmax_value
2841 
2842  !If there is something wrong, compose the message, and print it
2843  if(ok==0)then
2844    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2845      ierr,input_name,input_value,list_number,list_values,minmax_flag,minmax_value,unit)
2846  end if
2847 
2848  ABI_FREE(list_values)
2849 
2850  ! reset all cond_strings
2851  cond_string(:)='#####'
2852 
2853 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. WARNING : only integers are allowed !
 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.

SOURCE

2894 subroutine chkint_ne(advice_change_cond,cond_number,cond_string,cond_values,&
2895                      ierr,input_name,input_value, list_number,list_values,unit)
2896 
2897 !Arguments ------------------------------------
2898 !scalars
2899  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2900  integer,intent(in) :: unit
2901  integer,intent(inout) :: ierr
2902  character(len=*),intent(in) :: input_name
2903 !arrays
2904  integer,intent(in) :: cond_values(4),list_values(list_number)
2905  character(len=*),intent(inout) :: cond_string(4)
2906 
2907 !Local variables-------------------------------
2908 !scalars
2909  integer :: ilist,minmax_flag,minmax_value,ok
2910 
2911 !******************************************************************
2912 
2913  !Checks the allowed values
2914  ok=1
2915  if(list_number>0)then
2916    do ilist=1,list_number
2917      if(input_value == list_values(ilist))ok=0
2918    end do
2919  end if
2920  minmax_flag=2
2921  minmax_value=0
2922 
2923  !If there is something wrong, compose the message, and print it
2924  if(ok==0)then
2925    call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2926      ierr,input_name,input_value,&
2927      list_number,list_values,minmax_flag,minmax_value,unit)
2928  end if
2929 
2930  ! reset all cond_strings
2931  cond_string(:)='#####'
2932 
2933 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. WARNING : only integers are allowed !
 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)

SOURCE

2994 subroutine chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2995                       ierr,input_name,input_value,list_number,list_values,minmax_flag,minmax_value,unit)
2996 
2997 !Arguments ------------------------------------
2998 !scalars
2999  integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
3000  integer,intent(in) :: minmax_flag,minmax_value,unit
3001  integer,intent(inout) :: ierr
3002  character(len=*),intent(in) :: input_name
3003 !arrays
3004  integer,intent(in) :: cond_values(4),list_values(list_number)
3005  character(len=*),intent(in) :: cond_string(4)
3006 
3007 !Local variables-------------------------------
3008 !scalars
3009  integer :: icond
3010  character(len=500) :: msg
3011 
3012 !******************************************************************
3013 
3014  if(cond_number<0 .or. cond_number>4)then
3015    write(msg,'(a,i0,a)' )'The value of cond_number is ',cond_number,' but it should be positive and < 5.'
3016    ABI_BUG(msg)
3017  end if
3018 
3019  if(list_number<0 .or. list_number>40)then
3020    write(msg,'(a,i0,a)' )'The value of list_number is',list_number,' but it should be between 0 and 40.'
3021    ABI_BUG(msg)
3022  end if
3023 
3024  !Compose the message, and print it
3025  ierr=1
3026  write(msg, '(2a)' ) ch10,' chkint_prt: ERROR -'
3027  if(cond_number/=0)then
3028    do icond=1,cond_number
3029      ! The following format restricts cond_values(icond) to be between -99 and 999
3030      write(msg, '(5a,i0,a)' ) trim(msg),ch10,&
3031       ' Context: the value of the variable ',trim(cond_string(icond)),' is ',cond_values(icond),'.'
3032    end do
3033  end if
3034  write(msg, '(5a,i0,a)' ) trim(msg),ch10,&
3035   '  The value of the input variable ',trim(input_name),' is ',input_value,', while it must be'
3036  if(minmax_flag==2)then
3037    write(msg, '(3a,20(i0,1x))' ) trim(msg),ch10,&
3038    '  different from one of the following: ',list_values(1:list_number)
3039  else if(list_number>1 .or. minmax_flag==0 .or. list_values(1)/=minmax_value )then
3040    ! The following format restricts list_values to be between -99 and 999
3041    if(list_number/=1)then
3042      write(msg, '(3a,40(i0,1x))' ) trim(msg),ch10,&
3043      '  equal to one of the following: ',list_values(1:list_number)
3044    else
3045      write(msg, '(3a,40(i0,1x))' ) trim(msg),ch10,'  equal to ',list_values(1)
3046    end if
3047    if(minmax_flag==1)then
3048      ! The following format restricts minmax_value to be between -99 and 999
3049      write(msg, '(3a,i0,a)' ) trim(msg),ch10,'  or it must be larger or equal to ',minmax_value,'.'
3050    else if(minmax_flag==-1)then
3051      write(msg, '(3a,i0,a)' ) trim(msg),ch10,'  or it must be smaller or equal to ',minmax_value,'.'
3052    end if
3053  else if(minmax_flag==1)then
3054    ! The following format restricts minmax_value to be between -99 and 999
3055    write(msg, '(3a,i0,a)' ) trim(msg),ch10,'  larger or equal to ',minmax_value,'.'
3056  else if(minmax_flag==-1)then
3057    ! The following format restricts minmax_value to be between -99 and 999
3058    write(msg, '(3a,i0,a)' ) trim(msg),ch10,'  smaller or equal to ',minmax_value,'.'
3059  end if
3060  if(cond_number==0 .or. advice_change_cond==0)then
3061    write(msg, '(5a)' ) trim(msg),ch10,'  Action: you should change the input variable ',trim(input_name),'.'
3062  else if(cond_number==1)then
3063    write(msg, '(7a)' ) trim(msg),ch10,&
3064     '  Action: you should change the input variables ',trim(input_name),' or ',trim(cond_string(1)),'.'
3065  else if(cond_number==2)then
3066    write(msg, '(11a)' ) trim(msg),ch10,&
3067     '  Action: you should change one of the input variables ',trim(input_name),',',ch10,&
3068     '   ',trim(cond_string(1)),' or ',trim(cond_string(2)),'.'
3069  else if(cond_number==3)then
3070    write(msg, '(13a)' ) trim(msg),ch10,&
3071     '  Action: you should change one of the input variables ',trim(input_name),',',ch10,&
3072     '   ',trim(cond_string(1)),', ',trim(cond_string(2)),' or ',trim(cond_string(3)),'.'
3073  end if
3074  call wrtout([unit, std_out], msg)
3075 
3076 end subroutine chkint_prt

m_parser/chkvars_in_string [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  chkvars_in_string

FUNCTION

  Analyze variable names in string. Ignore tokens withing double quotation marks.
  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_vars_img(len=*)=string with the (upper case) names of the variables (excluding logicals and chars),
   for which the image can be specified.
  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.

SOURCE

3666 subroutine chkvars_in_string(protocol, list_vars, list_vars_img, list_logicals, list_strings, string)
3667 
3668 !Arguments ------------------------------------
3669 !scalars
3670  integer,intent(in) :: protocol
3671  character(len=*),intent(in) :: string
3672  character(len=*),intent(in) :: list_logicals,list_strings,list_vars, list_vars_img
3673 
3674 !Local variables-------------------------------
3675  character,parameter :: blank=' '
3676 !scalars
3677  integer :: index_blank,index_current,index_endfullword, index_endword,index_endwordnow,index_list_vars
3678  character(len=500) :: msg
3679 
3680 !************************************************************************
3681 
3682  !write(std_out,"(3a)")"Checking vars in string:", ch10, trim(string)
3683 
3684  index_current=1
3685  do
3686    ! Infinite do-loop, to identify the presence of each potential variable names
3687 
3688    if(len_trim(string)<=index_current)exit
3689    index_blank=index(string(index_current:),blank)+index_current-1
3690 
3691    if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_current:index_current))/=0)then
3692 
3693      index_endfullword = index_blank -1
3694      index_endword = index_blank -1
3695 
3696      if (protocol == 1) then
3697        ! Skip characters like : + or the digits at the end of the word
3698        ! Start from the blank that follows the end of the word
3699        do index_endword=index_blank-1,index_current,-1
3700          if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_endword:index_endword))/=0)exit
3701        end do
3702      end if
3703      !write(std_out,*)"Will analyze:", string(index_current:index_endword)
3704 
3705      ! Find the index of the potential variable name in the list of variables
3706      index_list_vars=index(list_vars,blank//string(index_current:index_endword)//blank)
3707 
3708      ! Treat the complications due to the possibility of images
3709      if (index_list_vars==0 .and. protocol==1) then
3710 
3711        ! Treat possible LASTIMG appendix
3712        if(index_endword-6>=1)then
3713          if(string(index_endword-6:index_endword)=='LASTIMG')index_endword=index_endword-7
3714        end if
3715 
3716        ! Treat possible IMG appendix
3717        if(index_endword-2>=1)then
3718          if(string(index_endword-2:index_endword)=='IMG')index_endword=index_endword-3
3719        end if
3720 
3721        index_endwordnow=index_endword
3722 
3723        ! Again skip characters like : + or the digits before IMG
3724        ! Start from the blank that follows the end of the word
3725        do index_endword=index_endwordnow,index_current,-1
3726          if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_endword:index_endword))/=0)exit
3727        end do
3728 
3729        ! Find the index of the potential variable name in the list of variables for which
3730        ! the image index can be specified
3731        index_list_vars=index(list_vars_img,blank//string(index_current:index_endword)//blank)
3732      end if
3733 
3734      if(index_list_vars==0)then
3735 
3736        ! Treat possible logical input variables
3737        if(index(list_logicals,blank//string(index_current:index_endword)//blank)/=0)then
3738          index_blank=index(string(index_current:),blank)+index_current-1
3739          if(index(' F T ',string(index_blank:index_blank+2))==0)then
3740            write(msg, '(8a)' )&
3741             'Found token `',string(index_current:index_endword),'` in the input file.',ch10,&
3742             'This variable should be given a logical value (T or F), but the following string was found:',&
3743             string(index_blank:index_blank+2),ch10,&
3744             'Action: check your input file. You likely misused the input variable.'
3745             ABI_ERROR(msg)
3746          else
3747            index_blank=index_blank+2
3748          end if
3749 
3750        else if(index(list_strings,blank//string(index_current:index_endword)//blank)/=0)then
3751          ! Treat possible string input variables
3752          ! Every following string is accepted
3753          index_current=index(string(index_current:),blank)+index_current
3754          index_blank=index(string(index_current:),blank)+index_current-1
3755 
3756        else
3757          ! If still not admitted, then there is a problem
3758          write(msg, '(9a)' )&
3759          'Found token: `',string(index_current:index_endfullword),'` in the input file.',ch10,&
3760          'This name is not one of the registered input variable names (see https://docs.abinit.org/).',ch10,&
3761          'Action: check your input file. Perhaps you mistyped the input variable,',ch10,&
3762          'or specified "img", although this was not permitted for this input variable.'
3763          ABI_ERROR(msg)
3764        end if
3765      end if
3766    end if
3767 
3768    index_current=index_blank+1
3769 
3770    if (string(index_current:index_current) == '"') then
3771      do
3772        index_current = index_current + 1
3773        if (string(index_current:index_current) == '"') exit
3774        if (index_current > len_trim(string)) then
3775          ABI_ERROR('Cannot find closing quotation mark " in string. You likely forgot to close a string')
3776        end if
3777      end do
3778 
3779    end if
3780 
3781  end do
3782 
3783 end subroutine chkvars_in_string

m_parser/geo_bcast [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_bcast

FUNCTION

  Brodcast object

SOURCE

4340 subroutine geo_bcast(self, master, comm)
4341 
4342 !Arguments ------------------------------------
4343  class(geo_t),intent(inout) :: self
4344  integer,intent(in) :: master, comm
4345 
4346 !Local variables-------------------------------
4347  integer :: ierr, my_rank, list_int(2)
4348 
4349 !************************************************************************
4350 
4351  if (xmpi_comm_size(comm) == 1) return
4352  my_rank = xmpi_comm_rank(comm)
4353 
4354  if (my_rank == master) list_int = [self%natom, self%ntypat]
4355  call xmpi_bcast(list_int, master, comm, ierr)
4356 
4357  if (my_rank /= master) then
4358    self%natom = list_int(1); self%ntypat = list_int(2)
4359    call self%malloc()
4360  end if
4361 
4362  call xmpi_bcast(self%rprimd, master, comm, ierr)
4363  call xmpi_bcast(self%xred, master, comm, ierr)
4364  call xmpi_bcast(self%typat, master, comm, ierr)
4365  call xmpi_bcast(self%znucl, master, comm, ierr)
4366  call xmpi_bcast(self%title, master, comm, ierr)
4367  call xmpi_bcast(self%fileformat, master, comm, ierr)
4368 
4369 end subroutine geo_bcast

m_parser/geo_free [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_free

FUNCTION

  Free memory.

SOURCE

4404 subroutine geo_free(self)
4405 
4406 !Arguments ------------------------------------
4407  class(geo_t),intent(inout) :: self
4408 
4409 !************************************************************************
4410 
4411  ABI_SFREE(self%typat)
4412  ABI_SFREE(self%xred)
4413  ABI_SFREE(self%znucl)
4414 
4415 end subroutine geo_free

m_parser/geo_from_abivar_string [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_from_abivars_string

FUNCTION

  Build object form abinit `structure` variable

INPUTS

  comm=MPI communicator. Used for performing IO.

SOURCE

3798 type(geo_t) function geo_from_abivar_string(string, comm) result(new)
3799 !type(geo_t) function geo_from_structure_string(string, comm) result(new)
3800 
3801 !Arguments ------------------------------------
3802  character(len=*),intent(in) :: string
3803  integer,intent(in) :: comm
3804 
3805 !Local variables-------------------------------
3806  integer :: ii
3807  character(len=len(string)) :: prefix
3808 
3809 !************************************************************************
3810 
3811  !print *, "in geo_from_abivar_string: `", trim(string), "`"
3812 
3813  ii = index(string, ":")
3814  ABI_CHECK(ii > 0, sjoin("Expecting string of the form `type:content`, got:", string))
3815  prefix = adjustl(string(1:ii-1))
3816 
3817  select case (prefix)
3818 
3819  case ("poscar")
3820    ! Build geo ifrom POSCAR from file.
3821    new = geo_from_poscar_path(trim(string(ii+1:)), comm)
3822 
3823  case ("abivars")
3824    ! Build geo from from file with Abinit variables.
3825    new = geo_from_abivars_path(trim(string(ii+1:)), comm)
3826 
3827  case ("abifile")
3828    if (endswith(string(ii+1:), ".nc")) then
3829      ! Build geo from netcdf file.
3830      new = geo_from_netcdf_path(trim(string(ii+1:)), comm)
3831    else
3832      ! Assume Fortran file with Abinit header.
3833      ABI_ERROR("structure variable with Fortran file is not yet implemented.")
3834      !new = geo_from_fortran_file_with_hdr(string(ii+1:), comm)
3835      !cryst = crystal_from_file(string(ii+1:), comm)
3836      !if (cryst%isalchemical()) then
3837      !  ABI_ERROR("Alchemical mixing is not compatibile with `structure` input variable!")
3838      !end if
3839      !new%natom = cryst%natom
3840      !new%ntypat = cryst%ntypat
3841      !new%rprimd = cryst%rprimd
3842      !call alloc_copy(cryst%typat, new%typat)
3843      !call alloc_copy(cryst%xred, new%xred)
3844      !call alloc_copy(cryst%znucl, new%znucl)
3845      !call cryst%free()
3846    end if
3847 
3848  case default
3849    ABI_ERROR(sjoin("Invalid prefix: `", prefix, "`"))
3850  end select
3851 
3852 end function geo_from_abivar_string

m_parser/geo_from_abivars_path [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_from_abivars_path

FUNCTION

SOURCE

3863 type(geo_t) function geo_from_abivars_path(path, comm) result(new)
3864 
3865 !Arguments ------------------------------------
3866  character(len=*),intent(in) :: path
3867  integer,intent(in) :: comm
3868 
3869 !Local variables-------------------------------
3870  integer,parameter :: master = 0, option1 = 1
3871  integer :: jdtset, iimage, nimage, iatom, itypat
3872  integer :: my_rank, lenstr, ierr, ii, start, tread, marr
3873  !character(len=500) :: msg
3874  character(len=strlen) :: string, raw_string
3875 !arrays
3876  integer,allocatable :: intarr(:)
3877  real(dp) :: acell(3), rprim(3,3)
3878  real(dp),allocatable :: dprarr(:)
3879  character(len=5),allocatable :: symbols(:)
3880 
3881 !************************************************************************
3882 
3883  ! Master node reads string and broadcasts
3884  my_rank = xmpi_comm_rank(comm)
3885 
3886  if (my_rank == master) then
3887    ! Below part copied from `parsefile`. strlen from defs_basis module
3888    call instrng(path, lenstr, option1, strlen, string, raw_string)
3889    ! To make case-insensitive, map characters of string to upper case.
3890    call inupper(string(1:lenstr))
3891    !call chkvars_in_string(protocol1, list_vars, list_logicals, list_strings, string)
3892  end if
3893 
3894  if (xmpi_comm_size(comm) > 1) then
3895    call xmpi_bcast(string, master, comm, ierr)
3896    call xmpi_bcast(lenstr, master, comm, ierr)
3897  end if
3898 
3899  ! ==============================
3900  ! Now all procs parse the string
3901  ! ==============================
3902 
3903  jdtset = 0; iimage = 0; nimage = 0
3904 
3905  ! Get the number of atom in the unit cell. Read natom from string
3906  marr = 1
3907  ABI_MALLOC(intarr, (marr))
3908  ABI_MALLOC(dprarr, (marr))
3909 
3910  call intagm(dprarr, intarr, jdtset, marr, 1, string(1:lenstr), 'natom', tread, 'INT')
3911  ABI_CHECK(tread /= 0, sjoin("natom is required in file:", path))
3912  new%natom = intarr(1)
3913 
3914  marr = max(12, 3*new%natom)
3915  ABI_REMALLOC(intarr, (marr))
3916  ABI_REMALLOC(dprarr, (marr))
3917 
3918  ! Set up unit cell from acell, rprim, angdeg
3919  call get_acell_rprim(lenstr, string, jdtset, iimage, nimage, marr, acell, rprim)
3920 
3921  ! Compute different matrices in real and reciprocal space, also checks whether ucvol is positive.
3922  call mkrdim(acell, rprim, new%rprimd)
3923 
3924  ! Parse atomic positions.
3925  ! Only xcart is supported here because it makes life easier and we don't need to handle symbols + Units
3926  ii = index(string(1:lenstr), "XRED_SYMBOLS")
3927  ABI_CHECK(ii /= 0, "In structure mode only `xred_symbols` with coords followed by element symbol are supported")
3928 
3929  new%fileformat = "abivars"
3930  ABI_MALLOC(new%xred, (3, new%natom))
3931 
3932  ABI_MALLOC(symbols, (new%natom))
3933  start = ii + len("XRED_SYMBOLS")
3934  do iatom=1,new%natom
3935    call inarray(start, "xred_symbols", dprarr, intarr, marr, 3, string, "DPR")
3936    new%xred(:, iatom) = dprarr(1:3)
3937    ABI_CHECK(next_token(string, start, symbols(iatom)) == 0, "Error while reading element symbol.")
3938    symbols(iatom) = tolower(symbols(iatom))
3939    symbols(iatom)(1:1) = toupper(symbols(iatom)(1:1))
3940    !write(std_out, *)"xred", new%xred(:, iatom), "symbol:", trim(symbols(iatom))
3941  end do
3942 
3943  call typat_from_symbols(symbols, new%ntypat, new%typat)
3944 
3945  ! Note that the first letter should be capitalized, rest must be lower case
3946  ABI_MALLOC(new%znucl, (new%ntypat))
3947  do iatom=1,new%natom
3948    itypat = new%typat(iatom)
3949    new%znucl(itypat) = symbol2znucl(symbols(iatom))
3950  end do
3951 
3952  ABI_FREE(symbols)
3953  ABI_FREE(intarr)
3954  ABI_FREE(dprarr)
3955 
3956  !call new%print_abivars(std_out)
3957 
3958 contains
3959 
3960 subroutine typat_from_symbols(symbols, ntypat, typat)
3961 
3962 !Arguments ------------------------------------
3963  character(len=*),intent(in) :: symbols(:)
3964  integer,intent(out) :: ntypat
3965  integer,allocatable,intent(out) :: typat(:)
3966 
3967 !Local variables-------------------------------
3968  integer :: ii, jj, nstr, found
3969 
3970 !************************************************************************
3971 
3972  nstr = size(symbols)
3973  ABI_ICALLOC(typat, (nstr))
3974 
3975  typat(1) = 1
3976  ntypat = 1
3977  do ii=2, nstr
3978    found = 0
3979    do jj=1, ntypat
3980      if (symbols(ii) == symbols(typat(jj))) then
3981        found = jj; exit
3982      end if
3983    end do
3984    if (found == 0) then
3985      ntypat = ntypat + 1
3986      typat(ii) = ntypat
3987    else
3988      typat(ii) = found
3989    end if
3990  end do
3991 
3992 end subroutine typat_from_symbols
3993 
3994 end function geo_from_abivars_path

m_parser/geo_from_netdf_path [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_from_netdf_path

FUNCTION

SOURCE

4258 type(geo_t) function geo_from_netcdf_path(path, comm) result(new)
4259 
4260 !Arguments ------------------------------------
4261  character(len=*),intent(in) :: path
4262  integer,intent(in) :: comm
4263 
4264 !Local variables-------------------------------
4265  integer, parameter :: master = 0
4266  integer :: ncid, npsp, dimid, itime
4267  logical :: has_nimage
4268 
4269 !************************************************************************
4270 
4271  new%fileformat = "netcdf"
4272 
4273 #ifdef HAVE_NETCDF
4274  if (xmpi_comm_rank(comm) == master) then
4275    NCF_CHECK(nctk_open_read(ncid, path, xmpi_comm_self))
4276 
4277    if (endswith(path, "_HIST.nc")) then
4278      ! See def_file_hist.
4279      !ABI_ERROR("Cannot yet read structure from HIST.nc file")
4280      NCF_CHECK(nctk_get_dim(ncid, "natom", new%natom))
4281      NCF_CHECK(nctk_get_dim(ncid, "ntypat", new%ntypat))
4282 
4283      NCF_CHECK(nctk_get_dim(ncid, "npsp", npsp))
4284      ABI_CHECK(npsp == new%ntypat, 'Geo from HIST file with alchemical mixing!')
4285      has_nimage = nf90_inq_dimid(ncid, "nimage", dimid) == nf90_noerr
4286      ABI_CHECK(.not. has_nimage, "Cannot initialize structure from HIST.nc when file contains images.")
4287 
4288      call new%malloc()
4289 
4290      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "typat"), new%typat))
4291      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "znucl"), new%znucl))
4292 
4293      ! time is NF90_UNLIMITED
4294      NCF_CHECK(nctk_get_dim(ncid, "time", itime))
4295 
4296      ! dim3 = [xyz_id, xyz_id, time_id]
4297      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "rprimd"), new%rprimd, start=[1,1,itime]))
4298 
4299      ! dim3 = [xyz_id, natom_id, time_id]
4300      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "xred"), new%xred, start=[1,1,itime]))
4301 
4302    else
4303      ! Assume netcdf file produced by calling crystal%ncwrite
4304      NCF_CHECK(nctk_get_dim(ncid, "number_of_atoms", new%natom))
4305      NCF_CHECK(nctk_get_dim(ncid, "number_of_atom_species", new%ntypat))
4306 
4307      ! Test if alchemical. NB: nsps added in crystal_ncwrite in v9.
4308      if (nf90_inq_dimid(ncid, "number_of_pseudopotentials", dimid) == nf90_noerr) then
4309        NCF_CHECK(nf90_inquire_dimension(ncid, dimid, len=npsp))
4310        ABI_CHECK(npsp == new%ntypat, 'Geo from HIST file with alchemical mixing!')
4311      end if
4312 
4313      call new%malloc()
4314 
4315      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "primitive_vectors"), new%rprimd))
4316      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "atom_species"), new%typat))
4317      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "atomic_numbers"), new%znucl))
4318      NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "reduced_atom_positions"), new%xred))
4319    end if
4320 
4321    NCF_CHECK(nf90_close(ncid))
4322  end if
4323 #endif
4324 
4325  call new%bcast(master, comm)
4326  !call new%print_abivars(std_out)
4327 
4328 end function geo_from_netcdf_path

m_parser/geo_from_poscar_path [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_from_poscar_path

FUNCTION

SOURCE

4005 type(geo_t) function geo_from_poscar_path(path, comm) result(new)
4006 
4007 !Arguments ------------------------------------
4008  character(len=*),intent(in) :: path
4009  integer,intent(in) :: comm
4010 
4011 !Local variables-------------------------------
4012  integer,parameter :: master = 0
4013  integer :: unt, my_rank
4014  character(len=500) :: msg
4015 
4016 !************************************************************************
4017 
4018  my_rank = xmpi_comm_rank(comm)
4019 
4020  if (my_rank == master) then
4021    if (open_file(path, msg, newunit=unt, form='formatted', status='old', action="read") /= 0) then
4022      ABI_ERROR(msg)
4023    end if
4024    new = geo_from_poscar_unit(unt)
4025    close(unt)
4026  end if
4027 
4028  if (xmpi_comm_size(comm) > 1) call new%bcast(master, comm)
4029 
4030 end function geo_from_poscar_path

m_parser/geo_from_poscar_unit [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_from_poscar_unit

FUNCTION

  Build object from string with seperator `sep`. Usually sep = newline = ch10

SOURCE

4042 type(geo_t) function geo_from_poscar_unit(unit) result(new)
4043 
4044 !Arguments ------------------------------------
4045  integer,intent(in) :: unit
4046 
4047 !Local variables-------------------------------
4048  !integer,parameter :: marr = 3
4049  integer :: beg, iatom, itypat, ierr, ii, cnt
4050  real(dp) :: scaling_constant
4051  character(len=500) :: line, system, iomsg
4052  character(len=5) :: symbol
4053 !arrays
4054  integer,allocatable :: nattyp(:)
4055  logical,allocatable :: duplicated(:)
4056  character(len=5),allocatable :: symbols(:), dupe_symbols(:)
4057  real(dp),allocatable :: xcart(:,:)
4058 
4059 !************************************************************************
4060 
4061  ! Example of POSCAR (with 6 figures --> space group won't be recognized by Abinit
4062  ! See also https://github.com/ExpHP/vasp-poscar/blob/master/doc/format.md
4063 
4064  ! Mg1 B2
4065  ! 1.0
4066  ! 2.672554 1.543000 0.000000
4067  ! -2.672554 1.543000 0.000000
4068  ! 0.000000 0.000000 3.523000
4069  ! Mg B
4070  ! 1 2
4071  ! direct
4072  ! 0.000000 0.000000 0.000000 Mg
4073  ! 0.333333 0.666667 0.500000 B
4074  ! 0.666667 0.333333 0.500000 B
4075 
4076  new%fileformat = "poscar"
4077  read(unit, "(a)", err=10, iomsg=iomsg) new%title
4078  read(unit, *, err=10, iomsg=iomsg) scaling_constant
4079  do ii=1,3
4080    read(unit, *, err=10, iomsg=iomsg) new%rprimd(:, ii)
4081  end do
4082 
4083  ! Read line with the names of the atoms.
4084  read(unit, "(a)", err=10, iomsg=iomsg) line
4085  !print *, "line:", trim(line)
4086 
4087  new%ntypat = 0
4088  do ii=1,2
4089    if (ii == 2) then
4090      ABI_MALLOC(symbols, (new%ntypat))
4091    end if
4092    itypat = 0; beg = 1
4093    do
4094      ierr = next_token(line, beg, symbol)
4095      !print *, "ierr:", ierr, "beg:", beg, "symbol:", trim(symbol)
4096      if (ierr /= 0) exit
4097      if (ii == 1) new%ntypat = new%ntypat + 1
4098      if (ii == 2) then
4099        itypat = itypat + 1
4100        symbols(itypat) = trim(symbol)
4101      end if
4102    end do
4103  end do
4104  !write(std_out, *)"ntypat: ", new%ntypat, "symbols: ", symbols
4105 
4106  ! TODO: Handle case in which not all atoms are not grouped by type
4107  ABI_MALLOC(duplicated, (new%ntypat))
4108  duplicated = .False.
4109  do itypat=1,new%ntypat-1
4110    do ii=itypat+1, new%ntypat
4111      if (symbols(itypat) == symbols(ii)) duplicated(ii) = .True.
4112    end do
4113  end do
4114 
4115  ! number of atoms of each type.
4116  ! NOTE: Assuming ntypat == npsp thus alchemical mixing is not supported.
4117  ! There's a check in the main parser though.
4118  ABI_MALLOC(nattyp, (new%ntypat))
4119  read(unit, *, err=10, iomsg=iomsg) nattyp
4120  new%natom = sum(nattyp)
4121  ABI_FREE(nattyp)
4122 
4123  if (any(duplicated)) then
4124    ! Need to recompute ntypat and symbols taking into account duplication.
4125    ABI_WARNING("Found POSCAR with duplicated symbols")
4126    ABI_MOVE_ALLOC(symbols, dupe_symbols)
4127    new%ntypat = count(.not. duplicated)
4128    ABI_MALLOC(symbols, (new%ntypat))
4129    cnt = 0
4130    do ii=1,size(duplicated)
4131      if (.not. duplicated(ii)) then
4132        cnt = cnt + 1; symbols(cnt) = dupe_symbols(ii)
4133      end if
4134    end do
4135    ABI_FREE(dupe_symbols)
4136  end if
4137 
4138  ! At this point, we can allocate Abinit arrays.
4139  call new%malloc()
4140 
4141  ! Note that first letter should be capitalized, rest must be lower case
4142  do itypat=1,new%ntypat
4143    new%znucl(itypat) = symbol2znucl(symbols(itypat))
4144  end do
4145 
4146  read(unit, *, err=10, iomsg=iomsg) system
4147  system = tolower(system)
4148  if (system /= "cartesian" .and. system /= "direct") then
4149    ABI_ERROR(sjoin("Expecting `cartesian` or `direct` for the coordinate system but got:", system))
4150  end if
4151 
4152  ! Parse atomic positions.
4153  do iatom=1,new%natom
4154 
4155    ! This should implement the POSCAR format.
4156    read(unit, *, err=10, iomsg=iomsg) new%xred(:, iatom), symbol
4157    if (len_trim(symbol) == 0) then
4158      if (new%ntypat == 1) then
4159        ABI_COMMENT("POTCAR without element symbol after coords but this is not critical because ntypat == 1")
4160        symbol = symbols(1)
4161      else
4162        ABI_ERROR("POTCAR positions should be followed by element symbol.")
4163      end if
4164    end if
4165 
4166    ! This to handle symbol + oxidation state e.g. Li1+
4167    !print *, symbol
4168    ii = find_digit(symbol)
4169    if (ii /= 0) symbol = symbol(:ii-1)
4170 
4171    do itypat=1, new%ntypat
4172      if (symbols(itypat) == symbol) then
4173        new%typat(iatom) = itypat; exit
4174      end if
4175    end do
4176    if (itypat == new%ntypat + 1) then
4177      ABI_ERROR(sjoin("Cannot find symbol:`", symbol, " `in initial symbol list. Typo or POSCAR without symbols?."))
4178    end if
4179  end do
4180 
4181  ! Convert ang -> bohr
4182  if (scaling_constant > zero) then
4183    new%rprimd = scaling_constant * new%rprimd * Ang_Bohr
4184  else if (scaling_constant < zero) then
4185    ! A negative scale factor is treated as a volume. translate scaling_constant to a lattice vector scaling.
4186    new%rprimd = Ang_Bohr * new%rprimd * (-scaling_constant / abs(det3r(new%rprimd))) ** (one / three)
4187  else
4188    ABI_CHECK(scaling_constant > zero, sjoin("scaling constant must be /= 0 but found:", ftoa(scaling_constant)))
4189  end if
4190 
4191  if (system == "cartesian") then
4192    ! Go from cartesian to reduced.
4193    ABI_MALLOC(xcart, (3, new%natom))
4194    xcart = new%xred * Ang_Bohr
4195    call xcart2xred(new%natom, new%rprimd, xcart, new%xred)
4196    ABI_FREE(xcart)
4197  end if
4198 
4199  ABI_FREE(symbols)
4200  ABI_FREE(duplicated)
4201  return
4202 
4203  10 ABI_ERROR(sjoin("Error while parsing POSCAR file,", ch10, "iomsg:", trim(iomsg)))
4204 
4205 end function geo_from_poscar_unit

m_parser/geo_malloc [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_malloc

FUNCTION

  Allocate memory once %natom and %ntypat are know

SOURCE

4381 subroutine geo_malloc(self)
4382 
4383 !Arguments ------------------------------------
4384  class(geo_t),intent(inout) :: self
4385 
4386 !************************************************************************
4387 
4388  ABI_MALLOC(self%typat, (self%natom))
4389  ABI_MALLOC(self%xred, (3, self%natom))
4390  ABI_MALLOC(self%znucl, (self%ntypat))
4391 
4392 end subroutine geo_malloc

m_parser/geo_print_abivars [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  geo_print_abivars

FUNCTION

  Print Abinit variables corresponding to POSCAR

SOURCE

4217 subroutine geo_print_abivars(self, unit)
4218 
4219 !Arguments ------------------------------------
4220  class(geo_t),intent(in) :: self
4221  integer,intent(in) :: unit
4222 
4223 !Local variables-------------------------------
4224  integer :: ii, iatom, itypat
4225 
4226 !************************************************************************
4227 
4228  if (unit == dev_null) return
4229 
4230  write(unit, "(2a)")"# fileformat: ", trim(self%fileformat)
4231  if (len_trim(self%title) > 0) write(unit, "(2a)")"# ",trim(self%title)
4232  write(unit, "(a, i0)")" natom ", self%natom
4233  write(unit, "(a, i0)")" ntypat ", self%ntypat
4234  write(unit, sjoin("(a, ", itoa(self%natom), "(i0,1x))")) " typat ", self%typat
4235  write(unit, sjoin("(a, ", itoa(self%ntypat), "(f5.1,1x))")) " znucl ", self%znucl
4236  write(unit, "(a)")" acell 1 1 1 Bohr"
4237  write(unit, "(a)")" rprim "
4238  do ii=1,3
4239    write(unit, "(2x, 3(f11.7,1x))") self%rprimd(:, ii)
4240  end do
4241  write(unit, "(a)")" xred"
4242  do iatom=1,self%natom
4243    itypat = self%typat(iatom)
4244    write(unit, "(2x, 3(f11.7,1x),3x,2a)") self%xred(:, iatom) , " # ", trim(znucl2symbol(self%znucl(itypat)))
4245  end do
4246 
4247 end subroutine geo_print_abivars

m_parser/geo_t [ Types ]

[ Top ] [ m_parser ] [ Types ]

NAME

 geo_t

FUNCTION

  Small object describing the crystalline structure read from an external file
  or a string given in the input file.

SOURCE

131  type,public :: geo_t
132 
133   integer :: natom = 0
134   ! Number of atoms
135 
136   integer :: ntypat = 0
137   ! Number of type of atoms
138 
139   character(len=500) :: title = ""
140   ! Optional title read for external file e.g. POSCAR
141 
142   character(len=500) :: fileformat = ""
143   ! (poscar, netcdf)
144 
145   integer,allocatable :: typat(:)
146   ! typat(natom)
147   ! Type of each natom.
148 
149   real(dp) :: rprimd(3,3)
150 
151   real(dp),allocatable :: xred(:,:)
152   ! xred(3,natom)
153   ! Reduced coordinates.
154 
155   real(dp),allocatable :: znucl(:)
156   ! znucl(ntypat)
157   ! Nuclear charge for each type of pseudopotential
158   ! Note that ntypat must be equal to npsp --> no alchemical mixing
159 
160  contains
161 
162    procedure :: free => geo_free
163    ! Free memory.
164 
165    procedure :: malloc => geo_malloc
166    ! Allocate memory
167 
168    procedure :: bcast => geo_bcast
169    ! Brodcast object
170 
171    procedure :: print_abivars => geo_print_abivars
172    !  Print Abinit variables corresponding to POSCAR
173 
174  end type geo_t
175 
176  public :: geo_from_abivar_string   ! Build object form abinit variable
177  public :: geo_from_poscar_path     ! Build object from POSCAR filepath.
178 
179  public :: intagm_img   !  Read input file variables according to images path definition (1D array)
180 
181  interface intagm_img
182    module procedure intagm_img_1D
183    module procedure intagm_img_2D
184  end interface intagm_img
185 
186 
187 CONTAINS  !===========================================================

m_parser/get_acell_rprim [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  get_acell_rprim

FUNCTION

  Get acell and rprim from string

INPUTS

 string*(*)=character string containing all the input data. Initialized previously in instrng.
 jdtset=number of the dataset looked for
 iimage= index of the current image
 nimage=Number of images.
 marr=dimension of the intarr and dprarr arrays, as declared in the calling subroutine.

OUTPUT

 acell(3)=length of primitive vectors
 rprim(3,3)=dimensionless real space primitive translations

FUNCTION

SOURCE

4440 subroutine get_acell_rprim(lenstr, string, jdtset, iimage, nimage, marr, acell, rprim)
4441 
4442 !Arguments ------------------------------------
4443  integer,intent(in) :: lenstr, jdtset, iimage, nimage, marr
4444  character(len=*),intent(in) :: string
4445  real(dp),intent(out) :: acell(3)
4446  real(dp),intent(out) :: rprim(3,3)
4447 
4448 !Local variables-------------------------------
4449  integer :: tacell, tangdeg, tread, trprim, mu
4450  real(dp) :: a2, aa, cc, cosang
4451  character(len=500) :: msg
4452 !arrays
4453  integer,allocatable :: intarr(:)
4454  real(dp) :: angdeg(3)
4455  real(dp),allocatable :: dprarr(:)
4456 
4457 !************************************************************************
4458 
4459  ABI_MALLOC(intarr, (marr))
4460  ABI_MALLOC(dprarr, (marr))
4461 
4462  acell(1:3) = one
4463  call intagm(dprarr,intarr,jdtset,marr,3,string(1:lenstr),'acell',tacell,'LEN')
4464  if(tacell==1) acell(1:3)=dprarr(1:3)
4465  call intagm_img(acell,iimage,jdtset,lenstr,nimage,3,string,"acell",tacell,'LEN')
4466 
4467  ! Check that input length scales acell(3) are > 0
4468  do mu=1,3
4469    if(acell(mu) <= zero) then
4470      write(msg, '(a,i0,a, 1p,e14.6,4a)' )&
4471       'Length scale ',mu,' is input as acell: ',acell(mu),ch10,&
4472       'However, length scales must be > 0 ==> stop',ch10,&
4473       'Action: correct acell in input file.'
4474      ABI_ERROR(msg)
4475    end if
4476  end do
4477 
4478  ! Initialize rprim, or read the angles
4479  tread=0
4480  call intagm(dprarr,intarr,jdtset,marr,9,string(1:lenstr),'rprim',trprim,'DPR')
4481  if (trprim==1) rprim(:,:) = reshape( dprarr(1:9), [3, 3])
4482  call intagm_img(rprim,iimage,jdtset,lenstr,nimage,3,3,string,"rprim",trprim,'DPR')
4483 
4484  if(trprim==0)then
4485    ! If none of the rprim were read ...
4486    call intagm(dprarr,intarr,jdtset,marr,3,string(1:lenstr),'angdeg',tangdeg,'DPR')
4487    angdeg(:)=dprarr(1:3)
4488    call intagm_img(angdeg,iimage,jdtset,lenstr,nimage,3,string,"angdeg",tangdeg,'DPR')
4489 
4490    if(tangdeg==1)then
4491      !call wrtout(std_out,' ingeo: use angdeg to generate rprim.')
4492 
4493      ! Check that input angles are positive
4494      do mu=1,3
4495        if(angdeg(mu)<=0.0_dp) then
4496          write(msg, '(a,i0,a,1p,e14.6,a,a,a,a)' )&
4497           'Angle number ',mu,' is input as angdeg: ',angdeg(mu),ch10,&
4498           'However, angles must be > 0 ==> stop',ch10,&
4499           'Action: correct angdeg in the input file.'
4500          ABI_ERROR(msg)
4501        end if
4502      end do
4503 
4504      ! Check that the sum of angles is smaller than 360 degrees
4505      if(angdeg(1)+angdeg(2)+angdeg(3)>=360.0_dp) then
4506        write(msg, '(a,a,a,es14.4,a,a,a)' )&
4507         'The sum of input angles (angdeg(1:3)) must be lower than 360 degrees',ch10,&
4508         'while it is: ',angdeg(1)+angdeg(2)+angdeg(3),'.',ch10,&
4509         'Action: correct angdeg in the input file.'
4510        ABI_ERROR(msg)
4511      end if
4512 
4513      if( abs(angdeg(1)-angdeg(2))<tol12 .and. &
4514          abs(angdeg(2)-angdeg(3))<tol12 .and. &
4515          abs(angdeg(1)-90._dp)+abs(angdeg(2)-90._dp)+abs(angdeg(3)-90._dp)>tol12 )then
4516        ! Treat the case of equal angles (except all right angles):
4517        ! generates trigonal symmetry wrt third axis
4518        cosang=cos(pi*angdeg(1)/180.0_dp)
4519        a2=2.0_dp/3.0_dp*(1.0_dp-cosang)
4520        aa=sqrt(a2)
4521        cc=sqrt(1.0_dp-a2)
4522        rprim(1,1)=aa        ; rprim(2,1)=0.0_dp                 ; rprim(3,1)=cc
4523        rprim(1,2)=-0.5_dp*aa ; rprim(2,2)= sqrt(3.0_dp)*0.5_dp*aa ; rprim(3,2)=cc
4524        rprim(1,3)=-0.5_dp*aa ; rprim(2,3)=-sqrt(3.0_dp)*0.5_dp*aa ; rprim(3,3)=cc
4525        ! write(std_out,*)' ingeo: angdeg=',angdeg(1:3), aa,cc=',aa,cc
4526      else
4527        ! Treat all the other cases
4528        rprim(:,:)=0.0_dp
4529        rprim(1,1)=1.0_dp
4530        rprim(1,2)=cos(pi*angdeg(3)/180.0_dp)
4531        rprim(2,2)=sin(pi*angdeg(3)/180.0_dp)
4532        rprim(1,3)=cos(pi*angdeg(2)/180.0_dp)
4533        rprim(2,3)=(cos(pi*angdeg(1)/180.0_dp)-rprim(1,2)*rprim(1,3))/rprim(2,2)
4534        rprim(3,3)=sqrt(1.0_dp-rprim(1,3)**2-rprim(2,3)**2)
4535      end if
4536 
4537    end if
4538  end if ! No problem if neither rprim nor angdeg are defined: use default rprim
4539 
4540  ABI_FREE(intarr)
4541  ABI_FREE(dprarr)
4542 
4543 end subroutine get_acell_rprim

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

SOURCE

2152 subroutine importxyz(lenstr,string_raw,string_upper,strln)
2153 
2154 !Arguments ------------------------------------
2155 !scalars
2156  integer,intent(in) :: strln
2157  integer,intent(inout) :: lenstr
2158  character(len=*),intent(in) :: string_raw
2159  character(len=*),intent(inout) :: string_upper
2160 
2161 !Local variables-------------------------------
2162  character :: blank=' '
2163 !scalars
2164  integer :: dtset_len,ixyz,ii,index_already_done,index_xyz_fname
2165  integer :: index_xyz_fname_end,index_xyz_token,kk
2166  character(len=2) :: dtset_char
2167  character(len=500) :: msg
2168  character(len=fnlen) :: xyz_fname
2169 
2170 !************************************************************************
2171 
2172  index_already_done=1
2173  ixyz=0
2174 
2175  do
2176    ! Infinite do-loop, to identify the presence of the xyzFILE token
2177    index_xyz_token=index(string_upper(index_already_done:lenstr),"XYZFILE")
2178    if(index_xyz_token==0)exit
2179 
2180    ixyz=ixyz+1
2181    if(ixyz==1)then
2182      write(msg,'(80a)')('=',ii=1,80)
2183      call wrtout(ab_out,msg)
2184    end if
2185 
2186    ! The xyzFILE token has been identified
2187    index_xyz_token=index_already_done+index_xyz_token-1
2188 
2189    ! Find the related dataset tag, and length
2190    dtset_char=string_upper(index_xyz_token+7:index_xyz_token+8)
2191    if(dtset_char(1:1)==blank)dtset_char(2:2)=blank
2192    dtset_len=len_trim(dtset_char)
2193 
2194    ! Find the name of the xyz file
2195    index_xyz_fname=index_xyz_token+8+dtset_len
2196    index_xyz_fname_end=index(string_upper(index_xyz_fname:lenstr),blank)
2197 
2198    if(index_xyz_fname_end ==0 )then
2199      write(msg, '(5a,i4,2a)' )&
2200      'Could not find the name of the xyz file.',ch10,&
2201      'index_xyz_fname_end should be non-zero, while it is :',ch10,&
2202      'index_xyz_fname_end=',index_xyz_fname_end,ch10,&
2203      'Action: check the filename that was provided after the XYZFILE input variable keyword.'
2204      ABI_ERROR(msg)
2205    end if
2206 
2207    index_xyz_fname_end=index_xyz_fname_end+index_xyz_fname-1
2208 
2209    index_already_done=index_xyz_fname_end
2210 
2211    ! Initialize xyz_fname to a blank line
2212    xyz_fname=repeat(blank,fnlen)
2213    xyz_fname=string_raw(index_xyz_fname:index_xyz_fname_end-1)
2214 
2215    write(msg, '(3a)') ch10, ' importxyz : Identified token XYZFILE, referring to file ',trim(xyz_fname)
2216    call wrtout([std_out, ab_out],msg)
2217 
2218    ! Append the data from the xyz file to the string, and update the length of the string
2219    call append_xyz(dtset_char,lenstr,string_upper,xyz_fname,strln)
2220 
2221    ! erase the file name from string_upper
2222    string_upper(index_xyz_fname:index_xyz_fname_end-1) = blank
2223  end do
2224 
2225  if (index_already_done > 1) then
2226    ! Initialize xyz_fname to a blank line
2227    xyz_fname=repeat(blank,fnlen)
2228    call append_xyz("-1",lenstr,string_upper,xyz_fname,strln)
2229  end if
2230 
2231  if(ixyz/=0)then
2232    call incomprs(string_upper,lenstr)
2233    ! A blank is needed at the beginning of the string
2234    do kk=lenstr,1,-1
2235      string_upper(kk+1:kk+1)=string_upper(kk:kk)
2236    end do
2237    string_upper(1:1)=blank
2238    lenstr=lenstr+1
2239    write(msg,'(a,80a,a)')ch10,('=',ii=1,80),ch10
2240    call wrtout(ab_out,msg)
2241  end if
2242 
2243 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 (starts with a blank)
  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, nm or angstrom,
            and return in au -atomic units=bohr- )
   'ENE' => real(dp) (expect a "energy", identify Ha, hartree, eV, meV, Ry, Rydberg)
   'BFI' => real(dp) (expect a "magnetic field", identify T, Tesla)
   'TIM' => real(dp) (expect a "time", identify S, Second)
   'LOG' => integer, but read logical variable T,F,.true., or .false.

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)

SOURCE

1959 subroutine inarray(b1,cs,dprarr,intarr,marr,narr,string,typevarphys)
1960 
1961 !Arguments ------------------------------------
1962 !scalars
1963  integer,intent(in) :: marr,narr
1964  integer,intent(inout) :: b1
1965  character(len=*),intent(in) :: string
1966  character(len=*),intent(in) :: typevarphys
1967  character(len=*),intent(in) :: cs
1968 !arrays
1969  integer,intent(inout) :: intarr(marr)
1970  real(dp),intent(out) :: dprarr(marr)
1971 
1972 !Local variables-------------------------------
1973  character(len=1), parameter :: blank=' '
1974 !scalars
1975  integer :: asciichar,b2,errcod,ii,integ,istar,nrep,strln
1976  real(dp) :: factor,real8
1977  character(len=3) :: typevar
1978  character(len=500*4) :: msg
1979 
1980 ! *************************************************************************
1981 
1982 !DEBUG
1983 ! write(std_out,'(5a)' )' inarray: token: ',trim(cs),' "',cs(1:6),'"'
1984 ! if(trim(cs)==' UPAWU1')then
1985 !   write(std_out,'(2a)' )'          string: ',trim(string(b1:))
1986 !   write(std_out,'(a,i0)' )'        narr: ',narr
1987 !   write(std_out,'(2a)' )'          typevarphys: ',typevarphys
1988 ! endif
1989 !ENDDEBUG
1990 
1991  ii = 0
1992  typevar='INT'
1993  if(typevarphys=='LOG') typevar='INT'
1994  if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. &
1995     typevarphys=='BFI' .or. typevarphys=='TIM') typevar='DPR'
1996 
1997  strln=len_trim(string)
1998 
1999  do while (ii < narr)
2000 
2001    ! Relative location of next blank after data
2002    ! b1 is the last character of the string
2003    if (b1>=strln) exit
2004 
2005    b2 = index(string(b1+1:),blank)
2006    ! If no second blank is found put the second blank just beyond strln
2007    if(b2==0) b2=strln-b1+1
2008 
2009    ! nrep tells how many times to repeat input in array:
2010    nrep=1
2011 
2012    ! Check for *, meaning repeated input (as in list-directed input):
2013    istar=index(string(b1+1:b1+b2-1),'*')
2014    if (istar/=0) then
2015      if (istar==1) then ! Simply fills the array with the data, repeated as many times as needed
2016        nrep=narr-ii
2017        errcod=0
2018      else
2019        call inread(string(b1+1:b1+istar-1),istar-1,'INT',nrep,real8,errcod)
2020      end if
2021      if (errcod/=0) exit
2022      ! Shift starting position of input field:
2023      b1=b1+istar
2024      b2=b2-istar
2025    end if
2026 
2027    ! Read data internally by calling inread at entry ini:
2028    call inread(string(b1+1:b1+b2-1),b2-1,typevarphys,integ,real8,errcod)
2029    if (errcod/=0) exit
2030 
2031    ! Allow for list-directed input with repeat number nrep:
2032    if(typevar=='INT')then
2033      intarr(1+ii:min(nrep+ii,narr))=integ
2034    else if(typevar=='DPR')then
2035      dprarr(1+ii:min(nrep+ii,narr))=real8
2036    else
2037      ABI_BUG('Disallowed typevar: '//typevar)
2038    end if
2039    ii=min(ii+nrep,narr)
2040 
2041    !  Find new absolute location of next element of array:
2042    b1=b1+b2
2043 
2044  end do ! while (ii<narr). Note "exit" instructions within loop.
2045 
2046  if (errcod /= 0) then
2047    write(msg, '(5a,i0,12a)' ) &
2048    'An error occurred reading data for keyword `',trim(cs),'`,',ch10,&
2049    'looking for ',narr,' elements.', ch10, &
2050    'There is a problem with the input string:',ch10,trim(string(b1:)), ch10, &
2051    'Maybe a disagreement between the declared dimension of the array,',ch10,&
2052    'and the number of items provided. ',ch10,&
2053    'Action: correct your input file and especially the keyword: ', trim(cs)
2054    ABI_ERROR(msg)
2055  end if
2056 
2057  ! In case of 'LEN', 'ENE', 'BFI', or 'TIM', try to identify the unit
2058  if (typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI' .or. typevarphys=='TIM') then
2059    do
2060      ! Relative location of next blank after data
2061      if(b1>=strln)exit   ! b1 is the last character of the string
2062      b2=index(string(b1+1:),blank)
2063      ! If no second blank is found put the second blank just beyond strln
2064      if(b2==0) b2=strln-b1+1
2065 
2066 !DEBUG
2067 ! if(trim(cs)==' UPAWU1')then
2068 !     write(std_out,*)' inarray : strln=',strln
2069 !     write(std_out,*)' inarray : b1=',b1,' b2=',b2
2070 !     write(std_out,*)' inarray : string(b1+1:)=',string(b1+1:)
2071 !     write(std_out,*)' typevarphys==',typevarphys
2072 ! endif
2073 !ENDDEBUG
2074 
2075      ! Identify the presence of a non-digit character
2076      asciichar=iachar(string(b1+1:b1+1))
2077      if(asciichar<48 .or. asciichar>57)then
2078        factor=one
2079        if(typevarphys=='LEN' .and. b2>=3)then
2080          if(string(b1+1:b1+6)=='ANGSTR')then
2081            factor=one/Bohr_Ang
2082          else if(string(b1+1:b1+3)=='NM ')then
2083            factor=ten/Bohr_Ang
2084          end if
2085        else if(typevarphys=='ENE' .and. b2>=3)then
2086          if(string(b1+1:b1+3)=='RY ')then
2087            factor=half
2088          else if(string(b1+1:b1+3)=='RYD')then
2089            factor=half
2090          else if(string(b1+1:b1+3)=='EV ')then
2091            factor=one/Ha_eV
2092          else if(string(b1+1:b1+4)=='MEV ')then
2093            factor=one/Ha_meV
2094          else if(string(b1+1:b1+7)=='Kelvin ')then
2095             factor=kb_HaK
2096          end if
2097        else if(typevarphys=='ENE' .and. b2>=2)then
2098          if(string(b1+1:b1+2)=='K ') factor=kb_HaK
2099        else if(typevarphys=='BFI' .and. b2>=2)then
2100          if(string(b1+1:b1+2)=='T ' .or. string(b1+1:b1+2)=='TE') factor=BField_Tesla
2101        else if (typevarphys=='TIM' .and. b2>=2) then
2102          if( string(b1+1:b1+2)=='SE' .or. string(b1+1:b1+2)=='S ') factor=one/Time_Sec
2103        endif
2104 
2105        dprarr(1:narr)=dprarr(1:narr)*factor
2106        exit
2107      else
2108        ! A digit has been observed, go to the next sequence
2109        b1=b1+b2
2110        cycle
2111      end if
2112 
2113    end do
2114  end if
2115 
2116 !DEBUG
2117 ! if(trim(cs)==' UPAWU1')then
2118 !   write(std_out,*)' dprarr(1:narr)==',dprarr(1:narr)
2119 !   stop
2120 ! endif
2121 !write(std_out,*)' inarray : exit '
2122 !ENDDEBUG
2123 
2124 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

SOURCE

 919 subroutine incomprs(string,length)
 920 
 921 !Arguments ------------------------------------
 922 !scalars
 923  integer,intent(out) :: length
 924  character(len=*),intent(inout) :: string
 925 
 926 !Local variables-------------------------------
 927  character(len=1) :: blank=' '
 928 !scalars
 929  integer :: bb,f1,ii,jj,kk,l1,lbef,lcut,lold,stringlen
 930 !arrays
 931  character(len=500) :: msg
 932 
 933 ! *************************************************************************
 934 
 935  ! String length determined by calling program declaration of "string"
 936  stringlen=len(string)
 937  length=stringlen
 938 
 939  ! Only proceed if string has nonzero length
 940  if (length>0) then
 941    ! Find last nonblank character (i.e. nonblank and nontab length)
 942    length=len_trim(string)
 943    if (length==0) then
 944      ! Line is all blanks or tabs so do not proceed
 945      ! write(std_out,*)' incomprs: blank line encountered'
 946    else
 947 
 948      ! Replace all characters lexically less than SP, and '=', by SP (blank)
 949      call inreplsp(string(1:length))
 950 
 951      ! Continue with parsing
 952      ! l1 is set to last nonblank, nontab character position
 953      l1=length
 954      do ii=1,l1
 955        if (string(ii:ii)/=blank) exit
 956      end do
 957 
 958      ! f1 is set to first nonblank, nontab character position
 959      f1=ii
 960      ! lbef is number of characters in string starting at
 961      ! first nonblank, nontab and going to last
 962      lbef=l1-f1+1
 963 
 964      ! Process characters one at a time from right to left:
 965      bb=0
 966      lcut=lbef
 967      do ii=1,lbef
 968        jj=lbef+f1-ii
 969        ! set bb=position of next blank coming in from right
 970        if (string(jj:jj)==blank) then
 971          if (bb==0) bb=jj
 972        else
 973          if (bb/=0) then
 974            ! if several blanks in a row were found, cut from string
 975            if (jj<bb-1) then
 976              ! lold becomes string length before cutting blanks
 977              lold=lcut
 978              ! lcut will be new string length
 979              lcut=lcut-(bb-1-jj)
 980              ! redefine string with repeated blanks gone
 981              do kk=1,f1+lcut-1-jj
 982                string(jj+kk:jj+kk)=string(kk+bb-1:kk+bb-1)
 983              end do
 984            end if
 985            bb=0
 986          end if
 987        end if
 988      end do
 989 
 990      ! Remove initial blanks in string if any
 991      if (f1>1) string(1:lcut)=string(f1:f1+lcut-1)
 992 
 993      ! Add blank on end unless string had no extra space
 994      if (lcut==stringlen) then
 995        write(msg,'(a,i7,a,a,a,a,a,a,a,a)')&
 996        'For input file, with data forming a string of',stringlen,' characters,',ch10,&
 997        'no double blanks or tabs were found.',ch10,&
 998        'This is unusual for an input file (or any file),',ch10,&
 999        'and may cause parsing trouble.  Is this a binary file?',ch10
1000        ABI_WARNING(msg)
1001      else
1002        length=lcut+1
1003        string(length:length)=blank
1004      end if
1005    end if
1006  end if
1007 
1008 end subroutine incomprs

m_parser/ingeo_img_1D [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  intagm_img_1D

FUNCTION

  Read input file variables according to images path definition (1D array)

  This function is exposed through generic interface that allows to
  initialize some of the geometry variables in the case of "images".
  Set up: acell, scalecart, rprim, angdeg, xred, xcart, vel
  These variables can be defined for a set of images of the cell.
  They also can be be defined along a path (in the configuration space).
  The path must be defined with its first and last points, but also
  with intermediate points.

INPUTS

  iimage=index of the current image
  jdtset=number of the dataset looked for
  lenstr=actual length of the input string
  nimage=number of images
  size1,size2, ...: size of array to be read (dp_data)
  string=character string containing 'tags' and data.
  token=character string for tagging the data to be read in input string
  typevarphys= variable type (for dimensionality purposes)

SIDE EFFECTS

  dp_data(size1,size2,...)=data to be read (double precision)
  tread_ok=flag to be set to 1 if the data have been found in input string

NOTES

 The routine is a generic interface calling subroutine according to the
 number of arguments of the variable to be read

SOURCE

1682 subroutine intagm_img_1D(dp_data,iimage,jdtset,lenstr,nimage,size1,string,token,tread_ok,typevarphys)
1683 
1684 !Arguments ------------------------------------
1685 !scalars
1686  integer,intent(in) :: iimage,jdtset,lenstr,nimage,size1
1687  integer,intent(inout) :: tread_ok
1688  real(dp),intent(inout) :: dp_data(size1)
1689  character(len=*),intent(in) :: typevarphys
1690  character(len=*),intent(in) :: token
1691  character(len=*),intent(in) :: string
1692 !arrays
1693 
1694 !Local variables-------------------------------
1695 !scalars
1696  integer :: iimage_after,iimage_before,marr,tread_after,tread_before,tread_current
1697  real(dp) :: alpha
1698  character(len=10) :: stringimage
1699  character(len=3*len(token)+10) :: token_img
1700 !arrays
1701  integer, allocatable :: intarr(:)
1702  real(dp),allocatable :: dprarr(:),dp_data_after(:),dp_data_before(:)
1703 
1704 ! *************************************************************************
1705 
1706 !Nothing to do in case of a single image
1707  if (nimage<=1) return
1708 
1709  marr=size1
1710  ABI_MALLOC(intarr,(marr))
1711  ABI_MALLOC(dprarr,(marr))
1712 
1713 !First, try to read data for current image
1714  tread_current=0
1715  write(stringimage,'(i10)') iimage
1716  token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1717  call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr),&
1718 &            token_img,tread_current,typevarphys)
1719  if (tread_current==1)then
1720    dp_data(1:size1)=dprarr(1:size1)
1721    tread_ok=1
1722  end if
1723  if (tread_current==0.and.iimage==nimage) then
1724 !  If the image is the last one, try to read data for last image (_lastimg)
1725    token_img=trim(token)//'_lastimg'
1726    call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr),&
1727 &              token_img,tread_current,typevarphys)
1728    if (tread_current==1)then
1729      dp_data(1:size1)=dprarr(1:size1)
1730      tread_ok=1
1731    end if
1732  end if
1733 
1734  if (tread_current==0) then
1735 
1736 !  The current image is not directly defined in the input string
1737    ABI_MALLOC(dp_data_before,(size1))
1738    ABI_MALLOC(dp_data_after,(size1))
1739 
1740 !  Find the nearest previous defined image
1741    tread_before=0;iimage_before=iimage
1742    do while (iimage_before>1.and.tread_before/=1)
1743      iimage_before=iimage_before-1
1744      write(stringimage,'(i10)') iimage_before
1745      token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1746      call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr),&
1747 &                token_img,tread_before,typevarphys)
1748      if (tread_before==1) dp_data_before(1:size1)=dprarr(1:size1)
1749    end do
1750    if (tread_before==0) then
1751      iimage_before=1
1752      dp_data_before(1:size1)=dp_data(1:size1)
1753    end if
1754 
1755 !  Find the nearest following defined image
1756    tread_after=0;iimage_after=iimage
1757    do while (iimage_after<nimage.and.tread_after/=1)
1758      iimage_after=iimage_after+1
1759      write(stringimage,'(i10)') iimage_after
1760      token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1761      call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr),&
1762 &                token_img,tread_after,typevarphys)
1763      if (tread_after==1) dp_data_after(1:size1)=dprarr(1:size1)
1764      if (tread_after==0.and.iimage_after==nimage) then
1765        token_img=trim(token)//'_lastimg'
1766        call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr),&
1767 &                  token_img,tread_after,typevarphys)
1768        if (tread_after==1) dp_data_after(1:size1)=dprarr(1:size1)
1769      end if
1770    end do
1771    if (tread_after==0) then
1772      iimage_after=nimage
1773      dp_data_after(1:size1)=dp_data(1:size1)
1774    end if
1775 
1776 !  Interpolate image data
1777    if (tread_before==1.or.tread_after==1) then
1778      alpha=real(iimage-iimage_before,dp)/real(iimage_after-iimage_before,dp)
1779      dp_data(1:size1)=dp_data_before(1:size1) &
1780 &                    +alpha*(dp_data_after(1:size1)-dp_data_before(1:size1))
1781      tread_ok=1
1782    end if
1783 
1784    ABI_FREE(dp_data_before)
1785    ABI_FREE(dp_data_after)
1786 
1787  end if
1788 
1789  ABI_FREE(intarr)
1790  ABI_FREE(dprarr)
1791 
1792 end subroutine intagm_img_1D

m_parser/ingeo_img_2D [ Functions ]

[ Top ] [ m_parser ] [ Functions ]

NAME

  intagm_img_2D

FUNCTION

  Read input file variables according to images path definition (2D array)

INPUTS

SOURCE

1808 subroutine intagm_img_2D(dp_data,iimage,jdtset,lenstr,nimage,size1,size2,string,token,tread_ok,typevarphys)
1809 
1810 !Arguments ------------------------------------
1811 !scalars
1812  integer,intent(in) :: iimage,jdtset,lenstr,nimage,size1,size2
1813  integer,intent(inout) :: tread_ok
1814  real(dp),intent(inout) :: dp_data(size1,size2)
1815  character(len=*),intent(in) :: typevarphys
1816  character(len=*),intent(in) :: token
1817  character(len=*),intent(in) :: string
1818 !arrays
1819 
1820 !Local variables-------------------------------
1821 !scalars
1822  integer :: iimage_after,iimage_before,marr,tread_after,tread_before,tread_current
1823  real(dp) :: alpha
1824  character(len=10) :: stringimage
1825  character(len=3*len(token)+10) :: token_img
1826 !arrays
1827  integer, allocatable :: intarr(:)
1828  real(dp),allocatable :: dprarr(:),dp_data_after(:,:),dp_data_before(:,:)
1829 
1830 ! *************************************************************************
1831 
1832 !Nothing to do in case of a single image
1833  if (nimage<=1) return
1834 
1835  marr=size1*size2
1836  ABI_MALLOC(intarr,(marr))
1837  ABI_MALLOC(dprarr,(marr))
1838 
1839 !First, try to read data for current image
1840  tread_current=0
1841  write(stringimage,'(i10)') iimage
1842  token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1843  call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr),&
1844 &            token_img,tread_current,typevarphys)
1845  if (tread_current==1)then
1846    dp_data(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
1847    tread_ok=1
1848  end if
1849  if (tread_current==0.and.iimage==nimage) then
1850 !  In the image is the last one, try to read data for last image (_lastimg)
1851    token_img=trim(token)//'_lastimg'
1852    call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr),&
1853 &              token_img,tread_current,typevarphys)
1854    if (tread_current==1)then
1855      dp_data(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
1856      tread_ok=1
1857    end if
1858  end if
1859 
1860  if (tread_current==0) then
1861 
1862 !  The current image is not directly defined in the input string
1863    ABI_MALLOC(dp_data_before,(size1,size2))
1864    ABI_MALLOC(dp_data_after,(size1,size2))
1865 
1866 !  Find the nearest previous defined image
1867    tread_before=0;iimage_before=iimage
1868    do while (iimage_before>1.and.tread_before/=1)
1869      iimage_before=iimage_before-1
1870      write(stringimage,'(i10)') iimage_before
1871      token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1872      call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr),&
1873 &                token_img,tread_before,typevarphys)
1874      if (tread_before==1) &
1875 &      dp_data_before(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
1876    end do
1877    if (tread_before==0) then
1878      iimage_before=1
1879      dp_data_before(1:size1,1:size2)=dp_data(1:size1,1:size2)
1880    end if
1881 
1882 !  Find the nearest following defined image
1883    tread_after=0;iimage_after=iimage
1884    do while (iimage_after<nimage.and.tread_after/=1)
1885      iimage_after=iimage_after+1
1886      write(stringimage,'(i10)') iimage_after
1887      token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1888      call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr),&
1889 &                token_img,tread_after,typevarphys)
1890      if (tread_after==1) &
1891 &      dp_data_after(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
1892      if (tread_after==0.and.iimage_after==nimage) then
1893        token_img=trim(token)//'_lastimg'
1894        call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr),&
1895 &                  token_img,tread_after,typevarphys)
1896        if (tread_after==1) &
1897 &        dp_data_after(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
1898      end if
1899    end do
1900    if (tread_after==0) then
1901      iimage_after=nimage
1902      dp_data_after(1:size1,1:size2)=dp_data(1:size1,1:size2)
1903    end if
1904 
1905 !  Interpolate image data
1906    if (tread_before==1.or.tread_after==1) then
1907      alpha=real(iimage-iimage_before,dp)/real(iimage_after-iimage_before,dp)
1908      dp_data(1:size1,1:size2)=dp_data_before(1:size1,1:size2) &
1909 &       +alpha*(dp_data_after(1:size1,1:size2)-dp_data_before(1:size1,1:size2))
1910      tread_ok=1
1911    end if
1912 
1913    ABI_FREE(dp_data_before)
1914    ABI_FREE(dp_data_after)
1915 
1916  end if
1917 
1918  ABI_FREE(intarr)
1919  ABI_FREE(dprarr)
1920 
1921 end subroutine intagm_img_2D

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 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.

SOURCE

316 subroutine inread(string,ndig,typevarphys,outi,outr,errcod)
317 
318 !Arguments ------------------------------------
319 !scalars
320  integer,intent(in) :: ndig
321  integer,intent(out) :: errcod,outi
322  real(dp),intent(out) :: outr
323  character(len=*),intent(in) :: string
324  character(len=*),intent(in) :: typevarphys
325 
326 !Local variables-------------------------------
327 !scalars
328  integer :: done,idig,index_slash,sign
329  real(dp) :: den,num
330  logical :: logi
331  character(len=500) :: msg,iomsg
332 
333 ! *************************************************************************
334 
335  !write(std_out,*)'inread: enter with string(1:ndig): ',string(1:ndig)
336  !write(std_out,*)'typevarphys: ',typevarphys
337 
338  if (typevarphys=='INT') then
339 
340    ! integer input section
341    read(unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) outi
342 
343    if(errcod/=0)then
344      ! integer reading error
345      write(msg,'(a,i0,8a)' ) &
346        "Attempted to read ndig: ",ndig," integer digits", ch10, &
347        "from string(1:ndig)= `",string(1:ndig),"` to initialize an integer variable",ch10,&
348        "iomsg: ", trim(iomsg)
349      ABI_WARNING(msg)
350      errcod=1
351    end if
352 
353  else if (typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' &
354          .or. typevarphys=='BFI' .or. typevarphys=='TIM') then
355 
356    ! real(dp) input section
357    ! Special treatment of SQRT(xxx) or -SQRT(xxx) chains of characters, where xxx can be a fraction
358    done=0
359    if (ndig>5) then
360      if(string(1:5)=='SQRT(' .and. string(ndig:ndig)==')')then
361        done=1 ; sign=1
362      else if(string(1:6)=='-SQRT(' .and. string(ndig:ndig)==')')then
363        done=1 ; sign=2
364      end if
365 
366      if(done==1)then
367        index_slash=index(string(5+sign:ndig-1),'/')
368        if(index_slash==0)then
369          read (unit=string(5+sign:ndig-1),fmt=*,iostat=errcod, iomsg=iomsg) outr
370        else if(index_slash/=0)then
371          read (unit=string(5+sign:5+sign+index_slash-2),fmt=*,iostat=errcod, iomsg=iomsg) num
372          if(errcod==0)then
373            read (unit=string(5+sign+index_slash:ndig-1),fmt=*,iostat=errcod, iomsg=iomsg) den
374            if(errcod==0)then
375              if(abs(den)<tol12)then
376                errcod=1
377              else
378                outr=num/den
379              end if
380            end if
381          end if
382        end if
383        if(outr<-tol12)then
384          errcod=1
385        else
386          outr=sqrt(outr)
387          if(sign==2)outr=-outr
388        end if
389      end if
390    end if
391 
392    ! Special treatment of fractions
393    if(done==0)then
394      index_slash=index(string(1:ndig),'/')
395      if(index_slash/=0)then
396        done=1
397        read (unit=string(1:index_slash-1), fmt=*, iostat=errcod, iomsg=iomsg) num
398        if(errcod==0)then
399          read (unit=string(index_slash+1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) den
400          if(errcod==0)then
401            if(abs(den)<tol12)then
402              errcod=1
403            else
404              outr=num/den
405            end if
406          end if
407        end if
408      end if
409    end if
410 
411    ! Normal treatment of floats
412    if(done==0) read (unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) outr
413 
414    ! Treatment of errors
415    if(errcod/=0)then
416      ! real(dp) data reading error
417      write(msg,'(a,i0,8a)' ) &
418         'Attempted to read ndig: ',ndig,' floating point digits,',ch10, &
419         'from string(1:ndig): `',string(1:ndig),'` to initialize a floating variable.',ch10, &
420         "iomsg: ", trim(iomsg)
421      ABI_WARNING(msg)
422      errcod=2
423    end if
424 
425  else if (typevarphys=='LOG') then
426 
427    read (unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) logi
428 
429    if(errcod/=0)then
430      ! integer reading error
431      write(msg,'(a,i0,8a)' ) &
432        "Attempted to read ndig: ",ndig," integer digits", ch10, &
433        "from string(1:ndig): `",string(1:ndig),"` to initialize a logical variable.",ch10,&
434        "iomsg: ", trim(iomsg)
435      ABI_WARNING(msg)
436      errcod=3
437    end if
438 
439    if(logi)outi=1
440    if(.not.logi)outi=0
441 
442  else
443    write(msg,'(4a)' ) &
444    'Argument typevarphys must be INT, DPR, LEN, ENE, BFI, TIM or LOG ',ch10,&
445    'but input value was: ',trim(typevarphys)
446    ABI_ERROR(msg)
447  end if
448 
449  if (errcod /= 0)then
450    do idig=1,ndig
451      if( string(idig:idig) == 'O' )then
452        write(msg,'(3a)' ) &
453        'Note that this string contains the letter O. ',ch10,&
454        'It is likely that this letter should be replaced by the number 0.'
455        ABI_WARNING(msg)
456        exit
457      end if
458    end do
459  end if
460 
461 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.

SOURCE

862 subroutine inreplsp(string)
863 
864 !Arguments ------------------------------------
865 !scalars
866  character(len=*),intent(inout) :: string
867 
868 !Local variables-------------------------------
869 !scalars
870  integer :: ilenth,length
871 
872 ! *************************************************************************
873 
874  ! Get length of string. Proceed only if string has nonzero length
875  length=len(string); if (length == 0) return
876 
877  !  Do replacement by going through input character string one character at a time
878  do ilenth=1,length
879    if (llt(string(ilenth:ilenth),' ')) string(ilenth:ilenth)=' '
880    if (string(ilenth:ilenth)=='=') string(ilenth:ilenth)=' '
881  end do
882 
883 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)=preprocessed string of character
  raw_string=string without any preprocessine (comments are included.

SOURCE

491 recursive subroutine instrng(filnam, lenstr, option, strln, string, raw_string)
492 
493 !Arguments ------------------------------------
494 !scalars
495  integer,intent(in) :: option,strln
496  integer,intent(out) :: lenstr
497  character(len=*),intent(in) :: filnam
498  character(len=*),intent(out) :: string
499  character(len=*),intent(out) :: raw_string
500 
501 !Local variables-------------------------------
502  character :: blank=' '
503 !scalars
504  integer,save :: include_level=-1
505  integer :: b0,b1,b2,b3,ierr,ii,ii1,ii2,ij,iline,ios,iost,isign
506  integer :: lenc,lenstr_inc,len_val,mline,nline1,input_unit,shift,sign,lenstr_raw
507  logical :: include_found, ex
508 !arrays
509  integer :: bs(2)
510  character(len=1) :: string1
511  character(len=3) :: string3
512  character(len=500) :: filnam_inc,msg
513  character(len=fnlen) :: shell_var, shell_value
514  character(len=fnlen+20) :: line
515  character(len=strlen),pointer :: string_inc, raw_string_inc
516 
517 !************************************************************************
518 
519  DBG_ENTER("COLL")
520 
521 !%%%%%%%%%%%%%%%%%%%%%%%%
522 !read in string from file
523 !%%%%%%%%%%%%%%%%%%%%%%%%
524 
525  ! The file can be included in another (prevent too many include levels)
526  include_level=include_level+1
527  if (include_level>2) then
528    write(msg, '(3a)' ) &
529    'At least 4 levels of included files are present in input file !',ch10,&
530    'This is not allowed. Action: change your input file.'
531    ABI_ERROR(msg)
532  end if
533 
534  ! Open data file and read one line at a time, compressing data
535  ! and concatenating into single string:
536  if (open_file(filnam,msg,newunit=input_unit,form="formatted",status="old",action="read") /= 0) then
537    ABI_ERROR(msg)
538  end if
539  rewind (unit=input_unit)
540 
541  ! Initialize string to blanks
542  string=blank
543  lenstr=1
544  lenstr_raw = 0
545 
546  ! Set maximum number lines to be read to some large number
547  mline=500000
548  do iline=1,mline
549 
550    ! Keeps reading lines until end of input file
551    read (unit=input_unit,fmt= '(a)' ,iostat=ios) line(1:fnlen+20)
552    !  Hello ! This is a commentary. Please, do not remove me.
553    !  In fact, this commentary protect tests_v4 t47 for miscopying
554    !  the input file into the output string. It _is_ strange.
555    !  The number of lines in the commentary is also resulting from
556    !  a long tuning..
557 
558    ! write(std_out,*)' instrng, iline=',iline,' ios=',ios,' echo :',trim(line(1:fnlen+20))
559 
560    ! Exit the reading loop when arrived at the end
561    if (ios/=0) then
562      backspace(input_unit)
563      read (unit=input_unit,fmt= '(a1)' ,iostat=ios) string1
564      if(ios/=0)exit
565      backspace(input_unit)
566      read (unit=input_unit,fmt= '(a3)' ,iostat=ios) string3
567      if(string3=='end') exit
568      write(msg, '(3a,i0,11a)' ) &
569       'It is observed in the input file: ',TRIM(filnam),', line number ',iline,',',ch10,&
570       'that there is a non-zero IO signal.',ch10,&
571       'This is normal when the file is completely read.',ch10,&
572       'However, it seems that the error appears while your file has not been completely read.',ch10,&
573       'Action: correct your file. If your file seems correct, then,',ch10,&
574       'add the keyword ''end'' at the very beginning of the last line of your input file.'
575      ABI_ERROR(msg)
576    end if
577 
578    ! Save raw line in raw_string including comments that may be needed by external processors
579    ! e.g. AbiPy may need the JSON section with pseudos. Also add new line.
580    ii2 = len_trim(line) + 1
581    if (lenstr_raw + ii2 > strln) then
582      write(msg, '(8a)' ) &
583       'The size of your input file: ',trim(filnam),' is such that the internal',ch10,&
584       'character string that should contain it is too small.',ch10,&
585       'Action: decrease the size of your input file,',ch10,&
586       'or contact the ABINIT group.'
587      ABI_ERROR(msg)
588    end if
589 
590    raw_string(lenstr_raw+1:lenstr_raw+ii2) = trim(line) // new_line("A")
591    lenstr_raw = lenstr_raw + ii2
592 
593    ! TODO: Ignore sections inside TEST_INFO markers so that we don't need to prepend comment markers.
594    !in_testinfo = 0
595    !if startswith(line, "#%%<BEGIN TEST_INFO") in_testinfo = 1
596    !if (in_testinfo /= 0) cycle
597    !if startswith(line, "#%%<END TEST_INFO> ") then
598    !  in_testinfo = 0; cycle
599    !end if
600 
601    ! Find length of input line ignoring delimiter characters (# or !)
602    ! and any characters beyond it (allows for comments beyond # or !)
603    ii1=index(line(1:fnlen+20),'#')
604    ii2=index(line(1:fnlen+20),'!')
605    if ( (ii1==0 .and. ii2==0) .or. option==0 ) then
606      ! delimiter character was not found on line so use full line
607      ii=fnlen+20
608    else if(ii1==0)then
609      ! ii will represent length of line up to but not including !
610      ii=ii2-1
611    else if(ii2==0)then
612      ! ii will represent length of line up to but not including #
613      ii=ii1-1
614    else
615      ii=min(ii1,ii2)-1
616    end if
617 
618    ! Checks that nothing is left beyond fnlen
619    if(ii>fnlen)then
620      !write(std_out, *)"line: `", line(1:fnlen+20), "`"
621      do ij=fnlen+1,ii
622        if(line(ij:ij)/=' ')then
623          write(msg,'(3a,i0,3a,i0,3a)' ) &
624           'It is observed in the input file: ',TRIM(filnam),' line number ',iline,',',ch10,&
625           'that more than ',fnlen,' columns are used.',ch10,&
626           'This is not allowed. Change this line of your input file.'
627          ABI_ERROR(msg)
628        end if
629      end do
630    end if
631 
632    if (ii>0) then
633      ! Check for the occurence of a minus sign followed by a blank
634      ij=index(line(1:ii),'- ')
635      if (ij>0 .and. option==1) then
636        write(msg, '(3a,i0,11a)' ) &
637        'It is observed in the input file:, ',TRIM(filnam),' line number ',iline,',',ch10,&
638        'the occurence of a minus sign followed',ch10,&
639        'by a blank. This is forbidden.',ch10,&
640        'If the minus sign is meaningful, do not leave a blank',ch10,&
641        'between it and the number to which it applies.',ch10,&
642        'Otherwise, remove it.'
643        ABI_ERROR(msg)
644      end if
645      ! Check for the occurence of a tab
646      ij=index(line(1:ii),char(9))
647      if (ij>0 .and. option==1 ) then
648        write(msg, '(3a,i0,3a)' ) &
649         'The occurence of a tab, in the input file: ',TRIM(filnam),' line number ',iline,',',ch10,&
650         'is observed. This sign is confusing, and has been forbidden.'
651        ABI_ERROR(msg)
652      end if
653 
654      ! Check for the occurence of a include statement
655      include_found=.false.
656      if (option==1) then
657        ! Look for include statement
658        ii1=index(line(1:ii),"include");ii2=index(line(1:ii),"INCLUDE")
659        include_found=(ii1>0.or.ii2>0)
660        if (include_found) then
661          ij=max(ii1,ii2);ii1=0;ii2=0
662          ! Look for quotes (ascii 34)
663          ii1=index(line(ij+7:ii),char(34))
664          if (ii1>1) ii2=index(line(ij+7+ii1:ii),char(34))
665          ! Look for quotes (ascii 39)
666          if (ii1==0.and.ii2==0) then
667            ii1=index(line(ij+7:ii),char(39))
668            if (ii1>1) ii2=index(line(ij+7+ii1:ii),char(39))
669          end if
670          ! Check if quotes are correctly set
671          ex=(ii1<=1.or.ii2<=1)
672          if (.not.ex) then
673            msg=line(ij+7:ij+5+ii1)
674            call incomprs(msg(1:ii1-1),lenc)
675            ex=(len(trim(msg))/=0)
676          end if
677          if (ex) then
678            write(msg, '(6a)' ) &
679             'A "include" statement has been found in input file: ',TRIM(filnam),ch10,&
680             'but there must be a problem with the quotes.',ch10,&
681             'Action: change your input file.'
682            ABI_ERROR(msg)
683          end if
684          ! Store included file name
685          filnam_inc=line(ij+7+ii1:ij+5+ii1+ii2)
686          ! Extract include statement from line
687          lenc=ii1+ii2+7
688          msg(1:ii-lenc)=line(1:ij-1)//line(ij+lenc:ii)
689          ii=ii-lenc;line(1:ii)=msg(1:ii)
690        end if
691      end if
692 
693      ! Compress: remove repeated blanks, make all ASCII characters
694      ! less than a blank (and '=') to become a blank.
695      call incomprs(line(1:ii),lenc)
696 
697    else
698      ! ii=0 means line starts with #, is entirely a comment line
699      lenc=0;include_found=.false.
700    end if
701 
702    ! Check resulting total string length
703    if (lenstr+lenc>strln) then
704      write(msg, '(8a)' ) &
705       'The size of your input file: ',TRIM(filnam),' is such that the internal',ch10,&
706       'character string that should contain it is too small.',ch10,&
707       'Action: decrease the size of your input file,',ch10,&
708       'or contact the ABINIT group.'
709      ABI_ERROR(msg)
710    end if
711 
712    if (lenc>0) then
713      ! Concatenate new compressed characters
714      ! with previous part of compressed string (unless all blank)
715      string(lenstr+1:lenstr+lenc)=line(1:lenc)
716    end if
717    ! Keep track of total string length
718    lenstr=lenstr+lenc
719 
720    ! Eventually (recursively) read included file
721    if (include_found) then
722      ! Check file existence
723      inquire(file=filnam_inc ,iostat=iost,exist=ex)
724      if (.not. ex .or. iost /= 0) then
725        write(msg, '(5a)' ) &
726         'Input file: ',TRIM(filnam),' reading: the included file ',trim(filnam_inc),' cannot be found !'
727        ABI_ERROR(msg)
728      end if
729      ! Read included file (warning: recursive call !)
730      ABI_MALLOC(string_inc,)
731      ABI_MALLOC(raw_string_inc,)
732      call instrng(trim(filnam_inc),lenstr_inc,option,strln-lenstr,string_inc,raw_string_inc)
733      ! Check resulting total string length
734      if (lenstr+lenstr_inc>strln) then
735        write(msg, '(6a)' ) &
736         'The size of your input file: ',TRIM(filnam),' (including included files) is such that',ch10,&
737         'the internal character string that should contain it is too small !',ch10,&
738         'Action: decrease the size of your input file.'
739        ABI_ERROR(msg)
740      end if
741      ! Concatenate total string
742      string(lenstr+1:lenstr+lenstr_inc)=string_inc(1:lenstr_inc)
743      lenstr=lenstr+lenstr_inc
744      ABI_FREE(string_inc)
745      ABI_FREE(raw_string_inc)
746    end if
747 
748    ! If mline is reached, something is wrong
749    if (iline>=mline) then
750      write(msg, '(a,i0,2a,i0,4a)' ) &
751      'The number of lines already read from input file: ',iline,ch10,&
752      'is equal or greater than maximum allowed mline: ',mline,ch10,&
753      'Action: you could decrease the length of the input file, or',ch10,&
754      'increase mline in this routine.'
755      ABI_ERROR(msg)
756    end if
757 
758  end do !  End loop on iline. Note that there is an "exit" instruction in the loop
759 
760  nline1=iline-1
761  close (unit=input_unit)
762 
763  !write(std_out,'(a,a)')' incomprs : 1, string=',string(:lenstr)
764 
765 !Substitute environment variables, if any
766  b0=0
767  do
768    b0=b0+1
769    b1 = index(string(b0:lenstr), '$')
770    if(b1==0 .or. b1>=lenstr)exit
771    b1 = b0 + b1 - 1
772    !Identify delimiter, either a '"', or a "'", or a blank, or a /
773    b2=index(string(b1+1:lenstr),'"')
774    b3=index(string(b1+1:lenstr),"'")
775    if(b3/=0 .and. b3<b2)b2=b3
776    b3=index(string(b1+1:lenstr),' ')
777    if(b3/=0 .and. b3<b2)b2=b3
778    b3=index(string(b1+1:lenstr),'/')
779    if(b3/=0 .and. b3<b2)b2=b3
780    if(b2/=0)then
781      shell_var=string(b1+1:b1+b2-1)
782      !write(std_out,'(a,a)')' shell_var=',shell_var(:b2-1)
783      call get_environment_variable(shell_var(:b2-1),shell_value,status=ierr,length=len_val)
784      if (ierr == -1) ABI_ERROR(sjoin(shell_var(:b2-1), "is present but value of environment variable is too long"))
785      if (ierr == +1) ABI_ERROR(sjoin(shell_var(:b2-1), "environment variable is not defined!"))
786      if (ierr == +2) ABI_ERROR(sjoin(shell_var(:b2-1), "used in input file but processor does not support environment variables"))
787      call wrtout(std_out, sjoin(shell_var(:b2-1), " found in environment, with value ",shell_value(:len_val)))
788      string(1:lenstr-(b2-b1)+len_val)=string(1:b1-1)//shell_value(:len_val)//string(b1+b2:lenstr)
789      lenstr=lenstr-(b2-b1)+len_val
790    endif
791  enddo
792  !write(std_out,'(a)')string(:lenstr)
793 
794  ! Identify concatenate string '" // "' with an arbitrary number of blanks before and after the //
795  ! Actually, at this stage, there is no consecutive blanks left...
796  do
797    b1 = index(string(1:lenstr), '//')
798    if(b1/=0)then
799      !See whether there are preceeding and following '"'
800      do sign=-1,1,2
801        isign=(1+sign)/2  !  0 for minus sign, 1 for plus sign
802        do ii=1,lenstr
803          shift=-ii+isign*(1+2*ii)  !  -ii for minus sign,  1+ii for plus sign
804          if( (isign==0 .and. b1+shift<1) .or. (isign==1 .and. b1+shift>lenstr) )then
805            bs(isign+1)=0 ; exit
806          endif
807          if (string(b1+shift:b1+shift)=='"') then
808            bs(isign+1)=shift ; exit
809          else if (string(b1+shift:b1+shift)/=' ') then
810            bs(isign+1)=0 ; exit
811          endif
812        enddo
813        if(bs(isign+1)==0)exit
814      enddo
815      if(bs(1)==0 .or. bs(2)==0)exit
816      !the two shifts have been found, they give delimiters of the '" // "' chain
817      string(1:lenstr-4)=string(1:b1+bs(1)-1)//string(b1+bs(2)+1:lenstr)
818      lenstr=lenstr+bs(1)-1-bs(2)
819    else
820      exit
821    endif
822  enddo
823 
824  !write(std_out,'(a,a)')' incomprs : 2, string=',string(:lenstr)
825 
826  ! Make sure we don't have unmatched quotation marks
827  if (mod(char_count(string(:lenstr), '"'), 2) /= 0) then
828    ABI_ERROR('Your input file contains unmatched quotation marks `"`. This confuses the parser. Check your input.')
829  end if
830 
831  include_level = include_level - 1
832 
833  write(msg,'(a,i0,3a)')'-instrng: ',nline1,' lines of input have been read from file ',trim(filnam),ch10
834  call wrtout(std_out,msg)
835  !write(std_out, "(3a)")"string after instrng:", ch10, string(:lenstr)
836 
837  DBG_EXIT("COLL")
838 
839 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, nm or angstrom,
       and return in au -atomic units=bohr- )
   'ENE'=>real(dp) (expect a "energy", identify Ha, hartree, eV, Ry, meV, Rydberg, K, Kelvin)
   '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".
      The string must be large enough to contain the output. fnlen is OK in many cases
      except when reading a list of files. The routine aborts if key_value cannot store the output.
      Output string is left justified.

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

SOURCE

1105 subroutine intagm(dprarr,intarr,jdtset,marr,narr,string,token,tread,typevarphys,ds_input,key_value)
1106 
1107 !Arguments ------------------------------------
1108 !scalars
1109  integer,intent(in) :: jdtset,marr,narr
1110  integer,intent(out) :: tread
1111  integer,intent(out),optional :: ds_input
1112  character(len=*),intent(in) :: string
1113  character(len=*),intent(in) :: token
1114  character(len=*),intent(in) :: typevarphys
1115  character(len=*),optional,intent(out) :: key_value
1116 !arrays
1117  integer,intent(inout) :: intarr(marr)
1118  real(dp),intent(inout) :: dprarr(marr)
1119 
1120 !Local variables-------------------------------
1121  character(len=1), parameter :: blank=' '
1122 !scalars
1123  integer :: b1,b2,b3,cs1len,cslen,dozens,ier,itoken,itoken1,itoken2,itoken2_1colon
1124  integer :: itoken2_1plus,itoken2_1times,itoken2_2colon,itoken2_2plus
1125  integer :: itoken2_2times,itoken2_colon,itoken2_plus,itoken2_times
1126  integer :: itoken_1colon,itoken_1plus,itoken_1times,itoken_2colon,itoken_2plus
1127  integer :: itoken_2times,itoken_colon,itoken_plus,itoken_times,number,opttoken
1128  integer :: sum_token,toklen,trial_cslen,trial_jdtset,unities
1129  integer :: ds_input_
1130  character(len=4) :: appen
1131  character(len=3) :: typevar
1132  character(len=500) :: msg
1133  character(len=fnlen) :: cs,cs1,cs1colon,cs1plus,cs1times,cs2colon,cs2plus
1134  character(len=fnlen) :: cs2times,cscolon,csplus,cstimes,trial_cs
1135 !arrays
1136  integer,allocatable :: int1(:),int2(:)
1137  real(dp),allocatable :: dpr1(:),dpr2(:)
1138 
1139 ! *************************************************************************
1140 
1141  ABI_CHECK(marr >= narr, sjoin("marr", itoa(marr)," < narr ", itoa(narr), "for token:", token))
1142 
1143  ds_input_ = -1
1144  dozens=jdtset/10
1145  unities=jdtset-10*dozens
1146 
1147  if(jdtset<0)then
1148    write(msg,'(a,i0,a)')' jdtset: ',jdtset,', while it should be non-negative.'
1149    ABI_ERROR(msg)
1150  end if
1151 
1152  if(jdtset > 9999)then
1153    write(msg,'(a,i0,a)')' jdtset: ',jdtset,', while it must be lower than 10000.'
1154    ABI_ERROR(msg)
1155  end if
1156 
1157  ! Default values: nothing has been read
1158  itoken=0
1159  opttoken=0
1160  ! Initialise flags in case of opttoken >= 2 later.
1161  itoken_times=0
1162  itoken_plus=0
1163  itoken_colon=0
1164  cslen=1
1165 
1166  if (narr/=0) then
1167 
1168    toklen=len_trim(token)
1169 
1170    ! --------------------------------------------------------------------------
1171    ! (1) try to find the token with dataset number appended
1172    if (jdtset > 0) then
1173 
1174      call appdig(jdtset,'',appen)
1175      cs=blank//token(1:toklen)//trim(appen)//blank
1176      if(jdtset<10) then
1177        cslen=toklen+3
1178      else if(jdtset<100) then
1179        cslen=toklen+4
1180      else if(jdtset<1000) then
1181        cslen=toklen+5
1182      else if(jdtset<10000)then
1183        cslen=toklen+6
1184      end if
1185      ! Map token to all upper case (make case-insensitive):
1186      call inupper(cs)
1187      ! Absolute index of blank//token//blank in string:
1188      itoken=index(string,cs(1:cslen))
1189      ! Look for another occurence of the same token in string, if so, leaves:
1190      itoken2=index(string,cs(1:cslen), BACK=.true. )
1191      if(itoken/=itoken2)then
1192        write(msg, '(7a)' )&
1193        'There are two occurences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1194        'This is confusing, so it has been forbidden.',ch10,&
1195        'Action: remove one of the two occurences.'
1196        ABI_ERROR(msg)
1197      end if
1198 
1199      if(itoken/=0) then
1200        opttoken=1
1201        ds_input_=jdtset
1202      end if
1203    end if
1204 
1205    ! --------------------------------------------------------------------------
1206    ! (2a) try to find the token appended with a string that contains the metacharacter "?".
1207    if (jdtset>0 .and. opttoken==0)then
1208 
1209      ! Use the metacharacter for the dozens, and save in cs and itoken
1210      write(appen,'(i1)')unities
1211      cs=blank//token(1:toklen)//'?'//trim(appen)//blank
1212      cslen=toklen+4
1213      ! Map token to all upper case (make case-insensitive):
1214      call inupper(cs)
1215      ! Absolute index of blank//token//blank in string:
1216      itoken=index(string,cs(1:cslen))
1217      ! Look for another occurence of the same token in string, if so, leaves:
1218      itoken2=index(string,cs(1:cslen), BACK=.true. )
1219      if(itoken/=itoken2)then
1220        write(msg, '(7a)' )&
1221         'There are two occurences of the keyword: "',cs(1:cslen),'" in the input file.',ch10,&
1222         'This is confusing, so it has been forbidden.',ch10,&
1223         'Action: remove one of the two occurences.'
1224        ABI_ERROR(msg)
1225      end if
1226      if(itoken/=0) then
1227        opttoken=1
1228        ds_input_=jdtset
1229      end if
1230 
1231      ! Use the metacharacter for the units, and save in cs1 and itoken1
1232      write(appen,'(i1)')dozens
1233      cs1=blank//token(1:toklen)//trim(appen)//'?'//blank
1234      ! Map token to all upper case (make case-insensitive):
1235      call inupper(cs1)
1236      ! Absolute index of blank//token//blank in string:
1237      itoken1=index(string,cs1(1:cslen))
1238      ! Look for another occurence of the same token in string, if so, leaves:
1239      itoken2=index(string,cs1(1:cslen), BACK=.true. )
1240      if(itoken1/=itoken2)then
1241        write(msg, '(7a)' )&
1242        'There are two occurences of the keyword "',cs1(1:cslen),'" in the input file.',ch10,&
1243        'This is confusing, so it has been forbidden.',ch10,&
1244        'Action: remove one of the two occurences.'
1245        ABI_ERROR(msg)
1246      end if
1247 
1248      if(itoken/=0 .and. itoken1/=0)then
1249        write(msg, '(9a)' )&
1250        'The keywords: "',cs(1:cslen),'" and: "',cs1(1:cslen),'"',ch10,&
1251        'cannot be used together in the input file.',ch10,&
1252        'Action: remove one of the two keywords.'
1253        ABI_ERROR(msg)
1254      end if
1255 
1256      if(itoken1/=0)then
1257        opttoken=1
1258        itoken=itoken1
1259        cs=cs1
1260        ds_input_=jdtset
1261      end if
1262 
1263    end if
1264 
1265    ! --------------------------------------------------------------------------
1266    ! (2b) try to find the tokens defining a series
1267    if (opttoken==0) then
1268 
1269      cs=token(1:toklen)
1270 
1271      cslen=toklen+3
1272      cs1len=toklen+4
1273 
1274      cscolon=blank//token(1:toklen)//':'//blank
1275      csplus=blank//token(1:toklen)//'+'//blank
1276      cstimes=blank//token(1:toklen)//'*'//blank
1277 
1278      cs1colon=blank//token(1:toklen)//'?'//':'//blank
1279      cs1plus=blank//token(1:toklen)//'?'//'+'//blank
1280      cs1times=blank//token(1:toklen)//'?'//'*'//blank
1281 
1282      cs2colon=blank//token(1:toklen)//':'//'?'//blank
1283      cs2plus=blank//token(1:toklen)//'+'//'?'//blank
1284      cs2times=blank//token(1:toklen)//'*'//'?'//blank
1285 
1286      ! Map token to all upper case (make case-insensitive):
1287      call inupper(cscolon)
1288      call inupper(csplus)
1289      call inupper(cstimes)
1290      call inupper(cs1colon)
1291      call inupper(cs1plus)
1292      call inupper(cs1times)
1293      call inupper(cs2colon)
1294      call inupper(cs2plus)
1295      call inupper(cs2times)
1296 
1297      ! Absolute index of tokens in string:
1298      itoken_colon=index(string,cscolon(1:cslen))
1299      itoken_plus=index(string,csplus(1:cslen))
1300      itoken_times=index(string,cstimes(1:cslen))
1301      itoken_1colon=index(string,cs1colon(1:cs1len))
1302      itoken_1plus=index(string,cs1plus(1:cs1len))
1303      itoken_1times=index(string,cs1times(1:cs1len))
1304      itoken_2colon=index(string,cs2colon(1:cs1len))
1305      itoken_2plus=index(string,cs2plus(1:cs1len))
1306      itoken_2times=index(string,cs2times(1:cs1len))
1307 
1308      ! Look for another occurence of the same tokens in string
1309      itoken2_colon=index(string,cscolon(1:cslen), BACK=.true. )
1310      itoken2_plus=index(string,csplus(1:cslen), BACK=.true. )
1311      itoken2_times=index(string,cstimes(1:cslen), BACK=.true. )
1312      itoken2_1colon=index(string,cs1colon(1:cs1len), BACK=.true. )
1313      itoken2_1plus=index(string,cs1plus(1:cs1len), BACK=.true. )
1314      itoken2_1times=index(string,cs1times(1:cs1len), BACK=.true. )
1315      itoken2_2colon=index(string,cs2colon(1:cs1len), BACK=.true. )
1316      itoken2_2plus=index(string,cs2plus(1:cs1len), BACK=.true. )
1317      itoken2_2times=index(string,cs2times(1:cs1len), BACK=.true. )
1318 
1319      if(jdtset==0)then
1320 
1321        ! If the multi-dataset mode is not used, no token should have been found
1322        if(itoken_colon+itoken_plus+itoken_times+ itoken_2colon+itoken_2plus+itoken_2times > 0 ) then
1323          write(msg,'(a,a,a,a,a,a,a,a,a,a,a,a, a)' )&
1324          'Although the multi-dataset mode is not activated,',ch10,&
1325          'the keyword "',trim(cs),'" has been found',ch10,&
1326          'appended with  + * or :  .',ch10,&
1327          'This is not allowed.',ch10,&
1328          'Action: remove the appended keyword, or',ch10,&
1329          'use the multi-dataset mode (ndtset/=0).'
1330          ABI_ERROR(msg)
1331        end if
1332        if(itoken_1colon+itoken_1plus+itoken_1times > 0 ) then
1333          write(msg, '(a,a,a,a,a,a,a,a,a,a,a,a,a)' )&
1334          'Although the multi-dataset mode is not activated,',ch10,&
1335          'the keyword "',trim(cs),'" has been found',ch10,&
1336          'appended with ? , then + * or :  .',ch10,&
1337          'This is not allowed.',ch10,&
1338          'Action: remove the appended keyword, or',ch10,&
1339          'use the multi-dataset mode (ndtset/=0).'
1340          ABI_ERROR(msg)
1341        end if
1342 
1343      else
1344 
1345        ! If the multi-dataset mode is used, exactly zero or two token must be found
1346        sum_token=0
1347        if(itoken_colon/=0)sum_token=sum_token+1
1348        if(itoken_plus /=0)sum_token=sum_token+1
1349        if(itoken_times/=0)sum_token=sum_token+1
1350        if(itoken_1colon/=0)sum_token=sum_token+1
1351        if(itoken_1plus /=0)sum_token=sum_token+1
1352        if(itoken_1times/=0)sum_token=sum_token+1
1353        if(itoken_2colon/=0)sum_token=sum_token+1
1354        if(itoken_2plus /=0)sum_token=sum_token+1
1355        if(itoken_2times/=0)sum_token=sum_token+1
1356 
1357        if(sum_token/=0 .and. sum_token/=2) then
1358          write(msg, '(a,a,a,a,a,i0,a,a,a,a,a,a,a)' )&
1359          'The keyword "',trim(cs),'" has been found to take part',ch10,&
1360          'to series definition in the multi-dataset mode  ',sum_token,' times.',ch10,&
1361          'This is not allowed, since it should be used once with ":",',ch10,&
1362          'and once with "+" or "*".',ch10,&
1363          'Action: change the number of occurences of this keyword.'
1364          ABI_ERROR(msg)
1365        end if
1366 
1367        ! If the multi-dataset mode is used, make sure that no twice the same combined keyword happens
1368        ier=0
1369        if(itoken_colon/=itoken2_colon)then
1370          ier=1 ; cs=cscolon
1371        end if
1372        if(itoken_plus/=itoken2_plus)then
1373          ier=1 ; cs=csplus
1374        end if
1375        if(itoken_times/=itoken2_times)then
1376          ier=1 ; cs=cstimes
1377        end if
1378        if(itoken_1colon/=itoken2_1colon)then
1379          ier=1 ; cs=cs1colon
1380        end if
1381        if(itoken_1plus/=itoken2_1plus)then
1382          ier=1 ; cs=cs1plus
1383        end if
1384        if(itoken_1times/=itoken2_1times)then
1385          ier=1 ; cs=cs1times
1386        end if
1387        if(itoken_2colon/=itoken2_2colon)then
1388          ier=1 ; cs=cs2colon
1389        end if
1390        if(itoken_2plus/=itoken2_2plus)then
1391          ier=1 ; cs=cs2plus
1392        end if
1393        if(itoken_2times/=itoken2_2times)then
1394          ier=1 ; cs=cs2times
1395        end if
1396        if(ier==1)then
1397          write(msg, '(a,a,a,a,a,a,a)' )&
1398          'There are two occurences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1399          'This is confusing, so it has been forbidden.',ch10,&
1400          'Action: remove one of the two occurences.'
1401          ABI_ERROR(msg)
1402        end if
1403 
1404        ! Select the series according to the presence of a colon flag
1405        if(itoken_colon>0)then
1406          opttoken=2
1407          ds_input_=jdtset
1408        else if(itoken_1colon>0)then
1409          opttoken=3
1410          cscolon=cs1colon ; csplus=cs1plus ; cstimes=cs1times
1411          itoken_colon=itoken_1colon
1412          itoken_plus=itoken_1plus ; itoken_times=itoken_1times
1413          cslen=cs1len
1414          ds_input_=jdtset
1415        else if(itoken_2colon>0)then
1416          opttoken=4
1417          cscolon=cs2colon ; csplus=cs2plus ; cstimes=cs2times
1418          itoken_colon=itoken_2colon
1419          itoken_plus=itoken_2plus ; itoken_times=itoken_2times
1420          cslen=cs1len
1421          ds_input_=jdtset
1422        end if
1423 
1424        ! Make sure that the proper combination of : + and * is found .
1425        if(itoken_colon > 0 .and. (itoken_plus==0 .and. itoken_times==0) )then
1426          write(msg, '(13a)' )&
1427          'The keyword "',cscolon(1:cslen),'" initiate a series,',ch10,&
1428          'but there is no occurence of "',csplus(1:cslen),'" or "',cstimes(1:cslen),'".',ch10,&
1429          'Action: either suppress the series, or make the increment',ch10,&
1430          'or the factor available.'
1431          ABI_ERROR(msg)
1432        end if
1433        if(itoken_plus/=0 .and. itoken_times/=0)then
1434          write(msg, '(a,a, a,a,a,a,a)' )&
1435          'The combined occurence of keywords "',csplus(1:cslen),'" and "',cstimes(1:cslen),'" is not allowed.',ch10,&
1436          'Action: suppress one of them in your input file.'
1437          ABI_ERROR(msg)
1438        end if
1439        if(itoken_colon==0 .and. (itoken_plus/=0 .or. itoken_times/=0) ) then
1440          cs=csplus
1441          if(itoken_times/=0)cs=cstimes
1442          write(msg, '(a,a,a,a,a,a,a,a,a,a,a)' )&
1443          'The keyword "',cscolon(1:cslen),'" does not appear in the input file.',ch10,&
1444          'However, the keyword "',cs(1:cslen),'" appears.',ch10,&
1445          'This is forbidden.',ch10,&
1446          'Action: make the first appear, or suppress the second.'
1447          ABI_ERROR(msg)
1448        end if
1449 
1450        ! At this stage, either
1451        !    - itoken_colon vanish as well as itoken_plus and itoken_times
1452        !    - itoken_colon does not vanish,
1453        ! as well as one of itoken_plus or itoken_times
1454 
1455      end if ! End the condition of multi-dataset mode
1456    end if ! End the check on existence of a series
1457 
1458    ! --------------------------------------------------------------------------
1459    ! (3) if not found, try to find the token with non-modified string
1460    if (opttoken==0) then
1461 
1462      cs=blank//token(1:toklen)//blank
1463      cslen=toklen+2
1464 
1465      ! Map token to all upper case (make case-insensitive):
1466      call inupper(cs)
1467 
1468      ! Absolute index of blank//token//blank in string:
1469      itoken=index(string,cs(1:cslen))
1470 
1471      ! Look for another occurence of the same token in string, if so, leaves:
1472      itoken2=index(string,cs(1:cslen), BACK=.true. )
1473      if (itoken/=itoken2) then
1474        write(msg, '(a,a,a,a,a,a,a)' )&
1475        'There are two occurences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1476        'This is confusing, so it has been forbidden.',ch10,&
1477        'Action: remove one of the two occurences.'
1478        ABI_ERROR(msg)
1479      end if
1480 
1481      if(itoken/=0) then
1482        opttoken=1
1483        ds_input_=0
1484      end if
1485 
1486    end if
1487 
1488    ! --------------------------------------------------------------------------
1489    ! If jdtset==0, means that the multi-dataset mode is not used, so
1490    ! checks whether the input file contains a multi-dataset keyword,
1491    ! and if this occurs, stop. Check also the forbidden occurence of
1492    ! use of 0 as a multi-dataset index.
1493    ! Note that the occurence of series initiators has already been checked.
1494 
1495    do trial_jdtset=0,9
1496      if(jdtset==0 .or. trial_jdtset==0)then
1497        write(appen,'(i1)')trial_jdtset
1498        trial_cs=blank//token(1:toklen)//trim(appen)
1499        trial_cslen=toklen+2
1500        ! Map token to all upper case (make case-insensitive):
1501        call inupper(trial_cs)
1502        ! Look for an occurence of this token in string, if so, leaves:
1503        itoken2=index(string,trial_cs(1:trial_cslen))
1504        if(itoken2/=0)then
1505          if(trial_jdtset==0)then
1506            write(msg, '(7a)' )&
1507            'There is an occurence of the keyword "',trim(token),'" appended with 0 in the input file.',ch10,&
1508            'This is forbidden.',ch10,&
1509            'Action: remove this occurence.'
1510          else
1511            write(msg, '(5a,i0,5a)' )&
1512            'In the input file, there is an occurence of the ',ch10,&
1513            'keyword "',trim(token),'", appended with the digit "',trial_jdtset,'".',ch10,&
1514            'This is forbidden when ndtset = =0 .',ch10,&
1515            'Action: remove this occurence, or change ndtset.'
1516          end if
1517          ABI_ERROR(msg)
1518        end if
1519      end if
1520    end do
1521 
1522  end if
1523 
1524  !===========================================================================
1525  ! At this stage, the location of the keyword string is known, as well
1526  ! as its length. So, can read the data.
1527  ! Usual reading if opttoken==1 (need itoken).
1528  ! If opttoken>=2, the characteristics of a series must be read
1529  ! (need itoken_colon and either itoken_plus or itoken_times)
1530 
1531  tread = 0
1532  typevar='INT'
1533 
1534  if(typevarphys=='LOG')typevar='INT'
1535  if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. &
1536     typevarphys=='BFI' .or. typevarphys=='TIM') typevar='DPR'
1537 
1538  if (typevarphys=='KEY') then
1539    ! Consistency check for keyword (no multidataset, no series)
1540    if (opttoken>=2) then
1541      write(msg, '(9a)' )&
1542        'For the keyword "',cs(1:cslen),'", of KEY type,',ch10,&
1543        'a series has been defined in the input file.',ch10,&
1544        'This is forbidden.',ch10,'Action: check your input file.'
1545      ABI_ERROR(msg)
1546    end if
1547    if (narr>=2) then
1548      write(msg, '(9a)' )&
1549        'For the keyword "',cs(1:cslen),'", of KEY type,',ch10,&
1550        'the number of data requested is larger than 1.',ch10,&
1551        'This is forbidden.',ch10,'Action: check your input file.'
1552      ABI_ERROR(msg)
1553    end if
1554  end if
1555 
1556  ! There is something to be read if opttoken>=1
1557  if (opttoken==1) then
1558 
1559    ! write(std_out,*)' intagm : opttoken==1 , token has been found, will read '
1560    ! Absolute location in string of blank which follows token:
1561    b1 = itoken + cslen - 1
1562 
1563    if (typevarphys == 'KEY') then
1564      ! In case of typevarphys='KEY', the chain of character will be returned in cs.
1565      ABI_CHECK(present(key_value), "typevarphys == KEY requires optional argument key_value")
1566      b2 = index(string(b1+1:), '"')
1567      ABI_CHECK(b2 /= 0, sjoin('Cannot find first " defining string for token:', token))
1568      b2 = b1 + b2 + 1
1569      b3 = index(string(b2:), '"')
1570      ABI_CHECK(b3 /= 0, sjoin('Cannot find second " defining string for token:', token))
1571      b3 = b3 + b2 - 2
1572      if ((b3 - b2 + 1) > len(key_value)) then
1573        ABI_ERROR("Len of key_value too small to contain value parsed from file")
1574      end if
1575      key_value = adjustl(string(b2:b3))
1576 
1577    else
1578      ! Read the array (or eventual scalar) that follows the blank
1579      call inarray(b1,cs,dprarr,intarr,marr,narr,string,typevarphys)
1580    end if
1581 
1582    ! if this point is reached then data has been read in successfully
1583    tread = 1
1584 
1585  else if(opttoken>=2) then
1586 
1587    ! write(std_out,*)' intagm : opttoken>=2 , token has been found, will read '
1588    ABI_MALLOC(dpr1,(narr))
1589    ABI_MALLOC(dpr2,(narr))
1590    ABI_MALLOC(int1,(narr))
1591    ABI_MALLOC(int2,(narr))
1592 
1593    ! Absolute location in string of blank which follows token//':':
1594    b1=itoken_colon+cslen-1
1595    call inarray(b1,cscolon,dpr1,int1,narr,narr,string,typevarphys)
1596 
1597    ! Initialise number even if the if series treat all cases.
1598    number=1
1599    ! Define the number of the term in the series
1600    if(opttoken==2)number=jdtset-1
1601    if(opttoken==3)number=unities-1
1602    if(opttoken==4)number=dozens-1
1603 
1604    ! Distinguish additive and multiplicative series
1605    if(itoken_plus/=0)then
1606 
1607      b1=itoken_plus+cslen-1
1608      call inarray(b1,csplus,dpr2,int2,narr,narr,string,typevarphys)
1609 
1610      if(typevar=='INT')then
1611        intarr(1:narr)=int1(:)+int2(:)*number
1612      else if(typevar=='DPR')then
1613        dprarr(1:narr)=dpr1(:)+dpr2(:)*number
1614      end if
1615 
1616    else if(itoken_times/=0)then
1617 
1618      b1=itoken_times+cslen-1
1619      call inarray(b1,cstimes,dpr2,int2,narr,narr,string,typevarphys)
1620      if(typevar=='INT')then
1621        intarr(1:narr)=int1(:)*int2(:)**number
1622      else if(typevar=='DPR')then
1623        dprarr(1:narr)=dpr1(:)*dpr2(:)**number
1624      end if
1625 
1626    end if
1627 
1628    tread = 1
1629 
1630    ABI_FREE(dpr1)
1631    ABI_FREE(dpr2)
1632    ABI_FREE(int1)
1633    ABI_FREE(int2)
1634  end if
1635 
1636  if(present(ds_input)) ds_input = ds_input_
1637 
1638  !write(std_out,*) ' intagm : exit value tread=',tread
1639  !write(std_out,*) ' intarr =',intarr(1:narr)
1640  !write(std_out,*) ' dprarr =',dprarr(1:narr)
1641 
1642 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.

SOURCE

211 subroutine parsefile(filnamin, lenstr, ndtset, string, comm)
212 
213 !Arguments ------------------------------------
214  character(len=*),intent(in) :: filnamin
215  integer,intent(in) :: comm
216  integer,intent(out) :: ndtset,lenstr
217  character(len=strlen),intent(out) :: string
218 
219 !Local variables-------------------------------
220 !scalars
221  integer,parameter :: master=0, option1= 1
222  integer :: marr,tread,lenstr_noxyz,ierr
223  character(len=strlen) :: string_raw, string_with_comments
224  character(len=500) :: msg
225 !arrays
226  integer :: intarr(1)
227  real(dp) :: dprarr(1)
228 
229 ! *************************************************************************
230 
231  ! Read the input file, and store the information in a long string of characters
232  ! Note: this is done only by me=0, and then string and other output vars are BCASTED
233 
234  if (xmpi_comm_rank(comm) == master) then
235 
236    ! strlen from defs_basis module
237    call instrng(filnamin, lenstr, option1, strlen, string, string_with_comments)
238 
239    ! Copy original file, without change of case
240    string_raw=string
241 
242    ! To make case-insensitive, map characters of string to upper case.
243    call inupper(string(1:lenstr))
244 
245    ! Might import data from xyz file(s) into string
246    ! Need string_raw to deal properly with xyz filenames
247    ! TODO: This capabilty can now be implemented via the structure:"xyx:path" variable
248    lenstr_noxyz = lenstr
249    call importxyz(lenstr,string_raw,string,strlen)
250 
251    ! Make sure we don't have unmatched quotation marks
252    if (mod(char_count(string(:lenstr), '"'), 2) /= 0) then
253      ABI_ERROR('Your input file contains unmatched quotation marks `"`. This confuses the parser. Check your input.')
254    end if
255 
256    ! Take ndtset from the input string
257    ndtset=0; marr=1
258    call intagm(dprarr,intarr,0,marr,1,string(1:lenstr),"ndtset",tread,'INT')
259    if (tread==1) ndtset=intarr(1)
260    ! Check that ndtset is within bounds
261    if (ndtset<0 .or. ndtset>9999) then
262      write(msg, '(a,i0,4a)' )&
263      'Input ndtset must be non-negative and < 10000, but was ',ndtset,ch10,&
264      'This is not allowed.',ch10,'Action: modify ndtset in the input file.'
265      ABI_ERROR(msg)
266    end if
267  end if ! master
268 
269  if (xmpi_comm_size(comm) > 1) then
270    ! Broadcast data.
271    call xmpi_bcast(lenstr, master, comm, ierr)
272    call xmpi_bcast(ndtset, master, comm, ierr)
273    call xmpi_bcast(string, master, comm, ierr)
274    call xmpi_bcast(string_raw, master, comm, ierr)
275  end if
276 
277  ! Save input string in global variable so that we can access it in ntck_open_create
278  ! XG20200720: Why not saving string ? string_raw is less processed than string ...
279  ! MG: Because we don't want a processed string without comments.
280  ! Abipy may use the commented section to extract additional metadata e.g. the pseudos md5
281  INPUT_STRING = string_with_comments
282 
283  !write(std_out,'(a)')string(:lenstr)
284 
285 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', 'TIM' 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)
   'TIM'=>real(dp) (output in second)
  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)

SOURCE

3146 subroutine prttagm(dprarr,intarr,iout,jdtset_,length,&
3147                     marr,narr,narrm,ncid,ndtset_alloc,token,typevarphys,use_narrm,&
3148                     firstchar,forceprint)  ! optional
3149 
3150 !Arguments ------------------------------------
3151 !scalars
3152  integer,intent(in) :: iout,length,marr,narr,ndtset_alloc,ncid,use_narrm
3153  integer,intent(in),optional :: forceprint
3154  character(len=*),intent(in) :: token
3155  character(len=3),intent(in) :: typevarphys
3156  character(len=1),intent(in),optional :: firstchar
3157 !arrays
3158  integer,intent(in) :: intarr(marr,0:ndtset_alloc)
3159  integer,intent(in) :: jdtset_(0:ndtset_alloc)
3160  integer,intent(in) :: narrm(0:ndtset_alloc)
3161  real(dp),intent(in) :: dprarr(marr,0:ndtset_alloc)
3162 
3163 !Local variables-------------------------------
3164 !character(len=*), parameter :: long_beg     ='(a,a16,a,1x,(t22,'
3165  character(len=*), parameter :: format_1     ='",a16,a,t22,'
3166  character(len=*), parameter :: format_2     ='",t22,'
3167  character(len=*), parameter :: short_int    ='10i5)'
3168  character(len=*), parameter :: long_int     ='8i8)'
3169  character(len=*), parameter :: veryshort_dpr='f11.5)'
3170  character(len=*), parameter :: short_dpr    ='es16.8)'
3171  character(len=*), parameter :: long_dpr     ='es18.10)'
3172  character(len=*), parameter :: veryshort_dim='f11.5),a'
3173  character(len=*), parameter :: short_dim    ='es16.8),a'
3174  character(len=*), parameter :: long_dim     ='es18.10),a'
3175  character(len=*), parameter :: f_symrel     ='3(3i3,1x),4x,3(3i3,1x))'
3176  character(len=*), parameter :: f_type       ='20i3)'
3177  character(len=*), parameter :: f_mem        ='8i8)'
3178  character(len=*), parameter :: f_tnons      ='3f11.7,3x,3f11.7)'
3179  character(len=*), parameter :: f_wtk        ='6f11.5)'
3180  character(len=*), parameter :: f_atvshift   ='5f11.5)'
3181  character(len=*), parameter :: f_kptrlatt   ='3(3i5,2x))'
3182 !scalars
3183  integer :: iarr,idtset,jdtset,multi,ndtset_eff,narr_eff
3184  logical :: print_netcdf,print_out
3185  real(dp),parameter :: tol21=1.0d-21
3186  real(dp) :: diff,scale_factor,sumtol
3187  character(len=4) :: digit
3188  character(len=1) :: first_column
3189  character(len=4) :: appen
3190  character(len=8) :: out_unit
3191  character(len=50) :: format_dp,format_int,full_format
3192  character(len=500) :: msg
3193 
3194 ! *************************************************************************
3195 
3196 !###########################################################
3197 !### 01. Check consistency of input
3198 
3199  if(len_trim(token)>16)then
3200    write(msg, '(3a,i0,2a)' )&
3201    'The length of the name of the input variable ',trim(token),' is ',len_trim(token),ch10,&
3202    'This exceeds 16 characters, the present maximum in routine prttagm.'
3203    ABI_ERROR(msg)
3204  end if
3205 
3206  if(ndtset_alloc<1)then
3207    write(msg, '(a,i0,a,a,a,a,a)' )&
3208    'ndtset_alloc=',ndtset_alloc,', while it should be >= 1.',ch10,&
3209    'This happened for token=',token,'.'
3210    ABI_BUG(msg)
3211  end if
3212 
3213  if(ndtset_alloc>9999)then
3214    write(msg, '(a,i0,a,a,a,a,a)' )&
3215    'ndtset_alloc=',ndtset_alloc,', while it must be lower than 10000.',ch10,&
3216    'This happened for token=',token,'.'
3217    ABI_BUG(msg)
3218  end if
3219 
3220  if(narr>99 .and. (typevarphys=='ENE'.or.typevarphys=='LEN'))then
3221    write(msg, '(3a,i0,a)' )' typevarphys=',typevarphys,' with narr=',narr,'  is not allowed.'
3222    ABI_BUG(msg)
3223  end if
3224 
3225  if ((narr>0).or.(use_narrm/=0)) then
3226 
3227    print_out=.true.;print_netcdf=.true.
3228    multi=0
3229 
3230 !  ###########################################################
3231 !  ### 02. Treatment of integer 'INT'
3232 
3233    if(typevarphys=='INT')then
3234 
3235 !    Determine whether the different non-default occurences are all equal
3236 
3237      if (use_narrm==0) then ! use of scalar 'narr' instead of array 'narrm'
3238        if(ndtset_alloc>1)then
3239          do idtset=1,ndtset_alloc
3240            do iarr=1,narr
3241              if(intarr(iarr,1)/=intarr(iarr,idtset))multi=1
3242            end do
3243          end do
3244        end if
3245      else
3246 !      If the sizes of the arrays are different we can not compare them
3247 !      So we have to assume they are different
3248        multi=1
3249      end if
3250 
3251 !    If they are all equal, then determine whether they are equal to the default
3252      if(multi==0)then
3253        print_out=.false.
3254        do iarr=1,narr
3255          if (intarr(iarr,1)/=intarr(iarr,0)) print_out=.true.
3256        end do
3257        print_netcdf=print_out
3258      end if
3259 
3260      if (present(forceprint)) then
3261        if (forceprint==1.or.forceprint==3) print_out=.true.
3262        if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3263      end if
3264 
3265 !    Print only if the values differ from the default
3266      if (print_out.or.print_netcdf.or.(ncid<0))then
3267        ndtset_eff=ndtset_alloc
3268        if((multi==0).or.(ncid<0)) ndtset_eff=1
3269        do idtset=1,ndtset_eff
3270 
3271 !        Initialize the character in the first column
3272          first_column=' ';if (present(firstchar)) first_column=firstchar
3273          if(abs(length)==5)first_column='P'
3274 !        Initialize the format
3275          if(abs(length)==1)format_int=trim(short_int)
3276          if(abs(length)==2)format_int=trim(long_int)
3277          if(abs(length)==3)format_int=trim(f_symrel)
3278          if(abs(length)==4)format_int=trim(f_type)
3279          if(abs(length)==5)format_int=trim(f_mem)
3280          if(abs(length)==6)format_int=trim(f_kptrlatt)
3281 !        Initialize the dataset number string, and print
3282          if((multi==0).or.(ncid<0))then
3283            appen=' '
3284          else
3285            jdtset=jdtset_(idtset)
3286            call appdig(jdtset,'',appen)
3287          end if
3288 !        full_format=trim(long_beg)//trim(format_int)
3289          full_format='("'//first_column//trim(format_1)//'("'// first_column//trim(format_2)//trim(format_int)//")"
3290 
3291 !        narr_eff could be narr or narrm(idtset)
3292 !        It depends if the size is variable for different datasets
3293          if (use_narrm==0)then
3294            narr_eff=narr
3295          else
3296            narr_eff=narrm(idtset)
3297          end if
3298 
3299          if (narr_eff/=0) then
3300 
3301            if (print_out) write(iout,full_format) token,trim(appen),intarr(1:narr_eff,idtset)
3302 #ifdef HAVE_NETCDF
3303            if (print_netcdf) then
3304              call write_var_netcdf(intarr(1:narr_eff,idtset),&
3305 &             dprarr(1:narr_eff,idtset),marr,narr_eff,abs(ncid),typevarphys,token//appen)
3306            end if
3307 #endif
3308          end if
3309 
3310        end do
3311      end if !(print==1)
3312 
3313 !    ###########################################################
3314 !    ### 03. Treatment of real 'DPR', 'LEN', 'ENE', 'BFI', 'TIM'
3315 
3316    else if (typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI' .or. typevarphys=='TIM') then
3317 
3318      if((ndtset_alloc>1).and.(use_narrm==0))then
3319        do idtset=1,ndtset_alloc
3320          do iarr=1,narr
3321 !          The determination of effective equality is more difficult than in the
3322 !          integer case :
3323 !          - if length > 0, ask for a relative accuracy, and also include
3324 !          the case of zero values, thanks to tol21.
3325 !          - if length < 0, ask for absolute accuracy.
3326            diff=abs( dprarr(iarr,1)-dprarr(iarr,idtset) )
3327            if(length>0)then
3328              sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,idtset))+10*tol21
3329              if(diff>sumtol*tol11)multi=1
3330            else
3331              if(diff>tol14)multi=1
3332            end if
3333          end do
3334        end do
3335      elseif (use_narrm/=0) then
3336        multi=1 ! Assume that values could not be compared between different datasets.
3337 !      Nevertheless, checks whether not all dataset might be equal to the default, despite varying dimensions (e.g. all zeroes)
3338        print_out=.false.
3339        do idtset=1,ndtset_alloc
3340          if(narrm(idtset)>narrm(0))then
3341            print_out=.true.
3342          else
3343            do iarr=1,narrm(idtset)
3344              diff=abs( dprarr(iarr,idtset)-dprarr(iarr,0) )
3345              if(length>0)then
3346                sumtol=abs(dprarr(iarr,idtset))+abs(dprarr(iarr,0))+10*tol21
3347                if(diff>sumtol*tol11)print_out=.true.
3348              else
3349                if(diff>tol14)print_out=.true.
3350              end if
3351            end do
3352          end if
3353        end do
3354        print_netcdf=print_out
3355      end if
3356 
3357      if(multi==0)then
3358        print_out=.false.
3359        do iarr=1,narr
3360          diff=abs( dprarr(iarr,1)-dprarr(iarr,0) )
3361          if(length>0)then
3362            sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,0))+10*tol21
3363            if(diff>sumtol*tol11)print_out=.true.
3364          else
3365            if(diff>tol14)print_out=.true.
3366          end if
3367        end do
3368        print_netcdf=print_out
3369      end if
3370 
3371      if (present(forceprint)) then
3372        if (forceprint==1.or.forceprint==3) print_out=.true.
3373        if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3374      end if
3375 
3376      if(print_out.or.print_netcdf.or.(ncid<0))then
3377 !      Select the proper format
3378        ndtset_eff=ndtset_alloc
3379        if((multi==0).or.(ncid<0))ndtset_eff=1
3380        narr_eff=narr
3381        if(use_narrm/=0)then
3382          narr_eff=maxval(narrm(1:ndtset_eff))
3383        end if
3384        if(abs(length)==1 .or. abs(length)==2 .or. abs(length)==6)then
3385          if(typevarphys=='DPR')then
3386            digit='3'
3387            if(abs(length)==1)format_dp=digit//short_dpr
3388            if(abs(length)==2)format_dp=digit//long_dpr
3389            if(abs(length)==6)format_dp=digit//veryshort_dpr
3390    else if(typevarphys=='ENE' .or. typevarphys=='LEN' .or. typevarphys=='BFI' .or. typevarphys=='TIM')then
3391            if (narr<10) write(digit,'(i1)')narr_eff
3392            if (narr> 9) write(digit,'(i2)')narr_eff
3393            if(abs(length)==1)format_dp=digit//short_dim
3394            if(abs(length)==2)format_dp=digit//long_dim
3395            if(abs(length)==6)format_dp=digit//veryshort_dim
3396          end if
3397        else
3398          if(abs(length)==3)format_dp=f_tnons
3399          if(abs(length)==4)format_dp=f_wtk
3400          if(abs(length)==5)format_dp=f_atvshift
3401        end if
3402        do idtset=1,ndtset_eff
3403 
3404 !        narr_eff could be narr or narrm(idtset)
3405 !        It depends if the size is variable for different datasets
3406          if (use_narrm==0)then
3407            narr_eff=narr
3408          else
3409            narr_eff=narrm(idtset)
3410          end if
3411 
3412          if (narr_eff/=0) then
3413 
3414 !          Initialize the character in the first column
3415            first_column=' ';if (present(firstchar)) first_column=firstchar
3416 !          Define scale_factor
3417            scale_factor=one !EB to what this is still usefull ???
3418 !          EB remove           if(typevarphys=='BFI')scale_factor=one/BField_Tesla
3419 !          Define out_unit
3420            if(typevarphys=='ENE')out_unit=' Hartree'
3421            if(typevarphys=='LEN')out_unit=' Bohr   '
3422            if(typevarphys=='BFI')out_unit='   ' !EB remove Tesla unit
3423            if(typevarphys=='TIM')out_unit=' Second'
3424 !          Format, according to the length of the dataset string
3425            if((multi==0).or.(ncid<0))then
3426              appen=' '
3427            else
3428              jdtset=jdtset_(idtset)
3429              call appdig(jdtset,'',appen)
3430            end if
3431            ! full_format=trim(long_beg)//trim(format_dp)
3432            full_format='("'//first_column//trim(format_1)//'("'// first_column//trim(format_2)//trim(format_dp)//")"
3433            ! write(ab_out,*)' trim(long_beg)=',trim(long_beg)
3434            ! write(ab_out,*)' trim(format_dp)=',trim(format_dp)
3435            ! write(ab_out,*)' trim(full_format)=',trim(full_format)
3436            if(typevarphys=='DPR')then
3437              if (print_out) write(iout,full_format) token,trim(appen),dprarr(1:narr_eff,idtset)*scale_factor
3438            else
3439              if (print_out) write(iout,full_format) token,trim(appen),dprarr(1:narr_eff,idtset)*scale_factor,trim(out_unit)
3440            end if
3441 #ifdef HAVE_NETCDF
3442            if (print_netcdf) then
3443              call write_var_netcdf(intarr(1:narr_eff,idtset),dprarr(1:narr_eff,idtset),&
3444                marr,narr_eff,abs(ncid),'DPR',token//trim(appen))
3445            end if
3446 #endif
3447 
3448          end if
3449 
3450        end do
3451      end if
3452 
3453 !    ###########################################################
3454 !    ### 04. The type is neither 'INT' nor 'DPR','ENE','LEN','BFI','TIM'
3455    else
3456      ABI_BUG('Disallowed typevarphys = '//TRIM(typevarphys))
3457    end if
3458 
3459  end if ! End condition of narr>0
3460 
3461 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)

SOURCE

3484 subroutine prttagm_images(dprarr_images,iout,jdtset_,length,&
3485 & marr,narrm,ncid,ndtset_alloc,token,typevarphys,&
3486 & mxnimage,nimagem,ndtset,prtimg,strimg,firstchar,forceprint)
3487 
3488 !Arguments ------------------------------------
3489 !scalars
3490  integer,intent(in) :: iout,length,marr,ndtset_alloc,ncid
3491  integer,intent(in) :: mxnimage,ndtset
3492  integer,intent(in),optional :: forceprint
3493  character(len=*),intent(in) :: token
3494  character(len=3),intent(in) :: typevarphys
3495  character(len=1),intent(in),optional :: firstchar
3496 !arrays
3497  integer,intent(in) :: prtimg(mxnimage,0:ndtset_alloc)
3498  integer,intent(in) :: jdtset_(0:ndtset_alloc)
3499  integer,intent(in) :: nimagem(0:ndtset_alloc)
3500  character(len=8),intent(in) :: strimg(mxnimage)
3501  integer,intent(in) :: narrm(0:ndtset_alloc)
3502  real(dp),intent(in) :: dprarr_images(marr,mxnimage,0:ndtset_alloc)
3503 
3504 !Local variables-------------------------------
3505  integer :: iarr,idtset,iimage,jdtset,multi_narr,narr
3506  integer :: intarr_images(marr,mxnimage,0:ndtset_alloc)
3507  integer,allocatable :: intarr(:,:)
3508  real(dp), allocatable :: dprarr(:,:)
3509  logical :: print_out,print_netcdf,test_multiimages
3510  character(len=1) :: first_column
3511  character(len=4) :: appen
3512  character(len=16) :: keywd
3513  character(len=50) :: full_format
3514  character(len=*), parameter :: format_1  ='",a16,t22,'
3515  character(len=*), parameter :: format_1a ='",a16,a,t22,'
3516  character(len=*), parameter :: format_2  ='",t22,'
3517  character(len=*), parameter :: long_dpr  ='3es18.10)'
3518 
3519 ! *************************************************************************
3520 
3521 !Test whether for this variable, the content of different images differ.
3522 !test_multiimages=.false. if, for all datasets, the content is identical.
3523  test_multiimages=.false.
3524  do idtset=1,ndtset_alloc
3525    if(nimagem(idtset)>1)then
3526      do iarr=1,narrm(idtset)
3527        if(sum(abs( dprarr_images(iarr,2:nimagem(idtset),idtset)- &
3528 &       dprarr_images(iarr,1              ,idtset)))>tol12)then
3529          test_multiimages=.true.
3530        end if
3531      end do
3532    end if
3533  end do
3534 
3535  if(nimagem(0)==0)test_multiimages=.true.
3536 
3537 !If there is no differences between images, one is back to the usual prttagm routine.
3538 !Note the treatment of firstchar and forceprint has to be transmitted to prttagm.
3539  if(.not.test_multiimages)then
3540 
3541    narr=narrm(1)
3542    ABI_MALLOC(intarr,(marr,0:ndtset_alloc))
3543    ABI_MALLOC(dprarr,(marr,0:ndtset_alloc))
3544    dprarr=zero
3545    do idtset=0,ndtset_alloc
3546      dprarr(1:narrm(idtset),idtset)=dprarr_images(1:narrm(idtset),1,idtset)
3547    end do
3548    multi_narr=0
3549    if(ndtset_alloc>1)then
3550      do idtset=1,ndtset_alloc
3551        if(narrm(1)/=narrm(idtset))multi_narr=1
3552      end do
3553    end if
3554    if (present(firstchar).and.present(forceprint)) then
3555      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3556        narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3557        firstchar=firstchar,forceprint=forceprint)
3558    else if (present(firstchar)) then
3559      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3560        narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3561        firstchar=firstchar)
3562    else if (present(forceprint)) then
3563      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3564        narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3565        forceprint=forceprint)
3566    else
3567      call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3568        narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr)
3569    end if
3570    ABI_FREE(intarr)
3571    ABI_FREE(dprarr)
3572 
3573  else
3574 
3575    first_column=' ';if (present(firstchar)) first_column=firstchar
3576 
3577    do idtset=1,ndtset_alloc
3578 
3579      if (narrm(idtset)>0)then
3580        do iimage=1,nimagem(idtset)
3581 
3582          print_out=.true.
3583          if (prtimg(iimage,idtset)==0) print_out=.false.
3584          if (nimagem(0)>=nimagem(idtset)) then
3585            if (sum(abs(dprarr_images(1:narrm(idtset),iimage,idtset) &
3586 &           -dprarr_images(1:narrm(idtset),iimage,0)))<tol12) print_out=.false.
3587          end if
3588          print_netcdf=print_out
3589 
3590          if (present(forceprint)) then
3591            if (forceprint==1.or.forceprint==3) print_out=.true.
3592            if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3593          end if
3594 
3595          if (print_out.or.print_netcdf.or.(ncid<0))then
3596            keywd=token//trim(strimg(iimage))
3597 
3598            if(ndtset>0)then
3599              jdtset=jdtset_(idtset)
3600              call appdig(jdtset,'',appen)
3601              if (print_out) then
3602                full_format='("'//first_column//trim(format_1a)//'("'// &
3603 &               first_column//trim(format_2)//trim(long_dpr)//")"
3604                write(iout,full_format) &
3605 &               trim(keywd),appen,dprarr_images(1:narrm(idtset),iimage,idtset)
3606              end if
3607 #ifdef HAVE_NETCDF
3608              if (print_netcdf) then
3609                call write_var_netcdf(intarr_images(1:narrm(idtset),iimage,idtset),&
3610 &               dprarr_images(1:narrm(idtset),iimage,idtset),&
3611 &               marr,narrm(idtset),ncid,'DPR',trim(keywd)//appen)
3612              end if
3613 #endif
3614            else
3615 
3616              if (print_out) then
3617                full_format='("'//first_column//trim(format_1)//'("'// &
3618 &               first_column//trim(format_2)//trim(long_dpr)//")"
3619                write(iout,full_format) &
3620 &               trim(keywd),dprarr_images(1:narrm(idtset),iimage,idtset)
3621              end if
3622 #ifdef HAVE_NETCDF
3623              if (print_netcdf) then
3624                call write_var_netcdf(intarr_images(1:narrm(idtset),iimage,idtset),&
3625 &               dprarr_images(1:narrm(idtset),iimage,idtset),&
3626 &               marr,narrm(idtset),abs(ncid),'DPR',trim(keywd))
3627              end if
3628 #endif
3629 
3630            end if
3631          end if
3632        end do
3633      end if
3634    end do
3635 
3636  end if
3637 
3638 end subroutine prttagm_images