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 2604 : 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 2604 : if (xmpi_comm_rank(comm) == master) then
231 :
232 : ! strlen from defs_basis module
233 2326 : string = repeat(" ", strlen)
234 2326 : string_with_comments = repeat(" ", strlen)
235 2326 : call instrng(filnamin, lenstr, option1, strlen, string, string_with_comments)
236 :
237 : ! Copy original file, without change of case
238 2326 : string_raw=string
239 :
240 : ! To make case-insensitive, map characters of string to upper case.
241 2326 : 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 2326 : lenstr_noxyz = lenstr
250 2326 : call importxyz(lenstr, string_raw, string, strlen)
251 :
252 : ! Make sure we don't have unmatched quotation marks
253 2326 : 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 2326 : ndtset=0; marr=1
259 2326 : call intagm(dprarr,intarr,0,marr,1,string(1:lenstr),"ndtset",tread,'INT')
260 2326 : if (tread==1) ndtset=intarr(1)
261 : ! Check that ndtset is within bounds
262 2326 : 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 2604 : if (xmpi_comm_size(comm) > 1) then
271 : ! Broadcast data.
272 386 : call xmpi_bcast(lenstr, master, comm, ierr)
273 386 : call xmpi_bcast(ndtset, master, comm, ierr)
274 386 : call xmpi_bcast(string, master, comm, ierr)
275 386 : 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 2604 : if (allocated(INPUT_STRING)) then
286 1162 : ABI_FREE_SCALAR(INPUT_STRING)
287 : end if
288 :
289 2604 : ABI_MALLOC_TYPE_SCALAR(character(len=len_trim(string_with_comments)), INPUT_STRING)
290 2604 : 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 2604 : 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 503679 : 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 503679 : if (typevarphys=='INT') then
350 :
351 : ! integer input section
352 271547 : read(unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) outi
353 :
354 271547 : 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 232132 : .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 232131 : done=0
370 232131 : if (ndig>5) then
371 52846 : if(string(1:5)=='SQRT(' .and. string(ndig:ndig)==')')then
372 : done=1 ; sign=1
373 52777 : 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 232015 : index_slash=index(string(1:ndig),'/')
406 232015 : if(index_slash/=0)then
407 8776 : done=1
408 8776 : read (unit=string(1:index_slash-1), fmt=*, iostat=errcod, iomsg=iomsg) num
409 8776 : if(errcod==0)then
410 8776 : read (unit=string(index_slash+1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) den
411 8776 : if(errcod==0)then
412 8776 : if(abs(den)<tol12)then
413 0 : errcod=1
414 : else
415 8776 : 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 223239 : if(done==0) read (unit=string(1:ndig), fmt=*, iostat=errcod, iomsg=iomsg) outr
424 :
425 : ! Treatment of errors
426 232131 : 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 503679 : 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 503679 : 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 2681 : 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 2681 : include_level=include_level+1
536 2681 : 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 2681 : 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 2681 : rewind (unit=input_unit)
549 :
550 : ! Initialize string to blanks
551 2681 : string=blank
552 2681 : lenstr=1
553 2681 : lenstr_raw = 0
554 :
555 : ! Set maximum number lines to be read to some large number
556 2681 : mline=500000
557 250362 : do iline=1,mline
558 :
559 : ! Keeps reading lines until end of input file
560 250362 : 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 250362 : if (ios/=0) then
571 2681 : backspace(input_unit)
572 2681 : read (unit=input_unit,fmt= '(a1)' ,iostat=ios) string1
573 2681 : 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 247681 : ii2 = len_trim(line) + 1
590 247681 : 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 247681 : raw_string(lenstr_raw+1:lenstr_raw+ii2) = trim(line) // new_line("A")
600 247681 : 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 247681 : ii1=index(line(1:fnlen+20),'#')
613 247681 : ii2=index(line(1:fnlen+20),'!')
614 247681 : 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 106681 : else if(ii1==0)then
618 : ! ii will represent length of line up to but not including !
619 2032 : ii=ii2-1
620 104649 : else if(ii2==0)then
621 : ! ii will represent length of line up to but not including #
622 104235 : ii=ii1-1
623 : else
624 414 : ii=min(ii1,ii2)-1
625 : end if
626 :
627 : ! Checks that nothing is left beyond fnlen
628 247681 : if(ii>fnlen)then
629 : !write(std_out, *)"line: `", line(1:fnlen+20), "`"
630 2961000 : do ij=fnlen+1,ii
631 2961000 : 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 247681 : if (ii>0) then
642 : ! Check for the occurrence of a minus sign followed by a blank
643 161833 : ij=index(line(1:ii),'- ')
644 161833 : 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 161833 : ij=index(line(1:ii),char(9))
656 161833 : 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 161833 : include_found=.false.
665 161833 : if (option==1) then
666 : ! Look for include statement
667 161833 : ii1=index(line(1:ii),"include");ii2=index(line(1:ii),"INCLUDE")
668 161833 : include_found=(ii1>0.or.ii2>0)
669 161833 : 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 161833 : call incomprs(line(1:ii),lenc)
705 :
706 : else
707 : ! ii=0 means line starts with #, is entirely a comment line
708 85848 : lenc=0;include_found=.false.
709 : end if
710 :
711 : ! Check resulting total string length
712 247681 : 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 247681 : if (lenc>0) then
722 : ! Concatenate new compressed characters
723 : ! with previous part of compressed string (unless all blank)
724 124895 : string(lenstr+1:lenstr+lenc)=line(1:lenc)
725 : end if
726 : ! Keep track of total string length
727 247681 : lenstr=lenstr+lenc
728 :
729 : ! Eventually (recursively) read included file
730 247681 : 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 250362 : 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 2681 : nline1=iline-1
770 2681 : 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 2681 : b0=0
776 : do
777 5005 : b0=b0+1
778 5005 : b1 = index(string(b0:lenstr), '$')
779 5005 : if(b1==0 .or. b1>=lenstr)exit
780 2324 : b1 = b0 + b1 - 1
781 : !Identify delimiter, either a '"', or a "'", or a blank, or a /
782 2324 : b2=index(string(b1+1:lenstr),'"')
783 2324 : b3=index(string(b1+1:lenstr),"'")
784 2324 : if(b3/=0 .and. b3<b2)b2=b3
785 2324 : b3=index(string(b1+1:lenstr),' ')
786 2324 : if(b3/=0 .and. b3<b2)b2=b3
787 2324 : b3=index(string(b1+1:lenstr),'/')
788 2324 : if(b3/=0 .and. b3<b2)b2=b3
789 4759 : if(b2/=0)then
790 2324 : shell_var=string(b1+1:b1+b2-1)
791 : !write(std_out,'(a,a)')' shell_var=',shell_var(:b2-1)
792 2324 : call get_environment_variable(shell_var(:b2-1), shell_value, status=ierr, length=len_val)
793 2324 : if (ierr == -1) ABI_ERROR(sjoin(shell_var(:b2-1), "is present but value of environment variable is too long"))
794 2324 : if (ierr == +1) ABI_ERROR(sjoin(shell_var(:b2-1), "environment variable is not defined!"))
795 2324 : if (ierr == +2) ABI_ERROR(sjoin(shell_var(:b2-1), "used in input file but processor does not support environment variables"))
796 2324 : call wrtout(std_out, sjoin(shell_var(:b2-1), " found in environment, with value ",shell_value(:len_val)))
797 2324 : string(1:lenstr-(b2-b1)+len_val)=string(1:b1-1)//shell_value(:len_val)//string(b1+b2:lenstr)
798 2324 : 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 2683 : b1 = index(string(1:lenstr), '//')
807 2683 : 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 2681 : 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 2681 : include_level = include_level - 1
841 :
842 2681 : write(msg,'(a,i0,3a)')'-instrng: ',nline1,' lines of input have been read from file ',trim(filnam),ch10
843 2681 : call wrtout(std_out,msg)
844 : !write(std_out, "(3a)")"string after instrng:", ch10, string(:lenstr)
845 :
846 : DBG_EXIT("COLL")
847 :
848 2681 : 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 124897 : 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 124897 : length=len(string); if (length == 0) return
881 :
882 : ! Do replacement by going through input character string one character at a time
883 2846242 : do ilenth=1,length
884 2721345 : if (llt(string(ilenth:ilenth),' ')) string(ilenth:ilenth)=' '
885 2846242 : 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 161837 : 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 161837 : stringlen=len(string)
941 161837 : length=stringlen
942 :
943 : ! Only proceed if string has nonzero length
944 161837 : if (length>0) then
945 : ! Find last nonblank character (i.e. nonblank and nontab length)
946 161837 : length=len_trim(string)
947 161837 : 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 124897 : call inreplsp(string(1:length))
954 :
955 : ! Continue with parsing
956 : ! l1 is set to last nonblank, nontab character position
957 124897 : l1=length
958 :
959 : ! find first non blank character
960 395665 : do ii=1,l1
961 395665 : if (string(ii:ii)/=blank) exit
962 : end do
963 : ! f1 is set to first nonblank, nontab character position
964 124897 : f1=ii
965 :
966 : ! lbef is number of characters in string starting at
967 : ! first nonblank, nontab and going to last
968 124897 : lbef=l1-f1+1
969 :
970 : ! Process characters one at a time from right to left:
971 124897 : bb=0
972 124897 : lcut=lbef
973 2575474 : do ii=1,lbef
974 2450577 : jj=lbef+f1-ii
975 : ! set bb=position of next blank coming in from right
976 2575474 : if (string(jj:jj)==blank) then
977 481594 : if (bb==0) bb=jj
978 : else
979 1968983 : if (bb/=0) then
980 : ! if several blanks in a row were found, cut from string
981 242475 : if (jj<bb-1) then
982 : ! lold becomes string length before cutting blanks
983 131085 : lold=lcut
984 : ! lcut will be new string length
985 131085 : lcut=lcut-(bb-1-jj)
986 : ! redefine string with repeated blanks gone
987 1709601 : do kk=1,f1+lcut-1-jj
988 1709601 : 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 124897 : if (f1>1) string(1:lcut)=string(f1:f1+lcut-1)
998 :
999 : ! Add blank on end unless string had no extra space
1000 124897 : 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 124897 : length=lcut+1
1009 124897 : string(length:length)=blank
1010 : end if
1011 : ! remove trailing characters left from the recursive string shifts
1012 124897 : string(length:stringlen)=blank
1013 : end if
1014 :
1015 : end if
1016 :
1017 161837 : 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 6259903 : 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 6259903 : integer,allocatable :: int1(:),int2(:)
1147 6259903 : 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 6259903 : ds_input_ = -1
1153 6259903 : dozens=jdtset/10
1154 6259903 : unities=jdtset-10*dozens
1155 :
1156 6259903 : 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 6259903 : 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 6259903 : itoken=0
1168 6259903 : opttoken=0
1169 : ! Initialise flags in case of opttoken >= 2 later.
1170 6259903 : itoken_times=0
1171 6259903 : itoken_plus=0
1172 6259903 : itoken_colon=0
1173 6259903 : cslen=1
1174 :
1175 6259903 : if (narr/=0) then
1176 :
1177 6182247 : toklen=len_trim(token)
1178 :
1179 : ! --------------------------------------------------------------------------
1180 : ! (1) try to find the token with dataset number appended
1181 6182247 : if (jdtset > 0) then
1182 :
1183 5797583 : call appdig(jdtset,'',append)
1184 5797583 : cs=blank//token(1:toklen)//trim(append)//blank
1185 5797583 : if(jdtset<10) then
1186 3422847 : cslen=toklen+3
1187 2374736 : else if(jdtset<100) then
1188 2153971 : cslen=toklen+4
1189 220765 : else if(jdtset<1000) then
1190 215539 : cslen=toklen+5
1191 5226 : else if(jdtset<10000)then
1192 5226 : cslen=toklen+6
1193 : end if
1194 : ! Map token to all upper case (make case-insensitive):
1195 5797583 : call inupper(cs)
1196 : ! Absolute index of blank//token//blank in string:
1197 5797583 : itoken=index(string,cs(1:cslen))
1198 : ! Look for another occurrence of the same token in string, if so, leaves:
1199 5797583 : itoken2=index(string,cs(1:cslen), BACK=.true. )
1200 5797583 : 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 5797583 : if(itoken/=0) then
1209 27451 : opttoken=1
1210 27451 : 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 6182247 : if (jdtset>0 .and. opttoken==0)then
1217 :
1218 : ! Use the metacharacter for the dozens, and save in cs and itoken
1219 5770132 : write(append,'(i1)')unities
1220 5770132 : cs=blank//token(1:toklen)//'?'//trim(append)//blank
1221 5770132 : cslen=toklen+4
1222 : ! Map token to all upper case (make case-insensitive):
1223 5770132 : call inupper(cs)
1224 : ! Absolute index of blank//token//blank in string:
1225 5770132 : itoken=index(string,cs(1:cslen))
1226 : ! Look for another occurrence of the same token in string, if so, leaves:
1227 5770132 : itoken2=index(string,cs(1:cslen), BACK=.true. )
1228 5770132 : 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 5770132 : 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 5770132 : write(append,'(i0)')dozens
1242 5770132 : cs1=blank//token(1:toklen)//trim(append)//'?'//blank
1243 5770132 : cs1len=toklen+len(trim(append))+3
1244 : ! Map token to all upper case (make case-insensitive):
1245 5770132 : call inupper(cs1)
1246 : ! Absolute index of blank//token//blank in string:
1247 5770132 : itoken1=index(string,cs1(1:cs1len))
1248 : ! Look for another occurrence of the same token in string, if so, leaves:
1249 5770132 : itoken2=index(string,cs1(1:cs1len), BACK=.true. )
1250 5770132 : 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 5770132 : 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 5770132 : 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 6153521 : if (opttoken==0) then
1279 :
1280 6147956 : cs=token(1:toklen)
1281 :
1282 6147956 : cslen=toklen+3
1283 6147956 : cs1len=toklen+4
1284 :
1285 6147956 : cscolon=blank//token(1:toklen)//':'//blank
1286 6147956 : csplus=blank//token(1:toklen)//'+'//blank
1287 6147956 : cstimes=blank//token(1:toklen)//'*'//blank
1288 :
1289 6147956 : cs1colon=blank//token(1:toklen)//'?'//':'//blank
1290 6147956 : cs1plus=blank//token(1:toklen)//'?'//'+'//blank
1291 6147956 : cs1times=blank//token(1:toklen)//'?'//'*'//blank
1292 :
1293 6147956 : cs2colon=blank//token(1:toklen)//':'//'?'//blank
1294 6147956 : cs2plus=blank//token(1:toklen)//'+'//'?'//blank
1295 6147956 : cs2times=blank//token(1:toklen)//'*'//'?'//blank
1296 :
1297 : ! Map token to all upper case (make case-insensitive):
1298 6147956 : call inupper(cscolon)
1299 6147956 : call inupper(csplus)
1300 6147956 : call inupper(cstimes)
1301 6147956 : call inupper(cs1colon)
1302 6147956 : call inupper(cs1plus)
1303 6147956 : call inupper(cs1times)
1304 6147956 : call inupper(cs2colon)
1305 6147956 : call inupper(cs2plus)
1306 6147956 : call inupper(cs2times)
1307 :
1308 : ! Absolute index of tokens in string:
1309 6147956 : itoken_colon=index(string,cscolon(1:cslen))
1310 6147956 : itoken_plus=index(string,csplus(1:cslen))
1311 6147956 : itoken_times=index(string,cstimes(1:cslen))
1312 6147956 : itoken_1colon=index(string,cs1colon(1:cs1len))
1313 6147956 : itoken_1plus=index(string,cs1plus(1:cs1len))
1314 6147956 : itoken_1times=index(string,cs1times(1:cs1len))
1315 6147956 : itoken_2colon=index(string,cs2colon(1:cs1len))
1316 6147956 : itoken_2plus=index(string,cs2plus(1:cs1len))
1317 6147956 : itoken_2times=index(string,cs2times(1:cs1len))
1318 :
1319 : ! Look for another occurrence of the same tokens in string
1320 6147956 : itoken2_colon=index(string,cscolon(1:cslen), BACK=.true. )
1321 6147956 : itoken2_plus=index(string,csplus(1:cslen), BACK=.true. )
1322 6147956 : itoken2_times=index(string,cstimes(1:cslen), BACK=.true. )
1323 6147956 : itoken2_1colon=index(string,cs1colon(1:cs1len), BACK=.true. )
1324 6147956 : itoken2_1plus=index(string,cs1plus(1:cs1len), BACK=.true. )
1325 6147956 : itoken2_1times=index(string,cs1times(1:cs1len), BACK=.true. )
1326 6147956 : itoken2_2colon=index(string,cs2colon(1:cs1len), BACK=.true. )
1327 6147956 : itoken2_2plus=index(string,cs2plus(1:cs1len), BACK=.true. )
1328 6147956 : itoken2_2times=index(string,cs2times(1:cs1len), BACK=.true. )
1329 :
1330 6147956 : if(jdtset==0)then
1331 :
1332 : ! If the multi-dataset mode is not used, no token should have been found
1333 384664 : 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 384664 : 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 5763292 : sum_token=0
1358 5763292 : if(itoken_colon/=0)sum_token=sum_token+1
1359 5763292 : if(itoken_plus /=0)sum_token=sum_token+1
1360 5763292 : if(itoken_times/=0)sum_token=sum_token+1
1361 5763292 : if(itoken_1colon/=0)sum_token=sum_token+1
1362 5763292 : if(itoken_1plus /=0)sum_token=sum_token+1
1363 5763292 : if(itoken_1times/=0)sum_token=sum_token+1
1364 5763292 : if(itoken_2colon/=0)sum_token=sum_token+1
1365 5763292 : if(itoken_2plus /=0)sum_token=sum_token+1
1366 5763292 : if(itoken_2times/=0)sum_token=sum_token+1
1367 :
1368 5763292 : 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 5763292 : ier=0
1380 5763292 : if(itoken_colon/=itoken2_colon)then
1381 0 : ier=1 ; cs=cscolon
1382 : end if
1383 5763292 : if(itoken_plus/=itoken2_plus)then
1384 0 : ier=1 ; cs=csplus
1385 : end if
1386 5763292 : if(itoken_times/=itoken2_times)then
1387 0 : ier=1 ; cs=cstimes
1388 : end if
1389 5763292 : if(itoken_1colon/=itoken2_1colon)then
1390 0 : ier=1 ; cs=cs1colon
1391 : end if
1392 5763292 : if(itoken_1plus/=itoken2_1plus)then
1393 0 : ier=1 ; cs=cs1plus
1394 : end if
1395 5763292 : if(itoken_1times/=itoken2_1times)then
1396 0 : ier=1 ; cs=cs1times
1397 : end if
1398 5763292 : if(itoken_2colon/=itoken2_2colon)then
1399 0 : ier=1 ; cs=cs2colon
1400 : end if
1401 5763292 : if(itoken_2plus/=itoken2_2plus)then
1402 0 : ier=1 ; cs=cs2plus
1403 : end if
1404 5763292 : if(itoken_2times/=itoken2_2times)then
1405 0 : ier=1 ; cs=cs2times
1406 : end if
1407 5763292 : 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 5763292 : if(itoken_colon>0)then
1417 : opttoken=2
1418 : ds_input_=jdtset
1419 5762879 : 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 5762762 : 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 5763292 : 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 5763292 : 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 5763292 : 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 6175407 : if (opttoken==0) then
1472 :
1473 6147064 : cs=blank//token(1:toklen)//blank
1474 6147064 : cslen=toklen+2
1475 :
1476 : ! Map token to all upper case (make case-insensitive):
1477 6147064 : call inupper(cs)
1478 :
1479 : ! Absolute index of blank//token//blank in string:
1480 6147064 : itoken=index(string,cs(1:cslen))
1481 :
1482 : ! Look for another occurrence of the same token in string, if so, leaves:
1483 6147064 : itoken2=index(string,cs(1:cslen), BACK=.true. )
1484 6147064 : 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 6147064 : if(itoken/=0) then
1493 189044 : opttoken=1
1494 189044 : 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 68004717 : do trial_jdtset=0,9
1507 68004717 : if(jdtset==0 .or. trial_jdtset==0)then
1508 9644223 : write(append,'(i1)')trial_jdtset
1509 9644223 : trial_cs=blank//token(1:toklen)//trim(append)
1510 9644223 : trial_cslen=toklen+2
1511 : ! Map token to all upper case (make case-insensitive):
1512 9644223 : call inupper(trial_cs)
1513 : ! Look for an occurrence of this token in string, if so, leaves:
1514 9644223 : itoken2=index(string,trial_cs(1:trial_cslen))
1515 9644223 : 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 6259903 : tread = 0
1543 6259903 : typevar='INT'
1544 :
1545 6259903 : if(typevarphys=='LOG')typevar='INT'
1546 : if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. &
1547 6259903 : typevarphys=='BFI' .or. typevarphys=='TIM') typevar='DPR'
1548 :
1549 6259903 : if (typevarphys=='KEY' .or. typevarphys=='INT_OR_KEY') then
1550 : ! Consistency check for keyword (no multidataset, no series)
1551 274295 : 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 274295 : 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 6259903 : 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 223335 : b1 = itoken + cslen - 1
1573 :
1574 223335 : 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 8993 : ABI_CHECK(present(key_value), "typevarphys == KEY or INT_OR_KEY requires optional argument key_value")
1577 8993 : if (typevarphys == 'INT_OR_KEY') then
1578 1 : ABI_CHECK(narr==1, "typevarphys == INT_OR_KEY requires narr==1")
1579 : end if
1580 8993 : b2 = index(string(b1+1:), '"')
1581 17999 : b3=0 ; do ii=b1,b1+b2-1 ; if (string(ii:ii)/=blank) b3=1 ; end do
1582 8993 : if (typevarphys == 'KEY') then
1583 8992 : ABI_CHECK(b2 /= 0, sjoin('Cannot find first " defining string for token:', token))
1584 8992 : ABI_CHECK(b3 == 0, sjoin('There are chars between token name and first " for token:', token))
1585 : end if
1586 8993 : if (typevarphys == 'KEY' .or. (b2/=0.and.b3==0)) then
1587 8992 : b2 = b1 + b2 + 1
1588 8992 : b3 = index(string(b2:), '"')
1589 8992 : ABI_CHECK(b3 /= 0, sjoin('Cannot find second " defining string for token:', token))
1590 8992 : b3 = b3 + b2 - 2
1591 8992 : 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 8992 : 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 214342 : 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 223335 : tread = 1
1607 :
1608 6036568 : 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 6259903 : 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 6259903 : 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 53962 : 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 53962 : character(len=3*len(token)+10) :: token_img
1722 : !arrays
1723 53962 : integer, allocatable :: intarr(:)
1724 53962 : real(dp),allocatable :: dprarr(:),dp_data_after(:),dp_data_before(:)
1725 : ! *************************************************************************
1726 :
1727 : !Nothing to do in case of a single image
1728 53962 : if (nimage<=1) return
1729 :
1730 2466 : marr=size1
1731 7398 : ABI_MALLOC(intarr,(marr))
1732 7398 : ABI_MALLOC(dprarr,(marr))
1733 :
1734 : !First, try to read data for current image
1735 2466 : tread_current=0
1736 2466 : write(stringimage,'(i10)') iimage
1737 2466 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1738 2466 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_current,typevarphys)
1739 2466 : if (tread_current==1)then
1740 296 : dp_data(1:size1)=dprarr(1:size1)
1741 15 : tread_ok=1
1742 : end if
1743 2466 : 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 390 : token_img=trim(token)//'_lastimg'
1746 390 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_current,typevarphys)
1747 390 : 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 2466 : if (tread_current==0) then
1754 :
1755 : ! The current image is not directly defined in the input string
1756 4888 : ABI_MALLOC(dp_data_before,(size1))
1757 4888 : ABI_MALLOC(dp_data_after,(size1))
1758 :
1759 : ! Find the nearest previous defined image
1760 2444 : tread_before=0;iimage_before=iimage
1761 9587 : do while (iimage_before>1.and.tread_before/=1)
1762 7143 : iimage_before=iimage_before-1
1763 7143 : write(stringimage,'(i10)') iimage_before
1764 7143 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1765 7143 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_before,typevarphys)
1766 9593 : if (tread_before==1) dp_data_before(1:size1)=dprarr(1:size1)
1767 : end do
1768 2444 : if (tread_before==0) then
1769 2442 : iimage_before=1
1770 7017 : dp_data_before(1:size1)=dp_data(1:size1)
1771 : end if
1772 :
1773 : ! Find the nearest following defined image
1774 2444 : tread_after=0;iimage_after=iimage
1775 9624 : do while (iimage_after<nimage.and.tread_after/=1)
1776 7180 : iimage_after=iimage_after+1
1777 7180 : write(stringimage,'(i10)') iimage_after
1778 7180 : token_img=trim(token)//'_'//trim(adjustl(stringimage))//'img'
1779 7180 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_after,typevarphys)
1780 7266 : if (tread_after==1) dp_data_after(1:size1)=dprarr(1:size1)
1781 9624 : if (tread_after==0.and.iimage_after==nimage) then
1782 2054 : token_img=trim(token)//'_lastimg'
1783 2054 : call intagm(dprarr,intarr,jdtset,marr,size1,string(1:lenstr), token_img,tread_after,typevarphys)
1784 2150 : if (tread_after==1) dp_data_after(1:size1)=dprarr(1:size1)
1785 : end if
1786 : end do
1787 2444 : if (tread_after==0) then
1788 2405 : iimage_after=nimage
1789 6804 : dp_data_after(1:size1)=dp_data(1:size1)
1790 : end if
1791 :
1792 : ! Interpolate image data
1793 2444 : 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 2444 : ABI_FREE(dp_data_before)
1800 2444 : ABI_FREE(dp_data_after)
1801 : end if
1802 :
1803 2466 : ABI_FREE(intarr)
1804 2466 : 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 36029 : 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 36029 : character(len=3*len(token)+10) :: token_img
1839 : !arrays
1840 36029 : integer, allocatable :: intarr(:)
1841 36029 : real(dp),allocatable :: dprarr(:),dp_data_after(:,:),dp_data_before(:,:)
1842 : ! *************************************************************************
1843 :
1844 : !Nothing to do in case of a single image
1845 36029 : 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 216136 : 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 216136 : ii = 0
1992 216136 : typevar='INT'
1993 216136 : if(typevarphys=='LOG') typevar='INT'
1994 : if(typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. &
1995 216136 : typevarphys=='BFI' .or. typevarphys=='TIM') typevar='DPR'
1996 :
1997 216136 : strln=len_trim(string)
1998 :
1999 706551 : do while (ii < narr)
2000 :
2001 : ! Relative location of next blank after data
2002 : ! b1 is the last character of the string
2003 490415 : if (b1>=strln) exit
2004 :
2005 490415 : b2 = index(string(b1+1:),blank)
2006 : ! If no second blank is found put the second blank just beyond strln
2007 490415 : if(b2==0) b2=strln-b1+1
2008 :
2009 : ! nrep tells how many times to repeat input in array:
2010 490415 : nrep=1
2011 :
2012 : ! Check for *, meaning repeated input (as in list-directed input):
2013 490415 : istar=index(string(b1+1:b1+b2-1),'*')
2014 490415 : if (istar/=0) then
2015 14477 : if (istar==1) then ! Simply fills the array with the data, repeated as many times as needed
2016 1284 : nrep=narr-ii
2017 1284 : errcod=0
2018 : else
2019 13193 : call inread(string(b1+1:b1+istar-1),istar-1,'INT',nrep,real8,errcod)
2020 : end if
2021 14477 : if (errcod/=0) exit
2022 : ! Shift starting position of input field:
2023 14477 : b1=b1+istar
2024 14477 : b2=b2-istar
2025 : end if
2026 :
2027 : ! Read data internally by calling inread at entry ini:
2028 490415 : call inread(string(b1+1:b1+b2-1),b2-1,typevarphys,integ,real8,errcod)
2029 490415 : if (errcod/=0) exit
2030 :
2031 : ! Allow for list-directed input with repeat number nrep:
2032 490415 : if(typevar=='INT')then
2033 543117 : intarr(1+ii:min(nrep+ii,narr))=integ
2034 232101 : else if(typevar=='DPR')then
2035 510943 : dprarr(1+ii:min(nrep+ii,narr))=real8
2036 : else
2037 0 : ABI_BUG('Disallowed typevar: '//typevar)
2038 : end if
2039 490415 : ii=min(ii+nrep,narr)
2040 :
2041 : ! Find new absolute location of next element of array:
2042 490415 : b1=b1+b2
2043 :
2044 : end do ! while (ii<narr). Note "exit" instructions within loop.
2045 :
2046 216136 : 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 216136 : 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 23631 : if(b1>=strln)exit ! b1 is the last character of the string
2062 23608 : b2=index(string(b1+1:),blank)
2063 : ! If no second blank is found put the second blank just beyond strln
2064 23608 : 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 23608 : asciichar=iachar(string(b1+1:b1+1))
2077 216166 : if(asciichar<48 .or. asciichar>57)then
2078 23578 : factor=one
2079 23578 : if(typevarphys=='LEN' .and. b2>=3)then
2080 8657 : if(string(b1+1:b1+6)=='ANGSTR')then
2081 : factor=one/Bohr_Ang
2082 7970 : else if(string(b1+1:b1+3)=='NM ')then
2083 23578 : factor=ten/Bohr_Ang
2084 : end if
2085 14921 : else if(typevarphys=='ENE' .and. b2>=3)then
2086 14634 : if(string(b1+1:b1+3)=='RY ')then
2087 : factor=half
2088 14592 : else if(string(b1+1:b1+3)=='RYD')then
2089 : factor=half
2090 14592 : else if(string(b1+1:b1+3)=='EV ')then
2091 : factor=one/Ha_eV
2092 13869 : else if(string(b1+1:b1+4)=='MEV ')then
2093 : factor=one/Ha_meV
2094 13866 : else if(string(b1+1:b1+7)=='Kelvin ')then
2095 23578 : 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 23578 : factor=tol17/Time_Sec
2108 : endif
2109 : endif
2110 :
2111 69323 : 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 216136 : 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 2326 : 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 2326 : index_already_done=1
2177 2326 : ixyz=0
2178 :
2179 : do
2180 : ! Infinite do-loop, to identify the presence of the xyzFILE token
2181 2328 : index_xyz_token=index(string_upper(index_already_done:lenstr),"XYZFILE")
2182 2328 : 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 2328 : string_upper(index_xyz_fname:index_xyz_fname_end-1) = blank
2228 : end do
2229 :
2230 :
2231 2326 : 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 2326 : if(ixyz/=0)then
2238 2 : call incomprs(string_upper,lenstr)
2239 : ! A blank is needed at the beginning of the string
2240 1404 : do kk=lenstr,1,-1
2241 1404 : 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 2326 : 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 213789 : 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 213789 : 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 213789 : ok=0
2473 213789 : if(minimal_flag==1 .and. input_value>=reference_value-tol10) ok=1
2474 213789 : if(minimal_flag==-1 .and. input_value<=reference_value+tol10) ok=1
2475 213789 : 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 205480 : 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 213789 : 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 35563 : subroutine chkint(advice_change_cond,cond_number,cond_string,cond_values,&
2579 35563 : 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 35563 : ok=0
2599 35563 : if(list_number>0)then
2600 373878 : do ilist=1,list_number
2601 373878 : if(input_value == list_values(ilist))ok=1
2602 : end do
2603 : end if
2604 35563 : if(minmax_flag==1 .and. input_value>=minmax_value)ok=1
2605 35563 : 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 34018 : 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 177815 : cond_string(:)='#####'
2616 :
2617 35563 : 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 844977 : subroutine chkint_eq(advice_change_cond,cond_number,cond_string,cond_values,&
2659 844977 : 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 844977 : ok=0
2679 844977 : if(list_number>0)then
2680 4416911 : do ilist=1,list_number
2681 4416911 : if(input_value == list_values(ilist))ok=1
2682 : end do
2683 : end if
2684 844977 : minmax_flag=0
2685 844977 : minmax_value=0
2686 :
2687 : !If there is something wrong, compose the message, and print it
2688 844977 : 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 4224885 : cond_string(:)='#####'
2696 :
2697 844977 : 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 404577 : 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 404577 : integer, allocatable :: list_values(:)
2750 :
2751 : !******************************************************************
2752 :
2753 : !Checks the allowed values
2754 404577 : ok=0
2755 404577 : minmax_flag=1
2756 404577 : if(input_value>=minmax_value)ok=1
2757 404577 : list_number=1
2758 404577 : ABI_MALLOC(list_values,(1))
2759 809154 : list_values=minmax_value
2760 :
2761 : !If there is something wrong, compose the message, and print it
2762 404577 : 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 404577 : ABI_FREE(list_values)
2769 :
2770 : ! reset all cond_strings
2771 2022885 : cond_string(:)='#####'
2772 :
2773 404577 : 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 104765 : 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 104765 : integer, allocatable :: list_values(:)
2826 :
2827 : !******************************************************************
2828 :
2829 : !Checks the allowed values
2830 104765 : ok=0
2831 104765 : minmax_flag=-1
2832 104765 : if(input_value<=minmax_value)ok=1
2833 : !write(std_out,*)' chkint_le : input_value,minmax_value=',input_value,minmax_value
2834 :
2835 104765 : list_number=1
2836 104765 : ABI_MALLOC(list_values,(1))
2837 209530 : list_values=minmax_value
2838 :
2839 : !If there is something wrong, compose the message, and print it
2840 104765 : 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 104765 : ABI_FREE(list_values)
2846 :
2847 : ! reset all cond_strings
2848 523825 : cond_string(:)='#####'
2849 :
2850 104765 : 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 18706 : subroutine chkint_ne(advice_change_cond,cond_number,cond_string,cond_values,&
2889 18706 : 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 18706 : ok=1
2909 18706 : if(list_number>0)then
2910 40431 : do ilist=1,list_number
2911 40431 : if(input_value == list_values(ilist))ok=0
2912 : end do
2913 : end if
2914 18706 : minmax_flag=2
2915 18706 : minmax_value=0
2916 :
2917 : !If there is something wrong, compose the message, and print it
2918 18706 : 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 93530 : cond_string(:)='#####'
2926 :
2927 18706 : 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 3684836 : subroutine prttagm(dprarr,intarr,iout,jdtset_,length,&
3137 3684836 : 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 3684836 : 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 3684836 : 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 3684836 : 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 3684836 : 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 3684836 : if ((narr>0).or.(use_narrm/=0)) then
3218 :
3219 3618060 : print_out=.true.;print_netcdf=.true.
3220 3618060 : multi=0
3221 :
3222 : ! ###########################################################
3223 : ! ### 02. Treatment of integer 'INT'
3224 :
3225 3618060 : if(typevarphys=='INT')then
3226 :
3227 : ! Determine whether the different non-default occurrences are all equal
3228 :
3229 2641586 : if (use_narrm==0) then ! use of scalar 'narr' instead of array 'narrm'
3230 2606460 : if(ndtset_alloc>1)then
3231 12972986 : do idtset=1,ndtset_alloc
3232 30050038 : do iarr=1,narr
3233 28284000 : 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 1766038 : if(multi==0)then
3245 : print_out=.false.
3246 6672760 : do iarr=1,narr
3247 6672760 : if (intarr(iarr,1)/=intarr(iarr,0)) print_out=.true.
3248 : end do
3249 : print_netcdf=print_out
3250 : end if
3251 :
3252 2641586 : if (present(forceprint)) then
3253 18096 : if (forceprint==1.or.forceprint==3) print_out=.true.
3254 18096 : if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3255 : end if
3256 :
3257 : ! Print only if the values differ from the default
3258 2628014 : if (print_out.or.print_netcdf.or.(ncid<0))then
3259 145344 : ndtset_eff=ndtset_alloc
3260 145344 : if((multi==0).or.(ncid<0)) ndtset_eff=1
3261 556172 : do idtset=1,ndtset_eff
3262 :
3263 : ! Initialize the character in the first column
3264 410828 : first_column=' ';if (present(firstchar)) first_column=firstchar
3265 410828 : if(abs(length)==5)first_column='P'
3266 : ! Initialize the format
3267 410828 : if(abs(length)==1)format_int=trim(short_int)
3268 410828 : if(abs(length)==2)format_int=trim(long_int)
3269 410828 : if(abs(length)==3)format_int=trim(f_symrel)
3270 410828 : if(abs(length)==4)format_int=trim(f_type)
3271 410828 : if(abs(length)==5)format_int=trim(f_mem)
3272 410828 : if(abs(length)==6)format_int=trim(f_kptrlatt)
3273 : ! Initialize the dataset number string, and print
3274 410828 : if((multi==0).or.(ncid<0))then
3275 85124 : append=' '
3276 : else
3277 325704 : jdtset=jdtset_(idtset)
3278 325704 : call appdig(jdtset,'',append)
3279 : end if
3280 : ! full_format=trim(long_beg)//trim(format_int)
3281 410828 : 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 410828 : if (use_narrm==0)then
3286 236688 : narr_eff=narr
3287 : else
3288 174140 : narr_eff=narrm(idtset)
3289 : end if
3290 :
3291 3052414 : if (narr_eff/=0) then
3292 :
3293 257494 : if (print_out) write(iout,full_format) token,trim(append),intarr(1:narr_eff,idtset)
3294 257494 : if (print_netcdf) then
3295 : call write_var_netcdf(intarr(1:narr_eff,idtset),&
3296 252022 : 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 976474 : else if (typevarphys=='DPR' .or. typevarphys=='LEN' .or. typevarphys=='ENE' .or. typevarphys=='BFI' .or. typevarphys=='TIM') then
3307 :
3308 976474 : if((ndtset_alloc>1).and.(use_narrm==0))then
3309 4800260 : do idtset=1,ndtset_alloc
3310 12831840 : 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 8031580 : diff=abs( dprarr(iarr,1)-dprarr(iarr,idtset) )
3317 12176884 : if(length>0)then
3318 6156808 : sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,idtset))+10*tol21
3319 6156808 : if(diff>sumtol*tol11)multi=1
3320 : else
3321 1904004 : if(diff>tol14)multi=1
3322 : end if
3323 : end do
3324 : end do
3325 321518 : elseif (use_narrm/=0) then
3326 72120 : 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 72120 : do idtset=1,ndtset_alloc
3330 72120 : if(narrm(idtset)>narrm(0))then
3331 : print_out=.true.
3332 : else
3333 690220 : do iarr=1,narrm(idtset)
3334 639668 : diff=abs( dprarr(iarr,idtset)-dprarr(iarr,0) )
3335 690220 : if(length>0)then
3336 279722 : sumtol=abs(dprarr(iarr,idtset))+abs(dprarr(iarr,0))+10*tol21
3337 279722 : if(diff>sumtol*tol11)print_out=.true.
3338 : else
3339 648946 : 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 663328 : if(multi==0)then
3348 : print_out=.false.
3349 2990754 : do iarr=1,narr
3350 2029740 : diff=abs( dprarr(iarr,1)-dprarr(iarr,0) )
3351 2990754 : if(length>0)then
3352 1546254 : sumtol=abs(dprarr(iarr,1))+abs(dprarr(iarr,0))+10*tol21
3353 1546254 : if(diff>sumtol*tol11)print_out=.true.
3354 : else
3355 2345594 : if(diff>tol14)print_out=.true.
3356 : end if
3357 : end do
3358 : print_netcdf=print_out
3359 : end if
3360 :
3361 976474 : if (present(forceprint)) then
3362 27116 : if (forceprint==1.or.forceprint==3) print_out=.true.
3363 27116 : if (forceprint==1.or.forceprint==2) print_netcdf=.true.
3364 : end if
3365 :
3366 949358 : if(print_out.or.print_netcdf.or.(ncid<0))then
3367 : ! Select the proper format
3368 74086 : ndtset_eff=ndtset_alloc
3369 74086 : if((multi==0).or.(ncid<0))ndtset_eff=1
3370 74086 : narr_eff=narr
3371 74086 : if(use_narrm/=0)then
3372 29562 : narr_eff=maxval(narrm(1:ndtset_eff))
3373 : end if
3374 74086 : if(abs(length)==1 .or. abs(length)==2 .or. abs(length)==6)then
3375 64822 : if(typevarphys=='DPR')then
3376 49436 : digit='3'
3377 49436 : if(abs(length)==1)format_dp=digit//short_dpr
3378 49436 : if(abs(length)==2)format_dp=digit//long_dpr
3379 49436 : if(abs(length)==6)format_dp=digit//veryshort_dpr
3380 15386 : else if(typevarphys=='ENE' .or. typevarphys=='LEN' .or. typevarphys=='BFI' .or. typevarphys=='TIM')then
3381 15386 : if (narr<10) write(digit,'(i1)')narr_eff
3382 15386 : if (narr> 9) write(digit,'(i2)')narr_eff
3383 15386 : if(abs(length)==1)format_dp=digit//short_dim
3384 15386 : if(abs(length)==2)format_dp=digit//long_dim
3385 15386 : if(abs(length)==6)format_dp=digit//veryshort_dim
3386 : end if
3387 : else
3388 9264 : if(abs(length)==3)format_dp=f_tnons
3389 9264 : if(abs(length)==4)format_dp=f_wtk
3390 9264 : if(abs(length)==5)format_dp=f_atvshift
3391 : end if
3392 218410 : 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 144324 : if (use_narrm==0)then
3397 117866 : narr_eff=narr
3398 : else
3399 26458 : narr_eff=narrm(idtset)
3400 : end if
3401 :
3402 1120798 : if (narr_eff/=0) then
3403 :
3404 : ! Initialize the character in the first column
3405 143514 : first_column=' ';if (present(firstchar)) first_column=firstchar
3406 : ! Define scale_factor
3407 143514 : 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 143514 : if(typevarphys=='ENE')out_unit=' Hartree'
3411 143514 : if(typevarphys=='LEN')out_unit=' Bohr '
3412 143514 : if(typevarphys=='BFI')out_unit=' ' !EB remove Tesla unit
3413 143514 : if(typevarphys=='TIM')out_unit=' Second'
3414 : ! Format, according to the length of the dataset string
3415 143514 : if((multi==0).or.(ncid<0))then
3416 63894 : append=' '
3417 : else
3418 79620 : jdtset=jdtset_(idtset)
3419 79620 : call appdig(jdtset,'',append)
3420 : end if
3421 : ! full_format=trim(long_beg)//trim(format_dp)
3422 143514 : 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 143514 : if(typevarphys=='DPR')then
3427 2041852 : if (print_out) write(iout,full_format) token,trim(append),dprarr(1:narr_eff,idtset)*scale_factor
3428 : else
3429 70182 : if (print_out) write(iout,full_format) token,trim(append),dprarr(1:narr_eff,idtset)*scale_factor,trim(out_unit)
3430 : end if
3431 143514 : if (print_netcdf) then
3432 : call write_var_netcdf(intarr(1:narr_eff,idtset),dprarr(1:narr_eff,idtset),&
3433 143106 : 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 3684836 : 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 56512 : subroutine prttagm_images(dprarr_images,iout,jdtset_,length,&
3553 56512 : & marr,narrm,ncid,ndtset_alloc,token,typevarphys,&
3554 56512 : & 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 113024 : integer :: intarr_images(marr,mxnimage,0:ndtset_alloc)
3575 56512 : integer,allocatable :: intarr(:,:)
3576 56512 : 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 56512 : test_multiimages=.false.
3591 313468 : do idtset=1,ndtset_alloc
3592 313468 : 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 56512 : 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 49800 : if(.not.test_multiimages)then
3607 :
3608 49612 : narr=narrm(1)
3609 198448 : ABI_MALLOC(intarr,(marr,0:ndtset_alloc))
3610 198448 : ABI_MALLOC(dprarr,(marr,0:ndtset_alloc))
3611 219187458 : dprarr=zero
3612 329262 : do idtset=0,ndtset_alloc
3613 2044686 : dprarr(1:narrm(idtset),idtset)=dprarr_images(1:narrm(idtset),1,idtset)
3614 : end do
3615 49612 : multi_narr=0
3616 49612 : if(ndtset_alloc>1)then
3617 247714 : do idtset=1,ndtset_alloc
3618 247714 : if(narrm(1)/=narrm(idtset))multi_narr=1
3619 : end do
3620 : end if
3621 49612 : 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 49612 : 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 49612 : 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 13512 : forceprint=forceprint)
3633 : else
3634 : call prttagm(dprarr,intarr,iout,jdtset_,length,marr,narr,&
3635 36100 : narrm,ncid,ndtset_alloc,token,typevarphys,multi_narr)
3636 : end if
3637 49612 : ABI_FREE(intarr)
3638 49612 : ABI_FREE(dprarr)
3639 :
3640 : else
3641 :
3642 6900 : first_column=' ';if (present(firstchar)) first_column=firstchar
3643 :
3644 33818 : do idtset=1,ndtset_alloc
3645 :
3646 33818 : if (narrm(idtset)>0)then
3647 50256 : do iimage=1,nimagem(idtset)
3648 :
3649 26740 : print_out=.true.
3650 26740 : if (prtimg(iimage,idtset)==0) print_out=.false.
3651 26740 : if (nimagem(0)>=nimagem(idtset)) then
3652 0 : if (sum(abs(dprarr_images(1:narrm(idtset),iimage,idtset) &
3653 26740 : & -dprarr_images(1:narrm(idtset),iimage,0)))<tol12) print_out=.false.
3654 : end if
3655 26740 : print_netcdf=print_out
3656 :
3657 26740 : 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 49460 : if (print_out.or.print_netcdf.or.(ncid<0))then
3663 26716 : keywd=token//trim(strimg(iimage))
3664 :
3665 26716 : if(ndtset>0)then
3666 23810 : jdtset=jdtset_(idtset)
3667 23810 : call appdig(jdtset,'',append)
3668 23810 : if (print_out) then
3669 : full_format='("'//first_column//trim(format_1a)//'("'// &
3670 23810 : first_column//trim(format_2)//trim(long_dpr)//")"
3671 : write(iout,full_format) &
3672 23810 : trim(keywd),append,dprarr_images(1:narrm(idtset),iimage,idtset)
3673 : end if
3674 23810 : 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 23810 : 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 56512 : 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 1606 : 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 1606 : index_current=1
3746 : do
3747 : ! Infinite do-loop, to identify the presence of each potential variable names
3748 :
3749 228243 : if(len_trim(string)<=index_current)exit
3750 226637 : index_blank=index(string(index_current:),blank)+index_current-1
3751 :
3752 226637 : if(index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',string(index_current:index_current))/=0)then
3753 :
3754 70049 : index_endfullword = index_blank -1
3755 70049 : index_endword = index_blank -1
3756 :
3757 70049 : 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 98149 : do index_endword=index_blank-1,index_current,-1
3761 98149 : 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 70049 : 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 70049 : if (index_list_vars==0 .and. protocol==1) then
3771 :
3772 : ! Treat possible LASTIMG appendix
3773 45 : if(index_endword-6>=1)then
3774 45 : if(string(index_endword-6:index_endword)=='LASTIMG')index_endword=index_endword-7
3775 : end if
3776 :
3777 : ! Treat possible IMG appendix
3778 45 : if(index_endword-2>=1)then
3779 45 : 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 88 : do index_endword=index_endwordnow,index_current,-1
3787 88 : 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 45 : index_list_vars=index(list_vars_img,blank//string(index_current:index_endword)//blank)
3793 : end if
3794 :
3795 395 : if(index_list_vars==0)then
3796 :
3797 : ! Treat possible logical input variables
3798 364 : 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 363 : 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 363 : index_current=index(string(index_current:),blank)+index_current
3815 363 : 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 226637 : index_current=index_blank+1
3830 :
3831 228243 : if (string(index_current:index_current) == '"') then
3832 : do
3833 267981 : index_current = index_current + 1
3834 267981 : if (string(index_current:index_current) == '"') exit
3835 267981 : 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 1606 : 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 14261 : subroutine geo_free(self)
4454 :
4455 : !Arguments ------------------------------------
4456 : class(geo_t),intent(inout) :: self
4457 : !************************************************************************
4458 :
4459 14261 : ABI_SFREE(self%typat)
4460 14261 : ABI_SFREE(self%xred)
4461 14261 : ABI_SFREE(self%znucl)
4462 :
4463 14261 : 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 7181 : 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 7181 : integer,allocatable :: intarr(:)
4502 : real(dp) :: angdeg(3)
4503 7181 : real(dp),allocatable :: dprarr(:)
4504 : !************************************************************************
4505 :
4506 21543 : ABI_MALLOC(intarr, (marr))
4507 21543 : ABI_MALLOC(dprarr, (marr))
4508 :
4509 28724 : acell(1:3) = one
4510 7181 : call intagm(dprarr,intarr,jdtset,marr,3,string(1:lenstr),'acell',tacell,'LEN')
4511 28685 : if(tacell==1) acell(1:3)=dprarr(1:3)
4512 7181 : 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 28724 : do mu=1,3
4516 28724 : 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 7181 : tread=0
4527 7181 : call intagm(dprarr,intarr,jdtset,marr,9,string(1:lenstr),'rprim',trprim,'DPR')
4528 7181 : if (trprim==1) rprim(:,:) = reshape( dprarr(1:9), [3, 3])
4529 7181 : call intagm_img(rprim,iimage,jdtset,lenstr,nimage,3,3,string,"rprim",trprim,'DPR')
4530 :
4531 7181 : if(trprim==0)then
4532 : ! If none of the rprim were read ...
4533 2829 : call intagm(dprarr,intarr,jdtset,marr,3,string(1:lenstr),'angdeg',tangdeg,'DPR')
4534 11316 : angdeg(:)=dprarr(1:3)
4535 2829 : call intagm_img(angdeg,iimage,jdtset,lenstr,nimage,3,string,"angdeg",tangdeg,'DPR')
4536 :
4537 2829 : 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 7181 : ABI_FREE(intarr)
4588 7181 : ABI_FREE(dprarr)
4589 :
4590 7181 : end subroutine get_acell_rprim
4591 : !!***
4592 :
4593 0 : end module m_parser
4594 : !!***
|
