!>>>>> ././src/M_intrinsics.f90 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== module M_intrinsics implicit none private public help_intrinsics !interface help_intrinsics ! module procedure help_intrinsics_all ! module procedure help_intrinsics_one !end interface help_intrinsics contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function help_intrinsics(name,prefix,topic,m_help) result (textblock) character(len=*),intent(in) :: name logical,intent(in),optional :: prefix logical,intent(in),optional :: topic logical,intent(in),optional :: m_help character(len=256),allocatable :: textblock(:) character(len=:),allocatable :: a, b, c integer :: i, p, pg select case(name) case('','manual','intrinsics','fortranmanual','fortran_manual') textblock=help_intrinsics_all(prefix,topic,m_help) case('fortran','toc') textblock=help_intrinsics_section() do i=1,size(textblock) p = index(textblock(i), '[') pg = index(textblock(i), ']') if(p.gt.0.and.pg.gt.p)then a=textblock(i)(:p-1) b=textblock(i)(p:pg) c=textblock(i)(pg+1:) textblock(i)=b//' '//a//c endif enddo call sort_name(textblock) case default textblock=help_intrinsics_one(name,prefix,topic,m_help) end select end function help_intrinsics !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function help_intrinsics_section() result (textblock) !@(#) grab lines in NAME section and append them to generate an index of manpages character(len=256),allocatable :: textblock(:) character(len=256),allocatable :: add(:) character(len=256),allocatable :: label character(len=10) :: cnum integer :: i integer :: icount logical :: is_label logical :: grab allocate(textblock(0)) icount=1 do write(cnum,'(i0)') icount add=help_intrinsics_one(cnum) ! get a document by number if( size(add) .eq. 0 ) exit label='' grab=.false. is_label=.false. ! look for NAME then append everything together till a line starting in column 1 that is all uppercase letters ! and assume that is the beginning of the next section to extract the NAME section as one line do i=1,size(add) if(add(i).eq.'')cycle is_label=verify(trim(add(i)),'ABCDEFGHIJKLMNOPQRSTUVWXYZ _') == 0 if(is_label.and.add(i).eq.'NAME')then grab=.true. elseif(is_label)then exit elseif(grab)then label=adjustl(trim(label))//' '//adjustl(trim(add(i))) endif enddo textblock=[character(len=256) :: textblock,label] icount=icount + 1 enddo end function help_intrinsics_section !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function help_intrinsics_all(prefix,topic,m_help) result (textblock) logical,intent(in),optional :: prefix logical,intent(in),optional :: topic logical,intent(in),optional :: m_help character(len=256),allocatable :: textblock(:) character(len=256),allocatable :: header(:) character(len=256),allocatable :: add(:) character(len=10) :: cnum integer :: icount allocate(textblock(0)) icount=1 do write(cnum,'(i0)') icount add=help_intrinsics_one(cnum,prefix,topic,m_help) if( size(add) .eq. 0 ) exit textblock=[character(len=256) :: textblock,add] icount=icount + 1 enddo if(present(m_help))then if(m_help)then header=[ character(len=256) :: & '================================================================================', & 'SUMMARY', & ' The primary Fortran topics are', & ' abs achar acos', & ' acosh adjustl adjustr', & ' aimag aint all', & ' allocated anint any', & ' asin asinh associated', & ' atan atan2 atanh', & ' atomic_add atomic_and atomic_cas', & ' atomic_define atomic_fetch_add atomic_fetch_and', & ' atomic_fetch_or atomic_fetch_xor atomic_or', & ' atomic_ref atomic_xor backspace', & ' bessel_j0 bessel_j1 bessel_jn', & ' bessel_y0 bessel_y1 bessel_yn', & ' bge bgt bit_size', & ' ble block blt', & ' btest c_associated ceiling', & ' c_f_pointer c_f_procpointer c_funloc', & ' char c_loc close', & ' cmplx co_broadcast co_lbound', & ' co_max co_min command_argument_count', & ' compiler_options compiler_version conjg', & ' continue co_reduce cos', & ' cosh co_sum co_ubound', & ' count cpu_time cshift', & ' c_sizeof date_and_time dble', & ' digits dim dot_product', & ' dprod dshiftl dshiftr', & ' eoshift epsilon erf', & ' erfc erfc_scaled event_query', & ' execute_command_line exit exp', & ' exponent extends_type_of findloc', & ' float floor flush', & ' fraction gamma get_command', & ' get_command_argument get_environment_variable huge', & ' hypot iachar iall', & ' iand iany ibclr', & ' ibits ibset ichar', & ' ieor image_index include', & ' index int ior', & ' iparity is_contiguous ishft', & ' ishftc is_iostat_end is_iostat_eor', & ' kind lbound leadz', & ' len len_trim lge', & ' lgt lle llt', & ' log log10 log_gamma', & ' logical maskl maskr', & ' matmul max maxexponent', & ' maxloc maxval merge', & ' merge_bits min minexponent', & ' minloc minval mod', & ' modulo move_alloc mvbits', & ' nearest new_line nint', & ' norm2 not null', & ' num_images pack parity', & ' popcnt poppar precision', & ' present product radix', & ' random_number random_seed range', & ' rank real repeat', & ' reshape return rewind', & ' rrspacing same_type_as scale', & ' scan selected_char_kind selected_int_kind', & ' selected_real_kind set_exponent shape', & ' shifta shiftl shiftr', & ' sign sin sinh', & ' size sngl spacing', & ' spread sqrt stop', & ' storage_size sum system_clock', & ' tan tanh this_image', & ' tiny trailz transfer', & ' transpose trim ubound', & ' unpack verify', & ''] textblock=[header,textblock] endif endif end function help_intrinsics_all !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function help_intrinsics_one(name,prefix,topic,m_help) result (textblock) character(len=*),intent(in) :: name logical,intent(in),optional :: prefix logical,intent(in),optional :: m_help logical,intent(in),optional :: topic character(len=256),allocatable :: textblock(:) character(len=:),allocatable :: shortname integer :: i select case(name) case('1','abs') textblock=[character(len=256) :: & '', & 'abs(3fortran) abs(3fortran)', & '', & '', & '', & 'NAME', & ' ABS(3) - [NUMERIC] Absolute value', & '', & '', & 'SYNOPSIS', & ' result = abs(a)', & '', & ' elemental TYPE(kind=KIND) function abs(a)', & '', & ' TYPE(kind=KIND),intent(in) :: a', & '', & '', & 'CHARACTERISTICS', & ' o A may be any real, integer, or complex value.', & '', & ' o If A is complex the returned value will be a real with the same kind as', & ' A.', & '', & ' Otherwise the returned type and kind is the same as for A.', & '', & 'DESCRIPTION', & ' ABS(3) computes the absolute value of numeric argument A.', & '', & ' In mathematics, the absolute value or modulus of a real number X, denoted', & ' |X|, is the magnitude of X without regard to its sign.', & '', & ' The absolute value of a number may be thought of as its distance from zero.', & ' So for a complex value the absolute value is a real number with magnitude', & ' SQRT(X%RE**2,X%IM**2), as if the real component is the x value and the', & ' imaginary value is the y value for the point .', & '', & 'OPTIONS', & ' o A : The value to compute the absolute value of.', & '', & 'RESULT', & ' If A is of type integer or real, the value of the result is the absolute', & ' value |A| and of the same type and kind as the input argument.', & '', & ' If A is complex with value (X, Y), the result is a real equal to a', & ' processor-dependent approximation to', & '', & ' sqrt(x**2 + y**2)', & '', & ' computed without undue overflow or underflow (that means the computation of', & ' the result can overflow the allowed magnitude of the real value returned,', & ' and that very small values can produce underflows if they are squared while', & ' calculating the returned value, for example).', & '', & ' That is, if you think of non-complex values as being complex values on the', & ' x-axis and complex values as being x-y points the result of', & ' ABS(3) is the (positive) magnitude of the distance of the value from the', & ' origin.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_abs', & ' implicit none', & ' integer,parameter :: dp=kind(0.0d0)', & '', & ' integer :: i = -1', & ' real :: x = -1.0', & ' complex :: z = (-3.0,-4.0)', & ' doubleprecision :: rr = -45.78_dp', & '', & ' character(len=*),parameter :: &', & ' ! some formats', & ' frmt = ''(1x,a15,1x," In: ",g0, T51," Out: ",g0)'', &', & ' frmtc = ''(1x,a15,1x," In: (",g0,",",g0,")",T51," Out: ",g0)'', &', & ' g = ''(*(g0,1x))''', & '', & ' ! basic usage', & ' ! any integer, real, or complex type', & ' write(*, frmt) ''integer '', i, abs(i)', & ' write(*, frmt) ''real '', x, abs(x)', & ' write(*, frmt) ''doubleprecision '', rr, abs(rr)', & ' write(*, frmtc) ''complex '', z, abs(z)', & '', & ' ! You can take the absolute value of any value whose positive value', & ' ! is representable with the same type and kind.', & ' write(*, *) ''abs range test : '', abs(huge(0)), abs(-huge(0))', & ' write(*, *) ''abs range test : '', abs(huge(0.0)), abs(-huge(0.0))', & ' write(*, *) ''abs range test : '', abs(tiny(0.0)), abs(-tiny(0.0))', & ' ! A dusty corner is that abs(-huge(0)-1) of an integer would be', & ' ! a representable negative value on most machines but result in a', & ' ! positive value out of range.', & '', & ' ! elemental', & ' write(*, g) '' abs is elemental:'', abs([20, 0, -1, -3, 100])', & '', & ' ! COMPLEX input produces REAL output', & ' write(*, g)'' complex input produces real output'', &', & ' & abs(cmplx(30.0_dp,40.0_dp,kind=dp))', & ' ! dusty corner: "kind=dp" is required or the value returned by', & ' ! CMPLX() is a default real instead of double precision', & '', & ' ! the returned value for complex input can be thought of as the', & ' ! distance from the origin <0,0>', & ' write(*, g) '' distance of ('', z, '') from zero is'', abs( z )', & ' write(*, g) '' so beware of overflow with complex values''', & ' !write(*, g) abs(cmplx( huge(0.0), huge(0.0) ))', & ' write(*, g) '' because the biggest default real is'',huge(0.0)', & '', & ' end program demo_abs', & '', & ' Results:', & '', & ' integer In: -1 Out: 1', & ' real In: -1.000000 Out: 1.000000', & ' doubleprecision In: -45.78000000000000 Out: 45.78000000000000', & ' complex In: (-3.000000,-4.000000) Out: 5.000000', & ' abs range test : 2147483647 2147483647', & ' abs range test : 3.4028235E+38 3.4028235E+38', & ' abs range test : 1.1754944E-38 1.1754944E-38', & ' abs is elemental: 20 0 1 3 100', & ' complex input produces real output 50.00000000000000', & ' distance of ( -3.000000 -4.000000 ) from zero is 5.000000', & ' so beware of overflow with complex values', & ' Inf', & ' because the biggest default real is .3402823E+39', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' SIGN(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 abs(3fortran)', & ''] shortname="abs" call process() case('2','achar') textblock=[character(len=256) :: & '', & 'achar(3fortran) achar(3fortran)', & '', & '', & '', & 'NAME', & ' ACHAR(3) - [CHARACTER:CONVERSION] Returns a character in a specified', & ' position in the ASCII collating sequence', & '', & '', & 'SYNOPSIS', & ' result = achar(i [,kind])', & '', & ' elemental character(len=1,kind=KIND) function achar(i,KIND)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o The character kind returned is the value of KIND if present. otherwise,', & ' a single default character is returned.', & '', & 'DESCRIPTION', & ' ACHAR(3) returns the character located at position I (commonly called the', & ' ADE or ASCII Decimal Equivalent) in the ASCII collating sequence.', & '', & ' The ACHAR(3) function is often used for generating in-band escape sequences', & ' to control terminal attributes, as it makes it easy to print unprintable', & ' characters such as escape and tab. For example:', & '', & ' write(*,''(*(a))'')achar(27),''[2J''', & '', & ' will clear the screen on an ANSI-compatible terminal display,', & '', & 'NOTE', & ' The ADEs (ASCII Decimal Equivalents) for ASCII are', & '', & ' *-------*-------*-------*-------*-------*-------*-------*-------*', & ' | 00 nul| 01 soh| 02 stx| 03 etx| 04 eot| 05 enq| 06 ack| 07 bel|', & ' | 08 bs | 09 ht | 10 nl | 11 vt | 12 np | 13 cr | 14 so | 15 si |', & ' | 16 dle| 17 dc1| 18 dc2| 19 dc3| 20 dc4| 21 nak| 22 syn| 23 etb|', & ' | 24 can| 25 em | 26 sub| 27 esc| 28 fs | 29 gs | 30 rs | 31 us |', & ' | 32 sp | 33 ! | 34 " | 35 # | 36 $ | 37 % | 38 & | 39 '' |', & ' | 40 ( | 41 ) | 42 * | 43 + | 44 , | 45 - | 46 . | 47 / |', & ' | 48 0 | 49 1 | 50 2 | 51 3 | 52 4 | 53 5 | 54 6 | 55 7 |', & ' | 56 8 | 57 9 | 58 : | 59 ; | 60 < | 61 = | 62 > | 63 ? |', & ' | 64 @ | 65 A | 66 B | 67 C | 68 D | 69 E | 70 F | 71 G |', & ' | 72 H | 73 I | 74 J | 75 K | 76 L | 77 M | 78 N | 79 O |', & ' | 80 P | 81 Q | 82 R | 83 S | 84 T | 85 U | 86 V | 87 W |', & ' | 88 X | 89 Y | 90 Z | 91 [ | 92 \ | 93 ] | 94 ^ | 95 _ |', & ' | 96 ` | 97 a | 98 b | 99 c |100 d |101 e |102 f |103 g |', & ' |104 h |105 i |106 j |107 k |108 l |109 m |110 n |111 o |', & ' |112 p |113 q |114 r |115 s |116 t |117 u |118 v |119 w |', & ' |120 x |121 y |122 z |123 { |124 | |125 } |126 ~ |127 del|', & ' *-------*-------*-------*-------*-------*-------*-------*-------*', & '', & '', & 'OPTIONS', & ' o I : the integer value to convert to an ASCII character, in the range 0 to', & ' 127. : ACHAR(3) shall have the value C for any character C capable of', & ' representation as a default character.', & '', & ' o KIND : a integer initialization expression indicating the kind parameter', & ' of the result.', & '', & 'RESULT', & ' Assuming I has a value in the range 0 <= I <= 127, the result is the', & ' character in position I of the ASCII collating sequence, provided the', & ' processor is capable of representing that character in the character kind of', & ' the result; otherwise, the result is processor dependent.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_achar', & ' use,intrinsic::iso_fortran_env,only:int8,int16,int32,int64', & ' implicit none', & ' integer :: i', & ' i=65', & ' write(*,''("decimal =",i0)'')i', & ' write(*,''("character =",a1)'')achar(i)', & ' write(*,''("binary =",b0)'')achar(i)', & ' write(*,''("octal =",o0)'')achar(i)', & ' write(*,''("hexadecimal =",z0)'')achar(i)', & '', & ' write(*,''(8(i3,1x,a,1x),/)'')(i,achar(i), i=32,126)', & '', & ' write(*,''(a)'')upper(''Mixed Case'')', & ' contains', & ' ! a classic use of achar(3) is to convert the case of a string', & '', & ' pure elemental function upper(str) result (string)', & ' !', & ' !$@(#) upper(3f): function to return a trimmed uppercase-only string', & ' !', & ' ! input string to convert to all uppercase', & ' character(*), intent(in) :: str', & ' ! output string that contains no miniscule letters', & ' character(len(str)) :: string', & ' integer :: i, iend', & ' integer,parameter :: toupper = iachar(''A'')-iachar(''a'')', & ' iend=len_trim(str)', & ' ! initialize output string to trimmed input string', & ' string = str(:iend)', & ' ! process each letter in the string', & ' do concurrent (i = 1:iend)', & ' select case (str(i:i))', & ' ! located miniscule letter', & ' case (''a'':''z'')', & ' ! change miniscule to majuscule letter', & ' string(i:i) = achar(iachar(str(i:i))+toupper)', & ' end select', & ' enddo', & ' end function upper', & ' end program demo_achar', & '', & ' Results:', & '', & ' decimal =65', & ' character =A', & ' binary =1000001', & ' octal =101', & ' hexadecimal =41', & ' 32 33 ! 34 " 35 # 36 $ 37 % 38 & 39 ''', & '', & ' 40 ( 41 ) 42 * 43 + 44 , 45 - 46 . 47 /', & '', & ' 48 0 49 1 50 2 51 3 52 4 53 5 54 6 55 7', & '', & ' 56 8 57 9 58 : 59 ; 60 < 61 = 62 > 63 ?', & '', & ' 64 @ 65 A 66 B 67 C 68 D 69 E 70 F 71 G', & '', & ' 72 H 73 I 74 J 75 K 76 L 77 M 78 N 79 O', & '', & ' 80 P 81 Q 82 R 83 S 84 T 85 U 86 V 87 W', & '', & ' 88 X 89 Y 90 Z 91 [ 92 \ 93 ] 94 ^ 95 _', & '', & ' 96 ` 97 a 98 b 99 c 100 d 101 e 102 f 103 g', & '', & ' 104 h 105 i 106 j 107 k 108 l 109 m 110 n 111 o', & '', & ' 112 p 113 q 114 r 115 s 116 t 117 u 118 v 119 w', & '', & ' 120 x 121 y 122 z 123 { 124 | 125 } 126 ~', & '', & ' MIXED CASE', & 'STANDARD', & ' FORTRAN 77. KIND argument added Fortran 2003', & '', & 'SEE ALSO', & ' CHAR(3), IACHAR(3), ICHAR(3)', & '', & 'RESOURCES', & ' o ANSI escape sequences', & '', & ' o M_attr module for controlling ANSI-compatible terminals', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 achar(3fortran)', & ''] shortname="achar" call process() case('3','acos') textblock=[character(len=256) :: & '', & 'acos(3fortran) acos(3fortran)', & '', & '', & '', & 'NAME', & ' ACOS(3) - [MATHEMATICS:TRIGONOMETRIC] Arccosine (inverse cosine) function', & '', & '', & 'SYNOPSIS', & ' result = acos(x)', & '', & ' elemental TYPE(kind=KIND) function acos(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o TYPE may be real or complex', & '', & ' o KIND may be any kind supported by the associated type.', & '', & ' o The returned value will be of the same type and kind as the argument.', & '', & 'DESCRIPTION', & ' ACOS(3) computes the arccosine of X (inverse of COS(X)).', & '', & 'OPTIONS', & ' o X : The value to compute the arctangent of. : If the type is real, the', & ' value must satisfy |X| <= 1.', & '', & 'RESULT', & ' The return value is of the same type and kind as X. The real part of the', & ' result is in radians and lies in the range 0 <= ACOS(X%RE) <= PI .', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_acos', & ' use, intrinsic :: iso_fortran_env, only : real_kinds,real32,real64,real128', & ' implicit none', & ' character(len=*),parameter :: all=''(*(g0,1x))''', & ' real(kind=real64) :: x , d2r', & '', & ' ! basics', & ' x = 0.866_real64', & ' print all,''acos('',x,'') is '', acos(x)', & '', & ' ! acos(-1) should be PI', & ' print all,''for reference &', & ' &PI ~= 3.14159265358979323846264338327950288419716939937510''', & ' write(*,*) acos(-1.0_real64)', & ' d2r=acos(-1.0_real64)/180.0_real64', & ' print all,''90 degrees is '', d2r*90.0_real64, '' radians''', & ' ! elemental', & ' print all,''elemental'',acos([-1.0,-0.5,0.0,0.50,1.0])', & ' ! complex', & ' print *,''complex'',acos( (-1.0, 0.0) )', & ' print *,''complex'',acos( (-1.0, -1.0) )', & ' print *,''complex'',acos( ( 0.0, -0.0) )', & ' print *,''complex'',acos( ( 1.0, 0.0) )', & '', & ' end program demo_acos', & '', & ' Results:', & '', & ' acos( 0.86599999999999999 ) is 0.52364958093182890', & ' for reference PI ~= 3.14159265358979323846264338327950288419716939937510', & ' 3.1415926535897931', & ' 90 degrees is 1.5707963267948966 radians', & ' elemental 3.14159274 2.09439516 1.57079637 1.04719758 0.00000000', & ' complex (3.14159274,-0.00000000)', & ' complex (2.23703575,1.06127501)', & ' complex (1.57079637,0.00000000)', & ' complex (0.00000000,-0.00000000)', & '', & '', & 'STANDARD', & ' FORTRAN 77 ; for a complex argument - Fortran 2008', & '', & 'SEE ALSO', & ' Inverse function: COS(3)', & '', & 'RESOURCES', & ' o wikipedia: inverse trigonometric functions', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 acos(3fortran)', & ''] shortname="acos" call process() case('4','acosh') textblock=[character(len=256) :: & '', & 'acosh(3fortran) acosh(3fortran)', & '', & '', & '', & 'NAME', & ' ACOSH(3) - [MATHEMATICS:TRIGONOMETRIC] Inverse hyperbolic cosine function', & '', & '', & 'SYNOPSIS', & ' result = acosh(x)', & '', & ' elemental TYPE(kind=KIND) function acosh(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o TYPE may be real or complex', & '', & ' o KIND may be any kind supported by the associated type.', & '', & ' o The returned value will be of the same type and kind as the argument.', & '', & 'DESCRIPTION', & ' ACOSH(3) computes the inverse hyperbolic cosine of X in radians.', & '', & 'OPTIONS', & ' o X : The value to compute the hyperbolic cosine of. A real value should be', & ' >= 1 or the result with be a Nan.', & '', & 'RESULT', & ' The result has a value equal to a processor-dependent approximation to the', & ' inverse hyperbolic cosine function of X.', & '', & ' If X is complex, the imaginary part of the result is in radians and lies', & ' between', & '', & ' 0 <= aimag(acosh(x)) <= PI', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_acosh', & ' use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32', & ' implicit none', & ' real(kind=dp), dimension(3) :: x = [ 1.0d0, 2.0d0, 3.0d0 ]', & ' if( any(x.lt.1) )then', & ' write (*,*) '' warning: values < 1 are present''', & ' endif', & ' write (*,*) acosh(x)', & ' end program demo_acosh', & '', & ' Results:', & '', & ' 0.000000000000000E+000 1.31695789692482 1.76274717403909', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' Inverse function: COSH(3)', & '', & 'RESOURCES', & ' o Wikipedia:hyperbolic functions', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 acosh(3fortran)', & ''] shortname="acosh" call process() case('5','adjustl') textblock=[character(len=256) :: & '', & 'adjustl(3fortran) adjustl(3fortran)', & '', & '', & '', & 'NAME', & ' ADJUSTL(3) - [CHARACTER:WHITESPACE] Left-justified a string', & '', & '', & 'SYNOPSIS', & ' result = adjustl(string)', & '', & ' elemental character(len=len(string),kind=KIND) function adjustl(string)', & '', & ' character(len=*,kind=KIND),intent(in) :: string', & '', & '', & 'CHARACTERISTICS', & ' o STRING is a character variable of any supported kind', & '', & ' o The return value is a character variable of the same kind and length as', & ' STRING', & '', & 'DESCRIPTION', & ' ADJUSTL(3) will left-justify a string by removing leading spaces. Spaces are', & ' inserted at the end of the string as needed.', & '', & 'OPTIONS', & ' o STRING : the string to left-justify', & '', & 'RESULT', & ' A copy of STRING where leading spaces are removed and the same number of', & ' spaces are inserted on the end of STRING.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_adjustl', & ' implicit none', & ' character(len=20) :: str = '' sample string''', & ' character(len=:),allocatable :: astr', & ' integer :: length', & '', & ' ! basic use', & ' write(*,''(a,"[",a,"]")'') ''original: '',str', & ' str=adjustl(str)', & ' write(*,''(a,"[",a,"]")'') ''adjusted: '',str', & '', & ' ! a fixed-length string can be printed', & ' ! trimmed using trim(3f) or len_trim(3f)', & ' write(*,''(a,"[",a,"]")'') ''trimmed: '',trim(str)', & ' length=len_trim(str)', & ' write(*,''(a,"[",a,"]")'') ''substring:'',str(:length)', & '', & ' ! note an allocatable string stays the same length too', & ' ! and is not trimmed by just an adjustl(3f) call.', & ' astr='' allocatable string ''', & ' write(*,''(a,"[",a,"]")'') ''original:'',astr', & ' astr = adjustl(astr)', & ' write(*,''(a,"[",a,"]")'') ''adjusted:'',astr', & ' ! trim(3f) can be used to change the length', & ' astr = trim(astr)', & ' write(*,''(a,"[",a,"]")'') ''trimmed: '',astr', & '', & ' end program demo_adjustl', & '', & ' Results:', & '', & ' original: [ sample string ]', & ' adjusted: [sample string ]', & ' trimmed: [sample string]', & ' substring:[sample string]', & ' original:[ allocatable string ]', & ' adjusted:[allocatable string ]', & ' trimmed: [allocatable string]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' ADJUSTR(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 adjustl(3fortran)', & ''] shortname="adjustl" call process() case('6','adjustr') textblock=[character(len=256) :: & '', & 'adjustr(3fortran) adjustr(3fortran)', & '', & '', & '', & 'NAME', & ' ADJUSTR(3) - [CHARACTER:WHITESPACE] Right-justify a string', & '', & '', & 'SYNOPSIS', & ' result = adjustr(string)', & '', & ' elemental character(len=len(string),kind=KIND) function adjustr(string)', & '', & ' character(len=*,kind=KIND),intent(in) :: string', & '', & '', & 'CHARACTERISTICS', & ' o STRING is a character variable', & '', & ' o The return value is a character variable of the same kind and length as', & ' STRING', & '', & 'DESCRIPTION', & ' ADJUSTR(3) right-justifies a string by removing trailing spaces. Spaces are', & ' inserted at the start of the string as needed to retain the original length.', & '', & 'OPTIONS', & ' o STRING : the string to right-justify', & '', & 'RESULT', & ' Trailing spaces are removed and the same number of spaces are inserted at', & ' the start of STRING.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_adjustr', & ' implicit none', & ' character(len=20) :: str', & ' ! print a short number line', & ' write(*,''(a)'')repeat(''1234567890'',2)', & '', & ' ! basic usage', & ' str = '' sample string ''', & ' write(*,''(a)'') str', & ' str = adjustr(str)', & ' write(*,''(a)'') str', & '', & ' !', & ' ! elemental', & ' !', & ' write(*,''(a)'')repeat(''1234567890'',5)', & ' write(*,''(a)'')adjustr([character(len=50) :: &', & ' '' first '', &', & ' '' second '', &', & ' '' third '' ])', & ' write(*,''(a)'')repeat(''1234567890'',5)', & '', & ' end program demo_adjustr', & '', & ' Results:', & '', & ' 12345678901234567890', & ' sample string', & ' sample string', & ' 12345678901234567890123456789012345678901234567890', & ' first', & ' second', & ' third', & ' 12345678901234567890123456789012345678901234567890', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' ADJUSTL(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 adjustr(3fortran)', & ''] shortname="adjustr" call process() case('7','aimag') textblock=[character(len=256) :: & '', & 'aimag(3fortran) aimag(3fortran)', & '', & '', & '', & 'NAME', & ' AIMAG(3) - [TYPE:NUMERIC] Imaginary part of complex number', & '', & '', & 'SYNOPSIS', & ' result = aimag(z)', & '', & ' elemental complex(kind=KIND) function aimag(z)', & '', & ' complex(kind=KIND),intent(in) :: z', & '', & '', & 'CHARACTERISTICS', & ' o The type of the argument Z shall be complex and any supported complex', & ' kind', & '', & ' o The return value is of type real with the kind type parameter of the', & ' argument.', & '', & 'DESCRIPTION', & ' AIMAG(3) yields the imaginary part of the complex argument Z.', & '', & ' This is similar to the modern complex-part-designator %IM which also', & ' designates the imaginary part of a value, accept a designator can appear on', & ' the left-hand side of an assignment as well, as in VAL%IM=10.0.', & '', & 'OPTIONS', & ' o Z : The complex value to extract the imaginary component of.', & '', & 'RESULT', & ' The return value is a real value with the magnitude and sign of the', & ' imaginary component of the argument Z.', & '', & ' That is, If Z has the value (X,Y), the result has the value Y.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_aimag', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' character(len=*),parameter :: g=''(*(1x,g0))''', & ' complex :: z4', & ' complex(kind=real64) :: z8', & ' ! basics', & ' z4 = cmplx(1.e0, 2.e0)', & ' print *, ''value='',z4', & ' print g, ''imaginary part='',aimag(z4),''or'', z4%im', & '', & ' ! other kinds other than the default may be supported', & ' z8 = cmplx(3.e0_real64, 4.e0_real64,kind=real64)', & ' print *, ''value='',z8', & ' print g, ''imaginary part='',aimag(z8),''or'', z8%im', & '', & ' ! an elemental function can be passed an array', & ' print *', & ' print *, [z4,z4/2.0,z4+z4,z4**3]', & ' print *', & ' print *, aimag([z4,z4/2.0,z4+z4,z4**3])', & '', & ' end program demo_aimag', & '', & ' Results:', & '', & ' value= (1.00000000,2.00000000)', & ' imaginary part= 2.00000000 or 2.00000000', & ' value= (3.0000000000000000,4.0000000000000000)', & ' imaginary part= 4.0000000000000000 or 4.0000000000000000', & '', & ' (1.00000000,2.00000000) (0.500000000,1.00000000) (2.00000000,4.00000000)', & ' (-11.0000000,-2.00000000)', & '', & ' 2.00000000 1.00000000 4.00000000 -2.00000000', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' o CMPLX(3) - Complex conversion function', & '', & ' o CONJG(3) - Complex conjugate function', & '', & ' o REAL(3) - Convert to real type', & '', & ' Fortran has strong support for complex values, including many intrinsics', & ' that take or produce complex values in addition to algebraic and logical', & ' expressions:', & '', & ' ABS(3), ACOSH(3), ACOS(3), ASINH(3), ASIN(3), ATAN2(3), ATANH(3), ATAN(3),', & ' COSH(3), COS(3), CO_SUM(3), DBLE(3), DOT_PRODUCT(3), EXP(3), INT(3),', & ' IS_CONTIGUOUS(3), KIND(3), LOG(3), MATMUL(3), PRECISION(3), PRODUCT(3),', & ' RANGE(3), RANK(3), SINH(3), SIN(3), SQRT(3), STORAGE_SIZE(3), SUM(3),', & ' TANH(3), TAN(3), UNPACK(3),', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 aimag(3fortran)', & ''] shortname="aimag" call process() case('8','aint') textblock=[character(len=256) :: & '', & 'aint(3fortran) aint(3fortran)', & '', & '', & '', & 'NAME', & ' AINT(3) - [NUMERIC] Truncate toward zero to a whole number', & '', & '', & 'SYNOPSIS', & ' result = aint(x [,kind])', & '', & ' elemental real(kind=KIND) function iaint(x,KIND)', & '', & ' real(kind=**),intent(in) :: x', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o the result is a real of the default kind unless KIND is specified.', & '', & ' o KIND is an integer initialization expression indicating the kind', & ' parameter of the result.', & '', & 'DESCRIPTION', & ' AINT(3) truncates its argument toward zero to a whole number.', & '', & 'OPTIONS', & ' o X : the real value to truncate.', & '', & ' o KIND : indicates the kind parameter of the result.', & '', & 'RESULT', & ' The sign is the same as the sign of X unless the magnitude of X is less than', & ' one, in which case zero is returned.', & '', & ' Otherwise AINT(3) returns the largest whole number that does not exceed the', & ' magnitude of X with the same sign as the input.', & '', & ' That is, it truncates the value towards zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_aint', & ' use, intrinsic :: iso_fortran_env, only : sp=>real32, dp=>real64', & ' implicit none', & ' real(kind=dp) :: x8', & ' print *,''basics:''', & ' print *,'' just chops off the fractional part''', & ' print *, aint(-2.999), aint(-2.1111)', & ' print *,'' if |x| < 1 a positive zero is returned''', & ' print *, aint(-0.999), aint( 0.9999)', & ' print *,'' input may be of any real kind''', & ' x8 = 4.3210_dp', & ' print *, aint(-x8), aint(x8)', & ' print *,''elemental:''', & ' print *,aint([ &', & ' & -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &', & ' & 0.0, &', & ' & +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ])', & ' end program demo_aint', & '', & ' Results:', & '', & ' basics:', & ' just chops off the fractional part', & ' -2.000000 -2.000000', & ' if |x| < 1 a positive zero is returned', & ' 0.0000000E+00 0.0000000E+00', & ' input may be of any real kind', & ' -4.00000000000000 4.00000000000000', & ' elemental:', & ' -2.000000 -2.000000 -2.000000 -2.000000 -1.000000', & ' -1.000000 0.0000000E+00 0.0000000E+00 0.0000000E+00 1.000000', & ' 1.000000 2.000000 2.000000 2.000000 2.000000', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ANINT(3), INT(3), NINT(3), SELECTED_INT_KIND(3), CEILING(3), FLOOR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 aint(3fortran)', & ''] shortname="aint" call process() case('9','all') textblock=[character(len=256) :: & '', & 'all(3fortran) all(3fortran)', & '', & '', & '', & 'NAME', & ' ALL(3) - [ARRAY:REDUCTION] Determines if all the values are true', & '', & '', & 'SYNOPSIS', & ' result = all(mask [,dim])', & '', & ' function all(mask ,dim)', & '', & ' logical(kind=KIND),intent(in) :: mask(..)', & ' integer,intent(in),optional :: dim', & ' logical(kind=KIND) :: all(..)', & '', & '', & 'CHARACTERISTICS', & ' o MASK is a logical array', & '', & ' o DIM is an integer', & '', & ' o the result is a logical array if DIM is supplied, otherwise it is a', & ' logical scalar. It has the same characteristics as MASK', & '', & 'DESCRIPTION', & ' ALL(3) determines if all the values are true in MASK in the array along', & ' dimension DIM if DIM is specified; otherwise all elements are tested', & ' together.', & '', & ' This testing type is called a logical conjunction of elements of MASK along', & ' dimension DIM.', & '', & ' The mask is generally a logical expression, allowing for comparing arrays', & ' and many other common operations.', & '', & 'OPTIONS', & ' o MASK : the logical array to be tested for all elements being .true.', & '', & ' o DIM : DIM indicates the direction through the elements of MASK to group', & ' elements for testing. : DIM has a value that lies between one and the', & ' rank of MASK. : The corresponding actual argument shall not be an', & ' optional dummy argument. : If DIM is not present all elements are tested', & ' and a single scalar value is returned.', & '', & 'RESULT', & ' 1. If DIM is not present ALL(MASK) is .true. if all elements of MASK are', & ' .true.. It also is .true. if MASK has zero size; otherwise, it is', & ' .false. .', & '', & ' 2. If the rank of MASK is one, then ALL(MASK, DIM) is equivalent to', & ' ALL(MASK).', & '', & ' 3. If the rank of MASK is greater than one and DIM is present then', & ' ALL(MASK,DIM) returns an array with the rank (number of dimensions) of', & ' MASK minus 1. The shape is determined from the shape of MASK where the', & ' DIM dimension is elided. A value is returned for each set of elements', & ' along the DIM dimension.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_all', & ' implicit none', & ' logical,parameter :: T=.true., F=.false.', & ' logical bool', & '', & ' ! basic usage', & ' ! is everything true?', & ' bool = all([ T,T,T ])', & ' print *, ''are all values true?'', bool', & ' bool = all([ T,F,T ])', & ' print *, ''are all values true now?'', bool', & '', & ' ! compare matrices, even by a dimension', & ' ARRAYS: block', & ' integer :: a(2,3), b(2,3)', & ' ! set everything to one except one value in b', & ' a = 1', & ' b = 1', & ' b(2,2) = 2', & ' ! now compare those two arrays', & ' print *,''entire array :'', all(a == b )', & ' print *,''compare columns:'', all(a == b, dim=1)', & ' print *,''compare rows:'', all(a == b, dim=2)', & ' end block ARRAYS', & '', & ' end program demo_all', & '', & ' Results:', & '', & ' > T', & ' > F', & ' > entire array : F', & ' > compare columns: T F T', & ' > compare rows: T F', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' ANY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 all(3fortran)', & ''] shortname="all" call process() case('10','allocated') textblock=[character(len=256) :: & '', & 'allocated(3fortran) allocated(3fortran)', & '', & '', & '', & 'NAME', & ' ALLOCATED(3) - [ARRAY:INQUIRY] Allocation status of an allocatable entity', & '', & '', & 'SYNOPSIS', & ' result = allocated(array|scalar)', & '', & ' logical function allocated(array,scalar)', & '', & ' type(TYPE(kind=**)),allocatable,optional :: array(..)', & ' type(TYPE(kind=**)),allocatable,optional :: scalar', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o ARRAY may be any allocatable array object of any type.', & '', & ' o SCALAR may be any allocatable scalar of any type.', & '', & ' o the result is a default logical scalar', & '', & 'DESCRIPTION', & ' ALLOCATED(3) checks the allocation status of both arrays and scalars.', & '', & ' At least one and only one of ARRAY or SCALAR must be specified.', & '', & 'OPTIONS', & ' o ENTITY : the allocatable object to test.', & '', & 'RESULT', & ' If the argument is allocated then the result is .true.; otherwise, it', & ' returns .false..', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_allocated', & ' use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32', & ' implicit none', & ' real(kind=sp), allocatable :: x(:)', & ' character(len=256) :: message', & ' integer :: istat', & ' ! basics', & ' if( allocated(x)) then', & ' write(*,*)''do things if allocated''', & ' else', & ' write(*,*)''do things if not allocated''', & ' endif', & '', & ' ! if already allocated, deallocate', & ' if ( allocated(x) ) deallocate(x,STAT=istat, ERRMSG=message )', & ' if(istat.ne.0)then', & ' write(*,*)trim(message)', & ' stop', & ' endif', & '', & ' ! only if not allocated, allocate', & ' if ( .not. allocated(x) ) allocate(x(20))', & '', & ' ! allocation and intent(out)', & ' call intentout(x)', & ' write(*,*)''note it is deallocated!'',allocated(x)', & '', & ' contains', & '', & ' subroutine intentout(arr)', & ' ! note that if arr has intent(out) and is allocatable,', & ' ! arr is deallocated on entry', & ' real(kind=sp),intent(out),allocatable :: arr(:)', & ' write(*,*)''note it was allocated in calling program'',allocated(arr)', & ' end subroutine intentout', & '', & ' end program demo_allocated', & '', & ' Results:', & '', & ' > do things if not allocated', & ' > note it was allocated in calling program F', & ' > note it is deallocated! F', & '', & '', & 'STANDARD', & ' Fortran 95. allocatable scalar entities were added in Fortran 2003.', & '', & 'SEE ALSO', & ' MOVE_ALLOC(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 allocated(3fortran)', & ''] shortname="allocated" call process() case('11','anint') textblock=[character(len=256) :: & '', & 'anint(3fortran) anint(3fortran)', & '', & '', & '', & 'NAME', & ' ANINT(3) - [NUMERIC] Real nearest whole number', & '', & '', & 'SYNOPSIS', & ' result = anint(a [,kind])', & '', & ' elemental real(kind=KIND) function anint(x,KIND)', & '', & ' real(kind=**),intent(in) :: x', & ' integer,intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o A is type real of any kind', & '', & ' o KIND is a scalar integer constant expression.', & '', & ' o the result is type real. The kind of the result is the same as X unless', & ' specified by KIND.', & '', & 'DESCRIPTION', & ' ANINT(3) rounds its argument to the nearest whole number.', & '', & ' Unlike NINT(3) which returns an integer the full range or real values can be', & ' returned (integer types typically have a smaller range of values than real', & ' types).', & '', & 'OPTIONS', & ' o A : the value to round', & '', & ' o KIND : specifies the kind of the result. The default is the kind of A.', & '', & 'RESULT', & ' The return value is the real whole number nearest A.', & '', & ' If A is greater than zero, ANINT(A)(3) returns AINT(A + 0.5).', & '', & ' If A is less than or equal to zero then it returns AINT(A - 0.5), except', & ' AINT specifies that for |A| < 1 the result is zero (0).', & '', & ' It is processor-dependent whether anint(a) returns negative zero when -0.5 <', & ' a <= -0.0. Compiler switches are often available which enable or disable', & ' support of negative zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_anint', & ' use, intrinsic :: iso_fortran_env, only : real32, real64, real128', & ' implicit none', & ' real,allocatable :: arr(:)', & '', & ' ! basics', & ' print *, ''ANINT (2.783) has the value 3.0 =>'', anint(2.783)', & ' print *, ''ANINT (-2.783) has the value -3.0 =>'', anint(-2.783)', & '', & ' print *, ''by default the kind of the output is the kind of the input''', & ' print *, anint(1234567890.1234567890e0)', & ' print *, anint(1234567890.1234567890d0)', & '', & ' print *, ''sometimes specifying the result kind is useful when passing''', & ' print *, ''results as an argument, for example.''', & ' print *, ''do you know why the results are different?''', & ' print *, anint(1234567890.1234567890,kind=real64)', & ' print *, anint(1234567890.1234567890d0,kind=real64)', & '', & ' ! elemental', & ' print *, ''numbers on a cusp are always the most troublesome''', & ' print *, anint([ -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, 0.0 ])', & '', & ' print *, ''negative zero is processor dependent''', & ' arr=[ 0.0, 0.1, 0.5, 1.0, 1.5, 2.0, 2.2, 2.5, 2.7 ]', & ' print *, anint(arr)', & ' arr=[ -0.0, -0.1, -0.5, -1.0, -1.5, -2.0, -2.2, -2.5, -2.7 ]', & ' print *, anint(arr)', & '', & ' end program demo_anint', & '', & ' Results:', & '', & ' > ANINT (2.783) has the value 3.0 => 3.000000', & ' > ANINT (-2.783) has the value -3.0 => -3.000000', & ' > by default the kind of the output is the kind of the input', & ' > 1.2345679E+09', & ' > 1234567890.00000', & ' > sometimes specifying the result kind is useful when passing', & ' > results as an argument, for example.', & ' > do you know why the results are different?', & ' > 1234567936.00000', & ' > 1234567890.00000', & ' > numbers on a cusp are always the most troublesome', & ' > -3.000000 -3.000000 -2.000000 -2.000000 -2.000000', & ' > -1.000000 -1.000000 0.0000000E+00', & ' > negative zero is processor dependent', & ' > 0.0000000E+00 0.0000000E+00 1.000000 1.000000 2.000000', & ' > 2.000000 2.000000 3.000000 3.000000', & ' > 0.0000000E+00 0.0000000E+00 -1.000000 -1.000000 -2.000000', & ' > -2.000000 -2.000000 -3.000000 -3.000000', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' AINT(3), INT(3), NINT(3), SELECTED_INT_KIND(3), CEILING(3), FLOOR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 anint(3fortran)', & ''] shortname="anint" call process() case('12','any') textblock=[character(len=256) :: & '', & 'any(3fortran) any(3fortran)', & '', & '', & '', & 'NAME', & ' ANY(3) - [ARRAY:REDUCTION] Determines if any of the values in the logical', & ' array are .true.', & '', & '', & 'SYNOPSIS', & ' result = any(mask [,dim])', & '', & ' function any(mask, dim)', & '', & ' logical(kind=KIND),intent(in) :: mask(..)', & ' integer,intent(in),optional :: dim', & ' logical(kind=KIND) :: any(..)', & '', & '', & 'CHARACTERISTICS', & ' o MASK is a logical array', & '', & ' o DIM is a scalar integer', & '', & ' o the result is a logical array if DIM is supplied, otherwise it is a', & ' logical scalar.', & '', & 'DESCRIPTION', & ' ANY(3) determines if any of the values in the logical array MASK along', & ' dimension DIM are .true..', & '', & 'OPTIONS', & ' o MASK : an array of logical expressions or values to be tested in groups', & ' or in total for a .true. value.', & '', & ' o DIM : a whole number value that lies between one and RANK(MASK) that', & ' indicates to return an array of values along the indicated dimension', & ' instead of a scalar answer.', & '', & 'RESULT', & ' ANY(MASK) returns a scalar value of type logical where the kind type', & ' parameter is the same as the kind type parameter of MASK. If DIM is present,', & ' then ANY(MASK, DIM) returns an array with the rank of MASK minus 1. The', & ' shape is determined from the shape of MASK where the DIM dimension is', & ' elided.', & '', & ' 1. ANY(MASK) is .true. if any element of MASK is .true.; otherwise, it is', & ' .false.. It also is .false. if MASK has zero size.', & '', & ' 2. If the rank of MASK is one, then ANY(MASK, DIM) is equivalent to', & ' ANY(MASK). If the rank is greater than one, then ANY(MASK, DIM) is', & ' determined by applying ANY(MASK) to the array sections.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_any', & ' implicit none', & ' logical,parameter :: T=.true., F=.false.', & ' integer :: a(2,3), b(2,3)', & ' logical :: bool', & ' ! basic usage', & ' bool = any([F,F,T,F])', & ' print *,bool', & ' bool = any([F,F,F,F])', & ' print *,bool', & ' ! fill two integer arrays with values for testing', & ' a = 1', & ' b = 1', & ' b(:,2) = 2', & ' b(:,3) = 3', & ' ! using any(3) with logical expressions you can compare two arrays', & ' ! in a myriad of ways', & ' ! first, print where elements of b are bigger than in a', & ' call printl( ''first print b > a '', b > a )', & ' ! now use any() to test', & ' call printl( ''any true values? any(b > a) '', any(b > a ) )', & ' call printl( ''again by columns? any(b > a,1)'', any(b > a, 1) )', & ' call printl( ''again by rows? any(b > a,2)'', any(b > a, 2) )', & ' contains', & ' ! CONVENIENCE ROUTINE. this is not specific to ANY()', & ' subroutine printl(title,a)', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & stderr=>ERROR_UNIT,&', & ' & stdin=>INPUT_UNIT,&', & ' & stdout=>OUTPUT_UNIT', & ' implicit none', & '', & ' !@(#) print small 2d logical scalar, vector, or matrix', & '', & ' character(len=*),parameter :: all=''(*(g0,1x))''', & ' character(len=*),parameter :: row=''(" > [ ",*(l1:,","))''', & ' character(len=*),intent(in) :: title', & ' logical,intent(in) :: a(..)', & ' integer :: i', & ' write(*,*)', & ' write(*,all,advance=''no'')trim(title),&', & ' & '' : shape='',shape(a),'',rank='',rank(a),'',size='',size(a)', & ' ! get size and shape of input', & ' select rank(a)', & ' rank (0); write(*,''(a)'')''(a scalar)''', & ' write(*,fmt=row,advance=''no'')a', & ' write(*,''(" ]")'')', & ' rank (1); write(*,''(a)'')''(a vector)''', & ' do i=1,size(a)', & ' write(*,fmt=row,advance=''no'')a(i)', & ' write(*,''(" ]")'')', & ' enddo', & ' rank (2); write(*,''(a)'')''(a matrix) ''', & ' do i=1,size(a,dim=1)', & ' write(*,fmt=row,advance=''no'')a(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' rank default', & ' write(stderr,*)''*printl* did not expect rank='', rank(a), &', & ' & ''shape='', shape(a),''size='',size(a)', & ' stop ''*printl* unexpected rank''', & ' end select', & '', & ' end subroutine printl', & '', & ' end program demo_any', & '', & ' Results:', & '', & ' > T', & ' > F', & ' >', & ' > first print b > a : shape=23,rank=2,size=6(a matrix)', & ' > > [ F,T,T ]', & ' > > [ F,T,T ]', & ' >', & ' > any true values? any(b > a) : shape=,rank=0,size=1(a scalar)', & ' > > [ T ]', & ' >', & ' > again by columns? any(b > a,1) : shape=3,rank=1,size=3(a vector)', & ' > > [ F ]', & ' > > [ T ]', & ' > > [ T ]', & ' >', & ' > again by rows? any(b > a,2) : shape=2,rank=1,size=2(a vector)', & ' > > [ T ]', & ' > > [ T ]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' ALL(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 any(3fortran)', & ''] shortname="any" call process() case('13','asin') textblock=[character(len=256) :: & '', & 'asin(3fortran) asin(3fortran)', & '', & '', & '', & 'NAME', & ' ASIN(3) - [MATHEMATICS:TRIGONOMETRIC] Arcsine function', & '', & '', & 'SYNOPSIS', & ' result = asin(x)', & '', & ' elemental TYPE(kind=KIND) function asin(x)', & '', & ' TYPE(kind=KIND) :: x', & '', & '', & 'CHARACTERISTICS', & ' o TYPE may be real or complex', & '', & ' o KIND may be any kind supported by the associated type.', & '', & ' o The returned value will be of the same type and kind as the argument.', & '', & 'DESCRIPTION', & ' ASIN(3) computes the arcsine of its argument X.', & '', & ' The arcsine is the inverse function of the sine function. It is commonly', & ' used in trigonometry when trying to find the angle when the lengths of the', & ' hypotenuse and the opposite side of a right triangle are known.', & '', & 'OPTIONS', & ' o X : The value to compute the arcsine of : The type shall be either real', & ' and a magnitude that is less than or equal to one; or be complex.', & '', & 'RESULT', & ' o RESULT The result has a value equal to a processor-dependent', & ' approximation to arcsin(x).', & '', & ' If X is real the result is real and it is expressed in radians and lies', & ' in the range', & '', & ' PI/2 <= ASIN (X) <= PI/2.', & '', & ' If the argument (and therefore the result) is imaginary the real part of', & ' the result is in radians and lies in the range', & '', & ' -PI/2 <= real(asin(x)) <= PI/2', & '', & '', & 'EXAMPLES', & ' The arcsine will allow you to find the measure of a right angle when you', & ' know the ratio of the side opposite the angle to the hypotenuse.', & '', & ' So if you knew that a train track rose 1.25 vertical miles on a track that', & ' was 50 miles long, you could determine the average angle of incline of the', & ' track using the arcsine. Given', & '', & ' sin(theta) = 1.25 miles/50 miles (opposite/hypotenuse)', & '', & ' Sample program:', & '', & ' program demo_asin', & ' use, intrinsic :: iso_fortran_env, only : dp=>real64', & ' implicit none', & ' ! value to convert degrees to radians', & ' real(kind=dp),parameter :: D2R=acos(-1.0_dp)/180.0_dp', & ' real(kind=dp) :: angle, rise, run', & ' character(len=*),parameter :: all=''(*(g0,1x))''', & ' ! given sine(theta) = 1.25 miles/50 miles (opposite/hypotenuse)', & ' ! then taking the arcsine of both sides of the equality yields', & ' ! theta = arcsine(1.25 miles/50 miles) ie. arcsine(opposite/hypotenuse)', & ' rise=1.250_dp', & ' run=50.00_dp', & ' angle = asin(rise/run)', & ' print all, ''angle of incline(radians) = '', angle', & ' angle = angle/D2R', & ' print all, ''angle of incline(degrees) = '', angle', & '', & ' print all, ''percent grade='',rise/run*100.0_dp', & ' end program demo_asin', & '', & ' Results:', & '', & ' angle of incline(radians) = 2.5002604899361139E-002', & ' angle of incline(degrees) = 1.4325437375665075', & ' percent grade= 2.5000000000000000', & '', & ' The percentage grade is the slope, written as a percent. To calculate the', & ' slope you divide the rise by the run. In the example the rise is 1.25 mile', & ' over a run of 50 miles so the slope is 1.25/50 = 0.025. Written as a', & ' percent this is 2.5 %.', & '', & ' For the US, two and 1/2 percent is generally thought of as the upper limit.', & ' This means a rise of 2.5 feet when going 100 feet forward. In the US this', & ' was the maximum grade on the first major US railroad, the Baltimore and', & ' Ohio. Note curves increase the frictional drag on a train reducing the', & ' allowable grade.', & '', & 'STANDARD', & ' FORTRAN 77 , for a complex argument Fortran 2008', & '', & 'SEE ALSO', & ' Inverse function: SIN(3)', & '', & 'RESOURCES', & ' o wikipedia: inverse trigonometric functions', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 asin(3fortran)', & ''] shortname="asin" call process() case('14','asinh') textblock=[character(len=256) :: & '', & 'asinh(3fortran) asinh(3fortran)', & '', & '', & '', & 'NAME', & ' ASINH(3) - [MATHEMATICS:TRIGONOMETRIC] Inverse hyperbolic sine function', & '', & '', & 'SYNOPSIS', & ' result = asinh(x)', & '', & ' elemental TYPE(kind=KIND) function asinh(x)', & '', & ' TYPE(kind=KIND) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be any real or complex type', & '', & ' o KIND may be any kind supported by the associated type', & '', & ' o The returned value will be of the same type and kind as the argument', & '', & ' X', & 'DESCRIPTION', & ' ASINH(3) computes the inverse hyperbolic sine of X.', & '', & 'OPTIONS', & ' o X : The value to compute the inverse hyperbolic sine of', & '', & 'RESULT', & ' The result has a value equal to a processor-dependent approximation to the', & ' inverse hyperbolic sine function of X.', & '', & ' If X is complex, the imaginary part of the result is in radians and lies', & ' between -PI/2 <= AIMAG(ASINH(X)) <= PI/2.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_asinh', & ' use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32', & ' implicit none', & ' real(kind=dp), dimension(3) :: x = [ -1.0d0, 0.0d0, 1.0d0 ]', & '', & ' ! elemental', & ' write (*,*) asinh(x)', & '', & ' end program demo_asinh', & '', & ' Results:', & '', & ' -0.88137358701954305 0.0000000000000000 0.88137358701954305', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' Inverse function: SINH(3)', & '', & 'RESOURCES', & ' o Wikipedia:hyperbolic functions', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 asinh(3fortran)', & ''] shortname="asinh" call process() case('15','associated') textblock=[character(len=256) :: & '', & 'associated(3fortran) associated(3fortran)', & '', & '', & '', & 'NAME', & ' ASSOCIATED(3) - [STATE:INQUIRY] Association status of a pointer or', & ' pointer/target pair', & '', & '', & 'SYNOPSIS', & ' result = associated(pointer [,target])', & '', & ' logical function associated(pointer,target)', & '', & ' type(TYPE(kind=KIND)),pointer :: pointer', & ' type(TYPE(kind=KIND)),pointer,optional :: target', & '', & '', & 'CHARACTERISTICS', & ' o POINTER shall have the pointer attribute and it can be any type or may be', & ' a procedure pointer', & '', & ' o TARGET shall be a pointer or a target. It must have the same type, kind', & ' type parameter, and array rank as POINTER.', & '', & ' o The association status of neither POINTER nor TARGET shall be undefined.', & '', & ' o the result is a default logical value', & '', & 'DESCRIPTION', & ' ASSOCIATED(3) determines the status of the pointer POINTER or if POINTER is', & ' associated with the target TARGET.', & '', & 'OPTIONS', & ' o POINTER : A pointer to test for association. Its pointer association', & ' status shall not be undefined.', & '', & ' o TARGET : A target that is to be tested for occupying the same storage', & ' units as the pointer POINTER. That is, it is tested as to whether it is', & ' pointed to by POINTER.', & '', & 'RESULT', & ' ASSOCIATED(3f) returns a scalar value of type logical. There are several', & ' cases:', & '', & ' 1. When the optional TARGET is not present then ASSOCIATED(POINTER) is', & ' .true. if POINTER is associated with a target; otherwise, it returns', & ' .false..', & '', & ' 2. If TARGET is present and a scalar target, the result is .true. if TARGET', & ' is not a zero-sized storage sequence and the target associated with', & ' POINTER occupies the same storage units. If POINTER is disassociated,', & ' the result is .false..', & '', & ' 3. If TARGET is present and an array target, the result is .true. if TARGET', & ' and POINTER have the same shape, are not zero-sized arrays, are arrays', & ' whose elements are not zero-sized storage sequences, and TARGET and', & ' POINTER occupy the same storage units in array element order.', & '', & ' As in case 2, the result is .false., if POINTER is disassociated.', & '', & ' 4. If TARGET is present and an scalar pointer, the result is .true. if', & ' TARGET is associated with POINTER, the target associated with TARGET are', & ' not zero-sized storage sequences and occupy the same storage units.', & '', & ' The result is .false., if either TARGET or POINTER is disassociated.', & '', & ' 5. If TARGET is present and an array pointer, the result is .true. if', & ' target associated with POINTER and the target associated with TARGET', & ' have the same shape, are not zero-sized arrays, are arrays whose', & ' elements are not zero-sized storage sequences, and TARGET and POINTER', & ' occupy the same storage units in array element order.', & '', & ' 6. If TARGET is present and is a procedure, the result is true if and only', & ' if POINTER is associated with TARGET and, if TARGET is an internal', & ' procedure, they have the same host instance.', & '', & ' 7. If TARGET is present and is a procedure pointer, the result is true if', & ' and only if POINTER and TARGET are associated with the same procedure', & ' and, if the procedure is an internal procedure, they have the same host', & ' instance.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_associated', & ' implicit none', & ' real, target :: tgt(2) = [1., 2.]', & ' real, pointer :: ptr(:)', & ' ptr => tgt', & ' if (associated(ptr) .eqv. .false.) &', & ' & stop ''POINTER NOT ASSOCIATED''', & ' if (associated(ptr,tgt) .eqv. .false.) &', & ' & stop ''POINTER NOT ASSOCIATED TO TARGET''', & ' end program demo_associated', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' NULL(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 associated(3fortran)', & ''] shortname="associated" call process() case('16','atan2') textblock=[character(len=256) :: & '', & 'atan2(3fortran) atan2(3fortran)', & '', & '', & '', & 'NAME', & ' ATAN2(3) - [MATHEMATICS:TRIGONOMETRIC] Arctangent (inverse tangent) function', & '', & '', & 'SYNOPSIS', & ' result = atan2(y, x)', & '', & ' elemental real(kind=KIND) function atan2(y, x)', & '', & ' real,kind=KIND) :: atan2', & ' real,kind=KIND),intent(in) :: y, x', & '', & '', & 'CHARACTERISTICS', & ' o X and Y must be reals of the same kind.', & '', & ' o The return value has the same type and kind as Y and X.', & '', & 'DESCRIPTION', & ' ATAN2(3) computes in radians a processor-dependent approximation of the', & ' arctangent of the complex number ( X, Y ) or equivalently the principal', & ' value of the arctangent of the value Y/X (which determines a unique angle).', & '', & ' If Y has the value zero, X shall not have the value zero.', & '', & ' The resulting phase lies in the range -PI <= ATAN2 (Y,X) <= PI and is equal', & ' to a processor-dependent approximation to a value of arctan(Y/X).', & '', & 'OPTIONS', & ' o Y : The imaginary component of the complex value (X,Y) or the Y component', & ' of the point .', & '', & ' o X : The real component of the complex value (X,Y) or the X component of', & ' the point .', & '', & 'RESULT', & ' The value returned is by definition the principal value of the complex', & ' number (X, Y), or in other terms, the phase of the phasor x+i*y.', & '', & ' The principal value is simply what we get when we adjust a radian value to', & ' lie between -PI and PI inclusive,', & '', & ' The classic definition of the arctangent is the angle that is formed in', & ' Cartesian coordinates of the line from the origin point <0,0> to the point', & ' .', & '', & ' Pictured as a vector it is easy to see that if X and Y are both zero the', & ' angle is indeterminate because it sits directly over the origin, so', & ' ATAN(0.0,0.0) will produce an error.', & '', & ' Range of returned values by quadrant:', & '', & ' > +PI/2', & ' > |', & ' > |', & ' > PI/2 < z < PI | 0 > z < PI/2', & ' > |', & ' > +-PI -------------+---------------- +-0', & ' > |', & ' > PI/2 < -z < PI | 0 < -z < PI/2', & ' > |', & ' > |', & ' > -PI/2', & ' >', & ' NOTES:', & '', & ' If the processor distinguishes -0 and +0 then the sign of the', & ' returned value is that of Y when Y is zero, else when Y is zero', & ' the returned value is always positive.', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atan2', & ' real :: z', & ' complex :: c', & ' !', & ' ! basic usage', & ' ! ATAN2 (1.5574077, 1.0) has the value 1.0 (approximately).', & ' z=atan2(1.5574077, 1.0)', & ' write(*,*) ''radians='',z,''degrees='',r2d(z)', & ' !', & ' ! elemental arrays', & ' write(*,*)''elemental'',atan2( [10.0, 20.0], [30.0,40.0] )', & ' !', & ' ! elemental arrays and scalars', & ' write(*,*)''elemental'',atan2( [10.0, 20.0], 50.0 )', & ' !', & ' ! break complex values into real and imaginary components', & ' ! (note TAN2() can take a complex type value )', & ' c=(0.0,1.0)', & ' write(*,*)''complex'',c,atan2( x=c%re, y=c%im )', & ' !', & ' ! extended sample converting cartesian coordinates to polar', & ' COMPLEX_VALS: block', & ' real :: ang, radius', & ' complex,allocatable :: vals(:)', & ' integer :: i', & ' !', & ' vals=[ &', & ' ( 1.0, 0.0 ), & ! 0', & ' ( 1.0, 1.0 ), & ! 45', & ' ( 0.0, 1.0 ), & ! 90', & ' (-1.0, 1.0 ), & ! 135', & ' (-1.0, 0.0 ), & ! 180', & ' (-1.0,-1.0 ), & ! 225', & ' ( 0.0,-1.0 )] ! 270', & ' do i=1,size(vals)', & ' call cartesian_to_polar(vals(i)%re, vals(i)%im, radius,ang)', & ' write(*,101)vals(i),ang,r2d(ang),radius', & ' enddo', & ' 101 format( &', & ' & ''X= '',f5.2, &', & ' & '' Y= '',f5.2, &', & ' & '' ANGLE= '',g0, &', & ' & T38,''DEGREES= '',g0.4, &', & ' & T54,''DISTANCE='',g0)', & ' endblock COMPLEX_VALS', & ' !', & ' contains', & ' !', & ' elemental real function r2d(radians)', & ' ! input radians to convert to degrees', & ' doubleprecision,parameter :: DEGREE=0.017453292519943d0 ! radians', & ' real,intent(in) :: radians', & ' r2d=radians / DEGREE ! do the conversion', & ' end function r2d', & ' !', & ' subroutine cartesian_to_polar(x,y,radius,inclination)', & ' ! return angle in radians in range 0 to 2*PI', & ' implicit none', & ' real,intent(in) :: x,y', & ' real,intent(out) :: radius,inclination', & ' radius=sqrt(x**2+y**2)', & ' if(radius.eq.0)then', & ' inclination=0.0', & ' else', & ' inclination=atan2(y,x)', & ' if(inclination < 0.0)inclination=inclination+2*atan2(0.0d0,-1.0d0)', & ' endif', & ' end subroutine cartesian_to_polar', & ' !', & ' end program demo_atan2', & '', & ' Results:', & '', & ' > radians= 1.000000 degrees= 57.29578', & ' > elemental 0.3217506 0.4636476', & ' > elemental 0.1973956 0.3805064', & ' > complex (0.0000000E+00,1.000000) 1.570796', & ' > X= 1.00 Y= 0.00 ANGLE= .000000 DEGREES= .000 DISTANCE=1.000000', & ' > X= 1.00 Y= 1.00 ANGLE= .7853982 DEGREES= 45.00 DISTANCE=1.414214', & ' > X= 0.00 Y= 1.00 ANGLE= 1.570796 DEGREES= 90.00 DISTANCE=1.000000', & ' > X= -1.00 Y= 1.00 ANGLE= 2.356194 DEGREES= 135.0 DISTANCE=1.414214', & ' > X= -1.00 Y= 0.00 ANGLE= 3.141593 DEGREES= 180.0 DISTANCE=1.000000', & ' > X= -1.00 Y= -1.00 ANGLE= 3.926991 DEGREES= 225.0 DISTANCE=1.414214', & ' > X= 0.00 Y= -1.00 ANGLE= 4.712389 DEGREES= 270.0 DISTANCE=1.000000', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' o ATAN(3)', & '', & 'RESOURCES', & ' o arctan:wikipedia fortran-lang intrinsic descriptions (license: MIT)', & ' @urbanjost', & '', & '', & '', & ' March 23, 2024 atan2(3fortran)', & ''] shortname="atan2" call process() case('17','atan') textblock=[character(len=256) :: & '', & 'atan(3fortran) atan(3fortran)', & '', & '', & '', & 'NAME', & ' ATAN(3) - [MATHEMATICS:TRIGONOMETRIC] Arctangent AKA inverse tangent', & ' function', & '', & '', & 'SYNOPSIS', & ' result = atan([x) | atan(y, x)', & '', & ' elemental TYPE(kind=KIND) function atan(y,x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & ' TYPE(kind=**),intent(in),optional :: y', & '', & '', & 'CHARACTERISTICS', & ' o If Y is present X and Y must both be real. Otherwise, X may be complex.', & '', & ' o KIND can be any kind supported by the associated type.', & '', & ' o The returned value is of the same type and kind as X.', & '', & 'DESCRIPTION', & ' ATAN(3) computes the arctangent of X.', & '', & 'OPTIONS', & ' o X : The value to compute the arctangent of. if Y is present, X shall be', & ' real.', & '', & ' o Y : is of the same type and kind as X. If X is zero, Y must not be zero.', & '', & 'RESULT', & ' The returned value is of the same type and kind as X. If Y is present, the', & ' result is identical to ATAN2(Y,X). Otherwise, it is the arc tangent of X,', & ' where the real part of the result is in radians and lies in the range -PI/2', & ' <= ATAN(X) <= PI/2', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atan', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' character(len=*),parameter :: all=''(*(g0,1x))''', & ' real(kind=real64),parameter :: &', & ' Deg_Per_Rad = 57.2957795130823208767981548_real64', & ' real(kind=real64) :: x', & ' x=2.866_real64', & ' print all, atan(x)', & '', & ' print all, atan( 2.0d0, 2.0d0),atan( 2.0d0, 2.0d0)*Deg_Per_Rad', & ' print all, atan( 2.0d0,-2.0d0),atan( 2.0d0,-2.0d0)*Deg_Per_Rad', & ' print all, atan(-2.0d0, 2.0d0),atan(-2.0d0, 2.0d0)*Deg_Per_Rad', & ' print all, atan(-2.0d0,-2.0d0),atan(-2.0d0,-2.0d0)*Deg_Per_Rad', & '', & ' end program demo_atan', & '', & ' Results:', & '', & ' 1.235085437457879', & ' .7853981633974483 45.00000000000000', & ' 2.356194490192345 135.0000000000000', & ' -.7853981633974483 -45.00000000000000', & ' -2.356194490192345 -135.0000000000000', & '', & '', & 'STANDARD', & ' FORTRAN 77 for a complex argument; and for two arguments Fortran 2008', & '', & 'SEE ALSO', & ' ATAN2(3), TAN(3)', & '', & 'RESOURCES', & ' o wikipedia: inverse trigonometric functions', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 atan(3fortran)', & ''] shortname="atan" call process() case('18','atanh') textblock=[character(len=256) :: & '', & 'atanh(3fortran) atanh(3fortran)', & '', & '', & '', & 'NAME', & ' ATANH(3) - [MATHEMATICS:TRIGONOMETRIC] Inverse hyperbolic tangent function', & '', & '', & 'SYNOPSIS', & ' result = atanh(x)', & '', & ' elemental TYPE(kind=KIND) function atanh(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be real or complex of any associated type', & '', & ' o The returned value will be of the same type and kind as the argument.', & '', & 'DESCRIPTION', & ' ATANH(3) computes the inverse hyperbolic tangent of X.', & '', & 'OPTIONS', & ' o X : The type shall be real or complex.', & '', & 'RESULT', & ' The return value has same type and kind as X. If X is complex, the imaginary', & ' part of the result is in radians and lies between', & '', & ' **-PI/2 <= aimag(atanh(x)) <= PI/2**', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atanh', & ' implicit none', & ' real, dimension(3) :: x = [ -1.0, 0.0, 1.0 ]', & '', & ' write (*,*) atanh(x)', & '', & ' end program demo_atanh', & '', & ' Results:', & '', & ' > -Infinity 0.0000000E+00 Infinity', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' Inverse function: TANH(3)', & '', & 'RESOURCES', & ' o Wikipedia:hyperbolic functions', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 atanh(3fortran)', & ''] shortname="atanh" call process() case('19','atomic_add') textblock=[character(len=256) :: & '', & 'atomic_add(3fortran) atomic_add(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_ADD(3) - [ATOMIC] Atomic ADD operation', & '', & '', & 'SYNOPSIS', & ' call atomic_add (atom, value [,stat] )', & '', & ' subroutine atomic_add(atom,value,stat)', & '', & ' integer(atomic_int_kind) :: atom[*]', & ' integer(atomic_int_kind),intent(in) :: value', & ' integer,intent(out),intent(out) :: stat', & '', & '', & 'CHARACTERISTICS', & ' o ATOM is a scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE is a scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT is a Scalar default-kind integer variable.', & '', & 'DESCRIPTION', & ' ATOMIC_ADD(3) atomically adds the value of VAR to the variable ATOM. When', & ' STAT is present and the invocation was successful, it is assigned the value', & ' 0. If it is present and the invocation has failed, it is assigned a positive', & ' value; in particular, for a coindexed ATOM, if the remote image has stopped,', & ' it is assigned the value of iso_fortran_env''s STAT_STOPPED_IMAGE and if the', & ' remote image has failed, the value STAT_FAILED_IMAGE.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_add', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*]', & ' call atomic_add (atom[1], this_image())', & ' end program demo_atomic_add', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_FETCH_ADD(3), ATOMIC_AND(3), ATOMIC_OR(3),', & ' ATOMIC_XOR(3) ISO_FORTRAN_ENV(3),', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_add(3fortran)', & ''] shortname="atomic_add" call process() case('20','atomic_and') textblock=[character(len=256) :: & '', & 'atomic_and(3fortran) atomic_and(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_AND(3) - [ATOMIC:BIT MANIPULATION] Atomic bitwise AND operation', & '', & '', & 'SYNOPSIS', & ' call atomic_and(atom, value [,stat])', & '', & ' subroutine atomic_and(atom,value,stat)', & '', & ' integer(atomic_int_kind) :: atom[*]', & ' integer(atomic_int_kind),intent(in) :: value', & ' integer,intent(out),intent(out) :: stat', & '', & '', & 'CHARACTERISTICS', & ' o ATOM is a scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE is a scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT is a Scalar default-kind integer variable.', & '', & 'DESCRIPTION', & ' ATOMIC_AND(3) atomically defines ATOM with the bitwise AND between the', & ' values of ATOM and VALUE. When STAT is present and the invocation was', & ' successful, it is assigned the value 0. If it is present and the invocation', & ' has failed, it is assigned a positive value; in particular, for a coindexed', & ' ATOM, if the remote image has stopped, it is assigned the value of', & ' iso_fortran_env''s stat_stopped_image and if the remote image has failed, the', & ' value stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_and', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*]', & ' call atomic_and(atom[1], int(b''10100011101''))', & ' end program demo_atomic_and', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_FETCH_AND(3), ATOMIC_DEFINE(3), ATOMIC_REF(3), ATOMIC_CAS(3),', & ' ISO_FORTRAN_ENV(3), ATOMIC_ADD(3), ATOMIC_OR(3), ATOMIC_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_and(3fortran)', & ''] shortname="atomic_and" call process() case('21','atomic_cas') textblock=[character(len=256) :: & '', & 'atomic_cas(3fortran) atomic_cas(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_CAS(3) - [ATOMIC] Atomic compare and swap', & '', & '', & 'SYNOPSIS', & ' call atomic_cas (atom, old, compare, new [,stat] )', & '', & ' subroutine atomic_cas (atom, old, compare, new, stat)', & '', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' ATOMIC_CAS(3) compares the variable ATOM with the value of COMPARE; if the', & ' value is the same, ATOM is set to the value of NEW. Additionally, OLD is set', & ' to the value of ATOM that was used for the comparison. When STAT is present', & ' and the invocation was successful, it is assigned the value 0. If it is', & ' present and the invocation has failed, it is assigned a positive value; in', & ' particular, for a coindexed ATOM, if the remote image has stopped, it is', & ' assigned the value of iso_fortran_env''s stat_stopped_image and if the remote', & ' image has failed, the value stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of either integer type with', & ' atomic_int_kind kind or logical type with atomic_logical_kind kind.', & '', & ' o OLD : Scalar of the same type and kind as ATOM.', & '', & ' o COMPARE : Scalar variable of the same type and kind as ATOM.', & '', & ' o NEW : Scalar variable of the same type as ATOM. If kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_cas', & ' use iso_fortran_env', & ' implicit none', & ' logical(atomic_logical_kind) :: atom[*], prev', & ' call atomic_cas(atom[1], prev, .false., .true.)', & ' end program demo_atomic_cas', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_REF(3), ISO_FORTRAN_ENV(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_cas(3fortran)', & ''] shortname="atomic_cas" call process() case('22','atomic_define') textblock=[character(len=256) :: & '', & 'atomic_define(3fortran) atomic_define(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_DEFINE(3) - [ATOMIC] Setting a variable atomically', & '', & '', & 'SYNOPSIS', & ' call atomic_define (atom, value [,stat] )', & '', & ' subroutine atomic_define(atom, value, stat)', & '', & ' TYPE(kind=atomic_KIND_kind) :: atom[*]', & ' TYPE(kind=KIND) :: value', & ' integer,intent(out),optional :: stat', & '', & '', & 'CHARACTERISTICS', & ' o ATOM : Scalar coarray or coindexed variable of either integer type with', & ' atomic_int_kind kind or logical type with atomic_logical_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'DESCRIPTION', & ' ATOMIC_DEFINE(3) defines the variable ATOM with the value VALUE atomically.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable to atomically assign the', & ' value VALUE to. kind.', & '', & ' o VALUE : value to assign to ATOM', & '', & ' o STAT : When STAT is present and the invocation was successful, it is', & ' assigned the value 0. If it is present and the invocation has failed, it', & ' is assigned a positive value; in particular, for a coindexed ATOM, if the', & ' remote image has stopped, it is assigned the value of iso_fortran_env''s', & ' stat_stopped_image and if the remote image has failed, the value', & ' stat_failed_image.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_define', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*]', & ' call atomic_define(atom[1], this_image())', & ' end program demo_atomic_define', & '', & '', & 'STANDARD', & ' Fortran 2008 ; with STAT, TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_REF(3), ATOMIC_CAS(3), ISO_FORTRAN_ENV(3), ATOMIC_ADD(3),', & ' ATOMIC_AND(3), ATOMIC_OR(3), ATOMIC_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_define(3fortran)', & ''] shortname="atomic_define" call process() case('23','atomic_fetch_add') textblock=[character(len=256) :: & '', & 'atomic_fetch_add(3fortran) atomic_fetch_add(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_FETCH_ADD(3) - [ATOMIC] Atomic ADD operation with prior fetch', & '', & '', & 'SYNOPSIS', & ' call atomic_fetch_add(atom, value, old [,stat] )', & '', & ' subroutine atomic_fetch_add(atom, value, old, stat)', & '', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' ATOMIC_FETCH_ADD(3) atomically stores the value of ATOM in OLD and adds the', & ' value of VAR to the variable ATOM. When STAT is present and the invocation', & ' was successful, it is assigned the value 0. If it is present and the', & ' invocation has failed, it is assigned a positive value; in particular, for a', & ' coindexed ATOM, if the remote image has stopped, it is assigned the value of', & ' iso_fortran_env''s stat_stopped_image and if the remote image has failed, the', & ' value stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind. atomic_logical_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o OLD : Scalar of the same type and kind as ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_fetch_add', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*], old', & ' call atomic_add(atom[1], this_image(), old)', & ' end program demo_atomic_fetch_add', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_ADD(3), ISO_FORTRAN_ENV(3),', & '', & ' ATOMIC_FETCH_AND(3), ATOMIC_FETCH_OR(3),', & '', & ' ATOMIC_FETCH_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_fetch_add(3fortran)', & ''] shortname="atomic_fetch_add" call process() case('24','atomic_fetch_and') textblock=[character(len=256) :: & '', & 'atomic_fetch_and(3fortran) atomic_fetch_and(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_FETCH_AND(3) - [ATOMIC:BIT MANIPULATION] Atomic bitwise AND operation', & ' with prior fetch', & '', & '', & 'SYNOPSIS', & ' call atomic_fetch_and(atom, value, old [,stat] )', & '', & ' subroutine atomic_fetch_and(atom, value, old, stat)', & '', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' ATOMIC_FETCH_AND(3) atomically stores the value of ATOM in OLD and defines', & ' ATOM with the bitwise AND between the values of ATOM and VALUE. When STAT', & ' is present and the invocation was successful, it is assigned the value 0. If', & ' it is present and the invocation has failed, it is assigned a positive', & ' value; in particular, for a coindexed ATOM, if the remote image has stopped,', & ' it is assigned the value of iso_fortran_env''s stat_stopped_image and if the', & ' remote image has failed, the value stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o OLD : Scalar of the same type and kind as ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_fetch_and', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*], old', & ' call atomic_fetch_and (atom[1], int(b''10100011101''), old)', & ' end program demo_atomic_fetch_and', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_AND(3), ISO_FORTRAN_ENV(3),', & '', & ' ATOMIC_FETCH_ADD(3), ATOMIC_FETCH_OR(3),', & '', & ' ATOMIC_FETCH_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_fetch_and(3fortran)', & ''] shortname="atomic_fetch_and" call process() case('25','atomic_fetch_or') textblock=[character(len=256) :: & '', & 'atomic_fetch_or(3fortran) atomic_fetch_or(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_FETCH_OR(3) - [ATOMIC:BIT MANIPULATION] Atomic bitwise OR operation', & ' with prior fetch', & '', & '', & 'SYNOPSIS', & ' call atomic_fetch_or(atom, value, old [,stat] )', & '', & ' subroutine atomic_fetch_or(atom, value, old, stat)', & '', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' ATOMIC_FETCH_OR(3) atomically stores the value of ATOM in OLD and defines', & ' ATOM with the bitwise OR between the values of ATOM and VALUE. When STAT is', & ' present and the invocation was successful, it is assigned the value 0. If it', & ' is present and the invocation has failed, it is assigned a positive value;', & ' in particular, for a coindexed ATOM, if the remote image has stopped, it is', & ' assigned the value of iso_fortran_env''s stat_stopped_image and if the remote', & ' image has failed, the value stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o OLD : Scalar of the same type and kind as ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_fetch_or', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*], old', & ' call atomic_fetch_or(atom[1], int(b''10100011101''), old)', & ' end program demo_atomic_fetch_or', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_OR(3), ISO_FORTRAN_ENV(3),', & '', & ' ATOMIC_FETCH_ADD(3), ATOMIC_FETCH_AND(3),', & '', & ' ATOMIC_FETCH_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_fetch_or(3fortran)', & ''] shortname="atomic_fetch_or" call process() case('26','atomic_fetch_xor') textblock=[character(len=256) :: & '', & 'atomic_fetch_xor(3fortran) atomic_fetch_xor(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_FETCH_XOR(3) - [ATOMIC:BIT MANIPULATION] Atomic bitwise XOR operation', & ' with prior fetch', & '', & '', & 'SYNOPSIS', & ' call atomic_fetch_xor (atom, value, old [,stat] )', & '', & ' subroutine atomic_fetch_xor (atom, value, old, stat)', & '', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' ATOMIC_FETCH_XOR(3) atomically stores the value of ATOM in OLD and defines', & ' ATOM with the bitwise XOR between the values of ATOM and VALUE. When STAT', & ' is present and the invocation was successful, it is assigned the value 0. If', & ' it is present and the invocation has failed, it is assigned a positive', & ' value; in particular, for a coindexed ATOM, if the remote image has stopped,', & ' it is assigned the value of iso_fortran_env''s stat_stopped_image and if the', & ' remote image has failed, the value stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o OLD : Scalar of the same type and kind as ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_fetch_xor', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*], old', & ' call atomic_fetch_xor (atom[1], int(b''10100011101''), old)', & ' end program demo_atomic_fetch_xor', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_XOR(3), ISO_FORTRAN_ENV(3),', & '', & ' ATOMIC_FETCH_ADD(3), ATOMIC_FETCH_AND(3),', & '', & ' ATOMIC_FETCH_OR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_fetch_xor(3fortran)', & ''] shortname="atomic_fetch_xor" call process() case('27','atomic_or') textblock=[character(len=256) :: & '', & 'atomic_or(3fortran) atomic_or(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_OR(3) - [ATOMIC:BIT MANIPULATION] Atomic bitwise OR operation', & '', & '', & 'SYNOPSIS', & ' call atomic_or(atom, value [,stat] )', & '', & ' subroutine atomic_or(atom,value,stat)', & '', & ' integer(atomic_int_kind) :: atom[*]', & ' integer(atomic_int_kind),intent(in) :: value', & ' integer,intent(out),intent(out) :: stat', & '', & '', & 'CHARACTERISTICS', & ' o ATOM is a scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE is a scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT is a Scalar default-kind integer variable.', & '', & 'DESCRIPTION', & ' ATOMIC_OR(3) atomically defines ATOM with the bitwise OR between the values', & ' of ATOM and VALUE. When STAT is present and the invocation was successful,', & ' it is assigned the value 0. If it is present and the invocation has failed,', & ' it is assigned a positive value; in particular, for a coindexed ATOM, if the', & ' remote image has stopped, it is assigned the value of iso_fortran_env''s', & ' stat_stopped_image and if the remote image has failed, the value', & ' stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_or', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*]', & ' call atomic_or(atom[1], int(b''10100011101''))', & ' end program demo_atomic_or', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_FETCH_OR(3),', & '', & ' ISO_FORTRAN_ENV(3), ATOMIC_ADD(3), ATOMIC_OR(3),', & '', & ' ATOMIC_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_or(3fortran)', & ''] shortname="atomic_or" call process() case('28','atomic_ref') textblock=[character(len=256) :: & '', & 'atomic_ref(3fortran) atomic_ref(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_REF(3) - [ATOMIC] Obtaining the value of a variable atomically', & '', & '', & 'SYNOPSIS', & ' call atomic_ref(value, atom [,stat] )', & '', & ' subroutine atomic_ref(value,atom,stat)', & '', & ' integer(atomic_int_kind),intent(in) :: value', & ' integer(atomic_int_kind) :: atom[*]', & ' integer,intent(out),intent(out) :: stat', & '', & '', & 'CHARACTERISTICS', & ' o ATOM is a scalar coarray or coindexed variable of either integer type', & ' with atomic_int_kind kind or logical type with atomic_logical_kind kind.', & '', & ' o VALUE is a scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT is a Scalar default-kind integer variable.', & '', & 'DESCRIPTION', & ' ATOMIC_REF(3) atomically assigns the value of the variable ATOM to VALUE.', & ' When STAT is present and the invocation was successful, it is assigned the', & ' value 0. If it is present and the invocation has failed, it is assigned a', & ' positive value; in particular, for a coindexed ATOM, if the remote image has', & ' stopped, it is assigned the value of iso_fortran_env''s STAT_STOPPED_IMAGE', & ' and if the remote image has failed, the value STAT_FAILED_IMAGE.', & '', & 'OPTIONS', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o ATOM : Scalar coarray or coindexed variable of either integer type with', & ' atomic_int_kind kind or logical type with atomic_logical_kind kind.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_ref', & ' use iso_fortran_env', & ' implicit none', & ' logical(atomic_logical_kind) :: atom[*]', & ' logical :: val', & ' call atomic_ref( val, atom[1] )', & ' if (val) then', & ' print *, "Obtained"', & ' endif', & ' end program demo_atomic_ref', & '', & '', & 'STANDARD', & ' Fortran 2008 ; with STAT, TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_CAS(3), ISO_FORTRAN_ENV(3),', & '', & ' ATOMIC_FETCH_ADD(3), ATOMIC_FETCH_AND(3),', & '', & ' ATOMIC_FETCH_OR(3), ATOMIC_FETCH_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_ref(3fortran)', & ''] shortname="atomic_ref" call process() case('29','atomic_xor') textblock=[character(len=256) :: & '', & 'atomic_xor(3fortran) atomic_xor(3fortran)', & '', & '', & '', & 'NAME', & ' ATOMIC_XOR(3) - [ATOMIC:BIT MANIPULATION] Atomic bitwise OR operation', & '', & '', & 'SYNOPSIS', & ' call atomic_xor(atom, value [,stat] )', & '', & ' subroutine atomic_xor(atom,value,stat)', & '', & ' integer(atomic_int_kind) :: atom[*]', & ' integer(atomic_int_kind),intent(in) :: value', & ' integer,intent(out),intent(out) :: stat', & '', & '', & 'CHARACTERISTICS', & ' o ATOM is a scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE is a scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT is a Scalar default-kind integer variable.', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' ATOMIC_XOR(3) atomically defines ATOM with the bitwise XOR between the', & ' values of ATOM and VALUE. When STAT is present and the invocation was', & ' successful, it is assigned the value 0. If it is present and the invocation', & ' has failed, it is assigned a positive value; in particular, for a coindexed', & ' ATOM, if the remote image has stopped, it is assigned the value of', & ' iso_fortran_env''s stat_stopped_image and if the remote image has failed, the', & ' value stat_failed_image.', & '', & 'OPTIONS', & ' o ATOM : Scalar coarray or coindexed variable of integer type with', & ' atomic_int_kind kind.', & '', & ' o VALUE : Scalar of the same type as ATOM. If the kind is different, the', & ' value is converted to the kind of ATOM.', & '', & ' o STAT : (optional) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_atomic_xor', & ' use iso_fortran_env', & ' implicit none', & ' integer(atomic_int_kind) :: atom[*]', & ' call atomic_xor(atom[1], int(b''10100011101''))', & ' end program demo_atomic_xor', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ATOMIC_DEFINE(3), ATOMIC_FETCH_XOR(3), ISO_FORTRAN_ENV(3), ATOMIC_ADD(3),', & ' ATOMIC_OR(3), ATOMIC_XOR(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 atomic_xor(3fortran)', & ''] shortname="atomic_xor" call process() case('30','backspace') textblock=[character(len=256) :: & '', & 'backspace(7fortran) backspace(7fortran)', & '', & '', & '', & 'NAME', & ' BACKSPACE(7f) - [FORTRAN:FILE_POSITIONING] - backspace one record on', & ' specified I/O unit', & '', & '', & 'SYNOPSIS', & ' BACKSPACE file-unit-number', & '', & ' BACKSPACE([UNIT=]unit-number][,IOMSG=iomsg][,IOSTAT=iostat][,ERR=label])', & '', & 'DESCRIPTION', & ' backspace(7f) positions the specified file back to the beginning of the', & ' current record or if already at the beginning of a record, back to the', & ' beginning of the previous record.', & '', & ' If the file is at its initial point, the position of the file is not', & ' changed.', & '', & ' It is most often used when a program has partially read a line and then', & ' wants to go back and reread the line using the information from the previous', & ' read(7f),', & '', & ' backspace(7f) is rarely used in new code as the subsequent addition of', & ' Fortran features such as non-advancing I/O and internal reads into a', & ' CHARACTER variable (which can be read from multiple times) are typically far', & ' more efficient and provide much of the same functionality when re-reading', & ' the current line.', & '', & ' Backspacing is very inefficient on many current platforms. Reading a file', & ' with stream-I/O and indexing relevant line positions to return to; or using', & ' direct-access files is far more efficient than backspacing through a file', & ' when moving back large numbers of lines on Linux and Unix platforms.', & '', & ' A unit open for direct access or unformatted access cannot be referenced by', & ' backspace(7f). backspace(7f) only works with formatted sequential files that', & ' may be repositioned. So it does not generally work with standard input from', & ' a terminal, pipes, and other formatted sequential file types that cannot be', & ' rewound or positioned.', & '', & ' Backspacing over records written using list-directed or namelist formatting', & ' is prohibited. It will usually work, but since the compiler is free to write', & ' list-directed or namelist output on a varying number of lines it is not', & ' supported, as it is not certain what data is on which line unless the', & ' program itself searches for particular strings.', & '', & ' Backspacing a file that is connected but does not exist is prohibited.', & '', & ' If a BACKSPACE statement causes the implicit writing of an endfile record,', & ' the file is positioned before the record that precedes the endfile record.', & '', & ' If the preceding record is an endfile record, the file is positioned before', & ' the endfile record.', & '', & 'OPTIONS', & ' UNIT : unit number of file to backspace one line on. A unit open for direct', & ' access or unformatted access cannot be referenced by a BACKSPACE. IOSTAT :', & ' a compiler-specific number that indicates an error occurred if non-zero.', & ' IOMSG : a message describing error IOSTAT if IOSTAT is not zero. ERR : a', & ' label number to jump to if an error occurs', & '', & 'EXAMPLE', & ' An example of a BACKSPACE statement is:', & '', & ' program demo_backspace', & ' implicit none', & ' character(len=256) :: line', & ' character(len=256) :: mssge', & ' integer :: i', & ' integer :: j', & ' integer :: ios', & ' integer,allocatable :: iarr(:)', & '', & ' ! create a basic sequential file', & ' open(10,file=''dem_backspace.txt'') ! open a file', & ' do i=1,30 ! write lines to it', & ' write(10,''(a,i3,*(i3))'') ''line '',i, (j,j=1,i)', & ' enddo', & '', & ' ! back up several lines', & ' do i=1,14', & ' backspace(10, iostat=ios,iomsg=mssge)', & ' if(ios.ne.0)then', & ' write(*,''(*(a))'') ''*dem_backspace* ERROR:'',mssge', & ' endif', & ' enddo', & ' read(10,''(a)'')line', & ' write(*,*)''back at a previous record !''', & '', & ' ! read line as a string', & ' write(*,''("string=",a)'')trim(line)', & '', & ' ! backspace so can read again as numbers', & ' backspace(10)', & ' ! read part of a line numerically to get size of array to read', & ' read(10,''(5x,i3)'')i', & ' allocate(iarr(i))', & '', & ' ! reread line just reading array', & ' backspace(10)', & ' read(10,''(8x,*(i3))'')iarr', & ' write(*,''(*(g0,1x))'')''size='',i,''array='',iarr', & '', & ' !! Note: writing a new line will truncate file', & ' !! to current record position', & '', & ' close(10,status=''delete'')', & '', & ' end program demo_backspace', & '', & ' Results:', & '', & ' > back at a previous record !', & ' > string=line 17 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', & ' > size= 17 array= 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 backspace(7fortran)', & ''] shortname="backspace" call process() case('31','bessel_j0') textblock=[character(len=256) :: & '', & 'bessel_j0(3fortran) bessel_j0(3fortran)', & '', & '', & '', & 'NAME', & ' BESSEL_J0(3) - [MATHEMATICS] Bessel function of the first kind of order 0', & '', & '', & 'SYNOPSIS', & ' result = bessel_j0(x)', & '', & ' elemental real(kind=KIND) function bessel_j0(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o KIND may be any KIND supported by the real type.', & '', & ' o The result is the same type and kind as X.', & '', & 'DESCRIPTION', & ' BESSEL_J0(3) computes the Bessel function of the first kind of order 0 of X.', & '', & 'OPTIONS', & ' o X : The value to operate on.', & '', & 'RESULT', & ' the Bessel function of the first kind of order 0 of X. The result lies in', & ' the range -0.4027 <= BESSEL(0,X) <= 1.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bessel_j0', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x', & ' x = 0.0_real64', & ' x = bessel_j0(x)', & ' write(*,*)x', & ' end program demo_bessel_j0', & '', & ' Results:', & '', & ' 1.0000000000000000', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BESSEL_J1(3), BESSEL_JN(3), BESSEL_Y0(3), BESSEL_Y1(3), BESSEL_YN(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 bessel_j0(3fortran)', & ''] shortname="bessel_j0" call process() case('32','bessel_j1') textblock=[character(len=256) :: & '', & 'bessel_j1(3fortran) bessel_j1(3fortran)', & '', & '', & '', & 'NAME', & ' BESSEL_J1(3) - [MATHEMATICS] Bessel function of the first kind of order 1', & '', & '', & 'SYNOPSIS', & ' result = bessel_j1(x)', & '', & ' elemental real(kind=KIND) function bessel_j1(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o KIND may be any supported real KIND.', & '', & ' o the result is of the same type and kind as X', & '', & 'DESCRIPTION', & ' BESSEL_J1(3) computes the Bessel function of the first kind of order 1 of X.', & '', & 'OPTIONS', & ' o X : The type shall be real.', & '', & 'RESULT', & ' The return value is of type real and lies in the range -0.5818 <=', & ' BESSEL(0,X) <= 0.5818 . It has the same kind as X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bessel_j1', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 1.0_real64', & ' x = bessel_j1(x)', & ' write(*,*)x', & ' end program demo_bessel_j1', & '', & ' Results:', & '', & ' 0.44005058574493350', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BESSEL_J0(3), BESSEL_JN(3), BESSEL_Y0(3), BESSEL_Y1(3), BESSEL_YN(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 bessel_j1(3fortran)', & ''] shortname="bessel_j1" call process() case('33','bessel_jn') textblock=[character(len=256) :: & '', & 'bessel_jn(3fortran) bessel_jn(3fortran)', & '', & '', & '', & 'NAME', & ' BESSEL_JN(3) - [MATHEMATICS] Bessel function of the first kind', & '', & '', & 'SYNOPSIS', & ' result = bessel_jn(n, x)', & '', & ' elemental real(kind=KIND) function bessel_jn(n,x)', & '', & ' integer(kind=**),intent(in) :: n', & ' real(kind=KIND),intent(in) :: x', & '', & '', & ' o KIND may be any valid value for type real', & '', & ' o X is real', & '', & ' o The return value has the same type and kind as X.', & '', & ' result = bessel_jn(n1, n2, x)', & '', & ' real(kind=KIND) function bessel_jn(n1, n2, ,x)', & '', & ' integer(kind=**),intent(in) :: n1', & ' integer(kind=**),intent(in) :: n2', & ' real(kind=KIND),intent(in) :: x', & '', & '', & ' o N1 is integer', & '', & ' o N2 is integer', & '', & ' o X is real', & '', & ' o The return value has the same type and kind as X.', & '', & 'DESCRIPTION', & ' BESSEL_JN( N, X ) computes the Bessel function of the first kind of order N', & ' of X.', & '', & ' BESSEL_JN(N1, N2, X) returns an array with the Bessel function|Bessel', & ' functions of the first kind of the orders N1 to N2.', & '', & 'OPTIONS', & ' o N : a non-negative scalar integer..', & '', & ' o N1 : a non-negative scalar integer.', & '', & ' o N2 : a non-negative scalar integer.', & '', & ' o X : Shall be a scalar for BESSEL_JN(N,X) or an array For BESSEL_JN(N1,', & ' N2, X).', & '', & 'RESULT', & ' The result value of BESSEL_JN (N, X) is a processor-dependent approximation', & ' to the Bessel function of the first kind and order N of X.', & '', & ' The result of BESSEL_JN (N1, N2, X) is a rank-one array with extent MAX', & ' (N2-N1+1, 0). Element i of the result value of BESSEL_JN (N1, N2, X) is a', & ' processor-dependent approximation to the Bessel function of the first kind', & ' and order N1+i-1 of X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bessel_jn', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 1.0_real64', & ' x = bessel_jn(5,x)', & ' write(*,*)x', & ' end program demo_bessel_jn', & '', & ' Results:', & '', & ' 2.4975773021123450E-004', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BESSEL_J0(3), BESSEL_J1(3), BESSEL_Y0(3), BESSEL_Y1(3), BESSEL_YN(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 bessel_jn(3fortran)', & ''] shortname="bessel_jn" call process() case('34','bessel_y0') textblock=[character(len=256) :: & '', & 'bessel_y0(3fortran) bessel_y0(3fortran)', & '', & '', & '', & 'NAME', & ' BESSEL_Y0(3) - [MATHEMATICS] Bessel function of the second kind of order 0', & '', & '', & 'SYNOPSIS', & ' result = bessel_y0(x)', & '', & ' elemental real(kind=KIND) function bessel_y0(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o KIND may be any supported real KIND.', & '', & ' o the result characteristics (type, kind) are the same as X', & '', & 'DESCRIPTION', & ' BESSEL_Y0(3) computes the Bessel function of the second kind of order 0 of', & ' X.', & '', & 'OPTIONS', & ' o X : The type shall be real. Its value shall be greater than zero.', & '', & 'RESULT', & ' The return value is of type real. It has the same kind as X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bessel_y0', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 0.0_real64', & ' x = bessel_y0(x)', & ' write(*,*)x', & ' end program demo_bessel_y0', & '', & ' Results:', & '', & ' -Infinity', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BESSEL_J0(3), BESSEL_J1(3), BESSEL_JN(3), BESSEL_Y1(3), BESSEL_YN(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 bessel_y0(3fortran)', & ''] shortname="bessel_y0" call process() case('35','bessel_y1') textblock=[character(len=256) :: & '', & 'bessel_y1(3fortran) bessel_y1(3fortran)', & '', & '', & '', & 'NAME', & ' BESSEL_Y1(3) - [MATHEMATICS] Bessel function of the second kind of order 1', & '', & '', & 'SYNOPSIS', & ' result = bessel_y1(x)', & '', & ' elemental real(kind=KIND) function bessel_y1(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o KIND may be any supported real KIND.', & '', & ' o the characteristics (type, kind) of the result are the same as X', & '', & 'DESCRIPTION', & ' BESSEL_Y1(3) computes the Bessel function of the second kind of order 1 of', & ' X.', & '', & 'OPTIONS', & ' o X : The type shall be real. Its value shall be greater than zero.', & '', & 'RESULT', & ' The return value is real. It has the same kind as X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bessel_y1', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 1.0_real64', & ' write(*,*)x, bessel_y1(x)', & ' end program demo_bessel_y1', & '', & ' Results:', & '', & ' > 1.00000000000000 -0.781212821300289', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BESSEL_J0(3), BESSEL_J1(3), BESSEL_JN(3), BESSEL_Y0(3), BESSEL_YN(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 bessel_y1(3fortran)', & ''] shortname="bessel_y1" call process() case('36','bessel_yn') textblock=[character(len=256) :: & '', & 'bessel_yn(3fortran) bessel_yn(3fortran)', & '', & '', & '', & 'NAME', & ' BESSEL_YN(3) - [MATHEMATICS] Bessel function of the second kind', & '', & '', & 'SYNOPSIS', & ' result = bessel_yn(n, x)', & '', & ' elemental real(kind=KIND) function bessel_yn(n,x)', & '', & ' integer(kind=**),intent(in) :: n', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o N is integer', & '', & ' o X is real', & '', & ' o The return value has the same type and kind as X.', & '', & ' result = bessel_yn(n1, n2, x)', & '', & ' real(kind=KIND) function bessel_yn(n1, n2, ,x)', & '', & ' integer(kind=**),intent(in) :: n1', & ' integer(kind=**),intent(in) :: n2', & ' real(kind=KIND),intent(in) :: x', & '', & '', & ' o N1 is integer', & '', & ' o N2 is integer', & '', & ' o X is real', & '', & ' o The return value has the same type and kind as X.', & '', & 'DESCRIPTION', & ' BESSEL_YN(N, X) computes the Bessel function of the second kind of order N', & ' of X.', & '', & ' BESSEL_YN(N1, N2, X) returns an array with the Bessel function|Bessel', & ' functions of the first kind of the orders N1 to N2.', & '', & 'OPTIONS', & ' o N : Shall be a scalar or an array of type integer and non-negative.', & '', & ' o N1 : Shall be a non-negative scalar of type integer and non-negative.', & '', & ' o N2 : Shall be a non-negative scalar of type integer and non-negative.', & '', & ' o X : A real non-negative value. Note BESSEL_YN(N1, N2, X) is not', & ' elemental, in which case it must be a scalar.', & '', & 'RESULT', & ' The result value of BESSEL_YN (N, X) is a processor-dependent approximation', & ' to the Bessel function of the second kind and order N of X.', & '', & ' The result of BESSEL_YN (N1, N2, X) is a rank-one array with extent MAX', & ' (N2-N1+1, 0). Element i of the result value of BESSEL_YN (N1, N2, X) is a', & ' processor-dependent approximation to the Bessel function of the second kind', & ' and order N1+i-1 of X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bessel_yn', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 1.0_real64', & ' write(*,*) x,bessel_yn(5,x)', & ' end program demo_bessel_yn', & '', & ' Results:', & '', & ' 1.0000000000000000 -260.40586662581222', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BESSEL_J0(3), BESSEL_J1(3), BESSEL_JN(3), BESSEL_Y0(3), BESSEL_Y1(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 bessel_yn(3fortran)', & ''] shortname="bessel_yn" call process() case('37','bge') textblock=[character(len=256) :: & '', & 'bge(3fortran) bge(3fortran)', & '', & '', & '', & 'NAME', & ' BGE(3) - [BIT:COMPARE] Bitwise greater than or equal to', & '', & '', & 'SYNOPSIS', & ' result = bge(i,j)', & '', & ' elemental logical function bge(i, j)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in) :: j', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o the integer kind of I and J may not necessarily be the same. In addition,', & ' values may be a BOZ constant with a value valid for the integer kind', & ' available with the most bits on the current platform.', & '', & ' o The return value is of type default logical.', & '', & 'DESCRIPTION', & ' BGE(3) Determines whether one integer is bitwise greater than or equal to', & ' another.', & '', & ' The bit-level representation of a value is platform dependent. The endian-', & ' ness of a system and whether the system uses a "two''s complement"', & ' representation of signs can affect the results, for example.', & '', & ' A BOZ constant (Binary, Octal, Hexadecimal) does not have a kind or type of', & ' its own, so be aware it is subject to truncation when transferred to an', & ' integer type. The most bits the constant may contain is limited by the most', & ' bits representable by any integer kind supported by the compilation.', & '', & ' Bit Sequence Comparison', & '', & ' When bit sequences of unequal length are compared, the shorter sequence is', & ' padded with zero bits on the left to the same length as the longer sequence', & ' (up to the largest number of bits any available integer kind supports).', & '', & ' Bit sequences are compared from left to right, one bit at a time, until', & ' unequal bits are found or until all bits have been compared and found to be', & ' equal.', & '', & ' The bits are always evaluated in this order, not necessarily from MSB to LSB', & ' (most significant bit to least significant bit).', & '', & ' If unequal bits are found the sequence with zero in the unequal position is', & ' considered to be less than the sequence with one in the unequal position.', & '', & 'OPTIONS', & ' o I : The value to test if >= J based on the bit representation of the', & ' values.', & '', & ' o J : The value to test I against.', & '', & 'RESULT', & ' Returns .true. if I is bit-wise greater than J and .false. otherwise.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bge', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: i', & ' integer(kind=int8) :: byte', & ' integer(kind=int8),allocatable :: arr1(:), arr2(:)', & '', & ' ! BASIC USAGE', & ' write(*,*)''bge(-127,127)='',bge( -127, 127 )', & ' ! on (very common) "two''s complement" machines that are', & ' ! little-endian -127 will be greater than 127', & '', & ' ! BOZ constants', & ' ! BOZ constants are subject to truncation, so make sure', & ' ! your values are valid for the integer kind being compared to', & ' write(*,*)''bge(b"0001",2)='',bge( b"1", 2)', & '', & ' ! ELEMENTAL', & ' ! an array and scalar', & ' write(*, *)''compare array of values [-128, -0, +0, 127] to 127''', & ' write(*, *)bge(int([-128, -0, +0, 127], kind=int8), 127_int8)', & '', & ' ! two arrays', & ' write(*, *)''compare two arrays''', & ' arr1=int( [ -127, -0, +0, 127], kind=int8 )', & ' arr2=int( [ 127, 0, 0, -127], kind=int8 )', & ' write(*,*)''arr1='',arr1', & ' write(*,*)''arr2='',arr2', & ' write(*, *)''bge(arr1,arr2)='',bge( arr1, arr2 )', & '', & ' ! SHOW TESTS AND BITS', & ' ! actually looking at the bit patterns should clarify what affect', & ' ! signs have ...', & ' write(*,*)''Compare some one-byte values to 64.''', & ' write(*,*)''Notice that the values are tested as bits not as integers''', & ' write(*,*)''so the results are as if values are unsigned integers.''', & ' do i=-128,127,32', & ' byte=i', & ' write(*,''(sp,i0.4,*(1x,1l,1x,b0.8))'')i,bge(byte,64_int8),byte', & ' enddo', & '', & ' ! SIGNED ZERO', & ' ! are +0 and -0 the same on your platform? When comparing at the', & ' ! bit level this is important', & ' write(*,''("plus zero=",b0)'') +0', & ' write(*,''("minus zero=",b0)'') -0', & '', & ' end program demo_bge', & '', & ' Results:', & '', & ' How an integer value is represented at the bit level can vary. These are', & ' just the values expected on Today''s most common platforms ...', & '', & ' > bge(-127,127)= T', & ' > bge(b"0001",2)= F', & ' > compare array of values [-128, -0, +0, 127] to 127', & ' > T F F T', & ' > compare two arrays', & ' > arr1= -127 0 0 127', & ' > arr2= 127 0 0 -127', & ' > bge(arr1,arr2)= T T T F', & ' > Compare some one-byte values to 64.', & ' > Notice that the values are tested as bits not as integers', & ' > so the results are as if values are unsigned integers.', & ' > -0128 T 10000000', & ' > -0096 T 10100000', & ' > -0064 T 11000000', & ' > -0032 T 11100000', & ' > +0000 F 00000000', & ' > +0032 F 00100000', & ' > +0064 T 01000000', & ' > +0096 T 01100000', & ' > plus zero=0', & ' > minus zero=0', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BGT(3), BLE(3), BLT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 bge(3fortran)', & ''] shortname="bge" call process() case('38','bgt') textblock=[character(len=256) :: & '', & 'bgt(3fortran) bgt(3fortran)', & '', & '', & '', & 'NAME', & ' BGT(3) - [BIT:COMPARE] Bitwise greater than', & '', & '', & 'SYNOPSIS', & ' result = bgt(i, j)', & '', & ' elemental logical function bgt(i, j)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in) :: j', & '', & '', & 'CHARACTERISTICS', & ' o I is an integer or a boz-literal-constant.', & '', & ' o J is an integer or a boz-literal-constant.', & '', & ' o a kind designated as ** may be any supported kind for the type The', & ' integer kind of I and J may not necessarily be the same. kind. In', & ' addition, values may be a BOZ constant with a value valid for the integer', & ' kind available with the most bits on the current platform.', & '', & ' o The return value is of type logical and of the default kind.', & '', & 'DESCRIPTION', & ' BGT determines whether an integer is bitwise greater than another. Bit-', & ' level representations of values are platform-dependent.', & '', & 'OPTIONS', & ' o I : reference value to compare against', & '', & ' o J : value to compare to I', & '', & 'RESULT', & ' The return value is of type logical and of the default kind. The result is', & ' true if the sequence of bits represented by i is greater than the sequence', & ' of bits represented by j, otherwise the result is false.', & '', & ' Bits are compared from right to left.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bgt', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: i', & ' integer(kind=int8) :: byte', & ' ! Compare some one-byte values to 64.', & ' ! Notice that the values are tested as bits not as integers', & ' ! so sign bits in the integer are treated just like any other', & ' write(*,''(a)'') ''we will compare other values to 64''', & ' i=64', & ' byte=i', & ' write(*,''(sp,i0.4,*(1x,1l,1x,b0.8))'')i,bgt(byte,64_int8),byte', & '', & ' write(*,''(a)'') "comparing at the bit level, not as whole numbers."', & ' write(*,''(a)'') "so pay particular attention to the negative"', & ' write(*,''(a)'') "values on this two''s complement platform ..."', & ' do i=-128,127,32', & ' byte=i', & ' write(*,''(sp,i0.4,*(1x,1l,1x,b0.8))'')i,bgt(byte,64_int8),byte', & ' enddo', & '', & ' ! see the BGE() description for an extended description', & ' ! of related information', & '', & ' end program demo_bgt', & '', & ' Results:', & '', & ' > we will compare other values to 64', & ' > +0064 F 01000000', & ' > comparing at the bit level, not as whole numbers.', & ' > so pay particular attention to the negative', & ' > values on this two''s complement platform ...', & ' > -0128 T 10000000', & ' > -0096 T 10100000', & ' > -0064 T 11000000', & ' > -0032 T 11100000', & ' > +0000 F 00000000', & ' > +0032 F 00100000', & ' > +0064 F 01000000', & ' > +0096 T 01100000', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BGE(3), BLE(3), BLT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 bgt(3fortran)', & ''] shortname="bgt" call process() case('39','bit_size') textblock=[character(len=256) :: & '', & 'bit_size(3fortran) bit_size(3fortran)', & '', & '', & '', & 'NAME', & ' BIT_SIZE(3) - [BIT:INQUIRY] Bit size inquiry function', & '', & '', & 'SYNOPSIS', & ' result = bit_size(i)', & '', & ' integer(kind=KIND) function bit_size(i)', & '', & ' integer(kind=KIND),intent(in) :: i(..)', & '', & '', & 'CHARACTERISTICS', & ' o I shall be of type integer. It may be a scalar or an array.', & '', & ' o the value of KIND is any valid value for an integer kind parameter on the', & ' processor.', & '', & ' o the return value is a scalar of the same kind as the input value.', & '', & 'DESCRIPTION', & ' BIT_SIZE(3) returns the number of bits (integer precision plus sign bit)', & ' represented by the type of the integer I.', & '', & 'OPTIONS', & ' o I : An integer value of any kind whose size in bits is to be determined.', & ' Because only the type of the argument is examined, the argument need not', & ' be defined; I can be a scalar or an array, but a scalar representing just', & ' a single element is always returned.', & '', & 'RESULT', & ' The number of bits used to represent a value of the type and kind of i. The', & ' result is a integer scalar of the same kind as i.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_bit_size', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' use,intrinsic :: iso_fortran_env, only : integer_kinds', & ' implicit none', & ' character(len=*),parameter :: fmt=&', & ' & ''(a,": bit size is ",i3," which is kind=",i3," on this platform")''', & '', & ' ! default integer bit size on this platform', & ' write(*,fmt) "default", bit_size(0), kind(0)', & '', & ' write(*,fmt) "int8 ", bit_size(0_int8), kind(0_int8)', & ' write(*,fmt) "int16 ", bit_size(0_int16), kind(0_int16)', & ' write(*,fmt) "int32 ", bit_size(0_int32), kind(0_int32)', & ' write(*,fmt) "int64 ", bit_size(0_int64), kind(0_int64)', & '', & ' write(*,''(a,*(i0:,", "))'') "The available kinds are ",integer_kinds', & '', & ' end program demo_bit_size', & '', & ' Typical Results:', & '', & ' default: bit size is 32 which is kind= 4 on this platform', & ' int8 : bit size is 8 which is kind= 1 on this platform', & ' int16 : bit size is 16 which is kind= 2 on this platform', & ' int32 : bit size is 32 which is kind= 4 on this platform', & ' int64 : bit size is 64 which is kind= 8 on this platform', & ' The available kinds are 1, 2, 4, 8, 16', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 bit_size(3fortran)', & ''] shortname="bit_size" call process() case('40','ble') textblock=[character(len=256) :: & '', & 'ble(3fortran) ble(3fortran)', & '', & '', & '', & 'NAME', & ' BLE(3) - [BIT:COMPARE] Bitwise less than or equal to', & '', & '', & 'SYNOPSIS', & ' result = ble(i,j)', & '', & ' elemental logical function ble(i, j)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in) :: j', & '', & '', & 'CHARACTERISTICS', & ' o I and J may be of any supported integer kind, not necessarily the same.', & ' An exception is that values may be a BOZ constant with a value valid for', & ' the integer kind available with the most bits on the current platform.', & '', & ' o the returned value is a logical scalar of default kind', & '', & 'DESCRIPTION', & ' BLE(3) determines whether an integer is bitwise less than or equal to', & ' another, assuming any shorter value is padded on the left with zeros to the', & ' length of the longer value.', & '', & 'OPTIONS', & ' o I : the value to compare J to', & '', & ' o J : the value to be tested for being less than or equal to I', & '', & 'RESULT', & ' The return value is .true. if any bit in J is less than any bit in I', & ' starting with the rightmost bit and continuing tests leftward.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ble', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: i', & ' integer(kind=int8) :: byte', & ' ! Compare some one-byte values to 64.', & ' ! Notice that the values are tested as bits not as integers', & ' ! so sign bits in the integer are treated just like any other', & ' do i=-128,127,32', & ' byte=i', & ' write(*,''(sp,i0.4,*(1x,1l,1x,b0.8))'')i,ble(byte,64_int8),byte', & ' write(*,''(sp,i0.4,*(4x,b0.8))'')64_int8,64_int8', & ' enddo', & '', & ' ! see the BGE() description for an extended description', & ' ! of related information', & '', & ' end program demo_ble', & '', & ' Results:', & '', & ' -0128 F 10000000', & ' +0064 01000000', & ' -0096 F 10100000', & ' +0064 01000000', & ' -0064 F 11000000', & ' +0064 01000000', & ' -0032 F 11100000', & ' +0064 01000000', & ' +0000 T 00000000', & ' +0064 01000000', & ' +0032 T 00100000', & ' +0064 01000000', & ' +0064 T 01000000', & ' +0064 01000000', & ' +0096 F 01100000', & ' +0064 01000000', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BGE(3), BGT(3), BLT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ble(3fortran)', & ''] shortname="ble" call process() case('41','blt') textblock=[character(len=256) :: & '', & 'blt(3fortran) blt(3fortran)', & '', & '', & '', & 'NAME', & ' BLT(3) - [BIT:COMPARE] Bitwise less than', & '', & '', & 'SYNOPSIS', & ' result = blt(i,j)', & '', & ' elemental logical function blt(i, j)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in) :: j', & '', & '', & 'CHARACTERISTICS', & ' o I is an integer of any kind or a BOZ-literal-constant', & '', & ' o J is an integer of any kind or a BOZ-literal-constant, not necessarily', & ' the same as I.', & '', & ' o the result is of default logical kind', & '', & ' BOZ constants must have a value valid for the integer kind available with', & ' the most bits on the current platform.', & '', & 'DESCRIPTION', & ' BLT(3) determines whether an integer is bitwise less than another.', & '', & 'OPTIONS', & ' o I : Shall be of integer type or a BOZ literal constant.', & '', & ' o J : Shall be of integer type or a BOZ constant.', & '', & 'RESULT', & ' The return value is of type logical and of the default kind.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_blt', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: i', & ' integer(kind=int8) :: byte', & ' ! Compare some one-byte values to 64.', & ' ! Notice that the values are tested as bits not as integers', & ' ! so sign bits in the integer are treated just like any other', & ' do i=-128,127,32', & ' byte=i', & ' write(*,''(sp,i0.4,*(1x,1l,1x,b0.8))'')i,blt(byte,64_int8),byte', & ' enddo', & ' ! BOZ literals', & ' write(*,*)blt(z''1000'', z''101011010'')', & ' ! see the BGE() description for an extended description', & ' ! of related information', & '', & ' end program demo_blt', & '', & ' Results:', & '', & ' > -0128 F 10000000', & ' > -0096 F 10100000', & ' > -0064 F 11000000', & ' > -0032 F 11100000', & ' > +0000 T 00000000', & ' > +0032 T 00100000', & ' > +0064 F 01000000', & ' > +0096 F 01100000', & ' > T', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BGE(3), BGT(3), BLE(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 blt(3fortran)', & ''] shortname="blt" call process() case('42','btest') textblock=[character(len=256) :: & '', & 'btest(3fortran) btest(3fortran)', & '', & '', & '', & 'NAME', & ' BTEST(3) - [BIT:INQUIRY] Tests a bit of an integer value.', & '', & '', & 'SYNOPSIS', & ' result = btest(i,pos)', & '', & ' elemental logical function btest(i,pos)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in) :: pos', & '', & '', & 'CHARACTERISTICS', & ' o I is an integer of any kind', & '', & ' o POS is a integer of any kind', & '', & ' o the result is a default logical', & '', & 'DESCRIPTION', & ' BTEST(3) returns logical .true. if the bit at POS in I is set to 1.', & ' Position zero is the right-most bit. Bit position increases from right to', & ' left up to BITSIZE(I)-1.', & '', & 'OPTIONS', & ' o I : The integer containing the bit to be tested', & '', & ' o POS : The position of the bit to query. it must be a valid position for', & ' the value I; ie. 0 <= POS <= BIT_SIZE(I).', & '', & 'RESULT', & ' The result is a logical that has the value .true. if bit position POS of I', & ' has the value 1 and the value .false. if bit POS of I has the value 0.', & '', & ' Positions of bits in the sequence are numbered from right to left, with the', & ' position of the rightmost bit being zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_btest', & ' implicit none', & ' integer :: i, j, pos, a(2,2)', & ' logical :: bool', & ' character(len=*),parameter :: g=''(*(g0))''', & '', & ' i = 32768 + 1024 + 64', & ' write(*,''(a,i0,"=>",b32.32,/)'')''Looking at the integer: '',i', & '', & ' ! looking one bit at a time from LOW BIT TO HIGH BIT', & ' write(*,g)''from bit 0 to bit '',bit_size(i),''==>''', & ' do pos=0,bit_size(i)-1', & ' bool = btest(i, pos)', & ' write(*,''(l1)'',advance=''no'')bool', & ' enddo', & ' write(*,*)', & '', & ' ! a binary format the hard way.', & ' ! Note going from bit_size(i) to zero.', & ' write(*,*)', & ' write(*,g)''so for '',i,'' with a bit size of '',bit_size(i)', & ' write(*,''(b32.32)'')i', & ' write(*,g)merge(''^'',''_'',[(btest(i,j),j=bit_size(i)-1,0,-1)])', & ' write(*,*)', & ' write(*,g)''and for '',-i,'' with a bit size of '',bit_size(i)', & ' write(*,''(b32.32)'')-i', & ' write(*,g)merge(''^'',''_'',[(btest(-i,j),j=bit_size(i)-1,0,-1)])', & '', & ' ! elemental:', & ' !', & ' a(1,:)=[ 1, 2 ]', & ' a(2,:)=[ 3, 4 ]', & ' write(*,*)', & ' write(*,''(a,/,*(i2,1x,i2,/))'')''given the array a ...'',a', & ' ! the second bit of all the values in a', & ' write(*,''(a,/,*(l2,1x,l2,/))'')''the value of btest (a, 2)'',btest(a,2)', & ' ! bits 1,2,3,4 of the value 2', & ' write(*,''(a,/,*(l2,1x,l2,/))'')''the value of btest (2, a)'',btest(2,a)', & ' end program demo_btest', & '', & ' Results:', & '', & ' > Looking at the integer: 33856=>11111111111111110111101111000000', & ' >', & ' > 00000000000000001000010001000000', & ' > 11111111111111110111101111000000', & ' > 1000010001000000', & ' > 11111111111111110111101111000000', & ' > from bit 0 to bit 32==>', & ' > FFFFFFTFFFTFFFFTFFFFFFFFFFFFFFFF', & ' >', & ' > so for 33856 with a bit size of 32', & ' > 00000000000000001000010001000000', & ' > ________________^____^___^______', & ' >', & ' > and for -33856 with a bit size of 32', & ' > 11111111111111110111101111000000', & ' > ^^^^^^^^^^^^^^^^_^^^^_^^^^______', & ' >', & ' > given the array a ...', & ' > 1 3', & ' > 2 4', & ' >', & ' > the value of btest (a, 2)', & ' > F F', & ' > F T', & ' >', & ' > the value of btest (2, a)', & ' > T F', & ' > F F', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' IAND(3), IBCLR(3), IBITS(3), IBSET(3), IEOR(3), IOR(3), MVBITS(3), NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 btest(3fortran)', & ''] shortname="btest" call process() case('43','c_associated') textblock=[character(len=256) :: & '', & 'c_associated(3fortran) c_associated(3fortran)', & '', & '', & '', & 'NAME', & ' C_ASSOCIATED(3) - [ISO_C_BINDING] Status of a C pointer', & '', & '', & 'SYNOPSIS', & ' result = c_associated(c_prt_1, [c_ptr_2] )', & '', & ' logical function c_associated(c_prt_1, cptr_2)', & '', & ' TYPE,intent(in) ::c_ptr_1', & ' TYPE,intent(in),optional ::c_ptr_2', & '', & '', & 'CHARACTERISTICS', & ' o C_PTR_1 is a scalar of the type c_ptr or c_funptr.', & '', & ' o C_PTR_2 is a scalar of the same type as c_ptr_1.', & '', & ' o The return value is of type logical', & '', & 'DESCRIPTION', & ' C_ASSOCIATED(3) determines the status of the C pointer c_ptr_1 or if c_ptr_1', & ' is associated with the target c_ptr_2.', & '', & 'OPTIONS', & ' o C_PTR_1 : C pointer to test for being a C NULL pointer, or to test if', & ' pointing to the same association as C_PTR_2 when present.', & '', & ' o C_PTR_2 : C pointer to test for shared association with C_PTR_1', & '', & 'RESULT', & ' The return value is of type logical; it is .false. if either c_ptr_1 is a C', & ' NULL pointer or if c_ptr1 and c_ptr_2 point to different addresses.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_c_associated', & '', & ' contains', & '', & ' subroutine association_test(a,b)', & ' use iso_c_binding, only: c_associated, c_loc, c_ptr', & ' implicit none', & ' real, pointer :: a', & ' type(c_ptr) :: b', & ' if(c_associated(b, c_loc(a))) &', & ' stop ''b and a do not point to same target''', & ' end subroutine association_test', & '', & ' end program demo_c_associated', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' C_LOC(3), C_FUNLOC(3), ISO_C_BINDING(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 c_associated(3fortran)', & ''] shortname="c_associated" call process() case('44','ceiling') textblock=[character(len=256) :: & '', & 'ceiling(3fortran) ceiling(3fortran)', & '', & '', & '', & 'NAME', & ' CEILING(3) - [NUMERIC] Integer ceiling function', & '', & '', & 'SYNOPSIS', & ' result = ceiling(a [,kind])', & '', & ' elemental integer(KIND) function ceiling(a,KIND)', & '', & ' real(kind=**),intent(in) :: a', & ' integer,intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o ** a is of type real', & '', & ' o KIND shall be a scalar integer constant expression. It specifies the kind', & ' of the result if present.', & '', & ' o the result is integer. It is default kind if KIND is not specified', & '', & 'DESCRIPTION', & ' CEILING(3) returns the least integer greater than or equal to A.', & '', & ' On the number line -n <-- 0 -> +n the value returned is always at or to the', & ' right of the input value.', & '', & 'OPTIONS', & ' o A : A real value to produce a ceiling for.', & '', & ' o KIND : indicates the kind parameter of the result.', & '', & 'RESULT', & ' The result will be the integer value equal to A or the least integer greater', & ' than A if the input value is not equal to a whole number.', & '', & ' If A is equal to a whole number, the returned value is INT(A).', & '', & ' The result is undefined if it cannot be represented in the specified integer', & ' type.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ceiling', & ' implicit none', & ' ! just a convenient format for a list of integers', & ' character(len=*),parameter :: ints=''(*(" > ",5(i0:,",",1x),/))''', & ' real :: x', & ' real :: y', & ' ! basic usage', & ' x = 63.29', & ' y = -63.59', & ' print ints, ceiling(x)', & ' print ints, ceiling(y)', & ' ! note the result was the next integer larger to the right', & '', & ' ! real values equal to whole numbers', & ' x = 63.0', & ' y = -63.0', & ' print ints, ceiling(x)', & ' print ints, ceiling(y)', & '', & ' ! elemental (so an array argument is allowed)', & ' print ints , &', & ' & ceiling([ &', & ' & -2.7, -2.5, -2.2, -2.0, -1.5, &', & ' & -1.0, -0.5, 0.0, +0.5, +1.0, &', & ' & +1.5, +2.0, +2.2, +2.5, +2.7 ])', & '', & ' end program demo_ceiling', & '', & ' Results:', & '', & ' > 64', & ' > -63', & ' > 63', & ' > -63', & ' > -2, -2, -2, -2, -1,', & ' > -1, 0, 0, 1, 1,', & ' > 2, 2, 3, 3, 3', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' FLOOR(3), NINT(3)', & '', & ' AINT(3), ANINT(3), INT(3), SELECTED_INT_KIND(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ceiling(3fortran)', & ''] shortname="ceiling" call process() case('45','c_f_pointer') textblock=[character(len=256) :: & '', & 'c_f_pointer(3fortran) c_f_pointer(3fortran)', & '', & '', & '', & 'NAME', & ' C_F_POINTER(3) - [ISO_C_BINDING] Convert C into Fortran pointer', & '', & '', & 'SYNOPSIS', & ' call c_f_pointer(cptr, fptr [,shape] )', & '', & ' subroutine c_f_pointer(cptr, fptr ,shape )', & '', & ' type(c_ptr),intent(in) :: cprt', & ' type(TYPE),pointer,intent(out) :: fprt', & ' integer,intent(in),optional :: shape(:)', & '', & '', & 'CHARACTERISTICS', & ' The Fortran pointer FPRT must be interoperable with CPTR', & '', & ' SHAPE is only specified if FPTR is an array.', & '', & 'DESCRIPTION', & ' C_F_POINTER(3) assigns the target (the C pointer CPTR) to the Fortran', & ' pointer FPTR and specifies its shape if FPTR points to an array.', & '', & 'OPTIONS', & ' o CPTR : scalar of the type c_ptr. It is INTENT(IN).', & '', & ' o FPTR : pointer interoperable with CPTR. it is INTENT(OUT).', & '', & ' o SHAPE : (Optional) Rank-one array of type integer with INTENT(IN) . It', & ' shall be present if and only if FPTR is an array. The size must be equal', & ' to the rank of FPTR.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_c_f_pointer', & ' use iso_c_binding', & ' implicit none', & ' interface', & ' subroutine my_routine(p) bind(c,name=''myC_func'')', & ' import :: c_ptr', & ' type(c_ptr), intent(out) :: p', & ' end subroutine', & ' end interface', & ' type(c_ptr) :: cptr', & ' real,pointer :: a(:)', & ' call my_routine(cptr)', & ' call c_f_pointer(cptr, a, [12])', & ' end program demo_c_f_pointer', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' C_LOC(3), C_F_PROCPOINTER(3), ISO_C_BINDING(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 c_f_pointer(3fortran)', & ''] shortname="c_f_pointer" call process() case('46','c_f_procpointer') textblock=[character(len=256) :: & '', & 'c_f_procpointer(3fortran) c_f_procpointer(3fortran)', & '', & '', & '', & 'NAME', & ' C_F_PROCPOINTER(3) - [ISO_C_BINDING] Convert C into Fortran procedure', & ' pointer', & '', & '', & 'SYNOPSIS', & ' call c_f_procpointer(cptr, fptr)', & '', & ' subroutine c_f_procpointer(cptr, fptr )', & '', & ' type(c_funptr),intent(in) :: cprt', & ' type(TYPE),pointer,intent(out) :: fprt', & '', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' C_F_PROCPOINTER(3) assigns the target of the C function pointer CPTR to the', & ' Fortran procedure pointer FPTR.', & '', & 'OPTIONS', & ' o CPTR : scalar of the type c_funptr. It is INTENT(IN).', & '', & ' o FPTR : procedure pointer interoperable with CPTR. It is INTENT(OUT).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_c_f_procpointer', & ' use iso_c_binding', & ' implicit none', & ' abstract interface', & ' function func(a)', & ' import :: c_float', & ' real(c_float), intent(in) :: a', & ' real(c_float) :: func', & ' end function', & ' end interface', & ' interface', & ' function getIterFunc() bind(c,name="getIterFunc")', & ' import :: c_funptr', & ' type(c_funptr) :: getIterFunc', & ' end function', & ' end interface', & ' type(c_funptr) :: cfunptr', & ' procedure(func), pointer :: myFunc', & ' cfunptr = getIterFunc()', & ' call c_f_procpointer(cfunptr, myFunc)', & ' end program demo_c_f_procpointer', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' C_LOC(3), C_F_POINTER(3), ISO_C_BINDING(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 c_f_procpointer(3fortran)', & ''] shortname="c_f_procpointer" call process() case('47','c_funloc') textblock=[character(len=256) :: & '', & 'c_funloc(3fortran) c_funloc(3fortran)', & '', & '', & '', & 'NAME', & ' C_FUNLOC(3) - [ISO_C_BINDING] Obtain the C address of a procedure', & '', & '', & 'SYNOPSIS', & ' result = c_funloc(x)', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' C_FUNLOC(3) determines the C address of the argument.', & '', & 'OPTIONS', & ' o X : Interoperable function or pointer to such function.', & '', & 'RESULT', & ' The return value is of type c_funptr and contains the C address of the', & ' argument.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' ! program demo_c_funloc and module', & ' module x', & ' use iso_c_binding', & ' implicit none', & ' contains', & ' subroutine sub(a) bind(c)', & ' real(c_float) :: a', & ' a = sqrt(a)+5.0', & ' end subroutine sub', & ' end module x', & ' !', & ' program demo_c_funloc', & ' use iso_c_binding', & ' use x', & ' implicit none', & ' interface', & ' subroutine my_routine(p) bind(c,name=''myC_func'')', & ' import :: c_funptr', & ' type(c_funptr), intent(in) :: p', & ' end subroutine', & ' end interface', & ' call my_routine(c_funloc(sub))', & ' !', & ' end program demo_c_funloc', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' C_ASSOCIATED(3), C_LOC(3), C_F_POINTER(3),', & '', & ' C_F_PROCPOINTER(3), ISO_C_BINDING(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 c_funloc(3fortran)', & ''] shortname="c_funloc" call process() case('48','char') textblock=[character(len=256) :: & '', & 'char(3fortran) char(3fortran)', & '', & '', & '', & 'NAME', & ' CHAR(3) - [CHARACTER] Generate a character from a code value', & '', & '', & 'SYNOPSIS', & ' result = char(i [,kind])', & '', & ' elemental character(kind=KIND) function char(i,KIND)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I is an integer of any kind', & '', & ' o KIND is an integer initialization expression indicating the kind', & ' parameter of the result.', & '', & ' o The returned value is a character with the kind specified by KIND or if', & ' KIND is not present, the default character kind.', & '', & 'DESCRIPTION', & ' Generates a character value given a numeric code representing the position I', & ' in the collating sequence associated with the specified kind KIND.', & '', & ' Note that ACHAR(3) is a similar function specifically for ASCII characters', & ' that is preferred when only ASCII is being processed, which is equivalent to', & ' CHAR(I,KIND=SELECTED_CHAR_KIND("ASCII") )', & '', & ' The ICHAR(3) function is the reverse of CHAR(3), converting characters to', & ' their collating sequence value.', & '', & 'OPTIONS', & ' o I : a value in the range 0 <= I <= N-1, where N is the number of', & ' characters in the collating sequence associated with the specified kind', & ' type parameter. : For ASCII, N is 127. The default character set may or', & ' may not allow higher values.', & '', & ' o KIND : A constant integer initialization expression indicating the kind', & ' parameter of the result. If not present, the default kind is assumed.', & '', & 'RESULT', & ' The return value is a single character of the specified kind, determined by', & ' the position of I in the collating sequence associated with the specified', & ' KIND.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_char', & ' implicit none', & ' integer, parameter :: ascii = selected_char_kind ("ascii")', & ' character(len=1, kind=ascii ) :: c', & ' integer :: i', & ' ! basic', & ' i=74', & ' c=char(i)', & ' write(*,*)''ASCII character '',i,''is '',c', & ' !', & ' print *, ''a selection of ASCII characters (shows hex if not printable)''', & ' do i=0,127,10', & ' c = char(i,kind=ascii)', & ' select case(i)', & ' case(32:126)', & ' write(*,''(i3,1x,a)'')i,c', & ' case(0:31,127)', & ' ! print hexadecimal value for unprintable characters', & ' write(*,''(i3,1x,z2.2)'')i,c', & ' case default', & ' write(*,''(i3,1x,a,1x,a)'')i,c,''non-standard ASCII''', & ' end select', & ' enddo', & '', & ' end program demo_char', & '', & ' Results:', & '', & ' ASCII character 74 is J', & ' a selection of ASCII characters (shows hex if not printable)', & ' 0 00', & ' 10 0A', & ' 20 14', & ' 30 1E', & ' 40 (', & ' 50 2', & ' 60 <', & ' 70 F', & ' 80 P', & ' 90 Z', & ' 100 d 110 n 120 x', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ACHAR(3), IACHAR(3), ICHAR(3)', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 char(3fortran)', & ''] shortname="char" call process() case('49','c_loc') textblock=[character(len=256) :: & '', & 'c_loc(3fortran) c_loc(3fortran)', & '', & '', & '', & 'NAME', & ' C_LOC(3) - [ISO_C_BINDING] Obtain the C address of an object', & '', & '', & 'SYNOPSIS', & ' result = c_loc(x)', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' C_LOC(3) determines the C address of the argument.', & '', & 'OPTIONS', & ' o X : Shall have either the pointer or target attribute. It shall not be a', & ' coindexed object. It shall either be a variable with interoperable type', & ' and kind type parameters, or be a scalar, nonpolymorphic variable with no', & ' length type parameters.', & '', & 'RESULT', & ' The return value is of type c_ptr and contains the C address of the', & ' argument.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' subroutine association_test(a,b)', & ' use iso_c_binding, only: c_associated, c_loc, c_ptr', & ' implicit none', & ' real, pointer :: a', & ' type(c_ptr) :: b', & ' if(c_associated(b, c_loc(a))) &', & ' stop ''b and a do not point to same target''', & ' end subroutine association_test', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' C_ASSOCIATED(3), C_FUNLOC(3), C_F_POINTER(3),', & '', & ' C_F_PROCPOINTER(3), ISO_C_BINDING(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 c_loc(3fortran)', & ''] shortname="c_loc" call process() case('50','cmplx') textblock=[character(len=256) :: & '', & 'cmplx(3fortran) cmplx(3fortran)', & '', & '', & '', & 'NAME', & ' CMPLX(3) - [TYPE:NUMERIC] Conversion to a complex type', & '', & '', & 'SYNOPSIS', & ' result = cmplx(x [,kind]) | cmplx(x [,y] [,kind])', & '', & ' elemental complex(kind=KIND) function cmplx( x, y, kind )', & '', & ' type(TYPE(kind=**)),intent(in) :: x', & ' type(TYPE(kind=**)),intent(in),optional :: y', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o X may be integer, real, or complex.', & '', & ' o Y may be integer or real. Y is allowed only if X is not complex.', & '', & ' o KIND is a constant integer initialization expression indicating the kind', & ' parameter of the result.', & '', & ' The type of the arguments does not affect the kind of the result except for', & ' a complex X value.', & '', & ' o if KIND is not present and X is complex the result is of the kind of X.', & '', & ' o if KIND is not present and X is not complex the result if of default', & ' complex kind.', & '', & ' NOTE: a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' The CMPLX(3) function converts numeric values to a complex value.', & '', & ' Even though constants can be used to define a complex variable using syntax', & ' like', & '', & ' z = (1.23456789, 9.87654321)', & '', & ' this will not work for variables. So you cannot enter', & '', & ' z = (a, b) ! NO ! (unless a and b are constants, not variables)', & '', & ' so to construct a complex value using non-complex values you must use the', & ' CMPLX(3) function:', & '', & ' z = cmplx(a, b)', & '', & ' or assign values separately to the imaginary and real components using the', & ' %IM and %RE designators:', & '', & ' z%re = a', & ' z%im = b', & '', & ' If X is complex Y is not allowed and CMPLX essentially returns the input', & ' value except for an optional change of kind, which can be useful when', & ' passing a value to a procedure that requires the arguments to have a', & ' different kind (and does not return an altered value):', & '', & ' call something(cmplx(z,kind=real64))', & '', & ' would pass a copy of a value with kind=real64 even if z had a different kind', & '', & ' but otherwise is equivalent to a simple assign. So if z1 and z2 were', & ' complex:', & '', & ' z2 = z1 ! equivalent statements', & ' z2 = cmplx(z1)', & '', & ' If X is not complex X is only used to define the real component of the', & ' result but Y is still optional -- the imaginary part of the result will just', & ' be assigned a value of zero.', & '', & ' If Y is present it is converted to the imaginary component.', & '', & ' CMPLX(3) AND DOUBLE PRECISION', & '', & ' Primarily in order to maintain upward compatibility you need to be careful', & ' when working with complex values of higher precision that the default.', & '', & ' It was necessary for Fortran to continue to specify that CMPLX(3) always', & ' return a result of the default kind if the KIND option is absent, since that', & ' is the behavior mandated by FORTRAN 77.', & '', & ' It might have been preferable to use the highest precision of the arguments', & ' for determining the return kind, but that is not the case. So with arguments', & ' with greater precision than default values you are required to use the KIND', & ' argument or the greater precision values will be reduced to default', & ' precision.', & '', & ' This means CMPLX(D1,D2), where D1 and D2 are doubleprecision, is treated as:', & '', & ' cmplx(sngl(d1), sngl(d2))', & '', & ' which looses precision.', & '', & ' So Fortran 90 extends the CMPLX(3) intrinsic by adding an extra argument', & ' used to specify the desired kind of the complex result.', & '', & ' integer,parameter :: dp=kind(0.0d0)', & ' complex(kind=dp) :: z8', & ' ! wrong ways to specify constant values ! note this was stored with default', & ' real precision ! z8 = cmplx(1.2345678901234567d0, 1.2345678901234567d0)', & ' print *, ''NO, Z8='',z8,real(z8),aimag(z8)', & '', & ' z8 = cmplx(1.2345678901234567e0_dp, 1.2345678901234567e0_dp) ! again, note', & ' output components are just real print *, ''NO, Z8='',z8,real(z8),aimag(z8) !', & ' ! YES ! ! kind= makes it work z8 = cmplx(1.2345678901234567d0,', & ' 1.2345678901234567d0,kind=dp) print *, ''YES, Z8='',z8,real(z8),aimag(z8)', & '', & ' A more recent alternative to using CMPLX(3) is "F2018 component syntax"', & ' where real and imaginary parts of a complex entity can be accessed', & ' independently:', & '', & ' value%RE ! %RE specifies the real part', & ' or', & ' value%IM ! %IM specifies the imaginary part', & '', & ' Where the designator value is of course of complex type.', & '', & ' The type of a complex-part-designator is real, and its kind and shape are', & ' those of the designator. That is, you retain the precision of the complex', & ' value by default, unlike with CMPLX.', & '', & ' The following are examples of complex part designators:', & '', & ' impedance%re !-- Same value as real(impedance)', & ' fft%im !-- Same value as AIMAG(fft)', & ' x%im = 0.0 !-- Sets the imaginary part of x to zero', & ' x(1:2)%re=[10,20] !-- even if x is an array', & '', & ' NOTE for I/O', & '', & ' Note that if format statements are specified a complex value is treated as', & ' two real values.', & '', & ' For list-directed I/O (ie. using an asterisk for a format) and NAMELIST', & ' output the values are expected to be delimited by "(" and ")" and of the', & ' form "(real_part,imaginary_part)". For NAMELIST input parenthesized values', & ' or lists of multiple real values are acceptable.', & '', & 'OPTIONS', & ' o X : The value assigned to the real component of the result when X is not', & ' complex.', & '', & ' If X is complex, the result is the same as if the real part of the input', & ' was passed as X and the imaginary part as Y.', & '', & ' result = CMPLX (REAL (X), AIMAG (X), KIND).', & '', & ' That is, a complex X value is copied to the result value with a possible', & ' change of kind.', & '', & ' o Y : Y is only allowed if X is not complex. Its value is assigned to the', & ' imaginary component of the result and defaults to a value of zero if', & ' absent.', & '', & ' o KIND : An integer initialization expression indicating the kind parameter', & ' of the result.', & '', & 'RESULT', & ' The return value is of complex type, with magnitudes determined by the', & ' values X and Y.', & '', & ' The common case when X is not complex is that the real component of the', & ' result is assigned the value of X and the imaginary part is zero or the', & ' value of Y if Y is present.', & '', & ' When X is complex Y is not allowed and the result is the same value as X', & ' with a possible change of kind. That is, the real part is REAL(X, KIND) and', & ' the imaginary part is REAL(Y, KIND).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_aimag', & ' implicit none', & ' integer,parameter :: dp=kind(0.0d0)', & ' real(kind=dp) :: precise', & ' complex(kind=dp) :: z8', & ' complex :: z4, zthree(3)', & ' precise=1.2345678901234567d0', & '', & ' ! basic', & ' z4 = cmplx(-3)', & ' print *, ''Z4='',z4', & ' z4 = cmplx(1.23456789, 1.23456789)', & ' print *, ''Z4='',z4', & ' ! with a format treat a complex as two real values', & ' print ''(1x,g0,1x,g0,1x,g0)'',''Z4='',z4', & '', & ' ! working with higher precision values', & ' ! using kind=dp makes it keep DOUBLEPRECISION precision', & ' ! otherwise the result would be of default kind', & ' z8 = cmplx(precise, -precise )', & ' print *, ''lost precision Z8='',z8', & ' z8 = cmplx(precise, -precise ,kind=dp)', & ' print *, ''kept precision Z8='',z8', & '', & ' ! assignment of constant values does not require cmplx(3)00', & ' ! The following is intuitive and works without calling cmplx(3)', & ' ! but does not work for variables just constants', & ' z8 = (1.1111111111111111d0, 2.2222222222222222d0 )', & ' print *, ''Z8 defined with constants='',z8', & '', & ' ! what happens when you assign a complex to a real?', & ' precise=z8', & ' print *, ''LHS='',precise,''RHS='',z8', & '', & ' ! elemental', & ' zthree=cmplx([10,20,30],-1)', & ' print *, ''zthree='',zthree', & '', & ' ! descriptors are an alternative', & ' zthree(1:2)%re=[100,200]', & ' print *, ''zthree='',zthree', & '', & ' end program demo_aimag', & '', & ' Results:', & '', & ' Z4= (-3.000000,0.0000000E+00)', & ' Z4= (1.234568,1.234568)', & ' Z4= 1.234568 1.234568', & ' lost precision Z8= (1.23456788063049,-1.23456788063049)', & ' kept precision Z8= (1.23456789012346,-1.23456789012346)', & ' Z8 defined with constants= (1.11111111111111,2.22222222222222)', & ' LHS= 1.11111111111111 RHS= (1.11111111111111,2.22222222222222)', & ' zthree= (10.00000,-1.000000) (20.00000,-1.000000) (30.00000,-1.000000)', & ' zthree= (100.0000,-1.000000) (200.0000,-1.000000) (30.00000,-1.000000)', & '', & '', & 'STANDARD', & ' FORTRAN 77, KIND added in Fortran 90.', & '', & 'SEE ALSO', & ' o AIMAG(3) - Imaginary part of complex number', & '', & ' o CONJG(3) - Complex conjugate function', & '', & ' o REAL(3) - Convert to real type', & '', & ' Fortran has strong support for complex values, including many intrinsics', & ' that take or produce complex values in addition to algebraic and logical', & ' expressions:', & '', & ' ABS(3), ACOSH(3), ACOS(3), ASINH(3), ASIN(3), ATAN2(3), ATANH(3), ATAN(3),', & ' COSH(3), COS(3), CO_SUM(3), DBLE(3), DOT_PRODUCT(3), EXP(3), INT(3),', & ' IS_CONTIGUOUS(3), KIND(3), LOG(3), MATMUL(3), PRECISION(3), PRODUCT(3),', & ' RANGE(3), RANK(3), SINH(3), SIN(3), SQRT(3), STORAGE_SIZE(3), SUM(3),', & ' TANH(3), TAN(3), UNPACK(3),', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 cmplx(3fortran)', & ''] shortname="cmplx" call process() case('51','co_broadcast') textblock=[character(len=256) :: & '', & 'co_broadcast(3fortran) co_broadcast(3fortran)', & '', & '', & '', & 'NAME', & ' CO_BROADCAST(3) - [COLLECTIVE] Copy a value to all images the current set of', & ' images', & '', & '', & 'SYNOPSIS', & ' call co_broadcast(a, source_image [,stat] [,errmsg] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' CO_BROADCAST(3) copies the value of argument A on the image with image index', & ' source_image to all images in the current team. A becomes defined as if by', & ' intrinsic assignment. If the execution was successful and STAT is present,', & ' it is assigned the value zero. If the execution failed, STAT gets assigned a', & ' nonzero value and, if present, ERRMSG gets assigned a value describing the', & ' occurred error.', & '', & 'OPTIONS', & ' o A : INTENT(INOUT) argument; shall have the same dynamic type and type', & ' parameters on all images of the current team. If it is an array, it shall', & ' have the same shape on all images.', & '', & ' o SOURCE_IMAGE : a scalar integer expression. It shall have the same the', & ' same value on all images and refer to an image of the current team.', & '', & ' o STAT : (optional) a scalar integer variable', & '', & ' o ERRMSG : (optional) a scalar character variable', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_co_broadcast', & ' implicit none', & ' integer :: val(3)', & ' if (this_image() == 1) then', & ' val = [1, 5, 3]', & ' endif', & ' call co_broadcast (val, source_image=1)', & ' print *, this_image(), ":", val', & ' end program demo_co_broadcast', & '', & '', & 'STANDARD', & ' Fortran xx', & '', & 'SEE ALSO', & ' CO_MAX(3), CO_MIN(3), CO_SUM(3), CO_REDUCE(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 co_broadcast(3fortran)', & ''] shortname="co_broadcast" call process() case('52','co_lbound') textblock=[character(len=256) :: & '', & 'co_lbound(3fortran) co_lbound(3fortran)', & '', & 'NAME', & ' CO_LBOUND(3) - [COLLECTIVE] Lower codimension bounds of an array', & '', & 'SYNOPSIS', & ' result = co_lbound( coarray [,dim] [,kind] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' CO_LBOUND(3) returns the lower bounds of a coarray, or a single lower', & ' cobound along the DIM codimension.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an coarray, of any type.', & '', & ' o DIM : (Optional) Shall be a scalar integer.', & '', & ' o KIND : (Optional) An integer initialization expression indicating the', & ' kind parameter of the result.', & '', & 'RESULT', & ' The return value is of type integer and of kind KIND. If KIND is absent, the', & ' return value is of default integer kind. If DIM is absent, the result is an', & ' array of the lower cobounds of COARRAY. If DIM is present, the result is a', & ' scalar corresponding to the lower cobound of the array along that', & ' codimension.', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' CO_UBOUND(3), LBOUND(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & ' February 18, 2023 co_lbound(3fortran)', & ''] shortname="co_lbound" call process() case('53','co_max') textblock=[character(len=256) :: & '', & 'co_max(3fortran) co_max(3fortran)', & '', & '', & '', & 'NAME', & ' CO_MAX(3) - [COLLECTIVE] Maximal value on the current set of images', & '', & '', & 'SYNOPSIS', & ' call co_max(a, result_image [,stat] [,errmsg] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' CO_MAX(3) determines element-wise the maximal value of A on all images of', & ' the current team. If result_image is present, the maximum values are', & ' returned in A on the specified image only and the value of A on the other', & ' images become undefined. If result_image is not present, the value is', & ' returned on all images. If the execution was successful and STAT is present,', & ' it is assigned the value zero. If the execution failed, STAT gets assigned a', & ' nonzero value and, if present, ERRMSG gets assigned a value describing the', & ' occurred error.', & '', & 'OPTIONS', & ' o A : shall be an integer, real or character variable, which has the same', & ' type and type parameters on all images of the team.', & '', & ' o RESULT_IMAGE : (optional) a scalar integer expression; if present, it', & ' shall have the same the same value on all images and refer to an image of', & ' the current team.', & '', & ' o STAT : (optional) a scalar integer variable', & '', & ' o ERRMSG : (optional) a scalar character variable', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_co_max', & ' implicit none', & ' integer :: val', & ' val = this_image()', & ' call co_max(val, result_image=1)', & ' if (this_image() == 1) then', & ' write(*,*) "Maximal value", val ! prints num_images()', & ' endif', & ' end program demo_co_max', & '', & ' Results:', & '', & ' Maximal value 2', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' CO_MIN(3), CO_SUM(3), CO_REDUCE(3), CO_BROADCAST(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 co_max(3fortran)', & ''] shortname="co_max" call process() case('54','co_min') textblock=[character(len=256) :: & '', & 'co_min(3fortran) co_min(3fortran)', & '', & '', & '', & 'NAME', & ' CO_MIN(3) - [COLLECTIVE] Minimal value on the current set of images', & '', & '', & 'SYNOPSIS', & ' call co_min(a, result_image [,stat] [,errmsg] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' CO_MIN(3) determines element-wise the minimal value of A on all images of', & ' the current team. If result_image is present, the minimal values are', & ' returned in A on the specified image only and the value of A on the other', & ' images become undefined. If result_image is not present, the value is', & ' returned on all images. If the execution was successful and STAT is present,', & ' it is assigned the value zero. If the execution failed, STAT gets assigned a', & ' nonzero value and, if present, ERRMSG gets assigned a value describing the', & ' occurred error.', & '', & 'OPTIONS', & ' o A : shall be an integer, real or character variable, which has the same', & ' type and type parameters on all images of the team.', & '', & ' o RESULT_IMAGE : (optional) a scalar integer expression; if present, it', & ' shall have the same the same value on all images and refer to an image of', & ' the current team.', & '', & ' o STAT : (optional) a scalar integer variable', & '', & ' o ERRMSG : (optional) a scalar character variable', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_co_min', & ' implicit none', & ' integer :: val', & ' val = this_image()', & ' call co_min(val, result_image=1)', & ' if (this_image() == 1) then', & ' write(*,*) "Minimal value", val ! prints 1', & ' endif', & ' end program demo_co_min', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' CO_MAX(3), CO_SUM(3), CO_REDUCE(3), CO_BROADCAST(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 co_min(3fortran)', & ''] shortname="co_min" call process() case('55','command_argument_count') textblock=[character(len=256) :: & '', & 'command_argument_count(3fortran) command_argument_count(3fortran)', & '', & '', & '', & 'NAME', & ' COMMAND_ARGUMENT_COUNT(3) - [SYSTEM:COMMAND LINE] Get number of command line', & ' arguments', & '', & '', & 'SYNOPSIS', & ' result = command_argument_count()', & '', & ' integer function command_argument_count()', & '', & '', & 'CHARACTERISTICS', & ' o the result is of default integer scalar.', & '', & 'DESCRIPTION', & ' COMMAND_ARGUMENT_COUNT(3) returns the number of arguments passed on the', & ' command line when the containing program was invoked.', & '', & 'OPTIONS', & ' None', & '', & 'RESULT', & ' : The return value is of type default integer. It is the number of arguments', & ' passed on the command line when the program was invoked.', & '', & ' If there are no command arguments available or if the processor does not', & ' support command arguments, then the result has the value zero.', & '', & ' If the processor has a concept of a command name, the command name does not', & ' count as one of the command arguments.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_command_argument_count', & ' implicit none', & ' integer :: count', & ' count = command_argument_count()', & ' print *, count', & ' end program demo_command_argument_count', & '', & ' Sample output:', & '', & ' # the command verb does not count', & ' ./test_command_argument_count', & ' 0', & ' # quoted strings may count as one argument', & ' ./test_command_argument_count count arguments', & ' 2', & ' ./test_command_argument_count ''count arguments''', & ' 1', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' GET_COMMAND(3), GET_COMMAND_ARGUMENT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024command_argument_count(3fortran)', & ''] shortname="command_argument_count" call process() case('56','compiler_options') textblock=[character(len=256) :: & '', & 'compiler_options(3fortran) compiler_options(3fortran)', & '', & '', & '', & 'NAME', & ' COMPILER_OPTIONS(3) - [COMPILER:INQUIRY] Options passed to the compiler', & '', & '', & 'SYNOPSIS', & ' result = compiler_options()', & '', & ' character(len=:) function compiler_options()', & '', & '', & 'CHARACTERISTICS', & ' o the return value is a default-kind character variable with system-', & ' dependent length.', & '', & 'DESCRIPTION', & ' COMPILER_OPTIONS(3) returns a string with the options used for compiling.', & '', & 'OPTIONS', & ' None.', & '', & 'RESULT', & ' The result contains the compiler flags used to compile the file containing', & ' the COMPILER_OPTIONS(3) call.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_compiler_version', & ' use, intrinsic :: iso_fortran_env, only : compiler_version', & ' use, intrinsic :: iso_fortran_env, only : compiler_options', & ' implicit none', & ' print ''(4a)'', &', & ' ''This file was compiled by '', &', & ' compiler_version(), &', & ' '' using the options '', &', & ' compiler_options()', & ' end program demo_compiler_version', & '', & ' Results:', & '', & ' This file was compiled by GCC version 10.3.0 using', & ' the options -I build/gfortran_2A42023B310FA28D', & ' -mtune=generic -march=x86-64 -auxbase-strip', & ' build/gfortran_2A42023B310FA28D/compiler_options/app_main.f90.o', & ' -g -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1', & ' -fcheck=bounds -fcheck=array-temps -fbacktrace', & ' -fcoarray=single -J build/gfortran_2A42023B310FA28D', & ' -fpre-include=/usr/include/finclude/math-vector-fortran.h', & '', & ' This file was compiled by nvfortran 21.5-0 LLVM', & ' using the options app/main.f90 -c -Minform=inform', & ' -Mbackslash -Mbounds -Mchkptr -Mchkstk -traceback -module', & ' build/nvfortran_78229DCE997517A4 -Ibuild/nvfortran_78229DCE997517A4 -o', & ' build/nvfortran_78229DCE997517A4/compiler_options/app_main.f90.o', & '', & ' This file was compiled by Intel(R) Fortran Intel(R) 64 Compiler Classic', & ' for applications running on Intel(R) 64, Version 2021.3.0 Build', & ' 20210609_000000 using the options -Ibuild/ifort_5C58216731706F11', & ' -c -warn all -check all -error-limit 1 -O0 -g -assume', & ' byterecl -traceback -module build/ifort_5C58216731706F11 -o', & ' build/ifort_5C58216731706F11/compiler_options/app_main.f90.o', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' COMPILER_VERSION(3), ISO_FORTRAN_ENV(7)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 compiler_options(3fortran)', & ''] shortname="compiler_options" call process() case('57','compiler_version') textblock=[character(len=256) :: & '', & 'compiler_version(3fortran) compiler_version(3fortran)', & '', & '', & '', & 'NAME', & ' COMPILER_VERSION(3) - [COMPILER:INQUIRY] Compiler version string', & '', & '', & 'SYNOPSIS', & ' result = compiler_version()', & '', & ' character(len=:) function compiler_version()', & '', & '', & 'CHARACTERISTICS', & ' o The return value is a default-kind scalar character with system-dependent', & ' length.', & '', & 'DESCRIPTION', & ' COMPILER_VERSION(3) returns a string containing the name and version of the', & ' compiler.', & '', & 'OPTIONS', & ' None.', & '', & 'RESULT', & ' The return value contains the name of the compiler and its version number', & ' used to compile the file containing the COMPILER_VERSION(3) call.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_compiler_version', & ' use, intrinsic :: iso_fortran_env, only : compiler_version', & ' implicit none', & ' print ''(2a)'', &', & ' ''This file was compiled by '', &', & ' compiler_version()', & ' end program demo_compiler_version', & '', & ' Results:', & '', & ' This file was compiled by GCC version 10.3.0', & '', & ' This file was compiled by Intel(R) Fortran Intel(R) 64 Compiler', & ' Classic for applications running on Intel(R) 64, Version 2021.3.0 Build', & ' 20210609_000000', & '', & ' This file was compiled by nvfortran 21.5-0 LLVM', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' COMPILER_OPTIONS(3), ISO_FORTRAN_ENV(7)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 compiler_version(3fortran)', & ''] shortname="compiler_version" call process() case('58','conjg') textblock=[character(len=256) :: & '', & 'conjg(3fortran) conjg(3fortran)', & '', & '', & '', & 'NAME', & ' CONJG(3) - [NUMERIC] Complex conjugate of a complex value', & '', & '', & 'SYNOPSIS', & ' result = conjg(z)', & '', & ' elemental complex(kind=KIND) function conjg(z)', & '', & ' complex(kind=**),intent(in) :: z', & '', & '', & 'CHARACTERISTICS', & ' o Z is a complex value of any valid kind.', & '', & ' o The returned value has the same complex type as the input.', & '', & 'DESCRIPTION', & ' CONJG(3) returns the complex conjugate of the complex value Z.', & '', & ' That is, If Z is the complex value (X, Y) then the result is (X, -Y).', & '', & ' In mathematics, the complex conjugate of a complex number is a value whose', & ' real and imaginary part are equal parts are equal in magnitude to each other', & ' but the Y value has opposite sign.', & '', & ' For matrices of complex numbers, CONJG(ARRAY) represents the element-by-', & ' element conjugation of ARRAY; not the conjugate transpose of the ARRAY .', & '', & 'OPTIONS', & ' o Z : The value to create the conjugate of.', & '', & 'RESULT', & ' Returns a value equal to the input value except the sign of the imaginary', & ' component is the opposite of the input value.', & '', & ' That is, if Z has the value (X,Y), the result has the value (X, -Y).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_conjg', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' complex :: z = (2.0, 3.0)', & ' complex(kind=real64) :: dz = ( &', & ' & 1.2345678901234567_real64, -1.2345678901234567_real64)', & ' complex :: arr(3,3)', & ' integer :: i', & ' ! basics', & ' ! notice the sine of the imaginary component changes', & ' print *, z, conjg(z)', & '', & ' ! any complex kind is supported. z is of default kind but', & ' ! dz is kind=real64.', & ' print *, dz', & ' dz = conjg(dz)', & ' print *, dz', & ' print *', & '', & ' ! the function is elemental so it can take arrays', & ' arr(1,:)=[(-1.0, 2.0),( 3.0, 4.0),( 5.0,-6.0)]', & ' arr(2,:)=[( 7.0,-8.0),( 8.0, 9.0),( 9.0, 9.0)]', & ' arr(3,:)=[( 1.0, 9.0),( 2.0, 0.0),(-3.0,-7.0)]', & '', & ' write(*,*)''original''', & ' write(*,''(3("(",g8.2,",",g8.2,")",1x))'')(arr(i,:),i=1,3)', & ' arr = conjg(arr)', & ' write(*,*)''conjugate''', & ' write(*,''(3("(",g8.2,",",g8.2,")",1x))'')(arr(i,:),i=1,3)', & '', & ' end program demo_conjg', & '', & ' Results:', & '', & ' > (2.000000,3.000000) (2.000000,-3.000000)', & ' >', & ' > (1.23456789012346,-1.23456789012346)', & ' > (1.23456789012346,1.23456789012346)', & ' >', & ' > original', & ' > (-1.0 , 2.0 ) ( 3.0 , 4.0 ) ( 5.0 ,-6.0 )', & ' > ( 7.0 ,-8.0 ) ( 8.0 , 9.0 ) ( 9.0 , 9.0 )', & ' > ( 1.0 , 9.0 ) ( 2.0 , 0.0 ) (-3.0 ,-7.0 )', & ' >', & ' > conjugate', & ' > (-1.0 ,-2.0 ) ( 3.0 ,-4.0 ) ( 5.0 , 6.0 )', & ' > ( 7.0 , 8.0 ) ( 8.0 ,-9.0 ) ( 9.0 ,-9.0 )', & ' > ( 1.0 ,-9.0 ) ( 2.0 , 0.0 ) (-3.0 , 7.0 )', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' o AIMAG(3) - Imaginary part of complex number', & '', & ' o CMPLX(3) - Complex conversion function', & '', & ' o REAL(3) - Convert to real type', & '', & ' Fortran has strong support for complex values, including many intrinsics', & ' that take or produce complex values in addition to algebraic and logical', & ' expressions:', & '', & ' ABS(3), ACOSH(3), ACOS(3), ASINH(3), ASIN(3), ATAN2(3), ATANH(3), ATAN(3),', & ' COSH(3), COS(3), CO_SUM(3), DBLE(3), DOT_PRODUCT(3), EXP(3), INT(3),', & ' IS_CONTIGUOUS(3), KIND(3), LOG(3), MATMUL(3), PRECISION(3), PRODUCT(3),', & ' RANGE(3), RANK(3), SINH(3), SIN(3), SQRT(3), STORAGE_SIZE(3), SUM(3),', & ' TANH(3), TAN(3), UNPACK(3),', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 conjg(3fortran)', & ''] shortname="conjg" call process() case('59','continue') textblock=[character(len=256) :: & '', & 'continue(7fortran) continue(7fortran)', & '', & '', & '', & 'NAME', & ' CONTINUE(7) - [EXECUTION_CONTROL] execution of a CONTINUE statement has no', & ' effect', & '', & '', & 'SYNOPSIS', & ' [NNNNN] continue', & '', & 'DESCRIPTION', & ' It is generally very confusing to have executable statements on labeled', & ' lines; a CONTINUE statement eliminates the ambiguities that arise in jumping', & ' to an executable line. Specifically:', & '', & ' o Execution of a CONTINUE statement has no effect.', & '', & ' o Preferably no target of a transfer should be an executable statement.', & '', & ' o Therefore, all numerically labeled executable lines should be a CONTINUE.', & '', & ' A CONTINUE statement is most often used as a target for transfer control', & ' statements such as GOTO. That is, a numeric label is added to the line.', & '', & ' CONTINUE(7f) is rarely used in new code but was very commonly encountered in', & ' older FORTRAN code before the advent of constructs like ENDDO, CYCLE, BLOCK,', & ' and EXIT.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' > program oldstyle', & ' > integer i,j', & ' > j=5', & ' > do 100 i=1,20', & ' > if(i.lt.5)goto 100', & ' > j=3', & ' >100 write(*,*)''J='',j', & ' > end', & '', & ' program demo_continue', & ' ! numbered targets should (almost?) always be a continue statement', & ' ! with a unique label for each looping structure', & ' integer :: i,j', & ' j=5', & ' do 100 i=1,20', & ' if(i.lt.5)goto 50', & ' j=3', & ' 50 continue', & ' write(*,*)''J='',j', & ' 100 continue', & ' end program demo_continue', & '', & ' program newer', & ' implicit none', & ' integer :: i,j', & ' j=5', & ' do i=1,20', & ' if(i >= 5)then', & ' j=3', & ' endif', & ' write(*,*)''J='',j', & ' enddo', & ' end program newer', & '', & ' fortran-lang statement descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 continue(7fortran)', & ''] shortname="continue" call process() case('60','co_reduce') textblock=[character(len=256) :: & '', & 'co_reduce(3fortran) co_reduce(3fortran)', & '', & '', & '', & 'NAME', & ' CO_REDUCE(3) - [COLLECTIVE] Reduction of values on the current set of images', & '', & '', & 'SYNOPSIS', & ' call co_reduce(a, operation, result_image [,stat] [,errmsg] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' CO_REDUCE(3) determines element-wise the reduction of the value of A on all', & ' images of the current team. The pure function passed as OPERATION is used to', & ' pairwise reduce the values of A by passing either the value of A of', & ' different images or the result values of such a reduction as argument. If A', & ' is an array, the reduction is done element wise. If result_image is present,', & ' the result values are returned in A on the specified image only and the', & ' value of A on the other images become undefined. If result_image is not', & ' present, the value is returned on all images. If the execution was', & ' successful and STAT is present, it is assigned the value zero. If the', & ' execution failed, STAT gets assigned a nonzero value and, if present, ERRMSG', & ' gets assigned a value describing the occurred error.', & '', & 'OPTIONS', & ' o A : is an INTENT(INOUT) argument and shall be nonpolymorphic. If it is', & ' allocatable, it shall be allocated; if it is a pointer, it shall be', & ' associated. A shall have the same type and type parameters on all images', & ' of the team; if it is an array, it shall have the same shape on all', & ' images.', & '', & ' o OPERATION : pure function with two scalar nonallocatable arguments, which', & ' shall be nonpolymorphic and have the same type and type parameters as A.', & ' The function shall return a nonallocatable scalar of the same type and', & ' type parameters as A. The function shall be the same on all images and', & ' with regards to the arguments mathematically commutative and associative.', & ' Note that OPERATION may not be an elemental unless it is an intrinsic', & ' function.', & '', & ' o RESULT_IMAGE', & '', & ' : (optional) a scalar integer expression; if present, it shall have', & ' the same the same value on all images and refer to an image of the', & ' current team.', & '', & '', & ' o STAT : (optional) a scalar integer variable', & '', & ' o ERRMSG : (optional) a scalar character variable', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_co_reduce', & ' implicit none', & ' integer :: val', & '', & ' val = this_image()', & ' call co_reduce(val, myprod, 1)', & ' if (this_image() == 1) then', & ' write(*,*) "Product value", val ! prints num_images() factorial', & ' endif', & '', & ' contains', & '', & ' pure function myprod(a, b)', & ' integer, value :: a, b', & ' integer :: myprod', & ' myprod = a * b', & ' end function myprod', & '', & ' end program demo_co_reduce', & '', & '', & 'NOTE', & ' While the rules permit in principle an intrinsic function, none of the', & ' intrinsics in the standard fulfill the criteria of having a specific', & ' function, which takes two arguments of the same type and returning that type', & ' as a result.', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' CO_MIN(3), CO_MAX(3), CO_SUM(3), CO_BROADCAST(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 co_reduce(3fortran)', & ''] shortname="co_reduce" call process() case('61','cos') textblock=[character(len=256) :: & '', & 'cos(3fortran) cos(3fortran)', & '', & '', & '', & 'NAME', & ' COS(3) - [MATHEMATICS:TRIGONOMETRIC] Cosine function', & '', & '', & 'SYNOPSIS', & ' result = cos(x)', & '', & ' elemental TYPE(kind=KIND) function cos(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is of type real or complex of any valid kind.', & '', & ' o KIND may be any kind supported by the associated type of X.', & '', & ' o The returned value will be of the same type and kind as the argument X.', & '', & 'DESCRIPTION', & ' COS(3) computes the cosine of an angle X given the size of the angle in', & ' radians.', & '', & ' The cosine of a real value is the ratio of the adjacent side to the', & ' hypotenuse of a right-angled triangle.', & '', & 'OPTIONS', & ' o X : The angle in radians to compute the cosine of.', & '', & 'RESULT', & ' The return value is the tangent of X.', & '', & ' If X is of the type real, the return value is in radians and lies in the', & ' range -1 <= COS(X) <= 1 .', & '', & ' If X is of type complex, its real part is regarded as a value in radians,', & ' often called the phase.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_cos', & ' implicit none', & ' character(len=*),parameter :: g2=''(a,t20,g0)''', & ' doubleprecision,parameter :: PI=atan(1.0d0)*4.0d0', & ' write(*,g2)''COS(0.0)='',cos(0.0)', & ' write(*,g2)''COS(PI)='',cos(PI)', & ' write(*,g2)''COS(PI/2.0d0)='',cos(PI/2.0d0),''EPSILON='',epsilon(PI)', & ' write(*,g2)''COS(2*PI)='',cos(2*PI)', & ' write(*,g2)''COS(-2*PI)='',cos(-2*PI)', & ' write(*,g2)''COS(-2000*PI)='',cos(-2000*PI)', & ' write(*,g2)''COS(3000*PI)='',cos(3000*PI)', & ' end program demo_cos', & '', & ' Results:', & '', & ' > COS(0.0)= 1.000000', & ' > COS(PI)= -1.000000000000000', & ' > COS(PI/2.0d0)= .6123233995736766E-16', & ' > EPSILON= .2220446049250313E-15', & ' > COS(2*PI)= 1.000000000000000', & ' > COS(-2*PI)= 1.000000000000000', & ' > COS(-2000*PI)= 1.000000000000000', & ' > COS(3000*PI)= 1.000000000000000', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ACOS(3), SIN(3), TAN(3)', & '', & 'RESOURCES', & ' o Wikipedia:sine and cosine', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 cos(3fortran)', & ''] shortname="cos" call process() case('62','cosh') textblock=[character(len=256) :: & '', & 'cosh(3fortran) cosh(3fortran)', & '', & '', & '', & 'NAME', & ' COSH(3) - [MATHEMATICS:TRIGONOMETRIC] Hyperbolic cosine function', & '', & '', & 'SYNOPSIS', & ' result = cosh(x)', & '', & ' elemental TYPE(kind=KIND) function cosh(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o TYPE may be real or complex of any kind.', & '', & ' o The returned value will be of the same type and kind as the argument.', & '', & 'DESCRIPTION', & ' COSH(3) computes the hyperbolic cosine of X.', & '', & ' If X is of type complex its imaginary part is regarded as a value in', & ' radians.', & '', & 'OPTIONS', & ' o X : the value to compute the hyperbolic cosine of', & '', & 'RESULT', & ' If X is complex, the imaginary part of the result is in radians.', & '', & ' If X is real, the return value has a lower bound of one, COSH(X) >= 1.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_cosh', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & real_kinds, real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 1.0_real64', & ' write(*,*)''X='',x,''COSH(X=)'',cosh(x)', & ' end program demo_cosh', & '', & ' Results:', & '', & ' > X= 1.00000000000000 COSH(X=) 1.54308063481524', & '', & '', & 'STANDARD', & ' FORTRAN 77 , for a complex argument - Fortran 2008', & '', & 'SEE ALSO', & ' Inverse function: ACOSH(3)', & '', & 'RESOURCES', & ' o Wikipedia:hyperbolic functions', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 cosh(3fortran)', & ''] shortname="cosh" call process() case('63','co_sum') textblock=[character(len=256) :: & '', & 'co_sum(3fortran) co_sum(3fortran)', & '', & '', & '', & 'NAME', & ' CO_SUM(3) - [COLLECTIVE] Sum of values on the current set of images', & '', & '', & 'SYNOPSIS', & ' call co_sum(a, result_image [,stat] [,errmsg] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' CO_SUM(3) sums up the values of each element of A on all images of the', & ' current team.', & '', & ' If result_image is present, the summed-up values are returned in A on the', & ' specified image only and the value of A on the other images become', & ' undefined.', & '', & ' If result_image is not present, the value is returned on all images. If the', & ' execution was successful and STAT is present, it is assigned the value zero.', & ' If the execution failed, STAT gets assigned a nonzero value and, if present,', & ' ERRMSG gets assigned a value describing the occurred error.', & '', & 'OPTIONS', & ' o A : shall be an integer, real or complex variable, which has the same', & ' type and type parameters on all images of the team.', & '', & ' o RESULT_IMAGE : (optional) a scalar integer expression; if present, it', & ' shall have the same the same value on all images and refer to an image of', & ' the current team.', & '', & ' o STAT : (optional) a scalar integer variable', & '', & ' o ERRMSG : (optional) a scalar character variable', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_co_sum', & ' implicit none', & ' integer :: val', & ' val = this_image()', & ' call co_sum(val, result_image=1)', & ' if (this_image() == 1) then', & ' ! prints (n**2 + n)/2, with n = num_images()', & ' write(*,*) "The sum is ", val', & ' endif', & ' end program demo_co_sum', & '', & ' Results:', & '', & ' The sum is 1', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' CO_MAX(3), CO_MIN(3), CO_REDUCE(3), CO_BROADCAST(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 co_sum(3fortran)', & ''] shortname="co_sum" call process() case('64','co_ubound') textblock=[character(len=256) :: & '', & 'co_ubound(3fortran) co_ubound(3fortran)', & '', & 'NAME', & ' CO_UBOUND(3) - [COLLECTIVE] Upper codimension bounds of an array', & '', & 'SYNOPSIS', & ' result = co_ubound(coarray [,dim] [,kind] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' CO_UBOUND(3) returns the upper cobounds of a coarray, or a single upper', & ' cobound along the DIM codimension.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an coarray, of any type.', & '', & ' o DIM : (Optional) Shall be a scalar integer.', & '', & ' o KIND : (Optional) An integer initialization expression indicating the', & ' kind parameter of the result.', & '', & 'RESULT', & ' The return value is of type integer and of kind KIND. If KIND is absent, the', & ' return value is of default integer kind. If DIM is absent, the result is an', & ' array of the lower cobounds of COARRAY. If DIM is present, the result is a', & ' scalar corresponding to the lower cobound of the array along that', & ' codimension.', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' CO_LBOUND(3), LBOUND(3), UBOUND(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & ' February 18, 2023 co_ubound(3fortran)', & ''] shortname="co_ubound" call process() case('65','count') textblock=[character(len=256) :: & '', & 'count(3fortran) count(3fortran)', & '', & '', & '', & 'NAME', & ' COUNT(3) - [ARRAY:REDUCTION] Count true values in an array', & '', & '', & 'SYNOPSIS', & ' result = count(mask [,dim] [,kind] )', & '', & ' integer(kind=KIND) function count(mask, dim, KIND )', & '', & ' logical(kind=**),intent(in) :: mask(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o MASK is a logical array of any shape and kind.', & '', & ' o If DIM is present, the result is an array with the specified rank', & ' removed.', & '', & ' o KIND is a scalar integer constant expression valid as an integer kind', & '', & ' o The return value is of default integer type unless KIND is specified to', & ' declare the kind of the result.', & '', & 'DESCRIPTION', & ' COUNT(3) counts the number of .true. elements in a logical MASK, or, if the', & ' DIM argument is supplied, counts the number of elements along each row of', & ' the array in the DIM direction. If the array has zero size or all of the', & ' elements of MASK are false, then the result is 0.', & '', & 'OPTIONS', & ' o MASK : an array to count the number of .true. values in', & '', & ' o DIM : specifies to remove this dimension from the result and produce an', & ' array of counts of .true. values along the removed dimension. If not', & ' present, the result is a scalar count of the true elements in MASK the', & ' value must be in the range 1 <= dim <= n, where n is the rank(number of', & ' dimensions) of MASK.', & '', & ' The corresponding actual argument shall not be an optional dummy', & ' argument, a disassociated pointer, or an unallocated allocatable.', & '', & ' o KIND : An integer initialization expression indicating the kind parameter', & ' of the result.', & '', & 'RESULT', & ' The return value is the number of .true. values in MASK if DIM is not', & ' present.', & '', & ' If DIM is present, the result is an array with a rank one less than the rank', & ' of the input array MASK, and a size corresponding to the shape of ARRAY with', & ' the DIM dimension removed, with the remaining elements containing the number', & ' of .true. elements along the removed dimension.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_count', & ' implicit none', & ' character(len=*),parameter :: ints=''(*(i2,1x))''', & ' ! two arrays and a mask all with the same shape', & ' integer, dimension(2,3) :: a, b', & ' logical, dimension(2,3) :: mymask', & ' integer :: i', & ' integer :: c(2,3,4)', & '', & ' print *,''the numeric arrays we will compare''', & ' a = reshape( [ 1, 2, 3, 4, 5, 6 ], [ 2, 3 ])', & ' b = reshape( [ 0, 7, 3, 4, 5, 8 ], [ 2, 3 ])', & ' c = reshape( [( i,i=1,24)], [ 2, 3 ,4])', & ' print ''(3i3)'', a(1,:)', & ' print ''(3i3)'', a(2,:)', & ' print *', & ' print ''(3i3)'', b(1,:)', & ' print ''(3i3)'', b(2,:)', & ' !', & ' ! basic calls', & ' print *, ''count a few basic things creating a mask from an expression''', & ' print *, ''count a>b'',count(a>b)', & ' print *, ''count bb) + &', & ' & count(a [",*(i''//trim(biggest)//'':,","))''', & ' ! print one row of array at a time', & ' do i=1,size(arr,dim=1)', & ' write(*,fmt=biggest,advance=''no'')arr(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' !', & ' end subroutine printi', & ' end program demo_count', & '', & ' Results:', & '', & ' > the numeric arrays we will compare', & ' > 1 3 5', & ' > 2 4 6', & ' >', & ' > 0 3 5', & ' > 7 4 8', & ' > count a few basic things creating a mask from an expression', & ' > count a>b 1', & ' > count b count b==a 3', & ' > check sum = T', & ' > make a mask identifying unequal elements ...', & ' > the mask generated from a.ne.b', & ' > T F F', & ' > T F T', & ' > count total and along rows and columns ...', & ' > number of elements not equal', & ' > (ie. total true elements in the mask)', & ' > 3', & ' > count of elements not equal in each column', & ' > (ie. total true elements in each column)', & ' > 2 0 1', & ' > count of elements not equal in each row', & ' > (ie. total true elements in each row)', & ' > 1 2', & ' > lets try this with c(2,3,4)', & ' > taking the result of the modulo', & ' > z=1 z=2 z=3 z=4', & ' > 1 3 0 || 2 4 1 || 3 0 2 || 4 1 3 |', & ' > 2 4 1 || 3 0 2 || 4 1 3 || 0 2 4 |', & ' >', & ' > would result in the mask ..', & ' > F F T || F F F || F T F || F F F |', & ' > F F F || F T F || F F F || T F F |', & ' >', & ' > the total number of .true.values is', & ' > 4', & ' >', & ' > counting up along a row and removing rows :( 3 4 )', & ' > > [ 0, 0, 0, 1 ]', & ' > > [ 0, 1, 1, 0 ]', & ' > > [ 1, 0, 0, 0 ]', & ' >', & ' > counting up along a column and removing columns :( 2 4 )', & ' > > [ 1, 0, 1, 0 ]', & ' > > [ 0, 1, 0, 1 ]', & ' >', & ' > counting up along a depth and removing depths :( 2 3 )', & ' > > [ 0, 1, 1 ]', & ' > > [ 1, 1, 0 ]', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument - Fortran 2003', & '', & 'SEE ALSO', & ' ANY(3), ALL(3), SUM(3),', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 count(3fortran)', & ''] shortname="count" call process() case('66','cpu_time') textblock=[character(len=256) :: & '', & 'cpu_time(3fortran) cpu_time(3fortran)', & '', & '', & '', & 'NAME', & ' CPU_TIME(3) - [SYSTEM:TIME] Return CPU processor time used in seconds', & '', & '', & 'SYNOPSIS', & ' call cpu_time(time)', & '', & ' subroutine cpu_time(time)', & '', & ' real,intent(out) :: time', & '', & '', & 'CHARACTERISTICS', & ' o TIME is a real of any kind', & '', & 'DESCRIPTION', & ' CPU_TIME(3) returns a real value representing the elapsed CPU time in', & ' seconds. This is useful for testing segments of code to determine execution', & ' time.', & '', & ' If no time source is available, TIME is set to a negative value.', & '', & ' The exact definition of time is left imprecise because of the variability in', & ' what different processors are able to provide.', & '', & ' Note that TIME may contain a system dependent, arbitrary offset and may not', & ' start with 0.0. For CPU_TIME(3) the absolute value is meaningless. Only', & ' differences between subsequent calls, as shown in the example below, should', & ' be used.', & '', & 'PARALLEL PROCESSING', & ' Whether the value assigned is an approximation to the amount of time used by', & ' the invoking image, or the amount of time used by the whole program, is', & ' processor dependent.', & '', & ' A processor for which a single result is inadequate (for example, a parallel', & ' processor) might choose to provide an additional version for which TIME is', & ' an array.', & '', & 'RESULT', & ' o TIME : is assigned a processor-dependent approximation to the processor', & ' time in seconds. If the processor cannot return a meaningful time, a', & ' processor-dependent negative value is returned.', & '', & ' : The start time is left imprecise because the purpose is to time', & ' sections of code, as in the example. This might or might not include', & ' system overhead time.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_cpu_time', & ' use, intrinsic :: iso_fortran_env, only : real_kinds,real32,real64,real128', & ' implicit none', & ' real :: start, finish', & ' real(kind=real64) :: startd, finishd', & ' !', & ' call cpu_time(start)', & ' call cpu_time(startd)', & ' ! put code to time here', & ' call cpu_time(finish)', & ' call cpu_time(finishd)', & ' !', & ' ! writes processor time taken by the piece of code.', & '', & ' ! the accuracy of the clock and whether it includes system time', & ' ! as well as user time is processor dependent. Accuracy up to', & ' ! milliseconds is common but not guaranteed, and may be much', & ' ! higher or lower', & ' print ''("Processor Time = ",f6.3," seconds.")'',finish-start', & '', & ' ! see your specific compiler documentation for how to measure', & ' ! parallel jobs and for the precision of the time returned', & ' print ''("Processor Time = ",g0," seconds.")'',finish-start', & ' print ''("Processor Time = ",g0," seconds.")'',finishd-startd', & ' end program demo_cpu_time', & '', & ' Results:', & '', & ' The precision of the result, some aspects of what is returned, and what if', & ' any options there are for parallel applications may very from system to', & ' system. See compiler-specific for details.', & '', & ' Processor Time = 0.000 seconds.', & ' Processor Time = .4000030E-05 seconds.', & ' Processor Time = .2000000000000265E-05 seconds.', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' SYSTEM_CLOCK(3), DATE_AND_TIME(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 cpu_time(3fortran)', & ''] shortname="cpu_time" call process() case('67','cshift') textblock=[character(len=256) :: & '', & 'cshift(3fortran) cshift(3fortran)', & '', & '', & '', & 'NAME', & ' CSHIFT(3) - [TRANSFORMATIONAL] Circular shift elements of an array', & '', & '', & 'SYNOPSIS', & ' result = cshift(array, shift [,dim])', & '', & ' type(TYPE(kind=KIND)) function cshift(array, shift, dim )', & '', & ' type(TYPE(kind=KIND)),intent(in) :: array(..)', & ' integer(kind=**),intent(in) :: shift', & ' integer(kind=**),intent(in) :: dim', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY may be any type and rank', & '', & ' o SHIFT an integer scalar if ARRAY has rank one. Otherwise, it shall be', & ' scalar or of rank n-1 and of shape [d1, d2, ..., dDIM-1, dDIM+1,', & '', & ' o DIM is an integer scalar with a value in the range 1 <= DIM <= n, where n', & ' is the rank of ARRAY. If DIM is absent, it is as if it were present with', & ' the value 1.', & '', & ' o the result will automatically be of the same type, kind and shape as', & ' ARRAY.', & '', & ' NOTE: :a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' CSHIFT(3) performs a circular shift on elements of ARRAY along the dimension', & ' of DIM. If DIM is omitted it is taken to be 1. DIM is a scalar of type', & ' integer in the range of 1 <= DIM <= N, where "n" is the rank of ARRAY.', & '', & ' If the rank of ARRAY is one, then all elements of ARRAY are shifted by SHIFT', & ' places. If rank is greater than one, then all complete rank one sections of', & ' ARRAY along the given dimension are shifted. Elements shifted out one end of', & ' each rank one section are shifted back in the other end.', & '', & 'OPTIONS', & ' o ARRAY : An array of any type which is to be shifted', & '', & ' o SHIFT : the number of positions to circularly shift. A negative value', & ' produces a right shift, a positive value produces a left shift.', & '', & ' o DIM : the dimension along which to shift a multi-rank ARRAY. Defaults to', & ' 1.', & '', & 'RESULT', & ' Returns an array of same type and rank as the ARRAY argument.', & '', & ' The rows of an array of rank two may all be shifted by the same amount or by', & ' different amounts.', & '', & ' cshift', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_cshift', & ' implicit none', & ' integer, dimension(5) :: i1,i2,i3', & ' integer, dimension(3,4) :: a, b', & ' !basics', & ' i1=[10,20,30,40,50]', & ' print *,''start with:''', & ' print ''(1x,5i3)'', i1', & ' print *,''shift -2''', & ' print ''(1x,5i3)'', cshift(i1,-2)', & ' print *,''shift +2''', & ' print ''(1x,5i3)'', cshift(i1,+2)', & '', & ' print *,''start with a matrix''', & ' a = reshape( [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 ], [ 3, 4 ])', & ' print ''(4i3)'', a(1,:)', & ' print ''(4i3)'', a(2,:)', & ' print ''(4i3)'', a(3,:)', & ' print *,''matrix shifted along rows, each by its own amount [-1,0,1]''', & ' b = cshift(a, SHIFT=[1, 0, -1], DIM=2)', & ' print *', & ' print ''(4i3)'', b(1,:)', & ' print ''(4i3)'', b(2,:)', & ' print ''(4i3)'', b(3,:)', & ' end program demo_cshift', & '', & ' Results:', & '', & ' > start with:', & ' > 10 20 30 40 50', & ' > shift -2', & ' > 40 50 10 20 30', & ' > shift +2', & ' > 30 40 50 10 20', & ' > start with a matrix', & ' > 1 4 7 10', & ' > 2 5 8 11', & ' > 3 6 9 12', & ' > matrix shifted along rows, each by its own amount', & ' >', & ' > 4 7 10 1', & ' > 2 5 8 11', & ' > 12 3 6 9', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o EOSHIFT(3) - End-off shift elements of an array', & '', & ' o SUM(3) - sum the elements of an array', & '', & ' o PRODUCT(3) - Product of array elements', & '', & ' o FINDLOC(3) - Location of first element of ARRAY identified by MASK along', & ' dimension DIM having a value', & '', & ' o MAXLOC(3) - Location of the maximum value within an array', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 cshift(3fortran)', & ''] shortname="cshift" call process() case('68','c_sizeof') textblock=[character(len=256) :: & '', & 'c_sizeof(3fortran) c_sizeof(3fortran)', & '', & '', & '', & 'NAME', & ' C_SIZEOF(3) - [ISO_C_BINDING] Size in bytes of an expression', & '', & '', & 'SYNOPSIS', & ' result = c_sizeof(x)', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' C_SIZEOF(3) calculates the number of bytes of storage the expression X', & ' occupies.', & '', & 'OPTIONS', & ' o X : The argument shall be an interoperable data entity.', & '', & 'RESULT', & ' The return value is of type integer and of the system-dependent kind csize_t', & ' (from the iso_c_binding module). Its value is the number of bytes occupied', & ' by the argument. If the argument has the pointer attribute, the number of', & ' bytes of the storage area pointed to is returned. If the argument is of a', & ' derived type with pointer or allocatable components, the return value does', & ' not account for the sizes of the data pointed to by these components.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_c_sizeof', & ' use iso_c_binding', & ' implicit none', & ' real(c_float) :: r, s(5)', & ' print *, (c_sizeof(s)/c_sizeof(r) == 5)', & ' end program demo_c_sizeof', & '', & ' Results:', & '', & ' T', & ' The example will print .true. unless you are using a platform where default', & ' real variables are unusually padded.', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' STORAGE_SIZE(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 c_sizeof(3fortran)', & ''] shortname="c_sizeof" call process() case('69','date_and_time') textblock=[character(len=256) :: & '', & 'date_and_time(3fortran) date_and_time(3fortran)', & '', & '', & '', & 'NAME', & ' DATE_AND_TIME(3) - [SYSTEM:TIME] Gets current date time', & '', & '', & 'SYNOPSIS', & ' call date_and_time( [date] [,time] [,zone] [,values] )', & '', & ' subroutine date_and_time(date, time, zone, values)', & '', & ' character(len=8),intent(out),optional :: date', & ' character(len=10),intent(out),optional :: time', & ' character(len=5),intent(out),optional :: zone', & ' integer,intent(out),optional :: values(8)', & '', & '', & 'CHARACTERISTICS', & ' o *date is a default character scalar', & '', & ' o *time is a default character scalar', & '', & ' o *zone is a default character scalar', & '', & ' o VALUES is a rank-one array of type integer with a decimal exponent range', & ' of at least four.', & '', & 'DESCRIPTION', & ' DATE_AND_TIME(3) gets the corresponding date and time information from the', & ' real-time system clock.', & '', & ' Unavailable time and date character parameters return blanks.', & '', & ' Unavailable numeric parameters return -HUGE(VALUE).', & '', & ' These forms are compatible with the representations defined in ISO', & ' 8601:2004. UTC is established by the International Bureau of Weights and', & ' Measures (BIPM, i.e. Bureau International des Poids et Mesures) and the', & ' International Earth Rotation Service (IERS).', & '', & 'OPTIONS', & ' o DATE : A character string of default kind of the form CCYYMMDD, of length', & ' 8 or larger, where', & '', & ' + CCYY is the year in the Gregorian calendar', & ' + MM is the month within the year', & ' + DD is the day within the month.', & '', & ' The characters of this value are all decimal digits.', & '', & ' If there is no date available, DATE is assigned all blanks.', & '', & ' o TIME : A character string of default kind of the form HHMMSS.SSS, of', & ' length 10 or larger, where', & '', & ' o hh is the hour of the day,', & '', & ' o mm is the minutes of the hour,', & '', & ' o and ss.sss is the seconds and milliseconds of the minute.', & '', & ' Except for the decimal point, the characters of this value shall all be', & ' decimal digits.', & '', & ' If there is no clock available, TIME is assigned all blanks.', & '', & ' o ZONE : A string of the form (+-)HHMM, of length 5 or larger, representing', & ' the difference with respect to Coordinated Universal Time (UTC), where', & '', & ' o hh and mm are the time difference with respect to Coordinated', & ' Universal Time (UTC) in hours and minutes, respectively.', & '', & ' The characters of this value following the sign character are all decimal', & ' digits.', & '', & ' If this information is not available, ZONE is assigned all blanks.', & '', & ' o VALUES : An array of at least eight elements. If there is no data', & ' available for a value it is set to -HUGE(VALUES). Otherwise, it contains:', & '', & ' o VALUES(1) : The year, including the century.', & '', & ' o VALUES(2) : The month of the year', & '', & ' o VALUES(3) : The day of the month', & '', & ' o VALUES(4) : Time difference in minutes between the reported time and', & ' UTC time.', & '', & ' o VALUES(5) : The hour of the day, in the range 0 to 23.', & '', & ' o VALUES(6) : The minutes of the hour, in the range 0 to 59', & '', & ' o VALUES(7) : The seconds of the minute, in the range 0 to 60', & '', & ' o VALUES(8) : The milliseconds of the second, in the range 0 to 999.', & '', & ' The date, clock, and time zone information might be available on some images', & ' and not others. If the date, clock, or time zone information is available on', & ' more than one image, it is processor dependent whether or not those images', & ' share the same information.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_date_and_time', & ' implicit none', & ' character(len=8) :: date', & ' character(len=10) :: time', & ' character(len=5) :: zone', & ' integer,dimension(8) :: values', & '', & ' call date_and_time(date,time,zone,values)', & '', & ' ! using keyword arguments', & ' call date_and_time(DATE=date,TIME=time,ZONE=zone)', & ' print ''(*(g0))'',''DATE="'',date,''" TIME="'',time,''" ZONE="'',zone,''"''', & '', & ' call date_and_time(VALUES=values)', & ' write(*,''(i5,a)'') &', & ' & values(1),'' - The year'', &', & ' & values(2),'' - The month'', &', & ' & values(3),'' - The day of the month'', &', & ' & values(4),'' - Time difference with UTC in minutes'', &', & ' & values(5),'' - The hour of the day'', &', & ' & values(6),'' - The minutes of the hour'', &', & ' & values(7),'' - The seconds of the minute'', &', & ' & values(8),'' - The milliseconds of the second''', & ' end program demo_date_and_time', & '', & ' Results:', & '', & ' > DATE="20201222" TIME="165738.779" ZONE="-0500"', & ' > 2020 - The year', & ' > 12 - The month', & ' > 22 - The day of the month', & ' > -300 - Time difference with UTC in minutes', & ' > 16 - The hour of the day', & ' > 57 - The minutes of the hour', & ' > 38 - The seconds of the minute', & ' > 779 - The milliseconds of the second', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' CPU_TIME(3), SYSTEM_CLOCK(3)', & '', & 'RESOURCES', & ' date and time conversion, formatting and computation', & '', & ' o M_time - https://github.com/urbanjost/M_time', & '', & ' o fortran-datetime https://github.com/dongli/fortran-datetime', & '', & ' o datetime-fortran - https://github.com/wavebitscientific/datetime-fortran', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 date_and_time(3fortran)', & ''] shortname="date_and_time" call process() case('70','dble') textblock=[character(len=256) :: & '', & 'dble(3fortran) dble(3fortran)', & '', & '', & '', & 'NAME', & ' DBLE(3) - [TYPE:NUMERIC] Converstion to double precision real', & '', & '', & 'SYNOPSIS', & ' result = dble(a)', & '', & ' elemental doubleprecision function dble(a)', & '', & ' doubleprecision :: dble', & ' TYPE(kind=KIND),intent(in) :: a', & '', & '', & 'CHARACTERISTICS', & ' o A my be integer, real, complex, or a BOZ-literal-constant', & '', & ' o the result is a doubleprecision real.', & '', & 'DESCRIPTION', & ' DBLE(3) Converts A to double precision real type.', & '', & 'OPTIONS', & ' o A : a value to convert to a doubleprecision real.', & '', & 'RESULT', & ' The return value is of type doubleprecision. For complex input, the returned', & ' value has the magnitude and sign of the real component of the input value.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_dble', & ' implicit none', & ' real:: x = 2.18', & ' integer :: i = 5', & ' complex :: z = (2.3,1.14)', & ' print *, dble(x), dble(i), dble(z)', & ' end program demo_dble', & '', & ' Results:', & '', & ' 2.1800000667572021 5.0000000000000000 2.2999999523162842', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' o AIMAG(3) - Imaginary part of complex number', & '', & ' o CMPLX(3) - Convert values to a complex type', & '', & ' o INT(3) - Truncate towards zero and convert to integer', & '', & ' o NINT(3) - Nearest whole number', & '', & ' o OUT_OF_RANGE(3) - Whether a value cannot be converted safely.', & '', & ' o REAL(3) - Convert to real type', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 dble(3fortran)', & ''] shortname="dble" call process() case('71','digits') textblock=[character(len=256) :: & '', & 'digits(3fortran) digits(3fortran)', & '', & '', & '', & 'NAME', & ' DIGITS(3) - [NUMERIC MODEL] Significant digits in the numeric model', & '', & '', & 'SYNOPSIS', & ' result = digits(x)', & '', & ' integer function digits(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x(..)', & '', & '', & 'CHARACTERISTICS', & ' o X an integer or real scalar or array', & '', & ' o The return value is an integer of default kind.', & '', & 'DESCRIPTION', & ' DIGITS(3) returns the number of significant digits of the internal model', & ' representation of X. For example, on a system using a 32-bit floating point', & ' representation, a default real number would likely return 24.', & '', & 'OPTIONS', & ' o X : a value of the type and kind to query', & '', & 'RESULT', & ' The number of significant digits in a variable of the type and kind of X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_digits', & ' implicit none', & ' integer :: i = 12345', & ' real :: x = 3.143', & ' doubleprecision :: y = 2.33d0', & ' print *,''default integer:'', digits(i)', & ' print *,''default real: '', digits(x)', & ' print *,''default doubleprecision:'', digits(y)', & ' end program demo_digits', & '', & ' Results:', & '', & ' > default integer: 31', & ' > default real: 24', & ' > default doubleprecision: 53', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3),', & ' SCALE(3), SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 digits(3fortran)', & ''] shortname="digits" call process() case('72','dim') textblock=[character(len=256) :: & '', & 'dim(3fortran) dim(3fortran)', & '', & '', & '', & 'NAME', & ' DIM(3) - [NUMERIC] Positive difference of X - Y', & '', & '', & 'SYNOPSIS', & ' result = dim(x, y)', & '', & ' elemental TYPE(kind=KIND) function dim(x, y )', & '', & ' TYPE(kind=KIND),intent(in) :: x, y', & '', & '', & 'CHARACTERISTICS', & ' o X and Y may be any real or integer but of the same type and kind', & '', & ' o the result is of the same type and kind as the arguments', & '', & 'DESCRIPTION', & ' DIM(3) returns the maximum of X - Y and zero. That is, it returns the', & ' difference X - Y if the result is positive; otherwise it returns zero. It', & ' is equivalent to', & '', & ' max(0,x-y)', & '', & '', & 'OPTIONS', & ' o X : the subtrahend, ie. the number being subtracted from.', & '', & ' o Y : the minuend; ie. the number being subtracted', & '', & 'RESULT', & ' Returns the difference X - Y or zero, whichever is larger.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_dim', & ' use, intrinsic :: iso_fortran_env, only : real64', & ' implicit none', & ' integer :: i', & ' real(kind=real64) :: x', & '', & ' ! basic usage', & ' i = dim(4, 15)', & ' x = dim(4.321_real64, 1.111_real64)', & ' print *, i', & ' print *, x', & '', & ' ! elemental', & ' print *, dim([1,2,3],2)', & ' print *, dim([1,2,3],[3,2,1])', & ' print *, dim(-10,[0,-10,-20])', & '', & ' end program demo_dim', & '', & ' Results:', & '', & ' > 0', & ' > 3.21000000000000', & ' > 0 0 1', & ' > 0 0 2', & ' > 0 0 10', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 dim(3fortran)', & ''] shortname="dim" call process() case('73','dot_product') textblock=[character(len=256) :: & '', & 'dot_product(3fortran) dot_product(3fortran)', & '', & '', & '', & 'NAME', & ' DOT_PRODUCT(3) - [TRANSFORMATIONAL] Dot product of two vectors', & '', & '', & 'SYNOPSIS', & ' result = dot_product(vector_a, vector_b)', & '', & ' TYPE(kind=KIND) function dot_product(vector_a, vector_b)', & '', & ' TYPE(kind=KIND),intent(in) :: vector_a(:)', & ' TYPE(kind=KIND),intent(in) :: vector_b(:)', & '', & '', & 'CHARACTERISTICS', & ' o VECTOR_A, VECTOR_B may be any numeric or logical type array of rank one', & ' of the same size', & '', & ' o the two vectors need not be of the same kind, but both must be logical or', & ' numeric for any given call.', & '', & ' o the result is the same type and kind of the vector that is the higher', & ' type that the other vector is optionally promoted to if they differ.', & '', & ' The two vectors may be either numeric or logical and must be arrays of rank', & ' one and of equal size.', & '', & 'DESCRIPTION', & ' DOT_PRODUCT(3) computes the dot product multiplication of two vectors', & ' VECTOR_A and VECTOR_B.', & '', & 'OPTIONS', & ' o VECTOR_A : A rank 1 vector of values', & '', & ' o VECTOR_B : The type shall be numeric if VECTOR_A is of numeric type or', & ' logical if vector_a is of type logical. vector_b shall be a rank-one', & ' array of the same size as VECTOR_A.', & '', & 'RESULT', & ' If the arguments are numeric, the return value is a scalar of numeric type.', & ' If the arguments are logical, the return value is .true. or .false..', & '', & ' If the vectors are integer or real, the result is', & '', & ' sum(vector_a*vector_b)', & '', & ' If the vectors are complex, the result is', & '', & ' sum(conjg(vector_a)*vector_b)**', & '', & ' If the vectors are logical, the result is', & '', & ' any(vector_a .and. vector_b)', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_dot_prod', & ' implicit none', & ' integer, dimension(3) :: a, b', & ' a = [ 1, 2, 3 ]', & ' b = [ 4, 5, 6 ]', & ' print ''(3i3)'', a', & ' print *', & ' print ''(3i3)'', b', & ' print *', & ' print *, dot_product(a,b)', & ' end program demo_dot_prod', & '', & ' Results:', & '', & ' > 1 2 3', & ' >', & ' > 4 5 6', & ' >', & ' > 32', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' SUM(3), CONJG(3), ANY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 dot_product(3fortran)', & ''] shortname="dot_product" call process() case('74','dprod') textblock=[character(len=256) :: & '', & 'dprod(3fortran) dprod(3fortran)', & '', & '', & '', & 'NAME', & ' DPROD(3) - [NUMERIC] Double precision real product', & '', & '', & 'SYNOPSIS', & ' result = dprod(x,y)', & '', & ' elemental function dprod(x,y)', & '', & ' real,intent(in) :: x', & ' real,intent(in) :: y', & ' doubleprecision :: dprod', & '', & '', & 'CHARACTERISTICS', & ' o X is a default real.', & '', & ' o Y is a default real.', & '', & ' o the result is a doubleprecision real.', & '', & ' The setting of compiler options specifying the size of a default real can', & ' affect this function.', & '', & 'DESCRIPTION', & ' DPROD(3) produces a doubleprecision product of default real values X and Y.', & '', & ' That is, it is expected to convert the arguments to double precision before', & ' multiplying, which a simple expression X*Y would not be required to do. This', & ' can be significant in specialized computations requiring high precision.', & '', & ' The result has a value equal to a processor-dependent approximation to the', & ' product of X and Y. Note it is recommended in the standard that the', & ' processor compute the product in double precision, rather than in single', & ' precision then converted to double precision; but is only a recommendation.', & '', & 'OPTIONS', & ' o X : the multiplier', & '', & ' o Y : the multiplicand', & '', & 'RESULT', & ' The returned value of the product should have the same value as', & ' DBLE(X)*DBLE(Y).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_dprod', & ' implicit none', & ' integer,parameter :: dp=kind(0.0d0)', & ' real :: x = 5.2', & ' real :: y = 2.3', & ' doubleprecision :: xx', & ' real(kind=dp) :: dd', & '', & ' print *,''algebraically 5.2 x 2.3 is exactly 11.96''', & ' print *,''as floating point values results may differ slightly:''', & ' ! basic usage', & ' dd = dprod(x,y)', & ' print *, ''compare dprod(xy)='',dd, &', & ' & ''to x*y='',x*y, &', & ' & ''to dble(x)*dble(y)='',dble(x)*dble(y)', & '', & ' print *,''test if an expected result is produced''', & ' xx=-6.0d0', & ' write(*,*)DPROD(-3.0, 2.0),xx', & ' write(*,*)merge(''PASSED'',''FAILED'',DPROD(-3.0, 2.0) == xx)', & '', & ' print *,''elemental''', & ' print *, dprod( [2.3,3.4,4.5], 10.0 )', & ' print *, dprod( [2.3,3.4,4.5], [9.8,7.6,5.4] )', & '', & ' end program demo_dprod', & '', & ' Results: (this can vary between programming environments):', & '', & ' > algebraically 5.2 x 2.3 is exactly 11.96', & ' > as floating point values results may differ slightly:', & ' > compare dprod(xy)= 11.9599993133545 to x*y= 11.96000', & ' > to dble(x)*dble(y)= 11.9599993133545', & ' > test if an expected result is produced', & ' > -6.00000000000000 -6.00000000000000', & ' > PASSED', & ' > elemental', & ' > 22.9999995231628 34.0000009536743 45.0000000000000', & ' > 22.5399999713898 25.8400004005432 24.3000004291534', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' DBLE(3) REAL(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 dprod(3fortran)', & ''] shortname="dprod" call process() case('75','dshiftl') textblock=[character(len=256) :: & '', & 'dshiftl(3fortran) dshiftl(3fortran)', & '', & '', & '', & 'NAME', & ' DSHIFTL(3) - [BIT:COPY] Combined left shift of the bits of two integers', & '', & '', & 'SYNOPSIS', & ' result = dshiftl(i, j, shift)', & '', & ' elemental integer(kind=KIND) function dshiftl(i, j, shift)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=KIND),intent(in) :: j', & ' integer(kind=**),intent(in) :: shift', & '', & '', & 'CHARACTERISTICS', & ' o the kind of I, J, and the return value are the same. An exception is that', & ' one of I and J may be a BOZ literal constant (A BOZ literal constant is a', & ' binary, octal or hex constant).', & '', & ' o If either I or J is a BOZ-literal-constant (but not both), it is first', & ' converted as if by the intrinsic function INT(3) to type integer with the', & ' kind type parameter of the other.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' DSHIFTL(3) combines bits of I and J. The rightmost SHIFT bits of the result', & ' are the leftmost SHIFT bits of J, and the remaining bits are the rightmost', & ' BITSIZE(I)-SHIFT of I.', & '', & ' Hence DSHIFTL is designated as a "combined left shift", because it is like', & ' we appended I and J together, shifted it SHIFT bits to the left, and then', & ' kept the same number of bits as I or J had.', & '', & ' For example, for two 16-bit values if SHIFT=6', & '', & ' SHIFT=6', & ' I = 1111111111111111', & ' J = 0000000000000000', & ' COMBINED 11111111111111110000000000000000', & ' DROP LEFT BITS 11111111110000000000000000', & ' KEEP LEFT 16 1111111111000000', & '', & '', & 'NOTE', & ' This is equivalent to', & '', & ' ior( shiftl(i, shift), shiftr(j, bit_size(j) - shift) )', & '', & ' Also note that using this last representation of the operation is can be', & ' derived that when both I and J have the same value as in', & '', & ' dshiftl(i, i, shift)', & '', & ' the result has the same value as a circular shift:', & '', & ' ishftc(i, shift)', & '', & '', & 'OPTIONS', & ' o I : used to define the left pattern of bits in the combined pattern', & '', & ' o J : used for the right pattern of bits in the combined pattern', & '', & ' o SHIFT : shall be nonnegative and less than or equal to the number of bits', & ' in an integer input value (ie. the bit size of either one that is not a', & ' BOZ literal constant).', & '', & 'RESULT', & ' The leftmost SHIFT bits of J are copied to the rightmost bits of the result,', & ' and the remaining bits are the rightmost bits of I.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_dshiftl', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int32) :: i, j', & ' integer :: shift', & '', & ' ! basic usage', & ' write(*,*) dshiftl (1, 2**30, 2) ! int32 values on little-endian => 5', & '', & ' ! print some simple calls as binary to better visual the results', & ' i=-1', & ' j=0', & ' shift=5', & ' call printit()', & '', & ' ! the leftmost SHIFT bits of J are copied to the rightmost result bits', & ' j=int(b"11111000000000000000000000000000")', & ' ! and the other bits are the rightmost bits of I', & ' i=int(b"00000000000000000000000000000000")', & ' call printit()', & '', & ' j=int(b"11111000000000000000000000000000")', & ' i=int(b"00000111111111111111111111111111")', & ' ! result should be all 1s', & ' call printit()', & '', & ' contains', & ' subroutine printit()', & ' ! print i,j,shift and then i,j, and the result as binary values', & ' write(*,''(*(g0))'')''I='',i,'' J='',j,'' SHIFT='',shift', & ' write(*,''(b32.32)'') i,j, dshiftl (i, j, shift)', & ' end subroutine printit', & '', & ' end program demo_dshiftl', & '', & ' Results:', & '', & ' > 5', & ' > I=-1 J=0 SHIFT=5', & ' > 11111111111111111111111111111111', & ' > 00000000000000000000000000000000', & ' > 11111111111111111111111111100000', & ' > I=0 J=-134217728 SHIFT=5', & ' > 00000000000000000000000000000000', & ' > 11111000000000000000000000000000', & ' > 00000000000000000000000000011111', & ' > I=134217727 J=-134217728 SHIFT=5', & ' > 00000111111111111111111111111111', & ' > 11111000000000000000000000000000', & ' > 11111111111111111111111111111111', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' DSHIFTR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 dshiftl(3fortran)', & ''] shortname="dshiftl" call process() case('76','dshiftr') textblock=[character(len=256) :: & '', & 'dshiftr(3fortran) dshiftr(3fortran)', & '', & '', & '', & 'NAME', & ' DSHIFTR(3) - [BIT:COPY] Combined right shift of the bits of two integers', & '', & '', & 'SYNOPSIS', & ' result = dshiftr(i, j, shift)', & '', & ' elemental integer(kind=KIND) function dshiftr(i, j, shift)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=KIND),intent(in) :: j', & ' integer(kind=**),intent(in) :: shift', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any kind value for the integer type', & '', & ' o the kind of I, J, and the return value are the same. An exception is that', & ' one of I and J may be a BOZ literal constant (A BOZ literal constant is a', & ' binary, octal or hex constant).', & '', & ' o If either I or J is a BOZ-literal-constant, it is first converted as if', & ' by the intrinsic function INT(3) to type integer with the kind type', & ' parameter of the other.', & '', & 'DESCRIPTION', & ' DSHIFTR(3) combines bits of I and J. The leftmost SHIFT bits of the result', & ' are the rightmost SHIFT bits of I, and the remaining bits are the leftmost', & ' bits of J.', & '', & ' It may be thought of as appending the bits of I and J, dropping off the', & ' SHIFT rightmost bits, and then retaining the same number of rightmost bits', & ' as an input value, hence the name "combined right shift"...', & '', & ' Given two 16-bit values labeled alphabetically ...', & '', & ' i=ABCDEFGHIJKLMNOP', & ' j=abcdefghijklmnop', & '', & ' Append them together', & '', & ' ABCDEFGHIJKLMNOPabcdefghijklmnop', & '', & ' Shift them N=6 bits to the right dropping off bits', & '', & ' ABCDEFGHIJKLMNOPabcdefghij', & '', & ' Keep the 16 right-most bits', & '', & ' KLMNOPabcdefghij', & '', & '', & 'NOTE', & ' DSHIFR(I,J,SHIFT) is equivalent to', & '', & ' ior(shiftl (i, bit_size(i) - shift), shiftr(j, shift) )', & '', & ' it can also be seen that if I and J have the same value', & '', & ' dshiftr( i, i, shift )', & '', & ' this has the same result as a negative circular shift', & '', & ' ishftc( i, -shift ).', & '', & '', & 'OPTIONS', & ' o I : left value of the pair of values to be combine-shifted right', & '', & ' o J : right value of the pair of values to be combine-shifted right', & '', & ' o SHIFT : the shift value is non-negative and less than or equal to the', & ' number of bits in an input value as can be computed by BIT_SIZE(3).', & '', & 'RESULT', & ' The result is a combined right shift of I and J that is the same as the bit', & ' patterns of the inputs being combined left to right, dropping off SHIFT bits', & ' on the right and then retaining the same number of bits as an input value', & ' from the rightmost bits.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_dshiftr', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int32) :: i, j', & ' integer :: shift', & '', & ' ! basic usage', & ' write(*,*) dshiftr (1, 2**30, 2)', & '', & ' ! print some calls as binary to better visualize the results', & ' i=-1', & ' j=0', & ' shift=5', & '', & ' ! print values', & ' write(*,''(*(g0))'')''I='',i,'' J='',j,'' SHIFT='',shift', & ' write(*,''(b32.32)'') i,j, dshiftr (i, j, shift)', & '', & ' ! visualizing a "combined right shift" ...', & ' i=int(b"00000000000000000000000000011111")', & ' j=int(b"11111111111111111111111111100000")', & ' ! appended together ( i//j )', & ' ! 0000000000000000000000000001111111111111111111111111111111100000', & ' ! shifted right SHIFT values dropping off shifted values', & ' ! 00000000000000000000000000011111111111111111111111111111111', & ' ! keep enough rightmost bits to fill the kind', & ' ! 11111111111111111111111111111111', & ' ! so the result should be all 1s bits ...', & '', & ' write(*,''(*(g0))'')''I='',i,'' J='',j,'' SHIFT='',shift', & ' write(*,''(b32.32)'') i,j, dshiftr (i, j, shift)', & '', & ' end program demo_dshiftr', & '', & ' Results:', & '', & ' > 1342177280', & ' > I=-1 J=0 SHIFT=5', & ' > 11111111111111111111111111111111', & ' > 00000000000000000000000000000000', & ' > 11111000000000000000000000000000', & ' > I=31 J=-32 SHIFT=5', & ' > 00000000000000000000000000011111', & ' > 11111111111111111111111111100000', & ' > 11111111111111111111111111111111', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' DSHIFTL(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 dshiftr(3fortran)', & ''] shortname="dshiftr" call process() case('77','eoshift') textblock=[character(len=256) :: & '', & 'eoshift(3fortran) eoshift(3fortran)', & '', & '', & '', & 'NAME', & ' EOSHIFT(3) - [TRANSFORMATIONAL] End-off shift of elements of an array', & '', & '', & 'SYNOPSIS', & ' result = eoshift( array, shift [,boundary] [,dim] )', & '', & ' type(TYPE(kind=KIND)) function eoshift(array,shift,boundary,dim)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: array(..)', & ' integer(kind=**),intent(in) :: shift(..)', & ' type(TYPE(kind=KIND)),intent(in) :: boundary(..)', & ' integer(kind=**),intent(in) :: dim', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY an array of any type', & '', & ' o SHIFT is an integer of any kind. It may be a scalar. If the rank of ARRAY', & ' is greater than one, and DIM is specified it is the same shape as ARRAY', & ' reduced by removing dimension DIM.', & '', & ' o BOUNDARY May be a scalar of the same type and kind as ARRAY. It must be a', & ' scalar when ARRAY has a rank of one. Otherwise, it may be an array of the', & ' same shape as ARRAY reduced by dimension DIM. It may only be absent for', & ' certain types, as described below.', & '', & ' o DIM is an integer of any kind. It defaults to one.', & '', & ' o the result has the same type, type parameters, and shape as ARRAY.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o The result is an array of same type, kind and rank as the ARRAY argument.', & '', & 'DESCRIPTION', & ' EOSHIFT(3) performs an end-off shift on elements of ARRAY along the', & ' dimension of DIM.', & '', & ' Elements shifted out one end of each rank one section are dropped.', & '', & ' If BOUNDARY is present then the corresponding value from BOUNDARY is copied', & ' back in the other end, else default values are used.', & '', & 'OPTIONS', & ' o ARRAY : array of any type whose elements are to be shifted. If the rank', & ' of ARRAY is one, then all elements of ARRAY are shifted by SHIFT places.', & ' If rank is greater than one, then all complete rank one sections of ARRAY', & ' along the given dimension are shifted.', & '', & ' o SHIFT : the number of elements to shift. A negative value shifts to the', & ' right, a positive value to the left of the vector(s) being shifted.', & '', & ' o BOUNDARY : the value to use to fill in the elements vacated by the shift.', & ' If BOUNDARY is not present then the following are copied in depending on', & ' the type of ARRAY.', & '', & ' Array Type | Boundary Value', & ' -----------------------------------------------------', & ' Numeric | 0, 0.0, or (0.0, 0.0) of the type and kind of "array"', & ' Logical | .false.', & ' Character(len)| LEN blanks', & '', & ' These are the only types for which BOUNDARY may not be present. For these', & ' types the kind is converted as neccessary to the kind of ARRAY.', & '', & ' o DIM : DIM is in the range of', & '', & ' 1 <= DIM <= n', & '', & ' where "N" is the rank of ARRAY. If DIM is omitted it is taken to be 1.', & '', & 'RESULT', & ' Returns an array of the same characteristics as the input with the specified', & ' number of elements dropped off along the specified direction indicated,', & ' backfilling the vacated elements with a value indicated by the BOUNDARY', & ' value.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_eoshift', & ' implicit none', & ' integer, dimension(3,3) :: a', & ' integer :: i', & '', & ' a = reshape( [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ], [ 3, 3 ])', & ' print ''(3i3)'', (a(i,:),i=1,3)', & '', & ' print *', & '', & ' ! shift it', & ' a = eoshift(a, SHIFT=[1, 2, 1], BOUNDARY=-5, DIM=2)', & ' print ''(3i3)'', (a(i,:),i=1,3)', & '', & ' end program demo_eoshift', & '', & ' Results:', & '', & ' > 1 4 7', & ' > 2 5 8', & ' > 3 6 9', & ' >', & ' > 4 7 -5', & ' > 8 -5 -5', & ' > 6 9 -5', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DSHIFTR(3), DSHIFTL(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 eoshift(3fortran)', & ''] shortname="eoshift" call process() case('78','epsilon') textblock=[character(len=256) :: & '', & 'epsilon(3fortran) epsilon(3fortran)', & '', & '', & '', & 'NAME', & ' EPSILON(3) - [NUMERIC MODEL] Epsilon function', & '', & '', & 'SYNOPSIS', & ' result = epsilon(x)', & '', & ' real(kind=kind(x)) function epsilon(x)', & '', & ' real(kind=kind(x),intent(in) :: x(..)', & '', & '', & 'CHARACTERISTICS', & ' o X shall be of type real. It may be a scalar or an array.', & '', & ' o the result is a scalar of the same type and kind type parameter as X.', & '', & 'DESCRIPTION', & ' EPSILON(3) returns the floating point relative accuracy. It is the nearly', & ' negligible number relative to 1 such that 1+ LITTLE_NUMBER is not equal to', & ' 1; or more precisely', & '', & ' real( 1.0, kind(x)) + epsilon(x) /= real( 1.0, kind(x))', & '', & ' It may be thought of as the distance from 1.0 to the next largest floating', & ' point number.', & '', & ' One use of EPSILON(3) is to select a delta value for algorithms that search', & ' until the calculation is within delta of an estimate.', & '', & ' If delta is too small the algorithm might never halt, as a computation', & ' summing values smaller than the decimal resolution of the data type does not', & ' change.', & '', & 'OPTIONS', & ' o X : The type shall be real.', & '', & 'RESULT', & ' The return value is of the same type as the argument.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_epsilon', & ' use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32', & ' implicit none', & ' real(kind=sp) :: x = 3.143', & ' real(kind=dp) :: y = 2.33d0', & '', & ' ! so if x is of type real32, epsilon(x) has the value 2**-23', & ' print *, epsilon(x)', & ' ! note just the type and kind of x matter, not the value', & ' print *, epsilon(huge(x))', & ' print *, epsilon(tiny(x))', & '', & ' ! the value changes with the kind of the real value though', & ' print *, epsilon(y)', & '', & ' ! adding and subtracting epsilon(x) changes x', & ' write(*,*)x == x + epsilon(x)', & ' write(*,*)x == x - epsilon(x)', & '', & ' ! these next two comparisons will be .true. !', & ' write(*,*)x == x + epsilon(x) * 0.999999', & ' write(*,*)x == x - epsilon(x) * 0.999999', & '', & ' ! you can calculate epsilon(1.0d0)', & ' write(*,*)my_dp_eps()', & '', & ' contains', & '', & ' function my_dp_eps()', & ' ! calculate the epsilon value of a machine the hard way', & ' real(kind=dp) :: t', & ' real(kind=dp) :: my_dp_eps', & '', & ' ! starting with a value of 1, keep dividing the value', & ' ! by 2 until no change is detected. Note that with', & ' ! infinite precision this would be an infinite loop,', & ' ! but floating point values in Fortran have a defined', & ' ! and limited precision.', & ' my_dp_eps = 1.0d0', & ' SET_ST: do', & ' my_dp_eps = my_dp_eps/2.0d0', & ' t = 1.0d0 + my_dp_eps', & ' if (t <= 1.0d0) exit', & ' enddo SET_ST', & ' my_dp_eps = 2.0d0*my_dp_eps', & '', & ' end function my_dp_eps', & ' end program demo_epsilon', & '', & ' Results:', & '', & ' 1.1920929E-07', & ' 1.1920929E-07', & ' 1.1920929E-07', & ' 2.220446049250313E-016', & '', & ' F', & ' F', & ' T', & ' T', & ' 2.220446049250313E-016', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3),', & ' SCALE(3), SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 epsilon(3fortran)', & ''] shortname="epsilon" call process() case('79','erf') textblock=[character(len=256) :: & '', & 'erf(3fortran) erf(3fortran)', & '', & '', & '', & 'NAME', & ' ERF(3) - [MATHEMATICS] Error function', & '', & '', & 'SYNOPSIS', & ' result = erf(x)', & '', & ' elemental real(kind=KIND) function erf(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is of type real', & '', & ' o The result is of the same type and kind as X.', & '', & 'DESCRIPTION', & ' ERF(3) computes the error function of X, defined as', & '', & ' $$ \text{erf}(x) = \frac{2}{\sqrt{\pi}} \int_0^x e^{-T^2} dt. $$', & '', & 'OPTIONS', & ' o X : The type shall be real.', & '', & 'RESULT', & ' The return value is of type real, of the same kind as X and lies in the', & ' range -1 <= ERF(x) <= 1 .', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_erf', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 0.17_real64', & ' write(*,*)x, erf(x)', & ' end program demo_erf', & '', & ' Results:', & '', & ' 0.17000000000000001 0.18999246120180879', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' ERFC(3), ERF_SCALED(3)', & '', & 'RESOURCES', & ' o Wikipedia:error function', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 erf(3fortran)', & ''] shortname="erf" call process() case('80','erfc') textblock=[character(len=256) :: & '', & 'erfc(3fortran) erfc(3fortran)', & '', & '', & '', & 'NAME', & ' ERFC(3) - [MATHEMATICS] Complementary error function', & '', & '', & 'SYNOPSIS', & ' result = erfc(x)', & '', & ' elemental real(kind=KIND) function erfc(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is of type real and any valid kind', & '', & ' o KIND is any value valid for type real', & '', & ' o the result has the same characteristics as X', & '', & 'DESCRIPTION', & ' ERFC(3) computes the complementary error function of X. Simply put this is', & ' equivalent to 1 - ERF(X), but ERFC is provided because of the extreme loss', & ' of relative accuracy if ERF(X) is called for large X and the result is', & ' subtracted from 1.', & '', & ' ERFC(X) is defined as', & '', & ' $$ \text{erfc}(x) = 1 - \text{erf}(x) = 1 - \frac{2}{\sqrt{\pi}}', & ' \int_x^{\infty} e^{-t^2} dt. $$', & '', & 'OPTIONS', & ' o X : The type shall be real.', & '', & 'RESULT', & ' The return value is of type real and of the same kind as X. It lies in the', & ' range', & '', & ' 0 \<= **erfc**(x) \<= 2.', & '', & ' and is a processor-dependent approximation to the complementary error', & ' function of X ( **1-erf(x) ).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_erfc', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & real_kinds, real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 0.17_real64', & ' write(*,''(*(g0))'')''X='',x, '' ERFC(X)='',erfc(x)', & ' write(*,''(*(g0))'')''equivalently 1-ERF(X)='',1-erf(x)', & ' end program demo_erfc', & '', & ' Results:', & '', & ' > X=.1700000000000000 ERFC(X)=.8100075387981912', & ' > equivalently 1-ERF(X)=.8100075387981912', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' ERF(3) ERF_SCALED(3)', & '', & 'RESOURCES', & ' o Wikipedia:error function', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 erfc(3fortran)', & ''] shortname="erfc" call process() case('81','erfc_scaled') textblock=[character(len=256) :: & '', & 'erfc_scaled(3fortran) erfc_scaled(3fortran)', & '', & '', & '', & 'NAME', & ' ERFC_SCALED(3) - [MATHEMATICS] Scaled complementary error function', & '', & '', & 'SYNOPSIS', & ' result = erfc_scaled(x)', & '', & ' elemental real(kind=KIND) function erfc_scaled(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is of type real of any valid kind', & '', & ' o KIND is any kind valid for a real type', & '', & ' o the result has the same characteristics as X', & '', & 'DESCRIPTION', & ' ERFC_SCALED(3) computes the exponentially-scaled complementary error', & ' function of X:', & '', & ' $$ e^{x^2} \frac{2}{\sqrt{\pi}} \int_{x}^{\infty} e^{-t^2} dt. $$', & '', & ' erfc_scaled(x)=exp(x*x)erfc(x)', & '', & ' NOTE1', & '', & ' The complementary error function is asymptotic to exp(-X2)/(X/PI). As such', & ' it underflows at approximately X >= 9 when using ISO/IEC/IEEE 60559:2011', & ' single precision arithmetic. The exponentially-scaled complementary error', & ' function is asymptotic to 1/(X PI). As such it does not underflow until X >', & ' HUGE (X)/PI.', & '', & 'OPTIONS', & ' o X the value to apply the ERFC function to', & '', & 'RESULT', & ' The approximation to the exponentially-scaled complementary error function', & ' of X', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_erfc_scaled', & ' implicit none', & ' real(kind(0.0d0)) :: x = 0.17d0', & ' x = erfc_scaled(x)', & ' print *, x', & ' end program demo_erfc_scaled', & '', & ' Results:', & '', & ' > 0.833758302149981', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' ERF(3), EXP(3), ERFC(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 erfc_scaled(3fortran)', & ''] shortname="erfc_scaled" call process() case('82','event_query') textblock=[character(len=256) :: & '', & 'event_query(3fortran) event_query(3fortran)', & '', & '', & '', & 'NAME', & ' EVENT_QUERY(3) - [COLLECTIVE] Query whether a coarray event has occurred', & '', & '', & 'SYNOPSIS', & ' call event_query(event, count [,stat] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' EVENT_QUERY(3) assigns the number of events to COUNT which have been posted', & ' to the EVENT variable and not yet been removed by calling EVENT_WAIT. When', & ' STAT is present and the invocation was successful, it is assigned the value', & ' 0. If it is present and the invocation has failed, it is assigned a positive', & ' value and COUNT is assigned the value -1.', & '', & 'OPTIONS', & ' o EVENT : (intent(in)) Scalar of type event_type, defined in', & ' iso_fortran_env; shall not be coindexed.', & '', & ' o COUNT : (intent(out))Scalar integer with at least the precision of', & ' default integer.', & '', & ' o STAT : (OPTIONAL) Scalar default-kind integer variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_event_query', & ' use iso_fortran_env', & ' implicit none', & ' type(event_type) :: event_value_has_been_set[*]', & ' integer :: cnt', & ' if (this_image() == 1) then', & ' call event_query(event_value_has_been_set, cnt)', & ' if (cnt > 0) write(*,*) "Value has been set"', & ' elseif (this_image() == 2) then', & ' event post(event_value_has_been_set[1])', & ' endif', & ' end program demo_event_query', & '', & '', & 'STANDARD', & ' TS 18508', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 event_query(3fortran)', & ''] shortname="event_query" call process() case('83','execute_command_line') textblock=[character(len=256) :: & '', & 'execute_command_line(3fortran) execute_command_line(3fortran)', & '', & '', & '', & 'NAME', & ' EXECUTE_COMMAND_LINE(3) - [SYSTEM:PROCESSES] Execute a shell command', & '', & '', & 'SYNOPSIS', & ' call execute_command_line( & & command [,wait] [,exitstat] [,cmdstat]', & ' [,cmdmsg] )', & '', & ' subroutine execute_command_line(command,wait,exitstat,cmdstat,cmdmsg)', & '', & ' character(len=*),intent(in) :: command', & ' logical,intent(in),optional :: wait', & ' integer,intent(inout),optional :: exitstat', & ' integer,intent(inout),optional :: cmdstat', & ' character(len=*),intent(inout),optional :: cmdmsg', & '', & '', & 'CHARACTERISTICS', & ' o COMMAND is a default character scalar', & '', & ' o WAIT is a default logical scalar. If WAIT is present with the', & '', & ' o EXITSTAT is an integer of the default kind. It must be of a kind with at', & ' least a decimal exponent range of 9.', & '', & ' o CMDSTAT is an integer of default kind The kind of the variable must', & ' support at least a decimal exponent range of four.', & '', & ' o CMDMSG is a character scalar of the default kind.', & '', & 'DESCRIPTION', & ' For EXECUTE_COMMAND_LINE(3) the COMMAND argument is passed to the shell and', & ' executed. (The shell is generally SH(1) on Unix systems, and cmd.exe on', & ' Windows.) If WAIT is present and has the value .false., the execution of the', & ' command is asynchronous if the system supports it; otherwise, the command is', & ' executed synchronously.', & '', & ' The three last arguments allow the user to get status information. After', & ' synchronous execution, EXITSTAT contains the integer exit code of the', & ' command, as returned by SYSTEM. CMDSTAT is set to zero if the command line', & ' was executed (whatever its exit status was). CMDMSG is assigned an error', & ' message if an error has occurred.', & '', & ' Note that the system call need not be thread-safe. It is the responsibility', & ' of the user to ensure that the system is not called concurrently if', & ' required.', & '', & ' When the command is executed synchronously, EXECUTE_COMMAND_LINE returns', & ' after the command line has completed execution. Otherwise,', & ' EXECUTE_COMMAND_LINE returns without waiting.', & '', & ' Because this intrinsic is making a system call, it is very system dependent.', & ' Its behavior with respect to signaling is processor dependent. In', & ' particular, on POSIX-compliant systems, the SIGINT and SIGQUIT signals will', & ' be ignored, and the SIGCHLD will be blocked. As such, if the parent process', & ' is terminated, the child process might not be terminated alongside.', & '', & ' One of the most common causes of errors is that the program requested is not', & ' in the search path. You should make sure that the program to be executed is', & ' installed on your system and that it is in the system''s path when the', & ' program calls it. You can check if it is installed by running it from the', & ' command prompt. If it runs successfully from the command prompt, it means', & ' that it is installed, and so you should next check that it is in the search', & ' path when the program executes (usually this means checking the environment', & ' variable PATH).', & '', & 'OPTIONS', & ' o COMMAND : the command line to be executed. The interpretation is', & ' programming-environment dependent.', & '', & ' o WAIT : If WAIT is present with the value .false., and the processor', & ' supports asynchronous execution of the command, the command is executed', & ' asynchronously; otherwise it is executed synchronously.', & '', & ' When the command is executed synchronously, EXECUTE_COMMAND_LINE(3)', & ' returns after the command line has completed execution. Otherwise,', & ' EXECUTE_COMMAND_LINE(3) returns without waiting.', & '', & ' o EXITSTAT : If the command is executed synchronously, it is assigned the', & ' value of the processor-dependent exit status. Otherwise, the value of', & ' EXITSTAT is unchanged.', & '', & ' o CMDSTAT : If an error condition occurs and CMDSTAT is not present, error', & ' termination of execution of the image is initiated.', & '', & ' It is assigned the value -1 if the processor does not support command', & ' line execution, a processor-dependent positive value if an error', & ' condition occurs, or the value -2 if no error condition occurs but WAIT', & ' is present with the value false and the processor does not support', & ' asynchronous execution. Otherwise it is assigned the value 0.', & '', & ' o CMDMSG : If an error condition occurs, it is assigned a processor-', & ' dependent explanatory message. Otherwise, it is unchanged.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_exec', & ' implicit none', & ' integer :: i', & '', & ' call execute_command_line("external_prog.exe", exitstat=i)', & ' print *, "Exit status of external_prog.exe was ", i', & '', & ' call execute_command_line("reindex_files.exe", wait=.false.)', & ' print *, "Now reindexing files in the background"', & ' end program demo_exec', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' GET_ENVIRONMENT_VARIABLE(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 execute_command_line(3fortran)', & ''] shortname="execute_command_line" call process() case('84','exp') textblock=[character(len=256) :: & '', & 'exp(3fortran) exp(3fortran)', & '', & '', & '', & 'NAME', & ' EXP(3) - [MATHEMATICS] Base-e exponential function', & '', & '', & 'SYNOPSIS', & ' result = exp(x)', & '', & ' elemental TYPE(kind=KIND) function exp(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be real or complex of any kind.', & '', & ' o The return value has the same type and kind as X.', & '', & 'DESCRIPTION', & ' EXP(3) returns the value of e (the base of natural logarithms) raised to the', & ' power of X.', & '', & ' "e" is also known as Euler''s constant.', & '', & ' If X is of type complex, its imaginary part is regarded as a value in', & ' radians such that if (see Euler''s formula):', & '', & ' cx=(re,im)', & '', & ' then', & '', & ' exp(cx) = exp(re) * cmplx(cos(im),sin(im),kind=kind(cx))', & '', & ' Since EXP(3) is the inverse function of LOG(3) the maximum valid magnitude', & ' of the real component of X is LOG(HUGE(X)).', & '', & 'OPTIONS', & ' o X : The type shall be real or complex.', & '', & 'RESULT', & ' The value of the result is E**X where E is Euler''s constant.', & '', & ' If X is of type complex, its imaginary part is regarded as a value in', & ' radians.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_exp', & ' implicit none', & ' real :: x, re, im', & ' complex :: cx', & '', & ' x = 1.0', & ' write(*,*)"Euler''s constant is approximately",exp(x)', & '', & ' !! complex values', & ' ! given', & ' re=3.0', & ' im=4.0', & ' cx=cmplx(re,im)', & '', & ' ! complex results from complex arguments are Related to Euler''s formula', & ' write(*,*)''given the complex value '',cx', & ' write(*,*)''exp(x) is'',exp(cx)', & ' write(*,*)''is the same as'',exp(re)*cmplx(cos(im),sin(im),kind=kind(cx))', & '', & ' ! exp(3) is the inverse function of log(3) so', & ' ! the real component of the input must be less than or equal to', & ' write(*,*)''maximum real component'',log(huge(0.0))', & ' ! or for double precision', & ' write(*,*)''maximum doubleprecision component'',log(huge(0.0d0))', & '', & ' ! but since the imaginary component is passed to the cos(3) and sin(3)', & ' ! functions the imaginary component can be any real value', & '', & ' end program demo_exp', & '', & ' Results:', & '', & ' Euler''s constant is approximately 2.718282', & ' given the complex value (3.000000,4.000000)', & ' exp(x) is (-13.12878,-15.20078)', & ' is the same as (-13.12878,-15.20078)', & ' maximum real component 88.72284', & ' maximum doubleprecision component 709.782712893384', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' o LOG(3)', & '', & 'RESOURCES', & ' o Wikipedia:Exponential function', & '', & ' o Wikipedia:Euler''s formula', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 exp(3fortran)', & ''] shortname="exp" call process() case('85','exponent') textblock=[character(len=256) :: & '', & 'exponent(3fortran) exponent(3fortran)', & '', & '', & '', & 'NAME', & ' EXPONENT(3) - [MODEL_COMPONENTS] Exponent of floating-point number', & '', & '', & 'SYNOPSIS', & ' result = exponent(x)', & '', & ' elemental integer function exponent(x)', & '', & ' real(kind=**),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X shall be of type real of any valid kind', & '', & ' o the result is a default integer type', & '', & 'DESCRIPTION', & ' EXPONENT(3) returns the value of the exponent part of X, provided the', & ' exponent is within the range of default integers.', & '', & 'OPTIONS', & ' o X : the value to query the exponent of', & '', & 'RESULT', & ' EXPONENT(3) returns the value of the exponent part of X', & '', & ' If X is zero the value returned is zero.', & '', & ' If X is an IEEE infinity or NaN, the result has the value HUGE(0).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_exponent', & ' implicit none', & ' real :: x = 1.0', & ' integer :: i', & ' i = exponent(x)', & ' print *, i', & ' print *, exponent(0.0)', & ' print *, exponent([10.0,100.0,1000.0,-10000.0])', & ' ! beware of overflow, it may occur silently', & ' !print *, 2**[10.0,100.0,1000.0,-10000.0]', & ' print *, exponent(huge(0.0))', & ' print *, exponent(tiny(0.0))', & ' end program demo_exponent', & '', & ' Results:', & '', & ' > 4 7 10 14', & ' > 128', & ' > -125', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), FRACTION(3), HUGE(3), MAXEXPONENT(3), MINEXPONENT(3),', & ' NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 exponent(3fortran)', & ''] shortname="exponent" call process() case('86','extends_type_of') textblock=[character(len=256) :: & '', & 'extends_type_of(3fortran) extends_type_of(3fortran)', & '', & '', & '', & 'NAME', & ' EXTENDS_TYPE_OF(3) - [STATE:INQUIRY] Determine if the dynamic type of A is', & ' an extension of the dynamic type of MOLD.', & '', & '', & 'SYNOPSIS', & ' result = extends_type_of(a, mold)', & '', & ' logical extends_type_of(a, mold)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: a', & ' type(TYPE(kind=KIND)),intent(in) :: mold', & '', & '', & 'CHARACTERISTICS', & ' -A shall be an object or pointer to an extensible declared type, or', & ' unlimited polymorphic. If it is a polymorphic pointer, it shall not have an', & ' undefined association status. -MOLE shall be an object or pointer to an', & ' extensible declared type or unlimited polymorphic. If it is a polymorphic', & ' pointer, it shall not have an undefined association status.', & '', & ' o the result is a scalar default logical type.', & '', & 'DESCRIPTION', & ' EXTENDS_TYPE_OF(3) is .true. if and only if the dynamic type of A is or', & ' could be (for unlimited polymorphic) an extension of the dynamic type of', & ' MOLD.', & '', & ' NOTE1', & '', & ' The dynamic type of a disassociated pointer or unallocated allocatable', & ' variable is its declared type.', & '', & ' NOTE2', & '', & ' The test performed by EXTENDS_TYPE_OF is not the same as the test performed', & ' by the type guard CLASS IS. The test performed by EXTENDS_TYPE_OF does not', & ' consider kind type parameters.', & '', & 'OPTIONS', & ' o A : be an object of extensible declared type or unlimited polymorphic. If', & ' it is a polymorphic pointer, it shall not have an undefined association', & ' status.', & '', & ' o MOLD : be an object of extensible declared type or unlimited polymorphic.', & ' If it is a polymorphic pointer, it shall not have an undefined', & ' association status.', & '', & 'RESULT', & ' If MOLD is unlimited polymorphic and is either a disassociated pointer or', & ' unallocated allocatable variable, the result is true.', & '', & ' Otherwise if A is unlimited polymorphic and is either a disassociated', & ' pointer or unallocated allocatable variable, the result is false.', & '', & ' Otherwise the result is true if and only if the dynamic type of A', & '', & ' if the dynamic type of A or MOLD is extensible, the result is true if and', & ' only if the dynamic type of A is an extension type of the dynamic type of', & ' MOLD; otherwise the result is processor dependent.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' ! program demo_extends_type_of', & ' module M_demo_extends_type_of', & ' implicit none', & ' private', & '', & ' type nothing', & ' end type nothing', & '', & ' type, extends(nothing) :: dot', & ' real :: x=0', & ' real :: y=0', & ' end type dot', & '', & ' type, extends(dot) :: point', & ' real :: z=0', & ' end type point', & '', & ' type something_else', & ' end type something_else', & '', & ' public :: nothing', & ' public :: dot', & ' public :: point', & ' public :: something_else', & '', & ' end module M_demo_extends_type_of', & '', & ' program demo_extends_type_of', & ' use M_demo_extends_type_of, only : nothing, dot, point, something_else', & ' implicit none', & ' type(nothing) :: grandpa', & ' type(dot) :: dad', & ' type(point) :: me', & ' type(something_else) :: alien', & '', & ' write(*,*)''these should all be true''', & ' write(*,*)extends_type_of(me,grandpa),''I am descended from Grandpa''', & ' write(*,*)extends_type_of(dad,grandpa),''Dad is descended from Grandpa''', & ' write(*,*)extends_type_of(me,dad),''Dad is my ancestor''', & '', & ' write(*,*)''is an object an extension of itself?''', & ' write(*,*)extends_type_of(grandpa,grandpa) ,''self-propagating!''', & ' write(*,*)extends_type_of(dad,dad) ,''clone!''', & '', & ' write(*,*)'' you did not father your grandfather''', & ' write(*,*)extends_type_of(grandpa,dad),''no paradox here''', & '', & ' write(*,*)extends_type_of(dad,me),''no paradox here''', & ' write(*,*)extends_type_of(grandpa,me),''no relation whatsoever''', & ' write(*,*)extends_type_of(grandpa,alien),''no relation''', & ' write(*,*)extends_type_of(me,alien),''not what everyone thinks''', & '', & ' call pointers()', & ' contains', & '', & ' subroutine pointers()', & ' ! Given the declarations and assignments', & ' type t1', & ' real c', & ' end type', & ' type, extends(t1) :: t2', & ' end type', & ' class(t1), pointer :: p, q', & ' allocate (p)', & ' allocate (t2 :: q)', & ' ! the result of EXTENDS_TYPE_OF (P, Q) will be false, and the result', & ' ! of EXTENDS_TYPE_OF (Q, P) will be true.', & ' write(*,*)''(P,Q)'',extends_type_of(p,q),"mind your P''s and Q''s"', & ' write(*,*)''(Q,P)'',extends_type_of(q,p)', & ' end subroutine pointers', & '', & ' end program demo_extends_type_of', & '', & ' Results:', & '', & ' these should all be true', & ' T I am descended from Grandpa', & ' T Dad is descended from Grandpa', & ' T Dad is my ancestor', & ' is an object an extension of itself?', & ' T self-propagating!', & ' T clone!', & ' you did not father your grandfather', & ' F no paradox here', & ' F no paradox here', & ' F no relation whatsoever', & ' F no relation', & ' F not what everyone thinks', & ' (P,Q) F mind your P''s and Q''s', & ' (Q,P) T', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' SAME_TYPE_AS(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 extends_type_of(3fortran)', & ''] shortname="extends_type_of" call process() case('87','findloc') textblock=[character(len=256) :: & '', & 'findloc(3fortran) findloc(3fortran)', & '', & '', & '', & 'NAME', & ' FINDLOC(3) - [ARRAY:LOCATION] Location of first element of ARRAY identified', & ' by MASK along dimension DIM matching a target value', & '', & '', & 'SYNOPSIS', & ' result = findloc (array, value, dim [,mask] [,kind] [,back]) | findloc', & ' (array, value [,mask] [,kind] [,back])', & '', & ' function findloc (array, value, dim, mask, kind, back)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: array(..)', & ' type(TYPE(kind=KIND)),intent(in) :: value', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & ' integer(kind=**),intent(in),optional :: kind', & ' logical(kind=**),intent(in),optional :: back', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY is an array of any intrinsic type.', & '', & ' o VALUE shall be scalar but in type conformance with ARRAY, as specified', & ' for the operator == or the operator .EQV..', & '', & ' o DIM an integer corresponding to a dimension of ARRAY. The corresponding', & ' actual argument shall not be an optional dummy argument.', & '', & ' o MASK is logical and shall be conformable with ARRAY.', & '', & ' o KIND a scalar integer initialization expression (ie. a constant)', & '', & ' o BACK a logical scalar.', & '', & ' o the result is integer of default kind or kind KIND if the KIND argument', & ' is present. If DIM does not appear, the result is an array of rank one', & ' and of size equal to the rank of ARRAY; otherwise, the result is an array', & ' of the same rank and shape as ARRAY reduced by the dimension DIM.', & '', & ' NOTE: a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' FINDLOC(3) returns the location of the first element of ARRAY identified by', & ' MASK along dimension DIM having a value equal to VALUE.', & '', & ' If both ARRAY and VALUE are of type logical, the comparison is performed', & ' with the .EQV. operator; otherwise, the comparison is performed with the ==', & ' operator. If the value of the comparison is .true., that element of ARRAY', & ' matches VALUE.', & '', & ' If only one element matches VALUE, that element''s subscripts are returned.', & ' Otherwise, if more than one element matches VALUE and BACK is absent or', & ' present with the value .false., the element whose subscripts are returned is', & ' the first such element, taken in array element order. If BACK is present', & ' with the value .true., the element whose subscripts are returned is the last', & ' such element, taken in array element order.', & '', & 'OPTIONS', & ' o ARRAY : shall be an array of intrinsic type.', & '', & ' o VALUE : shall be scalar and in type conformance with ARRAY.', & '', & ' o DIM : shall be an integer scalar with a value in the range 1 <= DIM <= n,', & ' where n is the rank of ARRAY. The corresponding actual argument shall not', & ' be an optional dummy argument.', & '', & ' o MASK : (optional) shall be of type logical and shall be conformable with', & ' ARRAY.', & '', & ' o KIND : (optional) shall be a scalar integer initialization expression.', & '', & ' o BACK : (optional) shall be a logical scalar.', & '', & 'RESULT', & ' KIND is present, the kind type parameter is that specified by the value of', & ' KIND; otherwise the kind type parameter is that of default integer type. If', & ' DIM does not appear, the result is an array of rank one and of size equal to', & ' the rank of ARRAY; otherwise, the result is of rank n - 1 and shape', & '', & ' [d1, d2, . . ., dDIM-1, dDIM+1, . . ., dn ]', & '', & ' where', & '', & ' [d1, d2, . . ., dn ]', & '', & ' is the shape of ARRAY.', & '', & 'RESULT', & ' o CASE (I): The result of FINDLOC (ARRAY, VALUE) is a rank-one array whose', & ' element values are the values of the subscripts of an element of ARRAY', & ' whose value matches VALUE. If there is such a value, the ith subscript', & ' returned lies in the range 1 to ei, where ei is the extent of the ith', & ' dimension of ARRAY. If no elements match VALUE or ARRAY has size zero,', & ' all elements of the result are zero.', & '', & ' o CASE (II): the result of FINDLOC (ARRAY, VALUE, MASK = MASK) is a rank-', & ' one array whose element values are the values of the subscripts of an', & ' element of ARRAY, corresponding to a true element of MASK, whose value', & ' matches VALUE. If there is such a value, the ith subscript returned lies', & ' in the range 1 to ei, where ei is the extent of the ith dimension of', & ' ARRAY. If no elements match VALUE, ARRAY has size zero, or every element', & ' of MASK has the value false, all elements of the result are zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_findloc', & ' logical,parameter :: T=.true., F=.false.', & ' integer,allocatable :: ibox(:,:)', & ' logical,allocatable :: mask(:,:)', & ' ! basics', & ' ! the first element matching the value is returned AS AN ARRAY', & ' call printi(''== 6'',findloc ([2, 6, 4, 6], value = 6))', & ' call printi(''== 6'',findloc ([2, 6, 4, 6], value = 6,back=.true.))', & ' ! the first element matching the value is returned AS A SCALAR', & ' call printi(''== 6'',findloc ([2, 6, 4, 6], value = 6,dim=1))', & ' call printi(''== 6'',findloc ([2, 6, 4, 6], value = 6,back=.true.,dim=1))', & '', & ' ibox=reshape([ 0,-5, 7, 7, &', & ' 3, 4, -1, 2, &', & ' 1, 5, 6, 7] ,shape=[3,4],order=[2,1])', & '', & ' mask=reshape([ T, T, F, T, &', & ' T, T, F, T, &', & ' T, T, F, T] ,shape=[3,4],order=[2,1])', & '', & ' call printi(''array is'', ibox )', & ' call printl(''mask is'', mask )', & ' print *, ''so for == 7 and back=.false.''', & ' call printi(''so for == 7 the address of the element is'', &', & ' & findloc (ibox, 7, mask = mask) )', & ' print *, ''so for == 7 and back=.true.''', & ' call printi(''so for == 7 the address of the element is'', &', & ' & findloc (ibox, 7, mask = mask, back=.true.) )', & '', & ' print *,''This is independent of declared lower bounds for the array''', & '', & ' print *, '' using dim=N''', & ' ibox=reshape([ 1, 2, -9, &', & ' 2, 2, 6 ] ,shape=[2,3],order=[2,1])', & '', & ' call printi(''array is'', ibox )', & ' ! has the value [2, 1, 0] and', & ' call printi('''',findloc (ibox, value = 2, dim = 1) )', & ' ! has the value [2, 1].', & ' call printi('''',findloc (ibox, value = 2, dim = 2) )', & ' contains', & ' ! GENERIC ROUTINES TO PRINT MATRICES', & ' subroutine printl(title,a)', & ' implicit none', & ' !@(#) print small 2d logical scalar, vector, matrix in row-column format', & ' character(len=*),intent(in) :: title', & ' logical,intent(in) :: a(..)', & '', & ' character(len=*),parameter :: row=''(" > [ ",*(l1:,","))''', & ' character(len=*),parameter :: all=''(" ",*(g0,1x))''', & ' logical,allocatable :: b(:,:)', & ' integer :: i', & ' write(*,all,advance=''no'')trim(title)', & ' ! copy everything to a matrix to keep code simple', & ' select rank(a)', & ' rank (0); write(*,''(a)'')'' (a scalar)''; b=reshape([a],[1,1])', & ' rank (1); write(*,''(a)'')'' (a vector)''; b=reshape(a,[size(a),1])', & ' rank (2); write(*,''(a)'')'' (a matrix)''; b=a', & ' rank default; stop ''*printl* unexpected rank''', & ' end select', & ' do i=1,size(b,dim=1)', & ' write(*,fmt=row,advance=''no'')b(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' write(*,all) ''>shape='',shape(a),'',rank='',rank(a),'',size='',size(a)', & ' write(*,*)', & ' end subroutine printl', & '', & ' subroutine printi(title,a)', & ' implicit none', & ' !@(#) print small 2d integer scalar, vector, matrix in row-column format', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: a(..)', & ' character(len=*),parameter :: all=''(" ",*(g0,1x))''', & ' character(len=20) :: row', & ' integer,allocatable :: b(:,:)', & ' integer :: i', & ' write(*,all,advance=''no'')trim(title)', & ' ! copy everything to a matrix to keep code simple', & ' select rank(a)', & ' rank (0); write(*,''(a)'')'' (a scalar)''; b=reshape([a],[1,1])', & ' rank (1); write(*,''(a)'')'' (a vector)''; b=reshape(a,[size(a),1])', & ' rank (2); write(*,''(a)'')'' (a matrix)''; b=a', & ' rank default; stop ''*printi* unexpected rank''', & ' end select', & ' ! find how many characters to use for integers', & ' write(row,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(b))))))+2', & ' ! use this format to write a row', & ' row=''(" > [",*(i''//trim(row)//'':,","))''', & ' do i=1,size(b,dim=1)', & ' write(*,fmt=row,advance=''no'')b(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' write(*,all) ''>shape='',shape(a),'',rank='',rank(a),'',size='',size(a)', & ' write(*,*)', & ' end subroutine printi', & ' end program demo_findloc', & '', & ' Results:', & '', & ' > == 6 (a vector)', & ' > > [ 2 ]', & ' > >shape= 1 ,rank= 1 ,size= 1', & ' >', & ' > == 6 (a vector)', & ' > > [ 4 ]', & ' > >shape= 1 ,rank= 1 ,size= 1', & ' >', & ' > == 6 (a scalar)', & ' > > [ 2 ]', & ' > >shape= ,rank= 0 ,size= 1', & ' >', & ' > == 6 (a scalar)', & ' > > [ 4 ]', & ' > >shape= ,rank= 0 ,size= 1', & ' >', & ' > array is (a matrix)', & ' > > [ 0, -5, 7, 7 ]', & ' > > [ 3, 4, -1, 2 ]', & ' > > [ 1, 5, 6, 7 ]', & ' > >shape= 3 4 ,rank= 2 ,size= 12', & ' >', & ' > mask is (a matrix)', & ' > > [ T,T,F,T ]', & ' > > [ T,T,F,T ]', & ' > > [ T,T,F,T ]', & ' > >shape= 3 4 ,rank= 2 ,size= 12', & ' >', & ' > so for == 7 and back=.false.', & ' > so for == 7 the address of the element is (a vector)', & ' > > [ 1 ]', & ' > > [ 4 ]', & ' > >shape= 2 ,rank= 1 ,size= 2', & ' >', & ' > so for == 7 and back=.true.', & ' > so for == 7 the address of the element is (a vector)', & ' > > [ 3 ]', & ' > > [ 4 ]', & ' > >shape= 2 ,rank= 1 ,size= 2', & ' >', & ' > This is independent of declared lower bounds for the array', & ' > using dim=N', & ' > array is (a matrix)', & ' > > [ 1, 2, -9 ]', & ' > > [ 2, 2, 6 ]', & ' > >shape= 2 3 ,rank= 2 ,size= 6', & ' >', & ' > (a vector)', & ' > > [ 2 ]', & ' > > [ 1 ]', & ' > > [ 0 ]', & ' > >shape= 3 ,rank= 1 ,size= 3', & ' >', & ' > (a vector)', & ' > > [ 2 ]', & ' > > [ 1 ]', & ' > >shape= 2 ,rank= 1 ,size= 2', & ' >', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o MAXLOC(3) - Location of the maximum value within an array', & '', & ' o MINLOC(3) - Location of the minimum value within an array', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 findloc(3fortran)', & ''] shortname="findloc" call process() case('88','floor') textblock=[character(len=256) :: & '', & 'floor(3fortran) floor(3fortran)', & '', & '', & '', & 'NAME', & ' FLOOR(3) - [NUMERIC] Function to return largest integral value not greater', & ' than argument', & '', & '', & 'SYNOPSIS', & ' result = floor(a [,kind])', & '', & ' elemental integer(kind=KIND) function floor( a ,kind )', & '', & ' real(kind=**),intent(in) :: a', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o A is a real of any kind', & '', & ' o KIND is any valid value for type integer.', & '', & ' o the result is an integer of the specified or default kind', & '', & 'DESCRIPTION', & ' FLOOR(3) returns the greatest integer less than or equal to A.', & '', & ' In other words, it picks the whole number at or to the left of the value on', & ' the number line.', & '', & ' This means care has to be taken that the magnitude of the real value A does', & ' not exceed the range of the output value, as the range of values supported', & ' by real values is typically larger than the range for integers.', & '', & 'OPTIONS', & ' o A : The value to operate on. Valid values are restricted by the size of', & ' the returned integer kind to the range -HUGE(INT(A,KIND=KIND))-1 to', & ' HUGE(INT(A),KIND=KIND).', & '', & ' o KIND : A scalar integer constant initialization expression indicating the', & ' kind parameter of the result.', & '', & 'RESULT', & ' The return value is of type integer(kind) if KIND is present and of default-', & ' kind integer otherwise.', & '', & ' The result is undefined if it cannot be represented in the specified integer', & ' type.', & '', & ' If in range for the kind of the result the result is the whole number at or', & ' to the left of the input value on the number line.', & '', & ' If A is positive the result is the value with the fractional part removed.', & '', & ' If A is negative, it is the whole number at or to the left of the input', & ' value.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_floor', & ' implicit none', & ' real :: x = 63.29', & ' real :: y = -63.59', & ' print *, x, floor(x)', & ' print *, y, floor(y)', & ' ! elemental', & ' print *,floor([ &', & ' & -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &', & ' & 0.0, &', & ' & +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ])', & '', & ' ! note even a small deviation from the whole number changes the result', & ' print *, [2.0,2.0-epsilon(0.0),2.0-2*epsilon(0.0)]', & ' print *,floor([2.0,2.0-epsilon(0.0),2.0-2*epsilon(0.0)])', & '', & ' ! A=Nan, Infinity or huge(0_KIND) is undefined', & ' end program demo_floor', & '', & ' Results:', & '', & ' > 63.29000 63', & ' > -63.59000 -64', & ' > -3 -3 -3 -2 -2 -1', & ' > -1 0 0 1 1 2', & ' > 2 2 2', & ' > 2.000000 2.000000 2.000000', & ' > 2 1 1', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' CEILING(3), NINT(3), AINT(3), ANINT(3), INT(3), SELECTED_INT_KIND(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 floor(3fortran)', & ''] shortname="floor" call process() case('89','flush') textblock=[character(len=256) :: & '', & 'flush(7fortran) flush(7fortran)', & '', & '', & '', & 'NAME', & ' flush(7f) - [FORTRAN:IO] flush I/O buffers of specified files', & '', & '', & 'SYNOPSIS', & ' flush file-unit-number', & ' flush([UNIT=]file_unit_number,[iostat=i],[iomsg=str],[err=label_number])', & '', & 'DESCRIPTION', & ' I/O statements can buffer output before delivering it to the host system in', & ' order to minimize the overhead of system calls. Use FLUSH(7F) to deliver any', & ' such pending I/O for the identified file to the host system.', & '', & ' This is generally not required accept to ensure critical information is', & ' displayed or written as reliably as possible or to synchronise data from', & ' different units going to the same device. Do not arbitrarily flush all I/O', & ' operations or programs using large amounts of I/O might experience', & ' significant performance degradation, particularly if the I/O is to a block-', & ' oriented device.', & '', & ' Note execution of a FLUSH(7F) statement performs a wait operation for all', & ' pending asynchronous data transfer operations for the specified unit.', & '', & ' More generally execution of a FLUSH(7F) statement causes data written to an', & ' external file not only to be available to other processes, causes data', & ' placed in an external file by means other than Fortran to be available to a', & ' READ(7F) statement; but these actions are processor dependent.', & '', & ' Execution of a FLUSH(7F) statement for a file that is connected but does not', & ' exist is permitted and has no effect on any file.', & '', & ' A FLUSH(7F) statement has no effect on file position.', & '', & 'OPTIONS', & ' UNIT A file-unit-number is required; if the optional characters "UNIT=" are', & ' omitted, the unit-number must be the first item in the FLUSH(7) statement.', & '', & 'RETURNS', & ' IOSTAT : status variable. It is set to a processor-dependent positive value', & ' if an error occurs, to zero if the flush operation was successful, or to a', & ' processor-dependent negative value if the flush operation is not supported', & ' for the unit specified. IOMSG : character variable holding error description', & ' when iostat is not zero. ERR : The numeric line label of a target statement', & ' in the same scope as the FLUSH(7F) statement.', & '', & ' NOTE From the Fortran standard:', & '', & ' Because the Fortran standard does not specify the mechanism of file', & ' storage, the exact meaning of the flush operation is not precisely', & ' defined. It is expected that the flush operation will make all data', & ' written to a file available to other processes or devices, or make data', & ' recently added to a file by other processes or devices available to', & ' the program via a subsequent read operation. This is commonly called', & ' flushing input/output buffers.', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_flush', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & stderr=>ERROR_UNIT, &', & ' & stdin=>INPUT_UNIT, &', & ' & stdout=>OUTPUT_UNIT', & ' implicit none', & ' integer :: iostat', & ' character(len=255) :: iomsg', & ' flush (stderr, iostat=iostat, iomsg=iomsg)', & ' if(iostat.ne.0)then', & ' write(*,*)''ERROR:''//trim(iomsg)', & ' error stop 1', & ' endif', & ' flush (stdout, err = 999 )', & ' stop', & ' 999 continue', & ' stop 10', & ' end program demo_flush', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 flush(7fortran)', & ''] shortname="flush" call process() case('90','fraction') textblock=[character(len=256) :: & '', & 'fraction(3fortran) fraction(3fortran)', & '', & '', & '', & 'NAME', & ' FRACTION(3) - [MODEL_COMPONENTS] Fractional part of the model representation', & '', & '', & 'SYNOPSIS', & ' result = fraction(x)', & '', & ' elemental real(kind=KIND) function fraction(x)', & '', & ' real(kind=KIND),intent(in) :: fraction', & '', & '', & 'CHARACTERISTICS', & ' o X is of type real', & '', & ' o The result has the same characteristics as the argument.', & '', & 'DESCRIPTION', & ' FRACTION(3) returns the fractional part of the model representation of X.', & '', & 'OPTIONS', & ' o X : The value to interrogate', & '', & 'RESULT', & ' The fractional part of the model representation of X is returned; it is X *', & ' RADIX(X)**(-EXPONENT(X)).', & '', & ' If X has the value zero, the result is zero.', & '', & ' If X is an IEEE NaN, the result is that NaN.', & '', & ' If X is an IEEE infinity, the result is an IEEE NaN.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_fraction', & ' implicit none', & ' real :: x', & ' x = 178.1387e-4', & ' print *, fraction(x), x * radix(x)**(-exponent(x))', & ' end program demo_fraction', & '', & ' Results:', & '', & ' 0.5700439 0.5700439', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), HUGE(3), MAXEXPONENT(3), MINEXPONENT(3),', & ' NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 fraction(3fortran)', & ''] shortname="fraction" call process() case('91','gamma') textblock=[character(len=256) :: & '', & 'gamma(3fortran) gamma(3fortran)', & '', & '', & '', & 'NAME', & ' GAMMA(3) - [MATHEMATICS] Gamma function, which yields factorials for', & ' positive whole numbers', & '', & '', & 'SYNOPSIS', & ' result = gamma(x)', & '', & ' elemental real(kind=**) function gamma( x)', & '', & ' type(real,kind=**),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is a real value of any available KIND', & '', & ' o returns a real value with the same kind as X.', & '', & 'DESCRIPTION', & ' GAMMA(X) computes Gamma of X. For positive whole number values of N the', & ' Gamma function can be used to calculate factorials, as (N-1)! ==', & ' GAMMA(REAL(N)). That is', & '', & ' n! == gamma(real(n+1))', & '', & ' $$ \GAMMA(x) = \int_0**\infty t**{x-1}{\mathrm{e}}**{-T}\,{\mathrm{d}}t $$', & '', & 'OPTIONS', & ' o X : Shall be of type real and neither zero nor a negative integer.', & '', & 'RESULT', & ' The return value is of type real of the same kind as x. The result has a', & ' value equal to a processor-dependent approximation to the gamma function of', & ' X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_gamma', & ' use, intrinsic :: iso_fortran_env, only : wp=>real64, int64', & ' implicit none', & ' real :: x, xa(4)', & ' integer :: i, j', & '', & ' ! basic usage', & ' x = gamma(1.0)', & ' write(*,*)''gamma(1.0)='',x', & '', & ' ! elemental', & ' xa=gamma([1.0,2.0,3.0,4.0])', & ' write(*,*)xa', & ' write(*,*)', & '', & '', & ' ! gamma() is related to the factorial function', & ' do i = 1, 171', & ' ! check value is not too big for default integer type', & ' if (factorial(i) <= huge(0)) then', & ' write(*,*) i, nint(factorial(i)), ''integer''', & ' elseif (factorial(i) <= huge(0_int64)) then', & ' write(*,*) i, nint(factorial(i),kind=int64),''integer(kind=int64)''', & ' else', & ' write(*,*) i, factorial(i) , ''user factorial function''', & ' write(*,*) i, product([(real(j, kind=wp), j=1, i)]), ''product''', & ' write(*,*) i, gamma(real(i + 1, kind=wp)), ''gamma directly''', & ' endif', & ' enddo', & '', & '', & ' contains', & ' function factorial(i) result(f)', & ' ! GAMMA(X) computes Gamma of X. For positive whole number values of N the', & ' ! Gamma function can be used to calculate factorials, as (N-1)! ==', & ' ! GAMMA(REAL(N)). That is', & ' !', & ' ! n! == gamma(real(n+1))', & ' !', & ' integer, intent(in) :: i', & ' real(kind=wp) :: f', & ' if (i <= 0) then', & ' write(*,''(*(g0))'') '' gamma(3) function value '', i, '' <= 0''', & ' stop '' bad value in gamma function''', & ' endif', & ' f = anint(gamma(real(i + 1,kind=wp)))', & ' end function factorial', & '', & ' end program demo_gamma', & '', & ' Results:', & '', & ' > gamma(1.0)= 1.00000000', & ' > 1.00000000 1.00000000 2.00000000 6.00000000', & ' >', & ' > 1 1 integer', & ' > 2 2 integer', & ' > 3 6 integer', & ' > 4 24 integer', & ' > 5 120 integer', & ' > 6 720 integer', & ' > 7 5040 integer', & ' > 8 40320 integer', & ' > 9 362880 integer', & ' > 10 3628800 integer', & ' > 11 39916800 integer', & ' > 12 479001600 integer', & ' > 13 6227020800 integer(kind=int64)', & ' > 14 87178291200 integer(kind=int64)', & ' > 15 1307674368000 integer(kind=int64)', & ' > 16 20922789888000 integer(kind=int64)', & ' > 17 355687428096000 integer(kind=int64)', & ' > 18 6402373705728001 integer(kind=int64)', & ' > 19 121645100408832000 integer(kind=int64)', & ' > 20 2432902008176640000 integer(kind=int64)', & ' > 21 5.1090942171709440E+019 user factorial function', & ' > 21 5.1090942171709440E+019 product', & ' > 21 5.1090942171709440E+019 gamma directly', & ' > :', & ' > :', & ' > :', & ' > 170 7.2574156153079990E+306 user factorial function', & ' > 170 7.2574156153079940E+306 product', & ' > 170 7.2574156153079990E+306 gamma directly', & ' > 171 Infinity user factorial function', & ' > 171 Infinity product', & ' > 171 Infinity gamma directly', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' Logarithm of the Gamma function: LOG_GAMMA(3)', & '', & 'RESOURCES', & ' Wikipedia: Gamma_function', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 gamma(3fortran)', & ''] shortname="gamma" call process() case('92','get_command') textblock=[character(len=256) :: & '', & 'get_command(3fortran) get_command(3fortran)', & '', & '', & '', & 'NAME', & ' GET_COMMAND(3) - [SYSTEM:COMMAND LINE] Get the entire command line', & ' invocation', & '', & '', & 'SYNOPSIS', & ' call get_command([command] [,length] [,status] [,errmsg])', & '', & ' subroutine get_command( command ,length ,status, errmsg )', & '', & ' character(len=*),intent(out),optional :: command', & ' integer(kind=**),intent(out),optional :: length', & ' integer(kind=**),intent(out),optional :: status', & ' character(len=*),intent(inout),optional :: errmsg', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type meeting', & ' the conditions described herein.', & '', & ' o COMMAND and ERRMSG are scalar character variables of default kind.', & '', & ' o LENGTH and STATUS are scalar integer with a decimal exponent range of at', & ' least four.', & '', & 'DESCRIPTION', & ' GET_COMMAND(3) retrieves the entire command line that was used to invoke the', & ' program.', & '', & ' Note that what is typed on the command line is often processed by a shell.', & ' The shell typically processes special characters and white space before', & ' passing it to the program. The processing can typically be turned off by', & ' turning off globbing or quoting the command line arguments and/or changing', & ' the default field separators, but this should rarely be necessary.', & '', & 'RESULT', & ' o COMMAND : If COMMAND is present, the entire command line that was used to', & ' invoke the program is stored into it. If the command cannot be', & ' determined, COMMAND is assigned all blanks.', & '', & ' o LENGTH : If LENGTH is present, it is assigned the length of the command', & ' line. It is system-dependent as to whether trailing blanks will be', & ' counted. : If the command length cannot be determined, a length of 0 is', & ' assigned.', & '', & ' o STATUS : If STATUS is present, it is assigned 0 upon success of the', & ' command, -1 if COMMAND is too short to store the command line, or a', & ' positive value in case of an error.', & '', & ' o ERRMSG : It is assigned a processor-dependent explanatory message if the', & ' command retrieval fails. Otherwise, it is unchanged.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_get_command', & ' implicit none', & ' integer :: command_line_length', & ' character(len=:),allocatable :: command_line', & ' ! get command line length', & ' call get_command(length=command_line_length)', & ' ! allocate string big enough to hold command line', & ' allocate(character(len=command_line_length) :: command_line)', & ' ! get command line as a string', & ' call get_command(command=command_line)', & ' ! trim leading spaces just in case', & ' command_line=adjustl(command_line)', & ' write(*,''("OUTPUT:",a)'')command_line', & ' end program demo_get_command', & '', & ' Results:', & '', & ' # note that shell expansion removes some of the whitespace', & ' # without quotes', & ' ./test_get_command arguments on command line to echo', & '', & ' OUTPUT:./test_get_command arguments on command line to echo', & '', & ' # using the bash shell with single quotes', & ' ./test_get_command ''arguments *><`~[]!{}?"\''| ''', & '', & ' OUTPUT:./test_get_command arguments *><`~[]!{}?"''|', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' GET_COMMAND_ARGUMENT(3), COMMAND_ARGUMENT_COUNT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 get_command(3fortran)', & ''] shortname="get_command" call process() case('93','get_command_argument') textblock=[character(len=256) :: & '', & 'get_command_argument(3fortran) get_command_argument(3fortran)', & '', & '', & '', & 'NAME', & ' GET_COMMAND_ARGUMENT(3) - [SYSTEM:COMMAND LINE] Get command line arguments', & '', & '', & 'SYNOPSIS', & ' call get_command_argument(number [,value] [,length] & & [,status] [,errmsg])', & '', & ' subroutine get_command_argument( number, value, length, &', & ' & status ,errmsg)', & '', & ' integer(kind=**),intent(in) :: number', & ' character(len=*),intent(out),optional :: value', & ' integer(kind=**),intent(out),optional :: length', & ' integer(kind=**),intent(out),optional :: status', & ' character(len=*),intent(inout),optional :: errmsg', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type meeting', & ' the conditions described herein.', & '', & ' o NUMBER, LENGTH, and STATUS are scalar integer with a decimal exponent', & ' range of at least four.', & '', & ' o VALUE and ERRMSG are scalar character variables of default kind.', & '', & 'DESCRIPTION', & ' GET_COMMAND_ARGUMENT(3) retrieves or queries the n-th argument that was', & ' passed on the command line to the current program execution.', & '', & ' There is not anything specifically stated about what an argument is but in', & ' practice the arguments are strings split on whitespace unless the arguments', & ' are quoted. IFS values (Internal Field Separators) used by common shells are', & ' typically ignored and unquoted whitespace is almost always the separator.', & '', & ' Shells have often expanded command arguments and spell characters before', & ' passing them to the program, so the strings read are often not exactly what', & ' the user typed on the command line.', & '', & 'OPTIONS', & ' o NUMBER : is a non-negative number indicating which argument of the', & ' current program command line is to be retrieved or queried. : If NUMBER =', & ' 0, the argument pointed to is set to the name of the program (on systems', & ' that support this feature). : if the processor does not have such a', & ' concept as a command name the value of command argument 0 is processor', & ' dependent. : For values from 1 to the number of arguments passed to the', & ' program a value is returned in an order determined by the processor.', & ' Conventionally they are returned consecutively as they appear on the', & ' command line from left to right.', & '', & 'RESULT', & ' o VALUE : The VALUE argument holds the command line argument. If VALUE can', & ' not hold the argument, it is truncated to fit the length of VALUE. : If', & ' there are less than NUMBER arguments specified at the command line or if', & ' the argument specified does not exist for other reasons, VALUE will be', & ' filled with blanks.', & '', & ' o LENGTH : The LENGTH argument contains the length of the n-th command line', & ' argument. The length of VALUE has no effect on this value, It is the', & ' length required to hold all the significant characters of the argument', & ' regardless of how much storage is provided by VALUE.', & '', & ' o STATUS : If the argument retrieval fails, STATUS is a positive number; if', & ' VALUE contains a truncated command line argument, STATUS is -1; and', & ' otherwise the STATUS is zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_get_command_argument', & ' implicit none', & ' character(len=255) :: progname', & ' integer :: count, i, argument_length, istat', & ' character(len=:),allocatable :: arg', & '', & ' ! command name assuming it is less than 255 characters in length', & ' call get_command_argument (0, progname, status=istat)', & ' if (istat == 0) then', & ' print *, "The program''s name is " // trim (progname)', & ' else', & ' print *, "Could not get the program''s name " // trim (progname)', & ' endif', & '', & ' ! get number of arguments', & ' count = command_argument_count()', & ' write(*,*)''The number of arguments is '',count', & '', & ' !', & ' ! allocate string array big enough to hold command line', & ' ! argument strings and related information', & ' !', & ' do i=1,count', & ' call get_command_argument(number=i,length=argument_length)', & ' if(allocated(arg))deallocate(arg)', & ' allocate(character(len=argument_length) :: arg)', & ' call get_command_argument(i, arg,status=istat)', & ' ! show the results', & ' write (*,''(i3.3,1x,i0.5,1x,i0.5,1x,"[",a,"]")'') &', & ' & i,istat,argument_length,arg', & ' enddo', & '', & ' end program demo_get_command_argument', & '', & ' Results:', & '', & ' ./demo_get_command_argument a test ''of getting arguments '' " leading"', & '', & ' The program''s name is ./demo_get_command_argument', & ' The number of arguments is 4', & ' 001 00000 00001 [a]', & ' 002 00000 00004 [test]', & ' 003 00000 00022 [of getting arguments ]', & ' 004 00000 00008 [ leading]', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' GET_COMMAND(3), COMMAND_ARGUMENT_COUNT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 get_command_argument(3fortran)', & ''] shortname="get_command_argument" call process() case('94','get_environment_variable') textblock=[character(len=256) :: & '', & 'get_environment_variable(3fortran) get_environment_variable(3fortran)', & '', & '', & '', & 'NAME', & ' GET_ENVIRONMENT_VARIABLE(3) - [SYSTEM:ENVIRONMENT] Get value of an', & ' environment variable', & '', & '', & 'SYNOPSIS', & ' call get_environment_variable(name [,value] [,length] & & [,status]', & ' [,trim_name] [,errmsg] )', & '', & ' subroutine character(len=*) get_environment_variable( &', & ' & name, value, length, status, trim_name, errmsg )', & '', & ' character(len=*),intent(in) :: name', & ' character(len=*),intent(out),optional :: value', & ' integer(kind=**),intent(out),optional :: length', & ' integer(kind=**),intent(out),optional :: status', & ' logical,intent(out),optional :: trim_name', & ' character(len=*),intent(inout),optional :: errmsg', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type meeting', & ' the conditions described herein.', & '', & ' o NAME, VALUE, and ERRMSG are a scalar character of default kind.', & '', & ' o LENGTH and STATUS are integer scalars with a decimal exponent range of at', & ' least four.', & '', & ' o TRIM_NAME is a scalar of type logical and of default kind.', & '', & 'DESCRIPTION', & ' GET_ENVIRONMENT_VARIABLE(3) gets the VALUE of the environment variable NAME.', & '', & ' Note that GET_ENVIRONMENT_VARIABLE(3) need not be thread-safe. It is the', & ' responsibility of the user to ensure that the environment is not being', & ' updated concurrently.', & '', & ' If running in parallel be aware It is processor dependent whether an', & ' environment variable that exists on an image also exists on another image,', & ' and if it does exist on both images whether the values are the same or', & ' different.', & '', & 'OPTIONS', & ' o NAME : The name of the environment variable to query. The interpretation', & ' of case is processor dependent.', & '', & 'RESULT', & ' o VALUE : The value of the environment variable being queried. If VALUE is', & ' not large enough to hold the data, it is truncated. If the variable NAME', & ' is not set or has no value, or the processor does not support environment', & ' variables VALUE will be filled with blanks.', & '', & ' o LENGTH : Argument LENGTH contains the length needed for storing the', & ' environment variable NAME. It is zero if the environment variable is not', & ' set.', & '', & ' o STATUS : STATUS is -1 if VALUE is present but too short for the', & ' environment variable; it is 1 if the environment variable does not exist', & ' and 2 if the processor does not support environment variables; in all', & ' other cases STATUS is zero.', & '', & ' o TRIM_NAME : If TRIM_NAME is present with the value .false., the trailing', & ' blanks in NAME are significant; otherwise they are not part of the', & ' environment variable name.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_getenv', & ' implicit none', & ' character(len=:),allocatable :: homedir', & ' character(len=:),allocatable :: var', & '', & ' var=''HOME''', & ' homedir=get_env(var)', & ' write (*,''(a,"=""",a,"""")'')var,homedir', & '', & ' contains', & '', & ' function get_env(name,default) result(value)', & ' ! a function that makes calling get_environment_variable(3) simple', & ' implicit none', & ' character(len=*),intent(in) :: name', & ' character(len=*),intent(in),optional :: default', & ' character(len=:),allocatable :: value', & ' integer :: howbig', & ' integer :: stat', & ' integer :: length', & ' length=0', & ' value=''''', & ' if(name.ne.'''')then', & ' call get_environment_variable( name, &', & ' & length=howbig,status=stat,trim_name=.true.)', & ' select case (stat)', & ' case (1)', & ' print *, name, " is not defined in the environment. Strange..."', & ' value=''''', & ' case (2)', & ' print *, &', & ' "This processor does not support environment variables. Boooh!"', & ' value=''''', & ' case default', & ' ! make string of sufficient size to hold value', & ' if(allocated(value))deallocate(value)', & ' allocate(character(len=max(howbig,1)) :: value)', & ' ! get value', & ' call get_environment_variable( &', & ' & name,value,status=stat,trim_name=.true.)', & ' if(stat.ne.0)value=''''', & ' end select', & ' endif', & ' if(value.eq.''''.and.present(default))value=default', & ' end function get_env', & '', & ' end program demo_getenv', & '', & ' Typical Results:', & '', & ' HOME="/home/urbanjs"', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' GET_COMMAND_ARGUMENT(3), GET_COMMAND(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 20get_environment_variable(3fortran)', & ''] shortname="get_environment_variable" call process() case('95','huge') textblock=[character(len=256) :: & '', & 'huge(3fortran) huge(3fortran)', & '', & '', & '', & 'NAME', & ' HUGE(3) - [NUMERIC MODEL] Largest number of a type and kind', & '', & '', & 'SYNOPSIS', & ' result = huge(x)', & '', & ' TYPE(kind=KIND) function huge(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x(..)', & '', & '', & 'CHARACTERISTICS', & ' o X may be any real or integer scalar or array and any kind.', & '', & ' o The result will be a scalar of the same type and kind as the input X', & '', & 'DESCRIPTION', & ' HUGE(3) returns the largest number that is not an overflow for the kind and', & ' type of X.', & '', & 'OPTIONS', & ' o X : X is an arbitrary value which is used merely to determine what kind', & ' and type of scalar is being queried. It need not be defined, as only its', & ' characteristics are used.', & '', & 'RESULT', & ' The result is the largest value supported by the specified type and kind.', & '', & ' Note the result is as the same kind as the input to ensure the returned', & ' value does not overflow. Any assignment of the result to a variable should', & ' take this into consideration.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_huge', & ' implicit none', & ' character(len=*),parameter :: f=''(i2,1x,2(i11,1x),f14.0:,1x,l1,1x,a)''', & ' integer :: i,j,k,biggest', & ' real :: v, w', & ' doubleprecision :: tally', & ' ! basic', & ' print *, huge(0), huge(0.0), huge(0.0d0)', & ' print *, tiny(0.0), tiny(0.0d0)', & '', & ' tally=0.0d0', & ' ! note subtracting one because counter is the end value+1 on exit', & ' do i=0,huge(0)-1', & ' tally=tally+i', & ' enddo', & ' write(*,*)''tally='',tally', & '', & ' ! advanced', & ' biggest=huge(0)', & ' ! be careful of overflow when using integers in computation', & ' do i=1,14', & ' j=6**i ! Danger, Danger', & ' w=6**i ! Danger, Danger', & ' v=6.0**i', & ' k=v ! Danger, Danger', & '', & ' if(v.gt.biggest)then', & ' write(*,f) i, j, k, v, v.eq.w, ''wrong j and k and w''', & ' else', & ' write(*,f) i, j, k, v, v.eq.w', & ' endif', & '', & ' enddo', & ' end program demo_huge', & '', & ' Results:', & '', & ' 2147483647 3.4028235E+38 1.797693134862316E+308', & ' 1.1754944E-38 2.225073858507201E-308', & '', & ' 1 6 6 6. T', & ' 2 36 36 36. T', & ' 3 216 216 216. T', & ' 4 1296 1296 1296. T', & ' 5 7776 7776 7776. T', & ' 6 46656 46656 46656. T', & ' 7 279936 279936 279936. T', & ' 8 1679616 1679616 1679616. T', & ' 9 10077696 10077696 10077696. T', & ' 10 60466176 60466176 60466176. T', & ' 11 362797056 362797056 362797056. T', & ' 12 -2118184960 -2147483648 2176782336. F wrong for j and k and w', & ' 13 175792128 -2147483648 13060694016. F wrong for j and k and w', & ' 14 1054752768 -2147483648 78364164096. F wrong for j and k and w', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3),', & ' SCALE(3), SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 huge(3fortran)', & ''] shortname="huge" call process() case('96','hypot') textblock=[character(len=256) :: & '', & 'hypot(3fortran) hypot(3fortran)', & '', & '', & '', & 'NAME', & ' HYPOT(3) - [MATHEMATICS] Returns the Euclidean distance - the distance', & ' between a point and the origin.', & '', & '', & 'SYNOPSIS', & ' result = hypot(x, y)', & '', & ' elemental real(kind=KIND) function hypot(x,y)', & '', & ' real(kind=KIND),intent(in) :: x', & ' real(kind=KIND),intent(in) :: y', & '', & '', & 'CHARACTERISTICS', & ' o X,Y and the result shall all be real and of the same KIND.', & '', & 'DESCRIPTION', & ' HYPOT(3) is referred to as the Euclidean distance function. It is equal to', & '', & ' sqrt(x**2+y**2)', & '', & ' without undue underflow or overflow.', & '', & ' In mathematics, the Euclidean distance between two points in Euclidean space', & ' is the length of a line segment between two points.', & '', & ' HYPOT(X,Y) returns the distance between the point and the origin.', & '', & 'OPTIONS', & ' o X : The type shall be real.', & '', & ' o Y : The type and kind type parameter shall be the same as X.', & '', & 'RESULT', & ' The return value has the same type and kind type parameter as X.', & '', & ' The result is the positive magnitude of the distance of the point from', & ' the origin <0.0,0.0> .', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_hypot', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & real_kinds, real32, real64, real128', & ' implicit none', & ' real(kind=real32) :: x, y', & ' real(kind=real32),allocatable :: xs(:), ys(:)', & ' integer :: i', & ' character(len=*),parameter :: f=''(a,/,SP,*(3x,g0,1x,g0:,/))''', & '', & ' x = 1.e0_real32', & ' y = 0.5e0_real32', & '', & ' write(*,*)', & ' write(*,''(*(g0))'')''point <'',x,'','',y,''> is '',hypot(x,y)', & ' write(*,''(*(g0))'')''units away from the origin''', & ' write(*,*)', & '', & ' ! elemental', & ' xs=[ x, x**2, x*10.0, x*15.0, -x**2 ]', & ' ys=[ y, y**2, -y*20.0, y**2, -y**2 ]', & '', & ' write(*,f)"the points",(xs(i),ys(i),i=1,size(xs))', & ' write(*,f)"have distances from the origin of ",hypot(xs,ys)', & ' write(*,f)"the closest is",minval(hypot(xs,ys))', & '', & ' end program demo_hypot', & '', & ' Results:', & '', & ' point <1.00000000,0.500000000> is 1.11803401', & ' units away from the origin', & '', & ' the points', & ' +1.00000000 +0.500000000', & ' +1.00000000 +0.250000000', & ' +10.0000000 -10.0000000', & ' +15.0000000 +0.250000000', & ' -1.00000000 -0.250000000', & ' have distances from the origin of', & ' +1.11803401 +1.03077638', & ' +14.1421356 +15.0020828', & ' +1.03077638', & ' the closest is', & ' +1.03077638', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 hypot(3fortran)', & ''] shortname="hypot" call process() case('97','iachar') textblock=[character(len=256) :: & '', & 'iachar(3fortran) iachar(3fortran)', & '', & '', & '', & 'NAME', & ' IACHAR(3) - [CHARACTER:CONVERSION] Return integer ASCII code of a character', & '', & '', & 'SYNOPSIS', & ' result = iachar(c [,kind])', & '', & ' elemental integer(kind=KIND) function iachar(c,kind)', & '', & ' character(len=1),intent(in) :: c', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o C is a single character', & '', & ' o The return value is of type integer and of kind KIND. If KIND is absent,', & ' the return value is of default integer kind.', & '', & ' NOTE: : a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' IACHAR(3) returns the code for the ASCII character in the first character', & ' position of C.', & '', & 'OPTIONS', & ' o C : A character to determine the ASCII code of. : A common extension is', & ' to allow strings but all but the first character is then ignored.', & '', & ' o KIND : A constant initialization expression indicating the kind parameter', & ' of the result.', & '', & 'RESULT', & ' the result is the position of the character C in the ASCII collating', & ' sequence. It is nonnegative and less than or equal to 127.', & '', & ' By ASCII, it is meant that C is in the collating sequence defined by the', & ' codes specified in ISO/IEC 646:1991 (International Reference Version).', & '', & ' The value of the result is processor dependent if C is not in the ASCII', & ' collating sequence.', & '', & ' The results are consistent with the LGE(3), LGT(3), LLE(3), and LLT(3)', & ' comparison functions. For example, if LLE(C, D) is true, IACHAR(C) <= IACHAR', & ' (D) is true where C and D are any two characters representable by the', & ' processor.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_iachar', & ' implicit none', & ' ! basic usage', & ' ! just does a string one character long', & ' write(*,*)iachar(''A'')', & ' ! elemental: can do an array of letters', & ' write(*,*)iachar([''A'',''Z'',''a'',''z''])', & '', & ' ! convert all characters to lowercase', & ' write(*,''(a)'')lower(''abcdefg ABCDEFG'')', & ' contains', & ' !', & ' pure elemental function lower(str) result (string)', & ' ! Changes a string to lowercase', & ' character(*), intent(In) :: str', & ' character(len(str)) :: string', & ' integer :: i', & ' string = str', & ' ! step thru each letter in the string in specified range', & ' do i = 1, len(str)', & ' select case (str(i:i))', & ' case (''A'':''Z'') ! change letter to miniscule', & ' string(i:i) = char(iachar(str(i:i))+32)', & ' case default', & ' end select', & ' end do', & ' end function lower', & ' !', & ' end program demo_iachar', & '', & ' Results:', & '', & ' 65', & ' 65 90 97 122', & ' abcdefg abcdefg', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument - Fortran 2003', & '', & 'SEE ALSO', & ' ACHAR(3), CHAR(3), ICHAR(3)', & '', & ' See ICHAR(3) in particular for a discussion of converting between numerical', & ' values and formatted string representations.', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 iachar(3fortran)', & ''] shortname="iachar" call process() case('98','iall') textblock=[character(len=256) :: & '', & 'iall(3fortran) iall(3fortran)', & '', & '', & '', & 'NAME', & ' IALL(3) - [BIT:LOGICAL] Bitwise and of array elements', & '', & '', & 'SYNOPSIS', & ' result = iall(array [,mask]) | iall(array ,dim [,mask])', & '', & ' integer(kind=KIND) function iall(array,dim,mask)', & '', & ' integer(kind=KIND),intent(in) :: array(*)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(*)', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o ARRAY must be an integer array', & '', & ' o MASK is a logical array that conforms to ARRAY of any logical kind.', & '', & ' o DIM may be of any integer kind.', & '', & ' o The result will by of the same type and kind as ARRAY.', & '', & 'DESCRIPTION', & ' IALL(3) reduces with a bitwise and the elements of ARRAY along dimension DIM', & ' if the corresponding element in MASK is .true..', & '', & 'OPTIONS', & ' o ARRAY : Shall be an array of type integer', & '', & ' o DIM : (Optional) shall be a scalar of type integer with a value in the', & ' range from 1 TO N, where N equals the rank of ARRAY.', & '', & ' o MASK : (Optional) shall be of type logical and either be a scalar or an', & ' array of the same shape as ARRAY.', & '', & 'RESULT', & ' The result is of the same type as ARRAY.', & '', & ' If DIM is absent, a scalar with the bitwise all of all elements in ARRAY is', & ' returned. Otherwise, an array of rank N-1, where N equals the rank of ARRAY,', & ' and a shape similar to that of ARRAY with dimension DIM dropped is returned.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_iall', & ' use, intrinsic :: iso_fortran_env, only : integer_kinds, &', & ' & int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int8) :: a(2)', & '', & ' a(1) = int(b''00100100'')', & ' a(2) = int(b''01101010'')', & '', & ' print ''(b8.8)'', iall(a)', & '', & ' end program demo_iall', & '', & ' Results:', & '', & ' > 00100000', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' IANY(3), IPARITY(3), IAND(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 iall(3fortran)', & ''] shortname="iall" call process() case('99','iand') textblock=[character(len=256) :: & '', & 'iand(3fortran) iand(3fortran)', & '', & '', & '', & 'NAME', & ' IAND(3) - [BIT:LOGICAL] Bitwise logical AND', & '', & '', & 'SYNOPSIS', & ' result = iand(i, j)', & '', & ' elemental integer(kind=KIND) function iand(i,j)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=KIND),intent(in) :: j', & '', & '', & 'CHARACTERISTICS', & ' o I, J and the result shall have the same integer type and kind, with the', & ' exception that one of I or J may be a BOZ constant.', & '', & 'DESCRIPTION', & ' IAND(3) returns the bitwise logical AND of two values.', & '', & 'OPTIONS', & ' o I : one of the pair of values to compare the bits of', & '', & ' o J : one of the pair of values to compare the bits of', & '', & ' If either I or J is a BOZ-literal-constant, it is first converted as if by', & ' the intrinsic function INT(3) to type integer with the kind type parameter', & ' of the other.', & '', & 'RESULT', & ' The result has the value obtained by combining I and I bit-by-bit according', & ' to the following table:', & '', & ' I | J | IAND (I, J)', & ' ----------------------------', & '', & ' 1 | 1 | 1', & '', & ' 1 | 0 | 0', & '', & ' 0 | 1 | 0', & '', & ' 0 | 0 | 0', & '', & ' So if both the bit in I and J are on the resulting bit is on (a one); else', & ' the resulting bit is off (a zero).', & '', & ' This is commonly called the "bitwise logical AND" of the two values.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_iand', & ' implicit none', & ' integer :: a, b', & ' data a / z''f'' /, b / z''3'' /', & ' write (*,*) ''a='',a,'' b='',b,''iand(a,b)='',iand(a, b)', & ' write (*,''(b32.32)'') a,b,iand(a,b)', & ' end program demo_iand', & '', & ' Results:', & '', & ' a= 15 b= 3 iand(a,b)= 3', & ' 00000000000000000000000000001111 00000000000000000000000000000011', & ' 00000000000000000000000000000011', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' BTEST(3), IBCLR(3), IBITS(3), IBSET(3), IEOR(3), IOR(3), MVBITS(3), NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 iand(3fortran)', & ''] shortname="iand" call process() case('100','iany') textblock=[character(len=256) :: & '', & 'iany(3fortran) iany(3fortran)', & '', & '', & '', & 'NAME', & ' IANY(3) - [BIT:LOGICAL] Bitwise OR of array elements', & '', & '', & 'SYNOPSIS', & ' result = iany(array [,mask]) | iany(array ,dim [,mask])', & '', & ' integer(kind=KIND) function iany(array,dim,mask)', & '', & ' integer(kind=KIND),intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY is an integer array', & '', & ' o DIM may be of any integer kind.', & '', & ' o MASK is a logical array that conforms to ARRAY', & '', & ' o The result will by of the same type and kind as ARRAY. It is scalar if', & ' DIM does not appear or is 1. Otherwise, it is the shape and rank of array', & ' reduced by the dimension DIM.', & '', & ' note a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' IANY(3) reduces with bitwise OR (inclusive OR) the elements of ARRAY along', & ' dimension DIM if the corresponding element in MASK is .true..', & '', & 'OPTIONS', & ' o ARRAY : an array of elements to selectively OR based on the mask.', & '', & ' o DIM : a value in the range from 1 TO N, where N equals the rank of ARRAY.', & '', & ' o MASK : a logical scalar; or an array of the same shape as ARRAY.', & '', & 'RESULT', & ' The result is of the same type as ARRAY.', & '', & ' If DIM is absent, a scalar with the bitwise or of all elements in ARRAY is', & ' returned. Otherwise, an array of rank N-1, where N equals the rank of ARRAY,', & ' and a shape similar to that of ARRAY with dimension DIM dropped is returned.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_iany', & ' use, intrinsic :: iso_fortran_env, only : integer_kinds, &', & ' & int8, int16, int32, int64', & ' implicit none', & ' logical,parameter :: T=.true., F=.false.', & ' integer(kind=int8) :: a(3)', & ' a(1) = int(b''00100100'',int8)', & ' a(2) = int(b''01101010'',int8)', & ' a(3) = int(b''10101010'',int8)', & ' write(*,*)''A=''', & ' print ''(1x,b8.8)'', a', & ' print *', & ' write(*,*)''IANY(A)=''', & ' print ''(1x,b8.8)'', iany(a)', & ' print *', & ' write(*,*)''IANY(A) with a mask''', & ' print ''(1x,b8.8)'', iany(a,mask=[T,F,T])', & ' print *', & ' write(*,*)''should match ''', & ' print ''(1x,b8.8)'', iany([a(1),a(3)])', & ' print *', & ' write(*,*)''does it?''', & ' write(*,*)iany(a,[T,F,T]) == iany([a(1),a(3)])', & ' end program demo_iany', & '', & ' Results:', & '', & ' A=', & ' 00100100', & ' 01101010', & ' 10101010', & '', & ' IANY(A)=', & ' 11101110', & '', & ' IANY(A) with a mask', & ' 10101110', & '', & ' should match', & ' 10101110', & '', & ' does it?', & '', & ' T', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' IPARITY(3), IALL(3), IOR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 iany(3fortran)', & ''] shortname="iany" call process() case('101','ibclr') textblock=[character(len=256) :: & '', & 'ibclr(3fortran) ibclr(3fortran)', & '', & '', & '', & 'NAME', & ' IBCLR(3) - [BIT:SET] Clear a bit', & '', & '', & 'SYNOPSIS', & ' result = ibclr(i, pos)', & '', & ' elemental integer(kind=KIND) function ibclr(i,pos)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: pos', & '', & '', & 'CHARACTERISTICS', & ' o I shall be type integer.', & '', & ' o POS shall be type integer.', & '', & ' o The return value is of the same kind as I.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' IBCLR(3) returns the value of I with the bit at position POS set to zero.', & '', & 'OPTIONS', & ' o I : The initial value to be modified', & '', & ' o POS : The position of the bit to change in the input value. A value of', & ' zero refers to the right-most bit. The value of POS must be nonnegative', & ' and less than (BIT_SIZE(I)).', & '', & 'RESULT', & ' The returned value has the same bit sequence as I except the designated bit', & ' is unconditionally set to 0', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ibclr', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int16) :: i', & ' ! basic usage', & ' print *,ibclr (16, 1), '' ==> ibclr(16,1) has the value 15''', & '', & ' ! it is easier to see using binary representation', & ' i=int(b''0000000000111111'',kind=int16)', & ' write(*,''(b16.16,1x,i0)'') ibclr(i,3), ibclr(i,3)', & '', & ' ! elemental', & ' print *,''an array of initial values may be given as well''', & ' print *,ibclr(i=[7,4096,9], pos=2)', & ' print *', & ' print *,''a list of positions results in multiple returned values''', & ' print *,''not multiple bits set in one value, as the routine is ''', & ' print *,''a scalar function; calling it elementally essentially ''', & ' print *,''calls it multiple times. ''', & ' write(*,''(b16.16)'') ibclr(i=-1_int16, pos=[1,2,3,4])', & '', & ' ! both may be arrays if of the same size', & '', & ' end program demo_ibclr', & '', & ' Results:', & '', & ' > 16 ==> ibclr(16,1) has the value 15', & ' > 0000000000110111 55', & ' > an array of initial values may be given as well', & ' > 3 4096 9', & ' >', & ' > a list of positions results in multiple returned values', & ' > not multiple bits set in one value, as the routine is', & ' > a scalar function; calling it elementally essentially', & ' > calls it multiple times.', & ' > 1111111111111101', & ' > 1111111111111011', & ' > 1111111111110111', & ' > 1111111111101111', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' BTEST(3), IAND(3), IBITS(3), IBSET(3), IEOR(3), IOR(3), MVBITS(3), NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ibclr(3fortran)', & ''] shortname="ibclr" call process() case('102','ibits') textblock=[character(len=256) :: & '', & 'ibits(3fortran) ibits(3fortran)', & '', & '', & '', & 'NAME', & ' IBITS(3) - [BIT:COPY] Extraction of a subset of bits', & '', & '', & 'SYNOPSIS', & ' result = ibits(i, pos, len)', & '', & ' elemental integer(kind=KIND) function ibits(i,pos,len)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: pos', & ' integer(kind=**),intent(in) :: len', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported integer kind', & '', & ' o I may be any supported integer kind as well', & '', & ' o the return value will be the same kind as I', & '', & 'DESCRIPTION', & ' IBITS(3) extracts a field of bits from I, starting from bit position POS and', & ' extending left for a total of LEN bits.', & '', & ' The result is then right-justified and the remaining left-most bits in the', & ' result are zeroed.', & '', & ' The position POS is calculated assuming the right-most bit is zero and the', & ' positions increment to the left.', & '', & 'OPTIONS', & ' o I : The value to extract bits from', & '', & ' o POS : The position of the bit to start copying at. POS is non-negative.', & '', & ' o LEN : the number of bits to copy from I. It must be non-negative.', & '', & ' POS + LEN shall be less than or equal to BIT_SIZE(I).', & '', & 'RESULT', & ' The return value is composed of the selected bits right-justified, left-', & ' padded with zeros.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ibits', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int16) :: i,j', & ' ! basic usage', & ' print *,ibits (14, 1, 3) ! should be seven', & ' print *,ibits(-1,10,3) ! and so is this', & ' ! it is easier to see using binary representation', & ' i=int(b''0101010101011101'',kind=int16)', & ' write(*,''(b16.16,1x,i0)'') ibits(i,3,3), ibits(i,3,3)', & '', & ' ! we can illustrate this as', & ' ! #-- position 15', & ' ! | #-- position 0', & ' ! | <-- +len |', & ' ! V V', & ' ! 5432109876543210', & ' i =int(b''1111111111111111'',kind=int16)', & ' ! ^^^^', & ' j=ibits(i,10,4) ! start at 10th from left and proceed', & ' ! left for a total of 4 characters', & ' write(*,''(a,b16.16)'')''j='',j', & ' ! lets do something less ambiguous', & ' i =int(b''0010011000000000'',kind=int16)', & ' j=ibits(i,9,5)', & ' write(*,''(a,b16.16)'')''j='',j', & ' end program demo_ibits', & '', & ' Results:', & '', & ' > 7', & ' > 7', & ' > 0000000000000011 3', & ' > j=0000000000001111', & ' > j=0000000000010011', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' BTEST(3), IAND(3), IBCLR(3), IBSET(3), IEOR(3), IOR(3), MVBITS(3), NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ibits(3fortran)', & ''] shortname="ibits" call process() case('103','ibset') textblock=[character(len=256) :: & '', & 'ibset(3fortran) ibset(3fortran)', & '', & '', & '', & 'NAME', & ' IBSET(3) - [BIT:SET] Set a bit to one in an integer value', & '', & '', & 'SYNOPSIS', & ' result = ibset(i, pos)', & '', & ' elemental integer(kind=KIND) function ibset(i,pos)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: pos', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o The return value is of the same kind as I. Otherwise, any integer kinds', & ' are allowed.', & '', & 'DESCRIPTION', & ' IBSET(3) returns the value of I with the bit at position POS set to one.', & '', & 'OPTIONS', & ' o I : The initial value to be modified', & '', & ' o POS : The position of the bit to change in the input value. A value of', & ' zero refers to the right-most bit. The value of POS must be nonnegative', & ' and less than (BIT_SIZE(I)).', & '', & 'RESULT', & ' The returned value has the same bit sequence as I except the designated bit', & ' is unconditionally set to 1.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ibset', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int16) :: i', & ' ! basic usage', & ' print *,ibset (12, 1), ''ibset(12,1) has the value 14''', & '', & ' ! it is easier to see using binary representation', & ' i=int(b''0000000000000110'',kind=int16)', & ' write(*,''(b16.16,1x,i0,1x,i0)'') ibset(i,12), ibset(i,12), i', & '', & ' ! elemental', & ' print *,''an array of initial values may be given as well''', & ' print *,ibset(i=[0,4096], pos=2)', & ' print *', & ' print *,''a list of positions results in multiple returned values''', & ' print *,''not multiple bits set in one value, as the routine is ''', & ' print *,''a scalar function; calling it elementally essentially ''', & ' print *,''calls it multiple times. ''', & ' write(*,''(b16.16)'') ibset(i=0, pos=[1,2,3,4])', & '', & ' ! both may be arrays if of the same size', & '', & ' end program demo_ibset', & '', & ' Results:', & '', & ' > 14 ibset(12,1) has the value 14', & ' > 0001000000000110 4102 6', & ' > an array of initial values may be given as well', & ' > 4 4100', & ' >', & ' > a list of positions results in multiple returned values', & ' > not multiple bits set in one value, as the routine is', & ' > a scalar function; calling it elementally essentially', & ' > calls it multiple times.', & ' > 0000000000000010', & ' > 0000000000000100', & ' > 0000000000001000', & ' > 0000000000010000', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' IBCLR(3)', & '', & ' BTEST(3), IAND(3), IBITS(3), IEOR(3), IOR(3), MVBITS(3), NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ibset(3fortran)', & ''] shortname="ibset" call process() case('104','ichar') textblock=[character(len=256) :: & '', & 'ichar(3fortran) ichar(3fortran)', & '', & '', & '', & 'NAME', & ' ICHAR(3) - [CHARACTER:CONVERSION] Character-to-integer code conversion', & ' function', & '', & '', & 'SYNOPSIS', & ' result = ichar(c [,kind])', & '', & ' elemental integer(kind=KIND) function ichar(c,KIND)', & '', & ' character(len=1,kind=**),intent(in) :: c', & ' integer,intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o C is a scalar character', & '', & ' o KIND is a constant integer initialization expression indicating the kind', & ' parameter of the result.', & '', & ' o The return value is of type integer and of kind KIND. If KIND is absent,', & ' the return value is of default integer kind.', & '', & 'DESCRIPTION', & ' ICHAR(3) returns the code for the character in the system''s native character', & ' set. The correspondence between characters and their codes is not', & ' necessarily the same across different Fortran implementations. For example,', & ' a platform using EBCDIC would return different values than an ASCII', & ' platform.', & '', & ' See IACHAR(3) for specifically working with the ASCII character set.', & '', & 'OPTIONS', & ' o C : The input character to determine the code for. Its value shall be', & ' that of a character capable of representation in the processor.', & '', & ' o KIND : indicates the kind parameter of the result. If KIND is absent, the', & ' return value is of default integer kind.', & '', & 'RESULT', & ' The code in the system default character set for the character being queried', & ' is returned.', & '', & ' The result is the position of C in the processor collating sequence', & ' associated with the kind type parameter of C.', & '', & ' it is nonnegative and less than n, where n is the number of characters in', & ' the collating sequence.', & '', & ' The kind type parameter of the result shall specify an integer kind that is', & ' capable of representing n.', & '', & ' For any characters C and D capable of representation in the processor, C <=', & ' D is true if and only if ICHAR (C) <= ICHAR (D) is true and C == D is true', & ' if and only if ICHAR (C) == ICHAR (D) is true.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ichar', & ' implicit none', & '', & ' write(*,*)ichar([''a'',''z'',''A'',''Z''])', & '', & ' end program demo_ichar', & '', & ' Results:', & '', & ' 97 122 65 90', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument -Fortran 2003', & '', & 'SEE ALSO', & ' ACHAR(3), CHAR(3), IACHAR(3)', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3),', & '', & ' SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ichar(3fortran)', & ''] shortname="ichar" call process() case('105','ieor') textblock=[character(len=256) :: & '', & 'ieor(3fortran) ieor(3fortran)', & '', & '', & '', & 'NAME', & ' IEOR(3) - [BIT:LOGICAL] Bitwise exclusive OR', & '', & '', & 'SYNOPSIS', & ' result = ieor(i, j)', & '', & ' elemental integer(kind=**) function ieor(i,j)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in) :: j', & '', & '', & 'CHARACTERISTICS', & ' o I, J and the result must be of the same integer kind.', & '', & ' o An exception is that one of I and J may be a BOZ literal constant', & '', & 'DESCRIPTION', & ' IEOR(3) returns a bitwise exclusive-OR of I and J.', & '', & ' An exclusive OR or "exclusive disjunction" is a logical operation that is', & ' true if and only if its arguments differ. In this case a one-bit and a zero-', & ' bit substitute for true and false.', & '', & ' This is often represented with the notation "XOR", for "eXclusive OR".', & '', & ' An alternate way to view the process is that the result has the value', & ' obtained by combining I and J bit-by-bit according to the following table:', & '', & ' > I | J |IEOR (I, J)', & ' > --#---#-----------', & ' > 1 | 1 | 0', & ' > 1 | 0 | 1', & ' > 0 | 1 | 1', & ' > 0 | 0 | 0', & '', & '', & 'OPTIONS', & ' o I : the first of the two values to XOR', & '', & ' o J : the second of the two values to XOR', & '', & ' If either I or J is a boz-literal-constant, it is first converted as if by', & ' the intrinsic function INT to type integer with the kind type parameter of', & ' the other.', & '', & 'RESULT', & ' If a bit is different at the same location in I and J the corresponding bit', & ' in the result is 1, otherwise it is 0.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ieor', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int16) :: i,j', & ' ! basic usage', & ' print *,ieor (16, 1), '' ==> ieor(16,1) has the value 17''', & '', & ' ! it is easier to see using binary representation', & ' i=int(b''0000000000111111'',kind=int16)', & ' j=int(b''0000001111110000'',kind=int16)', & ' write(*,''(a,b16.16,1x,i0)'')''i= '',i, i', & ' write(*,''(a,b16.16,1x,i0)'')''j= '',j, j', & ' write(*,''(a,b16.16,1x,i0)'')''result='',ieor(i,j), ieor(i,j)', & '', & ' ! elemental', & ' print *,''arguments may be arrays. If both are arrays they ''', & ' print *,''must have the same shape. ''', & ' print *,ieor(i=[7,4096,9], j=2)', & '', & ' ! both may be arrays if of the same size', & '', & ' end program demo_ieor', & '', & ' Results:', & '', & ' > 17 ==> ieor(16,1) has the value 17', & ' > i= 0000000000111111 63', & ' > j= 0000001111110000 1008', & ' > result=0000001111001111 975', & ' > arguments may be arrays. If both are arrays they', & ' > must have the same shape.', & ' > 5 4098 11', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' BTEST(3), IAND(3), IBCLR(3), IBITS(3), IBSET(3), IEOR(3), IOR(3), MVBITS(3),', & ' NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ieor(3fortran)', & ''] shortname="ieor" call process() case('106','image_index') textblock=[character(len=256) :: & '', & 'image_index(3fortran) image_index(3fortran)', & '', & '', & '', & 'NAME', & ' IMAGE_INDEX(3) - [COLLECTIVE] Cosubscript to image index conversion', & '', & '', & 'SYNOPSIS', & ' result = image_index(coarray, sub)', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' IMAGE_INDEX(3) returns the image index belonging to a cosubscript.', & '', & 'OPTIONS', & ' o COARRAY : Coarray of any type.', & '', & ' o SUB : default integer rank-1 array of a size equal to the corank of', & ' COARRAY.', & '', & 'RESULT', & ' Scalar default integer with the value of the image index which corresponds', & ' to the cosubscripts. For invalid cosubscripts the result is zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo image_index', & ' implicit none', & ' integer :: array[2,-1:4,8,*]', & ' ! Writes 28 (or 0 if there are fewer than 28 images)', & ' write (*,*) image_index(array, [2,0,3,1])', & ' end demo image_index', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' THIS_IMAGE(3), NUM_IMAGES(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 image_index(3fortran)', & ''] shortname="image_index" call process() case('107','index') textblock=[character(len=256) :: & '', & 'index(3fortran) index(3fortran)', & '', & '', & '', & 'NAME', & ' INDEX(3) - [CHARACTER:SEARCH] Position of a substring within a string', & '', & '', & 'SYNOPSIS', & ' result = index( string, substring [,back] [,kind] )', & '', & ' elemental integer(kind=KIND) function index(string,substring,back,kind)', & '', & ' character(len=*,kind=KIND),intent(in) :: string', & ' character(len=*,kind=KIND),intent(in) :: substring', & ' logical(kind=**),intent(in),optional :: back', & ' integer(kind=**),intent(in),optional :: kind', & '', & '', & 'CHARACTERISTICS', & ' o STRING is a character variable of any kind', & '', & ' o SUBSTRING is a character variable of the same kind as STRING', & '', & ' o BACK is a logical variable of any supported kind', & '', & ' o KIND is a scalar integer constant expression.', & '', & 'DESCRIPTION', & ' INDEX(3) returns the position of the start of the leftmost or rightmost', & ' occurrence of string SUBSTRING in STRING, counting from one. If SUBSTRING is', & ' not present in STRING, zero is returned.', & '', & 'OPTIONS', & ' o STRING : string to be searched for a match', & '', & ' o SUBSTRING : string to attempt to locate in STRING', & '', & ' o BACK : If the BACK argument is present and true, the return value is the', & ' start of the rightmost occurrence rather than the leftmost.', & '', & ' o KIND : if KIND is present, the kind type parameter is that specified by', & ' the value of KIND; otherwise the kind type parameter is that of default', & ' integer type.', & '', & 'RESULT', & ' The result is the starting position of the first substring SUBSTRING found', & ' in STRING.', & '', & ' If the length of SUBSTRING is longer than STRING the result is zero.', & '', & ' If the substring is not found the result is zero.', & '', & ' If BACK is .true. the greatest starting position is returned (that is, the', & ' position of the right-most match). Otherwise, the smallest position starting', & ' a match (ie. the left-most match) is returned.', & '', & ' The position returned is measured from the left with the first character of', & ' STRING being position one.', & '', & ' Otherwise, if no match is found zero is returned.', & '', & 'EXAMPLES', & ' Example program', & '', & ' program demo_index', & ' implicit none', & ' character(len=*),parameter :: str=&', & ' ''Search this string for this expression''', & ' !1234567890123456789012345678901234567890', & ' write(*,*)&', & ' index(str,''this'').eq.8, &', & ' ! return value is counted from the left end even if BACK=.TRUE.', & ' index(str,''this'',back=.true.).eq.24, &', & ' ! INDEX is case-sensitive', & ' index(str,''This'').eq.0', & ' end program demo_index', & '', & ' Expected Results:', & '', & ' T T T', & 'STANDARD', & ' FORTRAN 77 , with KIND argument Fortran 2003', & '', & 'SEE ALSO', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 index(3fortran)', & ''] shortname="index" call process() case('108','int') textblock=[character(len=256) :: & '', & 'int(3fortran) int(3fortran)', & '', & '', & '', & 'NAME', & ' INT(3) - [TYPE:NUMERIC] Truncate towards zero and convert to integer', & '', & '', & 'SYNOPSIS', & ' result = int(a [,kind])', & '', & ' elemental integer(kind=KIND) function int(a, KIND )', & '', & ' TYPE(kind=**),intent(in) :: a', & ' integer,optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o A shall be of type integer, real, or complex, or a boz-literal-constant.', & '', & ' o KIND shall be a scalar integer constant expression.', & '', & 'DESCRIPTION', & ' INT(3) truncates towards zero and return an integer.', & '', & 'OPTIONS', & ' o A : is the value to truncate towards zero', & '', & ' o KIND : indicates the kind parameter of the result. If not present the', & ' returned type is that of default integer type.', & '', & 'RESULT', & ' returns an integer variable applying the following rules:', & '', & ' CASE:', & '', & ' 1. If A is of type integer, INT(a) = a', & '', & ' 2. If A is of type real and |A| < 1, INT(A) equals 0. If |A| >= 1, then', & ' INT(A) equals the integer whose magnitude does not exceed A and whose', & ' sign is the same as the sign of A.', & '', & ' 3. If A is of type complex, rule 2 is applied to the real part of A.', & '', & ' 4. If a is a boz-literal constant, it is treated as an integer with the', & ' kind specified.', & '', & ' The interpretation of a bit sequence whose most significant bit is 1 is', & ' processor dependent.', & '', & ' The result is undefined if it cannot be represented in the specified integer', & ' type.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_int', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: i = 42', & ' complex :: z = (-3.7, 1.0)', & ' real :: x=-10.5, y=10.5', & '', & ' print *, int(x), int(y)', & '', & ' print *, int(i)', & '', & ' print *, int(z), int(z,8)', & ' ! elemental', & ' print *, int([-10.9,-10.5,-10.3,10.3,10.5,10.9])', & ' ! note int(3) truncates towards zero', & '', & ' ! CAUTION:', & ' ! a number bigger than a default integer can represent', & ' ! produces an incorrect result and is not required to', & ' ! be detected by the program.', & ' x=real(huge(0))+1000.0', & ' print *, int(x),x', & ' ! using a larger kind', & ' print *, int(x,kind=int64),x', & '', & ' print *, int(&', & ' & B"111111111111111111111111111111111111111111111111111111111111111",&', & ' & kind=int64)', & ' print *, int(O"777777777777777777777",kind=int64)', & ' print *, int(Z"7FFFFFFFFFFFFFFF",kind=int64)', & '', & ' ! elemental', & ' print *', & ' print *,int([ &', & ' & -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &', & ' & 0.0, &', & ' & +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ])', & '', & ' end program demo_int', & '', & ' Results:', & '', & ' > -10 10', & ' > 42', & ' > -3 -3', & ' > -10 -10 -10 10 10 10', & ' > -2147483648 2.14748467E+09', & ' > 2147484672 2.14748467E+09', & ' > 9223372036854775807', & ' > 9223372036854775807', & ' > 9223372036854775807', & ' >', & ' > -2 -2 -2 -2 -1', & ' > -1 0 0 0 1', & ' > 1 2 2 2 2', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' AINT(3), ANINT(3), NINT(3), SELECTED_INT_KIND(3), CEILING(3), FLOOR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 int(3fortran)', & ''] shortname="int" call process() case('109','ior') textblock=[character(len=256) :: & '', & 'ior(3fortran) ior(3fortran)', & '', & '', & '', & 'NAME', & ' IOR(3) - [BIT:LOGICAL] Bitwise logical inclusive OR', & '', & '', & 'SYNOPSIS', & ' result = ior(i, j)', & '', & ' elemental integer(kind=KIND) function ior(i,j)', & '', & ' integer(kind=KIND ,intent(in) :: i', & ' integer(kind=KIND ,intent(in) :: j', & '', & '', & 'CHARACTERISTICS', & ' o I, J and the result shall have the same integer type and kind, with the', & ' exception that one of I or J may be a BOZ constant.', & '', & 'DESCRIPTION', & ' IOR(3) returns the bit-wise Boolean inclusive-or of I and J.', & '', & 'OPTIONS', & ' o I : one of the pair of values to compare the bits of', & '', & ' o J : one of the pair of values to compare the bits of', & '', & ' If either I or J is a BOZ-literal-constant, it is first converted as if by', & ' the intrinsic function INT(3) to type integer with the kind type parameter', & ' of the other.', & '', & 'RESULT', & ' The result has the value obtained by combining I and J bit-by-bit according', & ' to the following table:', & '', & ' I J IOR (I, J)', & ' 1 1 1', & ' 1 0 1', & ' 0 1 1', & ' 0 0 0', & '', & ' Where if the bit is set in either input value, it is set in the result.', & ' Otherwise the result bit is zero.', & '', & ' This is commonly called the "bitwise logical inclusive OR" of the two', & ' values.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ior', & ' implicit none', & ' integer :: i, j, k', & ' i=53 ! i=00110101 binary (lowest order byte)', & ' j=45 ! j=00101101 binary (lowest order byte)', & ' k=ior(i,j) ! k=00111101 binary (lowest order byte), k=61 decimal', & ' write(*,''(i8,1x,b8.8)'')i,i,j,j,k,k', & ' end program demo_ior', & '', & ' Results:', & '', & ' 53 00110101', & ' 45 00101101', & ' 61 00111101', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' BTEST(3), IAND(3), IBCLR(3), IBITS(3), IBSET(3), IEOR(3), MVBITS(3), NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ior(3fortran)', & ''] shortname="ior" call process() case('110','iparity') textblock=[character(len=256) :: & '', & 'iparity(3fortran) iparity(3fortran)', & '', & '', & '', & 'NAME', & ' IPARITY(3) - [BIT:LOGICAL] Bitwise exclusive OR of array elements', & '', & '', & 'SYNOPSIS', & ' result = iparity( array [,mask] ) | iparity( array, dim [,mask] )', & '', & ' integer(kind=KIND) function iparity(array, dim, mask )', & '', & ' integer(kind=KIND),intent(in) :: array(..)', & ' logical(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & ' o ARRAY - An integer array.', & '', & ' o DIM - an integer scalar from 1 to the rank of ARRAY', & '', & ' o MASK - logical conformable with ARRAY.', & '', & 'DESCRIPTION', & ' IPARITY(3) reduces with bitwise xor (exclusive or) the elements of ARRAY', & ' along dimension DIM if the corresponding element in MASK is .true..', & '', & 'OPTIONS', & ' o ARRAY : an array of integer values', & '', & ' o DIM a value from 1 to the rank of ARRAY.', & '', & ' o MASK : a logical mask either a scalar or an array of the same shape as', & ' ARRAY.', & '', & 'RESULT', & ' The result is of the same type as ARRAY.', & '', & ' If DIM is absent, a scalar with the bitwise xor of all elements in ARRAY is', & ' returned. Otherwise, an array of rank N-1, where N equals the rank of ARRAY,', & ' and a shape similar to that of ARRAY with dimension DIM dropped is returned.', & '', & ' Case (i): The result of IPARITY (ARRAY) has a value equal to the bitwise', & ' exclusive OR of all the elements of ARRAY. If ARRAY has size zero the result', & ' has the value zero.', & '', & ' Case (ii): The result of IPARITY (ARRAY, MASK=MASK) has a value equal to', & ' that of', & '', & ' IPARITY (PACK (ARRAY, MASK)).', & '', & ' Case (iii): The result of IPARITY (ARRAY, DIM=DIM [, MASK=MASK]) has a value', & ' equal to that of IPARITY (ARRAY [, MASK=MASK]) if ARRAY has rank one.', & '', & ' Otherwise, an array of values reduced along the dimension', & ' **dim** is returned.', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_iparity', & ' implicit none', & ' integer, dimension(2) :: a', & ' a(1) = int(b''00100100'')', & ' a(2) = int(b''01101010'')', & ' print ''(b8.8)'', iparity(a)', & ' end program demo_iparity', & '', & ' Results:', & '', & ' 01001110', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' IANY(3), IALL(3), IEOR(3), PARITY(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 iparity(3fortran)', & ''] shortname="iparity" call process() case('111','is_contiguous') textblock=[character(len=256) :: & '', & 'is_contiguous(3fortran) is_contiguous(3fortran)', & '', & '', & '', & 'NAME', & ' IS_CONTIGUOUS(3) - [ARRAY:INQUIRY] Test if object is contiguous', & '', & '', & 'SYNOPSIS', & ' result = is_contiguous(array)', & '', & ' logical function is_contiguous(array)', & '', & ' type(TYPE(kind=**)),intent(in) :: array', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o ARRAY may be of any type. It shall be an array or assumed-rank. If it is', & ' a pointer it shall be associated.', & '', & ' o the result is a default logical scalar', & '', & 'DESCRIPTION', & ' IS_CONTIGUOUS(3) returns .true. if and only if an object is contiguous.', & '', & ' An object is contiguous if it is', & '', & ' o (1) an object with the CONTIGUOUS attribute,', & '', & ' o (2) a nonpointer whole array that is not assumed-shape,', & '', & ' o (3) an assumed-shape array that is argument associated with an array that', & ' is contiguous,', & '', & ' o (4) an array allocated by an ALLOCATE statement,', & '', & ' o (5) a pointer associated with a contiguous target, or', & '', & ' o (6) a nonzero-sized array section provided that', & '', & ' o (A) its base object is contiguous,', & '', & ' o (B) it does not have a vector subscript,', & '', & ' o (C) the elements of the section, in array element order, are a subset', & ' of the base object elements that are consecutive in array element', & ' order,', & '', & ' o (D) if the array is of type character and a substring-range appears,', & ' the substring-range specifies all of the characters of the parent-', & ' string,', & '', & ' o (E) only its final part-ref has nonzero rank, and', & '', & ' o (F) it is not the real or imaginary part of an array of type complex.', & '', & ' An object is not contiguous if it is an array subobject, and', & '', & ' o the object has two or more elements,', & '', & ' o the elements of the object in array element order are not consecutive in', & ' the elements of the base object,', & '', & ' o the object is not of type character with length zero, and', & '', & ' o the object is not of a derived type that has no ultimate components other', & ' than zero-sized arrays and', & '', & ' o characters with length zero.', & '', & ' It is processor-dependent whether any other object is contiguous.', & '', & 'OPTIONS', & ' o ARRAY : An array of any type to be tested for being contiguous. If it is', & ' a pointer it shall be associated.', & '', & 'RESULT', & ' The result has the value .true. if ARRAY is contiguous, and .false.', & ' otherwise.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_is_contiguous', & ' implicit none', & ' intrinsic is_contiguous', & ' real, DIMENSION (1000, 1000), TARGET :: A', & ' real, DIMENSION (:, :), POINTER :: IN, OUT', & ' IN => A ! Associate IN with target A', & ' OUT => A(1:1000:2,:) ! Associate OUT with subset of target A', & ' !', & ' write(*,*)''IN is '',IS_CONTIGUOUS(IN)', & ' write(*,*)''OUT is '',IS_CONTIGUOUS(OUT)', & ' !', & ' end program demo_is_contiguous', & '', & ' Results:', & '', & ' IN is T', & ' OUT is F', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 is_contiguous(3fortran)', & ''] shortname="is_contiguous" call process() case('112','ishft') textblock=[character(len=256) :: & '', & 'ishft(3fortran) ishft(3fortran)', & '', & '', & '', & 'NAME', & ' ISHFT(3) - [BIT:SHIFT] Logical shift of bits in an integer', & '', & '', & 'SYNOPSIS', & ' result = ishftc( i, shift )', & '', & ' elemental integer(kind=KIND) function ishft(i, shift )', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: shift', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I is an integer of any kind. the kind for I dictates the kind of the', & ' returned value.', & '', & ' o SHIFT is an integer of any kind.', & '', & 'DESCRIPTION', & ' ISHFT(3) returns a value corresponding to I with all of the bits shifted', & ' SHIFT places left or right as specified by the sign and magnitude of SHIFT.', & '', & ' Bits shifted out from the left end or right end are lost; zeros are shifted', & ' in from the opposite end.', & '', & 'OPTIONS', & ' o I : The value specifying the pattern of bits to shift', & '', & ' o SHIFT : A value of SHIFT greater than zero corresponds to a left shift, a', & ' value of zero corresponds to no shift, and a value less than zero', & ' corresponds to a right shift.', & '', & ' If the absolute value of SHIFT is greater than BIT_SIZE(I), the value is', & ' undefined.', & '', & 'RESULT', & ' The result has the value obtained by shifting the bits of I by SHIFT', & ' positions.', & '', & ' 1. If SHIFT is positive, the shift is to the left', & '', & ' 2. if SHIFT is negative, the shift is to the right', & '', & ' 3. if SHIFT is zero, no shift is performed.', & '', & ' Bits shifted out from the left or from the right, as appropriate, are lost.', & ' Zeros are shifted in from the opposite end.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ishft', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: shift', & ' character(len=*),parameter :: g=''(b32.32,1x,i0)''', & '', & ' write(*,*) ishft(3, 1),'' <== typically should have the value 6''', & '', & ' shift=4', & ' write(*,g) ishft(huge(0),shift), shift', & ' shift=0', & ' write(*,g) ishft(huge(0),shift), shift', & ' shift=-4', & ' write(*,g) ishft(huge(0),shift), shift', & ' end program demo_ishft', & '', & ' Results:', & '', & ' > 6 <== typically should have the value 6', & ' > 11111111111111111111111111110000 4', & ' > 01111111111111111111111111111111 0', & ' > 00000111111111111111111111111111 -4', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' ISHFTC(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ishft(3fortran)', & ''] shortname="ishft" call process() case('113','ishftc') textblock=[character(len=256) :: & '', & 'ishftc(3fortran) ishftc(3fortran)', & '', & '', & '', & 'NAME', & ' ISHFTC(3) - [BIT:SHIFT] Shift rightmost bits circularly, AKA. a logical', & ' shift', & '', & '', & 'SYNOPSIS', & ' result = ishftc( i, shift [,size] )', & '', & ' elemental integer(kind=KIND) function ishftc(i, shift, size)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: shift', & ' integer(kind=**),intent(in),optional :: size', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I may be an integer of any kind', & '', & ' o SHIFT and SIZE may be integers of any kind', & '', & ' o the kind for I dictates the kind of the returned value.', & '', & 'DESCRIPTION', & ' ISHFTC(3) circularly shifts just the specified rightmost bits of an integer.', & '', & ' ISHFTC(3) returns a value corresponding to I with the rightmost SIZE bits', & ' shifted circularly SHIFT places; that is, bits shifted out one end of the', & ' section are shifted into the opposite end of the section.', & '', & ' A value of SHIFT greater than zero corresponds to a left shift, a value of', & ' zero corresponds to no shift, and a value less than zero corresponds to a', & ' right shift.', & '', & 'OPTIONS', & ' o I : The value specifying the pattern of bits to shift', & '', & ' o SHIFT : If SHIFT is positive, the shift is to the left; if SHIFT is', & ' negative, the shift is to the right; and if SHIFT is zero, no shift is', & ' performed.', & '', & ' The absolute value of SHIFT must be less than SIZE (simply put, the', & ' number of positions to shift must be less than or equal to the number of', & ' bits specified to be shifted).', & '', & ' o SIZE : The value must be greater than zero and less than or equal to', & ' BIT_SIZE(i).', & '', & ' The default if BIT_SIZE(I) is absent is to circularly shift the entire', & ' value I.', & '', & 'RESULT', & ' The result characteristics (kind, shape, size, rank, ...) are the same as I.', & '', & ' The result has the value obtained by shifting the SIZE rightmost bits of I', & ' circularly by SHIFT positions.', & '', & ' No bits are lost.', & '', & ' The unshifted bits are unaltered.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_ishftc', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: i', & ' character(len=*),parameter :: g=''(b32.32,1x,i0)''', & ' ! basics', & ' write(*,*) ishftc(3, 1),'' <== typically should have the value 6''', & '', & ' print *, ''lets start with this:''', & ' write(*,''(b32.32)'')huge(0)', & ' print *, ''shift the value by various amounts, negative and positive''', & ' do i= -bit_size(0), bit_size(0), 8', & ' write(*,g) ishftc(huge(0),i), i', & ' enddo', & ' print *,''elemental''', & ' i=huge(0)', & ' write(*,*)ishftc(i,[2,3,4,5])', & ' write(*,*)ishftc([2**1,2**3,-2**7],3)', & ' print *,''note the arrays have to conform when elemental''', & ' write(*,*)ishftc([2**1,2**3,-2**7],[5,20,0])', & '', & ' end program demo_ishftc', & '', & ' Results:', & '', & ' > 6 <== typically should have the value 6', & ' > lets start with this:', & ' > 01111111111111111111111111111111', & ' > shift the value by various amounts, negative and positive', & ' > 01111111111111111111111111111111 -32', & ' > 11111111111111111111111101111111 -24', & ' > 11111111111111110111111111111111 -16', & ' > 11111111011111111111111111111111 -8', & ' > 01111111111111111111111111111111 0', & ' > 11111111111111111111111101111111 8', & ' > 11111111111111110111111111111111 16', & ' > 11111111011111111111111111111111 24', & ' > 01111111111111111111111111111111 32', & ' > elemental', & ' > -3 -5 -9 -17', & ' > 16 64 -1017', & ' > note the arrays have to conform when elemental', & ' > 64 8388608 -128', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o ISHFT(3) - Logical shift of bits in an integer', & '', & ' o SHIFTA(3) - Right shift with fill', & '', & ' o SHIFTL(3) - Shift bits left', & '', & ' o SHIFTR(3) - Combined right shift of the bits of two int...', & '', & ' o DSHIFTL(3) - Combined left shift of the bits of two inte...', & '', & ' o DSHIFTR(3) - Combined right shift of the bits of two int...', & '', & ' o CSHIFT(3) - Circular shift elements of an array', & '', & ' o EOSHIFT(3) - End-off shift elements of an array', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ishftc(3fortran)', & ''] shortname="ishftc" call process() case('114','is_iostat_end') textblock=[character(len=256) :: & '', & 'is_iostat_end(3fortran) is_iostat_end(3fortran)', & '', & '', & '', & 'NAME', & ' IS_IOSTAT_END(3) - [STATE:INQUIRY] Test for end-of-file value', & '', & '', & 'SYNOPSIS', & ' result = is_iostat_end(i)', & '', & ' elemental logical function is_iostat_end(i)', & '', & ' integer,intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o I is integer of any kind', & '', & ' o the return value is a default logical', & '', & 'DESCRIPTION', & ' IS_IOSTAT_END(3) tests whether a variable (assumed returned as a status from', & ' an I/O statement) has the "end of file" I/O status value.', & '', & ' The function is equivalent to comparing the variable with the IOSTAT_END', & ' parameter of the intrinsic module ISO_FORTRAN_ENV.', & '', & 'OPTIONS', & ' o I : An integer status value to test if indicating end of file.', & '', & 'RESULT', & ' returns .true. if and only ifI has the value which indicates an end of file', & ' condition for IOSTAT= specifiers, and is .false. otherwise.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_iostat', & ' implicit none', & ' real :: value', & ' integer :: ios', & ' character(len=256) :: message', & ' write(*,*)''Begin entering numeric values, one per line''', & ' do', & ' read(*,*,iostat=ios,iomsg=message)value', & ' if(ios.eq.0)then', & ' write(*,*)''VALUE='',value', & ' elseif( is_iostat_end(ios) ) then', & ' stop ''end of file. Goodbye!''', & ' else', & ' write(*,*)''ERROR:'',ios,trim(message)', & ' exit', & ' endif', & ' !', & ' enddo', & ' end program demo_iostat', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 is_iostat_end(3fortran)', & ''] shortname="is_iostat_end" call process() case('115','is_iostat_eor') textblock=[character(len=256) :: & '', & 'is_iostat_eor(3fortran) is_iostat_eor(3fortran)', & '', & '', & '', & 'NAME', & ' IS_IOSTAT_EOR(3) - [STATE:INQUIRY] Test for end-of-record value', & '', & '', & 'SYNOPSIS', & ' result = is_iostat_eor(i)', & '', & ' elemental integer function is_iostat_eor(i)', & '', & ' integer(kind=KIND),intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o I is integer of any kind', & '', & ' o the return value is a default logical', & '', & 'DESCRIPTION', & ' IS_IOSTAT_EOR(3) tests whether a variable has the value of the I/O status', & ' "end of record". The function is equivalent to comparing the variable with', & ' the IOSTAT_EOR parameter of the intrinsic module ISO_FORTRAN_ENV.', & '', & 'OPTIONS', & ' o I : The value to test as indicating "end of record".', & '', & 'RESULT', & ' Returns .true. if and only if I has the value which indicates an end-of-', & ' record condition for iostat= specifiers, and is .false. otherwise.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_is_iostat_eor', & ' use iso_fortran_env, only : iostat_eor', & ' implicit none', & ' integer :: inums(5), lun, ios', & '', & ' ! create a test file to read from', & ' open(newunit=lun, form=''formatted'',status=''scratch'')', & ' write(lun, ''(a)'') ''10 20 30''', & ' write(lun, ''(a)'') ''40 50 60 70''', & ' write(lun, ''(a)'') ''80 90''', & ' write(lun, ''(a)'') ''100''', & ' rewind(lun)', & '', & ' do', & ' read(lun, *, iostat=ios) inums', & ' write(*,*)''iostat='',ios', & ' if(is_iostat_eor(ios)) then', & ' stop ''end of record''', & ' elseif(is_iostat_end(ios)) then', & ' print *,''end of file''', & ' exit', & ' elseif(ios.ne.0)then', & ' print *,''I/O error'',ios', & ' exit', & ' endif', & ' enddo', & '', & ' close(lun,iostat=ios,status=''delete'')', & '', & ' end program demo_is_iostat_eor', & '', & ' Results:', & '', & ' > iostat= 0', & ' > iostat= -1', & ' > end of file', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 is_iostat_eor(3fortran)', & ''] shortname="is_iostat_eor" call process() case('116','kind') textblock=[character(len=256) :: & '', & 'kind(3fortran) kind(3fortran)', & '', & '', & '', & 'NAME', & ' KIND(3) - [KIND:INQUIRY] Query kind of an entity', & '', & '', & 'SYNOPSIS', & ' result = kind(x)', & '', & ' integer function kind(x)', & '', & ' type(TYPE(kind=**)),intent(in) :: x(..)', & '', & '', & 'CHARACTERISTICS', & ' o X may be of any intrinsic type. It may be a scalar or an array.', & '', & ' o the result is a default integer scalar', & '', & 'DESCRIPTION', & ' KIND(X)(3) returns the kind value of the entity X.', & '', & 'OPTIONS', & ' o X : Value to query the kind of.', & '', & 'RESULT', & ' The return value indicates the kind of the argument X.', & '', & ' Note that kinds are processor-dependent.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_kind', & ' implicit none', & ' integer,parameter :: dc = kind('' '')', & ' integer,parameter :: dl = kind(.true.)', & '', & ' print *, "The default character kind is ", dc', & ' print *, "The default logical kind is ", dl', & '', & ' end program demo_kind', & '', & ' Results:', & '', & ' The default character kind is 1', & ' The default logical kind is 4', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o ALLOCATED(3) - Status of an allocatable entity', & '', & ' o IS_CONTIGUOUS(3) - test if object is contiguous', & '', & ' o LBOUND(3) - Lower dimension bounds of an array', & '', & ' o RANK(3) - Rank of a data object', & '', & ' o SHAPE(3) - Determine the shape of an array', & '', & ' o SIZE(3) - Determine the size of an array', & '', & ' o UBOUND(3) - Upper dimension bounds of an array', & '', & ' o BIT_SIZE(3) - Bit size inquiry function', & '', & ' o STORAGE_SIZE(3) - Storage size in bits', & '', & ' o KIND(3) - Kind of an entity', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 kind(3fortran)', & ''] shortname="kind" call process() case('117','lbound') textblock=[character(len=256) :: & '', & 'lbound(3fortran) lbound(3fortran)', & '', & '', & '', & 'NAME', & ' LBOUND(3) - [ARRAY:INQUIRY] Lower dimension bounds of an array', & '', & '', & 'SYNOPSIS', & ' result = lbound(array [,dim] [,kind] )', & '', & ' elemental TYPE(kind=KIND) function lbound(array,dim,kind)', & '', & ' TYPE(kind=KIND),intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' integer(kind=**),intent(in),optional :: kind', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY shall be assumed-rank or an array, of any type. It cannot be an', & ' unallocated allocatable array or a pointer that is not associated.', & '', & ' o DIM shall be a scalar integer. The corresponding actual argument shall', & ' not be an optional dummy argument, a disassociated pointer, or an', & ' unallocated allocatable.', & '', & ' o KIND an integer initialization expression indicating the kind parameter', & ' of the result.', & '', & ' o The return value is of type integer and of kind KIND. If KIND is absent,', & ' the return value is of default integer kind. The result is scalar if DIM', & ' is present; otherwise, the result is an array of rank one and size n,', & ' where n is the rank of ARRAY.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' RESULT(3) returns the lower bounds of an array, or a single lower bound', & ' along the DIM dimension.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an array, of any type.', & '', & ' o DIM : Shall be a scalar integer. If DIM is absent, the result is an array', & ' of the upper bounds of ARRAY.', & '', & ' o KIND : An integer initialization expression indicating the kind parameter', & ' of the result.', & '', & 'RESULT', & ' If DIM is absent, the result is an array of the lower bounds of ARRAY.', & '', & ' If DIM is present, the result is a scalar corresponding to the lower bound', & ' of the array along that dimension. If ARRAY is an expression rather than a', & ' whole array or array structure component, or if it has a zero extent along', & ' the relevant dimension, the lower bound is taken to be', & '', & ' 1.', & '', & '', & ' NOTE1', & '', & ' If **array** is assumed-rank and has rank zero, **dim** cannot be', & ' present since it cannot satisfy the requirement **1 <= dim <= 0**.', & '', & '', & 'EXAMPLES', & ' Note that in my opinion this function should not be used on assumed-size', & ' arrays or in any function without an explicit interface. Errors can occur if', & ' there is no interface defined.', & '', & ' Sample program', & '', & ' ! program demo_lbound', & ' module m_bounds', & ' implicit none', & ' contains', & ' subroutine msub(arr)', & ' !!integer,intent(in) :: arr(*) ! cannot be assumed-size array', & ' integer,intent(in) :: arr(:)', & ' write(*,*)''MSUB: LOWER='',lbound(arr), &', & ' & ''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' end subroutine msub', & ' end module m_bounds', & '', & ' program demo_lbound', & ' use m_bounds, only : msub', & ' implicit none', & ' interface', & ' subroutine esub(arr)', & ' integer,intent(in) :: arr(:)', & ' end subroutine esub', & ' end interface', & ' integer :: arr(-10:10)', & ' write(*,*)''MAIN: LOWER='',lbound(arr), &', & ' & ''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' call csub()', & ' call msub(arr)', & ' call esub(arr)', & ' contains', & ' subroutine csub', & ' write(*,*)''CSUB: LOWER='',lbound(arr), &', & ' & ''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' end subroutine csub', & ' end', & '', & ' subroutine esub(arr)', & ' implicit none', & ' integer,intent(in) :: arr(:)', & ' ! WARNING: IF CALLED WITHOUT AN EXPLICIT INTERFACE', & ' ! THIS WILL GIVE UNDEFINED ANSWERS (like 0,0,0)', & ' write(*,*)''ESUB: LOWER='',lbound(arr), &', & ' & ''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' end subroutine esub', & '', & ' !end program demo_lbound', & '', & ' Results:', & '', & ' MAIN: LOWER= -10 UPPER= 10 SIZE= 21', & ' CSUB: LOWER= -10 UPPER= 10 SIZE= 21', & ' MSUB: LOWER= 1 UPPER= 21 SIZE= 21', & ' ESUB: LOWER= 1 UPPER= 21 SIZE= 21', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument - Fortran 2003', & '', & 'SEE ALSO', & ' Array inquiry:', & '', & ' o SIZE(3) - Determine the size of an array', & '', & ' o RANK(3) - Rank of a data object', & '', & ' o SHAPE(3) - Determine the shape of an array', & '', & ' o UBOUND(3) - Upper dimension bounds of an array', & '', & ' CO_UBOUND(3), CO_LBOUND(3)', & '', & ' State Inquiry:', & '', & ' o ALLOCATED(3) - Status of an allocatable entity', & '', & ' o IS_CONTIGUOUS(3) - Test if object is contiguous', & '', & ' Kind Inquiry:', & '', & ' o KIND(3) - Kind of an entity', & '', & ' Bit Inquiry:', & '', & ' o STORAGE_SIZE(3) - Storage size in bits', & '', & ' o BIT_SIZE(3) - Bit size inquiry function', & '', & ' o BTEST(3) - Tests a bit of an integer value.', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 lbound(3fortran)', & ''] shortname="lbound" call process() case('118','lcobound') textblock=[character(len=256) :: & '', & 'lcobound(3fortran) lcobound(3fortran)', & '', & '', & '', & 'NAME', & ' LCOBOUND(3) - [COLLECTIVE] Lower codimension bounds of an array', & '', & '', & 'SYNOPSIS', & ' result = lcobound( coarray [,dim] [,kind] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' LCOBOUND(3) returns the lower bounds of a coarray, or a single lower cobound', & ' along the DIM codimension.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an coarray, of any type.', & '', & ' o DIM : (Optional) Shall be a scalar integer.', & '', & ' o KIND : (Optional) An integer initialization expression indicating the', & ' kind parameter of the result.', & '', & 'RESULT', & ' The return value is of type integer and of kind KIND. If KIND is absent, the', & ' return value is of default integer kind. If DIM is absent, the result is an', & ' array of the lower cobounds of COARRAY. If DIM is present, the result is a', & ' scalar corresponding to the lower cobound of the array along that', & ' codimension.', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' UCOBOUND(3), LBOUND(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 lcobound(3fortran)', & ''] shortname="lcobound" call process() case('119','leadz') textblock=[character(len=256) :: & '', & 'leadz(3fortran) leadz(3fortran)', & '', & '', & '', & 'NAME', & ' LEADZ(3) - [BIT:COUNT] Number of leading zero bits of an integer', & '', & '', & 'SYNOPSIS', & ' result = leadz(i)', & '', & ' elemental integer function leadz(i)', & '', & ' integer(kind=**),intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o I may be an integer of any kind.', & '', & ' o the return value is a default integer type.', & '', & 'DESCRIPTION', & ' LEADZ(3) returns the number of leading zero bits of an integer.', & '', & 'OPTIONS', & ' o I : integer to count the leading zero bits of.', & '', & 'RESULT', & ' The number of leading zero bits, taking into account the kind of the input', & ' value. If all the bits of I are zero, the result value is BIT_SIZE(I).', & '', & ' The result may also be thought of as BIT_SIZE(I)-1-K where K is the position', & ' of the leftmost 1 bit in the input I. Positions are from 0 to bit-size(),', & ' with 0 at the right-most bit.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_leadz', & ' implicit none', & ' integer :: value, i', & ' character(len=80) :: f', & '', & ' ! make a format statement for writing a value as a bit string', & ' write(f,''("(b",i0,".",i0,")")'')bit_size(value),bit_size(value)', & '', & ' ! show output for various integer values', & ' value=0', & ' do i=-150, 150, 50', & ' value=i', & ' write (*,''("LEADING ZERO BITS=",i3)'',advance=''no'') leadz(value)', & ' write (*,''(" OF VALUE ")'',advance=''no'')', & ' write(*,f,advance=''no'') value', & ' write(*,''(*(1x,g0))'') "AKA",value', & ' enddo', & ' ! Notes:', & ' ! for two''s-complements programming environments a negative non-zero', & ' ! integer value will always start with a 1 and a positive value with 0', & ' ! as the first bit is the sign bit. Such platforms are very common.', & ' end program demo_leadz', & '', & ' Results:', & '', & ' LEADING ZERO BITS= 0 OF VALUE 11111111111111111111111101101010 AKA -150', & ' LEADING ZERO BITS= 0 OF VALUE 11111111111111111111111110011100 AKA -100', & ' LEADING ZERO BITS= 0 OF VALUE 11111111111111111111111111001110 AKA -50', & ' LEADING ZERO BITS= 32 OF VALUE 00000000000000000000000000000000 AKA 0', & ' LEADING ZERO BITS= 26 OF VALUE 00000000000000000000000000110010 AKA 50', & ' LEADING ZERO BITS= 25 OF VALUE 00000000000000000000000001100100 AKA 100', & ' LEADING ZERO BITS= 24 OF VALUE 00000000000000000000000010010110 AKA 150', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BIT_SIZE(3), POPCNT(3), POPPAR(3), TRAILZ(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 leadz(3fortran)', & ''] shortname="leadz" call process() case('120','len') textblock=[character(len=256) :: & '', & 'len(3fortran) len(3fortran)', & '', & '', & '', & 'NAME', & ' LEN(3) - [CHARACTER] Length of a character entity', & '', & '', & 'SYNOPSIS', & ' result = len(string [,kind])', & '', & ' integer(kind=KIND) function len(string,KIND)', & '', & ' character(len=*),intent(in) :: string(..)', & ' integer,optional,intent(in) :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o STRING is a scalar or array character variable', & '', & ' o KIND is a scalar integer constant expression.', & '', & ' o the returned value is the same integer kind as the KIND argument, or of', & ' the default integer kind if KIND is not specified.', & '', & 'DESCRIPTION', & ' LEN(3) returns the length of a character string.', & '', & ' If STRING is an array, the length of a single element of STRING is returned,', & ' as all elements of an array are the same length.', & '', & ' Note that STRING need not be defined when this intrinsic is invoked, as only', & ' the length (not the content) of STRING is needed.', & '', & 'OPTIONS', & ' o STRING : A scalar or array string to return the length of. If it is an', & ' unallocated allocatable variable or a pointer that is not associated, its', & ' length type parameter shall not be deferred.', & '', & ' o KIND : A constant indicating the kind parameter of the result.', & '', & 'RESULT', & ' The result has a value equal to the number of characters in STRING if it is', & ' scalar or in an element of STRING if it is an array.', & '', & 'EXAMPLES', & ' Sample program', & '', & ' program demo_len', & ' implicit none', & '', & ' ! fixed length', & ' character(len=40) :: string', & ' ! allocatable length', & ' character(len=:),allocatable :: astring', & ' character(len=:),allocatable :: many_strings(:)', & ' integer :: ii', & ' ! BASIC USAGE', & ' ii=len(string)', & ' write(*,*)''length ='',ii', & '', & ' ! ALLOCATABLE VARIABLE LENGTH CAN CHANGE', & ' ! the allocatable string length will be the length of RHS expression', & ' astring='' How long is this allocatable string? ''', & ' write(*,*)astring, '' LEN='', len(astring)', & ' ! print underline', & ' write(*,*) repeat(''='',len(astring))', & ' ! assign new value to astring and length changes', & ' astring=''New allocatable string''', & ' write(*,*)astring, '' LEN='', len(astring)', & ' ! print underline', & ' write(*,*) repeat(''='',len(astring))', & '', & ' ! THE STRING LENGTH WILL BE CONSTANT FOR A FIXED-LENGTH VARIABLE', & ' string='' How long is this fixed string? ''', & ' write(*,*)string,'' LEN='',len(string)', & ' string=''New fixed string ''', & ' write(*,*)string,'' LEN='',len(string)', & '', & ' ! ALL STRINGS IN AN ARRAY ARE THE SAME LENGTH', & ' ! a scalar is returned for an array, as all values in a Fortran', & ' ! character array must be of the same length.', & ' many_strings = [ character(len=7) :: ''Tom'', ''Dick'', ''Harry'' ]', & ' write(*,*)''length of ALL elements of array='',len(many_strings)', & '', & ' ! NAME%LEN IS ESSENTIALLY THE SAME AS LEN(NAME)', & ' ! you can also query the length (and other attributes) of a string', & ' ! using a "type parameter inquiry" (available since fortran 2018)', & ' write(*,*)''length from type parameter inquiry='',string%len', & ' ! %len is equivalent to a call to LEN() except the kind of the integer', & ' ! value returned is always of default kind.', & '', & ' ! LOOK AT HOW A PASSED STRING CAN BE USED ...', & ' call passed('' how long? '')', & '', & ' contains', & '', & ' subroutine passed(str)', & ' character(len=*),intent(in) :: str', & ' ! the length of str can be used in the definitions of variables', & ' ! you can query the length of the passed variable', & ' write(*,*)''length of passed value is '', LEN(str)', & ' end subroutine passed', & '', & ' end program demo_len', & '', & ' Results:', & '', & ' > length = 40', & ' > How long is this allocatable string? LEN= 38', & ' > ======================================', & ' > New allocatable string LEN= 22', & ' > ======================', & ' > How long is this fixed string? LEN= 40', & ' > New fixed string LEN= 40', & ' > length of ALL elements of array= 7', & ' > length from type parameter inquiry= 40', & ' > length of passed value is 11', & '', & '', & 'STANDARD', & ' FORTRAN 77 ; with KIND argument - Fortran 2003', & '', & 'SEE ALSO', & ' len_trim(3), adjustr(3), trim(3), and adjustl(3) are related routines that', & ' allow you to deal with leading and trailing blanks.', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 len(3fortran)', & ''] shortname="len" call process() case('121','len_trim') textblock=[character(len=256) :: & '', & 'len_trim(3fortran) len_trim(3fortran)', & '', & '', & '', & 'NAME', & ' LEN_TRIM(3) - [CHARACTER:WHITESPACE] Character length without trailing blank', & ' characters', & '', & '', & 'SYNOPSIS', & ' result = len_trim(string [,kind])', & '', & ' elemental integer(kind=KIND) function len_trim(string,KIND)', & '', & ' character(len=*),intent(in) :: string', & ' integer(kind=KIND),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o STRING is of type character', & '', & ' o KIND is a scalar integer constant expression specifying the kind of the', & ' returned value.', & '', & ' o The return value is of type integer and of kind KIND. If KIND is absent,', & ' the return value is of default integer kind.', & '', & 'DESCRIPTION', & ' LEN_TRIM(3) returns the length of a character string, ignoring any trailing', & ' blanks.', & '', & 'OPTIONS', & ' o STRING : The input string whose length is to be measured.', & '', & ' o KIND : Indicates the kind parameter of the result.', & '', & 'RESULT', & ' The result equals the number of characters remaining after any trailing', & ' blanks in STRING are removed.', & '', & ' If the input argument is of zero length or all blanks the result is zero.', & '', & 'EXAMPLES', & ' Sample program', & '', & ' program demo_len_trim', & ' implicit none', & ' character(len=:),allocatable :: string', & ' integer :: i', & ' ! basic usage', & ' string=" how long is this string? "', & ' write(*,*) string', & ' write(*,*)''UNTRIMMED LENGTH='',len(string)', & ' write(*,*)''TRIMMED LENGTH='',len_trim(string)', & '', & ' ! print string, then print substring of string', & ' string=''xxxxx ''', & ' write(*,*)string,string,string', & ' i=len_trim(string)', & ' write(*,*)string(:i),string(:i),string(:i)', & ' !', & ' ! elemental example', & ' ELE:block', & ' ! an array of strings may be used', & ' character(len=:),allocatable :: tablet(:)', & ' tablet=[character(len=256) :: &', & ' & '' how long is this string? '',&', & ' & ''and this one?'']', & ' write(*,*)''UNTRIMMED LENGTH= '',len(tablet)', & ' write(*,*)''TRIMMED LENGTH= '',len_trim(tablet)', & ' write(*,*)''SUM TRIMMED LENGTH='',sum(len_trim(tablet))', & ' endblock ELE', & ' !', & ' end program demo_len_trim', & '', & ' Results:', & '', & ' how long is this string?', & '', & ' UNTRIMMED LENGTH=', & ' 30', & '', & ' TRIMMED LENGTH=', & ' 25', & '', & ' xxxxx', & ' xxxxx xxxxx xxxxxxxxxxxxxxx', & '', & ' UNTRIMMED LENGTH=', & ' 256', & '', & ' TRIMMED LENGTH=', & ' 25 13', & '', & ' SUM TRIMMED LENGTH=', & ' 38', & '', & 'STANDARD', & ' Fortran 95 . KIND argument added with Fortran 2003.', & '', & 'SEE ALSO', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: REPEAT(3), LEN(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 len_trim(3fortran)', & ''] shortname="len_trim" call process() case('122','lge') textblock=[character(len=256) :: & '', & 'lge(3fortran) lge(3fortran)', & '', & '', & '', & 'NAME', & ' LGE(3) - [CHARACTER:COMPARE] ASCII Lexical greater than or equal', & '', & '', & 'SYNOPSIS', & ' result = lge(string_a, stringb)', & '', & ' elemental logical function lge(string_a, string_b)', & '', & ' character(len=*),intent(in) :: string_a', & ' character(len=*),intent(in) :: string_b', & '', & '', & 'CHARACTERISTICS', & ' o STRING_A is default character or an ASCII character.', & '', & ' o STRING_B is the same type and kind as STRING_A', & '', & ' o the result is a default logical', & '', & 'DESCRIPTION', & ' LGE(3) determines whether one string is lexically greater than or equal to', & ' another string, where the two strings are interpreted as containing ASCII', & ' character codes. If STRING_A and STRING_B are not the same length, the', & ' shorter is compared as if spaces were appended to it to form a value that', & ' has the same length as the longer.', & '', & ' The lexical comparison intrinsics LGE(3), LGT(3), LLE(3), and LLT(3) differ', & ' from the corresponding intrinsic operators .ge., .gt., .le., and .lt., in', & ' that the latter use the processor''s character ordering (which is not ASCII', & ' on some targets), whereas the former always use the ASCII ordering.', & '', & 'OPTIONS', & ' o STRING_A : string to be tested', & '', & ' o STRING_B : string to compare to STRING_A', & '', & 'RESULT', & ' Returns .true. if string_a == string_b, and .false. otherwise, based on the', & ' ASCII collating sequence.', & '', & ' If both input arguments are null strings, .true. is always returned.', & '', & ' If either string contains a character not in the ASCII character set, the', & ' result is processor dependent.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_lge', & ' implicit none', & ' integer :: i', & ' print *,''the ASCII collating sequence for printable characters''', & ' write(*,''(1x,19a)'')(char(i),i=32,126) ! ASCII order', & ' write(*,*) lge(''abc'',''ABC'') ! [T] lowercase is > uppercase', & ' write(*,*) lge(''abc'',''abc '') ! [T] trailing spaces', & ' ! If both strings are of zero length the result is true', & ' write(*,*) lge('''','''') ! [T]', & ' write(*,*) lge('''',''a'') ! [F] the null string is padded', & ' write(*,*) lge(''a'','''') ! [T]', & ' ! elemental', & ' write(*,*) lge(''abc'',[''abc'',''123'']) ! [T T] scalar and array', & ' write(*,*) lge([''cba'', ''123''],''abc'') ! [T F]', & ' write(*,*) lge([''abc'',''123''],[''cba'',''123'']) ! [F T] both arrays', & ' end program demo_lge', & '', & ' Results:', & '', & ' > the ASCII collating sequence for printable characters', & ' > !"#$%&''()*+,-./012', & ' > 3456789:;<=>?@ABCDE', & ' > FGHIJKLMNOPQRSTUVWX', & ' > YZ[\]^_`abcdefghijk', & ' > lmnopqrstuvwxyz{|}~', & ' > T', & ' > T', & ' > T', & ' > F', & ' > T', & ' > T T', & ' > T F', & ' > F T', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' LGT(3), LLE(3), LLT(3)', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3),', & '', & ' SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 lge(3fortran)', & ''] shortname="lge" call process() case('123','lgt') textblock=[character(len=256) :: & '', & 'lgt(3fortran) lgt(3fortran)', & '', & '', & '', & 'NAME', & ' LGT(3) - [CHARACTER:COMPARE] ASCII Lexical greater than', & '', & '', & 'SYNOPSIS', & ' result = lgt(string_a, string_b)', & '', & ' elemental logical function lgt(string_a, string_b)', & '', & ' character(len=*),intent(in) :: string_a', & ' character(len=*),intent(in) :: string_b', & '', & '', & 'CHARACTERISTICS', & ' o STRING_A is default character or an ASCII character.', & '', & ' o STRING_B is the same type and kind as STRING_A', & '', & ' o the result is a default logical', & '', & 'DESCRIPTION', & ' LGT(3) determines whether one string is lexically greater than another', & ' string, where the two strings are interpreted as containing ASCII character', & ' codes. If the String A and String B are not the same length, the shorter is', & ' compared as if spaces were appended to it to form a value that has the same', & ' length as the longer.', & '', & ' In general, the lexical comparison intrinsics LGE, LGT, LLE, and LLT differ', & ' from the corresponding intrinsic operators .ge., .gt., .le., and .lt., in', & ' that the latter use the processor''s character ordering (which is not ASCII', & ' on some targets), whereas the former always use the ASCII ordering.', & '', & 'OPTIONS', & ' o STRING_A : string to be tested', & '', & ' o STRING_B : string to compare to STRING_A', & '', & 'RESULT', & ' Returns .true. if string_a > string_b, and .false. otherwise, based on the', & ' ASCII ordering.', & '', & ' If both input arguments are null strings, .false. is returned.', & '', & ' If either string contains a character not in the ASCII character set, the', & ' result is processor dependent.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_lgt', & ' implicit none', & ' integer :: i', & ' print *,''the ASCII collating sequence for printable characters''', & ' write(*,''(1x,19a)'')(char(i),i=32,126)', & '', & ' write(*,*) lgt(''abc'',''ABC'') ! [T] lowercase is > uppercase', & ' write(*,*) lgt(''abc'',''abc '') ! [F] trailing spaces', & '', & ' ! If both strings are of zero length the result is false.', & ' write(*,*) lgt('''','''') ! [F]', & ' write(*,*) lgt('''',''a'') ! [F] the null string is padded', & ' write(*,*) lgt(''a'','''') ! [T]', & ' write(*,*) lgt(''abc'',[''abc'',''123'']) ! [F T] scalar and array', & ' write(*,*) lgt([''cba'', ''123''],''abc'') ! [T F]', & ' write(*,*) lgt([''abc'',''123''],[''cba'',''123'']) ! [F F] both arrays', & ' end program demo_lgt', & '', & ' Results:', & '', & ' > the ASCII collating sequence for printable characters', & ' > !"#$%&''()*+,-./012', & ' > 3456789:;<=>?@ABCDE', & ' > FGHIJKLMNOPQRSTUVWX', & ' > YZ[\]^_`abcdefghijk', & ' > lmnopqrstuvwxyz{|}~', & ' > T', & ' > F', & ' > F', & ' > F', & ' > T', & ' > F T', & ' > T F', & ' > F F', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' LGE(3), LLE(3), LLT(3)', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3),', & '', & ' SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 lgt(3fortran)', & ''] shortname="lgt" call process() case('124','lle') textblock=[character(len=256) :: & '', & 'lle(3fortran) lle(3fortran)', & '', & '', & '', & 'NAME', & ' LLE(3) - [CHARACTER:COMPARE] ASCII Lexical less than or equal', & '', & '', & 'SYNOPSIS', & ' result = lle(string_a, stringb)', & '', & ' elemental logical function lle(string_a, string_b)', & '', & ' character(len=*),intent(in) :: string_a', & ' character(len=*),intent(in) :: string_b', & '', & '', & 'CHARACTERISTICS', & ' o STRING_A is default character or an ASCII character.', & '', & ' o STRING_B is the same type and kind as STRING_A', & '', & ' o the result is a default logical', & '', & 'DESCRIPTION', & ' LLE(3) determines whether one string is lexically less than or equal to', & ' another string, where the two strings are interpreted as containing ASCII', & ' character codes.', & '', & ' If STRING_A and STRING_B are not the same length, the shorter is compared as', & ' if spaces were appended to it to form a value that has the same length as', & ' the longer.', & '', & ' Leading spaces are significant.', & '', & ' In general, the lexical comparison intrinsics LGE, LGT, LLE, and LLT differ', & ' from the corresponding intrinsic operators .ge., .gt., .le., and .lt., in', & ' that the latter use the processor''s character ordering (which is not ASCII', & ' on some targets), whereas LLE(3) always uses the ASCII ordering.', & '', & 'OPTIONS', & ' o STRING_A : string to be tested', & '', & ' o STRING_B : string to compare to STRING_A', & '', & 'RESULT', & ' o RESULT Returns .true. if STRING_A <= STRING_B, and .false. otherwise,', & ' based on the ASCII collating sequence.', & '', & ' If both input arguments are null strings, .true. is always returned.', & '', & ' If either string contains a character not in the ASCII character set, the', & ' result is processor dependent.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_lle', & ' implicit none', & ' integer :: i', & ' print *,''the ASCII collating sequence for printable characters''', & ' write(*,''(1x,19a)'')(char(i),i=32,126)', & ' ! basics', & '', & ' print *,''case matters''', & ' write(*,*) lle(''abc'',''ABC'') ! F lowercase is > uppercase', & '', & ' print *,''a space is the lowest printable character''', & ' write(*,*) lle(''abcd'',''abc'') ! F d > space', & ' write(*,*) lle(''abc'',''abcd'') ! T space < d', & '', & ' print *,''leading spaces matter, trailing spaces do not''', & ' write(*,*) lle(''abc'',''abc '') ! T trailing spaces', & ' write(*,*) lle(''abc'','' abc'') ! F leading spaces are significant', & '', & ' print *,''even null strings are padded and compared''', & ' ! If both strings are of zero length the result is true.', & ' write(*,*) lle('''','''') ! T', & ' write(*,*) lle('''',''a'') ! T the null string is padded', & ' write(*,*) lle(''a'','''') ! F', & ' print *,''elemental''', & ' write(*,*) lle(''abc'',[''abc'',''123'']) ! [T,F] scalar and array', & ' write(*,*) lle([''cba'', ''123''],''abc'') ! [F,T]', & ' ! per the rules for elemental procedures arrays must be the same size', & ' write(*,*) lle([''abc'',''123''],[''cba'',''123'']) ! [T,T] both arrays', & ' end program demo_lle', & '', & ' Results:', & '', & ' > the ASCII collating sequence for printable characters', & ' > !"#$%&''()*+,-./012', & ' > 3456789:;<=>?@ABCDE', & ' > FGHIJKLMNOPQRSTUVWX', & ' > YZ[\]^_`abcdefghijk', & ' > lmnopqrstuvwxyz{|}~', & ' > case matters', & ' > F', & ' > a space is the lowest printable character', & ' > F', & ' > T', & ' > leading spaces matter, trailing spaces do not', & ' > T', & ' > F', & ' > even null strings are padded and compared', & ' > T', & ' > T', & ' > F', & ' > elemental', & ' > T F', & ' > F T', & ' > T T', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' LGE(3), LGT(3), LLT(3)', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3),', & '', & ' SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 lle(3fortran)', & ''] shortname="lle" call process() case('125','llt') textblock=[character(len=256) :: & '', & 'llt(3fortran) llt(3fortran)', & '', & '', & '', & 'NAME', & ' LLT(3) - [CHARACTER:COMPARE] ASCII Lexical less than', & '', & '', & 'SYNOPSIS', & ' result = llt(string_a, stringb)', & '', & ' elemental logical function llt(string_a, string_b)', & '', & ' character(len=*),intent(in) :: string_a', & ' character(len=*),intent(in) :: string_b', & '', & '', & 'CHARACTERISTICS', & ' o STRING_A is default character or an ASCII character.', & '', & ' o STRING_B is the same type and kind as STRING_A', & '', & ' o the result is a default logical', & '', & 'DESCRIPTION', & ' LLT(3) determines whether one string is lexically less than another string,', & ' where the two strings are interpreted as containing ASCII character codes.', & ' If the STRING_A and STRING_B are not the same length, the shorter is', & ' compared as if spaces were appended to it to form a value that has the same', & ' length as the longer.', & '', & ' In general, the lexical comparison intrinsics LGE, LGT, LLE, and LLT differ', & ' from the corresponding intrinsic operators .ge., .gt., .le., and .lt., in', & ' that the latter use the processor''s character ordering (which is not ASCII', & ' on some targets), whereas the former always use the ASCII ordering.', & '', & 'OPTIONS', & ' o STRING_A : string to be tested', & '', & ' o STRING_B : string to compare to STRING_A', & '', & 'RESULT', & ' Returns .true. if string_a <= string_b, and .false. otherwise, based on the', & ' ASCII collating sequence.', & '', & ' If both input arguments are null strings, .false. is always returned.', & '', & ' If either string contains a character not in the ASCII character set, the', & ' result is processor dependent.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_llt', & ' implicit none', & ' integer :: i', & '', & ' print *,''the ASCII collating sequence for printable characters''', & ' write(*,''(1x,19a)'')(char(i),i=32,126) ! ASCII order', & '', & ' ! basics', & ' print *,''case matters''', & ' write(*,*) llt(''abc'',''ABC'') ! [F] lowercase is > uppercase', & ' write(*,*) llt(''abc'',''abc '') ! [F] trailing spaces', & ' ! If both strings are of zero length the result is false.', & ' write(*,*) llt('''','''') ! [F]', & ' write(*,*) llt('''',''a'') ! [T] the null string is padded', & ' write(*,*) llt(''a'','''') ! [F]', & ' print *,''elemental''', & ' write(*,*) llt(''abc'',[''abc'',''123'']) ! [F F] scalar and array', & ' write(*,*) llt([''cba'', ''123''],''abc'') ! [F T]', & ' write(*,*) llt([''abc'',''123''],[''cba'',''123'']) ! [T F] both arrays', & ' end program demo_llt', & '', & ' Results:', & '', & ' > the ASCII collating sequence for printable characters', & ' > !"#$%&''()*+,-./012', & ' > 3456789:;<=>?@ABCDE', & ' > FGHIJKLMNOPQRSTUVWX', & ' > YZ[\]^_`abcdefghijk', & ' > lmnopqrstuvwxyz{|}~', & ' > case matters', & ' > F', & ' > F', & ' > F', & ' > T', & ' > F', & ' > elemental', & ' > F F', & ' > F T', & ' > T F', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' LGE(3), LGT(3), LLE(3))', & '', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 llt(3fortran)', & ''] shortname="llt" call process() case('126','log10') textblock=[character(len=256) :: & '', & 'log10(3fortran) log10(3fortran)', & '', & '', & '', & 'NAME', & ' LOG10(3) - [MATHEMATICS] Base 10 or common logarithm', & '', & '', & 'SYNOPSIS', & ' result = log10(x)', & '', & ' elemental real(kind=KIND) function log10(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be any kind of real value', & '', & ' o the result is the same type and characteristics as X.', & '', & 'DESCRIPTION', & ' LOG10(3) computes the base 10 logarithm of X. This is generally called the', & ' "common logarithm".', & '', & 'OPTIONS', & ' o X : A real value > 0 to take the log of.', & '', & 'RESULT', & ' The logarithm to base 10 of X', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_log10', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 10.0_real64', & '', & ' x = log10(x)', & ' write(*,''(*(g0))'')''log10('',x,'') is '',log10(x)', & '', & ' ! elemental', & ' write(*, *)log10([1.0, 10.0, 100.0, 1000.0, 10000.0, &', & ' & 100000.0, 1000000.0, 10000000.0])', & '', & ' end program demo_log10', & '', & ' Results:', & '', & ' > log10(1.000000000000000) is .000000000000000', & ' > 0.0000000E+00 1.000000 2.000000 3.000000 4.000000', & ' > 5.000000 6.000000 7.000000', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 log10(3fortran)', & ''] shortname="log10" call process() case('127','log') textblock=[character(len=256) :: & '', & 'log(3fortran) log(3fortran)', & '', & '', & '', & 'NAME', & ' LOG(3) - [MATHEMATICS] Natural logarithm', & '', & '', & 'SYNOPSIS', & ' result = log(x)', & '', & ' elemental TYPE(kind=KIND) function log(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be any real or complex kind.', & '', & ' o the result is the same type and characteristics as X.', & '', & 'DESCRIPTION', & ' LOG(3) computes the natural logarithm of X, i.e. the logarithm to the base', & ' "e".', & '', & 'OPTIONS', & ' o X : The value to compute the natural log of. If X is real, its value', & ' shall be greater than zero. If X is complex, its value shall not be zero.', & '', & 'RESULT', & ' The natural logarithm of X. If X is the complex value (R,I) , the imaginary', & ' part "i" is in the range', & '', & ' -PI < i <= PI', & '', & ' If the real part of X is less than zero and the imaginary part of X is zero,', & ' then the imaginary part of the result is approximately PI if the imaginary', & ' part of PI is positive real zero or the processor does not distinguish', & ' between positive and negative real zero, and approximately -PI if the', & ' imaginary part of X is negative real zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_log', & ' implicit none', & ' real(kind(0.0d0)) :: x = 2.71828182845904518d0', & ' complex :: z = (1.0, 2.0)', & ' write(*,*)x, log(x) ! will yield (approximately) 1', & ' write(*,*)z, log(z)', & ' end program demo_log', & '', & ' Results:', & '', & ' 2.7182818284590451 1.0000000000000000', & ' (1.00000000,2.00000000) (0.804718971,1.10714877)', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 log(3fortran)', & ''] shortname="log" call process() case('128','log_gamma') textblock=[character(len=256) :: & '', & 'log_gamma(3fortran) log_gamma(3fortran)', & '', & '', & '', & 'NAME', & ' LOG_GAMMA(3) - [MATHEMATICS] Logarithm of the absolute value of the Gamma', & ' function', & '', & '', & 'SYNOPSIS', & ' result = log_gamma(x)', & '', & ' elemental real(kind=KIND) function log_gamma(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be any real type', & '', & ' o the return value is of same type and kind as X.', & '', & 'DESCRIPTION', & ' LOG_GAMMA(3) computes the natural logarithm of the absolute value of the', & ' Gamma function.', & '', & 'OPTIONS', & ' o X : neither negative nor zero value to render the result for.', & '', & 'RESULT', & ' The result has a value equal to a processor-dependent approximation to the', & ' natural logarithm of the absolute value of the gamma function of X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_log_gamma', & ' implicit none', & ' real :: x = 1.0', & ' write(*,*)x,log_gamma(x) ! returns 0.0', & ' write(*,*)x,log_gamma(3.0) ! returns 0.693 (approximately)', & ' end program demo_log_gamma', & '', & ' Results:', & '', & ' > 1.000000 0.0000000E+00', & ' > 1.000000 0.6931472', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' Gamma function: GAMMA(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 log_gamma(3fortran)', & ''] shortname="log_gamma" call process() case('129','logical') textblock=[character(len=256) :: & '', & 'logical(3fortran) logical(3fortran)', & '', & '', & '', & 'NAME', & ' LOGICAL(3) - [TYPE:LOGICAL] Conversion between kinds of logical values', & '', & '', & 'SYNOPSIS', & ' result = logical(l [,kind])', & '', & ' elemental logical(kind=KIND) function logical(l,KIND)', & '', & ' logical(kind=**),intent(in) :: l', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o L is of type logical', & '', & ' o KIND shall be a scalar integer constant expression. If KIND is present,', & ' the kind type parameter of the result is that specified by the value of', & ' KIND; otherwise, the kind type parameter is that of default logical.', & '', & 'DESCRIPTION', & ' LOGICAL(3) converts one kind of logical variable to another.', & '', & 'OPTIONS', & ' o L : The logical value to produce a copy of with kind KIND', & '', & ' o KIND : indicates the kind parameter of the result. If not present, the', & ' default kind is returned.', & '', & 'RESULT', & ' The return value is a logical value equal to L, with a kind corresponding to', & ' KIND, or of the default logical kind if KIND is not given.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' Linux', & ' program demo_logical', & ' ! Access array containing the kind type parameter values supported by this', & ' ! compiler for entities of logical type', & ' use iso_fortran_env, only : logical_kinds', & ' implicit none', & ' integer :: i', & '', & ' ! list kind values supported on this platform, which generally vary', & ' ! in storage size as alias declarations', & ' do i =1, size(logical_kinds)', & ' write(*,''(*(g0))'')''integer,parameter :: boolean'', &', & ' & logical_kinds(i),''='', logical_kinds(i)', & ' enddo', & '', & ' end program demo_logical', & '', & ' Results:', & '', & ' > integer,parameter :: boolean1=1', & ' > integer,parameter :: boolean2=2', & ' > integer,parameter :: boolean4=4', & ' > integer,parameter :: boolean8=8', & ' > integer,parameter :: boolean16=16', & '', & '', & 'STANDARD', & ' Fortran 95 , related ISO_FORTRAN_ENV module - fortran 2009', & '', & 'SEE ALSO', & ' INT(3), REAL(3), CMPLX(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 logical(3fortran)', & ''] shortname="logical" call process() case('130','maskl') textblock=[character(len=256) :: & '', & 'maskl(3fortran) maskl(3fortran)', & '', & '', & '', & 'NAME', & ' MASKL(3) - [BIT:SET] Generates a left justified mask', & '', & '', & 'SYNOPSIS', & ' result = maskl( i [,kind] )', & '', & ' elemental integer(kind=KIND) function maskl(i,KIND)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I is an integer', & '', & ' o KIND Shall be a scalar constant expression of type integer whose value is', & ' a supported integer kind.', & '', & ' o The result is an integer of the same kind as I unless KIND is present,', & ' which is then used to specify the kind of the result.', & '', & 'DESCRIPTION', & ' MASKL(3) has its leftmost I bits set to 1, and the remaining bits set to', & '', & ' 0.', & '', & '', & 'OPTIONS', & ' o I : the number of left-most bits to set in the integer result. It must be', & ' from 0 to the number of bits for the kind of the result. The default kind', & ' of the result is the same as I unless the result size is specified by', & ' KIND. That is, these Fortran statements must be .true. :', & '', & ' i >= 0 .and. i < bitsize(i) ! if KIND is not specified', & ' i >= 0 .and. i < bitsize(0_KIND) ! if KIND is specified', & '', & '', & ' o KIND : designates the kind of the integer result.', & '', & 'RESULT', & ' The leftmost I bits of the output integer are set to 1 and the other bits', & ' are set to 0.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_maskl', & ' implicit none', & ' integer :: i', & ' ! basics', & ' i=3', & ' write(*,''(i0,1x,b0)'') i, maskl(i)', & '', & ' ! elemental', & ' write(*,''(*(i11,1x,b0.32,1x,/))'') maskl([(i,i,i=0,bit_size(0),4)])', & ' end program demo_maskl', & '', & ' Results:', & '', & ' > 3 11100000000000000000000000000000', & ' > 0 00000000000000000000000000000000', & ' > -268435456 11110000000000000000000000000000', & ' > -16777216 11111111000000000000000000000000', & ' > -1048576 11111111111100000000000000000000', & ' > -65536 11111111111111110000000000000000', & ' > -4096 11111111111111111111000000000000', & ' > -256 11111111111111111111111100000000', & ' > -16 11111111111111111111111111110000', & ' > -1 11111111111111111111111111111111', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' MASKR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 maskl(3fortran)', & ''] shortname="maskl" call process() case('131','maskr') textblock=[character(len=256) :: & '', & 'maskr(3fortran) maskr(3fortran)', & '', & '', & '', & 'NAME', & ' MASKR(3) - [BIT:SET] Generates a right-justified mask', & '', & '', & 'SYNOPSIS', & ' result = maskr( i [,kind] )', & '', & ' elemental integer(kind=KIND) function maskr(i,KIND)', & '', & ' integer(kind=**),intent(in) :: i', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I is an integer', & '', & ' o KIND Shall be a scalar constant expression of type integer whose value is', & ' a supported integer kind.', & '', & ' o The result is an integer of the same kind as I unless KIND is present,', & ' which is then used to specify the kind of the result.', & '', & 'DESCRIPTION', & ' MASKR(3) generates an integer with its rightmost I bits set to 1, and the', & ' remaining bits set to 0.', & '', & 'OPTIONS', & ' o I : the number of right-most bits to set in the integer result. It must', & ' be from 0 to the number of bits for the kind of the result. The default', & ' kind of the result is the same as I unless the result size is specified', & ' by KIND. That is, these Fortran statements must be .true. :', & '', & ' i >= 0 .and. i < bitsize(i) ! if KIND is not specified', & ' i >= 0 .and. i < bitsize(0_KIND) ! if KIND is specified', & '', & '', & ' o KIND : designates the kind of the integer result.', & '', & 'RESULT', & ' The rightmost I bits of the output integer are set to 1 and the other bits', & ' are set to 0.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_maskr', & ' implicit none', & ' integer :: i', & '', & ' ! basics', & ' print *,''basics''', & ' write(*,''(i0,t5,b32.32)'') 1, maskr(1)', & ' write(*,''(i0,t5,b32.32)'') 5, maskr(5)', & ' write(*,''(i0,t5,b32.32)'') 11, maskr(11)', & ' print *,"should be equivalent on two''s-complement processors"', & ' write(*,''(i0,t5,b32.32)'') 1, shiftr(-1,bit_size(0)-1)', & ' write(*,''(i0,t5,b32.32)'') 5, shiftr(-1,bit_size(0)-5)', & ' write(*,''(i0,t5,b32.32)'') 11, shiftr(-1,bit_size(0)-11)', & '', & ' ! elemental', & ' print *,''elemental ''', & ' print *,''(array argument accepted like called with each element)''', & ' write(*,''(*(i11,1x,b0.32,1x,/))'') maskr([(i,i,i=0,bit_size(0),4)])', & '', & ' end program demo_maskr', & '', & ' Results:', & '', & ' > basics', & ' > 1 00000000000000000000000000000001', & ' > 5 00000000000000000000000000011111', & ' > 11 00000000000000000000011111111111', & ' > should be equivalent on two''s-complement processors', & ' > 1 00000000000000000000000000000001', & ' > 5 00000000000000000000000000011111', & ' > 11 00000000000000000000011111111111', & ' > elemental', & ' > (array argument accepted like called with each element)', & ' > 0 00000000000000000000000000000000', & ' > 15 00000000000000000000000000001111', & ' > 255 00000000000000000000000011111111', & ' > 4095 00000000000000000000111111111111', & ' > 65535 00000000000000001111111111111111', & ' > 1048575 00000000000011111111111111111111', & ' > 16777215 00000000111111111111111111111111', & ' > 268435455 00001111111111111111111111111111', & ' > -1 11111111111111111111111111111111', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' MASKL(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 maskr(3fortran)', & ''] shortname="maskr" call process() case('132','matmul') textblock=[character(len=256) :: & '', & 'matmul(3fortran) matmul(3fortran)', & '', & '', & '', & 'NAME', & ' MATMUL(3) - [TRANSFORMATIONAL] Numeric or logical matrix multiplication', & '', & '', & 'SYNOPSIS', & ' result = matmul(matrix_a,matrix_b)', & '', & ' function matmul(matrix_a, matrix_b)', & '', & ' type(TYPE1(kind=**)) :: matrix_a(..)', & ' type(TYPE2(kind=**)) :: matrix_b(..)', & ' type(TYPE(kind=PROMOTED)) :: matmul(..)', & '', & '', & 'CHARACTERISTICS', & ' o MATRIX_A is a numeric (integer, real, or complex ) or logical array of', & ' rank one two.', & '', & ' o MATRIX_B is a numeric (integer, real, or complex ) or logical array of', & ' rank one two.', & '', & ' o At least one argument must be rank two.', & '', & ' o the size of the first dimension of MATRIX_B must equal the size of the', & ' last dimension of MATRIX_A.', & '', & ' o the type of the result is the same as if an element of each argument had', & ' been multiplied as a RHS expression (that is, if the arguments are not of', & ' the same type the result follows the same rules of promotion as a simple', & ' scalar multiplication of the two types would produce)', & '', & ' o If one argument is logical, both must be logical. For logicals the', & ' resulting type is as if the .and. operator has been used on elements from', & ' the arrays.', & '', & ' o The shape of the result depends on the shapes of the arguments as', & ' described below.', & '', & 'DESCRIPTION', & ' MATMUL(3) performs a matrix multiplication on numeric or logical arguments.', & '', & 'OPTIONS', & ' o MATRIX_A : A numeric or logical array with a rank of one or two.', & '', & ' o MATRIX_B : A numeric or logical array with a rank of one or two. The last', & ' dimension of MATRIX_A and the first dimension of MATRIX_B must be equal.', & '', & ' Note that MATRIX_A and MATRIX_B may be different numeric types.', & '', & 'RESULT', & 'NUMERIC ARGUMENTS', & ' If MATRIX_A and MATRIX_B are numeric the result is an array containing the', & ' conventional matrix product of MATRIX_A and MATRIX_B.', & '', & ' First, for the numeric expression C=MATMUL(A,B)', & '', & ' o Any vector A(N) is treated as a row vector A(1,N).', & '', & ' o Any vector B(N) is treated as a column vector B(N,1).', & '', & 'SHAPE AND RANK', & ' The shape of the result can then be determined as the number of rows of the', & ' first matrix and the number of columns of the second; but if any argument is', & ' of rank one (a vector) the result is also rank one. Conversely when both', & ' arguments are of rank two, the result has a rank of two. That is ...', & '', & ' o If MATRIX_A has shape [n,m] and MATRIX_B has shape [m,k], the result has', & ' shape [n,k].', & '', & ' o If MATRIX_A has shape [m] and MATRIX_B has shape [m,k], the result has', & ' shape [k].', & '', & ' o If MATRIX_A has shape [n,m] and MATRIX_B has shape [m], the result has', & ' shape [n].', & '', & 'VALUES', & ' Then element C(I,J) of the product is obtained by multiplying term-by-term', & ' the entries of the ith row of A and the jth column of B, and summing these', & ' products. In other words, C(I,J) is the dot product of the ith row of A and', & ' the jth column of B.', & '', & 'LOGICAL ARGUMENTS', & 'VALUES', & ' If MATRIX_A and MATRIX_B are of type logical, the array elements of the', & ' result are instead:', & '', & ' Value_of_Element (i,j) = &', & ' ANY( (row_i_of_MATRIX_A) .AND. (column_j_of_MATRIX_B) )', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_matmul', & ' implicit none', & ' integer :: a(2,3), b(3,2), c(2), d(3), e(2,2), f(3), g(2), v1(4),v2(4)', & ' a = reshape([1, 2, 3, 4, 5, 6], [2, 3])', & ' b = reshape([10, 20, 30, 40, 50, 60], [3, 2])', & ' c = [1, 2]', & ' d = [1, 2, 3]', & ' e = matmul(a, b)', & ' f = matmul(c,a)', & ' g = matmul(a,d)', & '', & ' call print_matrix_int(''A is '',a)', & ' call print_matrix_int(''B is '',b)', & ' call print_vector_int(''C is '',c)', & ' call print_vector_int(''D is '',d)', & ' call print_matrix_int(''E is matmul(A,B)'',e)', & ' call print_vector_int(''F is matmul(C,A)'',f)', & ' call print_vector_int(''G is matmul(A,D)'',g)', & '', & ' ! look at argument shapes when one is a vector', & ' write(*,''(" > shape")'')', & ' ! at least one argument must be of rank two', & ' ! so for two vectors at least one must be reshaped', & ' v1=[11,22,33,44]', & ' v2=[10,20,30,40]', & '', & ' ! these return a vector C(1:1)', & ' ! treat A(1:n) as A(1:1,1:n)', & ' call print_vector_int(''Cd is a vector (not a scalar)'',&', & ' & matmul(reshape(v1,[1,size(v1)]),v2))', & ' ! or treat B(1:m) as B(1:m,1:1)', & ' call print_vector_int(''cD is a vector too'',&', & ' & matmul(v1,reshape(v2,[size(v2),1])))', & '', & ' ! or treat A(1:n) as A(1:1,1:n) and B(1:m) as B(1:m,1:1)', & ' ! but note this returns a matrix C(1:1,1:1) not a vector!', & ' call print_matrix_int(''CD is a matrix'',matmul(&', & ' & reshape(v1,[1,size(v1)]), &', & ' & reshape(v2,[size(v2),1])))', & '', & ' contains', & '', & ' ! CONVENIENCE ROUTINES TO PRINT IN ROW-COLUMN ORDER', & ' subroutine print_vector_int(title,arr)', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: arr(:)', & ' call print_matrix_int(title,reshape(arr,[1,shape(arr)]))', & ' end subroutine print_vector_int', & '', & ' subroutine print_matrix_int(title,arr)', & ' !@(#) print small 2d integer arrays in row-column format', & ' character(len=*),parameter :: all=''(" > ",*(g0,1x))'' ! a handy format', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: arr(:,:)', & ' integer :: i', & ' character(len=:),allocatable :: biggest', & '', & ' print all', & ' print all, trim(title)', & ' biggest='' '' ! make buffer to write integer into', & ' ! find how many characters to use for integers', & ' write(biggest,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2', & ' ! use this format to write a row', & ' biggest=''(" > [",*(i''//trim(biggest)//'':,","))''', & ' ! print one row of array at a time', & ' do i=1,size(arr,dim=1)', & ' write(*,fmt=biggest,advance=''no'')arr(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & '', & ' end subroutine print_matrix_int', & '', & ' end program demo_matmul', & '', & ' Results:', & '', & ' >', & ' > A is', & ' > [ 1, 3, 5 ]', & ' > [ 2, 4, 6 ]', & ' >', & ' > B is', & ' > [ 10, 40 ]', & ' > [ 20, 50 ]', & ' > [ 30, 60 ]', & ' >', & ' > C is', & ' > [ 1, 2 ]', & ' >', & ' > D is', & ' > [ 1, 2, 3 ]', & ' >', & ' > E is matmul(A,B)', & ' > [ 220, 490 ]', & ' > [ 280, 640 ]', & ' >', & ' > F is matmul(C,A)', & ' > [ 5, 11, 17 ]', & ' >', & ' > G is matmul(A,D)', & ' > [ 22, 28 ]', & ' > shape', & ' >', & ' > Cd is a vector (not a scalar)', & ' > [ 3300 ]', & ' >', & ' > cD is a vector too', & ' > [ 3300 ]', & ' >', & ' > CD is a matrix', & ' > [ 3300 ]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' PRODUCT(3), TRANSPOSE(3)', & '', & 'RESOURCES', & ' o Matrix multiplication : Wikipedia', & '', & ' o The Winograd variant of Strassen''s matrix-matrix multiply algorithm may', & ' be of interest for optimizing multiplication of very large matrices. See', & '', & ' "GEMMW: A portable level 3 BLAS Winograd variant of Strassen''s', & ' matrix-matrix multiply algorithm",', & '', & ' Douglas, C. C., Heroux, M., Slishman, G., and Smith, R. M.,', & ' Journal of Computational Physics,', & ' Vol. 110, No. 1, January 1994, pages 1-10.', & '', & ' The numerical instabilities of Strassen''s method for matrix multiplication', & ' requires special processing.', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 matmul(3fortran)', & ''] shortname="matmul" call process() case('133','max') textblock=[character(len=256) :: & '', & 'max(3fortran) max(3fortran)', & '', & '', & '', & 'NAME', & ' MAX(3) - [NUMERIC] Maximum value of an argument list', & '', & '', & 'SYNOPSIS', & ' result = max(a1, a2, a3, ...)', & '', & ' elemental TYPE(kind=KIND) function max(a1, a2, a3, ... )', & '', & ' TYPE(kind=KIND,intent(in),optional :: a1', & ' TYPE(kind=KIND,intent(in),optional :: a2', & ' TYPE(kind=KIND,intent(in),optional :: a3', & ' :', & ' :', & ' :', & '', & '', & 'CHARACTERISTICS', & ' o A3, A3, A4, ... must be of the same type and kind as A1', & '', & ' o the arguments may (all) be integer, real or character', & '', & ' o there must be at least two arguments', & '', & ' o the length of a character result is the length of the longest argument', & '', & ' o the type and kind of the result is the same as those of the arguments', & '', & 'DESCRIPTION', & ' MAX(3) returns the argument with the largest (most positive) value.', & '', & ' For arguments of character type, the result is as if the arguments had been', & ' successively compared with the intrinsic operational operators, taking into', & ' account the collating sequence of the character kind.', & '', & ' If the selected character argument is shorter than the longest argument, the', & ' result is as all values were extended with blanks on the right to the length', & ' of the longest argument.', & '', & ' It is unusual for a Fortran intrinsic to take an arbitrary number of', & ' options, and in addition MAX(3) is elemental, meaning any number of', & ' arguments may be arrays as long as they are of the same shape. The examples', & ' have an extended description clarifying the resulting behavior for those not', & ' familiar with calling a "scalar" function elementally with arrays.', & '', & ' See maxval(3) for simply getting the max value of an array.', & '', & 'OPTIONS', & ' o A1 : The first argument determines the type and kind of the returned', & ' value, and of any remaining arguments as well as being a member of the', & ' set of values to find the maximum (most positive) value of.', & '', & ' o A2,A3,... : the remaining arguments of which to find the maximum value(s)', & ' of. : There must be at least two arguments to MAX(3).', & '', & 'RESULT', & ' The return value corresponds to an array of the same shape of any array', & ' argument, or a scalar if all arguments are scalar.', & '', & ' The returned value when any argument is an array will be an array of the', & ' same shape where each element is the maximum value occurring at that', & ' location, treating all the scalar values as arrays of that same shape with', & ' all elements set to the scalar value.', & '', & 'EXAMPLES', & ' Sample program', & '', & ' program demo_max', & ' implicit none', & ' real :: arr1(4)= [10.0,11.0,30.0,-100.0]', & ' real :: arr2(5)= [20.0,21.0,32.0,-200.0,2200.0]', & ' integer :: box(3,4)= reshape([-6,-5,-4,-3,-2,-1,1,2,3,4,5,6],shape(box))', & '', & ' ! basic usage', & ' ! this is simple enough when all arguments are scalar', & '', & ' ! the most positive value is returned, not the one with the', & ' ! largest magnitude', & ' write(*,*)''scalars:'',max(10.0,11.0,30.0,-100.0)', & ' write(*,*)''scalars:'',max(-22222.0,-0.0001)', & '', & ' ! strings do not need to be of the same length', & ' write(*,*)''characters:'',max(''the'',''words'',''order'')', & '', & ' ! leading spaces are significant; everyone is padded on the right', & ' ! to the length of the longest argument', & ' write(*,*)''characters:'',max(''c'',''bb'',''a'')', & ' write(*,*)''characters:'',max('' c'',''b'',''a'')', & '', & ' ! elemental', & ' ! there must be at least two arguments, so even if A1 is an array', & ' ! max(A1) is not valid. See MAXVAL(3) and/or MAXLOC(3) instead.', & '', & ' ! strings in a single array do need to be of the same length', & ' ! but the different objects can still be of different lengths.', & ' write(*,"(*(''""'',a,''""'':,1x))")MAX([''A'',''Z''],[''BB'',''Y ''])', & ' ! note the result is now an array with the max of every element', & ' ! position, as can be illustrated numerically as well:', & ' write(*,''(a,*(i3,1x))'')''box= '',box', & ' write(*,''(a,*(i3,1x))'')''box**2='',sign(1,box)*box**2', & ' write(*,''(a,*(i3,1x))'')''max '',max(box,sign(1,box)*box**2)', & '', & ' ! Remember if any argument is an array by the definition of an', & ' ! elemental function all the array arguments must be the same shape.', & '', & ' ! to find the single largest value of arrays you could use something', & ' ! like MAXVAL([arr1, arr2]) or probably better (no large temp array),', & ' ! max(maxval(arr1),maxval(arr2)) instead', & '', & ' ! so this returns an array of the same shape as any input array', & ' ! where each result is the maximum that occurs at that position.', & ' write(*,*)max(arr1,arr2(1:4))', & ' ! this returns an array just like arr1 except all values less than', & ' ! zero are set to zero:', & ' write(*,*)max(box,0)', & ' ! When mixing arrays and scalars you can think of the scalars', & ' ! as being a copy of one of the arrays with all values set to', & ' ! the scalar value.', & '', & ' end program demo_max', & '', & ' Results:', & '', & ' scalars: 30.00000', & ' scalars: -9.9999997E-05', & ' characters:words', & ' characters:c', & ' characters:b', & ' "BB" "Z "', & '', & ' box=', & ' -6 -5 -4 -3 -2 -1 1 2 3 4 5 6', & '', & ' box**2=-36 -25 -16', & ' -9 -4 -1 1 4 9 16 25 36', & '', & ' max', & ' -6 -5 -4 -3 -2 -1 1 4 9 16 25 36', & '', & ' 20.00000', & ' 21.00000 32.00000 -100.0000', & '', & ' 0 0 0 0 0 0', & '', & ' 1 2 3 4 5 6', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' MAXLOC(3), MINLOC(3), MAXVAL(3), MINVAL(3), MIN(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 max(3fortran)', & ''] shortname="max" call process() case('134','maxexponent') textblock=[character(len=256) :: & '', & 'maxexponent(3fortran) maxexponent(3fortran)', & '', & '', & '', & 'NAME', & ' MAXEXPONENT(3) - [NUMERIC MODEL] Maximum exponent of a real kind', & '', & '', & 'SYNOPSIS', & ' result = maxexponent(x)', & '', & ' elemental integer function maxexponent(x)', & '', & ' real(kind=**),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is a real scalar or array of any real kind', & '', & ' o the result is a default integer scalar', & '', & 'DESCRIPTION', & ' MAXEXPONENT(3) returns the maximum exponent in the model of the type of X.', & '', & 'OPTIONS', & ' o X : A value used to select the kind of real to return a value for.', & '', & 'RESULT', & ' The value returned is the maximum exponent for the kind of the value queried', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_maxexponent', & ' use, intrinsic :: iso_fortran_env, only : real32,real64,real128', & ' implicit none', & ' character(len=*),parameter :: g=''(*(g0,1x))''', & ' print g, minexponent(0.0_real32), maxexponent(0.0_real32)', & ' print g, minexponent(0.0_real64), maxexponent(0.0_real64)', & ' print g, minexponent(0.0_real128), maxexponent(0.0_real128)', & ' end program demo_maxexponent', & '', & ' Results:', & '', & ' -125 128', & ' -1021 1024', & ' -16381 16384', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MINEXPONENT(3),', & ' NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 maxexponent(3fortran)', & ''] shortname="maxexponent" call process() case('135','maxloc') textblock=[character(len=256) :: & '', & 'maxloc(3fortran) maxloc(3fortran)', & '', & '', & '', & 'NAME', & ' MAXLOC(3) - [ARRAY:LOCATION] Location of the maximum value within an array', & '', & '', & 'SYNOPSIS', & ' result = maxloc(array [,mask]) | maxloc(array [,dim] [,mask])', & '', & ' NUMERIC function maxloc(array, dim, mask)', & '', & ' NUMERIC,intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o NUMERIC designates any intrinsic numeric type and kind.', & '', & 'DESCRIPTION', & ' MAXLOC(3) determines the location of the element in the array with the', & ' maximum value, or, if the DIM argument is supplied, determines the locations', & ' of the maximum element along each row of the array in the DIM direction.', & '', & ' If MASK is present, only the elements for which MASK is .true. are', & ' considered. If more than one element in the array has the maximum value, the', & ' location returned is that of the first such element in array element order.', & '', & ' If the array has zero size, or all of the elements of MASK are .false., then', & ' the result is an array of zeroes. Similarly, if DIM is supplied and all of', & ' the elements of MASK along a given row are zero, the result value for that', & ' row is zero.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an array of type integer, real, or character.', & '', & ' o DIM : (Optional) Shall be a scalar of type integer, with a value between', & ' one and the rank of ARRAY, inclusive. It may not be an optional dummy', & ' argument.', & '', & ' o MASK : Shall be an array of type logical, and conformable with ARRAY.', & '', & 'RESULT', & ' If DIM is absent, the result is a rank-one array with a length equal to the', & ' rank of ARRAY. If DIM is present, the result is an array with a rank one', & ' less than the rank of ARRAY, and a size corresponding to the size of ARRAY', & ' with the DIM dimension removed. If DIM is present and ARRAY has a rank of', & ' one, the result is a scalar. In all cases, the result is of default integer', & ' type.', & '', & ' The value returned is reference to the offset from the beginning of the', & ' array, not necessarily the subscript value if the array subscripts do not', & ' start with one.', & '', & 'EXAMPLES', & ' sample program', & '', & ' program demo_maxloc', & ' implicit none', & ' integer :: ii', & ' integer,save :: i(-3:3)=[(abs(abs(ii)-50),ii=-3,3)]', & ' integer,save :: ints(3,5)= reshape([&', & ' 1, 2, 3, 4, 5, &', & ' 10, 20, 30, 40, 50, &', & ' 11, 22, 33, 44, 55 &', & ' ],shape(ints),order=[2,1])', & '', & ' write(*,*) maxloc(ints)', & ' write(*,*) maxloc(ints,dim=1)', & ' write(*,*) maxloc(ints,dim=2)', & ' ! when array bounds do not start with one remember MAXLOC(3) returns', & ' ! the offset relative to the lower bound-1 of the location of the', & ' ! maximum value, not the subscript of the maximum value. When the', & ' ! lower bound of the array is one, these values are the same. In', & ' ! other words, MAXLOC(3) returns the subscript of the value assuming', & ' ! the first subscript of the array is one no matter what the lower', & ' ! bound of the subscript actually is.', & ' write(*,''(g0,1x,g0)'') (ii,i(ii),ii=lbound(i,dim=1),ubound(i,dim=1))', & ' write(*,*)maxloc(i)', & '', & ' end program demo_maxloc', & '', & ' Results:', & '', & ' > 3 5', & ' > 3 3 3 3 3', & ' > 5 5 5', & ' > -3 47', & ' > -2 48', & ' > -1 49', & ' > 0 50', & ' > 1 49', & ' > 2 48', & ' > 3 47', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o FINDLOC(3) - Location of first element of ARRAY identified by MASK along', & ' dimension DIM matching a target', & '', & ' o MINLOC(3) - Location of the minimum value within an array', & '', & ' o MAXVAL(3)', & '', & ' o MINVAL(3)', & '', & ' o MAX(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 maxloc(3fortran)', & ''] shortname="maxloc" call process() case('136','maxval') textblock=[character(len=256) :: & '', & 'maxval(3fortran) maxval(3fortran)', & '', & '', & '', & 'NAME', & ' MAXVAL(3) - [ARRAY:REDUCTION] Determines the maximum value in an array or', & ' row', & '', & '', & 'SYNOPSIS', & ' result = maxval(array [,mask]) | maxval(array [,dim] [,mask])', & '', & ' NUMERIC function maxval(array ,dim, mask)', & '', & ' NUMERIC,intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o NUMERIC designates any numeric type and kind.', & '', & 'DESCRIPTION', & ' MAXVAL(3) determines the maximum value of the elements in an array value,', & ' or, if the DIM argument is supplied, determines the maximum value along each', & ' row of the array in the DIM direction. If MASK is present, only the elements', & ' for which MASK is .true. are considered. If the array has zero size, or all', & ' of the elements of MASK are .false., then the result is the most negative', & ' number of the type and kind of ARRAY if ARRAY is numeric, or a string of', & ' nulls if ARRAY is of character type.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an array of type integer, real, or character.', & '', & ' o DIM : (Optional) Shall be a scalar of type integer, with a value between', & ' one and the rank of ARRAY, inclusive. It may not be an optional dummy', & ' argument.', & '', & ' o MASK : (Optional) Shall be an array of type logical, and conformable with', & ' ARRAY.', & '', & 'RESULT', & ' If DIM is absent, or if ARRAY has a rank of one, the result is a scalar. If', & ' DIM is present, the result is an array with a rank one less than the rank of', & ' ARRAY, and a size corresponding to the size of ARRAY with the DIM dimension', & ' removed. In all cases, the result is of the same type and kind as ARRAY.', & '', & 'EXAMPLES', & ' sample program:', & '', & ' program demo_maxval', & ' implicit none', & ' integer,save :: ints(3,5)= reshape([&', & ' 1, 2, 3, 4, 5, &', & ' 10, 20, 30, 40, 50, &', & ' 11, 22, 33, 44, 55 &', & ' ],shape(ints),order=[2,1])', & '', & ' write(*,*) maxval(ints)', & ' write(*,*) maxval(ints,dim=1)', & ' write(*,*) maxval(ints,dim=2)', & ' ! find biggest number less than 30 with mask', & ' write(*,*) maxval(ints,mask=ints.lt.30)', & ' end program demo_maxval', & '', & ' Results:', & '', & ' > 55', & ' > 11 22 33 44 55', & ' > 5 50 55', & ' > 22', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' MAXLOC(3), MINLOC(3), MINVAL(3), MAX(3), MIN(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 maxval(3fortran)', & ''] shortname="maxval" call process() case('137','merge') textblock=[character(len=256) :: & '', & 'merge(3fortran) merge(3fortran)', & '', & '', & '', & 'NAME', & ' MERGE(3) - [ARRAY:CONSTRUCTION] Merge variables', & '', & '', & 'SYNOPSIS', & ' result = merge(tsource, fsource, mask)', & '', & ' elemental type(TYPE(kind=KIND)) function merge(tsource,fsource,mask)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: tsource', & ' type(TYPE(kind=KIND)),intent(in) :: fsource', & ' logical(kind=**),intent(in) :: mask', & ' mask** : Shall be of type logical.', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o TSOURCE May be of any type, including user-defined.', & '', & ' o FSOURCE Shall be of the same type and type parameters as TSOURCE.', & '', & ' o MASK shall be of type logical.', & '', & ' o The result will by of the same type and type parameters as TSOURCE.', & '', & 'DESCRIPTION', & ' The elemental function MERGE(3) selects values from two arrays or scalars', & ' according to a logical mask. The result is equal to an element of TSOURCE', & ' where the corresponding element of MASK is .true., or an element of FSOURCE', & ' when it is .false. .', & '', & ' Multi-dimensional arrays are supported.', & '', & ' Note that argument expressions to MERGE(3) are not required to be short-', & ' circuited so (as an example) if the array X contains zero values in the', & ' statement below the standard does not prevent floating point divide by zero', & ' being generated; as 1.0/X may be evaluated for all values of X before the', & ' mask is used to select which value to retain:', & '', & ' y = merge( 1.0/x, 0.0, x /= 0.0 )', & '', & ' Note the compiler is also free to short-circuit or to generate an infinity', & ' so this may work in many programming environments but is not recommended.', & '', & ' For cases like this one may instead use masked assignment via the WHERE', & ' construct:', & '', & ' where(x .ne. 0.0)', & ' y = 1.0/x', & ' elsewhere', & ' y = 0.0', & ' endwhere', & '', & ' instead of the more obscure', & '', & ' merge(1.0/merge(x,1.0,x /= 0.0), 0.0, x /= 0.0)', & '', & '', & 'OPTIONS', & ' o TSOURCE : May be of any type, including user-defined.', & '', & ' o FSOURCE : Shall be of the same type and type parameters as TSOURCE.', & '', & ' o MASK : Shall be of type logical.', & '', & ' Note that (currently) character values must be of the same length.', & '', & 'RESULT', & ' The result is built from an element of TSOURCE if MASK is .true. and from', & ' FSOURCE otherwise.', & '', & ' Because TSOURCE and FSOURCE are required to have the same type and type', & ' parameters (for both the declared and dynamic types), the result is', & ' polymorphic if and only if both TSOURCE and FSOURCE are polymorphic.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_merge', & ' implicit none', & ' integer :: tvals(2,3), fvals(2,3), answer(2,3)', & ' logical :: mask(2,3)', & ' integer :: i', & ' integer :: k', & ' logical :: chooseleft', & '', & ' ! Works with scalars', & ' k=5', & ' write(*,*)merge (1.0, 0.0, k > 0)', & ' k=-2', & ' write(*,*)merge (1.0, 0.0, k > 0)', & '', & ' ! set up some simple arrays that all conform to the', & ' ! same shape', & ' tvals(1,:)=[ 10, -60, 50 ]', & ' tvals(2,:)=[ -20, 40, -60 ]', & '', & ' fvals(1,:)=[ 0, 3, 2 ]', & ' fvals(2,:)=[ 7, 4, 8 ]', & '', & ' mask(1,:)=[ .true., .false., .true. ]', & ' mask(2,:)=[ .false., .false., .true. ]', & '', & ' ! lets use the mask of specific values', & ' write(*,*)''mask of logicals''', & ' answer=merge( tvals, fvals, mask )', & ' call printme()', & '', & ' ! more typically the mask is an expression', & ' write(*, *)''highest values''', & ' answer=merge( tvals, fvals, tvals > fvals )', & ' call printme()', & '', & ' write(*, *)''lowest values''', & ' answer=merge( tvals, fvals, tvals < fvals )', & ' call printme()', & '', & ' write(*, *)''zero out negative values''', & ' answer=merge( 0, tvals, tvals < 0)', & ' call printme()', & '', & ' write(*, *)''binary choice''', & ' chooseleft=.false.', & ' write(*, ''(3i4)'')merge([1,2,3],[10,20,30],chooseleft)', & ' chooseleft=.true.', & ' write(*, ''(3i4)'')merge([1,2,3],[10,20,30],chooseleft)', & '', & ' contains', & '', & ' subroutine printme()', & ' write(*, ''(3i4)'')(answer(i, :), i=1, size(answer, dim=1))', & ' end subroutine printme', & '', & ' end program demo_merge', & '', & ' Results:', & '', & ' > 1.00000000', & ' > 0.00000000', & ' > mask of logicals', & ' > 10 3 50', & ' > 7 4 -60', & ' > highest values', & ' > 10 3 50', & ' > 7 40 8', & ' > lowest values', & ' > 0 -60 2', & ' > -20 4 -60', & ' > zero out negative values', & ' > 10 0 50', & ' > 0 40 0', & ' > binary choice', & ' > 10 20 30', & ' > 1 2 3', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o PACK(3) packs an array into an array of rank one', & '', & ' o SPREAD(3) is used to add a dimension and replicate data', & '', & ' o UNPACK(3) scatters the elements of a vector', & '', & ' o TRANSPOSE(3) - Transpose an array of rank two', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 merge(3fortran)', & ''] shortname="merge" call process() case('138','merge_bits') textblock=[character(len=256) :: & '', & 'merge_bits(3fortran) merge_bits(3fortran)', & '', & '', & '', & 'NAME', & ' MERGE_BITS(3) - [BIT:COPY] Merge bits using a mask', & '', & '', & 'SYNOPSIS', & ' result = merge_bits(i, j, mask)', & '', & ' elemental integer(kind=KIND) function merge_bits(i,j,mask)', & '', & ' integer(kind=KIND), intent(in) :: i, j, mask', & '', & '', & 'CHARACTERISTICS', & ' o the result and all input values have the same integer type and KIND with', & ' the exception that the mask and either I or J may be a BOZ constant.', & '', & 'DESCRIPTION', & ' A common graphics operation in Ternary Raster Operations is to combine bits', & ' from two different sources, generally referred to as bit-blending.', & ' MERGE_BITS(3) performs a masked bit-blend of I and J using the bits of the', & ' MASK value to determine which of the input values to copy bits from.', & '', & ' Specifically, The k-th bit of the result is equal to the k-th bit of I if', & ' the k-th bit of MASK is 1; it is equal to the k-th bit of J otherwise (so', & ' all three input values must have the same number of bits).', & '', & ' The resulting value is the same as would result from', & '', & ' ior (iand (i, mask),iand (j, not (mask)))', & '', & ' An exception to all values being of the same integer type is that I or J', & ' and/or the mask may be a BOZ constant (A BOZ constant means it is either a', & ' Binary, Octal, or Hexadecimal literal constant). The BOZ values are', & ' converted to the integer type of the non-BOZ value(s) as if called by the', & ' intrinsic function INT() with the kind of the non-BOZ value(s), so the BOZ', & ' values must be in the range of the type of the result.', & '', & 'OPTIONS', & ' o I : value to select bits from when the associated bit in the mask is', & '', & ' 1.', & '', & '', & ' o J : value to select bits from when the associated bit in the mask is', & '', & ' 0.', & '', & '', & ' o MASK : a value whose bits are used as a mask to select bits from I and J', & '', & 'RESULT', & ' The bits blended from I and J using the mask MASK.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_merge_bits', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int16) :: if_one,if_zero,msk', & ' character(len=*),parameter :: fmt=''(*(g0, 1X))''', & '', & ' ! basic usage', & ' print *,''MERGE_BITS( 5,10,41) should be 3.=>'',merge_bits(5,10,41)', & ' print *,''MERGE_BITS(13,18,22) should be 4.=>'',merge_bits(13,18,22)', & '', & ' ! use some values in base2 illustratively:', & ' if_one =int(b''1010101010101010'',kind=int16)', & ' if_zero=int(b''0101010101010101'',kind=int16)', & '', & ' msk=int(b''0101010101010101'',kind=int16)', & ' print ''("should get all zero bits =>",b16.16)'', &', & ' & merge_bits(if_one,if_zero,msk)', & '', & ' msk=int(b''1010101010101010'',kind=int16)', & ' print ''("should get all ones bits =>",b16.16)'', &', & ' & merge_bits(if_one,if_zero,msk)', & '', & ' ! using BOZ values', & ' print fmt, &', & ' & merge_bits(32767_int16, o''12345'', 32767_int16), &', & ' & merge_bits(o''12345'', 32767_int16, b''0000000000010101''), &', & ' & merge_bits(32767_int16, o''12345'', z''1234'')', & '', & ' ! a do-it-yourself equivalent for comparison and validation', & ' print fmt, &', & ' & ior(iand(32767_int16, 32767_int16), &', & ' & iand(o''12345'', not(32767_int16))), &', & '', & ' & ior(iand(o''12345'', int(o''12345'', kind=int16)), &', & ' & iand(32767_int16, not(int(o''12345'', kind=int16)))), &', & '', & ' & ior(iand(32767_int16, z''1234''), &', & ' & iand(o''12345'', not(int( z''1234'', kind=int16))))', & '', & ' end program demo_merge_bits', & '', & ' Results:', & '', & ' MERGE_BITS( 5,10,41) should be 3.=> 3', & ' MERGE_BITS(13,18,22) should be 4.=> 4', & ' should get all zero bits =>0000000000000000 should get all ones bits', & ' =>1111111111111111 32767 32751 5877 32767 32767 5877', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 merge_bits(3fortran)', & ''] shortname="merge_bits" call process() case('139','min') textblock=[character(len=256) :: & '', & 'min(3fortran) min(3fortran)', & '', & '', & '', & 'NAME', & ' MIN(3) - [NUMERIC] Minimum value of an argument list', & '', & '', & 'SYNOPSIS', & ' result = min(a1, a2, a3, ... )', & '', & ' elemental TYPE(kind=KIND) function min(a1, a2, a3, ... )', & '', & ' TYPE(kind=KIND,intent(in) :: a1', & ' TYPE(kind=KIND,intent(in) :: a2', & ' TYPE(kind=KIND,intent(in) :: a3', & ' :', & ' :', & ' :', & '', & '', & 'CHARACTERISTICS', & ' o TYPE may be integer, real or character.', & '', & 'DESCRIPTION', & ' MIN(3) returns the argument with the smallest (most negative) value.', & '', & ' See MAX(3) for an extended example of the behavior of MIN(3) as and MAX(3).', & '', & 'OPTIONS', & ' o A1 : the first element of the set of values to determine the minimum of.', & '', & ' o A2, A3, ... : An expression of the same type and kind as A1 completing', & ' the set of values to find the minimum of.', & '', & 'RESULT', & ' The return value corresponds to the minimum value among the arguments, and', & ' has the same type and kind as the first argument.', & '', & 'EXAMPLES', & ' Sample program', & '', & ' program demo_min', & ' implicit none', & ' write(*,*)min(10.0,11.0,30.0,-100.0)', & ' end program demo_min', & '', & ' Results:', & '', & ' -100.0000000', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' MAXLOC(3), MINLOC(3), MINVAL(3), MAX(3),', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 min(3fortran)', & ''] shortname="min" call process() case('140','minexponent') textblock=[character(len=256) :: & '', & 'minexponent(3fortran) minexponent(3fortran)', & '', & '', & '', & 'NAME', & ' MINEXPONENT(3) - [NUMERIC MODEL] Minimum exponent of a real kind', & '', & '', & 'SYNOPSIS', & ' result = minexponent(x)', & '', & ' elemental integer function minexponent(x)', & '', & ' real(kind=**),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is a real scalar or array of any real kind', & '', & ' o the result is a default integer scalar', & '', & 'DESCRIPTION', & ' MINEXPONENT(3) returns the minimum exponent in the model of the type of X.', & '', & 'OPTIONS', & ' o X : A value used to select the kind of real to return a value for.', & '', & 'RESULT', & ' The value returned is the maximum exponent for the kind of the value queried', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_minexponent', & ' use, intrinsic :: iso_fortran_env, only : &', & ' &real_kinds, real32, real64, real128', & ' implicit none', & ' real(kind=real32) :: x', & ' real(kind=real64) :: y', & ' print *, minexponent(x), maxexponent(x)', & ' print *, minexponent(y), maxexponent(y)', & ' end program demo_minexponent', & '', & ' Expected Results:', & '', & ' -125 128', & '', & ' -1021', & ' 1024', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 minexponent(3fortran)', & ''] shortname="minexponent" call process() case('141','minloc') textblock=[character(len=256) :: & '', & 'minloc(3fortran) minloc(3fortran)', & '', & '', & '', & 'NAME', & ' MINLOC(3) - [ARRAY:LOCATION] Location of the minimum value within an array', & '', & '', & 'SYNOPSIS', & ' result = minloc(array [,mask]) | minloc(array [,dim] [,mask])', & '', & ' NUMERIC function minloc(array, dim, mask)', & '', & ' NUMERIC,intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o NUMERIC is any numeric type and kind.', & '', & 'DESCRIPTION', & ' MINLOC(3) determines the location of the element in the array with the', & ' minimum value, or, if the DIM argument is supplied, determines the locations', & ' of the minimum element along each row of the array in the DIM direction.', & '', & ' If MASK is present, only the elements for which MASK is true. are', & ' considered.', & '', & ' If more than one element in the array has the minimum value, the location', & ' returned is that of the first such element in array element order.', & '', & ' If the array has zero size, or all of the elements of MASK are .false., then', & ' the result is an array of zeroes. Similarly, if DIM is supplied and all of', & ' the elements of MASK along a given row are zero, the result value for that', & ' row is zero.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an array of type integer, real, or character.', & '', & ' o DIM : (Optional) Shall be a scalar of type integer, with a value between', & ' one and the rank of ARRAY, inclusive. It may not be an optional dummy', & ' argument.', & '', & ' o MASK : Shall be an array of type logical, and conformable with ARRAY.', & '', & 'RESULT', & ' If DIM is absent, the result is a rank-one array with a length equal to the', & ' rank of ARRAY. If DIM is present, the result is an array with a rank one', & ' less than the rank of ARRAY, and a size corresponding to the size of ARRAY', & ' with the DIM dimension removed. If DIM is present and ARRAY has a rank of', & ' one, the result is a scalar. In all cases, the result is of default integer', & ' type.', & '', & 'EXAMPLES', & ' sample program:', & '', & ' program demo_minloc', & ' implicit none', & ' integer,save :: ints(3,5)= reshape([&', & ' 4, 10, 1, 7, 13, &', & ' 9, 15, 6, 12, 3, &', & ' 14, 5, 11, 2, 8 &', & ' ],shape(ints),order=[2,1])', & ' write(*,*) minloc(ints)', & ' write(*,*) minloc(ints,dim=1)', & ' write(*,*) minloc(ints,dim=2)', & ' ! where in each column is the smallest number .gt. 10 ?', & ' write(*,*) minloc(ints,dim=2,mask=ints.gt.10)', & ' ! a one-dimensional array with dim=1 explicitly listed returns a scalar', & ' write(*,*) minloc(pack(ints,.true.),dim=1) ! scalar', & ' end program demo_minloc', & '', & ' Results:', & '', & ' > 1 3', & ' > 1 3 1 3 2', & ' > 3 5 4', & ' > 5 4 3', & ' > 7', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o FINDLOC(3) - Location of first element of ARRAY identified by MASK along', & ' dimension DIM matching a target', & '', & ' o MAXLOC(3) - Location of the maximum value within an array', & '', & ' o MINLOC(3) - Location of the minimum value within an array', & '', & ' o MIN(3)', & '', & ' o MINVAL(3)', & '', & ' o MAXVAL(3)', & '', & ' o MAX(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 minloc(3fortran)', & ''] shortname="minloc" call process() case('142','minval') textblock=[character(len=256) :: & '', & 'minval(3fortran) minval(3fortran)', & '', & '', & '', & 'NAME', & ' MINVAL(3) - [ARRAY:REDUCTION] Minimum value of an array', & '', & '', & 'SYNOPSIS', & ' result = minval(array, [mask]) | minval(array [,dim] [,mask])', & '', & ' NUMERIC function minval(array, dim, mask)', & '', & ' NUMERIC,intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o NUMERIC is any numeric type and kind.', & '', & 'DESCRIPTION', & ' MINVAL(3) determines the minimum value of the elements in an array value,', & ' or, if the DIM argument is supplied, determines the minimum value along each', & ' row of the array in the DIM direction.', & '', & ' If MASK is present, only the elements for which MASK is .true. are', & ' considered.', & '', & ' If the array has zero size, or all of the elements of MASK are .false., then', & ' the result is HUGE(ARRAY) if ARRAY is numeric, or a string of CHAR(LEN=255)', & ' characters if ARRAY is of character type.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an array of type integer, real, or character.', & '', & ' o DIM : (Optional) Shall be a scalar of type integer, with a value between', & ' one and the rank of ARRAY, inclusive. It may not be an optional dummy', & ' argument.', & '', & ' o MASK : Shall be an array of type logical, and conformable with ARRAY.', & '', & 'RESULT', & ' If DIM is absent, or if ARRAY has a rank of one, the result is a scalar.', & '', & ' If DIM is present, the result is an array with a rank one less than the rank', & ' of ARRAY, and a size corresponding to the size of ARRAY with the DIM', & ' dimension removed. In all cases, the result is of the same type and kind as', & ' ARRAY.', & '', & 'EXAMPLES', & ' sample program:', & '', & ' program demo_minval', & ' implicit none', & ' integer :: i', & ' character(len=*),parameter :: g=''(3x,*(g0,1x))''', & '', & ' integer,save :: ints(3,5)= reshape([&', & ' 1, -2, 3, 4, 5, &', & ' 10, 20, -30, 40, 50, &', & ' 11, 22, 33, -44, 55 &', & ' ],shape(ints),order=[2,1])', & '', & ' integer,save :: box(3,5,2)', & '', & ' box(:,:,1)=ints', & ' box(:,:,2)=-ints', & '', & ' write(*,*)''Given the array''', & ' write(*,''(1x,*(g4.4,1x))'') &', & ' & (ints(i,:),new_line(''a''),i=1,size(ints,dim=1))', & '', & ' write(*,*)''What is the smallest element in the array?''', & ' write(*,g) minval(ints),''at <'',minloc(ints),''>''', & '', & ' write(*,*)''What is the smallest element in each column?''', & ' write(*,g) minval(ints,dim=1)', & '', & ' write(*,*)''What is the smallest element in each row?''', & ' write(*,g) minval(ints,dim=2)', & '', & ' ! notice the shape of the output has less columns', & ' ! than the input in this case', & ' write(*,*)''What is the smallest element in each column,''', & ' write(*,*)''considering only those elements that are''', & ' write(*,*)''greater than zero?''', & ' write(*,g) minval(ints, dim=1, mask = ints > 0)', & '', & ' write(*,*)&', & ' & ''if everything is false a zero-sized array is NOT returned''', & ' write(*,*) minval(ints, dim=1, mask = .false.)', & ' write(*,*)''even for a zero-sized input''', & ' write(*,g) minval([integer ::], dim=1, mask = .false.)', & '', & ' write(*,*)''a scalar answer for everything false is huge()''', & ' write(*,g) minval(ints, mask = .false.)', & ' write(*,g) minval([integer ::], mask = .false.)', & '', & ' write(*,*)''some calls with three dimensions''', & ' write(*,g) minval(box, mask = .true. )', & ' write(*,g) minval(box, dim=1, mask = .true. )', & '', & ' write(*,g) minval(box, dim=2, mask = .true. )', & ' write(*,g) ''shape of answer is '', &', & ' & shape(minval(box, dim=2, mask = .true. ))', & '', & ' end program demo_minval', & '', & ' Results:', & '', & ' > Given the array', & ' > 1 -2 3 4 5', & ' > 10 20 -30 40 50', & ' > 11 22 33 -44 55', & ' >', & ' > What is the smallest element in the array?', & ' > -44 at < 3 4 >', & ' > What is the smallest element in each column?', & ' > 1 -2 -30 -44 5', & ' > What is the smallest element in each row?', & ' > -2 -30 -44', & ' > What is the smallest element in each column,', & ' > considering only those elements that are', & ' > greater than zero?', & ' > 1 20 3 4 5', & ' > if everything is false a zero-sized array is NOT returned', & ' > 2147483647 2147483647 2147483647 2147483647 2147483647', & ' > even for a zero-sized input', & ' > 2147483647', & ' > a scalar answer for everything false is huge()', & ' > 2147483647', & ' > 2147483647', & ' > some calls with three dimensions', & ' > -55', & ' > 1 -2 -30 -44 5 -11 -22 -33 -40 -55', & ' > -2 -30 -44 -5 -50 -55', & ' > shape of answer is 3 2', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' MIN(3), MINLOC(3) MAXLOC(3), MAXVAL(3), MIN(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 minval(3fortran)', & ''] shortname="minval" call process() case('143','mod') textblock=[character(len=256) :: & '', & 'mod(3fortran) mod(3fortran)', & '', & '', & '', & 'NAME', & ' MOD(3) - [NUMERIC] Remainder function', & '', & '', & 'SYNOPSIS', & ' result = mod(a, p)', & '', & ' elemental type(TYPE(kind=KIND)) function mod(a,p)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: a', & ' type(TYPE(kind=KIND)),intent(in) :: p', & '', & '', & 'CHARACTERISTICS', & ' o The result and arguments are all of the same type and kind.', & '', & ' o The type may be any kind of real or integer.', & '', & 'DESCRIPTION', & ' MOD(3) computes the remainder of the division of A by P.', & '', & ' In mathematics, the remainder is the amount "left over" after performing', & ' some computation. In arithmetic, the remainder is the integer "left over"', & ' after dividing one integer by another to produce an integer quotient', & ' (integer division). In algebra of polynomials, the remainder is the', & ' polynomial "left over" after dividing one polynomial by another. The modulo', & ' operation is the operation that produces such a remainder when given a', & ' dividend and divisor.', & '', & ' o (remainder). (2022, October 10). In Wikipedia.', & ' https://en.wikipedia.org/wiki/Remainder', & '', & 'OPTIONS', & ' o A : The dividend', & '', & ' o P : the divisor (not equal to zero).', & '', & 'RESULT', & ' The return value is the result of A - (INT(A/P) * P).', & '', & ' As can be seen by the formula the sign of P is canceled out. Therefore the', & ' returned value always has the sign of A.', & '', & ' Of course, the magnitude of the result will be less than the magnitude of P,', & ' as the result has been reduced by all multiples of P.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_mod', & ' implicit none', & '', & ' ! basics', & ' print *, mod( -17, 3 ), modulo( -17, 3 )', & ' print *, mod( 17, -3 ), modulo( 17, -3 )', & ' print *, mod( 17, 3 ), modulo( 17, 3 )', & ' print *, mod( -17, -3 ), modulo( -17, -3 )', & '', & ' print *, mod(-17.5, 5.2), modulo(-17.5, 5.2)', & ' print *, mod( 17.5,-5.2), modulo( 17.5,-5.2)', & ' print *, mod( 17.5, 5.2), modulo( 17.5, 5.2)', & ' print *, mod(-17.5,-5.2), modulo(-17.5,-5.2)', & '', & ' ! with a divisor of 1 the fractional part is returned', & ' print *, mod(-17.5, 1.0), modulo(-17.5, 1.0)', & ' print *, mod( 17.5,-1.0), modulo( 17.5,-1.0)', & ' print *, mod( 17.5, 1.0), modulo( 17.5, 1.0)', & ' print *, mod(-17.5,-1.0), modulo(-17.5,-1.0)', & '', & ' end program demo_mod', & '', & ' Results:', & '', & ' -2 1', & ' 2 -1', & ' 2 2', & ' -2 -2', & '', & ' -1.900001', & ' 3.299999', & '', & ' 1.900001', & ' -3.299999', & '', & ' 1.900001', & ' 1.900001', & '', & ' -1.900001', & ' -1.900001', & '', & ' -0.5000000', & ' 0.5000000', & '', & ' 0.5000000', & ' -0.5000000', & '', & ' 0.5000000', & ' 0.5000000', & '', & ' -0.5000000', & ' -0.5000000', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' o MODULO(3) - Modulo function', & '', & ' o AINT(3) - truncate toward zero to a whole real number', & '', & ' o INT(3) - truncate toward zero to a whole integer number', & '', & ' o ANINT(3) - real nearest whole number', & '', & ' o NINT(3) - integer nearest whole number', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 mod(3fortran)', & ''] shortname="mod" call process() case('144','modulo') textblock=[character(len=256) :: & '', & 'modulo(3fortran) modulo(3fortran)', & '', & '', & '', & 'NAME', & ' MODULO(3) - [NUMERIC] Modulo function', & '', & '', & 'SYNOPSIS', & ' result = modulo(a, p)', & '', & ' elemental TYPE(kind=KIND) function modulo(a,p)', & '', & ' TYPE(kind=KIND),intent(in) :: a', & ' TYPE(kind=KIND),intent(in) :: p', & '', & '', & 'CHARACTERISTICS', & ' o A may be any kind of real or integer.', & '', & ' o P is the same type and kind as A', & '', & ' o The result and arguments are all of the same type and kind.', & '', & 'DESCRIPTION', & ' MODULO(3) computes the A modulo P.', & '', & 'OPTIONS', & ' o A : the value to take the MODULO of', & '', & ' o P : The value to reduce A by till the remainder is <= P. It shall not be', & ' zero.', & '', & 'RESULT', & ' The type and kind of the result are those of the arguments.', & '', & ' o If A and P are of type integer: MODULO(A,P) has the value of A - FLOOR', & ' (REAL(A) / REAL(P)) * P.', & '', & ' o If A and P are of type real: MODULO(A,P) has the value of A - FLOOR (A /', & ' P) * P.', & '', & ' The returned value has the same sign as P and a magnitude less than the', & ' magnitude of P.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_modulo', & ' implicit none', & ' print *, modulo(17,3) ! yields 2', & ' print *, modulo(17.5,5.5) ! yields 1.0', & '', & ' print *, modulo(-17,3) ! yields 1', & ' print *, modulo(-17.5,5.5) ! yields 4.5', & '', & ' print *, modulo(17,-3) ! yields -1', & ' print *, modulo(17.5,-5.5) ! yields -4.5', & ' end program demo_modulo', & '', & ' Results:', & '', & ' > 2', & ' > 1.000000', & ' > 1', & ' > 4.500000', & ' > -1', & ' > -4.500000', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' MOD(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 modulo(3fortran)', & ''] shortname="modulo" call process() case('145','move_alloc') textblock=[character(len=256) :: & '', & 'move_alloc(3fortran) move_alloc(3fortran)', & '', & '', & '', & 'NAME', & ' MOVE_ALLOC(3) - [MEMORY] Move allocation from one object to another', & '', & '', & 'SYNOPSIS', & ' call move_alloc(from, to [,stat] [,errmsg] )', & '', & ' subroutine move_alloc(from, to)', & '', & ' type(TYPE(kind=**)),intent(inout),allocatable :: from(..)', & ' type(TYPE(kind=**)),intent(out),allocatable :: to(..)', & ' integer(kind=**),intent(out) :: stat', & ' character(len=*),intent(inout) :: errmsg', & '', & '', & 'CHARACTERISTICS', & ' o FROM may be of any type and kind.', & '', & ' o TO shall be of the same type, kind and rank as FROM.', & '', & 'DESCRIPTION', & ' MOVE_ALLOC(3) moves the allocation from FROM to TO. FROM will become', & ' deallocated in the process.', & '', & ' This is potentially more efficient than other methods of assigning the', & ' values in FROM to TO and explicitly deallocating FROM, which are far more', & ' likely to require a temporary object or a copy of the elements of the array.', & '', & 'OPTIONS', & ' o FROM : The data object to be moved to TO and deallocated.', & '', & ' o TO : The destination data object to move the allocated data object FROM', & ' to. Typically, it is a different shape than FROM.', & '', & ' o STAT : If STAT is present and execution is successful, it is assigned the', & ' value zero. : If an error condition occurs,', & '', & ' o if **stat** is absent, error termination is initiated;', & '', & ' o otherwise, if **from** is a coarray and the current team contains a', & ' stopped image, **stat** is assigned the value STAT\_STOPPED\_IMAGE', & ' from the intrinsic module ISO\_FORTRAN\_ENV;', & '', & ' o otherwise, if **from** is a coarray and the current team contains a', & ' failed image, and no other error condition occurs, **stat** is', & ' assigned the value STAT\_FAILED\_IMAGE from the intrinsic module', & ' ISO\_FORTRAN\_ENV;', & '', & ' o otherwise, **stat** is assigned a processor-dependent positive value', & ' that differs from that of STAT\_STOPPED\_IMAGE or STAT\_FAILED\_IMAGE.', & '', & ' o ERRMSG : If the ERRMSG argument is present and an error condition occurs,', & ' it is assigned an explanatory message. If no error condition occurs, the', & ' definition status and value of ERRMSG are unchanged.', & '', & 'EXAMPLES', & ' Basic sample program to allocate a bigger grid', & '', & ' program demo_move_alloc', & ' implicit none', & ' ! Example to allocate a bigger GRID', & ' real, allocatable :: grid(:), tempgrid(:)', & ' integer :: n, i', & '', & ' ! initialize small GRID', & ' n = 3', & ' allocate (grid(1:n))', & ' grid = [ (real (i), i=1,n) ]', & '', & ' ! initialize TEMPGRID which will be used to replace GRID', & ' allocate (tempgrid(1:2*n)) ! Allocate bigger grid', & ' tempgrid(::2) = grid ! Distribute values to new locations', & ' tempgrid(2::2) = grid + 0.5 ! initialize other values', & '', & ' ! move TEMPGRID to GRID', & ' call MOVE_ALLOC (from=tempgrid, to=grid)', & '', & ' ! TEMPGRID should no longer be allocated', & ' ! and GRID should be the size TEMPGRID was', & ' if (size (grid) /= 2*n .or. allocated (tempgrid)) then', & ' print *, "Failure in move_alloc!"', & ' endif', & ' print *, allocated(grid), allocated(tempgrid)', & ' print ''(99f8.3)'', grid', & ' end program demo_move_alloc', & '', & ' Results:', & '', & ' T F', & ' 1.000', & ' 1.500 2.000 2.500 3.000 3.500', & '', & 'STANDARD', & ' Fortran 2003, STAT and ERRMSG options added 2018', & '', & 'SEE ALSO', & ' ALLOCATED(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 move_alloc(3fortran)', & ''] shortname="move_alloc" call process() case('146','mvbits') textblock=[character(len=256) :: & '', & 'mvbits(3fortran) mvbits(3fortran)', & '', & '', & '', & 'NAME', & ' MVBITS(3) - [BIT:COPY] Reproduce bit patterns found in one integer in', & ' another', & '', & '', & 'SYNOPSIS', & ' call mvbits(from, frompos, len, to, topos)', & '', & ' elemental subroutine mvbits( from, frompos, len, to, topos )', & '', & ' integer(kind=KIND),intent(in) :: from', & ' integer(kind=**),intent(in) :: frompos', & ' integer(kind=**),intent(in) :: len', & ' integer(kind=KIND),intent(inout) :: to', & ' integer(kind=**),intent(in) :: topos', & '', & '', & 'CHARACTERISTICS', & ' o FROM is an integer', & '', & ' o FROMPOS is an integer', & '', & ' o LEN is an integer', & '', & ' o TO is an integer of the same kind as FROM.', & '', & ' o TOPOS is an integer', & '', & 'DESCRIPTION', & ' MVBITS(3) copies a bit pattern found in a range of adjacent bits in the', & ' integer FROM to a specified position in another integer TO (which is of the', & ' same kind as FROM). It otherwise leaves the bits in TO as-is.', & '', & ' The bit positions copied must exist within the value of FROM. That is, the', & ' values of FROMPOS+LEN-1 and TOPOS+LEN-1 must be nonnegative and less than', & ' BIT_SIZE(from).', & '', & ' The bits are numbered 0 to BIT_SIZE(I)-1, from right to left.', & '', & 'OPTIONS', & ' o FROM : An integer to read bits from.', & '', & ' o FROMPOS : FROMPOS is the position of the first bit to copy. It is a', & ' nonnegative integer value < BIT_SIZE(FROM).', & '', & ' o LEN : A nonnegative integer value that indicates how many bits to copy', & ' from FROM. It must not specify copying bits past the end of FROM. That', & ' is, FROMPOS + LEN must be less than or equal to BIT_SIZE(FROM).', & '', & ' o TO : The integer variable to place the copied bits into. It must be of', & ' the same kind as FROM and may even be the same variable as FROM, or', & ' associated to it.', & '', & ' TO is set by copying the sequence of bits of length LEN, starting at', & ' position FROMPOS of FROM to position TOPOS of TO. No other bits of TO are', & ' altered. On return, the LEN bits of TO starting at TOPOS are equal to the', & ' value that the LEN bits of FROM starting at FROMPOS had on entry.', & '', & ' o TOPOS : A nonnegative integer value indicating the starting location in', & ' TO to place the specified copy of bits from FROM. TOPOS + LEN must be', & ' less than or equal to BIT_SIZE(TO).', & '', & 'EXAMPLES', & ' Sample program that populates a new 32-bit integer with its bytes in reverse', & ' order from the input value (ie. changes the Endian of the integer).', & '', & ' program demo_mvbits', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int32) :: intfrom, intto, abcd_int', & ' character(len=*),parameter :: bits= ''(g0,t30,b32.32)''', & ' character(len=*),parameter :: fmt= ''(g0,t30,a,t40,b32.32)''', & '', & ' intfrom=huge(0) ! all bits are 1 accept the sign bit', & ' intto=0 ! all bits are 0', & '', & ' !! CHANGE BIT 0', & ' ! show the value and bit pattern', & ' write(*,bits)intfrom,intfrom', & ' write(*,bits)intto,intto', & '', & ' ! copy bit 0 from intfrom to intto to show the rightmost bit changes', & ' ! (from, frompos, len, to, topos)', & ' call mvbits(intfrom, 0, 1, intto, 0) ! change bit 0', & ' write(*,bits)intto,intto', & '', & ' !! COPY PART OF A VALUE TO ITSELF', & ' ! can copy bit from a value to itself', & ' call mvbits(intfrom,0,1,intfrom,31)', & ' write(*,bits)intfrom,intfrom', & '', & ' !! MOVING BYTES AT A TIME', & ' ! make native integer value with bit patterns', & ' ! that happen to be the same as the beginning of the alphabet', & ' ! to make it easy to see the bytes are reversed', & ' abcd_int=transfer(''abcd'',0)', & ' ! show the value and bit pattern', & ' write(*,*)''native''', & ' write(*,fmt)abcd_int,abcd_int,abcd_int', & '', & ' ! change endian of the value', & ' abcd_int=int_swap32(abcd_int)', & ' ! show the values and their bit pattern', & ' write(*,*)''non-native''', & ' write(*,fmt)abcd_int,abcd_int,abcd_int', & '', & ' contains', & '', & ' pure elemental function int_swap32(intin) result(intout)', & ' ! Convert a 32 bit integer from big Endian to little Endian,', & ' ! or conversely from little Endian to big Endian.', & ' !', & ' integer(kind=int32), intent(in) :: intin', & ' integer(kind=int32) :: intout', & ' ! copy bytes from input value to new position in output value', & ' ! (from, frompos, len, to, topos)', & ' call mvbits(intin, 0, 8, intout, 24) ! byte1 to byte4', & ' call mvbits(intin, 8, 8, intout, 16) ! byte2 to byte3', & ' call mvbits(intin, 16, 8, intout, 8) ! byte3 to byte2', & ' call mvbits(intin, 24, 8, intout, 0) ! byte4 to byte1', & ' end function int_swap32', & '', & ' end program demo_mvbits', & '', & ' Results:', & '', & ' 2147483647 01111111111111111111111111111111', & ' 0 00000000000000000000000000000000', & ' 1 00000000000000000000000000000001', & ' -1 11111111111111111111111111111111', & ' native', & ' 1684234849 abcd 01100100011000110110001001100001', & ' non-native', & ' 1633837924 dcba 01100001011000100110001101100100', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' BTEST(3), IAND(3), IBCLR(3), IBITS(3), IBSET(3), IEOR(3), IOR(3), NOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 mvbits(3fortran)', & ''] shortname="mvbits" call process() case('147','nearest') textblock=[character(len=256) :: & '', & 'nearest(3fortran) nearest(3fortran)', & '', & '', & '', & 'NAME', & ' NEAREST(3) - [MODEL_COMPONENTS] Nearest representable number', & '', & '', & 'SYNOPSIS', & ' result = nearest(x, s)', & '', & ' elemental real(kind=KIND) function nearest(x,s)', & '', & ' real(kind=KIND),intent(in) :: x', & ' real(kind=**),intent(in) :: s', & '', & '', & 'CHARACTERISTICS', & ' o X may be a real value of any kind.', & '', & ' o S may be a real value of any kind.', & '', & ' o The return value is of the same type and kind as X.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' NEAREST(3) returns the processor-representable number nearest to X in the', & ' direction indicated by the sign of S.', & '', & 'OPTIONS', & ' o X : the value to find the nearest representable value of', & '', & ' o S : a non-zero value whose sign is used to determine the direction in', & ' which to search from X to the representable value.', & '', & ' If S is positive, NEAREST returns the processor-representable number', & ' greater than X and nearest to it.', & '', & ' If S is negative, NEAREST returns the processor-representable number', & ' smaller than X and nearest to it.', & '', & 'RESULT', & ' The return value is of the same type as X. If S is positive, NEAREST returns', & ' the processor-representable number greater than X and nearest to it. If S is', & ' negative, NEAREST returns the processor-representable number smaller than X', & ' and nearest to it.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_nearest', & ' implicit none', & '', & ' real :: x, y', & ' x = nearest(42.0, 1.0)', & ' y = nearest(42.0, -1.0)', & ' write (*,"(3(g20.15))") x, y, x - y', & '', & ' ! write (*,"(3(g20.15))") &', & ' ! nearest(tiny(0.0),1.0), &', & ' ! nearest(tiny(0.0),-1.0), &', & ' ! nearest(tiny(0.0),1.0) -nearest(tiny(0.0),-1.0)', & '', & ' ! write (*,"(3(g20.15))") &', & ' ! nearest(huge(0.0),1.0), &', & ' ! nearest(huge(0.0),-1.0), &', & ' ! nearest(huge(0.0),1.0)- nearest(huge(0.0),-1.0)', & '', & ' end program demo_nearest', & '', & ' Results:', & '', & ' 42.0000038146973 41.9999961853027 .762939453125000E-05', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 nearest(3fortran)', & ''] shortname="nearest" call process() case('148','new_line') textblock=[character(len=256) :: & '', & 'new_line(3fortran) new_line(3fortran)', & '', & '', & '', & 'NAME', & ' NEW_LINE(3) - [CHARACTER:INQUIRY] Newline character', & '', & '', & 'SYNOPSIS', & ' result = new_line(c)', & '', & ' character(len=1,kind=KIND) function new_line(c)', & '', & ' character(len=1,kind=KIND),intent(in) :: c(..)', & '', & '', & 'CHARACTERISTICS', & ' o C shall be of type character. It may be a scalar or an array.', & '', & ' o the result is a character scalar of length one with the same kind type', & ' parameter as C.', & '', & 'DESCRIPTION', & ' NEW_LINE(3) returns the newline character.', & '', & ' Normally, newlines are generated with regular formatted I/O statements like', & ' WRITE() and PRINT() when each statement completes:', & '', & ' print *, ''x=11''', & ' print *', & ' print *, ''y=22''', & ' end', & '', & ' produces: x=11', & '', & ' y=22', & '', & ' Alternatively, a "/" descriptor in a format is used to generate a', & ' newline on the output. For example:', & ' ```fortran', & ' write(*,''(a,1x,i0,/,a)'') ''x ='',11,''is the answer''', & ' end', & '', & ' produces:', & '', & ' x = 11', & ' is the answer', & '', & ' Also, for formatted sequential output if more data is listed on the output', & ' statement than can be represented by the format statement a newline is', & ' generated and then the format is reused until the output list is exhausted.', & '', & ' write(*,''(a,"=",i0)'') ''x'', 10, ''y'', 20', & ' end', & '', & ' produces', & '', & ' x=10', & ' y=20', & '', & ' But there are occasions, particularly when non-advancing I/O or stream I/O', & ' is being generated (which does not generate a newline at the end of each', & ' WRITE statement, as normally occurs) where it is preferable to place a', & ' newline explicitly in the output at specified points.', & '', & ' To do so you must make sure you are generating the correct newline', & ' character, which the techniques above do automatically.', & '', & ' The newline character varies between some platforms, and can even depend on', & ' the encoding (ie. which character set is being used) of the output file. In', & ' these cases selecting the correct character to output can be determined by', & ' the NEW_LINE(3) procedure.', & '', & 'OPTIONS', & ' o C : an arbitrary character whose kind is used to decide on the output', & ' character that represents a newline.', & '', & 'RESULT', & ' Case (i) : If A is default character and the character in position 10 of the', & ' ASCII collating sequence is representable in the default character set, then', & ' the result is ACHAR(10).', & '', & ' This is the typical case, and just requires using "new_line(''a'')".', & '', & ' Case (ii) : If A is an ASCII character or an ISO 10646 character, then the', & ' result is CHAR(10, KIND (A)).', & '', & ' Case (iii) : Otherwise, the result is a processor-dependent character that', & ' represents a newline in output to files connected for formatted stream', & ' output if there is such a character.', & '', & ' Case (iv) : If not of the previous cases apply, the result is the blank', & ' character.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_new_line', & ' implicit none', & ' character,parameter :: nl=new_line(''a'')', & ' character(len=:),allocatable :: string', & ' real :: r', & ' integer :: i, count', & '', & ' ! basics', & ' ! print a string with a newline embedded in it', & ' string=''This is record 1.''//nl//''This is record 2.''', & ' write(*,''(a)'') string', & '', & ' ! print a newline character string', & ' write(*,''(*(a))'',advance=''no'') &', & ' nl,''This is record 1.'',nl,''This is record 2.'',nl', & '', & ' ! output a number of words of random length as a paragraph', & ' ! by inserting a new_line before line exceeds 70 characters', & '', & ' ! simplistic paragraph print using non-advancing I/O', & ' count=0', & ' do i=1,100', & '', & ' ! make some fake word of random length', & ' call random_number(r)', & ' string=repeat(''x'',int(r*10)+1)', & '', & ' count=count+len(string)+1', & ' if(count.gt.70)then', & ' write(*,''(a)'',advance=''no'')nl', & ' count=len(string)+1', & ' endif', & ' write(*,''(1x,a)'',advance=''no'')string', & ' enddo', & ' write(*,''(a)'',advance=''no'')nl', & '', & ' end program demo_new_line', & '', & ' Results:', & '', & ' This is record 1.', & ' This is record 2.', & '', & ' This is record 1.', & ' This is record 2.', & ' x x xxxx xxxxxxx xxxxxxxxxx xxxxxxxxx xxxx xxxxxxxxxx xxxxxxxx', & ' xxxxxxxxx xxxx xxxxxxxxx x xxxxxxxxx xxxxxxxx xxxxxxxx xxxx x', & ' xxxxxxxxxx x x x xxxxxx xxxxxxxxxx x xxxxxxxxxx x xxxxxxx xxxxxxxxx', & ' xx xxxxxxxxxx xxxxxxxx x xx xxxxxxxxxx xxxxxxxx xxx xxxxxxx xxxxxx', & ' xxxxx xxxxxxxxx x xxxxxxxxxx xxxxxx xxxxxxxx xxxxx xxxxxxxx xxxxxxxx', & ' xxxxx xxx xxxxxxxx xxxxxxx xxxxxxxx xxx xxxx xxx xxxxxxxx xxxxxx', & ' xxxxxxx xxxxxxx xxxxx xxxxx xx xxxxxx xx xxxxxxxxxx xxxxxx x xxxx', & ' xxxxxx xxxxxxx x xxx xxxxx xxxxxxxxx xxx xxxxxxx x xxxxxx xxxxxxxxx', & ' xxxx xxxxxxxxx xxxxxxxx xxxxxxxx xxx xxxxxxx xxxxxxx xxxxxxxxxx', & ' xxxxxxxxxx xxxxxx xxxxx xxxx xxxxxxx xx xxxxxxxxxx xxxxxx xxxxxx', & ' xxxxxx xxxx xxxxx', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' ACHAR(3), CHAR(3), IACHAR(3), ICHAR(3), SELECTED_CHAR_KIND(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 new_line(3fortran)', & ''] shortname="new_line" call process() case('149','nint') textblock=[character(len=256) :: & '', & 'nint(3fortran) nint(3fortran)', & '', & '', & '', & 'NAME', & ' NINT(3) - [TYPE:NUMERIC] Nearest whole number', & '', & '', & 'SYNOPSIS', & ' result = nint( a [,kind] )', & '', & ' elemental integer(kind=KIND) function nint(a, kind )', & '', & ' real(kind=**),intent(in) :: a', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o A is type real of any kind', & '', & ' o KIND is a scalar integer constant expression', & '', & ' o The result is default integer kind or the value of KIND if KIND is', & ' present.', & '', & 'DESCRIPTION', & ' NINT(3) rounds its argument to the nearest whole number with its sign', & ' preserved.', & '', & ' The user must ensure the value is a valid value for the range of the KIND', & ' returned. If the processor cannot represent the result in the kind', & ' specified, the result is undefined.', & '', & ' If A is greater than zero, NINT(A) has the value INT(A+0.5).', & '', & ' If A is less than or equal to zero, NINT(A) has the value INT(A-0.5).', & '', & 'OPTIONS', & ' o A : The value to round to the nearest whole number', & '', & ' o KIND : can specify the kind of the output value. If not present, the', & ' output is the default type of integer.', & '', & 'RESULT', & ' The result is the integer nearest A, or if there are two integers equally', & ' near A, the result is whichever such integer has the greater magnitude.', & '', & ' The result is undefined if it cannot be represented in the specified integer', & ' type.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_nint', & ' implicit none', & ' integer,parameter :: dp=kind(0.0d0)', & ' real,allocatable :: in(:)', & ' integer,allocatable :: out(:)', & ' integer :: i', & ' real :: x4', & ' real(kind=dp) :: x8', & '', & ' ! basic use', & ' x4 = 1.234E0', & ' x8 = 4.721_dp', & ' print *, nint(x4), nint(-x4)', & ' print *, nint(x8), nint(-x8)', & '', & ' ! elemental', & ' in = [ -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, -0.4, &', & ' & 0.0, &', & ' & +0.04, +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ]', & ' out = nint(in)', & ' do i=1,size(in)', & ' write(*,*)in(i),out(i)', & ' enddo', & '', & ' ! dusty corners', & ' ISSUES: block', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' integer :: icheck', & ' ! make sure input is in range for the type returned', & ' write(*,*)''Range limits for typical KINDS:''', & ' write(*,''(1x,g0,1x,g0)'') &', & ' & int8,huge(0_int8), &', & ' & int16,huge(0_int16), &', & ' & int32,huge(0_int32), &', & ' & int64,huge(0_int64)', & '', & ' ! the standard does not require this to be an error ...', & ' x8=12345.67e15 ! too big of a number', & ' icheck=selected_int_kind(ceiling(log10(x8)))', & ' write(*,*)''Any KIND big enough? ICHECK='',icheck', & ' print *, ''These are all wrong answers for '',x8', & ' print *, nint(x8,kind=int8)', & ' print *, nint(x8,kind=int16)', & ' print *, nint(x8,kind=int32)', & ' print *, nint(x8,kind=int64)', & ' endblock ISSUES', & '', & ' end program demo_nint', & '', & ' Results:', & '', & ' > 1 -1', & ' > 5 -5', & ' > -2.700000 -3', & ' > -2.500000 -3', & ' > -2.200000 -2', & ' > -2.000000 -2', & ' > -1.500000 -2', & ' > -1.000000 -1', & ' > -0.5000000 -1', & ' > -0.4000000 0', & ' > 0.0000000E+00 0', & ' > 3.9999999E-02 0', & ' > 0.5000000 1', & ' > 1.000000 1', & ' > 1.500000 2', & ' > 2.000000 2', & ' > 2.200000 2', & ' > 2.500000 3', & ' > 2.700000 3', & ' > Range limits for typical KINDS:', & ' > 1 127', & ' > 2 32767', & ' > 4 2147483647', & ' > 8 9223372036854775807', & ' > Any KIND big enough? ICHECK= -1', & ' > These are all wrong answers for 1.234566949990144E+019', & ' > 0', & ' > 0', & ' > -2147483648', & ' > -9223372036854775808', & '', & '', & 'STANDARD', & ' FORTRAN 77 , with KIND argument - Fortran 90', & '', & 'SEE ALSO', & ' AINT(3), ANINT(3), INT(3), SELECTED_INT_KIND(3), CEILING(3), FLOOR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 nint(3fortran)', & ''] shortname="nint" call process() case('150','norm2') textblock=[character(len=256) :: & '', & 'norm2(3fortran) norm2(3fortran)', & '', & '', & '', & 'NAME', & ' NORM2(3) - [MATHEMATICS] Euclidean vector norm', & '', & '', & 'SYNOPSIS', & ' result = norm2(array, [dim])', & '', & ' real(kind=KIND) function norm2(array, dim)', & '', & ' real(kind=KIND),intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY shall be an array of type real.', & '', & ' o DIM shall be a scalar of type integer', & '', & ' o The result is of the same type as ARRAY.', & '', & 'DESCRIPTION', & ' NORM2(3) calculates the Euclidean vector norm (L_2 norm or generalized L', & ' norm) of ARRAY along dimension DIM.', & '', & 'OPTIONS', & ' o ARRAY : the array of input values for the L_2 norm computations', & '', & ' o DIM : a value in the range from 1 to RANK(ARRAY).', & '', & 'RESULT', & ' If DIM is absent, a scalar with the square root of the sum of squares of the', & ' elements of ARRAY is returned.', & '', & ' Otherwise, an array of rank N-1, where N equals the rank of ARRAY, and a', & ' shape similar to that of ARRAY with dimension DIM dropped is returned.', & '', & ' Case (i): The result of NORM2 (X) has a value equal to a', & ' processor-dependent approximation to the generalized', & ' L norm of X, which is the square root of the sum of', & ' the squares of the elements of X. If X has size zero,', & ' the result has the value zero.', & '', & ' Case (ii): The result of NORM2 (X, DIM=DIM) has a value equal', & ' to that of NORM2 (X) if X has rank one. Otherwise,', & ' the resulting array is reduced in rank with dimension', & ' **dim** removed, and each remaining elment is the', & ' result of NORM2(X) for the values along dimension', & ' **dim**.', & '', & ' It is recommended that the processor compute the result without undue', & ' overflow or underflow.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_norm2', & ' implicit none', & ' integer :: i', & ' real :: x(2,3) = reshape([ &', & ' 1, 2, 3, &', & ' 4, 5, 6 &', & ' ],shape(x),order=[2,1])', & '', & ' write(*,*) ''input in row-column order''', & ' write(*,*) ''x=''', & ' write(*,''(4x,3f4.0)'')transpose(x)', & ' write(*,*)', & ' write(*,*) ''norm2(x)='',norm2(x)', & ' write(*,*) ''which is equivalent to''', & ' write(*,*) ''sqrt(sum(x**2))='',sqrt(sum(x**2))', & ' write(*,*)', & ' write(*,*) ''for reference the array squared is''', & ' write(*,*) ''x**2=''', & ' write(*,''(4x,3f4.0)'')transpose(x**2)', & ' write(*,*)', & ' write(*,*) ''norm2(x,dim=1)='',norm2(x,dim=1)', & ' write(*,*) ''norm2(x,dim=2)='',norm2(x,dim=2)', & ' write(*,*) ''(sqrt(sum(x(:,i)**2)),i=1,3)='',(sqrt(sum(x(:,i)**2)),i=1,3)', & ' write(*,*) ''(sqrt(sum(x(i,:)**2)),i=1,2)='',(sqrt(sum(x(i,:)**2)),i=1,2)', & '', & ' end program demo_norm2', & '', & ' Results:', & '', & ' > input in row-column order', & ' > x=', & ' > 1. 2. 3.', & ' > 4. 5. 6.', & ' >', & ' > norm2(x)= 9.539392', & ' > which is equivalent to', & ' > sqrt(sum(x**2))= 9.539392', & ' >', & ' > for reference the array squared is', & ' > x**2=', & ' > 1. 4. 9.', & ' > 16. 25. 36.', & ' >', & ' > norm2(x,dim=1)= 4.123106 5.385165 6.708204', & ' > norm2(x,dim=2)= 3.741657 8.774964', & ' > (sqrt(sum(x(:,i)**2)),i=1,3)= 4.123106 5.385165 6.708204', & ' > (sqrt(sum(x(i,:)**2)),i=1,2)= 3.741657 8.774964', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' PRODUCT(3), SUM(3), HYPOT(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 norm2(3fortran)', & ''] shortname="norm2" call process() case('151','not') textblock=[character(len=256) :: & '', & 'not(3fortran) not(3fortran)', & '', & '', & '', & 'NAME', & ' NOT(3) - [BIT:LOGICAL] Logical negation; flips all bits in an integer', & '', & '', & 'SYNOPSIS', & ' result = not(i)', & '', & ' elemental integer(kind=KIND) function not(i)', & '', & ' integer(kind=KIND), intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o I may be an integer of any valid kind', & '', & ' o The returned integer is of the same kind as the argument I.', & '', & 'DESCRIPTION', & ' NOT(3) returns the bitwise Boolean inverse of I. This is also known as the', & ' "Bitwise complement" or "Logical negation" of the value.', & '', & ' If an input bit is a one, that position is a zero on output. Conversely any', & ' input bit that is zero is a one on output.', & '', & 'OPTIONS', & ' o I : The value to flip the bits of.', & '', & 'RESULT', & ' The result has the value obtained by complementing I bit-by-bit according to', & ' the following truth table:', & '', & ' > I | NOT(I)', & ' > ----#----------', & ' > 1 | 0', & ' > 0 | 1', & '', & ' That is, every input bit is flipped.', & '', & 'EXAMPLES', & ' Sample program', & '', & ' program demo_not', & ' implicit none', & ' integer :: i', & ' ! basics', & ' i=-13741', & ' print *,''the input value'',i,''represented in bits is''', & ' write(*,''(1x,b32.32,1x,i0)'') i, i', & ' i=not(i)', & ' print *,''on output it is'',i', & ' write(*,''(1x,b32.32,1x,i0)'') i, i', & ' print *, " on a two''s complement machine flip the bits and add 1"', & ' print *, " to get the value with the sign changed, for example."', & ' print *, 1234, not(1234)+1', & ' print *, -1234, not(-1234)+1', & ' print *, " of course ''x=-x'' works just fine and more generally."', & ' end program demo_not', & '', & ' Results:', & '', & ' the input value -13741 represented in bits is', & ' 11111111111111111100101001010011 -13741', & ' on output it is 13740', & ' 00000000000000000011010110101100 13740', & ' on a two''s complement machine flip the bits and add 1', & ' to get the value with the sign changed, for example.', & ' 1234 -1234', & ' -1234 1234', & ' of course ''x=-x'' works just fine and more generally.', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' IAND(3), IOR(3), IEOR(3), IBITS(3), IBSET(3),', & '', & ' IBCLR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 not(3fortran)', & ''] shortname="not" call process() case('152','null') textblock=[character(len=256) :: & '', & 'null(3fortran) null(3fortran)', & '', & '', & '', & 'NAME', & ' NULL(3) - [TRANSFORMATIONAL] Function that returns a disassociated pointer', & '', & '', & 'SYNOPSIS', & ' ptr => null( [mold] )', & '', & ' function null(mold)', & '', & ' type(TYPE(kind=**)),pointer,optional :: mold', & '', & '', & 'CHARACTERISTICS', & ' o MOLD is a pointer of any association status and of any type.', & '', & ' o The result is a disassociated pointer or an unallocated allocatable', & ' entity.', & '', & 'DESCRIPTION', & ' NULL(3) returns a disassociated pointer.', & '', & ' If MOLD is present, a disassociated pointer of the same type is returned,', & ' otherwise the type is determined by context.', & '', & ' In Fortran 95, MOLD is optional. Please note that Fortran 2003 includes', & ' cases where it is required.', & '', & 'OPTIONS', & ' o MOLD : a pointer of any association status and of any type.', & '', & 'RESULT', & ' A disassociated pointer or an unallocated allocatable entity.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' !program demo_null', & ' module showit', & ' implicit none', & ' private', & ' character(len=*),parameter :: g=''(*(g0,1x))''', & ' public gen', & ' ! a generic interface that only differs in the', & ' ! type of the pointer the second argument is', & ' interface gen', & ' module procedure s1', & ' module procedure s2', & ' end interface', & '', & ' contains', & '', & ' subroutine s1 (j, pi)', & ' integer j', & ' integer, pointer :: pi', & ' if(associated(pi))then', & ' write(*,g)''Two integers in S1:,'',j,''and'',pi', & ' else', & ' write(*,g)''One integer in S1:,'',j', & ' endif', & ' end subroutine s1', & '', & ' subroutine s2 (k, pr)', & ' integer k', & ' real, pointer :: pr', & ' if(associated(pr))then', & ' write(*,g)''integer and real in S2:,'',k,''and'',pr', & ' else', & ' write(*,g)''One integer in S2:,'',k', & ' endif', & ' end subroutine s2', & '', & ' end module showit', & '', & ' program demo_null', & ' use showit, only : gen', & '', & ' real,target :: x = 200.0', & ' integer,target :: i = 100', & '', & ' real, pointer :: real_ptr', & ' integer, pointer :: integer_ptr', & '', & ' ! so how do we call S1() or S2() with a disassociated pointer?', & '', & ' ! the answer is the null() function with a mold value', & '', & ' ! since s1() and s2() both have a first integer', & ' ! argument the NULL() pointer must be associated', & ' ! to a real or integer type via the mold option', & ' ! so the following can distinguish whether s1(1)', & ' ! or s2() is called, even though the pointers are', & ' ! not associated or defined', & '', & ' call gen (1, null (real_ptr) ) ! invokes s2', & ' call gen (2, null (integer_ptr) ) ! invokes s1', & ' real_ptr => x', & ' integer_ptr => i', & ' call gen (3, real_ptr ) ! invokes s2', & ' call gen (4, integer_ptr ) ! invokes s1', & '', & ' end program demo_null', & '', & ' Results:', & '', & ' One integer in S2:, 1', & ' One integer in S1:, 2', & ' integer and real in S2:, 3 and 200.000000', & ' Two integers in S1:, 4 and 100', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' ASSOCIATED(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 null(3fortran)', & ''] shortname="null" call process() case('153','num_images') textblock=[character(len=256) :: & '', & 'num_images(3fortran) num_images(3fortran)', & '', & '', & '', & 'NAME', & ' NUM_IMAGES(3) - [COLLECTIVE] Number of images', & '', & '', & 'SYNOPSIS', & ' result = num_images([team|team_number])', & '', & ' integer function num_images (team)', & '', & ' type(TEAM_TYPE),intent(in),optional :: team', & ' integer(kind=KIND),intent(in),optional :: team_number', & '', & '', & 'CHARACTERISTICS', & ' o use of TEAM and TEAM_NUMBER is mutually exclusive', & '', & ' o TEAM is a scalar of type TEAM_TYPE from the intrinsic module', & ' ISO_FORTRAN_ENV.', & '', & ' o TEAM_NUMBER is an integer scalar.', & '', & ' o the result is a default integer scalar.', & '', & 'DESCRIPTION', & ' NUM_IMAGES(3) Returns the number of images.', & '', & 'OPTIONS', & ' o TEAM : shall be a scalar of type TEAM_TYPE from the intrinsic module', & ' ISO_FORTRAN_ENV, with a value that identifies the current or an ancestor', & ' team.', & '', & ' o TEAM_NUMBER : identifies the initial team or a team whose parent is the', & ' same as that of the current team.', & '', & 'RESULT', & ' The number of images in the specified team, or in the current team if no', & ' team is specified.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_num_images', & ' implicit none', & ' integer :: value[*]', & ' real :: p[*]', & ' integer :: i', & '', & ' value = this_image()', & ' sync all', & ' if (this_image() == 1) then', & ' do i = 1, num_images()', & ' write(*,''(2(a,i0))'') ''value['', i, ''] is '', value[i]', & ' end do', & ' endif', & '', & ' ! The following code uses image 1 to read data and', & ' ! broadcast it to other images.', & ' if (this_image()==1) then', & ' p=1234.5678', & ' do i = 2, num_images()', & ' p[i] = p', & ' end do', & ' end if', & ' sync all', & '', & ' end program demo_num_images', & '', & '', & 'STANDARD', & ' Fortran 2008 . With DISTANCE or FAILED argument, TS 18508', & '', & 'SEE ALSO', & ' THIS_IMAGE(3), IMAGE_INDEX(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 num_images(3fortran)', & ''] shortname="num_images" call process() case('154','out_of_range') textblock=[character(len=256) :: & '', & 'out_of_range(3fortran) out_of_range(3fortran)', & '', & '', & '', & 'NAME', & ' OUT_OF_RANGE(3) - [TYPE:NUMERIC] Whether a numeric value can be converted', & ' safely to another type', & '', & '', & 'SYNOPSIS', & ' result = out_of_range (x, mold [, round])', & '', & ' elemental logical function(x, mold, round)', & '', & ' type(TYPE(kind=**)),intent(in) :: x', & ' type(TYPE(kind=**)),intent(in) :: mold', & ' logical,intent(in),optional :: round', & '', & '', & 'CHARACTERISTICS', & ' o X is of type integer or real.', & '', & ' o MOLD is an integer or real scalar.', & '', & ' o ROUND is a logical scalar.', & '', & ' o the result is a default logical.', & '', & 'DESCRIPTION', & ' OUT_OF_RANGE(3) determines whether a value X can be converted safely to a', & ' real or integer variable the same type and kind as MOLD.', & '', & ' For example, if INT8 is the KIND name for an 8-bit binary integer type, then', & ' for', & '', & ' logical :: L1, L2', & ' L1=out_of_range(-128.5, 0_int8)', & ' L2=out_of_range(-128.5, 0_int8,.true.)', & ' end', & '', & ' L1 likely will have the value __.false.__ because the value will be', & ' truncated to -128.0, which is a representable integer number on a two''s', & ' complement machine.', & '', & ' L2 will be __.true.__ because it will be rounded to -129.0, which is not', & ' likely to be a representable eight-bit integer.', & '', & 'OPTIONS', & ' o X : a scalar to be tested for whether it can be stored in a variable of', & ' the type and kind of MOLD', & '', & ' o MOLD : the type and kind of the variable (but not the value) is used to', & ' identify the characteristics of the variable type to fit X into.', & '', & ' o ROUND : flag whether to round the value of X before validating it as a', & ' value like MOLD.', & '', & ' ROUND can only be present if X is of type real and MOLD is of type', & ' integer.', & '', & 'RESULT', & ' From the standard:', & '', & ' Case (i): If MOLD is of type integer, and ROUND is absent or present with', & ' the value false, the result is true if and only if the value of X is an IEEE', & ' infinity or NaN, or if the integer with largest magnitude that lies between', & ' zero and X inclusive is not representable by objects with the type and kind', & ' of MOLD.', & '', & ' Case (ii): If MOLD is of type integer, and ROUND is present with the value', & ' true, the result is true if and only if the value of X is an IEEE infinity', & ' or NaN, or if the integer nearest X, or the integer of greater magnitude if', & ' two integers are equally near to X, is not representable by objects with the', & ' type and kind of MOLD.', & '', & ' Case (iii): Otherwise, the result is true if and only if the value of X is', & ' an IEEE infinity or NaN that is not supported by objects of the type and', & ' kind of MOLD, or if X is a finite number and the result of rounding the', & ' value of X (according to the IEEE rounding mode if appropriate) to the', & ' extended model for the kind of MOLD has magnitude larger than that of the', & ' largest finite number with the same sign as X that is representable by', & ' objects with the type and kind of MOLD.', & '', & 'NOTE', & ' MOLD is required to be a scalar because the only information taken from it', & ' is its type and kind. Allowing an array MOLD would require that it be', & ' conformable with X. ROUND is scalar because allowing an array rounding mode', & ' would have severe performance difficulties on many processors.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_out_of_range', & ' use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' use, intrinsic :: iso_fortran_env, only : real32, real64, real128', & ' implicit none', & ' integer :: i', & ' integer(kind=int8) :: i8, j8', & '', & ' ! compilers are not required to produce an error on out of range.', & ' ! here storing the default integers into 1-byte integers', & ' ! incorrectly can have unexpected results', & ' do i=127,130', & ' i8=i', & ' j8=-i', & ' ! OUT_OF_RANGE(3f) can let you check if the value will fit', & ' write(*,*)i8,j8,'' might have expected'',i,-i, &', & ' & out_of_range( i,i8), &', & ' & out_of_range(-i,i8)', & ' enddo', & ' write(*,*) ''RANGE IS '',-1-huge(0_int8),''TO'',huge(0_int8)', & ' ! the real -128.5 is truncated to -128 and is in range', & ' write(*,*) out_of_range ( -128.5, 0_int8) ! false', & '', & ' ! the real -128.5 is rounded to -129 and is not in range', & ' write(*,*) out_of_range ( -128.5, 0_int8, .true.) ! true', & '', & ' end program demo_out_of_range', & '', & ' Results:', & '', & ' > 127 -127 might have expected 127 -127 F F', & ' > -128 -128 might have expected 128 -128 T F', & ' > -127 127 might have expected 129 -129 T T', & ' > -126 126 might have expected 130 -130 T T', & ' > RANGE IS -128 TO 127', & ' > F', & ' > T', & '', & '', & 'STANDARD', & ' FORTRAN 2018', & '', & 'SEE ALSO', & ' o AIMAG(3) - Imaginary part of complex number', & '', & ' o CMPLX(3) - Convert values to a complex type', & '', & ' o DBLE(3) - Double conversion function', & '', & ' o INT(3) - Truncate towards zero and convert to integer', & '', & ' o NINT(3) - Nearest whole number', & '', & ' o REAL(3) - Convert to real type', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 out_of_range(3fortran)', & ''] shortname="out_of_range" call process() case('155','pack') textblock=[character(len=256) :: & '', & 'pack(3fortran) pack(3fortran)', & '', & '', & '', & 'NAME', & ' PACK(3) - [ARRAY:CONSTRUCTION] Pack an array into an array of rank one', & '', & '', & 'SYNOPSIS', & ' result = pack( array, mask [,vector] )', & '', & ' TYPE(kind=KIND) function pack(array,mask,vector)', & '', & ' TYPE(kind=KIND),option(in) :: array(..)', & ' logical :: mask(..)', & ' TYPE(kind=KIND),option(in),optional :: vector(*)', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY is an array of any type', & '', & ' o MASK a logical scalar as well as an array conformable with ARRAY.', & '', & ' o VECTOR is of the same kind and type as ARRAY and of rank one', & '', & ' o the returned value is of the same kind and type as ARRAY', & '', & 'DESCRIPTION', & ' PACK(3) stores the elements of ARRAY in an array of rank one.', & '', & ' The beginning of the resulting array is made up of elements whose MASK', & ' equals .true.. Afterwards, remaining positions are filled with elements', & ' taken from VECTOR', & '', & 'OPTIONS', & ' o ARRAY : The data from this array is used to fill the resulting vector', & '', & ' o MASK : the logical mask must be the same size as ARRAY or, alternatively,', & ' it may be a logical scalar.', & '', & ' o VECTOR : an array of the same type as ARRAY and of rank one. If present,', & ' the number of elements in VECTOR shall be equal to or greater than the', & ' number of true elements in MASK. If MASK is scalar, the number of', & ' elements in VECTOR shall be equal to or greater than the number of', & ' elements in ARRAY.', & '', & ' VECTOR shall have at least as many elements as there are in ARRAY.', & '', & 'RESULT', & ' The result is an array of rank one and the same type as that of ARRAY. If', & ' VECTOR is present, the result size is that of VECTOR, the number of .true.', & ' values in MASK otherwise.', & '', & ' If MASK is scalar with the value .true., in which case the result size is', & ' the size of ARRAY.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_pack', & ' implicit none', & ' integer, allocatable :: m(:)', & ' character(len=10) :: c(4)', & '', & ' ! gathering nonzero elements from an array:', & ' m = [ 1, 0, 0, 0, 5, 0 ]', & ' write(*, fmt="(*(i0, '' ''))") pack(m, m /= 0)', & '', & ' ! Gathering nonzero elements from an array and appending elements', & ' ! from VECTOR till the size of the mask array (or array size if the', & ' ! mask is scalar):', & ' m = [ 1, 0, 0, 2 ]', & ' write(*, fmt="(*(i0, '' ''))") pack(m, m /= 0, [ 0, 0, 3, 4 ])', & ' write(*, fmt="(*(i0, '' ''))") pack(m, m /= 0 )', & '', & ' ! select strings whose second character is "a"', & ' c = [ character(len=10) :: ''ape'', ''bat'', ''cat'', ''dog'']', & ' write(*, fmt="(*(g0, '' ''))") pack(c, c(:)(2:2) == ''a'' )', & '', & ' end program demo_pack', & '', & ' Results:', & '', & ' > 1 5', & ' > 1 2 3 4', & ' > 1 2', & ' > bat cat', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' MERGE(3), SPREAD(3), UNPACK(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 pack(3fortran)', & ''] shortname="pack" call process() case('156','parity') textblock=[character(len=256) :: & '', & 'parity(3fortran) parity(3fortran)', & '', & '', & '', & 'NAME', & ' PARITY(3) - [ARRAY:REDUCTION] Array reduction by .NEQV. operation', & '', & '', & 'SYNOPSIS', & ' result = parity( mask [,dim] )', & '', & ' logical(kind=KIND) function parity(mask, dim)', & '', & ' type(logical(kind=KIND)),intent(in) :: mask(..)', & ' type(integer(kind=**)),intent(in),optional :: dim', & '', & '', & 'CHARACTERISTICS', & ' o MASK is a logical array', & '', & ' o DIM is an integer scalar', & '', & ' o the result is of type logical with the same kind type parameter as MASK.', & ' It is a scalar if DIM does not appear; otherwise it is the rank and shape', & ' of MASK with the dimension specified by DIM removed.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' PARITY(3) calculates the parity array (i.e. the reduction using .neqv.) of', & ' MASK along dimension DIM if DIM is present and not 1. Otherwise, it returns', & ' the parity of the entire MASK array as a scalar.', & '', & 'OPTIONS', & ' o MASK : Shall be an array of type logical.', & '', & ' o DIM : (Optional) shall be a scalar of type integer with a value in the', & ' range from 1 to n, where n equals the rank of MASK.', & '', & 'RESULT', & ' The result is of the same type as MASK.', & '', & ' If DIM is absent, a scalar with the parity of all elements in MASK is', & ' returned: .true. if an odd number of elements are .true. and .false.', & ' otherwise.', & '', & ' If MASK has rank one, PARITY (MASK, DIM) is equal to PARITY (MASK).', & ' Otherwise, the result is an array of parity values with dimension DIM', & ' dropped.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_parity', & ' implicit none', & ' logical, parameter :: T=.true., F=.false.', & ' logical :: x(3,4)', & ' ! basics', & ' print *, parity([T,F])', & ' print *, parity([T,F,F])', & ' print *, parity([T,F,F,T])', & ' print *, parity([T,F,F,T,T])', & ' x(1,:)=[T,T,T,T]', & ' x(2,:)=[T,T,T,T]', & ' x(3,:)=[T,T,T,T]', & ' print *, parity(x)', & ' print *, parity(x,dim=1)', & ' print *, parity(x,dim=2)', & ' end program demo_parity', & '', & ' Results:', & '', & ' > T', & ' > T', & ' > F', & ' > T', & ' > F', & ' > T T T T', & ' > F F F', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' o ALL(3) - Determines if all the values are true', & '', & ' o ANY(3) - Determines if any of the values in the logical array are .true.', & '', & ' o COUNT(3) - Count true values in an array', & '', & ' o SUM(3) - Sum the elements of an array', & '', & ' o MAXVAL(3) - Determines the maximum value in an array or row', & '', & ' o MINVAL(3) - Minimum value of an array', & '', & ' o PRODUCT(3) - Product of array elements', & '', & ' o REDUCE(3) - General array reduction', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 parity(3fortran)', & ''] shortname="parity" call process() case('157','popcnt') textblock=[character(len=256) :: & '', & 'popcnt(3fortran) popcnt(3fortran)', & '', & '', & '', & 'NAME', & ' POPCNT(3) - [BIT:COUNT] Number of bits set', & '', & '', & 'SYNOPSIS', & ' result = popcnt(i)', & '', & ' elemental integer function popcnt(i)', & '', & ' integer(kind=KIND), intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o I may be an integer of any kind.', & '', & ' o The return value is an integer of the default integer kind.', & '', & 'DESCRIPTION', & ' POPCNT(3) returns the number of bits set to one in the binary representation', & ' of an integer.', & '', & 'OPTIONS', & ' o I : value to count set bits in', & '', & 'RESULT', & ' The number of bits set to one in I.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_popcnt', & ' use, intrinsic :: iso_fortran_env, only : integer_kinds, &', & ' & int8, int16, int32, int64', & ' implicit none', & ' character(len=*),parameter :: pretty=''(b64,1x,i0)''', & ' ! basic usage', & ' print pretty, 127, popcnt(127)', & ' print pretty, int(b"01010"), popcnt(int(b"01010"))', & '', & ' ! any kind of an integer can be used', & ' print pretty, huge(0_int8), popcnt(huge(0_int8))', & ' print pretty, huge(0_int16), popcnt(huge(0_int16))', & ' print pretty, huge(0_int32), popcnt(huge(0_int32))', & ' print pretty, huge(0_int64), popcnt(huge(0_int64))', & ' end program demo_popcnt', & '', & ' Results:', & '', & ' Note that on most machines the first bit is the sign bit, and a zero is used', & ' for positive values; but that this is system-dependent. These are typical', & ' values, where the huge(3f) function has set all but the first bit to 1.', & '', & ' > 1111111 7', & ' > 1010 2', & ' > 1111111 7', & ' > 111111111111111 15', & ' > 1111111111111111111111111111111 31', & ' > 111111111111111111111111111111111111111111111111111111111111111 63', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' There are many procedures that operator or query values at the bit level:', & '', & ' POPPAR(3), LEADZ(3), TRAILZ(3) ATOMIC_AND(3), ATOMIC_FETCH_AND(3),', & ' ATOMIC_FETCH_OR(3), ATOMIC_FETCH_XOR(3), ATOMIC_OR(3), ATOMIC_XOR(3),', & ' BGE(3), BGT(3), BIT_SIZE(3), BLE(3), BLT(3), BTEST(3), DSHIFTL(3),', & ' DSHIFTR(3), IALL(3), IAND(3), IANY(3), IBCLR(3), IBITS(3), IBSET(3),', & ' IEOR(3), IOR(3), IPARITY(3), ISHFTC(3), ISHFT(3), MASKL(3), MASKR(3),', & ' MERGE_BITS(3), MVBITS(3), NOT(3), SHIFTA(3), SHIFTL(3), SHIFTR(3),', & ' STORAGE_SIZE(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 popcnt(3fortran)', & ''] shortname="popcnt" call process() case('158','poppar') textblock=[character(len=256) :: & '', & 'poppar(3fortran) poppar(3fortran)', & '', & '', & '', & 'NAME', & ' POPPAR(3) - [BIT:COUNT] Parity of the number of bits set', & '', & '', & 'SYNOPSIS', & ' result = poppar(i)', & '', & ' elemental integer function poppar(i)', & '', & ' integer(kind=KIND), intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o I is an integer of any kind', & '', & ' o the return value is a default kind integer', & '', & 'DESCRIPTION', & ' POPPAR(3) returns the parity of an integer''s binary representation (i.e.,', & ' the parity of the number of bits set).', & '', & ' The parity is expressed as', & '', & ' o 0 (zero) if I has an even number of bits set to 1.', & '', & ' o 1 (one) if the number of bits set to one 1 is odd,', & '', & 'OPTIONS', & ' o I : The value to query for its bit parity', & '', & 'RESULT', & ' The return value is equal to 0 if I has an even number of bits set and 1 if', & ' an odd number of bits are set.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_poppar', & ' use, intrinsic :: iso_fortran_env, only : integer_kinds, &', & ' & int8, int16, int32, int64', & ' implicit none', & ' character(len=*),parameter :: pretty=''(b64,1x,i0)''', & ' ! basic usage', & ' print pretty, 127, poppar(127)', & ' print pretty, 128, poppar(128)', & ' print pretty, int(b"01010"), poppar(int(b"01010"))', & '', & ' ! any kind of an integer can be used', & ' print pretty, huge(0_int8), poppar(huge(0_int8))', & ' print pretty, huge(0_int16), poppar(huge(0_int16))', & ' print pretty, huge(0_int32), poppar(huge(0_int32))', & ' print pretty, huge(0_int64), poppar(huge(0_int64))', & ' end program demo_poppar', & '', & ' Results:', & '', & ' > 1111111 1', & ' > 10000000 1', & ' > 1010 0', & ' > 1111111111111111111111111111111 1', & ' > 1111111 1', & ' > 111111111111111 1', & ' > 1111111111111111111111111111111 1', & ' > 111111111111111111111111111111111111111111111111111111111111111 1', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' There are many procedures that operator or query values at the bit level:', & '', & ' POPCNT(3), LEADZ(3), TRAILZ(3) ATOMIC_AND(3), ATOMIC_FETCH_AND(3),', & ' ATOMIC_FETCH_OR(3), ATOMIC_FETCH_XOR(3), ATOMIC_OR(3), ATOMIC_XOR(3),', & ' BGE(3), BGT(3), BIT_SIZE(3), BLE(3), BLT(3), BTEST(3), DSHIFTL(3),', & ' DSHIFTR(3), IALL(3), IAND(3), IANY(3), IBCLR(3), IBITS(3), IBSET(3),', & ' IEOR(3), IOR(3), IPARITY(3), ISHFTC(3), ISHFT(3), MASKL(3), MASKR(3),', & ' MERGE_BITS(3), MVBITS(3), NOT(3), SHIFTA(3), SHIFTL(3), SHIFTR(3),', & ' STORAGE_SIZE(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 poppar(3fortran)', & ''] shortname="poppar" call process() case('159','precision') textblock=[character(len=256) :: & '', & 'precision(3fortran) precision(3fortran)', & '', & '', & '', & 'NAME', & ' PRECISION(3) - [NUMERIC MODEL] Decimal precision of a real kind', & '', & '', & 'SYNOPSIS', & ' result = precision(x)', & '', & ' integer function precision(x)', & '', & ' TYPE(kind=**),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X shall be of type real or complex. It may be a scalar or an array.', & '', & ' o the result is a default integer scalar.', & '', & 'DESCRIPTION', & ' PRECISION(3) returns the decimal precision in the model of the type of X.', & '', & 'OPTIONS', & ' o X : the type and kind of the argument are used to determine which number', & ' model to query. The value of the argument is not unused; it may even be', & ' undefined.', & '', & 'RESULT', & ' The precision of values of the type and kind of X', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_precision', & ' use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32', & ' implicit none', & ' real(kind=sp) :: x(2)', & ' complex(kind=dp) :: y', & '', & ' print *, precision(x), range(x)', & ' print *, precision(y), range(y)', & '', & ' end program demo_precision', & '', & ' Results:', & '', & ' > 6 37', & ' > 15 307', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), RADIX(3), RANGE(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 precision(3fortran)', & ''] shortname="precision" call process() case('160','present') textblock=[character(len=256) :: & '', & 'present(3fortran) present(3fortran)', & '', & '', & '', & 'NAME', & ' PRESENT(3) - [STATE:INQUIRY] Determine whether an optional dummy argument is', & ' specified', & '', & '', & 'SYNOPSIS', & ' result = present(a)', & '', & ' logical function present (a)', & '', & ' type(TYPE(kind=KIND)) :: a(..)', & '', & '', & 'CHARACTERISTICS', & ' o A May be of any type and may be a pointer, scalar or array value, or a', & ' dummy procedure.', & '', & 'DESCRIPTION', & ' PRESENT(3) can be used in a procedure to determine if an optional dummy', & ' argument was present on the current call to the procedure.', & '', & ' A shall be the name of an optional dummy argument that is accessible in the', & ' subprogram in which the PRESENT(3) function reference appears. There are no', & ' other requirements on A.', & '', & ' Note when an argument is not present when the current procedure is invoked,', & ' you may only pass it as an optional argument to another procedure or pass it', & ' as an argument to PRESENT.', & '', & 'OPTIONS', & ' o A : the name of an optional dummy argument accessible within the current', & ' subroutine or function.', & '', & 'RESULT', & ' Returns .true. if the optional argument A is present (was passed on the call', & ' to the procedure) , or .false. otherwise.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_present', & ' implicit none', & ' integer :: answer', & ' ! argument to func() is not present', & ' answer=func()', & ' write(*,*) answer', & ' ! argument to func() is present', & ' answer=func(1492)', & ' write(*,*) answer', & ' contains', & ' !', & ' integer function func(x)', & ' ! the optional characteristic on this definition allows this variable', & ' ! to not be specified on a call; and also allows it to subsequently', & ' ! be passed to PRESENT(3):', & ' integer, intent(in), optional :: x', & ' integer :: x_local', & ' !', & ' ! basic', & ' if(present(x))then', & ' ! if present, you can use x like any other variable.', & ' x_local=x', & ' else', & ' ! if not, you cannot define or reference x except to', & ' ! pass it as an optional parameter to another procedure', & ' ! or in a call to present(3f)', & ' x_local=0', & ' endif', & ' !', & ' func=x_local**2', & ' !', & ' ! passing the argument on to other procedures', & ' ! so something like this is a bad idea because x is used', & ' ! as the first argument to merge(3f) when it might not be', & ' ! present', & ' ! xlocal=merge(x,0,present(x)) ! NO!!', & ' !', & ' ! We can pass it to another procedure if another', & ' ! procedure declares the argument as optional as well,', & ' ! or we have tested that X is present', & ' call tattle(''optional argument x'',x)', & ' if(present(x))call not_optional(x)', & ' end function', & ' !', & ' subroutine tattle(label,arg)', & ' character(len=*),intent(in) :: label', & ' integer,intent(in),optional :: arg', & ' if(present(arg))then', & ' write(*,*)label,'' is present''', & ' else', & ' write(*,*)label,'' is not present''', & ' endif', & ' end subroutine tattle', & ' !', & ' subroutine not_optional(arg)', & ' integer,intent(in) :: arg', & ' write(*,*)''already tested X is defined'',arg', & ' end subroutine not_optional', & ' !', & ' end program demo_present', & '', & ' Results:', & '', & ' optional argument x is not present', & ' 0', & ' optional argument x is present', & ' already tested X is defined 1492', & ' 2226064', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 present(3fortran)', & ''] shortname="present" call process() case('161','product') textblock=[character(len=256) :: & '', & 'product(3fortran) product(3fortran)', & '', & '', & '', & 'NAME', & ' PRODUCT(3) - [ARRAY:REDUCTION] Product of array elements', & '', & '', & 'SYNOPSIS', & ' result = product(array [,dim] [,mask])', & '', & ' NUMERIC function product(array, dim, mask)', & '', & ' NUMERIC,intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o NUMERIC is any numeric type and kind.', & '', & 'DESCRIPTION', & ' PRODUCT(3) multiplies together all the selected elements of ARRAY, or along', & ' dimension DIM if the corresponding element in MASK is .true..', & '', & ' If DIM is absent, a scalar with the product of all elements in ARRAY is', & ' returned. (Note a zero-sized ARRAY returns 1).', & '', & ' When DIM is present, If the masked array has a dimension of one (ie. is a', & ' vector) the result is a scalar. Otherwise, an array of rank N-1, where N', & ' equals the rank of ARRAY, and a shape similar to that of ARRAY with', & ' dimension DIM dropped is returned.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an array of type integer, real or complex.', & '', & ' o DIM : shall be a scalar of type integer with a value in the range from 1', & ' TO N, where N equals the rank of ARRAY.', & '', & ' o MASK : shall be of type logical and either be a scalar or an array of the', & ' same shape as ARRAY.', & '', & 'RESULT', & ' The result is of the same type as ARRAY.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_product', & ' implicit none', & ' character(len=*),parameter :: all=''(*(g0,1x))'' ! a handy format', & ' character(len=1),parameter :: nl=new_line(''a'')', & '', & ' NO_DIM: block', & ' ! If DIM is not specified, the result is the product of all the', & ' ! selected array elements.', & ' integer :: i,n, p1, p2', & ' integer,allocatable :: array(:)', & ' ! all elements are selected by default', & ' do n=1,10', & ' print all, ''factorial of '',n,'' is '', product([(real(i),i=1,n)])', & ' enddo', & '', & ' ! using a mask', & ' array=[10,12,13,15,20,25,30]', & ' p1=product(array, mask=mod(array, 2)==1) ! only odd elements', & ' p2=product(array, mask=mod(array, 2)/=1) ! only even elements', & ' print all, nl,''product of all elements'',product(array) ! all elements', & ' print all, '' odd * even ='',nl,p1,''*'',p2,''='',p1*p2', & '', & ' ! NOTE: If ARRAY is a zero-sized array, the result is equal to one', & ' print all', & ' print all, ''zero-sized array=>'',product([integer :: ])', & ' ! NOTE: If nothing in the mask is true, this also results in a null', & ' ! array', & ' print all, ''all elements have a false mask=>'', &', & ' & product(array,mask=.false.)', & '', & ' endblock NO_DIM', & '', & ' WITH_DIM: block', & ' integer :: rect(2,3)', & ' integer :: box(2,3,4)', & '', & ' ! lets fill a few arrays', & ' rect = reshape([ &', & ' 1, 2, 3, &', & ' 4, 5, 6 &', & ' ],shape(rect),order=[2,1])', & ' call print_matrix_int(''rect'',rect)', & '', & ' ! Find the product of each column in RECT.', & ' print all, ''product of columns='',product(rect, dim = 1)', & '', & ' ! Find the product of each row in RECT.', & ' print all, ''product of rows='',product(rect, dim = 2)', & '', & ' ! now lets try a box', & ' box(:,:,1)=rect', & ' box(:,:,2)=rect*(+10)', & ' box(:,:,3)=rect*(-10)', & ' box(:,:,4)=rect*2', & ' ! lets look at the values', & ' call print_matrix_int(''box 1'',box(:,:,1))', & ' call print_matrix_int(''box 2'',box(:,:,2))', & ' call print_matrix_int(''box 3'',box(:,:,3))', & ' call print_matrix_int(''box 4'',box(:,:,4))', & '', & ' ! remember without dim= even a box produces a scalar', & ' print all, ''no dim gives a scalar'',product(real(box))', & '', & ' ! only one plane has negative values, so note all the "1" values', & ' ! for vectors with no elements', & ' call print_matrix_int(''negative values'', &', & ' & product(box,mask=box < 0,dim=1))', & '', & ' ! If DIM is specified and ARRAY has rank greater than one, the', & ' ! result is a new array in which dimension DIM has been eliminated.', & '', & ' ! pick a dimension to multiply though', & ' call print_matrix_int(''dim=1'',product(box,dim=1))', & '', & ' call print_matrix_int(''dim=2'',product(box,dim=2))', & '', & ' call print_matrix_int(''dim=3'',product(box,dim=3))', & '', & ' endblock WITH_DIM', & '', & ' contains', & '', & ' subroutine print_matrix_int(title,arr)', & ' implicit none', & '', & ' !@(#) print small 2d integer arrays in row-column format', & '', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: arr(:,:)', & ' integer :: i', & ' character(len=:),allocatable :: biggest', & '', & ' print all', & ' print all, trim(title),'':('',shape(arr),'')'' ! print title', & ' biggest='' '' ! make buffer to write integer into', & ' ! find how many characters to use for integers', & ' write(biggest,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2', & ' ! use this format to write a row', & ' biggest=''(" > [",*(i''//trim(biggest)//'':,","))''', & ' ! print one row of array at a time', & ' do i=1,size(arr,dim=1)', & ' write(*,fmt=biggest,advance=''no'')arr(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & '', & ' end subroutine print_matrix_int', & '', & ' end program demo_product', & '', & ' Results:', & '', & ' factorial of 1 is 1.000000', & ' factorial of 2 is 2.000000', & ' factorial of 3 is 6.000000', & ' factorial of 4 is 24.00000', & ' factorial of 5 is 120.0000', & ' factorial of 6 is 720.0000', & ' factorial of 7 is 5040.000', & ' factorial of 8 is 40320.00', & ' factorial of 9 is 362880.0', & ' factorial of 10 is 3628800.', & '', & ' product of all elements 351000000', & ' odd * even =', & ' 4875 * 72000 = 351000000', & '', & ' zero-sized array=> 1', & ' all elements have a false mask=> 1', & '', & ' rect :( 2 3 )', & ' > [ 1, 2, 3 ]', & ' > [ 4, 5, 6 ]', & ' product of columns= 4 10 18', & ' product of rows= 6 120', & '', & ' box 1 :( 2 3 )', & ' > [ 1, 2, 3 ]', & ' > [ 4, 5, 6 ]', & '', & ' box 2 :( 2 3 )', & ' > [ 10, 20, 30 ]', & ' > [ 40, 50, 60 ]', & '', & ' box 3 :( 2 3 )', & ' > [ -10, -20, -30 ]', & ' > [ -40, -50, -60 ]', & '', & ' box 4 :( 2 3 )', & ' > [ 2, 4, 6 ]', & ' > [ 8, 10, 12 ]', & ' no dim gives a scalar .1719927E+26', & '', & ' negative values :( 3 4 )', & ' > [ 1, 1, 400, 1 ]', & ' > [ 1, 1, 1000, 1 ]', & ' > [ 1, 1, 1800, 1 ]', & '', & ' dim=1 :( 3 4 )', & ' > [ 4, 400, 400, 16 ]', & ' > [ 10, 1000, 1000, 40 ]', & ' > [ 18, 1800, 1800, 72 ]', & '', & ' dim=2 :( 2 4 )', & ' > [ 6, 6000, -6000, 48 ]', & ' > [ 120, 120000, -120000, 960 ]', & '', & ' dim=3 :( 2 3 )', & ' > [ -200, -3200, -16200 ]', & ' > [ -51200, -125000, -259200 ]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' SUM(3), note that an element by element multiplication is done directly', & ' using the star character.', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 product(3fortran)', & ''] shortname="product" call process() case('162','radix') textblock=[character(len=256) :: & '', & 'radix(3fortran) radix(3fortran)', & '', & '', & '', & 'NAME', & ' RADIX(3) - [NUMERIC MODEL] Base of a numeric model', & '', & '', & 'SYNOPSIS', & ' result = radix(x)', & '', & ' integer function radix(x)', & '', & ' TYPE(kind=**),intent(in) :: x(..)', & '', & '', & 'CHARACTERISTICS', & ' o X may be scalar or an array of any real or integer type.', & '', & ' o the result is a default integer scalar.', & '', & 'DESCRIPTION', & ' RADIX(3) returns the base of the internal model representing the numeric', & ' entity X.', & '', & ' In a positional numeral system, the radix or base is the number of unique', & ' digits, including the digit zero, used to represent numbers.', & '', & ' This function helps to represent the internal computing model generically,', & ' but will be 2 (representing a binary machine) for any common platform for', & ' all the numeric types.', & '', & 'OPTIONS', & ' o X : used to identify the type of number to query.', & '', & 'RESULT', & ' The returned value indicates what base is internally used to represent the', & ' type of numeric value X represents.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_radix', & ' implicit none', & ' print *, "The radix for the default integer kind is", radix(0)', & ' print *, "The radix for the default real kind is", radix(0.0)', & ' print *, "The radix for the doubleprecision real kind is", radix(0.0d0)', & ' end program demo_radix', & '', & ' Results:', & '', & ' > The radix for the default integer kind is 2', & ' > The radix for the default real kind is 2', & ' > The radix for the doubleprecision real kind is 2', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RANGE(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 radix(3fortran)', & ''] shortname="radix" call process() case('163','random_init') textblock=[character(len=256) :: & '', & 'random_init(3fortran) random_init(3fortran)', & '', & '', & '', & 'NAME', & ' RANDOM_INIT(3) - [MATHEMATICS:RANDOM] Initializes the state of the', & ' pseudorandom number generator', & '', & '', & 'SYNOPSIS', & ' call random_init(repeatable, image_distinct)', & '', & ' logical,intent(in) :: repeatable', & ' logical,intent(in) :: image_distinct', & '', & '', & 'CHARACTERISTICS', & ' o HARVEST and IMAGE_DISTINCT are logical scalars', & '', & ' Description', & '', & ' Initializes the state of the pseudorandom number generator used by', & ' RANDOM_NUMBER.', & '', & 'OPTIONS', & ' REPEATABLE : If it is .TRUE., the seed is set to a processor-dependent value', & ' that is the same each time RANDOM_INIT is called from the same image. The', & ' term "same image" means a single instance of program execution. The sequence', & ' of random numbers is different for repeated execution of the program.', & '', & ' If it is .FALSE., the seed is set to a processor-dependent value.', & '', & ' IMAGE_DISTINCT : If is .true., the seed is set to a processor-dependent', & ' value that is distinct from the seed set by a call to RANDOM_INITin another', & ' image. If it is .FALSE., the seed is set value that does depend which image', & ' called RANDOM_INIT.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_random_init', & ' implicit none', & ' real x(3), y(3)', & ' call random_init(.true., .true.)', & ' call random_number(x)', & ' call random_init(.true., .true.)', & ' call random_number(y)', & ' ! x and y should be the same sequence', & ' if ( any(x /= y) ) stop "x(:) and y(:) are not all equal"', & ' end program demo_random_init', & '', & '', & '', & 'STANDARD', & ' Fortran 2018', & '', & 'SEE ALSO', & ' random_number, random_seed', & '', & ' _fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 random_init(3fortran)', & ''] shortname="random_init" call process() case('164','random_number') textblock=[character(len=256) :: & '', & 'random_number(3fortran) random_number(3fortran)', & '', & '', & '', & 'NAME', & ' RANDOM_NUMBER(3) - [MATHEMATICS:RANDOM] Pseudo-random number', & '', & '', & 'SYNOPSIS', & ' call random_number(harvest)', & '', & ' subroutine random_number(harvest)', & '', & ' real,intent(out) :: harvest(..)', & '', & '', & 'CHARACTERISTICS', & ' o HARVEST and the result are default real variables', & '', & 'DESCRIPTION', & ' RANDOM_NUMBER(3) returns a single pseudorandom number or an array of', & ' pseudorandom numbers from the uniform distribution over the range 0 <= x <', & ' 1.', & '', & 'OPTIONS', & ' o HARVEST : Shall be a scalar or an array of type real.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_random_number', & ' use, intrinsic :: iso_fortran_env, only : dp=>real64', & ' implicit none', & ' integer, allocatable :: seed(:)', & ' integer :: n', & ' integer :: first,last', & ' integer :: i', & ' integer :: rand_int', & ' integer,allocatable :: count(:)', & ' real(kind=dp) :: rand_val', & ' call random_seed(size = n)', & ' allocate(seed(n))', & ' call random_seed(get=seed)', & ' first=1', & ' last=10', & ' allocate(count(last-first+1))', & ' ! To have a discrete uniform distribution on the integers', & ' ! [first, first+1, ..., last-1, last] carve the continuous', & ' ! distribution up into last+1-first equal sized chunks,', & ' ! mapping each chunk to an integer.', & ' !', & ' ! One way is:', & ' ! call random_number(rand_val)', & ' ! choose one from last-first+1 integers', & ' ! rand_int = first + FLOOR((last+1-first)*rand_val)', & ' count=0', & ' ! generate a lot of random integers from 1 to 10 and count them.', & ' ! with a large number of values you should get about the same', & ' ! number of each value', & ' do i=1,100000000', & ' call random_number(rand_val)', & ' rand_int=first+floor((last+1-first)*rand_val)', & ' if(rand_int.ge.first.and.rand_int.le.last)then', & ' count(rand_int)=count(rand_int)+1', & ' else', & ' write(*,*)rand_int,'' is out of range''', & ' endif', & ' enddo', & ' write(*,''(i0,1x,i0)'')(i,count(i),i=1,size(count))', & ' end program demo_random_number', & '', & ' Results:', & '', & ' 1 10003588 2 10000104 3 10000169 4 9997996 5 9995349 6 10001304 7 10001909', & ' 8 9999133 9 10000252 10 10000196', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' RANDOM_SEED(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 random_number(3fortran)', & ''] shortname="random_number" call process() case('165','random_seed') textblock=[character(len=256) :: & '', & 'random_seed(3fortran) random_seed(3fortran)', & '', & '', & '', & 'NAME', & ' RANDOM_SEED(3) - [MATHEMATICS:RANDOM] Initialize a pseudo-random number', & ' sequence', & '', & '', & 'SYNOPSIS', & ' call random_seed( [size] [,put] [,get] )', & '', & ' subroutine random_seed( size, put, get )', & '', & ' integer,intent(out),optional :: size', & ' integer,intent(in),optional :: put(*)', & ' integer,intent(out),optional :: get(*)', & '', & '', & 'CHARACTERISTICS', & ' o SIZE a scalar default integer', & '', & ' o PUT a rank-one default integer array', & '', & ' o GET a rank-one default integer array', & '', & ' o the result', & '', & 'DESCRIPTION', & ' RANDOM_SEED(3) restarts or queries the state of the pseudorandom number', & ' generator used by random_number.', & '', & ' If random_seed is called without arguments, it is seeded with random data', & ' retrieved from the operating system.', & '', & 'OPTIONS', & ' o SIZE : specifies the minimum size of the arrays used with the PUT and GET', & ' arguments.', & '', & ' o PUT : the size of the array must be larger than or equal to the number', & ' returned by the SIZE argument.', & '', & ' o GET : It is INTENT(OUT) and the size of the array must be larger than or', & ' equal to the number returned by the SIZE argument.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_random_seed', & ' implicit none', & ' integer, allocatable :: seed(:)', & ' integer :: n', & '', & ' call random_seed(size = n)', & ' allocate(seed(n))', & ' call random_seed(get=seed)', & ' write (*, *) seed', & '', & ' end program demo_random_seed', & '', & ' Results:', & '', & ' -674862499 -1750483360 -183136071 -317862567 682500039', & ' 349459 344020729 -1725483289', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' RANDOM_NUMBER(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 random_seed(3fortran)', & ''] shortname="random_seed" call process() case('166','range') textblock=[character(len=256) :: & '', & 'range(3fortran) range(3fortran)', & '', & '', & '', & 'NAME', & ' RANGE(3) - [NUMERIC MODEL] Decimal exponent range of a numeric kind', & '', & '', & 'SYNOPSIS', & ' result = range(x)', & '', & ' integer function range (x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be of type integer, real, or complex. It may be a scalar or an', & ' array.', & '', & ' o KIND is any kind supported by the type of X', & '', & ' o the result is a default integer scalar', & '', & 'DESCRIPTION', & ' RANGE(3) returns the decimal exponent range in the model of the type of X.', & '', & ' Since X is only used to determine the type and kind being interrogated, the', & ' value need not be defined.', & '', & 'OPTIONS', & ' o X : the value whose type and kind are used for the query', & '', & 'RESULT', & ' Case (i) : For an integer argument, the result has the value', & '', & ' int (log10 (huge(x)))', & '', & ' Case (ii) : For a real argument, the result has the value', & '', & ' int(min (log10 (huge(x)), -log10(tiny(x) )))', & '', & ' Case (iii) : For a complex argument, the result has the value', & '', & ' range(real(x))', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_range', & ' use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32', & ' implicit none', & ' real(kind=sp) :: x(2)', & ' complex(kind=dp) :: y', & ' print *, precision(x), range(x)', & ' print *, precision(y), range(y)', & ' end program demo_range', & '', & ' Results:', & '', & ' > 6 37', & ' > 15 307', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RRSPACING(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 range(3fortran)', & ''] shortname="range" call process() case('167','rank') textblock=[character(len=256) :: & '', & 'rank(3fortran) rank(3fortran)', & '', & '', & '', & 'NAME', & ' RANK(3) - [ARRAY:INQUIRY] Rank of a data object', & '', & '', & 'SYNOPSIS', & ' result = rank(a)', & '', & ' integer function rank(a)', & '', & ' type(TYPE(kind=**)),intent(in) :: a(..)', & '', & '', & 'CHARACTERISTICS', & ' o A can be of any type TYPE and rank.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' RANK(3) returns the rank of a scalar or array data object.', & '', & ' The rank of an array is the number of dimensions it has (zero for a scalar).', & '', & 'OPTIONS', & ' o A is the data object to query the dimensionality of. The rank returned', & ' may be from 0 to 16.', & '', & ' The argument A may be any data object type, including an assumed-rank', & ' array.', & '', & 'RESULT', & ' For arrays, their rank is returned; for scalars zero is returned.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_rank', & ' implicit none', & '', & ' ! a bunch of data objects to query', & ' integer :: a', & ' real, allocatable :: b(:,:)', & ' real, pointer :: c(:)', & ' complex :: d', & '', & ' ! make up a type', & ' type mytype', & ' integer :: int', & ' real :: float', & ' character :: char', & ' end type mytype', & ' type(mytype) :: any_thing(1,2,3,4,5)', & '', & ' ! basics', & ' print *, ''rank of scalar a='',rank(a)', & ' ! you can query this array even though it is not allocated', & ' print *, ''rank of matrix b='',rank(b)', & ' print *, ''rank of vector pointer c='',rank(c)', & ' print *, ''rank of complex scalar d='',rank(d)', & '', & ' ! you can query any type, not just intrinsics', & ' print *, ''rank of any arbitrary type='',rank(any_thing)', & '', & ' ! an assumed-rank object may be queried', & ' call query_int(10)', & ' call query_int([20,30])', & ' call query_int( reshape([40,50,60,70],[2,2]) )', & '', & ' ! you can even query an unlimited polymorphic entity', & ' call query_anything(10.0)', & ' call query_anything([.true.,.false.])', & ' call query_anything( reshape([40.0,50.0,60.0,70.0],[2,2]) )', & '', & ' contains', & '', & ' subroutine query_int(data_object)', & ' ! It is hard to do much with something dimensioned', & ' ! name(..) if not calling C except inside of a', & ' ! SELECT_RANK construct but one thing you can', & ' ! do is call the inquiry functions ...', & ' integer,intent(in) :: data_object(..)', & ' character(len=*),parameter :: all=''(*(g0,1x))''', & '', & ' if(rank(data_object).eq.0)then', & ' print all,&', & ' & ''passed a scalar to an assumed rank, &', & ' & rank='',rank(data_object)', & ' else', & ' print all,&', & ' & ''passed an array to an assumed rank, &', & ' & rank='',rank(data_object)', & ' endif', & '', & ' end subroutine query_int', & '', & ' subroutine query_anything(data_object)', & ' class(*),intent(in) ::data_object(..)', & ' character(len=*),parameter :: all=''(*(g0,1x))''', & ' if(rank(data_object).eq.0)then', & ' print all,&', & ' &''passed a scalar to an unlimited polymorphic rank='', &', & ' & rank(data_object)', & ' else', & ' print all,&', & ' & ''passed an array to an unlimited polymorphic, rank='', &', & ' & rank(data_object)', & ' endif', & ' end subroutine query_anything', & '', & ' end program demo_rank', & '', & ' Results:', & '', & ' rank of scalar a= 0', & ' rank of matrix b= 2', & ' rank of vector pointer c= 1', & ' rank of complex scalar d= 0', & ' rank of any arbitrary type= 5', & '', & ' passed a scalar to an assumed rank,', & ' rank= 0', & '', & ' passed an array to an assumed rank,', & ' rank= 1', & '', & ' passed an array to an assumed rank,', & ' rank= 2 passed a scalar to an unlimited polymorphic rank= 0 passed an', & ' array to an unlimited polymorphic, rank= 1 passed an array to an', & ' unlimited polymorphic, rank= 2', & '', & 'STANDARD', & 'SEE ALSO', & ' Array inquiry:', & '', & ' o SIZE(3) - Determine the size of an array', & '', & ' o RANK(3) - Rank of a data object', & '', & ' o SHAPE(3) - Determine the shape of an array', & '', & ' o UBOUND(3) - Upper dimension bounds of an array', & '', & ' o LBOUND(3) - Lower dimension bounds of an array', & '', & ' State Inquiry:', & '', & ' o ALLOCATED(3) - Status of an allocatable entity', & '', & ' o IS_CONTIGUOUS(3) - Test if object is contiguous', & '', & ' Kind Inquiry:', & '', & ' o KIND(3) - Kind of an entity', & '', & ' Bit Inquiry:', & '', & ' o STORAGE_SIZE(3) - Storage size in bits', & '', & ' o BIT_SIZE(3) - Bit size inquiry function', & '', & ' o BTEST(3) - Tests a bit of an integer value.', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 rank(3fortran)', & ''] shortname="rank" call process() case('168','real') textblock=[character(len=256) :: & '', & 'real(3fortran) real(3fortran)', & '', & '', & '', & 'NAME', & ' REAL(3) - [TYPE:NUMERIC] Convert to real type', & '', & '', & 'SYNOPSIS', & ' result = real(x [,kind])', & '', & ' elemental real(kind=KIND) function real(x,KIND)', & '', & ' TYPE(kind=**),intent(in) :: x', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o the type of X may be integer, real, or complex; or a BOZ-literal-', & ' constant.', & '', & ' o KIND is a integer initialization expression (a constant expression)', & '', & ' o If KIND is present it defines the kind of the real result', & '', & ' o if KIND is not present', & '', & ' o when X is complex the result is a real of the same kind as X.', & '', & ' o when X is real or integer the result is a real of default kind', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' REAL(3) converts its argument X to a real type.', & '', & ' The real part of a complex value is returned. For complex values this is', & ' similar to the modern complex-part-designator %RE which also designates the', & ' real part of a complex value.', & '', & ' z=(3.0,4.0) ! if z is a complex value', & ' print *, z%re == real(z) ! these expressions are equivalent', & '', & '', & 'OPTIONS', & ' o X : An integer, real, or complex value to convert to real.', & '', & ' o KIND : When present the value of KIND defines the kind of the result.', & '', & 'RESULT', & ' 1. REAL(X) converts X to a default real type if X is an integer or real', & ' variable.', & '', & ' 2. REAL(X) converts a complex value to a real type with the magnitude of', & ' the real component of the input with kind type parameter the same as X.', & '', & ' 3. REAL(X, KIND) is converted to a real type with kind type parameter KIND', & ' if X is a complex, integer, or real variable.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_real', & ' use,intrinsic :: iso_fortran_env, only : dp=>real64', & ' implicit none', & ' complex :: zr = (1.0, 2.0)', & ' doubleprecision :: xd=huge(3.0d0)', & ' complex(kind=dp) :: zd=cmplx(4.0e0_dp,5.0e0_dp,kind=dp)', & '', & ' print *, real(zr), aimag(zr)', & ' print *, dble(zd), aimag(zd)', & '', & ' write(*,*)xd,real(xd,kind=kind(0.0d0)),dble(xd)', & ' end program demo_real', & '', & ' Results:', & '', & ' 1.00000000 2.00000000', & ' 4.0000000000000000 5.0000000000000000', & ' 1.7976931348623157E+308 1.7976931348623157E+308 1.7976931348623157E+308', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' o AIMAG(3) - Imaginary part of complex number', & '', & ' o CMPLX(3) - Complex conversion function', & '', & ' o CONJG(3) - Complex conjugate function', & '', & ' Fortran has strong support for complex values, including many intrinsics', & ' that take or produce complex values in addition to algebraic and logical', & ' expressions:', & '', & ' ABS(3), ACOSH(3), ACOS(3), ASINH(3), ASIN(3), ATAN2(3), ATANH(3), ATAN(3),', & ' COSH(3), COS(3), CO_SUM(3), DBLE(3), DOT_PRODUCT(3), EXP(3), INT(3),', & ' IS_CONTIGUOUS(3), KIND(3), LOG(3), MATMUL(3), PRECISION(3), PRODUCT(3),', & ' RANGE(3), RANK(3), SINH(3), SIN(3), SQRT(3), STORAGE_SIZE(3), SUM(3),', & ' TANH(3), TAN(3), UNPACK(3),', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 real(3fortran)', & ''] shortname="real" call process() case('169','reduce') textblock=[character(len=256) :: & '', & 'reduce(3fortran) reduce(3fortran)', & '', & '', & '', & 'NAME', & ' REDUCE(3) - [TRANSFORMATIONAL] General reduction of an array', & '', & '', & 'SYNOPSIS', & ' There are two forms to this function:', & '', & ' result = reduce(array, operation [,mask] [,identity] [,ordered] )', & '', & ' or', & '', & ' result = reduce (array, operation, dim &', & ' & [,mask] [,identity] [,ordered] )', & '', & ' type(TYPE(kind=KIND)) function reduce &', & ' & (array, operation, dim, mask, identity, ordered )', & '', & ' type(TYPE(kind=KIND)),intent(in) :: array', & ' pure function :: operation', & ' integer,intent(in),optional :: dim', & ' logical,optional :: mask', & ' type(TYPE),intent(in),optional :: identity', & ' logical,intent(in),optional :: ordered', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY is an array of any type', & '', & ' o OPERATION is a pure function with exactly two arguments', & '', & ' o each argument is scalar, non-allocatable, a nonpointer, nonpolymorphic', & ' and nonoptional with the same type and kind as array.', & '', & ' o if one argument has the asynchronous, target, or value attribute so', & ' shall the other.', & '', & ' o DIM is an integer scalar', & '', & ' o MASK is a logical conformable with ARRAY', & '', & ' o IDENTITY is a scalar with the same type and type parameters as ARRAY', & '', & ' o ORDERED is a logical scalar', & '', & ' o the result is of the same type and type parameters as ARRAY.', & '', & 'DESCRIPTION', & ' REDUCE(3) reduces a list of conditionally selected values from an array to a', & ' single value by iteratively applying a binary function.', & '', & ' Common in functional programming, a REDUCE function applies a binary', & ' operator (a pure function with two arguments) to all elements cumulatively.', & '', & ' REDUCE is a "higher-order" function; ie. it is a function that receives', & ' other functions as arguments.', & '', & ' The REDUCE function receives a binary operator (a function with two', & ' arguments, just like the basic arithmetic operators). It is first applied to', & ' two unused values in the list to generate an accumulator value which is', & ' subsequently used as the first argument to the function as the function is', & ' recursively applied to all the remaining selected values in the input array.', & '', & 'OPTIONS', & ' o ARRAY : An array of any type and allowed rank to select values from.', & '', & ' o OPERATION : shall be a pure function with exactly two arguments; each', & ' argument shall be a scalar, nonallocatable, nonpointer, nonpolymorphic,', & ' nonoptional dummy data object with the same type and type parameters as', & ' ARRAY. If one argument has the ASYNCHRONOUS, TARGET, or VALUE attribute,', & ' the other shall have that attribute. Its result shall be a nonpolymorphic', & ' scalar and have the same type and type parameters as ARRAY. OPERATION', & ' should implement a mathematically associative operation. It need not be', & ' commutative.', & '', & ' NOTE', & ' If OPERATION is not computationally associative, REDUCE without', & ' ORDERED=.TRUE. with the same argument values might not always produce the', & ' same result, as the processor can apply the associative law to the', & ' evaluation.', & '', & ' Many operations that mathematically are associative are not when applied to', & ' floating-point numbers. The order you sum values in may affect the result,', & ' for example.', & '', & ' o DIM : An integer scalar with a value in the range 1<= DIM <= n, where n', & ' is the rank of ARRAY.', & '', & ' o MASK : (optional) shall be of type logical and shall be conformable', & ' with ARRAY.', & '', & ' When present only those elements of ARRAY are passed to OPERATION for', & ' which the corresponding elements of MASK are true, as if *array was', & ' filtered with PACK(3).', & '', & ' o IDENTITY : shall be scalar with the same type and type parameters as', & ' ARRAY. If the initial sequence is empty, the result has the value', & ' IDENTIFY if IDENTIFY is present, and otherwise, error termination is', & ' initiated.', & '', & ' o ORDERED : shall be a logical scalar. If ORDERED is present with the', & ' value .true., the calls to the OPERATOR function begins with the first', & ' two elements of ARRAY and the process continues in row-column order', & ' until the sequence has only one element which is the value of the', & ' reduction. Otherwise, the compiler is free to assume that the', & ' operation is commutative and may evaluate the reduction in the most', & ' optimal way.', & '', & 'RESULT', & ' The result is of the same type and type parameters as ARRAY. It is scalar if', & ' DIM does not appear.', & '', & ' If DIM is present, it indicates the one dimension along which to perform the', & ' reduction, and the resultant array has a rank reduced by one relative to the', & ' input array.', & '', & 'EXAMPLES', & ' The following examples all use the function MY_MULT, which returns the', & ' product of its two real arguments.', & '', & ' program demo_reduce', & ' implicit none', & ' character(len=*),parameter :: f=''("[",*(g0,",",1x),"]")''', & ' integer,allocatable :: arr(:), b(:,:)', & '', & ' ! Basic usage:', & ' ! the product of the elements of an array', & ' arr=[1, 2, 3, 4 ]', & ' write(*,*) arr', & ' write(*,*) ''product='', reduce(arr, my_mult)', & ' write(*,*) ''sum='', reduce(arr, my_sum)', & '', & ' ! Examples of masking:', & ' ! the product of only the positive elements of an array', & ' arr=[1, -1, 2, -2, 3, -3 ]', & ' write(*,*)''positive value product='',reduce(arr, my_mult, mask=arr>0)', & ' ! sum values ignoring negative values', & ' write(*,*)''sum positive values='',reduce(arr, my_sum, mask=arr>0)', & '', & ' ! a single-valued array returns the single value as the', & ' ! calls to the operator stop when only one element remains', & ' arr=[ 1234 ]', & ' write(*,*)''single value sum'',reduce(arr, my_sum )', & ' write(*,*)''single value product'',reduce(arr, my_mult )', & '', & ' ! Example of operations along a dimension:', & ' ! If B is the array 1 3 5', & ' ! 2 4 6', & ' b=reshape([1,2,3,4,5,6],[2,3])', & ' write(*,f) REDUCE(B, MY_MULT),''should be [720]''', & ' write(*,f) REDUCE(B, MY_MULT, DIM=1),''should be [2,12,30]''', & ' write(*,f) REDUCE(B, MY_MULT, DIM=2),''should be [15, 48]''', & '', & ' contains', & '', & ' pure function my_mult(a,b) result(c)', & ' integer,intent(in) :: a, b', & ' integer :: c', & ' c=a*b', & ' end function my_mult', & '', & ' pure function my_sum(a,b) result(c)', & ' integer,intent(in) :: a, b', & ' integer :: c', & ' c=a+b', & ' end function my_sum', & '', & ' end program demo_reduce', & '', & ' Results:', & '', & ' > 1 2 3 4', & ' > product= 24', & ' > sum= 10', & ' > positive value sum= 6', & ' > sum positive values= 6', & ' > single value sum 1234', & ' > single value product 1234', & ' > [720, should be [720],', & ' > [2, 12, 30, should be [2,12,30],', & ' > [15, 48, should be [15, 48],', & '', & '', & 'STANDARD', & ' Fortran 2018', & '', & 'SEE ALSO', & ' o co_reduce(3)', & '', & 'RESOURCES', & ' o associative:wikipedia', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 reduce(3fortran)', & ''] shortname="reduce" call process() case('170','repeat') textblock=[character(len=256) :: & '', & 'repeat(3fortran) repeat(3fortran)', & '', & '', & '', & 'NAME', & ' REPEAT(3) - [CHARACTER] Repeated string concatenation', & '', & '', & 'SYNOPSIS', & ' result = repeat(string, ncopies)', & '', & ' character(len=len(string)*ncopies) function repeat(string, ncopies)', & '', & ' character(len=*),intent(in) :: string', & ' integer(kind=**),intent(in) :: ncopies', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o STRING is a scalar character type.', & '', & ' o NCOPIES is a scalar integer.', & '', & ' o the result is a new scalar of type character of the same kind as', & '', & ' STRING', & 'DESCRIPTION', & ' REPEAT(3) concatenates copies of a string.', & '', & 'OPTIONS', & ' o STRING : The input string to repeat', & '', & ' o NCOPIES : Number of copies to make of STRING, greater than or equal to', & ' zero (0).', & '', & 'RESULT', & ' A new string built up from NCOPIES copies of STRING.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_repeat', & ' implicit none', & ' write(*,''(a)'') repeat("^v", 35) ! line break', & ' write(*,''(a)'') repeat("_", 70) ! line break', & ' write(*,''(a)'') repeat("1234567890", 7) ! number line', & ' write(*,''(a)'') repeat(" |", 7) !', & ' end program demo_repeat', & '', & ' Results:', & '', & ' > ^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v', & ' > ______________________________________________________________________', & ' > 1234567890123456789012345678901234567890123456789012345678901234567890', & ' > | | | | | | |', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' Functions that perform operations on character strings:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NON-ELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 repeat(3fortran)', & ''] shortname="repeat" call process() case('171','reshape') textblock=[character(len=256) :: & '', & 'reshape(3fortran) reshape(3fortran)', & '', & '', & '', & ' reshape', & '', & 'NAME', & ' RESHAPE(3) - [ARRAY:RESHAPE] Function to reshape an array', & '', & '', & 'SYNOPSIS', & ' result = reshape( source, shape [,pad] [,order] )', & '', & ' type(TYPE(kind=KIND)) function reshape', & '', & ' type(TYPE(kind=KIND)),intent(in) :: source(..)', & ' integer(kind=**),intent(in) :: shape(:)', & ' type(TYPE(kind=KIND)),intent(in),optional :: pad(..)', & ' integer(kind=**),intent(in),optional :: order(:)', & '', & '', & 'CHARACTERISTICS', & ' o SOURCE is an array of any type', & '', & ' o SHAPE defines a Fortran shape and therefore an integer vector (of rank', & ' one) of constant size of up to 16 non-negative values.', & '', & ' o PAD is the same type as SOURCE', & '', & ' o ORDER is the same shape as SHAPE', & '', & ' o The result is an array of shape SHAPE with the same type as SOURCE.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' RESHAPE constructs an array of arbitrary shape SHAPE using the elements from', & ' SOURCE and possibly PAD to fill it.', & '', & ' If necessary, the new array may be padded with elements from PAD or permuted', & ' as defined by ORDER.', & '', & ' Among many other uses, RESHAPE can be used to reorder a Fortran array to', & ' match C array ordering before the array is passed from Fortran to a C', & ' procedure.', & '', & 'OPTIONS', & ' o SOURCE : an array containing the elements to be copied to the result.', & ' there must be enough elements in the source to fill the new shape if PAD', & ' is omitted or has size zero. Expressed in Fortran ...', & '', & ' if(.not.present(pad))then', & ' if(size(source) < product(shape))then', & ' stop ''not enough elements in the old array to fill the new one''', & ' endif', & ' endif', & '', & '', & ' o SHAPE : This is the shape of the new array being generated. Being by', & ' definition a shape; all elements are either positive integers or zero,', & ' the size but be 1 or greater, it may have up to 16 elements but must be', & ' of constant fixed size and rank one.', & '', & ' o PAD : used to fill in extra values if the result array is larger than', & ' SOURCE. It will be used repeatedly after all the elements of SOURCE have', & ' been placed in the result until the result has all elements assigned. :', & ' If it is absent or is a zero-sized array, you can only make SOURCE into', & ' another array of the same size as SOURCE or smaller.', & '', & ' o ORDER : used to insert elements in the result in an order other than the', & ' normal Fortran array element order, in which the first dimension varies', & ' fastest. : By definition of ranks the values have to be a permutation of', & ' the numbers from 1 to n, where n is the rank of SHAPE. : the elements of', & ' SOURCE and pad are placed into the result in order; changing the left-', & ' most rank most rapidly by default. To change the order by which the', & ' elements are placed in the result use ORDER.', & '', & 'RESULT', & ' The result is an array of shape SHAPE with the same type and type parameters', & ' as SOURCE. It is first filled with the values of elements of SOURCE, with', & ' the remainder filled with repeated copies of PAD until all elements are', & ' filled. The new array may be smaller than SOURCE.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_reshape', & ' implicit none', & ' ! notice the use of "shape(box)" on the RHS', & ' integer :: box(3,4)=reshape([1,2,3,4,5,6,7,8,9,10,11,12],shape(box))', & ' integer,allocatable :: v(:,:)', & ' integer :: rc(2)', & ' ! basics0', & ' ! what is the current shape of the array?', & ' call printi(''shape of box is '',box)', & ' ! change the shape', & ' call printi(''reshaped '',reshape(box,[2,6]))', & ' call printi(''reshaped '',reshape(box,[4,3]))', & '', & ' ! fill in row column order using order', & ' v=reshape([1,2,3,4,10,20,30,40,100,200,300,400],[1,12])', & ' call printi(''here is some data to shape'',v)', & ' call printi(''normally fills columns first '',reshape([v],[3,4]))', & ' call printi(''fill rows first'', reshape([v],[3,4],order=[2,1]))', & '', & ' ! if we take the data and put in back in filling', & ' ! rows first instead of columns, and flipping the', & ' ! height and width of the box we not only fill in', & ' ! a vector using row-column order we actually', & ' ! transpose it.', & ' rc(2:1:-1)=shape(box)', & ' ! copy the data in changing column number fastest', & ' v=reshape(box,rc,order=[2,1])', & ' call printi(''reshaped and reordered'',v)', & ' ! of course we could have just done a transpose', & ' call printi(''transposed'',transpose(box))', & '', & ' ! making the result bigger than source using pad', & ' v=reshape(box,rc*2,pad=[-1,-2,-3],order=[2,1])', & ' call printi(''bigger and padded and reordered'',v)', & ' contains', & '', & ' subroutine printi(title,arr)', & ' implicit none', & '', & ' !@(#) print small 2d integer arrays in row-column format', & '', & ' character(len=*),parameter :: all=''(*(g0,1x))'' ! a handy format', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: arr(:,:)', & ' integer :: i', & ' character(len=:),allocatable :: biggest', & '', & ' print all', & ' print all, trim(title),'':('',shape(arr),'')'' ! print title', & ' biggest='' '' ! make buffer to write integer into', & ' ! find how many characters to use for integers', & ' write(biggest,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2', & ' ! use this format to write a row', & ' biggest=''(" > [",*(i''//trim(biggest)//'':,","))''', & ' ! print one row of array at a time', & ' do i=1,size(arr,dim=1)', & ' write(*,fmt=biggest,advance=''no'')arr(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & '', & ' end subroutine printi', & '', & ' end program demo_reshape', & '', & ' Results:', & '', & ' shape of box is :( 3 4 )', & ' > [ 1, 4, 7, 10 ]', & ' > [ 2, 5, 8, 11 ]', & ' > [ 3, 6, 9, 12 ]', & '', & ' reshaped :( 2 6 )', & ' > [ 1, 3, 5, 7, 9, 11 ]', & ' > [ 2, 4, 6, 8, 10, 12 ]', & '', & ' reshaped :( 4 3 )', & ' > [ 1, 5, 9 ]', & ' > [ 2, 6, 10 ]', & ' > [ 3, 7, 11 ]', & ' > [ 4, 8, 12 ]', & '', & ' here is some data to shape :( 1 12 )', & ' > [ 1, 2, 3, 4, 10, 20, 30, 40, 100, 200, 300, 400 ]', & '', & ' normally fills columns first :( 3 4 )', & ' > [ 1, 4, 30, 200 ]', & ' > [ 2, 10, 40, 300 ]', & ' > [ 3, 20, 100, 400 ]', & '', & ' fill rows first :( 3 4 )', & ' > [ 1, 2, 3, 4 ]', & ' > [ 10, 20, 30, 40 ]', & ' > [ 100, 200, 300, 400 ]', & '', & ' reshaped and reordered :( 4 3 )', & ' > [ 1, 2, 3 ]', & ' > [ 4, 5, 6 ]', & ' > [ 7, 8, 9 ]', & ' > [ 10, 11, 12 ]', & '', & ' transposed :( 4 3 )', & ' > [ 1, 2, 3 ]', & ' > [ 4, 5, 6 ]', & ' > [ 7, 8, 9 ]', & ' > [ 10, 11, 12 ]', & '', & ' bigger and padded and reordered :( 8 6 )', & ' > [ 1, 2, 3, 4, 5, 6 ]', & ' > [ 7, 8, 9, 10, 11, 12 ]', & ' > [ -1, -2, -3, -1, -2, -3 ]', & ' > [ -1, -2, -3, -1, -2, -3 ]', & ' > [ -1, -2, -3, -1, -2, -3 ]', & ' > [ -1, -2, -3, -1, -2, -3 ]', & ' > [ -1, -2, -3, -1, -2, -3 ]', & ' > [ -1, -2, -3, -1, -2, -3 ]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' SHAPE(3), PACK(3), TRANSPOSE(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 reshape(3fortran)', & ''] shortname="reshape" call process() case('172','rrspacing') textblock=[character(len=256) :: & '', & 'rrspacing(3fortran) rrspacing(3fortran)', & '', & '', & '', & 'NAME', & ' RRSPACING(3) - [MODEL_COMPONENTS] Reciprocal of the relative spacing of a', & ' numeric type', & '', & '', & 'SYNOPSIS', & ' result = rrspacing(x)', & '', & ' elemental real(kind=KIND) function rrspacing(x)', & '', & ' real(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is type real an any kind', & '', & ' o The return value is of the same type and kind as X.', & '', & 'DESCRIPTION', & ' RRSPACING(3) returns the reciprocal of the relative spacing of model numbers', & ' near X.', & '', & 'OPTIONS', & ' o X : Shall be of type real.', & '', & 'RESULT', & ' The return value is of the same type and kind as X. The value returned is', & ' equal to ABS(FRACTION(X)) * FLOAT(RADIX(X))**DIGITS(X).', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), SCALE(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 rrspacing(3fortran)', & ''] shortname="rrspacing" call process() case('173','same_type_as') textblock=[character(len=256) :: & '', & 'same_type_as(3fortran) same_type_as(3fortran)', & '', & '', & '', & 'NAME', & ' SAME_TYPE_AS(3) - [STATE:INQUIRY] Query dynamic types for equality', & '', & '', & 'SYNOPSIS', & ' result = same_type_as(a, b)', & '', & ' logical same_type_as(a, b)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: a', & ' type(TYPE(kind=KIND)),intent(in) :: b', & '', & '', & 'CHARACTERISTICS', & ' o A shall be an object of extensible declared type or unlimited', & ' polymorphic. If it is a polymorphic pointer, it shall not have an', & ' undefined association status.', & '', & ' o B shall be an object of extensible declared type or unlimited', & ' polymorphic. If it is a polymorphic pointer, it shall not have an', & ' undefined association status.', & '', & 'DESCRIPTION', & ' SAME_TYPE_AS(3) queries the dynamic types of objects for equality.', & '', & 'OPTIONS', & ' o A : object to compare to B for equality of type', & '', & ' o B : object to be compared to for equality of type', & '', & 'RESULT', & ' If the dynamic type of A or B is extensible, the result is true if and only', & ' if the dynamic type of A is the same as the dynamic type of B. If neither A', & ' nor B has extensible dynamic type, the result is processor dependent.', & '', & ' NOTE1', & '', & ' The dynamic type of a disassociated pointer or unallocated allocatable', & ' variable is its declared type. An unlimited polymorphic entity has no', & ' declared type.', & '', & ' NOTE2', & '', & ' The test performed by SAME_TYPE_AS is not the same as the test performed by', & ' the type guard TYPE IS. The test performed by SAME_TYPE_AS does not consider', & ' kind type parameters.', & '', & ' Sample program:', & '', & ' ! program demo_same_type_as', & ' module M_ether', & ' implicit none', & ' private', & '', & ' type :: dot', & ' real :: x=0', & ' real :: y=0', & ' end type dot', & '', & ' type, extends(dot) :: point', & ' real :: z=0', & ' end type point', & '', & ' type something_else', & ' end type something_else', & '', & ' public :: dot', & ' public :: point', & ' public :: something_else', & '', & ' end module M_ether', & '', & ' program demo_same_type_as', & ' use M_ether, only : dot, point, something_else', & ' implicit none', & ' type(dot) :: dad, mom', & ' type(point) :: me', & ' type(something_else) :: alien', & '', & ' write(*,*)same_type_as(me,dad),''I am descended from Dad, but equal?''', & ' write(*,*)same_type_as(me,me) ,''I am what I am''', & ' write(*,*)same_type_as(dad,mom) ,''what a pair!''', & '', & ' write(*,*)same_type_as(dad,me),''no paradox here''', & ' write(*,*)same_type_as(dad,alien),''no relation''', & '', & ' call pointers()', & ' contains', & ' subroutine pointers()', & ' ! Given the declarations and assignments', & ' type t1', & ' real c', & ' end type', & ' type, extends(t1) :: t2', & ' end type', & ' class(t1), pointer :: p, q, r', & ' allocate (p, q)', & ' allocate (t2 :: r)', & ' ! the result of SAME_TYPE_AS (P, Q) will be true, and the result', & ' ! of SAME_TYPE_AS (P, R) will be false.', & ' write(*,*)''(P,Q)'',same_type_as(p,q),"mind your P''s and Q''s"', & ' write(*,*)''(P,R)'',same_type_as(p,r)', & ' end subroutine pointers', & '', & ' end program demo_same_type_as', & '', & ' Results:', & '', & ' F I am descended from Dad, but equal?', & ' T I am what I am', & ' T what a pair!', & ' F no paradox here', & ' F no relation', & ' (P,Q) T mind your P''s and Q''s', & ' (P,R) F', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' EXTENDS_TYPE_OF(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 same_type_as(3fortran)', & ''] shortname="same_type_as" call process() case('174','scale') textblock=[character(len=256) :: & '', & 'scale(3fortran) scale(3fortran)', & '', & '', & '', & 'NAME', & ' SCALE(3) - [MODEL_COMPONENTS] Scale a real value by a whole power of the', & ' radix', & '', & '', & 'SYNOPSIS', & ' result = scale(x, i)', & '', & ' elemental real(kind=KIND) function scale(x, i)', & '', & ' real(kind=KIND),intent(in) :: x', & ' integer(kind=**),intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o X is type real of any kind', & '', & ' o I is type an integer of any kind', & '', & ' o the result is real of the same kind as X', & '', & 'DESCRIPTION', & ' SCALE(3) returns x * RADIX(X)**I.', & '', & ' It is almost certain the radix(base) of the platform is two, therefore', & ' SCALE(3) is generally the same as X*2**I', & '', & 'OPTIONS', & ' o X : the value to multiply by RADIX(X)**I. Its type and kind is used to', & ' determine the radix for values with its characteristics and determines', & ' the characteristics of the result, so care must be taken the returned', & ' value is within the range of the characteristics of X.', & '', & ' o I : The power to raise the radix of the machine to', & '', & 'RESULT', & ' The return value is X * RADIX(X)**I, assuming that value can be represented', & ' by a value of the type and kind of X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_scale', & ' implicit none', & ' real :: x', & ' complex :: c', & ' integer :: i', & ' x = 1.0', & ' print *, (scale(x,i),i=1,5)', & ' x = 3.0', & ' print *, (scale(x,i),i=1,5)', & ' print *, (scale(log(1.0),i),i=1,5)', & ' ! on modern machines radix(x) is almost certainly 2', & ' x = 178.1387e-4', & ' i = 5', & ' print *, x, i, scale(x, i), x*radix(x)**i', & ' ! x*radix(x)**i is the same except roundoff errors are not restricted', & ' i = 2', & ' print *, x, i, scale(x, i), x*radix(x)**i', & ' ! relatively easy to do complex values as well', & ' c=(3.0,4.0)', & ' print *, c, i, scale_complex(c, i)!, c*radix(c)**i', & ' contains', & ' function scale_complex(x, n)', & ' ! example supporting complex value for default kinds', & ' complex, intent(in) :: x', & ' integer, intent(in) :: n', & ' complex :: scale_complex', & ' scale_complex=cmplx(scale(x%re, n), scale(x%im, n), kind=kind(x%im))', & ' end function scale_complex', & ' end program demo_scale', & '', & ' Results:', & '', & ' > 2.00000000 4.00000000 8.00000000 16.0000000 32.0000000', & ' > 6.00000000 12.0000000 24.0000000 48.0000000 96.0000000', & ' > 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000', & ' > 1.78138707E-02 5 0.570043862 0.570043862', & ' > 1.78138707E-02 2 7.12554827E-02 7.12554827E-02', & ' > (3.00000000,4.00000000) 2 (12.0000000,16.0000000)', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3),', & ' SET_EXPONENT(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 scale(3fortran)', & ''] shortname="scale" call process() case('175','scan') textblock=[character(len=256) :: & '', & 'scan(3fortran) scan(3fortran)', & '', & '', & '', & 'NAME', & ' SCAN(3) - [CHARACTER:SEARCH] Scan a string for the presence of a set of', & ' characters', & '', & '', & 'SYNOPSIS', & ' result = scan( string, set, [,back] [,kind] )', & '', & ' elemental integer(kind=KIND) function scan(string,set,back,kind)', & '', & ' character(len=*,kind=**),intent(in) :: string', & ' character(len=*,kind=**),intent(in) :: set', & ' logical,intent(in),optional :: back', & ' integer,intent(in),optional :: kind', & '', & '', & 'CHARACTERISTICS', & ' o STRING is a character string of any kind', & '', & ' o SET must be a character string with the same kind as STRING', & '', & ' o BACK is a logical', & '', & ' o KIND is a scalar integer constant expression', & '', & ' o the result is an integer with the kind specified by KIND. If KIND is not', & ' present the result is a default integer.', & '', & 'DESCRIPTION', & ' SCAN(3) scans a STRING for any of the characters in a SET of characters.', & '', & ' If BACK is either absent or equals .false., this function returns the', & ' position of the leftmost character of STRING that is in SET. If BACK equals', & ' .true., the rightmost position is returned. If no character of SET is found', & ' in STRING, the result is zero.', & '', & 'OPTIONS', & ' o STRING : the string to be scanned', & '', & ' o SET : the set of characters which will be matched', & '', & ' o BACK : if .true. the position of the rightmost character matched is', & ' returned, instead of the leftmost.', & '', & ' o KIND : the kind of the returned value is the same as KIND if present.', & ' Otherwise a default integer kind is returned.', & '', & 'RESULT', & ' If BACK is absent or is present with the value false and if STRING contains', & ' at least one character that is in SET, the value of the result is the', & ' position of the leftmost character of STRING that is in SET.', & '', & ' If BACK is present with the value true and if STRING contains at least one', & ' character that is in SET, the value of the result is the position of the', & ' rightmost character of STRING that is in SET.', & '', & ' The value of the result is zero if no character of STRING is in SET or if', & ' the length of STRING or SET is zero.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_scan', & ' implicit none', & ' write(*,*) scan("fortran", "ao") ! 2, found ''o''', & ' write(*,*) scan("fortran", "ao", .true.) ! 6, found ''a''', & ' write(*,*) scan("fortran", "c++") ! 0, found none', & ' end program demo_scan', & '', & ' Results:', & '', & ' > 2', & ' > 6', & ' > 0', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument - Fortran 2003', & '', & 'SEE ALSO', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 scan(3fortran)', & ''] shortname="scan" call process() case('176','selected_char_kind') textblock=[character(len=256) :: & '', & 'selected_char_kind(3fortran) selected_char_kind(3fortran)', & '', & '', & '', & 'NAME', & ' SELECTED_CHAR_KIND(3) - [KIND] Select character kind such as "Unicode"', & '', & '', & 'SYNOPSIS', & ' result = selected_char_kind(name)', & '', & ' integer function selected_char_kind(name)', & '', & ' character(len=*),intent(in) :: name', & '', & '', & 'CHARACTERISTICS', & ' o NAME is a default character scalar', & '', & ' o the result is a default integer scalar', & '', & 'DESCRIPTION', & ' SELECTED_CHAR_KIND(3) returns a kind parameter value for the character set', & ' named NAME.', & '', & ' If a name is not supported, -1 is returned. Otherwise the result is a value', & ' equal to that kind type parameter value.', & '', & ' The list of supported names is processor-dependent except for "DEFAULT".', & '', & ' o If NAME has the value "DEFAULT", then the result has a value equal to', & ' that of the kind type parameter of default character. This name is always', & ' supported.', & '', & ' o If NAME has the value "ASCII", then the result has a value equal to that', & ' of the kind type parameter of ASCII character.', & '', & ' o If NAME has the value "ISO_10646", then the result has a value equal to', & ' that of the kind type parameter of the ISO 10646 character kind', & ' (corresponding to UCS-4 as specified in ISO/IEC 10646).', & '', & ' o If NAME is a processor-defined name of some other character kind', & ' supported by the processor, then the result has a value equal to that', & ' kind type parameter value. Pre-defined names include "ASCII" and', & ' "ISO_10646".', & '', & ' The NAME is interpreted without respect to case or trailing blanks.', & '', & 'OPTIONS', & ' o NAME : A name to query the processor-dependent kind value of, and/or to', & ' determine if supported. NAME, interpreted without respect to case or', & ' trailing blanks.', & '', & ' Currently, supported character sets include "ASCII" and "DEFAULT" and', & ' "ISO_10646" (Universal Character Set, UCS-4) which is commonly known as', & ' "Unicode". Supported names other than "DEFAULT" are processor dependent.', & '', & 'RESULT', & 'EXAMPLES', & ' Sample program:', & '', & ' Linux', & ' program demo_selected_char_kind', & ' use iso_fortran_env', & ' implicit none', & '', & ' intrinsic date_and_time,selected_char_kind', & '', & ' ! set some aliases for common character kinds', & ' ! as the numbers can vary from platform to platform', & '', & ' integer, parameter :: default = selected_char_kind ("default")', & ' integer, parameter :: ascii = selected_char_kind ("ascii")', & ' integer, parameter :: ucs4 = selected_char_kind (''ISO_10646'')', & ' integer, parameter :: utf8 = selected_char_kind (''utf-8'')', & '', & ' ! assuming ASCII and UCS4 are supported (ie. not equal to -1)', & ' ! define some string variables', & ' character(len=26, kind=ascii ) :: alphabet', & ' character(len=30, kind=ucs4 ) :: hello_world', & ' character(len=30, kind=ucs4 ) :: string', & '', & ' write(*,*)''ASCII '',&', & ' & merge(''Supported '',''Not Supported'',ascii /= -1)', & ' write(*,*)''ISO_10646 '',&', & ' & merge(''Supported '',''Not Supported'',ucs4 /= -1)', & ' write(*,*)''UTF-8 '',&', & ' & merge(''Supported '',''Not Supported'',utf8 /= -1)', & '', & ' if(default.eq.ascii)then', & ' write(*,*)''ASCII is the default on this processor''', & ' endif', & '', & ' ! for constants the kind precedes the value, somewhat like a', & ' ! BOZ constant', & ' alphabet = ascii_"abcdefghijklmnopqrstuvwxyz"', & ' write (*,*) alphabet', & '', & ' hello_world = ucs4_''Hello World and Ni Hao -- '' &', & ' // char (int (z''4F60''), ucs4) &', & ' // char (int (z''597D''), ucs4)', & '', & ' ! an encoding option is required on OPEN for non-default I/O', & ' if(ucs4 /= -1 )then', & ' open (output_unit, encoding=''UTF-8'')', & ' write (*,*) trim (hello_world)', & ' else', & ' write (*,*) ''cannot use utf-8''', & ' endif', & '', & ' call create_date_string(string)', & ' write (*,*) trim (string)', & '', & ' contains', & '', & ' ! The following produces a Japanese date stamp.', & ' subroutine create_date_string(string)', & ' intrinsic date_and_time,selected_char_kind', & ' integer,parameter :: ucs4 = selected_char_kind("ISO_10646")', & ' character(len=1,kind=ucs4),parameter :: &', & ' nen = char(int( z''5e74'' ),ucs4), & ! year', & ' gatsu = char(int( z''6708'' ),ucs4), & ! month', & ' nichi = char(int( z''65e5'' ),ucs4) ! day', & ' character(len= *, kind= ucs4) string', & ' integer values(8)', & ' call date_and_time(values=values)', & ' write(string,101) values(1),nen,values(2),gatsu,values(3),nichi', & ' 101 format(*(i0,a))', & ' end subroutine create_date_string', & '', & ' end program demo_selected_char_kind', & '', & ' Results:', & '', & ' The results are very processor-dependent', & '', & ' > ASCII Supported', & ' > ISO_10646 Supported', & ' > UTF-8 Not Supported', & ' > ASCII is the default on this processor', & ' > abcdefghijklmnopqrstuvwxyz', & ' > Hello World and Ni Hao --', & ' > 20221015', & '', & '', & 'STANDARD', & ' Fortran 2003', & '', & 'SEE ALSO', & ' SELECTED_INT_KIND(3), SELECTED_REAL_KIND(3)', & '', & ' ACHAR(3), CHAR(3), ICHAR(3), IACHAR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 selected_char_kind(3fortran)', & ''] shortname="selected_char_kind" call process() case('177','selected_int_kind') textblock=[character(len=256) :: & '', & 'selected_int_kind(3fortran) selected_int_kind(3fortran)', & '', & '', & '', & 'NAME', & ' SELECTED_INT_KIND(3) - [KIND] Choose integer kind', & '', & '', & 'SYNOPSIS', & ' result = selected_int_kind(r)', & '', & ' integer function selected_int_kind(r)', & '', & ' integer(kind=KIND),intent(in) :: r', & '', & '', & 'CHARACTERISTICS', & ' o R is an integer scalar.', & '', & ' o the result is an default integer scalar.', & '', & 'DESCRIPTION', & ' SELECTED_INT_KIND(3) return the kind value of the smallest integer type that', & ' can represent all values ranging from -10**R (exclusive) to 10**R', & ' (exclusive). If there is no integer kind that accommodates this range,', & ' selected_int_kind returns -1.', & '', & 'OPTIONS', & ' o R : The value specifies the required range of powers of ten that need', & ' supported by the kind type being returned.', & '', & 'RESULT', & ' The result has a value equal to the value of the kind type parameter of an', & ' integer type that represents all values in the requested range.', & '', & ' if no such kind type parameter is available on the processor, the result is', & ' -1.', & '', & ' If more than one kind type parameter meets the criterion, the value returned', & ' is the one with the smallest decimal exponent range, unless there are', & ' several such values, in which case the smallest of these kind values is', & ' returned.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_selected_int_kind', & ' implicit none', & ' integer,parameter :: k5 = selected_int_kind(5)', & ' integer,parameter :: k15 = selected_int_kind(15)', & ' integer(kind=k5) :: i5', & ' integer(kind=k15) :: i15', & '', & ' print *, huge(i5), huge(i15)', & '', & ' ! the following inequalities are always true', & ' print *, huge(i5) >= 10_k5**5-1', & ' print *, huge(i15) >= 10_k15**15-1', & ' end program demo_selected_int_kind', & '', & ' Results:', & '', & ' > 2147483647 9223372036854775807', & ' > T', & ' > T', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' AINT(3), ANINT(3), INT(3), NINT(3), CEILING(3), FLOOR(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 selected_int_kind(3fortran)', & ''] shortname="selected_int_kind" call process() case('178','selected_real_kind') textblock=[character(len=256) :: & '', & 'selected_real_kind(3fortran) selected_real_kind(3fortran)', & '', & '', & '', & 'NAME', & ' SELECTED_REAL_KIND(3) - [KIND] Choose real kind', & '', & '', & 'SYNOPSIS', & ' result = selected_real_kind([p] [,r] [,radix] )', & '', & ' integer function selected_int_kind(r)', & '', & ' real(kind=KIND),intent(in),optional :: p', & ' real(kind=KIND),intent(in),optional :: r', & ' real(kind=KIND),intent(in),optional :: radix', & '', & '', & 'CHARACTERISTICS', & ' o P is an integer scalar', & '', & ' o R is an integer scalar', & '', & ' o RADIX is an integer scalar', & '', & ' o the result is an default integer scalar', & '', & 'DESCRIPTION', & ' SELECTED_REAL_KIND(3) return the kind value of a real data type with decimal', & ' precision of at least P digits, exponent range of at least R, and with a', & ' radix of RADIX. That is, if such a kind exists', & '', & ' + it has the decimal precision as returned by **precision**(3) of at', & ' least **p** digits.', & ' + a decimal exponent range, as returned by the function **range**(3)', & ' of at least **r**', & ' + a radix, as returned by the function **radix**(3) , of **radix**,', & '', & ' If the requested kind does not exist, -1 is returned.', & '', & ' At least one argument shall be present.', & '', & 'OPTIONS', & ' o P : the requested precision', & '', & ' o R : the requested range', & '', & ' o RADIX : the desired radix', & '', & ' Before FORTRAN 2008, at least one of the arguments R or P shall be', & ' present; since FORTRAN 2008, they are assumed to be zero if absent.', & '', & '', & 'RESULT', & ' selected_real_kind returns the value of the kind type parameter of a real', & ' data type with decimal precision of at least P digits, a decimal exponent', & ' range of at least R, and with the requested RADIX.', & '', & ' If P or R is absent, the result value is the same as if it were present with', & ' the value zero.', & '', & ' If the RADIX parameter is absent, there is no requirement on the radix of', & ' the selected kind and real kinds with any radix can be returned.', & '', & ' If more than one real data type meet the criteria, the kind of the data type', & ' with the smallest decimal precision is returned. If no real data type', & ' matches the criteria, the result is', & '', & ' o -1 : if the processor does not support a real data type with a precision', & ' greater than or equal to P, but the R and RADIX requirements can be', & ' fulfilled', & '', & ' o -2 : if the processor does not support a real type with an exponent range', & ' greater than or equal to R, but P and RADIX are fulfillable', & '', & ' o -3 : if RADIX but not P and R requirements are fulfillable', & '', & ' o -4 : if RADIX and either P or R requirements are fulfillable', & '', & ' o -5 : if there is no real type with the given RADIX', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_selected_real_kind', & ' implicit none', & ' integer,parameter :: p6 = selected_real_kind(6)', & ' integer,parameter :: p10r100 = selected_real_kind(10,100)', & ' integer,parameter :: r400 = selected_real_kind(r=400)', & ' real(kind=p6) :: x', & ' real(kind=p10r100) :: y', & ' real(kind=r400) :: z', & '', & ' print *, precision(x), range(x)', & ' print *, precision(y), range(y)', & ' print *, precision(z), range(z)', & ' end program demo_selected_real_kind', & '', & ' Results:', & '', & ' > 6 37', & ' > 15 307', & ' > 18 4931', & '', & '', & 'STANDARD', & ' Fortran 95 ; with RADIX - Fortran 2008', & '', & 'SEE ALSO', & ' PRECISION(3), RANGE(3), RADIX(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 selected_real_kind(3fortran)', & ''] shortname="selected_real_kind" call process() case('179','set_exponent') textblock=[character(len=256) :: & '', & 'set_exponent(3fortran) set_exponent(3fortran)', & '', & '', & '', & 'NAME', & ' SET_EXPONENT(3) - [MODEL_COMPONENTS] real value with specified exponent', & '', & '', & 'SYNOPSIS', & ' result = set_exponent(x, i)', & '', & ' elemental real(kind=KIND) function set_exponent(x,i)', & '', & ' real(kind=KIND),intent(in) :: x', & ' integer(kind=**),intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o X is type real', & '', & ' o I is type integer', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o The return value is of the same type and kind as X.', & '', & 'DESCRIPTION', & ' SET_EXPONENT(3) returns the real number whose fractional part is that of X', & ' and whose exponent part is I.', & '', & 'OPTIONS', & ' o X : Shall be of type real.', & '', & ' o I : Shall be of type integer.', & '', & 'RESULT', & ' The return value is of the same type and kind as X. The real number whose', & ' fractional part is that of X and whose exponent part if I is returned; it is', & ' FRACTION(X) * RADIX(X)**I.', & '', & ' If X has the value zero, the result has the same value as X.', & '', & ' If X is an IEEE infinity, the result is an IEEE NaN.', & '', & ' If X is an IEEE NaN, the result is the same NaN.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_setexp', & ' implicit none', & ' real :: x = 178.1387e-4', & ' integer :: i = 17', & ' print *, set_exponent(x, i), fraction(x) * radix(x)**i', & ' end program demo_setexp', & '', & ' Results:', & '', & ' 74716.7891 74716.7891', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3),', & ' SCALE(3), SPACING(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 set_exponent(3fortran)', & ''] shortname="set_exponent" call process() case('180','shape') textblock=[character(len=256) :: & '', & 'shape(3fortran) shape(3fortran)', & '', & '', & '', & 'NAME', & ' SHAPE(3) - [ARRAY:INQUIRY] Determine the shape of an array or scalar', & '', & '', & 'SYNOPSIS', & ' result = shape( source [,kind] )', & '', & ' integer(kind=KIND) function shape( source, KIND )', & '', & ' type(TYPE(kind=**)),intent(in) :: source(..)', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o SOURCE is an array or scalar of any type. If SOURCE is a pointer it must', & ' be associated and allocatable arrays must be allocated. It shall not be', & ' an assumed-size array.', & '', & ' o KIND is a constant integer initialization expression.', & '', & ' o the result is an integer array of rank one with size equal to the rank of', & ' SOURCE of the kind specified by KIND if KIND is present, otherwise it has', & ' the default integer kind.', & '', & 'DESCRIPTION', & ' SHAPE(3) queries the shape of an array.', & '', & 'OPTIONS', & ' o SOURCE : an array or scalar of any type. If SOURCE is a pointer it must', & ' be associated and allocatable arrays must be allocated.', & '', & ' o KIND : indicates the kind parameter of the result.', & '', & 'RESULT', & ' An integer array of rank one with as many elements as SOURCE has dimensions.', & '', & ' The elements of the resulting array correspond to the extent of SOURCE along', & ' the respective dimensions.', & '', & ' If SOURCE is a scalar, the result is an empty array (a rank-one array of', & ' size zero).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_shape', & ' implicit none', & ' character(len=*),parameter :: all=''(*(g0,1x))''', & ' integer, dimension(-1:1, -1:2) :: a', & ' print all, ''shape of array='',shape(a)', & ' print all, ''shape of constant='',shape(42)', & ' print all, ''size of shape of constant='',size(shape(42))', & ' print all, ''ubound of array='',ubound(a)', & ' print all, ''lbound of array='',lbound(a)', & ' end program demo_shape', & '', & ' Results:', & '', & ' shape of array= 3 4', & ' shape of constant=', & ' size of shape of constant= 0', & ' ubound of array= 1 2', & ' lbound of array= -1 -1', & '', & '', & 'STANDARD', & ' Fortran 95 ; with KIND argument Fortran 2003', & '', & 'SEE ALSO', & ' Array inquiry:', & '', & ' o SIZE(3) - Determine the size of an array', & '', & ' o RANK(3) - Rank of a data object', & '', & ' o UBOUND(3) - Upper dimension bounds of an array', & '', & ' o LBOUND(3) - Lower dimension bounds of an array', & '', & ' State Inquiry:', & '', & ' o ALLOCATED(3) - Status of an allocatable entity', & '', & ' o IS_CONTIGUOUS(3) - Test if object is contiguous', & '', & ' Kind Inquiry:', & '', & ' o KIND(3) - Kind of an entity', & '', & ' Bit Inquiry:', & '', & ' o STORAGE_SIZE(3) - Storage size in bits', & '', & ' o BIT_SIZE(3) - Bit size inquiry function', & '', & ' o BTEST(3) - Tests a bit of an integer value.', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 shape(3fortran)', & ''] shortname="shape" call process() case('181','shifta') textblock=[character(len=256) :: & '', & 'shifta(3fortran) shifta(3fortran)', & '', & '', & '', & 'NAME', & ' SHIFTA(3) - [BIT:SHIFT] Right shift with fill', & '', & '', & 'SYNOPSIS', & ' result = shifta(i, shift )', & '', & ' elemental integer(kind=KIND) function shifta(i, shift)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: shift', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I is an integer of any kind', & '', & ' o SHIFT is an integer of any kind', & '', & ' o the result will automatically be of the same type, kind and rank as I.', & '', & 'DESCRIPTION', & ' SHIFTA(3) returns a value corresponding to I with all of the bits shifted', & ' right by SHIFT places and the vacated bits on the left filled with the value', & ' of the original left-most bit.', & '', & 'OPTIONS', & ' o I : The initial value to shift and fill', & '', & ' o SHIFT : how many bits to shift right. It shall be nonnegative and less', & ' than or equal to BIT_SIZE(I). or the value is undefined. If SHIFT is zero', & ' the result is I.', & '', & 'RESULT', & ' The result has the value obtained by shifting the bits of I to the right', & ' SHIFT bits and replicating the leftmost bit of I in the left SHIFT bits', & ' (Note the leftmost bit in "two''s complement" representation is the sign', & ' bit).', & '', & ' Bits shifted out from the right end are lost.', & '', & ' If SHIFT is zero the result is I.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_shifta', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer(kind=int32) :: ival', & ' integer :: shift', & ' integer(kind=int32) :: oval', & ' integer(kind=int32),allocatable :: ivals(:)', & ' integer :: i', & ' integer(kind=int8) :: arr(2,2)=reshape([2,4,8,16],[2,2])', & '', & ' ! basic usage', & ' write(*,*)shifta(100,3)', & '', & ' ! loop through some interesting values', & ' shift=5', & '', & ' ivals=[ -1, -0, +0, +1, &', & ' & int(b"01010101010101010101010101010101"), &', & ' & int(b"10101010101010101010101010101010"), &', & ' & int(b"00000000000000000000000000011111") ]', & '', & ' ! does your platform distinguish between +0 and -0?', & ' ! note the original leftmost bit is used to fill in the vacated bits', & '', & ' write(*,''(/,"SHIFT = ",i0)'') shift', & ' do i=1,size(ivals)', & ' ival=ivals(i)', & ' write(*,''( "I = ",b32.32," == ",i0)'') ival,ival', & ' oval=shifta(ival,shift)', & ' write(*,''( "RESULT = ",b32.32," == ",i0)'') oval,oval', & ' enddo', & ' ! elemental', & ' write(*,*)"characteristics of the result are the same as input"', & ' write(*,''(*(g0,1x))'') &', & ' & "kind=",kind(shifta(arr,3)), "shape=",shape(shifta(arr,3)), &', & ' & "size=",size(shifta(arr,3)) !, "rank=",rank(shifta(arr,3))', & '', & ' end program demo_shifta', & '', & ' Results:', & '', & ' > 12', & ' >', & ' > SHIFT = 5', & ' > I = 11111111111111111111111111111111 == -1', & ' > RESULT = 11111111111111111111111111111111 == -1', & ' > I = 00000000000000000000000000000000 == 0', & ' > RESULT = 00000000000000000000000000000000 == 0', & ' > I = 00000000000000000000000000000000 == 0', & ' > RESULT = 00000000000000000000000000000000 == 0', & ' > I = 00000000000000000000000000000001 == 1', & ' > RESULT = 00000000000000000000000000000000 == 0', & ' > I = 01010101010101010101010101010101 == 1431655765', & ' > RESULT = 00000010101010101010101010101010 == 44739242', & ' > I = 10101010101010101010101010101010 == -1431655766', & ' > RESULT = 11111101010101010101010101010101 == -44739243', & ' > I = 00000000000000000000000000011111 == 31', & ' > RESULT = 00000000000000000000000000000000 == 0', & ' > characteristics of the result are the same as input', & ' > kind= 1 shape= 2 2 size= 4', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' SHIFTL(3), SHIFTR(3), ISHFT(3), ISHFTC(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 shifta(3fortran)', & ''] shortname="shifta" call process() case('182','shiftl') textblock=[character(len=256) :: & '', & 'shiftl(3fortran) shiftl(3fortran)', & '', & '', & '', & 'NAME', & ' SHIFTL(3) - [BIT:SHIFT] Shift bits left', & '', & '', & 'SYNOPSIS', & ' result = shiftl( i, shift )', & '', & ' elemental integer(kind=KIND) function shiftl(i, shift)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: shift', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I is an integer of any kind', & '', & ' o SHIFT is an integer of any kind', & '', & ' o the result will automatically be of the same type, kind and rank as I.', & '', & 'DESCRIPTION', & ' SHIFTL(3) returns a value corresponding to I with all of the bits shifted', & ' left by SHIFT places.', & '', & ' Bits shifted out from the left end are lost, and bits shifted in from the', & ' right end are set to 0.', & '', & ' If the absolute value of SHIFT is greater than BIT_SIZE(I), the value is', & ' undefined.', & '', & ' For example, for a 16-bit integer left-shifted five ...', & '', & ' > |a|b|c|d|e|f|g|h|i|j|k|l|m|n|o|p| <- original 16-bit example', & ' > |f|g|h|i|j|k|l|m|n|o|p| <- left-shifted five', & ' > |f|g|h|i|j|k|l|m|n|o|p|0|0|0|0|0| <- right-padded with zeros', & '', & ' Note the value of the result is the same as ISHFT (I, SHIFT).', & '', & 'OPTIONS', & ' o I : The initial value to shift and fill in with zeros', & '', & ' o SHIFT : how many bits to shift left. It shall be nonnegative and less', & ' than or equal to BIT_SIZE(I).', & '', & 'RESULT', & ' The return value is of type integer and of the same kind as I.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_shiftl', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: shift', & ' integer(kind=int32) :: oval', & ' integer(kind=int32) :: ival', & ' integer(kind=int32),allocatable :: ivals(:)', & ' integer :: i', & '', & ' print *, '' basic usage''', & ' ival=100', & ' write(*,*)ival, shiftl(ival,3)', & '', & ' ! elemental (input values may be conformant arrays)', & ' print *, '' elemental''', & '', & ' ! loop through some ivalues', & ' shift=9', & ' ivals=[ &', & ' & int(b"01010101010101010101010101010101"), &', & ' & int(b"10101010101010101010101010101010"), &', & ' & int(b"11111111111111111111111111111111") ]', & '', & ' write(*,''(/,"SHIFT = ",i0)'') shift', & ' do i=1,size(ivals)', & ' ! print initial value as binary and decimal', & ' write(*,''( "I = ",b32.32," == ",i0)'') ivals(i),ivals(i)', & ' ! print shifted value as binary and decimal', & ' oval=shiftl(ivals(i),shift)', & ' write(*,''( "RESULT = ",b32.32," == ",i0)'') oval,oval', & ' enddo', & '', & ' ! more about elemental', & ' ELEM : block', & ' integer(kind=int8) :: arr(2,2)=reshape([2,4,8,16],[2,2])', & ' write(*,*)"characteristics of the result are the same as input"', & ' write(*,''(*(g0,1x))'') &', & ' & "kind=",kind(shiftl(arr,3)), "shape=",shape(shiftl(arr,3)), &', & ' & "size=",size(shiftl(arr,3)) !, "rank=",rank(shiftl(arr,3))', & ' endblock ELEM', & '', & ' end program demo_shiftl', & '', & ' Results:', & '', & ' > basic usage', & ' > 100 800', & ' > elemental', & ' >', & ' > SHIFT = 9', & ' > I = 01010101010101010101010101010101 == 1431655765', & ' > RESULT = 10101010101010101010101000000000 == -1431655936', & ' > I = 10101010101010101010101010101010 == -1431655766', & ' > RESULT = 01010101010101010101010000000000 == 1431655424', & ' > I = 11111111111111111111111111111111 == -1', & ' > RESULT = 11111111111111111111111000000000 == -512', & ' > characteristics of the result are the same as input', & ' > kind= 1 shape= 2 2 size= 4', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' SHIFTA(3), SHIFTR(3), ISHFT(3), ISHFTC(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 shiftl(3fortran)', & ''] shortname="shiftl" call process() case('183','shiftr') textblock=[character(len=256) :: & '', & 'shiftr(3fortran) shiftr(3fortran)', & '', & '', & '', & 'NAME', & ' SHIFTR(3) - [BIT:SHIFT] Shift bits right', & '', & '', & 'SYNOPSIS', & ' result = shiftr( i, shift )', & '', & ' elemental integer(kind=KIND) function shiftr(i, shift)', & '', & ' integer(kind=KIND),intent(in) :: i', & ' integer(kind=**),intent(in) :: shift', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o I is an integer of any kind', & '', & ' o SHIFT is an integer of any kind', & '', & ' o the result will automatically be of the same type, kind and rank as I.', & '', & 'DESCRIPTION', & ' SHIFTR(3) returns a value corresponding to I with all of the bits shifted', & ' right by SHIFT places.', & '', & ' If the absolute value of SHIFT is greater than BIT_SIZE(I), the value is', & ' undefined.', & '', & ' Bits shifted out from the right end are lost, and bits shifted in from the', & ' left end are set to 0.', & '', & ' For example, for a 16-bit integer right-shifted five ...', & '', & ' > |a|b|c|d|e|f|g|h|i|j|k|l|m|n|o|p| <- original 16-bit example', & ' > |a|b|c|d|e|f|g|h|i|j|k| <- right-shifted five', & ' > |0|0|0|0|0|f|g|h|i|j|k|l|m|n|o|p| <- left-padded with zeros', & '', & ' Note the value of the result is the same as ISHFT (I, -SHIFT).', & '', & 'OPTIONS', & ' o I : The value to shift', & '', & ' o SHIFT : How many bits to shift right. It shall be nonnegative and less', & ' than or equal to BIT_SIZE(I).', & '', & 'RESULT', & ' The remaining bits shifted right SHIFT positions. Vacated positions on the', & ' left are filled with zeros.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_shiftr', & ' use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64', & ' implicit none', & ' integer :: shift', & ' integer(kind=int32) :: oval', & ' integer(kind=int32) :: ival', & ' integer(kind=int32),allocatable :: ivals(:)', & ' integer :: i', & '', & ' print *,'' basic usage''', & ' ival=100', & ' write(*,*)ival, shiftr(100,3)', & '', & ' ! elemental (input values may be conformant arrays)', & ' print *,'' elemental''', & ' shift=9', & ' ivals=[ &', & ' & int(b"01010101010101010101010101010101"), &', & ' & int(b"10101010101010101010101010101010"), &', & ' & int(b"11111111111111111111111111111111") ]', & '', & ' write(*,''(/,"SHIFT = ",i0)'') shift', & ' do i=1,size(ivals)', & ' ! print initial value as binary and decimal', & ' write(*,''( "I = ",b32.32," == ",i0)'') ivals(i),ivals(i)', & ' ! print shifted value as binary and decimal', & ' oval=shiftr(ivals(i),shift)', & ' write(*,''( "RESULT = ",b32.32," == ",i0,/)'') oval,oval', & ' enddo', & '', & ' ! more on elemental', & ' ELEM : block', & ' integer(kind=int8) :: arr(2,2)=reshape([2,4,8,16],[2,2])', & ' write(*,*)"characteristics of the result are the same as input"', & ' write(*,''(*(g0,1x))'') &', & ' & "kind=",kind(shiftr(arr,3)), "shape=",shape(shiftr(arr,3)), &', & ' & "size=",size(shiftr(arr,3)) !, "rank=",rank(shiftr(arr,3))', & ' endblock ELEM', & '', & ' end program demo_shiftr', & '', & ' Results:', & '', & ' > basic usage', & ' > 100 12', & ' > elemental', & ' >', & ' > SHIFT = 9', & ' > I = 01010101010101010101010101010101 == 1431655765', & ' > RESULT = 00000000001010101010101010101010 == 2796202', & ' >', & ' > I = 10101010101010101010101010101010 == -1431655766', & ' > RESULT = 00000000010101010101010101010101 == 5592405', & ' >', & ' > I = 11111111111111111111111111111111 == -1', & ' > RESULT = 00000000011111111111111111111111 == 8388607', & ' >', & ' > characteristics of the result are the same as input', & ' > kind= 1 shape= 2 2 size= 4', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' SHIFTA(3), SHIFTL(3), ISHFT(3), ISHFTC(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 shiftr(3fortran)', & ''] shortname="shiftr" call process() case('184','sign') textblock=[character(len=256) :: & '', & 'sign(3fortran) sign(3fortran)', & '', & '', & '', & 'NAME', & ' SIGN(3) - [NUMERIC] Sign copying function', & '', & '', & 'SYNOPSIS', & ' result = sign(a, b)', & '', & ' elemental type(TYPE(kind=KIND))function sign(a, b)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: a, b', & '', & '', & 'CHARACTERISTICS', & ' o A shall be of type integer or real.', & '', & ' o B shall be of the same type as A.', & '', & ' o the characteristics of the result are the same as A.', & '', & 'DESCRIPTION', & ' SIGN(3) returns a value with the magnitude of a but with the sign of b.', & '', & ' For processors that distinguish between positive and negative zeros sign()', & ' may be used to distinguish between real values 0.0 and -0.0. SIGN (1.0,', & ' -0.0) will return -1.0 when a negative zero is distinguishable.', & '', & 'OPTIONS', & ' o A : The value whose magnitude will be returned.', & '', & ' o B : The value whose sign will be returned.', & '', & 'RESULT', & ' a value with the magnitude of A with the sign of B. That is,', & '', & ' o If b >= 0 then the result is abs(a)', & '', & ' o else if b < 0 it is -abs(a).', & '', & ' o if b is real and the processor distinguishes between -0.0 and 0.0 then', & ' the result is -abs(a)', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_sign', & ' implicit none', & ' ! basics', & ' print *, sign( -12, 1 )', & ' print *, sign( -12, 0 )', & ' print *, sign( -12, -1 )', & ' print *, sign( 12, 1 )', & ' print *, sign( 12, 0 )', & ' print *, sign( 12, -1 )', & '', & ' if(sign(1.0,-0.0)== -1.0)then', & ' print *, ''this processor distinguishes +0 from -0''', & ' else', & ' print *, ''this processor does not distinguish +0 from -0''', & ' endif', & '', & ' print *, ''elemental'', sign( -12.0, [1.0, 0.0, -1.0] )', & '', & ' end program demo_sign', & '', & ' Results:', & '', & ' 12', & ' 12', & ' -12 12 12 -12 this processor does not distinguish +0 from -0', & '', & ' elemental', & ' 12.00000 12.00000 -12.00000', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ABS(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 sign(3fortran)', & ''] shortname="sign" call process() case('185','sin') textblock=[character(len=256) :: & '', & 'sin(3fortran) sin(3fortran)', & '', & '', & '', & 'NAME', & ' SIN(3) - [MATHEMATICS:TRIGONOMETRIC] Sine function', & '', & '', & 'SYNOPSIS', & ' result = sin(x)', & '', & ' elemental TYPE(kind=KIND) function sin(x)', & '', & ' TYPE(kind=KIND) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be any real or complex type', & '', & ' o KIND may be any kind supported by the associated type of X.', & '', & ' o The returned value will be of the same type and kind as the argument X.', & '', & 'DESCRIPTION', & ' SIN(3) computes the sine of an angle given the size of the angle in radians.', & '', & ' The sine of an angle in a right-angled triangle is the ratio of the length', & ' of the side opposite the given angle divided by the length of the', & ' hypotenuse.', & '', & 'OPTIONS', & ' o X : The angle in radians to compute the sine of.', & '', & 'RESULT', & ' o RESULT The return value contains the processor-dependent approximation of', & ' the sine of X', & '', & ' If X is of type real, it is regarded as a value in radians.', & '', & ' If X is of type complex, its real part is regarded as a value in radians.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program sample_sin', & ' implicit none', & ' real :: x = 0.0', & ' x = sin(x)', & ' write(*,*)''X='',x', & ' end program sample_sin', & '', & ' Results:', & '', & ' > X= 0.0000000E+00', & '', & ' Extended Example', & '', & ' Haversine Formula', & '', & ' From the article on "Haversine formula" in Wikipedia:', & '', & ' The haversine formula is an equation important in navigation,', & ' giving great-circle distances between two points on a sphere from', & ' their longitudes and latitudes.', & '', & ' So to show the great-circle distance between the Nashville International', & ' Airport (BNA) in TN, USA, and the Los Angeles International Airport (LAX) in', & ' CA, USA you would start with their latitude and longitude, commonly given as', & '', & ' BNA: N 36 degrees 7.2'', W 86 degrees 40.2''', & ' LAX: N 33 degrees 56.4'', W 118 degrees 24.0''', & '', & ' which converted to floating-point values in degrees is:', & '', & ' Latitude Longitude', & '', & '', & ' o BNA 36.12, -86.67', & '', & ' o LAX 33.94, -118.40', & '', & ' And then use the haversine formula to roughly calculate the distance along', & ' the surface of the Earth between the locations:', & '', & ' Sample program:', & '', & ' program demo_sin', & ' implicit none', & ' real :: d', & ' d = haversine(36.12,-86.67, 33.94,-118.40) ! BNA to LAX', & ' print ''(A,F9.4,A)'', ''distance: '',d,'' km''', & ' contains', & ' function haversine(latA,lonA,latB,lonB) result (dist)', & ' !', & ' ! calculate great circle distance in kilometers', & ' ! given latitude and longitude in degrees', & ' !', & ' real,intent(in) :: latA,lonA,latB,lonB', & ' real :: a,c,dist,delta_lat,delta_lon,lat1,lat2', & ' real,parameter :: radius = 6371 ! mean earth radius in kilometers,', & ' ! recommended by the International Union of Geodesy and Geophysics', & '', & ' ! generate constant pi/180', & ' real, parameter :: deg_to_rad = atan(1.0)/45.0', & ' delta_lat = deg_to_rad*(latB-latA)', & ' delta_lon = deg_to_rad*(lonB-lonA)', & ' lat1 = deg_to_rad*(latA)', & ' lat2 = deg_to_rad*(latB)', & ' a = (sin(delta_lat/2))**2 + &', & ' & cos(lat1)*cos(lat2)*(sin(delta_lon/2))**2', & ' c = 2*asin(sqrt(a))', & ' dist = radius*c', & ' end function haversine', & ' end program demo_sin', & '', & ' Results:', & '', & ' > distance: 2886.4446 km', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' ASIN(3), COS(3), TAN(3), ACOSH(3), ACOS(3), ASINH(3), ATAN2(3), ATANH(3),', & ' ACOSH(3), ASINH(3), ATANH(3)', & '', & 'RESOURCES', & ' o Wikipedia:sine and cosine', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 sin(3fortran)', & ''] shortname="sin" call process() case('186','sinh') textblock=[character(len=256) :: & '', & 'sinh(3fortran) sinh(3fortran)', & '', & '', & '', & 'NAME', & ' SINH(3) - [MATHEMATICS:TRIGONOMETRIC] Hyperbolic sine function', & '', & '', & 'SYNOPSIS', & ' result = sinh(x)', & '', & ' elemental TYPE(kind=KIND) function sinh(x)', & '', & ' TYPE(kind=KIND) :: x', & '', & '', & 'CHARACTERISTICS', & ' o TYPE may be real or complex', & '', & ' o KIND may be any kind supported by the associated type.', & '', & ' o The returned value will be of the same type and kind as the argument.', & '', & 'DESCRIPTION', & ' SINH(3) computes the hyperbolic sine of X.', & '', & ' The hyperbolic sine of x is defined mathematically as:', & '', & ' sinh(x) = (exp(x) - exp(-x)) / 2.0', & '', & '', & 'OPTIONS', & ' o X : The value to calculate the hyperbolic sine of', & '', & 'RESULT', & ' The result has a value equal to a processor-dependent approximation to', & ' sinh(X). If X is of type complex its imaginary part is regarded as a value', & ' in radians.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_sinh', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & real_kinds, real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = - 1.0_real64', & ' real(kind=real64) :: nan, inf', & ' character(len=20) :: line', & '', & ' ! basics', & ' print *, sinh(x)', & ' print *, (exp(x)-exp(-x))/2.0', & '', & ' ! sinh(3) is elemental and can handle an array', & ' print *, sinh([x,2.0*x,x/3.0])', & '', & ' ! a NaN input returns NaN', & ' line=''NAN''', & ' read(line,*) nan', & ' print *, sinh(nan)', & '', & ' ! a Inf input returns Inf', & ' line=''Infinity''', & ' read(line,*) inf', & ' print *, sinh(inf)', & '', & ' ! an overflow returns Inf', & ' x=huge(0.0d0)', & ' print *, sinh(x)', & '', & ' end program demo_sinh', & '', & ' Results:', & '', & ' -1.1752011936438014', & ' -1.1752011936438014', & ' -1.1752011936438014 -3.6268604078470190 -0.33954055725615012', & ' NaN', & ' Infinity', & ' Infinity', & '', & '', & 'STANDARD', & ' Fortran 95 , for a complex argument Fortran 2008', & '', & 'SEE ALSO', & ' ASINH(3)', & '', & 'RESOURCES', & ' o Wikipedia:hyperbolic functions', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 sinh(3fortran)', & ''] shortname="sinh" call process() case('187','size') textblock=[character(len=256) :: & '', & 'size(3fortran) size(3fortran)', & '', & '', & '', & 'NAME', & ' SIZE(3) - [ARRAY:INQUIRY] Determine the size of an array or extent of one', & ' dimension', & '', & '', & 'SYNOPSIS', & ' result = size(array [,dim] [,kind])', & '', & ' integer(kind=KIND) function size(array,dim,kind)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' integer(kind=**),intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY is an assumed-rank array or array of any type and associated kind.', & '', & ' If ARRAY is a pointer it must be associated and allocatable arrays must', & ' be allocated.', & '', & ' o DIM is an integer scalar', & '', & ' o KIND is a scalar integer constant expression.', & '', & ' o the result is an integer scalar of kind KIND. If KIND is absent a integer', & ' of default kind is returned.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' SIZE(3) returns the total number of elements in an array, or if DIM is', & ' specified returns the number of elements along that dimension.', & '', & ' SIZE(3) determines the extent of ARRAY along a specified dimension DIM, or', & ' the total number of elements in ARRAY if DIM is absent.', & '', & 'OPTIONS', & ' o ARRAY : the array to measure the number of elements of. If *array is an', & ' assumed-size array, DIM shall be present with a value less than the rank', & ' of ARRAY.', & '', & ' o DIM : a value shall be in the range from 1 to n, where n equals the rank', & ' of ARRAY.', & '', & ' If not present the total number of elements of the entire array are', & ' returned.', & '', & ' o KIND : An integer initialization expression indicating the kind parameter', & ' of the result.', & '', & ' If absent the kind type parameter of the returned value is that of', & ' default integer type.', & '', & ' The KIND must allow for the magnitude returned by SIZE or results are', & ' undefined.', & '', & ' If KIND is absent, the return value is of default integer kind.', & '', & 'RESULT', & ' If DIM is not present ARRAY is assumed-rank, the result has a value equal to', & ' PRODUCT(SHAPE(ARRAY,KIND)). Otherwise, the result has a value equal to the', & ' total number of elements of ARRAY.', & '', & ' If DIM is present the number of elements along that dimension are returned,', & ' except that if ARRAY is assumed-rank and associated with an assumed-size', & ' array and DIM is present with a value equal to the rank of ARRAY, the value', & ' is -1.', & '', & ' NOTE1', & '', & ' If ARRAY is assumed-rank and has rank zero, DIM cannot be present since it', & ' cannot satisfy the requirement', & '', & ' 1 <= DIM <= 0.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_size', & ' implicit none', & ' integer :: arr(0:2,-5:5)', & ' write(*,*)''SIZE of simple two-dimensional array''', & ' write(*,*)''SIZE(arr) :total count of elements:'',size(arr)', & ' write(*,*)''SIZE(arr,DIM=1) :number of rows :'',size(arr,dim=1)', & ' write(*,*)''SIZE(arr,DIM=2) :number of columns :'',size(arr,dim=2)', & '', & ' ! pass the same array to a procedure that passes the value two', & ' ! different ways', & ' call interfaced(arr,arr)', & ' contains', & '', & ' subroutine interfaced(arr1,arr2)', & ' ! notice the difference in the array specification', & ' ! for arr1 and arr2.', & ' integer,intent(in) :: arr1(:,:)', & ' integer,intent(in) :: arr2(2,*)', & ' !', & ' write(*,*)''interfaced assumed-shape array''', & ' write(*,*)''SIZE(arr1) :'',size(arr1)', & ' write(*,*)''SIZE(arr1,DIM=1) :'',size(arr1,dim=1)', & ' write(*,*)''SIZE(arr1,DIM=2) :'',size(arr1,dim=2)', & '', & ' ! write(*,*)''SIZE(arr2) :'',size(arr2)', & ' write(*,*)''SIZE(arr2,DIM=1) :'',size(arr2,dim=1)', & ' !', & ' ! CANNOT DETERMINE SIZE OF ASSUMED SIZE ARRAY LAST DIMENSION', & ' ! write(*,*)''SIZE(arr2,DIM=2) :'',size(arr2,dim=2)', & '', & ' end subroutine interfaced', & '', & ' end program demo_size', & '', & ' Results:', & '', & ' SIZE of simple two-dimensional array', & ' SIZE(arr) :total count of elements: 33', & ' SIZE(arr,DIM=1) :number of rows : 3', & ' SIZE(arr,DIM=2) :number of columns : 11', & ' interfaced assumed-shape array', & ' SIZE(arr1) : 33', & ' SIZE(arr1,DIM=1) : 3', & ' SIZE(arr1,DIM=2) : 11', & ' SIZE(arr2,DIM=1) : 2', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument - Fortran 2003', & '', & 'SEE ALSO', & ' Array inquiry:', & '', & ' o SIZE(3) - Determine the size of an array', & '', & ' o RANK(3) - Rank of a data object', & '', & ' o SHAPE(3) - Determine the shape of an array', & '', & ' o UBOUND(3) - Upper dimension bounds of an array', & '', & ' o LBOUND(3) - Lower dimension bounds of an array', & '', & ' State Inquiry:', & '', & ' o ALLOCATED(3) - Status of an allocatable entity', & '', & ' o IS_CONTIGUOUS(3) - Test if object is contiguous', & '', & ' Kind Inquiry:', & '', & ' o KIND(3) - Kind of an entity', & '', & ' Bit Inquiry:', & '', & ' o STORAGE_SIZE(3) - Storage size in bits', & '', & ' o BIT_SIZE(3) - Bit size inquiry function', & '', & ' o BTEST(3) - Tests a bit of an integer value.', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 size(3fortran)', & ''] shortname="size" call process() case('188','spacing') textblock=[character(len=256) :: & '', & 'spacing(3fortran) spacing(3fortran)', & '', & '', & '', & 'NAME', & ' SPACING(3) - [MODEL_COMPONENTS] Smallest distance between two numbers of a', & ' given type', & '', & '', & 'SYNOPSIS', & ' result = spacing(x)', & '', & ' elemental real(kind=KIND) function spacing(x)', & '', & ' real(kind=KIND), intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X is type real of any valid kind', & '', & ' o The result is of the same type as the input argument X.', & '', & 'DESCRIPTION', & ' SPACING(3) determines the distance between the argument X and the nearest', & ' adjacent number of the same type.', & '', & 'OPTIONS', & ' o X : Shall be of type real.', & '', & 'RESULT', & ' If X does not have the value zero and is not an IEEE infinity or NaN, the', & ' result has the value nearest to X for values of the same type and kind', & ' assuming the value is representable.', & '', & ' Otherwise, the value is the same as TINY(X). + zero produces TINY(X) + IEEE', & ' Infinity produces an IEEE Nan + if an IEEE NaN, that NaN is returned', & '', & ' If there are two extended model values equally near to X, the value of', & ' greater absolute value is taken.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_spacing', & ' implicit none', & ' integer, parameter :: sgl = selected_real_kind(p=6, r=37)', & ' integer, parameter :: dbl = selected_real_kind(p=13, r=200)', & '', & ' write(*,*) spacing(1.0_sgl)', & ' write(*,*) nearest(1.0_sgl,+1.0),nearest(1.0_sgl,+1.0)-1.0', & '', & ' write(*,*) spacing(1.0_dbl)', & ' end program demo_spacing', & '', & ' Results:', & '', & ' Typical values ...', & '', & ' 1.1920929E-07', & ' 1.000000 1.1920929E-07', & ' 0.9999999 -5.9604645E-08', & ' 2.220446049250313E-016', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3),', & ' SCALE(3), SET_EXPONENT(3), TINY(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 spacing(3fortran)', & ''] shortname="spacing" call process() case('189','spread') textblock=[character(len=256) :: & '', & 'spread(3fortran) spread(3fortran)', & '', & '', & '', & 'NAME', & ' SPREAD(3) - [ARRAY:CONSTRUCTION] Add a dimension and replicate data', & '', & '', & 'SYNOPSIS', & ' result = spread(source, dim, ncopies)', & '', & ' TYPE(kind=KIND) function spread(source, dim, ncopies)', & '', & ' TYPE(kind=KIND) :: source(..)', & ' integer(kind=**),intent(in) :: dim', & ' integer(kind=**),intent(in) :: ncopies', & '', & '', & 'CHARACTERISTICS', & ' o SOURCE is a scalar or array of any type and a rank less than fifteen.', & '', & ' o DIM is an integer scalar', & '', & ' o NCOPIES is an integer scalar', & '', & 'DESCRIPTION', & ' SPREAD(3) replicates a SOURCE array along a specified dimension DIM. The', & ' copy is repeated NCOPIES times.', & '', & ' So to add additional rows to a matrix DIM=1 would be used, but to add', & ' additional rows DIM=2 would be used, for example.', & '', & ' If SOURCE is scalar, the size of the resulting vector is NCOPIES and each', & ' element of the result has a value equal to SOURCE.', & '', & 'OPTIONS', & ' o SOURCE : the input data to duplicate', & '', & ' o DIM : The additional dimension value in the range from 1 to N+1, where N', & ' equals the rank of SOURCE.', & '', & ' o NCOPIES : the number of copies of the original data to generate', & '', & 'RESULT', & ' The result is an array of the same type as SOURCE and has rank N+1 where N', & ' equals the rank of SOURCE.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_spread', & ' implicit none', & '', & ' integer a1(4,3), a2(3,4), v(4), s', & '', & ' write(*,''(a)'' ) &', & ' ''TEST SPREAD(3) '', &', & ' '' SPREAD(3) is a FORTRAN90 function which replicates'', &', & ' '' an array by adding a dimension. '', &', & ' '' ''', & '', & ' s = 99', & ' call printi(''suppose we have a scalar S'',s)', & '', & ' write(*,*) ''to add a new dimension (1) of extent 4 call''', & ' call printi(''spread( s, dim=1, ncopies=4 )'',spread ( s, 1, 4 ))', & '', & ' v = [ 1, 2, 3, 4 ]', & ' call printi('' first we will set V to'',v)', & '', & ' write(*,''(a)'')'' and then do "spread ( v, dim=2, ncopies=3 )"''', & ' a1 = spread ( v, dim=2, ncopies=3 )', & ' call printi(''uses v as a column and makes 3 columns'',a1)', & '', & ' a2 = spread ( v, 1, 3 )', & ' call printi('' spread(v,1,3) uses v as a row and makes 3 rows'',a2)', & '', & ' contains', & ' ! CONVENIENCE ROUTINE; NOT DIRECTLY CONNECTED TO SPREAD(3)', & ' subroutine printi(title,a)', & ' use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,&', & ' & stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT', & ' implicit none', & '', & ' !@(#) print small 2d integer scalar, vector, matrix in row-column format', & '', & ' character(len=*),parameter :: all=''(" ",*(g0,1x))''', & ' character(len=*),intent(in) :: title', & ' character(len=20) :: row', & ' integer,intent(in) :: a(..)', & ' integer :: i', & '', & ' write(*,all,advance=''no'')trim(title)', & ' ! select rank of input', & ' select rank(a)', & ' rank (0); write(*,''(a)'')'' (a scalar)''', & ' write(*,''(" > [ ",i0," ]")'')a', & ' rank (1); write(*,''(a)'')'' (a vector)''', & ' ! find how many characters to use for integers', & ' write(row,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(a))))))+2', & ' ! use this format to write a row', & ' row=''(" > [",*(i''//trim(row)//'':,","))''', & ' do i=1,size(a)', & ' write(*,fmt=row,advance=''no'')a(i)', & ' write(*,''(" ]")'')', & ' enddo', & ' rank (2); write(*,''(a)'')'' (a matrix) ''', & ' ! find how many characters to use for integers', & ' write(row,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(a))))))+2', & ' ! use this format to write a row', & ' row=''(" > [",*(i''//trim(row)//'':,","))''', & ' do i=1,size(a,dim=1)', & ' write(*,fmt=row,advance=''no'')a(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' rank default', & ' write(stderr,*)''*printi* did not expect rank='', rank(a), &', & ' & ''shape='', shape(a),''size='',size(a)', & ' stop ''*printi* unexpected rank''', & ' end select', & ' write(*,all) ''>shape='',shape(a),'',rank='',rank(a),'',size='',size(a)', & ' write(*,*)', & '', & ' end subroutine printi', & '', & ' end program demo_spread', & '', & ' Results:', & '', & ' > TEST SPREAD(3)', & ' > SPREAD(3) is a FORTRAN90 function which replicates', & ' > an array by adding a dimension.', & ' >', & ' > suppose we have a scalar S (a scalar)', & ' > > [ 99 ]', & ' > >shape= ,rank= 0 ,size= 1', & ' >', & ' > to add a new dimension (1) of extent 4 call', & ' > spread( s, dim=1, ncopies=4 ) (a vector)', & ' > > [ 99 ]', & ' > > [ 99 ]', & ' > > [ 99 ]', & ' > > [ 0 ]', & ' > >shape= 4 ,rank= 1 ,size= 4', & ' >', & ' > first we will set V to (a vector)', & ' > > [ 1 ]', & ' > > [ 2 ]', & ' > > [ 3 ]', & ' > > [ 4 ]', & ' > >shape= 4 ,rank= 1 ,size= 4', & ' >', & ' > and then do "spread ( v, dim=2, ncopies=3 )"', & ' > uses v as a column and makes 3 columns (a matrix)', & ' > > [ 1, 1, 1 ]', & ' > > [ 2, 2, 2 ]', & ' > > [ 3, 3, 3 ]', & ' > > [ 4, 4, 4 ]', & ' > >shape= 4 3 ,rank= 2 ,size= 12', & ' >', & ' > spread(v,1,3) uses v as a row and makes 3 rows (a matrix)', & ' > > [ 1, 2, 3, 4 ]', & ' > > [ 1, 2, 3, 4 ]', & ' > > [ 1, 2, 3, 4 ]', & ' > >shape= 3 4 ,rank= 2 ,size= 12', & ' >', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' MERGE(3), PACK(3), UNPACK(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 spread(3fortran)', & ''] shortname="spread" call process() case('190','sqrt') textblock=[character(len=256) :: & '', & 'sqrt(3fortran) sqrt(3fortran)', & '', & '', & '', & 'NAME', & ' SQRT(3) - [MATHEMATICS] Square-root function', & '', & '', & 'SYNOPSIS', & ' result = sqrt(x)', & '', & ' elemental TYPE(kind=KIND) function sqrt(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o TYPE may be real or complex.', & '', & ' o KIND may be any kind valid for the declared type.', & '', & ' o the result has the same characteristics as X.', & '', & 'DESCRIPTION', & ' SQRT(3) computes the principal square root of X.', & '', & ' The number whose square root is being considered is known as the radicand.', & '', & ' In mathematics, a square root of a radicand X is a number Y such that Y*Y =', & ' X.', & '', & ' Every nonnegative radicand X has two square roots of the same unique', & ' magnitude, one positive and one negative. The nonnegative square root is', & ' called the principal square root.', & '', & ' The principal square root of 9 is 3, for example, even though (-3)*(-3) is', & ' also 9.', & '', & ' Square roots of negative numbers are a special case of complex numbers,', & ' where with COMPLEX input the components of the radicand need not be positive', & ' in order to have a valid square root.', & '', & 'OPTIONS', & ' o X : The radicand to find the principal square root of. If X is real its', & ' value must be greater than or equal to zero.', & '', & 'RESULT', & ' The principal square root of X is returned.', & '', & ' For a complex result the real part is greater than or equal to zero.', & '', & ' When the real part of the result is zero, the imaginary part has the same', & ' sign as the imaginary part of X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_sqrt', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x, x2', & ' complex :: z, z2', & '', & ' ! basics', & ' x = 2.0_real64', & ' ! complex', & ' z = (1.0, 2.0)', & ' write(*,*)''input values '',x,z', & '', & ' x2 = sqrt(x)', & ' z2 = sqrt(z)', & ' write(*,*)''output values '',x2,z2', & '', & ' ! elemental', & ' write(*,*)''elemental'',sqrt([64.0,121.0,30.0])', & '', & ' ! alternatives', & ' x2 = x**0.5', & ' z2 = z**0.5', & ' write(*,*)''alternatively'',x2,z2', & '', & ' end program demo_sqrt', & '', & ' Results:', & '', & ' input values 2.00000000000000 (1.000000,2.000000)', & ' output values 1.41421356237310 (1.272020,0.7861513)', & ' elemental 8.000000 11.00000 5.477226', & ' alternatively 1.41421356237310 (1.272020,0.7861513)', & '', & '', & 'STANDARD', & ' FORTRAN 77', & '', & 'SEE ALSO', & ' EXP(3), LOG(3), LOG10(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 sqrt(3fortran)', & ''] shortname="sqrt" call process() case('191','stop') textblock=[character(len=256) :: & '', & 'stop(7fortran) stop(7fortran)', & '', & '', & '', & 'NAME', & ' STOP(7) - [STATEMENT] initiates termination of execution', & '', & '', & 'SYNOPSIS', & ' stop [ stop-code ]', & '', & ' error stop [ stop-code ]', & '', & 'CHARACTERISTICS', & ' o STOP-CODE is a constant scalar _character_or integer expression, of', & ' default kind.', & '', & 'DESCRIPTION', & ' A STOP statement will cause the program to terminate normally.', & '', & ' It may provide additional information in the form of output or a system', & ' status code, depending on the system.', & '', & ' Any messages generated appear on the ERROR_UNIT file, as identified in the', & ' intrinsic module ISO_FORTRAN_ENV. This unit is often referred to as', & ' "stderr".', & '', & ' It is recommended that systems write the value of the stop code whether', & ' numeric or a string.', & '', & ' Note that although STOP causes a "normal" termination, system status codes', & ' or "exit codes" are often used for error processing in many scripting', & ' languages. This code may be detectable by EXECUTE_SYSTEM_COMMAND(3f).', & '', & ' Execution of an ERROR STOP statement initiates error termination of an', & ' execution, which on several systems includes the output from a traceback.', & '', & ' So when an image is terminated by a STOP or ERROR STOP statement, its stop', & ' code, if any, is made available in a processor-dependent manner.', & '', & ' If any exception is signaling on a stopped image, the processor issues a', & ' warning indicating which exceptions are signaling;', & '', & ' When normal termination occurs on more than one image, it is expected that a', & ' processor-dependent summary of any stop codes and signaling exceptions will', & ' be made available.', & '', & ' If an integer STOP-CODE is used as the process exit status, the processor', & ' might be able to interpret only values within a limited range, OR only a', & ' limited portion of the integer value (for example, only the least-', & ' significant 8 bits).', & '', & ' If the STOP-CODE is of type character or does not appear, OR if an END', & ' PROGRAM statement is executed, it is recommended that the value zero be', & ' supplied as the process exit status, if the processor supports that concept.', & '', & 'EXAMPLES', & ' Sample:', & '', & ' program demo_stop', & ' use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT', & ' implicit none', & ' integer :: stopcode', & ' character(len=:),allocatable :: message', & ' character(len=20) :: which', & ' INFINITE: do', & ' ! Normal terminations', & ' write(*,''(a)'')''enter a stop type:'', &', & ' & ''{basic, text, zero, nonzero, variable, expression}'', &', & ' & ''{error, errornum, errorstring}''', & ' read(*,''(a)'')which', & ' select case(which)', & ' ! normal terminations:', & ' ! A STOP with no non-zero numeric parameter is a normal', & ' ! termination and generally returns a zero status value if the', & ' ! system supports return statuses', & ' case(''basic''); stop ! usually displays nothing', & ' case(''zero''); stop 0 ! sometimes displays "STOP 0" or "0"', & ' case(''text''); stop ''That is all, folks!''', & ' !', & ' ! All other stops are generally used to indicate an error or', & ' ! special exit type', & ' case(''nonzero''); stop 10', & ' case(''variable''); stopcode=11; stop stopcode', & ' case(''expression''); stopcode=11; stop 110/stopcode', & ' case(''string''); message=''oops''; stop ''ERROR:[''//message//'']''', & ' ! Error terminations:', & ' ! ERROR STOP is always an error stop, even without a stop-code', & ' ! ERROR STOP often displays a traceback but that is not required', & ' case(''error'')', & ' error stop', & ' case(''errornum'')', & ' stopcode=10', & ' error stop stopcode+3', & ' case(''errorstring'')', & ' message=''That is all, folks!''', & ' error stop ''ERROR:''//message', & ' case default', & ' write(*,*)''try again ...''', & ' end select', & ' enddo INFINITE', & ' end program demo_stop', & '', & '', & 'STANDARD', & ' FORTRAN 77, ERROR STOP introduced in Fortran f2018', & '', & ' fortran-lang statement descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 stop(7fortran)', & ''] shortname="stop" call process() case('192','storage_size') textblock=[character(len=256) :: & '', & 'storage_size(3fortran) storage_size(3fortran)', & '', & '', & '', & 'NAME', & ' STORAGE_SIZE(3) - [BIT:INQUIRY] Storage size in bits', & '', & '', & 'SYNOPSIS', & ' result = storage_size(a [,KIND] )', & '', & ' integer(kind=KIND) storage_size(a,KIND)', & '', & ' type(TYPE(kind=**)) :: a', & ' integer,intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o A may be of any type and kind. If it is polymorphic it shall not be an', & ' undefined pointer. If it is unlimited polymorphic or has any deferred', & ' type parameters, it shall not be an unallocated allocatable variable or a', & ' disassociated or undefined pointer.', & '', & ' o The kind type parameter of the returned value is that specified by the', & ' value of KIND; otherwise, the kind type parameter is that of default', & ' integer type.', & '', & ' o The result is an integer scalar of default kind unless KIND is specified,', & ' in which case it has the kind specified by KIND.', & '', & 'DESCRIPTION', & ' STORAGE_SIZE(3) returns the storage size of argument A in bits.', & '', & 'OPTIONS', & ' o A : The entity to determine the storage size of', & '', & ' o KIND : a scalar integer constant expression that defines the kind of the', & ' output value.', & '', & 'RESULT', & ' The result value is the size expressed in bits for an element of an array', & ' that has the dynamic type and type parameters of A.', & '', & ' If the type and type parameters are such that storage association applies,', & ' the result is consistent with the named constants defined in the intrinsic', & ' module ISO_FORTRAN_ENV.', & '', & ' NOTE1', & '', & ' An array element might take "type" more bits to store than an isolated', & ' scalar, since any hardware-imposed alignment requirements for array elements', & ' might not apply to a simple scalar variable.', & '', & ' NOTE2', & '', & ' This is intended to be the size in memory that an object takes when it is', & ' stored; this might differ from the size it takes during expression handling', & ' (which might be the native register size) or when stored in a file. If an', & ' object is never stored in memory but only in a register, this function', & ' nonetheless returns the size it would take if it were stored in memory.', & '', & 'EXAMPLES', & ' Sample program', & '', & ' program demo_storage_size', & ' implicit none', & '', & ' ! a default real, integer, and logical are the same storage size', & ' write(*,*)''size of integer '',storage_size(0)', & ' write(*,*)''size of real '',storage_size(0.0)', & ' write(*,*)''size of logical '',storage_size(.true.)', & ' write(*,*)''size of complex '',storage_size((0.0,0.0))', & '', & ' ! note the size of an element of the array, not the storage size of', & ' ! the entire array is returned for array arguments', & ' write(*,*)''size of integer array '',storage_size([0,1,2,3,4,5,6,7,8,9])', & '', & ' end program demo_storage_size', & '', & ' Results:', & '', & ' size of integer 32', & ' size of real 32', & ' size of logical 32', & ' size of complex 64', & ' size of integer array 32', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' C_SIZEOF(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 storage_size(3fortran)', & ''] shortname="storage_size" call process() case('193','sum') textblock=[character(len=256) :: & '', & 'sum(3fortran) sum(3fortran)', & '', & '', & '', & 'NAME', & ' SUM(3) - [ARRAY:REDUCTION] Sum the elements of an array', & '', & '', & 'SYNOPSIS', & ' result = sum(array [,dim[,mask]] | [mask] )', & '', & ' TYPE(kind=KIND) function sum(array, dim, mask)', & '', & ' TYPE(kind=KIND),intent(in) :: array(..)', & ' integer(kind=**),intent(in),optional :: dim', & ' logical(kind=**),intent(in),optional :: mask(..)', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o ARRAY may be of any numeric type - integer, real or complex.', & '', & ' o DIM is an integer', & '', & ' o MASK is logical and conformable with ARRAY.', & '', & ' o The result is of the same type and kind as ARRAY. It is scalar if DIM is', & ' not present or ARRAY is a vector, else it is an array.', & '', & 'DESCRIPTION', & ' SUM(3) adds the elements of ARRAY.', & '', & ' When only ARRAY is specified all elements are summed, but groups of sums may', & ' be returned along the dimension specified by DIM and/or elements to add may', & ' be selected by a logical mask.', & '', & ' No method is designated for how the sum is conducted, so whether or not', & ' accumulated error is compensated for is processor-dependent.', & '', & 'OPTIONS', & ' o ARRAY : an array containing the elements to add', & '', & ' o DIM : a value in the range from 1 to n, where n equals the rank (the', & ' number of dimensions) of ARRAY. DIM designates the dimension along which', & ' to create sums. When absent a scalar sum of the elements optionally', & ' selected by MASK is returned.', & '', & ' o MASK : an array of the same shape as ARRAY that designates which elements', & ' to add. If absent all elements are used in the sum(s).', & '', & 'RESULT', & ' If DIM is absent, a scalar with the sum of all selected elements in ARRAY is', & ' returned. Otherwise, an array of rank n-1, where n equals the rank of ARRAY,', & ' and a shape similar to that of ARRAY with dimension DIM dropped is returned.', & ' Since a vector has a rank of one, the result is a scalar (if n==1, n-1 is', & ' zero; and a rank of zero means a scalar).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_sum', & ' implicit none', & ' integer :: vector(5) , matrix(3,4), box(5,6,7)', & '', & ' vector = [ 1, 2, -3, 4, 5 ]', & '', & ' matrix(1,:)=[ -1, 2, -3, 4 ]', & ' matrix(2,:)=[ 10, -20, 30, -40 ]', & ' matrix(3,:)=[ 100, 200, -300, 400 ]', & '', & ' box=11', & '', & ' ! basics', & ' print *, ''sum all elements:'',sum(vector)', & ' print *, ''real :'',sum([11.0,-5.0,20.0])', & ' print *, ''complex :'',sum([(1.1,-3.3),(4.0,5.0),(8.0,-6.0)])', & ' ! with MASK option', & ' print *, ''sum odd elements:'',sum(vector, mask=mod(vector, 2)==1)', & ' print *, ''sum positive values:'', sum(vector, mask=vector>0)', & '', & ' call printi(''the input array'', matrix )', & ' call printi(''sum of all elements in matrix'', sum(matrix) )', & ' call printi(''sum of positive elements'', sum(matrix,matrix>=0) )', & ' ! along dimensions', & ' call printi(''sum along rows'', sum(matrix,dim=1) )', & ' call printi(''sum along columns'', sum(matrix,dim=2) )', & ' call printi(''sum of a vector is always a scalar'', sum(vector,dim=1) )', & ' call printi(''sum of a volume by row'', sum(box,dim=1) )', & ' call printi(''sum of a volume by column'', sum(box,dim=2) )', & ' call printi(''sum of a volume by depth'', sum(box,dim=3) )', & '', & ' contains', & ' ! CONVENIENCE ROUTINE; NOT DIRECTLY CONNECTED TO SPREAD(3)', & ' subroutine printi(title,a)', & ' use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,&', & ' & stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT', & ' implicit none', & '', & ' !@(#) print small 2d integer scalar, vector, matrix in row-column format', & '', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: a(..)', & '', & ' character(len=*),parameter :: all=''(" ",*(g0,1x))''', & ' character(len=20) :: row', & ' integer,allocatable :: b(:,:)', & ' integer :: i', & ' write(*,all,advance=''no'')trim(title)', & ' ! copy everything to a matrix to keep code simple', & ' select rank(a)', & ' rank (0); write(*,''(a)'')'' (a scalar)''; b=reshape([a],[1,1])', & ' rank (1); write(*,''(a)'')'' (a vector)''; b=reshape(a,[size(a),1])', & ' rank (2); write(*,''(a)'')'' (a matrix)''; b=a', & ' rank default; stop ''*printi* unexpected rank''', & ' end select', & ' ! find how many characters to use for integers', & ' write(row,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(b))))))+2', & ' ! use this format to write a row', & ' row=''(" > [",*(i''//trim(row)//'':,","))''', & ' do i=1,size(b,dim=1)', & ' write(*,fmt=row,advance=''no'')b(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' write(*,all) ''>shape='',shape(a),'',rank='',rank(a),'',size='',size(a)', & ' write(*,*)', & ' end subroutine printi', & ' end program demo_sum', & '', & ' Results:', & '', & ' sum all elements: 9', & ' real : 26.00000', & ' complex : (13.10000,-4.300000)', & ' sum odd elements: 6', & ' sum positive values: 12', & ' the input array (a matrix)', & ' > [ -1, 2, -3, 4 ]', & ' > [ 10, -20, 30, -40 ]', & ' > [ 100, 200, -300, 400 ]', & ' >shape= 3 4 ,rank= 2 ,size= 12', & '', & ' sum of all elements in matrix (a scalar)', & ' > [ 382 ]', & ' >shape= ,rank= 0 ,size= 1', & '', & ' sum of positive elements (a scalar)', & ' > [ 746 ]', & ' >shape= ,rank= 0 ,size= 1', & '', & ' sum along rows (a vector)', & ' > [ 109 ]', & ' > [ 182 ]', & ' > [ -273 ]', & ' > [ 364 ]', & ' >shape= 4 ,rank= 1 ,size= 4', & '', & ' sum along columns (a vector)', & ' > [ 2 ]', & ' > [ -20 ]', & ' > [ 400 ]', & ' >shape= 3 ,rank= 1 ,size= 3', & '', & ' sum of a vector is always a scalar (a scalar)', & ' > [ 9 ]', & ' >shape= ,rank= 0 ,size= 1', & '', & ' sum of a volume by row (a matrix)', & ' > [ 55, 55, 55, 55, 55, 55, 55 ]', & ' > [ 55, 55, 55, 55, 55, 55, 55 ]', & ' > [ 55, 55, 55, 55, 55, 55, 55 ]', & ' > [ 55, 55, 55, 55, 55, 55, 55 ]', & ' > [ 55, 55, 55, 55, 55, 55, 55 ]', & ' > [ 55, 55, 55, 55, 55, 55, 55 ]', & ' >shape= 6 7 ,rank= 2 ,size= 42', & '', & ' sum of a volume by column (a matrix)', & ' > [ 66, 66, 66, 66, 66, 66, 66 ]', & ' > [ 66, 66, 66, 66, 66, 66, 66 ]', & ' > [ 66, 66, 66, 66, 66, 66, 66 ]', & ' > [ 66, 66, 66, 66, 66, 66, 66 ]', & ' > [ 66, 66, 66, 66, 66, 66, 66 ]', & ' >shape= 5 7 ,rank= 2 ,size= 35', & '', & ' sum of a volume by depth (a matrix)', & ' > [ 77, 77, 77, 77, 77, 77 ]', & ' > [ 77, 77, 77, 77, 77, 77 ]', & ' > [ 77, 77, 77, 77, 77, 77 ]', & ' > [ 77, 77, 77, 77, 77, 77 ]', & ' > [ 77, 77, 77, 77, 77, 77 ]', & ' >shape= 5 6 ,rank= 2 ,size= 30', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o ALL(3) - Determines if all the values are true', & '', & ' o ANY(3) - Determines if any of the values in the logical array are true.', & '', & ' o COUNT(3) - Count true values in an array', & '', & ' o MAXVAL(3) - Determines the maximum value in an array', & '', & ' o MINVAL(3) - Minimum value of an array', & '', & ' o PRODUCT(3) - Product of array elements', & '', & ' o MERGE(3) - Merge variables', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 sum(3fortran)', & ''] shortname="sum" call process() case('194','system_clock') textblock=[character(len=256) :: & '', & 'system_clock(3fortran) system_clock(3fortran)', & '', & '', & '', & 'NAME', & ' SYSTEM_CLOCK(3) - [SYSTEM:TIME] Query system clock', & '', & '', & 'SYNOPSIS', & ' call system_clock([count] [,count_rate] [,count_max] )', & '', & ' subroutine system_clock(count, count_rate, count_max)', & '', & ' integer(kind=**),intent(out),optional :: count', & ' type(TYPE(kind=**)),intent(out),optional :: count_rate', & ' integer(kind=**),intent(out),optional :: count_max', & '', & '', & 'CHARACTERISTICS', & ' o COUNT is an integer scalar', & '', & ' o COUNT_RATE is an integer or real scalar', & '', & ' o COUNT_MAX is an integer scalar', & '', & 'DESCRIPTION', & ' SYSTEM_CLOCK(3) lets you measure durations of time with the precision of the', & ' smallest time increment generally available on a system by returning', & ' processor-dependent values based on the current value of the processor', & ' clock.', & '', & ' SYSTEM_CLOCK is typically used to measure short time intervals (system', & ' clocks may be 24-hour clocks or measure processor clock ticks since boot,', & ' for example). It is most often used for measuring or tracking the time spent', & ' in code blocks in lieu of using profiling tools.', & '', & ' COUNT_RATE and COUNT_MAX are assumed constant (even though CPU rates can', & ' vary on a single platform).', & '', & ' Whether an image has no clock, has a single clock of its own, or shares a', & ' clock with another image, is processor dependent.', & '', & ' If there is no clock, or querying the clock fails, COUNT is set to', & ' -HUGE(COUNT), and COUNT_RATE and COUNT_MAX are set to zero.', & '', & ' The accuracy of the measurements may depend on the kind of the arguments!', & '', & ' Timing-related procedures are obviously processor and system-dependent.', & ' More specific information may generally be found in compiler-specific', & ' documentation.', & '', & 'OPTIONS', & ' o COUNT If there is no clock, the returned value for COUNT is the negative', & ' value -HUGE(COUNT).', & '', & ' Otherwise, the CLOCK value is incremented by one for each clock count', & ' until the value COUNT_MAX is reached and is then reset to zero at the', & ' next count. CLOCK therefore is a modulo value that lies in the range 0 TO', & ' COUNT_MAX.', & '', & ' o COUNT_RATE : is assigned a processor-dependent approximation to the', & ' number of processor clock counts per second, or zero if there is no', & ' clock. COUNT_RATE is system dependent and can vary depending on the kind', & ' of the arguments. Generally, a large real may generate a more precise', & ' interval.', & '', & ' o COUNT_MAX : is assigned the maximum value that COUNT can have, or zero if', & ' there is no clock.', & '', & 'EXAMPLES', & ' If the processor clock is a 24-hour clock that registers time at', & ' approximately 18.20648193 ticks per second, at 11:30 A.M. the reference', & '', & ' call system_clock (count = c, count_rate = r, count_max = m)', & '', & ' defines', & '', & ' C = (11*3600+30*60)*18.20648193 = 753748,', & ' R = 18.20648193, and', & ' M = 24*3600*18.20648193-1 = 1573039.', & '', & ' Sample program:', & '', & ' program demo_system_clock', & ' use, intrinsic :: iso_fortran_env, only: wp => real64, int32, int64', & ' implicit none', & ' character(len=*), parameter :: g = ''(1x,*(g0,1x))''', & '', & ' integer(kind=int64) :: count64, count_rate64, count_max64', & ' integer(kind=int64) :: start64, finish64', & '', & ' integer(kind=int32) :: count32, count_rate32, count_max32', & ' integer(kind=int32) :: start32, finish32', & '', & ' real(kind=wp) :: time_read', & ' real(kind=wp) :: sum', & ' integer :: i', & '', & ' print g, ''accuracy may vary with argument type!''', & '', & ' print g, ''query all arguments''', & '', & ' call system_clock(count64, count_rate64, count_max64)', & ' print g, ''COUNT_MAX(64bit)='', count_max64', & ' print g, ''COUNT_RATE(64bit)='', count_rate64', & ' print g, ''CURRENT COUNT(64bit)='', count64', & '', & ' call system_clock(count32, count_rate32, count_max32)', & ' print g, ''COUNT_MAX(32bit)='', count_max32', & ' print g, ''COUNT_RATE(32bit)='', count_rate32', & ' print g, ''CURRENT COUNT(32bit)='', count32', & '', & ' print g, ''time some computation''', & ' call system_clock(start64)', & '', & ' ! some code to time', & ' sum = 0.0_wp', & ' do i = -0, huge(0) - 1', & ' sum = sum + sqrt(real(i))', & ' end do', & ' print g, ''SUM='', sum', & '', & ' call system_clock(finish64)', & '', & ' time_read = (finish64 - start64)/real(count_rate64, wp)', & ' write (*, ''(1x,a,1x,g0,1x,a)'') ''time : '', time_read, '' seconds''', & '', & ' end program demo_system_clock', & '', & ' Results:', & '', & ' > accuracy may vary with argument type!', & ' > query all arguments', & ' > COUNT_MAX(64bit)= 9223372036854775807', & ' > COUNT_RATE(64bit)= 1000000000', & ' > CURRENT COUNT(64bit)= 1105422387865806', & ' > COUNT_MAX(32bit)= 2147483647', & ' > COUNT_RATE(32bit)= 1000', & ' > CURRENT COUNT(32bit)= 1105422387', & ' > time some computation', & ' > SUM= 66344288183024.266', & ' > time : 6.1341038460000004 seconds', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DATE_AND_TIME(3), CPU_TIME(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 system_clock(3fortran)', & ''] shortname="system_clock" call process() case('195','tan') textblock=[character(len=256) :: & '', & 'tan(3fortran) tan(3fortran)', & '', & '', & '', & 'NAME', & ' TAN(3) - [MATHEMATICS:TRIGONOMETRIC] Tangent function', & '', & '', & 'SYNOPSIS', & ' result = tan(x)', & '', & ' elemental TYPE(kind=KIND) function tan(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o the TYPE of X may be real or complex of any supported kind', & '', & ' o The returned value will be of the same type and kind as the argument X.', & '', & 'DESCRIPTION', & ' TAN(3) computes the tangent of X.', & '', & 'OPTIONS', & ' o X : The angle in radians to compute the tangent of for real input. If X', & ' is of type complex, its real part is regarded as a value in radians.', & '', & 'RESULT', & ' The return value is the tangent of the value X.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_tan', & ' use, intrinsic :: iso_fortran_env, only : real_kinds, &', & ' & real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 0.165_real64', & ' write(*,*)x, tan(x)', & ' end program demo_tan', & '', & ' Results:', & '', & ' 0.16500000000000001 0.16651386310913616', & '', & '', & 'STANDARD', & ' FORTRAN 77 . For a complex argument, Fortran 2008 .', & '', & 'SEE ALSO', & ' ATAN(3), ATAN2(3), COS(3), SIN(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 tan(3fortran)', & ''] shortname="tan" call process() case('196','tanh') textblock=[character(len=256) :: & '', & 'tanh(3fortran) tanh(3fortran)', & '', & '', & '', & 'NAME', & ' TANH(3) - [MATHEMATICS:TRIGONOMETRIC] Hyperbolic tangent function', & '', & '', & 'SYNOPSIS', & ' result = tanh(x)', & '', & ' elemental TYPE(kind=KIND) function tanh(x)', & '', & ' TYPE(kind=KIND),intent(in) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be real or complex and any associated kind supported by the', & ' processor.', & '', & ' o The returned value will be of the same type and kind as the argument.', & '', & 'DESCRIPTION', & ' TANH(3) computes the hyperbolic tangent of X.', & '', & 'OPTIONS', & ' o X : The value to compute the Hyperbolic tangent of.', & '', & 'RESULT', & ' Returns the hyperbolic tangent of X.', & '', & ' If X is complex, the imaginary part of the result is regarded as a radian', & ' value.', & '', & ' If X is real, the return value lies in the range', & '', & ' -1 <= tanh(x) <= 1.', & '', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_tanh', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & real_kinds, real32, real64, real128', & ' implicit none', & ' real(kind=real64) :: x = 2.1_real64', & ' write(*,*)x, tanh(x)', & ' end program demo_tanh', & '', & ' Results:', & '', & ' 2.1000000000000001 0.97045193661345386', & '', & '', & 'STANDARD', & ' FORTRAN 77 , for a complex argument Fortran 2008', & '', & 'SEE ALSO', & ' ATANH(3)', & '', & 'RESOURCES', & ' o Wikipedia:hyperbolic functions', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 tanh(3fortran)', & ''] shortname="tanh" call process() case('197','this_image') textblock=[character(len=256) :: & '', & 'this_image(3fortran) this_image(3fortran)', & '', & '', & '', & 'NAME', & ' THIS_IMAGE(3) - [COLLECTIVE] Cosubscript index of this image', & '', & '', & 'SYNOPSIS', & ' result = this_image() | = this_image(distance) | = this_image(coarray,dim)', & '', & ' integer function this_image( distance ,coarray, dim )', & '', & ' type(TYPE(kind=**)),optional :: coarray[*]', & ' integer,intent(in),optional :: distance', & ' integer,intent(in),optional :: dim', & '', & '', & 'CHARACTERISTICS', & ' o a kind designated as ** may be any supported kind for the type', & '', & ' o COARRAY can be of any type. If DIM is present it is required.', & '', & ' o DISTANCE is not permitted together with COARRAY', & '', & ' o if DIM if present, coarray is required.', & '', & 'DESCRIPTION', & ' THIS_IMAGE(3) returns the cosubscript for this image.', & '', & 'OPTIONS', & ' o DISTANCE : Nonnegative scalar integer (not permitted together with', & ' COARRAY).', & '', & ' o COARRAY : if DIM present, required).', & '', & ' o DIM : If present, DIM shall be between one and the corank of COARRAY.', & '', & 'RESULT', & ' Default integer. If COARRAY is not present, it is scalar; if DISTANCE is not', & ' present or has value 0, its value is the image index on the invoking image', & ' for the current team, for values smaller or equal distance to the initial', & ' team, it returns the image index on the ancestor team which has a distance', & ' of DISTANCE from the invoking team. If DISTANCE is larger than the distance', & ' to the initial team, the image index of the initial team is returned.', & ' Otherwise when the COARRAY is present, if DIM is not present, a rank-1 array', & ' with corank elements is returned, containing the cosubscripts for COARRAY', & ' specifying the invoking image. If DIM is present, a scalar is returned, with', & ' the value of the DIM element of THIS_IMAGE(COARRAY).', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_this_image', & ' implicit none', & ' integer :: value[*]', & ' integer :: i', & ' value = this_image()', & ' sync all', & ' if (this_image() == 1) then', & ' do i = 1, num_images()', & ' write(*,''(2(a,i0))'') ''value['', i, ''] is '', value[i]', & ' end do', & ' endif', & ' end program demo_this_image', & '', & ' Results:', & '', & ' value[1] is 1', & '', & '', & 'STANDARD', & ' Fortran 2008. With DISTANCE argument, TS 18508', & '', & 'SEE ALSO', & ' NUM_IMAGES(3), IMAGE_INDEX(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 this_image(3fortran)', & ''] shortname="this_image" call process() case('198','tiny') textblock=[character(len=256) :: & '', & 'tiny(3fortran) tiny(3fortran)', & '', & '', & '', & 'NAME', & ' TINY(3) - [NUMERIC MODEL] Smallest positive number of a real kind', & '', & '', & 'SYNOPSIS', & ' result = tiny(x)', & '', & ' real(kind=KIND) function tiny(x)', & '', & ' real(kind=KIND) :: x', & '', & '', & 'CHARACTERISTICS', & ' o X may be any real scalar or array', & '', & ' o the result has the same type and kind as X', & '', & 'DESCRIPTION', & ' TINY(3) returns the smallest positive (non zero) number of the type and kind', & ' of X.', & '', & ' For real X', & '', & ' result = 2.0**(minexponent(x)-1)', & '', & '', & 'OPTIONS', & ' o X : The value whose kind is used to determine the model type to query', & '', & 'RESULT', & ' The smallest positive value for the real type of the specified kind.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_tiny', & ' implicit none', & ' print *, ''default real is from'', tiny(0.0), ''to'',huge(0.0)', & ' print *, ''doubleprecision is from '', tiny(0.0d0), ''to'',huge(0.0d0)', & ' end program demo_tiny', & '', & ' Results:', & '', & ' default real is from 1.17549435E-38 to 3.40282347E+38', & ' doubleprecision is from 2.2250738585072014E-308 to', & ' 1.7976931348623157E+308', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' DIGITS(3), EPSILON(3), EXPONENT(3), FRACTION(3), HUGE(3), MAXEXPONENT(3),', & ' MINEXPONENT(3), NEAREST(3), PRECISION(3), RADIX(3), RANGE(3), RRSPACING(3),', & ' SCALE(3), SET_EXPONENT(3), SPACING(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 tiny(3fortran)', & ''] shortname="tiny" call process() case('199','trailz') textblock=[character(len=256) :: & '', & 'trailz(3fortran) trailz(3fortran)', & '', & '', & '', & 'NAME', & ' TRAILZ(3) - [BIT:COUNT] Number of trailing zero bits of an integer', & '', & '', & 'SYNOPSIS', & ' result = trailz(i)', & '', & ' elemental integer function trailz(i)', & '', & ' integer(kind=**),intent(in) :: i', & '', & '', & 'CHARACTERISTICS', & ' o I is an integer of any kind.', & '', & ' o the result is an integer of default kind', & '', & 'DESCRIPTION', & ' TRAILZ(3) returns the number of trailing zero bits of an integer value.', & '', & 'OPTIONS', & ' o I : the value to count trailing zero bits in', & '', & 'RESULT', & ' The number of trailing rightmost zero bits in an integer value after the', & ' last non-zero bit.', & '', & ' > right-most non-zero bit', & ' > V', & ' > |0|0|0|1|1|1|0|1|0|0|0|0|0|0|', & ' > ^ |___________| trailing zero bits', & ' > bit_size(i)', & '', & ' If all the bits of I are zero, the result is the size of the input value in', & ' bits, ie. BIT_SIZE(I).', & '', & ' The result may also be seen as the position of the rightmost 1 bit in I,', & ' starting with the rightmost bit being zero and counting to the left.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_trailz', & '', & ' ! some common integer kinds', & ' use, intrinsic :: iso_fortran_env, only : &', & ' & integer_kinds, int8, int16, int32, int64', & '', & ' implicit none', & '', & ' ! a handy format', & ' character(len=*),parameter :: &', & ' & show = ''(1x,"value=",i4,", value(bits)=",b32.32,1x,", trailz=",i3)''', & '', & ' integer(kind=int64) :: bigi', & ' ! basics', & ' write(*,*)''Note default integer is'',bit_size(0),''bits''', & ' print show, -1, -1, trailz(-1)', & ' print show, 0, 0, trailz(0)', & ' print show, 1, 1, trailz(1)', & ' print show, 96, 96, trailz(96)', & ' ! elemental', & ' print *, ''elemental and any integer kind:''', & ' bigi=2**5', & ' write(*,*) trailz( [ bigi, bigi*256, bigi/2 ] )', & ' write(*,''(1x,b64.64)'')[ bigi, bigi*256, bigi/2 ]', & '', & ' end program demo_trailz', & '', & ' Results:', & '', & ' Note default integer is 32 bits', & ' value= -1, value(bits)=11111111111111111111111111111111 , trailz= 0', & ' value= 0, value(bits)=00000000000000000000000000000000 , trailz= 32', & ' value= 1, value(bits)=00000000000000000000000000000001 , trailz= 0', & ' value= 96, value(bits)=00000000000000000000000001100000 , trailz= 5', & ' elemental and any integer kind:', & ' 5 13 4', & ' 0000000000000000000000000000000000000000000000000000000000100000', & ' 0000000000000000000000000000000000000000000000000010000000000000', & ' 0000000000000000000000000000000000000000000000000000000000010000', & '', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' BIT_SIZE(3), POPCNT(3), POPPAR(3), LEADZ(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 trailz(3fortran)', & ''] shortname="trailz" call process() case('200','transfer') textblock=[character(len=256) :: & '', & 'transfer(3fortran) transfer(3fortran)', & '', & '', & '', & 'NAME', & ' TRANSFER(3) - [TYPE:MOLD] Transfer bit patterns', & '', & '', & 'SYNOPSIS', & ' result = transfer(source, mold [,size] )', & '', & ' type(TYPE(kind=KIND)) function transfer(source,mold,size)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: source(..)', & ' type(TYPE(kind=KIND)),intent(in) :: mold(..)', & ' integer(kind=**),intent(in),optional :: size', & '', & '', & 'CHARACTERISTICS', & ' o SOURCE shall be a scalar or an array of any type.', & '', & ' o MOLD shall be a scalar or an array of any type.', & '', & ' o SIZE shall be a scalar of type integer.', & '', & ' o RESULT has the same type as MOLD', & '', & 'DESCRIPTION', & ' TRANSFER(3) copies the bitwise representation of SOURCE in memory into a', & ' variable or array of the same type and type parameters as MOLD.', & '', & ' This is approximately equivalent to the C concept of "casting" one type to', & ' another.', & '', & 'OPTIONS', & ' o SOURCE : Holds the bit pattern to be copied', & '', & ' o MOLD : the type of MOLD is used to define the type of the returned value.', & ' In addition, if it is an array the returned value is a one-dimensional', & ' array. If it is a scalar the returned value is a scalar.', & '', & ' o SIZE : If SIZE is present, the result is a one-dimensional array of', & ' length SIZE.', & '', & ' If SIZE is absent but MOLD is an array (of any size or shape), the result is', & ' a one-dimensional array of the minimum length needed to contain the entirety', & ' of the bitwise representation of SOURCE.', & '', & ' If SIZE is absent and MOLD is a scalar, the result is a scalar.', & '', & 'RESULT', & ' The result has the bit level representation of SOURCE.', & '', & ' If the bitwise representation of the result is longer than that of SOURCE,', & ' then the leading bits of the result correspond to those of SOURCE but any', & ' trailing bits are filled arbitrarily.', & '', & ' When the resulting bit representation does not correspond to a valid', & ' representation of a variable of the same type as MOLD, the results are', & ' undefined, and subsequent operations on the result cannot be guaranteed to', & ' produce sensible behavior. For example, it is possible to create logical', & ' variables for which VAR and .not. var both appear to be true.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_transfer', & ' use,intrinsic :: iso_fortran_env, only : int32, real32', & ' integer(kind=int32) :: i = 2143289344', & ' real(kind=real32) :: x', & ' character(len=10) :: string', & ' character(len=1) :: chars(10)', & ' x=transfer(i, 1.0) ! prints "nan" on i686', & ' ! the bit patterns are the same', & ' write(*,''(b0,1x,g0)'')x,x ! create a NaN', & ' write(*,''(b0,1x,g0)'')i,i', & '', & ' ! a string to an array of characters', & ' string=''abcdefghij''', & ' chars=transfer(string,chars)', & ' write(*,''(*("[",a,"]":,1x))'')string', & ' write(*,''(*("[",a,"]":,1x))'')chars', & ' end program demo_transfer', & '', & ' Results:', & '', & ' 1111111110000000000000000000000 NaN', & ' 1111111110000000000000000000000 2143289344', & ' [abcdefghij]', & ' [a] [b] [c] [d] [e] [f] [g] [h] [i] [j]', & '', & '', & 'COMMENTS', & ' Joe Krahn: Fortran uses MOLDING rather than CASTING.', & '', & ' Casting, as in C, is an in-place reinterpretation. A cast is a device that', & ' is built around an object to change its shape.', & '', & ' Fortran TRANSFER(3) reinterprets data out-of-place. It can be considered', & ' MOLDING rather than casting. A MOLD is a device that confers a shape onto an', & ' object placed into it.', & '', & ' The advantage of molding is that data is always valid in the context of the', & ' variable that holds it. For many cases, a decent compiler should optimize', & ' TRANSFER(3) into a simple assignment.', & '', & ' There are disadvantages of this approach. It is problematic to define a', & ' union of data types because you must know the largest data object, which can', & ' vary by compiler or compile options. In many cases, an EQUIVALENCE would be', & ' far more effective, but Fortran Standards committees seem oblivious to the', & ' benefits of EQUIVALENCE when used sparingly.', & '', & 'STANDARD', & ' Fortran 90', & '', & 'SEE ALSO', & ' ****(3)', & '', & ' fortran-lang intrinsic descriptions', & '', & '', & '', & ' March 23, 2024 transfer(3fortran)', & ''] shortname="transfer" call process() case('201','transpose') textblock=[character(len=256) :: & '', & 'transpose(3fortran) transpose(3fortran)', & '', & '', & '', & 'NAME', & ' TRANSPOSE(3) - [ARRAY:MANIPULATION] Transpose an array of rank two', & '', & '', & 'SYNOPSIS', & ' result = transpose(matrix)', & '', & ' function transpose(matrix)', & '', & ' type(TYPE(kind=KIND)) :: transpose(N,M)', & ' type(TYPE(kind=KIND)),intent(in) :: matrix(M,N)', & '', & '', & 'CHARACTERISTICS', & ' o MATRIX is an array of any type with a rank of two.', & '', & ' o The result will be the same type and kind as MATRIX and the reversed', & ' shape of the input array', & '', & 'DESCRIPTION', & ' TRANSPOSE(3) transposes an array of rank two.', & '', & ' An array is transposed by interchanging the rows and columns of the given', & ' matrix. That is, element (i,j) of the result has the value of element (j,i)', & ' of the input for all (i,j).', & '', & 'OPTIONS', & ' o MATRIX : The array to transpose', & '', & 'RESULT', & ' The transpose of the input array. The result has the same type as MATRIX,', & ' and has shape [ m, n ] if MATRIX has shape [ n, m ].', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_transpose', & ' implicit none', & ' integer,save :: xx(3,5)= reshape([&', & ' 1, 2, 3, 4, 5, &', & ' 10, 20, 30, 40, 50, &', & ' 11, 22, 33, 44, -1055 &', & ' ],shape(xx),order=[2,1])', & '', & ' call print_matrix_int(''xx array:'',xx)', & ' call print_matrix_int(''xx array transposed:'',transpose(xx))', & '', & ' contains', & '', & ' subroutine print_matrix_int(title,arr)', & ' ! print small 2d integer arrays in row-column format', & ' implicit none', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: arr(:,:)', & ' integer :: i', & ' character(len=:),allocatable :: biggest', & ' write(*,*)trim(title) ! print title', & ' biggest='' '' ! make buffer to write integer into', & ' ! find how many characters to use for integers', & ' write(biggest,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2', & ' ! use this format to write a row', & ' biggest=''(" > [",*(i''//trim(biggest)//'':,","))''', & ' ! print one row of array at a time', & ' do i=1,size(arr,dim=1)', & ' write(*,fmt=biggest,advance=''no'')arr(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' end subroutine print_matrix_int', & '', & ' end program demo_transpose', & '', & ' Results:', & '', & ' xx array:', & ' > [ 1, 2, 3, 4, 5 ]', & ' > [ 10, 20, 30, 40, 50 ]', & ' > [ 11, 22, 33, 44, -1055 ]', & ' xx array transposed:', & ' > [ 1, 10, 11 ]', & ' > [ 2, 20, 22 ]', & ' > [ 3, 30, 33 ]', & ' > [ 4, 40, 44 ]', & ' > [ 5, 50, -1055 ]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' o MERGE(3) - Merge variables', & '', & ' o PACK(3) - Pack an array into an array of rank one', & '', & ' o SPREAD(3) - Add a dimension and replicate data', & '', & ' o UNPACK(3) - Scatter the elements of a vector', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 transpose(3fortran)', & ''] shortname="transpose" call process() case('202','trim') textblock=[character(len=256) :: & '', & 'trim(3fortran) trim(3fortran)', & '', & '', & '', & 'NAME', & ' TRIM(3) - [CHARACTER:WHITESPACE] Remove trailing blank characters from a', & ' string', & '', & '', & 'SYNOPSIS', & ' result = trim(string)', & '', & ' character(len=:,kind=KIND) function trim(string)', & '', & ' character(len=*,kind=KIND),intent(in) :: string', & '', & '', & 'CHARACTERISTICS', & ' o KIND can be any kind supported for the character type.', & '', & ' o The result has the same type and kind as the input argument STRING.', & '', & 'DESCRIPTION', & ' TRIM(3) removes trailing blank characters from a string.', & '', & 'OPTIONS', & ' o STRING : A string to trim', & '', & 'RESULT', & ' The result is the same as STRING except trailing blanks are removed.', & '', & ' If STRING is composed entirely of blanks or has zero length, the result has', & ' zero length.', & '', & 'EXAMPLES', & ' Sample program:', & '', & ' program demo_trim', & ' implicit none', & ' character(len=:), allocatable :: str, strs(:)', & ' character(len=*),parameter :: brackets=''( *("[",a,"]":,1x) )''', & ' integer :: i', & '', & ' str='' trailing ''', & ' print brackets, str,trim(str) ! trims it', & '', & ' str='' leading''', & ' print brackets, str,trim(str) ! no effect', & '', & ' str='' ''', & ' print brackets, str,trim(str) ! becomes zero length', & ' print *, len(str), len(trim('' ''))', & '', & ' ! array elements are all the same length, so you often', & ' ! want to print them', & ' strs=[character(len=10) :: "Z"," a b c","ABC",""]', & '', & ' write(*,*)''untrimmed:''', & ' ! everything prints as ten characters; nice for neat columns', & ' print brackets, (strs(i), i=1,size(strs))', & ' print brackets, (strs(i), i=size(strs),1,-1)', & ' write(*,*)''trimmed:''', & ' ! everything prints trimmed', & ' print brackets, (trim(strs(i)), i=1,size(strs))', & ' print brackets, (trim(strs(i)), i=size(strs),1,-1)', & '', & ' end program demo_trim', & '', & ' Results:', & '', & ' > [ trailing ] [ trailing]', & ' > [ leading] [ leading]', & ' > [ ] []', & ' > 12 0', & ' > untrimmed:', & ' > [Z ] [ a b c ] [ABC ] [ ]', & ' > [ ] [ABC ] [ a b c ] [Z ]', & ' > trimmed:', & ' > [Z] [ a b c] [ABC] []', & ' > [] [ABC] [ a b c] [Z]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3), VERIFY(3)', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 trim(3fortran)', & ''] shortname="trim" call process() case('203','ubound') textblock=[character(len=256) :: & '', & 'ubound(3fortran) ubound(3fortran)', & '', & '', & '', & 'NAME', & ' UBOUND(3) - [ARRAY:INQUIRY] Upper dimension bounds of an array', & '', & '', & 'SYNOPSIS', & ' result = ubound(array [,dim] [,kind] )', & '', & ' elemental TYPE(kind=KIND) function ubound(array,dim,kind)', & '', & ' TYPE(kind=KIND),intent(in) :: array', & ' integer(kind=**),intent(in),optional :: dim', & ' integer(kind=**),intent(in),optional :: kind', & '', & '', & 'CHARACTERISTICS', & ' o ARRAY shall be assumed-rank or an array, of any type. It cannot be an', & ' unallocated allocatable array or a pointer that is not associated.', & '', & ' o DIM shall be a scalar integer. The corresponding actual argument shall', & ' not be an optional dummy argument, a disassociated pointer, or an', & ' unallocated allocatable.', & '', & ' o KIND an integer initialization expression indicating the kind parameter', & ' of the result.', & '', & ' o The return value is of type integer and of kind KIND. If KIND is absent,', & ' the return value is of default integer kind. The result is scalar if DIM', & ' is present; otherwise, the result is an array of rank one and size n,', & ' where n is the rank of ARRAY.', & '', & ' o a kind designated as ** may be any supported kind for the type', & '', & 'DESCRIPTION', & ' UBOUND(3) returns the upper bounds of an array, or a single upper bound', & ' along the DIM dimension.', & '', & 'OPTIONS', & ' o ARRAY : The assumed-rank or array of any type whose upper bounds are to', & ' be determined. If allocatable it must be allocated; if a pointer it must', & ' be associated. If an assumed-size array, DIM must be present.', & '', & ' o DIM : a specific dimension of ARRAY to determine the bounds of. If DIM is', & ' absent, the result is an array of the upper bounds of ARRAY. DIM is', & ' required if ARRAY is an assumed-size array, and in that case must be less', & ' than or equal to the rank of ARRAY.', & '', & ' o KIND : indicates the kind parameter of the result. If absent, an integer', & ' of the default kind is returned.', & '', & 'RESULT', & ' The return value is of type integer and of kind KIND. If KIND is absent, the', & ' return value is of default integer kind.', & '', & ' If DIM is absent, the result is an array of the upper bounds of each', & ' dimension of the ARRAY.', & '', & ' If DIM is present, the result is a scalar corresponding to the upper bound', & ' of the array along that dimension.', & '', & ' If ARRAY is an expression rather than a whole array or array structure', & ' component, or if it has a zero extent along the relevant dimension, the', & ' upper bound is taken to be the number of elements along the relevant', & ' dimension.', & '', & ' NOTE1 If ARRAY is assumed-rank and has rank zero, DIM cannot be present', & ' since it cannot satisfy the requirement 1 <= DIM <= 0.', & '', & 'EXAMPLES', & ' Note this function should not be used on assumed-size arrays or in any', & ' function without an explicit interface. Errors can occur if there is no', & ' interface defined.', & '', & ' Sample program', & '', & ' ! program demo_ubound', & ' module m2_bounds', & ' implicit none', & '', & ' contains', & '', & ' subroutine msub(arr)', & ' !!integer,intent(in) :: arr(*) ! cannot be assumed-size array', & ' integer,intent(in) :: arr(:)', & ' write(*,*)''MSUB: LOWER='',lbound(arr),''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' end subroutine msub', & '', & ' end module m2_bounds', & ' !', & ' program demo_ubound', & ' use m2_bounds, only : msub', & ' implicit none', & ' interface', & ' subroutine esub(arr)', & ' integer,intent(in) :: arr(:)', & ' end subroutine esub', & ' end interface', & ' integer :: arr(-10:10)', & ' write(*,*)''MAIN: LOWER='',lbound(arr),''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' call csub()', & ' call msub(arr)', & ' call esub(arr)', & ' contains', & ' subroutine csub', & ' write(*,*)''CSUB: LOWER='',lbound(arr),''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' end subroutine csub', & '', & ' end', & '', & ' subroutine esub(arr)', & ' implicit none', & ' integer,intent(in) :: arr(:)', & ' ! WARNING: IF CALLED WITHOUT AN EXPLICIT INTERFACE', & ' ! THIS WILL GIVE UNDEFINED ANSWERS (like 0,0,0)', & ' write(*,*)''ESUB: LOWER='',lbound(arr),''UPPER='',ubound(arr), &', & ' & ''SIZE='',size(arr)', & ' end subroutine esub', & ' !end program demo_ubound', & '', & ' Results:', & '', & ' > MAIN: LOWER= -10 UPPER= 10 SIZE= 21', & ' > CSUB: LOWER= -10 UPPER= 10 SIZE= 21', & ' > MSUB: LOWER= 1 UPPER= 21 SIZE= 21', & ' > ESUB: LOWER= 1 UPPER= 21 SIZE= 21', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument Fortran 2003', & '', & 'SEE ALSO', & ' Array inquiry:', & '', & ' o SIZE(3) - Determine the size of an array', & '', & ' o RANK(3) - Rank of a data object', & '', & ' o SHAPE(3) - Determine the shape of an array', & '', & ' o LBOUND(3) - Lower dimension bounds of an array', & '', & ' CO_UBOUND(3), CO_LBOUND(3)', & '', & ' State Inquiry:', & '', & ' o ALLOCATED(3) - Status of an allocatable entity', & '', & ' o IS_CONTIGUOUS(3) - Test if object is contiguous', & '', & ' Kind Inquiry:', & '', & ' o KIND(3) - Kind of an entity', & '', & ' Bit Inquiry:', & '', & ' o STORAGE_SIZE(3) - Storage size in bits', & '', & ' o BIT_SIZE(3) - Bit size inquiry function', & '', & ' o BTEST(3) - Tests a bit of an integer value.', & '', & ' o LBOUND(3),', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 ubound(3fortran)', & ''] shortname="ubound" call process() case('204','ucobound') textblock=[character(len=256) :: & '', & 'ucobound(3fortran) ucobound(3fortran)', & '', & '', & '', & 'NAME', & ' UCOBOUND(3) - [COLLECTIVE] Upper codimension bounds of an array', & '', & '', & 'SYNOPSIS', & ' result = ucobound(coarray [,dim] [,kind] )', & '', & 'CHARACTERISTICS', & 'DESCRIPTION', & ' UCOBOUND(3) returns the upper cobounds of a coarray, or a single upper', & ' cobound along the DIM codimension.', & '', & 'OPTIONS', & ' o ARRAY : Shall be an coarray, of any type.', & '', & ' o DIM : (Optional) Shall be a scalar integer.', & '', & ' o KIND : (Optional) An integer initialization expression indicating the', & ' kind parameter of the result.', & '', & 'RESULT', & ' The return value is of type integer and of kind KIND. If KIND is absent, the', & ' return value is of default integer kind. If DIM is absent, the result is an', & ' array of the lower cobounds of COARRAY. If DIM is present, the result is a', & ' scalar corresponding to the lower cobound of the array along that', & ' codimension.', & '', & 'STANDARD', & ' Fortran 2008', & '', & 'SEE ALSO', & ' LCOBOUND(3), LBOUND(3), UBOUND(3)', & '', & '', & '', & ' March 23, 2024 ucobound(3fortran)', & ''] shortname="ucobound" call process() case('205','unpack') textblock=[character(len=256) :: & '', & 'unpack(3fortran) unpack(3fortran)', & '', & '', & '', & 'NAME', & ' UNPACK(3) - [ARRAY:CONSTRUCTION] Scatter the elements of a vector into an', & ' array using a mask', & '', & '', & 'SYNOPSIS', & ' result = unpack(vector, mask, field)', & '', & ' type(TYPE(kind=KIND)) unpack(vector, mask, field)', & '', & ' type(TYPE(kind=KIND)),intent(in) :: vector(:)', & ' logical,intent(in) :: mask(..)', & ' type(TYPE(kind=KIND)),intent(in) :: field(..)', & '', & '', & 'CHARACTERISTICS', & ' o VECTOR is a rank-one array of any type', & '', & ' o MASK is a logical array', & '', & ' o FIELD is the same type and type parameters as VECTOR conformable with', & ' MASK.', & '', & ' o The result is an array of the same type and type parameters as VECTOR and', & ' the same shape as MASK.', & '', & 'DESCRIPTION', & ' UNPACK(3) scatters the elements of VECTOR into a copy of an array FIELD of', & ' any rank using .true. values from MASK in array element order to specify', & ' placement of the VECTOR values.', & '', & ' So a copy of FIELD is generated with select elements replaced with values', & ' from VECTOR. This allows for complex replacement patterns that would be', & ' difficult when using array syntax or multiple assignment statements,', & ' particularly when the replacements are conditional.', & '', & 'OPTIONS', & ' o VECTOR : New values to place into specified locations in FIELD. It shall', & ' have at least as many elements as MASK has .true. values.', & '', & ' o MASK : Shall be an array that specifies which values in FIELD are to be', & ' replaced with values from VECTOR.', & '', & ' o FIELD : The input array to be altered.', & '', & 'RESULT', & ' The element of the result that corresponds to the ith true element of MASK,', & ' in array element order, has the value VECTOR(I) for i = 1, 2, . . ., t,', & ' where t is the number of true values in MASK. Each other element has a value', & ' equal to *field if *field is scalar or to the corresponding element of', & ' *field if it is an array.', & '', & ' The resulting array corresponds to FIELD with .true. elements of MASK', & ' replaced by values from VECTOR in array element order.', & '', & 'EXAMPLES', & ' Particular values may be "scattered" to particular positions in an array by', & ' using', & '', & ' 1 0 0', & '', & ' If M is the array', & ' 0 1 0 0 0 1', & '', & ' V is the array [1, 2, 3], . T .', & '', & ' and Q is the logical mask', & ' T . . . . T where "T" represents true and "." represents false, then', & ' the result of', & '', & ' UNPACK (V, MASK = Q, FIELD = M) has the value', & '', & ' 1 2 0 1 1 0 0 0 3', & '', & ' and the result of UNPACK (V, MASK = Q, FIELD = 0) has the value', & '', & ' 0 2 0 1 0 0 0 0 3', & '', & ' Sample program:', & '', & ' program demo_unpack', & ' implicit none', & ' logical,parameter :: T=.true., F=.false.', & '', & ' integer :: vector(2) = [1,1]', & '', & ' ! mask and field must conform', & ' integer,parameter :: r=2, c=2', & ' logical :: mask(r,c) = reshape([ T,F,F,T ],[2,2])', & ' integer :: field(r,c) = 0, unity(2,2)', & '', & ' ! basic usage', & ' unity = unpack( vector, mask, field )', & ' call print_matrix_int(''unity='', unity)', & '', & ' ! if FIELD is a scalar it is used to fill all the elements', & ' ! not assigned to by the vector and mask.', & ' call print_matrix_int(''scalar field'', &', & ' & unpack( &', & ' & vector=[ 1, 2, 3, 4 ], &', & ' & mask=reshape([ T,F,T,F,F,F,T,F,T ], [3,3]), &', & ' & field=0) )', & '', & ' contains', & '', & ' subroutine print_matrix_int(title,arr)', & ' ! convenience routine:', & ' ! just prints small integer arrays in row-column format', & ' implicit none', & ' character(len=*),intent(in) :: title', & ' integer,intent(in) :: arr(:,:)', & ' integer :: i', & ' character(len=:),allocatable :: biggest', & '', & ' write(*,*)trim(title)', & ' ! make buffer to write integer into', & ' biggest='' ''', & ' ! find how many characters to use for integers', & ' write(biggest,''(i0)'')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2', & ' ! use this format to write a row', & ' biggest=''(" [",*(i''//trim(biggest)//'':,","))''', & ' ! print one row of array at a time', & ' do i=1,size(arr,dim=1)', & ' write(*,fmt=biggest,advance=''no'')arr(i,:)', & ' write(*,''(" ]")'')', & ' enddo', & ' end subroutine print_matrix_int', & '', & ' end program demo_unpack', & '', & ' Results:', & '', & ' > unity=', & ' > [ 1, 0 ]', & ' > [ 0, 1 ]', & ' > scalar field', & ' > [ 1, 0, 3 ]', & ' > [ 0, 0, 0 ]', & ' > [ 2, 0, 4 ]', & '', & '', & 'STANDARD', & ' Fortran 95', & '', & 'SEE ALSO', & ' MERGE(3), PACK(3), SPREAD(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 unpack(3fortran)', & ''] shortname="unpack" call process() case('206','verify') textblock=[character(len=256) :: & '', & 'verify(3fortran) verify(3fortran)', & '', & '', & '', & 'NAME', & ' VERIFY(3) - [CHARACTER:SEARCH] Position of a character in a string of', & ' characters that does not appear in a given set of characters.', & '', & '', & 'SYNOPSIS', & ' result = verify(string, set [,back] [,kind] )', & '', & ' elemental integer(kind=KIND) function verify(string,set,back,KIND)', & '', & ' character(len=*,kind=**),intent(in) :: string', & ' character(len=*,kind=**),intent(in) :: set', & ' logical,intent(in),optional :: back', & ' integer,intent(in),optional :: KIND', & '', & '', & 'CHARACTERISTICS', & ' o STRING and SET must be of type character and have the same kind for any', & ' individual call, but that can be any supported character kind.', & '', & ' o KIND must be a constant integer initialization expression and a valid', & ' kind for the integer type.', & '', & ' o BACK shall be of type logical.', & '', & ' o the kind of the returned value is the same as KIND if present. Otherwise', & ' a default integer kind is returned.', & '', & 'DESCRIPTION', & ' VERIFY(3) verifies that all the characters in STRING belong to the set of', & ' characters in SET by identifying the position of the first character in the', & ' string that is not in the set.', & '', & ' This makes it easy to verify strings are all uppercase or lowercase, follow', & ' a basic syntax, only contain printable characters, and many of the', & ' conditions tested for with the C routines ISALNUM(3c), ISALPHA(3c),', & ' ISASCII(3c), ISBLANK(3c), ISCNTRL(3c), ISDIGIT(3c), ISGRAPH(3c),', & ' ISLOWER(3c), ISPRINT(3c), ISPUNCT(3c), ISSPACE(3c), ISUPPER(3c), and', & ' ISXDIGIT(3c); but for a string as well as an array of strings.', & '', & 'OPTIONS', & ' o STRING : The string to search in for an unmatched character.', & '', & ' o SET : The set of characters that must be matched.', & '', & ' o BACK : The direction to look for an unmatched character. The left-most', & ' unmatched character position is returned unless BACK is present and', & ' .false., which causes the position of the right-most unmatched character', & ' to be returned instead of the left-most unmatched character.', & '', & ' o KIND : An integer initialization expression indicating the kind parameter', & ' of the result.', & '', & 'RESULT', & ' If all characters of STRING are found in SET, the result is zero.', & '', & ' If STRING is of zero length a zero (0) is always returned.', & '', & ' Otherwise, if an unmatched character is found The position of the first or', & ' last (if BACK is .false.) unmatched character in STRING is returned,', & ' starting with position one on the left end of the string.', & '', & 'EXAMPLES', & ' Sample program I:', & '', & ' program demo_verify', & ' implicit none', & ' ! some useful character sets', & ' character,parameter :: &', & ' & int*(*) = ''1234567890'', &', & ' & low*(*) = ''abcdefghijklmnopqrstuvwxyz'', &', & ' & upp*(*) = ''ABCDEFGHIJKLMNOPQRSTUVWXYZ'', &', & ' & punc*(*) = "!""#$%&''()*+,-./:;<=>?@[\]^_`{|}~", &', & ' & blank*(*) = '' '', &', & ' & tab = char(11), &', & ' & prnt*(*) = int//low//upp//blank//punc', & '', & ' character(len=:),allocatable :: string', & ' integer :: i', & ' print *, ''basics:''', & ' print *, VERIFY (''ABBA'', ''A'') ! has the value 2.', & ' print *, VERIFY (''ABBA'', ''A'', BACK = .TRUE.) ! has the value 3.', & ' print *, VERIFY (''ABBA'', ''AB'') ! has the value 0.', & '', & ' print *,''find first non-uppercase letter''', & ' ! will produce the location of "d", because there is no match in UPP', & ' write(*,*) ''something unmatched'',verify("ABCdEFG", upp)', & '', & ' print *,''if everything is matched return zero''', & ' ! will produce 0 as all letters have a match', & ' write(*,*) ''everything matched'',verify("ffoorrttrraann", "nartrof")', & '', & ' print *,''easily categorize strings as uppercase, lowercase, ...''', & ' ! easy C-like functionality but does entire strings not just characters', & ' write(*,*)''isdigit 123?'',verify("123", int) == 0', & ' write(*,*)''islower abc?'',verify("abc", low) == 0', & ' write(*,*)''isalpha aBc?'',verify("aBc", low//upp) == 0', & ' write(*,*)''isblank aBc dEf?'',verify("aBc dEf", blank//tab ) /= 0', & ' ! check if all printable characters', & ' string="aB;cde,fgHI!Jklmno PQRSTU vwxyz"', & ' write(*,*)''isprint?'',verify(string,prnt) == 0', & ' ! this now has a nonprintable tab character in it', & ' string(10:10)=char(11)', & ' write(*,*)''isprint?'',verify(string,prnt) == 0', & '', & ' print *,''VERIFY(3) is very powerful using expressions as masks''', & ' ! verify(3f) is often used in a logical expression', & ' string=" This is NOT all UPPERCASE "', & ' write(*,*)''all uppercase/spaces?'',verify(string, blank//upp) == 0', & ' string=" This IS all uppercase "', & ' write(*,*) ''string=[''//string//'']''', & ' write(*,*)''all uppercase/spaces?'',verify(string, blank//upp) == 0', & '', & ' ! set and show complex string to be tested', & ' string='' Check this out. Let me know ''', & ' ! show the string being examined', & ' write(*,*) ''string=[''//string//'']''', & ' write(*,*) '' ''//repeat(int,4) ! number line', & '', & ' ! the Fortran functions returns a position just not a logical like C', & ' print *, ''returning a position not just a logical is useful''', & ' ! which can be very useful for parsing strings', & ' write(*,*)''first non-blank character'',verify(string, blank)', & ' write(*,*)''last non-blank character'',verify(string, blank,back=.true.)', & ' write(*,*)''first non-letter non-blank'',verify(string,low//upp//blank)', & '', & ' !VERIFY(3) is elemental so you can check an array of strings in one call', & ' print *, ''elemental''', & ' ! are strings all letters (or blanks)?', & ' write(*,*) ''array of strings'',verify( &', & ' ! strings must all be same length, so force to length 10', & ' & [character(len=10) :: "YES","ok","000","good one","Nope!"], &', & ' & low//upp//blank) == 0', & '', & ' ! rarer, but the set can be an array, not just the strings to test', & ' ! you could do ISPRINT() this (harder) way :>', & ' write(*,*)''isprint?'',.not.all(verify("aBc", [(char(i),i=32,126)])==1)', & ' ! instead of this way', & ' write(*,*)''isprint?'',verify("aBc",prnt) == 0', & '', & ' end program demo_verify', & '', & ' Results:', & '', & ' > basics:', & ' > 2', & ' > 3', & ' > 0', & ' > find first non-uppercase letter', & ' > something unmatched 4', & ' > if everything is matched return zero', & ' > everything matched 0', & ' > easily categorize strings as uppercase, lowercase, ...', & ' > isdigit 123? T', & ' > islower abc? T', & ' > isalpha aBc? T', & ' > isblank aBc dEf? T', & ' > isprint? T', & ' > isprint? F', & ' > VERIFY(3) is very powerful using expressions as masks', & ' > all uppercase/spaces? F', & ' > string=[ This IS all uppercase ]', & ' > all uppercase/spaces? F', & ' > string=[ Check this out. Let me know ]', & ' > 1234567890123456789012345678901234567890', & ' > returning a position not just a logical is useful', & ' > first non-blank character 3', & ' > last non-blank character 29', & ' > first non-letter non-blank 17', & ' > elemental', & ' > array of strings T T F T F', & ' > isprint? T', & ' > isprint? T', & '', & ' Sample program II:', & '', & ' Determine if strings are valid integer representations', & '', & ' program fortran_ints', & ' implicit none', & ' integer :: i', & ' character(len=*),parameter :: ints(*)=[character(len=10) :: &', & ' ''+1 '', &', & ' ''3044848 '', &', & ' ''30.40 '', &', & ' ''September '', &', & ' ''1 2 3'', &', & ' '' -3000 '', &', & ' '' '']', & ' ! show the strings to test', & ' write(*,''("|",*(g0,"|"))'') ints', & ' ! show if strings pass or fail the test done by isint(3f)', & ' write(*,''("|",*(1x,l1,8x,"|"))'') isint(ints)', & '', & ' contains', & '', & ' elemental function isint(line) result (lout)', & ' !', & ' ! determine if string is a valid integer representation', & ' ! ignoring trailing spaces and leading spaces', & ' !', & ' character(len=*),parameter :: digits=''0123456789''', & ' character(len=*),intent(in) :: line', & ' character(len=:),allocatable :: name', & ' logical :: lout', & ' lout=.false.', & ' ! make sure at least two characters long to simplify tests', & ' name=adjustl(line)//'' ''', & ' ! blank string', & ' if( name == '''' )return', & ' ! allow one leading sign', & ' if( verify(name(1:1),''+-'') == 0 ) name=name(2:)', & ' ! was just a sign', & ' if( name == '''' )return', & ' lout=verify(trim(name), digits) == 0', & ' end function isint', & '', & ' end program fortran_ints', & '', & ' Results:', & '', & ' |+1 |3044848 |30.40 |September|1 2 3 | -3000 | |', & ' | T | T | F | F | F | T | F |', & '', & ' Sample program III:', & '', & ' Determine if strings represent valid Fortran symbol names', & '', & ' program fortran_symbol_name', & ' implicit none', & ' integer :: i', & ' character(len=*),parameter :: symbols(*)=[character(len=10) :: &', & ' ''A_ '', &', & ' ''10 '', &', & ' ''September '', &', & ' ''A B'', &', & ' ''_A '', &', & ' '' '']', & '', & ' write(*,''("|",*(g0,"|"))'') symbols', & ' write(*,''("|",*(1x,l1,8x,"|"))'') fortran_name(symbols)', & '', & ' contains', & '', & ' elemental function fortran_name(line) result (lout)', & ' !', & ' ! determine if a string is a valid Fortran name', & ' ! ignoring trailing spaces (but not leading spaces)', & ' !', & ' character(len=*),parameter :: int=''0123456789''', & ' character(len=*),parameter :: lower=''abcdefghijklmnopqrstuvwxyz''', & ' character(len=*),parameter :: upper=''ABCDEFGHIJKLMNOPQRSTUVWXYZ''', & ' character(len=*),parameter :: allowed=upper//lower//int//''_''', & '', & ' character(len=*),intent(in) :: line', & ' character(len=:),allocatable :: name', & ' logical :: lout', & ' name=trim(line)', & ' if(len(name).ne.0)then', & ' ! first character is alphameric', & ' lout = verify(name(1:1), lower//upper) == 0 &', & ' ! other characters are allowed in a symbol name', & ' & .and. verify(name,allowed) == 0 &', & ' ! allowable length', & ' & .and. len(name) <= 63', & ' else', & ' lout = .false.', & ' endif', & ' end function fortran_name', & '', & ' end program fortran_symbol_name', & '', & ' Results:', & '', & ' |A_ |10 |September |A B |_A | |', & ' | T | F | T | F | F | F |', & '', & ' Sample program IV:', & '', & ' check if string is of form NN-HHHHH', & '', & ' program checkform', & ' ! check if string is of form NN-HHHHH', & ' implicit none', & ' character(len=*),parameter :: int=''1234567890''', & ' character(len=*),parameter :: hex=''abcdefABCDEF0123456789''', & ' logical :: lout', & ' character(len=80) :: chars', & '', & ' chars=''32-af43d''', & ' lout=.true.', & '', & ' ! are the first two characters integer characters?', & ' lout = lout.and.(verify(chars(1:2), int) == 0)', & '', & ' ! is the third character a dash?', & ' lout = lout.and.(verify(chars(3:3), ''-'') == 0)', & '', & ' ! is remaining string a valid representation of a hex value?', & ' lout = lout.and.(verify(chars(4:8), hex) == 0)', & '', & ' if(lout)then', & ' write(*,*)trim(chars),'' passed''', & ' else', & ' write(*,*)trim(chars),'' failed''', & ' endif', & ' end program checkform', & '', & ' Results:', & '', & ' 32-af43d passed', & '', & ' Sample program V:', & '', & ' exploring uses of elemental functionality and dusty corners', & '', & ' program more_verify', & ' implicit none', & ' character(len=*),parameter :: &', & ' & int=''0123456789'', &', & ' & low=''abcdefghijklmnopqrstuvwxyz'', &', & ' & upp=''ABCDEFGHIJKLMNOPQRSTUVWXYZ'', &', & ' & blank='' ''', & ' ! note character variables in an array have to be of the same length', & ' character(len=6) :: strings(3)=["Go ","right ","home! "]', & ' character(len=2) :: sets(3)=["do","re","me"]', & '', & ' ! elemental -- you can use arrays for both strings and for sets', & '', & ' ! check each string from right to left for non-letter/non-blank', & ' write(*,*)''last non-letter'',verify(strings,upp//low//blank,back=.true.)', & '', & ' ! even BACK can be an array', & ' ! find last non-uppercase character in "Howdy "', & ' ! and first non-lowercase in "there "', & ' write(*,*) verify(strings(1:2),[upp,low],back=[.true.,.false.])', & '', & ' ! using a null string for a set is not well defined. Avoid it', & ' write(*,*) ''null'',verify("for tran ", "", .true.) ! 8,length of string?', & ' ! probably what you expected', & ' write(*,*) ''blank'',verify("for tran ", " ", .true.) ! 7,found ''n''', & '', & ' ! first character in "Go " not in "do",', & ' ! and first letter in "right " not in "ri"', & ' ! and first letter in "home! " not in "me"', & ' write(*,*) verify(strings,sets)', & '', & ' end program more_verify', & '', & ' Results:', & '', & ' > last non-letter 0 0 5', & ' > 6 6', & ' > null 9', & ' > blank 8', & ' > 1 2 1', & '', & '', & 'STANDARD', & ' Fortran 95 , with KIND argument - Fortran 2003', & '', & 'SEE ALSO', & ' Functions that perform operations on character strings, return lengths of', & ' arguments, and search for certain arguments:', & '', & ' o ELEMENTAL: ADJUSTL(3), ADJUSTR(3), INDEX(3), SCAN(3),', & '', & ' o NONELEMENTAL: LEN_TRIM(3), LEN(3), REPEAT(3), TRIM(3)', & '', & ' fortran-lang intrinsic descriptions (license: MIT) @urbanjost', & '', & '', & '', & ' March 23, 2024 verify(3fortran)', & ''] shortname="verify" call process() case default allocate (character(len=256) :: textblock(0)) end select contains subroutine process() if(present(topic))then if(topic)then textblock=[character(len=len(shortname)) :: shortname] endif endif if(present(prefix))then if(prefix)then do i=1,size(textblock) textblock(i)= shortname//':'//trim(textblock(i)) enddo endif endif if(present(m_help))then if(m_help)then textblock=[character(len=len(textblock)+1) :: ' ',textblock] ! add blank line to put shortname into textblock=' '//textblock ! shift to right by one character textblock(1)=shortname endif endif end subroutine process end function help_intrinsics_one !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine sort_name(lines) !@(#) sort_name(3fp):sort strings(a-z) over specified field using shell sort starting with [ character character(len = *) :: lines(:) character(len = :),allocatable :: ihold integer :: n, igap, i, j, k, jg n = size(lines) if(n.gt.0)then allocate(character(len = len(lines(1))) :: ihold) else ihold = '' endif igap = n INFINITE: do igap = igap/2 if(igap.eq.0) exit INFINITE k = n-igap i = 1 INNER: do j = i INSIDE: do jg = j+igap if( lle( lower(lines(j)), lower(lines(jg)) ) )exit INSIDE ihold = lines(j) lines(j) = lines(jg) lines(jg) = ihold j = j-igap if(j.lt.1) exit INSIDE enddo INSIDE i = i+1 if(i.gt.k) exit INNER enddo INNER enddo INFINITE end subroutine sort_name !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== elemental pure function lower(str) result (string) !@(#) M_strings::lower(3f): Changes a string to lowercase over specified range character(*), intent(In) :: str character(len(str)) :: string integer :: i string = str do i = 1, len_trim(str) ! step thru each letter in the string select case (str(i:i)) case ('A':'Z') string(i:i) = char(iachar(str(i:i))+32) ! change letter to miniscule case default end select end do end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== end module M_intrinsics !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !>>>>> build/dependencies/M_CLI2/src/M_CLI2.F90 !VERSION 1.0 20200115 !VERSION 2.0 20200802 !VERSION 3.0 20201021 LONG:SHORT syntax !VERSION 3.1 20201115 LONG:SHORT:: syntax !VERSION 3.2 20230205 set_mode() !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! M_CLI2(3fm) - [ARGUMENTS::M_CLI2::INTRO] command line argument !! parsing using a prototype command !! (LICENSE:PD) !!##SYNOPSIS !! !! Available procedures and variables: !! !! ! basic procedures !! use M_CLI2, only : set_args, get_args, specified, set_mode !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! ! variables !! use M_CLI2, only : unnamed, remaining, args !! ! working with non-allocatable strings and arrays !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! ! special function for creating subcommands !! use M_CLI2, only : get_subcommand(3f) !! !!##DESCRIPTION !! The M_CLI2 module cracks a Unix-style command line. !! !! Typically one call to SET_ARGS(3f) is made to define the command !! arguments, set default values and parse the command line. Then a call !! is made to the convenience procedures or GET_ARGS(3f) proper for each !! command keyword to obtain the argument values. !! !! Detailed descriptions of each procedure and example programs are !! included. !! !!##EXAMPLE !! !! !! Sample minimal program which may be called in various ways: !! !! mimimal -x 100.3 -y 3.0e4 !! mimimal --xvalue=300 --debug !! mimimal --yvalue 400 !! mimimal -x 10 file1 file2 file3 !! !! Program example: !! !! program minimal !! use M_CLI2, only : set_args, lget, rget, sgets !! implicit none !! real :: x, y !! integer :: i !! character(len=:),allocatable :: filenames(:) !! ! define and crack command line !! call set_args(' --yvalue:y 0.0 --xvalue:x 0.0 --debug F') !! ! get values !! x=rget('xvalue') !! y=rget('yvalue') !! if(lget('debug'))then !! write(*,*)'X=',x !! write(*,*)'Y=',y !! write(*,*)'ATAN2(Y,X)=',atan2(x=x,y=y) !! else !! write(*,*)atan2(x=x,y=y) !! endif !! filenames=sgets() ! sget with no name gets "unnamed" values !! if(size(filenames) > 0)then !! write(*,'(g0)')'filenames:' !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program minimal !! !! Sample program using get_args() and variants !! !! program demo_M_CLI2 !! use M_CLI2, only : set_args, get_args !! use M_CLI2, only : filenames=>unnamed !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! implicit none !! integer :: i !! integer,parameter :: dp=kind(0.0d0) !! ! !! ! Define ARGS !! real :: x, y, z !! logical :: l, lbig !! character(len=40) :: label ! FIXED LENGTH !! real(kind=dp),allocatable :: point(:) !! logical,allocatable :: logicals(:) !! character(len=:),allocatable :: title ! VARIABLE LENGTH !! real :: p(3) ! FIXED SIZE !! logical :: logi(3) ! FIXED SIZE !! ! !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o set a value for all keywords. !! ! o double-quote strings, strings must be at least one space !! ! because adjacent double-quotes designate a double-quote !! ! in the value. !! ! o set all logical values to F !! ! o numeric values support an "e" or "E" exponent !! ! o for lists delimit with a comma, colon, or space !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1 -2 -3 & !! & --point 11.11, 22.22, 33.33e0 & !! & --title "my title" -l F -L F & !! & --logicals F F F F F & !! & --logi F T F & !! & --label " " & !! ! note space between quotes is required !! & ') !! ! Assign values to elements using G_ARGS(3f). !! ! non-allocatable scalars can be done up to twenty per call !! call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig) !! ! As a convenience multiple pairs of keywords and variables may be !! ! specified if and only if all the values are scalars and the CHARACTER !! ! variables are fixed-length or pre-allocated. !! ! !! ! After SET_ARGS(3f) has parsed the command line !! ! GET_ARGS(3f) retrieves the value of keywords accept for !! ! two special cases. For fixed-length CHARACTER variables !! ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see !! ! GET_ARGS_FIXED_SIZE(3f). !! ! !! ! allocatables should be done one at a time !! call get_args('title',title) ! allocatable string !! call get_args('point',point) ! allocatable arrays !! call get_args('logicals',logicals) !! ! !! ! less commonly ... !! !! ! for fixed-length strings !! call get_args_fixed_length('label',label) !! !! ! for non-allocatable arrays !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('logi',logi) !! ! !! ! all done parsing, use values !! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z !! write(*,*)'p=',p !! write(*,*)'point=',point !! write(*,*)'title=',title !! write(*,*)'label=',label !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'logicals=',logicals !! write(*,*)'logi=',logi !! ! !! ! unnamed strings !! ! !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! ! !! end program demo_M_CLI2 !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !!##SEE ALSO !! + get_args(3f) !! + get_args_fixed_size(3f) !! + get_args_fixed_length(3f) !! + get_subcommand(3f) !! + set_mode(3f) !! + specified(3f) !! !! Note that the convenience routines are described under get_args(3f): !! dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f), !! igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f) !=================================================================================================================================== module M_CLI2 use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT, warn=>OUTPUT_UNIT implicit none private integer,parameter,private :: dp=kind(0.0d0) integer,parameter,private :: sp=kind(0.0) character(len=*),parameter :: gen='(*(g0))' character(len=:),allocatable,public :: unnamed(:) character(len=:),allocatable,public :: args(:) character(len=:),allocatable,public :: remaining public :: set_mode public :: set_args public :: get_subcommand public :: get_args public :: get_args_fixed_size public :: get_args_fixed_length public :: specified public :: print_dictionary public :: dget, iget, lget, rget, sget, cget public :: dgets, igets, lgets, rgets, sgets, cgets type option character(:),allocatable :: shortname character(:),allocatable :: longname character(:),allocatable :: value integer :: length logical :: present_in logical :: mandatory end type option character(len=:),allocatable,save :: keywords(:) character(len=:),allocatable,save :: shorts(:) character(len=:),allocatable,save :: values(:) integer,allocatable,save :: counts(:) logical,allocatable,save :: present_in(:) logical,allocatable,save :: mandatory(:) logical,save :: G_DEBUG=.false. logical,save :: G_UNDERDASH=.false. logical,save :: G_NODASHUNDER=.false. logical,save :: G_IGNORELONGCASE=.false. ! ignore case of long keywords logical,save :: G_IGNOREALLCASE=.false. ! ignore case of long and short keywords logical,save :: G_STRICT=.false. ! strict short and long rules or allow -longname and --shortname logical,save :: G_APPEND=.true. ! whether to append or replace when duplicate keywords found logical,save :: G_keyword_single_letter=.true. character(len=:),allocatable,save :: G_passed_in logical,save :: G_remaining_on, G_remaining_option_allowed character(len=:),allocatable,save :: G_remaining character(len=:),allocatable,save :: G_subcommand ! possible candidate for a subcommand character(len=:),allocatable,save :: G_STOP_MESSAGE integer,save :: G_STOP logical,save :: G_QUIET character(len=:),allocatable,save :: G_PREFIX ! try out response files ! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via "set_mode('response_file') logical,save,public :: CLI_RESPONSE_FILE=.false. ! allow @name abbreviations logical,save :: G_OPTIONS_ONLY ! process response file only looking for options for get_subcommand() logical,save :: G_RESPONSE ! allow @name abbreviations character(len=:),allocatable,save :: G_RESPONSE_IGNORED ! return allocatable arrays interface get_args; module procedure get_anyarray_d; end interface ! any size array interface get_args; module procedure get_anyarray_i; end interface ! any size array interface get_args; module procedure get_anyarray_r; end interface ! any size array interface get_args; module procedure get_anyarray_x; end interface ! any size array interface get_args; module procedure get_anyarray_c; end interface ! any size array and any length interface get_args; module procedure get_anyarray_l; end interface ! any size array ! return scalars interface get_args; module procedure get_scalar_d; end interface interface get_args; module procedure get_scalar_i; end interface interface get_args; module procedure get_scalar_real; end interface interface get_args; module procedure get_scalar_complex; end interface interface get_args; module procedure get_scalar_logical; end interface interface get_args; module procedure get_scalar_anylength_c; end interface ! any length ! multiple scalars interface get_args; module procedure many_args; end interface ! return non-allocatable arrays ! said in conflict with get_args_*. Using class to get around that. ! that did not work either. Adding size parameter as optional parameter works; but using a different name interface get_args_fixed_size; module procedure get_fixedarray_class; end interface ! any length, fixed size array !interface get_args; module procedure get_fixedarray_d; end interface !interface get_args; module procedure get_fixedarray_i; end interface !interface get_args; module procedure get_fixedarray_r; end interface !interface get_args; module procedure get_fixedarray_l; end interface !interface get_args; module procedure get_fixedarray_fixed_length_c; end interface interface get_args_fixed_length; module procedure get_args_fixed_length_a_array; end interface ! fixed length any size array interface get_args_fixed_length; module procedure get_args_fixed_length_scalar_c; end interface ! fixed length ! Generic subroutine inserts element into allocatable array at specified position ! find PLACE in sorted character array where value can be found or should be placed interface locate_; module procedure locate_c ; end interface ! insert entry into a sorted allocatable array at specified position interface insert_; module procedure insert_c, insert_i, insert_l ; end interface ! replace entry by index from a sorted allocatable array if it is present interface replace_; module procedure replace_c, replace_i, replace_l ; end interface ! delete entry by index from a sorted allocatable array if it is present interface remove_; module procedure remove_c, remove_i, remove_l ; end interface ! convenience functions interface cgets;module procedure cgs, cg;end interface interface dgets;module procedure dgs, dg;end interface interface igets;module procedure igs, ig;end interface interface lgets;module procedure lgs, lg;end interface interface rgets;module procedure rgs, rg;end interface interface sgets;module procedure sgs, sg;end interface contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process !! pre-defined options !! !!##SYNOPSIS !! !! subroutine check_commandline(help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! !!##DESCRIPTION !! Checks the commandline and processes the implicit --help, --version, !! --verbose, and --usage parameters. !! !! If the optional text values are supplied they will be displayed by !! --help and --version command-line options, respectively. !! !!##OPTIONS !! !! HELP_TEXT if present, will be displayed if program is called with !! --help switch, and then the program will terminate. If !! not supplied, the command line initialized string will be !! shown when --help is used on the commandline. !! !! VERSION_TEXT if present, will be displayed if program is called with !! --version switch, and then the program will terminate. !! !! If the first four characters of each line are "@(#)" this prefix !! will not be displayed and the last non-blank letter will be !! removed from each line. This if for support of the SCCS what(1) !! command. If you do not have the what(1) command on GNU/Linux and !! Unix platforms you can probably see how it can be used to place !! metadata in a binary by entering: !! !! strings demo_commandline|grep '@(#)'|tr '>' '\n'|sed -e 's/ */ /g' !! !!##EXAMPLE !! !! !! Typical usage: !! !! program check_commandline !! use M_CLI2, only : unnamed, set_args, get_args !! implicit none !! integer :: i !! character(len=:),allocatable :: version_text(:), help_text(:) !! real :: x, y, z !! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3' !! version_text=[character(len=80) :: "version 1.0","author: me"] !! help_text=[character(len=80) :: & !! & "wish I put instructions","here","I suppose?"] !! call set_args(cmd,help_text,version_text) !! call get_args('x',x,'y',y,'z',z) !! ! All done cracking the command line. Use the values in your program. !! write (*,*)x,y,z !! ! the optional unnamed values on the command line are !! ! accumulated in the character array "UNNAMED" !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program check_commandline !=================================================================================================================================== subroutine check_commandline(help_text,version_text) character(len=*),intent(in),optional :: help_text(:) character(len=*),intent(in),optional :: version_text(:) character(len=:),allocatable :: line integer :: i integer :: istart integer :: iback if(get('usage') == 'T')then call print_dictionary_usage() call mystop(32) return endif if(present(help_text))then if(get('help') == 'T')then do i=1,size(help_text) call journal(help_text(i)) enddo call mystop(1,'displayed help text') return endif elseif(get('help') == 'T')then call default_help() call mystop(2,'displayed default help text') return endif if(present(version_text))then if(get('version') == 'T')then istart=1 iback=0 if(size(version_text) > 0)then if(index(version_text(1),'@'//'(#)') == 1)then ! allow for what(1) syntax istart=5 iback=1 endif endif do i=1,size(version_text) !xINTEL BUG*!call journal(version_text(i)(istart:len_trim(version_text(i))-iback)) line=version_text(i)(istart:len_trim(version_text(i))-iback) call journal(line) enddo call mystop(3,'displayed version text') return endif elseif(get('version') == 'T')then if(G_QUIET)then G_STOP_MESSAGE = 'no version text' else call journal('*check_commandline* no version text') endif call mystop(4,'displayed default version text') return endif contains subroutine default_help() character(len=:),allocatable :: cmd_name integer :: ilength call get_command_argument(number=0,length=ilength) if(allocated(cmd_name))deallocate(cmd_name) allocate(character(len=ilength) :: cmd_name) call get_command_argument(number=0,value=cmd_name) G_passed_in=G_passed_in//repeat(' ',len(G_passed_in)) G_passed_in=replace_str(G_passed_in, ' --', NEW_LINE('A')//' --') if(.not.G_QUIET)then call journal(cmd_name,G_passed_in) ! no help text, echo command and default options endif deallocate(cmd_name) end subroutine default_help end subroutine check_commandline !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_args(prototype,help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: prototype !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! integer,intent(out),optional :: ierr !! character(len=:),intent(out),allocatable,optional :: errmsg !!##DESCRIPTION !! !! SET_ARGS(3f) requires a unix-like command prototype which defines !! the command-line options and their default values. When the program !! is executed this and the command-line options are applied and the !! resulting values are placed in an internal table for retrieval via !! GET_ARGS(3f). !! !! The built-in --help and --version options require optional help_text !! and version_text values to be provided to be particularly useful. !! !!##OPTIONS !! !! PROTOTYPE composed of all command arguments concatenated !! into a Unix-like command prototype string. For !! example: !! !! call set_args('-L F --ints 1,2,3 --title "my title" -R 10.3') !! !! The following options are predefined for all commands: !! '--verbose F --usage F --help F --version F'. !! !! see "DEFINING THE PROTOTYPE" in the next section for !! further details. !! !! HELP_TEXT if present, will be displayed when the program is called with !! a --help switch, and then the program will terminate. If !! help text is not supplied the command line initialization !! string will be echoed. !! !! VERSION_TEXT if present, any version text defined will be displayed !! when the program is called with a --version switch, !! and then the program will terminate. !! IERR if present a non-zero option is returned when an !! error occurs instead of the program terminating. !! ERRMSG a description of the error if ierr is present. !! !!##DEFINING THE PROTOTYPE !! !! o Keywords start with a single dash for short single-character !! keywords, and with two dashes for longer keywords. !! !! o all keywords on the prototype MUST get a value. !! !! * logicals must be set to an unquoted F. !! !! * strings must be delimited with double-quotes. !! Since internal double-quotes are represented with two !! double-quotes the string must be at least one space. !! !! o numeric keywords are not allowed; but this allows !! negative numbers to be used as values. !! !! o lists of values should be comma-delimited unless a !! user-specified delimiter is used. The prototype !! must use the same array delimiters as the call to !! get the value. !! !! o to define a zero-length allocatable array make the !! value a delimiter (usually a comma) or an empty set !! of braces ("[]"). !! !! LONG AND SHORT NAMES !! !! Long keywords start with two dashes followed by more than one letter. !! Short keywords are a dash followed by a single letter. !! !! o It is recommended long names (--keyword) should be all lowercase !! but are case-sensitive by default, unless !! "set_mode('ignorelongcase')" of "set_mode('ignoreallcase')" is !! in effect. !! !! o Long names should always be more than one character. !! !! o The recommended way to have short names is to suffix the long !! name with :LETTER in the definition. !! !! If this syntax is used then logical shorts may be combined on the !! command line when "set_mode('strict')" is in effect. !! !! SPECIAL BEHAVIORS !! !! o A special behavior occurs if a keyword name ends in ::. !! When the program is called the next parameter is taken as !! a value even if it starts with -. This is not generally !! recommended but is useful in rare cases where non-numeric !! values starting with a dash are desired. !! !! o If the prototype ends with "--" a special mode is turned !! on where anything after "--" on input goes into the variable !! REMAINING with values double-quoted and also into the array ARGS !! instead of becoming elements in the UNNAMED array. This is not !! needed for normal processing, but was needed for a program that !! needed this behavior for its subcommands. !! !! That is, for a normal call all unnamed values go into UNNAMED !! and ARGS and REMAINING are ignored. So for !! !! call set_args('-x 10 -y 20 ') !! !! A program invocation such as !! !! xx a b c -- A B C " dd " !! !! results in !! !! UNNAMED= ['a','b','c','A','B','C',' dd'] !! REMAINING= '' !! ARGS= [character(len=0) :: ] ! ie, an empty character array !! !! Whereas !! !! call set_args('-x 10 -y 20 --') !! !! generates the following output from the same program execution: !! !! UNNAMED= ['a','b','c'] !! REMAINING= '"A" "B" "C" " dd "' !! ARGS= ['A','B','C,' dd'] !! !!##USAGE NOTES !! When invoking the program line note the (subject to change) !! following restrictions (which often differ between various !! command-line parsers): !! !! o values for duplicate keywords are appended together with a space !! separator when a command line is executed by default. !! !! o shuffling is not supported. Values immediately follow their !! keywords. !! !! o Only short Boolean keywords can be bundled together. !! If allowing bundling is desired call "set_mode('strict')". !! This will require prefixing long names with "--" and short !! names with "-". Otherwise M_CLI2 relaxes that requirement !! and mostly does not care what prefix is used for a keyword. !! But this would make it unclear what was meant by "-ox" if !! allowed options were "-o F -x F --ox F " for example, so !! "strict" mode is required to remove the ambiguity. !! !! o if a parameter value of just "-" is supplied it is !! converted to the string "stdin". !! !! o values not needed for a keyword value go into the character !! array "UNNAMED". !! !! In addition if the keyword "--" is encountered on the command !! line the rest of the command line goes into the character array !! "UNNAMED". !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_set_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! use M_CLI2, only : get_args_fixed_size !! implicit none !! integer :: i !! ! DEFINE ARGS !! real :: x, y, z !! real :: p(3) !! character(len=:),allocatable :: title !! logical :: l, lbig !! integer,allocatable :: ints(:) !! ! !! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS) !! ! AND READ COMMAND LINE !! call set_args(' & !! ! reals !! & -x 1 -y 2.3 -z 3.4e2 & !! ! integer array !! & -p -1,-2,-3 & !! ! always double-quote strings !! & --title "my title" & !! ! string should be a single character at a minimum !! & --label " ", & !! ! set all logical values to F !! & -l F -L F & !! ! set allocatable size to zero if you like by using a delimiter !! & --ints , & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! ! SCALARS !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args('l',l) !! call get_args('L',lbig) !! call get_args('ints',ints) ! ALLOCATABLE ARRAY !! call get_args('title',title) ! ALLOCATABLE STRING !! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'y=',y !! write(*,*)'z=',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'ints=',ints !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! ! UNNAMED VALUES !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_set_args !! !!##RESPONSE FILES !! !! If you have no interest in using external files as abbreviations !! you can ignore this section. Otherwise, before calling set_args(3f) !! add: !! !! use M_CLI2, only : set_mode !! call set_mode('response_file') !! !! M_CLI2 Response files are small files containing CLI (Command Line !! Interface) arguments that end with ".rsp" that can be used when command !! lines are so long that they would exceed line length limits or so complex !! that it is useful to have a platform-independent method of creating !! an abbreviation. !! !! Shell aliases and scripts are often used for similar purposes (and !! allow for much more complex conditional execution, of course), but !! they generally cannot be used to overcome line length limits and are !! typically platform-specific. !! !! Examples of commands that support similar response files are the Clang !! and Intel compilers, although there is no standard format for the files. !! !! They are read if you add options of the syntax "@NAME" as the FIRST !! parameters on your program command line calls. They are not recursive -- !! that is, an option in a response file cannot be given the value "@NAME2" !! to call another response file. !! !! More than one response name may appear on a command line. !! !! They are case-sensitive names. !! !! Note "@" s a special character in Powershell, and requires being escaped !! with a grave character. !! !! LOCATING RESPONSE FILES !! !! A search for the response file always starts with the current directory. !! The search then proceeds to look in any additional directories specified !! with the colon-delimited environment variable CLI_RESPONSE_PATH. !! !! The first resource file found that results in lines being processed !! will be used and processing stops after that first match is found. If !! no match is found an error occurs and the program is stopped. !! !! RESPONSE FILE SECTIONS !! !! A simple response file just has options for calling the program in it !! prefixed with the word "options". !! But they can also contain section headers to denote selections that are !! only executed when a specific OS is being used, print messages, and !! execute system commands. !! !! SEARCHING FOR OSTYPE IN REGULAR FILES !! !! So assuming the name @NAME was specified on the command line a file !! named NAME.rsp will be searched for in all the search directories !! and then in that file a string that starts with the string @OSTYPE !! (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE !! takes precedence over $OS). !! !! SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES !! !! Then, the same files will be searched for lines above any line starting !! with "@". That is, if there is no special section for the current OS !! it just looks at the top of the file for unlabeled options. !! !! SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE !! !! In addition or instead of files with the same name as the @NAME option !! on the command line, you can have one file named after the executable !! name that contains multiple abbreviation names. !! !! So if your program executable is named EXEC you create a single file !! called EXEC.rsp and can append all the simple files described above !! separating them with lines of the form @OSTYPE@NAME or just @NAME. !! !! So if no specific file for the abbreviation is found a file called !! "EXEC.rsp" is searched for where "EXEC" is the name of the executable. !! This file is always a "compound" response file that uses the following format: !! !! Any compound EXEC.rsp file found in the current or searched directories !! will be searched for the string @OSTYPE@NAME first. !! !! Then if nothing is found, the less specific line @NAME is searched for. !! !! THE SEARCH IS OVER !! !! Sounds complicated but actually works quite intuitively. Make a file in !! the current directory and put options in it and it will be used. If that !! file ends up needing different cases for different platforms add a line !! like "@Linux" to the file and some more lines and that will only be !! executed if the environment variable OSTYPE or OS is "Linux". If no match !! is found for named sections the lines at the top before any "@" lines !! will be used as a default if no match is found. !! !! If you end up using a lot of files like this you can combine them all !! together and put them into a file called "program_name".rsp and just !! put lines like @NAME or @OSTYPE@NAME at that top of each selection. !! !! Now, back to the details on just what you can put in the files. !! !!##SPECIFICATION FOR RESPONSE FILES !! !! SIMPLE RESPONSE FILES !! !! The first word of a line is special and has the following meanings: !! !! options|- Command options following the rules of the SET_ARGS(3f) !! prototype. So !! o It is preferred to specify a value for all options. !! o double-quote strings. !! o give a blank string value as " ". !! o use F|T for lists of logicals, !! o lists of numbers should be comma-delimited. !! o --usage, --help, --version, --verbose, and unknown !! options are ignored. !! !! comment|# Line is a comment line !! system|! System command. !! System commands are executed as a simple call to !! system (so a cd(1) or setting a shell variable !! would not effect subsequent lines, for example) !! BEFORE the command being processed. !! print|> Message to screen !! stop display message and stop program. !! !! NOTE: system commands are executed when encountered, but options are !! gathered from multiple option lines and passed together at the end of !! processing of the block; so all commands will be executed BEFORE the !! command for which options are being supplied no matter where they occur. !! !! So if a program that does nothing but echos its parameters !! !! program testit !! use M_CLI2, only : set_args, rget, sget, lget, set_mode !! implicit none !! real :: x,y ; namelist/args/ x,y !! character(len=:),allocatable :: title ; namelist/args/ title !! logical :: big ; namelist/args/ big !! call set_mode('response_file') !! call set_args('-x 10.0 -y 20.0 --title "my title" --big F') !! x=rget('x') !! y=rget('y') !! title=sget('title') !! big=lget('big') !! write(*,nml=args) !! end program testit !! !! And a file in the current directory called "a.rsp" contains !! !! # defaults for project A !! options -x 1000 -y 9999 !! options --title " " !! options --big T !! !! The program could be called with !! !! $myprog # normal call !! X=10.0 Y=20.0 TITLE="my title" !! !! $myprog @a # change defaults as specified in "a.rsp" !! X=1000.0 Y=9999.0 TITLE=" " !! !! # change defaults but use any option as normal to override defaults !! $myprog @a -y 1234 !! X=1000.0 Y=1234.0 TITLE=" " !! !! COMPOUND RESPONSE FILES !! !! A compound response file has the same basename as the executable with a !! ".rsp" suffix added. So if your program is named "myprg" the filename !! must be "myprg.rsp". !! !! Note that here `basename` means the last leaf of the !! name of the program as returned by the Fortran intrinsic !! GET_COMMAND_ARGUMENT(0,...) trimmed of anything after a period ("."), !! so it is a good idea not to use hidden files. !! !! Unlike simple response files compound response files can contain multiple !! setting names. !! !! Specifically in a compound file !! if the environment variable $OSTYPE (first) or $OS is set the first search !! will be for a line of the form (no leading spaces should be used): !! !! @OSTYPE@alias_name !! !! If no match or if the environment variables $OSTYPE and $OS were not !! set or a match is not found then a line of the form !! !! @alias_name !! !! is searched for in simple or compound files. If found subsequent lines !! will be ignored that start with "@" until a line not starting with !! "@" is encountered. Lines will then be processed until another line !! starting with "@" is found or end-of-file is encountered. !! !! COMPOUND RESPONSE FILE EXAMPLE !! An example compound file !! !! ################# !! @if !! > RUNNING TESTS USING RELEASE VERSION AND ifort !! options test --release --compiler ifort !! ################# !! @gf !! > RUNNING TESTS USING RELEASE VERSION AND gfortran !! options test --release --compiler gfortran !! ################# !! @nv !! > RUNNING TESTS USING RELEASE VERSION AND nvfortran !! options test --release --compiler nvfortran !! ################# !! @nag !! > RUNNING TESTS USING RELEASE VERSION AND nagfor !! options test --release --compiler nagfor !! # !! ################# !! # OS-specific example: !! @Linux@install !! # !! # install executables in directory (assuming install(1) exists) !! # !! system mkdir -p ~/.local/bin !! options run --release T --runner "install -vbp -m 0711 -t ~/.local/bin" !! @install !! STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET !! # !! ################# !! @fpm@testall !! # !! !fpm test --compiler nvfortran !! !fpm test --compiler ifort !! !fpm test --compiler gfortran !! !fpm test --compiler nagfor !! STOP tests complete. Any additional parameters were ignored !! ################# !! !! Would be used like !! !! fpm @install !! fpm @nag -- !! fpm @testall !! !! NOTES !! !! The intel Fortran compiler now calls the response files "indirect !! files" and does not add the implied suffix ".rsp" to the files !! anymore. It also allows the @NAME syntax anywhere on the command line, !! not just at the beginning. -- 20201212 !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine set_args(prototype,help_text,version_text,string,prefix,ierr,errmsg) ! ident_1="@(#) M_CLI2 set_args(3f) parse prototype string" character(len=*),intent(in) :: prototype character(len=*),intent(in),optional :: help_text(:) character(len=*),intent(in),optional :: version_text(:) character(len=*),intent(in),optional :: string character(len=*),intent(in),optional :: prefix integer,intent(out),optional :: ierr character(len=:),intent(out),allocatable,optional :: errmsg character(len=:),allocatable :: hold ! stores command line argument integer :: ibig character(len=:),allocatable :: debug_mode debug_mode= upper(get_env('CLI_DEBUG_MODE','FALSE'))//' ' select case(debug_mode(1:1)) case('Y','T') G_DEBUG=.true. end select G_response=CLI_RESPONSE_FILE G_options_only=.false. G_passed_in='' G_STOP=0 G_STOP_MESSAGE='' if(present(prefix))then G_PREFIX=prefix else G_PREFIX='' endif if(present(ierr))then G_QUIET=.true. else G_QUIET=.false. endif ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine IF(ALLOCATED(UNNAMED)) DEALLOCATE(UNNAMED) ALLOCATE(CHARACTER(LEN=IBIG) :: UNNAMED(0)) if(allocated(args)) deallocate(args) allocate(character(len=ibig) :: args(0)) call wipe_dictionary() hold='--version F --usage F --help F --version F '//adjustl(prototype) call prototype_and_cmd_args_to_nlist(hold,string) if(allocated(G_RESPONSE_IGNORED))then if(G_DEBUG)write(*,gen)'SET_ARGS:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED if(size(unnamed) /= 0)write(*,*)'LOGIC ERROR' call split(G_RESPONSE_IGNORED,unnamed) endif if(.not.allocated(unnamed))then allocate(character(len=0) :: unnamed(0)) endif if(.not.allocated(args))then allocate(character(len=0) :: args(0)) endif call check_commandline(help_text,version_text) ! process --help, --version, --usage if(present(ierr))then ierr=G_STOP endif if(present(errmsg))then errmsg=G_STOP_MESSAGE endif end subroutine set_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_subcommand(3f) - [ARGUMENTS:M_CLI2] special-case routine for !! handling subcommands on a command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function get_subcommand() !! !! character(len=:),allocatable :: get_subcommand !! !!##DESCRIPTION !! In the special case when creating a program with subcommands it !! is assumed the first word on the command line is the subcommand. A !! routine is required to handle response file processing, therefore !! this routine (optionally processing response files) returns that !! first word as the subcommand name. !! !! It should not be used by programs not building a more elaborate !! command with subcommands. !! !!##RETURNS !! NAME name of subcommand !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_subcommand !! !x! SUBCOMMANDS !! !x! For a command with subcommands like git(1) !! !x! you can make separate namelists for each subcommand. !! !x! You can call this program which has two subcommands (run, test), !! !x! like this: !! !x! demo_get_subcommand --help !! !x! demo_get_subcommand run -x -y -z --title -l -L !! !x! demo_get_subcommand test --title -l -L --testname !! !x! demo_get_subcommand run --help !! implicit none !! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES !! real :: x=-999.0,y=-999.0,z=-999.0 !! character(len=80) :: title="not set" !! logical :: l=.false. !! logical :: l_=.false. !! character(len=80) :: testname="not set" !! character(len=20) :: name !! call parse(name) !x! DEFINE AND PARSE COMMAND LINE !! !x! ALL DONE CRACKING THE COMMAND LINE. !! !x! USE THE VALUES IN YOUR PROGRAM. !! write(*,*)'command was ',name !! write(*,*)'x,y,z .... ',x,y,z !! write(*,*)'title .... ',title !! write(*,*)'l,l_ ..... ',l,l_ !! write(*,*)'testname . ',testname !! contains !! subroutine parse(name) !! !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY !! use M_CLI2, only : set_args, get_args, get_args_fixed_length !! use M_CLI2, only : get_subcommand, set_mode !! character(len=*) :: name ! the subcommand name !! character(len=:),allocatable :: help_text(:), version_text(:) !! call set_mode('response_file') !! ! define version text !! version_text=[character(len=80) :: & !! '@(#)PROGRAM: demo_get_subcommand >', & !! '@(#)DESCRIPTION: My demo program >', & !! '@(#)VERSION: 1.0 20200715 >', & !! '@(#)AUTHOR: me, myself, and I>', & !! '@(#)LICENSE: Public Domain >', & !! '' ] !! ! general help for "demo_get_subcommand --help" !! help_text=[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L --title -x -y -z ', & !! ' * test -l -L --title ', & !! '' ] !! ! find the subcommand name by looking for first word on command !! ! not starting with dash !! name = get_subcommand() !! select case(name) !! case('run') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand "run" ', & !! ' ', & !! '' ] !! call set_args( & !! & '-x 1 -y 2 -z 3 --title "my title" -l F -L F',& !! & help_text,version_text) !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! case('test') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand "test" ', & !! ' ', & !! '' ] !! call set_args(& !! & '--title "my title" -l F -L F --testname "Test"',& !! & help_text,version_text) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! call get_args_fixed_length('testname',testname) !! case default !! ! process help and version !! call set_args(' ',help_text,version_text) !! write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']' !! write(*,'(a)')[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L -title -x -y -z ', & !! ' * test -l -L -title ', & !! '' ] !! stop !! end select !! end subroutine parse !! end program demo_get_subcommand !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== function get_subcommand() result(sub) ! ident_2="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files" character(len=:),allocatable :: sub character(len=:),allocatable :: cmdarg character(len=:),allocatable :: array(:) character(len=:),allocatable :: prototype integer :: ilongest integer :: i integer :: j G_subcommand='' G_options_only=.true. sub='' if(.not.allocated(unnamed))then allocate(character(len=0) :: unnamed(0)) endif ilongest=longest_command_argument() allocate(character(len=max(63,ilongest)):: cmdarg) cmdarg(:) = '' ! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM do i = 1, command_argument_count() call get_command_argument(i, cmdarg) if(scan(adjustl(cmdarg(1:1)),'@') == 1)then call get_prototype(cmdarg,prototype) call split(prototype,array) ! assume that if using subcommands first word not starting with dash is the subcommand do j=1,size(array) if(adjustl(array(j)(1:1)) /= '-')then G_subcommand=trim(array(j)) sub=G_subcommand exit endif enddo endif enddo if(G_subcommand /= '')then sub=G_subcommand elseif(size(unnamed) /= 0)then sub=unnamed(1) else cmdarg(:) = '' do i = 1, command_argument_count() call get_command_argument(i, cmdarg) if(adjustl(cmdarg(1:1)) /= '-')then sub=trim(cmdarg) exit endif enddo endif G_options_only=.false. end function get_subcommand !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_usage(3f) - [ARGUMENTS:M_CLI2] allow setting a short description !! for keywords for the --usage switch !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_usage(keyword,description) !! !! character(len=*),intent(in) :: keyword !! character(len=*),intent(in) :: description !! !!##DESCRIPTION !! !!##OPTIONS !! KEYWORD the name of a command keyword !! DESCRIPTION a brief one-line description of the keyword !! !! !!##EXAMPLE !! !! sample program: !! !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine set_usage(keyword,description,value) character(len=*),intent(in) :: keyword character(len=*),intent(in) :: description character(len=*),intent(in) :: value write(*,*)keyword write(*,*)description write(*,*)value ! store the descriptions in an array and then apply them when set_args(3f) is called. ! alternatively, could allow for a value as well in lieu of the prototype end subroutine set_usage !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command !! and store tokens into dictionary !! (LICENSE:PD) !! !!##SYNOPSIS !! !! recursive subroutine prototype_to_dictionary(string) !! !! character(len=*),intent(in) :: string !! !!##DESCRIPTION !! given a string of form !! !! -var value -var value !! !! define dictionary of form !! !! keyword(i), value(i) !! !! o string values !! !! o must be delimited with double quotes. !! o adjacent double quotes put one double quote into value !! o must not be null. A blank is specified as " ", not "". !! !! o logical values !! !! o logical values must have a value. Use F. !! !! o leading and trailing blanks are removed from unquoted values !! !! !!##OPTIONS !! STRING string is character input string to define command !! !!##RETURNS !! !!##EXAMPLE !! !! sample program: !! !! call prototype_to_dictionary(' -l F --ignorecase F --title "my title string" -x 10.20') !! call prototype_to_dictionary(' --ints 1,2,3,4') !! !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== recursive subroutine prototype_to_dictionary(string) ! ident_3="@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary" character(len=*),intent(in) :: string ! string is character input string of options and values character(len=:),allocatable :: dummy ! working copy of string character(len=:),allocatable :: value character(len=:),allocatable :: keyword character(len=3) :: delmt ! flag if in a delimited string or not character(len=1) :: currnt ! current character being processed character(len=1) :: prev ! character to left of CURRNT character(len=1) :: forwrd ! character to right of CURRNT integer,dimension(2) :: ipnt integer :: islen ! number of characters in input string integer :: ipoint integer :: itype integer,parameter :: VAL=1, KEYW=2 integer :: ifwd integer :: ibegin integer :: iend integer :: place islen=len_trim(string) ! find number of characters in input string if(islen == 0)then ! if input string is blank, even default variable will not be changed return endif dummy=adjustl(string)//' ' keyword="" ! initial variable name value="" ! initial value of a string ipoint=0 ! ipoint is the current character pointer for (dummy) ipnt(2)=2 ! pointer to position in keyword ipnt(1)=1 ! pointer to position in value itype=VAL ! itype=1 for value, itype=2 for variable delmt="off" prev=" " G_keyword_single_letter=.true. do ipoint=ipoint+1 ! move current character pointer forward currnt=dummy(ipoint:ipoint) ! store current character into currnt ifwd=min(ipoint+1,islen) ! ensure not past end of string forwrd=dummy(ifwd:ifwd) ! next character (or duplicate if last) if((currnt=="-" .and. prev==" " .and. delmt == "off" .and. index("0123456789.",forwrd) == 0).or.ipoint > islen)then ! beginning of a keyword if(forwrd == '-')then ! change --var to -var so "long" syntax is supported !x!dummy(ifwd:ifwd)='_' ipoint=ipoint+1 ! ignore second - instead (was changing it to _) G_keyword_single_letter=.false. ! flag this is a long keyword else G_keyword_single_letter=.true. ! flag this is a short (single letter) keyword endif if(ipnt(1)-1 >= 1)then ! position in value ibegin=1 iend=len_trim(value(:ipnt(1)-1)) TESTIT: do if(iend == 0)then ! len_trim returned 0, value is blank iend=ibegin exit TESTIT elseif(value(ibegin:ibegin) == " ")then ibegin=ibegin+1 else exit TESTIT endif enddo TESTIT if(keyword /= ' ')then if(value=='[]')value=',' call update(keyword,value) ! store name and its value elseif( G_remaining_option_allowed)then ! meaning "--" has been encountered if(value=='[]')value=',' call update('_args_',trim(value)) else !x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword) G_RESPONSE_IGNORED=TRIM(VALUE) if(G_DEBUG)write(*,gen)'PROTOTYPE_TO_DICTIONARY:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED endif else call locate_key(keyword,place) if(keyword /= ' '.and.place < 0)then call update(keyword,'F') ! store name and null value (first pass) elseif(keyword /= ' ')then call update(keyword,' ') ! store name and null value (second pass) elseif(.not.G_keyword_single_letter.and.ipoint-2 == islen) then ! -- at end of line G_remaining_option_allowed=.true. ! meaning for "--" is that everything on commandline goes into G_remaining endif endif itype=KEYW ! change to expecting a keyword value="" ! clear value for this variable keyword="" ! clear variable name ipnt(1)=1 ! restart variable value ipnt(2)=1 ! restart variable name else ! currnt is not one of the special characters ! the space after a keyword before the value if(currnt == " " .and. itype == KEYW)then ! switch from building a keyword string to building a value string itype=VAL ! beginning of a delimited value elseif(currnt == """".and.itype == VAL)then ! second of a double quote, put quote in if(prev == """")then if(itype == VAL)then value=value//currnt else keyword=keyword//currnt endif ipnt(itype)=ipnt(itype)+1 delmt="on" elseif(delmt == "on")then ! first quote of a delimited string delmt="off" else delmt="on" endif if(prev /= """")then ! leave quotes where found them if(itype == VAL)then value=value//currnt else keyword=keyword//currnt endif ipnt(itype)=ipnt(itype)+1 endif else ! add character to current keyword or value if(itype == VAL)then value=value//currnt else keyword=keyword//currnt endif ipnt(itype)=ipnt(itype)+1 endif endif prev=currnt if(ipoint <= islen)then cycle else exit endif enddo end subroutine prototype_to_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present !! on command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental impure function specified(name) !! !! character(len=*),intent(in) :: name !! logical :: specified !! !!##DESCRIPTION !! !! specified(3f) returns .true. if the specified keyword was present on !! the command line. !! !! M_CLI2 intentionally does not have validators except for SPECIFIED(3f) !! and of course a check whether the input conforms to the type when !! requesting a value (with get_args(3f) or the convenience functions !! like inum(3f)). !! !! Fortran already has powerful validation capabilities. Logical !! expressions ANY(3f) and ALL(3f) are standard Fortran features which !! easily allow performing the common validations for command line !! arguments without having to learn any additional syntax or methods. !! !!##OPTIONS !! !! NAME name of commandline argument to query the presence of. Long !! names should always be used. !! !!##RETURNS !! SPECIFIED returns .TRUE. if specified NAME was present on the command !! line when the program was invoked. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_specified !! use, intrinsic :: iso_fortran_env, only : & !! & stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT !! use M_CLI2, only : set_args, igets, rgets, specified, sget, lget !! implicit none !! !! ! Define args !! integer,allocatable :: ints(:) !! real,allocatable :: floats(:) !! logical :: flag !! character(len=:),allocatable :: color !! character(len=:),allocatable :: list(:) !! integer :: i !! !! call set_args('& !! & --color:c "red" & !! & --flag:f F & !! & --ints:i 1,10,11 & !! & --floats:T 12.3, 4.56 & !! & ') !! ints=igets('ints') !! floats=rgets('floats') !! flag=lget('flag') !! color=sget('color') !! !! write(*,*)'color=',color !! write(*,*)'flag=',flag !! write(*,*)'ints=',ints !! write(*,*)'floats=',floats !! !! write(*,*)'was -flag specified?',specified('flag') !! !! ! elemental !! write(*,*)specified(['floats','ints ']) !! !! ! If you want to know if groups of parameters were specified use !! ! ANY(3f) and ALL(3f) !! write(*,*)'ANY:',any(specified(['floats','ints '])) !! write(*,*)'ALL:',all(specified(['floats','ints '])) !! !! ! For mutually exclusive !! if (all(specified(['floats','ints '])))then !! write(*,*)'You specified both names --ints and --floats' !! endif !! !! ! For required parameter !! if (.not.any(specified(['floats','ints '])))then !! write(*,*)'You must specify --ints or --floats' !! endif !! !! ! check if all values are in range from 10 to 30 and even !! write(*,*)'are all numbers good?',all([ints>=10,ints<= 30,(ints/2)*2==ints]) !! !! ! perhaps you want to check one value at a time !! do i=1,size(ints) !! write(*,*)ints(i),[ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)] !! if(all([ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]) )then !! write(*,*)ints(i),'is an even number from 10 to 30 inclusive' !! else !! write(*,*)ints(i),'is not an even number from 10 to 30 inclusive' !! endif !! enddo !! !! list = [character(len=10) :: 'red','white','blue'] !! if( any(color == list) )then !! write(*,*)color,'matches a value in the list' !! else !! write(*,*)color,'not in the list' !! endif !! !! if(size(ints).eq.3)then !! write(*,*)'ints(:) has expected number of values' !! else !! write(*,*)'ints(:) does not have expected number of values' !! endif !! !! end program demo_specified !! !! Default output !! !! > color=red !! > flag= F !! > ints= 1 10 11 !! > floats= 12.3000002 4.55999994 !! > was -flag specified? F !! > F F !! > ANY: F !! > ALL: F !! > You must specify --ints or --floats !! > 1 F T F !! > 1 is not an even number from 10 to 30 inclusive !! > 10 T T T !! > 10 is an even number from 10 to 30 inclusive !! > 11 T T F !! > 11 is not an even number from 10 to 30 inclusive !! > red matches a value in the list !! > ints(:) has expected number of values !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure function specified(key) character(len=*),intent(in) :: key logical :: specified integer :: place call locate_key(key,place) ! find where string is or should be if(place < 1)then specified=.false. else specified=present_in(place) endif end function specified !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given !! keyword and value !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine update(key,val) !! !! character(len=*),intent(in) :: key !! character(len=*),intent(in),optional :: val !!##DESCRIPTION !! Update internal dictionary in M_CLI2(3fm) module. !!##OPTIONS !! key name of keyword to add, replace, or delete from dictionary !! val if present add or replace value associated with keyword. If not !! present remove keyword entry from dictionary. !! !! If "present" is true, a value will be appended !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine update(key,val) character(len=*),intent(in) :: key character(len=*),intent(in),optional :: val integer :: place, ii integer :: iilen character(len=:),allocatable :: val_local character(len=:),allocatable :: short character(len=:),allocatable :: long character(len=:),allocatable :: long_short(:) integer :: isize logical :: set_mandatory set_mandatory=.false. if(G_IGNOREALLCASE) then call split(lower(trim(key)),long_short,':',nulls='return') ! split long:short keyword or long:short:: or long:: or short:: else call split(trim(key),long_short,':',nulls='return') ! split long:short keyword or long:short:: or long:: or short:: endif ! check for :: on end isize=size(long_short) if(isize > 0)then ! very special-purpose syntax where if ends in :: next field is a value even if(long_short(isize) == '')then ! if it starts with a dash, for --flags option on fpm(1). set_mandatory=.true. long_short=long_short(:isize-1) endif endif select case(size(long_short)) case(0) long='' short='' case(1) long=trim(long_short(1)) if(len_trim(long) == 1)then !x!ii= findloc (shorts, long, dim=1) ! if parsing arguments on line and a short keyword look up long value ii=maxloc([0,merge(1, 0, shorts == long)],dim=1) if(ii > 1)then long=keywords(ii-1) endif short=long else short='' endif case(2) long=trim(long_short(1)) short=trim(long_short(2)) case default write(warn,*)'WARNING: incorrect syntax for key: ',trim(key) long=trim(long_short(1)) short=trim(long_short(2)) end select if(G_UNDERDASH) long=replace_str(long,'-','_') if(G_NODASHUNDER)then long=replace_str(long,'-','') long=replace_str(long,'_','') endif if(G_IGNORELONGCASE.and.len_trim(long) > 1)long=lower(long) if(present(val))then val_local=val iilen=len_trim(val_local) call locate_key(long,place) ! find where string is or should be if(place < 1)then ! if string was not found insert it call insert_(keywords,long,iabs(place)) call insert_(values,val_local,iabs(place)) call insert_(counts,iilen,iabs(place)) call insert_(shorts,short,iabs(place)) call insert_(present_in,.true.,iabs(place)) call insert_(mandatory,set_mandatory,iabs(place)) else if(present_in(place))then ! if multiple keywords append values with space between them if(G_append)then if(values(place)(1:1) == '"')then ! UNDESIRABLE: will ignore previous blank entries val_local='"'//trim(unquote(values(place)))//' '//trim(unquote(val_local))//'"' else val_local=clipends(values(place))//' '//val_local endif endif iilen=len_trim(val_local) endif call replace_(values,val_local,place) call replace_(counts,iilen,place) call replace_(present_in,.true.,place) endif else ! if no value is present remove the keyword and related values call locate_key(long,place) ! check name as long and short if(place > 0)then call remove_(keywords,place) call remove_(values,place) call remove_(counts,place) call remove_(shorts,place) call remove_(present_in,place) call remove_(mandatory,place) endif endif end subroutine update !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! wipe_dictionary(3fp) - [ARGUMENTS:M_CLI2] reset private M_CLI2(3fm) !! dictionary to empty !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine wipe_dictionary() !!##DESCRIPTION !! reset private M_CLI2(3fm) dictionary to empty !!##EXAMPLE !! !! Sample program: !! !! program demo_wipe_dictionary !! use M_CLI2, only : dictionary !! call wipe_dictionary() !! end program demo_wipe_dictionary !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine wipe_dictionary() if(allocated(keywords))deallocate(keywords) allocate(character(len=0) :: keywords(0)) if(allocated(values))deallocate(values) allocate(character(len=0) :: values(0)) if(allocated(counts))deallocate(counts) allocate(counts(0)) if(allocated(shorts))deallocate(shorts) allocate(character(len=0) :: shorts(0)) if(allocated(present_in))deallocate(present_in) allocate(present_in(0)) if(allocated(mandatory))deallocate(mandatory) allocate(mandatory(0)) end subroutine wipe_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with !! key name in private M_CLI2(3fm) dictionary !!##SYNOPSIS !! !! !!##DESCRIPTION !! Get dictionary value associated with key name in private M_CLI2(3fm) !! dictionary. !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !=================================================================================================================================== function get(key) result(valout) character(len=*),intent(in) :: key character(len=:),allocatable :: valout integer :: place ! find where string is or should be call locate_key(key,place) if(place < 1)then valout='' else valout=values(place)(:counts(place)) endif end function get !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert !! Unix-like command arguments to table !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine prototype_and_cmd_args_to_nlist(prototype) !! !! character(len=*) :: prototype !!##DESCRIPTION !! create dictionary with character keywords, values, and value lengths !! using the routines for maintaining a list from command line arguments. !!##OPTIONS !! prototype !!##EXAMPLE !! !! Sample program !! !! program demo_prototype_and_cmd_args_to_nlist !! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed !! implicit none !! character(len=:),allocatable :: readme !! character(len=256) :: message !! integer :: ios !! integer :: i !! doubleprecision :: something !! !! ! define arguments !! logical :: l,h,v !! real :: p(2) !! complex :: c !! doubleprecision :: x,y,z !! !! ! uppercase keywords get an underscore to make it easier to remember !! logical :: l_,h_,v_ !! ! character variables must be long enough to hold returned value !! character(len=256) :: a_,b_ !! integer :: c_(3) !! !! ! give command template with default values !! ! all values except logicals get a value. !! ! strings must be delimited with double quotes !! ! A string has to have at least one character as for -A !! ! lists of numbers should be comma-delimited. !! ! No spaces are allowed in lists of numbers !! call prototype_and_cmd_args_to_nlist('& !! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 & !! & -A " " -B "Value B" -C 10,20,30 -c (-123,-456)',readme) !! !! call get_args('x',x,'y',y,'z',z) !! something=sqrt(x**2+y**2+z**2) !! write (*,*)something,x,y,z !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program demo_prototype_and_cmd_args_to_nlist !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine prototype_and_cmd_args_to_nlist(prototype,string) ! ident_4="@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line" character(len=*),intent(in) :: prototype character(len=*),intent(in),optional :: string integer :: ibig integer :: itrim integer :: iused if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:START' G_passed_in=prototype ! make global copy for printing ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine ibig=max(ibig,1) IF(ALLOCATED(UNNAMED))DEALLOCATE(UNNAMED) ALLOCATE(CHARACTER(LEN=IBIG) :: UNNAMED(0)) if(allocated(args))deallocate(args) allocate(character(len=ibig) :: args(0)) G_remaining_option_allowed=.false. G_remaining_on=.false. G_remaining='' if(prototype /= '')then call prototype_to_dictionary(prototype) ! build dictionary from prototype ! if short keywords not used by user allow them for standard options call locate_key('h',iused) if(iused <= 0)then call update('help') call update('help:h','F') endif call locate_key('v',iused) if(iused <= 0)then call update('version') call update('version:v','F') endif call locate_key('V',iused) if(iused <= 0)then call update('verbose') call update('verbose:V','F') endif call locate_key('u',iused) if(iused <= 0)then call update('usage') call update('usage:u','F') endif present_in=.false. ! reset all values to false so everything gets written endif if(present(string))then ! instead of command line arguments use another prototype string if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:CALL PROTOTYPE_TO_DICTIONARY:STRING=',STRING call prototype_to_dictionary(string) ! build dictionary from prototype else if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:CALL CMD_ARGS_TO_DICTIONARY:CHECK=',.true. call cmd_args_to_dictionary() endif if( len(G_remaining) > 1)then ! if -- was in prototype then after -- on input return rest in this string itrim=len(G_remaining) if(G_remaining(itrim:itrim) == ' ')then ! was adding a space at end as building it, but do not want to remove blanks G_remaining=G_remaining(:itrim-1) endif remaining=G_remaining endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:NORMAL END' end subroutine prototype_and_cmd_args_to_nlist !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine expand_response(name) character(len=*),intent(in) :: name character(len=:),allocatable :: prototype logical :: hold if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:START:NAME=',name call get_prototype(name,prototype) if(prototype /= '')then hold=G_append G_append=.false. if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:CALL PROTOTYPE_TO_DICTIONARY:PROTOTYPE=',prototype call prototype_to_dictionary(prototype) ! build dictionary from prototype G_append=hold endif if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:END' end subroutine expand_response !=================================================================================================================================== subroutine get_prototype(name,prototype) ! process @name abbreviations character(len=*),intent(in) :: name character(len=:),allocatable,intent(out) :: prototype character(len=:),allocatable :: filename character(len=:),allocatable :: os character(len=:),allocatable :: plain_name character(len=:),allocatable :: search_for integer :: lun integer :: ios integer :: itrim character(len=4096) :: line !x! assuming input never this long character(len=256) :: message character(len=:),allocatable :: array(:) ! output array of tokens integer :: lines_processed lines_processed=0 plain_name=name//' ' plain_name=trim(name(2:)) os= '@' // get_env('OSTYPE',get_env('OS')) if(G_DEBUG)write(*,gen)'GET_PROTOTYPE:OS=',OS search_for='' ! look for NAME.rsp and see if there is an @OS section in it and position to it and read if(os /= '@')then search_for=os call find_and_read_response_file(plain_name) if(lines_processed /= 0)return endif ! look for NAME.rsp and see if there is anything before an OS-specific section search_for='' call find_and_read_response_file(plain_name) if(lines_processed /= 0)return ! look for ARG0.rsp with @OS@NAME section in it and position to it if(os /= '@')then search_for=os//name call find_and_read_response_file(basename(get_name(),suffix=.false.)) if(lines_processed /= 0)return endif ! look for ARG0.rsp with a section called @NAME in it and position to it search_for=name call find_and_read_response_file(basename(get_name(),suffix=.false.)) if(lines_processed /= 0)return write(*,gen)' response name ['//trim(name)//'] not found' stop 1 contains !=================================================================================================================================== subroutine find_and_read_response_file(rname) ! search for a simple file named the same as the @NAME field with one entry assumed in it character(len=*),intent(in) :: rname character(len=:),allocatable :: paths(:) character(len=:),allocatable :: testpath character(len=256) :: message integer :: i integer :: ios prototype='' ! look for NAME.rsp ! assume if have / or \ a full filename was supplied to support ifort(1) if((index(rname,'/') /= 0.or.index(rname,'\') /= 0) .and. len(rname) > 1 )then filename=rname lun=fileopen(filename,message) if(lun /= -1)then call process_response() close(unit=lun,iostat=ios) endif return else filename=rname//'.rsp' endif if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:FILENAME=',filename ! look for name.rsp in directories from environment variable assumed to be a colon-separated list of directories call split(get_env('CLI_RESPONSE_PATH','~/.local/share/rsp'),paths) paths=[character(len=len(paths)) :: ' ',paths] if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:PATHS=',paths do i=1,size(paths) testpath=join_path(paths(i),filename) lun=fileopen(testpath,message) if(lun /= -1)then if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:SEARCH_FOR=',search_for if(search_for /= '') call position_response() ! set to end of file or where string was found call process_response() if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:LINES_PROCESSED=',LINES_PROCESSED close(unit=lun,iostat=ios) if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:CLOSE:LUN=',LUN,' IOSTAT=',IOS if(lines_processed /= 0)exit endif enddo end subroutine find_and_read_response_file !=================================================================================================================================== subroutine position_response() integer :: ios line='' INFINITE: do read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then if(G_DEBUG)write(*,gen)'POSITION_RESPONSE:EOF' backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)'*position_response*:'//trim(message) exit INFINITE endif line=adjustl(line) if(line == search_for)return enddo INFINITE end subroutine position_response !=================================================================================================================================== subroutine process_response() character(len=:),allocatable :: padded character(len=:),allocatable :: temp line='' lines_processed=0 INFINITE: do read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)'*process_response*:'//trim(message) exit INFINITE endif line=clipends(line) temp=line if(index(temp//' ','#') == 1)cycle if(temp /= '')then if(index(temp,'@') == 1.and.lines_processed /= 0)exit INFINITE call split(temp,array) ! get first word itrim=len_trim(array(1))+2 temp=temp(itrim:) PROCESS: select case(lower(array(1))) case('comment','#','') case('system','!','$') if(G_options_only)exit PROCESS lines_processed= lines_processed+1 call execute_command_line(temp) case('options','option','-') lines_processed= lines_processed+1 prototype=prototype//' '//trim(temp) case('print','>','echo') if(G_options_only)exit PROCESS lines_processed= lines_processed+1 write(*,'(a)')trim(temp) case('stop') if(G_options_only)exit PROCESS write(*,'(a)')trim(temp) stop case default if(array(1)(1:1) == '-')then ! assume these are simply options to support ifort(1) ! if starts with a single dash must assume a single argument ! and rest is value to support -Dname and -Ifile option ! which currently is not supported, so multiple short keywords ! does not work. Just a ifort(1) test at this point, so do not document if(G_options_only)exit PROCESS padded=trim(line)//' ' if(padded(2:2) == '-')then prototype=prototype//' '//trim(line) else prototype=prototype//' '//padded(1:2)//' '//trim(padded(3:)) endif lines_processed= lines_processed+1 else if(array(1)(1:1) == '@')cycle INFINITE !skip adjacent @ lines from first lines_processed= lines_processed+1 write(*,'(*(g0))')'unknown response keyword [',array(1),'] with options of [',trim(temp),']' endif end select PROCESS endif enddo INFINITE end subroutine process_response end subroutine get_prototype !=================================================================================================================================== function fileopen(filename,message) result(lun) character(len=*),intent(in) :: filename character(len=*),intent(out),optional :: message integer :: lun integer :: ios character(len=256) :: message_local ios=0 message_local='' open(file=filename,newunit=lun,& & form='formatted',access='sequential',action='read',& & position='rewind',status='old',iostat=ios,iomsg=message_local) if(ios /= 0)then lun=-1 if(present(message))then message=trim(message_local) else write(*,gen)trim(message_local) endif endif if(G_DEBUG)write(*,gen)'FILEOPEN:FILENAME=',filename,' LUN=',lun,' IOS=',IOS,' MESSAGE=',trim(message_local) end function fileopen !=================================================================================================================================== function get_env(NAME,DEFAULT) result(VALUE) character(len=*),intent(in) :: NAME character(len=*),intent(in),optional :: DEFAULT character(len=:),allocatable :: VALUE integer :: howbig integer :: stat integer :: length ! get length required to hold value length=0 if(NAME /= '')then call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) select case (stat) case (1) !x!print *, NAME, " is not defined in the environment. Strange..." VALUE='' case (2) !x!print *, "This processor doesn't support environment variables. Boooh!" VALUE='' case default ! make string to hold value of sufficient size if(allocated(value))deallocate(value) allocate(character(len=max(howbig,1)) :: VALUE) ! get value call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) if(stat /= 0)VALUE='' end select else VALUE='' endif if(VALUE == ''.and.present(DEFAULT))VALUE=DEFAULT end function get_env !=================================================================================================================================== function join_path(a1,a2,a3,a4,a5) result(path) ! Construct path by joining strings with os file separator ! character(len=*), intent(in) :: a1, a2 character(len=*), intent(in), optional :: a3, a4, a5 character(len=:), allocatable :: path character(len=1) :: filesep filesep = separator() if(a1 /= '')then path = trim(a1) // filesep // trim(a2) else path = trim(a2) endif if (present(a3)) path = path // filesep // trim(a3) if (present(a4)) path = path // filesep // trim(a4) if (present(a5)) path = path // filesep // trim(a5) path=adjustl(path//' ') path=path(1:1)//replace_str(path,filesep//filesep,'') ! some systems allow names starting with '//' or '\\' path=trim(path) end function join_path !=================================================================================================================================== function get_name() result(name) ! get the pathname of arg0 character(len=:),allocatable :: arg0 integer :: arg0_length integer :: istat character(len=4096) :: long_name character(len=:),allocatable :: name arg0_length=0 name='' long_name='' call get_command_argument(0,length=arg0_length,status=istat) if(istat == 0)then if(allocated(arg0))deallocate(arg0) allocate(character(len=arg0_length) :: arg0) call get_command_argument(0,arg0,status=istat) if(istat == 0)then inquire(file=arg0,iostat=istat,name=long_name) name=trim(long_name) else name=arg0 endif endif end function get_name !=================================================================================================================================== function basename(path,suffix) result (base) ! Extract filename from path with/without suffix ! character(*), intent(In) :: path logical, intent(in), optional :: suffix character(:), allocatable :: base character(:), allocatable :: file_parts(:) logical :: with_suffix if (.not.present(suffix)) then with_suffix = .true. else with_suffix = suffix endif if (with_suffix) then call split(path,file_parts,delimiters='\/') if(size(file_parts) > 0)then base = trim(file_parts(size(file_parts))) else base = '' endif else call split(path,file_parts,delimiters='\/.') if(size(file_parts) >= 2)then base = trim(file_parts(size(file_parts)-1)) elseif(size(file_parts) == 1)then base = trim(file_parts(1)) else base = '' endif endif end function basename !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !! !> !!##NAME !! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory !! separator character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! function separator() result(sep) !! !! character(len=1) :: sep !! !!##DESCRIPTION !! First testing for the existence of "/.", then if that fails a list !! of variable names assumed to contain directory paths {PATH|HOME} are !! examined first for a backslash, then a slash. Assuming basically the !! choice is a ULS or MSWindows system, and users can do weird things like !! put a backslash in a ULS path and break it. !! !! Therefore can be very system dependent. If the queries fail the !! default returned is "/". !! !!##EXAMPLE !! !! !! sample usage !! !! program demo_separator !! use M_io, only : separator !! implicit none !! write(*,*)'separator=',separator() !! end program demo_separator !=================================================================================================================================== function separator() result(sep) ! use the pathname returned as arg0 to determine pathname separator integer :: ios integer :: i logical :: existing=.false. character(len=1) :: sep !x!IFORT BUG:character(len=1),save :: sep_cache=' ' integer,save :: isep=-1 character(len=4096) :: name character(len=:),allocatable :: envnames(:) ! NOTE: A parallel code might theoretically use multiple OS !x!FORT BUG:if(sep_cache /= ' ')then ! use cached value. !x!FORT BUG: sep=sep_cache !x!FORT BUG: return !x!FORT BUG:endif if(isep /= -1)then ! use cached value. sep=char(isep) return endif FOUND: block ! simple, but does not work with ifort ! most MSWindows environments see to work with backslash even when ! using POSIX filenames to do not rely on '\.'. inquire(file='/.',exist=existing,iostat=ios,name=name) if(existing.and.ios == 0)then sep='/' exit FOUND endif ! check variables names common to many platforms that usually have a ! directory path in them although a ULS file can contain a backslash ! and vice-versa (eg. "touch A\\B\\C"). Removed HOMEPATH because it ! returned a name with backslash on CygWin, Mingw, WLS even when using ! POSIX filenames in the environment. envnames=[character(len=10) :: 'PATH', 'HOME'] do i=1,size(envnames) if(index(get_env(envnames(i)),'\') /= 0)then sep='\' exit FOUND elseif(index(get_env(envnames(i)),'/') /= 0)then sep='/' exit FOUND endif enddo write(*,*)'unknown system directory path separator' sep='\' endblock FOUND !x!IFORT BUG:sep_cache=sep isep=ichar(sep) end function separator !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine cmd_args_to_dictionary() ! convert command line arguments to dictionary entries !x!logical :: guess_if_value integer :: pointer character(len=:),allocatable :: lastkeyword integer :: i, jj, kk integer :: ilength, istatus, imax character(len=1) :: letter character(len=:),allocatable :: current_argument character(len=:),allocatable :: current_argument_padded character(len=:),allocatable :: dummy character(len=:),allocatable :: oldvalue logical :: nomore logical :: next_mandatory if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START' next_mandatory=.false. nomore=.false. pointer=0 lastkeyword=' ' G_keyword_single_letter=.true. i=1 current_argument='' GET_ARGS: do while (get_next_argument()) ! insert and replace entries if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:WHILE:CURRENT_ARGUMENT=',current_argument if( current_argument == '-' .and. nomore .eqv. .true. )then ! sort of elseif( current_argument == '-')then ! sort of current_argument='"stdin"' endif if( current_argument == '--' .and. nomore .eqv. .true. )then ! -- was already encountered elseif( current_argument == '--' )then ! everything after this goes into the unnamed array nomore=.true. pointer=0 if(G_remaining_option_allowed)then G_remaining_on=.true. endif cycle GET_ARGS endif dummy=current_argument//' ' current_argument_padded=current_argument//' ' if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == '--')then ! beginning of long word if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_LONG:' G_keyword_single_letter=.false. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(3:),pointer) if(pointer <= 0)then if(G_QUIET)then lastkeyword="UNKNOWN" pointer=0 cycle GET_ARGS endif call print_dictionary('UNKNOWN LONG KEYWORD: '//current_argument) call mystop(1) return endif lastkeyword=trim(current_argument_padded(3:)) next_mandatory=mandatory(pointer) elseif(.not.next_mandatory & & .and..not.nomore & & .and.current_argument_padded(1:1) == '-' & & .and.index("0123456789.",dummy(2:2)) == 0)then ! short word if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_SHORT' G_keyword_single_letter=.true. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(2:),pointer) jj=len(current_argument) if( (pointer <= 0.or.jj.ge.3).and.(G_STRICT) )then ! name not found if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT NOT FOUND:',current_argument_padded(2:) ! in strict mode this might be multiple single-character values do kk=2,jj letter=current_argument_padded(kk:kk) call locate_key(letter,pointer) if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:LETTER:',letter,pointer if(pointer > 0)then call update(keywords(pointer),'T') else if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT:',letter call print_dictionary('UNKNOWN SHORT KEYWORD:'//letter) ! //' in '//current_argument) if(G_QUIET)then lastkeyword="UNKNOWN" pointer=0 cycle GET_ARGS endif call mystop(2) return endif current_argument='-'//current_argument_padded(jj:jj) enddo !-------------- lastkeyword="" pointer=0 if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:2:' cycle GET_ARGS !-------------- elseif(pointer<0)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT_CONFIRMED:',letter call print_dictionary('UNKNOWN SHORT KEYWORD:'//current_argument_padded(2:)) if(G_QUIET)then lastkeyword="UNKNOWN" pointer=0 cycle GET_ARGS endif call mystop(2) return endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:1:' lastkeyword=trim(current_argument_padded(2:)) next_mandatory=mandatory(pointer) elseif(pointer == 0)then ! unnamed arguments if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNNAMED ARGUMENT:',current_argument if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//'"" ' elseif(current_argument(1:1) == '-')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//'"'//current_argument//'" ' else G_remaining=G_remaining//'"'//current_argument//'" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ','@') == 1.and.G_response)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:1:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif else if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:FOUND:',current_argument oldvalue=get(keywords(pointer))//' ' if(oldvalue(1:1) == '"')then current_argument=quote(current_argument(:ilength)) endif if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then ! assume boolean parameter if(current_argument /= ' ')then if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//'"" ' elseif(current_argument(1:1) == '-')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//'"'//current_argument//'" ' else G_remaining=G_remaining//'"'//current_argument//'" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ','@') == 1.and.G_response)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif endif current_argument='T' endif call update(keywords(pointer),current_argument) pointer=0 lastkeyword='' next_mandatory=.false. endif enddo GET_ARGS if(lastkeyword /= '')then call ifnull() endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:NORMAL END' contains subroutine ifnull() oldvalue=clipends(get(lastkeyword))//' ' if(upper(oldvalue(1:1)) == 'F'.or.upper(oldvalue(1:1)) == 'T')then call update(lastkeyword,'T') elseif(oldvalue(1:1) == '"')then call update(lastkeyword,'" "') else call update(lastkeyword,' ') endif end subroutine ifnull function get_next_argument() ! ! get next argument from command line into allocated variable current_argument ! logical,save :: hadequal=.false. character(len=:),allocatable,save :: right_hand_side logical :: get_next_argument integer :: iright integer :: iequal if(hadequal)then ! use left-over value from previous -NAME=VALUE syntax current_argument=right_hand_side right_hand_side='' hadequal=.false. get_next_argument=.true. ilength=len(current_argument) return endif if(i>command_argument_count())then get_next_argument=.false. return else get_next_argument=.true. endif call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining argument ',i,& &'status=',istatus,& &'length=',ilength get_next_argument=.false. else ilength=max(ilength,1) if(allocated(current_argument))deallocate(current_argument) allocate(character(len=ilength) :: current_argument) call get_command_argument(number=i,value=current_argument,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining argument ',i,& &'status=',istatus,& &'length=',ilength,& &'target length=',len(current_argument) get_next_argument=.false. endif ! if an argument keyword and an equal before a space split on equal and save right hand side for next call if(nomore)then elseif( len(current_argument) == 0)then else iright=index(current_argument,' ') if(iright == 0)iright=len(current_argument) iequal=index(current_argument(:iright),'=') if(next_mandatory)then elseif(iequal /= 0.and.current_argument(1:1) == '-')then if(iequal /= len(current_argument))then right_hand_side=current_argument(iequal+1:) else right_hand_side='' endif hadequal=.true. current_argument=current_argument(:iequal-1) endif endif endif i=i+1 end function get_next_argument end subroutine cmd_args_to_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary !! created by calls to set_args(3f) !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine print_dictionary(header,stop) !! !! character(len=*),intent(in),optional :: header !! logical,intent(in),optional :: stop !!##DESCRIPTION !! Print the internal dictionary created by calls to set_args(3f). !! This routine is intended to print the state of the argument list !! if an error occurs in using the set_args(3f) procedure. !!##OPTIONS !! HEADER label to print before printing the state of the command !! argument list. !! STOP logical value that if true stops the program after displaying !! the dictionary. !!##EXAMPLE !! !! !! !! Typical usage: !! !! program demo_print_dictionary !! use M_CLI2, only : set_args, get_args !! implicit none !! real :: x, y, z !! call set_args('-x 10 -y 20 -z 30') !! call get_args('x',x,'y',y,'z',z) !! ! all done cracking the command line; use the values in your program. !! write(*,*)x,y,z !! end program demo_print_dictionary !! !! Sample output !! !! Calling the sample program with an unknown parameter or the --usage !! switch produces the following: !! !! $ ./demo_print_dictionary -A !! UNKNOWN SHORT KEYWORD: -A !! KEYWORD PRESENT VALUE !! z F [3] !! y F [2] !! x F [1] !! help F [F] !! version F [F] !! usage F [F] !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine print_dictionary(header,stop) character(len=*),intent(in),optional :: header logical,intent(in),optional :: stop integer :: i if(G_QUIET)return if(present(header))then if(header /= '')then write(warn,'(a)')header endif endif if(allocated(keywords))then if(size(keywords) > 0)then write(warn,'(a,1x,a,1x,a,1x,a)')atleast('KEYWORD',max(len(keywords),8)),'SHORT','PRESENT','VALUE' write(warn,'(*(a,1x,a5,1x,l1,8x,"[",a,"]",/))') & & (atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=size(keywords),1,-1) endif endif if(allocated(unnamed))then if(size(unnamed) > 0)then write(warn,'(a)')'UNNAMED' write(warn,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) endif endif if(allocated(args))then if(size(args) > 0)then write(warn,'(a)')'ARGS' write(warn,'(i6.6,3a)')(i,'[',args(i),']',i=1,size(args)) endif endif if(G_remaining /= '')then write(warn,'(a)')'REMAINING' write(warn,'(a)')G_remaining endif if(present(stop))then if(stop) call mystop(5) endif end subroutine print_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing !! command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! get_args(3f) and its convenience functions: !! !! use M_CLI2, only : get_args !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! !! subroutine get_args(name,value,delimiters) !! !! character(len=*),intent(in) :: name !! !! type(${TYPE}),allocatable,intent(out) :: value(:) !! ! or !! type(${TYPE}),allocatable,intent(out) :: value !! !! character(len=*),intent(in),optional :: delimiters !! !! where ${TYPE} may be from the set !! {real,doubleprecision,integer,logical,complex,character(len=:)} !!##DESCRIPTION !! !! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has !! been called to parse the command line. For fixed-length CHARACTER !! variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see !! GET_ARGS_FIXED_SIZE(3f). !! !! As a convenience multiple pairs of keywords and variables may be !! specified if and only if all the values are scalars and the CHARACTER !! variables are fixed-length or pre-allocated. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! VALUE variable to hold returned value. The kind of the value !! is used to determine the type of returned value. May !! be a scalar or allocatable array. If type is CHARACTER !! the scalar must have an allocatable length. !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##CONVENIENCE FUNCTIONS !! There are convenience functions that are replacements for calls to !! get_args(3f) for each supported default intrinsic type !! !! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), !! cget(3f) !! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f), !! sgets(3f), cgets(3f) !! !! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL, !! S for string (CHARACTER), and C for COMPLEX. !! !! If the functions are called with no argument they will return the !! UNNAMED array converted to the specified type. !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_get_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! implicit none !! integer :: i !! ! Define ARGS !! real :: x, y, z !! real,allocatable :: p(:) !! character(len=:),allocatable :: title !! logical :: l, lbig !! ! Define and parse (to set initial values) command line !! ! o only quote strings and use double-quotes !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1,-2,-3 & !! & --title "my title" & !! & -l F -L F & !! & --label " " & !! & ') !! ! Assign values to elements !! ! Scalars !! call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig) !! ! Allocatable string !! call get_args('title',title) !! ! Allocatable arrays !! call get_args('p',p) !! ! Use values !! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_get_args !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-length string when parsing command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_length(name,value) !! !! character(len=*),intent(in) :: name !! character(len=:),allocatable :: value !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! get_args_fixed_length(3f) returns the value of a string !! keyword when the string value is a fixed-length CHARACTER !! variable. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned value. !! Must be a fixed-length CHARACTER variable. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_length !! use M_CLI2, only : set_args, get_args_fixed_length !! implicit none !! !! ! Define args !! character(len=80) :: title !! ! Parse command line !! call set_args(' --title "my title" ') !! ! Assign values to variables !! call get_args_fixed_length('title',title) !! ! Use values !! write(*,*)'title=',title !! !! end program demo_get_args_fixed_length !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-size array when parsing command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_size(name,value) !! !! character(len=*),intent(in) :: name !! [real|doubleprecision|integer|logical|complex] :: value(NNN) !! or !! character(len=MMM) :: value(NNN) !! !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! get_args_fixed_size(3f) returns the value of keywords for fixed-size !! arrays after set_args(3f) has been called. On input on the command !! line all values of the array must be specified. !! !!##OPTIONS !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned values. The kind of the value !! is used to determine the type of returned value. Must be !! a fixed-size array. If type is CHARACTER the length must !! also be fixed. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_size !! use M_CLI2, only : set_args, get_args_fixed_size !! implicit none !! integer,parameter :: dp=kind(0.0d0) !! ! DEFINE ARGS !! real :: x(2) !! real(kind=dp) :: y(2) !! integer :: p(3) !! character(len=80) :: title(1) !! logical :: l(4), lbig(4) !! complex :: cmp(2) !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o only quote strings !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 10.0,20.0 & !! & -y 11.0,22.0 & !! & -p -1,-2,-3 & !! & --title "my title" & !! & -l F,T,F,T -L T,F,T,F & !! & --cmp 111,222.0,333.0e0,4444 & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! call get_args_fixed_size('x',x) !! call get_args_fixed_size('y',y) !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('title',title) !! call get_args_fixed_size('l',l) !! call get_args_fixed_size('L',lbig) !! call get_args_fixed_size('cmp',cmp) !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'cmp=',cmp !! end program demo_get_args_fixed_size !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine get_fixedarray_class(keyword,generic,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary class(*) :: generic(:) character(len=*),intent(in),optional :: delimiters select type(generic) type is (character(len=*)); call get_fixedarray_fixed_length_c(keyword,generic,delimiters) type is (integer); call get_fixedarray_i(keyword,generic,delimiters) type is (real); call get_fixedarray_r(keyword,generic,delimiters) type is (complex); call get_fixed_size_complex(keyword,generic,delimiters) type is (real(kind=dp)); call get_fixedarray_d(keyword,generic,delimiters) type is (logical); call get_fixedarray_l(keyword,generic,delimiters) class default call mystop(-7,'*get_fixedarray_class* crud -- procedure does not know about this type') end select end subroutine get_fixedarray_class !=================================================================================================================================== ! return allocatable arrays !=================================================================================================================================== subroutine get_anyarray_l(keyword,larray,delimiters) ! ident_5="@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)" character(len=*),intent(in) :: keyword ! the dictionary keyword (in form VERB_KEYWORD) to retrieve logical,allocatable :: larray(:) ! convert value to an array character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: carray(:) ! convert value to an array character(len=:),allocatable :: val integer :: i integer :: place integer :: iichar ! point to first character of word unless first character is "." call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if string was found val=values(place)(:counts(place)) call split(adjustl(upper(val)),carray,delimiters=delimiters) ! convert value to uppercase, trimmed; then parse into array else call journal('*get_anyarray_l* unknown keyword',keyword) call mystop(8 ,'*get_anyarray_l* unknown keyword '//keyword) if(allocated(larray))deallocate(larray) allocate(larray(0)) return endif if(size(carray) > 0)then ! if not a null string if(allocated(larray))deallocate(larray) allocate(larray(size(carray))) ! allocate output array do i=1,size(carray) larray(i)=.false. ! initialize return value to .false. if(carray(i)(1:1) == '.')then ! looking for fortran logical syntax .STRING. iichar=2 else iichar=1 endif select case(carray(i)(iichar:iichar)) ! check word to see if true or false case('T','Y',' '); larray(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) case('F','N'); larray(i)=.false. ! assume this is false or no case default call journal("*get_anyarray_l* bad logical expression for ",(keyword),'=',carray(i)) end select enddo else ! for a blank string return one T if(allocated(larray))deallocate(larray) allocate(larray(1)) ! allocate output array larray(1)=.true. endif end subroutine get_anyarray_l !=================================================================================================================================== subroutine get_anyarray_d(keyword,darray,delimiters) ! ident_6="@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)" character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real(kind=dp),allocatable,intent(out) :: darray(:) ! function type character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: carray(:) ! convert value to an array using split(3f) integer :: i integer :: place integer :: ierr character(len=:),allocatable :: val !----------------------------------------------------------------------------------------------------------------------------------- call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if string was found val=values(place)(:counts(place)) val=replace_str(val,'(','') val=replace_str(val,')','') call split(val,carray,delimiters=delimiters) ! find value associated with keyword and split it into an array else call journal('*get_anyarray_d* unknown keyword '//keyword) call mystop(9 ,'*get_anyarray_d* unknown keyword '//keyword) if(allocated(darray))deallocate(darray) allocate(darray(0)) return endif if(allocated(darray))deallocate(darray) allocate(darray(size(carray))) ! create the output array do i=1,size(carray) call a2d(carray(i), darray(i),ierr) ! convert the string to a numeric value if(ierr /= 0)then call mystop(10 ,'*get_anyarray_d* unreadable value '//carray(i)//' for keyword '//keyword) endif enddo end subroutine get_anyarray_d !=================================================================================================================================== subroutine get_anyarray_i(keyword,iarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary integer,allocatable :: iarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type call get_anyarray_d(keyword,darray,delimiters) iarray=nint(darray) end subroutine get_anyarray_i !=================================================================================================================================== subroutine get_anyarray_r(keyword,rarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real,allocatable :: rarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type call get_anyarray_d(keyword,darray,delimiters) rarray=real(darray) end subroutine get_anyarray_r !=================================================================================================================================== subroutine get_anyarray_x(keyword,xarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary complex(kind=sp),allocatable :: xarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type integer :: half,sz,i call get_anyarray_d(keyword,darray,delimiters) sz=size(darray) half=sz/2 if(sz /= half+half)then call journal('*get_anyarray_x* uneven number of values defining complex value '//keyword) call mystop(11,'*get_anyarray_x* uneven number of values defining complex value '//keyword) if(allocated(xarray))deallocate(xarray) allocate(xarray(0)) endif !x!================================================================================================ !x!IFORT,GFORTRAN OK, NVIDIA RETURNS NULL ARRAY: xarray=cmplx(real(darray(1::2)),real(darray(2::2))) if(allocated(xarray))deallocate(xarray) allocate(xarray(half)) do i=1,sz,2 xarray((i+1)/2)=cmplx( darray(i),darray(i+1),kind=sp ) enddo !x!================================================================================================ end subroutine get_anyarray_x !=================================================================================================================================== subroutine get_anyarray_c(keyword,strings,delimiters) ! ident_7="@(#) M_CLI2 get_anyarray_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=:),allocatable :: strings(:) character(len=*),intent(in),optional :: delimiters integer :: place character(len=:),allocatable :: val call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if index is valid return strings val=unquote(values(place)(:counts(place))) call split(val,strings,delimiters=delimiters) ! find value associated with keyword and split it into an array else call journal('*get_anyarray_c* unknown keyword '//keyword) call mystop(12,'*get_anyarray_c* unknown keyword '//keyword) if(allocated(strings))deallocate(strings) allocate(character(len=0)::strings(0)) endif end subroutine get_anyarray_c !=================================================================================================================================== subroutine get_args_fixed_length_a_array(keyword,strings,delimiters) ! ident_8="@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=*),allocatable :: strings(:) character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: strings_a(:) integer :: place character(len=:),allocatable :: val integer :: ibug call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if index is valid return strings val=unquote(values(place)(:counts(place))) call split(val,strings_a,delimiters=delimiters) ! find value associated with keyword and split it into an array if( len(strings_a) <= len(strings) )then strings=strings_a else ibug=len(strings) call journal('*get_args_fixed_length_a_array* values too long. Longest is',len(strings_a),'allowed is',ibug) write(*,'("strings=",3x,*(a,1x))')strings call journal('*get_args_fixed_length_a_array* keyword='//keyword) call mystop(13,'*get_args_fixed_length_a_array* keyword='//keyword) strings=[character(len=len(strings)) ::] endif else call journal('*get_args_fixed_length_a_array* unknown keyword '//keyword) call mystop(14,'*get_args_fixed_length_a_array* unknown keyword '//keyword) strings=[character(len=len(strings)) ::] endif end subroutine get_args_fixed_length_a_array !=================================================================================================================================== ! return non-allocatable arrays !=================================================================================================================================== subroutine get_fixedarray_i(keyword,iarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary integer :: iarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_d(keyword,darray,delimiters) dsize=size(darray) if(ubound(iarray,dim=1) == dsize)then iarray=nint(darray) else ibug=size(iarray) call journal('*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(33) iarray=0 endif end subroutine get_fixedarray_i !=================================================================================================================================== subroutine get_fixedarray_r(keyword,rarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real :: rarray(:) character(len=*),intent(in),optional :: delimiters real,allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_r(keyword,darray,delimiters) dsize=size(darray) if(ubound(rarray,dim=1) == dsize)then rarray=darray else ibug=size(rarray) call journal('*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(33) rarray=0.0 endif end subroutine get_fixedarray_r !=================================================================================================================================== subroutine get_fixed_size_complex(keyword,xarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary complex :: xarray(:) character(len=*),intent(in),optional :: delimiters complex,allocatable :: darray(:) ! function type integer :: half, sz integer :: dsize integer :: ibug call get_anyarray_x(keyword,darray,delimiters) dsize=size(darray) sz=dsize*2 half=sz/2 if(sz /= half+half)then call journal('*get_fixed_size_complex* uneven number of values defining complex value '//keyword) call mystop(15,'*get_fixed_size_complex* uneven number of values defining complex value '//keyword) xarray=0 return endif if(ubound(xarray,dim=1) == dsize)then xarray=darray else ibug=size(xarray) call journal('*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(34) xarray=cmplx(0.0,0.0) endif end subroutine get_fixed_size_complex !=================================================================================================================================== subroutine get_fixedarray_d(keyword,darr,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real(kind=dp) :: darr(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_d(keyword,darray,delimiters) dsize=size(darray) if(ubound(darr,dim=1) == dsize)then darr=darray else ibug=size(darr) call journal('*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(35) darr=0.0d0 endif end subroutine get_fixedarray_d !=================================================================================================================================== subroutine get_fixedarray_l(keyword,larray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary logical :: larray(:) character(len=*),intent(in),optional :: delimiters logical,allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_l(keyword,darray,delimiters) dsize=size(darray) if(ubound(larray,dim=1) == dsize)then larray=darray else ibug=size(larray) call journal('*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(36) larray=.false. endif end subroutine get_fixedarray_l !=================================================================================================================================== subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters) ! ident_9="@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*) :: strings(:) character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: str(:) character(len=*),intent(in) :: keyword ! name to look up in dictionary integer :: place integer :: ssize integer :: ibug character(len=:),allocatable :: val call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if index is valid return strings val=unquote(values(place)(:counts(place))) call split(val,str,delimiters=delimiters) ! find value associated with keyword and split it into an array ssize=size(str) if(ssize==size(strings))then strings(:ssize)=str else ibug=size(strings) call journal('*get_fixedarray_fixed_length_c* wrong number of values for keyword',& & keyword,'got',ssize,'expected ',ibug) !,ubound(strings,dim=1) call print_dictionary_usage() call mystop(30,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword) strings='' endif else call journal('*get_fixedarray_fixed_length_c* unknown keyword '//keyword) call mystop(16,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword) strings='' endif end subroutine get_fixedarray_fixed_length_c !=================================================================================================================================== ! return scalars !=================================================================================================================================== subroutine get_scalar_d(keyword,d) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real(kind=dp) :: d real(kind=dp),allocatable :: darray(:) ! function type integer :: ibug call get_anyarray_d(keyword,darray) if(size(darray) == 1)then d=darray(1) else ibug=size(darray) call journal('*get_anyarray_d* incorrect number of values for keyword "',keyword,'" expected one found',ibug) call print_dictionary_usage() call mystop(31,'*get_anyarray_d* incorrect number of values for keyword "'//keyword//'" expected one') endif end subroutine get_scalar_d !=================================================================================================================================== subroutine get_scalar_real(keyword,r) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real,intent(out) :: r real(kind=dp) :: d call get_scalar_d(keyword,d) r=real(d) end subroutine get_scalar_real !=================================================================================================================================== subroutine get_scalar_i(keyword,i) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary integer,intent(out) :: i real(kind=dp) :: d call get_scalar_d(keyword,d) i=nint(d) end subroutine get_scalar_i !=================================================================================================================================== subroutine get_scalar_anylength_c(keyword,string) ! ident_10="@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=:),allocatable,intent(out) :: string integer :: place call locate_key(keyword, place) ! find where string is or should be if (place > 0) then ! if index is valid return string string = unquote(values(place) (:counts(place))) else call journal('*get_anyarray_c* unknown keyword '//keyword) call mystop(17, '*get_anyarray_c* unknown keyword '//keyword) string = '' endif end subroutine get_scalar_anylength_c !=================================================================================================================================== elemental impure subroutine get_args_fixed_length_scalar_c(keyword,string) ! ident_11="@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=*),intent(out) :: string integer :: place integer :: unlen integer :: ibug call locate_key(keyword, place) ! find where string is or should be if (place > 0) then ! if index is valid return string string = unquote(values(place) (:counts(place))) else call mystop(18, '*get_args_fixed_length_scalar_c* unknown keyword '//keyword) string = '' endif unlen = len_trim(unquote(values(place) (:counts(place)))) if (unlen > len(string)) then ibug = len(string) call journal('*get_args_fixed_length_scalar_c* value too long for', keyword, 'allowed is', ibug,& & 'input string [', values(place), '] is', unlen) call mystop(19, '*get_args_fixed_length_scalar_c* value too long') string = '' endif end subroutine get_args_fixed_length_scalar_c !=================================================================================================================================== subroutine get_scalar_complex(keyword,x) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary complex,intent(out) :: x real(kind=dp) :: d(2) call get_fixedarray_d(keyword,d) x=cmplx(d(1),d(2),kind=sp) end subroutine get_scalar_complex !=================================================================================================================================== subroutine get_scalar_logical(keyword,l) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary logical :: l logical,allocatable :: larray(:) ! function type integer :: ibug l = .false. call get_anyarray_l(keyword, larray) if (.not. allocated(larray)) then call journal('*get_scalar_logical* expected one value found not allocated') call mystop(37, '*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"') elseif (size(larray) == 1) then l = larray(1) else ibug = size(larray) call journal('*get_scalar_logical* expected one value found', ibug) call mystop(21, '*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"') endif end subroutine get_scalar_logical !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE !use M_list, only : insert, locate, remove, replace !use M_journal, only : JOURNAL !use M_args, only : LONGEST_COMMAND_ARGUMENT ! routines extracted from other modules !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest !! argument on command line !! (LICENSE:PD) !!##SYNOPSIS !! !! function longest_command_argument() result(ilongest) !! !! integer :: ilongest !! !!##DESCRIPTION !! length of longest argument on command line. Useful when allocating !! storage for holding arguments. !!##RESULT !! longest_command_argument length of longest command argument !!##EXAMPLE !! !! Sample program !! !! program demo_longest_command_argument !! use M_args, only : longest_command_argument !! write(*,*)'longest argument is ',longest_command_argument() !! end program demo_longest_command_argument !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== function longest_command_argument() result(ilongest) integer :: i integer :: ilength integer :: istatus integer :: ilongest ilength = 0 ilongest = 0 GET_LONGEST: do i = 1, command_argument_count() ! loop throughout command line arguments to find longest call get_command_argument(number=i, length=ilength, status=istatus) ! get next argument if (istatus /= 0) then ! on error write (warn, *) '*prototype_and_cmd_args_to_nlist* error obtaining length for argument ', i exit GET_LONGEST elseif (ilength > 0) then ilongest = max(ilongest, ilength) endif end do GET_LONGEST end function longest_command_argument !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! journal(3f) - [M_CLI2] converts a list of standard scalar types to a string and writes message !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine journal(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep,line) !! !! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 !! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj !! character(len=*),intent(in),optional :: sep !! character(len=:),intent(out),allocatable,optional :: line !! !!##DESCRIPTION !! journal(3f) builds and prints a space-separated string from up to twenty scalar values. !! !!##OPTIONS !! g[0-9a-j] optional value to print the value of after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, !! COMPLEX, or CHARACTER. !! !! sep separator to place between values. Defaults to a space. !! line if present, the output is placed in the variable instead of !! being written !!##RETURNS !! journal description to print !!##EXAMPLES !! !! Sample program: !! !! program demo_journal !! use M_CLI2, only : journal !! implicit none !! character(len=:),allocatable :: frmt !! integer :: biggest !! !! call journal('HUGE(3f) integers',huge(0),'and real',& !! & huge(0.0),'and double',huge(0.0d0)) !! call journal('real :',huge(0.0),0.0,12345.6789,tiny(0.0) ) !! call journal('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) !! call journal('complex :',cmplx(huge(0.0),tiny(0.0)) ) !! !! end program demo_journal !! !! Output !! !! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and !! double 1.7976931348623157E+308 !! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38 !! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 !! 12345.678900000001 2.2250738585072014E-308 !! complex : (3.40282347E+38,1.17549435E-38) !! format=(*(i9:,1x)) !! program will now stop !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine journal(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep,line) ! ident_12="@(#) M_CLI2 journal(3fp) writes a message to stdout or a string composed of any standard scalar types" class(*),intent(in),optional :: g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj character(len=*),intent(in),optional :: sep character(len=:),intent(out),allocatable,optional :: line character(len=:),allocatable :: sep_local character(len=4096) :: local_line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep_local)+1 else sep_local=' ' increment=2 endif istart=1 local_line='' if(present(g0))call print_generic(g0) if(present(g1))call print_generic(g1) if(present(g2))call print_generic(g2) if(present(g3))call print_generic(g3) if(present(g4))call print_generic(g4) if(present(g5))call print_generic(g5) if(present(g6))call print_generic(g6) if(present(g7))call print_generic(g7) if(present(g8))call print_generic(g8) if(present(g9))call print_generic(g9) if(present(ga))call print_generic(ga) if(present(gb))call print_generic(gb) if(present(gc))call print_generic(gc) if(present(gd))call print_generic(gd) if(present(ge))call print_generic(ge) if(present(gf))call print_generic(gf) if(present(gg))call print_generic(gg) if(present(gh))call print_generic(gh) if(present(gi))call print_generic(gi) if(present(gj))call print_generic(gj) if(present(line))then line=trim(local_line) else write(*,'(a)')trim(local_line) endif contains !=================================================================================================================================== subroutine print_generic(generic) use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(local_line(istart:),'(i0)') generic type is (integer(kind=int16)); write(local_line(istart:),'(i0)') generic type is (integer(kind=int32)); write(local_line(istart:),'(i0)') generic type is (integer(kind=int64)); write(local_line(istart:),'(i0)') generic type is (real(kind=real32)); write(local_line(istart:),'(1pg0)') generic type is (real(kind=real64)) write(local_line(istart:),'(1pg0)') generic !x! DOES NOT WORK WITH NVFORTRAN: type is (real(kind=real128)); write(local_line(istart:),'(1pg0)') generic type is (logical) write(local_line(istart:),'(l1)') generic type is (character(len=*)) write(local_line(istart:),'(a)') trim(generic) type is (complex); write(local_line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(local_line)+increment local_line=trim(local_line)//sep_local end subroutine print_generic !=================================================================================================================================== end subroutine journal !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep) result(line) ! ident_13="@(#) M_CLI2 str(3fp) writes a message to a string composed of any standard scalar types" class(*),intent(in),optional :: g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj character(len=*),intent(in),optional :: sep character(len=:),allocatable :: line call journal(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep,line) end function str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function upper(str) result (string) ! ident_14="@(#) M_CLI2 upper(3f) Changes a string to uppercase" character(*), intent(in) :: str character(:),allocatable :: string integer :: i string = str do i = 1, len_trim(str) select case (str(i:i)) case ('a':'z') string(i:i) = char(iachar(str(i:i))-32) end select end do end function upper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function lower(str) result (string) ! ident_15="@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range" character(*), intent(In) :: str character(:),allocatable :: string integer :: i string = str do i = 1, len_trim(str) select case (str(i:i)) case ('A':'Z') string(i:i) = char(iachar(str(i:i))+32) end select end do end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine a2i(chars,valu,ierr) ! ident_16="@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string" character(len=*),intent(in) :: chars ! input string integer,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 integer,parameter :: ihuge=huge(0) valu8 = 0.0d0 call a2d(chars, valu8, ierr, onerr=0.0d0) if (valu8 <= huge(valu)) then if (valu8 <= huge(valu)) then valu = int(valu8) else call journal('*a2i*', '- value too large', valu8, '>', ihuge) valu = huge(valu) ierr = -1 endif endif end subroutine a2i !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2d(chars,valu,ierr,onerr) ! ident_17="@(#) M_CLI2 a2d(3fp) subroutine returns double value from string" ! 1989,2016 John S. Urban. ! ! o works with any g-format input, including integer, real, and exponential. ! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0. ! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data. ! IERR will still be non-zero in this case. !---------------------------------------------------------------------------------------------------------------------------------- character(len=*),intent(in) :: chars ! input string character(len=:),allocatable :: local_chars doubleprecision,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) class(*),optional,intent(in) :: onerr !---------------------------------------------------------------------------------------------------------------------------------- character(len=*),parameter :: fmt="('(bn,g',i5,'.0)')" ! format used to build frmt character(len=15) :: frmt ! holds format built to read input string character(len=256) :: msg ! hold message from I/O errors integer :: intg integer :: pnd integer :: basevalue, ivalu character(len=3),save :: nan_string='NaN' !---------------------------------------------------------------------------------------------------------------------------------- ierr=0 ! initialize error flag to zero local_chars=unquote(chars) msg='' if(len(local_chars) == 0)local_chars=' ' local_chars=replace_str(local_chars,',','') ! remove any comma characters pnd=scan(local_chars,'#:') if(pnd /= 0)then write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)' read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue ! try to read value from string if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then valu=real(ivalu,kind=kind(0.0d0)) else valu=0.0d0 ierr=-1 endif else select case(local_chars(1:1)) case('z','Z','h','H') ! assume hexadecimal write(frmt,"('(Z',i0,')')")len(local_chars) read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('b','B') ! assume binary (base 2) write(frmt,"('(B',i0,')')")len(local_chars) read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('o','O') ! assume octal write(frmt,"('(O',i0,')')")len(local_chars) read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case default write(frmt,fmt)len(local_chars) ! build format of form '(BN,Gn.0)' read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu ! try to read value from string end select endif if(ierr /= 0)then ! if an error occurred ierr will be non-zero. if(present(onerr))then select type(onerr) type is (integer) valu=onerr type is (real) valu=onerr type is (doubleprecision) valu=onerr end select else ! set return value to NaN read(nan_string,'(f3.3)')valu endif if(local_chars /= 'eod')then ! print warning message except for special value "eod" call journal('*a2d* - cannot produce number from string ['//trim(chars)//']') if(msg /= '')then call journal('*a2d* - ['//trim(msg)//']') endif endif endif end subroutine a2d !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified !! delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine split(input_line,array,delimiters,order,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=:),allocatable,intent(out) :: array(:) !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: order !! character(len=*),optional,intent(in) :: nulls !!##DESCRIPTION !! SPLIT(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! !! INPUT_LINE Input string to tokenize !! !! ARRAY Output array of tokens !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the "whitespace" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. !! By default ARRAY contains the tokens having parsed !! the INPUT_LINE from left to right. If ORDER='RIGHT' !! or ORDER='REVERSE' the parsing goes from right to left. !! !! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_split !! use M_CLI2, only: split !! character(len=*),parameter :: & !! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! character(len=:),allocatable :: array(:) ! output array of tokens !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,'(80("="))') !! write(*,*)'typical call:' !! CALL split(line,array) !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80("-"))') !! write(*,*)'custom list of delimiters (colon and vertical line):' !! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80("-"))') !! write(*,*)& !! &'custom list of delimiters, reverse array order and count null fields:' !! CALL split(line,array,delimiters=':|',order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80("-"))') !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,*)& !! &'default delimiters and reverse array order and return null fields:' !! CALL split(line,array,delimiters='',order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! end program demo_split !! !! Output !! !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > =========================================================================== !! > typical call: !! > 1 ==> aBcdef !! > 2 ==> ghijklmnop !! > 3 ==> qrstuvwxyz !! > 4 ==> 1:|:2 !! > 5 ==> 333|333 !! > 6 ==> a !! > 7 ==> B !! > 8 ==> cc !! > SIZE: 8 !! > -------------------------------------------------------------------------- !! > custom list of delimiters (colon and vertical line): !! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > 2 ==> 2 333 !! > 3 ==> 333 a B cc !! > SIZE: 3 !! > -------------------------------------------------------------------------- !! > custom list of delimiters, reverse array order and return null fields: !! > 1 ==> 333 a B cc !! > 2 ==> 2 333 !! > 3 ==> !! > 4 ==> !! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > SIZE: 5 !! > -------------------------------------------------------------------------- !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > default delimiters and reverse array order and count null fields: !! > 1 ==> !! > 2 ==> !! > 3 ==> !! > 4 ==> cc !! > 5 ==> B !! > 6 ==> a !! > 7 ==> 333|333 !! > 8 ==> !! > 9 ==> !! > 10 ==> !! > 11 ==> !! > 12 ==> 1:|:2 !! > 13 ==> !! > 14 ==> qrstuvwxyz !! > 15 ==> ghijklmnop !! > 16 ==> !! > 17 ==> !! > 18 ==> aBcdef !! > 19 ==> !! > 20 ==> !! > SIZE: 20 !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine split(input_line,array,delimiters,order,nulls) ! ident_18="@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array" ! John S. Urban intrinsic index, min, present, len ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character(len=*),intent(in) :: input_line ! input string to tokenize character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right] character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens !----------------------------------------------------------------------------------------------------------------------------------- integer :: n ! max number of strings INPUT_LINE could split into if all delimiter integer,allocatable :: ibegin(:) ! positions in input string where tokens start integer,allocatable :: iterm(:) ! positions in input string where tokens end character(len=:),allocatable :: dlim ! string containing delimiter characters character(len=:),allocatable :: ordr ! string containing order keyword character(len=:),allocatable :: nlls ! string containing nulls keyword integer :: ii,iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: iilen ! length of input string with trailing spaces trimmed integer :: i10,i20,i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data integer :: inotnull ! count strings not composed of delimiters integer :: ireturn ! number of tokens returned integer :: imax ! length of longest token !----------------------------------------------------------------------------------------------------------------------------------- ! decide on value for optional DELIMITERS parameter if (present(delimiters)) then ! optional delimiter list was present if(delimiters /= '')then ! if DELIMITERS was specified and not null use it dlim=delimiters else ! DELIMITERS was specified on call as empty string dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified endif else ! no delimiter value was specified dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified endif idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string !----------------------------------------------------------------------------------------------------------------------------------- if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter !----------------------------------------------------------------------------------------------------------------------------------- n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter if(allocated(ibegin))deallocate(ibegin) !x! intel compiler says allocated already ??? allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens if(allocated(iterm))deallocate(iterm) !x! intel compiler says allocated already ??? allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens ibegin(:)=1 iterm(:)=1 !----------------------------------------------------------------------------------------------------------------------------------- iilen=len(input_line) ! IILEN is the column position of the last non-blank character icount=0 ! how many tokens found inotnull=0 ! how many tokens found not composed of delimiters imax=0 ! length of longest token found if(iilen > 0)then ! there is at least one non-delimiter in INPUT_LINE if get here icol=1 ! initialize pointer into input line INFINITE: do i30=1,iilen,1 ! store into each array element ibegin(i30)=icol ! assume start new token on the character if(index(dlim(1:idlim),input_line(icol:icol)) == 0)then ! if current character is not a delimiter iterm(i30)=iilen ! initially assume no more tokens do i10=1,idlim ! search for next delimiter ifound=index(input_line(ibegin(i30):iilen),dlim(i10:i10)) IF(ifound > 0)then iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) endif enddo icol=iterm(i30)+2 ! next place to look as found end of this token inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters else ! character is a delimiter for a null string iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning icol=icol+1 ! advance pointer into input string endif imax=max(imax,iterm(i30)-ibegin(i30)+1) icount=i30 ! increment count of number of tokens found if(icol > iilen)then ! no text left exit INFINITE endif enddo INFINITE endif !----------------------------------------------------------------------------------------------------------------------------------- select case (clipends(nlls)) case ('ignore','','ignoreend') ireturn=inotnull case default ireturn=icount end select if(allocated(array))deallocate(array) allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to turn !----------------------------------------------------------------------------------------------------------------------------------- select case (clipends(ordr)) ! decide which order to store tokens case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first case default ; ii=1 ; iiii=1 ! first to last end select !----------------------------------------------------------------------------------------------------------------------------------- do i20=1,icount ! fill the array with the tokens that were found if(iterm(i20) < ibegin(i20))then select case (clipends(nlls)) case ('ignore','','ignoreend') case default array(ii)=' ' ii=ii+iiii end select else array(ii)=input_line(ibegin(i20):iterm(i20)) ii=ii+iiii endif enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine split !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one !! substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function replace_str(targetline,old,new,range,ierr) result (newline) !! !! character(len=*) :: targetline !! character(len=*),intent(in) :: old !! character(len=*),intent(in) :: new !! integer,intent(in),optional :: range(2) !! integer,intent(out),optional :: ierr !! logical,intent(in),optional :: clip !! character(len=:),allocatable :: newline !!##DESCRIPTION !! Globally replace one substring for another in string. !! Either CMD or OLD and NEW must be specified. !! !!##OPTIONS !! targetline input line to be changed !! old old substring to replace !! new new substring !! range if present, only change range(1) to range(2) of !! occurrences of old string !! ierr error code. If ier = -1 bad directive, >= 0 then !! count of changes made !! clip whether to return trailing spaces or not. Defaults to .false. !!##RETURNS !! newline allocatable string returned !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_replace_str !! use M_CLI2, only : replace_str !! implicit none !! character(len=:),allocatable :: targetline !! !! targetline='this is the input string' !! !! call testit('th','TH','THis is THe input string') !! !! ! a null old substring means "at beginning of line" !! call testit('','BEFORE:', 'BEFORE:THis is THe input string') !! !! ! a null new string deletes occurrences of the old substring !! call testit('i','', 'BEFORE:THs s THe nput strng') !! !! targetline=replace_str('a b ab baaa aaaa','a','A') !! write(*,*)'replace a with A ['//targetline//']' !! !! write(*,*)'Examples of the use of RANGE=' !! !! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5]) !! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5]) !! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa',& !! & 'aa','CCCC',range=[3,5]) !! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']' !! !! contains !! subroutine testit(old,new,expected) !! character(len=*),intent(in) :: old,new,expected !! write(*,*)repeat('=',79) !! write(*,*)':STARTED ['//targetline//']' !! write(*,*)':OLD['//old//']', ' NEW['//new//']' !! targetline=replace_str(targetline,old,new) !! write(*,*)':GOT ['//targetline//']' !! write(*,*)':EXPECTED['//expected//']' !! write(*,*)':TEST [',targetline == expected,']' !! end subroutine testit !! !! end program demo_replace_str !! !! Expected output !! !! =============================================================================== !! STARTED [this is the input string] !! OLD[th] NEW[TH] !! GOT [THis is THe input string] !! EXPECTED[THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [THis is THe input string] !! OLD[] NEW[BEFORE:] !! GOT [BEFORE:THis is THe input string] !! EXPECTED[BEFORE:THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [BEFORE:THis is THe input string] !! OLD[i] NEW[] !! GOT [BEFORE:THs s THe nput strng] !! EXPECTED[BEFORE:THs s THe nput strng] !! TEST [ T ] !! replace a with A [A b Ab bAAA AAAA] !! Examples of the use of RANGE= !! replace a with A instances 3 to 5 [a b ab bAAA aaaa] !! replace a with null instances 3 to 5 [a b ab b aaaa] !! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC !! a a a aa aaaaaa] !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== function replace_str(targetline,old,new,ierr,range) result (newline) ! ident_19="@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string" !----------------------------------------------------------------------------------------------------------------------------------- ! parameters character(len=*),intent(in) :: targetline ! input line to be changed character(len=*),intent(in) :: old ! old substring to replace character(len=*),intent(in) :: new ! new substring integer,intent(out),optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made integer,intent(in),optional :: range(2) ! start and end of which changes to make !----------------------------------------------------------------------------------------------------------------------------------- ! returns character(len=:),allocatable :: newline ! output string buffer !----------------------------------------------------------------------------------------------------------------------------------- ! local integer :: icount,ichange integer :: original_input_length integer :: len_old, len_new integer :: ladd integer :: left_margin, right_margin integer :: ind integer :: ic integer :: iichar integer :: range_local(2) !----------------------------------------------------------------------------------------------------------------------------------- icount=0 ! initialize error flag/change count ichange=0 ! initialize error flag/change count original_input_length=len_trim(targetline) ! get non-blank length of input line len_old=len(old) ! length of old substring to be replaced len_new=len(new) ! length of new substring to replace old substring left_margin=1 ! left_margin is left margin of window to change right_margin=len(targetline) ! right_margin is right margin of window to change newline='' ! begin with a blank line as output string !----------------------------------------------------------------------------------------------------------------------------------- if(present(range))then range_local=range else range_local=[1,original_input_length] endif !----------------------------------------------------------------------------------------------------------------------------------- if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin) iichar=len_new + original_input_length if(len_new > 0)then newline=new(:len_new)//targetline(left_margin:original_input_length) else newline=targetline(left_margin:original_input_length) endif ichange=1 ! made one change. actually, c/// should maybe return 0 if(present(ierr))ierr=ichange return endif !----------------------------------------------------------------------------------------------------------------------------------- iichar=left_margin ! place to put characters into output string ic=left_margin ! place looking at in input string loop: do ind=index(targetline(ic:),old(:len_old))+ic-1 ! try finding start of OLD in remaining part of input in change window if(ind == ic-1.or.ind > right_margin)then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif icount=icount+1 ! found an old string to change, so increment count of change candidates if(ind > ic)then ! if found old string past at current position in input string copy unchanged ladd=ind-ic ! find length of character range to copy as-is from input to output newline=newline(:iichar-1)//targetline(ic:ind-1) iichar=iichar+ladd endif if(icount >= range_local(1).and.icount <= range_local(2))then ! check if this is an instance to change or keep ichange=ichange+1 if(len_new /= 0)then ! put in new string newline=newline(:iichar-1)//new(:len_new) iichar=iichar+len_new endif else if(len_old /= 0)then ! put in copy of old string newline=newline(:iichar-1)//old(:len_old) iichar=iichar+len_old endif endif ic=ind+len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case (ichange) case (0) ! there were no changes made to the window newline=targetline ! if no changes made output should be input case default if(ic <= len(targetline))then ! if there is more after last change on original line add it newline=newline(:iichar-1)//targetline(ic:max(ic,original_input_length)) endif end select if(present(ierr))ierr=ichange !----------------------------------------------------------------------------------------------------------------------------------- end function replace_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with !! list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! function quote(str,mode,clip) result (quoted_str) !! !! character(len=*),intent(in) :: str !! character(len=*),optional,intent(in) :: mode !! logical,optional,intent(in) :: clip !! character(len=:),allocatable :: quoted_str !!##DESCRIPTION !! Add quotes to a CHARACTER variable as if it was written using !! list-directed input. This is particularly useful for processing !! strings to add to CSV files. !! !!##OPTIONS !! str input string to add quotes to, using the rules of !! list-directed input (single quotes are replaced by two !! adjacent quotes) !! mode alternate quoting methods are supported: !! !! DOUBLE default. replace quote with double quotes !! ESCAPE replace quotes with backslash-quote instead !! of double quotes !! !! clip default is to trim leading and trailing spaces from the !! string. If CLIP !! is .FALSE. spaces are not trimmed !! !!##RESULT !! quoted_str The output string, which is based on adding quotes to STR. !!##EXAMPLE !! !! Sample program: !! !! program demo_quote !! use M_CLI2, only : quote !! implicit none !! character(len=:),allocatable :: str !! character(len=1024) :: msg !! integer :: ios !! character(len=80) :: inline !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)inline !! if(ios /= 0)then !! write(*,*)trim(inline) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'ORIGINAL ['//trim(inline)//']' !! !! ! the string processed by quote(3f) !! str=quote(inline) !! write(*,'(a)')'QUOTED ['//str//']' !! !! ! write the string list-directed to compare the results !! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:' !! write(*,*,iostat=ios,iomsg=msg,delim='none') inline !! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline !! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline !! enddo !! end program demo_quote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !----------------------------------------------------------------------------------------------------------------------------------- function quote(str,mode,clip) result (quoted_str) character(len=*),intent(in) :: str ! the string to be quoted character(len=*),optional,intent(in) :: mode logical,optional,intent(in) :: clip logical :: clip_local character(len=:),allocatable :: quoted_str character(len=1),parameter :: double_quote = '"' character(len=20) :: local_mode if(present(mode))then local_mode=mode else local_mode='DOUBLE' endif if(present(clip))then clip_local=clip else clip_local=.false. endif if(clip_local)then quoted_str=adjustl(str) else quoted_str=str endif select case(lower(local_mode)) case('double') quoted_str=double_quote//trim(replace_str(quoted_str,'"','""'))//double_quote case('escape') quoted_str=double_quote//trim(replace_str(quoted_str,'"','\"'))//double_quote case default call journal('*quote* ERROR: unknown quote mode ',local_mode) quoted_str=str end select end function quote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read !! with list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! pure function unquote(quoted_str,esc) result (unquoted_str) !! !! character(len=*),intent(in) :: quoted_str !! character(len=1),optional,intent(in) :: esc !! character(len=:),allocatable :: unquoted_str !!##DESCRIPTION !! Remove quotes from a CHARACTER variable as if it was read using !! list-directed input. This is particularly useful for processing !! tokens read from input such as CSV files. !! !! Fortran can now read using list-directed input from an internal file, !! which should handle quoted strings, but list-directed input does not !! support escape characters, which UNQUOTE(3f) does. !!##OPTIONS !! quoted_str input string to remove quotes from, using the rules of !! list-directed input (two adjacent quotes inside a quoted !! region are replaced by a single quote, a single quote or !! double quote is selected as the delimiter based on which !! is encountered first going from left to right, ...) !! esc optional character used to protect the next quote !! character from being processed as a quote, but simply as !! a plain character. !!##RESULT !! unquoted_str The output string, which is based on removing quotes !! from quoted_str. !!##EXAMPLE !! !! Sample program: !! !! program demo_unquote !! use M_CLI2, only : unquote !! implicit none !! character(len=128) :: quoted_str !! character(len=:),allocatable :: unquoted_str !! character(len=1),parameter :: esc='\' !! character(len=1024) :: msg !! integer :: ios !! character(len=1024) :: dummy !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str !! if(ios /= 0)then !! write(*,*)trim(msg) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' !! !! ! the string processed by unquote(3f) !! unquoted_str=unquote(trim(quoted_str),esc) !! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' !! !! ! read the string list-directed to compare the results !! read(quoted_str,*,iostat=ios,iomsg=msg)dummy !! if(ios /= 0)then !! write(*,*)trim(msg) !! else !! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' !! endif !! enddo !! end program demo_unquote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== pure function unquote(quoted_str,esc) result (unquoted_str) character(len=*),intent(in) :: quoted_str ! the string to be unquoted character(len=1),optional,intent(in) :: esc ! escape character character(len=:),allocatable :: unquoted_str integer :: inlen character(len=1),parameter :: single_quote = "'" character(len=1),parameter :: double_quote = '"' integer :: quote ! whichever quote is to be used integer :: before integer :: current integer :: iesc integer :: iput integer :: i logical :: inside !----------------------------------------------------------------------------------------------------------------------------------- if(present(esc))then ! select escape character as specified character or special value meaning not set iesc=ichar(esc) ! allow for an escape character else iesc=-1 ! set to value that matches no character endif !----------------------------------------------------------------------------------------------------------------------------------- inlen=len(quoted_str) ! find length of input string if(allocated(unquoted_str))deallocate(unquoted_str) allocate(character(len=inlen) :: unquoted_str) ! initially make output string length of input string !----------------------------------------------------------------------------------------------------------------------------------- if(inlen >= 1)then ! double_quote is the default quote unless the first character is single_quote if(quoted_str(1:1) == single_quote)then quote=ichar(single_quote) else quote=ichar(double_quote) endif else quote=ichar(double_quote) endif !----------------------------------------------------------------------------------------------------------------------------------- before=-2 ! initially set previous character to impossible value unquoted_str(:)='' ! initialize output string to null string iput=1 inside=.false. STEPTHROUGH: do i=1,inlen current=ichar(quoted_str(i:i)) if(before == iesc)then ! if previous character was escape use current character unconditionally iput=iput-1 ! backup unquoted_str(iput:iput)=char(current) iput=iput+1 before=-2 ! this could be second esc or quote elseif(current == quote)then ! if current is a quote it depends on whether previous character was a quote if(before == quote)then unquoted_str(iput:iput)=char(quote) ! this is second quote so retain it iput=iput+1 before=-2 elseif(.not.inside.and.before /= iesc)then inside=.true. else ! this is first quote so ignore it except remember it in case next is a quote before=current endif else unquoted_str(iput:iput)=char(current) iput=iput+1 before=current endif enddo STEPTHROUGH !----------------------------------------------------------------------------------------------------------------------------------- unquoted_str=unquoted_str(:iput-1) !----------------------------------------------------------------------------------------------------------------------------------- end function unquote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base !! [2-36] to base 10 number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function decodebase(string,basein,out10) !! !! character(len=*),intent(in) :: string !! integer,intent(in) :: basein !! integer,intent(out) :: out10 !!##DESCRIPTION !! !! Convert a numeric string representing a whole number in base BASEIN !! to base 10. The function returns FALSE if BASEIN is not in the range !! [2..36] or if string STRING contains invalid characters in base BASEIN !! or if result OUT10 is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##OPTIONS !! string input string. It represents a whole number in !! the base specified by BASEIN unless BASEIN is set !! to zero. When BASEIN is zero STRING is assumed to !! be of the form BASE#VALUE where BASE represents !! the function normally provided by BASEIN. !! basein base of input string; either 0 or from 2 to 36. !! out10 output value in base 10 !! !!##EXAMPLE !! !! Sample program: !! !! program demo_decodebase !! use M_CLI2, only : codebase, decodebase !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! integer :: r !! !! print *,' BASE CONVERSION' !! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd !! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba !! INFINITE: do !! print *,'' !! write(*,'("Enter number in start base: ")',advance='no'); read *, x !! if(x == '0') exit INFINITE !! if(decodebase(x,bd,r)) then !! if(codebase(r,ba,y)) then !! write(*,'("In base ",I2,": ",A20)') ba, y !! else !! print *,'Error in coding number.' !! endif !! else !! print *,'Error in decoding number.' !! endif !! enddo INFINITE !! !! end program demo_decodebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: "Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function decodebase(string,basein,out_baseten) ! ident_20="@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number" character(len=*),intent(in) :: string integer,intent(in) :: basein integer,intent(out) :: out_baseten character(len=len(string)) :: string_local integer :: long, i, j, k real :: y real :: mult character(len=1) :: ch real,parameter :: XMAXREAL=real(huge(1)) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local=upper(clipends(string)) decodebase=.false. ipound=index(string_local,'#') ! determine if in form [-]base#whole if(basein == 0.and.ipound > 1)then ! split string into two values call a2i(string_local(:ipound-1),basein_local,ierr) ! get the decimal value of the base string_local=string_local(ipound+1:) ! now that base is known make string just the value if(basein_local >= 0)then ! allow for a negative sign prefix out_sign=1 else out_sign=-1 endif basein_local=abs(basein_local) else ! assume string is a simple positive value basein_local=abs(basein) out_sign=1 endif out_baseten=0 y=0.0 ALL: if(basein_local<2.or.basein_local>36) then print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local else ALL out_baseten=0;y=0.0; mult=1.0 long=LEN_TRIM(string_local) do i=1, long k=long+1-i ch=string_local(k:k) IF(CH == '-'.AND.K == 1)THEN out_sign=-1 cycle endif if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then write(*,*)'*decodebase* ERROR: invalid character ',ch exit ALL endif if(ch<='9') then j=IACHAR(ch)-IACHAR('0') else j=IACHAR(ch)-IACHAR('A')+10 endif if(j>=basein_local)then exit ALL endif y=y+mult*j if(mult>XMAXREAL/basein_local)then exit ALL endif mult=mult*basein_local enddo decodebase=.true. out_baseten=nint(out_sign*y)*sign(1,basein) endif ALL end function decodebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! locate_(3f) - [M_CLI2] finds the index where a string is found or !! should be in a sorted array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine locate_(list,value,place,ier,errmsg) !! !! character(len=:)|doubleprecision|real|integer,allocatable :: list(:) !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! integer, intent(out) :: PLACE !! !! integer, intent(out),optional :: IER !! character(len=*),intent(out),optional :: ERRMSG !! !!##DESCRIPTION !! !! LOCATE_(3f) finds the index where the VALUE is found or should !! be found in an array. The array must be sorted in descending !! order (highest at top). If VALUE is not found it returns the index !! where the name should be placed at with a negative sign. !! !! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL,INTEGER) !! !!##OPTIONS !! !! VALUE the value to locate in the list. !! LIST is the list array. !! !!##RETURNS !! PLACE is the subscript that the entry was found at if it is !! greater than zero(0). !! !! If PLACE is negative, the absolute value of !! PLACE indicates the subscript value where the !! new entry should be placed in order to keep the !! list alphabetized. !! !! IER is zero(0) if no error occurs. !! If an error occurs and IER is not !! present, the program is stopped. !! !! ERRMSG description of any error !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_locate !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! call update_dic(arr,'b') !! call update_dic(arr,'[') !! call update_dic(arr,'c') !! call update_dic(arr,'ZZ') !! call update_dic(arr,'ZZZZ') !! call update_dic(arr,'z') !! !! contains !! subroutine update_dic(arr,string) !! character(len=:),intent(in),allocatable :: arr(:) !! character(len=*),intent(in) :: string !! integer :: place, plus, ii, end !! ! find where string is or should be !! call locate_(arr,string,place) !! write(*,*)'for "'//string//'" index is ',place, size(arr) !! ! if string was not found insert it !! if(place < 1)then !! plus=abs(place) !! ii=len(arr) !! end=size(arr) !! ! empty array !! if(end == 0)then !! arr=[character(len=ii) :: string ] !! ! put in front of array !! elseif(plus == 1)then !! arr=[character(len=ii) :: string, arr] !! ! put at end of array !! elseif(plus == end)then !! arr=[character(len=ii) :: arr, string ] !! ! put in middle of array !! else !! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ] !! endif !! ! show array !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! endif !! end subroutine update_dic !! end program demo_locate !! !! Results: !! !! for "b" index is 2 5 !! for "[" index is -4 5 !! SIZE=5 xxx,b,aaa,[,ZZZ, !! for "c" index is -2 6 !! SIZE=6 xxx,c,b,aaa,[,ZZZ, !! for "ZZ" index is -7 7 !! SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! for "ZZZZ" index is -6 8 !! SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! for "z" index is -1 9 !! SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine locate_c(list,value,place,ier,errmsg) ! ident_21="@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed" character(len=*),intent(in) :: value integer,intent(out) :: place character(len=:),allocatable :: list(:) integer,intent(out),optional :: ier character(len=*),intent(out),optional :: errmsg integer :: i character(len=:),allocatable :: message integer :: arraysize integer :: maxtry integer :: imin, imax integer :: error if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif arraysize=size(list) error=0 if(arraysize == 0)then maxtry=0 place=-1 else maxtry=nint(log(float(arraysize))/log(2.0)+1.0) place=(arraysize+1)/2 endif imin=1 imax=arraysize message='' LOOP: block do i=1,maxtry if(value == list(PLACE))then exit LOOP elseif(value > list(place))then imax=place-1 else imin=place+1 endif if(imin > imax)then place=-imin if(iabs(place) > arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place=(imax+imin)/2 if(place > arraysize.or.place <= 0)then message='*locate_* error: search is out of bounds of list. Probably an unsorted input array' error=-1 exit LOOP endif enddo message='*locate_* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if(present(ier))then ier=error elseif(error /= 0)then write(warn,*)message//' VALUE=',trim(value)//' PLACE=',place call mystop(-24,'(*locate_c* '//message) endif if(present(errmsg))then errmsg=message endif end subroutine locate_c !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! remove_(3f) - [M_CLI2] remove entry from an allocatable array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine remove_(list,place) !! !! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:) !! integer, intent(out) :: PLACE !! !!##DESCRIPTION !! !! Remove a value from an allocatable array at the specified index. !! The array is assumed to be sorted in descending order. It may be of !! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. !! !!##OPTIONS !! !! list is the list array. !! PLACE is the subscript for the entry that should be removed !! !!##EXAMPLES !! !! !! Sample program !! !! program demo_remove !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, remove_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! integer :: end !! !! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,1) !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,4) !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! !! end program demo_remove !! !! Results: !! !! Expected output !! !! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=7 bb,b,b,aaa,ZZZ,Z,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine remove_c(list,place) ! ident_22="@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position" character(len=:),allocatable :: list(:) integer,intent(in) :: place integer :: ii, end if(.not.allocated(list))then list=[character(len=2) :: ] endif ii=len(list) end=size(list) if(place <= 0.or.place > end)then ! index out of bounds of array elseif(place == end)then ! remove from array list=[character(len=ii) :: list(:place-1) ] else list=[character(len=ii) :: list(:place-1), list(place+1:) ] endif end subroutine remove_c subroutine remove_l(list,place) ! ident_23="@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position" logical,allocatable :: list(:) integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(place <= 0.or.place > end)then ! index out of bounds of array elseif(place == end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif end subroutine remove_l subroutine remove_i(list,place) ! ident_24="@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position" integer,allocatable :: list(:) integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(place <= 0.or.place > end)then ! index out of bounds of array elseif(place == end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif end subroutine remove_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! replace_(3f) - [M_CLI2] replace entry in a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine replace_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer, intent(out) :: place !! !!##DESCRIPTION !! !! replace a value in an allocatable array at the specified index. Unless the !! array needs the string length to increase this is merely an assign of a value !! to an array element. !! !! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER> !! It is assumed to be sorted in descending order without duplicate values. !! !! The value and list must be of the same type. !! !!##OPTIONS !! !! VALUE the value to place in the array !! LIST is the array. !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Replace key-value pairs in a dictionary !! !! program demo_replace !! use M_CLI2, only : insert_, locate_, replace_ !! ! Find if a key is in a list and insert it !! ! into the key list and value list if it is not present !! ! or replace the associated value if the key existed !! implicit none !! character(len=20) :: key !! character(len=100) :: val !! character(len=:),allocatable :: keywords(:) !! character(len=:),allocatable :: values(:) !! integer :: i !! integer :: place !! call update_dic('b','value of b') !! call update_dic('a','value of a') !! call update_dic('c','value of c') !! call update_dic('c','value of c again') !! call update_dic('d','value of d') !! call update_dic('a','value of a again') !! ! show array !! write(*,'(*(a,"==>",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords)) !! !! call locate_key('a',place) !! if(place > 0)then !! write(*,*)'The value of "a" is',trim(values(place)) !! else !! write(*,*)'"a" not found' !! endif !! !! contains !! subroutine update_dic(key,val) !! character(len=*),intent(in) :: key !! character(len=*),intent(in) :: val !! integer :: place !! !! ! find where string is or should be !! call locate_key(key,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(keywords,key,abs(place)) !! call insert_(values,val,abs(place)) !! else ! replace !! call replace_(values,val,place) !! endif !! !! end subroutine update_dic !! end program demo_replace !! !! Expected output !! !! d==>value of d !! c==>value of c again !! b==>value of b !! a==>value of a again !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine replace_c(list,value,place) ! ident_25="@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position" character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) character(len=:),allocatable :: kludge(:) integer,intent(in) :: place integer :: ii integer :: tlen integer :: end if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif tlen=len_trim(value) end=size(list) if(place < 0.or.place > end)then write(warn,*)'*replace_c* error: index out of range. end=',end,' index=',place elseif(len_trim(value) <= len(list))then list(place)=value else ! increase length of variable ii=max(tlen,len(list)) kludge=[character(len=ii) :: list ] list=kludge list(place)=value endif end subroutine replace_c subroutine replace_l(list,value,place) ! ident_26="@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position" logical,allocatable :: list(:) logical,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place > 0.and.place <= end)then list(place)=value else ! put in middle of array write(warn,*)'*replace_l* error: index out of range. end=',end,' index=',place endif end subroutine replace_l subroutine replace_i(list,value,place) ! ident_27="@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position" integer,intent(in) :: value integer,allocatable :: list(:) integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place > 0.and.place <= end)then list(place)=value else ! put in middle of array write(warn,*)'*replace_i* error: index out of range. end=',end,' index=',place endif end subroutine replace_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! insert_(3f) - [M_CLI2] insert entry into a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine insert_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer,intent(in) :: place !! !!##DESCRIPTION !! !! Insert a value into an allocatable array at the specified index. !! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL, or INTEGER) !! !!##OPTIONS !! !! list is the list array. Must be sorted in descending order. !! value the value to place in the array !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_insert !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, insert_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! ! add or replace values !! call update_dic(arr,'b') !! call update_dic(arr,'[') !! call update_dic(arr,'c') !! call update_dic(arr,'ZZ') !! call update_dic(arr,'ZZZ') !! call update_dic(arr,'ZZZZ') !! call update_dic(arr,'') !! call update_dic(arr,'z') !! !! contains !! subroutine update_dic(arr,string) !! character(len=:),allocatable :: arr(:) !! character(len=*) :: string !! integer :: place, end !! !! end=size(arr) !! ! find where string is or should be !! call locate_(arr,string,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(arr,string,abs(place)) !! endif !! ! show array !! end=size(arr) !! write(*,'("array is now SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! !! end subroutine update_dic !! end program demo_insert !! !! Results: !! !! array is now SIZE=5 xxx,b,aaa,ZZZ,, !! array is now SIZE=6 xxx,b,aaa,[,ZZZ,, !! array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,, !! array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine insert_c(list,value,place) ! ident_28="@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position" character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) character(len=:),allocatable :: kludge(:) integer,intent(in) :: place integer :: ii integer :: end if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif ii=max(len_trim(value),len(list),2) end=size(list) if(end == 0)then ! empty array list=[character(len=ii) :: value ] elseif(place == 1)then ! put in front of array kludge=[character(len=ii) :: value, list] list=kludge elseif(place > end)then ! put at end of array kludge=[character(len=ii) :: list, value ] list=kludge elseif(place >= 2.and.place <= end)then ! put in middle of array kludge=[character(len=ii) :: list(:place-1), value,list(place:) ] list=kludge else ! index out of range write(warn,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine insert_c subroutine insert_l(list,value,place) ! ident_29="@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position" logical,allocatable :: list(:) logical,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place == 1)then ! put in front of array list=[value, list] elseif(place > end)then ! put at end of array list=[list, value ] elseif(place >= 2.and.place <= end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(warn,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine insert_l subroutine insert_i(list,value,place) ! ident_30="@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position" integer,allocatable :: list(:) integer,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place == 1)then ! put in front of array list=[value, list] elseif(place > end)then ! put at end of array list=[list, value ] elseif(place >= 2.and.place <= end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(warn,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine insert_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine many_args(n0,g0, n1,g1, n2,g2, n3,g3, n4,g4, n5,g5, n6,g6, n7,g7, n8,g8, n9,g9, & & na,ga, nb,gb, nc,gc, nd,gd, ne,ge, nf,gf, ng,gg, nh,gh, ni,gi, nj,gj ) ! ident_31="@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)" character(len=*),intent(in) :: n0, n1 character(len=*),intent(in),optional :: n2, n3, n4, n5, n6, n7, n8, n9, na, nb, nc, nd, ne, nf, ng, nh, ni, nj class(*),intent(out) :: g0, g1 class(*),intent(out),optional :: g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj call get_generic(n0,g0) call get_generic(n1,g1) if( present(n2) .and. present(g2) )call get_generic(n2,g2) if( present(n3) .and. present(g3) )call get_generic(n3,g3) if( present(n4) .and. present(g4) )call get_generic(n4,g4) if( present(n5) .and. present(g5) )call get_generic(n5,g5) if( present(n6) .and. present(g6) )call get_generic(n6,g6) if( present(n7) .and. present(g7) )call get_generic(n7,g7) if( present(n8) .and. present(g8) )call get_generic(n8,g8) if( present(n9) .and. present(g9) )call get_generic(n9,g9) if( present(na) .and. present(ga) )call get_generic(na,ga) if( present(nb) .and. present(gb) )call get_generic(nb,gb) if( present(nc) .and. present(gc) )call get_generic(nc,gc) if( present(nd) .and. present(gd) )call get_generic(nd,gd) if( present(ne) .and. present(ge) )call get_generic(ne,ge) if( present(nf) .and. present(gf) )call get_generic(nf,gf) if( present(ng) .and. present(gg) )call get_generic(ng,gg) if( present(nh) .and. present(gh) )call get_generic(nh,gh) if( present(ni) .and. present(gi) )call get_generic(ni,gi) if( present(nj) .and. present(gj) )call get_generic(nj,gj) contains !=================================================================================================================================== function c(generic) class(*),intent(in) :: generic character(len=:),allocatable :: c select type(generic) type is (character(len=*)); c=trim(generic) class default c='unknown' stop 'get_many:: parameter name is not character' end select end function c !=================================================================================================================================== subroutine get_generic(name,generic) use,intrinsic :: iso_fortran_env, only : real64 character(len=*),intent(in) :: name class(*),intent(out) :: generic select type(generic) type is (integer); call get_args(name,generic) type is (real); call get_args(name,generic) type is (real(kind=real64)); call get_args(name,generic) type is (logical); call get_args(name,generic) !x!type is (character(len=:),allocatable ::); call get_args(name,generic) type is (character(len=*)); call get_args_fixed_length(name,generic) type is (complex); call get_args(name,generic) class default stop 'unknown type in *get_generic*' end select end subroutine get_generic !=================================================================================================================================== end subroutine many_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function iget(n); integer :: iget; character(len=*),intent(in) :: n; call get_args(n,iget); end function iget function rget(n); real :: rget; character(len=*),intent(in) :: n; call get_args(n,rget); end function rget function dget(n); real(kind=dp) :: dget; character(len=*),intent(in) :: n; call get_args(n,dget); end function dget function sget(n); character(len=:),allocatable :: sget; character(len=*),intent(in) :: n; call get_args(n,sget); end function sget function cget(n); complex :: cget; character(len=*),intent(in) :: n; call get_args(n,cget); end function cget function lget(n); logical :: lget; character(len=*),intent(in) :: n; call get_args(n,lget); end function lget function igs(n); integer,allocatable :: igs(:); character(len=*),intent(in) :: n; call get_args(n,igs); end function igs function rgs(n); real,allocatable :: rgs(:); character(len=*),intent(in) :: n; call get_args(n,rgs); end function rgs function dgs(n); real(kind=dp),allocatable :: dgs(:); character(len=*),intent(in) :: n; call get_args(n,dgs); end function dgs function sgs(n,delims) character(len=:),allocatable :: sgs(:) character(len=*),optional,intent(in) :: delims character(len=*),intent(in) :: n call get_args(n,sgs,delims) end function sgs function cgs(n); complex,allocatable :: cgs(:); character(len=*),intent(in) :: n; call get_args(n,cgs); end function cgs function lgs(n); logical,allocatable :: lgs(:); character(len=*),intent(in) :: n; call get_args(n,lgs); end function lgs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function ig() integer,allocatable :: ig(:) integer :: i, ierr if(allocated(ig))deallocate(ig) allocate(ig(size(unnamed))) do i=1,size(ig) call a2i(unnamed(i),ig(i),ierr) enddo end function ig !=================================================================================================================================== function rg() real,allocatable :: rg(:) rg=real(dg()) end function rg !=================================================================================================================================== function dg() real(kind=dp),allocatable :: dg(:) integer :: i integer :: ierr if(allocated(dg))deallocate(dg) allocate(dg(size(unnamed))) do i=1,size(dg) call a2d(unnamed(i),dg(i),ierr) enddo end function dg !=================================================================================================================================== function lg() logical,allocatable :: lg(:) integer :: i integer :: iichar character,allocatable :: hold if(allocated(lg))deallocate(lg) allocate(lg(size(unnamed))) do i=1,size(lg) hold=upper(clipends(unnamed(i))) if(hold(1:1) == '.')then ! looking for fortran logical syntax .STRING. iichar=2 else iichar=1 endif select case(hold(iichar:iichar)) ! check word to see if true or false case('T','Y',' '); lg(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) case('F','N'); lg(i)=.false. ! assume this is false or no case default call journal("*lg* bad logical expression for element",i,'=',hold) end select enddo end function lg !=================================================================================================================================== function cg() complex,allocatable :: cg(:) integer :: i, ierr real(kind=dp) :: rc, ic if(allocated(cg))deallocate(cg) allocate(cg(size(unnamed))) do i=1,size(cg),2 call a2d(unnamed(i),rc,ierr) call a2d(unnamed(i+1),ic,ierr) cg(i)=cmplx(rc,ic,kind=sp) enddo end function cg !=================================================================================================================================== ! Does not work with gcc 5.3 !function sg() !character(len=:),allocatable :: sg(:) ! sg=unnamed !end function sg !=================================================================================================================================== function sg() character(len=:),allocatable :: sg(:) if(allocated(sg))deallocate(sg) allocate(sg,source=unnamed) end function sg !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine mystop(sig,msg) ! negative signal means always stop program ! else do not stop and set G_STOP_MESSAGE if G_QUIET is true ! or ! print message and stop if G_QUIET is false ! the MSG is NOT for displaying except for internal errors when the program will be stopped. ! It is for returning a value when the stop is being ignored ! integer,intent(in) :: sig character(len=*),intent(in),optional :: msg if(sig < 0)then if(present(msg))call journal(msg) stop 1 elseif(.not.G_QUIET)then stop else if(present(msg)) then G_STOP_MESSAGE=msg else G_STOP_MESSAGE='' endif G_STOP=sig endif end subroutine mystop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function atleast(line,length,pattern) result(strout) ! ident_32="@(#) M_strings atleast(3f) return string padded to at least specified length" character(len=*),intent(in) :: line integer,intent(in) :: length character(len=*),intent(in),optional :: pattern character(len=max(length,len(trim(line)))) :: strout if(present(pattern))then strout=line//repeat(pattern,len(strout)/len(pattern)+1) else strout=line endif end function atleast !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function clipends(string) result(lopped) ! trim leading and trailings spaces from resulting string character(len=*),intent(in) :: string character(len=:),allocatable :: lopped integer :: ends(2) ends=verify( string, " ", [.false.,.true.] ) if(ends(1) == 0)then lopped="" else lopped=string(ends(1):ends(2)) endif end function clipends !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine locate_key(keyname,place) ! ident_33="@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where KEYNAME can be found or should be placed" character(len=*),intent(in) :: keyname integer,intent(out) :: place integer :: ii character(len=:),allocatable :: keyword_local if(G_UNDERDASH)then keyword_local=trim(replace_str(keyname,'-','_')) else keyword_local=trim(keyname) endif if(G_NODASHUNDER)then keyword_local=replace_str(keyword_local,'-','') keyword_local=replace_str(keyword_local,'_','') endif if(G_IGNORELONGCASE.and.len_trim(keyword_local) > 1)keyword_local=lower(keyword_local) if(G_IGNOREALLCASE)keyword_local=lower(keyword_local) if(len(keyword_local) == 1)then !x!ii=findloc(shorts,keyword_local,dim=1) ii=maxloc([0,merge(1, 0, shorts == keyword_local)],dim=1) if(ii > 1)then place=ii-1 else call locate_(keywords,keyword_local,place) endif else call locate_(keywords,keyword_local,place) endif if(G_DEBUG) write(*,gen)'LOCATE_KEY:KEYNAME:',trim(keyname),':KEYWORD:',keyword_local end subroutine locate_key !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_mode(key,mode) !! !! character(len=*),intent(in) :: key !! logical,intent(in),optional :: mode !! !!##DESCRIPTION !! Allow optional behaviors. !! !!##OPTIONS !! KEY name of option !! !! The following values are allowed: !! !! o response_file - enable use of response file !! !! o ignorelongcase - ignore case in long key names. So the user !! does not have to remember if the option is --CurtMode or --curtmode !! or --curtMode . !! !! o ignoreallcase - ignore case in long and short key names. !! This is similar to Powershell, which is case-insensitive. !! !! o dashunder - treat dash in keyword as an underscore. !! So the user should not have to remember if the option is !! --ignore_case or --ignore-case. !! !! o nodashunder - ignore dash and underscore in keywords. !! !! o strict - allow Boolean keys to be bundled, but requires !! a single dash prefix be used for short key names and long names !! must be prefixed with two dashes. !! !! o lastonly - when multiple keywords occur keep the rightmost !! value specified instead of appending the values together. !! !! MODE set to .true. to activate the optional mode. !! Set to .false. to deactivate the mode. !! It is .true. by default. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_set_mode !! use M_CLI2, only : set_args, lget, set_mode !! implicit none !! character(len=*),parameter :: all='(*(g0))' !! ! !! ! enable use of response files !! call set_mode('response_file') !! ! !! ! Any dash in a keyword is treated as an underscore !! call set_mode('underdash') !! ! !! ! The case of long keywords are ignored. !! ! Values and short names remain case-sensitive !! call set_mode('ignorelongcase') !! ! The case of short and long keywords are ignored !! call set_mode('ignoreallcase') !! ! !! ! short single-character boolean keys may be bundled !! ! but it is required that a single dash is used for !! ! short keys and a double dash for long keywords. !! call set_mode('strict') !! ! !! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F') !! ! !! ! show the results !! print all,'--switch_X or -X ... ',lget('switch_X') !! print all,'--switch_Y or -Y ... ',lget('switch_Y') !! print all,'--ox or -O ... ',lget('ox') !! print all,'-o ... ',lget('o') !! print all,'-x ... ',lget('x') !! print all,'-t ... ',lget('t') !! end program demo_set_mode !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure subroutine set_mode(key,mode) character(len=*),intent(in) :: key logical,intent(in),optional :: mode logical :: local_mode if(present(mode))then local_mode=mode else local_mode=.true. endif select case(lower(key)) case('response_file','response file'); CLI_RESPONSE_FILE=local_mode case('debug'); G_DEBUG=local_mode case('ignorecase','ignorelongcase'); G_IGNORELONGCASE=local_mode case('ignoreallcase'); G_IGNOREALLCASE=local_mode case('underdash','dashunder'); G_UNDERDASH=local_mode case('nodashunder','nounderdash'); G_NODASHUNDER=local_mode case('strict'); G_STRICT=local_mode case('lastonly'); G_APPEND=.not.local_mode case default call journal('*set_mode* unknown key name ',key) end select if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:END' end subroutine set_mode !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine print_dictionary_usage() if(G_DEBUG)then call print_dictionary( str('response_file=', CLI_RESPONSE_FILE, & &'ignorelongcase=', G_IGNORELONGCASE,& &'ignoreallcase=', G_IGNOREALLCASE,& &'underdash=', G_UNDERDASH,& &'strict=', G_STRICT,& &'lastonly=', G_APPEND,& &'NODASHUNDER=', G_NODASHUNDER,& &'debug=', G_DEBUG) ) else call print_dictionary('USAGE:') endif end subroutine print_dictionary_usage !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end module M_CLI2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !>>>>> build/dependencies/M_match/src/M_match.f90 !09/22/1980 15:38:34 !04/19/2020 11:05:06 !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! M_match(3fp) - [M_MATCH] Basic Regular Expressions !! (LICENSE:PD) !!##SYNOPSIS !! !! use M_match, only: match, amatch, getpat, makpat !! use M_match, only: YES, MAXPAT, MAXARG, MAXLINE, EOS, NEWLINE, ERR !! !!##DESCRIPTION !! Find a string matching a regular expression. !! !! * zero or more occurrences of the previous character !! . any character !! ^ beginning of line !! $ end of line !! [] class of characters. Inside the braces !! !! ^ at the beginning of the class means to !! negate the class. !! - if not the first or last character in !! the class, denotes a range of characters !! Escape characters: !! \\n newline !! \\r carriage return !! \\t tab !! \\b backspace !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain module M_match use, intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit implicit none private public :: getpat !....... encode regular expression for pattern matching public :: match !....... match pattern anywhere on line public :: amatch !....... look for pattern matching regular expression public :: makpat !....... encode regular expression for pattern matching public :: regex_pattern public :: bpos, epos private :: omatch private :: error private :: addset private :: dodash private :: locate private :: patsiz private :: stclos private :: getccl private :: filset private :: esc integer,parameter,public :: MAXTAGS=10 interface getpat; module procedure getpat_, getpat__; end interface interface makpat; module procedure makpat_ ; end interface interface amatch; module procedure amatch_, amatch__; end interface interface match; module procedure match_, match__ ; end interface interface omatch; module procedure omatch_ ; end interface !========== STANDARD RATFOR DEFINITIONS ========== !x!integer,parameter :: CHARACTER=INTEGER integer,parameter :: chr=kind(1) integer,parameter :: byte=kind(1) integer,parameter :: def=kind(1) !x!integer,parameter :: ANDIF=IF integer(kind=byte),parameter :: EOF=10003_byte integer(kind=byte),parameter,public :: EOS=10002_byte integer(kind=byte),parameter,public :: ERR=10001_byte integer(kind=byte),parameter,public :: YES=1_byte !x!integer(kind=byte),parameter :: ARB=100_byte integer(kind=byte),parameter :: ACCENT=96_byte integer(kind=byte),parameter :: AND=38_byte integer(kind=byte),parameter :: ATSIGN=64_byte integer(kind=byte),parameter :: BACKSLASH=92_byte integer(kind=byte),parameter :: BACKSPACE=8_byte integer(kind=byte),parameter :: CR=13_byte integer(kind=byte),parameter :: BANG=33_byte integer(kind=byte),parameter :: BAR=124_byte integer(kind=byte),parameter :: BIGA=65_byte integer(kind=byte),parameter :: BIGB=66_byte integer(kind=byte),parameter :: BIGC=67_byte integer(kind=byte),parameter :: BIGD=68_byte integer(kind=byte),parameter :: BIGE=69_byte integer(kind=byte),parameter :: BIGF=70_byte integer(kind=byte),parameter :: BIGG=71_byte integer(kind=byte),parameter :: BIGH=72_byte integer(kind=byte),parameter :: BIGI=73_byte integer(kind=byte),parameter :: BIGJ=74_byte integer(kind=byte),parameter :: BIGK=75_byte integer(kind=byte),parameter :: BIGL=76_byte integer(kind=byte),parameter :: BIGM=77_byte integer(kind=byte),parameter :: BIGN=78_byte integer(kind=byte),parameter :: BIGO=79_byte integer(kind=byte),parameter :: BIGP=80_byte integer(kind=byte),parameter :: BIGQ=81_byte integer(kind=byte),parameter :: BIGR=82_byte integer(kind=byte),parameter :: BIGS=83_byte integer(kind=byte),parameter :: BIGT=84_byte integer(kind=byte),parameter :: BIGU=85_byte integer(kind=byte),parameter :: BIGV=86_byte integer(kind=byte),parameter :: BIGW=87_byte integer(kind=byte),parameter :: BIGX=88_byte integer(kind=byte),parameter :: BIGY=89_byte integer(kind=byte),parameter :: BIGZ=90_byte integer(kind=byte),parameter,public :: BLANK=32_byte integer(kind=byte),parameter :: CARET=94_byte integer(kind=byte),parameter :: COLON=58_byte integer(kind=byte),parameter :: COMMA=44_byte integer(kind=byte),parameter :: DIG0=48_byte integer(kind=byte),parameter :: DIG1=49_byte integer(kind=byte),parameter :: DIG2=50_byte integer(kind=byte),parameter :: DIG3=51_byte integer(kind=byte),parameter :: DIG4=52_byte integer(kind=byte),parameter :: DIG5=53_byte integer(kind=byte),parameter :: DIG6=54_byte integer(kind=byte),parameter :: DIG7=55_byte integer(kind=byte),parameter :: DIG8=56_byte integer(kind=byte),parameter :: DIG9=57_byte integer(kind=byte),parameter :: DIGIT=2_byte integer(kind=byte),parameter :: DOLLAR=36_byte integer(kind=byte),parameter :: DQUOTE=34_byte integer(kind=byte),parameter :: EQUALS=61_byte integer(kind=byte),parameter :: ERROUT=2_byte integer(kind=byte),parameter :: GREATER=62_byte integer(kind=byte),parameter :: LBRACE=123_byte integer(kind=byte),parameter :: LBRACK=91_byte integer(kind=byte),parameter :: LESS=60_byte integer(kind=byte),parameter :: LETA=97_byte integer(kind=byte),parameter :: LETB=98_byte integer(kind=byte),parameter :: LETC=99_byte integer(kind=byte),parameter :: LETD=100_byte integer(kind=byte),parameter :: LETE=101_byte integer(kind=byte),parameter :: LETF=102_byte integer(kind=byte),parameter :: LETG=103_byte integer(kind=byte),parameter :: LETH=104_byte integer(kind=byte),parameter :: LETI=105_byte integer(kind=byte),parameter :: LETJ=106_byte integer(kind=byte),parameter :: LETK=107_byte integer(kind=byte),parameter :: LETL=108_byte integer(kind=byte),parameter :: LETM=109_byte integer(kind=byte),parameter :: LETN=110_byte integer(kind=byte),parameter :: LETO=111_byte integer(kind=byte),parameter :: LETP=112_byte integer(kind=byte),parameter :: LETQ=113_byte integer(kind=byte),parameter :: LETR=114_byte integer(kind=byte),parameter :: LETS=115_byte integer(kind=byte),parameter :: LETT=116_byte integer(kind=byte),parameter :: LETTER=1_byte integer(kind=byte),parameter :: LETU=117_byte integer(kind=byte),parameter :: LETV=118_byte integer(kind=byte),parameter :: LETW=119_byte integer(kind=byte),parameter :: LETX=120_byte integer(kind=byte),parameter :: LETY=121_byte integer(kind=byte),parameter :: LETZ=122_byte integer(kind=byte),parameter :: LPAREN=40_byte !x!integer(kind=byte),parameter :: MAXCHARS=20_byte integer(kind=byte),parameter,public :: MAXLINE=1024_byte ! TYPICAL LINE LENGTH !x!integer(kind=byte),parameter :: MAXNAME=30_byte ! TYPICAL FILE NAME SIZE integer(kind=byte),parameter :: MINUS=45_byte integer(kind=byte),parameter :: NEWLINE=10_byte integer(kind=byte),parameter,public :: NO=0_byte integer(kind=byte),parameter :: NOERR=0_byte integer(kind=byte),parameter :: NOT=126_byte ! SAME AS TILDE integer(kind=byte),parameter :: OK=-2_byte integer(kind=byte),parameter :: OR=BAR ! SAME AS BAR integer(kind=byte),parameter :: PERCENT=37_byte integer(kind=byte),parameter :: PERIOD=46_byte integer(kind=byte),parameter :: PLUS=43_byte integer(kind=byte),parameter :: QMARK=63_byte integer(kind=byte),parameter :: RBRACE=125_byte integer(kind=byte),parameter :: RBRACK=93_byte integer(kind=byte),parameter :: READ=0_byte integer(kind=byte),parameter :: READWRITE=2_byte integer(kind=byte),parameter :: RPAREN=41_byte integer(kind=byte),parameter :: SEMICOL=59_byte integer(kind=byte),parameter :: SHARP=35_byte integer(kind=byte),parameter :: SLASH=47_byte integer(kind=byte),parameter :: SQUOTE=39_byte integer(kind=byte),parameter :: STAR=42_byte integer(kind=byte),parameter :: TAB=9_byte integer(kind=byte),parameter :: TILDE=126_byte integer(kind=byte),parameter :: UNDERLINE=95_byte integer(kind=byte),parameter :: WRITE=1_byte ! HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE integer(kind=byte),parameter,public :: MAXPAT=512 integer(kind=byte),parameter,public :: MAXARG=512 integer(kind=byte),parameter :: MAXSUBS=10 integer(kind=byte),parameter :: COUNT=1 integer(kind=byte),parameter :: PREVCL=2 integer(kind=byte),parameter :: START=3 integer(kind=byte),parameter :: CLOSIZE=4 !x!integer(kind=byte),parameter :: ESCAPE=ATSIGN !x!integer(kind=byte),parameter :: ANY=QMARK !x!integer(kind=byte),parameter :: BOL=PERCENT integer(kind=byte),parameter :: EOL=DOLLAR integer(kind=byte),parameter :: CLOSURE=STAR integer(kind=byte),parameter :: DASH=MINUS integer(kind=byte),parameter :: ESCAPE=BACKSLASH integer(kind=byte),parameter :: ANY=PERIOD integer(kind=byte),parameter :: BOL=CARET integer(kind=byte),parameter :: CCL=LBRACK integer(kind=byte),parameter :: CCLEND=RBRACK integer(kind=byte),parameter :: NCCL=LETN integer(kind=byte),parameter :: CHAR=LETA integer(kind=byte),parameter :: BOSS=LBRACE ! < integer(kind=byte),parameter :: EOSS=RBRACE ! > !x!COMMON /CSUBS/ BPOS(MAXSUBS), EPOS(MAXSUBS) integer(kind=byte) :: bpos(maxsubs) ! beginning of partial match integer(kind=byte) :: epos(maxsubs) ! end of corresponding partial match type :: regex_pattern integer :: pat(MAXPAT) end type regex_pattern contains !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! function f2r(string,isize) character(len=*),parameter::ident_1="& &@(#)M_match::f2r(3f): convert Fortran character variable to Ratfor integer array with Ratfor terminator" character(len=*),intent(in) :: string integer,intent(in) :: isize !!integer :: f2r(len(string)+1) integer :: f2r(isize) integer :: i f2r=blank do i=1,len_trim(string) f2r(i)=ichar(string(i:i)) enddo f2r(i)=eos end function f2r !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! function r2f(ints) character(len=*),parameter::ident_2="@(#)M_match::r2f(3f): convert Ratfor integer array to Fortran character variable" integer,intent(in) :: ints(:) character(len=size(ints)-1) :: r2f integer :: i intrinsic char r2f=' ' do i=1,size(ints)-1 if(ints(i).eq.eos)then exit endif r2f(i:i)=char(ints(i)) enddo end function r2f !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! getpat(3f) - [M_MATCH] convert str into pattern !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function getpat(str, pat) !!##DESCRIPTION !! convert str into pattern !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function getpat_(arg, pat) ! ident_1="@(#)M_match::getpat_ convert argument into pattern" integer(kind=def) :: getpat_ integer(kind=def) :: arg(maxarg) integer(kind=def) :: pat(maxpat) getpat_ = makpat_(arg, 1, EOS, pat) end function getpat_ !=================================================================================================================================== function getpat__(arg_str, pat) character(len=*),intent(in) :: arg_str integer(kind=def),intent(out) :: pat(maxpat) integer(kind=def) :: getpat__ integer(kind=def) :: arg(maxarg) integer :: len_arg_str len_arg_str=len(arg_str) if(len_arg_str.gt.MAXARG-1)then write(*,*)'*getpat* error: input arg_str too long,',len_arg_str,' > ',MAXARG-1 stop endif arg=f2r(arg_str,size(arg)) getpat__ = makpat_(arg, 1, eos, pat) end function getpat__ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! addset(3f) - [M_MATCH] put c in string(J) if it fits, increment J !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function addset(c, str, j, maxsiz) !!##DESCRIPTION !! put c in string(j) if it fits, increment !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function addset(c, set, j, maxsiz) ! ident_2="@(#)M_match::addset put C in SET(J) if it fits, increment J" integer(kind=byte) :: addset integer(kind=chr),intent(in) :: c integer(kind=chr) :: set(:) integer(kind=byte) :: j integer(kind=byte),intent(in) :: maxsiz if (j > maxsiz)then addset = NO else set(j) = c j = j + 1 addset = YES endif end function addset !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! dodash(3f) - [M_MATCH] expand array(i-1)-array(i+1) into set(j)... from valid !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine dodash(valid, array, i, set, j, maxset) !!##DESCRIPTION !! expand array(i-1)-array(i+1) into set(j)... from valid !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain ! dodash - expand array(i-1)-array(i+1) into set(j)... from valid subroutine dodash(valid, array, i, set, j, maxset) integer(kind=def) :: i, j, junk, k, limit, maxset character(len=*),intent(in) :: valid integer(kind=chr) :: array(:) integer(kind=chr) :: set(:) intrinsic char i = i + 1 j = j - 1 limit = index(valid, char(esc(array, i))) k=index(valid,char(set(j))) do if(.not. (k.le.limit)) exit junk = addset(ichar(valid(k:k)), set, j, maxset) k=k+1 enddo end subroutine dodash !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! locate(3f) - [M_MATCH] look for c in char class at pat(offset) !! (LICENSE:PD) !!##SYNOPSIS !! !! pure integer function locate(c, pat, offset) !!##DESCRIPTION !! look for c in char class at pat(offset) !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! pure function locate(c, pat, offset) ! ident_3="@(#)M_match::locate look for c in char class at pat(offset)" integer(kind=def) :: locate integer(kind=chr),intent(in) :: c integer(kind=chr),intent(in) :: pat(maxpat) integer(kind=def),intent(in) :: offset integer(kind=def) :: i ! size of class is at pat(offset), characters follow !x!for (i = offset + pat(offset); i > offset; i = i - 1) locate = NO LOC: do i = offset + pat(offset), offset+1, -1 if (c == pat(i)) then locate = YES exit LOC endif enddo LOC end function locate !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! match(3f) - [M_MATCH] find match to a basic regular expression anywhere on input string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! integer function match(line, pattern) !! !! character(len=*),intent(in) :: line !! integer,intent(in) :: pattern(MAXPAT) !! !!##DESCRIPTION !! Given a BRE(Basic Regular Expression) converted to a pattern !! return whether an input string matches it. !! !!##OPTIONS !! LIN string to search for a match to the pattern !! PAT pattern generated from a BRE using getpat(3f) or makpat(3f). !! !!##EXAMPLE !! !! Sample program: !! !! program demo_match !! use :: M_match, only : getpat, match !! use :: M_match, only : MAXPAT, MAXARG, MAXLINE, YES, ERR !! implicit none !! ! find _ find patterns in text !! integer :: pat(MAXPAT) !! character(len=MAXARG-1) :: argument !! integer :: stat !! integer :: ios !! integer :: len_arg !! character(len=MAXLINE-2) :: line !! call get_command_argument(1, argument,status=stat,length=len_arg) !! if(stat.ne.0.or.argument.eq.'')then !! write(*,*)"usage: find pattern." !! elseif(getpat(argument(:len_arg), pat) .eq. ERR) then !! write(*,*)"illegal pattern." !! else !! INFINITE: do !! read(*,'(a)',iostat=ios)line !! if(ios.ne.0)exit !! if(match(trim(line), pat) .eq. YES) then !! write(*,'(*(a))')trim(line) !! endif !! enddo INFINITE !! endif !! end program demo_match !! !!##AUTHOR !! John S. Urban !! !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !! !!##LICENSE !! Public Domain function match_(lin, pat) ! ident_4="@(#)M_match::match find match anywhere on line" integer(kind=def) :: match_ integer(kind=chr) :: lin(maxline), pat(maxpat) integer(kind=def) :: i if (pat(1) == bol) then ! anchored match if (amatch_(lin, 1, pat) > 0) then match_ = yes return endif else ! unanchored !- for (i = 1; lin(i) /= eos; i = i + 1) i=1 do while (lin(i) /= eos) if (amatch_(lin, i, pat) > 0) then match_ = yes return endif i=i+1 enddo endif match_ = no end function match_ !==================================================================================================================================! function match__(lin_str, pat) ! ident_5="@(#)M_match::match find match anywhere on line" character(len=*),intent(in) :: lin_str integer(kind=def) :: match__ integer(kind=chr) :: lin(maxline), pat(maxpat) lin=f2r(lin_str,size(lin)) match__=match_(lin,pat) end function match__ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! patsiz(3f) - [M_MATCH] returns size of pattern entry at pat(n) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function patsiz(pat, n) !!##DESCRIPTION !! returns size of pattern entry at pat(n) !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function patsiz(pat, n) ! ident_6="@(#)M_match::patsiz returns size of pattern entry at pat(n)" integer(kind=def) :: patsiz integer(kind=chr) :: pat(MAXPAT) integer(kind=def) :: n select case(pat(n)) case(CHAR,BOSS,EOSS) patsiz = 2 case(BOL,EOL,ANY) patsiz = 1 case(CCL,NCCL) patsiz = pat(n + 1) + 2 case(CLOSURE) ! optional patsiz = CLOSIZE case default call error("in patsiz: cannot happen.") end select end function patsiz !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! stclos(3f) - [M_MATCH] insert CLOSURE entry at pat(j) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function stclos(pat, j, lastj, lastcl) !!##DESCRIPTION !! insert CLOSURE entry at pat(j) !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function stclos(pat, j, lastj, lastcl) ! ident_7="@(#)M_match::stclos insert closure entry at pat(j)" integer(kind=def) :: stclos integer(kind=chr) :: pat(maxpat) integer(kind=def) :: j, jp, jt, junk, lastcl, lastj !- for (jp = j - 1; jp >= lastj; jp = jp - 1) < ! make a hole do jp = j - 1, lastj, - 1 ! make a hole jt = jp + closize junk = addset(pat(jp), pat, jt, maxpat) enddo j = j + closize stclos = lastj junk = addset(closure, pat, lastj, maxpat) ! put closure in it junk = addset(0, pat, lastj, maxpat) ! count junk = addset(lastcl, pat, lastj, maxpat) ! prevcl junk = addset(0, pat, lastj, maxpat) ! start end function stclos !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! getccl(3f) - [M_MATCH] expand char class at arg(i) into pat(j) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function getccl(arg, i, pat, j) !!##DESCRIPTION !! expand char class at arg(i) into pat(j) !!##OPTIONS !! ARG ADE string array !! I index into ARG !! PAT encoded regular expression !! J . !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function getccl(arg, i, pat, j) ! ident_8="@(#)M_match::getccl expand char class at arg(i) into pat(j)" integer(kind=def) :: getccl integer(kind=chr) :: arg(maxarg), pat(maxpat) integer(kind=def) :: i, j, jstart, junk i = i + 1 ! skip over [ if (arg(i) == tilde .or. arg(i) == caret) then junk = addset(nccl, pat, j, maxpat) i = i + 1 else junk = addset(ccl, pat, j, maxpat) endif jstart = j junk = addset(0, pat, j, maxpat) ! leave room for count call filset(cclend, arg, i, pat, j, maxpat) pat(jstart) = j - jstart - 1 if (arg(i) == cclend)then getccl = ok else getccl = err endif end function getccl !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! filset(3f) - [M_MATCH] expand set at array(i) into set(j), stop at delim !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine filset(delim, array, i, set, j, maxset) !!##DESCRIPTION !! expand set at array(i) into set(j), stop at delim !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain subroutine filset(delim, array, i, set, j, maxset) ! ident_9="@(#)M_match::filset expand set at array(i) into set(j), stop at delim" integer(kind=def) :: i, j, junk, maxset integer(kind=chr) :: array(:), delim, set(:) character(len=*),parameter :: digits= "0123456789" character(len=*),parameter :: lowalf= "abcdefghijklmnopqrstuvwxyz" character(len=*),parameter :: upalf= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" intrinsic char !- for ( ; array(i) /= delim .and. array(i) /= eos; i = i + 1) do while( array(i) /= delim .and. array(i) /= eos) if (array(i) == escape) then junk = addset(esc(array, i), set, j, maxset) elseif (array(i) /= dash) then junk = addset(array(i), set, j, maxset) elseif (j <= 1 .or. array(i+1) == eos) then ! literal - junk = addset(dash, set, j, maxset) elseif (index(digits, char(set (j - 1))) > 0) then call dodash(digits, array, i, set, j, maxset) elseif (index(lowalf, char(set (j - 1))) > 0) then call dodash(lowalf, array, i, set, j, maxset) elseif (index(upalf, char(set (j - 1))) > 0) then call dodash(upalf, array, i, set, j, maxset) else junk = addset (DASH, set, j, maxset) endif i=i+1 enddo end subroutine filset !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! esc(3f) - [M_MATCH] map array(i) into escaped character if appropriate !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function esc(array, i) !! integer,intent(in) :: array(*) !! integer :: i !! !!##DESCRIPTION !! To support commonly used non-printable characters escaped strings are !! supported. When the ESCAPE character is encountered the following !! character is examined. If one of the special characters ESC(3f) will !! increment I and return the designated non-printable character. Otherwise !! it will return the character as-is. !! !! o convert \n to newline !! o convert \t to horizontal tab !! o convert \r to carriage return !! o convert \b to backspace !! o convert \nnn to character represented by octal value !! !!##OPTIONS !! ARRAY array of ADE (ASCII Decimal Equivalent) values terminated by !! an EOS (End-Of-String) character representing a string to scan !! for escaped characters. !! I pointer into ARRAY. It is incremented to the position of the !! next character in ARRAY on return. !! !!##RETURNS !! ESC The ADE for the substituted character !! !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban !! !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !! !!##LICENSE !! Public Domain function esc(array, i) ! ident_10="@(#)M_match::esc map array(i) into escaped character if appropriate" integer(kind=chr) :: esc integer(kind=chr) :: array(:) integer(kind=def) :: i if (array(i) /= escape)then ! if not an escape character, return the character as-is esc = array(i) elseif (array(i+1) == eos)then ! if ESCAP is the last character it is left as-is and is not special esc = escape else i = i + 1 ! increment I to look at character after ESCAP select case(array(i)) ! make substitution to special character for designated characters case(ichar('n'),ichar('N')); esc = newline case(ichar('t'),ichar('T')); esc = tab case(ichar('b'),ichar('B')); esc = backspace case(ichar('r'),ichar('R')); esc = cr case(dig0:dig7) !- for (esc = 0; array(i) >= dig0 .and. array(i) <= dig7; i = i + 1) esc=0 do while (array(i) >= dig0 .and. array(i) <= dig7) i = i + 1 esc = 8*esc + array(i) - dig0 i = i - 1 ! so like other cases enddo case default esc = array(i) ! otherwise just copy character end select endif end function esc !----------------------------------------------------------------------------------------------------------------------------------! ! Conventional C Constants ! Oct Dec Hex Char ! ----------------------- ! 000 0 00 NUL '\0' Null ! 007 7 07 BEL '\a' Bell ! *010 8 08 BS '\b' Backspace ! *011 9 09 HT '\t' Horizontal Tab ! *012 10 0A LF '\n' Line Feed ! 013 11 0B VT '\v' Vertical Tab ! 014 12 0C FF '\f' Form Feed ! *015 13 0D CR '\r' Carriage Return ! 134 92 5C \ '\\' Backslash !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! omatch(3f) - [M_MATCH] try to match a single pattern at pat(j) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function omatch(lin, i, pat, j) !!##DESCRIPTION !! try to match a single pattern at pat(j) !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function omatch_(lin, i, pat, j) ! ident_11="@(#)M_match::omatch_ try to match a single pattern at pat(j)" integer(kind=def) :: omatch_ integer(kind=chr) :: lin(maxline), pat(maxpat) integer(kind=def) :: bump, i, j, k omatch_ = no if (lin(i) == eos)then return endif bump = -1 if (pat(j) == char) then if (lin(i) == pat(j + 1))then bump = 1 endif elseif (pat(j) == bol) then if (i == 1)then bump = 0 endif elseif (pat(j) == any) then if (lin(i) /= newline)then bump = 1 endif elseif (pat(j) == eol) then if (lin(i) == newline .or. lin(i) == eos)then bump = 0 endif elseif (pat(j) == ccl) then if (locate(lin(i), pat, j + 1) == yes)then bump = 1 endif elseif (pat(j) == nccl) then if (lin(i) /= newline .and. locate(lin(i), pat, j + 1) == no)then bump = 1 endif elseif (pat(j) == boss) then k = pat(j+1) bpos(k+1) = i bump = 0 elseif (pat(j) == eoss) then k = pat(j+1) epos(k+1) = i bump = 0 else call error("in omatch_: can't happen.") endif if (bump >= 0) then i = i + bump omatch_ = yes endif end function omatch_ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! amatch(3f) - [M_MATCH] look for pattern matching regular expression; returns its location !! (LICENSE:PD) !!##SYNOPSIS !! !! loc = amatch(line, from, pat, tagbeg, tagend) !! !! character(len=*),intent(in) :: line !! integer,intent(in) :: from !! character :: pat(MAXPAT) !! integer :: tagbeg(MAXTAGS), tagend(MAXTAGS) !! integer :: loc !!##DESCRIPTION !! AMATCH scans LINE starting at location FROM, looking !! for a pattern which matches the regular expression coded !! in PAT. If the pattern is found, its starting location !! in LINE is returned. If the pattern is not found, AMATCH !! returns 0. !! !! The regular expression in PAT must have been previously !! encoded by GETPAT(3f) or MAKPAT(3f). (For a complete description !! of regular expressions, see the manpage for M_match.) !! !! AMATCH(3f) is a special-purpose version of MATCH(3f), which should !! be used in most cases. !!##OPTIONS !! LINE input line to scan !! FROM beginning location to start scan from !! PAT coded regular expression encoded by GETPAT(3f) or MAKPAT(3f) !! TAGBEG,TAGEND element "i + 1" returns start or end, respectively, of "i"th tagged subpattern !!##RETURNS !! LOC returns location match was found or zero (0) if no match remains !!##EXAMPLE !! !! Sample program: !! !! program demo_amatch !! use :: M_match, only : getpat, amatch !! use :: M_match, only : MAXPAT, MAXARG, MAXLINE, MAXTAGS, YES, ERR !! implicit none !! ! find _ find patterns in text !! integer :: pat(MAXPAT) !! character(len=MAXARG-1) :: argument !! integer :: stat !! integer :: ios !! integer :: len_arg !! integer :: loc !! integer :: ii !! character(len=MAXLINE-2) :: line !! integer :: tagbeg(MAXTAGS),tagend(MAXTAGS) !! call get_command_argument(1, argument,status=stat,length=len_arg) !! if(stat.ne.0.or.argument.eq.'')then !! write(*,*)"usage: find pattern." !! elseif(getpat(argument(:len_arg), pat) .eq. ERR) then !! write(*,*)"illegal pattern." !! else !! INFINITE: do !! read(*,'(a)',iostat=ios)line !! tagbeg=-9999;tagend=-9999 !! if(ios.ne.0)exit !! loc = amatch(trim(line), 1, pat, tagbeg, tagend) ! returns location/0 !! if(loc.gt.0)then ! matched; if no match, loc is returned as 0 !! write(*,'(*(a))')trim(line) !! ! (element "i + 1" returns start or end, respectively, of "i"th tagged subpattern) !! write(*,'(*(i0,1x,i0,1x,i0,/))')(ii,tagbeg(ii),tagend(ii),ii=1,size(tagbeg)) !! endif !! enddo INFINITE !! endif !! end program demo_amatch !! !!##SEE ALSO !! match, getpat, makpat !!##DIAGNOSTICS !! None !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function amatch_(lin, from, pat) ! ident_12="@(#)M_match::amatch_ (non-recursive) look for match starting at lin(from)" integer(kind=def) :: amatch_ integer(kind=chr) :: lin(maxline), pat(maxpat) integer(kind=def) :: from, i, j, offset, stack stack = 0 offset = from ! next unexamined input character !- for (j = 1; j <= maxsubs; j = j + 1) < ! clear partial match results do j = 1, maxsubs ! clear partial match results bpos(j) = offset epos(j) = offset enddo !- for (j = 1; pat(j) /= eos; j = j + patsiz(pat, j)) j=1 do while (pat(j) /= eos) if (pat(j) == closure) then ! a closure entry stack = j j = j + closize ! step over closure !- for (i = offset; lin(i) /= eos; ) ! match as many as possible i = offset do while ( lin(i) /= eos ) ! match as many as if (omatch_(lin, i, pat, j) == no)then ! possible exit endif enddo pat(stack+count) = i - offset pat(stack+start) = offset offset = i ! character that made us fail elseif (omatch_(lin, offset, pat, j) == no) then ! non-closure !- for ( ; stack > 0; stack = pat(stack+prevcl)) do while (stack >0) if (pat(stack+count) > 0)then exit endif stack = pat(stack+prevcl) enddo if (stack <= 0) then ! stack is empty amatch_ = 0 ! return failure return endif pat(stack+count) = pat(stack+count) - 1 j = stack + closize offset = pat(stack+start) + pat(stack+count) endif j = j + patsiz(pat, j) enddo ! else omatch_ succeeded epos(1) = offset amatch_ = offset ! success end function amatch_ !==================================================================================================================================! function amatch__(lin_str, from, pat) ! ident_13="@(#)M_match::amatch" character(len=*),intent(in) :: lin_str integer,intent(in) :: from integer(kind=def) :: amatch__ integer(kind=chr) :: pat(maxpat) integer(kind=chr) :: lin(maxline) lin=f2r(lin_str,size(lin)) amatch__=amatch_(lin,from,pat) end function amatch__ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! makpat(3f) - [M_MATCH] make pattern from arg(from), terminate on delim !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function makpat(arg, from, delim, pat) !!##DESCRIPTION !! make pattern from arg(from), terminate on delim !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function makpat_(arg, from, delim, pat) ! ident_14="@(#)M_match::makpat_ make pattern from arg(from), terminate at delim" integer(kind=def) :: makpat_ integer(kind=chr) :: arg(maxarg), delim, pat(maxpat) integer(kind=def) :: from, i, j, junk, lastcl, lastj, lj, nsubs, sp, substk(maxsubs) j = 1 ! pat index lastj = 1 lastcl = 0 nsubs = 0 ! counts number of @(@) pairs sp = 0 ! stack pointer for substk !- for (i = from; arg(i) /= delim .and. arg(i) /= eos; i = i + 1) < i=from do while ( arg(i) /= delim .and. arg(i) /= eos ) lj = j if (arg(i) == any)then junk = addset(any, pat, j, maxpat) elseif (arg(i) == bol .and. i == from)then junk = addset(bol, pat, j, maxpat) elseif (arg(i) == eol .and. arg(i + 1) == delim)then junk = addset(eol, pat, j, maxpat) elseif (arg(i) == ccl) then if (getccl(arg, i, pat, j) == err)then exit endif elseif (arg(i) == closure .and. i > from) then lj = lastj !x!if(pat(lj)==bol .or. pat(lj)==eol .or. pat(lj)==closure .or. pat(lj-1) == boss .or. pat(lj-1) == eoss) then if(pat(lj)==bol .or. pat(lj)==eol .or. pat(lj)==closure .or. pat(lj) == boss .or. pat(lj) == eoss) then exit endif lastcl = stclos(pat, j, lastj, lastcl) elseif (arg(i) == escape .and. arg(i+1) == lparen) then nsubs = nsubs + 1 if (nsubs >= maxsubs)then exit endif junk = addset(boss, pat, j, maxpat) junk = addset(nsubs, pat, j, maxpat) sp = sp + 1 substk(sp) = nsubs i = i + 1 elseif (arg(i) == escape .and. arg(i+1) == rparen) then if (sp <= 0)then exit endif junk = addset(eoss, pat, j, maxpat) junk = addset(substk(sp), pat, j, maxpat) sp = sp - 1 i = i + 1 else junk = addset(char, pat, j, maxpat) junk = addset(esc(arg, i), pat, j, maxpat) endif lastj = lj i=i+1 enddo if (arg(i) /= delim .or. sp /= 0)then ! terminated early makpat_ = err elseif (addset(eos, pat, j, maxpat) == no)then ! no room makpat_ = err else makpat_ = i endif end function makpat_ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! error(3f) - [M_MATCH] print message and stop program execution !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine error(line) !!##DESCRIPTION !! print message and stop program execution !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain subroutine error(message) ! ident_15="@(#)M_match::error(3f): print message and stop program execution" character(len=*),intent(in) :: message write(stderr,'(a)')trim(message) stop end subroutine error !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! end module M_match !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !>>>>> build/dependencies/M_strings/src/M_strings.F90 !> !!##NAME !! M_strings(3f) - [M_strings::INTRO] Fortran string module !! !!##DESCRIPTION !! The M_strings(3fm) module is a collection of Fortran procedures !! that supplement the built-in intrinsic string routines. Routines !! for parsing, tokenizing, changing case, substituting new strings for !! substrings, locating strings with simple wildcard expressions, removing !! tabs and line terminators and other string manipulations are included. !! !! M_strings__oop(3fm) is a companion module that provides an OOP !! interface to the M_strings module. !! !!##SYNOPSIS !! !! public entities: !! !! use M_strings,only : split, sep, delim, chomp, strtok !! use M_strings,only : split2020, find_field !! use M_strings,only : substitute, change, modif, transliterate, & !! & reverse, squeeze !! use M_strings,only : replace, join !! use M_strings,only : upper, lower, upper_quoted !! use M_strings,only : rotate13, percent_encode !! use M_strings,only : adjustc, compact, nospace, indent !! use M_strings,only : crop, clip, unquote, quote, matching_delimiter !! use M_strings,only : len_white, pad, lpad, cpad, rpad, zpad, & !! & stretch, lenset, merge_str !! use M_strings,only : switch, s2c, c2s !! use M_strings,only : noesc, notabs, dilate, expand, visible !! use M_strings,only : longest_common_substring !! use M_strings,only : string_to_value, string_to_values, s2v, s2vs !! use M_strings,only : int, real, dble, nint !! use M_strings,only : atoi, atol, aton !! use M_strings,only : value_to_string, v2s, msg !! use M_strings,only : listout, getvals !! use M_strings,only : glob, ends_with !! use M_strings,only : paragraph !! use M_strings,only : base, decodebase, codebase, base2 !! use M_strings,only : isalnum, isalpha, iscntrl, isdigit !! use M_strings,only : isgraph, islower, isprint, ispunct !! use M_strings,only : isspace, isupper, isascii, isblank, isxdigit !! use M_strings,only : isnumber !! use M_strings,only : fortran_name !! use M_strings,only : describe !! use M_strings,only : edit_distance !! use M_strings,only : bundle !! !! TOKENS !! !! split subroutine parses string using specified delimiter characters !! and stores tokens into an array !! sep function interface to split(3f) !! delim subroutine parses string using specified delimiter characters !! and store tokens into an array !! chomp function consumes input line as it returns next token in a !! string using specified delimiters !! paragraph convert a string into a paragraph !! strtok tokenize a string like C strtok(3c) routine !! !! CONTRIBUTIONS !! !! split2020 split a string using prototype of proposed standard !! procedure !! find_field token a string !! !! EDITING !! !! substitute subroutine non-recursively globally replaces old !! substring with new substring !! replace function non-recursively globally replaces old !! substring with new substring using allocatable string !! (version of substitute(3f) without limitation on !! length of output string) !! change subroutine non-recursively globally replaces old !! substring with new substring with a directive like !! line editor !! modif subroutine modifies a string with a directive like the !! XEDIT line editor MODIFY command !! transliterate replace characters found in set one with characters !! from set two !! reverse reverse character order in a string !! join join an array of CHARACTER variables with specified !! separator !! rotate13 apply trivial encryption algorithm ROT13 to a string !! percent_encode apply percent-encryption (aka. URL encryption) to characters !! squeeze delete adjacent duplicate characters from a string !! !! CASE !! !! upper function converts string to uppercase !! lower function converts string to miniscule !! upper_quoted function converts string to uppercase skipping strings !! quoted per Fortran rules !! !! STRING LENGTH AND PADDING !! !! len_white find location of last non-whitespace character !! lenset return a string of specified length !! pad return a string of at least specified length !! zpad pad integer or string to length with zero characters !! on left !! lpad convert scalar intrinsic to a string padded on left to !! specified length !! cpad convert scalar intrinsic to a centered string of the !! specified length !! rpad convert scalar intrinsic to a string padded on right to !! specified length !! stretch return a string of at least specified length with suffix !! merge_str make strings of equal length and then call MERGE(3f) !! intrinsic !! WHITE SPACE !! !! adjustc elemental function centers text within the length of the !! input string !! compact left justify string and replace duplicate whitespace with !! single characters or nothing !! nospace function replaces whitespace with nothing !! indent find number of leading spaces !! crop function trims leading and trailing spaces and control !! characters !! clip function trims leading and trailing spaces !! !! See Also: squeeze !! !! QUOTES !! !! matching_delimiter find position of matching delimiter !! unquote remove quotes from string as if read with list-directed input !! quote add quotes to string as if written with list-directed input !! !! !! CHARACTER ARRAY VERSUS STRING !! !! switch switch between a string and an array of single characters !! s2c convert string to array of single characters and add null !! terminator for passing to C !! c2s convert null-terminated array of single characters to !! string for converting strings returned from C !! !! NONALPHA !! !! noesc convert non-printable ASCII8 characters to a space !! notabs convert tabs to spaces while maintaining columns, !! assuming tabs are set every 8 characters !! dilate function to convert tabs to spaces assuming tabs are set !! every 8 characters !! expand expand escape sequences in a string !! visible expand escape sequences in a string to "control" and !! meta-control representations !! !! NUMERIC STRINGS !! !! string_to_value generic subroutine returns numeric value (REAL, !! DOUBLEPRECISION, INTEGER) from string !! string_to_values subroutine reads an array of numbers from a string !! getvals subroutine reads a relatively arbitrary number !! of values from a string using list-directed read !! s2v function returns DOUBLEPRECISION numeric value !! from string !! s2vs function returns a DOUBLEPRECISION array of numbers !! from a string !! s2vs function returns a DOUBLEPRECISION array of numbers !! from a string !! atoi function returns INTEGER(kind=int32) from a string !! atol function returns INTEGER(kind=int64) from a string !! aton changes string to numeric value !! msg append the values of up to nine values into a string !! !! value_to_string generic subroutine returns string given numeric value !! (REAL, DOUBLEPRECISION, INTEGER, LOGICAL ) !! v2s generic function returns string from numeric value !! (REAL, DOUBLEPRECISION, INTEGER ) !! listout expand a list of numbers where negative numbers !! denote range ends (1 -10 means 1 thru 10) !! isnumber determine if string represents a number !! !! CHARACTER TESTS !! !! glob compares given string for match to pattern which may !! contain wildcard characters !! ends_with test whether strings ends with one of the specified suffixes !! !! o isalnum returns .true. if character is a letter or digit !! o isalpha returns .true. if character is a letter and !! .false. otherwise !! o iscntrl returns .true. if character is a delete character or !! ordinary control character !! o isdigit returns .true. if character is a digit (0,1,...,9) !! and .false. otherwise !! o isgraph returns .true. if character is a printable character !! except a space is considered non-printable !! o islower returns .true. if character is a miniscule letter (a-z) !! o isprint returns .true. if character is an ASCII printable !! character !! o ispunct returns .true. if character is a printable punctuation !! character !! o isspace returns .true. if character is a null, space, tab, !! carriage return, new line, vertical tab, or formfeed !! o isupper returns .true. if character is an uppercase letter (A-Z) !! o isascii returns .true. if the character is in the range char(0) !! to char(127) !! o isblank returns .true. if character is a blank character !! (space or horizontal tab. !! o isxdigit returns .true. if character is a hexadecimal digit !! (0-9, a-f, or A-F). !! !! fortran_name returns .true. if input string is a valid Fortran name !! !! BASE CONVERSION !! !! base convert whole number string in base [2-36] to string !! in alternate base [2-36] !! base2 convert INTEGER to a string representing a binary value !! codebase convert whole number string in base [2-36] to base !! 10 number !! decodebase convert whole number in base 10 to string in base [2-36] !! !! MISCELLANEOUS !! !! bundle return up to twenty strings of arbitrary length as !! an array !! describe returns a string describing the name of a single !! character !! edit_distance returns a naive edit distance using the Levenshtein !! distance algorithm !! longest_common_substring function that returns the longest common !! substring of two strings. !! !! INTRINSICS !! !! The M_strings(3fm) module supplements and works in combination with !! the Fortran built-in intrinsics. Stand-alone Fortran lets you access !! the characters in a string using ranges much like they are character !! arrays, assignment, comparisons with standard operators, supports !! dynamically allocatable strings and supports concatenation using the // !! operator, as well as a number of intrinsic string routines: !! !! adjustl Left adjust a string !! adjustr Right adjust a string !! index Position of a substring within a string !! repeat Repeated string concatenation !! scan Scan a string for the presence of a set !! of characters !! trim Remove trailing blank characters of a string !! verify Scan a string for the absence of a set of !! characters !! len It returns the length of a character string !! achar converts an integer into a character !! iachar converts a character into an integer !! len_trim finds length of string with trailing spaces !! ignored !! new_line Newline character !! selected_char_kind Choose character kind !! lge Lexical greater than or equal !! lgt Lexical greater than !! lle Lexical less than or equal !! llt Lexical less than !! !! OOPS INTERFACE !! !! The M_strings__oop(3fm) module (included with the M_strings(3fm) !! module) provides an OOP (Object-Oriented Programming) interface to !! the M_strings(3fm) module. !! !!##SEE ALSO !! There are additional routines in other GPF modules for working with !! expressions (M_calculator), time strings (M_time), random strings !! (M_random, M_uuid), lists (M_list), and interfacing with the C regular !! expression library (M_regex). !! !!##EXAMPLES !! !! Each of the procedures includes an [example](example/) program in !! the corresponding man(1) page for the function. !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== MODULE M_strings ! use, intrinsic :: iso_fortran_env, only : ERROR_UNIT ! access computing environment use, intrinsic :: iso_fortran_env, only : output_unit, stderr=>error_unit use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 implicit none ! ident_1="@(#) M_strings(3f) Fortran module containing routines that deal with character strings" !----------------------------------------------------------------------------------------------------------------------------------- private !----------------------# TOKENS public split ! subroutine parses a string using specified delimiter characters and store tokens into an allocatable array public sep ! function interface to split public chomp ! function consumes input line as it returns next token in a string using specified delimiters public delim ! subroutine parses a string using specified delimiter characters and store tokens into an array public strtok ! gets next token. Used by change(3f) public paragraph ! convert a long string into a paragraph !----------------------# EDITING public substitute ! subroutine non-recursively globally replaces old substring with new substring in string public replace ! function non-recursively globally replaces old substring with new substring in string public change ! replaces old substring with new substring in string with a directive like a line editor public modif ! change string using a directive using rules similar to XEDIT line editor MODIFY command public transliterate ! when characters in set one are found replace them with characters from set two public reverse ! elemental function reverses character order in a string public join ! append an array of character variables with specified separator into a single CHARACTER variable public squeeze ! delete adjacent duplicate characters from a string public rotate13 ! apply trivial encryption algorithm ROT13 to string public percent_encode ! percent-encode characters or a string interface percent_encode; module procedure percent_encode_string, percent_encode_characters; end interface !----------------------# CHARACTER ARRAY VERSUS STRING public switch ! generic switch between a string and an array of single characters (a2s,s2a) private a2s ! function to copy char array to string private s2a ! function to copy string(1:Clen(string)) to char array public s2c ! convert character variable to array of character(len=1) with null terminator for C compatibility public c2s ! convert null-terminated array of character(len=1) to string for strings returned by C !----------------------# CASE public upper ! elemental function converts string to uppercase interface upper; module procedure upper_all, upper_range; end interface public lower ! elemental function converts string to miniscule public upper_quoted ! elemental function converts string to uppercase skipping strings quoted per Fortran syntax rules !----------------------# WHITE SPACE public adjustc ! elemental function centers string within the length of the input string public compact ! left justify string and replace duplicate whitespace with single characters or nothing public nospace ! function replaces whitespace with nothing public indent ! count number of leading spaces public crop ! function trims leading and trailing spaces and control characters public clip ! function trims leading and trailing spaces !----------------------# QUOTES public matching_delimiter ! find position of matching delimiter public unquote ! remove quotes from string as if read with list-directed input public quote ! add quotes to string as if written with list-directed input !----------------------# STRING LENGTH public lenset ! return a string as specified length public pad ! return a string of at least specified length public zpad ! return a string of at least specified length padded on left with zeros interface zpad; module procedure zpad_scalar, zpad_vector; end interface public lpad ! convert value to a string of at least specified length padded on left with zeros interface lpad; module procedure lpad_scalar, lpad_vector; end interface public cpad ! convert value to a centered string of at least specified length interface cpad; module procedure cpad_scalar, cpad_vector; end interface public rpad ! convert value to a string of at least specified length padded on right with zeros interface rpad; module procedure rpad_scalar, rpad_vector; end interface public stretch ! return a string of at least specified length with suffix public merge_str ! make strings of equal length and then call MERGE(3f) intrinsic public len_white ! find location of last non-whitespace character !----------------------# NONALPHA public noesc ! elemental function converts non-printable ASCII8 characters to a space public notabs ! convert tabs to spaces in output while maintaining columns, assuming a tab is set every 8 characters public dilate ! convert tabs to spaces in output while maintaining columns, assuming a tab is set every 8 characters public expand ! expand escape sequences in a string public visible ! expand escape sequences in a string to control and meta-control representations !----------------------# NUMERIC STRINGS public string_to_value ! generic subroutine returns REAL|DOUBLEPRECISION|INTEGER value from string (a2d,a2r,a2i) private a2d ! subroutine returns double value from string private a2r ! subroutine returns real value from string private a2i ! subroutine returns integer value from string public string_to_values! subroutine returns values from a string public getvals ! subroutine returns values from a string public s2v ! function returns doubleprecision value from string public s2vs ! function returns a doubleprecision array of numbers from a string ! NOT USING INTERNAL READ FOR CONVERSION public atoi ! function returns an INTEGER(kind=int32) value from a string public atol ! function returns an INTEGER(kind=int64) value from a string public aton ! function returns true or false as to whether string converts to numeric value, and numeric value !------------------------------------------------------------------------------------------------------------ public msg ! function returns a string representing up to nine scalar intrinsic values public value_to_string ! generic subroutine returns string given numeric REAL|DOUBLEPRECISION|INTEGER|LOGICAL value public v2s ! generic function returns string given numeric REAL|DOUBLEPRECISION|INTEGER|LOGICAL value private d2s ! function returns string from doubleprecision value private r2s ! function returns string from real value private i2s ! function returns string from integer value private l2s ! function returns string from logical value public isnumber ! determine if string represents a number private trimzeros_ ! Delete trailing zeros from numeric decimal string public listout ! expand a list of numbers where negative numbers denote range ends (1 -10 means 1 thru 10) !----------------------------------------------------------------------------------------------------------------------------------- ! ! extend intrinsics to accept CHARACTER values ! public int, real, dble, nint interface int; module procedure atoi; end interface interface real; module procedure real_s2v; end interface interface dble; module procedure dble_s2v; end interface interface nint; module procedure nint_s2v; end interface interface aton module procedure ator_real32 module procedure ator_real64 module procedure atoi_int8 module procedure atoi_int16 module procedure atoi_int32 module procedure atoi_int64 end interface !----------------------------------------------------------------------------------------------------------------------------------- !----------------------# BIT ROUTINES public setbits8 ! use a string representing a positive binary value to fill the bits of an INTEGER value public setbits16 ! use a string representing a positive binary value to fill the bits of an INTEGER value public setbits32 ! use a string representing a positive binary value to fill the bits of an INTEGER value public setbits64 ! use a string representing a positive binary value to fill the bits of an INTEGER value !----------------------# BASE CONVERSION public base ! convert whole number string in base [2-36] to string in alternate base [2-36] public codebase ! convert whole number string in base [2-36] to base 10 number public decodebase ! convert whole number in base 10 to string in base [2-36] public base2 ! convert INTEGER to a string representing a binary value !----------------------# LOGICAL TESTS public glob ! compares given string for match to pattern which may contain wildcard characters public ends_with ! test whether strings ends with one of the specified suffix public isalnum ! elemental function returns .true. if CHR is a letter or digit public isalpha ! elemental function returns .true. if CHR is a letter and .false. otherwise public isascii ! elemental function returns .true. if the low order byte of c is in the range char(0) to char(127) public isblank ! elemental function returns .true. if CHR is a blank character (space or horizontal tab. public iscntrl ! elemental function returns .true. if CHR is a delete character or ordinary control character public isdigit ! elemental function returns .true. if CHR is a digit (0,1,...,9) and .false. otherwise public isgraph ! elemental function true if CHR is an ASCII printable character except considers a space non-printable public islower ! elemental function returns .true. if CHR is a miniscule letter (a-z) public isprint ! elemental function determines if CHR is an ASCII printable character public ispunct ! elemental function returns .true. if CHR is a printable punctuation character public isspace ! elemental function true if CHR is a null, space, tab, carriage return, new line, vertical tab, or formfeed public isupper ! elemental function returns .true. if CHR is an uppercase letter (A-Z) public isxdigit ! elemental function returns .true. if CHR is a hexadecimal digit (0-9, a-f, or A-F). !----------------------# !-------------------------------# public fortran_name ! elemental function returns .true. if LINE is a valid Fortran name public describe ! returns a string describing character public edit_distance ! returns a naive edit distance using the Levenshtein distance algorithm public bundle ! return up to twenty strings of arbitrary length as an array public longest_common_substring ! function that returns the longest common substring of two strings. !-------------------------------# !----------------------------------------------------------------------------------------------------------------------------------- ! ident_2="@(#) M_strings switch(3f) toggle between string and array of characters; generic{a2s s2a}" interface switch module procedure a2s, s2a end interface switch ! note how returned result is "created" by the function !----------------------------------------------------------------------------------------------------------------------------------- ! ident_3="@(#) M_strings string_to_value(3f) Generic subroutine converts numeric string to a number (a2d a2r a2i)" interface string_to_value module procedure a2d, a2r, a2i end interface !----------------------------------------------------------------------------------------------------------------------------------- ! ident_4="@(#) M_strings v2s(3f) Generic function returns string given REAL|INTEGER|DOUBLEPRECISION value(d2s r2s i2s)" interface v2s module procedure d2s, r2s, i2s, l2s end interface !----------------------------------------------------------------------------------------------------------------------------------- !-!interface setbits ! boz !-! module procedure setbits8, setbits16, setbits32, setbits64 !-!end interface !----------------------------------------------------------------------------------------------------------------------------------- ! ident_5="@(#) M_strings msg(3f) convert up to nine scalar values to a string. Alternatively can also handle one-dimensional arrays" interface msg module procedure msg_scalar, msg_one end interface msg !----------------------------------------------------------------------------------------------------------------------------------- ! ASCII character constants character, public, parameter :: ascii_nul = char(0) ! null character, public, parameter :: ascii_bel = char(7) ! bell character, public, parameter :: ascii_bs = char(8) ! backspace character, public, parameter :: ascii_ht = char(9) ! horizontal tab character, public, parameter :: ascii_lf = char(10) ! line feed or newline character, public, parameter :: ascii_ff = char(12) ! form feed or newpage character, public, parameter :: ascii_cr = char(13) ! carriage return character, public, parameter :: ascii_esc = char(27) ! escape !----------------------------------------------------------------------------------------------------------------------------------- interface ends_with procedure :: ends_with_str procedure :: ends_with_any end interface ends_with !----------------------------------------------------------------------------------------------------------------------------------- public :: split2020, string_tokens public :: find_field interface split2020 module procedure :: split_tokens, split_first_last, split_pos end interface split2020 !----------------------------------------------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------------------------------------------- !This contains a conditionally built mini-version of M_journal which allows the M_strings.f90 module !to be built using make as a stand-alone distribution but still have make.shell built a true version ! !This is so when built with make.shell(1) or fpm(1) it will use the !real M_journal.f90 file but that fpm(1) will not auto-discover the mini !M_journal.f90 file and built it and cause duplicates. interface journal module procedure flush_trail ! journal() ! no options module procedure write_message_only ! journal(c) ! must have one string module procedure where_write_message_all ! journal(where,[g1-g9]) ! must have two strings end interface journal interface str module procedure str_scalar, str_one end interface str !$@(#) M_journal::journal(3fg): provides public message routine, no paging or graphic mode change ! global variables integer,save,private :: stdout=OUTPUT_UNIT logical,save :: debug=.false. integer,save :: last_int=0 !----------------------------------------------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------------------------------------------- ! for compatibility allow old name for renamed procedures interface matchw; module procedure glob; end interface interface atleast; module procedure pad; end interface interface cc; module procedure bundle; end interface public matchw ! clone of glob -- for backward compatibiity public atleast ! clone of pad -- for backward compatibiity public cc ! clone of pad -- for backward compatibiity !----------------------------------------------------------------------------------------------------------------------------------- CONTAINS !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! glob(3f) - [M_strings:COMPARE] compare given string for match to !! a pattern which may contain globbing wildcard characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function glob(string, pattern ) !! !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: pattern !! !!##DESCRIPTION !! glob(3f) compares given (entire) STRING for a match to PATTERN which may !! contain basic wildcard "globbing" characters. !! !! In this version to get a match the entire string must be described !! by PATTERN. Trailing whitespace is significant, so trim the input !! string to have trailing whitespace ignored. !! !! Patterns like "b*ba" fail on a string like "babababa" because the !! algorithm finds an early match. To skip over the early matches insert !! an extra character at the end of the string and pattern that does !! not occur in the pattern. Typically a NULL is used (char(0)). !! !!##OPTIONS !! string the input string to test to see if it contains the pattern. !! pattern the following simple globbing options are available !! !! o "?" matching any one character !! o "*" matching zero or more characters. !! Do NOT use adjacent asterisks. !! o spaces are significant and must be matched or pretrimmed !! o There is no escape character, so matching strings with !! literal question mark and asterisk is problematic. !! !!##EXAMPLES !! !! Example program !! !! program demo_glob !! implicit none !! ! This main() routine passes a bunch of test strings !! ! into the above code. In performance comparison mode, !! ! it does that over and over. Otherwise, it does it just !! ! once. Either way, it outputs a passed/failed result. !! ! !! integer :: nReps !! logical :: allpassed !! integer :: i !! allpassed = .true. !! !! nReps = 10000 !! ! Can choose as many repetitions as you're expecting !! ! in the real world. !! nReps = 1 !! !! do i=1,nReps !! ! Cases with repeating character sequences. !! allpassed= test("a*abab", "a*b", .true.) .and. allpassed !! allpassed= test("ab", "*?", .true.) .and. allpassed !! allpassed= test("abc", "*?", .true.) .and. allpassed !! allpassed= test("abcccd", "*ccd", .true.) .and. allpassed !! allpassed= test("bLah", "bLaH", .false.) .and. allpassed !! allpassed= test("mississippi", "*sip*", .true.) .and. allpassed !! allpassed= & !! & test("xxxx*zzzzzzzzy*f", "xxx*zzy*f", .true.) .and. allpassed !! allpassed= & !! & test("xxxx*zzzzzzzzy*f", "xxxx*zzy*fffff", .false.) .and. allpassed !! allpassed= & !! & test("mississipissippi", "*issip*ss*", .true.) .and. allpassed !! allpassed= & !! & test("xxxxzzzzzzzzyf", "xxxx*zzy*fffff", .false.) .and. allpassed !! allpassed= & !! & test("xxxxzzzzzzzzyf", "xxxx*zzy*f", .true.) .and. allpassed !! allpassed= test("xyxyxyzyxyz", "xy*z*xyz", .true.) .and. allpassed !! allpassed= test("xyxyxyxyz", "xy*xyz", .true.) .and. allpassed !! allpassed= test("mississippi", "mi*sip*", .true.) .and. allpassed !! allpassed= test("ababac", "*abac*", .true.) .and. allpassed !! allpassed= test("aaazz", "a*zz*", .true.) .and. allpassed !! allpassed= test("a12b12", "*12*23", .false.) .and. allpassed !! allpassed= test("a12b12", "a12b", .false.) .and. allpassed !! allpassed= test("a12b12", "*12*12*", .true.) .and. allpassed !! !! ! Additional cases where the '*' char appears in the tame string. !! allpassed= test("*", "*", .true.) .and. allpassed !! allpassed= test("a*r", "a*", .true.) .and. allpassed !! allpassed= test("a*ar", "a*aar", .false.) .and. allpassed !! !! ! More double wildcard scenarios. !! allpassed= test("XYXYXYZYXYz", "XY*Z*XYz", .true.) .and. allpassed !! allpassed= test("missisSIPpi", "*SIP*", .true.) .and. allpassed !! allpassed= test("mississipPI", "*issip*PI", .true.) .and. allpassed !! allpassed= test("xyxyxyxyz", "xy*xyz", .true.) .and. allpassed !! allpassed= test("miSsissippi", "mi*sip*", .true.) .and. allpassed !! allpassed= test("miSsissippi", "mi*Sip*", .false.) .and. allpassed !! allpassed= test("abAbac", "*Abac*", .true.) .and. allpassed !! allpassed= test("aAazz", "a*zz*", .true.) .and. allpassed !! allpassed= test("A12b12", "*12*23", .false.) .and. allpassed !! allpassed= test("a12B12", "*12*12*", .true.) .and. allpassed !! allpassed= test("oWn", "*oWn*", .true.) .and. allpassed !! !! ! Completely tame (no wildcards) cases. !! allpassed= test("bLah", "bLah", .true.) .and. allpassed !! !! ! Simple mixed wildcard tests suggested by IBMer Marlin Deckert. !! allpassed= test("a", "*?", .true.) .and. allpassed !! !! ! More mixed wildcard tests including coverage for false positives. !! allpassed= test("a", "??", .false.) .and. allpassed !! allpassed= test("ab", "?*?", .true.) .and. allpassed !! allpassed= test("ab", "*?*?*", .true.) .and. allpassed !! allpassed= test("abc", "?**?*?", .true.) .and. allpassed !! allpassed= test("abc", "?**?*&?", .false.) .and. allpassed !! allpassed= test("abcd", "?b*??", .true.) .and. allpassed !! allpassed= test("abcd", "?a*??", .false.) .and. allpassed !! allpassed= test("abcd", "?**?c?", .true.) .and. allpassed !! allpassed= test("abcd", "?**?d?", .false.) .and. allpassed !! allpassed= test("abcde", "?*b*?*d*?", .true.) .and. allpassed !! !! ! Single-character-match cases. !! allpassed= test("bLah", "bL?h", .true.) .and. allpassed !! allpassed= test("bLaaa", "bLa?", .false.) .and. allpassed !! allpassed= test("bLah", "bLa?", .true.) .and. allpassed !! allpassed= test("bLaH", "?Lah", .false.) .and. allpassed !! allpassed= test("bLaH", "?LaH", .true.) .and. allpassed !! !! allpassed= test('abcdefghijk' , '?b*', .true.) .and. allpassed !! allpassed= test('abcdefghijk' , '*c*', .true.) .and. allpassed !! allpassed= test('abcdefghijk' , '*c', .false.) .and. allpassed !! allpassed= test('abcdefghijk' , '*c*k', .true.) .and. allpassed !! allpassed= test('LS' , '?OW', .false.) .and. allpassed !! allpassed= test('teztit' , 'tez*t*t', .true.) .and. allpassed !! ! Two pattern match problems that might pose difficulties !! allpassed= test('e ' , '*e* ', .true.) .and. allpassed !! allpassed= test('abcde ' , '*e *', .true.) .and. allpassed !! allpassed= test('bababa' , 'b*ba', .true.) .and. allpassed !! allpassed= test('baaaaax' , 'b*ax', .true.) .and. allpassed !! allpassed= test('baaaaa' , 'b*ax', .false.) .and. allpassed !! allpassed= test('baaaaax' , 'b*a', .false.) .and. allpassed !! allpassed= test('' , 'b*', .false.) .and. allpassed !! allpassed= test('' , '*', .true.) .and. allpassed !! allpassed= test('b' , '', .false.) .and. allpassed !! allpassed= test('3' , '??', .false.) .and. allpassed !! ! known flaws !! allpassed= test('' , '', .true.) .and. allpassed !! allpassed= test('baaaaa' , 'b*a', .true.) .and. allpassed !! ! add unused character to work around !! allpassed= test(''//char(0), ''//char(0), .true.).and.allpassed !! allpassed= test('baaaaa'//char(0),'b*a'//char(0),.true.).and.allpassed !! !! ! Many-wildcard scenarios. !! allpassed= test(& !! &"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa& !! &aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab",& !! &"a*a*a*a*a*a*aa*aaa*a*a*b",& !! &.true.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacacac& !! &adaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*a*aa*aaa*fa*ga*b*",& !! &.true.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacaca& !! &cadaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*a*x*aaa*fa*ga*b*",& !! &.false.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacacacad& !! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*aaaa*fa*ga*gggg*b*",& !! &.false.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacacacad& !! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*aaaa*fa*ga*ggg*b*",& !! &.true.) .and. allpassed !! allpassed= test("aaabbaabbaab","*aabbaa*a*",.true.).and.allpassed !! allpassed= & !! test("a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*",& !! &"a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) .and. allpassed !! allpassed= test("aaaaaaaaaaaaaaaaa",& !! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) .and. allpassed !! allpassed= test("aaaaaaaaaaaaaaaa",& !! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .false.) .and. allpassed !! allpassed= test(& !! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& !! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& !! & "abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc& !! &*abc*abc*abc*",& !! &.false.) .and. allpassed !! allpassed= test(& !! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& !! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& !! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*",& !! &.true.) .and. allpassed !! allpassed= test("abc*abcd*abcd*abc*abcd",& !! &"abc*abc*abc*abc*abc", .false.) .and. allpassed !! allpassed= test( "abc*abcd*abcd*abc*abcd*abcd& !! &*abc*abcd*abc*abc*abcd", & !! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abcd",& !! &.true.) .and. allpassed !! allpassed= test("abc",& !! &"********a********b********c********", .true.) .and. allpassed !! allpassed=& !! &test("********a********b********c********", "abc",.false.)& !! & .and.allpassed !! allpassed= & !! &test("abc", "********a********b********b********",.false.)& !! & .and.allpassed !! allpassed= test("*abc*", "***a*b*c***", .true.) .and. allpassed !! !! ! A case-insensitive algorithm test. !! ! allpassed=test("mississippi", "*issip*PI", .true.) .and. allpassed !! enddo !! !! if (allpassed)then !! write(*,'(*(g0,1x))')"Passed",nReps !! else !! write(*,'(a)')"Failed" !! endif !! contains !! ! This is a test program for wildcard matching routines. !! ! It can be used either to test a single routine for correctness, !! ! or to compare the timings of two (or more) different wildcard !! ! matching routines. !! ! !! function test(tame, wild, bExpectedResult) result(bPassed) !! use M_strings, only : glob !! character(len=*) :: tame !! character(len=*) :: wild !! logical :: bExpectedResult !! logical :: bResult !! logical :: bPassed !! bResult = .true. ! We'll do "&=" cumulative checking. !! bPassed = .false. ! Assume the worst. !! write(*,*)repeat('=',79) !! bResult = glob(tame, wild) ! Call a wildcard matching routine. !! !! ! To assist correctness checking, output the two strings in any !! ! failing scenarios. !! if (bExpectedResult .eqv. bResult) then !! bPassed = .true. !! if(nReps == 1) write(*,*)"Passed match on ",tame," vs. ", wild !! else !! if(nReps == 1) write(*,*)"Failed match on ",tame," vs. ", wild !! endif !! !! end function test !! end program demo_glob !! !! Expected output !! !!##AUTHOR !! John S. Urban !! !!##REFERENCE !! The article "Matching Wildcards: An Empirical Way to Tame an Algorithm" !! in Dr Dobb's Journal, By Kirk J. Krauss, October 07, 2014 !! !!##LICENSE !! Public Domain function glob(tame,wild) ! ident_6="@(#) M_strings glob(3f) function compares text strings one of which can have wildcards ('*' or '?')." logical :: glob character(len=*) :: tame ! A string without wildcards character(len=*) :: wild ! A (potentially) corresponding string with wildcards character(len=len(tame)+1) :: tametext character(len=len(wild)+1) :: wildtext character(len=1),parameter :: NULL=char(0) integer :: wlen integer :: ti, wi integer :: i character(len=:),allocatable :: tbookmark, wbookmark ! These two values are set when we observe a wildcard character. They ! represent the locations, in the two strings, from which we start once we have observed it. tametext=tame//NULL wildtext=wild//NULL tbookmark = NULL wbookmark = NULL wlen=len(wild) wi=1 ti=1 do ! Walk the text strings one character at a time. if(wildtext(wi:wi) == '*')then ! How do you match a unique text string? do i=wi,wlen ! Easy: unique up on it! if(wildtext(wi:wi) == '*')then wi=wi+1 else exit endif enddo if(wildtext(wi:wi) == NULL) then ! "x" matches "*" glob=.true. return endif if(wildtext(wi:wi) /= '?') then ! Fast-forward to next possible match. do while (tametext(ti:ti) /= wildtext(wi:wi)) ti=ti+1 if (tametext(ti:ti) == NULL)then glob=.false. return ! "x" doesn't match "*y*" endif enddo endif wbookmark = wildtext(wi:) tbookmark = tametext(ti:) elseif(tametext(ti:ti) /= wildtext(wi:wi) .and. wildtext(wi:wi) /= '?') then ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. if(wbookmark /= NULL) then if(wildtext(wi:) /= wbookmark) then wildtext = wbookmark wlen=len_trim(wbookmark) wi=1 ! Don't go this far back again. if (tametext(ti:ti) /= wildtext(wi:wi)) then tbookmark=tbookmark(2:) tametext = tbookmark ti=1 cycle ! "xy" matches "*y" else wi=wi+1 endif endif if (tametext(ti:ti) /= NULL) then ti=ti+1 cycle ! "mississippi" matches "*sip*" endif endif glob=.false. return ! "xy" doesn't match "x" endif ti=ti+1 wi=wi+1 if (ti > len(tametext)) then glob=.false. return elseif (tametext(ti:ti) == NULL) then ! How do you match a tame text string? if(wildtext(wi:wi) /= NULL)then do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! wi=wi+1 ! "x" matches "x*" if(wildtext(wi:wi) == NULL)exit enddo endif if (wildtext(wi:wi) == NULL)then glob=.true. return ! "x" matches "x" endif glob=.false. return ! "x" doesn't match "xy" endif enddo end function glob !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! ends_with(3f) - [M_strings:COMPARE] test if string ends with specified !! suffix(es) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function ends_with(source_string,suffix) !! !! or !! !! function ends_with(source_string,[suffix]) !! !! character(len=*),intent(in) :: source_string !! character(len=*),intent(in) :: suffix(..) !! logical :: ends_with !! !!##DESCRIPTION !! !!##OPTIONS !! SOURCE_STRING string to tokenize !! SUFFIX list of separator strings. May be scalar or an array. !! Trailing spaces are ignored. !! !!##RETURNS !! ENDS_WITH returns .TRUE. if one of the suffix match the end !! of SOURCE_STRING. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ends_with !! use M_strings, only : ends_with !! use, intrinsic :: iso_fortran_env, only : stdout=>output_unit !! implicit none !! write(stdout,*)ends_with('prog.a',['.o','.i','.s']) !! write(stdout,*)ends_with('prog.f90',['.F90','.f90','.f ','.F ']) !! write(stdout,*)ends_with('prog.pdf','.pdf') !! write(stdout,*)ends_with('prog.doc','.txt') !! end program demo_ends_with !! !! Results: !! !! F !! T !! T !! F !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function ends_with_str(string, ending) result(matched) character(*), intent(in) :: string, ending integer :: n1, n2 logical :: matched n1 = len(string) - len(ending) + 1 n2 = len(string) if (n1 < 1) then matched = .false. else matched = (string(n1:n2) == ending) endif end function ends_with_str !----------------------------------------------------------------------------------------------------------------------------------- pure function ends_with_any(string, endings) result(matched) character(*), intent(in) :: string character(*), intent(in) :: endings(:) logical :: matched integer :: i matched = .true. FINDIT: block do i=1, size(endings) if(ends_with_str(string,trim(endings(i)))) exit FINDIT enddo matched = .false. endblock FINDIT end function ends_with_any !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! sep(3f) - [M_strings:TOKENS] function to parse string into an array using !! specified delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function sep(input_line,delimiters,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: nulls !! character(len=:),allocatable :: sep(:) !! !!##DESCRIPTION !! sep(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! INPUT_LINE Input string to tokenize !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the "whitespace" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! NULLS=IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! ORDER='ASCENDING'|'DESCENDING' by default the tokens are returned from !! last to first; order='ASCENDING' returns !! them from first to last (left to right). !!##RETURNS !! SEP Output array of tokens !! !!##EXAMPLES !! !! Sample program: !! !! program demo_sep !! use M_strings, only: sep !! character(len=*),parameter :: fo='(/,a,*(/,"[",g0,"]":,","))' !! character(len=*),parameter :: line=& !! ' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! write(*,'(a)') 'INPUT LINE:['//LINE//']' !! write(*,fo) 'typical call:',sep(line) !! write(*,fo) 'delimiters ":|":',sep(line,':|') !! write(*,fo) 'count null fields ":|":',sep(line,':|','return') !! end program demo_sep !! !! Output !! !! INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! !! typical call: !! [cc ], !! [B ], !! [a ], !! [333|333 ], !! [1:|:2 ], !! [qrstuvwxyz], !! [ghijklmnop], !! [aBcdef ] !! !! delimiters ":|": !! [333 a B cc ], !! [2 333 ], !! [ aBcdef ghijklmnop qrstuvwxyz 1] !! !! count null fields ":|": !! [333 a B cc ], !! [2 333 ], !! [ ], !! [ ], !! [ aBcdef ghijklmnop qrstuvwxyz 1] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function sep(input_line,delimiters,nulls,order) !----------------------------------------------------------------------------------------------------------------------------------- ! ident_7="@(#) M_strings sep(3f) parse string on delimiter characters and store tokens into an allocatable array" ! John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- intrinsic index, min, present, len !----------------------------------------------------------------------------------------------------------------------------------- ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character(len=*),intent(in) :: input_line ! input string to tokenize character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character(len=*),optional,intent(in) :: order ! return strings composed of delimiters or not ignore|return|ignoreend character(len=:),allocatable :: sep(:) ! output array of tokens integer :: isize call split(input_line,sep,delimiters,'right',nulls) if(present(order))then select case(order) case('ascending','ASCENDING') isize=size(sep) if(isize > 1)then sep=sep(isize:1:-1) endif end select endif !----------------------------------------------------------------------------------------------------------------------------------- end function sep !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split(3f) - [M_strings:TOKENS] parse string into an array using !! specified delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine split(input_line,array,delimiters,order,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=:),allocatable,intent(out) :: array(:) !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: order !! character(len=*),optional,intent(in) :: nulls !! !!##DESCRIPTION !! SPLIT(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! INPUT_LINE Input string to tokenize !! !! ARRAY Output array of tokens !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the "whitespace" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. !! By default ARRAY contains the tokens having parsed !! the INPUT_LINE from left to right. If ORDER='RIGHT' !! or ORDER='REVERSE' the parsing goes from right to left. !! (This can be accomplished with array syntax in modern !! Fortran, but was more useful pre-fortran90). !! !! NULLS=IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_split !! use M_strings, only: split !! implicit none !! integer :: i !! character(len=*),parameter :: line=& !! ' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! character(len=:),allocatable :: array(:) ! output array of tokens !! write(*,*)'INPUT LINE:['//line//']' !! write(*,'(70("="))') !! write(*,*)'typical call:' !! call split(line,array) !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! write(*,'(70("-"))') !! write(*,*)'custom list of delimiters (colon and vertical line):' !! call split(line,array,delimiters=':|',& !! & order='sequential',nulls='ignore') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! write(*,'(70("-"))') !! write(*,*) 'custom list of delimiters, & !! &reverse array order and count null fields:' !! call split(line,array,delimiters=':|',& !! &order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! write(*,'(70("-"))') !! write(*,*)'INPUT LINE:['//line//']' !! write(*,*) 'default delimiters and reverse array order & !! &and return null fields:' !! call split(line,array,delimiters='',order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! end program demo_split !! !! Output !! !! >INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333| !! 333 a B cc ] !! >================================================================= !! > typical call: !! >1 ==> aBcdef !! >2 ==> ghijklmnop !! >3 ==> qrstuvwxyz !! >4 ==> 1:|:2 !! >5 ==> 333|333 !! >6 ==> a !! >7 ==> B !! >8 ==> cc !! > SIZE: 8 !! >---------------------------------------------------------------- !! > custom list of delimiters (colon and vertical line): !! >1 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! >2 ==> 2 333 !! >3 ==> 333 a B cc !! > SIZE: 3 !! >---------------------------------------------------------------- !! > custom list of delimiters, reverse array order and !! return null fields: !! >1 ==> 333 a B cc !! >2 ==> 2 333 !! >3 ==> !! >4 ==> !! >5 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > SIZE: 5 !! >---------------------------------------------------------------- !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333| !! 333 a B cc ] !! > default delimiters and reverse array order and count null fields: !! >1 ==> !! >2 ==> !! >3 ==> !! >4 ==> cc !! >5 ==> B !! >6 ==> a !! >7 ==> 333|333 !! >8 ==> !! >9 ==> !! >10 ==> !! >11 ==> !! >12 ==> 1:|:2 !! >13 ==> !! >14 ==> qrstuvwxyz !! >15 ==> ghijklmnop !! >16 ==> !! >17 ==> !! >18 ==> aBcdef !! >19 ==> !! >20 ==> !! > SIZE: 20 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine split(input_line,array,delimiters,order,nulls) !----------------------------------------------------------------------------------------------------------------------------------- ! ident_8="@(#) M_strings split(3f) parse string on delimiter characters and store tokens into an allocatable array" ! John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- intrinsic index, min, present, len !----------------------------------------------------------------------------------------------------------------------------------- ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character(len=*),intent(in) :: input_line ! input string to tokenize character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right] character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens !----------------------------------------------------------------------------------------------------------------------------------- integer :: n ! max number of strings INPUT_LINE could split into if all delimiter integer,allocatable :: ibegin(:) ! positions in input string where tokens start integer,allocatable :: iterm(:) ! positions in input string where tokens end character(len=:),allocatable :: dlim ! string containing delimiter characters character(len=:),allocatable :: ordr ! string containing order keyword character(len=:),allocatable :: nlls ! string containing nulls keyword integer :: ii,iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: lgth ! length of input string with trailing spaces trimmed integer :: i10,i20,i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data integer :: inotnull ! count strings not composed of delimiters integer :: ireturn ! number of tokens returned integer :: imax ! length of longest token !----------------------------------------------------------------------------------------------------------------------------------- ! decide on value for optional DELIMITERS parameter if (present(delimiters)) then ! optional delimiter list was present if(delimiters /= '')then ! if DELIMITERS was specified and not null use it dlim=delimiters else ! DELIMITERS was specified on call as empty string dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified endif else ! no delimiter value was specified dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified endif idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string !----------------------------------------------------------------------------------------------------------------------------------- if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter !----------------------------------------------------------------------------------------------------------------------------------- n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter if(allocated(ibegin))deallocate(ibegin) !x! intel compiler says allocated already ? if(allocated(iterm))deallocate(iterm) !x! intel compiler says allocated already ? allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens ibegin(:)=1 iterm(:)=1 !----------------------------------------------------------------------------------------------------------------------------------- lgth=len(input_line) ! lgth is the column position of the last non-blank character icount=0 ! how many tokens found inotnull=0 ! how many tokens found not composed of delimiters imax=0 ! length of longest token found !----------------------------------------------------------------------------------------------------------------------------------- if(lgth > 0)then ! there is at least one non-delimiter in INPUT_LINE if get here icol=1 ! initialize pointer into input line INFINITE: do i30=1,lgth,1 ! store into each array element ibegin(i30)=icol ! assume start new token on the character if(index(dlim(1:idlim),input_line(icol:icol)) == 0)then ! if current character is not a delimiter iterm(i30)=lgth ! initially assume no more tokens do i10=1,idlim ! search for next delimiter ifound=index(input_line(ibegin(i30):lgth),dlim(i10:i10)) IF(ifound > 0)then iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) endif enddo icol=iterm(i30)+2 ! next place to look as found end of this token inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters else ! character is a delimiter for a null string iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning icol=icol+1 ! advance pointer into input string endif imax=max(imax,iterm(i30)-ibegin(i30)+1) icount=i30 ! increment count of number of tokens found if(icol > lgth)then ! no text left exit INFINITE endif enddo INFINITE endif !----------------------------------------------------------------------------------------------------------------------------------- select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') ireturn=inotnull case default ireturn=icount end select allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to return !----------------------------------------------------------------------------------------------------------------------------------- select case (trim(adjustl(ordr))) ! decide which order to store tokens case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first case default ; ii=1 ; iiii=1 ! first to last end select !----------------------------------------------------------------------------------------------------------------------------------- do i20=1,icount ! fill the array with the tokens that were found if(iterm(i20) < ibegin(i20))then select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') case default array(ii)=' ' ii=ii+iiii end select else array(ii)=input_line(ibegin(i20):iterm(i20)) ii=ii+iiii endif enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine split !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! chomp(3f) - [M_strings:TOKENS] Tokenize a string, consuming it one !! token per call !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function chomp(source_string,token[,delimiters]) !! !! character(len=*) :: source_string !! character(len=:),intent(out) :: token !! character(len=:),intent(in),optional :: delimiters !! integer :: chomp !! !!##DESCRIPTION !! The CHOMP(3f) function is used to isolate sequential tokens in a !! string, SOURCE_STRING. These tokens are delimited in the string by at !! least one of the characters in DELIMITERS. This routine consumes the !! source_string one token per call. It returns -1 when complete. The !! default delimiter list is "space,tab,carriage return,newline". !! !!##OPTIONS !! SOURCE_STRING string to tokenize !! DELIMITERS list of separator characters !! !!##RETURNS !! TOKEN returned token !! CHOMP status flag. 0 = success, -1 = no tokens remain !! !!##EXAMPLES !! !! Sample program: !! !! program demo_chomp !! !! use M_strings, only : chomp !! implicit none !! character(len=100) :: inline !! character(len=:),allocatable :: token !! character(len=*),parameter :: delimiters=' ;,' !! integer :: ios !! integer :: icount !! integer :: itoken !! icount=0 !! do ! read lines from stdin until end-of-file or error !! read (unit=*,fmt="(a)",iostat=ios) inline !! if(ios /= 0)stop !! icount=icount+1 !! itoken=0 !! write(*,*)'INLINE ',trim(inline) !! do while ( chomp(inline,token,delimiters) >= 0) !! itoken=itoken+1 !! print *, itoken,'TOKEN=['//trim(token)//']' !! enddo !! enddo !! !! end program demo_chomp !! !! sample input file !! !! this is a test of chomp; A:B :;,C;; !! !! sample output file !! !! > INLINE this is a test of chomp; A:B :;,C;; !! > 1 TOKEN=[this] !! > 2 TOKEN=[is] !! > 3 TOKEN=[a] !! > 4 TOKEN=[test] !! > 5 TOKEN=[of] !! > 6 TOKEN=[chomp] !! > 7 TOKEN=[A:B] !! > 8 TOKEN=[:] !! > 9 TOKEN=[C] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain FUNCTION chomp(source_string,token,delimiters) ! ident_9="@(#) M_strings chomp(3f) Tokenize a string JSU- 20151030" character(len=*) :: source_string ! string to tokenize character(len=:),allocatable,intent(out) :: token ! returned token character(len=*),intent(in),optional :: delimiters ! list of separator characters integer :: chomp ! returns copy of shifted source_string character(len=:),allocatable :: delimiters_local integer :: token_start ! beginning of token found if function result is .true. integer :: token_end ! end of token found if function result is .true. integer :: isource_len !----------------------------------------------------------------------------------------------------------------------------------- ! calculate where token_start should start for this pass if(present(delimiters))then delimiters_local=delimiters else ! increment start to previous end + 1 delimiters_local=char(32)//char(09)//char(10)//char(13) ! space,horizontal tab, newline, carriage return endif !----------------------------------------------------------------------------------------------------------------------------------- isource_len=len(source_string) ! length of input string !----------------------------------------------------------------------------------------------------------------------------------- ! find beginning of token token_start=1 do while (token_start <= isource_len) ! step thru each character to find next delimiter, if any if(index(delimiters_local,source_string(token_start:token_start)) /= 0) then token_start = token_start + 1 else exit endif enddo !----------------------------------------------------------------------------------------------------------------------------------- token_end=token_start do while (token_end <= isource_len-1) ! step thru each character to find next delimiter, if any if(index(delimiters_local,source_string(token_end+1:token_end+1)) /= 0) then ! found a delimiter in next character exit endif token_end = token_end + 1 enddo !write(*,*)'TOKEN_START ',token_start !write(*,*)'TOKEN_END ',token_end chomp=isource_len-token_end if(chomp >= 0)then token=source_string(token_start:token_end) source_string=source_string(token_end+1:) else token='' source_string='' endif !----------------------------------------------------------------------------------------------------------------------------------- end function chomp !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! delim(3f) - [M_strings:TOKENS] parse a string and store tokens into !! an array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine delim(line,array,n,icount,ibegin,iterm,lgth,dlim) !! !! character(len=*),intent(in) :: line !! integer,integer(in) :: n !! integer,intent(out) :: icount !! character(len=*) :: array(n) !! integer,intent(out) :: ibegin(n) !! integer,intent(out) :: iterm(n) !! integer,intent(out) :: lgth !! character(len=*) :: dlim !! !!##DESCRIPTION !! Given a LINE of structure " par1 par2 par3 ... parn " !! store each par(n) into a separate variable in ARRAY (UNLESS !! ARRAY(1) == '#N#') !! !! Also set ICOUNT to number of elements of array initialized, and !! return beginning and ending positions for each element in IBEGIN(N) !! and ITERM(N). !! !! Return position of last non-blank character (even if more !! than N elements were found) in lgth !! !! No quoting or escaping of delimiter is allowed, so the delimiter !! character can not be placed in a token. !! !! No checking for more than N parameters; If any more they are ignored. !! !!##OPTIONS !! LINE input string to parse into tokens !! ARRAY(N) array that receives tokens !! N size of arrays ARRAY, IBEGIN, ITERM !! ICOUNT number of tokens found !! IBEGIN(N) starting columns of tokens found !! ITERM(N) ending columns of tokens found !! LGTH position of last non-blank character in input string LINE !! DLIM delimiter characters !! !!##EXAMPLES !! !! Sample program: !! !! program demo_delim !! !! use M_strings, only: delim !! implicit none !! character(len=80) :: line !! character(len=80) :: dlm !! integer,parameter :: n=10 !! character(len=20) :: array(n)=' ' !! integer :: ibegin(n),iterm(n) !! integer :: i20, icount, lgth, i10 !! line=' first second 10.3 words_of_stuff ' !! do i20=1,4 !! ! change delimiter list and what is calculated or parsed !! if(i20 == 1)dlm=' ' !! if(i20 == 2)dlm='o' !! if(i20 == 3)dlm=' aeiou' ! NOTE SPACE IS FIRST !! if(i20 == 3)ARRAY(1)='#N#' ! QUIT RETURNING STRING ARRAY !! if(i20 == 4)line='AAAaBBBBBBbIIIIIi J K L' !! !! ! write out a break line composed of =========== .. !! write(*,'(57("="))') !! ! show line being parsed !! write(*,'(a)')'PARSING=['//trim(line)//'] on '//trim(dlm) !! ! call parsing procedure !! call delim(line,array,n,icount,ibegin,iterm,lgth,dlm) !! write(*,*)'number of tokens found=',icount !! write(*,*)'last character in column ',lgth !! if(icount > 0)then !! if(lgth /= iterm(icount))then !! write(*,*)'ignored from column ',iterm(icount)+1,' to ',lgth !! endif !! do i10=1,icount !! ! check flag to see if ARRAY() was set !! if(array(1) /= '#N#')then !! ! from returned array !! write(*,'(a,a,a)',advance='no')& !! &'[',array(i10)(:iterm(i10)-ibegin(i10)+1),']' !! endif !! enddo !! ! using start and end positions in IBEGIN() and ITERM() !! write(*,*) !! do i10=1,icount !! ! from positions in original line !! write(*,'(a,a,a)',advance='no')& !! &'[',line(ibegin(i10):iterm(i10)),']' !! enddo !! write(*,*) !! endif !! enddo !! end program demo_delim !! !! Results: !! !! ========================================================= !! PARSING=[ first second 10.3 words_of_stuff] on !! number of tokens found= 4 !! last character in column 34 !! [first][second][10.3][words_of_stuff] !! [first][second][10.3][words_of_stuff] !! ========================================================= !! PARSING=[ first second 10.3 words_of_stuff] on o !! number of tokens found= 4 !! last character in column 34 !! [ first sec][nd 10.3 w][rds_][f_stuff] !! [ first sec][nd 10.3 w][rds_][f_stuff] !! ========================================================= !! PARSING=[ first second 10.3 words_of_stuff] on aeiou !! number of tokens found= 10 !! last character in column 34 !! !! [f][rst][s][c][nd][10.3][w][rds_][f_st][ff] !! ========================================================= !! PARSING=[AAAaBBBBBBbIIIIIi J K L] on aeiou !! number of tokens found= 5 !! last character in column 24 !! !! [AAA][BBBBBBbIIIII][J][K][L] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine delim(line,array,n,icount,ibegin,iterm,lgth,dlim) ! ident_10="@(#) M_strings delim(3f) parse a string and store tokens into an array" ! ! given a line of structure " par1 par2 par3 ... parn " ! store each par(n) into a separate variable in array. ! ! IF ARRAY(1) == '#N#' do not store into string array (KLUDGE)) ! ! also count number of elements of array initialized, and ! return beginning and ending positions for each element. ! also return position of last non-blank character (even if more ! than n elements were found). ! ! no quoting of delimiter is allowed ! no checking for more than n parameters, if any more they are ignored ! character(len=*),intent(in) :: line integer,intent(in) :: n character(len=*) :: array(n) integer,intent(out) :: icount integer,intent(out) :: ibegin(n) integer,intent(out) :: iterm(n) integer,intent(out) :: lgth character(len=*),intent(in) :: dlim !----------------------------------------------------------------------------------------------------------------------------------- character(len=len(line)):: line_local logical :: lstore integer :: i10 integer :: iarray integer :: icol integer :: idlim integer :: iend integer :: ifound integer :: istart !----------------------------------------------------------------------------------------------------------------------------------- icount=0 lgth=len_trim(line) line_local=line idlim=len(dlim) if(idlim > 5)then idlim=len_trim(dlim) ! dlim a lot of blanks on some machines if dlim is a big string if(idlim == 0)then idlim=1 ! blank string endif endif if(lgth == 0)then ! command was totally blank return endif ! ! there is at least one non-blank character in the command ! lgth is the column position of the last non-blank character ! find next non-delimiter icol=1 if(array(1) == '#N#')then ! special flag to not store into character array lstore=.false. else lstore=.true. endif do iarray=1,n,1 ! store into each array element until done or too many words NOINCREMENT: do if(index(dlim(1:idlim),line_local(icol:icol)) == 0)then ! if current character is not a delimiter istart=icol ! start new token on the non-delimiter character ibegin(iarray)=icol iend=lgth-istart+1+1 ! assume no delimiters so put past end of line do i10=1,idlim ifound=index(line_local(istart:lgth),dlim(i10:i10)) if(ifound > 0)then iend=min(iend,ifound) endif enddo if(iend <= 0)then ! no remaining delimiters iterm(iarray)=lgth if(lstore)then array(iarray)=line_local(istart:lgth) endif icount=iarray return else iend=iend+istart-2 iterm(iarray)=iend if(lstore)then array(iarray)=line_local(istart:iend) endif endif icol=iend+2 exit NOINCREMENT endif icol=icol+1 enddo NOINCREMENT ! last character in line was a delimiter, so no text left ! (should not happen where blank=delimiter) if(icol > lgth)then icount=iarray if( (iterm(icount)-ibegin(icount)) < 0)then ! last token was all delimiters icount=icount-1 endif return endif enddo icount=n ! more than n elements end subroutine delim !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! replace(3f) - [M_strings:EDITING] function replaces one !! substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! syntax: !! !! function replace(targetline,old,new,cmd,& !! & occurrence, & !! & repeat, & !! & ignorecase, & !! & ierr) result (newline) !! character(len=*) :: targetline !! character(len=*),intent(in),optional :: old !! character(len=*),intent(in),optional :: new !! character(len=*),intent(in),optional :: cmd !! integer,intent(in),optional :: occurrence !! integer,intent(in),optional :: repeat !! logical,intent(in),optional :: ignorecase !! integer,intent(out),optional :: ierr !! character(len=:),allocatable :: newline !! !!##DESCRIPTION !! Replace one substring for another in string. !! Either CMD or OLD and NEW must be specified. !! !!##OPTIONS !! targetline input line to be changed !! old old substring to replace !! new new substring !! cmd alternate way to specify old and new string, in !! the form c/old/new/; where "/" can be any character !! not in "old" or "new". !! occurrence if present, start changing at the Nth occurrence of the !! OLD string. If negative start replacing from the left !! end of the string. !! repeat number of replacements to perform. Defaults to a global !! replacement. !! ignorecase whether to ignore ASCII case or not. Defaults !! to .false. . !!##RETURNS !! newline allocatable string returned !! ierr error code. iF ier = -1 bad directive, >= 0 then !! count of changes made. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_replace !! use M_strings, only : replace !! implicit none !! character(len=:),allocatable :: line !! !! write(*,*)replace('Xis is Xe string','X','th') !! write(*,*)replace('Xis is xe string','x','th',ignorecase=.true.) !! write(*,*)replace('Xis is xe string','X','th',ignorecase=.false.) !! !! ! a null old substring means "at beginning of line" !! write(*,*) replace('my line of text','','BEFORE:') !! !! ! a null new string deletes occurrences of the old substring !! write(*,*) replace('I wonder i ii iii','i','') !! !! ! Examples of the use of RANGE !! !! line=replace('aaaaaaaaa','a','A',occurrence=1,repeat=1) !! write(*,*)'replace first a with A ['//line//']' !! !! line=replace('aaaaaaaaa','a','A',occurrence=3,repeat=3) !! write(*,*)'replace a with A for 3rd to 5th occurrence ['//line//']' !! !! line=replace('ababababa','a','',occurrence=3,repeat=3) !! write(*,*)'replace a with null instances 3 to 5 ['//line//']' !! !! line=replace( & !! & 'a b ab baaa aaaa aa aa a a a aa aaaaaa',& !! & 'aa','CCCC',occurrence=-1,repeat=1) !! write(*,*)'replace lastaa with CCCC ['//line//']' !! !! write(*,*)replace('myf90stuff.f90.f90','f90','for',occurrence=-1,repeat=1) !! write(*,*)replace('myf90stuff.f90.f90','f90','for',occurrence=-2,repeat=2) !! !! end program demo_replace !! !! Results: !! !! this is the string !! this is the string !! this is xe string !! BEFORE:my line of text !! I wonder !! replace first a with A [Aaaaaaaaa] !! replace a with A for 3rd to 5th occurrence [aaAAAaaaa] !! replace a with null instances 3 to 5 [ababbb] !! replace lastaa with CCCC [a b ab baaa aaaa aa aa a a a aa aaaaCCCC] !! myf90stuff.f90.for !! myforstuff.for.f90 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine crack_cmd(cmd,old,new,ierr) !----------------------------------------------------------------------------------------------------------------------------------- character(len=*),intent(in) :: cmd character(len=:),allocatable,intent(out) :: old,new ! scratch string buffers integer :: ierr !----------------------------------------------------------------------------------------------------------------------------------- character(len=1) :: delimiters integer :: itoken integer,parameter :: id=2 ! expected location of delimiter logical :: ifok integer :: lmax ! length of target string integer :: start_token,end_token !----------------------------------------------------------------------------------------------------------------------------------- ierr=0 old='' new='' lmax=len_trim(cmd) ! significant length of change directive if(lmax >= 4)then ! strtok ignores blank tokens so look for special case where first token is really null delimiters=cmd(id:id) ! find delimiter in expected location itoken=0 ! initialize strtok(3f) procedure if(strtok(cmd(id:),itoken,start_token,end_token,delimiters)) then ! find OLD string old=cmd(start_token+id-1:end_token+id-1) else old='' endif if(cmd(id:id) == cmd(id+1:id+1))then new=old old='' else ! normal case ifok=strtok(cmd(id:),itoken,start_token,end_token,delimiters) ! find NEW string if(end_token == (len(cmd)-id+1) )end_token=len_trim(cmd(id:)) ! if missing ending delimiter new=cmd(start_token+id-1:min(end_token+id-1,lmax)) endif else ! command was two or less characters ierr=-1 call journal('sc','*crack_cmd* incorrect change directive -too short') endif end subroutine crack_cmd !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function replace(targetline,old,new,cmd,occurrence,repeat,ignorecase,ierr) result (newline) ! ident_11="@(#) M_strings replace(3f) replace one substring for another in string" !----------------------------------------------------------------------------------------------------------------------------------- ! parameters character(len=*),intent(in) :: targetline ! input line to be changed character(len=*),intent(in),optional :: old ! old substring to replace character(len=*),intent(in),optional :: new ! new substring character(len=*),intent(in),optional :: cmd ! contains the instructions changing the string integer,intent(in),optional :: occurrence ! Nth occurrence of OLD string to start replacement at integer,intent(in),optional :: repeat ! how many replacements logical,intent(in),optional :: ignorecase integer,intent(out),optional :: ierr ! error code. if ierr = -1 bad directive, >=0 then ierr changes made !----------------------------------------------------------------------------------------------------------------------------------- ! returns character(len=:),allocatable :: newline ! output string buffer !----------------------------------------------------------------------------------------------------------------------------------- ! local character(len=:),allocatable :: new_local, old_local, old_local_for_comparison integer :: icount,ichange,ier2 integer :: original_input_length integer :: len_old, len_new integer :: ladd integer :: left_margin, right_margin integer :: ind integer :: ic integer :: ichr integer :: range_local(2) character(len=:),allocatable :: targetline_for_comparison ! input line to be changed logical :: ignorecase_local logical :: flip character(len=:),allocatable :: targetline_local ! input line to be changed !----------------------------------------------------------------------------------------------------------------------------------- flip=.false. ignorecase_local=.false. original_input_length=len_trim(targetline) ! get non-blank length of input line ! get old_local and new_local from cmd or old and new if(present(cmd))then call crack_cmd(cmd,old_local,new_local,ier2) if(ier2 /= 0)then newline=targetline ! if no changes are made return original string on error if(present(ierr))ierr=ier2 return endif elseif(present(old).and.present(new))then old_local=old new_local=new else newline=targetline ! if no changes are made return original string on error call journal('sc','*replace* must specify OLD and NEW or CMD') return endif if(present(ignorecase))then ignorecase_local=ignorecase else ignorecase_local=.false. endif if(present(occurrence))then range_local(1)=abs(occurrence) else range_local(1)=1 endif if(present(repeat))then range_local(2)=range_local(1)+repeat-1 else range_local(2)=original_input_length endif if(ignorecase_local)then targetline_for_comparison=lower(targetline) old_local_for_comparison=lower(old_local) else targetline_for_comparison=targetline old_local_for_comparison=old_local endif if(present(occurrence))then if(occurrence < 0)then flip=.true. targetline_for_comparison=reverse(targetline_for_comparison) targetline_local=reverse(targetline) old_local_for_comparison=reverse(old_local_for_comparison) old_local=reverse(old_local) new_local=reverse(new_local) else targetline_local=targetline endif else targetline_local=targetline endif !----------------------------------------------------------------------------------------------------------------------------------- icount=0 ! initialize error flag/change count ichange=0 ! initialize error flag/change count len_old=len(old_local) ! length of old substring to be replaced len_new=len(new_local) ! length of new substring to replace old substring left_margin=1 ! left_margin is left margin of window to change right_margin=len(targetline) ! right_margin is right margin of window to change newline='' ! begin with a blank line as output string !----------------------------------------------------------------------------------------------------------------------------------- if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin) ichr=len_new + original_input_length if(len_new > 0)then newline=new_local(:len_new)//targetline_local(left_margin:original_input_length) else newline=targetline_local(left_margin:original_input_length) endif ichange=1 ! made one change. actually, c/// should maybe return 0 if(present(ierr))ierr=ichange if(flip) newline=reverse(newline) return endif !----------------------------------------------------------------------------------------------------------------------------------- ichr=left_margin ! place to put characters into output string ic=left_margin ! place looking at in input string loop: do ! try finding start of OLD in remaining part of input in change window ind=index(targetline_for_comparison(ic:),old_local_for_comparison(:len_old))+ic-1 if(ind == ic-1.or.ind > right_margin)then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif icount=icount+1 ! found an old string to change, so increment count of change candidates if(ind > ic)then ! if found old string past at current position in input string copy unchanged ladd=ind-ic ! find length of character range to copy as-is from input to output newline=newline(:ichr-1)//targetline_local(ic:ind-1) ichr=ichr+ladd endif if(icount >= range_local(1).and.icount <= range_local(2))then ! check if this is an instance to change or keep ichange=ichange+1 if(len_new /= 0)then ! put in new string newline=newline(:ichr-1)//new_local(:len_new) ichr=ichr+len_new endif else if(len_old /= 0)then ! put in copy of old string newline=newline(:ichr-1)//old_local(:len_old) ichr=ichr+len_old endif endif ic=ind+len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case (ichange) case (0) ! there were no changes made to the window newline=targetline_local ! if no changes made output should be input case default if(ic <= len(targetline))then ! if there is more after last change on original line add it newline=newline(:ichr-1)//targetline_local(ic:max(ic,original_input_length)) endif end select if(present(ierr))ierr=ichange if(flip) newline=reverse(newline) !----------------------------------------------------------------------------------------------------------------------------------- end function replace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! substitute(3f) - [M_strings:EDITING] subroutine globally substitutes !! one substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine substitute(targetline,old,new,ierr,start,end) !! !! character(len=*) :: targetline !! character(len=*),intent(in) :: old !! character(len=*),intent(in) :: new !! integer,intent(out),optional :: ierr !! integer,intent(in),optional :: start !! integer,intent(in),optional :: end !! !!##DESCRIPTION !! Globally substitute one substring for another in string. !! !!##OPTIONS !! TARGETLINE input line to be changed. Must be long enough to !! hold altered output. !! OLD substring to find and replace !! NEW replacement for OLD substring !! IERR error code. If IER = -1 bad directive, >= 0 then !! count of changes made. !! START sets the left margin to be scanned for OLD in !! TARGETLINE. !! END sets the right margin to be scanned for OLD in !! TARGETLINE. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_substitute !! use M_strings, only : substitute !! implicit none !! ! must be long enough to hold changed line !! character(len=80) :: targetline !! !! targetline='this is the input string' !! write(*,*)'ORIGINAL : '//trim(targetline) !! !! ! changes the input to 'THis is THe input string' !! call substitute(targetline,'th','TH') !! write(*,*)'th => TH : '//trim(targetline) !! !! ! a null old substring means "at beginning of line" !! ! changes the input to 'BEFORE:this is the input string' !! call substitute(targetline,'','BEFORE:') !! write(*,*)'"" => BEFORE: '//trim(targetline) !! !! ! a null new string deletes occurrences of the old substring !! ! changes the input to 'ths s the nput strng' !! call substitute(targetline,'i','') !! write(*,*)'i => "" : '//trim(targetline) !! !! end program demo_substitute !! !! Expected output !! !! ORIGINAL : this is the input string !! th => TH : THis is THe input string !! "" => BEFORE: BEFORE:THis is THe input string !! i => "" : BEFORE:THs s THe nput strng !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine substitute(targetline,old,new,ierr,start,end) ! ident_12="@(#) M_strings substitute(3f) Globally substitute one substring for another in string" !----------------------------------------------------------------------------------------------------------------------------------- character(len=*) :: targetline ! input line to be changed character(len=*),intent(in) :: old ! old substring to replace character(len=*),intent(in) :: new ! new substring integer,intent(out),optional :: ierr ! error code. if ierr = -1 bad directive, >=0 then ierr changes made integer,intent(in),optional :: start ! start sets the left margin integer,intent(in),optional :: end ! end sets the right margin !----------------------------------------------------------------------------------------------------------------------------------- character(len=len(targetline)) :: dum1 ! scratch string buffers integer :: ml, mr, ier1 integer :: maxlengthout ! MAXIMUM LENGTH ALLOWED FOR NEW STRING integer :: original_input_length integer :: len_old, len_new integer :: ladd integer :: ir integer :: ind integer :: il integer :: id integer :: ic integer :: ichr !----------------------------------------------------------------------------------------------------------------------------------- if (present(start)) then ! optional starting column ml=start else ml=1 endif if (present(end)) then ! optional ending column mr=end else mr=len(targetline) endif !----------------------------------------------------------------------------------------------------------------------------------- ier1=0 ! initialize error flag/change count maxlengthout=len(targetline) ! max length of output string original_input_length=len_trim(targetline) ! get non-blank length of input line dum1(:)=' ' ! initialize string to build output in id=mr-ml ! check for window option ! change to optional parameter(s) !----------------------------------------------------------------------------------------------------------------------------------- len_old=len(old) ! length of old substring to be replaced len_new=len(new) ! length of new substring to replace old substring if(id <= 0)then ! no window so change entire input string il=1 ! il is left margin of window to change ir=maxlengthout ! ir is right margin of window to change dum1(:)=' ' ! begin with a blank line else ! if window is set il=ml ! use left margin ir=min0(mr,maxlengthout) ! use right margin or rightmost dum1=targetline(:il-1) ! begin with what's below margin endif ! end of window settings !----------------------------------------------------------------------------------------------------------------------------------- if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin) ichr=len_new + original_input_length if(ichr > maxlengthout)then call journal('sc','*substitute* new line will be too long') ier1=-1 if (present(ierr))ierr=ier1 return endif if(len_new > 0)then dum1(il:)=new(:len_new)//targetline(il:original_input_length) else dum1(il:)=targetline(il:original_input_length) endif targetline(1:maxlengthout)=dum1(:maxlengthout) ier1=1 ! made one change. actually, c/// should maybe return 0 if(present(ierr))ierr=ier1 return endif !----------------------------------------------------------------------------------------------------------------------------------- ichr=il ! place to put characters into output string ic=il ! place looking at in input string loop: do ind=index(targetline(ic:),old(:len_old))+ic-1 ! try to find start of old string in remaining part of input in change window if(ind == ic-1.or.ind > ir)then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif ier1=ier1+1 ! found an old string to change, so increment count of changes if(ind > ic)then ! if found old string past at current position in input string copy unchanged ladd=ind-ic ! find length of character range to copy as-is from input to output if(ichr-1+ladd > maxlengthout)then ier1=-1 exit loop endif dum1(ichr:)=targetline(ic:ind-1) ichr=ichr+ladd endif if(ichr-1+len_new > maxlengthout)then ier1=-2 exit loop endif if(len_new /= 0)then dum1(ichr:)=new(:len_new) ichr=ichr+len_new endif ic=ind+len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case (ier1) case (:-1) call journal('sc','*substitute* new line will be too long') case (0) ! there were no changes made to the window case default ladd=original_input_length-ic if(ichr+ladd > maxlengthout)then call journal('sc','*substitute* new line will be too long') ier1=-1 if(present(ierr))ierr=ier1 return endif if(ic < len(targetline))then dum1(ichr:)=targetline(ic:max(ic,original_input_length)) endif targetline=dum1(:maxlengthout) end select if(present(ierr))ierr=ier1 !----------------------------------------------------------------------------------------------------------------------------------- end subroutine substitute !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! change(3f) - [M_strings:EDITING] change old string to new string with !! a directive like a line editor !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine change(target_string,cmd,ierr) !! !! character(len=*),intent(inout) :: target_string !! character(len=*),intent(in) :: cmd !! integer :: ierr !! !!##DESCRIPTION !! change an old substring into a new substring in a character variable !! like a line editor. Primarily used to create interactive utilities !! such as input history editors for interactive line-mode programs. The !! output string is assumed long enough to accommodate the change. !! a directive resembles a line editor directive of the form !! !! C/old_string/new_string/ !! !! where / may be any character which is not included in old_string !! or new_string. !! !! a null old_string implies "beginning of string". !! !!##OPTIONS !! target_string line to be changed !! cmd contains instructions to change the string !! ierr error code. !! !! o =-1 bad directive !! o =0 no changes made !! o >0 count of changes made !! !!##EXAMPLES !! !! Sample program: !! !! program demo_change !! !! use M_strings, only : change !! implicit none !! character(len=132) :: line='This is a test string to change' !! integer :: ierr !! write(*,*)trim(line) !! ! change miniscule a to uppercase A !! call change(line,'c/a/A/',ierr) !! write(*,*)trim(line) !! ! put string at beginning of line !! call change(line,'c//prefix: /',ierr) !! write(*,*)trim(line) !! ! remove blanks !! call change(line,'c/ //',ierr) !! write(*,*)trim(line) !! end program demo_change !! !! Expected output !! !! This is a test string to change !! This is A test string to chAnge !! prefix: This is A test string to chAnge !! prefix:ThisisAteststringtochAnge !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine change(target_string,cmd,ierr) ! Change a string assumed long enough to accommodate the change, with a directive that resembles a line editor directive of the form ! C/old_string/new_string/ ! where / may be any character which is not included in old_string or new_string. ! a null old_string implies "beginning of string" !=================================================================================================================================== ! ident_13="@(#) M_strings change(3f) change a character string like a line editor" character(len=*),intent(inout) :: target_string ! line to be changed character(len=*),intent(in) :: cmd ! contains the instructions changing the string character(len=1) :: delimiters integer :: ierr ! error code. ier=-1 bad directive;=0 no changes made;>0 ier changes made integer :: itoken integer,parameter :: id=2 ! expected location of delimiter character(len=:),allocatable :: old,new ! scratch string buffers logical :: ifok integer :: lmax ! length of target string integer :: start_token,end_token !----------------------------------------------------------------------------------------------------------------------------------- lmax=len_trim(cmd) ! significant length of change directive if(lmax >= 4)then ! strtok ignores blank tokens so look for special case where first token is really null delimiters=cmd(id:id) ! find delimiter in expected location itoken=0 ! initialize strtok(3f) procedure if(strtok(cmd(id:),itoken,start_token,end_token,delimiters)) then ! find OLD string old=cmd(start_token+id-1:end_token+id-1) else old='' endif if(cmd(id:id) == cmd(id+1:id+1))then new=old old='' else ! normal case ifok=strtok(cmd(id:),itoken,start_token,end_token,delimiters) ! find NEW string if(end_token == (len(cmd)-id+1) )end_token=len_trim(cmd(id:)) ! if missing ending delimiter new=cmd(start_token+id-1:min(end_token+id-1,lmax)) endif call substitute(target_string,old,new,ierr,1,len_trim(target_string)) ! change old substrings to new substrings else ! command was two or less characters ierr=-1 call journal('sc','*change* incorrect change directive -too short') endif !----------------------------------------------------------------------------------------------------------------------------------- end subroutine change !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! strtok(3f) - [M_strings:TOKENS] Tokenize a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function strtok(source_string,itoken,token_start,token_end,delimiters) !! result(strtok_status) !! !! ! returned value !! logical :: strtok_status !! ! string to tokenize !! character(len=*),intent(in) :: source_string !! ! token count since started !! integer,intent(inout) :: itoken !! ! beginning of token !! integer,intent(out) :: token_start !! ! end of token !! integer,intent(inout) :: token_end !! ! list of separator characters !! character(len=*),intent(in) :: delimiters !! !!##DESCRIPTION !! The STRTOK(3f) function is used to isolate sequential tokens in a !! string, SOURCE_STRING. These tokens are delimited in the string by !! at least one of the characters in DELIMITERS. The first time that !! STRTOK(3f) is called, ITOKEN should be specified as zero. Subsequent !! calls, wishing to obtain further tokens from the same string, !! should pass back in TOKEN_END and ITOKEN until the function result !! returns .false. !! !! This routine assumes no other calls are made to it using any other !! input string while it is processing an input line. !! !!##OPTIONS !! source_string input string to parse !! itoken token count should be set to zero for a new string !! delimiters characters used to determine the end of tokens !! !!##RETURN !! token_start beginning position in SOURCE_STRING where token was found !! token_end ending position in SOURCE_STRING where token was found !! strtok_status !! !!##EXAMPLES !! !! Sample program: !! !! program demo_strtok !! use M_strings, only : strtok !! implicit none !! character(len=264) :: inline !! character(len=*),parameter :: delimiters=' ;,' !! integer :: ios, itoken, istart, iend !! do ! read lines from stdin until end-of-file or error !! read (unit=*,fmt="(a)",iostat=ios) inline !! if(ios /= 0)stop !! ! must set ITOKEN=0 before looping on strtok(3f) !! ! on a new string. !! itoken=0 !! do while & !! &( strtok(inline,itoken,istart,iend,delimiters) ) !! print *, itoken,& !! & 'TOKEN=['//(inline(istart:iend))//']',istart,iend !! enddo !! enddo !! end program demo_strtok !! !! sample input file !! !! this is a test of strtok; A:B :;,C;; !! !! sample output file !! !! 1 TOKEN=[this] 2 5 !! 2 TOKEN=[is] 7 8 !! 3 TOKEN=[a] 10 10 !! 4 TOKEN=[test] 12 15 !! 5 TOKEN=[of] 17 18 !! 6 TOKEN=[strtok] 20 25 !! 7 TOKEN=[A:B] 28 30 !! 8 TOKEN=[:] 32 32 !! 9 TOKEN=[C] 35 35 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain FUNCTION strtok(source_string,itoken,token_start,token_end,delimiters) result(strtok_status) ! JSU- 20151030 ! ident_14="@(#) M_strings strtok(3f) Tokenize a string" character(len=*),intent(in) :: source_string ! Source string to tokenize. character(len=*),intent(in) :: delimiters ! list of separator characters. May change between calls integer,intent(inout) :: itoken ! token count since started logical :: strtok_status ! returned value integer,intent(out) :: token_start ! beginning of token found if function result is .true. integer,intent(inout) :: token_end ! end of token found if function result is .true. integer,save :: isource_len !---------------------------------------------------------------------------------------------------------------------------- ! calculate where token_start should start for this pass if(itoken <= 0)then ! this is assumed to be the first call token_start=1 else ! increment start to previous end + 1 token_start=token_end+1 endif !---------------------------------------------------------------------------------------------------------------------------- isource_len=len(source_string) ! length of input string !---------------------------------------------------------------------------------------------------------------------------- if(token_start > isource_len)then ! user input error or at end of string token_end=isource_len ! assume end of token is end of string until proven otherwise so it is set strtok_status=.false. return endif !---------------------------------------------------------------------------------------------------------------------------- ! find beginning of token do while (token_start <= isource_len) ! step thru each character to find next delimiter, if any if(index(delimiters,source_string(token_start:token_start)) /= 0) then token_start = token_start + 1 else exit endif enddo !---------------------------------------------------------------------------------------------------------------------------- token_end=token_start do while (token_end <= isource_len-1) ! step thru each character to find next delimiter, if any if(index(delimiters,source_string(token_end+1:token_end+1)) /= 0) then ! found a delimiter in next character exit endif token_end = token_end + 1 enddo !---------------------------------------------------------------------------------------------------------------------------- if (token_start > isource_len) then ! determine if finished strtok_status=.false. ! flag that input string has been completely processed else itoken=itoken+1 ! increment count of tokens found strtok_status=.true. ! flag more tokens may remain endif !---------------------------------------------------------------------------------------------------------------------------- end function strtok !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! modif(3f) - [M_strings:EDITING] emulate the MODIFY command from the !! line editor XEDIT !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine modif(cline,cmod) !! !! character(len=*) :: cline ! input string to change !! ! directive provides directions on changing string !! character(len=*) :: cmod !! !!##DESCRIPTION !! MODIF(3f) Modifies the line currently pointed at using a directive !! that acts much like a line editor directive. !! Primarily used to create interactive utilities such as input history !! editors for interactive line-mode programs. !! !! the modify directives are as follows- !! !! DIRECTIVE EXPLANATION !! !! ^STRING# Causes the string of characters between the ^ and the !! next # to be inserted before the characters pointed to !! by the ^. an ^ or & within the string is treated as a !! regular character. If the closing # is not specified, !! MODIF(3f) inserts the remainder of the line as if a # was !! specified after the last nonblank character. !! !! There are two exceptions. the combination ^# causes a # !! to be inserted before the character pointed to by the !! ^, and an ^ as the last character of the directives !! causes a blank to be inserted. !! !! # (When not the first # after an ^) causes the character !! above it to be deleted. !! !! & Replaces the character above it with a space. !! !! (SPACE) A space below a character leaves it unchanged. !! !! Any other character replaces the character above it. !! !!##EXAMPLES !! !! Example input/output: !! !! THE INPUT LINE........ 10 THIS STRING TO BE MORTIFD !! THE DIRECTIVES LINE... ^ IS THE# D# ^IE !! ALTERED INPUT LINE.... 10 THIS IS THE STRING TO BE MODIFIED !! !! Sample program: !! !! program demo_modif !! use M_strings, only : modif !! implicit none !! character(len=256) :: line !! integer :: ios !! integer :: count !! integer :: COMMAND_LINE_LENGTH !! character(len=:),allocatable :: COMMAND_LINE !! ! get command name length !! call get_command_argument(0,length=count) !! ! get command line length !! call get_command(length=COMMAND_LINE_LENGTH) !! ! allocate string big enough to hold command line !! allocate(character(len=COMMAND_LINE_LENGTH+200) :: COMMAND_LINE) !! ! get command line as a string !! call get_command(command=COMMAND_LINE) !! ! trim leading spaces just in case !! COMMAND_LINE=adjustl(COMMAND_LINE) !! ! remove command name !! COMMAND_LINE=adjustl(COMMAND_LINE(COUNT+2:)) !! INFINITE: do !! read(*,'(a)',iostat=ios)line !! if(ios /= 0)exit !! call modif(line,COMMAND_LINE) !! write(*,'(a)')trim(line) !! enddo INFINITE !! end program demo_modif !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine modif(cline,mod) !$@(#) M_strings::modif(3f): Emulate the MODIFY command from the line editor XEDIT ! ! MODIF ! ===== ! ACTION- MODIFIES THE LINE CURRENTLY POINTED AT. THE INPUT STRING CLINE IS ASSUMED TO BE LONG ENOUGH TO ACCOMMODATE THE CHANGES ! THE MODIFY DIRECTIVES ARE AS FOLLOWS- ! ! DIRECTIVE EXPLANATION ! --------- ------------ ! ^STRING# CAUSES THE STRING OF CHARACTERS BETWEEN THE ^ AND THE ! NEXT # TO BE INSERTED BEFORE THE CHARACTERS POINTED TO ! BY THE ^. AN ^ OR & WITHIN THE STRING IS TREATED AS A ! REGULAR CHARACTER. IF THE CLOSING # IS NOT SPECIFIED, ! MODIF(3f) INSERTS THE REMAINDER OFTHELINE AS IF A # WAS ! SPECIFIED AFTER THE LAST NONBLANK CHARACTER. ! ! THERE ARE TWO EXCEPTIONS. THE COMBINATION ^# CAUSES A # ! TO BE INSERTED BEFORE THE CHARACTER POINTED TO BY THE ! ^, AND AN ^ AS THE LAST CHARACTER OF THE DIRECTIVES ! CAUSES A BLANK TO BE INSERTED. ! ! # (WHEN NOT THE FIRST # AFTER AN ^) CAUSES THE CHARACTER ! ABOVE IT TO BE DELETED. ! ! & REPLACES THE CHARACTER ABOVE IT WITH A SPACE. ! ! (SPACE) A SPACE BELOW A CHARACTER LEAVES IT UNCHANGED. ! ! ANY OTHER CHARACTER REPLACES THE CHARACTER ABOVE IT. ! ! EXAMPLE- ! THE INPUT LINE........ 10 THIS STRING TO BE MORTIFD ! THE DIRECTIVES LINE... ^ IS THE# D# ^IE ! ALTERED INPUT LINE.... 10 THIS IS THE STRING TO BE MODIFIED !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character(len=*) :: cline !STRING TO BE MODIFIED character(len=*),intent(in) :: mod !STRING TO DIRECT MODIFICATION character(len=len(cline)) :: cmod character(len=3),parameter :: c='#&^' !ASSIGN DEFAULT EDIT CHARACTERS integer :: maxscra !LENGTH OF SCRATCH BUFFER character(len=len(cline)) :: dum2 !SCRATCH CHARACTER BUFFER logical :: linsrt !FLAG FOR INSERTING DATA ON LINE integer :: i, j, ic, ichr, iend, lmax, lmx1 maxscra=len(cline) cmod=trim(mod) lmax=min0(len(cline),maxscra) !DETERMINE MAXIMUM LINE LENGTH lmx1=lmax-1 !MAX LINE LENGTH -1 dum2=' ' !INITIALIZE NEW LINE linsrt=.false. !INITIALIZE INSERT MODE iend=len_trim(cmod) !DETERMINE END OF MODS i=0 !CHAR COUNTER FOR MOD LINE CMOD ic=0 !CHAR COUNTER FOR CURRENT LINE CLINE ichr=0 !CHAR COUNTER NEW LINE DUM2 11 continue i=i+1 !NEXT CHAR IN MOD LINE if(ichr > lmx1)goto 999 !IF TOO MANY CHARS IN NEW LINE if(linsrt) then !IF INSERTING NEW CHARS if(i > iend) cmod(i:i)=c(1:1) !FORCE END OF INSERT MODE if(cmod(i:i) == c(1:1))then !IF END OF INSERT MODE linsrt=.false. !RESET INSERT MODE FLAG if(ic+1 == i)then !NULL INSERT STRING ichr=ichr+1 !INCREMENT COUNTER FOR NEW LINE dum2(ichr:ichr)=c(1:1) !INSERT INSERT MODE TERMINATOR endif do j=ic,i !LOOP OF NUMBER OF CHARS INSERTED ichr=ichr+1 !INCREMENT COUNTER FOR NEW LINE if(ichr > lmax)goto 999 !IF AT BUFFER LIMIT, QUIT dum2(ichr:ichr)=cline(j:j) !APPEND CHARS FROM ORIG LINE enddo !...WHICH ALIGN WITH INSERTED CHARS ic=i !RESET CHAR COUNT TO END OF INSERT goto 1 !CHECK NEW LINE LENGTH AND CYCLE endif !END OF TERMINATED INSERT LOGIC ichr=ichr+1 !INCREMENT NEW LINE COUNT dum2(ichr:ichr)=cmod(i:i) !SET NEWLINE CHAR TO INSERTED CHAR else !IF NOT INSERTING CHARACTERS ic=ic+1 !INCREMENT ORIGINAL LINE COUNTER if(cmod(i:i) == c(1:1))goto 1 !IF DELETE CHAR. NO COPY AND CYCLE if(cmod(i:i) == c(3:3))then !IF BEGIN INSERT MODE linsrt=.true. !SET INSERT FLAG TRUE goto 1 !CHECK LINE LENGTH AND CONTINUE endif !IF NOT BEGINNING INSERT MODE ichr=ichr+1 !INCREMENT NEW LINE COUNTER if(cmod(i:i) == c(2:2))then !IF REPLACE WITH BLANK dum2(ichr:ichr)=' ' !SET NEWLINE CHAR TO BLANK goto 1 !CHECK LINE LENGTH AND CYCLE endif !IF NOT REPLACE WITH BLANK if(cmod(i:i) == ' ')then !IF BLANK, KEEP ORIGINAL CHARACTER dum2(ichr:ichr)=cline(ic:ic) !SET NEW CHAR TO ORIGINAL CHAR else !IF NOT KEEPING OLD CHAR dum2(ichr:ichr)=cmod(i:i) !REPLACE ORIGINAL CHAR WITH NEW endif !END CHAR KEEP OR REPLACE endif !END INSERT OR NO-INSERT 1 continue if(i < lmax)goto 11 !CHECK FOR END OF LINE REACHED !AND CYCLE IF OK 999 continue cline=dum2 !SET ORIGINAL CHARS TO NEW CHARS end subroutine modif !RETURN !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! len_white(3f) - [M_strings:LENGTH] get length of string trimmed !! of whitespace. !! (LICENSE:PD) !! !!##SYNOPSIS !! !! integer function len_white(string) !! !! character(len=*) :: string !! !!##DESCRIPTION !! len_white(3f) returns the position of the last character in !! string that is not a whitespace character. The Fortran90 intrinsic !! LEN_TRIM() should be used when trailing whitespace can be assumed !! to always be spaces. !! !! This procedure was heavily used in the past because ANSI FORTRAN !! 77 character objects are fixed length and blank padded and the !! LEN_TRIM() intrinsic did not exist. It should now be used only when !! whitespace characters other than blanks are likely. !! !!##OPTIONS !! string input string whose trimmed length is being calculated !! ignoring all trailing whitespace characters. !!##RETURNS !! len_white the number of characters in the trimmed string !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_len_white !! !! use M_strings, only : len_white !! implicit none !! character(len=80) :: s !! integer :: lgth, lastnb !! intrinsic len !! !! s=' ABCDEFG abcdefg ' !! lgth = len(s) !! lastnb = len_white(s) !! !! write(*,*) 'total length of variable is ',lgth !! write(*,*) 'trimmed length of variable is ',lastnb !! write(*,*) 'trimmed string=[',s(:lastnb),']' !! !! end program demo_len_white !! !! Results: !! !! total length of variable is 80 !! trimmed length of variable is 16 !! trimmed string=[ ABCDEFG abcdefg] !! !!##NOTES !! !! o len_white !! !! is a resource-intensive routine. Once the end of !! the string is found, it is probably best to keep track of it in !! order to avoid repeated calls to len_white. Because they !! might be more efficient, consider looking for vendor-supplied or !! system-optimized equivalents. For example: !! !! o lnblnk - Solaris f77 !! o len_trim - FORTRAN 90 !! !! o Some compilers seem to have trouble passing a string of variable !! length properly. To be safe, use something like this: !! !! subroutine message(s) !! character(len=*) :: s ! s is of variable length !! lgth=len(s) ! get total length of variable !! ! explicitly specify a substring instead of just variable name !! lastnb = len_white(s(:lgth)) !! write(*,*)'error:[',s(:lastnb),']' !! end subroutine messages !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental integer function len_white(string) ! DEPRECATED. Use len_trim(3f),trim(3f) unless you might have trailing nulls (common when interacting with C procedures)" ! John S. Urban, 1984, 1997-12-31 ! Note that if the string is blank, a length of 0 is returned; which is not a legal string length in Fortran77. ! this routine used to return one instead of zero. ! - mod 1: 1994 ! added null (char(0)) because HP and some Suns not padding ! strings with blank, but with null characters; 1994 JSU ! - mod 2: 1999 ! update syntax with INTENT(), ENDDO, no RETURN ! still need instead of LEN_TRIM() because some systems stil pad CHARACTER with NULL !----------------------------------------------------------------------------------------------------------------------------------- ! ident_15="@(#) M_strings len_white(3f) return position of last non-blank/non-null character in string" character(len=*),intent(in):: string ! input string to determine length of integer :: i10 intrinsic len len_white=0 do i10=len(string),1,-1 select case(string(i10:i10)) case(' ') ! space(32) case(char(0)) ! null(0) case(char(9):char(13)) ! tab(9), new line(10), vertical tab(11), formfeed(12), carriage return(13) case default len_white=i10 exit end select enddo end function len_white !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! crop(3f) - [M_strings:WHITESPACE] trim leading and trailing blanks !! and control characters from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function crop(strin) result (strout) !! !! character(len=*),intent(in) :: strin !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! All control characters throughout the string are replaced with spaces !! and leading and trailing spaces are trimmed from the resulting string. !! Tabs are expanded assuming a stop every eight characters. !! !!##OPTIONS !! strin input string to trim leading and trailing space and control !! characters from !! !!##RETURNS !! strout cropped version of input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_crop !! use M_strings, only: crop !! implicit none !! character(len=20) :: untrimmed = ' ABCDEFG abcdefg ' !! write(*,*) 'untrimmed string=[',untrimmed,']' !! write(*,*) 'cropped string=[',crop(untrimmed),']' !! end program demo_crop !! !! Expected output !! !! untrimmed string=[ ABCDEFG abcdefg ] !! cropped string=[ABCDEFG abcdefg] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function crop(strin) result (strout) ! ident_16="@(#) M_strings crop(3f) replace control characters with whitespace and trim leading and trailings spaces from resulting string" character(len=*),intent(in) :: strin character(len=:),allocatable :: strout strout=trim(adjustl(noesc(dilate(strin)))) end function crop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! clip(3f) - [M_strings:WHITESPACE] trim leading and trailing blanks from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function clip(strin) result (strout) !! !! character(len=*),intent(in) :: strin !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! leading and trailing spaces are trimmed from the resulting string. !! !!##OPTIONS !! strin input string to trim leading and trailing space characters from !! !!##RETURNS !! strout clipped version of input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_clip !! use M_strings, only: clip !! implicit none !! character(len=20) :: untrimmed = ' ABCDEFG abcdefg ' !! write(*,*) 'untrimmed string=[',untrimmed,']' !! write(*,*) 'clipped string=[',clip(untrimmed),']' !! end program demo_clip !! !! Expected output !! !! untrimmed string=[ ABCDEFG abcdefg ] !! clipped string=[ABCDEFG abcdefg] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function clip(string) result(lopped) ! ident_17="@(#) M_strings clip(3f) trim leading and trailings spaces from resulting string" logical,parameter :: T=.true.,F=.false. character(len=*),intent(in) :: string character(len=:),allocatable :: lopped integer :: ends(2) ends=verify( string, " ", [F,T] ) if(ends(1) == 0)then lopped="" else lopped=string(ends(1):ends(2)) endif end function clip !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! transliterate(3f) - [M_strings:EDITING] replace characters from old !! set with new set !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function transliterate(instr,old_set,new_set) result(outstr) !! !! character(len=*),intent(in) :: instr !! character(len=*),intent(in) :: old_set !! character(len=*),intent(in) :: new_set !! character(len=len(instr)) :: outstr !! !!##DESCRIPTION !! Translate, squeeze, and/or delete characters from the input string. !! !!##OPTIONS !! instr input string to change !! old_set list of letters to change in INSTR if found !! !! Each character in the input string that matches a character !! in the old set is replaced. !! !! new_set list of letters to replace letters in OLD_SET with. !! !! If the new_set is the empty set the matched characters !! are deleted. !! !! If the new_set is shorter than the old set the last character !! in the new set is used to replace the remaining characters !! in the new set. !! !!##RETURNS !! outstr instr with substitutions applied !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_transliterate !! !! use M_strings, only : transliterate !! implicit none !! character(len=80) :: STRING !! !! STRING='aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ' !! write(*,'(a)') STRING !! !! ! convert a string to uppercase: !! write(*,*) TRANSLITERATE(STRING, & !! & 'abcdefghijklmnopqrstuvwxyz','ABCDEFGHIJKLMNOPQRSTUVWXYZ') !! !! ! change all miniscule letters to a colon (":"): !! write(*,*) TRANSLITERATE(STRING, & !! & 'abcdefghijklmnopqrstuvwxyz',':') !! !! ! delete all miniscule letters !! write(*,*) TRANSLITERATE(STRING, & !! & 'abcdefghijklmnopqrstuvwxyz','') !! !! end program demo_transliterate !! !! Expected output !! !! > aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ !! > AABBCCDDEEFFGGHHIIJJKKLLMMNNOOPPQQRRSSTTUUVVWWXXYYZZ !! > :A:B:C:D:E:F:G:H:I:J:K:L:M:N:O:P:Q:R:S:T:U:V:W:X:Y:Z !! > ABCDEFGHIJKLMNOPQRSTUVWXYZ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain PURE FUNCTION transliterate(instr,old_set,new_set) RESULT(outstr) ! ident_18="@(#) M_strings transliterate(3f) replace characters from old set with new set" !----------------------------------------------------------------------------------------------------------------------------------- CHARACTER(LEN=*),INTENT(IN) :: instr ! input string to change CHARACTER(LEN=*),intent(in) :: old_set CHARACTER(LEN=*),intent(in) :: new_set !----------------------------------------------------------------------------------------------------------------------------------- CHARACTER(LEN=LEN(instr)) :: outstr ! output string to generate !----------------------------------------------------------------------------------------------------------------------------------- INTEGER :: i10 ! loop counter for stepping thru string INTEGER :: ii,jj !----------------------------------------------------------------------------------------------------------------------------------- jj=LEN(new_set) IF(jj /= 0)THEN outstr=instr ! initially assume output string equals input string stepthru: DO i10 = 1, LEN(instr) ii=iNDEX(old_set,instr(i10:i10)) ! see if current character is in old_set IF (ii /= 0)THEN if(ii <= jj)then ! use corresponding character in new_set outstr(i10:i10) = new_set(ii:ii) else outstr(i10:i10) = new_set(jj:jj) ! new_set not as long as old_set; use last character in new_set endif ENDIF ENDDO stepthru else ! new_set is null string so delete characters in old_set outstr=' ' hopthru: DO i10 = 1, LEN(instr) ii=iNDEX(old_set,instr(i10:i10)) ! see if current character is in old_set IF (ii == 0)THEN ! only keep characters not in old_set jj=jj+1 outstr(jj:jj) = instr(i10:i10) ENDIF ENDDO hopthru endif END FUNCTION transliterate !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! rotate13(3f) - [M_strings:ENCODE] apply trivial ROT13 encryption to a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! rotate13(input) result(output) !! !! character(len=*),intent(in) :: input !! character(len=len(input)) :: output !! !!##DESCRIPTION !! ROT13 ("rotate by 13 places", sometimes hyphenated ROT-13) is a simple !! letter substitution cipher that replaces a letter with the 13th letter !! after it in the alphabet; wrapping around if necessary. !! !! The transformation can be done using a lookup table, such as the !! following: !! !! Input ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz !! Output NOPQRSTUVWXYZABCDEFGHIJKLMnopqrstuvwxyzabcdefghijklm !! !! ROT13 is used in online forums as a means of hiding spoilers, !! punchlines, puzzle solutions, and offensive materials from the casual !! glance. ROT13 has inspired a variety of letter and word games on-line, !! and is frequently mentioned in newsgroup conversations. !! !! The algorithm provides virtually no cryptographic security, and is !! often cited as a canonical example of weak encryption. !! !! ROT13 is a special case of the Caesar cipher which was developed in !! ancient Rome. !! !! ALGORITHM !! !! Applying ROT13 to a piece of text merely requires examining its !! alphabetic characters and replacing each one by the letter 13 places !! further along in the alphabet, wrapping back to the beginning if !! necessary. A becomes N, B becomes O, and so on up to M, which becomes !! Z, then the sequence continues at the beginning of the alphabet: N !! becomes A, O becomes B, and so on to Z, which becomes M. Only those !! letters which occur in the English alphabet are affected; numbers, !! symbols, whitespace, and all other characters are left unchanged. !! !! SAME ALGORITHM FOR ENCODING AND DECODING !! !! Because there are 26 letters in the English alphabet and 26 = 2 x 13, !! the ROT13 function is its own inverse: so the same action can be used !! for encoding and decoding. In other words, two successive applications !! of ROT13 restore the original text (in mathematics, this is sometimes !! called an involution; in cryptography, a reciprocal cipher). !! !! TRIVIAL SECURITY !! !! The use of a constant shift means that the encryption effectively !! has no key, and decryption requires no more knowledge than the fact !! that ROT13 is in use. Even without this knowledge, the algorithm is !! easily broken through frequency analysis. !! !! In encrypted normal English-language text of any significant size, !! ROT13 is recognizable from some letter/word patterns. The words "n", !! "V" (capitalized only), and "gur" (ROT13 for "a", "I", and "the"), !! and words ending in "yl" ("ly") are examples. !! !!##REFERENCES !! Wikipedia, the free encyclopedia !! !!##EXAMPLE !! !! Sample program !! !! program demo_rotate13 !! use M_strings, only : rotate13 !! implicit none !! character(len=256) :: line !! integer :: ios !! do !! read(*,'(a)',iostat=ios)line !! if(ios /= 0)exit !! write(*,'(a)')rotate13(line) !! enddo !! end program demo_rotate13 !! !! Sample usage: !! !! demo_rotate13 !! United we stand, divided we fall. !! Havgrq jr fgnaq, qvivqrq jr snyy. !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function rotate13 (input) ! ident_19="@(#) M_strings rotate13(3f) converts a character to its ROT13 equivalent which is a trivial encryption." character(len=*),intent(in) :: input character(len=len(input)) :: rotate13 integer :: itemp integer :: i rotate13=' ' do i=1,len_trim(input) itemp = iachar(input(i:i)) select case(itemp) case(65:77,97:109) itemp = itemp + 13 case(78:90,110:122) itemp = itemp - 13 end select rotate13(i:i) = char ( itemp ) enddo end function rotate13 !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! percent_encode(3f) - [M_strings:ENCODE] percent-encode strings and !! character arrays !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! function percent_encode(text) !! !! character(len=1),intent(in) :: text(:) !! character(len=;),allocatable :: percent_encode !! !! or !! !! function percent_encode(text) !! !! character(len=*),intent(in) :: text !! character(len=;),allocatable :: percent_encode !! !!##DESCRIPTION !! !! This function percent-encodes ASCII strings or ASCII character arrays. !! "Reserved" characters are encoded. !! !! URI containing spaces or most other non-alphanumeric characters must !! be encoded using percent encoding (aka. URL encoding). !! !! The characters allowed in a URI are either reserved or unreserved !! (or a percent character as part of a percent-encoding). Reserved !! characters are those characters that sometimes have special meaning, !! while unreserved characters have no such meaning. Using percent-encoding, !! characters which otherwise would not be allowed are represented using !! allowed characters. The sets of reserved and unreserved characters and !! the circumstances under which certain reserved characters have special !! meaning have changed slightly with each revision of specifications that !! govern URIs and URI schemes. !! !! According to RFC 3986, the characters in a URL have to be taken from !! a defined set of unreserved and reserved ASCII characters. Any other !! characters are not allowed in a URL. !! !! The unreserved characters can be encoded, but should not be. The !! unreserved characters are: !! !! > ABCDEFGHIJKLMNOPQRSTUVWXYZ !! > abcdefghijklmnopqrstuvwxyz !! > 0123456789-_.~ !! !! The reserved characters have to be encoded only under certain !! circumstances. The reserved characters are: !! !! > * ' ( ) ; : @ & = + $ , / ? % # [ ] !! !!##OPTIONS !! SOURCE_STRING string or character array to encode !! !!##RETURNS !! percent_encode a string holding a percent-encoded copy of the input !! !!##EXAMPLES !! !! Sample program: !! !! program demo_percent_encode !! use M_strings, only : percent_encode !! use, intrinsic :: iso_fortran_env, only : stdout=>output_unit !! implicit none !! write(*,*)percent_encode('[this is a string]') !! end program demo_percent_encode !! !! Results: !! !! > %5Bthis%20is%20a%20string%5D !! !!##AUTHOR !! John S. Urban function percent_encode_string(text) character(len=*),intent(in) :: text character(len=:),allocatable :: percent_encode_string percent_encode_string=percent_encode_characters(switch(text)) end function percent_encode_string function percent_encode_characters(text) character(len=1),intent(in) :: text(:) character(len=:),allocatable :: percent_encode_characters integer :: i,pos allocate(character(len=3*size(text)) :: percent_encode_characters ) percent_encode_characters(:)=repeat(' ',len(percent_encode_characters)) pos=1 do i=1,size(text) select case(text(i)) case('a':'z','A':'Z','0':'9','-','_','.','~') percent_encode_characters(pos:pos)=text(i) pos=pos+1 case default write(percent_encode_characters(pos:pos+2),'(a1,z2.2)')'%',text(i) pos=pos+3 end select enddo percent_encode_characters=trim(percent_encode_characters) end function percent_encode_characters !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! join(3f) - [M_strings:EDITING] append CHARACTER variable array into !! a single CHARACTER variable with specified separator !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function join(str,sep,trm,left,right,start,end) result (string) !! !! character(len=*),intent(in) :: str(:) !! character(len=*),intent(in),optional :: sep !! logical,intent(in),optional :: trm !! character(len=*),intent(in),optional :: right !! character(len=*),intent(in),optional :: left !! character(len=*),intent(in),optional :: start !! character(len=*),intent(in),optional :: end !! character(len=:),allocatable :: string !! !!##DESCRIPTION !! JOIN(3f) appends the elements of a CHARACTER array into a single !! CHARACTER variable, with elements 1 to N joined from left to right. !! By default each element is trimmed of trailing spaces and the !! default separator is a null string. !! !!##OPTIONS !! STR(:) array of CHARACTER variables to be joined !! SEP separator string to place between each variable. defaults !! to a null string. !! LEFT string to place at left of each element !! RIGHT string to place at right of each element !! START prefix string !! END suffix string !! TRM option to trim each element of STR of trailing !! spaces. Defaults to .TRUE. !! !!##RESULT !! STRING CHARACTER variable composed of all of the elements of STR() !! appended together with the optional separator SEP placed !! between the elements. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_join !! use M_strings, only: join !! implicit none !! character(len=:),allocatable :: s(:) !! character(len=:),allocatable :: out !! integer :: i !! s=[character(len=10) :: 'United',' we',' stand,', & !! & ' divided',' we fall.'] !! out=join(s) !! write(*,'(a)') out !! write(*,'(a)') join(s,trm=.false.) !! write(*,'(a)') (join(s,trm=.false.,sep='|'),i=1,3) !! write(*,'(a)') join(s,sep='<>') !! write(*,'(a)') join(s,sep=';',left='[',right=']') !! write(*,'(a)') join(s,left='[',right=']') !! write(*,'(a)') join(s,left='>>') !! end program demo_join !! !! Expected output: !! !! United we stand, divided we fall. !! United we stand, divided we fall. !! United | we | stand, | divided | we fall. !! United | we | stand, | divided | we fall. !! United | we | stand, | divided | we fall. !! United<> we<> stand,<> divided<> we fall. !! [United];[ we];[ stand,];[ divided];[ we fall.] !! [United][ we][ stand,][ divided][ we fall.] !! >>United>> we>> stand,>> divided>> we fall. !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function join(str,sep,trm,left,right,start,end) result (string) ! ident_20="@(#) M_strings join(3f) merge string array into a single CHARACTER value adding specified separators caps prefix and suffix" character(len=*),intent(in) :: str(:) character(len=*),intent(in),optional :: sep, right, left, start, end logical,intent(in),optional :: trm character(len=:),allocatable :: sep_local, left_local, right_local character(len=:),allocatable :: string logical :: trm_local integer :: i if(present(sep))then ; sep_local=sep ; else ; sep_local='' ; endif if(present(trm))then ; trm_local=trm ; else ; trm_local=.true. ; endif if(present(left))then ; left_local=left ; else ; left_local='' ; endif if(present(right))then ; right_local=right ; else ; right_local='' ; endif string='' if(size(str) == 0)then string=string//left_local//right_local else do i = 1,size(str)-1 if(trm_local)then string=string//left_local//trim(str(i))//right_local//sep_local else string=string//left_local//str(i)//right_local//sep_local endif enddo if(trm_local)then string=string//left_local//trim(str(i))//right_local else string=string//left_local//str(i)//right_local endif endif if(present(start))string=start//string if(present(end))string=string//end end function join !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! reverse(3f) - [M_strings:EDITING] Return a string reversed !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function reverse(str) result (string) !! !! character(*), intent(in) :: str !! character(len(str)) :: string !! !!##DESCRIPTION !! reverse(string) returns a copy of the input string with !! all characters reversed from right to left. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_reverse !! use M_strings, only: reverse !! implicit none !! character(len=:),allocatable :: s !! write(*,*)'REVERSE STRINGS:',reverse('Madam, I''m Adam') !! s='abcdefghijklmnopqrstuvwxyz' !! write(*,*) 'original input string is ....',s !! write(*,*) 'reversed output string is ...',reverse(s) !! end program demo_reverse !! !! Results: !! !! > REVERSE STRINGS:madA m'I ,madaM !! > original input string is ....abcdefghijklmnopqrstuvwxyz !! > reversed output string is ...zyxwvutsrqponmlkjihgfedcba !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function reverse(string) result (rev) ! ident_21="@(#) M_strings reverse(3f) Return a string reversed" character(len=*),intent(in) :: string ! string to reverse character(len=len(string)) :: rev ! return value (reversed string) integer :: length integer :: i length = len(string) do i = 1,length rev(i:i)=string(length-i+1:length-i+1) enddo end function reverse !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! upper_quoted(3f) - [M_strings:CASE] elemental function converts string to !! uppercase skipping strings quoted per Fortran syntax rules !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function upper_quoted(str) result (string) !! !! character(*), intent(in) :: str !! character(len(str)) :: string ! output string !! !!##DESCRIPTION !! upper_quoted(string) returns a copy of the input string with all not-quoted !! characters converted to uppercase, assuming ASCII character sets !! are being used. The quoting rules are the same as for Fortran source. !! Either a single or double quote starts a quoted string, and a quote !! character of the same type is doubled when it appears internally in !! the quoted string. If a double quote quotes the string single quotes !! may appear in the quoted string as single characters, and vice-versa !! for single quotes. !! !!##OPTIONS !! str string to convert to uppercase !! !!##RESULTS !! upper copy of the input string with all unquoted characters converted !! to uppercase !! !!##EXAMPLE !! !! Sample program: !! !! program demo_upper_quoted !! use M_strings, only: upper_quoted !! implicit none !! character(len=:),allocatable :: s !! s=' ABCDEFG abcdefg "Double-Quoted" ''Single-Quoted'' "with ""& !! & Quote" everything else' !! write(*,*) 'mixed-case input string is ....',s !! write(*,*) 'upper-case output string is ...',upper_quoted(s) !! write(*,'(1x,a,*(a:,"+"))') 'upper_quoted(3f) is elemental ==>', & !! & upper_quoted(["abc","def","ghi"]) !! end program demo_upper_quoted !! !! Expected output: !! !! mixed-case input string is .... ABCDEFG abcdefg "Double-Quoted" !! 'Single-Quoted' "with "" Quote" everything else !! upper-case output string is ... ABCDEFG ABCDEFG "Double-Quoted" !! 'Single-Quoted' "with "" Quote" EVERYTHING ELSE !! upper_quoted(3f) is elemental ==>ABC+DEF+GHI !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental pure function upper_quoted(str) result (string) ! ident_22="@(#) M_strings upper_quoted(3f) elemental function converts string to uppercase skipping strings quoted per Fortran syntax rules" character(len=*), intent(in) :: str ! The input string character(len=len(str)) :: string ! The output string logical :: toggle character(len=1) :: togglechar integer :: irnk integer :: i character(len=26), parameter :: large="ABCDEFGHIJKLMNOPQRSTUVWXYZ" character(len=26), parameter :: small="abcdefghijklmnopqrstuvwxyz" string=str toggle = .TRUE. do i = 1, len_trim(string) if(toggle) then if(string(i:i) == '"' .or. string(i:i) == "'") then toggle = .not. toggle togglechar = string(i:i) endif irnk = index(small, string(i:i)) if(irnk > 0) then string(i:i) = large(irnk:irnk) endif else if(string(i:i) == togglechar) toggle = .not. toggle endif enddo end function upper_quoted !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! upper(3f) - [M_strings:CASE] changes a string to uppercase !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function upper(str,begin,end) result (string) !! !! character(*), intent(in) :: str !! integer,optional,intent(in) :: begin,end !! character(len(str)) :: string ! output string !! !!##DESCRIPTION !! upper(string) returns a copy of the input string with all characters !! converted in the optionally specified range to uppercase, assuming !! ASCII character sets are being used. If no range is specified the !! entire string is converted to uppercase. !! !!##OPTIONS !! str string to convert to uppercase !! begin optional starting position in "str" to begin converting to !! uppercase !! end optional ending position in "str" to stop converting to !! uppercase !! !!##RESULTS !! upper copy of the input string with all characters converted to !! uppercase over optionally specified range. !! !!##TRIVIA !! The terms "uppercase" and "lowercase" date back to the early days of !! the mechanical printing press. Individual metal alloy casts of each !! needed letter, or punctuation symbol, were meticulously added to a !! press block, by hand, before rolling out copies of a page. These !! metal casts were stored and organized in wooden cases. The more !! often needed miniscule letters were placed closer to hand, in the !! lower cases of the work bench. The less often needed, capitalized, !! majuscule letters, ended up in the harder to reach upper cases. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_upper !! use M_strings, only: upper !! implicit none !! character(len=:),allocatable :: s !! s=' ABCDEFG abcdefg ' !! write(*,*) 'mixed-case input string is ....',s !! write(*,*) 'upper-case output string is ...',upper(s) !! write(*,*) 'make first character uppercase ... ',& !! & upper('this is a sentence.',1,1) !! write(*,'(1x,a,*(a:,"+"))') 'UPPER(3f) is elemental ==>',& !! & upper(["abc","def","ghi"]) !! end program demo_upper !! !! Expected output !! !! mixed-case input string is .... ABCDEFG abcdefg !! upper-case output string is ... ABCDEFG ABCDEFG !! make first character uppercase ... This is a sentence. !! UPPER(3f) is elemental ==>ABC+DEF+GHI !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== ! Timing ! ! Several different methods have been proposed for changing case. ! A simple program that copies a large file and converts it to ! uppercase was timed and compared to a simple copy. This was used ! to select the default function. ! ! NULL: 83.41user 9.25system 1:37.94elapsed 94%CPU ! upper: 101.44user 10.89system 1:58.36elapsed 94%CPU ! upper2: 105.04user 10.69system 2:04.17elapsed 93%CPU ! upper3: 267.21user 11.69system 4:49.21elapsed 96%CPU elemental pure function upper_all(str) result (string) ! ident_23="@(#) M_strings upper_all(3f) returns an uppercase string" character(*), intent(in) :: str ! input string to convert to all uppercase character(len(str)) :: string ! output string that contains no miniscule letters integer :: i ! loop counter ! note using kind=int8 is faster than int32 in gfortran integer(kind=int8), parameter :: ade_a = iachar('a'), ade_z = iachar('z') integer(kind=int8), parameter :: diff = iachar('A',kind=int8) - iachar('a',kind=int8) integer(kind=int8) :: ade_char do concurrent(i=1:len(str)) ! step thru each letter in the string in specified range ade_char = iachar(str(i:i), int8) ! ASCII Decimal Equivalent if (ade_char >= ade_a .and. ade_char <= ade_z) ade_char = ade_char + diff string(i:i) = achar(ade_char) enddo if(len(str).eq.0)string = str end function upper_all elemental pure function upper_range(str,begin,end) result (string) ! ident_24="@(#) M_strings upper_range(3f) returns a string with the specified range converted to uppercase" character(*), intent(in) :: str ! input string to convert to all uppercase integer, intent(in) :: begin,end character(len(str)) :: string ! output string that contains no miniscule letters integer :: i ! loop counter integer :: ibegin,iend ! note using kind=int8 is faster than int32 in gfortran integer(kind=int8), parameter :: diff = iachar('A',kind=int8) - iachar('a',kind=int8) iend=len(str) if(iend.ne.0.and.(end.le.iend.and.end.ge.1).and.(begin.ge.1.and.begin.le.iend))then ibegin=begin iend=end string = str ! initialize output string to input string ! note doing everything in a loop instead of just assigning string=str and then doing just changed values in loop is faster! do concurrent (i = ibegin:iend) ! step thru each letter in the string in specified range select case (str(i:i)) case ('a':'z') ! located miniscule letter string(i:i) = achar(iachar(str(i:i),kind=int8) + diff) ! change miniscule letter to majascule case default string(i:i) = str(i:i) end select enddo else string=str endif end function upper_range !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! lower(3f) - [M_strings:CASE] changes a string to lowercase over !! specified range !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function lower(str,begin,end) result (string) !! !! character(*), intent(in) :: str !! integer,optional :: begin, end !! character(len(str)) :: string ! output string !! !!##DESCRIPTION !! lower(string) returns a copy of the input string with all characters !! converted to miniscule over the specified range, assuming ASCII !! character sets are being used. If no range is specified the entire !! string is converted to miniscule. !! !!##OPTIONS !! str string to convert to miniscule !! begin optional starting position in "str" to begin converting to !! miniscule !! end optional ending position in "str" to stop converting to !! miniscule !! !!##RESULTS !! lower copy of the input string with all characters converted to !! miniscule over optionally specified range. !! !!##TRIVIA !! The terms "uppercase" and "lowercase" date back to the early days of !! the mechanical printing press. Individual metal alloy casts of each !! needed letter, or punctuation symbol, were meticulously added to a !! press block, by hand, before rolling out copies of a page. These !! metal casts were stored and organized in wooden cases. The more !! often needed miniscule letters were placed closer to hand, in the !! lower cases of the work bench. The less often needed, capitalized, !! majuscule letters, ended up in the harder to reach upper cases. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_lower !! use M_strings, only: lower !! implicit none !! character(len=:),allocatable :: s !! s=' ABCDEFG abcdefg ' !! write(*,*) 'mixed-case input string is ....',s !! write(*,*) 'lower-case output string is ...',lower(s) !! end program demo_lower !! !! Expected output !! !! mixed-case input string is .... ABCDEFG abcdefg !! lower-case output string is ... abcdefg abcdefg !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental pure function lower(str,begin,end) result (string) ! ident_25="@(#) M_strings lower(3f) Changes a string to lowercase over specified range" character(*), intent(in) :: str character(len(str)) :: string integer,intent(in),optional :: begin, end integer :: i integer :: ibegin, iend integer,parameter :: diff = iachar('A')-iachar('a') string = str ibegin=1 iend=len_trim(str) if (present(begin))then ibegin = min(max(1,begin),iend) endif if (present(end))then iend= max(1,min(iend,end)) endif do concurrent (i = ibegin:iend) ! step thru each letter in the string in specified range select case (str(i:i)) case ('A':'Z') string(i:i) = achar(iachar(str(i:i))-diff) ! change letter to miniscule case default end select enddo end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! switch(3f) - [M_strings:ARRAY] converts between CHARACTER scalar and !! array of single characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function switch(array) result (string) !! !! character(len=1),intent(in) :: array(:) !! character(len=SIZE(array)) :: string !! !! or !! !! pure function switch(string) result (array) !! !! character(len=*),intent(in) :: string !! character(len=1) :: array(len(string)) !! !!##DESCRIPTION !! SWITCH(3f): generic function that switches CHARACTER string to an array !! of single characters or an array of single characters to a CHARACTER !! string. Useful in passing strings to C. New Fortran features may !! supersede these routines. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_switch !! use M_strings, only : switch, isalpha, islower, nospace !! character(len=*),parameter :: & !! & dashes='-----------------------------------' !! character(len=*),parameter :: string='This is a string' !! character(len=1024) :: line !! !! ! First, examples of standard Fortran features !! ! returns array [F,T,T,T,T,T] !! write(*,*)['A','=','=','=','=','='] == '=' !! ! this would return T !! write(*,*)all(['=','=','=','=','=','='] == '=') !! ! this would return F !! write(*,*)all(['A','=','=','=','=','='] == '=') !! !! ! so to test if the string DASHES is all dashes !! ! using SWITCH(3f) is !! if(all(switch(dashes) == '-'))then !! write(*,*)'DASHES is all dashes' !! endif !! !! ! so to test is a string is all letters !! ! isalpha(3f) returns .true. only if character is a letter !! ! false because dashes are not a letter !! write(*,*) all(isalpha(switch(dashes))) !! ! false because of spaces !! write(*,*) all(isalpha(switch(string))) !! ! true because removed whitespace !! write(*,*) all(isalpha(switch(nospace(string)))) !! !! ! to see if a string is all uppercase !! ! show the string !! write(*,*) string !! ! converted to character array !! write(*,'(1x,*("[",a,"]":))') switch(string) !! write(*,'(*(l3))') islower(switch(string)) !! !! ! we need a string that is all letters !! line=nospace(string) !! write(*,*)'LINE=',trim(line) !! ! all true except first character !! write(*,*) islower(switch(nospace(string))) !! ! should be false !! write(*,*) all(islower(switch(nospace(string)))) !! ! should be true !! write(*,*) all(islower(switch(nospace(string(2:))))) !! !! end program demo_switch !! !! Expected output !! !! F T T T T T !! T !! F !! DASHES is all dashes !! F !! F !! T !! This is a string !! [T][h][i][s][ ][i][s][ ][a][ ][s][t][r][i][n][g] !! F T T T F T T F T F T T T T T T !! LINE=Thisisastring !! F T T T T T T T T T T T T !! F !! T !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function a2s(array) result (string) ! ident_26="@(#) M_strings a2s(3fp) function to copy char array to string" character(len=1),intent(in) :: array(:) character(len=SIZE(array)) :: string integer :: i ! ---------------------------------------------------------------------------------------------------------------------------------- forall( i = 1:size(array)) string(i:i) = array(i) ! ---------------------------------------------------------------------------------------------------------------------------------- ! string=transfer(array,string) end function a2s !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure function s2a(string) RESULT (array) ! ident_27="@(#) M_strings s2a(3fp) function to copy string(1 Clen(string)) to char array" character(len=*),intent(in) :: string character(len=1) :: array(len(string)) integer :: i ! ---------------------------------------------------------------------------------------------------------------------------------- forall(i=1:len(string)) array(i) = string(i:i) ! ---------------------------------------------------------------------------------------------------------------------------------- ! array=transfer(string,array) end function s2a !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! s2c(3f) - [M_strings:ARRAY] convert character variable to array of !! characters with last element set to null !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function s2c(string) !! !! character(len=*),intent=(in) :: string !! character(len=1),allocatable :: s2c(:) !! !!##DESCRIPTION !! Given a character variable convert it to an array of single-character !! character variables with the last element set to a null character. !! This is generally used to pass character variables to C procedures. !! !!##EXAMPLES !! !! !! character(len=3),allocatable :: array(:) !! integer :: i !! ! put one character into each 3-character element of array !! array = [(string(i:i),i=1,len(string))] !! ! write array with ASCII Decimal Equivalent below it except show !! ! unprintable characters like NULL as "XXX" !! write(*,g) merge('XXX',array,iachar(array(:)(1:1)) < 32) !! write(*,g) iachar(array(:)(1:1)) !! !! Sample Program: !! !! program demo_s2c !! use M_strings, only : s2c !! implicit none !! character(len=*),parameter :: string="single string" !! character(len=*),parameter :: g= '(1x,*("[",g3.3,"]":))' !! character(len=3),allocatable :: array(:) !! write(*,*)'INPUT STRING ',trim(string) !! ! put one character into each 3-character element of array !! array=s2c(string) !! ! write array with ASCII Decimal Equivalent below it except show !! ! unprintable characters like NULL as "XXX" !! write(*,g) merge('XXX',array,iachar(array(:)(1:1)) < 32) !! write(*,g) iachar(array(:)(1:1)) !! end program demo_s2c !! !! Expected output: !! !! INPUT STRING single string !! [s ][i ][n ][g ][l ][e ][ ][s ][t ][r ][i ][n ][g ][XXX] !! [115][105][110][103][108][101][ 32][115][116][114][105][110][103][ 0] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function s2c(string) RESULT (array) use,intrinsic :: ISO_C_BINDING, only : C_CHAR ! ident_28="@(#) M_strings s2c(3f) copy string(1 Clen(string)) to char array with null terminator" character(len=*),intent(in) :: string ! This is changing, but currently the most portable way to pass a CHARACTER variable to C is to convert it to an array of ! character variables with length one and add a null character to the end of the array. The s2c(3f) function helps do this. character(kind=C_CHAR,len=1) :: array(len_trim(string)+1) integer :: i do i = 1,size(array)-1 array(i) = string(i:i) enddo array(size(array):)=achar(0) end function s2c !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! c2s(3f) - [M_strings:ARRAY] convert C string pointer to Fortran !! character string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function c2s(c_string_pointer) result(f_string) !! !! type(c_ptr), intent(in) :: c_string_pointer !! character(len=:), allocatable :: f_string !! !!##DESCRIPTION !! Given a C pointer to a character string return a Fortran character !! string. !! !!##OPTIONS !! c_string_pointer C pointer to convert !! !!##RETURNS !! f_string Fortran character variable to return !! !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function c2s(c_string_pointer) result(f_string) ! gets a C string (pointer), and returns the corresponding Fortran string; ! If the C string is null, it returns "NULL", similar to C's "(null)" printed in similar cases: use, intrinsic :: iso_c_binding, only: c_ptr,c_f_pointer,c_char,c_null_char ! ident_29="@(#) M_strings c2s(3f) copy pointer to C char array till a null is encountered to a Fortran string up to 4096 characters" integer,parameter :: max_length=4096 type(c_ptr), intent(in) :: c_string_pointer character(len=:), allocatable :: f_string character(kind=c_char), dimension(:), pointer :: char_array_pointer => null() character(len=max_length) :: aux_string integer :: i,length=0 call c_f_pointer(c_string_pointer,char_array_pointer,[max_length]) if (.not.associated(char_array_pointer)) then allocate(character(len=4)::f_string) f_string="NULL" return endif aux_string=" " do i=1,max_length if (char_array_pointer(i)==c_null_char) then length=i-1 exit endif aux_string(i:i)=char_array_pointer(i) enddo allocate(character(len=length)::f_string) f_string=aux_string(1:length) end function c2s !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! indent(3f) - [M_strings:WHITESPACE] count number of leading spaces !! in a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function indent(line) !! !! integer :: indent !! character(len=*),intent(in) :: line !! !!##DESCRIPTION !! Count number of leading spaces in a CHARACTER variable. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_indent !! ! test filter to count leading spaces in a character variable !! ! might want to call notabs(3f) to expand tab characters !! use M_strings, only : indent !! implicit none !! character(len=1024) :: in !! integer :: ios !! READFILE: do !! read(*,'(A)',iostat=ios)in !! if(ios /= 0) exit READFILE !! write(*,'(i3,"",a)')indent(in),trim(in) !! enddo READFILE !! end program demo_indent !! !! Results: !! !! 3 a b c !! 0a b c !! 6 a b c !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function indent(line) ! ident_30="@(#) M_strings indent(3f) find number of leading spaces in a string" integer :: indent character(len=*),intent(in) :: line integer :: i indent=0 NOTSPACE: block SCAN: do i=1,len(line) if(line(i:i) /= ' ')then indent=i-1 exit NOTSPACE endif enddo SCAN indent=len(line) endblock NOTSPACE end function indent !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! visible(3f) - [M_strings:NONALPHA] expand a string to control and !! meta-control representations !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function visible(input) result(output) !! !! character(len=*),intent(in) :: input !! character(len=:),allocatable :: output !! !!##DESCRIPTION !! visible(3f) expands characters to commonly used sequences used !! to represent the characters as control sequences or meta-control !! sequences. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_visible !! use M_strings, only : visible !! integer :: i !! do i=0,255 !! write(*,'(i0,1x,a)')i,visible(char(i)) !! enddo !! end program demo_visible !!##BUGS !! The expansion is not reversible, as input sequences such as "M-" or !! "^a" will look like expanded sequences. !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function visible(input) result(output) character(len=*),intent(in) :: input character(len=:),allocatable :: output ! ident_31="@(#) M_strings visible(3f) expand escape sequences in a string to control and meta-control representations" integer :: i character(len=1) :: c character(len=*),parameter :: chars(0:255)= [ & '^@ ', '^A ', '^B ', '^C ', '^D ', '^E ', '^F ', '^G ', '^H ', '^I ', & '^J ', '^K ', '^L ', '^M ', '^N ', '^O ', '^P ', '^Q ', '^R ', '^S ', & '^T ', '^U ', '^V ', '^W ', '^X ', '^Y ', '^Z ', '^[ ', '^\ ', '^] ', & '^^ ', '^_ ', ' ', '! ', '" ', '# ', '$ ', '% ', '& ', ''' ', & '( ', ') ', '* ', '+ ', ', ', '- ', '. ', '/ ', '0 ', '1 ', & '2 ', '3 ', '4 ', '5 ', '6 ', '7 ', '8 ', '9 ', ': ', '; ', & '< ', '= ', '> ', '? ', '@ ', 'A ', 'B ', 'C ', 'D ', 'E ', & 'F ', 'G ', 'H ', 'I ', 'J ', 'K ', 'L ', 'M ', 'N ', 'O ', & 'P ', 'Q ', 'R ', 'S ', 'T ', 'U ', 'V ', 'W ', 'X ', 'Y ', & 'Z ', '[ ', '\ ', '] ', '^ ', '_ ', '` ', 'a ', 'b ', 'c ', & 'd ', 'e ', 'f ', 'g ', 'h ', 'i ', 'j ', 'k ', 'l ', 'm ', & 'n ', 'o ', 'p ', 'q ', 'r ', 's ', 't ', 'u ', 'v ', 'w ', & 'x ', 'y ', 'z ', '{ ', '| ', '} ', '~ ', '^? ', 'M-^@', 'M-^A', & 'M-^B', 'M-^C', 'M-^D', 'M-^E', 'M-^F', 'M-^G', 'M-^H', 'M-^I', 'M-^J', 'M-^K', & 'M-^L', 'M-^M', 'M-^N', 'M-^O', 'M-^P', 'M-^Q', 'M-^R', 'M-^S', 'M-^T', 'M-^U', & 'M-^V', 'M-^W', 'M-^X', 'M-^Y', 'M-^Z', 'M-^[', 'M-^\', 'M-^]', 'M-^^', 'M-^_', & 'M- ', 'M-! ', 'M-" ', 'M-# ', 'M-$ ', 'M-% ', 'M-& ', 'M-'' ', 'M-( ', 'M-) ', & 'M-* ', 'M-+ ', 'M-, ', 'M-- ', 'M-. ', 'M-/ ', 'M-0 ', 'M-1 ', 'M-2 ', 'M-3 ', & 'M-4 ', 'M-5 ', 'M-6 ', 'M-7 ', 'M-8 ', 'M-9 ', 'M-: ', 'M-; ', 'M-< ', 'M-= ', & 'M-> ', 'M-? ', 'M-@ ', 'M-A ', 'M-B ', 'M-C ', 'M-D ', 'M-E ', 'M-F ', 'M-G ', & 'M-H ', 'M-I ', 'M-J ', 'M-K ', 'M-L ', 'M-M ', 'M-N ', 'M-O ', 'M-P ', 'M-Q ', & 'M-R ', 'M-S ', 'M-T ', 'M-U ', 'M-V ', 'M-W ', 'M-X ', 'M-Y ', 'M-Z ', 'M-[ ', & 'M-\ ', 'M-] ', 'M-^ ', 'M-_ ', 'M-` ', 'M-a ', 'M-b ', 'M-c ', 'M-d ', 'M-e ', & 'M-f ', 'M-g ', 'M-h ', 'M-i ', 'M-j ', 'M-k ', 'M-l ', 'M-m ', 'M-n ', 'M-o ', & 'M-p ', 'M-q ', 'M-r ', 'M-s ', 'M-t ', 'M-u ', 'M-v ', 'M-w ', 'M-x ', 'M-y ', & 'M-z ', 'M-{ ', 'M-| ', 'M-} ', 'M-~ ', 'M-^?'] output='' do i=1,len(input) c=input(i:i) if(c == ' ')then output=output//' ' else output=output//trim(chars(iachar(c))) endif enddo end function visible !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! expand(3f) - [M_strings:NONALPHA] expand C-like escape sequences !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function expand(line,escape) result(lineout) !! !! character(len=*) :: line !! character(len=1),intent(in),optional :: escape !! character(len=:),allocatable :: lineout !! !!##DESCRIPTION !! EXPAND() expands sequences used to represent commonly used escape !! sequences or control characters. By default ... !! !! Escape sequences !! \ backslash !! a alert (BEL) -- g is an alias for a !! b backspace !! c suppress further output !! e escape !! f form feed !! n new line !! r carriage return !! t horizontal tab !! v vertical tab !! oNNN byte with octal value NNN (3 digits) !! dNNN byte with decimal value NNN (3 digits) !! xHH byte with hexadecimal value HH (2 digits) -- h is an alias for x !! !! The default escape character is the backslash, but this may be !! changed using the optional parameter ESCAPE. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_expand !! use M_strings, only : expand !! integer,parameter :: iwidth=1024 !! integer :: i !! character(len=iwidth),parameter :: input(5)=[ character(len=iwidth) :: & !! '\e[H\e[2J',& !! '\tABC\tabc',& !! '\tA\a',& !! '\nONE\nTWO\nTHREE',& !! '\\'] !! write(*,'(a)')(trim(expand(input(i))),i=1,size(input)) !! end program demo_expand !! !! Results (with nonprintable characters shown visible): !! > ^[[H^[[2J !! > ^IABC^Iabc !! > ^IA^G !! > !! > ONE !! > TWO !! > THREE !! > \ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function expand(line,escape) result(lineout) !x!USE ISO_C_BINDING ,ONLY: c_horizontal_tab ! ident_32="@(#) M_strings expand(3f) return string with escape sequences expanded" character(len=*),parameter :: c_horizontal_tab=char(9) character(len=*),intent(in) :: line character(len=1),intent(in),optional :: escape ! escape character. Default is backslash ! expand escape sequences found in input string ! Escape sequences ! %% escape character %a alert (BEL) -- gi is an alias for a ! %b backspace %c suppress further output ! %e escape %E escape ! %f form feed %n new line ! %r carriage return %t horizontal tab ! %v vertical tab ! %oNNN byte with octal value NNN (3 digits) ! %dNNN byte with decimal value NNN (3 digits) ! %xHH byte with hexadecimal value HH (2 digits) -- h is an alias for x character(len=1) :: esc ! escape character. Default is % character(len=:),allocatable :: lineout integer :: i integer :: lgth character(len=3) :: thr integer :: xxx integer :: ios i=0 ! pointer into input lgth=len_trim(line) lineout='' if(lgth == 0)return if (present(escape))then esc=escape else esc=char(92) endif EXP: do i=i+1 if(i > lgth)exit if(line(i:i) == esc)then i=i+1 if(i > lgth)exit if(line(i:i) /= esc)then BACKSLASH: select case(line(i:i)) case('a','A','g','G');lineout=lineout//char( 7) ! %a alert (BEL) case('b','B');lineout=lineout//char( 8) ! %b backspace case('c','C');exit EXP ! %c suppress further output case('d','D') ! %d Dnnn decimal value thr=line(i+1:) read(thr,'(i3)',iostat=ios)xxx lineout=lineout//char(xxx) i=i+3 case('e','E');lineout=lineout//char( 27) ! %e escape case('f','F');lineout=lineout//char( 12) ! %f form feed case('n','N');lineout=lineout//char( 10) ! %n new line !case('n','N');lineout=lineout//new_line('A') ! %n new line case('o','O') thr=line(i+1:) read(thr,'(o3)',iostat=ios)xxx lineout=lineout//char(xxx) i=i+3 case('r','R');lineout=lineout//char( 13) ! %r carriage return case('t','T');lineout=lineout//c_horizontal_tab ! %t horizontal tab case('v','V');lineout=lineout//char( 11) ! %v vertical tab case('x','X','h','H') ! %x xHH byte with hexadecimal value HH (1 to 2 digits) thr=line(i+1:) read(thr,'(z2)',iostat=ios)xxx lineout=lineout//char(xxx) i=i+2 end select BACKSLASH else lineout=lineout//esc ! escape character, defaults to backslash endif else lineout=lineout//line(i:i) endif if(i >= lgth)exit EXP enddo EXP end function expand !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! notabs(3f) - [M_strings:NONALPHA] expand tab characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine notabs(INSTR,OUTSTR,lgth) !! !! character(len=*),intent=(in) :: INSTR !! character(len=*),intent=(out) :: OUTSTR !! integer,intent=(out) :: lgth !! !!##DESCRIPTION !! NOTABS() converts tabs in INSTR to spaces in OUTSTR while maintaining !! columns. It assumes a tab is set every 8 characters. Trailing spaces !! are removed. !! !! In addition, trailing carriage returns and line feeds are removed !! (they are usually a problem created by going to and from MSWindows). !! !! What are some reasons for removing tab characters from an input line? !! Some Fortran compilers have problems with tabs, as tabs are not !! part of the Fortran character set. Some editors and printers will !! have problems with tabs. It is often useful to expand tabs in input !! files to simplify further processing such as tokenizing an input line. !! !!##OPTIONS !! instr Input line to remove tabs from !! !!##RESULTS !! outstr Output string with tabs expanded. Assumed to be of sufficient !! length !! lgth Significant length of returned string !! !!##EXAMPLES !! !! Sample program: !! !! program demo_notabs !! !! ! test filter to remove tabs and trailing white space from input !! ! on files up to 1024 characters wide !! use M_strings, only : notabs !! character(len=1024) :: in,out !! integer :: ios,iout !! do !! read(*,'(A)',iostat=ios)in !! if(ios /= 0) exit !! call notabs(in,out,iout) !! write(*,'(a)')out(:iout) !! enddo !! end program demo_notabs !! !!##SEE ALSO !! GNU/Unix commands expand(1) and unexpand(1) !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental impure subroutine notabs(instr,outstr,lgth) ! ident_33="@(#) M_strings notabs(3f) convert tabs to spaces while maintaining columns remove CRLF chars" character(len=*),intent(in) :: instr ! input line to scan for tab characters character(len=*),intent(out) :: outstr ! tab-expanded version of INSTR produced integer,intent(out) :: lgth ! column position of last character put into output string ! that is, lgth holds the position of the last non-blank character in OUTSTR !=================================================================================================================================== integer,parameter :: tabsize=8 ! assume a tab stop is set every 8th column integer :: ipos ! position in OUTSTR to put next character of INSTR integer :: lenin ! length of input string trimmed of trailing spaces integer :: lenout ! number of characters output string can hold integer :: istep ! counter that advances thru input string INSTR one character at a time character(len=1) :: c ! character in input line being processed integer :: iade ! ADE (ASCII Decimal Equivalent) of character being tested !=================================================================================================================================== ipos=1 ! where to put next character in output string OUTSTR lenin=len_trim(instr( 1:len(instr) )) ! length of INSTR trimmed of trailing spaces lenout=len(outstr) ! number of characters output string OUTSTR can hold outstr=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters !=================================================================================================================================== SCAN_LINE: do istep=1,lenin ! look through input string one character at a time c=instr(istep:istep) ! get next character iade=iachar(c) ! get ADE of the character EXPAND_TABS : select case (iade) ! take different actions depending on which character was found case(9) ! test if character is a tab and move pointer out to appropriate column ipos = ipos + (tabsize - (mod(ipos-1,tabsize))) case(10,13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files ipos=ipos+1 case default ! c is anything else other than a tab,newline,or return insert it in output string if(ipos > lenout)then call journal("*notabs* output string overflow") exit else outstr(ipos:ipos)=c ipos=ipos+1 endif end select EXPAND_TABS enddo SCAN_LINE !=================================================================================================================================== ipos=min(ipos,lenout) ! tabs or newline or return characters or last character might have gone too far lgth=len_trim(outstr(:ipos)) ! trim trailing spaces !=================================================================================================================================== end subroutine notabs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! dilate(3f) - [M_strings:NONALPHA] expand tab characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function dilate(INSTR) result(OUTSTR) !! !! character(len=*),intent=(in) :: INSTR !! character(len=:),allocatable :: OUTSTR !! !!##DESCRIPTION !! dilate() converts tabs in INSTR to spaces in OUTSTR. It assumes a !! tab is set every 8 characters. Trailing spaces are removed. !! !! In addition, trailing carriage returns and line feeds are removed !! (they are usually a problem created by going to and from MSWindows). !! !!##OPTIONS !! instr Input line to remove tabs from !! !!##RESULTS !! outstr Output string with tabs expanded. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dilate !! !! use M_strings, only : dilate, visible !! implicit none !! character(len=:),allocatable :: in !! integer :: i !! in=' this is my string ' !! ! change spaces to tabs to make a sample input !! do i=1,len(in) !! if(in(i:i) == ' ')in(i:i)=char(9) !! enddo !! write(*,'("[",a,"]")')visible(in) !! write(*,'("[",a,"]")')visible(dilate(in)) !! end program demo_dilate !! !! Results: !! !! > [^I^Ithis^Iis^Imy^Istring^I^I] !! > [ this is my string] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function dilate(INSTR) result(OUTSTR) ! ident_34="@(#) M_strings dilate(3f) convert tabs to spaces and trims line removing CRLF chars" CHARACTER(LEN=*),INTENT(IN) :: instr ! input line to scan for tab characters CHARACTER(LEN=:),allocatable :: outstr ! tab-expanded version of INSTR produced integer :: i integer :: icount integer :: lgth icount=0 do i=1,len(instr) if(instr(i:i) == char(9))icount=icount+1 enddo allocate(character(len=(len(instr)+8*icount)) :: outstr) call notabs(instr,outstr,lgth) outstr=outstr(:lgth) END function dilate !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! adjustc(3f) - [M_strings:WHITESPACE] center text !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function adjustc(string[,length]) !! !! character(len=*),intent(in) :: string !! integer,intent(in),optional :: length !! character(len=:),allocatable :: adjustc !! !!##DESCRIPTION !! Centers input text in a string of the length specified. Returns a !! string of length LENGTH if LENGTH is present. Otherwise returns a !! string of the length of the input string. !! !!##OPTIONS !! string input string to trim and center !! length line length to center text in, optional. !! !!##RETURNS !! adjustc centered output string !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_adjustc !! use M_strings, only : adjustc !! ! using length of the input string !! write(*,'(a)') '================================' !! write(*,'(a)')adjustc('centered string ') !! write(*,'(a)')adjustc(' centered string') !! write(*,'(a)')adjustc(' centered string ') !! ! using explicit output string length !! write(*,'(a)')repeat('=',50) !! write(*,'(a)')adjustc('this is a centered string',50) !! write(*,'(a)')repeat('=',50) !! end program demo_adjustc !! !! Expected output !! !! ================================ !! centered string !! centered string !! centered string !! ================================================== !! this is a centered string !! ================================================== !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function adjustc(string,length) ! ident_35="@(#) M_strings adjustc(3f) center text" !> !! PROCEDURE: adjustc(3f) !! DESCRIPTION: center text using implicit or explicit length !!##VERSION: 2.0, 20160711 !! AUTHOR: John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- character(len=*),intent(in) :: string ! input string to trim and center integer,intent(in),optional :: length ! line length to center text in character(len=:),allocatable :: adjustc ! output string integer :: inlen integer :: ileft ! left edge of string if it is centered !----------------------------------------------------------------------------------------------------------------------------------- if(present(length))then ! optional length inlen=length ! length will be requested length if(inlen <= 0)then ! bad input length inlen=len(string) ! could not use input value, fall back to length of input string endif else ! output length was not explicitly specified, use input string length inlen=len(string) endif allocate(character(len=inlen):: adjustc) ! create output at requested length adjustc(1:inlen)=' ' ! initialize output string to all blanks !----------------------------------------------------------------------------------------------------------------------------------- ileft =(inlen-len_trim(adjustl(string)))/2 ! find starting point to start input string to center it if(ileft > 0)then ! if string will fit centered in output adjustc(ileft+1:inlen)=adjustl(string) ! center the input text in the output string else ! input string will not fit centered in output string adjustc(1:inlen)=adjustl(string) ! copy as much of input to output as can endif end function adjustc !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! nospace(3f) - [M_strings:WHITESPACE] remove all whitespace from !! input string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function nospace(str) - remove all whitespace from input string !! !! character(len=*),intent(in) :: str !! character(len=:),allocatable :: nospace !! !!##DESCRIPTION !! nospace(3f) removes space, tab, carriage return, new line, vertical !! tab, formfeed and null characters (called "whitespace"). The output !! is returned trimmed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_nospace !! use M_strings, only: nospace !! implicit none !! character(len=:),allocatable :: s !! s=' This is a test ' !! write(*,*) 'original input string is ....',s !! write(*,*) 'processed output string is ...',nospace(s) !! if(nospace(s) == 'Thisisatest')then !! write(*,*)'nospace test passed' !! else !! write(*,*)'nospace test error' !! endif !! end program demo_nospace !! !! Expected output !! !! original input string is .... This is a test !! processed output string is ...Thisisatest !! nospace test passed !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function nospace(line) ! ident_36="@(#) M_strings nospace(3f) remove all whitespace from input string" character(len=*),intent(in) :: line ! remove whitespace from this string and return it character(len=:),allocatable :: nospace ! returned string integer :: ipos ! position to place next output character at integer :: i ! counter to increment from beginning to end of input string !----------------------------------------------------------------------------------------------------------------------------------- allocate(nospace,mold=line) ! initially make output line length of input line nospace(:len_trim(nospace))=' ' ipos=0 do i=1,len_trim(line) ! increment from first to last character of the input line if ( isspace( line(i:i) ) ) cycle ! if a blank is encountered skip it ipos=ipos+1 ! increment count of non-blank characters found nospace(ipos:ipos)=line(i:i) ! store non-blank character in output enddo nospace=trim(nospace) ! blank out unpacked part of line end function nospace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! stretch(3f) - [M_strings:LENGTH] return string padded to at least !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function stretch(str,length,pattern,suffix) result(strout) !! !! character(len=*),intent(in) :: str !! integer,intent(in) :: length !! character(len=*)intent(in),optional :: pattern !! character(len=*)intent(in),optional :: suffix !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! stretch(3f) pads a string with spaces to at least the specified !! length. If the trimmed input string is longer than the requested !! length the original string is returned trimmed of trailing spaces. !! !!##OPTIONS !! str the input string to return trimmed, but then padded to !! the specified length if shorter than length !! length The minimum string length to return !! pattern optional string to use as padding. Defaults to a space. !! suffix optional string to append to output string !! !!##RETURNS !! strout The input string padded to the requested length or !! the trimmed input string if the input string is !! longer than the requested length. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_stretch !! use M_strings, only : stretch !! implicit none !! character(len=10) :: string='abcdefghij' !! character(len=:),allocatable :: answer !! integer :: i !! answer=stretch(string,5) !! write(*,'("[",a,"]")') answer !! answer=stretch(string,20) !! write(*,'("[",a,"]")') answer !! i=30 !! write(*,*) !! write(*,'(1x,a,i0)') & !! & stretch('CHAPTER 1 : The beginning ',i,'.'), 1 ,& !! & stretch('CHAPTER 2 : The end ',i,'.'), 1234 ,& !! & stretch('APPENDIX ',i,'.'), 1235 !! write(*,*) !! write(*,'(1x,a,i7)') & !! & stretch('CHAPTER 1 : The beginning ',i,'.'), 1 ,& !! & stretch('CHAPTER 2 : The end ',i,'.'), 1234 ,& !! & stretch('APPENDIX ',i,'.'), 1235 !! write(*,*) !! write(*,*) & !! & stretch('CHAPTER 1 : The beginning ',i,suffix=': '), 1 !! write(*,*) & !! & stretch('CHAPTER 2 : The end ',i,suffix=': '),1234 !! write(*,*) & !! & stretch('APPENDIX ',i,suffix=': '), 1235 !! end program demo_stretch !! !! Results: !! !! [abcdefghij] !! [abcdefghij ] !! !! CHAPTER 1 : The beginning ....1 !! CHAPTER 2 : The end ..........1234 !! APPENDIX .....................1235 !! !! CHAPTER 1 : The beginning .... 1 !! CHAPTER 2 : The end .......... 1234 !! APPENDIX ..................... 1235 !! !! CHAPTER 1 : The beginning : 1 !! CHAPTER 2 : The end : 1234 !! APPENDIX : 1235 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function stretch(line,length,pattern,suffix) result(strout) ! ident_37="@(#) M_strings stretch(3f) return string padded to at least specified length" character(len=*),intent(in) :: line integer,intent(in) :: length character(len=*),intent(in),optional :: pattern character(len=*),intent(in),optional :: suffix !-!character(len=max(length,len(trim(line)))) :: strout character(len=:),allocatable :: strout if(present(pattern))then strout=pad(line,length,pattern) else strout=pad(line,length) endif if(present(suffix))then strout=strout//suffix endif end function stretch !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! rpad(3f) - [M_strings:LENGTH] convert to a string and pad on the right !! to requested length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function rpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in) :: length !! !!##DESCRIPTION !! rpad(3f) converts a scalar intrinsic value to a string and then pads !! it on the right with spaces to at least the specified length. If the !! trimmed input string is longer than the requested length the string !! is returned trimmed of leading and trailing spaces. !! !!##OPTIONS !! str The input may be scalar or a vector. !! the input value to return as a string, padded on the left to !! the specified length if shorter than length. The input may be !! any intrinsic scalar which is converted to a cropped string !! much as if written with list-directed output. !! length The minimum string length to return !! !!##RETURNS !! strout The input string padded to the requested length !! on the right with spaces. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_rpad !! use M_strings, only : rpad !! implicit none !! write(*,'("[",a,"]")') rpad( 'my string', 20) !! write(*,'("[",a,"]")') rpad( 'my string ', 20) !! write(*,'("[",a,"]")') rpad( ' my string', 20) !! write(*,'("[",a,"]")') rpad( ' my string ', 20) !! write(*,'("[",a,"]")') rpad( valuein=42 , length=7) !! write(*,'("[",a,"]")') rpad( valuein=1.0/9.0 , length=20) !! end program demo_rpad !! !! Results: !! !! > [my string ] !! > [my string ] !! > [my string ] !! > [my string ] !! > [42 ] !! > [0.111111112 ] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function rpad_scalar(valuein,length) result(strout) ! ident_38="@(#) M_strings rpad_scalar(3f) return value padded to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=96) :: line integer :: local_length select type(valuein) type is (integer(kind=int8)); write(line,'(i0)') valuein type is (integer(kind=int16)); write(line,'(i0)') valuein type is (integer(kind=int32)); write(line,'(i0)') valuein type is (integer(kind=int64)); write(line,'(i0)') valuein type is (real(kind=real32)); write(line,'(1pg0)') valuein type is (real(kind=real64)); write(line,'(1pg0)') valuein type is (logical); write(line,'(l1)') valuein type is (complex); write(line,'("(",1pg0,",",1pg0,")")') valuein type is (character(len=*)) if(present(length))then local_length = length else local_length = len(valuein) endif strout = pad(valuein,local_length,' ',clip=.true.) return class default stop '*rpad_scalar* unknown type' end select if(present(length))then strout = pad( line, length, ' ', clip=.true. ) else strout = crop( line ) endif end function rpad_scalar !=================================================================================================================================== function rpad_vector(valuein,length) result(strout) ! ident_39="@(#) M_strings rpad_vector(3f) return strings or arguments converted to string right-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=rpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(rpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=rpad_scalar(valuein(i),mxlen) enddo endif end function rpad_vector !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! cpad(3f) - [M_strings:LENGTH] convert to a cropped string and then !! centers the string to specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function cpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in) :: length !! !!##DESCRIPTION !! cpad(3f) converts a scalar value to a cropped string and then pads !! it with spaces to center it to at least the specified length. If !! the trimmed input is longer than the requested length the string is !! returned trimmed of leading and trailing spaces. !! !!##OPTIONS !! str The input may be scalar or a vector. !! the input value to return as a string, padded with spaces to !! center it at the the specified length if shorter than !! length. The input may be any intrinsic scalar which is !! converted to a cropped string much as if written with !! list-directed output. !! length The minimum string length to return !! !!##RETURNS !! strout The input string center-padded to the requested length !! with spaces. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_cpad !! use M_strings, only : cpad !! implicit none !! write(*,'("[",a,"]")') cpad( 'my string', 20) !! write(*,'("[",a,"]")') cpad( 'my string ', 20) !! write(*,'("[",a,"]")') cpad( ' my string', 20) !! write(*,'("[",a,"]")') cpad( ' my string ', 20) !! write(*,'("[",a,"]")') cpad( valuein=42 , length=7) !! write(*,'("[",a,"]")') cpad( valuein=1.0/9.0 , length=20) !! end program demo_cpad !! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function cpad_scalar(valuein,length) result(strout) ! ident_40="@(#) M_strings cpad_scalar(3f) convert value to string center-padded to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=96) :: line integer :: local_length select type(valuein) type is (integer(kind=int8)); write( line, '(i0)' ) valuein type is (integer(kind=int16)); write( line, '(i0)' ) valuein type is (integer(kind=int32)); write( line, '(i0)' ) valuein type is (integer(kind=int64)); write( line, '(i0)' ) valuein type is (real(kind=real32)); write( line, '(1pg0)' ) valuein type is (real(kind=real64)); write( line, '(1pg0)' ) valuein type is (logical); write( line, '(l1)' ) valuein type is (complex); write( line, '("(",1pg0,",",1pg0,")")' ) valuein type is (character(len = *)) if(present( length ) )then local_length = length else local_length = len(valuein) endif strout = adjustc( crop(valuein), local_length ) return class default stop '*cpad_scalar* unknown type' end select if(present(length))then strout = adjustc( crop(line), length ) else strout = crop( line ) endif end function cpad_scalar !=================================================================================================================================== function cpad_vector(valuein,length) result(strout) ! ident_41="@(#) M_strings cpad_vector(3f) return strings or arguments converted to string center-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=cpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(cpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=cpad_scalar(valuein(i),mxlen) enddo endif end function cpad_vector !=================================================================================================================================== !> !! !!##NAME !! lpad(3f) - [M_strings:LENGTH] convert to a cropped string and then !! blank-pad on the left to requested length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function lpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in) :: length !! !!##DESCRIPTION !! lpad(3f) converts a scalar value to a cropped string and then pads !! it on the left with spaces to at least the specified length. If !! the trimmed input is longer than the requested length the string is !! returned trimmed of leading and trailing spaces. !! !!##OPTIONS !! str The input may be scalar or a vector. !! the input value to return as a string, padded on the left to !! the specified length if shorter than length. The input may be !! any intrinsic scalar which is converted to a cropped string !! much as if written with list-directed output. !! length The minimum string length to return !! !!##RETURNS !! strout The input string padded to the requested length !! on the left with spaces. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_lpad !! use M_strings, only : lpad !! implicit none !! write(*,'("[",a,"]")') lpad( 'my string', 20) !! write(*,'("[",a,"]")') lpad( 'my string ', 20) !! write(*,'("[",a,"]")') lpad( ' my string', 20) !! write(*,'("[",a,"]")') lpad( ' my string ', 20) !! write(*,'("[",a,"]")') lpad( valuein=42 , length=7) !! write(*,'("[",a,"]")') lpad( valuein=1.0/9.0 , length=20) !! end program demo_lpad !! !! Results: !! !! > [ my string] !! > [ my string] !! > [ my string] !! > [ my string] !! > [ 42] !! > [ 0.111111112] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function lpad_scalar(valuein,length) result(strout) ! ident_42="@(#) M_strings lpad_scalar(3f) convert value to string padded on left to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=96) :: line integer :: local_length select type(valuein) type is (integer(kind=int8)); write(line,'(i0)') valuein type is (integer(kind=int16)); write(line,'(i0)') valuein type is (integer(kind=int32)); write(line,'(i0)') valuein type is (integer(kind=int64)); write(line,'(i0)') valuein type is (real(kind=real32)); write(line,'(1pg0)') valuein type is (real(kind=real64)); write(line,'(1pg0)') valuein type is (logical); write(line,'(l1)') valuein type is (complex); write(line,'("(",1pg0,",",1pg0,")")') valuein type is (character(len=*)) if(present( length ))then local_length=length else local_length=len( valuein ) endif strout = pad( valuein, local_length, ' ', right=.false., clip=.true. ) return class default stop '*lpad_scalar* unknown type' end select if(present(length))then strout = pad( line, length, ' ', clip=.true., right=.false. ) else strout = crop( line ) endif end function lpad_scalar !=================================================================================================================================== function lpad_vector(valuein,length) result(strout) ! ident_43="@(#) M_strings lpad_vector(3f) return vector of strings or arguments converted to string left-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=lpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(lpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=lpad_scalar(valuein(i),mxlen) enddo endif end function lpad_vector !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! zpad(3f) - [M_strings:LENGTH] pad a string on the left with zeros to !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function zpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in),optional :: length !! !!##DESCRIPTION !! zpad(3f) crops the input string (or integer, which will be converted !! to a string) and then pads it on the left with zeros to the specified !! length. !! !! Note that if the trimmed input string is already as long or longer !! than the requested length the trimmed original string is returned. !! !! For strings representing unsigned numbers this is basically an !! alias for !! !! strout=pad(str,length,'0',clip=.true.,right=.false.) !! !! For integers the same is often done with internal WRITE(3f) statements !! such as !! !! write(strout,'(i5.5)')ivalue !! !! but unlike internal I/O the function call can be used in expressions !! or passed as a procedure argument. !! !!##OPTIONS !! valuein The input value to left-pad. May be a scalar or vector !! string or integer. If the leftmost non-blank character is !! a sign character it is moved to the left-most position of !! the output. !! length The minimum string length to return. If not present, the !! length of the input parameter VALUEIN is used. If the input !! value VALUEIN is an integer no zero padding occurs if LENGTH !! is not supplied. !! !!##RETURNS !! strout A trimmed string padded on the left with zeros to !! the requested length !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_zpad !! use M_strings, only : zpad !! implicit none !! character(len=*),parameter :: boxed='("[",a,"]",*(g0,1x))' !! integer :: lun, i !! print boxed, zpad( '111', 5),'basic use' !! print boxed, zpad( valuein=42 , length=7),'by argument name' !! print boxed, zpad( ' 34567 ', 7),'cropped before padding' !! print boxed, zpad( '123456789', 5),'input longer than length' !! print boxed, zpad( ' +34567 ', 7),'starts with plus sign' !! print boxed, zpad( ' -34567 ', 7),'starts with minus sign' !! print boxed, zpad(1234),'some integers instead of strings' !! print boxed, zpad(-1234) !! print boxed, zpad(1234,8) !! print boxed, zpad(-1234,8) !! print boxed, zpad(''),'a null gets you nothing' !! print boxed, zpad('0'),'but blanks are used for default length' !! print boxed, zpad('0 ') !! print boxed, zpad(' ') !! print *, 'input value may be an array:' !! print '("[",a,"]")', zpad([1,10,100,1000,10000,100000],8) !! !! ! example usage: !! ! open output_00085.dat !! i=85 !! open(newunit=lun,file='output_'//zpad(i,5)//'.dat') !! close(unit=lun,status='delete') !! !! end program demo_zpad !! !! Results: !! !! > [00111]basic use !! > [0000042]by argument name !! > [0034567]cropped before padding !! > [123456789]input longer than length !! > [+0034567]starts with plus sign !! > [-0034567]starts with minus sign !! > [1234]some integers instead of strings !! > [-1234] !! > [00001234] !! > [-00001234] !! > []a null gets you nothing !! > [0]but blanks are used for default length !! > [00000] !! > [00000] !! > input value may be an array: !! > [00000001] !! > [00000010] !! > [00000100] !! > [00001000] !! > [00010000] !! > [00100000] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function zpad_scalar(valuein,length) result(strout) ! ident_44="@(#) M_strings zpad_vector(3f) return string or argument converted to string zero-padded to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=4096) :: line integer :: local_length if(present(length))then local_length=length else local_length=-1 endif select type(valuein) type is (integer(kind=int8)); write(line,'(i0)') valuein type is (integer(kind=int16)); write(line,'(i0)') valuein type is (integer(kind=int32)); write(line,'(i0)') valuein type is (integer(kind=int64)); write(line,'(i0)') valuein type is (real(kind=real32)); write(line,'(1pg0)') valuein type is (real(kind=real64)); write(line,'(1pg0)') valuein type is (logical); write(line,'(l1)') valuein type is (character(len=*)); line=valuein if(local_length==-1)local_length=len(valuein) type is (complex); write(line,'("(",1pg0,",",1pg0,")")') valuein end select if(local_length == -1)then strout=clip(line) else line=clip(line)//' ' if(scan(line(1:1),'+-') == 1)then strout= line(1:1)//pad(line(2:),local_length,'0',clip=.true.,right=.false.) else strout= pad(line,local_length,'0',clip=.true.,right=.false.) endif endif end function zpad_scalar !=================================================================================================================================== function zpad_vector(valuein,length) result(strout) ! ident_45="@(#) M_strings zpad_vector(3f) return vector of strings or arguments converted to string zero-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=zpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(zpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=zpad_scalar(valuein(i),mxlen) enddo endif end function zpad_vector !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! pad(3f) - [M_strings:LENGTH] return string padded to at least !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! function pad(str,length,pattern,right,clip) result(strout) !! !! character(len=*) :: str !! integer,intent(in) :: length !! character(len=max(length,len(trim(line)))) :: strout !! character(len=*),intent(in),optional :: pattern !! logical,intent(in),optional :: right !! logical,intent(in),optional :: clip !! !!##DESCRIPTION !! pad(3f) pads a string with a pattern to at least the specified !! length. If the trimmed input string is longer than the requested !! length the trimmed string is returned. !! !!##OPTIONS !! str the input string to return trimmed, but then padded to !! the specified length if shorter than length !! length The minimum string length to return !! pattern optional string to use as padding. Defaults to a space. !! right if true pads string on the right, else on the left !! clip trim spaces from input string but otherwise retain length. !! Except for simple cases you typically would trim the input !! yourself. !! !!##RETURNS !! strout The input string padded to the requested length or !! the trimmed input string if the input string is !! longer than the requested length. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_pad !! use M_strings, only : pad !! implicit none !! character(len=10) :: string='abcdefghij' !! character(len=:),allocatable :: answer !! integer :: i !! character(len=*),parameter :: g='(*(g0))' !! answer=pad(string,5) !! write(*,'("[",a,"]")') answer !! answer=pad(string,20) !! write(*,'("[",a,"]")') answer !! i=30 !! write(*,g) !! write(*,'(1x,a,1x,i0)') & !! & pad('CHAPTER 1 : The beginning ',i,'.'), 1 , & !! & pad('CHAPTER 2 : The end ',i,'.'), 1234, & !! & pad('APPENDIX ',i,'.'), 1235 !! write(*,*) !! write(*,'(1x,a,i7)') & !! & pad('CHAPTER 1 : The beginning ',i,'.'), 1 , & !! & pad('CHAPTER 2 : The end ',i,'.'), 1234, & !! & pad('APPENDIX ',i,'.'), 1235 !! !! write(*,g)pad('12',5,'0',right=.false.) !! !! write(*,g)pad('12345 ',30,'_',right=.false.) !! write(*,g)pad('12345 ',30,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',7,'_',right=.false.) !! write(*,g)pad('12345 ',7,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',6,'_',right=.false.) !! write(*,g)pad('12345 ',6,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',5,'_',right=.false.) !! write(*,g)pad('12345 ',5,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',4,'_',right=.false.) !! write(*,g)pad('12345 ',4,'_',right=.false.,clip=.true.) !! end program demo_pad !! !! Results: !! !! > [abcdefghij] !! > [abcdefghij ] !! > !! > CHAPTER 1 : The beginning .... 1 !! > CHAPTER 2 : The end .......... 1234 !! > APPENDIX ..................... 1235 !! > !! > CHAPTER 1 : The beginning .... 1 !! > CHAPTER 2 : The end .......... 1234 !! > APPENDIX ..................... 1235 !! > 00012 !! > ________________________12345 !! > _________________________12345 !! > _12345 !! > __12345 !! > 12345 !! > _12345 !! > 12345 !! > 12345 !! > 12345 !! > 12345 !! !!##SEE ALSO !! adjustl(3f), adjustr(3f), repeat(3f), trim(3f), len_trim(3f), len(3f) !! !! adjustc(3f), stretch(3f), lpad(3f), rpad(3f), cpad(3f), zpad(3f), lenset(3f) !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== function pad(line,length,pattern,right,clip) result(strout) !$@(#) M_strings::pad(3f): return string padded to at least specified length character(len=*),intent(in) :: line integer,intent(in) :: length character(len=*),intent(in),optional :: pattern logical,optional,intent(in) :: right logical,optional,intent(in) :: clip character(len=:),allocatable :: strout logical :: local_right logical :: local_clip character(len=:),allocatable :: local_pattern character(len=:),allocatable :: local_line if( present(right) )then; local_right=right; else; local_right=.true.; endif if( present(clip) )then; local_clip=clip; else; local_clip=.false.; endif if( present(pattern) )then; local_pattern=pattern; else; local_pattern=' '; endif if(len(local_pattern) == 0)then strout=line else if(local_clip)then local_line=trim(adjustl(line)) allocate(character(len=max(length,len(local_line))) :: strout) else local_line=line allocate(character(len=max(length,len(line))) :: strout) endif if(local_right)then strout(:)=local_line//repeat(local_pattern,len(strout)/len(local_pattern)+1) else strout(:)=repeat(local_pattern, ceiling(real(len(strout))/len(local_pattern))) strout(max(0,len(strout)-len(local_line))+1:)=local_line endif endif end function pad !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! lenset(3f) - [M_strings:LENGTH] return string trimmed or padded to !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function lenset(str,length) result(strout) !! !! character(len=*) :: str !! character(len=length) :: strout !! integer,intent(in) :: length !! !!##DESCRIPTION !! lenset(3f) truncates a string or pads it with spaces to the specified !! length. !! !!##OPTIONS !! str input string !! length output string length !! !!##RESULTS !! strout output string !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_lenset !! use M_strings, only : lenset !! implicit none !! character(len=10) :: string='abcdefghij' !! character(len=:),allocatable :: answer !! answer=lenset(string,5) !! write(*,'("[",a,"]")') answer !! answer=lenset(string,20) !! write(*,'("[",a,"]")') answer !! end program demo_lenset !! !! Expected output: !! !! [abcde] !! [abcdefghij ] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function lenset(line,length) result(strout) ! ident_46="@(#) M_strings lenset(3f) return string trimmed or padded to specified length" character(len=*),intent(in) :: line integer,intent(in) :: length character(len=length) :: strout strout=line end function lenset !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! merge_str(3f) - [M_strings:LENGTH] pads strings to same length and !! then calls MERGE(3f) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function merge_str(str1,str2,expr) result(strout) !! !! character(len=*),intent(in),optional :: str1 !! character(len=*),intent(in),optional :: str2 !! logical,intent(in) :: expr !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! merge_str(3f) pads the shorter of str1 and str2 to the longest length !! of str1 and str2 and then calls MERGE(padded_str1,padded_str2,expr). !! It trims trailing spaces off the result and returns the trimmed !! string. This makes it easier to call MERGE(3f) with strings, as !! MERGE(3f) requires the strings to be the same length. !! !! NOTE: STR1 and STR2 are always required even though declared optional. !! this is so the call "STR_MERGE(A,B,present(A))" is a valid call. !! The parameters STR1 and STR2 when they are optional parameters !! can be passed to a procedure if the options are optional on the !! called procedure. !! !!##OPTIONS !! STR1 string to return if the logical expression EXPR is true !! STR2 string to return if the logical expression EXPR is false !! EXPR logical expression to evaluate to determine whether to return !! STR1 when true, and STR2 when false. !!##RESULT !! MERGE_STR a trimmed string is returned that is otherwise the value !! of STR1 or STR2, depending on the logical expression EXPR. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_merge_str !! use M_strings, only : merge_str !! implicit none !! character(len=:), allocatable :: answer !! answer=merge_str('first string', & !! & 'second string is longer',10 == 10) !! write(*,'("[",a,"]")') answer !! answer=merge_str('first string', & !! & 'second string is longer',10 /= 10) !! write(*,'("[",a,"]")') answer !! end program demo_merge_str !! !! Expected output !! !! [first string] !! [second string is longer] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function merge_str(str1,str2,expr) result(strout) ! for some reason the MERGE(3f) intrinsic requires the strings it compares to be of equal length ! make an alias for MERGE(3f) that makes the lengths the same before doing the comparison by padding the shorter one with spaces ! ident_47="@(#) M_strings merge_str(3f) pads first and second arguments to MERGE(3f) to same length" character(len=*),intent(in),optional :: str1 character(len=*),intent(in),optional :: str2 character(len=:),allocatable :: str1_local character(len=:),allocatable :: str2_local logical,intent(in) :: expr character(len=:),allocatable :: strout integer :: big if(present(str2))then str2_local=str2 else str2_local='' endif if(present(str1))then str1_local=str1 else str1_local='' endif big=max(len(str1_local),len(str2_local)) ! note: perhaps it would be better to warn or fail if an optional value that is not present is returned, instead of returning '' strout=trim(merge(lenset(str1_local,big),lenset(str2_local,big),expr)) end function merge_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! squeeze(3f) - [M_strings:EDITING] delete adjacent duplicate occurrences !! of a character from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function squeeze(STR,CHAR) result (OUTSTR) !! !! character(len=*),intent(in) :: STR !! character(len=*),intent(in),optional :: CHAR !! character(len=len(str)) :: OUTSTR !! !!##DESCRIPTION !! squeeze(3f) reduces adjacent duplicates of the specified character !! to a single character !! !!##OPTIONS !! STR input string in which to reduce adjacent duplicate characters !! to a single character !! CHAR The character to remove adjacent duplicates of !! !!##RETURNS !! OUTSTR string with all contiguous adjacent occurrences of CHAR removed !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_squeeze !! use M_strings, only : squeeze !! implicit none !! character(len=:),allocatable :: strings(:) !! !! strings=[ character(len=72) :: & !! &'', & !! &'"If I were two-faced,& !! &would I be wearing this one?" --- Abraham Lincoln', & !! &'..1111111111111111111& !! &111111111111111111111111111111111111111111117777888', & !! &'I never give ''em hell,& !! &I just tell the truth, and they think it''s hell.',& !! &' & !! & --- Harry S Truman' & !! &] !! call printme( trim(strings(1)), ' ' ) !! call printme( strings(2:4), ['-','7','.'] ) !! call printme( strings(5), [' ','-','r'] ) !! contains !! impure elemental subroutine printme(str,chr) !! character(len=*),intent(in) :: str !! character(len=1),intent(in) :: chr !! character(len=:),allocatable :: answer !! write(*,'(a)')repeat('=',11) !! write(*,'("IN: <<<",g0,">>>")')str !! answer=squeeze(str,chr) !! write(*,'("OUT: <<<",g0,">>>")')answer !! write(*,'("LENS: ",*(g0,1x))')"from",len(str),"to",len(answer), & !! & "for a change of",len(str)-len(answer) !! write(*,'("CHAR: ",g0)')chr !! end subroutine printme !! end program demo_squeeze !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function squeeze(str,charp) result (outstr) character(len=*),intent(in) :: str character(len=1),intent(in) :: charp character(len=:),allocatable :: outstr character(len=1) :: ch, last_one integer :: i, pio ! position in output outstr=repeat(' ',len(str)) ! start with a string big enough to hold any output if(len(outstr)==0)return ! handle edge condition last_one=str(1:1) ! since at least this long start output with first character outstr(1:1)=last_one pio=1 do i=2,len(str) ch=str(i:i) pio=pio+merge(0,1, ch == last_one.and.ch == charp) ! decide whether to advance before saving outstr(pio:pio)=ch ! store new one or overlay the duplcation last_one=ch enddo outstr=outstr(:pio) ! trim the output string to just what was set end function squeeze !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! compact(3f) - [M_strings:WHITESPACE] converts contiguous whitespace !! to a single character (or nothing) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function compact(STR,CHAR) result (OUTSTR) !! !! character(len=*),intent(in) :: STR !! character(len=*),intent(in),optional :: CHAR !! character(len=len(str)) :: OUTSTR !! !!##DESCRIPTION !! COMPACT(3f) converts multiple spaces, tabs and control characters !! (called "whitespace") to a single character or nothing. Leading !! whitespace is removed. !! !!##OPTIONS !! STR input string to reduce or remove whitespace from !! CHAR By default the character that replaces adjacent !! whitespace is a space. If the optional CHAR parameter is supplied !! it will be used to replace the whitespace. If a null character is !! supplied for CHAR whitespace is removed. !! !!##RETURNS !! OUTSTR string of same length as input string but with all contiguous !! whitespace reduced to a single space and leading whitespace !! removed !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_compact !! use M_strings, only : compact !! implicit none !! ! produces 'This is a test ' !! write(*,*)compact(' This is a test ') !! ! produces 'Thisisatest ' !! write(*,*)compact(' This is a test ',char='') !! ! produces 'This:is:a:test ' !! write(*,*)compact(' This is a test ',char=':') !! ! note CHAR is used to replace the whitespace, but if CHAR is !! ! in the original string it is just copied !! write(*,*)compact('A AA A AAAAA',char='A') !! ! produces (original A characters are left as-is) 'AAAAAAAAAAAA' !! ! not 'A' !! end program demo_compact !! !! Expected output !! !! >This is a test !! >Thisisatest !! >This:is:a:test !! >AAAAAAAAAAAA !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !elemental pure function compact(str,char) result (outstr) function compact(str,char) result (outstr) ! ident_48="@(#) M_strings compact(3f) Converts white-space to single spaces; removes leading spaces" character(len=*),intent(in) :: str character(len=*),intent(in),optional :: char character(len=len(str)) :: outstr character(len=1) :: ch integer :: i integer :: position_in_output logical :: last_was_space character(len=1) :: char_p logical :: nospace if(present(char))then char_p=char if(len(char) == 0)then nospace=.true. else nospace=.false. endif else char_p=' ' nospace=.false. endif outstr=' ' last_was_space=.false. position_in_output=0 IFSPACE: do i=1,len_trim(str) ch=str(i:i) select case(iachar(ch)) case(0:32,127) ! space or tab character or control character if(position_in_output == 0)then ! still at beginning so ignore leading whitespace cycle IFSPACE elseif(.not.last_was_space) then ! if have not already put out a space output one if(.not.nospace)then position_in_output=position_in_output+1 outstr(position_in_output:position_in_output)=char_p endif endif last_was_space=.true. case(:-1,33:126,128:) ! not a space, quote, or control character so copy it position_in_output=position_in_output+1 outstr(position_in_output:position_in_output)=ch last_was_space=.false. end select enddo IFSPACE end function compact !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! noesc(3f) - [M_strings:NONALPHA] convert non-printable characters !! to a space !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental function noesc(INSTR) !! !! character(len=*),intent(in) :: INSTR !! character(len=len(instr)) :: noesc !! !!##DESCRIPTION !! Convert non-printable characters to a space. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_noesc !! !! use M_strings, only : noesc !! implicit none !! character(len=128) :: ascii !! character(len=128) :: cleared !! integer :: i !! ! fill variable with base ASCII character set !! do i=1,128 !! ascii(i:i)=char(i-1) !! enddo !! cleared=noesc(ascii) !! write(*,*)'characters and their ADE (ASCII Decimal Equivalent)' !! call ade(ascii) !! write(*,*)'Cleared of non-printable characters' !! call ade(cleared) !! write(*,*)'Cleared string:' !! write(*,*)cleared !! contains !! subroutine ade(string) !! implicit none !! ! the string to print !! character(len=*),intent(in) :: string !! ! number of characters in string to print !! integer :: lgth !! ! counter used to step thru string !! integer :: i !! ! get trimmed length of input string !! lgth=len_trim(string(:len(string))) !! !! ! replace lower unprintable characters with spaces !! write(*,101)(merge(string(i:i),' ',& !! & iachar(string(i:i)) >= 32 & !! & .and. & !! & iachar(string(i:i)) <= 126) & !! & ,i=1,lgth) !! !! ! print ADE value of character underneath it !! write(*,202) (iachar(string(i:i))/100, i=1,lgth) !! write(*,202)(mod( iachar(string(i:i)),100)/10,i=1,lgth) !! write(*,202)(mod((iachar(string(i:i))),10), i=1,lgth) !! ! format for printing string characters !! 101 format(*(a1:)) !! ! format for printing ADE values !! 202 format(*(i1:)) !! end subroutine ade !! end program demo_noesc !! !! Expected output !! !! The string is printed with the ADE value vertically beneath. !! The original string has all the ADEs from 000 to 127. After !! NOESC(3f) is called on the string all the "non-printable" !! characters are replaced with a space (ADE of 032). !! !! characters and their ADE (ASCII Decimal Equivalent) !! !! > !"#$%&'()*+,-./0123456789 !! :;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !! >0000000000000000000000000000000000000000000000000000000000 !! 0000000000000000000000000000000000000000001111111111111111111111111111 !! >00000000001111111111222222222233333333334444444444555555555566666666 !! 667777777777888888888899999999990000000000111111111122222222 !! >012345678901234567890123456789012345678901234567890123456789012345678 !! 90123456789012345678901234567890123456789012345678901234567 !! !! Cleared of non-printable characters !! !! > !"#$%&'()*+,-./0123456789 !! :;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !! >0000000000000000000000000000000000000000000000000000000000 !! 000000000000000000000000000000000000000000111111111111111111111111111 !! >3333333333333333333333333333333333333333444444444455555555 !! 556666666666777777777788888888889999999999000000000011111111112222222 !! >2222222222222222222222222222222223456789012345678901234567 !! 890123456789012345678901234567890123456789012345678901234567890123456 !! !! Cleared string: !! !! > !"#$%&'()*+,-./0123456789:;<=>?@ !! ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function noesc(INSTR) ! ident_49="@(#) M_strings noesc(3f) convert non-printable characters to a space" character(len=*),intent(in) :: INSTR ! string that might contain nonprintable characters character(len=len(instr)) :: noesc integer :: ic,i10 !----------------------------------------------------------------------------------------------------------------------------------- noesc='' ! initialize output string do i10=1,len_trim(INSTR(1:len(INSTR))) ic=iachar(INSTR(i10:i10)) if(ic <= 31.or.ic == 127)then ! find characters with ADE of 0-31, 127 noesc(I10:I10)=' ' ! replace non-printable characters with a space else noesc(I10:I10)=INSTR(i10:i10) ! copy other characters as-is from input string to output string endif enddo end function noesc !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! string_to_value(3f) - [M_strings:TYPE] subroutine returns numeric !! value from string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine string_to_value(chars,valu,ierr) !! !! character(len=*),intent(in) :: chars ! input string !! integer|real|doubleprecision,intent(out) :: valu !! integer,intent(out) :: ierr !! !!##DESCRIPTION !! Returns a numeric value from a numeric character string. !! !! Works with any g-format input, including integer, real, and !! exponential. If the input string begins with "B", "Z", or "O" !! and otherwise represents a positive whole number it is assumed to !! be a binary, hexadecimal, or octal value. If the string contains !! commas they are removed. If the string is of the form NN:MMM... or !! NN#MMM then NN is assumed to be the base of the whole number. !! !! If an error occurs in the READ, IOSTAT is returned in IERR and !! value is set to zero. if no error occurs, IERR=0. !! !!##OPTIONS !! CHARS input string to read numeric value from !! !!##RETURNS !! VALU numeric value returned. May be INTEGER, REAL, or !! DOUBLEPRECISION. !! IERR error flag (0 == no error) !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_string_to_value !! use M_strings, only: string_to_value !! implicit none !! real :: value !! integer :: ierr !! character(len=80) :: string !! string=' -40.5e-2 ' !! call string_to_value(string,value,ierr) !! write(*,*) 'value of string ['//trim(string)//'] is ',value !! end program demo_string_to_value !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine a2r(chars,valu,ierr) ! ident_50="@(#) M_strings a2r(3fp) subroutine returns real value from string" character(len=*),intent(in) :: chars ! input string real,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 valu8=0.0d0 call a2d(chars,valu8,ierr,onerr=0.0d0) if(ierr == 0)then if(valu8 <= huge(valu))then valu=real(valu8) else call journal('sc','*a2r*','- value too large',valu8,'>',huge(valu)) valu=huge(valu) ierr=-1 endif endif end subroutine a2r !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2i(chars,valu,ierr) ! ident_51="@(#) M_strings a2i(3fp) subroutine returns integer value from string" character(len=*),intent(in) :: chars ! input string integer,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 valu8=0.0d0 call a2d(chars,valu8,ierr,onerr=0.0d0) if(valu8 <= huge(valu))then if(valu8 <= huge(valu))then valu=int(valu8) else call journal('sc','*a2i*','- value too large',valu8,'>',huge(valu)) valu=huge(valu) ierr=-1 endif endif end subroutine a2i !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2d(chars,valu,ierr,onerr) ! ident_52="@(#) M_strings a2d(3fp) subroutine returns double value from string" ! 1989,2016 John S. Urban. ! ! o works with any g-format input, including integer, real, and exponential. ! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0. ! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data. ! IERR will still be non-zero in this case. !---------------------------------------------------------------------------------------------------------------------------------- character(len=*),intent(in) :: chars ! input string character(len=:),allocatable :: local_chars doubleprecision,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) class(*),optional,intent(in) :: onerr !---------------------------------------------------------------------------------------------------------------------------------- character(len=*),parameter :: fmt="('(bn,g',i5,'.0)')" ! format used to build frmt character(len=15) :: frmt ! holds format built to read input string character(len=256) :: msg ! hold message from I/O errors integer :: intg integer :: pnd integer :: basevalue, ivalu character(len=3),save :: nan_string='NaN' !---------------------------------------------------------------------------------------------------------------------------------- ierr=0 ! initialize error flag to zero local_chars=unquote(chars) msg='' if(len(local_chars) == 0)local_chars=' ' call substitute(local_chars,',','') ! remove any comma characters pnd=scan(local_chars,'#:') if(pnd /= 0)then write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)' read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue ! try to read value from string if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then valu=real(ivalu,kind=kind(0.0d0)) else valu=0.0d0 ierr=-1 endif else select case(local_chars(1:1)) case('z','Z','h','H') ! assume hexadecimal frmt='(Z'//v2s(len(local_chars))//')' read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('b','B') ! assume binary (base 2) frmt='(B'//v2s(len(local_chars))//')' read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('o','O') ! assume octal frmt='(O'//v2s(len(local_chars))//')' read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case default write(frmt,fmt)len(local_chars) ! build format of form '(BN,Gn.0)' read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu ! try to read value from string end select endif if(ierr /= 0)then ! if an error occurred ierr will be non-zero. if(present(onerr))then select type(onerr) type is (integer) valu=onerr type is (real) valu=onerr type is (doubleprecision) valu=onerr end select else ! set return value to NaN read(nan_string,'(g3.3)')valu endif if(local_chars /= 'eod')then ! print warning message except for special value "eod" call journal('sc','*a2d* - cannot produce number from string ['//trim(chars)//']') if(msg /= '')then call journal('sc','*a2d* - ['//trim(msg)//']') endif endif endif end subroutine a2d !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! s2v(3f) - [M_strings:TYPE] function returns doubleprecision !! numeric value from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function s2v(string[,ierr][,onerr]) !! !! character(len=*) :: string !! doubleprecision :: s2v !! integer,intent(out),optional :: ierr !! class(*),intent(in),optional :: onerr !! !!##DESCRIPTION !! This function converts a string to a DOUBLEPRECISION numeric value. !! !! The intrinsics INT(3f), REAL(3f), and DBLE(3f) are also extended !! to take CHARACTER variables. The KIND= keyword is not supported !! on the extensions. !! !!##OPTIONS !! !! string holds string assumed to represent a numeric value !! ierr If an error occurs the program is stopped if the optional !! parameter IERR is not present. If IERR returns a non-zero !! value an error occurred. !! onerr The value to return on error. A value of NaN is !! returned on error by default. !! !!##RETURNS !! s2v numeric value read from string !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_s2v !! !! use M_strings, only: s2v, int, real, dble !! implicit none !! character(len=8) :: s=' 10.345 ' !! integer :: i !! character(len=14),allocatable :: strings(:) !! doubleprecision :: dv !! integer :: errnum !! !! ! different strings representing INTEGER, REAL, and DOUBLEPRECISION !! strings=[& !! &' 10.345 ',& !! &'+10 ',& !! &' -3 ',& !! &' -4.94e-2 ',& !! &'0.1 ',& !! &'12345.678910d0',& !! &' ',& ! Note: will return zero without an error message !! &'1 2 1 2 1 . 0 ',& ! Note: spaces will be ignored !! &'WHAT? '] ! Note: error messages will appear, zero returned !! !! ! a numeric value is returned, !! ! so it can be used in numeric expression !! write(*,*) '1/2 value of string is ',s2v(s)/2.0d0 !! write(*,*) !! write(*,*)' STRING VALUE ERROR_NUMBER' !! do i=1,size(strings) !! ! Note: not a good idea to use s2v(3f) in a WRITE(3f) statement, !! ! as it does I/O when errors occur, so called on a separate line !! dv=s2v(strings(i),errnum) !! write(*,*) strings(i)//'=',dv,errnum !! enddo !! write(*,*)"Extended intrinsics" !! write(*,*)'given inputs:',s,strings(:8) !! write(*,*)'INT(3f):',int(s),int(strings(:8)) !! write(*,*)'REAL(3f):',real(s),real(strings(:8)) !! write(*,*)'DBLE(3f):',dble(s),dble(strings(:8)) !! write(*,*)"That's all folks!" !! !! end program demo_s2v !! !! Expected output !! !! >1/2 value of string is 5.1725000000000003 !! > !! > STRING VALUE ERROR_NUMBER !! > 10.345 = 10.345000000000001 0 !! >+10 = 10.000000000000000 0 !! > -3 = -3.0000000000000000 0 !! > -4.94e-2 = -4.9399999999999999E-002 0 !! >0.1 = 0.10000000000000001 0 !! >12345.678910d0= 12345.678910000001 0 !! > = 0.0000000000000000 0 !! >1 2 1 2 1 . 0 = 12121.000000000000 0 !! >*a2d* - cannot produce number from string [WHAT?] !! >*a2d* - [Bad value during floating point read] !! >WHAT? = 0.0000000000000000 5010 !! >Extended intrinsics !! >given inputs: 10.345 10.345 +10 -3 -4.94e-2 0.1 !! 12345.678910d0 1 2 1 2 1 . 0 !! >INT(3f): 10 10 10 -3 0 0 12345 0 12121 !! >REAL(3f): 10.3450003 10.3450003 10.0000000 -3.00000000 !! -4.94000018E-02 !! > 0.100000001 12345.6787 0.00000000 12121.0000 !! >DBLE(3f): 10.345000000000001 10.345000000000001 !! 10.000000000000000 !! > -3.0000000000000000 -4.9399999999999999E-002 !! 0.10000000000000001 !! > 12345.678910000001 0.0000000000000000 !! 12121.000000000000 !! >That's all folks! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !> !!##PROCEDURE: !! DESCRIPTION: s2v(3f): function returns doubleprecision number from string;zero if error occurs !!##VERSION: 2.0, 20160704 !! AUTHOR: John S. Urban doubleprecision function s2v(chars,ierr,onerr) ! 1989 John S. Urban ! ident_53="@(#) M_strings s2v(3f) returns doubleprecision number from string;zero if error occurs" character(len=*),intent(in) :: chars integer,optional :: ierr doubleprecision :: valu integer :: ierr_local class(*),intent(in),optional :: onerr ierr_local=0 if(present(onerr))then call a2d(chars,valu,ierr_local,onerr) else call a2d(chars,valu,ierr_local) endif if(present(ierr))then ! if error is not returned stop program on error ierr=ierr_local s2v=valu elseif(ierr_local /= 0)then write(*,*)'*s2v* stopped while reading '//trim(chars) stop 1 else s2v=valu endif end function s2v !=================================================================================================================================== ! calls to s2v(3f) for extending intrinsics int(3f), real(3f), dble(3f) !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! dble(3f) - [M_strings:TYPE] overloads DBLE(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function dble(string) !! !! character(len=*) :: string !! integer :: dble !! !!##DESCRIPTION !! dble(3f) returns a DOUBLE value when given a numeric representation of a !! numeric value. This overloads the DBLE(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to a dble value !! !!##RETURNS !! DBLE double precision value represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_dble !! use M_strings, only: dble !! implicit none !! write(*,*)dble('100'),dble('20.4') !! write(*,*)'dble still works',dble(20),dble(20.4) !! write(*,*)'elemental',& !! & dble([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_dble !! !! Results: !! !! > 100.00000000000000 20.399999999999999 !! > dble still works 20.000000000000000 20.399999618530273 !! > elemental 10.00000000000000 20.30000000000000 !! > 20.50000000000000 20.60000000000000 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain impure elemental doubleprecision function dble_s2v(chars) character(len=*),intent(in) :: chars dble_s2v=s2v(chars) end function dble_s2v !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! real(3f) - [M_strings:TYPE] overloads REAL(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function real(string) !! !! character(len=*) :: string !! integer :: real !! !!##DESCRIPTION !! real(3f) returns a REAL value when given a numeric representation of a !! numeric value. This overloads the REAL(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to a real value !! !!##RETURNS !! REAL real value represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_real !! use M_strings, only: real !! implicit none !! write(*,*)real('100'),real('20.4') !! write(*,*)'real still works',real(20) !! write(*,*)'elemental',& !! & real([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_real !! !! Results: !! !! > 100.000000 20.3999996 !! > real still works 20.0000000 !! > elemental 10.0000000 20.2999992 20.5000000 20.6000004 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== impure elemental real function real_s2v(chars) character(len=*),intent(in) :: chars real_s2v=real(s2v(chars)) end function real_s2v !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! int(3f) - [M_strings:TYPE] overloads INT(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function int(string) !! !! character(len=*) :: string !! integer(kind=int32) :: int !! !!##DESCRIPTION !! int(3f) returns an integer when given a numeric representation of a !! numeric value. This overloads the INT(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to an INT32 integer !! !!##RETURNS !! INT integer represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_int !! use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 !! use M_strings, only: int !! implicit none !! character(len=*),parameter :: g='(*(g0,1x))' !! write(*,g)int('100'),int('20.4') !! write(*,g)'intrinsic int(3f) still works',int(20,int32) !! write(*,g)'elemental',& !! & int([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_int !! !! Results: !! !! > 100 20 !! > intrinsic int(3f) still works 20 !! > elemental 10 20 20 20 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! nint(3f) - [M_strings:TYPE] overloads NINT(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function nint(string) !! !! character(len=*) :: string !! integer :: nint !! !!##DESCRIPTION !! nint(3f) returns an integer when given a numeric representation of a !! numeric value. This overloads the NINT(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to an integer !! !!##RETURNS !! NINT integer represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_nint !! use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 !! use M_strings, only: nint !! implicit none !! character(len=*),parameter :: g='(*(g0,1x))' !! write(*,g)nint('100'),nint('20.4') !! write(*,g)'intrinsic nint(3f) still works',nint(20.4) !! write(*,g)'elemental',& !! & nint([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_nint !! !! Results: !! !! > 100 20 !! > intrinsic nint(3f) still works 20 !! > elemental 10 20 21 21 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== impure elemental integer function nint_s2v(chars) character(len=*),intent(in) :: chars nint_s2v=nint(s2v(chars)) end function nint_s2v !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! value_to_string(3f) - [M_strings:TYPE] return numeric string !! from a numeric value !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine value_to_string(value,chars[,lgth,ierr,fmt,trimz]) !! !! character(len=*) :: chars ! minimum of 23 characters required !! !-------- !! ! VALUE may be any one of the following types: !! doubleprecision,intent(in) :: value !! real,intent(in) :: value !! integer,intent(in) :: value !! logical,intent(in) :: value !! !-------- !! character(len=*),intent(out) :: chars !! integer,intent(out),optional :: lgth !! integer,optional :: ierr !! character(len=*),intent(in),optional :: fmt !! logical,intent(in) :: trimz !! !!##DESCRIPTION !! value_to_string(3f) returns a numeric representation of a numeric !! value in a string given a numeric value of type REAL, DOUBLEPRECISION, !! INTEGER or LOGICAL. It creates the string using internal writes. It !! then removes trailing zeros from non-zero values, and left-justifies !! the string. !! !!##OPTIONS !! VALUE input value to be converted to a string !! FMT You may specify a specific format that produces a string !! up to the length of CHARS; optional. !! TRIMZ If a format is supplied the default is not to try to trim !! trailing zeros. Set TRIMZ to .true. to trim zeros from a !! string assumed to represent a simple numeric value. !! !!##RETURNS !! CHARS returned string representing input value, must be at least !! 23 characters long; or what is required by optional FMT !! if longer. !! LGTH position of last non-blank character in returned string; !! optional. !! IERR If not zero, error occurred; optional. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_value_to_string !! use M_strings, only: value_to_string !! implicit none !! character(len=80) :: string !! integer :: lgth !! call value_to_string(3.0/4.0,string,lgth) !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string(3.0/4.0,string,lgth,fmt='') !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string& !! &(3.0/4.0,string,lgth,fmt='("THE VALUE IS ",g0)') !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string(1234,string,lgth) !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string(1.0d0/3.0d0,string,lgth) !! write(*,*) 'The value is [',string(:lgth),']' !! !! end program demo_value_to_string !! !! Expected output !! !! The value is [0.75] !! The value is [ 0.7500000000] !! The value is [THE VALUE IS .750000000] !! The value is [1234] !! The value is [0.33333333333333331] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine value_to_string(gval,chars,length,err,fmt,trimz) ! ident_54="@(#) M_strings value_to_string(3fp) subroutine returns a string from a value" class(*),intent(in) :: gval character(len=*),intent(out) :: chars integer,intent(out),optional :: length integer,optional :: err integer :: err_local character(len=*),optional,intent(in) :: fmt ! format to write value with logical,intent(in),optional :: trimz character(len=:),allocatable :: fmt_local character(len=1024) :: msg ! Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION,LOGICAL) if (present(fmt)) then select type(gval) type is (integer) fmt_local='(i0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (real) fmt_local='(bz,g23.10e3)' fmt_local='(bz,g0.8)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (doubleprecision) fmt_local='(bz,g0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (logical) fmt_local='(l1)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval class default call journal('*value_to_string* UNKNOWN TYPE') chars=' ' end select if(fmt == '') then chars=adjustl(chars) call trimzeros_(chars) endif else ! no explicit format option present err_local=-1 select type(gval) type is (integer) write(chars,*,iostat=err_local,iomsg=msg)gval type is (real) write(chars,*,iostat=err_local,iomsg=msg)gval type is (doubleprecision) write(chars,*,iostat=err_local,iomsg=msg)gval type is (logical) write(chars,*,iostat=err_local,iomsg=msg)gval class default chars='' end select chars=adjustl(chars) if(index(chars,'.') /= 0) call trimzeros_(chars) endif if(present(trimz))then if(trimz)then chars=adjustl(chars) call trimzeros_(chars) endif endif if(present(length)) then length=len_trim(chars) endif if(present(err)) then err=err_local elseif(err_local /= 0)then ! cannot currently do I/O from a function being called from I/O !write(ERROR_UNIT,'(a)')'*value_to_string* WARNING:['//trim(msg)//']' chars=chars//' *value_to_string* WARNING:['//trim(msg)//']' endif end subroutine value_to_string !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! v2s(3f) - [M_strings:TYPE] return numeric string from a numeric value !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function v2s(value) result(outstr) !! !! integer|real|doubleprecision|logical,intent(in ) :: value !! character(len=:),allocatable :: outstr !! character(len=*),optional,intent(in) :: fmt !! !!##DESCRIPTION !! v2s(3f) returns a representation of a numeric value as a !! string when given a numeric value of type REAL, DOUBLEPRECISION, !! INTEGER or LOGICAL. It creates the strings using internal WRITE() !! statements. Trailing zeros are removed from non-zero values, and the !! string is left-justified. !! !!##OPTIONS !! VALUE input value to be converted to a string !! FMT format can be explicitly given, but is limited to !! generating a string of eighty or less characters. !! !!##RETURNS !! OUTSTR returned string representing input value, !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_v2s !! use M_strings, only: v2s !! write(*,*) 'The value of 3.0/4.0 is ['//v2s(3.0/4.0)//']' !! write(*,*) 'The value of 1234 is ['//v2s(1234)//']' !! write(*,*) 'The value of 0d0 is ['//v2s(0d0)//']' !! write(*,*) 'The value of .false. is ['//v2s(.false.)//']' !! write(*,*) 'The value of .true. is ['//v2s(.true.)//']' !! end program demo_v2s !! !! Expected output !! !! The value of 3.0/4.0 is [0.75] !! The value of 1234 is [1234] !! The value of 0d0 is [0] !! The value of .false. is [F] !! The value of .true. is [T] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== function d2s(dvalue,fmt) result(outstr) ! ident_55="@(#) M_strings d2s(3fp) private function returns string given doubleprecision value" doubleprecision,intent(in) :: dvalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(dvalue,string,fmt=fmt) else call value_to_string(dvalue,string) endif outstr=trim(string) end function d2s !=================================================================================================================================== function r2s(rvalue,fmt) result(outstr) ! ident_56="@(#) M_strings r2s(3fp) private function returns string given real value" real,intent(in) :: rvalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(rvalue,string,fmt=fmt) else call value_to_string(rvalue,string) endif outstr=trim(string) end function r2s !=================================================================================================================================== function i2s(ivalue,fmt) result(outstr) ! ident_57="@(#) M_strings i2s(3fp) private function returns string given integer value" integer,intent(in) :: ivalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(ivalue,string,fmt=fmt) else call value_to_string(ivalue,string) endif outstr=trim(string) end function i2s !=================================================================================================================================== function l2s(lvalue,fmt) result(outstr) ! ident_58="@(#) M_strings l2s(3fp) private function returns string given logical value" logical,intent(in) :: lvalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(lvalue,string,fmt=fmt) else call value_to_string(lvalue,string) endif outstr=trim(string) end function l2s !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isnumber(3f) - [M_strings:TYPE] determine if a string represents a number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function isnumber(str,msg) !! !! character(len=*),intent(in) :: str !! character(len=:),intent(out),allocatable,optional :: msg !! !!##DESCRIPTION !! ISNUMBER(3f) returns a value greater than zero if the string represents !! a number, and a number less than or equal to zero if it is a bad number. !! Blank characters are ignored. !! !!##OPTIONS !! str the string to evaluate as to whether it represents a numeric value !! or not !! msg An optional message describing the string !! !!##RETURNS !! isnumber the following values are returned !! !! 1 for an integer [-+]NNNNN !! 2 for a whole number [-+]NNNNN. !! 3 for a real value [-+]NNNNN.MMMM !! 4 for a exponential value [-+]NNNNN.MMMM[-+]LLLL !! [-+]NNNNN.MMMM[ed][-+]LLLL !! !! values less than 1 represent an error !! !!##EXAMPLES !! !! As the example shows, you can use an internal READ(3f) along with the !! IOSTAT= parameter to check (and read) a string as well. !! !! program demo_isnumber !! use M_strings, only : isnumber !! implicit none !! character(len=256) :: line !! real :: value !! integer :: ios1, ios2 !! integer :: answer !! character(len=256) :: message !! character(len=:),allocatable :: description !! write(*,*)'Begin entering values, one per line' !! do !! read(*,'(a)',iostat=ios1)line !! ! !! ! try string as number using list-directed input !! line='' !! read(line,*,iostat=ios2,iomsg=message) value !! if(ios2 == 0)then !! write(*,*)'VALUE=',value !! elseif( is_iostat_end(ios1) ) then !! stop 'end of file' !! else !! write(*,*)'ERROR:',ios2,trim(message) !! endif !! ! !! ! try string using isnumber(3f) !! answer=isnumber(line,msg=description) !! if(answer > 0)then !! write(*,*) & !! & ' for ',trim(line),' ',answer,':',description !! else !! write(*,*) & !! & ' ERROR for ',trim(line),' ',answer,':',description !! endif !! ! !! enddo !! end program demo_isnumber !! !! Example run !! !! > Begin entering values !! > ERROR: -1 End of file !! > ERROR for -1 :null string !! >10 !! > VALUE= 10.0000000 !! > for 10 1 :integer !! >20 !! > VALUE= 20.0000000 !! > for 20 1 :integer !! >20. !! > VALUE= 20.0000000 !! > for 20. 2 :whole number !! >30.1 !! > VALUE= 30.1000004 !! > for 30.1 3 :real number !! >3e1 !! > VALUE= 30.0000000 !! > for 3e1 4 :value with exponent !! >1-2 !! > VALUE= 9.99999978E-03 !! > for 1-2 4 :value with exponent !! >100.22d-4 !! > VALUE= 1.00220004E-02 !! > for 100.22d-4 4 :value with exponent !! >1--2 !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1--2 -5 :bad number !! >e !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for e -6 :missing leading value before exponent !! >e1 !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for e1 -6 :missing leading value before exponent !! >1e !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1e -3 :missing exponent !! >1e+ !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1e+ -4 :missing exponent after sign !! >1e+2.0 !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1e+2.0 -5 :bad number !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function isNumber(string,msg,verbose) ! ident_59="@(#) M_strings isnumber(3f) Determines if a string is a number of not." character(len=*),intent(in) :: string character(len=:),intent(out),allocatable,optional :: msg logical,intent(in),optional :: verbose integer :: isnumber integer :: i,iend character(len=1),allocatable :: z(:) character(len=:),allocatable :: message logical :: founddigit logical :: verbose_local i=1 founddigit=.false. isnumber=0 z=switch(trim(nospace(string))) iend=size(z) message='not a number' if(present(verbose))then verbose_local=verbose else verbose_local=.false. endif DONE : block if(iend == 0)then isnumber=-1 ! string is null message='null string' exit DONE endif if(index('+-',z(i)) /= 0) i=i+1 ! skip optional leading sign if(i > iend)then isnumber=-2 ! string was just a sign message='just a sign' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=1 ! [+-]NNNNNN message='integer' exit DONE endif if(z(i) == '.')then ! a period would be OK at this point i=i+1 endif if(i > iend)then ! [+-]NNNNNN. isnumber=2 message='whole number' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=3 ! [+-]NNNNNN.MMMM message='real number' exit DONE endif if(index('eEdD',z(i)) /= 0)then i=i+1 if(i == 2)then isnumber=-6 ! [+-]NNNNNN[.[MMMM]]e but a value must follow message='missing leading value before exponent' exit DONE endif endif if(i > iend)then isnumber=-3 ! [+-]NNNNNN[.[MMMM]]e but a value must follow message='missing exponent' exit DONE endif if(.not.founddigit)then isnumber=-7 message='missing value before exponent' exit DONE endif if(index('+-',z(i)) /= 0) i=i+1 if(i > iend)then isnumber=-4 ! [+-]NNNNNN[.[MMMM]]e[+-] but a value must follow message='missing exponent after sign' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=4 ! [+-]NNNNNN.MMMMe[+-]LL message='value with exponent' exit DONE endif isnumber=-5 message='bad number' endblock DONE if(verbose_local)then write(*,*)trim(string)//' is '//message endif if(present(msg))then msg=message endif contains subroutine next() ! move to next non-digit or end of string+1 integer :: j do j=i,iend if(.not.isdigit(z(j)))then exit endif founddigit=.true. if(verbose_local) write(*,*)'I=',i,' J=',j,' Z(j)=',z(j) enddo i=j if(verbose_local)then write(*,*)'I and J=',i if(i <= iend) then write(*,*)'Z(I)=',z(i) else write(*,*)'====>' endif endif end subroutine next end function isNumber !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! trimzeros_(3fp) - [M_strings:TYPE] Delete trailing zeros from !! numeric decimal string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine trimzeros_(str) !! !! character(len=*) :: str !! !!##DESCRIPTION !! TRIMZEROS_(3f) deletes trailing zeros from a string representing a !! number. If the resulting string would end in a decimal point, one !! trailing zero is added. !! !!##OPTIONS !! str input string will be assumed to be a numeric value and have !! trailing zeros removed !!##EXAMPLES !! !! Sample program: !! !! program demo_trimzeros_ !! use M_strings, only : trimzeros_ !! character(len=:),allocatable :: string !! write(*,*)trimzeros_('123.450000000000') !! write(*,*)trimzeros_('12345') !! write(*,*)trimzeros_('12345.') !! write(*,*)trimzeros_('12345.00e3') !! end program demo_trimzeros_ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine trimzeros_(string) ! ident_60="@(#) M_strings trimzeros_(3fp) Delete trailing zeros from numeric decimal string" ! if zero needs added at end assumes input string has room character(len=*) :: string character(len=len(string) + 2) :: str character(len=len(string)) :: exp ! the exponent string if present integer :: ipos ! where exponent letter appears if present integer :: i, ii str = string ! working copy of string ipos = scan(str, 'eEdD') ! find end of real number if string uses exponent notation if (ipos > 0) then ! letter was found exp = str(ipos:) ! keep exponent string so it can be added back as a suffix str = str(1:ipos - 1) ! just the real part, exponent removed will not have trailing zeros removed endif if (index(str, '.') == 0) then ! if no decimal character in original string add one to end of string ii = len_trim(str) str(ii + 1:ii + 1) = '.' ! add decimal to end of string endif do i = len_trim(str), 1, -1 ! scanning from end find a non-zero character select case (str(i:i)) case ('0') ! found a trailing zero so keep trimming cycle case ('.') ! found a decimal character at end of remaining string if (i <= 1) then str = '0' else str = str(1:i - 1) endif exit case default str = str(1:i) ! found a non-zero character so trim string and exit exit end select end do if (ipos > 0) then ! if originally had an exponent place it back on string = trim(str)//trim(exp) else string = str endif end subroutine trimzeros_ !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! listout(3f) - [M_strings:NUMERIC] expand a list of numbers where negative !! numbers denote range ends (1 -10 means 1 thru 10) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine listout(icurve_lists,icurve_expanded,inums,ierr) !! !! integer,intent(in) :: icurve_lists(:) !! integer,intent(out) :: icurve_expanded(:) !! integer,intent(out) :: inums !! integer,intent(out) :: ierr !! !!##DESCRIPTION !! expand a list of whole numbers where negative numbers indicate a range. !! So [10,-20] would be expanded to [10,11,12,13,14,15,16,17,18,19,20]. !! !!##OPTIONS !! icurve_lists(:) input array !! !!##RETURNS !! icurve_expanded(:) output array; assumed large enough to hold !! returned list !! inums number of icurve_expanded numbers on output !! ierr zero if no error occurred !! !!##EXAMPLE !! !! Sample program: !! !! program demo_listout !! use M_strings, only : listout !! implicit none !! integer,allocatable :: icurve_lists(:) !! integer :: icurve_expanded(1000) !! ! icurve_lists is input array !! integer :: inums !! ! icurve_expanded is output array !! integer :: i !! ! number of icurve_lists values on input, !! ! number of icurve_expanded numbers on output !! integer :: ierr !! icurve_lists=[1, 20, -30, 101, 100, 99, 100, -120, 222, -200] !! inums=size(icurve_lists) !! call listout(icurve_lists,icurve_expanded,inums,ierr) !! if(ierr == 0)then !! write(*,'(i0)')(icurve_expanded(i),i=1,inums) !! else !! write(*,'(a,i0)')'error occurred in *listout* ',ierr !! write(*,'(i0)')(icurve_expanded(i),i=1,inums) !! endif !! end program demo_listout !! !! Results: !! !! > 1 20 21 22 23 !! > 24 25 26 27 28 !! > 29 30 101 100 99 !! > 100 101 102 103 104 !! > 105 106 107 108 109 !! > 110 111 112 113 114 !! > 115 116 117 118 119 !! > 120 222 221 220 219 !! > 218 217 216 215 214 !! > 213 212 211 210 209 !! > 208 207 206 205 204 !! > 203 202 201 200 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine listout(icurve_lists,icurve_expanded,inums_out,ierr) ! ident_61="@(#) M_strings listout(3f) copy icurve_lists to icurve_expanded expanding negative numbers to ranges (1 -10 means 1 thru 10)" ! Created: 19971231 integer,intent(in) :: icurve_lists(:) ! input array integer,intent(out) :: icurve_expanded(:) ! output array integer,intent(out) :: inums_out ! number of icurve_expanded numbers on output integer,intent(out) :: ierr ! status variable character(len=80) :: temp1 integer :: i80, i90 integer :: imin, imax integer :: idirection, icount integer :: iin integer :: inums_max ierr=0 icurve_expanded=0 ! initialize output array inums_out=0 ! initialize number of significant values in output array inums_max=size(icurve_expanded) if(inums_max == 0)then ierr=-2 return endif iin=size(icurve_lists) if(iin > 0)then icurve_expanded(1)=icurve_lists(1) endif icount=2 do i90=2,iin if(icurve_lists(i90) < 0)then imax=abs(icurve_lists(i90)) imin=abs(icurve_lists(i90-1)) if(imin > imax)then idirection=-1 imin=imin-1 elseif(imax > imin)then idirection=1 imin=imin+1 else idirection=1 endif do i80=imin,imax,idirection if(icount > inums_max) then write(temp1,'(a,i5,a)')'*listout* only ',inums_max,' values allowed' ierr=-1 call journal(temp1) inums_out=icount-1 exit endif icurve_expanded(icount)=i80 icount=icount+1 enddo else icurve_expanded(icount)=icurve_lists(i90) icount=icount+1 endif enddo inums_out=icount-1 end subroutine listout !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! quote(3f) - [M_strings:QUOTES] add quotes to string as if written !! with list-directed input !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function quote(str,mode,clip) result (quoted_str) !! !! character(len=*),intent(in) :: str !! character(len=*),optional,intent(in) :: mode !! logical,optional,intent(in) :: clip !! character(len=:),allocatable :: quoted_str !! !!##DESCRIPTION !! Add quotes to a CHARACTER variable as if it was written using !! list-directed input. This is particularly useful for processing !! strings to add to CSV files. !! !!##OPTIONS !! str input string to add quotes to, using the rules of !! list-directed input (single quotes are replaced by two !! adjacent quotes) !! mode alternate quoting methods are supported: !! !! DOUBLE default. replace quote with double quotes !! ESCAPE replace quotes with backslash-quote instead of !! double quotes !! !! clip default is to trim leading and trailing spaces from the !! string. If CLIP is .FALSE. spaces are not trimmed !! !!##RESULT !! quoted_str The output string, which is based on adding quotes to STR. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_quote !! use M_strings, only : quote !! implicit none !! character(len=:),allocatable :: str !! character(len=1024) :: msg !! integer :: ios !! character(len=80) :: inline !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)inline !! if(ios /= 0)then !! write(*,*)trim(inline) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'ORIGINAL ['//trim(inline)//']' !! !! ! the string processed by quote(3f) !! str=quote(inline) !! write(*,'(a)')'QUOTED ['//str//']' !! !! ! write the string list-directed to compare the results !! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:' !! write(*,*,iostat=ios,iomsg=msg,delim='none') inline !! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline !! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline !! enddo !! end program demo_quote !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function quote(str,mode,clip) result (quoted_str) character(len=*),intent(in) :: str ! the string to be quoted character(len=*),optional,intent(in) :: mode logical,optional,intent(in) :: clip character(len=:),allocatable :: quoted_str character(len=1),parameter :: double_quote = '"' character(len=20) :: local_mode if(present(clip))then if(clip)then quoted_str=adjustl(str) else quoted_str=str endif else quoted_str=str endif local_mode=merge_str(mode,'DOUBLE',present(mode)) select case(lower(local_mode)) case('double') quoted_str=double_quote//trim(replace(quoted_str,'"','""'))//double_quote case('escape') quoted_str=double_quote//trim(replace(quoted_str,'"','\"'))//double_quote case default call journal('sc','*quote* ERROR: unknown quote mode ',local_mode) quoted_str=str end select !----------------------------------------------------------------------------------------------------------------------------------- end function quote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! unquote(3f) - [M_strings:QUOTES] remove quotes from string as if !! read with list-directed input !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function unquote(quoted_str,esc) result (unquoted_str) !! !! character(len=*),intent(in) :: quoted_str !! character(len=1),optional,intent(in) :: esc !! character(len=:),allocatable :: unquoted_str !! !!##DESCRIPTION !! Remove quotes from a CHARACTER variable as if it was read using !! list-directed input. This is particularly useful for processing !! tokens read from input such as CSV files. !! !! Fortran can now read using list-directed input from an internal file, !! which should handle quoted strings, but list-directed input does not !! support escape characters, which UNQUOTE(3f) does. !! !!##OPTIONS !! quoted_str input string to remove quotes from, using the rules of !! list-directed input (two adjacent quotes inside a quoted !! region are replaced by a single quote, a single quote or !! double quote is selected as the delimiter based on which !! is encountered first going from left to right, ...) !! esc optional character used to protect the next quote !! character from being processed as a quote, but simply as !! a plain character. !! !!##RESULT !! unquoted_str The output string, which is based on removing quotes !! from quoted_str. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_unquote !! use M_strings, only : unquote !! implicit none !! character(len=128) :: quoted_str !! character(len=:),allocatable :: unquoted_str !! character(len=1),parameter :: esc='\' !! character(len=1024) :: msg !! integer :: ios !! character(len=1024) :: dummy !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str !! if(ios /= 0)then !! write(*,*)trim(msg) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' !! !! ! the string processed by unquote(3f) !! unquoted_str=unquote(trim(quoted_str),esc) !! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' !! !! ! read the string list-directed to compare the results !! read(quoted_str,*,iostat=ios,iomsg=msg)dummy !! if(ios /= 0)then !! write(*,*)trim(msg) !! else !! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' !! endif !! enddo !! end program demo_unquote !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function unquote(quoted_str,esc) result (unquoted_str) character(len=*),intent(in) :: quoted_str ! the string to be unquoted character(len=1),optional,intent(in) :: esc ! escape character character(len=:),allocatable :: unquoted_str integer :: inlen character(len=1),parameter :: single_quote = "'" character(len=1),parameter :: double_quote = '"' integer :: quote ! whichever quote is to be used integer :: before integer :: current integer :: iesc integer :: iput integer :: i logical :: inside !----------------------------------------------------------------------------------------------------------------------------------- if(present(esc))then ! select escape character as specified character or special value meaning not set iesc=iachar(esc) ! allow for an escape character else iesc=-1 ! set to value that matches no character endif !----------------------------------------------------------------------------------------------------------------------------------- inlen=len(quoted_str) ! find length of input string allocate(character(len=inlen) :: unquoted_str) ! initially make output string length of input string !----------------------------------------------------------------------------------------------------------------------------------- if(inlen >= 1)then ! double_quote is the default quote unless the first character is single_quote if(quoted_str(1:1) == single_quote)then quote=iachar(single_quote) else quote=iachar(double_quote) endif else quote=iachar(double_quote) endif !----------------------------------------------------------------------------------------------------------------------------------- before=-2 ! initially set previous character to impossible value unquoted_str(:)='' ! initialize output string to null string iput=1 inside=.false. STEPTHROUGH: do i=1,inlen current=iachar(quoted_str(i:i)) if(before == iesc)then ! if previous character was escape use current character unconditionally iput=iput-1 ! backup unquoted_str(iput:iput)=char(current) iput=iput+1 before=-2 ! this could be second esc or quote elseif(current == quote)then ! if current is a quote it depends on whether previous character was a quote if(before == quote)then unquoted_str(iput:iput)=char(quote) ! this is second quote so retain it iput=iput+1 before=-2 elseif(.not.inside.and.before /= iesc)then inside=.true. else ! this is first quote so ignore it except remember it in case next is a quote before=current endif else unquoted_str(iput:iput)=char(current) iput=iput+1 before=current endif enddo STEPTHROUGH !----------------------------------------------------------------------------------------------------------------------------------- unquoted_str=unquoted_str(:iput-1) !----------------------------------------------------------------------------------------------------------------------------------- end function unquote !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! edit_distance(3f) - [M_strings:DESCRIBE] returns a naive edit distance using !! the Levenshtein distance algorithm !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure elemental function edit_distance(str1,str2) result (distance) !! !! character(len=*),intent(in) :: str1, str2 !! integer :: distance !! !!##DESCRIPTION !! !! The Levenshtein distance function returns how many edits (deletions, !! insertions, transposition) are required to turn one string into another. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_edit_distance !! use M_strings, only : edit_distance !! write(*,*)edit_distance('kittens','sitting')==3 !! write(*,*)edit_distance('geek','gesek')==1 !! write(*,*)edit_distance('Saturday','Sunday')==3 !! end program demo_edit_distance !! !! Expected output !! !! T !! T !! T !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain ! The Levenshtein distance function returns how many edits (deletions, ! insertions, transposition) are required to turn one string into another. pure elemental integer function edit_distance (a,b) character(len=*), intent(in) :: a, b integer :: len_a, len_b, i, j, cost ! matrix for calculating Levenshtein distance !integer :: matrix(0:len_trim(a), 0:len_trim(b)) ! not supported by all compilers yet integer,allocatable :: matrix(:,:) len_a = len_trim(a) len_b = len_trim(b) !-------------------------------------- ! required by older compilers instead of above declaration if(allocated(matrix))deallocate(matrix) allocate(matrix(0:len_a,0:len_b)) !-------------------------------------- matrix(:,0) = [(i,i=0,len_a)] matrix(0,:) = [(j,j=0,len_b)] do i = 1, len_a do j = 1, len_b cost=merge(0,1,a(i:i)==b(j:j)) matrix(i,j) = min(matrix(i-1,j)+1, matrix(i,j-1)+1, matrix(i-1,j-1)+cost) enddo enddo edit_distance = matrix(len_a,len_b) end function edit_distance !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! bundle(3f) - [M_strings:ARRAY] return up to twenty strings of arbitrary length !! as an array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function bundle(str1,str2,...str20,len) result (vec) !! !! character(len=*),intent(in),optional :: str1, str2 ... str20 !! integer,intent(in),optional :: len !! !!##DESCRIPTION !! Given a list of up to twenty strings create a string array. The !! length of the variables with be the same as the maximum length !! of the input strings unless explicitly specified via LEN. !! !! This is an alternative to the syntax !! !! [ CHARACTER(LEN=NN) :: str1, str2, ... ] !! !! that by default additionally calculates the minimum length required !! to prevent truncation. !! !!##OPTIONS !! str1,str2, ... str20 input strings to combine into a vector !! len length of returned array variables !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_bundle !! use M_strings, only: bundle !! implicit none !! print "(*('""',a,'""':,',',1x))", bundle("one") !! print "(*('""',a,'""':,',',1x))", bundle("one","two") !! print "(*('""',a,'""':,',',1x))", bundle("one","two","three") !! print "(*('""',a,'""':,',',1x))", bundle("one","two","three",& !! & "four","five","six","seven") !! end program demo_bundle !! !! Expected output !! !! "one" !! "one", "two" !! "one ", "two ", "three" !! "one ", "two ", "three", "four ", "five ", "six ", "seven" !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function bundle(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,len) result(vec) ! return character array containing present arguments character(len=*),intent(in),optional :: x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 character(len=*),intent(in),optional :: x11,x12,x13,x14,x15,x16,x17,x18,x19,x20 integer,intent(in),optional :: len character(len=:),allocatable :: vec(:) integer :: ilen, icount, iset ilen=0 icount=0 iset=0 call increment(x1) call increment(x2) call increment(x3) call increment(x4) call increment(x5) call increment(x6) call increment(x7) call increment(x8) call increment(x9) call increment(x10) call increment(x11) call increment(x12) call increment(x13) call increment(x14) call increment(x15) call increment(x16) call increment(x17) call increment(x18) call increment(x19) call increment(x20) if(present(len)) ilen=len allocate (character(len=ilen) ::vec(icount)) call set(x1) call set(x2) call set(x3) call set(x4) call set(x5) call set(x6) call set(x7) call set(x8) call set(x9) call set(x10) call set(x11) call set(x12) call set(x13) call set(x14) call set(x15) call set(x16) call set(x17) call set(x18) call set(x19) call set(x20) contains subroutine increment(str) character(len=*),intent(in),optional :: str if(present(str))then ilen=max(ilen,len_trim(str)) icount=icount+1 endif end subroutine increment subroutine set(str) character(len=*),intent(in),optional :: str if(present(str))then iset=iset+1 vec(iset)=str endif end subroutine set end function bundle !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! describe(3f) - [M_strings:DESCRIBE] returns a string describing the name of !! a single character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function describe(ch) result (string) !! !! character(len=1),intent(in) :: ch !! character(len=:),allocatable :: string !! !!##DESCRIPTION !! describe(3f) returns a string describing long name of a single !! character !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_describe !! use M_strings, only : describe !! implicit none !! integer :: i !! do i=1,128 ! fill variable with base ASCII character set !! write(*,*)describe(char(i-1)) !! enddo !! end program demo_describe !! !! Expected output !! !! ctrl-@ or ctrl-? (NUL) null !! ctrl-A (SOH) start of heading !! ctrl-B (STX) start of text !! ctrl-C (ETX) end of text !! ctrl-D (EOT) end of transmission !! ctrl-E (ENQ) enquiry !! ctrl-F (ACK) acknowledge !! ctrl-G (BEL) bell !! ctrl-H (BS) backspace !! ctrl-I (HT) horizontal tabulation !! ctrl-J (LF) line feed !! ctrl-K (VT) vertical tabulation !! ctrl-L (FF) form feed !! ctrl-M (CR) carriage return !! ctrl-N (SO) shift out !! ctrl-O (SI) shift in !! ctrl-P (DLE) data link escape !! ctrl-Q (DC1) device control 1 !! ctrl-R (DC2) device control 2 !! ctrl-S (DC3) device control 3 !! ctrl-T (DC4) device control 4 !! ctrl-U (NAK) negative acknowledge !! ctrl-V (SYN) synchronous idle !! ctrl-W (ETB) end of transmission block !! ctrl-X (CAN) cancel !! ctrl-Y (EM) end of medium !! ctrl-Z (SUB) substitute !! ctrl-[ (ESC) escape !! ctrl-\ or ctrl-@ (FS) file separator !! ctrl-] (GS) group separator !! ctrl-^ or ctrl-= (RS) record separator !! ctrl-_ (US) unit separator !! space !! ! exclamation point !! " quotation marks !! # number sign !! $ currency symbol !! % percent !! & ampersand !! ' apostrophe !! ( left parenthesis !! ) right parenthesis !! * asterisk !! + plus !! , comma !! - minus !! . period !! / slash !! 0 zero !! 1 one !! 2 two !! 3 three !! 4 four !! 5 five !! 6 six !! 7 seven !! 8 eight !! 9 nine !! : colon !! ; semicolon !! < less than !! = equals !! > greater than !! ? question mark !! @ at sign !! majuscule A !! majuscule B !! majuscule C !! majuscule D !! majuscule E !! majuscule F !! majuscule G !! majuscule H !! majuscule I !! majuscule J !! majuscule K !! majuscule L !! majuscule M !! majuscule N !! majuscule O !! majuscule P !! majuscule Q !! majuscule R !! majuscule S !! majuscule T !! majuscule U !! majuscule V !! majuscule W !! majuscule X !! majuscule Y !! majuscule Z !! [ left bracket !! \ backslash !! ] right bracket !! ^ caret !! _ underscore !! ` grave accent !! miniscule a !! miniscule b !! miniscule c !! miniscule d !! miniscule e !! miniscule f !! miniscule g !! miniscule h !! miniscule i !! miniscule j !! miniscule k !! miniscule l !! miniscule m !! miniscule n !! miniscule o !! miniscule p !! miniscule q !! miniscule r !! miniscule s !! miniscule t !! miniscule u !! miniscule v !! miniscule w !! miniscule x !! miniscule y !! miniscule z !! { left brace !! | vertical line !! } right brace !! ~ tilde !! ctrl-? (DEL) delete !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function describe(ch) result (string) ! ident_62="@(#) M_strings describe(3f) return string describing long name of a single character" character(len=1),intent(in) :: ch character(len=:),allocatable :: string ! LATER: add hex, octal, decimal, key-press description, alternate names ! ASCII character codes select case (iachar(ch)) case( 0 ); STRING="ctrl-@ or ctrl-? (NUL) null" case( 1 ); STRING="ctrl-A (SOH) start of heading" case( 2 ); STRING="ctrl-B (STX) start of text" case( 3 ); STRING="ctrl-C (ETX) end of text" case( 4 ); STRING="ctrl-D (EOT) end of transmission" case( 5 ); STRING="ctrl-E (ENQ) enquiry" case( 6 ); STRING="ctrl-F (ACK) acknowledge" case( 7 ); STRING="ctrl-G (BEL) bell" case( 8 ); STRING="ctrl-H (BS) backspace" case( 9 ); STRING="ctrl-I (HT) horizontal tabulation" case( 10 ); STRING="ctrl-J (LF) line feed" case( 11 ); STRING="ctrl-K (VT) vertical tabulation" case( 12 ); STRING="ctrl-L (FF) form feed" case( 13 ); STRING="ctrl-M (CR) carriage return" case( 14 ); STRING="ctrl-N (SO) shift out" case( 15 ); STRING="ctrl-O (SI) shift in" case( 16 ); STRING="ctrl-P (DLE) data link escape" case( 17 ); STRING="ctrl-Q (DC1) device control 1" case( 18 ); STRING="ctrl-R (DC2) device control 2" case( 19 ); STRING="ctrl-S (DC3) device control 3" case( 20 ); STRING="ctrl-T (DC4) device control 4" case( 21 ); STRING="ctrl-U (NAK) negative acknowledge" case( 22 ); STRING="ctrl-V (SYN) synchronous idle" case( 23 ); STRING="ctrl-W (ETB) end of transmission block" case( 24 ); STRING="ctrl-X (CAN) cancel" case( 25 ); STRING="ctrl-Y (EM) end of medium" case( 26 ); STRING="ctrl-Z (SUB) substitute" case( 27 ); STRING="ctrl-[ (ESC) escape" case( 28 ); STRING="ctrl-\ or ctrl-@ (FS) file separator" case( 29 ); STRING="ctrl-] (GS) group separator" case( 30 ); STRING="ctrl-^ or ctrl-= (RS) record separator" case( 31 ); STRING="ctrl-_ (US) unit separator" case( 32 ); STRING="space" case( 33 ); STRING="! exclamation point (screamer, gasper, slammer, startler, bang, shriek, pling)" case( 34 ); STRING=""" quotation marks" case( 35 ); STRING="# number sign (hash, pound sign, hashtag)" case( 36 ); STRING="$ currency symbol" case( 37 ); STRING="% percent" case( 38 ); STRING="& ampersand" case( 39 ); STRING="' apostrophe" case( 40 ); STRING="( left parenthesis" case( 41 ); STRING=") right parenthesis" case( 42 ); STRING="* asterisk" case( 43 ); STRING="+ plus" case( 44 ); STRING=", comma" case( 45 ); STRING="- minus" case( 46 ); STRING=". period" case( 47 ); STRING="/ slash" case( 48 ); STRING="0 zero" case( 49 ); STRING="1 one" case( 50 ); STRING="2 two" case( 51 ); STRING="3 three" case( 52 ); STRING="4 four" case( 53 ); STRING="5 five" case( 54 ); STRING="6 six" case( 55 ); STRING="7 seven" case( 56 ); STRING="8 eight" case( 57 ); STRING="9 nine" case( 58 ); STRING=": colon" case( 59 ); STRING="; semicolon" case( 60 ); STRING="< less than" case( 61 ); STRING="= equals" case( 62 ); STRING="> greater than" case( 63 ); STRING="? question mark" case( 64 ); STRING="@ at (at cost of, at sign, each at, commercial at, commat, rollmop, monkey|pigs|elephant tail,& & snail, arroba, strudel, asperand, ampersat, rose, cabbage, swirl, whorl)" case( 65 ); STRING="A majuscule A" case( 66 ); STRING="B majuscule B" case( 67 ); STRING="C majuscule C" case( 68 ); STRING="D majuscule D" case( 69 ); STRING="E majuscule E" case( 70 ); STRING="F majuscule F" case( 71 ); STRING="G majuscule G" case( 72 ); STRING="H majuscule H" case( 73 ); STRING="I majuscule I" case( 74 ); STRING="J majuscule J" case( 75 ); STRING="K majuscule K" case( 76 ); STRING="L majuscule L" case( 77 ); STRING="M majuscule M" case( 78 ); STRING="N majuscule N" case( 79 ); STRING="O majuscule O" case( 80 ); STRING="P majuscule P" case( 81 ); STRING="Q majuscule Q" case( 82 ); STRING="R majuscule R" case( 83 ); STRING="S majuscule S" case( 84 ); STRING="T majuscule T" case( 85 ); STRING="U majuscule U" case( 86 ); STRING="V majuscule V" case( 87 ); STRING="W majuscule W" case( 88 ); STRING="X majuscule X" case( 89 ); STRING="Y majuscule Y" case( 90 ); STRING="Z majuscule Z" case( 91 ); STRING="[ left bracket" case( 92 ); STRING="\ backslash" case( 93 ); STRING="] right bracket" case( 94 ); STRING="^ caret" case( 95 ); STRING="_ underscore" case( 96 ); STRING="` grave accent" case( 97 ); STRING="a miniscule a" case( 98 ); STRING="b miniscule b" case( 99 ); STRING="c miniscule c" case( 100 ); STRING="d miniscule d" case( 101 ); STRING="e miniscule e" case( 102 ); STRING="f miniscule f" case( 103 ); STRING="g miniscule g" case( 104 ); STRING="h miniscule h" case( 105 ); STRING="i miniscule i" case( 106 ); STRING="j miniscule j" case( 107 ); STRING="k miniscule k" case( 108 ); STRING="l miniscule l" case( 109 ); STRING="m miniscule m" case( 110 ); STRING="n miniscule n" case( 111 ); STRING="o miniscule o" case( 112 ); STRING="p miniscule p" case( 113 ); STRING="q miniscule q" case( 114 ); STRING="r miniscule r" case( 115 ); STRING="s miniscule s" case( 116 ); STRING="t miniscule t" case( 117 ); STRING="u miniscule u" case( 118 ); STRING="v miniscule v" case( 119 ); STRING="w miniscule w" case( 120 ); STRING="x miniscule x" case( 121 ); STRING="y miniscule y" case( 122 ); STRING="z miniscule z" case( 123 ); STRING="{ left brace" case( 124 ); STRING="| vertical line" case( 125 ); STRING="} right brace" case( 126 ); STRING="~ tilde" case( 127 ); STRING="ctrl-? (DEL) delete" case default STRING='UNKNOWN'//v2s(IACHAR(ch)) end select end function describe !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! getvals(3f) - [M_strings:TYPE] read arbitrary number of REAL values !! from a character variable up to size of VALUES() array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine getvals(line,values,icount,ierr) !! !! character(len=*),intent(in) :: line !! class(*),intent(out) :: values(:) !! integer,intent(out) :: icount !! integer,intent(out),optional :: ierr !! !!##DESCRIPTION !! GETVALS(3f) reads a relatively arbitrary number of numeric values from !! a character variable into a REAL array using list-directed input. !! !! NOTE: In this version null values are skipped instead of meaning to leave !! that value unchanged !! !! 1,,,,,,,2 / reads VALUES=[1.0,2.0] !! !! Per list-directed rules when reading values, allowed delimiters are !! comma, semi-colon and space. !! !! the slash separator can be used to add inline comments. !! !! 10.1, 20.43e-1 ; 11 / THIS IS TREATED AS A COMMENT !! !! Repeat syntax can be used up to the size of the output array. These are !! equivalent input lines: !! !! 4*10.0 !! 10.0, 10.0, 10.0, 10.0 !! !!##OPTIONS !! LINE A character variable containing the characters representing !! a list of numbers !! !!##RETURNS !! VALUES() array holding numbers read from string. May be of type !! INTEGER, REAL, DOUBLEPRECISION, or CHARACTER. If CHARACTER the !! strings are returned as simple words instead of numeric values. !! ICOUNT number of defined numbers in VALUES(). If ICOUNT reaches !! the size of the VALUES() array parsing stops. !! IERR zero if no error occurred in reading numbers. Optional. !! If not present and an error occurs the program is terminated. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_getvals !! use M_strings, only: getvals !! implicit none !! integer,parameter :: longest_line=256 !! character(len=longest_line) :: line !! real :: values(longest_line/2+1) !! integer :: ios,icount,ierr !! INFINITE: do !! read(*,'(a)',iostat=ios) line !! if(ios /= 0)exit INFINITE !! call getvals(line,values,icount,ierr) !! write(*,'(4(g0,1x))')'VALUES=',values(:icount) !! enddo INFINITE !! end program demo_getvals !! !! Sample input lines !! !! 10,20 30.4 !! 1 2 3 !! 1 !! !! 3 4*2.5 8 !! 32.3333 / comment 1 !! 30e3;300, 30.0, 3 !! even 1 like this! 10 !! 11,,,,22,,,,33 !! !! Expected output: !! !! VALUES= 10.0000000 20.0000000 30.3999996 !! VALUES= 1.00000000 2.00000000 3.00000000 !! VALUES= 1.00000000 !! VALUES= !! VALUES= 3.00000000 2.50000000 2.50000000 !! 2.50000000 2.50000000 8.00000000 !! VALUES= 32.3333015 !! VALUES= 30000.0000 300.000000 30.0000000 !! 3.00000000 !! *getvals* WARNING:[even] is not a number !! *getvals* WARNING:[like] is not a number !! *getvals* WARNING:[this!] is not a number !! VALUES= 1.00000000 10.0000000 !! VALUES= 11.0000000 22.0000000 33.0000000 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine getvals(line,values,icount,ierr) ! ident_63="@(#) M_strings getvals(3f) read arbitrary number of values from a character variable" ! JSU 20170831 character(len=*),intent(in) :: line class(*),intent(out) :: values(:) integer,intent(out) :: icount integer,intent(out),optional :: ierr character(len=:),allocatable :: buffer character(len=len(line)) :: words(size(values)) integer :: ios, i, ierr_local,isize isize=0 select type(values) type is (integer); isize=size(values) type is (real); isize=size(values) type is (doubleprecision); isize=size(values) type is (character(len=*)); isize=size(values) end select ierr_local=0 words=' ' ! make sure words() is initialized to null+blanks buffer=trim(unquote(line))//"/" ! add a slash to the end so how the read behaves with missing values is clearly defined read(buffer,*,iostat=ios) words ! undelimited strings are read into an array icount=0 do i=1,isize ! loop thru array and convert non-blank words to numbers if(words(i) == ' ')cycle select type(values) type is (integer); read(words(i),*,iostat=ios)values(icount+1) type is (real); read(words(i),*,iostat=ios)values(icount+1) type is (doubleprecision); read(words(i),*,iostat=ios)values(icount+1) type is (character(len=*)); values(icount+1)=words(i) end select if(ios == 0)then icount=icount+1 else ierr_local=ios write(ERROR_UNIT,*)'*getvals* WARNING:['//trim(words(i))//'] is not a number of specified type' endif enddo if(present(ierr))then ierr=ierr_local elseif(ierr_local /= 0)then ! error occurred and not returning error to main program to print message and stop program write(ERROR_UNIT,*)'*getval* error reading line ['//trim(line)//']' stop 2 endif end subroutine getvals !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! string_to_values(3f) - [M_strings:TYPE] read a string representing !! numbers into a numeric array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine string_to_values(line,iread,values,inums,delims,ierr) !! !! character(len=*) :: line !! integer :: iread !! real :: values(*) !! integer :: inums !! character(len=*) :: delims !! integer :: ierr !! !!##DESCRIPTION !! This routine can take a string representing a series of numbers and !! convert it to a numeric array and return how many numbers were found. !! !!##OPTIONS !! LINE Input string containing numbers !! IREAD maximum number of values to try to read from input string !! !!##RESULTS !! VALUES real array to be filled with numbers !! INUMS number of values successfully read (before error occurs !! if one does) !! DELIMS delimiter character(s), usually a space. must not be a !! null string. If more than one character, a space must !! not be the last character or it will be ignored. !! IERR error flag (0=no error, else column number string starts !! at that error occurred on). !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_string_to_values !! use M_strings, only : string_to_values !! implicit none !! character(len=80) :: s=' 10 20e3;3.45 -400.3e-2;1234; 5678 ' !! integer,parameter :: isz=10 !! real :: array(isz) !! integer :: inums, ierr, ii !! !! call string_to_values(s,10,array,inums,' ;',ierr) !! call reportit() !! !! call string_to_values('10;2.3;3.1416',isz,array,inums,' ;',ierr) !! call reportit() !! !! contains !! subroutine reportit() !! write(*,*)'string_to_values:' !! write(*,*)'input string.............',trim(s) !! write(*,*)'number of values found...',inums !! write(*,*)'values...................',(array(ii),ii=1,inums) !! end subroutine reportit !! end program demo_string_to_values !! !! Expected output !! !! string_to_values: !! input string............. 10 20e3;3.45 -400.3e-2;1234; 5678 !! number of values found... 6 !! values................... 10.0000000 20000.0000 3.45000005 !! -4.00299978 1234.00000 5678.00000 !! string_to_values: !! input string............. 10 20e3;3.45 -400.3e-2;1234; 5678 !! number of values found... 3 !! values................... 10.0000000 2.29999995 3.14159989 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine string_to_values(line,iread,values,inums,delims,ierr) !---------------------------------------------------------------------------------------------------------------------------------- ! 1989,1997-12-31,2014 John S. Urban ! given a line of structure , string , string , string process each ! string as a numeric value and store into an array. ! DELIMS contain the legal delimiters. If a space is an allowed delimiter, it must not appear last in DELIMS. ! There is no direct checking for more values than can fit in VALUES. ! Quits if encounters any errors in read. !---------------------------------------------------------------------------------------------------------------------------------- ! ident_64="@(#) M_strings string_to_values(3f) reads an array of numbers from a numeric string" character(len=*),intent(in) :: line ! input string integer,intent(in) :: iread ! maximum number of values to try to read into values real,intent(inout) :: values(iread) ! real array to be filled with values integer,intent(out) :: inums ! number of values successfully read from string character(len=*),intent(in) :: delims ! allowed delimiters integer,intent(out) :: ierr ! 0 if no error, else column number undecipherable string starts at !---------------------------------------------------------------------------------------------------------------------------------- character(len=256) :: delims_local ! mutable copy of allowed delimiters integer :: istart,iend,lgth,icol integer :: i10,i20,i40 real :: rval integer :: ier integer :: delimiters_length !---------------------------------------------------------------------------------------------------------------------------------- delims_local=delims ! need a mutable copy of the delimiter list if(delims_local == '')then ! if delimiter list is null or all spaces make it a space delims_local=' ' ! delimiter is a single space delimiters_length=1 ! length of delimiter list else delimiters_length=len_trim(delims) ! length of variable WITH TRAILING WHITESPACE TRIMMED endif !---------------------------------------------------------------------------------------------------------------------------------- ierr=0 ! initialize error code returned inums=0 ! initialize count of values successfully returned istart=0 !---------------------------------------------------------------------------------------------------------------------------------- lgth=0 ! lgth will be the position of the right-most non-delimiter in the input line do i20=len(line),1,-1 ! loop from end of string to beginning to find right-most non-delimiter if(index(delims_local(:delimiters_length),line(i20:i20)) == 0)then ! found a non-delimiter lgth=i20 exit endif enddo if(lgth == 0)then ! command was totally composed of delimiters call journal('*string_to_values* blank line passed as a list of numbers') return endif !---------------------------------------------------------------------------------------------------------------------------------- ! there is at least one non-delimiter sub-string ! lgth is the column position of the last non-delimiter character ! now, starting at beginning of string find next non-delimiter icol=1 ! pointer to beginning of unprocessed part of LINE LOOP: dO i10=1,iread,1 ! each pass should find a value if(icol > lgth) EXIT LOOP ! everything is done INFINITE: do if(index(delims_local(:delimiters_length),line(icol:icol)) == 0)then ! found non-delimiter istart=icol iend=0 ! FIND END OF SUBSTRING do i40=istart,lgth ! look at each character starting at left if(index(delims_local(:delimiters_length),line(i40:i40)) /= 0)then ! determine if character is a delimiter iend=i40 ! found a delimiter. record where it was found EXIT ! found end of substring so leave loop endif enddo if(iend == 0)iend=lgth+1 ! no delimiters found, so this substring goes to end of line iend=iend-1 ! do not want to pass delimiter to be converted rval=0.0 call string_to_value(line(istart:iend),rval,ier) ! call procedure to convert string to a numeric value if(ier == 0)then ! a substring was successfully converted to a numeric value values(i10)=rval ! store numeric value in return array inums=inums+1 ! increment number of values converted to a numeric value else ! an error occurred converting string to value ierr=istart ! return starting position of substring that could not be converted return endif icol=iend+2 ! set to next character to look at CYCLE LOOP ! start looking for next value else ! this is a delimiter so keep looking for start of next string icol=icol+1 ! increment pointer into LINE CYCLE INFINITE endif enddo INFINITE enddo LOOP ! error >>>>> more than iread numbers were in the line. end subroutine string_to_values !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! s2vs(3f) - [M_strings:TYPE] given a string representing numbers !! return a numeric array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function s2vs(line[,delim]) !! !! character(len=*) :: line !! doubleprecision,allocatable :: s2vs(:) !! !!##DESCRIPTION !! The function S2VS(3f) takes a string representing a series of numbers !! and converts it to a numeric doubleprecision array. The string values !! may be delimited by spaces, semi-colons, and commas by default. !! !!##OPTIONS !! LINE Input string containing numbers !! DELIM optional list of delimiter characters. If a space is !! included, it should appear as the left-most character !! in the list. The default is " ;," (spaces, semi-colons, !! and commas). !! !!##RESULTS !! S2VS doubleprecision array !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_s2vs !! use M_strings, only : s2vs !! implicit none !! character(len=80) :: s=' 10 20e3;3.45 -400.3e-2;1234; 5678 ' !! real,allocatable :: values(:) !! integer,allocatable :: ivalues(:) !! integer :: ii !! !! values=s2vs(s) !! ivalues=int(s2vs(s)) !! call reportit() !! !! contains !! subroutine reportit() !! write(*,*)'S2VS:' !! write(*,*)'input string.............',& !! & trim(s) !! write(*,*)'number of values found...',& !! & size(values) !! write(*,*)'values...................',& !! & (values(ii),ii=1,size(values)) !! write(*,'(*(g0,1x))')'ivalues..................',& !! & (ivalues(ii),ii=1,size(values)) !! end subroutine reportit !! end program demo_s2vs !! !! Expected output !! !! S2VS: !! input string............. 10 20e3;3.45 -400.3e-2;1234; 5678 !! number of values found... 6 !! values................... 10.0000000 20000.0000 3.45000005 !! -4.00299978 1234.00000 5678.00000 !! ivalues.................. 10 20000 3 -4 1234 5678 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function s2vs(string,delim) result(darray) ! ident_65="@(#) M_strings s2vs(3f) function returns array of values from a string" character(len=*),intent(in) :: string ! keyword to retrieve value for from dictionary character(len=*),optional :: delim ! delimiter characters character(len=:),allocatable :: delim_local doubleprecision,allocatable :: darray(:) ! function type character(len=:),allocatable :: carray(:) ! convert value to an array using split(3f) integer :: i integer :: ier !----------------------------------------------------------------------------------------------------------------------------------- if(present(delim))then delim_local=delim else delim_local=' ;,' endif !----------------------------------------------------------------------------------------------------------------------------------- call split(string,carray,delimiters=delim_local) ! split string into an array allocate(darray(size(carray))) ! create the output array do i=1,size(carray) call string_to_value(carray(i), darray(i), ier) ! convert the string to a numeric value enddo !----------------------------------------------------------------------------------------------------------------------------------- end function s2vs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isprint(3f) - [M_strings:COMPARE] returns .true. if character is an !! ASCII printable character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isprint(onechar) !! !! character,intent(in) :: onechar !! logical :: isprint !! !!##DESCRIPTION !! isprint(3f) returns .true. if character is an ASCII printable character !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isprint logical value returns true if character is a !! printable ASCII character else false. !!##EXAMPLE !! !! Sample Program: !! !! program demo_isprint !! use M_strings, only : isprint !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISPRINT: ',pack( string, isprint(string) ) !! end program demo_isprint !! !! Results: !! !! ISPRINT: !"#$%&'()*+,-./0123456789:;<=>?@ABCDEF !! GHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmn !! opqrstuvwxyz{|}~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isprint(onechar) ! ident_66="@(#) M_strings isprint(3f) indicates if input character is a printable ASCII character" character,intent(in) :: onechar logical :: isprint select case (onechar) case (' ':'~') ; isprint=.TRUE. case default ; isprint=.FALSE. end select end function isprint !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isgraph(3f) - [M_strings:COMPARE] returns .true. if character is a !! printable character except a space is considered non-printable !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isgraph(onechar) !! !! character,intent(in) :: onechar !! logical :: isgraph !! !!##DESCRIPTION !! isgraph(3f) returns .true. if character is a printable character !! except a space is considered non-printable !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isgraph logical value returns true if character is a printable !! non-space character !!##EXAMPLE !! !! Sample Program: !! !! program demo_isgraph !! use M_strings, only : isgraph !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISGRAPH: ',pack( string, isgraph(string) ) !! end program demo_isgraph !! !! Results: !! !! ISGRAPH: !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFG !! HIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmno !! pqrstuvwxyz{|}~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isgraph(onechar) ! ident_67="@(#) M_strings isgraph(3f) indicates if character is printable ASCII character excluding space" character,intent(in) :: onechar logical :: isgraph select case (iachar(onechar)) case (33:126) isgraph=.TRUE. case default isgraph=.FALSE. end select end function isgraph !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isalpha(3f) - [M_strings:COMPARE] returns .true. if character is a !! letter and .false. otherwise !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isalpha(onechar) !! !! character,intent(in) :: onechar !! logical :: isalpha !! !!##DESCRIPTION !! isalpha(3f) returns .true. if character is a letter and !! .false. otherwise !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isalpha logical value returns .true. if character is a ASCII letter !! or false otherwise. !!##EXAMPLE !! !! !! Sample program !! !! program demo_isalpha !! use M_strings, only : isalpha !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISGRAPH: ',pack( string, isalpha(string) ) !! end program demo_isalpha !! !! Results: !! !! ISGRAPH: ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklm !! nopqrstuvwxyz !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isalpha(ch) result(res) ! ident_68="@(#) M_strings isalpha(3f) Return .true. if character is a letter and .false. otherwise" character,intent(in) :: ch logical :: res select case(ch) case('A':'Z','a':'z') res=.true. case default res=.false. end select end function isalpha !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isxdigit(3f) - [M_strings:COMPARE] returns .true. if character is a !! hexadecimal digit (0-9, a-f, or A-F). !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isxdigit(onechar) !! !! character,intent(in) :: onechar !! logical :: isxdigit !! !!##DESCRIPTION !! isxdigit(3f) returns .true. if character is a hexadecimal digit (0-9, !! a-f, or A-F). !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isxdigit logical value returns true if character is a hexadecimal digit !! !!##EXAMPLE !! !! Sample program !! !! program demo_isxdigit !! use M_strings, only : isxdigit !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISXDIGIT: ',pack( string, isxdigit(string) ) !! end program demo_isxdigit !! !! Results: !! !! ISXDIGIT: 0123456789ABCDEFabcdef !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isxdigit(ch) result(res) ! ident_69="@(#) M_strings isxdigit(3f) returns .true. if c is a hexadecimal digit (0-9 a-f or A-F)" character,intent(in) :: ch logical :: res select case(ch) case('A':'F','a':'f','0':'9') res=.true. case default res=.false. end select end function isxdigit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isdigit(3f) - [M_strings:COMPARE] returns .true. if character is a !! digit (0,1,...,9) and .false. otherwise !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isdigit(onechar) !! !! character,intent(in) :: onechar !! logical :: isdigit !! !!##DESCRIPTION !! isdigit(3f) returns .true. if character is a digit (0,1,...,9) !! and .false. otherwise !! !!##EXAMPLES !! !! !! Sample Program: !! !! program demo_isdigit !! use M_strings, only : isdigit, isspace, switch !! implicit none !! character(len=10),allocatable :: string(:) !! integer :: i !! string=[& !! & '1 2 3 4 5 ' ,& !! & 'letters ' ,& !! & '1234567890' ,& !! & 'both 8787 ' ] !! ! if string is nothing but digits and whitespace return .true. !! do i=1,size(string) !! write(*,'(a)',advance='no')'For string['//string(i)//']' !! write(*,*) & !! & all(isdigit(switch(string(i))).or.& !! & isspace(switch(string(i)))) !! enddo !! end program demo_isdigit !! !! Expected output: !! !! For string[1 2 3 4 5 ] T !! For string[letters ] F !! For string[1234567890] T !! For string[both 8787 ] F !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isdigit(ch) result(res) ! ident_70="@(#) M_strings isdigit(3f) Returns .true. if ch is a digit (0-9) and .false. otherwise" character,intent(in) :: ch logical :: res select case(ch) case('0':'9') res=.true. case default res=.false. end select end function isdigit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isblank(3f) - [M_strings:COMPARE] returns .true. if character is a !! blank character (space or horizontal tab). !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isblank(onechar) !! !! character,intent(in) :: onechar !! logical :: isblank !! !!##DESCRIPTION !! isblank(3f) returns .true. if character is a blank character (space !! or horizontal tab). !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isblank logical value returns true if character is a "blank" !! ( an ASCII space or horizontal tab character). !!##EXAMPLE !! !! Sample program: !! !! program demo_isblank !! use M_strings, only : isblank !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(*(g0,1x))')'ISXBLANK: ',& !! & iachar(pack( string, isblank(string) )) !! end program demo_isblank !! !! Results: !! !! ISXBLANK: 9 32 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isblank(ch) result(res) ! ident_71="@(#) M_strings isblank(3f) returns .true. if character is a blank (space or horizontal tab)" character,intent(in) :: ch logical :: res select case(ch) case(' ',char(9)) res=.true. case default res=.false. end select end function isblank !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isascii(3f) - [M_strings:COMPARE] returns .true. if the character is !! in the range char(0) to char(256) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isascii(onechar) !! !! character,intent(in) :: onechar !! logical :: isascii !! !!##DESCRIPTION !! isascii(3f) returns .true. if the character is in the range char(0) !! to char(127) !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isupper logical value returns true if character is an ASCII !! character. !!##EXAMPLE !! !! Sample program !! !! program demo_isascii !! use M_strings, only : isascii !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,255)] !! write(*,'(10(g0,1x))')'ISASCII: ', & !! & iachar(pack( string, isascii(string) )) !! end program demo_isascii !! !! Results: !! !! ISASCII: 0 1 2 3 4 5 6 7 8 !! 9 10 11 12 13 14 15 16 17 18 !! 19 20 21 22 23 24 25 26 27 28 !! 29 30 31 32 33 34 35 36 37 38 !! 39 40 41 42 43 44 45 46 47 48 !! 49 50 51 52 53 54 55 56 57 58 !! 59 60 61 62 63 64 65 66 67 68 !! 69 70 71 72 73 74 75 76 77 78 !! 79 80 81 82 83 84 85 86 87 88 !! 89 90 91 92 93 94 95 96 97 98 !! 99 100 101 102 103 104 105 106 107 108 !! 109 110 111 112 113 114 115 116 117 118 !! 119 120 121 122 123 124 125 126 127 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isascii(ch) result(res) ! ident_72="@(#) M_strings isascii(3f) returns .true. if character is in the range char(0) to char(127)" character,intent(in) :: ch logical :: res select case(iachar(ch)) case(0:127) res=.true. case default res=.false. end select end function isascii !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isspace(3f) - [M_strings:COMPARE] returns .true. if character is a !! null, space, tab, carriage return, new line, vertical tab, or formfeed !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isspace(onechar) !! !! character,intent(in) :: onechar !! logical :: isspace !! !!##DESCRIPTION !! isspace(3f) returns .true. if character is a null, space, tab, !! carriage return, new line, vertical tab, or formfeed !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isspace returns true if character is ASCII white space !! !!##EXAMPLE !! !! Sample program: !! !! program demo_isspace !! use M_strings, only : isspace !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(20(g0,1x))')'ISSPACE: ', & !! & iachar(pack( string, isspace(string) )) !! end program demo_isspace !! !! Results: !! !! ISSPACE: 0 9 10 11 12 13 32 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isspace(ch) result(res) ! ident_73="@(#) M_strings isspace(3f) true if null space tab return new line vertical tab or formfeed" character,intent(in) :: ch logical :: res select case(ch) case(' ') ! space(32) res=.true. case(char(0)) ! null(0) res=.true. case(char(9):char(13)) ! tab(9), new line(10), vertical tab(11), formfeed(12), carriage return(13), res=.true. case default res=.false. end select end function isspace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! iscntrl(3f) - [M_strings:COMPARE] returns .true. if character is a !! delete character or ordinary control character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function iscntrl(onechar) !! !! character,intent(in) :: onechar !! logical :: iscntrl !! !!##DESCRIPTION !! iscntrl(3f) returns .true. if character is a delete character or !! ordinary control character !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! iscntrl logical value returns true if character is a control character !! !!##EXAMPLE !! !! Sample program !! !! program demo_iscntrl !! use M_strings, only : iscntrl !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(20(g0,1x))')'ISCNTRL: ', & !! & iachar(pack( string, iscntrl(string) )) !! end program demo_iscntrl !! !! Results: !! !! ISCNTRL: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 !! 20 21 22 23 24 25 26 27 28 29 30 31 127 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function iscntrl(ch) result(res) ! ident_74="@(#) M_strings iscntrl(3f) true if a delete or ordinary control character(0x7F or 0x00-0x1F)" character,intent(in) :: ch logical :: res select case(ch) case(char(127),char(0):char(31)) res=.true. case default res=.false. end select end function iscntrl !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! ispunct(3f) - [M_strings:COMPARE] returns .true. if character is a !! printable punctuation character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function ispunct(onechar) !! !! character,intent(in) :: onechar !! logical :: ispunct !! !!##DESCRIPTION !! ispunct(3f) returns .true. if character is a printable punctuation !! character !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! ispunct logical value returns true if character is a printable !! punctuation character. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_ispunct !! use M_strings, only : ispunct !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(20(g0,1x))')'ISPUNCT: ', & !! & iachar(pack( string, ispunct(string) )) !! write(*,'(20(g0,1x))')'ISPUNCT: ', & !! & pack( string, ispunct(string) ) !! end program demo_ispunct !! Results: !! !! ISPUNCT: 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 58 59 60 61 !! 62 63 64 91 92 93 94 95 96 123 124 125 126 !! ISPUNCT: ! " # $ % & ' ( ) * + , - . / : ; < = !! > ? @ [ \ ] ^ _ ` { | } ~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function ispunct(ch) result(res) ! ident_75="@(#) M_strings ispunct(3f) true if a printable punctuation character (isgraph(c)&&!isalnum(c))" character,intent(in) :: ch logical :: res select case(ch) case (char(33):char(47), char(58):char(64), char(91):char(96), char(123):char(126)) res=.true. ! case(' ','0':'9','A':'Z','a':'z',char(128):) ! res=.true. ! case(char(0):char(31),char(127)) ! res=.true. case default res=.false. end select end function ispunct !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! fortran_name(3f) - [M_strings:COMPARE] test if string meets criteria !! for being a fortran name !! !!##SYNOPSIS !! !! !! elemental function fortran_name(line) result (lout) !! !! character(len=*),intent(in) :: line !! logical :: lout !! !!##DESCRIPTION !! Determines if a string is an allowed Fortran name. To pass the input !! string must be composed of 1 to 63 ASCII characters and start with a !! letter and be composed entirely of alphanumeric characters [a-zA-Z0-9] !! and underscores. !! !!##OPTIONS !! LINE input string to test. Leading spaces are significant but !! trailing spaces are ignored. !! !!##RETURNS !! LOUT a logical value indicating if the input string passed or failed !! the test to see if it is a valid Fortran name or not. !! !!##EXAMPLE !! !! Sample program !! !! program demo_fortran_name !! use M_strings, only : fortran_name !! implicit none !! character(len=20),parameter :: names(*)=[character(len=20) :: & !! & '_name', 'long_variable_name', 'name_', & !! & '12L', 'a__b__c ', 'PropertyOfGas', & !! & '3%3', '$NAME', ' ', & !! & 'Variable-name', 'A', 'x@x' ] !! integer :: i !! write(*,'(i3,1x,a20,1x,l1)')& !! & (i,names(i),fortran_name(names(i)),i=1,size(names)) !! end program demo_fortran_name !! !! Results: !! !! > 1 _name F !! > 2 long_variable_name T !! > 3 name_ T !! > 4 12L F !! > 5 a__b__c T !! > 6 PropertyOfGas T !! > 7 3%3 F !! > 8 $NAME F !! > 9 F !! > 10 Variable-name F !! > 11 A T !! > 12 x@x F elemental function fortran_name(line) result (lout) ! ident_76="@(#) M_strings fortran_name(3f) Return .true. if name is a valid Fortran name" ! determine if a string is a valid Fortran name ignoring trailing spaces (but not leading spaces) character(len=*),parameter :: int='0123456789' character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' character(len=*),parameter :: allowed=upper//lower//int//'_' character(len=*),intent(in) :: line character(len=:),allocatable :: name logical :: lout name=trim(line) if(len(name) /= 0)then lout = verify(name(1:1), lower//upper) == 0 & & .and. verify(name,allowed) == 0 & & .and. len(name) <= 63 else lout = .false. endif end function fortran_name !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isupper(3f) - [M_strings:COMPARE] returns .true. if character is an !! uppercase letter (A-Z) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isupper(onechar) !! !! character,intent(in) :: onechar !! logical :: isupper !! !!##DESCRIPTION !! isupper(3f) returns .true. if character is an uppercase letter (A-Z) !! !!##OPTIONS !! onechar character to test !!##RETURNS !! isupper logical value returns true if character is an uppercase !! ASCII character else false. !!##EXAMPLE !! !! Sample program: !! !! program demo_isupper !! use M_strings, only : isupper !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(10(g0,1x))')'ISUPPER: ', & !! & iachar(pack( string, isupper(string) )) !! write(*,'(10(g0,1x))')'ISUPPER: ', & !! & pack( string, isupper(string) ) !! end program demo_isupper !! !! Results: !! !! ISUPPER: 65 66 67 68 69 70 71 72 73 !! 74 75 76 77 78 79 80 81 82 83 !! 84 85 86 87 88 89 90 !! ISUPPER: A B C D E F G H I !! J K L M N O P Q R S !! T U V W X Y Z !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure elemental function isupper(ch) result(res) ! ident_77="@(#) M_strings isupper(3f) returns true if character is an uppercase letter (A-Z)" character,intent(in) :: ch logical :: res select case(ch) case('A':'Z'); res=.true. case default; res=.false. end select end function isupper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! islower(3f) - [M_strings:COMPARE] returns .true. if character is a !! miniscule letter (a-z) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function islower(onechar) !! !! character,intent(in) :: onechar !! logical :: islower !! !!##DESCRIPTION !! islower(3f) returns .true. if character is a miniscule letter (a-z) !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! islower logical value returns true if character is a lowercase !! ASCII character else false. !!##EXAMPLE !! !! Sample program !! !! program demo_islower !! use M_strings, only : islower !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(15(g0,1x))')'ISLOWER: ', & !! & iachar(pack( string, islower(string) )) !! write(*,'(15(g0,1x))')'ISLOWER: ', & !! & pack( string, islower(string) ) !! end program demo_islower !! Results: !! !! ISLOWER: 97 98 99 100 101 102 103 104 105 106 107 108 109 110 !! 111 112 113 114 115 116 117 118 119 120 121 122 !! ISLOWER: a b c d e f g h i j k l m n !! o p q r s t u v w x y z !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function islower(ch) result(res) ! ident_78="@(#) M_strings islower(3f) returns true if character is a miniscule letter (a-z)" character,intent(in) :: ch logical :: res select case(ch) case('a':'z'); res=.true. case default; res=.false. end select end function islower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isalnum,isalpha,iscntrl,isdigit,isgraph,islower, !! isprint,ispunct,isspace,isupper, !! isascii,isblank,isxdigit(3f) - [M_strings:COMPARE] test membership in !! subsets of ASCII set !! (LICENSE:PD) !! !!##SYNOPSIS !! !! Where "FUNCNAME" is one of the function names in the group, the !! functions are defined by !! !! elemental function FUNCNAME(onechar) !! character,intent(in) :: onechar !! logical :: FUNC_NAME !!##DESCRIPTION !! !! These elemental functions test if a character belongs to various !! subsets of the ASCII character set. !! !! isalnum returns .true. if character is a letter (a-z,A-Z) !! or digit (0-9) !! isalpha returns .true. if character is a letter and !! .false. otherwise !! isascii returns .true. if character is in the range char(0) !! to char(127) !! isblank returns .true. if character is a blank (space or !! horizontal tab). !! iscntrl returns .true. if character is a delete character or !! ordinary control character (0x7F or 0x00-0x1F). !! isdigit returns .true. if character is a digit (0,1,...,9) !! and .false. otherwise !! isgraph returns .true. if character is a printable ASCII !! character excluding space !! islower returns .true. if character is a miniscule letter (a-z) !! isprint returns .true. if character is a printable ASCII character !! ispunct returns .true. if character is a printable punctuation !! character (isgraph(c) && !isalnum(c)). !! isspace returns .true. if character is a null, space, tab, !! carriage return, new line, vertical tab, or formfeed !! isupper returns .true. if character is an uppercase letter (A-Z) !! isxdigit returns .true. if character is a hexadecimal digit !! (0-9, a-f, or A-F). !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_isdigit !! !! use M_strings, only : isdigit, isspace, switch !! implicit none !! character(len=10),allocatable :: string(:) !! integer :: i !! string=[& !! & '1 2 3 4 5 ' ,& !! & 'letters ' ,& !! & '1234567890' ,& !! & 'both 8787 ' ] !! ! if string is nothing but digits and whitespace return .true. !! do i=1,size(string) !! write(*,'(a)',advance='no')'For string['//string(i)//']' !! write(*,*) & !! all(isdigit(switch(string(i))) .or. & !! & isspace(switch(string(i)))) !! enddo !! !! end program demo_isdigit !! !! Expected output: !! !! For string[1 2 3 4 5 ] T !! For string[letters ] F !! For string[1234567890] T !! For string[both 8787 ] F !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain elemental function isalnum(ch) result(res) ! ident_79="@(#) M_strings isalnum(3f) returns true if character is a letter (a-z A-Z) or digit(0-9)" character,intent(in) :: ch logical :: res select case(ch) case('a':'z','A':'Z','0':'9') res=.true. case default res=.false. end select end function isalnum !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! base(3f) - [M_strings:BASE] convert whole number string in base [2-36] !! to string in alternate base [2-36] !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental impure logical function base(x,b,y,a) !! !! character(len=*),intent(in) :: x !! character(len=*),intent(out) :: y !! integer,intent(in) :: b,a !!##DESCRIPTION !! !! Convert a numeric string from base B to base A. The function returns !! FALSE if B is not in the range [2..36] or if string X contains invalid !! characters in base B or if result Y is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in a base > 10. !! !!##OPTIONS !! x input string representing numeric whole value !! b assumed base of input string !! y output string !! a base specified for output string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_base !! use M_strings, only : base !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! !! print *,' BASE CONVERSION' !! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd !! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba !! INFINITE: do !! write(*,'("Enter number in start base (0 to quit): ")',advance='no') !! read *, x !! if(x == '0') exit INFINITE !! if(base(x,bd,y,ba))then !! write(*,'("In base ",I2,": ",A20)') ba, y !! else !! print *,'Error in decoding/encoding number.' !! endif !! enddo INFINITE !! !! end program demo_base !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain elemental impure logical function base(x, b, y, a) character(len=*), intent(in) :: x character(len=*), intent(out) :: y integer, intent(in) :: b, a integer :: temp ! ident_80="@(#) M_strings base(3f) convert whole number string in base [2-36] to string in alternate base [2-36]" base = .true. if (decodebase(x, b, temp)) then if (codebase(temp, a, y)) then else print *, 'Error in coding number.' base = .false. endif else print *, 'Error in decoding number.' base = .false. endif end function base !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! base2(3f) - [M_strings:BASE] convert whole number to string in base 2 !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function base2(int) !! !! integer,intent(in) :: int !! character(len=:),allocatable :: base2 !! !!##DESCRIPTION !! !! Convert a whole number to a string in base 2. !! !! This is often done with the B edit descriptor and !! an internal WRITE() statement, but is done without !! calling the I/O routines, and as a function. !! !!##OPTIONS !! int input string representing numeric whole value !!##RETURNS !! base2 string representing input value in base 2 !!##EXAMPLE !! !! Sample program: !! !! program demo_base2 !! use M_strings, only : base2 !! implicit none !! write(*,'(a)') base2(huge(0)) !! write(*,'(a)') base2(0) !! write(*,'(a)') base2(64) !! write(*,'(a)') base2(-64) !! write(*,'(a)') base2(-huge(0)-1) !! end program demo_base2 !! Results: !! !! > 1111111111111111111111111111111 !! > 0 !! > 1000000 !! > 11111111111111111111111111000000 !! > 10000000000000000000000000000000 !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function base2(x) result(str) ! return string representing number as a binary number. Fixed-length string: integer, intent(in) :: x integer :: i character(len=max(1,bit_size(x)-leadz(x))) :: str associate(n => len(str)) str = repeat('0',n) do i = 0,n-1 if (btest(x,i)) str(n-i:n-i) = '1' end do end associate end function base2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! decodebase(3f) - [M_strings:BASE] convert whole number string in base !! [2-36] to base 10 number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function decodebase(string,basein,out10) !! !! character(len=*),intent(in) :: string !! integer,intent(in) :: basein !! integer,intent(out) :: out10 !!##DESCRIPTION !! !! Convert a numeric string representing a whole number in base BASEIN !! to base 10. The function returns FALSE if BASEIN is not in the range !! [2..36] or if string STRING contains invalid characters in base BASEIN !! or if result OUT10 is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##OPTIONS !! string input string. It represents a whole number in !! the base specified by BASEIN unless BASEIN is set !! to zero. When BASEIN is zero STRING is assumed to !! be of the form BASE#VALUE where BASE represents !! the function normally provided by BASEIN. !! basein base of input string; either 0 or from 2 to 36. !! out10 output value in base 10 !! !!##EXAMPLE !! !! Sample program: !! !! program demo_decodebase !! use M_strings, only : codebase, decodebase !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! integer :: r !! !! print *,' BASE CONVERSION' !! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd !! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba !! INFINITE: do !! print *,'' !! write(*,'("Enter number in start base: ")',advance='no'); read *, x !! if(x == '0') exit INFINITE !! if(decodebase(x,bd,r)) then !! if(codebase(r,ba,y)) then !! write(*,'("In base ",I2,": ",A20)') ba, y !! else !! print *,'Error in coding number.' !! endif !! else !! print *,'Error in decoding number.' !! endif !! enddo INFINITE !! !! end program demo_decodebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: "Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function decodebase(string,basein,out_baseten) ! ident_81="@(#) M_strings decodebase(3f) convert whole number string in base [2-36] to base 10 number" character(len=*),intent(in) :: string integer,intent(in) :: basein integer,intent(out) :: out_baseten character(len=len(string)) :: string_local integer :: long, i, j, k real :: y real :: mult character(len=1) :: ch real,parameter :: XMAXREAL=real(huge(1)) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local=upper(trim(adjustl(string))) decodebase=.false. ipound=index(string_local,'#') ! determine if in form [-]base#whole if(basein == 0.and.ipound > 1)then ! split string into two values call string_to_value(string_local(:ipound-1),basein_local,ierr) ! get the decimal value of the base string_local=string_local(ipound+1:) ! now that base is known make string just the value if(basein_local >= 0)then ! allow for a negative sign prefix out_sign=1 else out_sign=-1 endif basein_local=abs(basein_local) else ! assume string is a simple positive value basein_local=abs(basein) out_sign=1 endif out_baseten=0 y=0.0 ALL: if(basein_local<2.or.basein_local>36) then print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local else ALL out_baseten=0;y=0.0; mult=1.0 long=LEN_TRIM(string_local) do i=1, long k=long+1-i ch=string_local(k:k) if(ch == '-'.and.k == 1)then out_sign=-1 cycle endif if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then write(*,*)'*decodebase* ERROR: invalid character ',ch exit ALL endif if(ch<='9') then j=IACHAR(ch)-IACHAR('0') else j=IACHAR(ch)-IACHAR('A')+10 endif if(j>=basein_local)then exit ALL endif y=y+mult*j if(mult>XMAXREAL/basein_local)then exit ALL endif mult=mult*basein_local enddo decodebase=.true. out_baseten=nint(out_sign*y)*sign(1,basein) endif ALL end function decodebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! codebase(3f) - [M_strings:BASE] convert whole number in base 10 to !! string in base [2-36] !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function codebase(in_base10,out_base,answer) !! !! integer,intent(in) :: in_base10 !! integer,intent(in) :: out_base !! character(len=*),intent(out) :: answer !! !!##DESCRIPTION !! Convert a number from base 10 to base OUT_BASE. The function returns !! .FALSE. if OUT_BASE is not in [2..36] or if number IN_BASE10 is !! too big. !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_codebase !! use M_strings, only : codebase !! implicit none !! character(len=20) :: answer !! integer :: i, j !! logical :: ierr !! do j=1,100 !! do i=2,36 !! ierr=codebase(j,i,answer) !! write(*,*)'VALUE=',j,' BASE=',i,' ANSWER=',answer !! enddo !! enddo !! end program demo_codebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: "Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function codebase(inval10,outbase,answer) ! ident_82="@(#) M_strings codebase(3f) convert whole number in base 10 to string in base [2-36]" integer,intent(in) :: inval10 integer,intent(in) :: outbase character(len=*),intent(out) :: answer integer :: n real :: inval10_local integer :: outbase_local integer :: in_sign answer='' in_sign=sign(1,inval10)*sign(1,outbase) inval10_local=abs(inval10) outbase_local=abs(outbase) if(outbase_local<2.or.outbase_local>36) then print *,'*codebase* ERROR: base must be between 2 and 36. base was',outbase_local codebase=.false. else do while(inval10_local>0.0 ) n=INT(inval10_local-outbase_local*INT(inval10_local/outbase_local)) if(n<10) then answer=ACHAR(IACHAR('0')+n)//answer else answer=ACHAR(IACHAR('A')+n-10)//answer endif inval10_local=INT(inval10_local/outbase_local) enddo codebase=.true. endif if(in_sign == -1)then answer='-'//trim(answer) endif if(answer == '')then answer='0' endif end function codebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function todecimal(base, instr) ! ident_83="@(#) M_strings todecimal(3f) given string and base return decimal integer" ! based on an example at rosetta code. character(len=36),parameter :: alphanum = "0123456789abcdefghijklmnopqrstuvwxyz" integer,intent(in) :: base character(*),intent(in) :: instr character(len=:),allocatable :: instr_local integer :: todecimal integer :: length, i, n instr_local=trim(lower(instr)) todecimal = 0 length = len(instr_local) do i = 1, length n = index(alphanum, instr_local(i:i)) - 1 n = n * base**(length-i) todecimal = todecimal + n enddo end function todecimal !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function tobase(base, number) ! ident_84="@(#) M_strings tobase(3f) given integer and base return string" ! based on an example at rosetta code. character(len=36),parameter :: alphanum = "0123456789abcdefghijklmnopqrstuvwxyz" integer,intent(in) :: base integer,intent(in) :: number character(len=:),allocatable :: tobase character(len=31) :: holdit integer :: number_local, i, rem number_local=number holdit = " " do i = 31, 1, -1 if(number_local < base) then holdit(i:i) = alphanum(number_local+1:number_local+1) exit endif rem = mod(number_local, base) holdit(i:i) = alphanum(rem+1:rem+1) number_local = number_local / base enddo tobase = adjustl(holdit) end function tobase !SUBROUTINE DectoBase(decimal, string, base) ! CHARACTER string ! string = '0' ! temp = decimal ! length = CEILING( LOG(decimal+1, base) ) !<<<<<<<< INTERESTING ! DO i = length, 1, -1 ! n = MOD( temp, base ) ! string(i) = "0123456789abcdefghijklmnopqrstuvwxyz"(n+1) ! temp = INT(temp / base) ! ENDDO ! END !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! paragraph(3f) - [M_strings:TOKENS] break a long line into a paragraph !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function paragraph(source_string,length) !! !! character(len=*),intent(in) :: source_string !! integer,intent(in) :: length !! character(allocatable(len=length) :: paragraph(:) !! !!##DESCRIPTION !! paragraph(3f) breaks a long line into a simple paragraph of specified !! line length. !! !! Given a long string break it on spaces into an array such that no !! variable is longer than the specified length. Individual words longer !! than LENGTH will be placed in variables by themselves. !! !!##OPTIONS !! SOURCE_STRING input string to break into an array of shorter strings !! on blank delimiters !! LENGTH length of lines to break the string into. !! !!##RETURNS !! PARAGRAPH character array filled with data from source_string !! broken at spaces into variables of length LENGTH. !! !!##EXAMPLE !! !! sample program !! !! program demo_paragraph !! use M_strings, only : paragraph !! implicit none !! character(len=:),allocatable :: paragrph(:) !! character(len=*),parameter :: string= '& !! &one two three four five & !! &six seven eight & !! &nine ten eleven twelve & !! &thirteen fourteen fifteen sixteen & !! &seventeen' !! !! write(*,*)'LEN=',len(string) !! write(*,*)'INPUT:' !! write(*,*)string !! !! paragrph=paragraph(string,40) !! write(*,*)'LEN=',len(paragrph),' SIZE=',size(paragrph) !! write(*,*)'OUTPUT:' !! write(*,'(a)')paragrph !! !! write(*,'(a)')paragraph(string,0) !! write(*,'(3x,a)')paragraph(string,47) !! !! end program demo_paragraph !! !! Results: !! !! LEN= 106 !! INPUT: !! one two three four five six seven eight nine ten eleven twelve !! thirteen fourteen fifteen sixteen seventeen !! LEN= 40 SIZE= 3 !! OUTPUT: !! one two three four five six seven eight !! nine ten eleven twelve thirteen fourteen !! fifteen sixteen seventeen !! one !! two !! three !! four !! five !! six !! seven !! eight !! nine !! ten !! eleven !! twelve !! thirteen !! fourteen !! fifteen !! sixteen !! seventeen !! one two three four five six seven eight nine !! ten eleven twelve thirteen fourteen fifteen !! sixteen seventeen !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function paragraph(source_string,length) ! ident_85="@(#) M_strings paragraph(3f) wrap a long string into a paragraph" character(len=*),intent(in) :: source_string integer,intent(in) :: length integer :: itoken integer :: istart integer :: iend character(len=*),parameter :: delimiters=' ' character(len=:),allocatable :: paragraph(:) integer :: ilines integer :: ilength integer :: iword, iword_max integer :: i !----------------------------------------------------------------------------------------------------------------------------------- ! parse string once to find out how big to make the returned array, then redo everything but store the data ! could store array of endpoints and leave original whitespace alone or many other options do i=1,2 iword_max=0 ! length of longest token ilines=1 ! number of output line output will go on ilength=0 ! length of output line so far itoken=0 ! must set ITOKEN=0 before looping on strtok(3f) on a new string. do while ( strtok(source_string,itoken,istart,iend,delimiters) ) iword=iend-istart+1 iword_max=max(iword_max,iword) if(iword > length)then ! this token is longer than the desired line length so put it on a line by itself if(ilength /= 0)then ilines=ilines+1 endif if(i == 2)then ! if paragraph has been allocated store data, else just gathering data to determine size of paragraph paragraph(ilines)=source_string(istart:iend)//' ' endif ilength=iword+1 elseif(ilength+iword <= length)then ! this word will fit on current line if(i == 2)then paragraph(ilines)=paragraph(ilines)(:ilength)//source_string(istart:iend) endif ilength=ilength+iword+1 else ! adding this word would make line too long so start new line ilines=ilines+1 ilength=0 if(i == 2)then paragraph(ilines)=paragraph(ilines)(:ilength)//source_string(istart:iend) endif ilength=iword+1 endif enddo if(i==1)then ! determined number of lines needed so allocate output array allocate(character(len=max(length,iword_max)) :: paragraph(ilines)) paragraph=' ' endif enddo paragraph=paragraph(:ilines) end function paragraph !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function setbits8(string) result(answer) integer(kind=int8) :: answer character(len=8),intent(in) :: string integer :: pos integer :: lgth answer=0_int8 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits8* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,lgth select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits8* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits8 !----------------------------------------------------------------------------------------------------------------------------------- function setbits16(string) result(answer) integer(kind=int16) :: answer character(len=16),intent(in) :: string integer :: pos integer :: lgth answer=0_int16 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits16* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,len(string) select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits16* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits16 !----------------------------------------------------------------------------------------------------------------------------------- function setbits32(string) result(answer) integer(kind=int32) :: answer character(len=32),intent(in) :: string integer :: pos integer :: lgth answer=0_int32 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits32* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,len(string) select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits32* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits32 !----------------------------------------------------------------------------------------------------------------------------------- function setbits64(string) result(answer) integer(kind=int64) :: answer character(len=64),intent(in) :: string integer :: pos integer :: lgth answer=0_int64 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits64* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,len(string) select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits64* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits64 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! msg(3f) - [M_strings:TYPE] converts any standard scalar type to a string !! (LICENSE:PD) !!##SYNOPSIS !! !! !! function msg(g1,g2g3,g4,g5,g6,g7,g8,g9,sep) !! !! class(*),intent(in),optional :: g1,g2,g3,g4,g5,g6,g7,g8,g9 !! character(len=*),intent(in),optional :: sep !! character(len=:),allocatable :: msg !! !!##DESCRIPTION !! msg(3f) builds a space-separated string from up to nine scalar values. !! !!##OPTIONS !! g[1-9] optional value to print the value of after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, COMPLEX, !! or CHARACTER. !! sep separator between values. Defaults to a space !! !!##RETURNS !! msg description to print !! !!##EXAMPLES !! !! !! Sample program: !! !! program demo_msg !! use M_strings, only : msg !! implicit none !! character(len=:),allocatable :: pr !! character(len=:),allocatable :: frmt !! integer :: biggest !! !! pr=msg('HUGE(3f) integers',huge(0),& !! & 'and real',huge(0.0),'and double',huge(0.0d0)) !! write(*,'(a)')pr !! pr=msg('real :',& !! & huge(0.0),0.0,12345.6789,tiny(0.0) ) !! write(*,'(a)')pr !! pr=msg('doubleprecision :',& !! & huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) !! write(*,'(a)')pr !! pr=msg('complex :',& !! & cmplx(huge(0.0),tiny(0.0)) ) !! write(*,'(a)')pr !! !! ! create a format on the fly !! biggest=huge(0) !! ! +0 for gfortran-11 bug !! frmt=msg('(*(i',int(log10(real(biggest)))+0,':,1x))',sep='') !! write(*,*)'format=',frmt !! !! ! although it will often work, using msg(3f) in an I/O statement !! ! is not recommended !! write(*,*)msg('program will now stop') !! !! end program demo_msg !! !! Output !! !! HUGE(3f) integers 2147483647 and real 3.40282347E+38 !! and double 1.7976931348623157E+308 !! real : 3.40282347E+38 0.00000000 !! 12345.6787 1.17549435E-38 !! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 !! 12345.678900000001 2.2250738585072014E-308 !! complex : (3.40282347E+38,1.17549435E-38) !! format=(*(i9:,1x)) !! program will now stop !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== function msg_scalar(generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) ! ident_86="@(#) M_strings msg_scalar(3fp) writes a message to a string composed of any standard scalar types" class(*),intent(in),optional :: generic1 ,generic2 ,generic3 ,generic4 ,generic5 class(*),intent(in),optional :: generic6 ,generic7 ,generic8 ,generic9 character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_scalar character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) msg_scalar=trim(line) contains !=================================================================================================================================== subroutine print_generic(generic) class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real256)); write(line(istart:),'(1pg0)') generic type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic !=================================================================================================================================== end function msg_scalar !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function msg_one(generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) ! ident_87="@(#) M_strings msg_one(3fp) writes a message to a string composed of any standard one dimensional types" class(*),intent(in) :: generic1(:) class(*),intent(in),optional :: generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) msg_one=trim(line) contains !=================================================================================================================================== subroutine print_generic(generic) class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real256)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic end select istart=len_trim(line)+increment line=trim(line)//"]"//sep_local end subroutine print_generic !=================================================================================================================================== end function msg_one !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! find_field(3f) - [M_strings:TOKENS] parse a string into tokens !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! subroutine find_field (string, field, position, delims, delim, found) !! !! character*(*),intent(in) :: string !! character*(*),intent(out) :: field !! integer,optional,intent(inout) :: position !! character*(*),optional,intent(in) :: delims !! character*(*),optional,intent(out) :: delim !! logical,optional,intent(out) :: found !! !!##DESCRIPTION !! !! Find a delimited field in a string. !! !! Here's my equivalent, which I've used for nearly 2 decades, as you can !! see from the date. This doesn't try to mimic the C strtok (and doesn't !! have its limitations either). It is in a much more native Fortran style. !! !! It is a little more complicated than some because it does some things !! that I regularly find useful. For example, it can tell the caller what !! trailing delimiter it found. This can be useful, for example, to !! distinguish between !! !! somefield, someotherfield !! !! versus !! !! somefield=somevalue, someotherfield !! !! Also, I have a bit of special handling for blanks. All the usage !! information is in the argument descriptions. Note that most of the !! arguments are optional. !! !! from comp.lang.fortran @ Richard Maine !! !!##OPTIONS !! STRING The string input. !! !! FIELD The returned field. Blank if no field found. !! !! POSITION On entry, the starting position for searching for the field. !! Default is 1 if the argument is not present. !! On exit, the starting position of the next field or !! len(string)+1 if there is no following field. !! !! DELIMS String containing the characters to be accepted as delimiters. !! If this includes a blank character, then leading blanks are !! removed from the returned field and the end delimiter may !! optionally be preceded by blanks. If this argument is !! not present, the default delimiter set is a blank. !! !! DELIM Returns the actual delimiter that terminated the field. !! Returns char(0) if the field was terminated by the end of !! the string or if no field was found. !! If blank is in delimiters and the field was terminated !! by one or more blanks, followed by a non-blank delimiter, !! the non-blank delimiter is returned. !! !! FOUND True if a field was found. !! !!##EXAMPLES !! !! Sample of uses !! !! program demo_find_field !! use M_strings, only : find_field !! implicit none !! character(len=256) :: string !! character(len=256) :: field !! integer :: position !! character(len=:),allocatable :: delims !! character(len=1) :: delim !! logical :: found !! !! delims='[,]' !! position=1 !! found=.true. !! string='[a,b,[ccc,ddd],and more]' !! write(*,'(a)')trim(string) !! do !! call find_field(string,field,position,delims,delim,found=found) !! if(.not.found)exit !! write(*,'("<",a,">")')trim(field) !! enddo !! write(*,'(*(g0))')repeat('=',70) !! !! position=1 !! found=.true. !! write(*,'(a)')trim(string) !! do !! call find_field(string,field,position,'[], ',delim,found=found) !! if(.not.found)exit !! write(*,'("<",a,">",i0,1x,a)')trim(field),position,delim !! enddo !! write(*,'(*(g0))')repeat('=',70) !! !! end program demo_find_field !! ``` !! Results: !! ```text !! > [a,b,[ccc,ddd],and more] !! > <> !! > !! > !! > <> !! > !! > !! > <> !! > !! > <> !! > ====================================================================== !! > [a,b,[ccc,ddd],and more] !! > <>2 [ !! > 4 , !! > 6 , !! > <>7 [ !! > 11 , !! > 15 ] !! > <>16 , !! > 20 !! > 257 ] !! > ====================================================================== !! !!##AUTHOR !! Richard Maine !! !!##LICENSE !! MIT !! !!##VERSION !! version 0.1.0, copyright Nov 15 1990, Richard Maine !! !! Minor editing to conform to inclusion in the string procedure module subroutine find_field (string, field, position, delims, delim, found) !-- Find a delimited field in a string. !-- 15 Nov 90, Richard Maine. !-------------------- interface. character*(*),intent(in) :: string character*(*),intent(out) :: field integer,optional,intent(inout) :: position character*(*),optional,intent(in) :: delims character*(*),optional,intent(out) :: delim logical,optional,intent(out) :: found !-------------------- local. character :: delimiter*1 integer :: pos, field_start, field_end, i logical :: trim_blanks !-------------------- executable code. field = '' delimiter = char(0) pos = 1 if (present(found)) found = .false. if (present(position)) pos = position if (pos > len(string)) goto 9000 !if (pos < 1) error stop 'Illegal position in find_field' if (pos < 1) stop 'Illegal position in find_field' !-- Skip leading blanks if blank is a delimiter. field_start = pos trim_blanks = .true. if (present(delims)) trim_blanks = index(delims,' ') /= 0 if (trim_blanks) then i = verify(string(pos:),' ') if (i == 0) then pos = len(string) + 1 goto 9000 end if field_start = pos + i - 1 end if if (present(found)) found = .true. !-- Find the end of the field. if (present(delims)) then i = scan(string(field_start:), delims) else i = scan(string(field_start:), ' ') end if if (i == 0) then field_end = len(string) delimiter = char(0) pos = field_end + 1 else field_end = field_start + i - 2 delimiter = string(field_end+1:field_end+1) pos = field_end + 2 end if !-- Return the field. field = string(field_start:field_end) !-- Skip trailing blanks if blank is a delimiter. if (trim_blanks) then i = verify(string(field_end+1:), ' ') if (i == 0) then pos = len(string) + 1 goto 9000 end if pos = field_end + i !-- If the first non-blank character is a delimiter, !-- skip blanks after it. i = 0 if (present(delims)) i = index(delims, string(pos:pos)) if (i /= 0) then delimiter = string(pos:pos) pos = pos + 1 i = verify(string(pos:), ' ') if (i == 0) then pos = len(string) + 1 else pos = pos + i - 1 end if end if end if !---------- Normal exit. 9000 continue if (present(delim)) delim = delimiter if (present(position)) position = pos end subroutine find_field !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split2020(3f) - [M_strings:TOKENS] parse a string into tokens using !! proposed f2023 method !! (LICENSE:PD) !! !!##SYNOPSIS !! !! TOKEN form !! !! subroutine split2020 (string, set, tokens, separator) !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: set !! character(len=:),allocatable,intent(out) :: tokens(:) !! character(len=1),allocatable,intent(out),optional :: separator(:) !! !! BOUNDS ARRAY form !! !! subroutine split2020 (string, set, first, last) !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: set !! integer,allocatable,intent(out) :: first(:) !! integer,allocatable,intent(out) :: last(:) !! !! STEP THROUGH BY POSITION form !! !! subroutine split2020 (string, set, pos [, back]) !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: set !! integer,intent(inout) :: pos !! logical,intent(in),optional :: back !! !!##DESCRIPTION !! Parse a string into tokens. STRING, SET, TOKENS and SEPARATOR must !! all be of the same CHARACTER kind type parameter. !! !!##OPTIONS !! STRING string to break into tokens !! !! SET Each character in SET is a token delimiter. A !! sequence of zero or more characters in STRING delimited by !! any token delimiter, or the beginning or end of STRING, !! comprise a token. Thus, two consecutive token delimiters !! in STRING, or a token delimiter in the first or last !! character of STRING, indicate a token with zero length. !! !! ??? how about if null defaults to all whitespace characters !! !! TOKENS It is allocated with the lower bound equal to !! one and the upper bound equal to the number of tokens in !! STRING, and with character length equal to the length of !! the longest token. The tokens in STRING are assigned by !! intrinsic assignment, in the order found, to the elements !! of TOKENS, in array element order. !! !! ???If input is null it still must be of size 1? !! !! SEPARATOR Each element in SEPARATOR(i) is assigned the value of !! the ith token delimiter in STRING. !! It is allocated with the lower bound equal to !! one and the upper bound equal to one less than the number !! of tokens in STRING, and with character length equal to !! one. !! !! ???one less than? '' ' ' !! !! FIRST It is allocated with the lower bound equal to one and the !! upper bound equal to the number of tokens in STRING. Each !! element is assigned, in array element order, the starting !! position of each token in STRING, in the order found. If a !! token has zero length, the starting position is equal to one !! if the token is at the beginning of STRING, and one greater !! than the position of the preceding delimiter otherwise. !! !! LAST It is allocated with the lower bound equal to one and the !! upper bound equal to the number of tokens in STRING. Each !! element is assigned, in array element order, the ending !! position of each token in STRING, in the order found. If !! a token has zero length, the ending position is one less !! than the starting position. !! !! POS If BACK is present with the value .TRUE., the value !! of POS shall be in the range 0 < POS LEN (STRING)+1; !! otherwise it shall be in the range 0 POS LEN (STRING). !! !! If BACK is absent or is present with the value .FALSE., POS !! is assigned the position of the leftmost token delimiter in !! STRING whose position is greater than POS, or if there is !! no such character, it is assigned a value one greater than !! the length of STRING. This identifies a token with starting !! position one greater than the value of POS on invocation, !! and ending position one less than the value of POS on return. !! !! If BACK is present with the value true, POS is assigned the !! position of the rightmost token delimiter in STRING whose !! position is less than POS, or if there is no such character, !! it is assigned the value zero. This identifies a token with !! ending position one less than the value of POS on invocation, !! and starting position one greater than the value of POS !! on return. !! !! When SPLIT is invoked with a value for POS of !! 1 <= POS <= LEN(STRING) and STRING(POS:POS) is not a !! token delimiter present in SET, the token identified by !! SPLIT does not comprise a complete token as described in the !! description of the SET argument, but rather a partial token. !! !! BACK shall be a logical scalar. It is an INTENT (IN) argument. If !! POS does not appear and BACK is present with the value true, !! STRING is scanned backwards for tokens starting from the !! end. If POS does not appear and BACK is absent or present !! with the value false, STRING is scanned forwards for tokens !! starting from the beginning. !! !!##EXAMPLES !! !! Sample of uses !! !! program demo_sort2020 !! use M_strings, only : split2020 !! implicit none !! character(len=*),parameter :: gen='(*("[",g0,"]":,","))' !! !! ! Execution of TOKEN form !! block !! character (len=:), allocatable :: string !! character (len=:), allocatable :: tokens(:) !! character (len=*),parameter :: set = " ," !! string = 'first,second,third' !! call split2020(string, set, tokens ) !! write(*,gen)tokens !! !! ! assigns the value ['first ','second','third ' ] !! ! to TOKENS. !! endblock !! !! ! Execution of BOUNDS form !! !! block !! character (len=:), allocatable :: string !! character (len=*),parameter :: set = " ," !! integer, allocatable :: first(:), last(:) !! string = 'first,second,,forth' !! call split2020 (string, set, first, last) !! write(*,gen)first !! write(*,gen)last !! !! ! will assign the value [ 1, 7, 14, 15 ] to FIRST, !! ! and the value [ 5, 12, 13, 19 ] to LAST. !! endblock !! !! ! Execution of STEP form !! block !! character (len=:), allocatable :: string !! character (len=*),parameter :: set = " ," !! integer :: p, istart, iend !! string = " one, last example " !! do while (p < len(string)) !! istart = p + 1 !! call split2020 (string, set, p) !! iend=p-1 !! if(iend > istart)then !! print '(t3,a,1x,i0,1x,i0)', string (istart:iend),istart,iend !! endif !! enddo !! endblock !! end program demo_sort2020 !! !! Results: !! !! [first ],[second],[third ] !! [1],[7],[14],[15] !! [5],[12],[13],[19] !! one 2 4 !! last 9 12 !! example 15 21 !! !! > ??? option to skip adjacent delimiters (not return null tokens) !! > common with whitespace !! > ??? quoted strings, especially CSV both " and ', Fortran adjacent !! > is insert versus other rules !! > ??? escape character like \\ . !! > ??? multi-character delimiters like \\n, \\t, !! > ??? regular expression separator !! !!##AUTHOR !! Milan Curcic, "milancurcic@hey.com" !! !!##LICENSE !! MIT !! !!##VERSION !! version 0.1.0, copyright 2020, Milan Curcic pure subroutine split_tokens(string, set, tokens, separator) ! Splits a string into tokens using characters in set as token delimiters. ! If present, separator contains the array of token delimiters. character(*), intent(in) :: string character(*), intent(in) :: set character(:), allocatable, intent(out) :: tokens(:) character, allocatable, intent(out), optional :: separator(:) integer, allocatable :: first(:), last(:) integer :: n call split2020(string, set, first, last) allocate(character(len=maxval(last - first) + 1) :: tokens(size(first))) do concurrent (n = 1:size(tokens)) tokens(n) = string(first(n):last(n)) enddo if (present(separator)) then allocate(separator(size(tokens) - 1)) do concurrent (n = 1:size(tokens) - 1) separator(n) = string(first(n+1)-1:first(n+1)-1) enddo endif end subroutine split_tokens !=================================================================================================================================== pure subroutine split_first_last(string, set, first, last) ! Computes the first and last indices of tokens in input string, delimited ! by the characters in set, and stores them into first and last output ! arrays. character(*), intent(in) :: string character(*), intent(in) :: set integer, allocatable, intent(out) :: first(:) integer, allocatable, intent(out) :: last(:) character :: set_array(len(set)) logical, dimension(len(string)) :: is_first, is_last, is_separator integer :: n, slen slen = len(string) do concurrent (n = 1:len(set)) set_array(n) = set(n:n) enddo do concurrent (n = 1:slen) is_separator(n) = any(string(n:n) == set_array) enddo is_first = .false. is_last = .false. if (.not. is_separator(1)) is_first(1) = .true. do concurrent (n = 2:slen-1) if (.not. is_separator(n)) then if (is_separator(n - 1)) is_first(n) = .true. if (is_separator(n + 1)) is_last(n) = .true. else if (is_separator(n - 1)) then is_first(n) = .true. is_last(n-1) = .true. endif endif enddo if (.not. is_separator(slen)) is_last(slen) = .true. first = pack([(n, n = 1, slen)], is_first) last = pack([(n, n = 1, slen)], is_last) end subroutine split_first_last !=================================================================================================================================== pure subroutine split_pos(string, set, pos, back) ! If back is absent, computes the leftmost token delimiter in string whose ! position is > pos. If back is present and true, computes the rightmost ! token delimiter in string whose position is < pos. The result is stored ! in pos. character(*), intent(in) :: string character(*), intent(in) :: set integer, intent(in out) :: pos logical, intent(in), optional :: back logical :: backward character :: set_array(len(set)) integer :: n, result_pos !TODO use optval when implemented in stdlib !backward = optval(back, .false.) backward = .false. if (present(back)) backward = back do concurrent (n = 1:len(set)) set_array(n) = set(n:n) enddo if (backward) then result_pos = 0 do n = pos - 1, 1, -1 if (any(string(n:n) == set_array)) then result_pos = n exit endif enddo else result_pos = len(string) + 1 do n = pos + 1, len(string) if (any(string(n:n) == set_array)) then result_pos = n exit endif enddo endif pos = result_pos end subroutine split_pos !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure function string_tokens(string, set) result(tokens) ! Splits a string into tokens using characters in set as token delimiters. character(*), intent(in) :: string character(*), intent(in) :: set character(:), allocatable :: tokens(:) call split_tokens(string, set, tokens) end function string_tokens !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! Duplicate the M_journal module in condensed form for now so can be stand-alone on GITHUB ! ll ! l ! j l ! l ! j l ! j oooooo u u r rrrrrr n nnnnn aaaa l ! j o o u u rr nn n a l ! j o o u u r n n aaaaaa l ! j j o o u u r n n a a l ! jj oooooo uuuuuu u r n n aaaaa a l ! !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! @(#) place-holder for journal module !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine where_write_message(where,msg) !@(#) M_journal::where_write_message(3fp): basic message routine used for journal files character(len=*),intent(in) :: where character(len=*),intent(in) :: msg logical,save :: trailopen=.false. integer,save :: itrail character,save :: comment='#' integer :: i integer :: ios integer :: times ! number of times written to stdout character(len=3) :: adv ! whether remaining writes from this call use advancing I/O character(len=:),allocatable,save :: prefix_template ! string to run thru now_ex(3f) to make prefix character(len=:),allocatable :: prefix ! the prefix string to add to output logical,save :: prefix_it=.false. ! flag whether time prefix mode is on or not character(len=4096) :: mssge !----------------------------------------------------------------------------------------------------------------------------------- adv='yes' !----------------------------------------------------------------------------------------------------------------------------------- prefix='' !----------------------------------------------------------------------------------------------------------------------------------- times=0 do i=1,len_trim(where) select case(where(i:i)) case('T','t') if(trailopen) then write(itrail,'(a)',advance=adv)prefix//trim(msg) !elseif(times == 0)then ! write(stdout,'(a)',advance=adv)prefix//trim(msg) ! times=times+1 endif !----------------------------------------------------------------------------------------------------------------------------- case('S','s') write(stdout,'(a)',advance=adv)prefix//trim(msg) times=times+1 !----------------------------------------------------------------------------------------------------------------------------- case('E','e') write(stderr,'(a)',advance=adv)prefix//trim(msg) times=times+1 !----------------------------------------------------------------------------------------------------------------------------- case('+'); adv='no' !----------------------------------------------------------------------------------------------------------------------------- case('>'); debug=.true. !----------------------------------------------------------------------------------------------------------------------------- case('<'); debug=.false. !----------------------------------------------------------------------------------------------------------------------------- case('%') ! setting timestamp prefix if(msg == '')then ! if message is blank turn off prefix prefix_it=.false. else ! store message as string to pass to now_ex() on subsequent calls to make prefix prefix_template=msg prefix_it=.true. endif !----------------------------------------------------------------------------------------------------------------------------- case('N') ! new name for stdout if(msg /= ' '.and.msg /= '#N#'.and.msg /= '"#N#"')then ! if filename not special or blank open new file close(unit=last_int,iostat=ios) open(unit=last_int,file=clip(msg),iostat=ios) if(ios == 0)then stdout=last_int else write(*,*)'*journal* error opening redirected output file, ioerr=',ios write(*,*)'*journal* msg='//trim(msg) endif elseif(msg == ' ')then close(unit=last_int,iostat=ios) stdout=6 endif !----------------------------------------------------------------------------------------------------------------------------- case('C','c') if(trailopen)then write(itrail,'(3a)',advance=adv)prefix,comment,trim(msg) elseif(times == 0)then ! write(stdout,'(2a)',advance=adv)prefix,trim(msg) ! times=times+1 endif case('D','d') if(debug)then if(trailopen)then write(itrail,'(4a)',advance=adv)prefix,comment,'DEBUG: ',trim(msg) elseif(times == 0)then write(stdout,'(3a)',advance=adv)prefix,'DEBUG:',trim(msg) times=times+1 endif endif case('F','f') flush(unit=itrail,iostat=ios,iomsg=mssge) if(ios /= 0)then write(*,'(a)') trim(mssge) endif case('A','a') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential',file=clip(msg),& & form='formatted',iostat=ios,position='append') trailopen=.true. endif case('O','o') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential', file=clip(msg),form='formatted',iostat=ios) trailopen=.true. else if(trailopen)then write(itrail,'(4a)',advance=adv)prefix,comment,'closing trail file:',trim(msg) endif close(unit=itrail,iostat=ios) trailopen=.false. endif case default write(stdout,'(a)',advance=adv)'*journal* bad WHERE value '//trim(where)//' when msg=['//trim(msg)//']' end select enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine where_write_message !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine flush_trail() call where_write_message('F','IGNORE THIS STRING') end subroutine flush_trail !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine where_write_message_all(where, g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,nospace) !$(#) M_journal::where_write_message_all(3f): writes a message to a string composed of any standard scalar types character(len=*),intent(in) :: where class(*),intent(in) :: g0 class(*),intent(in),optional :: g1,g2,g3,g4,g5,g6,g7,g8,g9 logical,intent(in),optional :: nospace !call where_write_message(where,str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9,nospace)) end subroutine where_write_message_all !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine write_message_only(message) !$(#) M_journal::write_message_only(3fp): calls JOURNAL('sc',message) character(len=*),intent(in) :: message !----------------------------------------------------------------------------------------------------------------------------------- call where_write_message('sc',trim(message)) !----------------------------------------------------------------------------------------------------------------------------------- end subroutine write_message_only !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function str_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, & & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, & & sep) class(*),intent(in),optional :: generic0, generic1, generic2, generic3, generic4 class(*),intent(in),optional :: generic5, generic6, generic7, generic8, generic9 class(*),intent(in),optional :: generica, genericb, genericc, genericd, generice class(*),intent(in),optional :: genericf, genericg, generich, generici, genericj character(len=*),intent(in),optional :: sep character(len=:), allocatable :: str_scalar character(len=4096) :: line integer :: istart integer :: increment character(len=:),allocatable :: sep_local if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line='' if(present(generic0))call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) if(present(generica))call print_generic(generica) if(present(genericb))call print_generic(genericb) if(present(genericc))call print_generic(genericc) if(present(genericd))call print_generic(genericd) if(present(generice))call print_generic(generice) if(present(genericf))call print_generic(genericf) if(present(genericg))call print_generic(genericg) if(present(generich))call print_generic(generich) if(present(generici))call print_generic(generici) if(present(genericj))call print_generic(genericj) str_scalar=trim(line) contains !=================================================================================================================================== subroutine print_generic(generic) class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real256)); write(line(istart:),'(1pg0)') generic type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic end function str_scalar !=================================================================================================================================== function str_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) class(*),intent(in) :: generic0(:) class(*),intent(in),optional :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: str_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) str_one=trim(line) contains subroutine print_generic(generic) class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real256)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic class default stop 'unknown type in *print_generic*' end select line=trim(line)//"]"//sep_local istart=len_trim(line)+increment end subroutine print_generic end function str_one !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! matching_delimiter(3f) - [M_strings:QUOTES] find position of matching delimiter !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental subroutine matching_delimiter(str,ipos,imatch) !! !! character(len=*),intent(in) :: str !! integer,intent(in) :: ipos !! integer,intent(out) :: imatch !! !!##DESCRIPTION !! Sets imatch to the position in string of the delimiter matching the !! delimiter in position ipos. Allowable delimiters are (), [], {}, <>. !! !!##OPTIONS !! str input string to locate delimiter position in !! ipos position of delimiter to find match for !! imatch location of matching delimiter. If no match is found, zero (0) !! is returned. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_matching_delimiter !! use M_strings, only : matching_delimiter !! implicit none !! character(len=128) :: str !! integer :: imatch !! !! str=' a [[[[b] and ] then ] finally ]' !! write(*,*)'string=',str !! call matching_delimiter(str,1,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,4,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,5,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,6,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,7,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,32,imatch) !! write(*,*)'location=',imatch !! !! end program demo_matching_delimiter !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== impure elemental subroutine matching_delimiter(str,ipos,imatch) ! Sets imatch to the position in string of the delimiter matching the delimiter ! in position ipos. Allowable delimiters are (), [], {}, <>. ! pedigree? character(len=*),intent(in) :: str integer,intent(in) :: ipos integer,intent(out) :: imatch character :: delim1,delim2,ch integer :: lenstr integer :: idelim2 integer :: istart, iend integer :: inc integer :: isum integer :: i imatch=0 lenstr=len_trim(str) delim1=str(ipos:ipos) select case(delim1) case('(') idelim2=iachar(delim1)+1 istart=ipos+1 iend=lenstr inc=1 case(')') idelim2=iachar(delim1)-1 istart=ipos-1 iend=1 inc=-1 case('[','{','<') idelim2=iachar(delim1)+2 istart=ipos+1 iend=lenstr inc=1 case(']','}','>') idelim2=iachar(delim1)-2 istart=ipos-1 iend=1 inc=-1 case default write(*,*) delim1,' is not a valid delimiter' return end select if(istart < 1 .or. istart > lenstr) then write(*,*) delim1,' has no matching delimiter' return endif delim2=achar(idelim2) ! matching delimiter isum=1 do i=istart,iend,inc ch=str(i:i) if(ch /= delim1 .and. ch /= delim2) cycle if(ch == delim1) isum=isum+1 if(ch == delim2) isum=isum-1 if(isum == 0) exit enddo if(isum /= 0) then write(*,*) delim1,' has no matching delimiter' return endif imatch=i end subroutine matching_delimiter !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! longest_common_substring(3f) - [M_strings:COMPARE] function that !! returns the longest common substring of two strings. !!##SYNOPSIS !! !! function longest_common_substring(a,b) result(match) !! !! character(len=*),intent(in) :: a, b !! character(len=:),allocatable :: match !!##DESCRIPTION !! function that returns the longest common substring of two strings. !! !! Note that substrings are consecutive characters within a string. !! This distinguishes them from subsequences, which is any sequence of !! characters within a string, even if there are extraneous characters in !! between them. !! !! Hence, the longest common subsequence between "thisisatest" and !! "testing123testing" is "tsitest", whereas the longest common substring !! is just "test". !!##OPTIONS !! a,b strings to search for the longest common substring. !!##RETURNS !! longest_common_substring the longest common substring found !!##EXAMPLE !! !! Sample program !! !! program demo_longest_common_substring !! use M_strings, only : longest_common_substring !! implicit none !! call compare('testing123testingthing','thisis', 'thi') !! call compare('testing', 'sting', 'sting') !! call compare('thisisatest_stinger','testing123testingthing','sting') !! call compare('thisisatest_stinger', 'thisis', 'thisis') !! call compare('thisisatest', 'testing123testing', 'test') !! call compare('thisisatest', 'thisisatest', 'thisisatest') !! contains !! !! subroutine compare(a,b,answer) !! character(len=*),intent(in) :: a, b, answer !! character(len=:),allocatable :: match !! character(len=*),parameter :: g='(*(g0))' !! match=longest_common_substring(a,b) !! write(*,g) 'comparing "',a,'" and "',b,'"' !! write(*,g) merge('(PASSED) "','(FAILED) "',answer == match), & !! & match,'"; expected "',answer,'"' !! end subroutine compare !! !! end program demo_longest_common_substring !! !! expected output !! !! comparing "testing123testingthing" and "thisis" !! (PASSED) "thi"; expected "thi" !! comparing "testing" and "sting" !! (PASSED) "sting"; expected "sting" !! comparing "thisisatest_stinger" and "testing123testingthing" !! (PASSED) "sting"; expected "sting" !! comparing "thisisatest_stinger" and "thisis" !! (PASSED) "thisis"; expected "thisis" !! comparing "thisisatest" and "testing123testing" !! (PASSED) "test"; expected "test" !! comparing "thisisatest" and "thisisatest" !! (PASSED) "thisisatest"; expected "thisisatest" function longest_common_substring(a,b) result(match) character(len=*),intent(in) :: a, b character(len=:),allocatable :: match character(len=:),allocatable :: a2, b2 integer :: left, foundat, len_a, i if(len(a) < len(b))then ! to reduce required comparisions look for shortest string in longest string a2=a b2=b else a2=b b2=a endif match='' do i=1,len(a2)-1 len_a=len(a2) do left=1,len_a foundat=index(b2,a2(left:)) if(foundat /= 0.and.len(match) < len_a-left+1)then if(len(a2(left:)) > len(match))then match=a2(left:) exit endif endif enddo if(len(a2) < len(match))exit a2=a2(:len(a2)-1) enddo end function longest_common_substring !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure elemental function atoi (string) result(val) ! Convert STRING to an integer value integer(kind=int32) :: val character(len=*), intent(in) :: string character(len=1) :: c integer :: i integer :: j integer :: ilen logical :: neg val = 0 neg=.false. i=0 c=' ' ilen=len(string) do i=1, ilen ! Pass over any leading spaces c = string(i:i) if (c /= ' ') exit enddo if (c == '-') then ! check for +- as first digit neg = .true. i = i + 1 elseif (c == '+') then neg = .false. i = i + 1 endif do j=i,ilen ! Continue as long as its a digit ... c = string(j:j) if (lge(c, '0') .and. lle(c, '9')) then val = 10*val + ichar(c)-48 ! Shift number over and add new digit else exit endif enddo if (neg) val = -val ! Negate the result if necessary end function atoi pure elemental function atol (string) result(val) ! Convert STRING to an integer value integer(kind=int64) :: val character(len=*), intent(in) :: string character(len=1) :: c integer :: i integer :: j integer :: ilen logical :: neg val = 0 neg=.false. i=0 c=' ' ilen=len(string) do i=1, ilen ! Pass over any leading spaces c = string(i:i) if (c /= ' ') exit enddo if (c == '-') then ! check for +- as first digit neg = .true. i = i + 1 elseif (c == '+') then neg = .false. i = i + 1 endif do j=i,ilen ! Continue as long as its a digit ... c = string(j:j) if (lge(c, '0') .and. lle(c, '9')) then val = 10*val + ichar(c)-48 ! Shift number over and add new digit else exit endif enddo if (neg) val = -val ! Negate the result if necessary end function atol !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! aton(3f) - [M_strings:TYPE] function returns argument as a numeric !! value from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function aton(str,val[,msg]) !! !! character(len=*),intent(in) :: str !! type(TYPE(kind=KIND)),intent(out) :: val !! character(len=:),allocatable,intent(out) :: msg !! !!##DESCRIPTION !! This function converts a string to a numeric value. !! !!##OPTIONS !! !! str holds string assumed to represent a numeric value !! val returned value. May be REAL or INTEGER. !! msg message describing error when ATON returns .false. !! !!##RETURNS !! aton .true. if the conversion was successful, .false. otherwise !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_aton !! !! use M_strings, only: aton !! implicit none !! character(len=14),allocatable :: strings(:) !! doubleprecision :: dv !! integer :: iv !! real :: rv !! integer :: i !! !! ! different strings representing INTEGER, REAL, and DOUBLEPRECISION !! strings=[& !! &' 10.345 ',& !! &'+10 ',& !! &' -3 ',& !! &' -4.94e-2 ',& !! &'0.1 ',& !! &'12345.678910d0',& !! &' ',& ! Note: will return zero without an error message !! &'1 2 1 2 1 . 0 ',& ! Note: spaces will be ignored !! &'WHAT? '] ! Note: error messages will appear, zero returned !! !! do i=1,size(strings) !! write(*,'(a)',advance='no')'STRING:',strings(i) !! if(aton(strings(i),iv)) write(*,'(g0)',advance='no')':INTEGER ',iv !! if(aton(strings(i),rv)) write(*,'(g0)',advance='no')':INTEGER ',rv !! if(aton(strings(i),dv)) write(*,'(g0)',advance='no')':INTEGER ',dv !! enddo !! !! end program demo_aton !! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain logical function ator_real32(str,val,msg) use iso_fortran_env, only: wp => real32, ip => int64, int8 ! Convert ASCII-text to DP and return .TRUE. if OK character(len=*),intent(in) :: str real(kind=wp) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: upper_e=iachar('E'), lower_e=iachar('e'), upper_d=iachar('D'), lower_d=iachar('d') integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-'), decimal=iachar('.') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: sval(3) integer :: digit_count(3) integer(kind=int8) :: value(3,len(str)) real(kind=wp) :: whole, fractional integer :: power integer :: cnt(6) integer(kind=int8) :: a, part integer :: i, ipos, ios, too_many_digit_count value=0.0_wp cnt=0 digit_count=0 ipos=0 ator_real32 = .false. sval = [1,0,1] part = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) digit_count(part) = digit_count(part) + 1 if(digit_count(part) < 19)then value(part,digit_count(part)) = a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif case(decimal) ! if more than once should report error if(part > 2)cnt(5)=99999 ! decimal in exponent part = 2 ! starting fractional value cnt(1)=cnt(1)+1 case(upper_e,lower_e,upper_d,lower_d) ! if more than once should report error part = 3 cnt(2)=cnt(2)+1 ! if more than one encountered an error ipos=0 case(minus_sign) ! sign in non-standard position or duplicated should report error sval(part) = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces ipos=ipos-1 case default value(part,:) = 0.0_wp cnt(5)=99999 ! unknown character !return end select enddo ! is no value after E an error? whole=0.0_wp do i = digit_count(1),1,-1 whole=whole+value(1,i)*10**(digit_count(1)-i) enddo power=0 do i = digit_count(3),1,-1 power=power+value(3,i)*10**(digit_count(3)-i) enddo fractional=0.0_wp do i = digit_count(2),1,-1 fractional=fractional+real(value(2,i),kind=wp)/10.0_wp**i enddo associate ( sgn=>sval(1), sexp=>sval(3) ) val = sign(whole + fractional,real(sgn,kind=wp))* (10.0_wp**(power*sexp+too_many_digit_count)) end associate if(all(cnt <= 1).and.ipos /= 0)then ator_real32 = .true. else read(str,fmt=*,iostat=ios) val ! use internal read for INF, NAN for now if(ios == 0)then ator_real32 = .true. if(present(msg)) msg='' else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(5) /= 0)then msg='decimal in exponent in "'//trim(str)//'"' elseif(cnt(1) >= 2)then msg='multiple decimals in "'//trim(str)//'"' elseif(cnt(2) >= 2)then msg='more than one exponent prefix (e,d,E,D) in "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif ator_real32 = .false. endif endif end function ator_real32 logical function ator_real64(str,val,msg) use iso_fortran_env, only: wp => real64, ip => int64, int8 ! Convert ASCII-text to DP and return .TRUE. if OK character(len=*),intent(in) :: str real(kind=wp) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: upper_e=iachar('E'), lower_e=iachar('e'), upper_d=iachar('D'), lower_d=iachar('d') integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-'), decimal=iachar('.') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: sval(3) integer :: digit_count(3) integer(kind=int8) :: value(3,len(str)) real(kind=wp) :: whole, fractional integer :: power integer :: cnt(6) integer(kind=int8) :: a, part integer :: i, ipos, ios, too_many_digit_count value=0.0_wp cnt=0 digit_count=0 ipos=0 ator_real64 = .false. sval = [1,0,1] part = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) digit_count(part) = digit_count(part) + 1 if(digit_count(part) < 19)then value(part,digit_count(part)) = a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif case(decimal) ! if more than once should report error if(part > 2)cnt(5)=99999 ! decimal in exponent part = 2 ! starting fractional value cnt(1)=cnt(1)+1 case(upper_e,lower_e,upper_d,lower_d) ! if more than once should report error part = 3 cnt(2)=cnt(2)+1 ! if more than one encountered an error ipos=0 case(minus_sign) ! sign in non-standard position or duplicated should report error sval(part) = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces ipos=ipos-1 case default value(part,:) = 0.0_wp cnt(5)=99999 ! unknown character !return end select enddo ! is no value after E an error? whole=0.0_wp do i = digit_count(1),1,-1 whole=whole+value(1,i)*10**(digit_count(1)-i) enddo power=0 do i = digit_count(3),1,-1 power=power+value(3,i)*10**(digit_count(3)-i) enddo fractional=0.0_wp do i = digit_count(2),1,-1 fractional=fractional+real(value(2,i),kind=wp)/10.0_wp**i enddo associate ( sgn=>sval(1), sexp=>sval(3) ) val = sign(whole + fractional,real(sgn,kind=wp))* (10.0_wp**(power*sexp+too_many_digit_count)) end associate if(all(cnt <= 1).and.ipos /= 0)then ator_real64 = .true. else read(str,fmt=*,iostat=ios) val ! use internal read for INF, NAN for now if(ios == 0)then ator_real64 = .true. if(present(msg)) msg='' else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(5) /= 0)then msg='decimal in exponent in "'//trim(str)//'"' elseif(cnt(1) >= 2)then msg='multiple decimals in "'//trim(str)//'"' elseif(cnt(2) >= 2)then msg='more than one exponent prefix (e,d,E,D) in "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif ator_real64 = .false. endif endif end function ator_real64 logical function atoi_int8(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int8) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int8 = .true. if(present(msg)) msg='' else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int8 = .false. endif end function atoi_int8 logical function atoi_int16(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int16) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int16 = .true. if(present(msg)) msg='' else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int16 = .false. endif end function atoi_int16 logical function atoi_int32(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int32) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int32 = .true. if(present(msg)) msg='' else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int32 = .false. endif end function atoi_int32 logical function atoi_int64(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int64) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int64 = .true. if(present(msg)) msg='' else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int64 = .false. endif end function atoi_int64 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end module M_strings !>>>>> build/dependencies/M_attr/src/M_attr.f90 !> !!##NAME !! M_attr(3f) - [M_attr::INTRO] control text attributes on terminals !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! !! use M_attr, only : attr, attr_mode, attr_update !! !! use M_attr, only : alert ! generate standard messages !! !!##DESCRIPTION !! M_attr(3f) is a Fortran module that uses common ANSI escape sequences !! to control terminal text attributes. !! !! use M_attr !! write(*,*)attr('Red Text! Green Text!') !! end !! !! It is designed to use three simple procedures to !! !! + Specify attributes using simple HTML-like syntax !! + allow the sequences to be suppressed when desired !! + permit the user program to completely customize the keywords. !! The user can add, delete and replace the sequences associated with !! a keyword without changing the code. !! !! One advantage of the approach of using formatting directives which !! are replaced with in-band escape sequences is that it is easy to turn !! off when running batch. !! !! Another important capability is that programs can be run in "raw" mode !! and create a simple text file with the formatting directives in it !! that can then be read back in by a simple filter program that strips !! it back to plain text( see app/plain.f90), or displays it to a screen !! in color(see app/light.f90) or perhaps converts it to another format. !! !! So this approach makes it trivial to read specially-formatted data !! from a file like a message catalog (perhaps with various versions in !! different languages) and colorize it or display it as plain text !! !! By making each line self-contained (by default) lines can be filtered !! by external utilities and still display correctly. !! !!##ACCESS !! Via git(1): !! !! git clone https://github.com/urbanjost/M_attr.git !! cd M_attr/src !! # change Makefile if not using one of the listed compilers !! make clean; make gfortran # for gfortran !! make clean; make ifort # for ifort !! make clean; make nvfortran # for nvfortran !! !! This will compile the M_attr module and example programs. !! !! Alternatively, via fpm (see https://github.com/fortran-lang/fpm): !! !! git clone https://github.com/urbanjost/M_attr.git !! !! or just list it as a dependency in your fpm.toml project file. !! !! [dependencies] !! M_attr = { git = "https://github.com/urbanjost/M_attr.git" } !! !!##LIMITATIONS !! o colors are not nestable. !! o keywords are case-sensitive, !! o ANSI escape sequences are not universally supported by !! all terminal emulators; and normally should be suppressed !! when not going to a tty device. Therefore, you should use !! M_system::system_istty(3f) or the common Fortran extension !! ISATTY() to set the default to "plain" instead of "color" !! when the output file is not a conforming terminal. On basic !! MSWindows console windows, it is best to use Windows 10+ and/or !! the Linux mode; you may have to enable ANSI escape sequence !! mode on MSWindows. It does work as-is with CygWin and MinGW and !! Putty windows and mintty(1) as tested. !! !!##EXAMPLE !! !! Sample program !! !! program demo_M_attr !! use M_attr, only : attr, attr_mode, attr_update, alert !! implicit none !! character(len=256) :: line !! character(len=*),parameter :: f='( & !! &" GREAT: & !! &The new value ",f8.4,1x," is in range"& !! &)' !! real :: value !! !! write(*,'(a)')& !! &attr(' ERROR: red text on a white background') !! !! value=3.4567 !! write(line,fmt=f) value !! write(*,'(a)')attr(trim(line)) !! !! ! write same string as plain text !! write(*,*) !! call attr_mode(manner='plain') !! write(*,'(a)')attr(trim(line)) !! !! call attr_mode(manner='color') !! ! use pre-defined or user defined strings !! write(*,*) !! write(*,'(a)')attr(' Woe is nigh.') !! write(*,'(a)')attr(' The night is young.') !! write(*,'(a)')attr(' It is Monday') !! !! call alert('', 'Woe is nigh.') !! call alert('', 'The night is young.') !! call alert('', 'It is Monday') !! !! ! create a custom mnemonic !! call attr_update('MYERROR',attr(& !! ' E-R-R-O-R: '& !! )) !! write(*,*) !! write(*,'(a)')attr(' my custom message style') !! !! end program demo_M_attr !! !!##AUTHOR !! John S. Urban, 2021 !! !!##LICENSE !! MIT !! !!##SEE ALSO !! attr(3f), attr_mode(3f), attr_update(3f) !! !! Related information: !! !! terminfo(3c), termlib(3c), tput(1), reset(1), clear(1), !! console_codes(4), ECMA-48, !! https://en.wikipedia.org/wiki/ANSI_escape_code module M_attr use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,stdin=>INPUT_UNIT,stdout=>OUTPUT_UNIT use, intrinsic :: iso_c_binding, only: c_int implicit none private public :: attr public :: attr_mode public :: attr_update public :: alert, advice private :: attr_matrix private :: attr_scalar private :: attr_scalar_width private :: get private :: locate ! find PLACE in sorted character array where value can be found or should be placed private :: insert ! insert entry into a sorted allocatable array at specified position private :: replace ! replace entry by index from a sorted allocatable array if it is present private :: remove ! delete entry by index from a sorted allocatable array if it is present private :: wipe_dictionary private :: vt102 interface attr module procedure attr_scalar module procedure attr_matrix module procedure attr_scalar_width end interface interface advice ! deprecated old name for alert(3f) module procedure alert end interface ! direct use of constant strings character(len=:),allocatable,save :: keywords(:) character(len=:),allocatable,save :: values(:) character(len=:),allocatable,save :: mono_values(:) character(len=:),allocatable,save :: mode ! mnemonics character(len=*),parameter :: NL=new_line('a') ! New line character. ! DECIMAL ! *-------*-------*-------*-------*-------*-------*-------*-------* ! | 00 nul| 01 soh| 02 stx| 03 etx| 04 eot| 05 enq| 06 ack| 07 bel| ! | 08 bs | 09 ht | 10 nl | 11 vt | 12 np | 13 cr | 14 so | 15 si | ! | 16 dle| 17 dc1| 18 dc2| 19 dc3| 20 dc4| 21 nak| 22 syn| 23 etb| ! | 24 can| 25 em | 26 sub| 27 esc| 28 fs | 29 gs | 30 rs | 31 us | ! | 32 sp | 33 ! | 34 " | 35 # | 36 $ | 37 % | 38 & | 39 ' | ! | 40 ( | 41 ) | 42 * | 43 + | 44 , | 45 - | 46 . | 47 / | ! | 48 0 | 49 1 | 50 2 | 51 3 | 52 4 | 53 5 | 54 6 | 55 7 | ! | 56 8 | 57 9 | 58 : | 59 ; | 60 < | 61 = | 62 > | 63 ? | ! | 64 @ | 65 A | 66 B | 67 C | 68 D | 69 E | 70 F | 71 G | ! | 72 H | 73 I | 74 J | 75 K | 76 L | 77 M | 78 N | 79 O | ! | 80 P | 81 Q | 82 R | 83 S | 84 T | 85 U | 86 V | 87 W | ! | 88 X | 89 Y | 90 Z | 91 [ | 92 \ | 93 ] | 94 ^ | 95 _ | ! | 96 ` | 97 a | 98 b | 99 c |100 d |101 e |102 f |103 g | ! |104 h |105 i |106 j |107 k |108 l |109 m |110 n |111 o | ! |112 p |113 q |114 r |115 s |116 t |117 u |118 v |119 w | ! |120 x |121 y |122 z |123 { |124 | |125 } |126 ~ |127 del| ! *-------*-------*-------*-------*-------*-------*-------*-------* character(len=*),parameter :: nul=achar(0) character(len=*),parameter :: bel =achar(7) ! ^G beeps; character(len=*),parameter :: bs =achar(8) ! ^H backspaces one column (but not past the beginning of the line); character(len=*),parameter :: ht =achar(9) ! ^I goes to next tab stop or to the end of the line if there is no earlier tab stop character(len=*),parameter :: lf =achar(10) ! ^J character(len=*),parameter :: vt =achar(11) ! ^K character(len=*),parameter :: ff =achar(12) ! ^L all give a linefeed, and if LF/NL (new-line mode) is set also a carriage return character(len=*),parameter :: cr =achar(13) ! ^M gives a carriage return; character(len=*),parameter :: so =achar(14) ! ^N activates the G1 character set; character(len=*),parameter :: si =achar(15) ! ^O activates the G0 character set; character(len=*),parameter :: can =achar(24) ! ^X interrupt escape sequences; character(len=*),parameter :: sub=achar(26) ! ^Z interrupt escape sequences; character(len=*),parameter :: esc =achar(27) ! ^[ starts an escape sequence; character(len=*),parameter :: del =achar(127) ! is ignored; ! codes character(len=*),parameter :: CODE_START=esc//'[' ! Start ANSI code, "\[". character(len=*),parameter :: CODE_END='m' ! End ANSI code, "m". character(len=*),parameter :: CODE_RESET=CODE_START//'0'//CODE_END ! Clear all styles, "\[0m". character(len=*),parameter :: CLEAR_DISPLAY=CODE_START//'2J' character(len=*),parameter :: HOME_DISPLAY=CODE_START//'H' character(len=*),parameter :: BELL=achar(7) character(len=*),parameter :: AT_BOLD='1', AT_ITALIC='3', AT_UNDERLINE='4', AT_INVERSE='7' character(len=*),parameter :: BLACK='0', RED='1', GREEN='2', YELLOW='3', BLUE='4', MAGENTA='5', CYAN='6', WHITE='7', DEFAULT='9' !prefixes character(len=*),parameter :: FG='3' character(len=*),parameter :: BG='4' character(len=*),parameter :: FG_INTENSE='9' character(len=*),parameter :: BG_INTENSE='10' character(len=*),parameter :: ON='' character(len=*),parameter :: OFF='2' ! foreground colors character(len=*),parameter,public :: fg_red = CODE_START//FG//RED//CODE_END character(len=*),parameter,public :: fg_cyan = CODE_START//FG//CYAN//CODE_END character(len=*),parameter,public :: fg_magenta = CODE_START//FG//MAGENTA//CODE_END character(len=*),parameter,public :: fg_blue = CODE_START//FG//BLUE//CODE_END character(len=*),parameter,public :: fg_green = CODE_START//FG//GREEN//CODE_END character(len=*),parameter,public :: fg_yellow = CODE_START//FG//YELLOW//CODE_END character(len=*),parameter,public :: fg_white = CODE_START//FG//WHITE//CODE_END character(len=*),parameter,public :: fg_ebony = CODE_START//FG//BLACK//CODE_END character(len=*),parameter,public :: fg_black = CODE_START//FG//BLACK//CODE_END character(len=*),parameter,public :: fg_default = CODE_START//FG//DEFAULT//CODE_END ! background colors character(len=*),parameter,public :: bg_red = CODE_START//BG//RED//CODE_END character(len=*),parameter,public :: bg_cyan = CODE_START//BG//CYAN//CODE_END character(len=*),parameter,public :: bg_magenta = CODE_START//BG//MAGENTA//CODE_END character(len=*),parameter,public :: bg_blue = CODE_START//BG//BLUE//CODE_END character(len=*),parameter,public :: bg_green = CODE_START//BG//GREEN//CODE_END character(len=*),parameter,public :: bg_yellow = CODE_START//BG//YELLOW//CODE_END character(len=*),parameter,public :: bg_white = CODE_START//BG//WHITE//CODE_END character(len=*),parameter,public :: bg_ebony = CODE_START//BG//BLACK//CODE_END character(len=*),parameter,public :: bg_black = CODE_START//BG//BLACK//CODE_END character(len=*),parameter,public :: bg_default = CODE_START//BG//DEFAULT//CODE_END ! attributes character(len=*),parameter,public :: bold = CODE_START//ON//AT_BOLD//CODE_END character(len=*),parameter,public :: italic = CODE_START//ON//AT_ITALIC//CODE_END character(len=*),parameter,public :: inverse = CODE_START//ON//AT_INVERSE//CODE_END character(len=*),parameter,public :: underline = CODE_START//ON//AT_UNDERLINE//CODE_END character(len=*),parameter,public :: unbold = CODE_START//'22'//CODE_END character(len=*),parameter,public :: unitalic = CODE_START//OFF//AT_ITALIC//CODE_END character(len=*),parameter,public :: uninverse = CODE_START//OFF//AT_INVERSE//CODE_END character(len=*),parameter,public :: ununderline = CODE_START//OFF//AT_UNDERLINE//CODE_END character(len=*),parameter,public :: reset = CODE_RESET character(len=*),parameter,public :: clear = HOME_DISPLAY//CLEAR_DISPLAY !private fmt private str integer,save :: alert_unit=stdout logical,save :: alert_debug=.true. logical,save :: alert_warn=.true. logical,save :: alert_info=.true. logical,save :: alert_error=.true. logical,save :: alert_other=.true. interface str module procedure msg_scalar, msg_one end interface str contains !> !!##NAME !! attr(3f) - [M_attr] substitute escape sequences for HTML-like syntax !! in strings !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! function attr(string,reset) result (expanded) !! !! ! scalar !! character(len=*),intent(in) :: string !! logical,intent(in),optional :: reset !! character(len=:),allocatable :: expanded !! ! or array !! character(len=*),intent(in) :: string(:) !! logical,intent(in),optional :: reset !! character(len=:),allocatable :: expanded(:) !! integer,intent(in),optional :: chars !! !!##DESCRIPTION !! Use HTML-like syntax to add attributes to terminal output such as !! color on devices that recognize ANSI escape sequences. !! !!##OPTIONS !! string input string of form !! !! "string ...". !! !! where the current attributes are color names, !! bold, italic, underline, ... !! !! reset By default, a sequence to clear all text attributes !! is sent at the end of each returned line if an escape !! character appears in the output string. This can be !! turned off by setting RESET to .false. . !! !! Note if turning off the reset attributes may be !! continued across lines, but if each line is not !! self-contained attributes may not display properly !! when filtered with commands such as grep(1). !! !! chars For arrays, a reset will be placed after the Nth !! displayable column count in order to make it easier !! to generate consistent right borders for non-default !! background colors for a text block. !!##KEYWORDS !! primary default keywords !! !! colors: !! r, red, R, RED !! g, green, G, GREEN !! b, blue, B, BLUE !! m, magenta, M, MAGENTA !! c, cyan, C, CYAN !! y, yellow, Y, YELLOW !! e, ebony, E, EBONY !! w, white, W, WHITE !! !! attributes: !! it, italic !! bo, bold !! un, underline !! !! basic control characters: !! nul !! bel (0x07, ^G) beeps; !! bs (0x08, ^H) backspaces one column (but not past the beginning of !! the line); !! ht (0x09, ^I) goes to the next tab stop or to the end of the line if !! there is no earlier tab stop; !! lf (0x0A, ^J), !! vt (0x0B, ^K) !! ff (0x0C, ^L) all give a linefeed, and if LF/NL (new-line mode) is !! set also a carriage return !! cr (0x0D, ^M) gives a carriage return; !! so (0x0E, ^N) activates the G1 character set; !! si (0x0F, ^O) activates the G0 character set; !! can (0x18, ^X) and SUB (0x1A, ^Z) interrupt escape sequences; !! sub !! esc (0x1B, ^[) starts an escape sequence; !! del (0x7F) is ignored; !! !! other: !! clear !! default !! reset !! gt !! lt !! save,DECSC Save current state (cursor coordinates, attributes, !! character sets pointed at by G0, G1). !! restore,DECRC Restore state most recently saved by ESC 7. !! CSI "Control Sequence Introducer"(0x9B) is equivalent to !! "ESC [". !! !! dual-value (one for color, one for mono): !! !! write(*,*)attr('an error message') !! write(*,*)attr('a warning message') !! write(*,*)attr('an informational message') !! !! By default, if the color mnemonics (ie. the keywords) are uppercase !! they change the background color. If lowercase, the foreground color. !! When preceded by a "/" character the attribute is returned to the !! default. !! !! The "default" keyword is typically used explicitly when reset=.false, !! and sets all text attributes to their initial defaults. !! !!##LIMITATIONS !! o colors are not nestable, keywords are case-sensitive, !! o not all terminals obey the sequences. On Windows, it is best if !! you use Windows 10+ and/or the Linux mode; although it has worked !! with all CygWin and MinGW and Putty windows and mintty. !! o you should use "" and "" instead of ">" and "<" in a string !! processed by attr(3f) instead of in any plain text output so that !! the raw mode will create correct input for the attr(3f) function !! if read back in. !! !!##EXAMPLE !! !! Sample program !! !! program demo_attr !! use M_attr, only : attr, attr_mode, attr_update !! call printstuff('defaults') !! !! call attr_mode(manner='plain') !! call printstuff('plain:') !! !! call printstuff('raw') !! !! call attr_mode(manner='color') !! call printstuff('') !! !! write(*,'(a)') attr('TEST ADDING A CUSTOM SEQUENCE:') !! call attr_update('blink',char(27)//'[5m') !! call attr_update('/blink',char(27)//'[25m') !! write(*,'(a)') attr('Items for Friday') !! !! contains !! subroutine printstuff(label) !! character(len=*),intent(in) :: label !! character(len=:),allocatable :: array(:) !! call attr_mode(manner=label) !! !! array=[character(len=60) :: & !! 'TEST MANNER='//label, & !! 'RED,GREEN,BLUE', & !! 'CYAN,MAGENTA,YELLOW', & !! 'WHITE and EBONY'] !! write(*,'(a)') attr(array) !! !! write(*,'(a)') attr('Adding bold') !! write(*,'(a)') attr('RED,GREEN,BLUE') !! write(*,'(a)') attr('CYAN,MAGENTA,YELLOW') !! write(*,'(a)') attr('WHITE and EBONY') !! !! write(*,'(a)') attr('Adding
    underline
') !! write(*,'(a)') attr(& !! &'
    RED,GREEN,BLUE
') !! write(*,'(a)') attr(& !! &'
    CYAN,MAGENTA,YELLOW
') !! write(*,'(a)') attr('
    WHITE and EBONY
') !! !! write(*,'(a)') attr('Adding
    italic
') !! write(*,'(a)') attr(& !! &'
    RED,GREEN,BLUE
') !! write(*,'(a)') attr(& !! &'
    CYAN,MAGENTA,YELLOW
') !! write(*,'(a)') attr('
    WHITE and EBONY
') !! !! write(*,'(a)') attr('Adding inverse') !! write(*,'(a)') attr('
    RED,GREEN,& !! &BLUE
') !! write(*,'(a)') attr('
    CYAN,MAGENTA,& !! &YELLOW
') !! write(*,'(a)') attr(& !! &'
    WHITE and EBONY
') !! end subroutine printstuff !! end program demo_attr !! !!##AUTHOR !! John S. Urban, 2021 !! !!##LICENSE !! MIT !! !!##SEE ALSO !! attr_mode(3f), attr_update(3f) function attr_scalar(string,reset) result (expanded) character(len=*),intent(in) :: string logical,intent(in),optional :: reset logical :: clear_at_end character(len=:),allocatable :: padded character(len=:),allocatable :: expanded character(len=:),allocatable :: name integer :: i integer :: ii integer :: maxlen integer :: place if(present(reset))then clear_at_end=reset else clear_at_end=.true. endif if(.not.allocated(mode))then ! set substitution mode mode='color' ! 'color'|'raw'|'plain' call vt102() endif if(mode=='raw')then expanded=string return endif maxlen=len(string) padded=string//' ' i=1 expanded='' do select case(padded(i:i)) case('>') ! should not get here unless unmatched i=i+1 expanded=expanded//'>' case('<') ! assuming not nested for now ii=index(padded(i+1:),'>') if(ii.eq.0)then expanded=expanded//'<' i=i+1 else name=padded(i+1:i+ii-1) name=trim(adjustl(name)) call locate(keywords,name,place) if(mode.eq.'plain')then expanded=expanded//get(name) elseif(place.le.0)then ! unknown name; print what you found expanded=expanded//padded(i:i+ii) maxlen=maxlen-ii-1 else expanded=expanded//get(name) endif i=ii+i+1 endif case default expanded=expanded//padded(i:i) i=i+1 end select if(i >= maxlen+1)exit enddo if( (index(expanded,esc).ne.0).and.(clear_at_end))then if((mode.ne.'raw').and.(mode.ne.'plain'))then expanded=expanded//CODE_RESET ! Clear all styles endif endif expanded=expanded end function attr_scalar function attr_matrix(strings,reset,chars) result (expanded) character(len=*),intent(in) :: strings(:) logical,intent(in),optional :: reset integer,intent(in),optional :: chars character(len=:),allocatable :: expanded(:) ! gfortran does not return allocatable array from a function properly, but works with subroutine call kludge_bug(strings,reset,chars,expanded) end function attr_matrix subroutine kludge_bug(strings,reset,chars,expanded) character(len=*),intent(in) :: strings(:) logical,intent(in),optional :: reset integer,intent(in),optional :: chars character(len=:),allocatable :: expanded(:) integer :: width character(len=:),allocatable :: hold integer :: i integer :: right integer :: len_local allocate(character(len=0) :: expanded(0)) if(present(chars))then right=chars else right=len(strings) endif if(.not.allocated(mode))then ! set substitution mode mode='color' ! 'color'|'raw'|'plain' call vt102() endif do i=1,size(strings) if(mode.eq.'color')then mode='plain' len_local=len(attr_scalar(strings(i))) hold=trim(strings(i))//repeat(' ',max(0,right-len_local)) mode='color' else hold=strings(i) endif hold=trim(attr_scalar(hold,reset=reset)) width=max(len(hold),len(expanded)) expanded=[character(len=width) :: expanded,hold] enddo end subroutine kludge_bug function attr_scalar_width(string,reset,chars) result (expanded) character(len=*),intent(in) :: string logical,intent(in),optional :: reset integer,intent(in) :: chars character(len=:),allocatable :: expanded_arr(:) character(len=:),allocatable :: expanded expanded_arr=attr_matrix([string],reset,chars) expanded=expanded_arr(1) end function attr_scalar_width subroutine vt102() ! create a dictionary with character keywords, values, and value lengths ! using the routines for maintaining a list call wipe_dictionary() ! insert and replace entries call attr_update('bold',bold) call attr_update('/bold',unbold) call attr_update('bo',bold) call attr_update('/bo',unbold) call attr_update('italic',italic) call attr_update('/italic',unitalic) call attr_update('it',italic) call attr_update('/it',unitalic) call attr_update('inverse',inverse) call attr_update('/inverse',uninverse) call attr_update('in',inverse) call attr_update('/in',uninverse) call attr_update('underline',underline) call attr_update('/underline',ununderline) call attr_update('un',underline) call attr_update('/un',ununderline) call attr_update('ul',underline) call attr_update('/ul',ununderline) call attr_update('bell',BELL) call attr_update('nul', nul ) call attr_update('bel', bel ) call attr_update('bs', bs ) call attr_update('ht', ht ) call attr_update('lf', lf ) call attr_update('vt', vt ) call attr_update('ff', ff ) call attr_update('cr', cr ) call attr_update('so', so ) call attr_update('si', si ) call attr_update('can', can ) call attr_update('sub', sub ) call attr_update('esc', esc ) call attr_update('escape',esc) call attr_update('del', del ) call attr_update('save',esc//'7') call attr_update('DECSC',esc//'7') call attr_update('restore',esc//'8') call attr_update('DECRC',esc//'8') call attr_update('CSI',esc//'[') call attr_update('clear',clear) call attr_update('reset',reset) call attr_update('gt','>','>') call attr_update('lt','<','<') ! foreground colors call attr_update('r',fg_red) call attr_update('/r',fg_default) call attr_update('red',fg_red) call attr_update('/red',fg_default) call attr_update('fg_red',fg_red) call attr_update('/fg_red',fg_default) call attr_update('c',fg_cyan) call attr_update('/c',fg_default) call attr_update('cyan',fg_cyan) call attr_update('/cyan',fg_default) call attr_update('fg_cyan',fg_cyan) call attr_update('/fg_cyan',fg_default) call attr_update('m',fg_magenta) call attr_update('/m',fg_default) call attr_update('magenta',fg_magenta) call attr_update('/magenta',fg_default) call attr_update('fg_magenta',fg_magenta) call attr_update('/fg_magenta',fg_default) call attr_update('b',fg_blue) call attr_update('/b',fg_default) call attr_update('blue',fg_blue) call attr_update('fg_blue',fg_blue) call attr_update('/fg_blue',fg_default) call attr_update('g',fg_green) call attr_update('/g',fg_default) call attr_update('green',fg_green) call attr_update('/green',fg_default) call attr_update('fg_green',fg_green) call attr_update('/fg_green',fg_default) call attr_update('y',fg_yellow) call attr_update('/y',fg_default) call attr_update('yellow',fg_yellow) call attr_update('/yellow',fg_default) call attr_update('fg_yellow',fg_yellow) call attr_update('/fg_yellow',fg_default) call attr_update('w',fg_white) call attr_update('/w',fg_default) call attr_update('white',fg_white) call attr_update('/white',fg_default) call attr_update('fg_white',fg_white) call attr_update('/fg_white',fg_default) call attr_update('e',fg_ebony) call attr_update('/e',fg_default) call attr_update('ebony',fg_ebony) call attr_update('/ebony',fg_default) call attr_update('fg_ebony',fg_ebony) call attr_update('/fg_ebony',fg_default) call attr_update('x',fg_ebony) call attr_update('/x',fg_default) call attr_update('black',fg_ebony) call attr_update('/black',fg_default) call attr_update('fg_black',fg_ebony) call attr_update('/fg_black',fg_default) ! background colors call attr_update('R',bg_red) call attr_update('/R',bg_default) call attr_update('RED',bg_red) call attr_update('/RED',bg_default) call attr_update('bg_red',bg_red) call attr_update('/bg_red',bg_default) call attr_update('C',bg_cyan) call attr_update('/C',bg_default) call attr_update('CYAN',bg_cyan) call attr_update('/CYAN',bg_default) call attr_update('bg_cyan',bg_cyan) call attr_update('/bg_cyan',bg_default) call attr_update('M',bg_magenta) call attr_update('/M',bg_default) call attr_update('MAGENTA',bg_magenta) call attr_update('/MAGENTA',bg_default) call attr_update('bg_magenta',bg_magenta) call attr_update('/bg_magenta',bg_default) call attr_update('B',bg_blue) call attr_update('/B',bg_default) call attr_update('BLUE',bg_blue) call attr_update('/BLUE',bg_default) call attr_update('bg_blue',bg_blue) call attr_update('/bg_blue',bg_default) call attr_update('G',bg_green) call attr_update('/G',bg_default) call attr_update('GREEN',bg_green) call attr_update('/GREEN',bg_default) call attr_update('bg_green',bg_green) call attr_update('/bg_green',bg_default) call attr_update('Y',bg_yellow) call attr_update('/Y',bg_default) call attr_update('YELLOW',bg_yellow) call attr_update('/YELLOW',bg_default) call attr_update('bg_yellow',bg_yellow) call attr_update('/bg_yellow',bg_default) call attr_update('W',bg_white) call attr_update('/W',bg_default) call attr_update('WHITE',bg_white) call attr_update('/WHITE',bg_default) call attr_update('bg_white',bg_white) call attr_update('/bg_white',bg_default) call attr_update('E',bg_ebony) call attr_update('/E',bg_default) call attr_update('EBONY',bg_ebony) call attr_update('/EBONY',bg_default) call attr_update('bg_ebony',bg_ebony) call attr_update('/bg_ebony',bg_default) call attr_update('X',bg_ebony) call attr_update('/X',bg_default) call attr_update('BLACK',bg_ebony) call attr_update('/BLACK',bg_default) call attr_update('bg_black',bg_ebony) call attr_update('/bg_black',bg_default) ! compound call attr_update('ERROR',fg_red//bold//bg_ebony //':error: '//bg_default//fg_default,':error:') call attr_update('WARNING',fg_yellow//bold//bg_ebony//':warning:'//bg_default//fg_default,':warning:') call attr_update('INFO',fg_green//bold//bg_ebony //':info: '//bg_default//fg_default,':info:') end subroutine vt102 !> !! !> !!##NAME !! attr_mode(3f) - [M_attr] select processing mode for output from attr(3f) !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! subroutine attr_mode(manner) !! !! character(len=*),intent(in) :: manner !! !!##DESCRIPTION !! Turn off the generation of strings associated with the HTML keywords !! in the string generated by the attr(3f) function, or display the !! text in raw mode as it was passed to attr(3f) or return to ANSI !! escape control sequence generation. !! !!##OPTIONS !! MANNER The current manners or modes supported via the attr_mode(3f) !! procedure are !! !! plain suppress the output associated with keywords !! color(default) commonly supported escape sequences !! raw echo the input to attr(3f) as its output !! reload restore original keyword meanings deleted or !! replaced by calls to attr_update(3f). !! !!##EXAMPLE !! !! Sample program !! !! program demo_attr_mode !! use M_attr, only : attr, attr_mode !! implicit none !! character(len=:),allocatable :: lines(:) !! character(len=:),allocatable :: outlines(:) !! integer :: i !! lines=[character(len=110):: & !! &'',& !! &' Suffice it to say that black and white are also colors',& !! &' for their simultaneous contrast is as striking as that ',& !! &' of green and red, for instance. & !! & --- Vincent van Gogh',& !! &' '] !! !! outlines=attr(lines,chars=57) !! write(*,'(a)')(trim(outlines(i)),i=1,size(outlines)) !! !! call attr_mode(manner='plain') ! write as plain text !! write(*,'(a)')attr(lines) !! !! call attr_mode(manner='raw') ! write as-is !! write(*,'(a)')attr(lines) !! !! call attr_mode(manner='ansi') ! return to default mode !! !! end program demo_attr_mode !! !!##AUTHOR !! John S. Urban, 2021 !! !!##LICENSE !! MIT subroutine attr_mode(manner) character(len=*),intent(in) :: manner integer :: i if(.not.allocated(mode))then ! set substitution mode mode='color' call vt102() endif select case(manner) case('vt102','ANSI','ansi','color','COLOR') mode='color' case('reload','default','defaults','') call vt102() mode='color' case('raw') mode='raw' case('dump') ! dump dictionary for debugging if(allocated(keywords))then if(size(keywords).gt.0)then write(stderr,'(*(a,t30,a))')'KEYWORD','VALUE' write(stderr,'(*(a,t30,2("[",a,"]"),/))')(trim(keywords(i)),values(i),mono_values(i),i=1,size(keywords)) endif endif case('dummy','plain','text') mode='plain' case default write(*,*)'unknown manner. Try color|raw|plain' mode='color' end select end subroutine attr_mode subroutine wipe_dictionary() if(allocated(keywords))deallocate(keywords) allocate(character(len=0) :: keywords(0)) if(allocated(values))deallocate(values) allocate(character(len=0) :: values(0)) if(allocated(mono_values))deallocate(mono_values) allocate(character(len=0) :: mono_values(0)) end subroutine wipe_dictionary !> !! !> !!##NAME !! attr_update(3f) - [M_attr] update internal dictionary given keyword !! and value !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! subroutine attr_update(key,val) !! !! character(len=*),intent(in) :: key !! character(len=*),intent(in),optional :: val !! character(len=*),intent(in),optional :: mono_val !! !!##DESCRIPTION !! Update internal dictionary in M_attr(3fm) module. !! !!##OPTIONS !! key name of keyword to add, replace, or delete from dictionary !! val if present add or replace value associated with keyword. If !! not present remove keyword entry from dictionary. !! mono_val if present add or replace second value associated with !! keyword used for plain text mode. !! Must only be specified if VAL is also specified. !! !!##KEYWORDS !! The following keywords are defined by default !! !! colors: !! !! r,red c,cyan w,white !! g,green m,magenta e,ebony !! b,blue y,yellow !! !! If the color keywords are capitalized they control the text background !! instead of the text color. !! !! attributes: !! !! ul,underline !! it,italics (often produces inverse colors on many devices !! !!##EXAMPLE !! !! Sample program !! !! program demo_update !! use M_attr, only : attr, attr_update !! write(*,'(a)') attr('TEST CUSTOMIZATIONS:') !! ! add custom keywords !! call attr_update('blink',char(27)//'[5m') !! call attr_update('/blink',char(27)//'[25m') !! write(*,*) !! write(*,'(a)') attr('Items for Friday') !! call attr_update('ouch',attr( & !! ' BIG mistake! ')) !! write(*,*) !! write(*,'(a)') attr(' Did not see that coming.') !! write(*,*) !! write(*,'(a)') attr( & !! 'ORIGINALLY: Apple, Sky, Grass') !! ! delete !! call attr_update('r') !! call attr_update('/r') !! ! replace (or create) !! call attr_update('b','<<<<') !! call attr_update('/b','>>>>') !! write(*,*) !! write(*,'(a)') attr( & !! 'CUSTOMIZED: Apple, Sky, Grass') !! end program demo_update !! !!##AUTHOR !! John S. Urban, 2021 !! !!##LICENSE !! MIT subroutine attr_update(key,valin,mono_valin) character(len=*),intent(in) :: key character(len=*),intent(in),optional :: valin character(len=*),intent(in),optional :: mono_valin integer :: place character(len=:),allocatable :: val character(len=:),allocatable :: mono_val if(.not.allocated(mode))then ! set substitution mode mode='color' ! 'color'|'raw'|'plain' call vt102() endif if(present(mono_valin))then mono_val=mono_valin else mono_val='' endif if(present(valin))then val=valin ! find where string is or should be call locate(keywords,key,place) ! if string was not found insert it if(place.lt.1)then call insert(keywords,key,iabs(place)) call insert(values,val,iabs(place)) call insert(mono_values,mono_val,iabs(place)) else call replace(values,val,place) call replace(mono_values,mono_val,place) endif else call locate(keywords,key,place) if(place.gt.0)then call remove(keywords,place) call remove(values,place) call remove(mono_values,place) endif endif end subroutine attr_update function get(key) result(valout) character(len=*),intent(in) :: key character(len=:),allocatable :: valout integer :: place ! find where string is or should be call locate(keywords,key,place) if(place.lt.1)then valout='' else if(mode.eq.'plain')then valout=trim(mono_values(place)) else valout=trim(values(place)) endif endif end function get subroutine locate(list,value,place,ier,errmsg) character(len=*),intent(in) :: value integer,intent(out) :: place character(len=:),allocatable :: list(:) integer,intent(out),optional :: ier character(len=*),intent(out),optional :: errmsg integer :: i character(len=:),allocatable :: message integer :: arraysize integer :: maxtry integer :: imin, imax integer :: error if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif arraysize=size(list) error=0 if(arraysize.eq.0)then maxtry=0 place=-1 else maxtry=nint(log(float(arraysize))/log(2.0)+1.0) place=(arraysize+1)/2 endif imin=1 imax=arraysize message='' LOOP: block do i=1,maxtry if(value.eq.list(PLACE))then exit LOOP else if(value.gt.list(place))then imax=place-1 else imin=place+1 endif if(imin.gt.imax)then place=-imin if(iabs(place).gt.arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place=(imax+imin)/2 if(place.gt.arraysize.or.place.le.0)then message='*locate* error: search is out of bounds of list. Probably an unsorted input array' error=-1 exit LOOP endif enddo message='*locate* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if(present(ier))then ier=error else if(error.ne.0)then write(stderr,*)message//' VALUE=',trim(value)//' PLACE=',place stop 1 endif if(present(errmsg))then errmsg=message endif end subroutine locate subroutine remove(list,place) character(len=:),allocatable :: list(:) integer,intent(in) :: place integer :: ii, end if(.not.allocated(list))then list=[character(len=2) :: ] endif ii=len(list) end=size(list) if(place.le.0.or.place.gt.end)then ! index out of bounds of array elseif(place.eq.end)then ! remove from array list=[character(len=ii) :: list(:place-1) ] else list=[character(len=ii) :: list(:place-1), list(place+1:) ] endif end subroutine remove subroutine replace(list,value,place) character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) character(len=:),allocatable :: kludge(:) integer,intent(in) :: place integer :: ii integer :: tlen integer :: end if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif tlen=len_trim(value) end=size(list) if(place.lt.0.or.place.gt.end)then write(stderr,*)'*replace* error: index out of range. end=',end,' index=',place elseif(len_trim(value).le.len(list))then list(place)=value else ! increase length of variable ii=max(tlen,len(list)) kludge=[character(len=ii) :: list ] list=kludge list(place)=value endif end subroutine replace subroutine insert(list,value,place) character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) character(len=:),allocatable :: kludge(:) integer,intent(in) :: place integer :: ii integer :: end if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif ii=max(len_trim(value),len(list),2) end=size(list) if(end.eq.0)then ! empty array list=[character(len=ii) :: value ] elseif(place.eq.1)then ! put in front of array kludge=[character(len=ii) :: value, list] list=kludge elseif(place.gt.end)then ! put at end of array kludge=[character(len=ii) :: list, value ] list=kludge elseif(place.ge.2.and.place.le.end)then ! put in middle of array kludge=[character(len=ii) :: list(:place-1), value,list(place:) ] list=kludge else ! index out of range write(stderr,*)'*insert* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine insert !> !! !> !!##NAME !! alert(3f) - [M_attr] print messages using a standard format including !! time and program name !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! subroutine alert(message,& !! g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj) !! !! character(len=*),intent(in),optional :: type !! character(len=*),intent(in),optional :: message !! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9, & !! & ga,gb,gc,gd,ge,gf,gg,gh,gi,gj !! !!##DESCRIPTION !! Display a message prefixed with a timestamp and the name !! of the calling program when the TYPE is specified as any !! of 'error','warn', or 'info'. !! !! It also allows the keywords !! ,,,,,
,,, to be used in the !! message (which is passed to ATTR(3f)). !! !! Note that time stamp keywords will only be updated when using ALERT(3f) !! and will only be displayed in color mode! !! !!##OPTIONS !! TYPE if present and one of 'warn','message','info', or 'debug' !! a predefined message is written to stderr of the form !! !! :
::. : () : TYPE -> message !! !! MESSAGE the user-supplied message to display via a call to ATTR(3f) !! !! g[0-9a-j] optional values to print after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, !! COMPLEX, or CHARACTER. !! !! if no parameters are supplied the macros are updated but no output !! is generated. !! !!##EXAMPLE !! !! Sample program !! !! program demo_alert !! use M_attr, only : alert, attr, attr_mode !! implicit none !! real X !! call attr_mode(manner='plain') !! call attr_mode(manner='color') !! call alert("error",& !! "Say you didn't!") !! call alert("warn", & !! "I wouldn't if I were you, Will Robinson.") !! call alert("info", & !! "I fixed that for you, but it was a bad idea.") !! call alert("debug", & !! "Who knows what is happening now?.") !! call alert("??? ", "not today you don't") !! ! call to just update the macros !! call alert() !! ! conventional call to ATTR(3f) using the ALERT(3f)-defined macros !! write(*,*)attr(& !! 'The year was , the month was ') !! ! optional arguments !! X=211.3 !! call alert('error',& !! 'allowed range of X is 0 X 100, X=',X) !! ! up to twenty values are allowed of intrinsic type !! call alert('info','values are',10,234.567,& !! cmplx(11.0,22.0),123.456d0,'today') !! end program demo_alert !! !! Results: !! !! 00:38:30: (prg) : error -> Say you didn't! !! 00:38:30: (prg) : warning -> I wouldn't if I were you, ... !! Will Robinson. !! 00:38:30: (prg) : info -> I fixed that for you, ... !! but it was a bad idea. !! 00:38:30: (prg) : debug -> Who knows what is happening now?. ... !! 00:38:30: (prg) : ??? -> not today you don't !! 00:38:30: (prg) : error -> allowed range of X is 0 X 100, ... !! X= 211.300003 !! 00:38:30: (prg) : info -> values are 10 234.567001 ... !! (11.0000000,22.0000000) ... !! 123.45600000000000 today !! !!##AUTHOR !! John S. Urban, 2021 !! !!##LICENSE !! MIT subroutine alert(type,message,g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj) ! TODO: could add a warning level to ignore info, or info|warning, or all implicit none character(len=*),intent(in),optional :: type character(len=*),intent(in),optional :: message class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj character(len=8) :: dt character(len=10) :: tm character(len=5) :: zone integer,dimension(8) :: values character(len=4096) :: arg0 character(len=:),allocatable :: new_message character(len=:),allocatable :: other logical :: printme call date_and_time(dt,tm,zone,values) call attr_update('YE',dt(1:4),dt(1:4)) call attr_update('MO',dt(5:6),dt(5:6)) call attr_update('DA',dt(7:8),dt(7:8)) call attr_update('HR',tm(1:2),tm(1:2)) call attr_update('MI',tm(3:4),tm(3:4)) call attr_update('SE',tm(5:6),tm(5:6)) call attr_update('MS',tm(8:10),tm(8:10)) call attr_update('TZ',zone,zone) call get_command_argument(0,arg0) if(index(arg0,'/').ne.0) arg0=arg0(index(arg0,'/',back=.true.)+1:) if(index(arg0,'\').ne.0) arg0=arg0(index(arg0,'\',back=.true.)+1:) call attr_update('ARG0',arg0,arg0) printme=.true. if(present(type))then new_message= ' '//tm(1:2)//':'//tm(3:4)//':'//tm(5:6)//'.'//tm(8:10)//' : ('//trim(arg0)//') : ' other=message//' '//str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj) select case(type) case('warn','WARN','warning','WARNING') new_message= new_message//'warning - ' printme=alert_warn case('info','INFO','information','INFORMATION') new_message= new_message//'info - ' printme=alert_info case('error','ERROR') new_message= new_message//'error - ' printme=alert_error case('debug','DEBUG') new_message= new_message//'debug - ' printme=alert_debug case default new_message= new_message//''//type//' - ' printme=alert_other end select if(printme)then write(alert_unit,'(a)')attr(trim(new_message//other)) endif elseif(present(message))then write(alert_unit,'(a)')attr(trim(other)) endif end subroutine alert !> !!##NAME !! str(3f) - [M_attr] converts any standard scalar type to a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! Syntax: !! !! function str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,& !! & ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep) !! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 !! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj !! character(len=*),intent(in),optional :: sep !! character,len=(:),allocatable :: str !! !!##DESCRIPTION !! str(3f) builds a space-separated string from up to twenty scalar !! values. !! !!##OPTIONS !! g[0-9a-j] optional value to print the value of after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, !! COMPLEX, or CHARACTER. !! !! Optionally, all the generic values can be !! single-dimensioned arrays. Currently, mixing scalar !! arguments and array arguments is not supported. !! !! sep separator string used between values. Defaults to a space. !! !!##RETURNS !! str description to print !! !!##EXAMPLES !! !! Sample program: !! !! program demo_msg !! use M_attr, only : alert !! end program demo_msg !! !! Output !! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function msg_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, & & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, & & sep) implicit none ! ident_1="@(#) M_attr msg_scalar(3fp) writes a message to a string composed of any standard scalar types" class(*),intent(in),optional :: generic0, generic1, generic2, generic3, generic4 class(*),intent(in),optional :: generic5, generic6, generic7, generic8, generic9 class(*),intent(in),optional :: generica, genericb, genericc, genericd, generice class(*),intent(in),optional :: genericf, genericg, generich, generici, genericj character(len=:),allocatable :: msg_scalar character(len=4096) :: line integer :: istart integer :: increment character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local if(present(sep))then increment=len(sep)+1 sep_local=sep else increment=2 sep_local=' ' endif istart=1 line='' if(present(generic0))call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) if(present(generica))call print_generic(generica) if(present(genericb))call print_generic(genericb) if(present(genericc))call print_generic(genericc) if(present(genericd))call print_generic(genericd) if(present(generice))call print_generic(generice) if(present(genericf))call print_generic(genericf) if(present(genericg))call print_generic(genericg) if(present(generich))call print_generic(generich) if(present(generici))call print_generic(generici) if(present(genericj))call print_generic(genericj) msg_scalar=trim(line) contains subroutine print_generic(generic) !use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128 use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic end function msg_scalar function msg_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,& & generica,genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj,& & sep) implicit none ! ident_2="@(#) M_attr msg_one(3fp) writes a message to a string composed of any standard one dimensional types" class(*),intent(in) :: generic0(:) class(*),intent(in),optional :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) class(*),intent(in),optional :: generica(:), genericb(:), genericc(:), genericd(:), generice(:) class(*),intent(in),optional :: genericf(:), genericg(:), generich(:), generici(:), genericj(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then increment=1+len(sep) sep_local=sep else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) if(present(generica))call print_generic(generica) if(present(genericb))call print_generic(genericb) if(present(genericc))call print_generic(genericc) if(present(genericd))call print_generic(genericd) if(present(generice))call print_generic(generice) if(present(genericf))call print_generic(genericf) if(present(genericg))call print_generic(genericg) if(present(generich))call print_generic(generich) if(present(generici))call print_generic(generici) if(present(genericj))call print_generic(genericj) msg_one=trim(line) contains subroutine print_generic(generic) !use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128 use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic !type is (real(kind=real256)); write(error_unit,'(1pg0)',advance='no') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic class default stop 'unknown type in *print_generic*' end select istart=len_trim(line)+increment+1 line=trim(line)//']'//sep_local end subroutine print_generic end function msg_one end module M_attr !>>>>> app/fpm-man.f90 program fman use M_intrinsics, only : help_intrinsics use M_CLI2, only : set_args, sget, lget, specified, topics=>unnamed use M_match, only : getpat, match, regex_pattern use M_match, only : YES, ERR use M_strings, only : lower, indent, atleast use M_attr, only : attr implicit none type(regex_pattern) :: p, start_p, end_p character(len=:),allocatable :: help_text(:), version_text(:) character(len=256),allocatable :: manual(:),section(:) character(len=:),allocatable :: regex, start, end character(len=:),allocatable :: query integer :: i, j, k logical :: topic logical :: prefix, ignorecase, demo, color ! process command line call setup() call set_args(' --regex:e " " --ignorecase:i F --topic_only:t F --demo:d F --color:c -query:Q " " & & -start:S " " -end:E "^[A-Z][A-Z_ ]*$" --prefixoff:O F',& & help_text,version_text) regex=sget('regex') start=sget('start') end=sget('end') topic=lget('topic_only') ignorecase=lget('ignorecase') demo=lget('demo') color=lget('color') query=sget('query') ! if -t then just show topic names and exit if(topic)then manual = help_intrinsics('',topic=topic) ! could truncate if name is too long, could get a bit fancier or use ! M_display(3f) and have default just print one per line write(*,'(3(g0))') ( [character(len=80/3) :: manual(i)], i=1, size(manual) ) stop endif ! compile any regular expression ! Also, if doing a regular expression and not the single topic "toc" ! add a section prefix when building manual ! initially assume prefixing is off unless a regular expression is used if(regex.ne.' '.or.start.ne.' ')then prefix=.true. else prefix=.false. endif ! normalize the topics list ! ensure there is at least one topic by applying a default if(size(topics).eq.0)then topics=['toc'] endif if( ( size(topics).eq.1 .and. topics(1).eq.'toc') )then prefix=.false. ignorecase=.true. endif if(specified('prefixoff'))then prefix=.not.lget('prefixoff') endif if(regex.ne.' ')then if (getpat(merge(lower(regex),regex,ignorecase), p%pat) .eq. ERR) then stop '*fman* Illegal regex pattern.' endif endif if(start.ne.' ')then if (getpat(merge(lower(start),start,ignorecase), start_p%pat) .eq. ERR) then stop '*fman* Illegal start pattern.' endif if (getpat(merge(lower(end),end,ignorecase), end_p%pat) .eq. ERR) then stop '*fman* Illegal end pattern.' endif endif if(lget('verbose'))then write(*,'(*(g0:,1x))')'AFTER NORMALIZING:' write(*,'(*(g0:,1x))')'REGEX ',regex write(*,'(*(g0:,1x))')'IGNORECASE ',ignorecase write(*,'(*(g0:,1x))')'TOPIC_ONLY ',topic write(*,'(*(g0:,1x))')'PREFIX ',prefix write(*,'(*(g0:,1x))')'DEMO ',demo write(*,'(*(g0:,1x))')'TOPICS ',topics write(*,'(*(g0:,1x))')'START ',start write(*,'(*(g0:,1x))')'END ',end endif ! build text to display or search manual=[character(len=0) ::] do i=1, size(topics) section = help_intrinsics(topics(i),prefix=prefix) if(color)section=crayons(section) ! extract demo program if found (has to follow specific format) if(demo)then call find_demo() endif if(start /= '' )then call find_start() endif manual = [character(len=max(len(manual),len(section))) :: manual,section] enddo ! display selected text if(size(manual).eq.0)then write(*,'(g0)')'Sorry. did not find that. Perhaps you should search the TOC. try' write(*,'(g0)')' fman -e TOPIC' write(*,'(g0)')'or search the entire manual:' write(*,'(g0)')' fman manual -i -e TOPIC' stop 1 else ! display what was found do i=1,size(manual) if(regex.ne.'')then select case(ignorecase) case(.true.) if(match(lower(trim(manual(i)))//char(10), p%pat) .eq. YES) then write(*,'(g0)')trim(manual(i)) endif case(.false.) if (match(trim(manual(i))//char(10), p%pat) .eq. YES) then write(*,'(g0)')trim(manual(i)) endif end select else write(*,'(g0)')trim(manual(i)) endif enddo endif contains subroutine find_demo() character(len=256),allocatable :: newsection(:) integer :: ii,jj,kk integer :: start_keep, end_keep if(allocated(newsection)) deallocate(newsection) allocate(newsection(0)) if(demo)then start_keep=0 end_keep=0 jj=0 do ii=1,size(section) jj=jj+1 if(jj.gt.size(section))exit if(index(lower(section(jj)),'program demo_').ne.0)then start_keep=jj do kk=start_keep+1,size(section) if(kk.gt.size(section))exit if(index(lower(section(kk)),'end program demo_').ne.0)then end_keep=kk if(start_keep.ne.0 .and. end_keep.ne.0)then newsection=[character(len=max(len(newsection),len(section))) :: newsection,section(start_keep:end_keep)] jj=kk+1 endif exit endif enddo endif enddo endif if(size(newsection).eq.0)then write(*,*)'! *fman* standard demo code format not found for ',trim(topics(i)) section=[''] else section=newsection deallocate(newsection) endif end subroutine find_demo subroutine find_start() character(len=256),allocatable :: newsection(:) integer :: ii,jj,kk,ic integer :: start_keep, end_keep if(size(section).eq.0)return if(allocated(newsection)) deallocate(newsection) allocate(newsection(0)) if(specified('start'))then start_keep=0 end_keep=0 jj=0 do jj=jj+1 if(prefix)then ic=index(section(jj),':')+1 else ic=1 endif if(jj.gt.size(section))exit if(match(trim(section(jj)(ic:))//char(10), start_p%pat) .eq. YES) then start_keep=jj do kk=start_keep+1,size(section) if(kk.gt.size(section))exit if (match(trim(section(kk)(ic:))//char(10), end_p%pat) .eq. YES) then end_keep=kk-1 if(start_keep.gt.0 .and. end_keep .gt. 0)then newsection=[character(len=max(len(newsection),len(section))) :: newsection,section(start_keep:end_keep)] jj=kk+1 endif exit endif enddo endif if(jj.ge.size(section))exit enddo endif if(size(newsection).eq.0)then write(*,*)'! *fman* standard start code format not found for ',trim(topics(i)) section=[''] else section=newsection deallocate(newsection) endif end subroutine find_start function crayons(oldblock) result(newblock) ! just playing. There is a lot of stuff not done robustly here character(len=256),intent(in),allocatable :: oldblock(:) character(len=256),allocatable :: newblock(:) integer :: ilen integer :: lead logical :: program_text program_text=.false. newblock= oldblock lead=0 do j=1,size(oldblock) if( index(oldblock(j),'end program demo_') .eq. 0 .and. index(oldblock(j),'program demo_') .ne. 0)then program_text=.true. lead=indent(oldblock(j)) endif if(program_text .eqv. .true.)then newblock(j)=attr(''//repeat(' ',lead)//''//atleast(trim(oldblock(j)(lead+1:)),80-lead) ) elseif(verify(oldblock(j)(1:1), 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ) == 0 .and. & & verify(oldblock(j), 'ABCDEFGHIJKLMNOPQRSTUVWXYZ _') == 0 )then ilen=len_trim(oldblock(j)) newblock(j)=attr(' '//trim(oldblock(j))//' '//repeat(' ',max(0,80-ilen-2))//'') else ilen=len_trim(oldblock(j)) ilen=len_trim(than(oldblock(j)))-ilen newblock(j)=attr(''//atleast(than(oldblock(j)),80+ilen)//'') endif if( index(oldblock(j),'end program demo_') .ne.0)then program_text=.false. endif enddo end function crayons function than(in) result(out) character(len=*),intent(in) :: in character(len=:),allocatable :: out integer :: i out='' do i=1,len_trim(in) select case(in(i:i)) case('<') out=out//'' case('>') out=out//'' case default out=out//in(i:i) endselect enddo end function than subroutine setup() help_text=[ CHARACTER(LEN=128) :: & 'help_text=[ CHARACTER(LEN=128) :: &',& 'NAME ',& ' fman(1f) - [DEVELOPER] output descriptions of Fortran intrinsics',& ' (LICENSE:PD) ',& ' ',& 'SYNOPSIS ',& ' fman NAME(s) [[-ignorecase][--regex Regular_Expression]]|[-topic_only]',& ' [--color][--demo] ',& ' ',& ' fman [ --help| --version] ',& ' ',& 'DESCRIPTION ',& ' fman(1) prints descriptions of Fortran intrinsics as simple flat text. ',& ' ',& ' The text is formatted in the txt2man(1) markdown language so one can easily',& ' generate man-pages on ULS (Unix-Like Systems). ',& ' ',& 'OPTIONS ',& ' TOPIC(s) A list of Fortran intrinsic names or the special names ',& ' "toc" and "manual" (which generate a table of contents ',& ' and the entire set of documents respecively). ',& ' The default is "toc" and to ignore case. ',& ' --regex,-e Search all output per the provided Regular Expression. ',& ' Output is prefixed with the topic it was found in. ',& ' --topic_only,-t Only show topic names. Other switches are ignored. ',& ' --ignorecase,-i Ignore case when searching for a Regular Expression. ',& ' --demo,-d extract first demo program found for a topic (starting with',& ' "program demo_*" and ending with "end program demo_*"). ',& ' --color Use ANSI in-line escape sequences to display the text in ',& ' set colors. Does not work with all terminal emulators or ',& ' terminals. Must use the -r switch with less(1) for less(1) ',& ' to display colors. ',& ' --help Display this help and exit ',& ' --version Output version information and exit ',& ' ',& 'EXAMPLES ',& ' Sample commands ',& ' ',& ' fman # list table of contents ',& ' fman -e character # check TOC for string. try "trigo","size","complex" ',& ' fman tan|less # display a description of tan(3f) ',& ' ',& ' fman --regex ''''character'''' # look for string in the TOC ignoring case ',& ' ',& ' fman manual>fortran.txt # create a copy of all descriptions ',& ' ',& ' # list the topic "scan" if found and lines containing "scan" from the entire',& ' # manual, prefixing the lines with the section name, while ignoring case. ',& ' fman -e scan -i manual ',& ' ',& ' fman -d verify >demo_verify.f90 # get sample program to try VERIFY(3f). ',& ''] version_text=[ CHARACTER(LEN=128) :: & '@(#) PRODUCT: GPF (General Purpose Fortran) utilities and examples >',& '@(#) PROGRAM: fman(1) >',& '@(#) DESCRIPTION: output Fortran intrinsic descriptions >',& '@(#) VERSION: 1.0.2, 202100108 >',& '@(#) AUTHOR: John S. Urban >',& '@(#) HOME PAGE: http://www.urbanjost.altervista.org/index.html >',& '@(#) LICENSE: MIT License >',& ''] end subroutine setup end program fman ! kludge1: older versions of gfortran do not handle character arrays with both line and size allocatable