102
103
104
105
106
107
113 implicit none
114 character(*), intent(in):: varname
115 type(GT_HISTORY_ATTR), intent(in):: attrs(:)
116 type(GT_HISTORY), intent(inout), target, optional:: history
117 type(GT_HISTORY), pointer:: hst =>null()
118 integer :: i
119 character(*), parameter:: subname = "append_attrs"
120 continue
121 call beginsub(subname,
'varname=<%c>, size(attrs(:))=<%d>', &
122 & c1=trim(varname), i=(/size(attrs(:))/))
123 if (present(history)) then
124 hst => history
125 else
126 hst => default
127 endif
128
129 do i = 1, size( attrs(:) )
130
131 if (
strhead(
'char', trim(
lchar(attrs(i)%attrtype))) )
then
133 & varname, attrs(i)%attrname, &
134 & trim(attrs(i)%Charvalue), hst )
135 elseif (
strhead(
'int', trim(
lchar(attrs(i)%attrtype))) )
then
136 if ( attrs(i)%array ) then
139 & varname, attrs(i)%attrname , &
140 & attrs(i)%Intarray, hst )
141 else
144 & varname, attrs(i)%attrname , &
145 & attrs(i)%Intvalue, hst )
146 endif
147 elseif (
strhead(
'real', trim(
lchar(attrs(i)%attrtype))) )
then
148 if ( attrs(i)%array ) then
151 & varname, attrs(i)%attrname, attrs(i)%Realarray, hst)
152 else
155 & varname, attrs(i)%attrname, attrs(i)%Realvalue, hst)
156 endif
157 elseif (
strhead(
'double', trim(
lchar(attrs(i)%attrtype))) )
then
158 if ( attrs(i)%array ) then
159 call dbgmessage(
'Doublearray(:) is selected.')
161 & varname, attrs(i)%attrname, attrs(i)%Doublearray, hst)
162 else
165 & varname, attrs(i)%attrname, attrs(i)%Doublevalue, hst)
166 endif
167 elseif (
strhead(
'logical', trim(
lchar(attrs(i)%attrtype))) )
then
169 & varname, attrs(i)%attrname, attrs(i)%Logicalvalue, hst)
170 else
171 call dbgmessage(
'attrtype=<%c>=<%c>is Invalid.' , &
172 & c1=trim(attrs(i)%attrtype) , &
173 & c2=trim(
lchar(attrs(i)%attrtype)) )
174 endif
175 enddo
Handling character types.
subroutine, public dbgmessage(fmt, i, r, d, l, n, c1, c2, c3, ca)
subroutine, public beginsub(name, fmt, i, r, d, l, n, c1, c2, c3, ca, version)
subroutine, public endsub(name, fmt, i, r, d, l, n, c1, c2, c3, ca)