Branch data Line data Source code
1 : : !!****m* ABINIT/m_parser
2 : : !! NAME
3 : : !! m_parser
4 : : !!
5 : : !! FUNCTION
6 : : !! This module contains (low-level) procedures to parse and validate input files.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2008-2026 ABINIT group (XG, MJV, MT)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! SOURCE
15 : :
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 : : use netcdf
30 : : use m_nctk
31 : : !use m_nctk, only : write_var_netcdf ! FIXME Deprecated
32 : :
33 : : use m_io_tools, only : open_file
34 : : use m_fstrings, only : sjoin, strcat, itoa, inupper, ftoa, tolower, toupper, next_token, &
35 : : endswith, char_count, find_digit, replace !, startswith,
36 : : use m_geometry, only : xcart2xred, det3r, mkrdim
37 : :
38 : : implicit none
39 : :
40 : : private
41 : : !!***
42 : :
43 : : !----------------------------------------------------------------------
44 : :
45 : : !!****t* defs_abitypes/ab_dimensions
46 : : !! NAME
47 : : !! ab_dimensions
48 : : !!
49 : : !! FUNCTION
50 : : !! One record for each dimension of arrays used in ABINIT.
51 : : !! Will be used to e.g.:
52 : : !! - contain the maximum size attained over all datasets (mxvals)
53 : : !! - indicate whether this dimension is the same for all datasets or not (multivals).
54 : : !! Used for example inside outvars
55 : : !!
56 : : !! SOURCE
57 : :
58 : : type,public :: ab_dimensions
59 : :
60 : : integer :: ga_n_rules ! maximal value of input ga_n_rules for all the datasets
61 : : integer :: gw_nqlwl ! maximal value of input gw_nqlwl for all the datasets
62 : : integer :: lpawu ! maximal value of input lpawu for all the datasets
63 : : integer :: mband
64 : : integer :: mband_upper ! maximal value of input nband for all the datasets
65 : : ! Maybe this one could be removed
66 : : integer :: natom
67 : : integer :: natpawu ! maximal value of number of atoms on which +U is applied for all the datasets
68 : : integer :: natsph ! maximal value of input natsph for all the datasets
69 : : integer :: natsph_extra ! maximal value of input natsph_extra for all the datasets
70 : : integer :: natvshift ! maximal value of input natvshift for all the datasets
71 : : integer :: nberry = 20 ! This is presently a fixed value. Should be changed.
72 : : integer :: nbandhf
73 : : integer :: nconeq ! maximal value of input nconeq for all the datasets
74 : : integer :: n_efmas_dirs
75 : : integer :: nfreqsp
76 : : integer :: n_projection_frequencies
77 : : integer :: nimage
78 : : integer :: nimfrqs
79 : : integer :: nkpt ! maximal value of input nkpt for all the datasets
80 : : integer :: nkptgw ! maximal value of input nkptgw for all the datasets
81 : : integer :: nkpthf ! maximal value of input nkpthf for all the datasets
82 : : integer :: nnos ! maximal value of input nnos for all the datasets
83 : : integer :: nqptdm ! maximal value of input nqptdm for all the datasets
84 : : integer :: nshiftk
85 : : integer :: nsp
86 : : integer :: nspinor ! maximal value of input nspinor for all the datasets
87 : : integer :: nsppol ! maximal value of input nsppol for all the datasets
88 : : integer :: nsym ! maximum number of symmetries
89 : : integer :: ntypalch
90 : : integer :: ntypat ! maximum number of types of atoms
91 : : integer :: nzchempot ! maximal value of input nzchempot for all the datasets
92 : :
93 : : end type ab_dimensions
94 : : !!***
95 : :
96 : : public :: parsefile
97 : : public :: inread
98 : : public :: instrng
99 : : public :: incomprs
100 : : public :: intagm
101 : : public :: importxyz
102 : :
103 : : public :: chkdpr ! Checks the value of an input real(dp) variable.
104 : : public :: chkint ! Checks the value of an input integer variable.
105 : : public :: chkint_eq ! Checks the value of an input integer variable against a list.
106 : : public :: chkint_ge ! Checks the value of an input integer variable, expected to be greater than some value.
107 : : public :: chkint_le ! Checks the value of an input integer variable, expected to be lower than some value.
108 : : public :: chkint_ne ! Checks the value of an input integer variable against a list.
109 : : !public :: chkint_prt
110 : :
111 : : public :: prttagm ! Print the content of intarr or dprarr.
112 : : public :: prttagm_images ! Extension to prttagm to include the printing of images information.
113 : : public :: chkvars_in_string ! Analyze variable names in string. Abort if name is not recognized.
114 : : public :: get_acell_rprim ! Get acell and rprim from string
115 : :
116 : :
117 : : !----------------------------------------------------------------------
118 : :
119 : : !!****t* m_parser/geo_t
120 : : !! NAME
121 : : !! geo_t
122 : : !!
123 : : !! FUNCTION
124 : : !! Small object describing the crystalline structure read from an external file
125 : : !! or a string given in the input file.
126 : : !!
127 : : !! SOURCE
128 : :
129 : : type,public :: geo_t
130 : :
131 : : integer :: natom = 0
132 : : ! Number of atoms
133 : :
134 : : integer :: ntypat = 0
135 : : ! Number of type of atoms
136 : :
137 : : character(len=500) :: title = ""
138 : : ! Optional title read for external file e.g. POSCAR
139 : :
140 : : character(len=500) :: fileformat = ""
141 : : ! (poscar, netcdf)
142 : :
143 : : integer,allocatable :: typat(:)
144 : : ! typat(natom)
145 : : ! Type of each natom.
146 : :
147 : : real(dp) :: rprimd(3,3)
148 : :
149 : : real(dp),allocatable :: xred(:,:)
150 : : ! xred(3,natom)
151 : : ! Reduced coordinates.
152 : :
153 : : real(dp),allocatable :: znucl(:)
154 : : ! znucl(ntypat)
155 : : ! Nuclear charge for each type of pseudopotential
156 : : ! Note that ntypat must be equal to npsp --> no alchemical mixing
157 : :
158 : : contains
159 : :
160 : : procedure :: free => geo_free
161 : : ! Free memory.
162 : :
163 : : procedure :: malloc => geo_malloc
164 : : ! Allocate memory
165 : :
166 : : procedure :: bcast => geo_bcast
167 : : ! Broadcast object
168 : :
169 : : procedure :: print_abivars => geo_print_abivars
170 : : ! Print Abinit variables corresponding to POSCAR
171 : :
172 : : end type geo_t
173 : :
174 : : public :: geo_from_abivar_string ! Build object form abinit variable
175 : : public :: geo_from_poscar_path ! Build object from POSCAR filepath.
176 : : public :: intagm_img ! Read input file variables according to images path definition (1D array)
177 : :
178 : : interface intagm_img
179 : : module procedure intagm_img_1D
180 : : module procedure intagm_img_2D
181 : : end interface intagm_img
182 : :
183 : :
184 : : CONTAINS !===========================================================
185 : : !!***
186 : :
187 : : !!****f* m_parser/parsefile
188 : : !! NAME
189 : : !! parsefile
190 : : !!
191 : : !! FUNCTION
192 : : !! Glue function, to read the given file, put it into a string,
193 : : !! change everything to uppercase, remove carriage returns and
194 : : !! non significant blank characters. May also read a XYZ input
195 : : !! file if specified. Finally read ndtset input variable.
196 : : !!
197 : : !! INPUTS
198 : : !! filnamin= the file to read
199 : : !! comm=MPI communicator
200 : : !!
201 : : !! OUTPUT
202 : : !! lenstr= the length of the resulting string.
203 : : !! ndtset= the number of declared datasets.
204 : : !! string= contains on output the content of the file, ready for parsing.
205 : : !!
206 : : !! SOURCE
207 : :
208 : 2629 : subroutine parsefile(filnamin, lenstr, ndtset, string, comm)
209 : :
210 : : !Arguments ------------------------------------
211 : : character(len=*),intent(in) :: filnamin
212 : : integer,intent(in) :: comm
213 : : integer,intent(out) :: ndtset,lenstr
214 : : character(len=strlen),intent(out) :: string
215 : :
216 : : !Local variables-------------------------------
217 : : !scalars
218 : : integer,parameter :: master = 0, option1 = 1
219 : : integer :: marr,tread,lenstr_noxyz,ierr
220 : : character(len=strlen) :: string_raw, string_with_comments
221 : : character(len=500) :: msg
222 : : !arrays
223 : : integer :: intarr(1)
224 : : real(dp) :: dprarr(1)
225 : : ! *************************************************************************
226 : :
227 : : ! Read the input file, and store the information in a long string of characters
228 : : ! Note: this is done only by me=0, and then string and other output vars are BCASTED
229 : :
230 [ + + ]: 2629 : if (xmpi_comm_rank(comm) == master) then
231 : :
232 : : ! strlen from defs_basis module
233 : 2348 : string = repeat(" ", strlen)
234 : 2348 : string_with_comments = repeat(" ", strlen)
235 : 2348 : call instrng(filnamin, lenstr, option1, strlen, string, string_with_comments)
236 : :
237 : : ! Copy original file, without change of case
238 : 2348 : string_raw=string
239 : :
240 : : ! To make case-insensitive, map characters of string to upper case.
241 : 2348 : call inupper(string(1:lenstr))
242 : :
243 : : ! Make sure double quotation marks are used to enclose strings.
244 : : !string = replace(string(1:lenstr), "'", '"')
245 : :
246 : : ! Might import data from xyz file(s) into string
247 : : ! Need string_raw to deal properly with xyz filenames
248 : : ! TODO: This capability can now be implemented via the structure:"xyx:path" variable
249 : 2348 : lenstr_noxyz = lenstr
250 : 2348 : call importxyz(lenstr, string_raw, string, strlen)
251 : :
252 : : ! Make sure we don't have unmatched quotation marks
253 [ - + ]: 2348 : if (mod(char_count(string(:lenstr), '"'), 2) /= 0) then
254 : 0 : ABI_ERROR('Your input file contains unmatched quotation marks `"`. This confuses the parser. Check your input.')
255 : : end if
256 : :
257 : : ! Take ndtset from the input string
258 : 2348 : ndtset=0; marr=1
259 : 2348 : call intagm(dprarr,intarr,0,marr,1,string(1:lenstr),"ndtset",tread,'INT')
260 [ + + ]: 2348 : if (tread==1) ndtset=intarr(1)
261 : : ! Check that ndtset is within bounds
262 [ - + ]: 2348 : if (ndtset<0 .or. ndtset>9999) then
263 : : write(msg, '(a,i0,4a)' )&
264 : 0 : 'Input ndtset must be non-negative and < 10000, but was ',ndtset,ch10,&
265 : 0 : 'This is not allowed.',ch10,'Action: modify ndtset in the input file.'
266 : 0 : ABI_ERROR(msg)
267 : : end if
268 : : end if ! master
269 : :
270 [ + + ]: 2629 : if (xmpi_comm_size(comm) > 1) then
271 : : ! Broadcast data.
272 : 390 : call xmpi_bcast(lenstr, master, comm, ierr)
273 : 390 : call xmpi_bcast(ndtset, master, comm, ierr)
274 : 390 : call xmpi_bcast(string, master, comm, ierr)
275 : 390 : call xmpi_bcast(string_raw, master, comm, ierr)
276 : : end if
277 : :
278 : : ! Save input string in global variable so that we can access it in ntck_open_create
279 : : ! XG20200720: Why not saving string? string_raw is less processed than string ...
280 : : ! MG: Because we don't want a processed string without comments.
281 : : ! Abipy may use the commented section to extract additional metadata e.g. the pseudos md5
282 : :
283 : : ! The Fortran compiler may limit the length of character string constants to a specific maximum e.g.
284 : : ! intel16 has a 7198 limit so we allocate INPUT_STRING here.
285 [ + + ]: 2629 : if (allocated(INPUT_STRING)) then
286 : 1173 : ABI_FREE_SCALAR(INPUT_STRING)
287 : : end if
288 : :
289 [ - + - + ]: 2629 : ABI_MALLOC_TYPE_SCALAR(character(len=len_trim(string_with_comments)), INPUT_STRING)
290 [ - + - + : 2629 : INPUT_STRING = trim(string_with_comments)
+ - ]
291 : :
292 : : !write(std_out, *)"len_trim(string_with_comments):", len_trim(string_with_comments)
293 : : !write(std_out,'(4a)')"string_with_comments", ch10, trim(string_with_comments), ch10
294 : : !write(std_out,'(4a)')"INPUT_STRING", ch10, trim(INPUT_STRING), ch10; write(std_out,'(a)')string(:lenstr); stop
295 : :
296 : 2629 : end subroutine parsefile
297 : : !!***
298 : :
299 : : !!****f* m_parser/inread
300 : : !! NAME
301 : : !! inread
302 : : !!
303 : : !! FUNCTION
304 : : !! Carry out internal read from input character string, starting
305 : : !! at first character in string, reading ndig digits (including possible
306 : : !! sign, decimal, and exponent) by computing the appropriate format and
307 : : !! performing a formatted read (list-directed read would be perfect for
308 : : !! this application but is inconsistent with internal read according to Fortran90 standard).
309 : : !! In case of a real number, this routine
310 : : !! is also able to read SQRT(number): return the square root of the number.
311 : : !!
312 : : !! INPUTS
313 : : !! string=character string.
314 : : !! ndig=length of field to be read (including signs, decimals, and exponents).
315 : : !! typevarphys=variable type (might indicate the physical meaning for dimensionality purposes)
316 : : !! 'INT'=>integer
317 : : !! 'DPR','LEN','ENE'=>real(dp) (no special treatment)
318 : : !! 'LOG'=>integer, but read logical variable T,F,.true., or .false.
319 : : !! 'KEY'=>character, returned in token
320 : : !!
321 : : !! OUTPUT
322 : : !! outi or outr (integer or real respectively)
323 : : !! errcod, =0 for success, 1,2 for ini, inr failure resp.
324 : : !!
325 : : !! SOURCE
326 : :
327 : 506705 : subroutine inread(string,ndig,typevarphys,outi,outr,errcod)
328 : :
329 : : !Arguments ------------------------------------
330 : : !scalars
331 : : integer,intent(in) :: ndig
332 : : integer,intent(out) :: errcod,outi
333 : : real(dp),intent(out) :: outr
334 : : character(len=*),intent(in) :: string
335 : : character(len=*),intent(in) :: typevarphys
336 : :
337 : : !Local variables-------------------------------
338 : : !scalars
339 : : integer :: done,idig,index_slash,sign
340 : : real(dp) :: den,num
341 : : logical :: logi
342 : : character(len=500) :: msg
343 : : character(len=100) :: iomsg
344 : : ! *************************************************************************
345 : :
346 : : !write(std_out,*)'inread: enter with string(1:ndig): ',string(1:ndig)
347 : : !write(std_out,*)'typevarphys: ',typevarphys
348 : :
349 [ + + ]: 506705 : if (typevarphys=='INT') then
350 : :
351 : : ! integer input section
352 : 273179 : read(unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) outi
353 : :
354 [ - + ]: 273179 : if(errcod/=0)then
355 : : ! integer reading error
356 : : write(msg,'(a,i0,8a)' ) &
357 : 0 : "Attempted to read ndig: ",ndig," integer digits", ch10, &
358 : 0 : "from string(1:ndig)= `",string(1:ndig),"` to initialize an integer variable",ch10,&
359 : 0 : "iomsg: ", trim(iomsg)
360 : 0 : ABI_WARNING(msg)
361 : 0 : errcod=1
362 : : end if
363 : :
364 : : else if (typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' &
365 [ + + + + : 233526 : .or. typevarphys=='BFI' .or. typevarphys=='TIM') then
+ + + + +
+ ]
366 : :
367 : : ! real(dp) input section
368 : : ! Special treatment of SQRT(xxx) or -SQRT(xxx) chains of characters, where xxx can be a fraction
369 : 233525 : done=0
370 [ + + ]: 233525 : if (ndig>5) then
371 [ + + - + ]: 53247 : if(string(1:5)=='SQRT(' .and. string(ndig:ndig)==')')then
372 : : done=1 ; sign=1
373 [ + + + - ]: 53178 : else if(string(1:6)=='-SQRT(' .and. string(ndig:ndig)==')')then
374 : : done=1 ; sign=2
375 : : end if
376 : :
377 : : if(done==1)then
378 : 116 : index_slash=index(string(5+sign:ndig-1),'/')
379 [ + - ]: 116 : if(index_slash==0)then
380 : 116 : read (unit=string(5+sign:ndig-1),fmt=*,iostat=errcod, iomsg=iomsg) outr
381 : : else if(index_slash/=0)then
382 : 0 : read (unit=string(5+sign:5+sign+index_slash-2),fmt=*,iostat=errcod, iomsg=iomsg) num
383 [ # # ]: 0 : if(errcod==0)then
384 : 0 : read (unit=string(5+sign+index_slash:ndig-1),fmt=*,iostat=errcod, iomsg=iomsg) den
385 [ # # ]: 0 : if(errcod==0)then
386 [ # # ]: 0 : if(abs(den)<tol12)then
387 : 0 : errcod=1
388 : : else
389 : 0 : outr=num/den
390 : : end if
391 : : end if
392 : : end if
393 : : end if
394 [ - + ]: 116 : if(outr<-tol12)then
395 : 0 : errcod=1
396 : : else
397 : 116 : outr=sqrt(outr)
398 [ + + ]: 116 : if(sign==2)outr=-outr
399 : : end if
400 : : end if
401 : : end if
402 : :
403 : : ! Special treatment of fractions
404 : : if(done==0)then
405 : 233409 : index_slash=index(string(1:ndig),'/')
406 [ + + ]: 233409 : if(index_slash/=0)then
407 : 8784 : done=1
408 : 8784 : read (unit=string(1:index_slash-1), fmt=*, iostat=errcod, iomsg=iomsg) num
409 [ + - ]: 8784 : if(errcod==0)then
410 : 8784 : read (unit=string(index_slash+1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) den
411 [ + - ]: 8784 : if(errcod==0)then
412 [ - + ]: 8784 : if(abs(den)<tol12)then
413 : 0 : errcod=1
414 : : else
415 : 8784 : outr=num/den
416 : : end if
417 : : end if
418 : : end if
419 : : end if
420 : : end if
421 : :
422 : : ! Normal treatment of floats
423 : 224625 : if(done==0) read (unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) outr
424 : :
425 : : ! Treatment of errors
426 [ - + ]: 233525 : if(errcod/=0)then
427 : : ! real(dp) data reading error
428 : : write(msg,'(a,i0,8a)' ) &
429 : 0 : 'Attempted to read ndig: ',ndig,' floating point digits,',ch10, &
430 : 0 : 'from string(1:ndig): `',string(1:ndig),'` to initialize a floating variable.',ch10, &
431 : 0 : "iomsg: ", trim(iomsg)
432 : 0 : ABI_WARNING(msg)
433 : 0 : errcod=2
434 : : end if
435 : :
436 [ + - ]: 1 : else if (typevarphys=='LOG') then
437 : :
438 : 1 : read (unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) logi
439 : :
440 [ - + ]: 1 : if(errcod/=0)then
441 : : ! integer reading error
442 : : write(msg,'(a,i0,8a)' ) &
443 : 0 : "Attempted to read ndig: ",ndig," integer digits", ch10, &
444 : 0 : "from string(1:ndig): `",string(1:ndig),"` to initialize a logical variable.",ch10,&
445 : 0 : "iomsg: ", trim(iomsg)
446 : 0 : ABI_WARNING(msg)
447 : 0 : errcod=3
448 : : end if
449 : :
450 [ + - ]: 1 : if(logi)outi=1
451 [ - + ]: 1 : if(.not.logi)outi=0
452 : :
453 : : else
454 : : write(msg,'(4a)' ) &
455 : 0 : 'Argument typevarphys must be INT, DPR, LEN, ENE, BFI, TIM or LOG ',ch10,&
456 : 0 : 'but input value was: ',trim(typevarphys)
457 : 0 : ABI_ERROR(msg)
458 : : end if
459 : :
460 [ - + ]: 506705 : if (errcod /= 0)then
461 [ # # ]: 0 : do idig=1,ndig
462 [ # # ]: 0 : if( string(idig:idig) == 'O' )then
463 : : write(msg,'(3a)' ) &
464 : 0 : 'Note that this string contains the letter O. ',ch10,&
465 : 0 : 'It is likely that this letter should be replaced by the number 0.'
466 : 0 : ABI_WARNING(msg)
467 : 0 : exit
468 : : end if
469 : : end do
470 : : end if
471 : :
472 : 506705 : end subroutine inread
473 : : !!***
474 : :
475 : : !!****f* m_parser/instrng
476 : : !! NAME
477 : : !! instrng
478 : : !!
479 : : !! FUNCTION
480 : : !! Read the input file, and product a string of character,
481 : : !! with all data, to be analyzed in later routines. The length
482 : : !! of this string is lenstr. This number is checked to be smaller
483 : : !! than the dimension of the string of character, namely strln.
484 : : !!
485 : : !! INPUTS
486 : : !! filnam=name of the input file, to be read
487 : : !! option= if 0, simple storing of the character string,
488 : : !! no special treatment for ABINIT (comment delimiters, checks, include ...)
489 : : !! if 1, suppresses text after an ABINIT comment delimiter (! or #),
490 : : !! checks that a minus sign is followed by a number ...
491 : : !! check for INCLUDE statement:
492 : : !! if present, add string from included file
493 : : !! strln=maximal number of character of string, as declared in the calling routine
494 : : !!
495 : : !! OUTPUT
496 : : !! lenstr=actual number of character in string
497 : : !! string*(strln)=preprocessed string of character
498 : : !! raw_string=string without any preprocessing (comments are included)
499 : : !!
500 : : !! SOURCE
501 : :
502 : 2707 : recursive subroutine instrng(filnam, lenstr, option, strln, string, raw_string)
503 : :
504 : : !Arguments ------------------------------------
505 : : !scalars
506 : : integer,intent(in) :: option,strln
507 : : integer,intent(out) :: lenstr
508 : : character(len=*),intent(in) :: filnam
509 : : character(len=*),intent(out) :: string, raw_string
510 : :
511 : : !Local variables-------------------------------
512 : : character :: blank=' '
513 : : !scalars
514 : : integer,save :: include_level=-1
515 : : integer :: b0,b1,b2,b3,ierr,ii,ii1,ii2,ij,iline,ios,iost,isign
516 : : integer :: lenc,lenstr_inc,len_val,mline,nline1,input_unit,shift,sign,lenstr_raw
517 : : logical :: include_found, ex
518 : : !arrays
519 : : integer :: bs(2)
520 : : character(len=1) :: string1
521 : : character(len=3) :: string3
522 : : character(len=500) :: filnam_inc,msg
523 : : character(len=fnlen) :: shell_var, shell_value
524 : : character(len=fnlen+20) :: line
525 : : character(len=strlen),pointer :: string_inc, raw_string_inc
526 : : !************************************************************************
527 : :
528 : : DBG_ENTER("COLL")
529 : :
530 : : !%%%%%%%%%%%%%%%%%%%%%%%%
531 : : !read in string from file
532 : : !%%%%%%%%%%%%%%%%%%%%%%%%
533 : :
534 : : ! The file can be included in another (prevent too many include levels)
535 : 2707 : include_level=include_level+1
536 [ - + ]: 2707 : if (include_level>2) then
537 : : write(msg, '(3a)' ) &
538 : 0 : 'At least 4 levels of included files are present in input file !',ch10,&
539 : 0 : 'This is not allowed. Action: change your input file.'
540 : 0 : ABI_ERROR(msg)
541 : : end if
542 : :
543 : : ! Open data file and read one line at a time, compressing data
544 : : ! and concatenating into single string:
545 [ - + ]: 2707 : if (open_file(filnam,msg,newunit=input_unit,form="formatted",status="old",action="read") /= 0) then
546 : 0 : ABI_ERROR(msg)
547 : : end if
548 : 2707 : rewind (unit=input_unit)
549 : :
550 : : ! Initialize string to blanks
551 [ + - + - ]: 2707 : string=blank
552 : 2707 : lenstr=1
553 : 2707 : lenstr_raw = 0
554 : :
555 : : ! Set maximum number lines to be read to some large number
556 : 2707 : mline=500000
557 [ + - ]: 252166 : do iline=1,mline
558 : :
559 : : ! Keeps reading lines until end of input file
560 : 252166 : read (unit=input_unit,fmt= '(a)' ,iostat=ios) line(1:fnlen+20)
561 : : ! Hello ! This is a commentary. Please, do not remove me.
562 : : ! In fact, this commentary protect tests_v4 t47 for miscopying
563 : : ! the input file into the output string. It _is_ strange.
564 : : ! The number of lines in the commentary is also resulting from
565 : : ! a long tuning..
566 : :
567 : : ! write(std_out,*)' instrng, iline=',iline,' ios=',ios,' echo :',trim(line(1:fnlen+20))
568 : :
569 : : ! Exit the reading loop when arrived at the end
570 [ + + ]: 252166 : if (ios/=0) then
571 : 2707 : backspace(input_unit)
572 : 2707 : read (unit=input_unit,fmt= '(a1)' ,iostat=ios) string1
573 [ + - ]: 2707 : if(ios/=0)exit
574 : 0 : backspace(input_unit)
575 : 0 : read (unit=input_unit,fmt= '(a3)' ,iostat=ios) string3
576 [ # # ]: 0 : if(string3=='end') exit
577 : : write(msg, '(3a,i0,11a)' ) &
578 : 0 : 'It is observed in the input file: ',TRIM(filnam),', line number ',iline,',',ch10,&
579 : 0 : 'that there is a non-zero IO signal.',ch10,&
580 : 0 : 'This is normal when the file is completely read.',ch10,&
581 : 0 : 'However, it seems that the error appears while your file has not been completely read.',ch10,&
582 : 0 : 'Action: correct your file. If your file seems correct, then,',ch10,&
583 : 0 : 'add the keyword ''end'' at the very beginning of the last line of your input file.'
584 : 0 : ABI_ERROR(msg)
585 : : end if
586 : :
587 : : ! Save raw line in raw_string including comments that may be needed by external processors
588 : : ! e.g. AbiPy may need the JSON section with pseudos. Also add new line.
589 : 249459 : ii2 = len_trim(line) + 1
590 [ - + ]: 249459 : if (lenstr_raw + ii2 > strln) then
591 : : write(msg, '(8a)' ) &
592 : 0 : 'The size of your input file: ',trim(filnam),' is such that the internal',ch10,&
593 : 0 : 'character string that should contain it is too small.',ch10,&
594 : 0 : 'Action: decrease the size of your input file,',ch10,&
595 : 0 : 'or contact the ABINIT group.'
596 : 0 : ABI_ERROR(msg)
597 : : end if
598 : :
599 [ + - - + ]: 249459 : raw_string(lenstr_raw+1:lenstr_raw+ii2) = trim(line) // new_line("A")
600 : 249459 : lenstr_raw = lenstr_raw + ii2
601 : :
602 : : ! TODO: Ignore sections inside TEST_INFO markers so that we don't need to prepend comment markers.
603 : : !in_testinfo = 0
604 : : !if startswith(line, "#%%<BEGIN TEST_INFO") in_testinfo = 1
605 : : !if (in_testinfo /= 0) cycle
606 : : !if startswith(line, "#%%<END TEST_INFO> ") then
607 : : ! in_testinfo = 0; cycle
608 : : !end if
609 : :
610 : : ! Find length of input line ignoring delimiter characters (# or !)
611 : : ! and any characters beyond it (allows for comments beyond # or !)
612 : 249459 : ii1=index(line(1:fnlen+20),'#')
613 : 249459 : ii2=index(line(1:fnlen+20),'!')
614 [ + + + - ]: 249459 : if ( (ii1==0 .and. ii2==0) .or. option==0 ) then
615 : : ! delimiter character was not found on line so use full line
616 : : ii=fnlen+20
617 [ + + ]: 107097 : else if(ii1==0)then
618 : : ! ii will represent length of line up to but not including !
619 : 2032 : ii=ii2-1
620 [ + + ]: 105065 : else if(ii2==0)then
621 : : ! ii will represent length of line up to but not including #
622 : 104649 : ii=ii1-1
623 : : else
624 : 416 : ii=min(ii1,ii2)-1
625 : : end if
626 : :
627 : : ! Checks that nothing is left beyond fnlen
628 [ + + ]: 249459 : if(ii>fnlen)then
629 : : !write(std_out, *)"line: `", line(1:fnlen+20), "`"
630 [ + + ]: 2989602 : do ij=fnlen+1,ii
631 [ - + ]: 2989602 : if(line(ij:ij)/=' ')then
632 : : write(msg,'(3a,i0,3a,i0,3a)' ) &
633 : 0 : 'It is observed in the input file: ',TRIM(filnam),' line number ',iline,',',ch10,&
634 : 0 : 'that more than ',fnlen,' columns are used.',ch10,&
635 : 0 : 'This is not allowed. Change this line of your input file.'
636 : 0 : ABI_ERROR(msg)
637 : : end if
638 : : end do
639 : : end if
640 : :
641 [ + + ]: 249459 : if (ii>0) then
642 : : ! Check for the occurrence of a minus sign followed by a blank
643 : 163271 : ij=index(line(1:ii),'- ')
644 [ - + - - ]: 163271 : if (ij>0 .and. option==1) then
645 : : write(msg, '(3a,i0,11a)' ) &
646 : 0 : 'It is observed in the input file:, ',TRIM(filnam),' line number ',iline,',',ch10,&
647 : 0 : 'the occurrence of a minus sign followed',ch10,&
648 : 0 : 'by a blank. This is forbidden.',ch10,&
649 : 0 : 'If the minus sign is meaningful, do not leave a blank',ch10,&
650 : 0 : 'between it and the number to which it applies.',ch10,&
651 : 0 : 'Otherwise, remove it.'
652 : 0 : ABI_ERROR(msg)
653 : : end if
654 : : ! Check for the occurrence of a tab
655 : 163271 : ij=index(line(1:ii),char(9))
656 [ - + - - ]: 163271 : if (ij>0 .and. option==1 ) then
657 : : write(msg, '(3a,i0,3a)' ) &
658 : 0 : 'The occurrence of a tab, in the input file: ',TRIM(filnam),' line number ',iline,',',ch10,&
659 : 0 : 'is observed. This sign is confusing, and has been forbidden.'
660 : 0 : ABI_ERROR(msg)
661 : : end if
662 : :
663 : : ! Check for the occurrence of a include statement
664 : 163271 : include_found=.false.
665 [ + - ]: 163271 : if (option==1) then
666 : : ! Look for include statement
667 : 163271 : ii1=index(line(1:ii),"include");ii2=index(line(1:ii),"INCLUDE")
668 : 163271 : include_found=(ii1>0.or.ii2>0)
669 [ + + ]: 163271 : if (include_found) then
670 : 2 : ij=max(ii1,ii2);ii1=0;ii2=0
671 : : ! Look for quotes (ascii 34)
672 : 2 : ii1=index(line(ij+7:ii),char(34))
673 [ + - ]: 2 : if (ii1>1) ii2=index(line(ij+7+ii1:ii),char(34))
674 : : ! Look for quotes (ascii 39)
675 [ - + ]: 2 : if (ii1==0.and.ii2==0) then
676 : 0 : ii1=index(line(ij+7:ii),char(39))
677 [ # # ]: 0 : if (ii1>1) ii2=index(line(ij+7+ii1:ii),char(39))
678 : : end if
679 : : ! Check if quotes are correctly set
680 : 2 : ex=(ii1<=1.or.ii2<=1)
681 [ + - ]: 2 : if (.not.ex) then
682 [ + - ]: 2 : msg=line(ij+7:ij+5+ii1)
683 : 2 : call incomprs(msg(1:ii1-1),lenc)
684 : 2 : ex=(len(trim(msg))/=0)
685 : : end if
686 [ - + ]: 2 : if (ex) then
687 : : write(msg, '(6a)' ) &
688 : 0 : 'A "include" statement has been found in input file: ',TRIM(filnam),ch10,&
689 : 0 : 'but there must be a problem with the quotes.',ch10,&
690 : 0 : 'Action: change your input file.'
691 : 0 : ABI_ERROR(msg)
692 : : end if
693 : : ! Store included file name
694 [ + - ]: 2 : filnam_inc=line(ij+7+ii1:ij+5+ii1+ii2)
695 : : ! Extract include statement from line
696 : 2 : lenc=ii1+ii2+7
697 [ + - - + ]: 2 : msg(1:ii-lenc)=line(1:ij-1)//line(ij+lenc:ii)
698 [ + - ]: 2 : ii=ii-lenc;line(1:ii)=msg(1:ii)
699 : : end if
700 : : end if
701 : :
702 : : ! Compress: remove repeated blanks, make all ASCII characters
703 : : ! less than a blank (and '=') to become a blank.
704 : 163271 : call incomprs(line(1:ii),lenc)
705 : :
706 : : else
707 : : ! ii=0 means line starts with #, is entirely a comment line
708 : 86188 : lenc=0;include_found=.false.
709 : : end if
710 : :
711 : : ! Check resulting total string length
712 [ - + ]: 249459 : if (lenstr+lenc>strln) then
713 : : write(msg, '(8a)' ) &
714 : 0 : 'The size of your input file: ',TRIM(filnam),' is such that the internal',ch10,&
715 : 0 : 'character string that should contain it is too small.',ch10,&
716 : 0 : 'Action: decrease the size of your input file,',ch10,&
717 : 0 : 'or contact the ABINIT group.'
718 : 0 : ABI_ERROR(msg)
719 : : end if
720 : :
721 [ + + ]: 249459 : if (lenc>0) then
722 : : ! Concatenate new compressed characters
723 : : ! with previous part of compressed string (unless all blank)
724 [ + - - + ]: 125997 : string(lenstr+1:lenstr+lenc)=line(1:lenc)
725 : : end if
726 : : ! Keep track of total string length
727 : 249459 : lenstr=lenstr+lenc
728 : :
729 : : ! Eventually (recursively) read included file
730 [ + + ]: 249459 : if (include_found) then
731 : : ! Check file existence
732 : 2 : inquire(file=filnam_inc ,iostat=iost,exist=ex)
733 [ + - - + ]: 2 : if (.not. ex .or. iost /= 0) then
734 : : write(msg, '(5a)' ) &
735 : 0 : 'Input file: ',TRIM(filnam),' reading: the included file ',trim(filnam_inc),' cannot be found !'
736 : 0 : ABI_ERROR(msg)
737 : : end if
738 : : ! Read included file (warning: recursive call !)
739 [ - + ]: 2 : ABI_MALLOC(string_inc,)
740 [ - + ]: 2 : ABI_MALLOC(raw_string_inc,)
741 [ + - ]: 2 : call instrng(trim(filnam_inc),lenstr_inc,option,strln-lenstr,string_inc,raw_string_inc)
742 : : ! Check resulting total string length
743 [ - + ]: 2 : if (lenstr+lenstr_inc>strln) then
744 : : write(msg, '(6a)' ) &
745 : 0 : 'The size of your input file: ',TRIM(filnam),' (including included files) is such that',ch10,&
746 : 0 : 'the internal character string that should contain it is too small !',ch10,&
747 : 0 : 'Action: decrease the size of your input file.'
748 : 0 : ABI_ERROR(msg)
749 : : end if
750 : : ! Concatenate total string
751 [ + - - + ]: 2 : string(lenstr+1:lenstr+lenstr_inc)=string_inc(1:lenstr_inc)
752 : 2 : lenstr=lenstr+lenstr_inc
753 [ - + ]: 2 : ABI_FREE(string_inc)
754 [ - + ]: 2 : ABI_FREE(raw_string_inc)
755 : : end if
756 : :
757 : : ! If mline is reached, something is wrong
758 [ - + ]: 252166 : if (iline>=mline) then
759 : : write(msg, '(a,i0,2a,i0,4a)' ) &
760 : 0 : 'The number of lines already read from input file: ',iline,ch10,&
761 : 0 : 'is equal or greater than maximum allowed mline: ',mline,ch10,&
762 : 0 : 'Action: you could decrease the length of the input file, or',ch10,&
763 : 0 : 'increase mline in this routine.'
764 : 0 : ABI_ERROR(msg)
765 : : end if
766 : :
767 : : end do ! End loop on iline. Note that there is an "exit" instruction in the loop
768 : :
769 : 2707 : nline1=iline-1
770 : 2707 : close (unit=input_unit)
771 : :
772 : : !write(std_out,'(a,a)')' incomprs : 1, string=',string(:lenstr)
773 : :
774 : : ! Substitute environment variables, if any. Example "$ABI_PSPDIR"
775 : 2707 : b0=0
776 : : do
777 : 5053 : b0=b0+1
778 : 5053 : b1 = index(string(b0:lenstr), '$')
779 [ + + - + ]: 5053 : if(b1==0 .or. b1>=lenstr)exit
780 : 2346 : b1 = b0 + b1 - 1
781 : : !Identify delimiter, either a '"', or a "'", or a blank, or a /
782 : 2346 : b2=index(string(b1+1:lenstr),'"')
783 : 2346 : b3=index(string(b1+1:lenstr),"'")
784 [ - + ]: 2346 : if(b3/=0 .and. b3<b2)b2=b3
785 : 2346 : b3=index(string(b1+1:lenstr),' ')
786 [ - + ]: 2346 : if(b3/=0 .and. b3<b2)b2=b3
787 : 2346 : b3=index(string(b1+1:lenstr),'/')
788 [ + + ]: 2346 : if(b3/=0 .and. b3<b2)b2=b3
789 [ - + ]: 4793 : if(b2/=0)then
790 [ + - ]: 2346 : shell_var=string(b1+1:b1+b2-1)
791 : : !write(std_out,'(a,a)')' shell_var=',shell_var(:b2-1)
792 : 2346 : call get_environment_variable(shell_var(:b2-1), shell_value, status=ierr, length=len_val)
793 [ - + ]: 2346 : if (ierr == -1) ABI_ERROR(sjoin(shell_var(:b2-1), "is present but value of environment variable is too long"))
794 [ - + ]: 2346 : if (ierr == +1) ABI_ERROR(sjoin(shell_var(:b2-1), "environment variable is not defined!"))
795 [ - + ]: 2346 : if (ierr == +2) ABI_ERROR(sjoin(shell_var(:b2-1), "used in input file but processor does not support environment variables"))
796 : 2346 : call wrtout(std_out, sjoin(shell_var(:b2-1), " found in environment, with value ",shell_value(:len_val)))
797 [ + - + - ]: 2346 : string(1:lenstr-(b2-b1)+len_val)=string(1:b1-1)//shell_value(:len_val)//string(b1+b2:lenstr)
798 : 2346 : lenstr=lenstr-(b2-b1)+len_val
799 : : endif
800 : : enddo
801 : : !write(std_out,'(a)')string(:lenstr)
802 : :
803 : : ! Identify concatenate string '" // "' with an arbitrary number of blanks before and after the //
804 : : ! Actually, at this stage, there is no consecutive blanks left...
805 : 2 : do
806 : 2709 : b1 = index(string(1:lenstr), '//')
807 [ + + ]: 2709 : if(b1/=0)then
808 : : !See whether there are preceding and following '"'
809 [ + + ]: 4 : do sign=-1,1,2
810 : 4 : isign=(1+sign)/2 ! 0 for minus sign, 1 for plus sign
811 [ + - ]: 4 : do ii=1,lenstr
812 : 4 : shift=-ii+isign*(1+2*ii) ! -ii for minus sign, 1+ii for plus sign
813 [ + + + - : 4 : if( (isign==0 .and. b1+shift<1) .or. (isign==1 .and. b1+shift>lenstr) )then
+ + - + ]
814 : 0 : bs(isign+1)=0 ; exit
815 : : endif
816 [ + - ]: 4 : if (string(b1+shift:b1+shift)=='"') then
817 : 4 : bs(isign+1)=shift ; exit
818 [ # # ]: 0 : else if (string(b1+shift:b1+shift)/=' ') then
819 : 0 : bs(isign+1)=0 ; exit
820 : : endif
821 : : enddo
822 [ + - ]: 6 : if(bs(isign+1)==0)exit
823 : : enddo
824 [ + - - + ]: 2 : if(bs(1)==0 .or. bs(2)==0)exit
825 : : !the two shifts have been found, they give delimiters of the '" // "' chain
826 [ + - - + ]: 2 : string(1:lenstr-4)=string(1:b1+bs(1)-1)//string(b1+bs(2)+1:lenstr)
827 : 2 : lenstr=lenstr+bs(1)-1-bs(2)
828 : : else
829 : : exit
830 : : endif
831 : : enddo
832 : :
833 : : !write(std_out,'(a,a)')' incomprs : 2, string=',string(:lenstr)
834 : :
835 : : ! Make sure we don't have unmatched quotation marks
836 [ - + ]: 2707 : if (mod(char_count(string(:lenstr), '"'), 2) /= 0) then
837 : 0 : ABI_ERROR('Your input file contains unmatched quotation marks `"`. This confuses the parser. Check your input.')
838 : : end if
839 : :
840 : 2707 : include_level = include_level - 1
841 : :
842 : 2707 : write(msg,'(a,i0,3a)')'-instrng: ',nline1,' lines of input have been read from file ',trim(filnam),ch10
843 : 2707 : call wrtout(std_out,msg)
844 : : !write(std_out, "(3a)")"string after instrng:", ch10, string(:lenstr)
845 : :
846 : : DBG_EXIT("COLL")
847 : :
848 : 2707 : end subroutine instrng
849 : : !!***
850 : :
851 : : !!****f* m_parser/inreplsp
852 : : !! NAME
853 : : !! inreplsp
854 : : !!
855 : : !! FUNCTION
856 : : !! Replace all occurrences of characters lexically less than SP (blank)
857 : : !! by SP in the input string, returning modified string of same length.
858 : : !! Also replace a '=' by a SP.
859 : : !!
860 : : !! INPUTS
861 : : !! string=character string to be modified
862 : : !!
863 : : !! SIDE EFFECTS
864 : : !! string=same character string with ASCII (decimal) 0-31 replaced by 32.
865 : : !!
866 : : !! SOURCE
867 : :
868 : 125999 : subroutine inreplsp(string)
869 : :
870 : : !Arguments ------------------------------------
871 : : !scalars
872 : : character(len=*),intent(inout) :: string
873 : :
874 : : !Local variables-------------------------------
875 : : !scalars
876 : : integer :: ilenth,length
877 : : ! *************************************************************************
878 : :
879 : : ! Get length of string. Proceed only if string has nonzero length
880 [ + - ]: 125999 : length=len(string); if (length == 0) return
881 : :
882 : : ! Do replacement by going through input character string one character at a time
883 [ + + ]: 2875292 : do ilenth=1,length
884 [ - + ]: 2749293 : if (llt(string(ilenth:ilenth),' ')) string(ilenth:ilenth)=' '
885 [ + + ]: 2875292 : if (string(ilenth:ilenth)=='=') string(ilenth:ilenth)=' '
886 : : end do
887 : :
888 : : end subroutine inreplsp
889 : : !!***
890 : :
891 : : !!****f* m_parser/incomprs
892 : : !! NAME
893 : : !! incomprs
894 : : !!
895 : : !! FUNCTION
896 : : !! Compresses input character string into the following form:
897 : : !! (1) Replaces tabs and all other characters lexically less than
898 : : !! SP (blank) with SP (blank), where lexically less than refers to
899 : : !! the ASCII collating sequence (SP is hex 20, dec 32).
900 : : !! The use of llt is needed e.g. on the IBM 9000 because it does not
901 : : !! handle tab characters sensibly in its AIX fortran.
902 : : !! Also replace occurrences of '=' by a SP.
903 : : !! (2) Removes all repeated blanks, ignoring trailing blanks
904 : : !! after first (returns nontrailing final length in arg 'length').
905 : : !! (3) Makes first character in string NONBLANK. This is done
906 : : !! to prevent double blanks from occurring when compressed string
907 : : !! is concatenated with other compressed strings.
908 : : !! (4) Makes last character (string(length:length)) a blank.
909 : : !! If input string is entirely blank or tabs, simply returns with length=0.
910 : : !!
911 : : !! INPUTS
912 : : !! (see side effects)
913 : : !!
914 : : !! OUTPUT
915 : : !! length=nonblank, nontab length of string as defined above
916 : : !!
917 : : !! SIDE EFFECT
918 : : !! string=at input: character string
919 : : !! at output: repeated blanks and tabs have been removed and
920 : : !! remaining tabs have been replaced by blanks
921 : : !!
922 : : !! SOURCE
923 : :
924 : 163275 : subroutine incomprs(string,length)
925 : :
926 : : !Arguments ------------------------------------
927 : : !scalars
928 : : integer,intent(out) :: length
929 : : character(len=*),intent(inout) :: string
930 : :
931 : : !Local variables-------------------------------
932 : : character(len=1) :: blank=' '
933 : : !scalars
934 : : integer :: bb,f1,ii,jj,kk,l1,lbef,lcut,lold,stringlen
935 : : !arrays
936 : : character(len=500) :: msg
937 : : ! *************************************************************************
938 : :
939 : : ! String length determined by calling program declaration of "string"
940 : 163275 : stringlen=len(string)
941 : 163275 : length=stringlen
942 : :
943 : : ! Only proceed if string has nonzero length
944 [ + - ]: 163275 : if (length>0) then
945 : : ! Find last nonblank character (i.e. nonblank and nontab length)
946 : 163275 : length=len_trim(string)
947 [ + + ]: 163275 : if (length==0) then
948 : : ! Line is all blanks or tabs so do not proceed
949 : : ! write(std_out,*)' incomprs: blank line encountered'
950 : : else
951 : :
952 : : ! Replace all characters lexically less than SP, and '=', by SP (blank)
953 : 125999 : call inreplsp(string(1:length))
954 : :
955 : : ! Continue with parsing
956 : : ! l1 is set to last nonblank, nontab character position
957 : 125999 : l1=length
958 : :
959 : : ! find first non blank character
960 [ + - ]: 397265 : do ii=1,l1
961 [ + + ]: 397265 : if (string(ii:ii)/=blank) exit
962 : : end do
963 : : ! f1 is set to first nonblank, nontab character position
964 : 125999 : f1=ii
965 : :
966 : : ! lbef is number of characters in string starting at
967 : : ! first nonblank, nontab and going to last
968 : 125999 : lbef=l1-f1+1
969 : :
970 : : ! Process characters one at a time from right to left:
971 : 125999 : bb=0
972 : 125999 : lcut=lbef
973 [ + + ]: 2604026 : do ii=1,lbef
974 : 2478027 : jj=lbef+f1-ii
975 : : ! set bb=position of next blank coming in from right
976 [ + + ]: 2604026 : if (string(jj:jj)==blank) then
977 [ + + ]: 484682 : if (bb==0) bb=jj
978 : : else
979 [ + + ]: 1993345 : if (bb/=0) then
980 : : ! if several blanks in a row were found, cut from string
981 [ + + ]: 244091 : if (jj<bb-1) then
982 : : ! lold becomes string length before cutting blanks
983 : 131759 : lold=lcut
984 : : ! lcut will be new string length
985 : 131759 : lcut=lcut-(bb-1-jj)
986 : : ! redefine string with repeated blanks gone
987 [ + + ]: 1724263 : do kk=1,f1+lcut-1-jj
988 : 1724263 : string(jj+kk:jj+kk)=string(kk+bb-1:kk+bb-1)
989 : : end do
990 : : end if
991 : : bb=0
992 : : end if
993 : : end if
994 : : end do
995 : :
996 : : ! Remove initial blanks in string if any
997 [ + + + - : 125999 : if (f1>1) string(1:lcut)=string(f1:f1+lcut-1)
- + ]
998 : :
999 : : ! Add blank on end unless string had no extra space
1000 [ - + ]: 125999 : if (lcut==stringlen) then
1001 : : write(msg,'(a,i7,a,a,a,a,a,a,a,a)')&
1002 : 0 : 'For input file, with data forming a string of',stringlen,' characters,',ch10,&
1003 : 0 : 'no double blanks or tabs were found.',ch10,&
1004 : 0 : 'This is unusual for an input file (or any file),',ch10,&
1005 : 0 : 'and may cause parsing trouble. Is this a binary file?',ch10
1006 : 0 : ABI_WARNING(msg)
1007 : : else
1008 : 125999 : length=lcut+1
1009 : 125999 : string(length:length)=blank
1010 : : end if
1011 : : ! remove trailing characters left from the recursive string shifts
1012 [ + - + + ]: 125999 : string(length:stringlen)=blank
1013 : : end if
1014 : :
1015 : : end if
1016 : :
1017 : 163275 : end subroutine incomprs
1018 : : !!***
1019 : :
1020 : : !!****f* m_parser/intagm
1021 : : !! NAME
1022 : : !! intagm
1023 : : !!
1024 : : !! FUNCTION
1025 : : !! Search input 'string' for specific 'token'. Search depends on
1026 : : !! input dataset through 'jdtset'. Then, return the information mentioned after 'token'.
1027 : : !! See the "notes" section
1028 : : !!
1029 : : !! INPUTS
1030 : : !! jdtset=see the notes section
1031 : : !! marr=dimension of the intarr and dprarr arrays, as declared in the calling subroutine.
1032 : : !! narr=actual size of array to be read in.
1033 : : !! string=character string containing 'tags' and data.
1034 : : !! token=character string for 'tag'.
1035 : : !! typevarphys= variable type (might indicate the physical meaning of for dimensionality purposes)
1036 : : !! 'INT'=>integer
1037 : : !! 'DPR'=>real(dp) (no special treatment)
1038 : : !! 'LEN'=>real(dp) (expect a "length", identify bohr, au, nm or angstrom,
1039 : : !! and return in au -atomic units=bohr- )
1040 : : !! 'ENE'=>real(dp) (expect a "energy", identify Ha, hartree, eV, Ry, meV, Rydberg, K, Kelvin)
1041 : : !! 'LOG'=>integer, but read logical variable T,F,.true., or .false.
1042 : : !! 'KEY'=>character, returned in key_value
1043 : : !! 'INT_OR_KEY'=>integer scalar (returned in intarr(1)) or character (returned in key_value)
1044 : : !!
1045 : : !! OUTPUT
1046 : : !! intarr(1:narr), dprarr(1:narr)
1047 : : !! integer or real(dp) arrays, respectively (see typevarphys),
1048 : : !! into which data is read if typevarphys/='KEY'. Use these arrays even for scalars.
1049 : : !! tread is an integer: tread = 0 => no data was read
1050 : : !! tread = 1 => data was read
1051 : : !! ds_input is an optional integer flag:
1052 : : !! ds_input = 0 => value was found which is not specific to jdtset
1053 : : !! ds_input > 0 => value was found which is specific to jdtset
1054 : : !! one could add more information, eg whether a ? or a : was used, etc...
1055 : : !! [key_value]=Stores the value of key if typevarphys=="KEY" or typevarphys=="INT_OR_KEY".
1056 : : !! The string must be large enough to contain the output. fnlen is OK in many cases
1057 : : !! except when reading a list of files. The routine aborts if key_value cannot store the output.
1058 : : !! Output string is left justified.
1059 : : !!
1060 : : !! NOTES
1061 : : !!
1062 : : !! If jdtset==0:
1063 : : !!
1064 : : !! Search compressed 'string' for blank//'token'//blank and
1065 : : !! read input data beside 'token', to be read into appropriate variable.
1066 : : !! For this routine to find a given token, the token has to be preceded
1067 : : !! and followed by blanks--i.e. the first token should not start out as
1068 : : !! the first character in the input file. This is checked in the calling
1069 : : !! subroutine 'input'. Calls inread which performs internal read from
1070 : : !! specified string. Also calls upper which maps characters to all upper case.
1071 : : !! Also checks whether there is an occurrence of blank//'token'//digit,
1072 : : !! in which case the input file might be erroneous, so stops.
1073 : : !!
1074 : : !! If jdtset is a positive number:
1075 : : !!
1076 : : !! (1) First search for modified string, blank//'token'//jdtset//blank
1077 : : !!
1078 : : !! (2a) if the occurrence of (1) is not found,
1079 : : !! look for other modified strings,
1080 : : !! blank//'token'//'?'//unities//blank
1081 : : !! or
1082 : : !! blank//'token'//dozens//'?'//blank
1083 : : !! (issue an error message if more than one occurs)
1084 : : !! where jdtset=dozens*10+unities (decimal decomposition of jdtset)
1085 : : !! if one of them exists, just take the value
1086 : : !! Note that unities is a one-digit number, while dozens might be bigger than 9.
1087 : : !!
1088 : : !! (2b-2c) search for a series, with the following tokens :
1089 : : !! (issue an error message if more than one occurs, or
1090 : : !! goto (3) if none exist)
1091 : : !!
1092 : : !! blank//'token'//':'//blank
1093 : : !! if it exists, then a series might have been defined in the input file
1094 : : !! must thus find either the increment, blank//'token'//'+'//blank,
1095 : : !! or the multiplicative factor, blank//'token'//'*'//blank
1096 : : !!
1097 : : !! blank//'token'//'?'//':'//blank
1098 : : !! if it exists, then a series for the inner loop
1099 : : !! might have been defined in the input file
1100 : : !! must thus find either the increment, blank//'token'//'?'//'+'//blank,
1101 : : !! or the multiplicative factor, blank//'token'//'?'//'*'//blank
1102 : : !!
1103 : : !! blank//'token'//':'//'?'//blank
1104 : : !! if it exists, then a series for the outer loop
1105 : : !! might have been defined in the input file
1106 : : !! must thus find either the increment, blank//'token'//'+'//'?'//blank,
1107 : : !! or the multiplicative factor, blank//'token'//'*'//'?'//blank
1108 : : !!
1109 : : !! (3) if neither (1) nor (2) are found, search for the 'normal'
1110 : : !! string, blank//'token'//blank
1111 : : !!
1112 : : !!
1113 : : !! SOURCE
1114 : :
1115 : 6333621 : subroutine intagm(dprarr,intarr,jdtset,marr,narr,string,token,tread,typevarphys,ds_input,key_value)
1116 : :
1117 : : !Arguments ------------------------------------
1118 : : !scalars
1119 : : integer,intent(in) :: jdtset,marr,narr
1120 : : integer,intent(out) :: tread
1121 : : integer,intent(out),optional :: ds_input
1122 : : character(len=*),intent(in) :: string
1123 : : character(len=*),intent(in) :: token
1124 : : character(len=*),intent(in) :: typevarphys
1125 : : character(len=*),optional,intent(out) :: key_value
1126 : : !arrays
1127 : : integer,intent(inout) :: intarr(marr)
1128 : : real(dp),intent(inout) :: dprarr(marr)
1129 : :
1130 : : !Local variables-------------------------------
1131 : : character(len=1), parameter :: blank=' '
1132 : : !scalars
1133 : : integer :: b1,b2,b3,cs1len,cslen,dozens,ier,ii,itoken,itoken1,itoken2,itoken2_1colon
1134 : : integer :: itoken2_1plus,itoken2_1times,itoken2_2colon,itoken2_2plus
1135 : : integer :: itoken2_2times,itoken2_colon,itoken2_plus,itoken2_times
1136 : : integer :: itoken_1colon,itoken_1plus,itoken_1times,itoken_2colon,itoken_2plus
1137 : : integer :: itoken_2times,itoken_colon,itoken_plus,itoken_times,number,opttoken
1138 : : integer :: sum_token,toklen,trial_cslen,trial_jdtset,unities
1139 : : integer :: ds_input_
1140 : : character(len=4) :: append
1141 : : character(len=3) :: typevar
1142 : : character(len=500) :: msg
1143 : : character(len=fnlen) :: cs,cs1,cs1colon,cs1plus,cs1times,cs2colon,cs2plus
1144 : : character(len=fnlen) :: cs2times,cscolon,csplus,cstimes,trial_cs
1145 : : !arrays
1146 : 6333621 : integer,allocatable :: int1(:),int2(:)
1147 : 6333621 : real(dp),allocatable :: dpr1(:),dpr2(:)
1148 : : ! *************************************************************************
1149 : :
1150 : 0 : ABI_CHECK(marr >= narr, sjoin("marr", itoa(marr)," < narr ", itoa(narr), "for token:", token))
1151 : :
1152 : 6333621 : ds_input_ = -1
1153 : 6333621 : dozens=jdtset/10
1154 : 6333621 : unities=jdtset-10*dozens
1155 : :
1156 [ - + ]: 6333621 : if(jdtset<0)then
1157 : 0 : write(msg,'(a,i0,a)')' jdtset: ',jdtset,', while it should be non-negative.'
1158 : 0 : ABI_ERROR(msg)
1159 : : end if
1160 : :
1161 [ - + ]: 6333621 : if(jdtset > 9999)then
1162 : 0 : write(msg,'(a,i0,a)')' jdtset: ',jdtset,', while it must be lower than 10000.'
1163 : 0 : ABI_ERROR(msg)
1164 : : end if
1165 : :
1166 : : ! Default values: nothing has been read
1167 : 6333621 : itoken=0
1168 : 6333621 : opttoken=0
1169 : : ! Initialise flags in case of opttoken >= 2 later.
1170 : 6333621 : itoken_times=0
1171 : 6333621 : itoken_plus=0
1172 : 6333621 : itoken_colon=0
1173 : 6333621 : cslen=1
1174 : :
1175 [ + + ]: 6333621 : if (narr/=0) then
1176 : :
1177 : 6255404 : toklen=len_trim(token)
1178 : :
1179 : : ! --------------------------------------------------------------------------
1180 : : ! (1) try to find the token with dataset number appended
1181 [ + + ]: 6255404 : if (jdtset > 0) then
1182 : :
1183 : 5868876 : call appdig(jdtset,'',append)
1184 [ + - ]: 5868876 : cs=blank//token(1:toklen)//trim(append)//blank
1185 [ + + ]: 5868876 : if(jdtset<10) then
1186 : 3483288 : cslen=toklen+3
1187 [ + + ]: 2385588 : else if(jdtset<100) then
1188 : 2163811 : cslen=toklen+4
1189 [ + + ]: 221777 : else if(jdtset<1000) then
1190 : 216527 : cslen=toklen+5
1191 [ + - ]: 5250 : else if(jdtset<10000)then
1192 : 5250 : cslen=toklen+6
1193 : : end if
1194 : : ! Map token to all upper case (make case-insensitive):
1195 : 5868876 : call inupper(cs)
1196 : : ! Absolute index of blank//token//blank in string:
1197 : 5868876 : itoken=index(string,cs(1:cslen))
1198 : : ! Look for another occurrence of the same token in string, if so, leaves:
1199 : 5868876 : itoken2=index(string,cs(1:cslen), BACK=.true. )
1200 [ - + ]: 5868876 : if(itoken/=itoken2)then
1201 : : write(msg, '(7a)' )&
1202 : 0 : 'There are two occurrences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1203 : 0 : 'This is confusing, so it has been forbidden.',ch10,&
1204 : 0 : 'Action: remove one of the two occurrences.'
1205 : 0 : ABI_ERROR(msg)
1206 : : end if
1207 : :
1208 [ + + ]: 5868876 : if(itoken/=0) then
1209 : 27666 : opttoken=1
1210 : 27666 : ds_input_=jdtset
1211 : : end if
1212 : : end if
1213 : :
1214 : : ! --------------------------------------------------------------------------
1215 : : ! (2a) try to find the token appended with a string that contains the metacharacter "?".
1216 [ + + + + ]: 6255404 : if (jdtset>0 .and. opttoken==0)then
1217 : :
1218 : : ! Use the metacharacter for the dozens, and save in cs and itoken
1219 : 5841210 : write(append,'(i1)')unities
1220 [ + - ]: 5841210 : cs=blank//token(1:toklen)//'?'//trim(append)//blank
1221 : 5841210 : cslen=toklen+4
1222 : : ! Map token to all upper case (make case-insensitive):
1223 : 5841210 : call inupper(cs)
1224 : : ! Absolute index of blank//token//blank in string:
1225 : 5841210 : itoken=index(string,cs(1:cslen))
1226 : : ! Look for another occurrence of the same token in string, if so, leaves:
1227 : 5841210 : itoken2=index(string,cs(1:cslen), BACK=.true. )
1228 [ - + ]: 5841210 : if(itoken/=itoken2)then
1229 : : write(msg, '(7a)' )&
1230 : 0 : 'There are two occurrences of the keyword: "',cs(1:cslen),'" in the input file.',ch10,&
1231 : 0 : 'This is confusing, so it has been forbidden.',ch10,&
1232 : 0 : 'Action: remove one of the two occurrences.'
1233 : 0 : ABI_ERROR(msg)
1234 : : end if
1235 [ + + ]: 5841210 : if(itoken/=0) then
1236 : 5565 : opttoken=1
1237 : 5565 : ds_input_=jdtset
1238 : : end if
1239 : :
1240 : : ! Use the metacharacter for the units, and save in cs1 and itoken1
1241 : 5841210 : write(append,'(i0)')dozens
1242 [ + - ]: 5841210 : cs1=blank//token(1:toklen)//trim(append)//'?'//blank
1243 : 5841210 : cs1len=toklen+len(trim(append))+3
1244 : : ! Map token to all upper case (make case-insensitive):
1245 : 5841210 : call inupper(cs1)
1246 : : ! Absolute index of blank//token//blank in string:
1247 : 5841210 : itoken1=index(string,cs1(1:cs1len))
1248 : : ! Look for another occurrence of the same token in string, if so, leaves:
1249 : 5841210 : itoken2=index(string,cs1(1:cs1len), BACK=.true. )
1250 [ - + ]: 5841210 : if(itoken1/=itoken2)then
1251 : : write(msg, '(7a)' )&
1252 : 0 : 'There are two occurrences of the keyword "',cs1(1:cs1len),'" in the input file.',ch10,&
1253 : 0 : 'This is confusing, so it has been forbidden.',ch10,&
1254 : 0 : 'Action: remove one of the two occurrences.'
1255 : 0 : ABI_ERROR(msg)
1256 : : end if
1257 : :
1258 [ - + ]: 5841210 : if(itoken/=0 .and. itoken1/=0)then
1259 : : write(msg, '(9a)' )&
1260 : 0 : 'The keywords: "',cs(1:cslen),'" and: "',cs1(1:cs1len),'"',ch10,&
1261 : 0 : 'cannot be used together in the input file.',ch10,&
1262 : 0 : 'Action: remove one of the two keywords.'
1263 : 0 : ABI_ERROR(msg)
1264 : : end if
1265 : :
1266 [ + + ]: 5841210 : if(itoken1/=0)then
1267 : 1275 : opttoken=1
1268 : 1275 : itoken=itoken1
1269 : 1275 : cs=cs1
1270 : : cslen=cs1len
1271 : : ds_input_=jdtset
1272 : : end if
1273 : :
1274 : : end if
1275 : :
1276 : : ! --------------------------------------------------------------------------
1277 : : ! (2b) try to find the tokens defining a series
1278 [ + + ]: 6226463 : if (opttoken==0) then
1279 : :
1280 [ + - ]: 6220898 : cs=token(1:toklen)
1281 : :
1282 : 6220898 : cslen=toklen+3
1283 : 6220898 : cs1len=toklen+4
1284 : :
1285 [ + - ]: 6220898 : cscolon=blank//token(1:toklen)//':'//blank
1286 [ + - ]: 6220898 : csplus=blank//token(1:toklen)//'+'//blank
1287 [ + - ]: 6220898 : cstimes=blank//token(1:toklen)//'*'//blank
1288 : :
1289 [ + - ]: 6220898 : cs1colon=blank//token(1:toklen)//'?'//':'//blank
1290 [ + - ]: 6220898 : cs1plus=blank//token(1:toklen)//'?'//'+'//blank
1291 [ + - ]: 6220898 : cs1times=blank//token(1:toklen)//'?'//'*'//blank
1292 : :
1293 [ + - ]: 6220898 : cs2colon=blank//token(1:toklen)//':'//'?'//blank
1294 [ + - ]: 6220898 : cs2plus=blank//token(1:toklen)//'+'//'?'//blank
1295 [ + - ]: 6220898 : cs2times=blank//token(1:toklen)//'*'//'?'//blank
1296 : :
1297 : : ! Map token to all upper case (make case-insensitive):
1298 : 6220898 : call inupper(cscolon)
1299 : 6220898 : call inupper(csplus)
1300 : 6220898 : call inupper(cstimes)
1301 : 6220898 : call inupper(cs1colon)
1302 : 6220898 : call inupper(cs1plus)
1303 : 6220898 : call inupper(cs1times)
1304 : 6220898 : call inupper(cs2colon)
1305 : 6220898 : call inupper(cs2plus)
1306 : 6220898 : call inupper(cs2times)
1307 : :
1308 : : ! Absolute index of tokens in string:
1309 : 6220898 : itoken_colon=index(string,cscolon(1:cslen))
1310 : 6220898 : itoken_plus=index(string,csplus(1:cslen))
1311 : 6220898 : itoken_times=index(string,cstimes(1:cslen))
1312 : 6220898 : itoken_1colon=index(string,cs1colon(1:cs1len))
1313 : 6220898 : itoken_1plus=index(string,cs1plus(1:cs1len))
1314 : 6220898 : itoken_1times=index(string,cs1times(1:cs1len))
1315 : 6220898 : itoken_2colon=index(string,cs2colon(1:cs1len))
1316 : 6220898 : itoken_2plus=index(string,cs2plus(1:cs1len))
1317 : 6220898 : itoken_2times=index(string,cs2times(1:cs1len))
1318 : :
1319 : : ! Look for another occurrence of the same tokens in string
1320 : 6220898 : itoken2_colon=index(string,cscolon(1:cslen), BACK=.true. )
1321 : 6220898 : itoken2_plus=index(string,csplus(1:cslen), BACK=.true. )
1322 : 6220898 : itoken2_times=index(string,cstimes(1:cslen), BACK=.true. )
1323 : 6220898 : itoken2_1colon=index(string,cs1colon(1:cs1len), BACK=.true. )
1324 : 6220898 : itoken2_1plus=index(string,cs1plus(1:cs1len), BACK=.true. )
1325 : 6220898 : itoken2_1times=index(string,cs1times(1:cs1len), BACK=.true. )
1326 : 6220898 : itoken2_2colon=index(string,cs2colon(1:cs1len), BACK=.true. )
1327 : 6220898 : itoken2_2plus=index(string,cs2plus(1:cs1len), BACK=.true. )
1328 : 6220898 : itoken2_2times=index(string,cs2times(1:cs1len), BACK=.true. )
1329 : :
1330 [ + + ]: 6220898 : if(jdtset==0)then
1331 : :
1332 : : ! If the multi-dataset mode is not used, no token should have been found
1333 [ - + ]: 386528 : if(itoken_colon+itoken_plus+itoken_times+ itoken_2colon+itoken_2plus+itoken_2times > 0 ) then
1334 : : write(msg,'(a,a,a,a,a,a,a,a,a,a,a,a, a)' )&
1335 : 0 : 'Although the multi-dataset mode is not activated,',ch10,&
1336 : 0 : 'the keyword "',trim(cs),'" has been found',ch10,&
1337 : 0 : 'appended with + * or : .',ch10,&
1338 : 0 : 'This is not allowed.',ch10,&
1339 : 0 : 'Action: remove the appended keyword, or',ch10,&
1340 : 0 : 'use the multi-dataset mode (ndtset/=0).'
1341 : 0 : ABI_ERROR(msg)
1342 : : end if
1343 [ - + ]: 386528 : if(itoken_1colon+itoken_1plus+itoken_1times > 0 ) then
1344 : : write(msg, '(a,a,a,a,a,a,a,a,a,a,a,a,a)' )&
1345 : 0 : 'Although the multi-dataset mode is not activated,',ch10,&
1346 : 0 : 'the keyword "',trim(cs),'" has been found',ch10,&
1347 : 0 : 'appended with ? , then + * or : .',ch10,&
1348 : 0 : 'This is not allowed.',ch10,&
1349 : 0 : 'Action: remove the appended keyword, or',ch10,&
1350 : 0 : 'use the multi-dataset mode (ndtset/=0).'
1351 : 0 : ABI_ERROR(msg)
1352 : : end if
1353 : :
1354 : : else
1355 : :
1356 : : ! If the multi-dataset mode is used, exactly zero or two token must be found
1357 : 5834370 : sum_token=0
1358 [ + + ]: 5834370 : if(itoken_colon/=0)sum_token=sum_token+1
1359 [ + + ]: 5834370 : if(itoken_plus /=0)sum_token=sum_token+1
1360 [ + + ]: 5834370 : if(itoken_times/=0)sum_token=sum_token+1
1361 [ + + ]: 5834370 : if(itoken_1colon/=0)sum_token=sum_token+1
1362 [ + + ]: 5834370 : if(itoken_1plus /=0)sum_token=sum_token+1
1363 [ - + ]: 5834370 : if(itoken_1times/=0)sum_token=sum_token+1
1364 [ + + ]: 5834370 : if(itoken_2colon/=0)sum_token=sum_token+1
1365 [ + + ]: 5834370 : if(itoken_2plus /=0)sum_token=sum_token+1
1366 [ - + ]: 5834370 : if(itoken_2times/=0)sum_token=sum_token+1
1367 : :
1368 [ - + ]: 5834370 : if(sum_token/=0 .and. sum_token/=2) then
1369 : : write(msg, '(a,a,a,a,a,i0,a,a,a,a,a,a,a)' )&
1370 : 0 : 'The keyword "',trim(cs),'" has been found to take part',ch10,&
1371 : 0 : 'to series definition in the multi-dataset mode ',sum_token,' times.',ch10,&
1372 : 0 : 'This is not allowed, since it should be used once with ":",',ch10,&
1373 : 0 : 'and once with "+" or "*".',ch10,&
1374 : 0 : 'Action: change the number of occurrences of this keyword.'
1375 : 0 : ABI_ERROR(msg)
1376 : : end if
1377 : :
1378 : : ! If the multi-dataset mode is used, make sure that no twice the same combined keyword happens
1379 : 5834370 : ier=0
1380 [ - + ]: 5834370 : if(itoken_colon/=itoken2_colon)then
1381 : 0 : ier=1 ; cs=cscolon
1382 : : end if
1383 [ - + ]: 5834370 : if(itoken_plus/=itoken2_plus)then
1384 : 0 : ier=1 ; cs=csplus
1385 : : end if
1386 [ - + ]: 5834370 : if(itoken_times/=itoken2_times)then
1387 : 0 : ier=1 ; cs=cstimes
1388 : : end if
1389 [ - + ]: 5834370 : if(itoken_1colon/=itoken2_1colon)then
1390 : 0 : ier=1 ; cs=cs1colon
1391 : : end if
1392 [ - + ]: 5834370 : if(itoken_1plus/=itoken2_1plus)then
1393 : 0 : ier=1 ; cs=cs1plus
1394 : : end if
1395 [ - + ]: 5834370 : if(itoken_1times/=itoken2_1times)then
1396 : 0 : ier=1 ; cs=cs1times
1397 : : end if
1398 [ - + ]: 5834370 : if(itoken_2colon/=itoken2_2colon)then
1399 : 0 : ier=1 ; cs=cs2colon
1400 : : end if
1401 [ - + ]: 5834370 : if(itoken_2plus/=itoken2_2plus)then
1402 : 0 : ier=1 ; cs=cs2plus
1403 : : end if
1404 [ - + ]: 5834370 : if(itoken_2times/=itoken2_2times)then
1405 : 0 : ier=1 ; cs=cs2times
1406 : : end if
1407 [ - + ]: 5834370 : if(ier==1)then
1408 : : write(msg, '(a,a,a,a,a,a,a)' )&
1409 : 0 : 'There are two occurrences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1410 : 0 : 'This is confusing, so it has been forbidden.',ch10,&
1411 : 0 : 'Action: remove one of the two occurrences.'
1412 : 0 : ABI_ERROR(msg)
1413 : : end if
1414 : :
1415 : : ! Select the series according to the presence of a colon flag
1416 [ + + ]: 5834370 : if(itoken_colon>0)then
1417 : : opttoken=2
1418 : : ds_input_=jdtset
1419 [ + + ]: 5833957 : else if(itoken_1colon>0)then
1420 : 117 : opttoken=3
1421 : 117 : cscolon=cs1colon ; csplus=cs1plus ; cstimes=cs1times
1422 : 117 : itoken_colon=itoken_1colon
1423 : 117 : itoken_plus=itoken_1plus ; itoken_times=itoken_1times
1424 : 117 : cslen=cs1len
1425 : 117 : ds_input_=jdtset
1426 [ + + ]: 5833840 : else if(itoken_2colon>0)then
1427 : 362 : opttoken=4
1428 : 362 : cscolon=cs2colon ; csplus=cs2plus ; cstimes=cs2times
1429 : 362 : itoken_colon=itoken_2colon
1430 : 362 : itoken_plus=itoken_2plus ; itoken_times=itoken_2times
1431 : 362 : cslen=cs1len
1432 : 362 : ds_input_=jdtset
1433 : : end if
1434 : :
1435 : : ! Make sure that the proper combination of : + and * is found .
1436 [ + + - + ]: 5834370 : if(itoken_colon > 0 .and. (itoken_plus==0 .and. itoken_times==0) )then
1437 : : write(msg, '(13a)' )&
1438 : 0 : 'The keyword "',cscolon(1:cslen),'" initiate a series,',ch10,&
1439 : 0 : 'but there is no occurrence of "',csplus(1:cslen),'" or "',cstimes(1:cslen),'".',ch10,&
1440 : 0 : 'Action: either suppress the series, or make the increment',ch10,&
1441 : 0 : 'or the factor available.'
1442 : 0 : ABI_ERROR(msg)
1443 : : end if
1444 [ - + ]: 5834370 : if(itoken_plus/=0 .and. itoken_times/=0)then
1445 : : write(msg, '(a,a, a,a,a,a,a)' )&
1446 : 0 : 'The combined occurrence of keywords "',csplus(1:cslen),'" and "',cstimes(1:cslen),'" is not allowed.',ch10,&
1447 : 0 : 'Action: suppress one of them in your input file.'
1448 : 0 : ABI_ERROR(msg)
1449 : : end if
1450 [ + + - + ]: 5834370 : if(itoken_colon==0 .and. (itoken_plus/=0 .or. itoken_times/=0) ) then
1451 : 0 : cs=csplus
1452 [ # # ]: 0 : if(itoken_times/=0)cs=cstimes
1453 : : write(msg, '(a,a,a,a,a,a,a,a,a,a,a)' )&
1454 : 0 : 'The keyword "',cscolon(1:cslen),'" does not appear in the input file.',ch10,&
1455 : 0 : 'However, the keyword "',cs(1:cslen),'" appears.',ch10,&
1456 : 0 : 'This is forbidden.',ch10,&
1457 : 0 : 'Action: make the first appear, or suppress the second.'
1458 : 0 : ABI_ERROR(msg)
1459 : : end if
1460 : :
1461 : : ! At this stage, either
1462 : : ! - itoken_colon vanish as well as itoken_plus and itoken_times
1463 : : ! - itoken_colon does not vanish,
1464 : : ! as well as one of itoken_plus or itoken_times
1465 : :
1466 : : end if ! End the condition of multi-dataset mode
1467 : : end if ! End the check on existence of a series
1468 : :
1469 : : ! --------------------------------------------------------------------------
1470 : : ! (3) if not found, try to find the token with non-modified string
1471 [ + + ]: 6248564 : if (opttoken==0) then
1472 : :
1473 [ + - ]: 6220006 : cs=blank//token(1:toklen)//blank
1474 : 6220006 : cslen=toklen+2
1475 : :
1476 : : ! Map token to all upper case (make case-insensitive):
1477 : 6220006 : call inupper(cs)
1478 : :
1479 : : ! Absolute index of blank//token//blank in string:
1480 : 6220006 : itoken=index(string,cs(1:cslen))
1481 : :
1482 : : ! Look for another occurrence of the same token in string, if so, leaves:
1483 : 6220006 : itoken2=index(string,cs(1:cslen), BACK=.true. )
1484 [ - + ]: 6220006 : if (itoken/=itoken2) then
1485 : : write(msg, '(a,a,a,a,a,a,a)' )&
1486 : 0 : 'There are two occurrences of the keyword "',cs(1:cslen),'" in the input file.',ch10,&
1487 : 0 : 'This is confusing, so it has been forbidden.',ch10,&
1488 : 0 : 'Action: remove one of the two occurrences.'
1489 : 0 : ABI_ERROR(msg)
1490 : : end if
1491 : :
1492 [ + + ]: 6220006 : if(itoken/=0) then
1493 : 190645 : opttoken=1
1494 : 190645 : ds_input_=0
1495 : : end if
1496 : :
1497 : : end if
1498 : :
1499 : : ! --------------------------------------------------------------------------
1500 : : ! If jdtset==0, means that the multi-dataset mode is not used, so
1501 : : ! checks whether the input file contains a multi-dataset keyword,
1502 : : ! and if this occurs, stop. Check also the forbidden occurrence of
1503 : : ! use of 0 as a multi-dataset index.
1504 : : ! Note that the occurrence of series initiators has already been checked.
1505 : :
1506 [ + + ]: 68809444 : do trial_jdtset=0,9
1507 [ + + + + ]: 68809444 : if(jdtset==0 .or. trial_jdtset==0)then
1508 : 9734156 : write(append,'(i1)')trial_jdtset
1509 [ + - ]: 9734156 : trial_cs=blank//token(1:toklen)//trim(append)
1510 : 9734156 : trial_cslen=toklen+2
1511 : : ! Map token to all upper case (make case-insensitive):
1512 : 9734156 : call inupper(trial_cs)
1513 : : ! Look for an occurrence of this token in string, if so, leaves:
1514 : 9734156 : itoken2=index(string,trial_cs(1:trial_cslen))
1515 [ - + ]: 9734156 : if(itoken2/=0)then
1516 [ # # ]: 0 : if(trial_jdtset==0)then
1517 : : write(msg, '(7a)' )&
1518 : 0 : 'There is an occurrence of the keyword "',trim(token),'" appended with 0 in the input file.',ch10,&
1519 : 0 : 'This is forbidden.',ch10,&
1520 : 0 : 'Action: remove this occurrence.'
1521 : : else
1522 : : write(msg, '(5a,i0,5a)' )&
1523 : 0 : 'In the input file, there is an occurrence of the ',ch10,&
1524 : 0 : 'keyword "',trim(token),'", appended with the digit "',trial_jdtset,'".',ch10,&
1525 : 0 : 'This is forbidden when ndtset = =0 .',ch10,&
1526 : 0 : 'Action: remove this occurrence, or change ndtset.'
1527 : : end if
1528 : 0 : ABI_ERROR(msg)
1529 : : end if
1530 : : end if
1531 : : end do
1532 : :
1533 : : end if
1534 : :
1535 : : !===========================================================================
1536 : : ! At this stage, the location of the keyword string is known, as well
1537 : : ! as its length. So, can read the data.
1538 : : ! Usual reading if opttoken==1 (need itoken).
1539 : : ! If opttoken>=2, the characteristics of a series must be read
1540 : : ! (need itoken_colon and either itoken_plus or itoken_times)
1541 : :
1542 : 6333621 : tread = 0
1543 : 6333621 : typevar='INT'
1544 : :
1545 [ + + ]: 6333621 : if(typevarphys=='LOG')typevar='INT'
1546 : : if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. &
1547 [ + + + + : 6333621 : typevarphys=='BFI' .or. typevarphys=='TIM') typevar='DPR'
+ + + + +
+ ]
1548 : :
1549 [ + + + + ]: 6333621 : if (typevarphys=='KEY' .or. typevarphys=='INT_OR_KEY') then
1550 : : ! Consistency check for keyword (no multidataset, no series)
1551 [ - + ]: 276311 : if (opttoken>=2) then
1552 : : write(msg, '(10a)' )&
1553 : 0 : 'For the keyword "',cs(1:cslen),'", of ',trim(typevarphys),' type,',ch10,&
1554 : 0 : 'a series has been defined in the input file.',ch10,&
1555 : 0 : 'This is forbidden.',ch10,'Action: check your input file.'
1556 : 0 : ABI_ERROR(msg)
1557 : : end if
1558 [ - + ]: 276311 : if (narr>=2) then
1559 : : write(msg, '(10a)' )&
1560 : 0 : 'For the keyword "',cs(1:cslen),'", of ',trim(typevarphys),' type,',ch10,&
1561 : 0 : 'the number of data requested is larger than 1.',ch10,&
1562 : 0 : 'This is forbidden.',ch10,'Action: check your input file.'
1563 : 0 : ABI_ERROR(msg)
1564 : : end if
1565 : : end if
1566 : :
1567 : : ! There is something to be read if opttoken>=1
1568 [ + + ]: 6333621 : if (opttoken==1) then
1569 : :
1570 : : ! write(std_out,*)' intagm : opttoken==1 , token has been found, will read '
1571 : : ! Absolute location in string of blank which follows token:
1572 : 225151 : b1 = itoken + cslen - 1
1573 : :
1574 [ + + + + ]: 225151 : if (typevarphys == 'KEY' .or. typevarphys=='INT_OR_KEY') then
1575 : : ! In case of typevarphys='KEY', the chain of character will be returned in cs.
1576 [ - + ]: 9075 : ABI_CHECK(present(key_value), "typevarphys == KEY or INT_OR_KEY requires optional argument key_value")
1577 [ + + ]: 9075 : if (typevarphys == 'INT_OR_KEY') then
1578 [ - + ]: 1 : ABI_CHECK(narr==1, "typevarphys == INT_OR_KEY requires narr==1")
1579 : : end if
1580 : 9075 : b2 = index(string(b1+1:), '"')
1581 [ + + + + ]: 18163 : b3=0 ; do ii=b1,b1+b2-1 ; if (string(ii:ii)/=blank) b3=1 ; end do
1582 [ + + ]: 9075 : if (typevarphys == 'KEY') then
1583 [ - + ]: 9074 : ABI_CHECK(b2 /= 0, sjoin('Cannot find first " defining string for token:', token))
1584 [ - + ]: 9074 : ABI_CHECK(b3 == 0, sjoin('There are chars between token name and first " for token:', token))
1585 : : end if
1586 [ + + - + ]: 9075 : if (typevarphys == 'KEY' .or. (b2/=0.and.b3==0)) then
1587 : 9074 : b2 = b1 + b2 + 1
1588 : 9074 : b3 = index(string(b2:), '"')
1589 [ - + ]: 9074 : ABI_CHECK(b3 /= 0, sjoin('Cannot find second " defining string for token:', token))
1590 : 9074 : b3 = b3 + b2 - 2
1591 [ - + ]: 9074 : if ((b3 - b2 + 1) > len(key_value)) then
1592 : 0 : ABI_ERROR("Len of key_value too small to contain value parsed from file")
1593 : : end if
1594 [ + - + - ]: 9074 : key_value = adjustl(string(b2:b3))
1595 [ + - ]: 1 : else if (typevarphys == 'INT_OR_KEY') then
1596 : : ! Read the scalar that follows the blank
1597 : 1 : call inarray(b1,cs,dprarr,intarr,marr,narr,string,'INT')
1598 : : endif
1599 : :
1600 : : else
1601 : : ! Read the array (or eventual scalar) that follows the blank
1602 : 216076 : call inarray(b1,cs,dprarr,intarr,marr,narr,string,typevarphys)
1603 : : end if
1604 : :
1605 : : ! if this point is reached then data has been read in successfully
1606 : 225151 : tread = 1
1607 : :
1608 [ + + ]: 6108470 : else if(opttoken>=2) then
1609 : :
1610 : : ! write(std_out,*)' intagm : opttoken>=2 , token has been found, will read '
1611 [ - + + - : 2676 : ABI_MALLOC(dpr1,(narr))
+ - + - -
+ - + ]
1612 [ - + + - : 1784 : ABI_MALLOC(dpr2,(narr))
- + - + ]
1613 [ - + + - : 2676 : ABI_MALLOC(int1,(narr))
+ - + - -
+ - + ]
1614 [ - + + - : 1784 : ABI_MALLOC(int2,(narr))
- + - + ]
1615 : :
1616 : : ! Absolute location in string of blank which follows token//':':
1617 : 892 : b1=itoken_colon+cslen-1
1618 : 892 : call inarray(b1,cscolon,dpr1,int1,narr,narr,string,typevarphys)
1619 : :
1620 : : ! Initialise number even if the if series treat all cases.
1621 : 892 : number=1
1622 : : ! Define the number of the term in the series
1623 [ + + ]: 892 : if(opttoken==2)number=jdtset-1
1624 [ + + ]: 892 : if(opttoken==3)number=unities-1
1625 [ + + ]: 892 : if(opttoken==4)number=dozens-1
1626 : :
1627 : : ! Distinguish additive and multiplicative series
1628 [ + + ]: 892 : if(itoken_plus/=0)then
1629 : :
1630 : 882 : b1=itoken_plus+cslen-1
1631 : 882 : call inarray(b1,csplus,dpr2,int2,narr,narr,string,typevarphys)
1632 : :
1633 [ + + ]: 882 : if(typevar=='INT')then
1634 [ + + ]: 990 : intarr(1:narr)=int1(:)+int2(:)*number
1635 [ + - ]: 387 : else if(typevar=='DPR')then
1636 [ + + ]: 2188 : dprarr(1:narr)=dpr1(:)+dpr2(:)*number
1637 : : end if
1638 : :
1639 [ + - ]: 10 : else if(itoken_times/=0)then
1640 : :
1641 : 10 : b1=itoken_times+cslen-1
1642 : 10 : call inarray(b1,cstimes,dpr2,int2,narr,narr,string,typevarphys)
1643 [ - + ]: 10 : if(typevar=='INT')then
1644 [ # # ]: 0 : intarr(1:narr)=int1(:)*int2(:)**number
1645 [ + - ]: 10 : else if(typevar=='DPR')then
1646 [ + + ]: 20 : dprarr(1:narr)=dpr1(:)*dpr2(:)**number
1647 : : end if
1648 : :
1649 : : end if
1650 : :
1651 : 892 : tread = 1
1652 : :
1653 [ - + ]: 892 : ABI_FREE(dpr1)
1654 [ - + ]: 892 : ABI_FREE(dpr2)
1655 [ - + ]: 892 : ABI_FREE(int1)
1656 [ - + ]: 892 : ABI_FREE(int2)
1657 : : end if
1658 : :
1659 [ + + ]: 6333621 : if(present(ds_input)) ds_input = ds_input_
1660 : :
1661 : : !write(std_out,*) ' intagm : exit value tread=',tread
1662 : : !write(std_out,*) ' intarr =',intarr(1:narr)
1663 : : !write(std_out,*) ' dprarr =',dprarr(1:narr)
1664 : :
1665 [ - + ]: 6333621 : end subroutine intagm
1666 : : !!***
1667 : :
1668 : : !----------------------------------------------------------------------
1669 : :
1670 : : !!****f* m_parser/ingeo_img_1D
1671 : : !! NAME
1672 : : !! intagm_img_1D
1673 : : !!
1674 : : !! FUNCTION
1675 : : !! Read input file variables according to images path definition (1D array)
1676 : : !!
1677 : : !! This function is exposed through generic interface that allows to
1678 : : !! initialize some of the geometry variables in the case of "images".
1679 : : !! Set up: acell, scalecart, rprim, angdeg, xred, xcart, vel
1680 : : !! These variables can be defined for a set of images of the cell.
1681 : : !! They also can be be defined along a path (in the configuration space).
1682 : : !! The path must be defined with its first and last points, but also
1683 : : !! with intermediate points.
1684 : : !!
1685 : : !! INPUTS
1686 : : !! iimage=index of the current image
1687 : : !! jdtset=number of the dataset looked for
1688 : : !! lenstr=actual length of the input string
1689 : : !! nimage=number of images
1690 : : !! size1,size2, ...: size of array to be read (dp_data)
1691 : : !! string=character string containing 'tags' and data.
1692 : : !! token=character string for tagging the data to be read in input string
1693 : : !! typevarphys= variable type (for dimensionality purposes)
1694 : : !!
1695 : : !! SIDE EFFECTS
1696 : : !! dp_data(size1,size2,...)=data to be read (double precision)
1697 : : !! tread_ok=flag to be set to 1 if the data have been found in input string
1698 : : !!
1699 : : !! NOTES
1700 : : !! The routine is a generic interface calling subroutine according to the
1701 : : !! number of arguments of the variable to be read
1702 : : !!
1703 : : !! SOURCE
1704 : :
1705 : 54519 : subroutine intagm_img_1D(dp_data,iimage,jdtset,lenstr,nimage,size1,string,token,tread_ok,typevarphys)
1706 : :
1707 : : !Arguments ------------------------------------
1708 : : !scalars
1709 : : integer,intent(in) :: iimage,jdtset,lenstr,nimage,size1
1710 : : integer,intent(inout) :: tread_ok
1711 : : real(dp),intent(inout) :: dp_data(size1)
1712 : : character(len=*),intent(in) :: typevarphys
1713 : : character(len=*),intent(in) :: token
1714 : : character(len=*),intent(in) :: string
1715 : :
1716 : : !Local variables-------------------------------
1717 : : !scalars
1718 : : integer :: iimage_after,iimage_before,marr,tread_after,tread_before,tread_current
1719 : : real(dp) :: alpha
1720 : : character(len=10) :: stringimage
1721 : 54519 : character(len=3*len(token)+10) :: token_img
1722 : : !arrays
1723 : 54519 : integer, allocatable :: intarr(:)
1724 : 54519 : real(dp),allocatable :: dprarr(:),dp_data_after(:),dp_data_before(:)
1725 : : ! *************************************************************************
1726 : :
1727 : : !Nothing to do in case of a single image
1728 [ + + ]: 54519 : if (nimage<=1) return
1729 : :
1730 : 2472 : marr=size1
1731 [ - + + - : 7416 : ABI_MALLOC(intarr,(marr))
+ - + - -
+ - + ]
1732 [ - + + - : 7416 : ABI_MALLOC(dprarr,(marr))
+ - + - -
+ - + ]
1733 : :
1734 : : !First, try to read data for current image
1735 : 2472 : tread_current=0
1736 : 2472 : write(stringimage,'(i10)') iimage
1737 [ + - + - : 2472 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
+ - ]
1738 : 2472 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_current,typevarphys)
1739 [ + + ]: 2472 : if (tread_current==1)then
1740 [ + + ]: 296 : dp_data(1:size1)=dprarr(1:size1)
1741 : 15 : tread_ok=1
1742 : : end if
1743 [ + + + + ]: 2472 : if (tread_current==0.and.iimage==nimage) then
1744 : : ! If the image is the last one, try to read data for last image (_lastimg)
1745 [ + - + - ]: 393 : token_img=trim(token)//'_lastimg'
1746 : 393 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_current,typevarphys)
1747 [ + + ]: 393 : if (tread_current==1)then
1748 [ + + ]: 28 : dp_data(1:size1)=dprarr(1:size1)
1749 : 7 : tread_ok=1
1750 : : end if
1751 : : end if
1752 : :
1753 [ + + ]: 2472 : if (tread_current==0) then
1754 : :
1755 : : ! The current image is not directly defined in the input string
1756 [ - + + - : 4900 : ABI_MALLOC(dp_data_before,(size1))
- + - + ]
1757 [ - + + - : 4900 : ABI_MALLOC(dp_data_after,(size1))
- + - + ]
1758 : :
1759 : : ! Find the nearest previous defined image
1760 : 2450 : tread_before=0;iimage_before=iimage
1761 [ + + ]: 9596 : do while (iimage_before>1.and.tread_before/=1)
1762 : 7146 : iimage_before=iimage_before-1
1763 : 7146 : write(stringimage,'(i10)') iimage_before
1764 [ + - + - : 7146 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
+ - ]
1765 : 7146 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_before,typevarphys)
1766 [ + + + + ]: 9602 : if (tread_before==1) dp_data_before(1:size1)=dprarr(1:size1)
1767 : : end do
1768 [ + + ]: 2450 : if (tread_before==0) then
1769 : 2448 : iimage_before=1
1770 [ + + ]: 7029 : dp_data_before(1:size1)=dp_data(1:size1)
1771 : : end if
1772 : :
1773 : : ! Find the nearest following defined image
1774 : 2450 : tread_after=0;iimage_after=iimage
1775 [ + + + + ]: 9633 : do while (iimage_after<nimage.and.tread_after/=1)
1776 : 7183 : iimage_after=iimage_after+1
1777 : 7183 : write(stringimage,'(i10)') iimage_after
1778 [ + - + - : 7183 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
+ - ]
1779 : 7183 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_after,typevarphys)
1780 [ + + + + ]: 7269 : if (tread_after==1) dp_data_after(1:size1)=dprarr(1:size1)
1781 [ + + + + ]: 9633 : if (tread_after==0.and.iimage_after==nimage) then
1782 [ + - + - ]: 2057 : token_img=trim(token)//'_lastimg'
1783 : 2057 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_after,typevarphys)
1784 [ + + + + ]: 2153 : if (tread_after==1) dp_data_after(1:size1)=dprarr(1:size1)
1785 : : end if
1786 : : end do
1787 [ + + ]: 2450 : if (tread_after==0) then
1788 : 2411 : iimage_after=nimage
1789 [ + + ]: 6816 : dp_data_after(1:size1)=dp_data(1:size1)
1790 : : end if
1791 : :
1792 : : ! Interpolate image data
1793 [ + + + + ]: 2450 : if (tread_before==1.or.tread_after==1) then
1794 : 39 : alpha=real(iimage-iimage_before,dp)/real(iimage_after-iimage_before,dp)
1795 [ + + ]: 221 : dp_data(1:size1)=dp_data_before(1:size1) + alpha*(dp_data_after(1:size1)-dp_data_before(1:size1))
1796 : 39 : tread_ok=1
1797 : : end if
1798 : :
1799 [ - + ]: 2450 : ABI_FREE(dp_data_before)
1800 [ - + ]: 2450 : ABI_FREE(dp_data_after)
1801 : : end if
1802 : :
1803 [ - + ]: 2472 : ABI_FREE(intarr)
1804 [ - + ]: 2472 : ABI_FREE(dprarr)
1805 : :
1806 : : end subroutine intagm_img_1D
1807 : : !!***
1808 : :
1809 : : !----------------------------------------------------------------------
1810 : :
1811 : : !!****f* m_parser/ingeo_img_2D
1812 : : !! NAME
1813 : : !! intagm_img_2D
1814 : : !!
1815 : : !! FUNCTION
1816 : : !! Read input file variables according to images path definition (2D array)
1817 : : !!
1818 : : !! INPUTS
1819 : : !!
1820 : : !! SOURCE
1821 : :
1822 : 36284 : subroutine intagm_img_2D(dp_data,iimage,jdtset,lenstr,nimage,size1,size2,string,token,tread_ok,typevarphys)
1823 : :
1824 : : !Arguments ------------------------------------
1825 : : !scalars
1826 : : integer,intent(in) :: iimage,jdtset,lenstr,nimage,size1,size2
1827 : : integer,intent(inout) :: tread_ok
1828 : : real(dp),intent(inout) :: dp_data(size1,size2)
1829 : : character(len=*),intent(in) :: typevarphys
1830 : : character(len=*),intent(in) :: token
1831 : : character(len=*),intent(in) :: string
1832 : :
1833 : : !Local variables-------------------------------
1834 : : !scalars
1835 : : integer :: iimage_after,iimage_before,marr,tread_after,tread_before,tread_current
1836 : : real(dp) :: alpha
1837 : : character(len=10) :: stringimage
1838 : 36284 : character(len=3*len(token)+10) :: token_img
1839 : : !arrays
1840 : 36284 : integer, allocatable :: intarr(:)
1841 : 36284 : real(dp),allocatable :: dprarr(:),dp_data_after(:,:),dp_data_before(:,:)
1842 : : ! *************************************************************************
1843 : :
1844 : : !Nothing to do in case of a single image
1845 [ + + ]: 36284 : if (nimage<=1) return
1846 : :
1847 : 1558 : marr=size1*size2
1848 [ - + + - : 4674 : ABI_MALLOC(intarr,(marr))
+ - + - -
+ - + ]
1849 [ - + + - : 4674 : ABI_MALLOC(dprarr,(marr))
+ - + - -
+ - + ]
1850 : :
1851 : : !First, try to read data for current image
1852 : 1558 : tread_current=0
1853 : 1558 : write(stringimage,'(i10)') iimage
1854 [ + - + - : 1558 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
+ - ]
1855 : 1558 : call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr), token_img,tread_current,typevarphys)
1856 [ + + ]: 1558 : if (tread_current==1)then
1857 [ + + ]: 9 : dp_data(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
1858 : 3 : tread_ok=1
1859 : : end if
1860 [ + + + + ]: 1558 : if (tread_current==0.and.iimage==nimage) then
1861 : : ! In the image is the last one, try to read data for last image (_lastimg)
1862 [ + - + - ]: 251 : token_img=trim(token)//'_lastimg'
1863 : 251 : call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr), token_img,tread_current,typevarphys)
1864 [ + + ]: 251 : if (tread_current==1)then
1865 [ + + ]: 120 : dp_data(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
1866 : 40 : tread_ok=1
1867 : : end if
1868 : : end if
1869 : :
1870 [ + + ]: 1558 : if (tread_current==0) then
1871 : :
1872 : : ! The current image is not directly defined in the input string
1873 [ - + + - : 6060 : ABI_MALLOC(dp_data_before,(size1,size2))
- + + - +
- + - - +
- + ]
1874 [ - + + - : 4545 : ABI_MALLOC(dp_data_after,(size1,size2))
- + + - -
+ - + ]
1875 : :
1876 : : ! Find the nearest previous defined image
1877 : 1515 : tread_before=0;iimage_before=iimage
1878 [ + + ]: 5809 : do while (iimage_before>1.and.tread_before/=1)
1879 : 4294 : iimage_before=iimage_before-1
1880 : 4294 : write(stringimage,'(i10)') iimage_before
1881 [ + - + - : 4294 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
+ - ]
1882 : 4294 : call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr), token_img,tread_before,typevarphys)
1883 [ + - - - : 5809 : if (tread_before==1) dp_data_before(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
- - - - ]
1884 : : end do
1885 [ + - ]: 1515 : if (tread_before==0) then
1886 : 1515 : iimage_before=1
1887 [ + + + + ]: 18111 : dp_data_before(1:size1,1:size2)=dp_data(1:size1,1:size2)
1888 : : end if
1889 : :
1890 : : ! Find the nearest following defined image
1891 : 1515 : tread_after=0;iimage_after=iimage
1892 [ + + + + ]: 6042 : do while (iimage_after<nimage.and.tread_after/=1)
1893 : 4527 : iimage_after=iimage_after+1
1894 : 4527 : write(stringimage,'(i10)') iimage_after
1895 [ + - + - : 4527 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
+ - ]
1896 : 4527 : call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr), token_img,tread_after,typevarphys)
1897 [ + + + + : 4532 : if (tread_after==1) dp_data_after(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
+ + + + ]
1898 [ + + + + ]: 6042 : if (tread_after==0.and.iimage_after==nimage) then
1899 [ + - + - ]: 1303 : token_img=trim(token)//'_lastimg'
1900 : 1303 : call intagm(dprarr,intarr,jdtset,marr,size1*size2,string(1:lenstr), token_img,tread_after,typevarphys)
1901 [ + + + + : 3872 : if (tread_after==1) dp_data_after(1:size1,1:size2)=reshape( dprarr(1:size1*size2),(/size1,size2/) )
+ + + + ]
1902 : : end if
1903 : : end do
1904 [ + + ]: 1515 : if (tread_after==0) then
1905 : 1282 : iimage_after=nimage
1906 [ + + + + ]: 15770 : dp_data_after(1:size1,1:size2)=dp_data(1:size1,1:size2)
1907 : : end if
1908 : :
1909 : : ! Interpolate image data
1910 [ + - + + ]: 1515 : if (tread_before==1.or.tread_after==1) then
1911 : 233 : alpha=real(iimage-iimage_before,dp)/real(iimage_after-iimage_before,dp)
1912 : : dp_data(1:size1,1:size2)=dp_data_before(1:size1,1:size2) &
1913 [ + + + + ]: 2341 : +alpha*(dp_data_after(1:size1,1:size2)-dp_data_before(1:size1,1:size2))
1914 : 233 : tread_ok=1
1915 : : end if
1916 : :
1917 [ - + ]: 1515 : ABI_FREE(dp_data_before)
1918 [ - + ]: 1515 : ABI_FREE(dp_data_after)
1919 : : end if
1920 : :
1921 [ - + ]: 1558 : ABI_FREE(intarr)
1922 [ - + ]: 1558 : ABI_FREE(dprarr)
1923 : :
1924 : : end subroutine intagm_img_2D
1925 : : !!***
1926 : :
1927 : : !!****f* m_parser/inarray
1928 : : !! NAME
1929 : : !! inarray
1930 : : !!
1931 : : !! FUNCTION
1932 : : !! Read the array of narr numbers located immediately after a specified blank in a string of character.
1933 : : !! Might read instead one word, after the specified blank. Takes care of multipliers.
1934 : : !!
1935 : : !! INPUTS
1936 : : !! cs=character token (starts with a blank)
1937 : : !! marr=dimension of the intarr and dprarr arrays, as declared in the
1938 : : !! calling subroutine.
1939 : : !! narr=actual size of array to be read in (if typevarphys='KEY', only narr=1 is allowed)
1940 : : !! string=character string containing the data.
1941 : : !! typevarphys=variable type (might indicate the physical meaning of
1942 : : !! for dimensionality purposes)
1943 : : !! 'INT' => integer
1944 : : !! 'DPR' => real(dp) (no special treatment)
1945 : : !! 'LEN' => real(dp) (expect a "length", identify bohr, au, nm or angstrom,
1946 : : !! and return in au -atomic units=bohr- )
1947 : : !! 'ENE' => real(dp) (expect a "energy", identify Ha, hartree, eV, meV, Ry, Rydberg)
1948 : : !! 'BFI' => real(dp) (expect a "magnetic field", identify T, Tesla)
1949 : : !! 'TIM' => real(dp) (expect a "time", identify S, Second)
1950 : : !! 'LOG' => integer, but read logical variable T,F,.true., or .false.
1951 : : !!
1952 : : !! OUTPUT
1953 : : !! intarr(1:narr), dprarr(1:narr)
1954 : : !! integer or real(dp) arrays, respectively into which data is read. Use these arrays even for scalars.
1955 : : !! errcod: if /= 0, then something went wrong in subroutine "inread"
1956 : : !!
1957 : : !! SIDE EFFECT
1958 : : !! b1=absolute location in string of blank which follows the token (will be modified in the execution)
1959 : : !!
1960 : : !! SOURCE
1961 : :
1962 : 217870 : subroutine inarray(b1,cs,dprarr,intarr,marr,narr,string,typevarphys)
1963 : :
1964 : : !Arguments ------------------------------------
1965 : : !scalars
1966 : : integer,intent(in) :: marr,narr
1967 : : integer,intent(inout) :: b1
1968 : : character(len=*),intent(in) :: string
1969 : : character(len=*),intent(in) :: typevarphys
1970 : : character(len=*),intent(in) :: cs
1971 : : !arrays
1972 : : integer,intent(inout) :: intarr(marr)
1973 : : real(dp),intent(out) :: dprarr(marr)
1974 : :
1975 : : !Local variables-------------------------------
1976 : : character(len=1), parameter :: blank=' '
1977 : : !scalars
1978 : : integer :: asciichar,b2,errcod,ii,integ,istar,nrep,strln
1979 : : real(dp) :: factor,real8
1980 : : character(len=3) :: typevar
1981 : : character(len=500*4) :: msg
1982 : : ! *************************************************************************
1983 : :
1984 : : ! write(std_out,'(5a)' )' inarray: token: ',trim(cs),' "',cs(1:6),'"'
1985 : : ! if(trim(cs)==' UPAWU1')then
1986 : : ! write(std_out,'(2a)' )' string: ',trim(string(b1:))
1987 : : ! write(std_out,'(a,i0)' )' narr: ',narr
1988 : : ! write(std_out,'(2a)' )' typevarphys: ',typevarphys
1989 : : ! endif
1990 : :
1991 : 217870 : ii = 0
1992 : 217870 : typevar='INT'
1993 [ + + ]: 217870 : if(typevarphys=='LOG') typevar='INT'
1994 : : if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. &
1995 [ + + + + : 217870 : typevarphys=='BFI' .or. typevarphys=='TIM') typevar='DPR'
+ + + + +
+ ]
1996 : :
1997 : 217870 : strln=len_trim(string)
1998 : :
1999 [ + + ]: 711165 : do while (ii < narr)
2000 : :
2001 : : ! Relative location of next blank after data
2002 : : ! b1 is the last character of the string
2003 [ - + ]: 493295 : if (b1>=strln) exit
2004 : :
2005 : 493295 : b2 = index(string(b1+1:),blank)
2006 : : ! If no second blank is found put the second blank just beyond strln
2007 [ - + ]: 493295 : if(b2==0) b2=strln-b1+1
2008 : :
2009 : : ! nrep tells how many times to repeat input in array:
2010 : 493295 : nrep=1
2011 : :
2012 : : ! Check for *, meaning repeated input (as in list-directed input):
2013 : 493295 : istar=index(string(b1+1:b1+b2-1),'*')
2014 [ + + ]: 493295 : if (istar/=0) then
2015 [ + + ]: 14656 : if (istar==1) then ! Simply fills the array with the data, repeated as many times as needed
2016 : 1317 : nrep=narr-ii
2017 : 1317 : errcod=0
2018 : : else
2019 : 13339 : call inread(string(b1+1:b1+istar-1),istar-1,'INT',nrep,real8,errcod)
2020 : : end if
2021 [ - + ]: 14656 : if (errcod/=0) exit
2022 : : ! Shift starting position of input field:
2023 : 14656 : b1=b1+istar
2024 : 14656 : b2=b2-istar
2025 : : end if
2026 : :
2027 : : ! Read data internally by calling inread at entry ini:
2028 : 493295 : call inread(string(b1+1:b1+b2-1),b2-1,typevarphys,integ,real8,errcod)
2029 [ - + ]: 493295 : if (errcod/=0) exit
2030 : :
2031 : : ! Allow for list-directed input with repeat number nrep:
2032 [ + + ]: 493295 : if(typevar=='INT')then
2033 [ + + ]: 546457 : intarr(1+ii:min(nrep+ii,narr))=integ
2034 [ + - ]: 233495 : else if(typevar=='DPR')then
2035 [ + + ]: 513937 : dprarr(1+ii:min(nrep+ii,narr))=real8
2036 : : else
2037 : 0 : ABI_BUG('Disallowed typevar: '//typevar)
2038 : : end if
2039 : 493295 : ii=min(ii+nrep,narr)
2040 : :
2041 : : ! Find new absolute location of next element of array:
2042 : 493295 : b1=b1+b2
2043 : :
2044 : : end do ! while (ii<narr). Note "exit" instructions within loop.
2045 : :
2046 [ - + ]: 217870 : if (errcod /= 0) then
2047 : : write(msg, '(5a,i0,14a)' ) &
2048 : 0 : 'An error occurred reading data for keyword `',trim(cs),'`,',ch10,&
2049 : 0 : 'looking for ',narr,' elements.', ch10, &
2050 [ # # ]: 0 : 'There is a problem with the input string:',ch10,ch10, trim(string(b1:)), ch10, ch10, &
2051 : 0 : 'Maybe a disagreement between the declared dimension of the array,',ch10,&
2052 : 0 : 'and the number of items provided. ',ch10,&
2053 : 0 : 'Action: check the documentation, correct your input file and especially the keyword: ', trim(cs)
2054 : 0 : ABI_ERROR(msg)
2055 : : end if
2056 : :
2057 : : ! In case of 'LEN', 'ENE', 'BFI', or 'TIM', try to identify the unit
2058 [ + + + + : 217870 : if (typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI' .or. typevarphys=='TIM') then
+ + + + ]
2059 : 30 : do
2060 : : ! Relative location of next blank after data
2061 [ + + ]: 23804 : if(b1>=strln)exit ! b1 is the last character of the string
2062 : 23781 : b2=index(string(b1+1:),blank)
2063 : : ! If no second blank is found put the second blank just beyond strln
2064 [ - + ]: 23781 : 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 : 23781 : asciichar=iachar(string(b1+1:b1+1))
2077 [ + + ]: 217900 : if(asciichar<48 .or. asciichar>57)then
2078 : 23751 : factor=one
2079 [ + + + - ]: 23751 : if(typevarphys=='LEN' .and. b2>=3)then
2080 [ + + ]: 8711 : if(string(b1+1:b1+6)=='ANGSTR')then
2081 : : factor=one/Bohr_Ang
2082 [ + + ]: 8024 : else if(string(b1+1:b1+3)=='NM ')then
2083 : 23751 : factor=ten/Bohr_Ang
2084 : : end if
2085 [ + + + + ]: 15040 : else if(typevarphys=='ENE' .and. b2>=3)then
2086 [ + + ]: 14753 : if(string(b1+1:b1+3)=='RY ')then
2087 : : factor=half
2088 [ + - ]: 14711 : else if(string(b1+1:b1+3)=='RYD')then
2089 : : factor=half
2090 [ + + ]: 14711 : else if(string(b1+1:b1+3)=='EV ')then
2091 : : factor=one/Ha_eV
2092 [ + + ]: 13987 : else if(string(b1+1:b1+4)=='MEV ')then
2093 : : factor=one/Ha_meV
2094 [ + - ]: 13984 : else if(string(b1+1:b1+7)=='Kelvin ')then
2095 : 23751 : factor=kb_HaK
2096 : : end if
2097 [ + + + - ]: 287 : else if(typevarphys=='ENE' .and. b2>=2)then
2098 [ - + ]: 160 : if(string(b1+1:b1+2)=='K ') factor=kb_HaK
2099 [ + + + - ]: 127 : else if(typevarphys=='BFI' .and. b2>=2)then
2100 [ + - + - ]: 14 : if(string(b1+1:b1+2)=='T ' .or. string(b1+1:b1+2)=='TE') factor=BField_Tesla
2101 [ - + - + ]: 113 : else if (typevarphys=='TIM' .and. b2>=2) then
2102 [ + - + + ]: 113 : if(string(b1+1:b1+2)=='SE' .or. string(b1+1:b1+2)=='S ') then
2103 : : factor=one/Time_Sec
2104 [ + - ]: 109 : else if(string(b1+1:b1+2)=='FS') then
2105 : : factor=tol15/Time_Sec
2106 [ + - ]: 109 : else if(string(b1+1:b1+2)=='AS') then
2107 : 23751 : factor=tol17/Time_Sec
2108 : : endif
2109 : : endif
2110 : :
2111 [ + + ]: 69783 : dprarr(1:narr)=dprarr(1:narr)*factor
2112 : : exit
2113 : : else
2114 : : ! A digit has been observed, go to the next sequence
2115 : 30 : b1=b1+b2
2116 : : cycle
2117 : : end if
2118 : :
2119 : : end do
2120 : : end if
2121 : :
2122 : : !DEBUG
2123 : : ! if(trim(cs)==' UPAWU1')then
2124 : : ! write(std_out,*)' dprarr(1:narr)==',dprarr(1:narr) stop
2125 : : ! endif
2126 : : !write(std_out,*)' inarray : exit '
2127 : : !ENDDEBUG
2128 : :
2129 : 217870 : end subroutine inarray
2130 : : !!***
2131 : :
2132 : : !!****f* m_parser/importxyz
2133 : : !! NAME
2134 : : !! importxyz
2135 : : !!
2136 : : !! FUNCTION
2137 : : !! Examine the input string, to see whether data from xyz
2138 : : !! file(s) has to be incorporated.
2139 : : !! For each such xyz file, translate the relevant
2140 : : !! information into intermediate input variables compatible
2141 : : !! with the usual ABINIT formatting, then append it
2142 : : !! to the input string.
2143 : : !!
2144 : : !! INPUTS
2145 : : !! string_raw*(strln)=raw string of character from input file (with original case)
2146 : : !! strln=maximal number of character of string, as declared in the calling routine
2147 : : !!
2148 : : !! OUTPUT
2149 : : !!
2150 : : !! SIDE EFFECTS
2151 : : !! lenstr=actual number of character in string
2152 : : !! string_upper*(strln)=string of character
2153 : : !! the string (with upper case) from the input file, to which the xyz data are appended to it
2154 : : !!
2155 : : !! SOURCE
2156 : :
2157 : 2348 : subroutine importxyz(lenstr,string_raw,string_upper,strln)
2158 : :
2159 : : !Arguments ------------------------------------
2160 : : !scalars
2161 : : integer,intent(in) :: strln
2162 : : integer,intent(inout) :: lenstr
2163 : : character(len=*),intent(in) :: string_raw
2164 : : character(len=*),intent(inout) :: string_upper
2165 : :
2166 : : !Local variables-------------------------------
2167 : : character :: blank=' '
2168 : : !scalars
2169 : : integer :: dtset_len,ixyz,ii,index_already_done,index_xyz_fname
2170 : : integer :: index_xyz_fname_end,index_xyz_token,kk
2171 : : character(len=2) :: dtset_char
2172 : : character(len=500) :: msg
2173 : : character(len=fnlen) :: xyz_fname
2174 : : !************************************************************************
2175 : :
2176 : 2348 : index_already_done=1
2177 : 2348 : ixyz=0
2178 : :
2179 : : do
2180 : : ! Infinite do-loop, to identify the presence of the xyzFILE token
2181 : 2350 : index_xyz_token=index(string_upper(index_already_done:lenstr),"XYZFILE")
2182 [ + + ]: 2350 : if(index_xyz_token==0)exit
2183 : :
2184 : 2 : ixyz=ixyz+1
2185 [ + - ]: 2 : if(ixyz==1)then
2186 [ + - + + ]: 162 : write(msg,'(80a)')('=',ii=1,80)
2187 : 2 : call wrtout(ab_out,msg)
2188 : : end if
2189 : :
2190 : : ! The xyzFILE token has been identified
2191 : 2 : index_xyz_token=index_already_done+index_xyz_token-1
2192 : :
2193 : : ! Find the related dataset tag, and length
2194 : 2 : dtset_char=string_upper(index_xyz_token+7:index_xyz_token+8)
2195 [ + - ]: 2 : if(dtset_char(1:1)==blank)dtset_char(2:2)=blank
2196 : 2 : dtset_len=len_trim(dtset_char)
2197 : :
2198 : : ! Find the name of the xyz file
2199 : 2 : index_xyz_fname=index_xyz_token+8+dtset_len
2200 : 2 : index_xyz_fname_end=index(string_upper(index_xyz_fname:lenstr),blank)
2201 : :
2202 [ - + ]: 2 : if(index_xyz_fname_end ==0 )then
2203 : : write(msg, '(5a,i4,2a)' )&
2204 : 0 : 'Could not find the name of the xyz file.',ch10,&
2205 : 0 : 'index_xyz_fname_end should be non-zero, while it is :',ch10,&
2206 : 0 : 'index_xyz_fname_end=',index_xyz_fname_end,ch10,&
2207 : 0 : 'Action: check the filename that was provided after the XYZFILE input variable keyword.'
2208 : 0 : ABI_ERROR(msg)
2209 : : end if
2210 : :
2211 : : ! this chops off the space or the quote?
2212 : 2 : index_xyz_fname_end=index_xyz_fname_end+index_xyz_fname-1
2213 : :
2214 : 2 : index_already_done=index_xyz_fname_end
2215 : :
2216 : : ! Initialize xyz_fname to a blank line
2217 [ + + ]: 802 : xyz_fname=repeat(blank,fnlen)
2218 [ + - ]: 2 : xyz_fname=string_raw(index_xyz_fname:index_xyz_fname_end-1)
2219 : :
2220 : 2 : write(msg, '(3a)') ch10, ' importxyz : Identified token XYZFILE, referring to file ',trim(xyz_fname)
2221 [ + + ]: 6 : call wrtout([std_out, ab_out],msg)
2222 : :
2223 : : ! Append the data from the xyz file to the string, and update the length of the string
2224 : 2 : call append_xyz(dtset_char,lenstr,string_upper,xyz_fname,strln)
2225 : :
2226 : : ! erase the file name from string_upper
2227 [ - + + - ]: 2350 : string_upper(index_xyz_fname:index_xyz_fname_end-1) = blank
2228 : : end do
2229 : :
2230 : :
2231 [ + + ]: 2348 : if (index_already_done > 1) then
2232 : : ! Initialize xyz_fname to a blank line
2233 [ + + ]: 802 : xyz_fname=repeat(blank,fnlen)
2234 : 2 : call append_xyz("-1",lenstr,string_upper,xyz_fname,strln)
2235 : : end if
2236 : :
2237 [ + + ]: 2348 : if(ixyz/=0)then
2238 : 2 : call incomprs(string_upper,lenstr)
2239 : : ! A blank is needed at the beginning of the string
2240 [ + + ]: 1436 : do kk=lenstr,1,-1
2241 : 1436 : string_upper(kk+1:kk+1)=string_upper(kk:kk)
2242 : : end do
2243 : 2 : string_upper(1:1)=blank
2244 : 2 : lenstr=lenstr+1
2245 [ + - + + ]: 162 : write(msg,'(a,80a,a)')ch10,('=',ii=1,80),ch10
2246 : 2 : call wrtout(ab_out,msg)
2247 : : end if
2248 : :
2249 : 2348 : end subroutine importxyz
2250 : : !!***
2251 : :
2252 : : !!****f* m_parser/append_xyz
2253 : : !! NAME
2254 : : !! append_xyz
2255 : : !!
2256 : : !! FUNCTION
2257 : : !! Translate the data from a xyz file (xyz_fname),
2258 : : !! and add it at the end of the usual ABINIT input data string (string),
2259 : : !! taking into account the dtset (dtset_char)
2260 : : !!
2261 : : !! INPUTS
2262 : : !! dtset_char*2=possible dtset label
2263 : : !! xyz_fname = name of the xyz file
2264 : : !! strln=maximal number of characters of string, as declared in the calling routine
2265 : : !!
2266 : : !! OUTPUT
2267 : : !!
2268 : : !! SIDE EFFECTS
2269 : : !! lenstr=actual number of characters in string
2270 : : !! string*(strln)=string of characters (upper case) to which the xyz data are appended
2271 : : !!
2272 : : !! SOURCE
2273 : :
2274 : 4 : subroutine append_xyz(dtset_char,lenstr,string,xyz_fname,strln)
2275 : :
2276 : : !Arguments ------------------------------------
2277 : : !scalars
2278 : : integer,intent(in) :: strln
2279 : : integer,intent(inout) :: lenstr
2280 : : character(len=2),intent(in) :: dtset_char
2281 : : character(len=fnlen),intent(in) :: xyz_fname
2282 : : character(len=strln),intent(inout) :: string
2283 : :
2284 : : !Local variables-------------------------------
2285 : : character :: blank=' '
2286 : : !scalars
2287 : : integer :: unitxyz, iatom, natom, mu
2288 : : integer :: lenstr_new
2289 : : integer :: lenstr_old
2290 : : integer :: ntypat
2291 : : real(dp) :: znucl
2292 : : character(len=5) :: string5
2293 : : character(len=20) :: string20
2294 : : character(len=500) :: msg
2295 : : type(atomdata_t) :: atom
2296 : : !arrays
2297 : 4 : real(dp),allocatable :: xcart(:,:)
2298 : : integer, save :: atomspecies(200) = 0
2299 : : character(len=500), save :: znuclstring = ""
2300 : 4 : character(len=2),allocatable :: elementtype(:)
2301 : : !************************************************************************
2302 : :
2303 : 4 : lenstr_new=lenstr
2304 : :
2305 [ + + ]: 4 : if (dtset_char == "-1") then
2306 : : ! write znucl
2307 : 2 : lenstr_old=lenstr_new
2308 : 2 : lenstr_new=lenstr_new+7+len_trim(znuclstring)+1
2309 [ + - - + ]: 2 : string(lenstr_old+1:lenstr_new)=" ZNUCL"//blank//trim(znuclstring)//blank
2310 : :
2311 : : ! write ntypat
2312 [ + + ]: 402 : ntypat = sum(atomspecies)
2313 : 2 : write(string20,'(i10)') ntypat
2314 : 2 : lenstr_old=lenstr_new
2315 : 2 : lenstr_new=lenstr_new+8+len_trim(string20)+1
2316 [ + - - + ]: 2 : string(lenstr_old+1:lenstr_new)=" NTYPAT"//blank//trim(string20)//blank
2317 : :
2318 : : return
2319 : : end if
2320 : :
2321 : : ! open file with xyz data
2322 [ - + ]: 2 : if (open_file(xyz_fname, msg, newunit=unitxyz, status="unknown") /= 0) then
2323 : 0 : ABI_ERROR(msg)
2324 : : end if
2325 : 2 : write(msg, '(3a)')' importxyz : Opened file ',trim(xyz_fname),'; content stored in string_xyz'
2326 : 2 : call wrtout(std_out,msg)
2327 : :
2328 : : ! check number of atoms is correct
2329 : 2 : read(unitxyz,*) natom
2330 : :
2331 : 2 : write(string5,'(i5)')natom
2332 : 2 : lenstr_old=lenstr_new
2333 : 2 : lenstr_new=lenstr_new+7+len_trim(dtset_char)+1+5
2334 [ + - - + ]: 2 : string(lenstr_old+1:lenstr_new)=" _NATOM"//trim(dtset_char)//blank//string5
2335 : :
2336 [ - + + - : 6 : ABI_MALLOC(xcart,(3,natom))
+ - + - -
+ - + ]
2337 [ - + + - : 4 : ABI_MALLOC(elementtype,(natom))
+ - - + -
+ ]
2338 : :
2339 : : ! read dummy line
2340 : 2 : read(unitxyz,*)
2341 : :
2342 : : ! read atomic types and positions
2343 [ + + ]: 12 : do iatom = 1, natom
2344 : 10 : read(unitxyz,*) elementtype(iatom), xcart(:,iatom)
2345 [ + + ]: 40 : xcart(:,iatom)=xcart(:,iatom)/Bohr_Ang
2346 : : ! extract znucl for each atom type
2347 : 10 : call atomdata_from_symbol(atom,elementtype(iatom))
2348 : 10 : znucl = atom%znucl
2349 [ - + ]: 10 : if (znucl > 200) then
2350 : : write (msg,'(5a)')&
2351 : 0 : 'found element beyond Z=200 ', ch10,&
2352 : 0 : 'Solution: increase size of atomspecies in append_xyz', ch10
2353 : 0 : ABI_ERROR(msg)
2354 : : end if
2355 : : ! found a new atom type
2356 [ + + ]: 10 : if (atomspecies(int(znucl)) == 0) then
2357 : 2 : write(string20,'(f10.2)') znucl
2358 [ + - ]: 2 : znuclstring = trim(znuclstring) // " " // trim(string20) // " "
2359 : : end if
2360 : 22 : atomspecies(int(znucl)) = 1
2361 : : end do
2362 : 2 : close (unitxyz)
2363 : :
2364 : :
2365 : : !Write the element types
2366 : 2 : lenstr_old=lenstr_new
2367 : 2 : lenstr_new=lenstr_new+7+len_trim(dtset_char)+1
2368 [ + - - + ]: 2 : string(lenstr_old+1:lenstr_new)=" _TYPAX"//trim(dtset_char)//blank
2369 [ + + ]: 12 : do iatom=1,natom
2370 : 10 : lenstr_old=lenstr_new
2371 : 10 : lenstr_new=lenstr_new+3
2372 : 12 : string(lenstr_old+1:lenstr_new)=elementtype(iatom)//blank
2373 : : end do
2374 : 2 : lenstr_old=lenstr_new
2375 : 2 : lenstr_new=lenstr_new+3
2376 : 2 : string(lenstr_old+1:lenstr_new)="XX " ! end card for TYPAX
2377 : :
2378 : : !Write the coordinates
2379 : 2 : lenstr_old=lenstr_new
2380 : 2 : lenstr_new=lenstr_new+8+len_trim(dtset_char)+1
2381 [ + - + - ]: 2 : string(lenstr_old+1:lenstr_new)=" _XCART"//trim(dtset_char)//blank
2382 : :
2383 [ + + ]: 12 : do iatom=1,natom
2384 [ + + ]: 42 : do mu=1,3
2385 : 30 : write(string20,'(f20.12)')xcart(mu,iatom)
2386 : 30 : lenstr_old=lenstr_new
2387 : 30 : lenstr_new=lenstr_new+20
2388 : 40 : string(lenstr_old+1:lenstr_new)=string20
2389 : : end do
2390 : : end do
2391 : :
2392 [ - + ]: 2 : ABI_FREE(elementtype)
2393 [ - + ]: 2 : ABI_FREE(xcart)
2394 : :
2395 : : !Check the length of the string
2396 [ - + ]: 2 : if(lenstr_new>strln)then
2397 : : write(msg,'(3a)')&
2398 : 0 : 'The maximal size of the input variable string has been exceeded.',ch10,&
2399 : 0 : 'The use of a xyz file is more character-consuming than the usual input file. Sorry.'
2400 : 0 : ABI_BUG(msg)
2401 : : end if
2402 : :
2403 : : !Update the length of the string
2404 : 2 : lenstr=lenstr_new
2405 : :
2406 : : end subroutine append_xyz
2407 : : !!***
2408 : :
2409 : : !!****f* m_parser/chkdpr
2410 : : !! NAME
2411 : : !! chkdpr
2412 : : !!
2413 : : !! FUNCTION
2414 : : !! Checks the value of an input real(dp) variable, and
2415 : : !! write a sophisticated error message when it is erroneous.
2416 : : !! A few conditions might have been checked before calling chkdpr,
2417 : : !! and these are mentioned in the error message.
2418 : : !!
2419 : : !! INPUTS
2420 : : !! advice_change_cond= if 1, and if an error is detected, will
2421 : : !! advice to change the value of the conditions.
2422 : : !! cond_number= number of conditions checked before calling chkdpr.
2423 : : !! cond_string(cond_number)= name of the variables associated to the conditions.
2424 : : !! cond_values(cond_number)= value of the variables associated to the conditions. WARNING : only integers are allowed !
2425 : : !! input_name=name of the input variable to be checked
2426 : : !! input_value=value of the input variable to be checked
2427 : : !! minimal_flag=if 0, the reference_value must be matched within 1.0d-10
2428 : : !! if 1, admit values larger or equal to reference_value
2429 : : !! if -1, admit values smaller or equal to reference_value
2430 : : !! reference_value=see the description of minimal_flag
2431 : : !! unit=unit number for clean output file
2432 : : !!
2433 : : !! OUTPUT
2434 : : !! (only side effect)
2435 : : !!
2436 : : !! SIDE EFFECTS
2437 : : !! ierr= switch it to 1 if an error was detected. No action otherwise.
2438 : : !!
2439 : : !! NOTES
2440 : : !! cond_values(cond_number)
2441 : : !! must be between -99 and 999 to be printed correctly.
2442 : : !! for the time being, at most 3 conditions are allowed.
2443 : : !!
2444 : : !! SOURCE
2445 : :
2446 : 229435 : subroutine chkdpr(advice_change_cond,cond_number,cond_string,cond_values,&
2447 : : & ierr,input_name,input_value,minimal_flag,reference_value,unit)
2448 : :
2449 : : !Arguments ------------------------------------
2450 : : !scalars
2451 : : integer,intent(in) :: advice_change_cond,cond_number,minimal_flag,unit
2452 : : integer,intent(inout) :: ierr
2453 : : real(dp),intent(in) :: input_value,reference_value
2454 : : character(len=*),intent(in) :: input_name
2455 : : !arrays
2456 : : integer,intent(in) :: cond_values(4)
2457 : : character(len=*),intent(in) :: cond_string(4)
2458 : :
2459 : : !Local variables-------------------------------
2460 : : !scalars
2461 : : integer :: icond,ok
2462 : : character(len=500) :: msg
2463 : :
2464 : : !******************************************************************
2465 : :
2466 [ - + ]: 229435 : if(cond_number<0 .or. cond_number>4)then
2467 : 0 : write(msg,'(a,i0,a)' )'The value of cond_number is ',cond_number,'but it should be positive and < 5.'
2468 : 0 : ABI_BUG(msg)
2469 : : end if
2470 : :
2471 : : !Checks the allowed values
2472 : 229435 : ok=0
2473 [ + + - + ]: 229435 : if(minimal_flag==1 .and. input_value>=reference_value-tol10) ok=1
2474 [ + + - + ]: 229435 : if(minimal_flag==-1 .and. input_value<=reference_value+tol10) ok=1
2475 [ + + - + ]: 229435 : if(minimal_flag==0 .and. abs(input_value-reference_value)<=tol10) ok=1
2476 : :
2477 : : ! If there is something wrong, compose the message, and print it
2478 [ - + ]: 221058 : if(ok==0)then
2479 : 0 : ierr=1
2480 : 0 : write(msg, '(a,a)' ) ch10,' chkdpr: ERROR -'
2481 [ # # ]: 0 : if(cond_number/=0)then
2482 [ # # ]: 0 : do icond=1,cond_number
2483 : : ! The following format restricts cond_values(icond) to be between -99 and 999
2484 : 0 : write(msg, '(2a,a,a,a,i4,a)' ) trim(msg),ch10,&
2485 [ # # ]: 0 : ' Context : the value of the variable ',trim(cond_string(icond)),' is',cond_values(icond),'.'
2486 : : end do
2487 : : end if
2488 : 0 : write(msg, '(2a,a,a,a,es20.12,a)' ) trim(msg),ch10,&
2489 : 0 : ' The value of the input variable ',trim(input_name),' is',input_value,','
2490 [ # # ]: 0 : if(minimal_flag==0)then
2491 : 0 : write(msg, '(2a,a,es20.12,a)' ) trim(msg),ch10,' while it must be equal to ',reference_value,'.'
2492 [ # # ]: 0 : else if(minimal_flag==1)then
2493 : 0 : write(msg, '(2a,a,es20.12,a)' ) trim(msg),ch10,' while it must be larger or equal to',reference_value,'.'
2494 [ # # ]: 0 : else if(minimal_flag==-1)then
2495 : 0 : write(msg, '(2a,a,es20.12,a)' ) trim(msg),ch10,' while it must be smaller or equal to',reference_value,'.'
2496 : : end if
2497 : :
2498 [ # # # # ]: 0 : if(cond_number==0 .or. advice_change_cond==0)then
2499 : 0 : write(msg, '(2a,a,a,a)' ) trim(msg),ch10,&
2500 : 0 : ' Action: you should change the input variable ',trim(input_name),'.'
2501 [ # # ]: 0 : else if(cond_number==1)then
2502 : 0 : write(msg, '(2a,a,a,a,a,a)' ) trim(msg),ch10,&
2503 [ # # ]: 0 : ' Action: you should change the input variables ',trim(input_name),' or ',trim(cond_string(1)),'.'
2504 [ # # ]: 0 : else if(cond_number==2)then
2505 : 0 : write(msg, '(2a,a,a,a,a,a,a,a,a,a)' ) trim(msg),ch10,&
2506 : 0 : ' Action: you should change one of the input variables ',trim(input_name),',',ch10,&
2507 [ # # # # ]: 0 : ' ',trim(cond_string(1)),' or ',trim(cond_string(2)),'.'
2508 [ # # ]: 0 : else if(cond_number==3)then
2509 : 0 : write(msg, '(2a,a,a,a,a,a,a,a,a,a,a,a)' ) trim(msg),ch10,&
2510 : 0 : ' Action: you should change one of the input variables ',trim(input_name),',',ch10,&
2511 [ # # # # : 0 : ' ',trim(cond_string(1)),', ',trim(cond_string(2)),' or ',trim(cond_string(3)),'.'
# # ]
2512 : : end if
2513 : :
2514 : 0 : call wrtout(unit,msg)
2515 : 0 : ABI_WARNING(msg)
2516 : : end if
2517 : :
2518 : 229435 : end subroutine chkdpr
2519 : : !!***
2520 : :
2521 : : !!****f* m_parser/chkint
2522 : : !! NAME
2523 : : !! chkint
2524 : : !!
2525 : : !! FUNCTION
2526 : : !! Checks the value of an input integer variable, and
2527 : : !! write a sophisticated error message when it is erroneous.
2528 : : !! A few conditions might have been checked before calling chkint,
2529 : : !! and these are mentioned in the error message.
2530 : : !! See the examples in the NOTES
2531 : : !!
2532 : : !! INPUTS
2533 : : !! advice_change_cond= if 1, and if an error is detected, will
2534 : : !! advice to change the value of the conditions.
2535 : : !! cond_number= number of conditions checked before calling chkint.
2536 : : !! cond_string(cond_number)= name of the variables associated to the conditions.
2537 : : !! cond_values(cond_number)= value of the variables associated to the conditions. WARNING : only integers are allowed !
2538 : : !! input_name=name of the input variable to be checked
2539 : : !! input_value=value of the input variable to be checked
2540 : : !! list_number=number of allowed values (maximum 40).
2541 : : !! list_values=list of allowed values
2542 : : !! minmax_flag=if 0, only values in the list are allowed
2543 : : !! if 1, admit values larger or equal to minmax_value
2544 : : !! if -1, admit values smaller or equal to minmax_value
2545 : : !! minmax_value=see the description of minmax_flag
2546 : : !! unit=unit number for clean output file
2547 : : !!
2548 : : !! OUTPUT
2549 : : !! (only side effect)
2550 : : !!
2551 : : !! SIDE EFFECT
2552 : : !! ierr= switch it to 1 if an error was detected. No action otherwise.
2553 : : !!
2554 : : !! NOTES
2555 : : !! cond_values(cond_number) or list_values(list_number)
2556 : : !! must be between -99 and 999 to be printed correctly.
2557 : : !!
2558 : : !! for the time being, at most 3 conditions are allowed.
2559 : : !!
2560 : : !! in order to ask only for a minimal value, set list_number
2561 : : !! as well as minmax_flag to 1, and put the minimal value in both
2562 : : !! list_values and minmax_value.
2563 : : !!
2564 : : !! Examples :
2565 : : !! List of values - ionmov must be equal to 0, 1, 3, 8, or 9
2566 : : !! call chkint(0,0,cond_string,cond_values,ierr,'ionmov',ionmov,5,(/0,1,3,8,9/),0,0,iout)
2567 : : !!
2568 : : !! Larger or equal to a given value - nberry >= limit
2569 : : !! call chkint(0,0,cond_string,cond_values,ierr,'nberry',nberry,1,(/limit/),1,limit,iout)
2570 : : !!
2571 : : !! Smaller or equal to a given value - nberry <= limit
2572 : : !! call chkint(0,0,cond_string,cond_values,ierr,'nberry',nberry,1,(/limit/),-1,limit,iout)
2573 : : !!
2574 : : !! Conditional cases (examples to be provided - see chkinp.f for the time being)
2575 : : !!
2576 : : !! SOURCE
2577 : :
2578 : 35878 : subroutine chkint(advice_change_cond,cond_number,cond_string,cond_values,&
2579 : 35878 : ierr,input_name,input_value,list_number,list_values,minmax_flag,minmax_value,unit)
2580 : :
2581 : : !Arguments ------------------------------------
2582 : : !scalars
2583 : : integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2584 : : integer,intent(in) :: minmax_flag,minmax_value,unit
2585 : : integer,intent(inout) :: ierr
2586 : : character(len=*),intent(in) :: input_name
2587 : : !arrays
2588 : : integer,intent(in) :: cond_values(4),list_values(list_number)
2589 : : character(len=*),intent(inout) :: cond_string(4)
2590 : :
2591 : : !Local variables-------------------------------
2592 : : !scalars
2593 : : integer :: ilist,ok
2594 : :
2595 : : !******************************************************************
2596 : :
2597 : : ! Checks the allowed values
2598 : 35878 : ok=0
2599 [ + - ]: 35878 : if(list_number>0)then
2600 [ + + ]: 376565 : do ilist=1,list_number
2601 [ + + ]: 376565 : if(input_value == list_values(ilist))ok=1
2602 : : end do
2603 : : end if
2604 [ + + + + ]: 35878 : if(minmax_flag==1 .and. input_value>=minmax_value)ok=1
2605 [ + + + + ]: 35878 : if(minmax_flag==-1 .and. input_value<=minmax_value)ok=1
2606 : :
2607 : : ! If there is something wrong, compose the message, and print it
2608 [ - + ]: 34292 : if(ok==0)then
2609 : : call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2610 : : ierr,input_name,input_value,&
2611 : 0 : list_number,list_values,minmax_flag,minmax_value,unit)
2612 : : end if
2613 : :
2614 : : ! reset all cond_strings
2615 [ + + + - : 179390 : cond_string(:)='#####'
+ - ]
2616 : :
2617 : 35878 : end subroutine chkint
2618 : : !!***
2619 : :
2620 : : !!****f* m_parser/chkint_eq
2621 : : !! NAME
2622 : : !! chkint_eq
2623 : : !!
2624 : : !! FUNCTION
2625 : : !! Checks the value of an input integer variable against a list, and
2626 : : !! write a sophisticated error message when the value does not appear
2627 : : !! A few conditions might have been checked before calling chkint,
2628 : : !! and these are mentioned in the error message.
2629 : : !!
2630 : : !! See the examples in the NOTES
2631 : : !!
2632 : : !! INPUTS
2633 : : !! advice_change_cond= if 1, and if an error is detected, will
2634 : : !! advice to change the value of the conditions.
2635 : : !! cond_number= number of conditions checked before calling chkint.
2636 : : !! cond_string(cond_number)= name of the variables associated to the conditions.
2637 : : !! cond_values(cond_number)= value of the variables associated to the conditions. WARNING : only integers are allowed !
2638 : : !! input_name=name of the input variable to be checked
2639 : : !! input_value=value of the input variable to be checked
2640 : : !! list_number=number of allowed values (maximum 40).
2641 : : !! list_values=list of allowed values
2642 : : !! unit=unit number for clean output file
2643 : : !!
2644 : : !! OUTPUT
2645 : : !! (only side effect)
2646 : : !!
2647 : : !! SIDE EFFECT
2648 : : !! ierr= switch it to 1 if an error was detected. No action otherwise.
2649 : : !!
2650 : : !! NOTES
2651 : : !! cond_values(cond_number) or list_values(list_number)
2652 : : !! must be between -99 and 999 to be printed correctly.
2653 : : !!
2654 : : !! for the time being, at most 3 conditions are allowed.
2655 : : !!
2656 : : !! SOURCE
2657 : :
2658 : 865837 : subroutine chkint_eq(advice_change_cond,cond_number,cond_string,cond_values,&
2659 : 865837 : ierr,input_name,input_value,list_number,list_values,unit)
2660 : :
2661 : : !Arguments ------------------------------------
2662 : : !scalars
2663 : : integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2664 : : integer,intent(in) :: unit
2665 : : integer,intent(inout) :: ierr
2666 : : character(len=*),intent(in) :: input_name
2667 : : !arrays
2668 : : integer,intent(in) :: cond_values(4),list_values(list_number)
2669 : : character(len=*),intent(inout) :: cond_string(4)
2670 : :
2671 : : !Local variables-------------------------------
2672 : : !scalars
2673 : : integer :: ilist,minmax_flag,minmax_value,ok
2674 : :
2675 : : !******************************************************************
2676 : :
2677 : : !Checks the allowed values
2678 : 865837 : ok=0
2679 [ + - ]: 865837 : if(list_number>0)then
2680 [ + + ]: 4501058 : do ilist=1,list_number
2681 [ + + ]: 4501058 : if(input_value == list_values(ilist))ok=1
2682 : : end do
2683 : : end if
2684 : 865837 : minmax_flag=0
2685 : 865837 : minmax_value=0
2686 : :
2687 : : !If there is something wrong, compose the message, and print it
2688 [ - + ]: 865837 : if(ok==0)then
2689 : : call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2690 : : ierr,input_name,input_value,&
2691 : 0 : list_number,list_values,minmax_flag,minmax_value,unit)
2692 : : end if
2693 : :
2694 : : ! reset all cond_strings
2695 [ + + + - : 4329185 : cond_string(:)='#####'
+ - ]
2696 : :
2697 : 865837 : end subroutine chkint_eq
2698 : : !!***
2699 : :
2700 : : !!****f* m_parser/chkint_ge
2701 : : !! NAME
2702 : : !! chkint_ge
2703 : : !!
2704 : : !! FUNCTION
2705 : : !! Checks the value of an input integer variable, expected to be greater than some value, and
2706 : : !! write a sophisticated error message when it is erroneous.
2707 : : !! A few conditions might have been checked before calling chkint_ge,
2708 : : !! and these are mentioned in the error message.
2709 : : !!
2710 : : !! See the examples in the NOTES
2711 : : !!
2712 : : !! INPUTS
2713 : : !! advice_change_cond= if 1, and if an error is detected, will
2714 : : !! advice to change the value of the conditions.
2715 : : !! cond_number= number of conditions checked before calling chkint_ge.
2716 : : !! cond_string(cond_number)= name of the variables associated to the conditions.
2717 : : !! cond_values(cond_number)= value of the variables associated to the conditions. WARNING : only integers are allowed !
2718 : : !! input_name=name of the input variable to be checked
2719 : : !! input_value=value of the input variable to be checked
2720 : : !! minmax_value=see the description of minmax_flag
2721 : : !! unit=unit number for clean output file
2722 : : !!
2723 : : !! SIDE EFFECT
2724 : : !! ierr= switch it to 1 if an error was detected. No action otherwise.
2725 : : !!
2726 : : !! NOTES
2727 : : !! cond_values(cond_number) or list_values(list_number)
2728 : : !! must be between -99 and 999 to be printed correctly.
2729 : : !! For the time being, at most 3 conditions are allowed.
2730 : : !!
2731 : : !! SOURCE
2732 : :
2733 : 407556 : subroutine chkint_ge(advice_change_cond,cond_number,cond_string,cond_values,&
2734 : : ierr,input_name,input_value,minmax_value,unit)
2735 : :
2736 : : !Arguments ------------------------------------
2737 : : !scalars
2738 : : integer,intent(in) :: advice_change_cond,cond_number,input_value
2739 : : integer,intent(in) :: minmax_value,unit
2740 : : integer,intent(inout) :: ierr
2741 : : character(len=*),intent(in) :: input_name
2742 : : !arrays
2743 : : integer,intent(in) :: cond_values(4)
2744 : : character(len=*),intent(inout) :: cond_string(4)
2745 : :
2746 : : !Local variables-------------------------------
2747 : : !scalars
2748 : : integer :: list_number,minmax_flag,ok
2749 : 407556 : integer, allocatable :: list_values(:)
2750 : :
2751 : : !******************************************************************
2752 : :
2753 : : !Checks the allowed values
2754 : 407556 : ok=0
2755 : 407556 : minmax_flag=1
2756 [ + - ]: 407556 : if(input_value>=minmax_value)ok=1
2757 : 407556 : list_number=1
2758 [ + - ]: 407556 : ABI_MALLOC(list_values,(1))
2759 [ + + ]: 815112 : list_values=minmax_value
2760 : :
2761 : : !If there is something wrong, compose the message, and print it
2762 [ - + ]: 407556 : if(ok==0)then
2763 : : call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2764 : : ierr,input_name,input_value,&
2765 : 0 : list_number,list_values,minmax_flag,minmax_value,unit)
2766 : : end if
2767 : :
2768 [ - + ]: 407556 : ABI_FREE(list_values)
2769 : :
2770 : : ! reset all cond_strings
2771 [ + + + - : 2037780 : cond_string(:)='#####'
+ - ]
2772 : :
2773 : 407556 : end subroutine chkint_ge
2774 : : !!***
2775 : :
2776 : : !!****f* m_parser/chkint_le
2777 : : !! NAME
2778 : : !! chkint_le
2779 : : !!
2780 : : !! FUNCTION
2781 : : !! Checks the value of an input integer variable, expected to be lower than some value, and
2782 : : !! write a sophisticated error message when it is erroneous.
2783 : : !! A few conditions might have been checked before calling chkint_le,
2784 : : !! and these are mentioned in the error message.
2785 : : !!
2786 : : !! See the examples in the NOTES
2787 : : !!
2788 : : !! INPUTS
2789 : : !! advice_change_cond= if 1, and if an error is detected, will
2790 : : !! advice to change the value of the conditions.
2791 : : !! cond_number= number of conditions checked before calling chkint_le.
2792 : : !! cond_string(cond_number)= name of the variables associated to the conditions.
2793 : : !! cond_values(cond_number)= value of the variables associated to the conditions. WARNING : only integers are allowed !
2794 : : !! input_name=name of the input variable to be checked
2795 : : !! input_value=value of the input variable to be checked
2796 : : !! minmax_value=see the description of minmax_flag
2797 : : !! unit=unit number for clean output file
2798 : : !!
2799 : : !! SIDE EFFECT
2800 : : !! ierr= switch it to 1 if an error was detected. No action otherwise.
2801 : : !!
2802 : : !! NOTES
2803 : : !! cond_values(cond_number) or list_values(list_number)
2804 : : !! must be between -99 and 999 to be printed correctly.
2805 : : !! for the time being, at most 3 conditions are allowed.
2806 : : !!
2807 : : !! SOURCE
2808 : :
2809 : 105531 : subroutine chkint_le(advice_change_cond,cond_number,cond_string,cond_values,&
2810 : : ierr,input_name,input_value,minmax_value,unit)
2811 : :
2812 : : !Arguments ------------------------------------
2813 : : !scalars
2814 : : integer,intent(in) :: advice_change_cond,cond_number,input_value
2815 : : integer,intent(in) :: minmax_value,unit
2816 : : integer,intent(inout) :: ierr
2817 : : character(len=*),intent(in) :: input_name
2818 : : !arrays
2819 : : integer,intent(in) :: cond_values(4)
2820 : : character(len=*),intent(inout) :: cond_string(4)
2821 : :
2822 : : !Local variables-------------------------------
2823 : : !scalars
2824 : : integer :: list_number,minmax_flag,ok
2825 : 105531 : integer, allocatable :: list_values(:)
2826 : :
2827 : : !******************************************************************
2828 : :
2829 : : !Checks the allowed values
2830 : 105531 : ok=0
2831 : 105531 : minmax_flag=-1
2832 [ + - ]: 105531 : if(input_value<=minmax_value)ok=1
2833 : : !write(std_out,*)' chkint_le : input_value,minmax_value=',input_value,minmax_value
2834 : :
2835 : 105531 : list_number=1
2836 [ + - ]: 105531 : ABI_MALLOC(list_values,(1))
2837 [ + + ]: 211062 : list_values=minmax_value
2838 : :
2839 : : !If there is something wrong, compose the message, and print it
2840 [ - + ]: 105531 : if(ok==0)then
2841 : : call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2842 : 0 : ierr,input_name,input_value,list_number,list_values,minmax_flag,minmax_value,unit)
2843 : : end if
2844 : :
2845 [ - + ]: 105531 : ABI_FREE(list_values)
2846 : :
2847 : : ! reset all cond_strings
2848 [ + + + - : 527655 : cond_string(:)='#####'
+ - ]
2849 : :
2850 : 105531 : end subroutine chkint_le
2851 : : !!***
2852 : :
2853 : : !!****f* m_parser/chkint_ne
2854 : : !! NAME
2855 : : !! chkint_ne
2856 : : !!
2857 : : !! FUNCTION
2858 : : !! Checks the value of an input integer variable against a list, and
2859 : : !! write a sophisticated error message when the value appears in the list.
2860 : : !! A few conditions might have been checked before calling chkint,
2861 : : !! and these are mentioned in the error message.
2862 : : !!
2863 : : !! See the examples in the NOTES
2864 : : !!
2865 : : !! INPUTS
2866 : : !! advice_change_cond= if 1, and if an error is detected, will
2867 : : !! advice to change the value of the conditions.
2868 : : !! cond_number= number of conditions checked before calling chkint.
2869 : : !! cond_string(cond_number)= name of the variables associated to the conditions.
2870 : : !! cond_values(cond_number)= value of the variables associated to the conditions. WARNING : only integers are allowed !
2871 : : !! input_name=name of the input variable to be checked
2872 : : !! input_value=value of the input variable to be checked
2873 : : !! list_number=number of NOT allowed values (maximum 40).
2874 : : !! list_values=list of allowed values
2875 : : !! unit=unit number for clean output file
2876 : : !!
2877 : : !! SIDE EFFECT
2878 : : !! ierr= switch it to 1 if an error was detected. No action otherwise.
2879 : : !!
2880 : : !! NOTES
2881 : : !! cond_values(cond_number) or list_values(list_number)
2882 : : !! must be between -99 and 999 to be printed correctly.
2883 : : !!
2884 : : !! for the time being, at most 3 conditions are allowed.
2885 : : !!
2886 : : !! SOURCE
2887 : :
2888 : 18831 : subroutine chkint_ne(advice_change_cond,cond_number,cond_string,cond_values,&
2889 : 18831 : ierr,input_name,input_value, list_number,list_values,unit)
2890 : :
2891 : : !Arguments ------------------------------------
2892 : : !scalars
2893 : : integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2894 : : integer,intent(in) :: unit
2895 : : integer,intent(inout) :: ierr
2896 : : character(len=*),intent(in) :: input_name
2897 : : !arrays
2898 : : integer,intent(in) :: cond_values(4),list_values(list_number)
2899 : : character(len=*),intent(inout) :: cond_string(4)
2900 : :
2901 : : !Local variables-------------------------------
2902 : : !scalars
2903 : : integer :: ilist,minmax_flag,minmax_value,ok
2904 : :
2905 : : !******************************************************************
2906 : :
2907 : : !Checks the allowed values
2908 : 18831 : ok=1
2909 [ + - ]: 18831 : if(list_number>0)then
2910 [ + + ]: 40687 : do ilist=1,list_number
2911 [ - + ]: 40687 : if(input_value == list_values(ilist))ok=0
2912 : : end do
2913 : : end if
2914 : 18831 : minmax_flag=2
2915 : 18831 : minmax_value=0
2916 : :
2917 : : !If there is something wrong, compose the message, and print it
2918 [ - + ]: 18831 : if(ok==0)then
2919 : : call chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2920 : : ierr,input_name,input_value,&
2921 : 0 : list_number,list_values,minmax_flag,minmax_value,unit)
2922 : : end if
2923 : :
2924 : : ! reset all cond_strings
2925 [ + + + - : 94155 : cond_string(:)='#####'
+ - ]
2926 : :
2927 : 18831 : end subroutine chkint_ne
2928 : : !!***
2929 : :
2930 : : !!****f* m_parser/chkint_prt
2931 : : !! NAME
2932 : : !! chkint_prt
2933 : : !!
2934 : : !! FUNCTION
2935 : : !! During the checking of the value of a variable,
2936 : : !! write a sophisticated error message when it is erroneous.
2937 : : !! A few conditions might have been checked before calling chkval,
2938 : : !! and these are mentioned in the error message.
2939 : : !!
2940 : : !! See the examples in the NOTES
2941 : : !!
2942 : : !! INPUTS
2943 : : !! advice_change_cond= if 1, and if an error is detected, will
2944 : : !! advice to change the value of the conditions.
2945 : : !! cond_number= number of conditions checked before calling chkint.
2946 : : !! cond_string(cond_number)= name of the variables associated to the conditions.
2947 : : !! cond_values(cond_number)= value of the variables associated to the conditions. WARNING : only integers are allowed !
2948 : : !! input_name=name of the input variable to be checked
2949 : : !! input_value=value of the input variable to be checked
2950 : : !! list_number=number of allowed values (maximum 40).
2951 : : !! list_values=list of allowed values
2952 : : !! minmax_flag=if 0, only values in the list are allowed
2953 : : !! if 1, admit values larger or equal to minmax_value
2954 : : !! if -1, admit values smaller or equal to minmax_value
2955 : : !! if 2, values in the list are not allowed
2956 : : !! minmax_value=see the description of minmax_flag
2957 : : !! unit=unit number for clean output file
2958 : : !!
2959 : : !! SIDE EFFECT
2960 : : !! ierr= switch it to 1 if an error was detected. No action otherwise.
2961 : : !!
2962 : : !! NOTES
2963 : : !! cond_values(cond_number) or list_values(list_number)
2964 : : !! must be between -99 and 999 to be printed correctly.
2965 : : !!
2966 : : !! for the time being, at most 3 conditions are allowed.
2967 : : !! In order to ask only for a minimal value, set list_number
2968 : : !! as well as minmax_flag to 1, and put the minimal value in both
2969 : : !! list_values and minmax_value.
2970 : : !!
2971 : : !! Examples:
2972 : : !! List of values - ionmov must be equal to 0, 1, 3, 8, or 9
2973 : : !! call chkint_prt(0,0,cond_string,cond_values,ierr,'ionmov',ionmov,5,(/0,1,3,8,9/),0,0,iout)
2974 : : !!
2975 : : !! Larger or equal to a given value - nberry >= limit
2976 : : !! call chkint_prt(0,0,cond_string,cond_values,ierr,'nberry',nberry,1,(/limit/),1,limit,iout)
2977 : : !!
2978 : : !! Smaller or equal to a given value - nberry <= limit
2979 : : !! call chkint_prt(0,0,cond_string,cond_values,ierr,'nberry',nberry,1,(/limit/),-1,limit,iout)
2980 : : !!
2981 : : !! Conditional cases (examples to be provided - see chkinp.f for the time being)
2982 : : !!
2983 : : !! SOURCE
2984 : :
2985 : 0 : subroutine chkint_prt(advice_change_cond,cond_number,cond_string,cond_values,&
2986 : 0 : ierr,input_name,input_value,list_number,list_values,minmax_flag,minmax_value,unit)
2987 : :
2988 : : !Arguments ------------------------------------
2989 : : !scalars
2990 : : integer,intent(in) :: advice_change_cond,cond_number,input_value,list_number
2991 : : integer,intent(in) :: minmax_flag,minmax_value,unit
2992 : : integer,intent(inout) :: ierr
2993 : : character(len=*),intent(in) :: input_name
2994 : : !arrays
2995 : : integer,intent(in) :: cond_values(4),list_values(list_number)
2996 : : character(len=*),intent(in) :: cond_string(4)
2997 : :
2998 : : !Local variables-------------------------------
2999 : : !scalars
3000 : : integer :: icond
3001 : : character(len=500) :: msg
3002 : : !******************************************************************
3003 : :
3004 [ # # ]: 0 : if(cond_number<0 .or. cond_number>4)then
3005 : 0 : write(msg,'(a,i0,a)' )'The value of cond_number is ',cond_number,' but it should be positive and < 5.'
3006 : 0 : ABI_BUG(msg)
3007 : : end if
3008 : :
3009 [ # # ]: 0 : if(list_number<0 .or. list_number>40)then
3010 : 0 : write(msg,'(a,i0,a)' )'The value of list_number is',list_number,' but it should be between 0 and 40.'
3011 : 0 : ABI_BUG(msg)
3012 : : end if
3013 : :
3014 : : !Compose the message, and print it
3015 : 0 : ierr=1
3016 : 0 : write(msg, '(2a)' ) ch10,' chkint_prt: ERROR -'
3017 [ # # ]: 0 : if(cond_number/=0)then
3018 [ # # ]: 0 : do icond=1,cond_number
3019 : : ! The following format restricts cond_values(icond) to be between -99 and 999
3020 : 0 : write(msg, '(5a,i0,a)' ) trim(msg),ch10,&
3021 [ # # ]: 0 : ' Context: the value of the variable ',trim(cond_string(icond)),' is ',cond_values(icond),'.'
3022 : : end do
3023 : : end if
3024 : 0 : write(msg, '(5a,i0,a)' ) trim(msg),ch10,&
3025 : 0 : ' The value of the input variable ',trim(input_name),' is ',input_value,', while it must be'
3026 [ # # ]: 0 : if(minmax_flag==2)then
3027 : 0 : write(msg, '(3a,20(i0,1x))' ) trim(msg),ch10,&
3028 : 0 : ' different from one of the following: ',list_values(1:list_number)
3029 [ # # # # : 0 : else if(list_number>1 .or. minmax_flag==0 .or. list_values(1)/=minmax_value )then
# # ]
3030 : : ! The following format restricts list_values to be between -99 and 999
3031 [ # # ]: 0 : if(list_number/=1)then
3032 : 0 : write(msg, '(3a,40(i0,1x))' ) trim(msg),ch10,&
3033 : 0 : ' equal to one of the following: ',list_values(1:list_number)
3034 : : else
3035 : 0 : write(msg, '(3a,40(i0,1x))' ) trim(msg),ch10,' equal to ',list_values(1)
3036 : : end if
3037 [ # # ]: 0 : if(minmax_flag==1)then
3038 : : ! The following format restricts minmax_value to be between -99 and 999
3039 : 0 : write(msg, '(3a,i0,a)' ) trim(msg),ch10,' or it must be larger or equal to ',minmax_value,'.'
3040 [ # # ]: 0 : else if(minmax_flag==-1)then
3041 : 0 : write(msg, '(3a,i0,a)' ) trim(msg),ch10,' or it must be smaller or equal to ',minmax_value,'.'
3042 : : end if
3043 [ # # ]: 0 : else if(minmax_flag==1)then
3044 : : ! The following format restricts minmax_value to be between -99 and 999
3045 : 0 : write(msg, '(3a,i0,a)' ) trim(msg),ch10,' larger or equal to ',minmax_value,'.'
3046 [ # # ]: 0 : else if(minmax_flag==-1)then
3047 : : ! The following format restricts minmax_value to be between -99 and 999
3048 : 0 : write(msg, '(3a,i0,a)' ) trim(msg),ch10,' smaller or equal to ',minmax_value,'.'
3049 : : end if
3050 [ # # # # ]: 0 : if(cond_number==0 .or. advice_change_cond==0)then
3051 : 0 : write(msg, '(5a)' ) trim(msg),ch10,' Action: you should change the input variable ',trim(input_name),'.'
3052 [ # # ]: 0 : else if(cond_number==1)then
3053 : 0 : write(msg, '(7a)' ) trim(msg),ch10,&
3054 [ # # ]: 0 : ' Action: you should change the input variables ',trim(input_name),' or ',trim(cond_string(1)),'.'
3055 [ # # ]: 0 : else if(cond_number==2)then
3056 : 0 : write(msg, '(11a)' ) trim(msg),ch10,&
3057 : 0 : ' Action: you should change one of the input variables ',trim(input_name),',',ch10,&
3058 [ # # # # ]: 0 : ' ',trim(cond_string(1)),' or ',trim(cond_string(2)),'.'
3059 [ # # ]: 0 : else if(cond_number==3)then
3060 : 0 : write(msg, '(13a)' ) trim(msg),ch10,&
3061 : 0 : ' Action: you should change one of the input variables ',trim(input_name),',',ch10,&
3062 [ # # # # : 0 : ' ',trim(cond_string(1)),', ',trim(cond_string(2)),' or ',trim(cond_string(3)),'.'
# # ]
3063 : : end if
3064 [ # # ]: 0 : call wrtout([unit, std_out], msg)
3065 : :
3066 : 0 : end subroutine chkint_prt
3067 : : !!***
3068 : :
3069 : : !!****f* m_parser/prttagm
3070 : : !!
3071 : : !! NAME
3072 : : !! prttagm
3073 : : !!
3074 : : !! FUNCTION
3075 : : !! Eventually print the content of dprarr (if typevarphys='DPR','LEN', 'ENE', 'TIM' and 'BFI'),
3076 : : !! or intarr (if typevarphys='INT'), arrays of effective dimensions narr and 0:ndtset_alloc
3077 : : !! For the second dimension, the 0 index relates to a default.
3078 : : !! Print the array only if the content for at least one value of the second
3079 : : !! index is different from the default.
3080 : : !! Print a generic value if the non-default values are all equal.
3081 : : !! Print the detail of all values otherwise.
3082 : : !! The input variable 'length' controls the print format, and, in the case
3083 : : !! of the real(dp) variable, the way two numbers are determined to be
3084 : : !! different or not.
3085 : : !!
3086 : : !! INPUTS
3087 : : !! intarr(1:marr,0:ndtset_alloc), dprarr(1:marr,0:ndtset_alloc)
3088 : : !! integer or real(dp) arrays, respectively,
3089 : : !! containing the data to be printed. Use these arrays even for scalars.
3090 : : !! For the first index, only the range 1:narr is relevant.
3091 : : !! iout=unit number for echoed output
3092 : : !! jdtset_(0:ndtset_alloc)=list of dataset indices.
3093 : : !! length= if 1, short format for printing, if 2, long format for printing
3094 : : !! special formats: if 3, INT : for symrel or kptrlatt
3095 : : !! if 4, INT : for type
3096 : : !! if 5, INT : for mkmem, mkqmem, mk1mem
3097 : : !! if 6, INT : for kptrlatt
3098 : : !! if 3, DPR : for tnons
3099 : : !! if 4, DPR : for wtk and znucl
3100 : : !! if 5, DPR : for atvshift
3101 : : !! if 6, DPR : very short format for printing
3102 : : !! If the typevarphys is 'DPR', a negative value of 'length' will request that
3103 : : !! the equality of real(dp) numbers is determined by an ABSOLUTE
3104 : : !! difference criterion only. The absolute value of length is used
3105 : : !! to determine the format, as above.
3106 : : !!
3107 : : !! marr=first dimension of the intarr and dprarr arrays, as declared in the
3108 : : !! calling subroutine.
3109 : : !! narr=actual first dimension of intarr and dprarr.
3110 : : !! narrm=used when the effective first dimension of intarr is variable
3111 : : !! in this case narrm(0:ndtset_alloc)
3112 : : !! ncid= NETCDF id
3113 : : !! ndtset_alloc=govern second dimension of intarr and dprarr
3114 : : !! token=character string for 'tag'. Assumed no longer than 9 characters
3115 : : !! typevarphys=physical variable type (might indicate the physical meaning of
3116 : : !! for dimensionality purposes)
3117 : : !! 'INT'=>integer
3118 : : !! 'DPR'=>real(dp) (no special treatment)
3119 : : !! 'LEN'=>real(dp) (output in bohr and angstrom)
3120 : : !! 'ENE'=>real(dp) (output in hartree and eV)
3121 : : !! 'BFI'=>real(dp) (output in Tesla)
3122 : : !! 'TIM'=>real(dp) (output in second)
3123 : : !! use_narrm= if 0, use of scalar 'narr' instead of array 'narrm'
3124 : : !! [firstchar]= (optional) first character of the line (default=' ')
3125 : : !! [forceprint]= (optional) control if output is forced even if a variable is equal to its default value:
3126 : : !! 0: not printed out if equal to default value
3127 : : !! 1: output forced even if equal to default value in both TEXT and NETCDF file
3128 : : !! 2: output forced even if equal to default value in NETCDF file only
3129 : : !! 3: output forced even if equal to default value in TEXT file only
3130 : : !!
3131 : : !! OUTPUT
3132 : : !! (only writing)
3133 : : !!
3134 : : !! SOURCE
3135 : :
3136 : 3734424 : subroutine prttagm(dprarr,intarr,iout,jdtset_,length,&
3137 : 3734424 : marr,narr,narrm,ncid,ndtset_alloc,token,typevarphys,use_narrm,&
3138 : 0 : firstchar,forceprint,strarr) ! optional
3139 : :
3140 : : !Arguments ------------------------------------
3141 : : !scalars
3142 : : integer,intent(in) :: iout,length,marr,narr,ndtset_alloc,ncid,use_narrm
3143 : : integer,intent(in),optional :: forceprint
3144 : : character(len=*),intent(in) :: token
3145 : : character(len=3),intent(in) :: typevarphys
3146 : : character(len=1),intent(in),optional :: firstchar
3147 : : !arrays
3148 : : integer,intent(in) :: intarr(marr,0:ndtset_alloc)
3149 : : integer,intent(in) :: jdtset_(0:ndtset_alloc)
3150 : : integer,intent(in) :: narrm(0:ndtset_alloc)
3151 : : real(dp),intent(in) :: dprarr(marr,0:ndtset_alloc)
3152 : : character(len=fnlen),intent(in),optional :: strarr(marr,0:ndtset_alloc)
3153 : :
3154 : : !Local variables-------------------------------
3155 : : !character(len=*), parameter :: long_beg ='(a,a16,a,1x,(t22,'
3156 : : character(len=*), parameter :: format_1 ='",a16,a,t22,'
3157 : : character(len=*), parameter :: format_2 ='",t22,'
3158 : : character(len=*), parameter :: short_int ='10i5)'
3159 : : character(len=*), parameter :: long_int ='8i8)'
3160 : : character(len=*), parameter :: veryshort_dpr='f11.5)'
3161 : : character(len=*), parameter :: short_dpr ='es16.8)'
3162 : : character(len=*), parameter :: long_dpr ='es18.10)'
3163 : : character(len=*), parameter :: veryshort_dim='f11.5),a'
3164 : : character(len=*), parameter :: short_dim ='es16.8),a'
3165 : : character(len=*), parameter :: long_dim ='es18.10),a'
3166 : : character(len=*), parameter :: f_symrel ='3(3i3,1x),4x,3(3i3,1x))'
3167 : : character(len=*), parameter :: f_type ='20i3)'
3168 : : character(len=*), parameter :: f_mem ='8i8)'
3169 : : character(len=*), parameter :: f_tnons ='3f11.7,3x,3f11.7)'
3170 : : character(len=*), parameter :: f_wtk ='6f11.5)'
3171 : : character(len=*), parameter :: f_atvshift ='5f11.5)'
3172 : : character(len=*), parameter :: f_kptrlatt ='3(3i5,2x))'
3173 : : character(len=*), parameter :: f_str ='2x,a'
3174 : : !scalars
3175 : : integer :: iarr,idtset,jdtset,multi,ndtset_eff,narr_eff
3176 : : logical :: print_netcdf,print_out
3177 : : real(dp),parameter :: tol21=1.0d-21
3178 : : real(dp) :: diff,scale_factor,sumtol
3179 : : character(len=4) :: digit
3180 : : character(len=1) :: first_column
3181 : : character(len=4) :: append
3182 : : character(len=8) :: out_unit
3183 : : character(len=50) :: format_dp,format_int,full_format
3184 : : character(len=48) :: format_str
3185 : : character(len=500) :: msg
3186 : : ! *************************************************************************
3187 : :
3188 : : !###########################################################
3189 : : !### 01. Check consistency of input
3190 : :
3191 [ - + ]: 3734424 : if(len_trim(token)>16)then
3192 : : write(msg, '(3a,i0,2a)' )&
3193 : 0 : 'The length of the name of the input variable ',trim(token),' is ',len_trim(token),ch10,&
3194 : 0 : 'This exceeds 16 characters, the present maximum in routine prttagm.'
3195 : 0 : ABI_ERROR(msg)
3196 : : end if
3197 : :
3198 [ - + ]: 3734424 : if(ndtset_alloc<1)then
3199 : : write(msg, '(a,i0,a,a,a,a,a)' )&
3200 : 0 : 'ndtset_alloc=',ndtset_alloc,', while it should be >= 1.',ch10,&
3201 : 0 : 'This happened for token=',token,'.'
3202 : 0 : ABI_BUG(msg)
3203 : : end if
3204 : :
3205 [ - + ]: 3734424 : if(ndtset_alloc>9999)then
3206 : : write(msg, '(a,i0,a,a,a,a,a)' )&
3207 : 0 : 'ndtset_alloc=',ndtset_alloc,', while it must be lower than 10000.',ch10,&
3208 : 0 : 'This happened for token=',token,'.'
3209 : 0 : ABI_BUG(msg)
3210 : : end if
3211 : :
3212 [ + + + - : 3734424 : if(narr>99 .and. (typevarphys=='ENE'.or.typevarphys=='LEN'))then
- + ]
3213 : 0 : write(msg, '(3a,i0,a)' )' typevarphys=',typevarphys,' with narr=',narr,' is not allowed.'
3214 : 0 : ABI_BUG(msg)
3215 : : end if
3216 : :
3217 [ + + + + ]: 3734424 : if ((narr>0).or.(use_narrm/=0)) then
3218 : :
3219 : 3667000 : print_out=.true.;print_netcdf=.true.
3220 : 3667000 : multi=0
3221 : :
3222 : : ! ###########################################################
3223 : : ! ### 02. Treatment of integer 'INT'
3224 : :
3225 [ + + ]: 3667000 : if(typevarphys=='INT')then
3226 : :
3227 : : ! Determine whether the different non-default occurrences are all equal
3228 : :
3229 [ + + ]: 2676442 : if (use_narrm==0) then ! use of scalar 'narr' instead of array 'narrm'
3230 [ + + ]: 2640984 : if(ndtset_alloc>1)then
3231 [ + + ]: 13147778 : do idtset=1,ndtset_alloc
3232 [ + + ]: 30407478 : do iarr=1,narr
3233 [ + + ]: 28609836 : if(intarr(iarr,1)/=intarr(iarr,idtset))multi=1
3234 : : end do
3235 : : end do
3236 : : end if
3237 : : else
3238 : : ! If the sizes of the arrays are different we can not compare them
3239 : : ! So we have to assume they are different
3240 : : multi=1
3241 : : end if
3242 : :
3243 : : ! If they are all equal, then determine whether they are equal to the default
3244 [ + + ]: 1797642 : if(multi==0)then
3245 : : print_out=.false.
3246 [ + + ]: 6749852 : do iarr=1,narr
3247 [ + + ]: 6749852 : if (intarr(iarr,1)/=intarr(iarr,0)) print_out=.true.
3248 : : end do
3249 : : print_netcdf=print_out
3250 : : end if
3251 : :
3252 [ + + ]: 2676442 : if (present(forceprint)) then
3253 [ + + ]: 18272 : if (forceprint==1.or.forceprint==3) print_out=.true.
3254 [ + + ]: 18272 : if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3255 : : end if
3256 : :
3257 : : ! Print only if the values differ from the default
3258 [ + + + + ]: 2662738 : if (print_out.or.print_netcdf.or.(ncid<0))then
3259 : 146896 : ndtset_eff=ndtset_alloc
3260 [ + + + + ]: 146896 : if((multi==0).or.(ncid<0)) ndtset_eff=1
3261 [ + + ]: 561432 : do idtset=1,ndtset_eff
3262 : :
3263 : : ! Initialize the character in the first column
3264 [ + + ]: 414536 : first_column=' ';if (present(firstchar)) first_column=firstchar
3265 [ + + ]: 414536 : if(abs(length)==5)first_column='P'
3266 : : ! Initialize the format
3267 [ + + ]: 414536 : if(abs(length)==1)format_int=trim(short_int)
3268 [ + + ]: 414536 : if(abs(length)==2)format_int=trim(long_int)
3269 [ + + ]: 414536 : if(abs(length)==3)format_int=trim(f_symrel)
3270 [ + + ]: 414536 : if(abs(length)==4)format_int=trim(f_type)
3271 [ + + ]: 414536 : if(abs(length)==5)format_int=trim(f_mem)
3272 [ + + ]: 414536 : if(abs(length)==6)format_int=trim(f_kptrlatt)
3273 : : ! Initialize the dataset number string, and print
3274 [ + + + + ]: 414536 : if((multi==0).or.(ncid<0))then
3275 : 86012 : append=' '
3276 : : else
3277 : 328524 : jdtset=jdtset_(idtset)
3278 : 328524 : call appdig(jdtset,'',append)
3279 : : end if
3280 : : ! full_format=trim(long_beg)//trim(format_int)
3281 [ + - ]: 414536 : full_format='("'//first_column//trim(format_1)//'("'// first_column//trim(format_2)//trim(format_int)//")"
3282 : :
3283 : : ! narr_eff could be narr or narrm(idtset)
3284 : : ! It depends if the size is variable for different datasets
3285 [ + + ]: 414536 : if (use_narrm==0)then
3286 : 239024 : narr_eff=narr
3287 : : else
3288 : 175512 : narr_eff=narrm(idtset)
3289 : : end if
3290 : :
3291 [ + + ]: 3090978 : if (narr_eff/=0) then
3292 : :
3293 [ + + ]: 259934 : if (print_out) write(iout,full_format) token,trim(append),intarr(1:narr_eff,idtset)
3294 [ + + ]: 259934 : if (print_netcdf) then
3295 : : call write_var_netcdf(intarr(1:narr_eff,idtset),&
3296 : 254418 : dprarr(1:narr_eff,idtset),marr,narr_eff,abs(ncid),typevarphys,token//append)
3297 : : end if
3298 : : end if
3299 : :
3300 : : end do
3301 : : end if !(print==1)
3302 : :
3303 : : ! ###########################################################
3304 : : ! ### 03. Treatment of real 'DPR', 'LEN', 'ENE', 'BFI', 'TIM'
3305 : :
3306 [ + + + + : 990558 : else if (typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI' .or. typevarphys=='TIM') then
+ + - + -
- ]
3307 : :
3308 [ + + + + ]: 990558 : if((ndtset_alloc>1).and.(use_narrm==0))then
3309 [ + + ]: 4871162 : do idtset=1,ndtset_alloc
3310 [ + + ]: 12992792 : do iarr=1,narr
3311 : : ! The determination of effective equality is more difficult than in the
3312 : : ! integer case :
3313 : : ! - if length > 0, ask for a relative accuracy, and also include
3314 : : ! the case of zero values, thanks to tol21.
3315 : : ! - if length < 0, ask for absolute accuracy.
3316 : 8121630 : diff=abs( dprarr(iarr,1)-dprarr(iarr,idtset) )
3317 [ + + ]: 12325280 : if(length>0)then
3318 : 6234906 : sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,idtset))+10*tol21
3319 [ + + ]: 6234906 : if(diff>sumtol*tol11)multi=1
3320 : : else
3321 [ + + ]: 1916164 : if(diff>tol14)multi=1
3322 : : end if
3323 : : end do
3324 : : end do
3325 [ + + ]: 323046 : elseif (use_narrm/=0) then
3326 : 72480 : multi=1 ! Assume that values could not be compared between different datasets.
3327 : : ! Nevertheless, checks whether not all dataset might be equal to the default, despite varying dimensions (e.g. all zeroes)
3328 : : print_out=.false.
3329 [ + + ]: 72480 : do idtset=1,ndtset_alloc
3330 [ + + ]: 72480 : if(narrm(idtset)>narrm(0))then
3331 : : print_out=.true.
3332 : : else
3333 [ + + ]: 691168 : do iarr=1,narrm(idtset)
3334 : 640388 : diff=abs( dprarr(iarr,idtset)-dprarr(iarr,0) )
3335 [ + + ]: 691168 : if(length>0)then
3336 : 280442 : sumtol=abs(dprarr(iarr,idtset))+abs(dprarr(iarr,0))+10*tol21
3337 [ + + ]: 280442 : if(diff>sumtol*tol11)print_out=.true.
3338 : : else
3339 [ + + ]: 649666 : if(diff>tol14)print_out=.true.
3340 : : end if
3341 : : end do
3342 : : end if
3343 : : end do
3344 : : print_netcdf=print_out
3345 : : end if
3346 : :
3347 [ + + ]: 675952 : if(multi==0)then
3348 : : print_out=.false.
3349 [ + + ]: 3025834 : do iarr=1,narr
3350 : 2050904 : diff=abs( dprarr(iarr,1)-dprarr(iarr,0) )
3351 [ + + ]: 3025834 : if(length>0)then
3352 : 1564778 : sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,0))+10*tol21
3353 [ + + ]: 1564778 : if(diff>sumtol*tol11)print_out=.true.
3354 : : else
3355 [ + + ]: 2368294 : if(diff>tol14)print_out=.true.
3356 : : end if
3357 : : end do
3358 : : print_netcdf=print_out
3359 : : end if
3360 : :
3361 [ + + ]: 990558 : if (present(forceprint)) then
3362 [ - + ]: 27380 : if (forceprint==1.or.forceprint==3) print_out=.true.
3363 [ - + ]: 27380 : if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3364 : : end if
3365 : :
3366 [ + + + + ]: 963178 : if(print_out.or.print_netcdf.or.(ncid<0))then
3367 : : ! Select the proper format
3368 : 74820 : ndtset_eff=ndtset_alloc
3369 [ + + + + ]: 74820 : if((multi==0).or.(ncid<0))ndtset_eff=1
3370 : 74820 : narr_eff=narr
3371 [ + + ]: 74820 : if(use_narrm/=0)then
3372 [ + + ]: 29698 : narr_eff=maxval(narrm(1:ndtset_eff))
3373 : : end if
3374 [ + + + + ]: 74820 : if(abs(length)==1 .or. abs(length)==2 .or. abs(length)==6)then
3375 [ + + ]: 65468 : if(typevarphys=='DPR')then
3376 : 49924 : digit='3'
3377 [ + + ]: 49924 : if(abs(length)==1)format_dp=digit//short_dpr
3378 [ + + ]: 49924 : if(abs(length)==2)format_dp=digit//long_dpr
3379 [ - + ]: 49924 : if(abs(length)==6)format_dp=digit//veryshort_dpr
3380 [ + + + + : 15544 : else if(typevarphys=='ENE' .or. typevarphys=='LEN' .or. typevarphys=='BFI' .or. typevarphys=='TIM')then
- + - - ]
3381 [ + - ]: 15544 : if (narr<10) write(digit,'(i1)')narr_eff
3382 [ - + ]: 15544 : if (narr> 9) write(digit,'(i2)')narr_eff
3383 [ + + ]: 15544 : if(abs(length)==1)format_dp=digit//short_dim
3384 [ + + ]: 15544 : if(abs(length)==2)format_dp=digit//long_dim
3385 [ + + ]: 15544 : if(abs(length)==6)format_dp=digit//veryshort_dim
3386 : : end if
3387 : : else
3388 [ + + ]: 9352 : if(abs(length)==3)format_dp=f_tnons
3389 [ + + ]: 9352 : if(abs(length)==4)format_dp=f_wtk
3390 [ + + ]: 9352 : if(abs(length)==5)format_dp=f_atvshift
3391 : : end if
3392 [ + + ]: 220478 : do idtset=1,ndtset_eff
3393 : :
3394 : : ! narr_eff could be narr or narrm(idtset)
3395 : : ! It depends if the size is variable for different datasets
3396 [ + + ]: 145658 : if (use_narrm==0)then
3397 : 119088 : narr_eff=narr
3398 : : else
3399 : 26570 : narr_eff=narrm(idtset)
3400 : : end if
3401 : :
3402 [ + + ]: 1136216 : if (narr_eff/=0) then
3403 : :
3404 : : ! Initialize the character in the first column
3405 [ - + ]: 144848 : first_column=' ';if (present(firstchar)) first_column=firstchar
3406 : : ! Define scale_factor
3407 : 144848 : scale_factor=one !EB to what this is still useful ???
3408 : : ! EB remove if(typevarphys=='BFI')scale_factor=one/BField_Tesla
3409 : : ! Define out_unit
3410 [ + + ]: 144848 : if(typevarphys=='ENE')out_unit=' Hartree'
3411 [ + + ]: 144848 : if(typevarphys=='LEN')out_unit=' Bohr '
3412 [ + + ]: 144848 : if(typevarphys=='BFI')out_unit=' ' !EB remove Tesla unit
3413 [ - + ]: 144848 : if(typevarphys=='TIM')out_unit=' Second'
3414 : : ! Format, according to the length of the dataset string
3415 [ + + - + ]: 144848 : if((multi==0).or.(ncid<0))then
3416 : 64504 : append=' '
3417 : : else
3418 : 80344 : jdtset=jdtset_(idtset)
3419 : 80344 : call appdig(jdtset,'',append)
3420 : : end if
3421 : : ! full_format=trim(long_beg)//trim(format_dp)
3422 [ + - ]: 144848 : full_format='("'//first_column//trim(format_1)//'("'// first_column//trim(format_2)//trim(format_dp)//")"
3423 : : ! write(ab_out,*)' trim(long_beg)=',trim(long_beg)
3424 : : ! write(ab_out,*)' trim(format_dp)=',trim(format_dp)
3425 : : ! write(ab_out,*)' trim(full_format)=',trim(full_format)
3426 [ + + ]: 144848 : if(typevarphys=='DPR')then
3427 [ + + + + ]: 2049304 : if (print_out) write(iout,full_format) token,trim(append),dprarr(1:narr_eff,idtset)*scale_factor
3428 : : else
3429 [ + + + + ]: 70880 : if (print_out) write(iout,full_format) token,trim(append),dprarr(1:narr_eff,idtset)*scale_factor,trim(out_unit)
3430 : : end if
3431 [ + + ]: 144848 : if (print_netcdf) then
3432 : : call write_var_netcdf(intarr(1:narr_eff,idtset),dprarr(1:narr_eff,idtset),&
3433 [ + + ]: 144438 : marr,narr_eff,abs(ncid),'DPR',token//trim(append))
3434 : : end if
3435 : :
3436 : : end if
3437 : :
3438 : : end do
3439 : : end if
3440 : :
3441 : : ! ###########################################################
3442 : : ! ### 04. Treatment of strings 'STR'
3443 : :
3444 [ # # ]: 0 : else if(typevarphys=='STR')then
3445 [ # # ]: 0 : if (.not. present(strarr)) then
3446 : 0 : write(msg,'(a,a)') 'typevarphys equal STR but no strarr given!',ch10
3447 : 0 : ABI_ERROR(msg)
3448 : : end if
3449 : :
3450 : : ! Determine whether the different non-default occurrences are all equal
3451 : :
3452 [ # # ]: 0 : if (use_narrm==0) then ! use of scalar 'narr' instead of array 'narrm'
3453 [ # # ]: 0 : if(ndtset_alloc>1)then
3454 [ # # ]: 0 : do idtset=1,ndtset_alloc
3455 [ # # ]: 0 : do iarr=1,narr
3456 [ # # ]: 0 : if(strarr(iarr,1)/=strarr(iarr,idtset))multi=1
3457 : : end do
3458 : : end do
3459 : : end if
3460 : : else
3461 : : ! If the sizes of the arrays are different we can not compare them
3462 : : ! So we have to assume they are different
3463 : : multi=1
3464 : : end if
3465 : :
3466 : : ! If they are all equal, then determine whether they are equal to the default
3467 [ # # ]: 0 : if(multi==0)then
3468 : : print_out=.false.
3469 : : do iarr=1,narr
3470 : : if (trim(strarr(iarr,1))/=trim(strarr(iarr,0))) print_out=.true.
3471 : : end do
3472 : : print_netcdf=print_out
3473 : : end if
3474 : :
3475 : : if (present(forceprint)) then
3476 : : if (forceprint==1.or.forceprint==3) print_out=.true.
3477 : : if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3478 : : end if
3479 : :
3480 : 0 : print_out = .TRUE.
3481 : :
3482 : : ! Print only if the values differ from the default
3483 : : if (print_out.or.print_netcdf.or.(ncid<0))then
3484 : 0 : ndtset_eff=ndtset_alloc
3485 [ # # # # ]: 0 : if((multi==0).or.(ncid<0)) ndtset_eff=1
3486 [ # # ]: 0 : do idtset=1,ndtset_eff
3487 : :
3488 : : ! Initialize the character in the first column
3489 [ # # ]: 0 : first_column=' ';if (present(firstchar)) first_column=firstchar
3490 : : ! Initialize the format
3491 : 0 : format_str=f_str
3492 : : ! Initialize the dataset number string, and print
3493 [ # # # # ]: 0 : if((multi==0).or.(ncid<0))then
3494 : 0 : append=' '
3495 : : else
3496 : 0 : jdtset=jdtset_(idtset)
3497 : 0 : call appdig(jdtset,'',append)
3498 : : end if
3499 [ # # ]: 0 : full_format='("'//first_column//trim(format_1)//trim(format_str)//")"
3500 : :
3501 : : ! narr_eff could be narr or narrm(idtset)
3502 : : ! It depends if the size is variable for different datasets
3503 [ # # ]: 0 : if (use_narrm==0)then
3504 : 0 : narr_eff=narr
3505 : : else
3506 : 0 : narr_eff=narrm(idtset)
3507 : : end if
3508 : :
3509 [ # # ]: 0 : if (narr_eff/=0) then
3510 : :
3511 [ # # # # : 0 : if (print_out) write(iout,full_format) token,trim(append),(trim(strarr(iarr,idtset)),iarr=1,narr_eff)
# # ]
3512 : : ! if (print_netcdf) then
3513 : : ! call write_var_netcdf(intarr(1:narr_eff,idtset),&
3514 : : !& dprarr(1:narr_eff,idtset),marr,narr_eff,abs(ncid),typevarphys,token//append)
3515 : : ! end if
3516 : : end if
3517 : :
3518 : : end do
3519 : : end if !(print==1)
3520 : :
3521 : : ! ###########################################################
3522 : : ! ### 05. The type is neither 'INT' nor 'DPR', 'STR', 'ENE','LEN','BFI','TIM'
3523 : : else
3524 [ # # ]: 0 : ABI_BUG('Disallowed typevarphys = '//TRIM(typevarphys))
3525 : : end if
3526 : :
3527 : : end if ! End condition of narr>0
3528 : :
3529 [ - + ]: 3734424 : end subroutine prttagm
3530 : : !!***
3531 : :
3532 : : !!****f* m_parser/prttagm_images
3533 : : !!
3534 : : !! NAME
3535 : : !! prttagm_images
3536 : : !!
3537 : : !! FUNCTION
3538 : : !! Extension to prttagm to include the printing of
3539 : : !! images information, in those cases the same variable
3540 : : !! is printed several times for each dataset
3541 : : !!
3542 : : !! Cases where images information are relevant includes xcart, xred, acell, fcart.
3543 : : !!
3544 : : !! INPUT
3545 : : !! (see prttagm.F90)
3546 : : !!
3547 : : !! OUTPUT
3548 : : !! (only writing)
3549 : : !!
3550 : : !! SOURCE
3551 : :
3552 : 57062 : subroutine prttagm_images(dprarr_images,iout,jdtset_,length,&
3553 : 57062 : & marr,narrm,ncid,ndtset_alloc,token,typevarphys,&
3554 : 57062 : & mxnimage,nimagem,ndtset,prtimg,strimg,firstchar,forceprint)
3555 : :
3556 : : !Arguments ------------------------------------
3557 : : !scalars
3558 : : integer,intent(in) :: iout,length,marr,ndtset_alloc,ncid
3559 : : integer,intent(in) :: mxnimage,ndtset
3560 : : integer,intent(in),optional :: forceprint
3561 : : character(len=*),intent(in) :: token
3562 : : character(len=3),intent(in) :: typevarphys
3563 : : character(len=1),intent(in),optional :: firstchar
3564 : : !arrays
3565 : : integer,intent(in) :: prtimg(mxnimage,0:ndtset_alloc)
3566 : : integer,intent(in) :: jdtset_(0:ndtset_alloc)
3567 : : integer,intent(in) :: nimagem(0:ndtset_alloc)
3568 : : character(len=8),intent(in) :: strimg(mxnimage)
3569 : : integer,intent(in) :: narrm(0:ndtset_alloc)
3570 : : real(dp),intent(in) :: dprarr_images(marr,mxnimage,0:ndtset_alloc)
3571 : :
3572 : : !Local variables-------------------------------
3573 : : integer :: iarr,idtset,iimage,jdtset,multi_narr,narr
3574 : 114124 : integer :: intarr_images(marr,mxnimage,0:ndtset_alloc)
3575 : 57062 : integer,allocatable :: intarr(:,:)
3576 : 57062 : real(dp), allocatable :: dprarr(:,:)
3577 : : logical :: print_out,print_netcdf,test_multiimages
3578 : : character(len=1) :: first_column
3579 : : character(len=4) :: append
3580 : : character(len=16) :: keywd
3581 : : character(len=50) :: full_format
3582 : : character(len=*), parameter :: format_1 ='",a16,t22,'
3583 : : character(len=*), parameter :: format_1a ='",a16,a,t22,'
3584 : : character(len=*), parameter :: format_2 ='",t22,'
3585 : : character(len=*), parameter :: long_dpr ='3es18.10)'
3586 : : ! *************************************************************************
3587 : :
3588 : : !Test whether for this variable, the content of different images differ.
3589 : : !test_multiimages=.false. if, for all datasets, the content is identical.
3590 : 57062 : test_multiimages=.false.
3591 [ + + ]: 316268 : do idtset=1,ndtset_alloc
3592 [ + + ]: 316268 : if(nimagem(idtset)>1)then
3593 [ + + ]: 10460 : do iarr=1,narrm(idtset)
3594 [ + + + + ]: 53248 : if(sum(abs( dprarr_images(iarr,2:nimagem(idtset),idtset)- &
3595 : 1900 : & dprarr_images(iarr,1 ,idtset)))>tol12)then
3596 : 2536 : test_multiimages=.true.
3597 : : end if
3598 : : end do
3599 : : end if
3600 : : end do
3601 : :
3602 [ + + ]: 57062 : if(nimagem(0)==0)test_multiimages=.true.
3603 : :
3604 : : !If there is no differences between images, one is back to the usual prttagm routine.
3605 : : !Note the treatment of firstchar and forceprint has to be transmitted to prttagm.
3606 [ + + ]: 50284 : if(.not.test_multiimages)then
3607 : :
3608 : 50096 : narr=narrm(1)
3609 [ - + + - : 200384 : ABI_MALLOC(intarr,(marr,0:ndtset_alloc))
- + + - +
- + - - +
- + ]
3610 [ - + + - : 200384 : ABI_MALLOC(dprarr,(marr,0:ndtset_alloc))
- + + - +
- + - - +
- + ]
3611 [ + + + + ]: 219555782 : dprarr=zero
3612 [ + + ]: 332210 : do idtset=0,ndtset_alloc
3613 [ + + ]: 2056866 : dprarr(1:narrm(idtset),idtset)=dprarr_images(1:narrm(idtset),1,idtset)
3614 : : end do
3615 : 50096 : multi_narr=0
3616 [ + + ]: 50096 : if(ndtset_alloc>1)then
3617 [ + + ]: 250178 : do idtset=1,ndtset_alloc
3618 [ + + ]: 250178 : if(narrm(1)/=narrm(idtset))multi_narr=1
3619 : : end do
3620 : : end if
3621 [ - + ]: 50096 : if (present(firstchar).and.present(forceprint)) then
3622 : : call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3623 : : narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3624 : 0 : firstchar=firstchar,forceprint=forceprint)
3625 [ - + ]: 50096 : else if (present(firstchar)) then
3626 : : call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3627 : : narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3628 : 0 : firstchar=firstchar)
3629 [ + + ]: 50096 : else if (present(forceprint)) then
3630 : : call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3631 : : narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr,&
3632 : 13644 : forceprint=forceprint)
3633 : : else
3634 : : call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3635 : 36452 : narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr)
3636 : : end if
3637 [ - + ]: 50096 : ABI_FREE(intarr)
3638 [ - + ]: 50096 : ABI_FREE(dprarr)
3639 : :
3640 : : else
3641 : :
3642 [ - + ]: 6966 : first_column=' ';if (present(firstchar)) first_column=firstchar
3643 : :
3644 [ + + ]: 34154 : do idtset=1,ndtset_alloc
3645 : :
3646 [ + + ]: 34154 : if (narrm(idtset)>0)then
3647 [ + + ]: 50764 : do iimage=1,nimagem(idtset)
3648 : :
3649 : 26994 : print_out=.true.
3650 [ + + ]: 26994 : if (prtimg(iimage,idtset)==0) print_out=.false.
3651 [ + - ]: 26994 : if (nimagem(0)>=nimagem(idtset)) then
3652 [ # # # # ]: 0 : if (sum(abs(dprarr_images(1:narrm(idtset),iimage,idtset) &
3653 : 26994 : & -dprarr_images(1:narrm(idtset),iimage,0)))<tol12) print_out=.false.
3654 : : end if
3655 : 26994 : print_netcdf=print_out
3656 : :
3657 [ + + ]: 26994 : if (present(forceprint)) then
3658 [ - + ]: 796 : if (forceprint==1.or.forceprint==3) print_out=.true.
3659 [ - + ]: 796 : if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3660 : : end if
3661 : :
3662 [ + + - + ]: 49968 : if (print_out.or.print_netcdf.or.(ncid<0))then
3663 [ + + ]: 26970 : keywd=token//trim(strimg(iimage))
3664 : :
3665 [ + + ]: 26970 : if(ndtset>0)then
3666 : 24064 : jdtset=jdtset_(idtset)
3667 : 24064 : call appdig(jdtset,'',append)
3668 [ + - ]: 24064 : if (print_out) then
3669 : : full_format='("'//first_column//trim(format_1a)//'("'// &
3670 : 24064 : first_column//trim(format_2)//trim(long_dpr)//")"
3671 : : write(iout,full_format) &
3672 : 24064 : trim(keywd),append,dprarr_images(1:narrm(idtset),iimage,idtset)
3673 : : end if
3674 [ + - ]: 24064 : if (print_netcdf) then
3675 : : call write_var_netcdf(intarr_images(1:narrm(idtset),iimage,idtset),&
3676 : : dprarr_images(1:narrm(idtset),iimage,idtset),&
3677 [ + - ]: 24064 : marr,narrm(idtset),ncid,'DPR',trim(keywd)//append)
3678 : : end if
3679 : : else
3680 : :
3681 [ + - ]: 2906 : if (print_out) then
3682 : : full_format='("'//first_column//trim(format_1)//'("'// &
3683 : 2906 : first_column//trim(format_2)//trim(long_dpr)//")"
3684 : : write(iout,full_format) &
3685 : 2906 : trim(keywd),dprarr_images(1:narrm(idtset),iimage,idtset)
3686 : : end if
3687 [ + - ]: 2906 : if (print_netcdf) then
3688 : : call write_var_netcdf(intarr_images(1:narrm(idtset),iimage,idtset),&
3689 : : & dprarr_images(1:narrm(idtset),iimage,idtset),&
3690 [ + - ]: 2906 : & marr,narrm(idtset),abs(ncid),'DPR',trim(keywd))
3691 : : end if
3692 : : end if
3693 : : end if
3694 : : end do
3695 : : end if
3696 : : end do
3697 : :
3698 : : end if
3699 : :
3700 : 57062 : end subroutine prttagm_images
3701 : : !!***
3702 : :
3703 : : !!****f* m_parser/chkvars_in_string
3704 : : !! NAME
3705 : : !! chkvars_in_string
3706 : : !!
3707 : : !! FUNCTION
3708 : : !! Analyze variable names in string. Ignore tokens within double quotation marks.
3709 : : !! Abort if name is not recognized.
3710 : : !!
3711 : : !! INPUTS
3712 : : !! protocol=
3713 : : !! 0 if parser does not accept multiple datasets and +* syntax (e.g. anaddb)
3714 : : !! 1 if parser accepts multiple datasets and +* syntax (e.g. abinit)
3715 : : !!
3716 : : !! list_vars(len=*)=string with the (upper case) names of the variables (excluding logicals and chars).
3717 : : !! list_vars_img(len=*)=string with the (upper case) names of the variables (excluding logicals and chars),
3718 : : !! for which the image can be specified.
3719 : : !! list_logicals(len=*)=string with the (upper case) names of the logical variables.
3720 : : !! list_strings(len=*)=string with the (upper case) names of the character variables.
3721 : : !! string(len=*)=string (with upper case) from the input file.
3722 : : !!
3723 : : !! OUTPUT
3724 : : !! Abort if variable name is not recognized.
3725 : : !!
3726 : : !! SOURCE
3727 : :
3728 : 1620 : subroutine chkvars_in_string(protocol, list_vars, list_vars_img, list_logicals, list_strings, string)
3729 : :
3730 : : !Arguments ------------------------------------
3731 : : !scalars
3732 : : integer,intent(in) :: protocol
3733 : : character(len=*),intent(in) :: string
3734 : : character(len=*),intent(in) :: list_logicals,list_strings,list_vars, list_vars_img
3735 : :
3736 : : !Local variables-------------------------------
3737 : : character,parameter :: blank=' '
3738 : : !scalars
3739 : : integer :: index_blank,index_current,index_endfullword, index_endword,index_endwordnow,index_list_vars
3740 : : character(len=500) :: msg
3741 : : !************************************************************************
3742 : :
3743 : : !write(std_out,"(3a)")"Checking vars in string:", ch10, trim(string)
3744 : :
3745 : 1620 : index_current=1
3746 : : do
3747 : : ! Infinite do-loop, to identify the presence of each potential variable names
3748 : :
3749 [ + + ]: 229749 : if(len_trim(string)<=index_current)exit
3750 : 228129 : index_blank=index(string(index_current:),blank)+index_current-1
3751 : :
3752 [ + + ]: 228129 : if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_current:index_current))/=0)then
3753 : :
3754 : 70651 : index_endfullword = index_blank -1
3755 : 70651 : index_endword = index_blank -1
3756 : :
3757 [ + + ]: 70651 : if (protocol == 1) then
3758 : : ! Skip characters like : + or the digits at the end of the word
3759 : : ! Start from the blank that follows the end of the word
3760 [ + - ]: 98932 : do index_endword=index_blank-1,index_current,-1
3761 [ + + ]: 98932 : if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_endword:index_endword))/=0)exit
3762 : : end do
3763 : : end if
3764 : : !write(std_out,*)"Will analyze:", string(index_current:index_endword)
3765 : :
3766 : : ! Find the index of the potential variable name in the list of variables
3767 : 70651 : index_list_vars=index(list_vars,blank//string(index_current:index_endword)//blank)
3768 : :
3769 : : ! Treat the complications due to the possibility of images
3770 [ + + + + ]: 70651 : if (index_list_vars==0 .and. protocol==1) then
3771 : :
3772 : : ! Treat possible LASTIMG appendix
3773 [ + - ]: 49 : if(index_endword-6>=1)then
3774 [ + + ]: 49 : if(string(index_endword-6:index_endword)=='LASTIMG')index_endword=index_endword-7
3775 : : end if
3776 : :
3777 : : ! Treat possible IMG appendix
3778 [ + - ]: 49 : if(index_endword-2>=1)then
3779 [ + + ]: 49 : if(string(index_endword-2:index_endword)=='IMG')index_endword=index_endword-3
3780 : : end if
3781 : :
3782 : : index_endwordnow=index_endword
3783 : :
3784 : : ! Again skip characters like : + or the digits before IMG
3785 : : ! Start from the blank that follows the end of the word
3786 [ + - ]: 92 : do index_endword=index_endwordnow,index_current,-1
3787 [ + + ]: 92 : if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_endword:index_endword))/=0)exit
3788 : : end do
3789 : :
3790 : : ! Find the index of the potential variable name in the list of variables for which
3791 : : ! the image index can be specified
3792 : 49 : index_list_vars=index(list_vars_img,blank//string(index_current:index_endword)//blank)
3793 : : end if
3794 : :
3795 [ + + ]: 399 : if(index_list_vars==0)then
3796 : :
3797 : : ! Treat possible logical input variables
3798 [ + + ]: 368 : if(index(list_logicals,blank//string(index_current:index_endword)//blank)/=0)then
3799 : 1 : index_blank=index(string(index_current:),blank)+index_current-1
3800 [ - + ]: 1 : if(index(' F T ',string(index_blank:index_blank+2))==0)then
3801 : : write(msg, '(8a)' )&
3802 : 0 : 'Found token `',string(index_current:index_endword),'` in the input file.',ch10,&
3803 : 0 : 'This variable should be given a logical value (T or F), but the following string was found:',&
3804 : 0 : string(index_blank:index_blank+2),ch10,&
3805 : 0 : 'Action: check your input file. You likely misused the input variable.'
3806 : 0 : ABI_ERROR(msg)
3807 : : else
3808 : : index_blank=index_blank+2
3809 : : end if
3810 : :
3811 [ + - ]: 367 : else if(index(list_strings,blank//string(index_current:index_endword)//blank)/=0)then
3812 : : ! Treat possible string input variables
3813 : : ! Every following string is accepted
3814 : 367 : index_current=index(string(index_current:),blank)+index_current
3815 : 367 : index_blank=index(string(index_current:),blank)+index_current-1
3816 : :
3817 : : else
3818 : : ! If still not admitted, then there is a problem
3819 : : write(msg, '(9a)' )&
3820 : 0 : 'Found token: `',string(index_current:index_endfullword),'` in the input file.',ch10,&
3821 : 0 : 'This name is not one of the registered input variable names (see https://docs.abinit.org/).',ch10,&
3822 : 0 : 'Action: check your input file. Perhaps you mistyped the input variable,',ch10,&
3823 : 0 : 'or specified "img", although this was not permitted for this input variable.'
3824 : 0 : ABI_ERROR(msg)
3825 : : end if
3826 : : end if
3827 : : end if
3828 : :
3829 : 228129 : index_current=index_blank+1
3830 : :
3831 [ + + ]: 229749 : if (string(index_current:index_current) == '"') then
3832 : : do
3833 : 295992 : index_current = index_current + 1
3834 [ + + ]: 295992 : if (string(index_current:index_current) == '"') exit
3835 [ + - ]: 295992 : if (index_current > len_trim(string)) then
3836 : 0 : ABI_ERROR('Cannot find closing quotation mark " in string. You likely forgot to close a string')
3837 : : end if
3838 : : end do
3839 : :
3840 : : end if
3841 : :
3842 : : end do
3843 : :
3844 : 1620 : end subroutine chkvars_in_string
3845 : : !!***
3846 : :
3847 : : !!****f* m_parser/geo_from_abivar_string
3848 : : !! NAME
3849 : : !! geo_from_abivars_string
3850 : : !!
3851 : : !! FUNCTION
3852 : : !! Build object form abinit `structure` variable
3853 : : !!
3854 : : !! INPUTS
3855 : : !! comm=MPI communicator. Used for performing IO.
3856 : : !!
3857 : : !! SOURCE
3858 : :
3859 : 165 : type(geo_t) function geo_from_abivar_string(string, comm) result(new)
3860 : :
3861 : : !Arguments ------------------------------------
3862 : : character(len=*),intent(in) :: string
3863 : : integer,intent(in) :: comm
3864 : :
3865 : : !Local variables-------------------------------
3866 : : integer :: ii
3867 : 165 : character(len=len(string)) :: prefix
3868 : : !************************************************************************
3869 : :
3870 : : !print *, "in geo_from_abivar_string: `", trim(string), "`"
3871 : :
3872 : 165 : ii = index(string, ":")
3873 : 0 : ABI_CHECK(ii > 0, sjoin("Expecting string of the form `type:content`, got:", string))
3874 [ + - + - ]: 165 : prefix = adjustl(string(1:ii-1))
3875 : :
3876 : 48 : select case (prefix)
3877 : :
3878 : : case ("poscar")
3879 : : ! Build geo ifrom POSCAR from file.
3880 [ + - ]: 48 : new = geo_from_poscar_path(trim(string(ii+1:)), comm)
3881 : :
3882 : : case ("abivars")
3883 : : ! Build geo from from file with Abinit variables.
3884 [ + - ]: 3 : new = geo_from_abivars_path(trim(string(ii+1:)), comm)
3885 : :
3886 : : case ("abifile")
3887 [ + - ]: 114 : if (endswith(string(ii+1:), ".nc")) then
3888 : : ! Build geo from netcdf file.
3889 [ + - ]: 114 : new = geo_from_netcdf_path(trim(string(ii+1:)), comm)
3890 : : else
3891 : : ! Assume Fortran file with Abinit header.
3892 : 0 : ABI_ERROR("structure variable with Fortran file is not yet implemented.")
3893 : : !new = geo_from_fortran_file_with_hdr(string(ii+1:), comm)
3894 : : !cryst = crystal_from_file(string(ii+1:), comm)
3895 : : !if (cryst%isalchemical()) then
3896 : : ! ABI_ERROR("Alchemical mixing is not compatible with `structure` input variable!")
3897 : : !end if
3898 : : !new%natom = cryst%natom
3899 : : !new%ntypat = cryst%ntypat
3900 : : !new%rprimd = cryst%rprimd
3901 : : !call alloc_copy(cryst%typat, new%typat)
3902 : : !call alloc_copy(cryst%xred, new%xred)
3903 : : !call alloc_copy(cryst%znucl, new%znucl)
3904 : : !call cryst%free()
3905 : : end if
3906 : :
3907 : : case default
3908 [ + + + - ]: 165 : ABI_ERROR(sjoin("Invalid prefix: `", prefix, "`"))
3909 : : end select
3910 : :
3911 [ - + ]: 165 : end function geo_from_abivar_string
3912 : : !!***
3913 : :
3914 : : !!****f* m_parser/geo_from_abivars_path
3915 : : !! NAME
3916 : : !! geo_from_abivars_path
3917 : : !!
3918 : : !! FUNCTION
3919 : : !!
3920 : : !! SOURCE
3921 : :
3922 : 3 : type(geo_t) function geo_from_abivars_path(path, comm) result(new)
3923 : :
3924 : : !Arguments ------------------------------------
3925 : : character(len=*),intent(in) :: path
3926 : : integer,intent(in) :: comm
3927 : :
3928 : : !Local variables-------------------------------
3929 : : integer,parameter :: master = 0, option1 = 1
3930 : : integer :: jdtset, iimage, nimage, iatom, itypat
3931 : : integer :: my_rank, lenstr, ierr, ii, start, tread, marr
3932 : : !character(len=500) :: msg
3933 : : character(len=strlen) :: string, raw_string
3934 : : !arrays
3935 : 3 : integer,allocatable :: intarr(:)
3936 : : real(dp) :: acell(3), rprim(3,3)
3937 : 3 : real(dp),allocatable :: dprarr(:)
3938 : 3 : character(len=5),allocatable :: symbols(:)
3939 : : !************************************************************************
3940 : :
3941 : : ! Master node reads string and broadcasts
3942 : 6 : my_rank = xmpi_comm_rank(comm)
3943 : :
3944 [ + - ]: 3 : if (my_rank == master) then
3945 : : ! Below part copied from `parsefile`. strlen from defs_basis module
3946 : 3 : call instrng(path, lenstr, option1, strlen, string, raw_string)
3947 : : ! To make case-insensitive, map characters of string to upper case.
3948 : 3 : call inupper(string(1:lenstr))
3949 : : !call chkvars_in_string(protocol1, list_vars, list_logicals, list_strings, string)
3950 : : end if
3951 : :
3952 [ - + ]: 3 : if (xmpi_comm_size(comm) > 1) then
3953 : 0 : call xmpi_bcast(string, master, comm, ierr)
3954 : 0 : call xmpi_bcast(lenstr, master, comm, ierr)
3955 : : end if
3956 : :
3957 : : ! ==============================
3958 : : ! Now all procs parse the string
3959 : : ! ==============================
3960 : :
3961 : 3 : jdtset = 0; iimage = 0; nimage = 0
3962 : :
3963 : : ! Get the number of atom in the unit cell. Read natom from string
3964 : 3 : marr = 1
3965 [ - + ]: 3 : ABI_MALLOC(intarr, (marr))
3966 [ - + ]: 3 : ABI_MALLOC(dprarr, (marr))
3967 : :
3968 : 3 : call intagm(dprarr, intarr, jdtset, marr, 1, string(1:lenstr), 'natom', tread, 'INT')
3969 [ - + ]: 3 : ABI_CHECK(tread /= 0, sjoin("natom is required in file:", path))
3970 : 3 : new%natom = intarr(1)
3971 : :
3972 : 3 : marr = max(12, 3*new%natom)
3973 [ - + + - : 9 : ABI_REMALLOC(intarr, (marr))
+ - - + -
+ - + ]
3974 [ + - - + : 9 : ABI_REMALLOC(dprarr, (marr))
+ - + - -
+ - + -
+ ]
3975 : :
3976 : : ! Set up unit cell from acell, rprim, angdeg
3977 : 3 : call get_acell_rprim(lenstr, string, jdtset, iimage, nimage, marr, acell, rprim)
3978 : :
3979 : : ! Compute different matrices in real and reciprocal space, also checks whether ucvol is positive.
3980 : 3 : call mkrdim(acell, rprim, new%rprimd)
3981 : :
3982 : : ! Parse atomic positions.
3983 : : ! Only xcart is supported here because it makes life easier and we don't need to handle symbols + Units
3984 : 3 : ii = index(string(1:lenstr), "XRED_SYMBOLS")
3985 [ - + ]: 3 : ABI_CHECK(ii /= 0, "In structure mode only `xred_symbols` with coords followed by element symbol are supported")
3986 : :
3987 : 3 : new%fileformat = "abivars"
3988 [ - + + - : 9 : ABI_MALLOC(new%xred, (3, new%natom))
+ - + - -
+ - + -
+ ]
3989 : :
3990 [ - + + - : 9 : ABI_MALLOC(symbols, (new%natom))
+ - + - -
+ - + -
+ ]
3991 : 3 : start = ii + len("XRED_SYMBOLS")
3992 [ + + ]: 12 : do iatom=1,new%natom
3993 : 9 : call inarray(start, "xred_symbols", dprarr, intarr, marr, 3, string, "DPR")
3994 [ + + ]: 36 : new%xred(:, iatom) = dprarr(1:3)
3995 [ - + ]: 9 : ABI_CHECK(next_token(string, start, symbols(iatom)) == 0, "Error while reading element symbol.")
3996 [ + - ]: 9 : symbols(iatom) = tolower(symbols(iatom))
3997 [ - + ]: 12 : symbols(iatom)(1:1) = toupper(symbols(iatom)(1:1))
3998 : : !write(std_out, *)"xred", new%xred(:, iatom), "symbol:", trim(symbols(iatom))
3999 : : end do
4000 : :
4001 [ - + ]: 3 : call typat_from_symbols(symbols, new%ntypat, new%typat)
4002 : :
4003 : : ! Note that the first letter should be capitalized, rest must be lower case
4004 [ - + + - : 9 : ABI_MALLOC(new%znucl, (new%ntypat))
+ - + - -
+ - + -
+ ]
4005 [ + + ]: 12 : do iatom=1,new%natom
4006 : 9 : itypat = new%typat(iatom)
4007 : 12 : new%znucl(itypat) = symbol2znucl(symbols(iatom))
4008 : : end do
4009 : :
4010 [ - + ]: 3 : ABI_FREE(symbols)
4011 [ - + ]: 3 : ABI_FREE(intarr)
4012 [ - + ]: 6 : ABI_FREE(dprarr)
4013 : :
4014 : : !call new%print_abivars(std_out)
4015 : :
4016 : : contains
4017 : :
4018 [ - + ]: 3 : subroutine typat_from_symbols(symbols, ntypat, typat)
4019 : :
4020 : : !Arguments ------------------------------------
4021 : : character(len=*),intent(in) :: symbols(:)
4022 : : integer,intent(out) :: ntypat
4023 : : integer,allocatable,intent(out) :: typat(:)
4024 : :
4025 : : !Local variables-------------------------------
4026 : : integer :: ii, jj, nstr, found
4027 : : !************************************************************************
4028 : :
4029 : 3 : nstr = size(symbols)
4030 [ - + + - : 18 : ABI_ICALLOC(typat, (nstr))
+ - + - -
+ - + - +
+ + ]
4031 : :
4032 : 3 : typat(1) = 1
4033 : 3 : ntypat = 1
4034 [ + + ]: 9 : do ii=2, nstr
4035 : 6 : found = 0
4036 [ + + ]: 12 : do jj=1, ntypat
4037 [ + + ]: 12 : if (symbols(ii) == symbols(typat(jj))) then
4038 : : found = jj; exit
4039 : : end if
4040 : : end do
4041 [ + + ]: 9 : if (found == 0) then
4042 : 3 : ntypat = ntypat + 1
4043 : 3 : typat(ii) = ntypat
4044 : : else
4045 : 3 : typat(ii) = found
4046 : : end if
4047 : : end do
4048 : :
4049 : 3 : end subroutine typat_from_symbols
4050 : :
4051 : : end function geo_from_abivars_path
4052 : : !!***
4053 : :
4054 : : !!****f* m_parser/geo_from_poscar_path
4055 : : !! NAME
4056 : : !! geo_from_poscar_path
4057 : : !!
4058 : : !! FUNCTION
4059 : : !!
4060 : : !! SOURCE
4061 : :
4062 : 48 : type(geo_t) function geo_from_poscar_path(path, comm) result(new)
4063 : :
4064 : : !Arguments ------------------------------------
4065 : : character(len=*),intent(in) :: path
4066 : : integer,intent(in) :: comm
4067 : :
4068 : : !Local variables-------------------------------
4069 : : integer,parameter :: master = 0
4070 : : integer :: unt, my_rank
4071 : : character(len=500) :: msg
4072 : : !************************************************************************
4073 : :
4074 : 96 : my_rank = xmpi_comm_rank(comm)
4075 : :
4076 [ + - ]: 48 : if (my_rank == master) then
4077 [ - + ]: 48 : if (open_file(path, msg, newunit=unt, form='formatted', status='old', action="read") /= 0) then
4078 : 0 : ABI_ERROR(msg)
4079 : : end if
4080 : 48 : new = geo_from_poscar_unit(unt)
4081 : 48 : close(unt)
4082 : : end if
4083 : :
4084 [ - + ]: 48 : if (xmpi_comm_size(comm) > 1) call new%bcast(master, comm)
4085 : :
4086 : 48 : end function geo_from_poscar_path
4087 : : !!***
4088 : :
4089 : : !!****f* m_parser/geo_from_poscar_unit
4090 : : !! NAME
4091 : : !! geo_from_poscar_unit
4092 : : !!
4093 : : !! FUNCTION
4094 : : !! Build object from string with separator `sep`. Usually sep = newline = ch10
4095 : : !!
4096 : : !! SOURCE
4097 : :
4098 : 48 : type(geo_t) function geo_from_poscar_unit(unit) result(new)
4099 : :
4100 : : !Arguments ------------------------------------
4101 : : integer,intent(in) :: unit
4102 : :
4103 : : !Local variables-------------------------------
4104 : : !integer,parameter :: marr = 3
4105 : : integer :: beg, iatom, itypat, ierr, ii, cnt
4106 : : real(dp) :: scaling_constant
4107 : : character(len=500) :: line, system, iomsg
4108 : : character(len=5) :: symbol
4109 : : !arrays
4110 : 48 : integer,allocatable :: nattyp(:)
4111 : 48 : logical,allocatable :: duplicated(:)
4112 : 48 : character(len=5),allocatable :: symbols(:), dupe_symbols(:)
4113 : 48 : real(dp),allocatable :: xcart(:,:)
4114 : : !************************************************************************
4115 : :
4116 : : ! Example of POSCAR (with 6 figures --> space group won't be recognized by Abinit
4117 : : ! See also https://github.com/ExpHP/vasp-poscar/blob/master/doc/format.md
4118 : :
4119 : : ! Mg1 B2
4120 : : ! 1.0
4121 : : ! 2.672554 1.543000 0.000000
4122 : : ! -2.672554 1.543000 0.000000
4123 : : ! 0.000000 0.000000 3.523000
4124 : : ! Mg B
4125 : : ! 1 2
4126 : : ! direct
4127 : : ! 0.000000 0.000000 0.000000 Mg
4128 : : ! 0.333333 0.666667 0.500000 B
4129 : : ! 0.666667 0.333333 0.500000 B
4130 : :
4131 : 48 : new%fileformat = "poscar"
4132 [ + - ]: 48 : read(unit, "(a)", err=10, iomsg=iomsg) new%title
4133 [ + - ]: 48 : read(unit, *, err=10, iomsg=iomsg) scaling_constant
4134 [ + + ]: 192 : do ii=1,3
4135 [ + - ]: 192 : read(unit, *, err=10, iomsg=iomsg) new%rprimd(:, ii)
4136 : : end do
4137 : :
4138 : : ! Read line with the names of the atoms.
4139 [ + - ]: 48 : read(unit, "(a)", err=10, iomsg=iomsg) line
4140 : : !print *, "line:", trim(line)
4141 : :
4142 : 48 : new%ntypat = 0
4143 [ + + ]: 144 : do ii=1,2
4144 [ + + ]: 96 : if (ii == 2) then
4145 [ - + + - : 144 : ABI_MALLOC(symbols, (new%ntypat))
+ - + - -
+ - + -
+ ]
4146 : : end if
4147 : 96 : itypat = 0; beg = 1
4148 : 48 : do
4149 : 378 : ierr = next_token(line, beg, symbol)
4150 : : !print *, "ierr:", ierr, "beg:", beg, "symbol:", trim(symbol)
4151 [ + + ]: 378 : if (ierr /= 0) exit
4152 [ + + ]: 282 : if (ii == 1) new%ntypat = new%ntypat + 1
4153 [ + + ]: 378 : if (ii == 2) then
4154 : 141 : itypat = itypat + 1
4155 : 141 : symbols(itypat) = trim(symbol)
4156 : : end if
4157 : : end do
4158 : : end do
4159 : : !write(std_out, *)"ntypat: ", new%ntypat, "symbols: ", symbols
4160 : :
4161 : : ! TODO: Handle case in which not all atoms are not grouped by type
4162 [ - + + - : 144 : ABI_MALLOC(duplicated, (new%ntypat))
+ - + - -
+ - + ]
4163 [ + + ]: 189 : duplicated = .False.
4164 [ + + ]: 141 : do itypat=1,new%ntypat-1
4165 [ + + ]: 306 : do ii=itypat+1, new%ntypat
4166 [ - + ]: 258 : if (symbols(itypat) == symbols(ii)) duplicated(ii) = .True.
4167 : : end do
4168 : : end do
4169 : :
4170 : : ! number of atoms of each type.
4171 : : ! NOTE: Assuming ntypat == npsp thus alchemical mixing is not supported.
4172 : : ! There's a check in the main parser though.
4173 [ - + + - : 96 : ABI_MALLOC(nattyp, (new%ntypat))
- + - + -
+ ]
4174 [ + - ]: 48 : read(unit, *, err=10, iomsg=iomsg) nattyp
4175 [ + + ]: 189 : new%natom = sum(nattyp)
4176 [ - + ]: 48 : ABI_FREE(nattyp)
4177 : :
4178 [ + + + - : 189 : if (any(duplicated)) then
- + ]
4179 : : ! Need to recompute ntypat and symbols taking into account duplication.
4180 : 0 : ABI_WARNING("Found POSCAR with duplicated symbols")
4181 : 0 : ABI_MOVE_ALLOC(symbols, dupe_symbols)
4182 [ # # # # ]: 0 : new%ntypat = count(.not. duplicated)
4183 [ # # # # : 0 : ABI_MALLOC(symbols, (new%ntypat))
# # # # #
# # # ]
4184 : 0 : cnt = 0
4185 [ # # ]: 0 : do ii=1,size(duplicated)
4186 [ # # ]: 0 : if (.not. duplicated(ii)) then
4187 : 0 : cnt = cnt + 1; symbols(cnt) = dupe_symbols(ii)
4188 : : end if
4189 : : end do
4190 [ # # ]: 0 : ABI_FREE(dupe_symbols)
4191 : : end if
4192 : :
4193 : : ! At this point, we can allocate Abinit arrays.
4194 : 48 : call new%malloc()
4195 : :
4196 : : ! Note that first letter should be capitalized, rest must be lower case
4197 [ + + ]: 189 : do itypat=1,new%ntypat
4198 : 189 : new%znucl(itypat) = symbol2znucl(symbols(itypat))
4199 : : end do
4200 : :
4201 [ + - ]: 48 : read(unit, *, err=10, iomsg=iomsg) system
4202 [ + - ]: 48 : system = tolower(system)
4203 [ + + - + ]: 48 : if (system /= "cartesian" .and. system /= "direct") then
4204 : 0 : ABI_ERROR(sjoin("Expecting `cartesian` or `direct` for the coordinate system but got:", system))
4205 : : end if
4206 : :
4207 : : ! Parse atomic positions.
4208 [ + + ]: 630 : do iatom=1,new%natom
4209 : :
4210 : : ! This should implement the POSCAR format.
4211 [ + - ]: 582 : read(unit, *, err=10, iomsg=iomsg) new%xred(:, iatom), symbol
4212 [ - + ]: 582 : if (len_trim(symbol) == 0) then
4213 [ # # ]: 0 : if (new%ntypat == 1) then
4214 : 0 : ABI_COMMENT("POTCAR without element symbol after coords but this is not critical because ntypat == 1")
4215 : 0 : symbol = symbols(1)
4216 : : else
4217 : 0 : ABI_ERROR("POTCAR positions should be followed by element symbol.")
4218 : : end if
4219 : : end if
4220 : :
4221 : : ! This to handle symbol + oxidation state e.g. Li1+
4222 : : !print *, symbol
4223 : 582 : ii = find_digit(symbol)
4224 [ - + - - ]: 582 : if (ii /= 0) symbol = symbol(:ii-1)
4225 : :
4226 [ + - ]: 1488 : do itypat=1, new%ntypat
4227 [ + + ]: 1488 : if (symbols(itypat) == symbol) then
4228 : 582 : new%typat(iatom) = itypat; exit
4229 : : end if
4230 : : end do
4231 [ - + ]: 630 : if (itypat == new%ntypat + 1) then
4232 : 0 : ABI_ERROR(sjoin("Cannot find symbol:`", symbol, " `in initial symbol list. Typo or POSCAR without symbols?."))
4233 : : end if
4234 : : end do
4235 : :
4236 : : ! Convert ang -> bohr
4237 [ + - ]: 48 : if (scaling_constant > zero) then
4238 [ + + + + ]: 624 : new%rprimd = scaling_constant * new%rprimd * Ang_Bohr
4239 [ # # ]: 0 : else if (scaling_constant < zero) then
4240 : : ! A negative scale factor is treated as a volume. translate scaling_constant to a lattice vector scaling.
4241 [ # # # # ]: 0 : new%rprimd = Ang_Bohr * new%rprimd * (-scaling_constant / abs(det3r(new%rprimd))) ** (one / three)
4242 : : else
4243 : 0 : ABI_CHECK(scaling_constant > zero, sjoin("scaling constant must be /= 0 but found:", ftoa(scaling_constant)))
4244 : : end if
4245 : :
4246 [ + + ]: 48 : if (system == "cartesian") then
4247 : : ! Go from cartesian to reduced.
4248 [ - + + - : 135 : ABI_MALLOC(xcart, (3, new%natom))
+ - + - -
+ - + ]
4249 [ + - + - : 2382 : xcart = new%xred * Ang_Bohr
- + - - +
+ + + ]
4250 : 45 : call xcart2xred(new%natom, new%rprimd, xcart, new%xred)
4251 [ - + ]: 45 : ABI_FREE(xcart)
4252 : : end if
4253 : :
4254 [ - + ]: 48 : ABI_FREE(symbols)
4255 [ - + ]: 48 : ABI_FREE(duplicated)
4256 : 48 : return
4257 : :
4258 [ # # ]: 0 : 10 ABI_ERROR(sjoin("Error while parsing POSCAR file,", ch10, "iomsg:", trim(iomsg)))
4259 : :
4260 [ - + - + : 96 : end function geo_from_poscar_unit
- + ]
4261 : : !!***
4262 : :
4263 : : !!****f* m_parser/geo_print_abivars
4264 : : !! NAME
4265 : : !! geo_print_abivars
4266 : : !!
4267 : : !! FUNCTION
4268 : : !! Print Abinit variables corresponding to POSCAR
4269 : : !!
4270 : : !! SOURCE
4271 : :
4272 : 0 : subroutine geo_print_abivars(self, unit)
4273 : :
4274 : : !Arguments ------------------------------------
4275 : : class(geo_t),intent(in) :: self
4276 : : integer,intent(in) :: unit
4277 : :
4278 : : !Local variables-------------------------------
4279 : : integer :: ii, iatom, itypat
4280 : : !************************************************************************
4281 : :
4282 [ # # ]: 0 : if (unit == dev_null) return
4283 : :
4284 : 0 : write(unit, "(2a)")"# fileformat: ", trim(self%fileformat)
4285 [ # # ]: 0 : if (len_trim(self%title) > 0) write(unit, "(2a)")"# ",trim(self%title)
4286 : 0 : write(unit, "(a, i0)")" natom ", self%natom
4287 : 0 : write(unit, "(a, i0)")" ntypat ", self%ntypat
4288 : 0 : write(unit, sjoin("(a, ", itoa(self%natom), "(i0,1x))")) " typat ", self%typat
4289 : 0 : write(unit, sjoin("(a, ", itoa(self%ntypat), "(f5.1,1x))")) " znucl ", self%znucl
4290 : 0 : write(unit, "(a)")" acell 1 1 1 Bohr"
4291 : 0 : write(unit, "(a)")" rprim "
4292 [ # # ]: 0 : do ii=1,3
4293 : 0 : write(unit, "(2x, 3(f11.7,1x))") self%rprimd(:, ii)
4294 : : end do
4295 : 0 : write(unit, "(a)")" xred"
4296 [ # # ]: 0 : do iatom=1,self%natom
4297 : 0 : itypat = self%typat(iatom)
4298 [ # # ]: 0 : write(unit, "(2x, 3(f11.7,1x),3x,2a)") self%xred(:, iatom) , " # ", trim(znucl2symbol(self%znucl(itypat)))
4299 : : end do
4300 : :
4301 : : end subroutine geo_print_abivars
4302 : : !!***
4303 : :
4304 : : !!****f* m_parser/geo_from_netdf_path
4305 : : !! NAME
4306 : : !! geo_from_netdf_path
4307 : : !!
4308 : : !! FUNCTION
4309 : : !!
4310 : : !! SOURCE
4311 : :
4312 : 114 : type(geo_t) function geo_from_netcdf_path(path, comm) result(new)
4313 : :
4314 : : !Arguments ------------------------------------
4315 : : character(len=*),intent(in) :: path
4316 : : integer,intent(in) :: comm
4317 : :
4318 : : !Local variables-------------------------------
4319 : : integer, parameter :: master = 0
4320 : : integer :: ncid, npsp, dimid, itime
4321 : : logical :: has_nimage
4322 : : !************************************************************************
4323 : :
4324 : 114 : new%fileformat = "netcdf"
4325 : :
4326 [ + - ]: 114 : if (xmpi_comm_rank(comm) == master) then
4327 [ - + ]: 114 : NCF_CHECK(nctk_open_read(ncid, path, xmpi_comm_self))
4328 : :
4329 [ + + ]: 114 : if (endswith(path, "_HIST.nc")) then
4330 : : ! See def_file_hist.
4331 : : !ABI_ERROR("Cannot yet read structure from HIST.nc file")
4332 [ - + ]: 3 : NCF_CHECK(nctk_get_dim(ncid, "natom", new%natom))
4333 [ - + ]: 3 : NCF_CHECK(nctk_get_dim(ncid, "ntypat", new%ntypat))
4334 : :
4335 [ - + ]: 3 : NCF_CHECK(nctk_get_dim(ncid, "npsp", npsp))
4336 [ - + ]: 3 : ABI_CHECK(npsp == new%ntypat, 'Geo from HIST file with alchemical mixing!')
4337 : 3 : has_nimage = nf90_inq_dimid(ncid, "nimage", dimid) == nf90_noerr
4338 [ - + ]: 3 : ABI_CHECK(.not. has_nimage, "Cannot initialize structure from HIST.nc when file contains images.")
4339 : :
4340 : 3 : call new%malloc()
4341 : :
4342 [ - + ]: 3 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "typat"), new%typat))
4343 [ - + ]: 3 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "znucl"), new%znucl))
4344 : :
4345 : : ! time is NF90_UNLIMITED
4346 [ - + ]: 3 : NCF_CHECK(nctk_get_dim(ncid, "time", itime))
4347 : :
4348 : : ! dim3 = [xyz_id, xyz_id, time_id]
4349 [ + + - + : 12 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "rprimd"), new%rprimd, start=[1,1,itime]))
- - ]
4350 : :
4351 : : ! dim3 = [xyz_id, natom_id, time_id]
4352 [ + + - + : 12 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "xred"), new%xred, start=[1,1,itime]))
- - ]
4353 : :
4354 : : else
4355 : : ! Assume netcdf file produced by calling crystal%ncwrite
4356 [ - + ]: 111 : NCF_CHECK(nctk_get_dim(ncid, "number_of_atoms", new%natom))
4357 [ - + ]: 111 : NCF_CHECK(nctk_get_dim(ncid, "number_of_atom_species", new%ntypat))
4358 : :
4359 : : ! Test if alchemical. NB: nsps added in crystal_ncwrite in v9.
4360 [ - + ]: 111 : if (nf90_inq_dimid(ncid, "number_of_pseudopotentials", dimid) == nf90_noerr) then
4361 [ # # ]: 0 : NCF_CHECK(nf90_inquire_dimension(ncid, dimid, len=npsp))
4362 [ # # ]: 0 : ABI_CHECK(npsp == new%ntypat, 'Geo from HIST file with alchemical mixing!')
4363 : : end if
4364 : :
4365 : 111 : call new%malloc()
4366 : :
4367 [ - + ]: 111 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "primitive_vectors"), new%rprimd))
4368 [ - + ]: 111 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "atom_species"), new%typat))
4369 [ - + ]: 111 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "atomic_numbers"), new%znucl))
4370 [ - + ]: 111 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "reduced_atom_positions"), new%xred))
4371 : : end if
4372 : :
4373 [ - + ]: 114 : NCF_CHECK(nf90_close(ncid))
4374 : : end if
4375 : :
4376 : 114 : call new%bcast(master, comm)
4377 : : !call new%print_abivars(std_out)
4378 : :
4379 : 114 : end function geo_from_netcdf_path
4380 : : !!***
4381 : :
4382 : : !!****f* m_parser/geo_bcast
4383 : : !! NAME
4384 : : !! geo_bcast
4385 : : !!
4386 : : !! FUNCTION
4387 : : !! Broadcast object
4388 : : !!
4389 : : !! SOURCE
4390 : :
4391 : 114 : subroutine geo_bcast(self, master, comm)
4392 : :
4393 : : !Arguments ------------------------------------
4394 : : class(geo_t),intent(inout) :: self
4395 : : integer,intent(in) :: master, comm
4396 : :
4397 : : !Local variables-------------------------------
4398 : : integer :: ierr, my_rank, list_int(2)
4399 : : !************************************************************************
4400 : :
4401 [ + - ]: 114 : if (xmpi_comm_size(comm) == 1) return
4402 : 0 : my_rank = xmpi_comm_rank(comm)
4403 : :
4404 [ # # # # ]: 0 : if (my_rank == master) list_int = [self%natom, self%ntypat]
4405 : 0 : call xmpi_bcast(list_int, master, comm, ierr)
4406 : :
4407 [ # # ]: 0 : if (my_rank /= master) then
4408 : 0 : self%natom = list_int(1); self%ntypat = list_int(2)
4409 : 0 : call self%malloc()
4410 : : end if
4411 : :
4412 : 0 : call xmpi_bcast(self%rprimd, master, comm, ierr)
4413 : 0 : call xmpi_bcast(self%xred, master, comm, ierr)
4414 : 0 : call xmpi_bcast(self%typat, master, comm, ierr)
4415 : 0 : call xmpi_bcast(self%znucl, master, comm, ierr)
4416 : 0 : call xmpi_bcast(self%title, master, comm, ierr)
4417 : 0 : call xmpi_bcast(self%fileformat, master, comm, ierr)
4418 : :
4419 : : end subroutine geo_bcast
4420 : : !!***
4421 : :
4422 : : !!****f* m_parser/geo_malloc
4423 : : !! NAME
4424 : : !! geo_malloc
4425 : : !!
4426 : : !! FUNCTION
4427 : : !! Allocate memory once %natom and %ntypat are know
4428 : : !!
4429 : : !! SOURCE
4430 : :
4431 : 162 : subroutine geo_malloc(self)
4432 : :
4433 : : !Arguments ------------------------------------
4434 : : class(geo_t),intent(inout) :: self
4435 : : !************************************************************************
4436 : :
4437 [ - + + - : 486 : ABI_MALLOC(self%typat, (self%natom))
+ - + - -
+ - + -
+ ]
4438 [ - + + - : 486 : ABI_MALLOC(self%xred, (3, self%natom))
+ - + - -
+ - + -
+ ]
4439 [ - + + - : 486 : ABI_MALLOC(self%znucl, (self%ntypat))
+ - + - -
+ - + -
+ ]
4440 : :
4441 : 162 : end subroutine geo_malloc
4442 : : !!***
4443 : :
4444 : : !!****f* m_parser/geo_free
4445 : : !! NAME
4446 : : !! geo_free
4447 : : !!
4448 : : !! FUNCTION
4449 : : !! Free memory.
4450 : : !!
4451 : : !! SOURCE
4452 : :
4453 : 14363 : subroutine geo_free(self)
4454 : :
4455 : : !Arguments ------------------------------------
4456 : : class(geo_t),intent(inout) :: self
4457 : : !************************************************************************
4458 : :
4459 [ + + ]: 14363 : ABI_SFREE(self%typat)
4460 [ + + ]: 14363 : ABI_SFREE(self%xred)
4461 [ + + ]: 14363 : ABI_SFREE(self%znucl)
4462 : :
4463 : 14363 : end subroutine geo_free
4464 : : !!***
4465 : :
4466 : : !!****f* m_parser/get_acell_rprim
4467 : : !! NAME
4468 : : !! get_acell_rprim
4469 : : !!
4470 : : !! FUNCTION
4471 : : !! Get acell and rprim from string
4472 : : !!
4473 : : !! INPUTS
4474 : : !! string*(*)=character string containing all the input data. Initialized previously in instrng.
4475 : : !! jdtset=number of the dataset looked for
4476 : : !! iimage= index of the current image
4477 : : !! nimage=Number of images.
4478 : : !! marr=dimension of the intarr and dprarr arrays, as declared in the calling subroutine.
4479 : : !!
4480 : : !! OUTPUT
4481 : : !! acell(3)=length of primitive vectors
4482 : : !! rprim(3,3)=dimensionless real space primitive translations
4483 : : !!
4484 : : !! FUNCTION
4485 : : !!
4486 : : !! SOURCE
4487 : :
4488 : 7232 : subroutine get_acell_rprim(lenstr, string, jdtset, iimage, nimage, marr, acell, rprim)
4489 : :
4490 : : !Arguments ------------------------------------
4491 : : integer,intent(in) :: lenstr, jdtset, iimage, nimage, marr
4492 : : character(len=*),intent(in) :: string
4493 : : real(dp),intent(out) :: acell(3)
4494 : : real(dp),intent(out) :: rprim(3,3)
4495 : :
4496 : : !Local variables-------------------------------
4497 : : integer :: tacell, tangdeg, tread, trprim, mu
4498 : : real(dp) :: a2, aa, cc, cosang
4499 : : character(len=500) :: msg
4500 : : !arrays
4501 : 7232 : integer,allocatable :: intarr(:)
4502 : : real(dp) :: angdeg(3)
4503 : 7232 : real(dp),allocatable :: dprarr(:)
4504 : : !************************************************************************
4505 : :
4506 [ - + + - : 21696 : ABI_MALLOC(intarr, (marr))
+ - + - -
+ - + ]
4507 [ - + + - : 21696 : ABI_MALLOC(dprarr, (marr))
+ - + - -
+ - + ]
4508 : :
4509 [ + + ]: 28928 : acell(1:3) = one
4510 : 7232 : call intagm(dprarr,intarr,jdtset,marr,3,string(1:lenstr),'acell',tacell,'LEN')
4511 [ + + + + ]: 28889 : if(tacell==1) acell(1:3)=dprarr(1:3)
4512 : 7232 : call intagm_img(acell,iimage,jdtset,lenstr,nimage,3,string,"acell",tacell,'LEN')
4513 : :
4514 : : ! Check that input length scales acell(3) are > 0
4515 [ + + ]: 28928 : do mu=1,3
4516 [ - + ]: 28928 : if(acell(mu) <= zero) then
4517 : : write(msg, '(a,i0,a, 1p,e14.6,4a)' )&
4518 : 0 : 'Length scale ',mu,' is input as acell: ',acell(mu),ch10,&
4519 : 0 : 'However, length scales must be > 0 ==> stop',ch10,&
4520 : 0 : 'Action: correct acell in input file.'
4521 : 0 : ABI_ERROR(msg)
4522 : : end if
4523 : : end do
4524 : :
4525 : : ! Initialize rprim, or read the angles
4526 : 7232 : tread=0
4527 : 7232 : call intagm(dprarr,intarr,jdtset,marr,9,string(1:lenstr),'rprim',trprim,'DPR')
4528 [ + + ]: 7232 : if (trprim==1) rprim(:,:) = reshape( dprarr(1:9), [3, 3])
4529 : 7232 : call intagm_img(rprim,iimage,jdtset,lenstr,nimage,3,3,string,"rprim",trprim,'DPR')
4530 : :
4531 [ + + ]: 7232 : if(trprim==0)then
4532 : : ! If none of the rprim were read ...
4533 : 2837 : call intagm(dprarr,intarr,jdtset,marr,3,string(1:lenstr),'angdeg',tangdeg,'DPR')
4534 [ + + ]: 11348 : angdeg(:)=dprarr(1:3)
4535 : 2837 : call intagm_img(angdeg,iimage,jdtset,lenstr,nimage,3,string,"angdeg",tangdeg,'DPR')
4536 : :
4537 [ + + ]: 2837 : if(tangdeg==1)then
4538 : : !call wrtout(std_out,' ingeo: use angdeg to generate rprim.')
4539 : :
4540 : : ! Check that input angles are positive
4541 [ + + ]: 6872 : do mu=1,3
4542 [ - + ]: 6872 : if(angdeg(mu)<=0.0_dp) then
4543 : : write(msg, '(a,i0,a,1p,e14.6,a,a,a,a)' )&
4544 : 0 : 'Angle number ',mu,' is input as angdeg: ',angdeg(mu),ch10,&
4545 : 0 : 'However, angles must be > 0 ==> stop',ch10,&
4546 : 0 : 'Action: correct angdeg in the input file.'
4547 : 0 : ABI_ERROR(msg)
4548 : : end if
4549 : : end do
4550 : :
4551 : : ! Check that the sum of angles is smaller than 360 degrees
4552 [ - + ]: 1718 : if(angdeg(1)+angdeg(2)+angdeg(3)>=360.0_dp) then
4553 : : write(msg, '(a,a,a,es14.4,a,a,a)' )&
4554 : 0 : 'The sum of input angles (angdeg(1:3)) must be lower than 360 degrees',ch10,&
4555 : 0 : 'while it is: ',angdeg(1)+angdeg(2)+angdeg(3),'.',ch10,&
4556 : 0 : 'Action: correct angdeg in the input file.'
4557 : 0 : ABI_ERROR(msg)
4558 : : end if
4559 : :
4560 : : if( abs(angdeg(1)-angdeg(2))<tol12 .and. &
4561 [ + + + + : 1718 : abs(angdeg(2)-angdeg(3))<tol12 .and. &
+ + ]
4562 : : abs(angdeg(1)-90._dp)+abs(angdeg(2)-90._dp)+abs(angdeg(3)-90._dp)>tol12 )then
4563 : : ! Treat the case of equal angles (except all right angles):
4564 : : ! generates trigonal symmetry wrt third axis
4565 : 146 : cosang=cos(pi*angdeg(1)/180.0_dp)
4566 : 146 : a2=2.0_dp/3.0_dp*(1.0_dp-cosang)
4567 : 146 : aa=sqrt(a2)
4568 : 146 : cc=sqrt(1.0_dp-a2)
4569 : 146 : rprim(1,1)=aa ; rprim(2,1)=0.0_dp ; rprim(3,1)=cc
4570 : 146 : rprim(1,2)=-0.5_dp*aa ; rprim(2,2)= sqrt(3.0_dp)*0.5_dp*aa ; rprim(3,2)=cc
4571 : 146 : rprim(1,3)=-0.5_dp*aa ; rprim(2,3)=-sqrt(3.0_dp)*0.5_dp*aa ; rprim(3,3)=cc
4572 : : ! write(std_out,*)' ingeo: angdeg=',angdeg(1:3), aa,cc=',aa,cc
4573 : : else
4574 : : ! Treat all the other cases
4575 : 1572 : rprim(:,:)=0.0_dp
4576 : 1572 : rprim(1,1)=1.0_dp
4577 : 1572 : rprim(1,2)=cos(pi*angdeg(3)/180.0_dp)
4578 : 1572 : rprim(2,2)=sin(pi*angdeg(3)/180.0_dp)
4579 : 1572 : rprim(1,3)=cos(pi*angdeg(2)/180.0_dp)
4580 : 1572 : rprim(2,3)=(cos(pi*angdeg(1)/180.0_dp)-rprim(1,2)*rprim(1,3))/rprim(2,2)
4581 : 1572 : rprim(3,3)=sqrt(1.0_dp-rprim(1,3)**2-rprim(2,3)**2)
4582 : : end if
4583 : :
4584 : : end if
4585 : : end if ! No problem if neither rprim nor angdeg are defined: use default rprim
4586 : :
4587 [ - + ]: 7232 : ABI_FREE(intarr)
4588 [ - + ]: 7232 : ABI_FREE(dprarr)
4589 : :
4590 : 7232 : end subroutine get_acell_rprim
4591 : : !!***
4592 : :
4593 [ # # # # : 0 : end module m_parser
# # # # #
# # # # #
# # # # ]
4594 : : !!***
|
