source: XMLF90/src/wxml/m_wxml_core.f90 @ 295

Last change on this file since 295 was 6, checked in by ymipsl, 12 years ago

Import des sources XMLF90

File size: 10.5 KB
Line 
1module m_wxml_core
2
3use m_wxml_buffer
4use m_wxml_elstack
5use m_wxml_dictionary
6
7logical, private, save  :: pcdata_advance_line_default = .false.
8logical, private, save  :: pcdata_advance_space_default = .false.
9
10integer, private, parameter ::  sp = selected_real_kind(6,30)
11integer, private, parameter ::  dp = selected_real_kind(14,100)
12
13private
14
15type, public :: xmlf_t
16   integer            :: lun
17   type(buffer_t)     :: buffer
18   type(elstack_t)    :: stack
19   type(wxml_dictionary_t) :: dict
20   logical            :: start_tag_closed
21   logical            :: root_element_output
22   logical            :: indenting_requested
23end type xmlf_t
24
25public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close
26public :: xml_AddPcdata, xml_AddAttribute, xml_AddXMLDeclaration
27public :: xml_AddComment, xml_AddCdataSection
28
29public :: xml_AddArray
30interface xml_AddArray
31   module procedure  xml_AddArray_integer,  &
32                xml_AddArray_real_dp, xml_AddArray_real_sp
33end interface
34private :: xml_AddArray_integer,  xml_AddArray_real_dp, xml_AddArray_real_sp
35
36private :: get_unit
37private :: add_eol
38private :: write_attributes
39
40
41integer, private, parameter  :: COLUMNS = 80
42
43CONTAINS
44
45!-------------------------------------------------------------------
46subroutine xml_OpenFile(filename, xf, indent)
47character(len=*), intent(in)  :: filename
48type(xmlf_t), intent(inout)   :: xf
49logical, intent(in), optional :: indent
50
51integer :: iostat
52
53call get_unit(xf%lun,iostat)
54if (iostat /= 0) stop "cannot open file"
55open(unit=xf%lun, file=filename, form="formatted", status="replace", &
56     action="write", position="rewind") ! , recl=65536)
57
58call reset_elstack(xf%stack)
59call reset_dict(xf%dict)
60call reset_buffer(xf%buffer)
61
62xf%start_tag_closed = .true.
63xf%root_element_output = .false.
64
65xf%indenting_requested = .false.
66if (present(indent)) then
67   xf%indenting_requested = indent
68endif
69end subroutine xml_OpenFile
70
71!-------------------------------------------------------------------
72subroutine xml_AddXMLDeclaration(xf,encoding)
73type(xmlf_t), intent(inout)   :: xf
74character(len=*), intent(in), optional :: encoding
75
76if (present(encoding)) then
77   call add_to_buffer("<?xml version=""1.0"" encoding=""" &
78                     // trim(encoding) // """ ?>", xf%buffer)
79else
80   call add_to_buffer("<?xml version=""1.0"" ?>", xf%buffer)
81endif
82end subroutine xml_AddXMLDeclaration
83
84!-------------------------------------------------------------------
85subroutine xml_AddComment(xf,comment)
86type(xmlf_t), intent(inout)   :: xf
87character(len=*), intent(in)  :: comment
88
89call close_start_tag(xf,">")
90call add_eol(xf)
91call add_to_buffer("<!--", xf%buffer)
92call add_to_buffer(comment, xf%buffer)
93call add_to_buffer("-->", xf%buffer)
94end subroutine xml_AddComment
95
96!-------------------------------------------------------------------
97subroutine xml_AddCdataSection(xf,cdata)
98type(xmlf_t), intent(inout)   :: xf
99character(len=*), intent(in)  :: cdata
100
101call close_start_tag(xf,">")
102call add_to_buffer("<![CDATA[", xf%buffer)
103call add_to_buffer(cdata, xf%buffer)
104call add_to_buffer("]]>", xf%buffer)
105end subroutine xml_AddCdataSection
106
107!-------------------------------------------------------------------
108subroutine xml_NewElement(xf,name)
109type(xmlf_t), intent(inout)   :: xf
110character(len=*), intent(in)  :: name
111
112if (is_empty(xf%stack)) then
113   if (xf%root_element_output) stop "two root elements"
114   xf%root_element_output = .true.
115endif
116
117call close_start_tag(xf,">")
118call push_elstack(name,xf%stack)
119call add_eol(xf)
120call add_to_buffer("<" // trim(name),xf%buffer)
121xf%start_tag_closed = .false.
122call reset_dict(xf%dict)
123
124end subroutine xml_NewElement
125!-------------------------------------------------------------------
126subroutine xml_AddPcdata(xf,pcdata,space,line_feed)
127type(xmlf_t), intent(inout)   :: xf
128character(len=*), intent(in)  :: pcdata
129logical, intent(in), optional  :: space
130logical, intent(in), optional  :: line_feed
131
132logical :: advance_line , advance_space
133integer :: n, i, jmax
134integer, parameter   :: chunk_size = 128
135
136advance_line = pcdata_advance_line_default 
137if (present(line_feed)) then
138   advance_line = line_feed
139endif
140
141advance_space = pcdata_advance_space_default 
142if (present(space)) then
143   advance_space = space
144endif
145
146if (is_empty(xf%stack)) then
147   stop "pcdata outside element content"
148endif
149
150call close_start_tag(xf,">")
151
152if (advance_line) then
153   call add_eol(xf)
154   advance_space = .false.
155else
156   if (xf%indenting_requested) then
157      if ((len(xf%buffer) + len_trim(pcdata) + 1) > COLUMNS ) then
158         call add_eol(xf)
159         advance_space = .false.
160      endif
161   endif
162endif
163if (advance_space) call add_to_buffer(" ",xf%buffer)
164if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.false.)
165!
166! We bypass the buffer for the bulk of the dump
167!
168n = len(pcdata)
169!print *, "writing pcdata of length: ", n
170i = 1
171do
172   jmax = min(i+chunk_size-1,n)
173!   print *, "writing chunk: ", i, jmax
174   write(unit=xf%lun,fmt="(a)",advance="no") pcdata(i:jmax)
175   if (jmax == n) exit
176   i = jmax + 1
177enddo
178end subroutine xml_AddPcdata
179
180!-------------------------------------------------------------------
181subroutine xml_AddAttribute(xf,name,value)
182type(xmlf_t), intent(inout)   :: xf
183character(len=*), intent(in)  :: name
184character(len=*), intent(in)  :: value
185
186if (is_empty(xf%stack)) then
187   stop "attributes outside element content"
188endif
189
190if (xf%start_tag_closed)  then
191   stop "attributes outside start tag"
192endif
193if (has_key(xf%dict,name)) then
194   stop "duplicate att name"
195endif
196
197call add_key_to_dict(trim(name),xf%dict)
198call add_value_to_dict(trim(value),xf%dict)
199
200end subroutine xml_AddAttribute
201
202!-----------------------------------------------------------
203subroutine xml_EndElement(xf,name)
204type(xmlf_t), intent(inout)   :: xf
205character(len=*), intent(in)  :: name
206
207character(len=100)  :: current
208
209if (is_empty(xf%stack)) then
210   stop "Out of elements to close"
211endif
212
213call get_top_elstack(xf%stack,current)
214if (current /= name) then
215   print *, "current, name: ", trim(current), " ", trim(name)
216   stop
217endif
218if (.not. xf%start_tag_closed)  then                ! Empty element
219   if (len(xf%dict) > 0) call write_attributes(xf)
220   call add_to_buffer(" />",xf%buffer)
221   xf%start_tag_closed = .true.
222else
223   call add_eol(xf)
224   call add_to_buffer("</" // trim(name) // ">", xf%buffer)
225endif
226call pop_elstack(xf%stack,current)
227
228end subroutine xml_EndElement
229
230!----------------------------------------------------------------
231
232subroutine xml_Close(xf)
233type(xmlf_t), intent(in)   :: xf
234
235write(unit=xf%lun,fmt="(a)") char(xf%buffer)
236close(unit=xf%lun)
237
238end subroutine xml_Close
239
240!==================================================================
241!-------------------------------------------------------------------
242subroutine get_unit(lun,iostat)
243
244! Get an available Fortran unit number
245
246integer, intent(out)  :: lun
247integer, intent(out)  :: iostat
248
249integer :: i
250logical :: unit_used
251
252do i = 10, 99
253   lun = i
254   inquire(unit=lun,opened=unit_used)
255   if (.not. unit_used) then
256      iostat = 0
257      return
258   endif
259enddo
260iostat = -1
261lun = -1
262end subroutine get_unit
263
264!----------------------------------------------------------
265subroutine add_eol(xf)
266type(xmlf_t), intent(inout)   :: xf
267
268integer :: indent_level
269character(len=100), parameter  ::  blanks =  ""
270
271indent_level = len(xf%stack) - 1
272write(unit=xf%lun,fmt="(a)") char(xf%buffer)
273call reset_buffer(xf%buffer)
274
275if (xf%indenting_requested) &
276   call add_to_buffer(blanks(1:indent_level),xf%buffer)
277
278end subroutine add_eol
279!------------------------------------------------------------
280subroutine dump_buffer(xf,lf)
281type(xmlf_t), intent(inout)   :: xf
282logical, intent(in), optional :: lf
283
284if (present(lf)) then
285   if (lf) then
286      write(unit=xf%lun,fmt="(a)",advance="yes") char(xf%buffer)
287   else
288      write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer)
289   endif
290else
291   write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer)
292endif
293call reset_buffer(xf%buffer)
294
295end subroutine dump_buffer
296
297!------------------------------------------------------------
298subroutine close_start_tag(xf,s)
299type(xmlf_t), intent(inout)   :: xf
300character(len=*), intent(in)  :: s
301
302if (.not. xf%start_tag_closed)  then
303   if (len(xf%dict) > 0)  call write_attributes(xf)
304   call add_to_buffer(s, xf%buffer)
305   xf%start_tag_closed = .true.
306endif
307
308end subroutine close_start_tag
309
310!-------------------------------------------------------------
311subroutine write_attributes(xf)
312type(xmlf_t), intent(inout)   :: xf
313
314integer  :: i, status, size
315character(len=100)  :: key, value
316
317do i = 1, len(xf%dict)
318   call get_key(xf%dict,i,key,status)
319   call get_value(xf%dict,key,value,status)
320   key = adjustl(key)
321   value = adjustl(value)
322   size = len_trim(key) + len_trim(value) + 4
323   if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf)
324   call add_to_buffer(" ", xf%buffer)
325   call add_to_buffer(trim(key), xf%buffer)
326   call add_to_buffer("=", xf%buffer)
327   call add_to_buffer("""",xf%buffer)
328   call add_to_buffer(trim(value), xf%buffer)
329   call add_to_buffer("""", xf%buffer)
330enddo
331
332end subroutine write_attributes
333
334!---------------------------------------------------------------
335    subroutine xml_AddArray_integer(xf,a,format)
336      type(xmlf_t), intent(inout)         :: xf
337      integer, intent(in), dimension(:)   :: a
338      character(len=*), intent(in), optional  :: format
339
340      call close_start_tag(xf,">")
341      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
342      if (present(format)) then
343         write(xf%lun,format) a
344      else
345         write(xf%lun,"(6(i12))") a
346      endif
347    end subroutine xml_AddArray_integer
348
349!-------------------------------------------------------------------
350    subroutine xml_AddArray_real_dp(xf,a,format)
351      type(xmlf_t), intent(inout)         :: xf
352      real(kind=dp), intent(in), dimension(:)   :: a
353      character(len=*), intent(in), optional  :: format
354
355      call close_start_tag(xf,">")
356      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
357      if (present(format)) then
358         write(xf%lun,format) a
359      else
360         write(xf%lun,"(4(es20.12))") a
361      endif
362    end subroutine xml_AddArray_real_dp
363
364!------------------------------------------------------------------
365    subroutine xml_AddArray_real_sp(xf,a,format)
366      type(xmlf_t), intent(inout)         :: xf
367      real(kind=sp), intent(in), dimension(:)   :: a
368      character(len=*), intent(in), optional  :: format
369
370      call close_start_tag(xf,">")
371      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
372      if (present(format)) then
373         write(xf%lun,format) a
374      else
375         write(xf%lun,"(4(es20.12))") a
376      endif
377    end subroutine xml_AddArray_real_sp
378
379end module m_wxml_core
380
Note: See TracBrowser for help on using the repository browser.