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()
Daniel Wortmann's avatar
Daniel Wortmann committed
44
      USE m_judft
45
      USE m_constants
46
      USE m_utility
47 48
      USE m_compile_descr
      
49
      IMPLICIT NONE
50

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

   SUBROUTINE endXMLOutput()
111

112
      IMPLICIT NONE
113 114 115

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

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

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

      IMPLICIT NONE

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

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

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

      charAttributeValues = ''
      charContentList = ''

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

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

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

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

220 221
   END SUBROUTINE writeXMLElementPoly

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

      IMPLICIT NONE

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

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

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

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

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

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

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

331 332
   END SUBROUTINE writeXMLElement

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

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

      IMPLICIT NONE

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

   SUBROUTINE openXMLElementPoly(elementName,attributeNames,attributeValues)

      IMPLICIT NONE

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

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

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

      ALLOCATE(charAttributeValues(SIZE(attributeValues)))

      charAttributeValues = ''

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

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

458
   END SUBROUTINE openXMLElementFormPoly
459

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

      IMPLICIT NONE

      CHARACTER(LEN=*)             :: elementName

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

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

480 481
   END SUBROUTINE openXMLElementNoAttributes

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

      IMPLICIT NONE

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

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

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

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

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

      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

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

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

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

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

579 580
   END SUBROUTINE closeXMLElement

581 582 583 584 585
   LOGICAL FUNCTION isCurrentXMLElement(elementName)

      IMPLICIT NONE

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

   END FUNCTION isCurrentXMLElement

594
END MODULE m_xmlOutput