xmlOutput.F90 22.5 KB
Newer Older
1
2
3
4
5
6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

7
8
9
10
11
12
13
14
15
16
17
18
19
20
MODULE m_xmlOutput

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!
!!!   XML output service routines
!!!
!!!   This module provides several subroutines that simplify the
!!!   generation of the out.xml file.
!!!                                         GM'16
!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   IMPLICIT NONE

21
   PRIVATE
22
23
24
25
26
   INTEGER, SAVE :: currentElementIndex
   INTEGER, SAVE :: maxNumElements
   INTEGER, SAVE :: xmlOutputUnit
   CHARACTER(LEN= 40), ALLOCATABLE :: elementList(:)

Gregor Michalicek's avatar
Gregor Michalicek committed
27
28
29
   PUBLIC startXMLOutput, endXMLOutput
   PUBLIC writeXMLElementFormPoly, writeXMLElementPoly
   PUBLIC writeXMLElementForm, writeXMLElement
30
31
32
   PUBLIC openXMLElementFormPoly, openXMLElementPoly
   PUBLIC openXMLElementForm, openXMLElement
   PUBLIC openXMLElementNoAttributes, closeXMLElement
33
   PUBLIC getXMLOutputUnitNumber, isCurrentXMLElement
34

35
36
   CONTAINS

37
38
39
40
41
42
   FUNCTION getXMLOutputUnitNumber()
      IMPLICIT NONE
      INTEGER getXMLOutputUnitNumber
      getXMLOutputUnitNumber = xmlOutputUnit
   END FUNCTION getXMLOutputUnitNumber

43
   SUBROUTINE startXMLOutput()
44

45
      USE m_constants
46
      USE m_utility
47

48
      IMPLICIT NONE
49

50
51
#ifdef CPP_MPI
      include "mpif.h"
52
      INTEGER           :: err, isize
53
#endif
54
      INTEGER           :: numFlags
55
56
      CHARACTER(LEN=8)  :: date
      CHARACTER(LEN=10) :: time
57
      CHARACTER(LEN=10) :: zone
58
      CHARACTER(LEN=10) :: dateString
59
60
61
62
      CHARACTER(LEN=10) :: timeString
      CHARACTER(LEN=6)  :: precisionString
      CHARACTER(LEN=9)  :: flags(11)
      CHARACTER(LEN=20) :: structureSpecifiers(11)
63

64
65
66
67
68
      maxNumElements = 10
      ALLOCATE(elementList(maxNumElements))
      elementList = ''
      currentElementIndex = 0
      xmlOutputUnit = 53
69
70
71
      CALL DATE_AND_TIME(date,time,zone)
      WRITE(dateString,'(a4,a1,a2,a1,a2)') date(1:4),'/',date(5:6),'/',date(7:8)
      WRITE(timeString,'(a2,a1,a2,a1,a2)') time(1:2),':',time(3:4),':',time(5:6)
72
73
74
      OPEN (xmlOutputUnit,file='out.xml',form='formatted',status='unknown')
      WRITE (xmlOutputUnit,'(a)') '<?xml version="1.0" encoding="UTF-8" standalone="no"?>'
      WRITE (xmlOutputUnit,'(a)') '<fleurOutput fleurOutputVersion="0.27">'
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
      CALL openXMLElement('programVersion',(/'version'/),(/version_const/))
      CALL getComputerArchitectures(flags, numFlags)
      IF (numFlags.EQ.0) THEN
         numFlags = 1
         flags(numFlags) = 'GEN'
      END IF
      CALL writeXMLElementNoAttributes('targetComputerArchitectures',flags(1:numFlags))
      IF (numFlags.GT.1) THEN 
         STOP "ERROR: Define only one system architecture! (called by xmlOutput)"
      END IF
      CALL getPrecision(precisionString)
      CALL writeXMLElement('precision',(/'type'/),(/precisionString/))
      CALL getTargetStructureProperties(structureSpecifiers, numFlags)
      CALL writeXMLElementNoAttributes('targetStructureClass',structureSpecifiers(1:numFlags))
      CALL getAdditionalCompilationFlags(flags, numFlags)
      IF (numFlags.GE.1) THEN
         CALL writeXMLElementNoAttributes('additionalCompilerFlags',flags(1:numFlags))
      END IF
      CALL closeXMLElement('programVersion')
94
95
96
97
#ifdef CPP_MPI
      CALL MPI_COMM_SIZE(MPI_COMM_WORLD,isize,err)
      CALL writeXMLElementPoly('parallelizationParameters',(/'mpiPEs'/),(/isize/))
#endif
98
      CALL writeXMLElement('startDateAndTime',(/'date','time','zone'/),(/dateString,timeString,zone/))
99
100
101
   END SUBROUTINE startXMLOutput

   SUBROUTINE endXMLOutput()
102

103
      IMPLICIT NONE
104
105
106

      CHARACTER(LEN=8)  :: date
      CHARACTER(LEN=10) :: time
107
      CHARACTER(LEN=10)  :: zone
108
      CHARACTER(LEN=10) :: dateString
109
      CHARACTER(LEN=10)  :: timeString
110

111
112
113
114
      DO WHILE (currentElementIndex.NE.0)
         CALL closeXMLElement(elementList(currentElementIndex))
      END DO
      DEALLOCATE(elementList)
115
116
117
118
      CALL DATE_AND_TIME(date,time,zone)
      WRITE(dateString,'(a4,a1,a2,a1,a2)') date(1:4),'/',date(5:6),'/',date(7:8)
      WRITE(timeString,'(a2,a1,a2,a1,a2)') time(1:2),':',time(3:4),':',time(5:6)
      CALL writeXMLElement('endDateAndTime',(/'date','time','zone'/),(/dateString,timeString,zone/))
119
120
121
122
      WRITE (xmlOutputUnit,'(a)') '</fleurOutput>'
      CLOSE(xmlOutputUnit)
   END SUBROUTINE endXMLOutput

Gregor Michalicek's avatar
Gregor Michalicek committed
123
   SUBROUTINE writeXMLElementFormPoly(elementName,attributeNames,attributeValues,lengths,contentList)
124
125
126

      IMPLICIT NONE

Gregor Michalicek's avatar
Gregor Michalicek committed
127
128
129
130
131
      CHARACTER(LEN=*), INTENT(IN)           :: elementName
      CHARACTER(LEN=*), INTENT(IN)           :: attributeNames(:)
      CLASS(*),         INTENT(IN)           :: attributeValues(:)
      INTEGER,          INTENT(IN)           :: lengths(:,:)
      CLASS(*),         INTENT(IN), OPTIONAL :: contentList(:)
132
133
134
135
136
137

      CHARACTER(LEN= 30), ALLOCATABLE :: charAttributeValues(:)
      CHARACTER(LEN= 30), ALLOCATABLE :: charContentList(:)
      INTEGER                         :: i

      ALLOCATE(charAttributeValues(SIZE(attributeValues)))
Gregor Michalicek's avatar
Gregor Michalicek committed
138
139
      IF (PRESENT(contentList)) THEN
         ALLOCATE(charContentList(SIZE(contentList)))
140
141
      ELSE
         ALLOCATE(charContentList(1))
Gregor Michalicek's avatar
Gregor Michalicek committed
142
      END IF
143
144
145
146
147
148

      charAttributeValues = ''
      charContentList = ''

      DO i = 1, SIZE(attributeValues)
         SELECT TYPE (attributeValues)
149
           TYPE IS(INTEGER)
150
               WRITE(charAttributeValues(i),'(i0)') attributeValues(i)
151
            TYPE IS(REAL)
152
               WRITE(charAttributeValues(i),'(f19.10)') attributeValues(i)
153
            TYPE IS(LOGICAL)
154
               WRITE(charAttributeValues(i),'(l1)') attributeValues(i)
155
#ifndef __PGI
156
            TYPE IS(CHARACTER(LEN=*))
157
               WRITE(charAttributeValues(i),'(a)') TRIM(ADJUSTL(attributeValues(i)))
158
159
            CLASS DEFAULT
               STOP 'Type of attributeValues not allowed'
160
#endif
161
162
163
         END SELECT
      END DO

Gregor Michalicek's avatar
Gregor Michalicek committed
164
165
166
167
      IF (PRESENT(contentList)) THEN
         DO i = 1, SIZE(contentList)
            SELECT TYPE(contentList)
               TYPE IS(INTEGER)
168
                  WRITE(charContentList(i),'(i0)') contentList(i)
Gregor Michalicek's avatar
Gregor Michalicek committed
169
               TYPE IS(REAL)
170
                  WRITE(charContentList(i),'(f19.10)') contentList(i)
Gregor Michalicek's avatar
Gregor Michalicek committed
171
               TYPE IS(LOGICAL)
172
                  WRITE(charContentList(i),'(l1)') contentList(i)
173
#ifndef __PGI
174
               TYPE IS(CHARACTER(LEN=*))
175
                  WRITE(charContentList(i),'(a)') TRIM(ADJUSTL(contentList(i)))
Gregor Michalicek's avatar
Gregor Michalicek committed
176
177
               CLASS DEFAULT
                  STOP 'Type of contentList not allowed'
178
#endif
Gregor Michalicek's avatar
Gregor Michalicek committed
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
            END SELECT
         END DO
         CALL writeXMLElementForm(elementName,attributeNames,charAttributeValues,lengths,charContentList)
         DEALLOCATE(charContentList,charAttributeValues)
      ELSE
         CALL writeXMLElementForm(elementName,attributeNames,charAttributeValues,lengths)
      END IF

   END SUBROUTINE writeXMLElementFormPoly

   SUBROUTINE writeXMLElementPoly(elementName,attributeNames,attributeValues,contentList)

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN)           :: elementName
      CHARACTER(LEN=*), INTENT(IN)           :: attributeNames(:)
      CLASS(*),         INTENT(IN)           :: attributeValues(:)
      CLASS(*),         INTENT(IN), OPTIONAL :: contentList(:)
197

Gregor Michalicek's avatar
Gregor Michalicek committed
198
199
      INTEGER, ALLOCATABLE :: lengths(:,:)
      INTEGER              :: contentListSize
200

Gregor Michalicek's avatar
Gregor Michalicek committed
201
202
203
204
205
206
207
208
209
      contentListSize = 0
      IF (PRESENT(contentList)) THEN
         contentListSize = SIZE(contentList)
      END IF

      ALLOCATE(lengths(MAX(SIZE(attributeNames),contentListSize),3))
      lengths = 0
      CALL writeXMLElementFormPoly(elementName,attributeNames,attributeValues,lengths,contentList)
      DEALLOCATE(lengths)
210

211
212
   END SUBROUTINE writeXMLElementPoly

Gregor Michalicek's avatar
Gregor Michalicek committed
213
   SUBROUTINE writeXMLElementForm(elementName,attributeNames,attributeValues,lengths,contentList)
214
215
216

      IMPLICIT NONE

Gregor Michalicek's avatar
Gregor Michalicek committed
217
218
219
220
221
      CHARACTER(LEN=*), INTENT(IN)           :: elementName
      CHARACTER(LEN=*), INTENT(IN)           :: attributeNames(:)
      CHARACTER(LEN=*), INTENT(IN)           :: attributeValues(:)
      INTEGER,          INTENT(IN)           :: lengths(:,:)
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: contentList(:)
222
223

      CHARACTER(LEN=200), ALLOCATABLE :: contentLineList(:)
Gregor Michalicek's avatar
Gregor Michalicek committed
224
225
      INTEGER, ALLOCATABLE            :: bigLengths(:,:)
      INTEGER :: i, j, contentLineLength, contentLineListSize
226
227
      CHARACTER(LEN=70)               :: format
      CHARACTER(LEN=200)              :: outputString
228
      INTEGER                         :: contentListSize, overallListSize, numContentLineChars
Gregor Michalicek's avatar
Gregor Michalicek committed
229
      INTEGER                         :: lengthsShape(2)
230
231
232
233
234
235

      IF(SIZE(attributeNames).NE.SIZE(attributeValues)) THEN
         WRITE(*,*) 'attributeNames', attributeNames
         WRITE(*,*) 'attributeValues', attributeValues
         STOP 'ERROR: SIZE(attributeNames).NE.SIZE(attributeValues)'
      END IF
Gregor Michalicek's avatar
Gregor Michalicek committed
236
237
238
239
240

      lengthsShape = SHAPE(lengths)
      contentListSize = 0
      IF (PRESENT(contentList)) THEN
         contentListSize = SIZE(contentList)
241
      END IF
Gregor Michalicek's avatar
Gregor Michalicek committed
242
243
244
245
246
247
248
249
250
      overallListSize = MAX(SIZE(attributeNames),contentListSize)
      ALLOCATE(bigLengths(overallListSize,2))
      bigLengths = 0
      DO j = 1, 2
         DO i = 1, MIN(overallListSize,lengthsShape(1))
            bigLengths(i,j) = lengths(i,j)
         END DO
      END DO

251
252
      outputString = '<'//TRIM(ADJUSTL(elementName))
      DO i = 1, SIZE(attributeNames)
Gregor Michalicek's avatar
Gregor Michalicek committed
253
254
255
256
257
258
259
         WRITE(format,'(a)') "(a,a,a"
         IF (bigLengths(i,1).GT.0) WRITE(format,'(a,i0)') TRIM(ADJUSTL(format)),bigLengths(i,1)
         WRITE(format,'(a,a)') TRIM(ADJUSTL(format)),",a,a"
         IF (bigLengths(i,2).GT.0) WRITE(format,'(a,i0)') TRIM(ADJUSTL(format)),bigLengths(i,2)
         WRITE(format,'(a,a)') TRIM(ADJUSTL(format)),",a)"
         WRITE(outputString,format) TRIM(ADJUSTL(outputString)), ' ', TRIM(ADJUSTL(attributeNames(i))),&
                                    '="', TRIM(ADJUSTL(attributeValues(i))), '"'
260
      END DO
261
      WRITE(format,'(a,i0,a)') "(a",3*(currentElementIndex+1),",a)"
Gregor Michalicek's avatar
Gregor Michalicek committed
262
263
264
265
266
267
268
269
270
      IF (PRESENT(contentList)) THEN
         contentLineLength = 5 ! At most 5 data elements per line
         contentLineListSize = SIZE(contentList) / contentLineLength
         IF(contentLineListSize*contentLineLength.NE.SIZE(contentList)) THEN
            contentLineListSize = contentLineListSize + 1
         END IF
         ALLOCATE(contentLineList(contentLineListSize))
         CALL fillContentLineList(contentList,contentLineList,contentLineLength)
         IF(SIZE(contentLineList).LE.1) THEN
271
            outputString = TRIM(ADJUSTL(outputString))//'>'//TRIM(ADJUSTL(contentLineList(1)))//'</'//&
272
                 TRIM(ADJUSTL(elementName))//'>'
Gregor Michalicek's avatar
Gregor Michalicek committed
273
274
275
         ELSE
            outputString = TRIM(ADJUSTL(outputString))//'>'
         END IF
276
         WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(outputString))
Gregor Michalicek's avatar
Gregor Michalicek committed
277
278
         IF(SIZE(contentLineList).GT.1) THEN
            DO i = 1, SIZE(contentLineList)
279
280
281
282
283
284
285
               IF (i.EQ.SIZE(contentLineList)) THEN
                  numContentLineChars = 20*MOD(SIZE(contentList),contentLineLength)
                  IF(numContentLineChars.EQ.0) numContentLineChars = 20 * contentLineLength
                  WRITE(format,'(a,i0,a,i0,a)') "(a",3*(currentElementIndex+2),",a",numContentLineChars,")"
               ELSE
                  WRITE(format,'(a,i0,a)') "(a",3*(currentElementIndex+2),",a100)"
               END IF
Gregor Michalicek's avatar
Gregor Michalicek committed
286
287
288
289
290
291
292
293
294
295
296
               WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(contentLineList(i)))
            END DO
            WRITE(format,'(a,i0,a)') "(a",3*(currentElementIndex+1),",a)"
            outputString = '</'//TRIM(ADJUSTL(elementName))//'>'
            WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(outputString))
         END IF
      ELSE
         outputString = TRIM(ADJUSTL(outputString))//'/>'
         WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(outputString))
      END IF
      DEALLOCATE (bigLengths)
297

Gregor Michalicek's avatar
Gregor Michalicek committed
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
   END SUBROUTINE writeXMLElementForm

   SUBROUTINE writeXMLElement(elementName,attributeNames,attributeValues,contentList)

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN)           :: elementName
      CHARACTER(LEN=*), INTENT(IN)           :: attributeNames(:)
      CHARACTER(LEN=*), INTENT(IN)           :: attributeValues(:)
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: contentList(:)

      INTEGER, ALLOCATABLE :: lengths(:,:)
      INTEGER              :: contentListSize

      contentListSize = 0
      IF (PRESENT(contentList)) THEN
         contentListSize = SIZE(contentList)
315
      END IF
Gregor Michalicek's avatar
Gregor Michalicek committed
316
317
318
319
320

      ALLOCATE(lengths(MAX(SIZE(attributeNames),contentListSize),2))
      lengths = 0
      CALL writeXMLElementForm(elementName,attributeNames,attributeValues,lengths,contentList)
      DEALLOCATE(lengths)
321

322
323
   END SUBROUTINE writeXMLElement

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
   SUBROUTINE writeXMLElementNoAttributes(elementName,contentList)

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN)           :: elementName
      CHARACTER(LEN=*), INTENT(IN)           :: contentList(:)

      CHARACTER(LEN=200), ALLOCATABLE :: contentLineList(:)
      INTEGER :: i, j, contentLineLength, contentLineListSize
      CHARACTER(LEN=70)               :: format
      CHARACTER(LEN=200)              :: outputString
      INTEGER                         :: contentListSize, overallListSize, numContentLineChars

      outputString = '<'//TRIM(ADJUSTL(elementName))

      WRITE(format,'(a,i0,a)') "(a",3*(currentElementIndex+1),",a)"

      contentLineLength = 5 ! At most 5 data elements per line
      contentLineListSize = SIZE(contentList) / contentLineLength
      IF(contentLineListSize*contentLineLength.NE.SIZE(contentList)) THEN
         contentLineListSize = contentLineListSize + 1
      END IF
      ALLOCATE(contentLineList(contentLineListSize))
      CALL fillContentLineList(contentList,contentLineList,contentLineLength)
      IF(contentLineListSize.LE.1) THEN
         outputString = TRIM(ADJUSTL(outputString))//'>'//TRIM(ADJUSTL(contentLineList(1)))//'</'//&
              TRIM(ADJUSTL(elementName))//'>'
      ELSE
         outputString = TRIM(ADJUSTL(outputString))//'>'
      END IF
      WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(outputString))
      IF(contentLineListSize.GT.1) THEN
         DO i = 1, SIZE(contentLineList)
            IF (i.EQ.SIZE(contentLineList)) THEN
               numContentLineChars = 20*MOD(SIZE(contentList),contentLineLength)
               IF(numContentLineChars.EQ.0) numContentLineChars = 20 * contentLineLength
               WRITE(format,'(a,i0,a,i0,a)') "(a",3*(currentElementIndex+2),",a",numContentLineChars,")"
            ELSE
               WRITE(format,'(a,i0,a)') "(a",3*(currentElementIndex+2),",a100)"
            END IF
            WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(contentLineList(i)))
         END DO
         WRITE(format,'(a,i0,a)') "(a",3*(currentElementIndex+1),",a)"
         outputString = '</'//TRIM(ADJUSTL(elementName))//'>'
         WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(outputString))
      END IF

   END SUBROUTINE writeXMLElementNoAttributes

373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
   SUBROUTINE fillContentLineList(contentList,contentLineList,contentLineLength)

      IMPLICIT NONE

      CHARACTER(LEN= 30), INTENT(IN)    :: contentList(:)
      CHARACTER(LEN=200), INTENT(INOUT) :: contentLineList(:)
      INTEGER,            INTENT(IN)    :: contentLineLength
      INTEGER :: i, j

      contentLineList = ''
      DO i = 1, SIZE(contentLineList)
         DO j = 1, contentLineLength
            IF((i-1)*contentLineLength+j.GT.SIZE(contentList)) THEN
               RETURN
            END IF
388
389
            WRITE(contentLineList(i),'(a,a20)') TRIM(ADJUSTL(contentLineList(i))),&
                        TRIM(ADJUSTL(contentList((i-1)*contentLineLength+j)))
390
391
392
393
394
395
396
397
         END DO
      END DO
   END SUBROUTINE fillContentLineList

   SUBROUTINE openXMLElementPoly(elementName,attributeNames,attributeValues)

      IMPLICIT NONE

398
399
400
      CHARACTER(LEN=*)             :: elementName
      CHARACTER(LEN=*), INTENT(IN) :: attributeNames(:)
      CLASS(*),         INTENT(IN) :: attributeValues(:)
401

402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
      INTEGER, ALLOCATABLE :: lengths(:,:)

      ALLOCATE(lengths(SIZE(attributeNames),2))
      lengths = 0
      CALL openXMLElementFormPoly(elementName,attributeNames,attributeValues,lengths)
      DEALLOCATE(lengths)

   END SUBROUTINE openXMLElementPoly

   SUBROUTINE openXMLElementFormPoly(elementName,attributeNames,attributeValues,lengths)

      IMPLICIT NONE

      CHARACTER(LEN=*)             :: elementName
      CHARACTER(LEN=*), INTENT(IN) :: attributeNames(:)
      CLASS(*),         INTENT(IN) :: attributeValues(:)
      INTEGER,          INTENT(IN) :: lengths(:,:)

420
421
422
423
424
425
426
427
428
429
      CHARACTER(LEN= 30), ALLOCATABLE :: charAttributeValues(:)
      INTEGER                         :: i

      ALLOCATE(charAttributeValues(SIZE(attributeValues)))

      charAttributeValues = ''

      DO i = 1, SIZE(attributeValues)
         SELECT TYPE (attributeValues)
            TYPE IS(INTEGER)
430
               WRITE(charAttributeValues(i),'(i0)') attributeValues(i)
431
            TYPE IS(REAL)
432
               WRITE(charAttributeValues(i),'(f19.10)') attributeValues(i)
433
            TYPE IS(LOGICAL)
434
               WRITE(charAttributeValues(i),'(l1)') attributeValues(i)
435
#ifndef __PGI
436
            TYPE IS(CHARACTER(LEN=*))
437
               WRITE(charAttributeValues(i),'(a)') TRIM(ADJUSTL(attributeValues(i)))
438
439
            CLASS DEFAULT
               STOP 'Type of attributeValues not allowed'
440
#endif
441
442
443
         END SELECT
      END DO

444
      CALL openXMLElementForm(elementName,attributeNames,charAttributeValues,lengths)
445
446
      DEALLOCATE(charAttributeValues)

447
   END SUBROUTINE openXMLElementFormPoly
448

449
450
451
452
453
454
455
456
457
458
459
   SUBROUTINE openXMLElementNoAttributes(elementName)

      IMPLICIT NONE

      CHARACTER(LEN=*)             :: elementName

      INTEGER :: i
      CHARACTER(LEN=70)  :: format
      CHARACTER(LEN=200) :: openingString

      IF(currentElementIndex.EQ.maxNumElements) THEN
460
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
461
462
463
464
465
466
467
         STOP 'ERROR: xml hierarchy too deep!'
      END IF
      currentElementIndex = currentElementIndex + 1
      elementList(currentElementIndex) = TRIM(ADJUSTL(elementName))
      openingString = '<'//TRIM(ADJUSTL(elementName))//'>'
      WRITE(format,'(a,i0,a)') "(a",3*currentElementIndex,",a)"
      WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(openingString))
468

469
470
   END SUBROUTINE openXMLElementNoAttributes

471
472
473
474
   SUBROUTINE openXMLElement(elementName,attributeNames,attributeValues)

      IMPLICIT NONE

475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
      CHARACTER(LEN=*), INTENT(IN)           :: elementName
      CHARACTER(LEN=*), INTENT(IN)           :: attributeNames(:)
      CHARACTER(LEN=*), INTENT(IN)           :: attributeValues(:)

      INTEGER, ALLOCATABLE :: lengths(:,:)

      ALLOCATE(lengths(SIZE(attributeNames),2))
      lengths = 0
      CALL openXMLElementForm(elementName,attributeNames,attributeValues,lengths)
      DEALLOCATE(lengths)

   END SUBROUTINE

   SUBROUTINE openXMLElementForm(elementName,attributeNames,attributeValues,lengths)

      IMPLICIT NONE

492
493
494
      CHARACTER(LEN=*)             :: elementName
      CHARACTER(LEN=*), INTENT(IN) :: attributeNames(:)
      CHARACTER(LEN=*), INTENT(IN) :: attributeValues(:)
495
      INTEGER,          INTENT(IN) :: lengths(:,:)
496
497
498
499

      CHARACTER(LEN=70)  :: format
      CHARACTER(LEN=200) :: openingString

500
501
502
503
504
      INTEGER, ALLOCATABLE            :: bigLengths(:,:)
      INTEGER                         :: i, j
      INTEGER                         :: overallListSize
      INTEGER                         :: lengthsShape(2)

505
      IF(SIZE(attributeNames).NE.SIZE(attributeValues)) THEN
506
507
508
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
         WRITE(*,*) 'attributeNames ', attributeNames
         WRITE(*,*) 'attributeValues ', attributeValues
509
510
511
         STOP 'ERROR: SIZE(attributeNames).NE.SIZE(attributeValues)'
      END IF
      IF(currentElementIndex.EQ.maxNumElements) THEN
512
513
514
515
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
         WRITE(*,*) 'attributeNames ', attributeNames
         WRITE(*,*) 'attributeValues ', attributeValues
         WRITE(*,*) 'elementList ', elementList
516
517
         STOP 'ERROR: xml hierarchy too deep!'
      END IF
518
519
520
521
522
523
524
525
526
527
528

      lengthsShape = SHAPE(lengths)
      overallListSize = SIZE(attributeNames)
      ALLOCATE(bigLengths(overallListSize,2))
      bigLengths = 0
      DO j = 1, 2
         DO i = 1, MIN(overallListSize,lengthsShape(1))
            bigLengths(i,j) = lengths(i,j)
         END DO
      END DO

529
530
      openingString = '<'//TRIM(ADJUSTL(elementName))
      DO i = 1, SIZE(attributeNames)
531
532
533
534
535
536
537
         WRITE(format,'(a)') "(a,a,a"
         IF (bigLengths(i,1).GT.0) WRITE(format,'(a,i0)') TRIM(ADJUSTL(format)),bigLengths(i,1)
         WRITE(format,'(a,a)') TRIM(ADJUSTL(format)),",a,a"
         IF (bigLengths(i,2).GT.0) WRITE(format,'(a,i0)') TRIM(ADJUSTL(format)),bigLengths(i,2)
         WRITE(format,'(a,a)') TRIM(ADJUSTL(format)),",a)"
         WRITE(openingString,format) TRIM(ADJUSTL(openingString)), ' ', TRIM(ADJUSTL(attributeNames(i))),&
                                    '="', TRIM(ADJUSTL(attributeValues(i))), '"'
538
539
      END DO
      openingString = TRIM(ADJUSTL(openingString))//'>'
540
541
542

      currentElementIndex = currentElementIndex + 1
      elementList(currentElementIndex) = TRIM(ADJUSTL(elementName))
543
      WRITE(format,'(a,i0,a)') "(a",3*currentElementIndex,",a)"
544
      WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(openingString))
545
546
547
      DEALLOCATE (bigLengths)

   END SUBROUTINE openXMLElementForm
548
549
550
551
552
553
554
555
556
557
558

   SUBROUTINE closeXMLElement(elementName)

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN) :: elementName
      INTEGER :: i
      CHARACTER(LEN=70) :: format
      CHARACTER(LEN=70) :: closingString

      IF(TRIM(ADJUSTL(elementList(currentElementIndex))).NE.TRIM(ADJUSTL(elementName))) THEN
559
560
         WRITE(*,*) 'elementList(currentElementIndex): ', TRIM(ADJUSTL(elementList(currentElementIndex)))
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
561
562
         STOP 'ERROR: Closing xml element inconsistency!'
      END IF
563
564
      closingString = '</'//TRIM(ADJUSTL(elementName))//'>'
      WRITE(format,'(a,i0,a)') "(a",3*currentElementIndex,",a)"
565
566
      WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(closingString))
      currentElementIndex = currentElementIndex - 1
567

568
569
   END SUBROUTINE closeXMLElement

570
571
572
573
574
   LOGICAL FUNCTION isCurrentXMLElement(elementName)

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN) :: elementName
575
      if (currentElementIndex==0.or.currentElementIndex>SIZE(elementList)) THEN
Daniel Wortmann's avatar
Daniel Wortmann committed
576
577
578
                  isCurrentXMLElement=.false.
                  return
      endif
579
580
581
582
      isCurrentXMLElement = (TRIM(ADJUSTL(elementList(currentElementIndex))).EQ.TRIM(ADJUSTL(elementName)))

   END FUNCTION isCurrentXMLElement

583
END MODULE m_xmlOutput