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