! CLAF90 MODULE ! ! Copyright (c) 2020 Edward D. Zaron, Portland, Oregon, USA ! ! Permission is hereby granted, free of charge, to any person obtaining a copy of this ! software and associated documentation files (the "Software"), to deal in the Software ! without restriction, including without limitation the rights to use, copy, modify, merge, ! publish, distribute, sublicense, and/or sell copies of the Software, and to permit ! persons to whom the Software is furnished to do so, subject to the following conditions: ! ! The above copyright notice and this permission notice shall be included in all copies or ! substantial portions of the Software. ! ! Except as contained in this notice, the name(s) of the above copyright holders shall not ! be used in advertising or otherwise to promote the sale, use or other dealings in this ! Software without prior written authorization. ! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, ! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR ! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE ! FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR ! OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ! DEALINGS IN THE SOFTWARE. ! module MODgvec_cla_kinds implicit none integer(kind=4), public, parameter :: int_kind = 4 integer(kind=4), public, parameter :: real_kind = 4 integer(kind=4), public, parameter :: ptr_kind = 8 integer(kind=4), public, parameter :: STRLEN = 120 integer(kind=4), public, parameter :: XSTRLEN = 256 end module MODgvec_cla_kinds ! ! Edward D. Zaron ! edward.d.zaron@oregonstate.edu ! module MODgvec_cla use MODgvec_cla_kinds #ifdef f2003 use, intrinsic :: iso_fortran_env, only : & input_unit => stdin, & output_unit => stdout, & error_unit => stderr #else #define stdin 5 #define stdout 6 #define stderr 0 #endif implicit none ! Command Line Arguments ! A key-value parser for the commandline integer(kind=int_kind), parameter :: & cla_int = 1, & cla_float = 2, & cla_char = 3, & cla_xchar = 4, & ! NOT IMPLEMENTED cla_logical=5, & cla_flag = 6 ! Optionally, these routines can parse a string contaning arguments, cla_cla, ! rather than the command line arguments. integer(kind=int_kind), parameter, private :: CLALEN=1024 character(len=CLALEN), private :: cla_cla integer(kind=int_kind), private :: cla_cla_len character(len=STRLEN), dimension(6) :: cla_kindstr character(len=STRLEN), private :: cla_empty character(len=STRLEN), dimension(6) :: cla_true_str type, private :: cla_t character(len=2) :: key character(len=STRLEN) :: longkey character(len=XSTRLEN) :: description integer(kind=int_kind) :: kind character(len=STRLEN) :: default end type cla_t type, private :: cla_posarg_t character(len=STRLEN) :: key character(len=XSTRLEN) :: description integer(kind=int_kind) :: kind character(len=STRLEN) :: default end type cla_posarg_t type(cla_t), private, dimension(:), pointer :: cla_registry type(cla_posarg_t), private, dimension(:), pointer :: cla_posarg_registry integer(kind=int_kind), private :: cla_num integer(kind=int_kind), private :: cla_posarg_num interface cla_init module procedure & cla_init_default, & ! no input parameters ==> read and parse the command line cla_init_str ! string input parameter ==> read and parse the string instead of the command line end interface cla_init interface cla_get module procedure & cla_get_float_r4, & cla_get_float_r8, & cla_get_int_i4, & cla_get_int_i8, & cla_get_char, & cla_get_logical end interface contains integer function cla_command_argument_count() ! Define these wrappers for these intrinsic functions because we want to implement ! a cla parser that can work with plain strings, read from stdin for example, ! not just from the command line. ! The purpose is to easily adapt a program that runs using command line inputs into ! a program that can run with string input it eats from a pipe. implicit none CHARACTER(len=CLALEN) :: outs INTEGER :: i, k, n if (cla_cla_len == 0) then cla_command_argument_count = command_argument_count() else ! Count number of spaces to get ! number of parameters minus 1: cla_command_argument_count = 0 ! Now count arguments: ! write(*,*) 'Counting arguments in :',trim(cla_cla) cla_cla_len = len_trim(cla_cla) if (cla_cla_len == 0) then return end if do i=1,cla_cla_len if (cla_cla(i:i) == ' ') then cla_command_argument_count = cla_command_argument_count + 1 end if end do cla_command_argument_count = cla_command_argument_count + 1 ! write(*,*) 'cla_command_argument_count found ',cla_command_argument_count end if end function cla_command_argument_count subroutine cla_get_command_argument(i,arg) implicit none integer :: i,n,nm1,nn character(len=*) :: arg if (cla_cla_len == 0) then call get_command_argument(i,arg) else nm1 = 0 nn = 0 do n=1,i nm1 = nn + nm1 nn = index(cla_cla(nm1+1:),' ') end do arg(1:nn) = cla_cla(nm1+1:nm1+nn-1) arg(nn:) = ' ' ! write(*,*) 'trim(cla_cla)=',trim(cla_cla) ! write(*,*) 'get_command_argument got : arg=',i,' val=',trim(arg) end if end subroutine cla_get_command_argument subroutine cla_message(message) character(LEN=*) message ! Default stop with message without print or stop statements. ! May need to be modified for, e.g. MPI codes write(stdout,*)message end subroutine subroutine cla_fatal(message) character(LEN=*) message ! Default stop with message without print or stop statements. ! May need to be modified for, e.g. MPI codes write(stderr,*)message stop 6 end subroutine subroutine cla_read_str(cla_input_str) implicit none character(len=*) :: cla_input_str integer :: i,n,k character(CLALEN) :: outs cla_cla = trim(adjustl(cla_input_str)) cla_cla_len = len_trim(cla_cla) ! Replace whitespace with single space: outs = cla_cla n = 0 ; k=cla_cla_len ! k=index last non-blank (may be null) DO i = 1,k-1 ! dont process last char yet n = n+1 ; outs(n:n) = cla_cla(i:i) IF (cla_cla(i:i+1) == ' ') n = n-1 ! backup/discard consecutive output blank END DO n = n+1 ; outs(n:n) = cla_cla(k:k) ! last non-blank char output (may be null) IF (n < k) outs(n+1:) = ' ' ! pad trailing blanks cla_cla = outs cla_cla_len = len_trim(cla_cla) end subroutine cla_read_str subroutine cla_init_str(cla_input_str) implicit none character(len=*) :: cla_input_str integer :: i,n,k character(CLALEN) :: outs cla_cla = trim(adjustl(cla_input_str)) cla_cla_len = len_trim(cla_cla) ! Replace whitespace with single space: outs = cla_cla n = 0 ; k=cla_cla_len ! k=index last non-blank (may be null) DO i = 1,k-1 ! dont process last char yet n = n+1 ; outs(n:n) = cla_cla(i:i) IF (cla_cla(i:i+1) == ' ') n = n-1 ! backup/discard consecutive output blank END DO n = n+1 ; outs(n:n) = cla_cla(k:k) ! last non-blank char output (may be null) IF (n < k) outs(n+1:) = ' ' ! pad trailing blanks cla_cla = outs cla_cla_len = len_trim(cla_cla) ! Allocate a zero size registry, just so that it gets ! associated. cla_num = 0 allocate(cla_registry(0)) allocate(cla_posarg_registry(0)) cla_kindstr(cla_int) = 'integer' cla_kindstr(cla_float) = 'float' cla_kindstr(cla_char) = 'character' cla_kindstr(cla_xchar) = 'xcharacter' !NOT IMPLEMENTED cla_kindstr(cla_logical) = 'logical' cla_kindstr(cla_flag) = 'flag' cla_empty='THIS_IS_THE_EMPTY_STRING' cla_true_str(1)='true' cla_true_str(2)='on' cla_true_str(3)='1' cla_true_str(4)='t' cla_true_str(5)='T' cla_true_str(6)='.true.' end subroutine cla_init_str subroutine cla_init_default ! Allocate a zero size registry, just so that it gets ! associated. cla_num = 0 cla_posarg_num = 0 ! Hmmm. 2020-10-23. Somehow this worked previously without this! allocate(cla_registry(0)) allocate(cla_posarg_registry(0)) cla_kindstr(cla_int) = 'integer' cla_kindstr(cla_float) = 'float' cla_kindstr(cla_char) = 'character' cla_kindstr(cla_xchar) = 'xcharacter' !NOT IMPLEMENTED cla_kindstr(cla_logical) = 'logical' cla_kindstr(cla_flag) = 'flag' cla_empty='THIS_IS_THE_EMPTY_STRING' cla_true_str(1)='true' cla_true_str(2)='on' cla_true_str(3)='1' cla_true_str(4)='t' cla_true_str(5)='T' cla_true_str(6)='.true.' ! Set cla_cla_len = 0 in default case when command line is actually to be parsed ! rather than in input string: cla_cla_len = 0 end subroutine cla_init_default subroutine cla_posarg_register(key,description,kkind,default) character(len=*) :: key character(len=*) :: description integer(kind=int_kind) :: kkind character(len=*) :: default type(cla_posarg_t), dimension(:), pointer :: cla_posarg_registry_tmp integer(kind=int_kind) :: i ! This is a dumb way to increase the size of the ! registry of command line arguments, but there ! should not be so many arguments that either speed ! or memory is an issue. allocate(cla_posarg_registry_tmp(cla_posarg_num+1)) do i=1,cla_posarg_num cla_posarg_registry_tmp(i)%key = cla_posarg_registry(i)%key cla_posarg_registry_tmp(i)%description = cla_posarg_registry(i)%description cla_posarg_registry_tmp(i)%kind = cla_posarg_registry(i)%kind cla_posarg_registry_tmp(i)%default = cla_posarg_registry(i)%default if (index(trim(key),' ') /= 0) then call cla_fatal('Error: cla_posarg key contains a space character.') end if if (cla_str_eq(trim(cla_posarg_registry(i)%key),trim(key))) then call cla_fatal('cla_posarg key already been registered' // & cla_posarg_registry(i)%key) end if end do cla_posarg_num = cla_posarg_num + 1 deallocate(cla_posarg_registry) allocate(cla_posarg_registry(cla_posarg_num)) do i=1,cla_posarg_num-1 cla_posarg_registry(i)%key = cla_posarg_registry_tmp(i)%key cla_posarg_registry(i)%description = cla_posarg_registry_tmp(i)%description cla_posarg_registry(i)%kind = cla_posarg_registry_tmp(i)%kind cla_posarg_registry(i)%default = cla_posarg_registry_tmp(i)%default end do i = cla_posarg_num cla_posarg_registry(i)%key = key cla_posarg_registry(i)%description = description cla_posarg_registry(i)%description = description cla_posarg_registry(i)%kind = kkind cla_posarg_registry(i)%default = default deallocate(cla_posarg_registry_tmp) end subroutine subroutine cla_register(key,longkey,description,kkind,default) character(len=2) :: key character(len=*) :: longkey character(len=*) :: description integer(kind=int_kind) :: kkind character(len=*) :: default type(cla_t), dimension(:), pointer :: cla_registry_tmp integer(kind=int_kind) :: i if (key(1:1) .ne. '-')then call cla_fatal("The short key must begin with a dash (e.g., -e)") endif if (longkey(1:2) .ne. '--')then call cla_fatal("The long key must begin with a two dashes (e.g., --extended_key)") end if ! This is a dumb way to increase the size of the ! registry of command line arguments, but there ! should not be so many arguments that either speed ! or memory is an issue. allocate(cla_registry_tmp(cla_num+1)) do i=1,cla_num cla_registry_tmp(i)%key = cla_registry(i)%key cla_registry_tmp(i)%longkey = cla_registry(i)%longkey cla_registry_tmp(i)%description = cla_registry(i)%description cla_registry_tmp(i)%kind = cla_registry(i)%kind cla_registry_tmp(i)%default = cla_registry(i)%default if (index(trim(key),' ') /= 0) then call cla_fatal('Attempt to register cla key containing a space.') end if if (index(trim(longkey),' ') /= 0) then call cla_fatal('Attempt to register long key containing space') end if if (cla_str_eq(trim(cla_registry(i)%key),trim(key))) then call cla_fatal('Attempt to register cla key already registered'// & trim(key)) end if end do cla_num = cla_num + 1 deallocate(cla_registry) allocate(cla_registry(cla_num)) do i=1,cla_num-1 cla_registry(i)%key = cla_registry_tmp(i)%key cla_registry(i)%longkey = cla_registry_tmp(i)%longkey cla_registry(i)%description = cla_registry_tmp(i)%description cla_registry(i)%kind = cla_registry_tmp(i)%kind cla_registry(i)%default = cla_registry_tmp(i)%default end do i = cla_num cla_registry(i)%key = key cla_registry(i)%longkey = longkey cla_registry(i)%description = description cla_registry(i)%kind = kkind cla_registry(i)%default = default deallocate(cla_registry_tmp) end subroutine subroutine cla_show integer(kind=int_kind) :: i character(len=STRLEN) :: value character(len=STRLEN) :: i_str call cla_message('General usage:') call cla_message(' command -[key] [value] --[longkey] [value] -[flag] [positional arguments]') call cla_message(' The key/value pairs must be matched if they appear.') call cla_message(' Key/value pairs and flags may be in any order.') call cla_message(' ') call cla_message('The following command line arguments and switches are expected:') do i=1,cla_num write(i_str,'(i5)')i call cla_message('---------- i: '// trim(i_str)) call cla_message(' key: '// trim(cla_registry(i)%key)) call cla_message(' longkey: '// trim(cla_registry(i)%longkey)) call cla_message(' description: '// trim(cla_registry(i)%description)) call cla_message(' kind: '// & trim(cla_kindstr(cla_registry(i)%kind))) call cla_message(' default: '// trim(cla_registry(i)%default)) end do call cla_message(' ') call cla_message('The following positional (non-keyword) arguments are expected:') do i=1,cla_posarg_num write(i_str,'(i5)')i call cla_message('---------- i: '// trim(i_str)) call cla_message(' key: '// trim(cla_posarg_registry(i)%key)) call cla_message(' description: '// trim(cla_posarg_registry(i)%description)) call cla_message(' kind: '// & trim(cla_kindstr(cla_posarg_registry(i)%kind))) call cla_message(' default: '// trim(cla_posarg_registry(i)%default)) if ( cla_key_present(trim(cla_registry(i)%key)) ) then call cla_get_char(trim(cla_registry(i)%key),value) call cla_message(' present?: T') if (cla_registry(i)%kind == cla_flag) then else call cla_message(' value: '// trim(value)) endif else call cla_message(' present?: F') endif end do call cla_message(' ') call cla_message('Also, -?, -h, -H, -help, --help, and --usage are recognized.') call cla_message(' ') end subroutine cla_show subroutine cla_help(cmd_name) character(len=*) :: cmd_name integer(kind=int_kind) :: i character(len=256) :: cmd_usage cmd_usage = "" do i=1,cla_num if (cla_registry(i)%kind == cla_flag) then cmd_usage = trim(cmd_usage) // " [" // trim(cla_registry(i)%key) // "]" else cmd_usage = trim(cmd_usage) // " [" // trim(cla_registry(i)%key) // "=" // & trim(cla_registry(i)%default) // "]" endif enddo do i=1,cla_posarg_num cmd_usage = trim(cmd_usage) // " " // trim(cla_posarg_registry(i)%key) enddo write(stdout,*)'General usage:' write(stdout,*)' ',cmd_name, trim(cmd_usage) write(stdout,*)' ' write(stdout,*)'Options and flags {default values}:' if (cla_num == 0) write(stdout,*)"None" do i=1,cla_num if (cla_registry(i)%kind == cla_flag) then write(stdout,'(1x,a,1x,a24,":",4x,a)')trim(cla_registry(i)%key), & trim(cla_registry(i)%longkey), & trim(cla_registry(i)%description) else write(stdout,'(1x,a,1x,a24,":",4x,a,2x,"{",a,"}")')trim(cla_registry(i)%key), & trim(cla_registry(i)%longkey), & trim(cla_registry(i)%description), & trim(cla_registry(i)%default) endif end do write(stdout,*)' ' write(stdout,*)'Positional arguments:' if (cla_posarg_num == 0) write(stdout,*)"None" do i=1,cla_posarg_num write(stdout,'(1x,a,":",1x,a,4x,a)')trim(cla_posarg_registry(i)%key), & trim(cla_posarg_registry(i)%description) end do write(stdout,*)' ' write(stdout,*)'Also, -?, -h, -H, -help, --help, and --usage are recognized.' write(stdout,*)' ' end subroutine cla_help integer function cla_eq(str1,str2) implicit none character(*) :: str1, str2 cla_eq = index(trim(str1),trim(str2))*index(trim(str2),trim(str1)) end function cla_eq logical function cla_key_arg_match(key,longkey,arg) implicit none ! do a match that includes two alternate keys and possibility of = in arg integer :: iequal character(*) :: key,longkey,arg cla_key_arg_match = .false. cla_key_arg_match = cla_str_eq(trim(key),trim(arg)) .or. & cla_str_eq(trim(longkey),trim(arg)) if (cla_key_arg_match) return iequal = index(arg,"=") if (iequal > 1) & cla_key_arg_match = cla_str_eq(trim(key),arg(1:(iequal-1))) .or. & cla_str_eq(trim(longkey),arg(1:(iequal-1))) end function cla_key_arg_match logical function cla_str_eq(str1,str2) implicit none character(*) :: str1, str2 integer :: str_test str_test = index(trim(str1),trim(str2))*index(trim(str2),trim(str1)) cla_str_eq = .false. if (str_test /= 0) cla_str_eq = .true. end function cla_str_eq subroutine cla_validate(cmd_name) implicit none character(len=*) :: cmd_name call cla_validate_info(cmd_name,.false.) end subroutine cla_validate subroutine cla_validate_info(cmd_name,info) implicit none character(len=*) :: cmd_name character(len=STRLEN) :: arg character(len=STRLEN) :: value, key integer(kind=int_kind) :: ncla, k, kk, iequal, kcla, kkv logical :: info if (info) write(stdout,*) "Validating the command line arguments:" ncla = cla_command_argument_count() if (ncla == 0) then if (info) write(stdout,*) " ... none found. Returning." return end if ! First check for -?, -h, -H, -help, or --help flags. call cla_get_command_argument(1,arg) key = trim(arg) if (cla_str_eq(trim(key),'-h') .or. & cla_str_eq(trim(key),'-?') .or. & cla_str_eq(trim(key),'/?') .or. & cla_str_eq(trim(key),'-H') .or. & cla_str_eq(trim(key),'-help') .or. & cla_str_eq(trim(key),'--help') .or. & cla_str_eq(trim(key),'--usage') & ) then call cla_help(cmd_name) stop " " endif if (info) write(stdout,*) " cla_command_argument_count = ",ncla do k=1,ncla call cla_get_command_argument(k,arg) if (info) write(stdout,*) " cla_command_argument #",k,": ",arg end do ! Positional arguments must all occur either before or after all the key/value arguments. kcla = 0 do while (kcla < ncla) call cla_get_command_argument(kcla+1,arg) ! Search the arguments until we find one that begins with "-", which we know is the marker ! for the key,value pairs or flags. if (index(arg,"-") /= 1) then if (info .and.(kcla == 0)) write(stdout,*) " Positional arguments appear to occur prior to key/value arguments." kcla = kcla + 1 if (kcla > cla_posarg_num) then write(stderr,*)" ERROR: Too many positional arguments found!" stop 5 endif else exit end if if (info) write(stdout,*) " positional arg #",kcla,"= ",trim(arg), & " is expected to be of type ",trim(cla_kindstr(cla_posarg_registry(kcla)%kind)) end do ! Look for key value pairs: do while (kcla < ncla) call cla_get_command_argument(kcla+1,key) if (info) then if ( (index(key,"-") == 1) .and. (kcla == 0) .and. (cla_posarg_num > 0)) then write(stdout,*) " Positional arguments appear to occur after to key/value arguments." endif endif kkv = kcla do kk=1,cla_num ! must test for exact match, not just substring if (cla_key_arg_match(cla_registry(kk)%key, & cla_registry(kk)%longkey, & key))then if (cla_registry(kk)%kind == cla_flag) then if (info) write(stdout,*)" key = ",trim(key)," is a flag" kcla = kcla + 1 exit else call cla_get_command_argument(kcla+2,value) kcla = kcla + 2 if (info) write(stdout,*)" key, value ?= ",trim(key)," ",trim(value), & " is expected to be of type ",trim(cla_kindstr(cla_registry(kk)%kind)) end if end if end do if (kcla == kkv) then if (index(key,"-") == 1) then write(stderr,*)" ERROR: "//trim(key)//" could not be matched to any known key!" stop 5 else ! We have reached the end of the key/value,flags and now check again for posarg. exit endif end if end do kkv = kcla do while (kcla < ncla) call cla_get_command_argument(kcla+1,arg) if (index(arg,"-") /= 1) then kcla = kcla + 1 if ((kcla - kkv) > cla_posarg_num) then write(stderr,*)" ERROR: Too many positional arguments found!" stop 5 endif else write(stderr,*) " ERROR: Positional arguments appear to be mixed in with -key value arguments." write(stderr,*) " Move position arguments to the end of the list." stop 5 end if if (info) write(stdout,*)" positional arg ?= ",arg end do if (info) write(stdout,*)" No errors found in syntax validation, but type/kind-validity not checked!" if (info) write(stdout,*)" If a -key value pair is repeated, the last one is used." end subroutine cla_validate_info logical function cla_key_present(key) implicit none character(len=STRLEN) :: arg character(len=*) :: key character(len=STRLEN) :: longkey character(len=2) :: shortkey character(len=STRLEN) :: value integer(kind=int_kind) :: ncla, k, kk ! integer :: cla_command_argument_count ! external cla_command_argument_count ! Loop over the command line arguments to assign to ! value. ! Note that no error is reported if the key was NOT ! registered, but it is present on the command line. cla_key_present = .false. ! write(*,*) 'Calling cla_key_present with key = ',trim(key) value = trim(cla_empty) do kk=1,cla_num ! must test for exact match, not just substring if (cla_key_arg_match(cla_registry(kk)%key, & cla_registry(kk)%longkey, & key))then value = trim(cla_registry(kk)%default) longkey = cla_registry(kk)%longkey shortkey = cla_registry(kk)%key exit end if end do if (index(trim(value),trim(cla_empty)) /= 0) then call cla_show call cla_fatal('Unknown command line argument: '//trim(key)) endif ncla = cla_command_argument_count() if (ncla == 0) return do k=1,ncla call cla_get_command_argument(k,arg) ! test for exact match if (cla_key_arg_match(shortkey,longkey,arg))then cla_key_present = .true. return endif enddo end function cla_key_present subroutine cla_get_char(key,value) implicit none character(len=STRLEN) :: arg character(len=*) :: key character(len=2) :: shortkey character(len=STRLEN) :: longkey character(len=STRLEN) :: value, pvalue character(len=STRLEN) :: kkey integer(kind=int_kind) :: ncla, k, kkind, iequal integer :: kk, kmatch, ordinal logical :: just_matched, prev_matched, is_match, carryover ! integer :: cla_command_argument_count ! external cla_command_argument_count ! Loop over the command line arguments to assign to ! value. ! Note that no error is reported if the key was NOT ! registered, but it is present on the command line. if (index(key,"-") /= 1)then ! assume positional argument, confirm by matching name ordinal = -1 do k=1,cla_posarg_num ! must test for exact match, not just substring if (cla_str_eq(trim(cla_posarg_registry(k)%key),trim(key))) then pvalue = trim(cla_posarg_registry(k)%default) ordinal = k end if end do ! It seems that value is not yet defined here: ! if (index(trim(value),trim(cla_empty)) /= 0) then if (ordinal == -1) then write(stderr,*) 'Error: You tried to retrieve an unknown command line argument: ',trim(key) call cla_show stop 5 endif if (ordinal > 0) then ncla = cla_command_argument_count() if (ncla == 0) then value=pvalue return end if kmatch = 0 prev_matched = .False. do k=1,ncla call cla_get_command_argument(k,arg) ! test for exact match among key args just_matched = .False. do kk = 1, cla_num kkey = cla_registry(kk)%key kkind = cla_registry(kk)%kind is_match = cla_key_arg_match(kkey,cla_registry(kk)%longkey,arg) carryover = kkind/=cla_flag iequal = index(arg,"=") if (is_match .and. iequal > 1)then carryover = .False. end if just_matched = just_matched .or. is_match if (just_matched) exit ! preserve kkey and kkind end do if (just_matched .or. prev_matched )then ! current arg part of keyword arg constructal ! so this is not positional prev_matched = just_matched .and. carryover carryover = .False. cycle end if kmatch = kmatch + 1 ! increment # of positionals if(kmatch == ordinal) then pvalue = trim(arg) value=pvalue return end if end do end if value = pvalue return end if ! keyword do k=1,cla_num ! must test for exact match, not just substring if (cla_key_arg_match(cla_registry(k)%key, & cla_registry(k)%longkey, & key)) then shortkey = cla_registry(k)%key longkey = cla_registry(k)%longkey value = trim(cla_registry(k)%default) kkind = cla_registry(k)%kind end if end do if (index(trim(value),trim(cla_empty)) /= 0) then write(stderr,*) 'Error: You tried to retrieve an unknown command line argument: ',trim(key) call cla_show stop 5 endif ncla = cla_command_argument_count() if (ncla == 0) return do k=1,ncla call cla_get_command_argument(k,arg) ! test for exact match if (cla_key_arg_match(shortkey,longkey,trim(arg))) then if (kkind == cla_flag) then value = 't' return else iequal = index(arg,"=") if (iequal < 1)then call cla_get_command_argument(k+1,arg) value = trim(arg) return else value=arg(iequal+1:len_trim(arg)) return end if endif end if enddo end subroutine cla_get_char subroutine cla_get_float_r4(key,float_value) implicit none character(len=*) :: key character(len=STRLEN) :: value real(kind=4) :: float_value call cla_get_char(key,value) if (index(trim(value),trim(cla_empty)) == 0) read(value,*,err=100)float_value return 100 call cla_fatal("Input value not correct type: "//key//":"//value) end subroutine cla_get_float_r4 subroutine cla_get_float_r8(key,float_value) implicit none character(len=*) :: key character(len=STRLEN) :: value real(kind=8) :: float_value call cla_get_char(key,value) if (index(trim(value),trim(cla_empty)) == 0) read(value,*,err=100)float_value return 100 call cla_fatal("Input value not correct type: "//key//":"//value) end subroutine cla_get_float_r8 subroutine cla_get_int_i4(key,int_value) implicit none character(len=*) :: key character(len=STRLEN) :: value integer(kind=4) :: int_value call cla_get_char(key,value) if (index(trim(value),trim(cla_empty)) == 0) read(value,*,err=100)int_value return 100 call cla_fatal("Input value not correct type: "//key//":"//value) end subroutine cla_get_int_i4 subroutine cla_get_int_i8(key,int_value) implicit none character(len=*) :: key character(len=STRLEN) :: value integer(kind=8) :: int_value call cla_get_char(key,value) if (index(trim(value),trim(cla_empty)) == 0) read(value,*,err=100)int_value return 100 call cla_fatal("Input value not correct type: "//key//":"//value) end subroutine cla_get_int_i8 subroutine cla_get_logical(key,logical_value) implicit none character(len=*) :: key character(len=STRLEN) :: value logical :: logical_value integer(kind=int_kind) :: k logical_value = .false. call cla_get_char(key,value) if (index(trim(value),trim(cla_empty)) == 0) then do k=1,6 if (index(trim(value),trim(cla_true_str(k))) /= 0) then logical_value = .true. endif end do end if end subroutine cla_get_logical subroutine cla_get_flag(key,logical_value) implicit none character(len=*) :: key character(len=STRLEN) :: value logical :: logical_value integer(kind=int_kind) :: k logical_value = .false. call cla_get_char(key,value) if (index(trim(value),trim(cla_empty)) == 0) then do k=1,6 if (index(trim(value),trim(cla_true_str(k))) /= 0) then logical_value = .true. endif end do end if end subroutine cla_get_flag end module MODgvec_cla