xmlOutput.F90 23.2 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_juDFT_args
46
      USE m_constants
47
      USE m_utility
48 49
      USE m_compile_descr
      
50
      IMPLICIT NONE
51

52 53
#ifdef CPP_MPI
      include "mpif.h"
54
      INTEGER           :: err, isize
55
#endif
56
      INTEGER           :: numFlags
57 58
      CHARACTER(LEN=8)  :: date
      CHARACTER(LEN=10) :: time
59
      CHARACTER(LEN=10) :: zone
60
      CHARACTER(LEN=10) :: dateString
61 62 63 64
      CHARACTER(LEN=10) :: timeString
      CHARACTER(LEN=6)  :: precisionString
      CHARACTER(LEN=9)  :: flags(11)
      CHARACTER(LEN=20) :: structureSpecifiers(11)
Daniel Wortmann's avatar
Daniel Wortmann committed
65
      CHARACTER(LEN=50) :: gitdesc,githash,gitbranch,compile_date,compile_user,compile_host
66
      
67 68 69 70 71
      maxNumElements = 10
      ALLOCATE(elementList(maxNumElements))
      elementList = ''
      currentElementIndex = 0
      xmlOutputUnit = 53
72 73 74
      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)
75
      IF (juDFT_was_argument("-info")) THEN
Daniel Wortmann's avatar
Daniel Wortmann committed
76 77 78 79
         OPEN (xmlOutputUnit,status='scratch')
      ELSE
         OPEN (xmlOutputUnit,file='out.xml',form='formatted',status='unknown')
      ENDIF
80 81
      WRITE (xmlOutputUnit,'(a)') '<?xml version="1.0" encoding="UTF-8" standalone="no"?>'
      WRITE (xmlOutputUnit,'(a)') '<fleurOutput fleurOutputVersion="0.27">'
82
      CALL openXMLElement('programVersion',(/'version'/),(/version_const/))
Daniel Wortmann's avatar
Daniel Wortmann committed
83
      CALL get_compile_desc(gitdesc,githash,gitbranch,compile_date,compile_user,compile_host)
84
      CALL writeXMLElement('compilationInfo',(/'date','user','host'/),(/compile_date,compile_user,compile_host/))
Daniel Wortmann's avatar
Daniel Wortmann committed
85
      CALL writeXMLElement('gitInfo',(/'version       ','branch        ','lastCommitHash'/),(/gitdesc,gitbranch,githash/))
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
      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')
104 105 106 107
#ifdef CPP_MPI
      CALL MPI_COMM_SIZE(MPI_COMM_WORLD,isize,err)
      CALL writeXMLElementPoly('parallelizationParameters',(/'mpiPEs'/),(/isize/))
#endif
108
      CALL writeXMLElement('startDateAndTime',(/'date','time','zone'/),(/dateString,timeString,zone/))
109 110 111
   END SUBROUTINE startXMLOutput

   SUBROUTINE endXMLOutput()
112

113
      IMPLICIT NONE
114 115 116

      CHARACTER(LEN=8)  :: date
      CHARACTER(LEN=10) :: time
117
      CHARACTER(LEN=10)  :: zone
118
      CHARACTER(LEN=10) :: dateString
119
      CHARACTER(LEN=10)  :: timeString
120

121 122 123 124
      DO WHILE (currentElementIndex.NE.0)
         CALL closeXMLElement(elementList(currentElementIndex))
      END DO
      DEALLOCATE(elementList)
125 126 127 128
      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/))
129 130 131 132
      WRITE (xmlOutputUnit,'(a)') '</fleurOutput>'
      CLOSE(xmlOutputUnit)
   END SUBROUTINE endXMLOutput

Gregor Michalicek's avatar
Gregor Michalicek committed
133
   SUBROUTINE writeXMLElementFormPoly(elementName,attributeNames,attributeValues,lengths,contentList)
134 135 136

      IMPLICIT NONE

Gregor Michalicek's avatar
Gregor Michalicek committed
137 138 139 140 141
      CHARACTER(LEN=*), INTENT(IN)           :: elementName
      CHARACTER(LEN=*), INTENT(IN)           :: attributeNames(:)
      CLASS(*),         INTENT(IN)           :: attributeValues(:)
      INTEGER,          INTENT(IN)           :: lengths(:,:)
      CLASS(*),         INTENT(IN), OPTIONAL :: contentList(:)
142 143 144 145 146 147

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

      ALLOCATE(charAttributeValues(SIZE(attributeValues)))
Gregor Michalicek's avatar
Gregor Michalicek committed
148 149
      IF (PRESENT(contentList)) THEN
         ALLOCATE(charContentList(SIZE(contentList)))
150 151
      ELSE
         ALLOCATE(charContentList(1))
Gregor Michalicek's avatar
Gregor Michalicek committed
152
      END IF
153 154 155 156 157 158

      charAttributeValues = ''
      charContentList = ''

      DO i = 1, SIZE(attributeValues)
         SELECT TYPE (attributeValues)
159
           TYPE IS(INTEGER)
160
               WRITE(charAttributeValues(i),'(i0)') attributeValues(i)
161
            TYPE IS(REAL)
162
               WRITE(charAttributeValues(i),'(f19.10)') attributeValues(i)
163
            TYPE IS(LOGICAL)
164
               WRITE(charAttributeValues(i),'(l1)') attributeValues(i)
165
#ifndef __PGI
166
            TYPE IS(CHARACTER(LEN=*))
167
               WRITE(charAttributeValues(i),'(a)') TRIM(ADJUSTL(attributeValues(i)))
168 169
            CLASS DEFAULT
               STOP 'Type of attributeValues not allowed'
170
#endif
171 172 173
         END SELECT
      END DO

Gregor Michalicek's avatar
Gregor Michalicek committed
174 175 176 177
      IF (PRESENT(contentList)) THEN
         DO i = 1, SIZE(contentList)
            SELECT TYPE(contentList)
               TYPE IS(INTEGER)
178
                  WRITE(charContentList(i),'(i0)') contentList(i)
Gregor Michalicek's avatar
Gregor Michalicek committed
179
               TYPE IS(REAL)
180
                  WRITE(charContentList(i),'(f19.10)') contentList(i)
Gregor Michalicek's avatar
Gregor Michalicek committed
181
               TYPE IS(LOGICAL)
182
                  WRITE(charContentList(i),'(l1)') contentList(i)
183
#ifndef __PGI
184
               TYPE IS(CHARACTER(LEN=*))
185
                  WRITE(charContentList(i),'(a)') TRIM(ADJUSTL(contentList(i)))
Gregor Michalicek's avatar
Gregor Michalicek committed
186 187
               CLASS DEFAULT
                  STOP 'Type of contentList not allowed'
188
#endif
Gregor Michalicek's avatar
Gregor Michalicek committed
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
            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(:)
207

Gregor Michalicek's avatar
Gregor Michalicek committed
208 209
      INTEGER, ALLOCATABLE :: lengths(:,:)
      INTEGER              :: contentListSize
210

Gregor Michalicek's avatar
Gregor Michalicek committed
211 212 213 214 215 216 217 218 219
      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)
220

221 222
   END SUBROUTINE writeXMLElementPoly

Gregor Michalicek's avatar
Gregor Michalicek committed
223
   SUBROUTINE writeXMLElementForm(elementName,attributeNames,attributeValues,lengths,contentList)
224 225 226

      IMPLICIT NONE

Gregor Michalicek's avatar
Gregor Michalicek committed
227 228 229 230 231
      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(:)
232 233

      CHARACTER(LEN=200), ALLOCATABLE :: contentLineList(:)
Gregor Michalicek's avatar
Gregor Michalicek committed
234 235
      INTEGER, ALLOCATABLE            :: bigLengths(:,:)
      INTEGER :: i, j, contentLineLength, contentLineListSize
236 237
      CHARACTER(LEN=70)               :: format
      CHARACTER(LEN=200)              :: outputString
238
      INTEGER                         :: contentListSize, overallListSize, numContentLineChars
Gregor Michalicek's avatar
Gregor Michalicek committed
239
      INTEGER                         :: lengthsShape(2)
240 241 242 243 244 245

      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
246 247 248 249 250

      lengthsShape = SHAPE(lengths)
      contentListSize = 0
      IF (PRESENT(contentList)) THEN
         contentListSize = SIZE(contentList)
251
      END IF
Gregor Michalicek's avatar
Gregor Michalicek committed
252 253 254 255 256 257 258 259 260
      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

261 262
      outputString = '<'//TRIM(ADJUSTL(elementName))
      DO i = 1, SIZE(attributeNames)
Gregor Michalicek's avatar
Gregor Michalicek committed
263 264 265 266 267 268 269
         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))), '"'
270
      END DO
271
      WRITE(format,'(a,i0,a)') "(a",3*(currentElementIndex+1),",a)"
Gregor Michalicek's avatar
Gregor Michalicek committed
272 273 274 275 276 277 278 279 280
      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
281
            outputString = TRIM(ADJUSTL(outputString))//'>'//TRIM(ADJUSTL(contentLineList(1)))//'</'//&
282
                 TRIM(ADJUSTL(elementName))//'>'
Gregor Michalicek's avatar
Gregor Michalicek committed
283 284 285
         ELSE
            outputString = TRIM(ADJUSTL(outputString))//'>'
         END IF
286
         WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(outputString))
Gregor Michalicek's avatar
Gregor Michalicek committed
287 288
         IF(SIZE(contentLineList).GT.1) THEN
            DO i = 1, SIZE(contentLineList)
289 290 291 292 293 294 295
               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
296 297 298 299 300 301 302 303 304 305 306
               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)
307

Gregor Michalicek's avatar
Gregor Michalicek committed
308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
   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)
325
      END IF
Gregor Michalicek's avatar
Gregor Michalicek committed
326 327 328 329 330

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

332 333
   END SUBROUTINE writeXMLElement

334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357
   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)
358 359 360
      IF(contentLineListSize.EQ.0) THEN
         outputString = TRIM(ADJUSTL(outputString))//'> </'//TRIM(ADJUSTL(elementName))//'>'
      ELSE IF(contentLineListSize.EQ.1) THEN
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384
         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

385 386 387 388
   SUBROUTINE fillContentLineList(contentList,contentLineList,contentLineLength)

      IMPLICIT NONE

389
      CHARACTER(LEN= *), INTENT(IN)    :: contentList(:)
390 391 392 393 394 395 396 397 398 399
      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
400 401
            WRITE(contentLineList(i),'(a,a20)') TRIM(ADJUSTL(contentLineList(i))),&
                        TRIM(ADJUSTL(contentList((i-1)*contentLineLength+j)))
402 403 404 405 406 407 408 409
         END DO
      END DO
   END SUBROUTINE fillContentLineList

   SUBROUTINE openXMLElementPoly(elementName,attributeNames,attributeValues)

      IMPLICIT NONE

410 411 412
      CHARACTER(LEN=*)             :: elementName
      CHARACTER(LEN=*), INTENT(IN) :: attributeNames(:)
      CLASS(*),         INTENT(IN) :: attributeValues(:)
413

414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431
      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(:,:)

432 433 434 435 436 437 438 439 440 441
      CHARACTER(LEN= 30), ALLOCATABLE :: charAttributeValues(:)
      INTEGER                         :: i

      ALLOCATE(charAttributeValues(SIZE(attributeValues)))

      charAttributeValues = ''

      DO i = 1, SIZE(attributeValues)
         SELECT TYPE (attributeValues)
            TYPE IS(INTEGER)
442
               WRITE(charAttributeValues(i),'(i0)') attributeValues(i)
443
            TYPE IS(REAL)
444
               WRITE(charAttributeValues(i),'(f19.10)') attributeValues(i)
445
            TYPE IS(LOGICAL)
446
               WRITE(charAttributeValues(i),'(l1)') attributeValues(i)
447
#ifndef __PGI
448
            TYPE IS(CHARACTER(LEN=*))
449
               WRITE(charAttributeValues(i),'(a)') TRIM(ADJUSTL(attributeValues(i)))
450 451
            CLASS DEFAULT
               STOP 'Type of attributeValues not allowed'
452
#endif
453 454 455
         END SELECT
      END DO

456
      CALL openXMLElementForm(elementName,attributeNames,charAttributeValues,lengths)
457 458
      DEALLOCATE(charAttributeValues)

459
   END SUBROUTINE openXMLElementFormPoly
460

461 462 463 464 465 466 467 468 469 470 471
   SUBROUTINE openXMLElementNoAttributes(elementName)

      IMPLICIT NONE

      CHARACTER(LEN=*)             :: elementName

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

      IF(currentElementIndex.EQ.maxNumElements) THEN
472
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
473 474 475 476 477 478 479
         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))
480

481 482
   END SUBROUTINE openXMLElementNoAttributes

483 484 485 486
   SUBROUTINE openXMLElement(elementName,attributeNames,attributeValues)

      IMPLICIT NONE

487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503
      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

504 505 506
      CHARACTER(LEN=*)             :: elementName
      CHARACTER(LEN=*), INTENT(IN) :: attributeNames(:)
      CHARACTER(LEN=*), INTENT(IN) :: attributeValues(:)
507
      INTEGER,          INTENT(IN) :: lengths(:,:)
508 509 510 511

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

512 513 514 515 516
      INTEGER, ALLOCATABLE            :: bigLengths(:,:)
      INTEGER                         :: i, j
      INTEGER                         :: overallListSize
      INTEGER                         :: lengthsShape(2)

517
      IF(SIZE(attributeNames).NE.SIZE(attributeValues)) THEN
518 519 520
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
         WRITE(*,*) 'attributeNames ', attributeNames
         WRITE(*,*) 'attributeValues ', attributeValues
521 522 523
         STOP 'ERROR: SIZE(attributeNames).NE.SIZE(attributeValues)'
      END IF
      IF(currentElementIndex.EQ.maxNumElements) THEN
524 525 526 527
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
         WRITE(*,*) 'attributeNames ', attributeNames
         WRITE(*,*) 'attributeValues ', attributeValues
         WRITE(*,*) 'elementList ', elementList
528 529
         STOP 'ERROR: xml hierarchy too deep!'
      END IF
530 531 532 533 534 535 536 537 538 539 540

      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

541 542
      openingString = '<'//TRIM(ADJUSTL(elementName))
      DO i = 1, SIZE(attributeNames)
543 544 545 546 547 548 549
         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))), '"'
550 551
      END DO
      openingString = TRIM(ADJUSTL(openingString))//'>'
552 553 554

      currentElementIndex = currentElementIndex + 1
      elementList(currentElementIndex) = TRIM(ADJUSTL(elementName))
555
      WRITE(format,'(a,i0,a)') "(a",3*currentElementIndex,",a)"
556
      WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(openingString))
557 558 559
      DEALLOCATE (bigLengths)

   END SUBROUTINE openXMLElementForm
560 561 562 563 564 565 566 567 568 569 570

   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
571 572
         WRITE(*,*) 'elementList(currentElementIndex): ', TRIM(ADJUSTL(elementList(currentElementIndex)))
         WRITE(*,*) 'elementName ', TRIM(ADJUSTL(elementName))
573 574
         STOP 'ERROR: Closing xml element inconsistency!'
      END IF
575 576
      closingString = '</'//TRIM(ADJUSTL(elementName))//'>'
      WRITE(format,'(a,i0,a)') "(a",3*currentElementIndex,",a)"
577 578
      WRITE(xmlOutputUnit,format) ' ', TRIM(ADJUSTL(closingString))
      currentElementIndex = currentElementIndex - 1
579

580 581
   END SUBROUTINE closeXMLElement

582 583 584 585 586
   LOGICAL FUNCTION isCurrentXMLElement(elementName)

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN) :: elementName
587
      if (currentElementIndex==0.or.currentElementIndex>SIZE(elementList)) THEN
Daniel Wortmann's avatar
Daniel Wortmann committed
588 589 590
                  isCurrentXMLElement=.false.
                  return
      endif
591 592 593 594
      isCurrentXMLElement = (TRIM(ADJUSTL(elementList(currentElementIndex))).EQ.TRIM(ADJUSTL(elementName)))

   END FUNCTION isCurrentXMLElement

595
END MODULE m_xmlOutput