In Fortran, overwriting a statement like WRITE() is not possible that I know of, so building a format on the fly, macro substitution, multiple write statements, internal writes, generic functions like in M_msg, etc, … needs used as far as I can think of. Since variable names are not exposed in Fortran, except arguably in NAMELIST groups, I was experimenting with different approaches. Here is one. I might clean up a few others. If so, I will add them here.
CLICK TO EXPAND EXAMPLE PROGRAMS
sequential macro substitution
program demo_M_vfe
implicit none
integer,allocatable :: vector(:)
integer :: neg, zero, pos
neg=3
zero=4
pos=5
vector=[11,22,33,5,6,7,8,9,10,11,12]
! macros are <1>, <2>, <3>, ... which are placed where integer values can go
! and then that number of integer values are given. In this simple version
! <N> cannot appear as a string otherwise in the format; all macros must be
! given a value greater than zero, and extra numeric values have no affect.
write(*, vfe("(1x, <1>('N',i0:,1x), <2>('@',i0:,1x), <3>('P',i0:,1x))",[neg,zero,pos])) vector
! was not actually sure a function returning a string could be used as a format,
! but it appears it can; which could have other uses for selecting languages,
! globally available formats, ... .
contains
function vfe(fstring,ints) result (out)
use,intrinsic :: iso_fortran_env, only : int64
character(len=*),intent(in) :: fstring
integer,intent(in) :: ints(:)
character(len=:),allocatable :: out, macro, value
character(len=range(0_int64)+3) :: temp
out=fstring
do i=1,size(ints)
write(temp,'(i0)')ints(i)
value=trim(temp)
write(temp,'("<",i0,">")')i
macro=trim(temp)
out=replace(out,macro,value)
enddo
end function vfe
function replace(original,old,new) result (out)
! ident_11="@(#) M_strings replace(3f) replace one substring for another in string"
character(len=*),intent(in) :: original, old, new
character(len=:),allocatable :: out
integer :: icount,ichange
integer :: len_old, len_new, ladd, ind, ic, ichr
integer :: right_margin
right_margin=len_trim(original) ! get non-blank length of input line
len_old=len(old) ! length of old substring to be replaced
if(len_old.eq.0)then ! c//new/ means insert new at beginning of line (or left margin)
out=original(1:right_margin)
return
endif
len_new=len(new) ! length of new substring to replace old substring
icount=0 ! initialize error flag/change count
ichange=0 ! initialize error flag/change count
out='' ! begin with a blank line as output string
ichr=1 ! place to put characters into output string
ic=1 ! place looking at in input string
loop: do
! try finding start of OLD in remaining part of input in change window
ind=index(original(ic:),old(:len_old))+ic-1
if(ind.eq.ic-1.or.ind.gt.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.gt.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
out=out(:ichr-1)//original(ic:ind-1)
ichr=ichr+ladd
endif
if(icount.ge.1.and.icount.le.right_margin)then ! check if this is an instance to change or keep
ichange=ichange+1
if(len_new.ne.0)then ! put in new string
out=out(:ichr-1)//new(:len_new)
ichr=ichr+len_new
endif
else
if(len_old.ne.0)then ! put in copy of old string
out=out(:ichr-1)//old(: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
out=original ! if no changes made output should be input
case default
if(ic.le.len(original))then ! if there is more after last change on original line add it
out=out(:ichr-1)//original(ic:max(ic,right_margin))
endif
end select
end function replace
end program demo_M_vfe
Learned about using a function for a Format and what zero repeat counts in a Fortran do in different compilers, which I had never thought about before!
Unlimited Polymorphic
module M_build
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128
implicit none
private
public build
contains
! build(3f) - [M_build] converts up to twenty scalar integers and strings to a string (LICENSE:PD)
function build(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj)
implicit none
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=:),allocatable :: build
character(len=4096) :: line
integer :: istart
integer :: increment
character(len=:),allocatable :: sep
sep=''
increment=len(sep)+1
istart=1
line=''
if(present(g0))call print_g(g0)
if(present(g1))call print_g(g1)
if(present(g2))call print_g(g2)
if(present(g3))call print_g(g3)
if(present(g4))call print_g(g4)
if(present(g5))call print_g(g5)
if(present(g6))call print_g(g6)
if(present(g7))call print_g(g7)
if(present(g8))call print_g(g8)
if(present(g9))call print_g(g9)
if(present(ga))call print_g(ga)
if(present(gb))call print_g(gb)
if(present(gc))call print_g(gc)
if(present(gd))call print_g(gd)
if(present(ge))call print_g(ge)
if(present(gf))call print_g(gf)
if(present(gg))call print_g(gg)
if(present(gh))call print_g(gh)
if(present(gi))call print_g(gi)
if(present(gj))call print_g(gj)
build=trim(line)
contains
subroutine print_g(g)
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128
class(*),intent(in) :: g
select type(g)
type is (integer); write(line(istart:),'(i0)') g
type is (character(len=*)); write(line(istart:),'(a)') trim(g)
end select
istart=len_trim(line)+increment
line=trim(line)//sep
end subroutine print_g
end function build
end module M_build
program demo_build
use M_build, only : build
implicit none
integer,allocatable :: vector(:)
integer :: neg, zero, pos
neg=3
zero=4
pos=5
vector=[11,22,33,5,6,7,8,9,10,11,12]
! build with unlimited polymorphic
write(*, build("(1x,",neg,"('N',i0:,1x),",zero,"('@',i0:,1x),",pos,"('P',i0:,1x))")) vector
end program demo_build
Fancy Overload
module M_overloading
implicit none
private
public operator(//)
interface operator ( // )
module procedure g_g
end interface operator ( // )
contains
function g_g(value1,value2) result (string)
! @(#)M_overloading::g_g(3f): convert two single intrinsic values to a string
class(*),intent(in) :: value1, value2
character(len=:),allocatable :: string1
character(len=:),allocatable :: string2
character(len=:),allocatable :: string
! use this so character variables are not trimmed and/or spaces are not added
!ifort_bug!string = ffmt(value1,'(g0)') // ffmt(value2,'(g0)')
string1 = ffmt(value1)
string2 = ffmt(value2)
allocate(character(len=len(string1)+len(string2)) :: string)
string(1:len(string1))=string1
string(len(string1)+1:)=string2
end function g_g
function ffmt(generic) result (line)
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
! @(#)M_overloading::ffmt(3f): convert intrinsic to a string using specified format
class(*),intent(in) :: generic
character(len=:),allocatable :: line
integer :: ios
character(len=255) :: msg
character(len=1),parameter :: nill=char(0) ! use to keep trailing spaces in strings
integer :: ilen
allocate(character(len=256) :: line) ! cannot currently write into allocatable variable
ios=0
select type(generic)
type is (integer(kind=int8)); write(line,'(i0,a)',iostat=ios,iomsg=msg) generic,nill
type is (integer(kind=int16)); write(line,'(i0,a)',iostat=ios,iomsg=msg) generic,nill
type is (integer(kind=int32)); write(line,'(i0,a)',iostat=ios,iomsg=msg) generic,nill
type is (integer(kind=int64)); write(line,'(i0,a)',iostat=ios,iomsg=msg) generic,nill
type is (character(len=*)); write(line,'(a,a)',iostat=ios,iomsg=msg) generic,nill
end select
if(ios.ne.0)then
line='<ERROR>'//trim(msg)
else
ilen=index(line,nill,back=.true.)
if(ilen.eq.0)ilen=len(line)
line=line(:ilen-1)
endif
end function ffmt
end module M_overloading
program testit
use M_overloading, only : operator(//)
implicit none
integer,allocatable :: vector(:)
integer :: neg, zero, pos
integer :: left
vector=[1,2,3,4,5,6,7,8,9,10,11,12]
neg=3
zero=4
pos=5
write(*, "(1x,"//neg//"('N',i0:,1x),"//zero//"('@',i0:,1x),"//pos//"('P',i0:,1x))") vector
end program testit
The overload could be considerably simpler, but this is set up to easily be extended to the // operator can work with any intrinsic types by just adding a line.