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