| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| character(len=*), | intent(in), | DIMENSION(:,:) | :: | body | ||
| character(len=*), | intent(in), | DIMENSION(:) | :: | rowLabels | ||
| character(len=*), | intent(in), | DIMENSION(:) | :: | columnLabels | ||
| integer, | intent(inout), | DIMENSION(:) | :: | widthColumn | ||
| logical, | intent(in), | optional | :: | transposeXML | ||
| character(len=*), | intent(in), | optional | :: | footnoteText |
Nodes of different colours represent the following:
Solid arrows point from a procedure to one which it calls. Dashed arrows point from an interface to procedures which implement that interface. This could include the module procedures in a generic interface or the implementation in a submodule of an interface in a parent module. Where possible, edges connecting nodes are given different colours to make them easier to distinguish in large graphs.
Nodes of different colours represent the following:
Solid arrows point from a procedure to one which it calls. Dashed arrows point from an interface to procedures which implement that interface. This could include the module procedures in a generic interface or the implementation in a submodule of an interface in a parent module. Where possible, edges connecting nodes are given different colours to make them easier to distinguish in large graphs.
SUBROUTINE WriteTable(body,rowLabels,columnLabels,widthColumn,transposeXML,footnoteText)
! SUBROUTINE INFORMATION:
! AUTHOR Jason Glazer
! DATE WRITTEN August 2003
! MODIFIED na
! RE-ENGINEERED na
! PURPOSE OF THIS SUBROUTINE:
! Output a table to the tabular output file in the selected
! style (comma, tab, space, html, xml).
!
! The widthColumn array is only used for fixed space formatted reports
! if columnLables contain a vertical bar '|', they are broken into multiple
! rows. If they exceed the column width even after that and the format is
! fixed, they are further shortened.
!
! To include the currency symbol ($ by default but other symbols if the user
! has input it with Economics:CurrencyType) use the string ~~$~~ in the row
! headers, column headers, and body. For HTML files, the ASCII or UNICODE
! symbol for the currency will be included. For TXT files, the ASCII symbol
! will be used.
IMPLICIT NONE
! SUBROUTINE ARGUMENT DEFINITIONS:
CHARACTER(len=*),INTENT(IN),DIMENSION(:,:) :: body ! row,column
CHARACTER(len=*),INTENT(IN),DIMENSION(:) :: rowLabels
CHARACTER(len=*),INTENT(IN),DIMENSION(:) :: columnLabels
INTEGER,INTENT(INOUT),DIMENSION(:) :: widthColumn
LOGICAL,INTENT(IN),OPTIONAL :: transposeXML
CHARACTER(len=*),INTENT(IN),OPTIONAL :: footnoteText
! SUBROUTINE PARAMETER DEFINITIONS:
CHARACTER(len=*), PARAMETER :: fmta="(A)"
CHARACTER(len=*), PARAMETER :: blank=' '
! INTERFACE BLOCK SPECIFICATIONS:
! na
! DERIVED TYPE DEFINITIONS:
! na
! SUBROUTINE LOCAL VARIABLE DECLARATIONS:
CHARACTER(len=MaxNameLength*2),DIMENSION(:,:), ALLOCATABLE :: colLabelMulti
CHARACTER(len=1000) :: workColumn
CHARACTER(len=MaxNameLength),DIMENSION(:),ALLOCATABLE :: rowLabelTags
CHARACTER(len=MaxNameLength),DIMENSION(:),ALLOCATABLE :: columnLabelTags
CHARACTER(len=MaxNameLength),DIMENSION(:),ALLOCATABLE :: rowUnitStrings
CHARACTER(len=MaxNameLength),DIMENSION(:),ALLOCATABLE :: columnUnitStrings
CHARACTER(len=MaxNameLength),DIMENSION(:,:),ALLOCATABLE :: bodyEsc
INTEGER :: numColLabelRows
INTEGER :: maxNumColLabelRows
INTEGER :: widthRowLabel
INTEGER :: maxWidthRowLabel
INTEGER :: rowsBody
INTEGER :: colsBody
INTEGER :: colsColumnLabels
INTEGER :: colsWidthColumn
INTEGER :: rowsRowLabels
INTEGER :: iCol
INTEGER :: jRow
INTEGER :: colWidthLimit
INTEGER :: barLoc
CHARACTER(LEN=1000) :: outputLine
CHARACTER(LEN=1000) :: spaces
INTEGER :: iStyle
INTEGER :: curFH
CHARACTER(LEN=1) :: curDel
CHARACTER(len=MaxNameLength) :: tagWithAttrib
integer :: col1start
LOGICAL :: doTransposeXML
LOGICAL :: isTableBlank
LOGICAL :: isRecordBlank
IF (Present(transposeXML)) THEN
doTransposeXML = transposeXML
ELSE
doTransposeXML = .FALSE. !if not present assume that the XML table should not be transposed
END IF
! create blank string
spaces = blank ! REPEAT(' ',1000)
! get sizes of arrays
rowsBody = SIZE(Body,1)
colsBody = SIZE(Body,2)
rowsRowLabels = SIZE(rowLabels)
colsColumnLabels = SIZE(columnLabels)
colsWidthColumn = SIZE(widthColumn)
! check size of arrays for consistancy and if inconsistent use smaller value
! and display warning
IF (rowsBody .NE. rowsRowLabels) THEN
CALL ShowWarningError('REPORT:TABLE Inconsistant number of rows.')
rowsBody = MIN(rowsBody,rowsRowLabels)
rowsRowLabels = rowsBody
ENDIF
IF ((colsBody .NE. colsColumnLabels) .OR. (colsBody .NE.colsWidthColumn)) THEN
CALL ShowWarningError('REPORT:TABLE Inconsistant number of columns.')
colsBody = MIN(colsBody,MIN(colsColumnLabels,colsWidthColumn))
colsWidthColumn = colsBody
colsColumnLabels = colsBody
ENDIF
! create arrays to hold the XML tags
ALLOCATE(rowLabelTags(rowsBody))
ALLOCATE(columnLabelTags(colsBody))
ALLOCATE(rowUnitStrings(rowsBody))
ALLOCATE(columnUnitStrings(colsBody))
ALLOCATE(bodyEsc(rowsBody,colsBody))
! create new array to hold multiple line column lables
ALLOCATE(colLabelMulti(50,colsColumnLabels))
colLabelMulti = blank !set array to blank
numColLabelRows = 0 !default value
maxNumColLabelRows = 0
DO iStyle = 1, numStyles
curFH = TabularOutputFile(iStyle)
curDel = del(iStyle)
! go through the columns and break them into multiple lines
! if bar '|' is found in a row then break into two lines
! if longer than the column width break into two lines for fixed style only
DO iCol = 1, colsColumnLabels
numColLabelRows = 0
workColumn = columnLabels(iCol)
widthcolumn(icol)=MAX(widthcolumn(icol),len_trim(columnLabels(iCol)))
DO
barLoc = INDEX(workColumn,'|')
IF (barLoc .GT. 0) THEN
numColLabelRows = numColLabelRows + 1
colLabelMulti(numColLabelRows,iCol) = workColumn(:barLoc-1)
workColumn = workColumn(barLoc+1:)
ELSE
numColLabelRows = numColLabelRows + 1
colLabelMulti(numColLabelRows,iCol) = workColumn
EXIT !inner do loop
END IF
END DO
IF (numColLabelRows .GT. maxNumColLabelRows) THEN
maxNumColLabelRows = numColLabelRows
END IF
END DO
! extra preprocessing for fixed style reports
IF (TableStyle(iStyle) .EQ. tableStyleFixed) THEN
! break column headings into multiple rows if long (for fixed) or contain two spaces in a row.
DO iCol = 1, colsColumnLabels
colWidthLimit = widthColumn(iCol)
DO jRow = 1, maxNumColLabelRows
colLabelMulti(jRow,iCol) = colLabelMulti(jRow,iCol)(1:colWidthLimit)
END DO
END DO
maxWidthRowLabel = 0
DO jRow = 1, rowsRowLabels
widthRowLabel = LEN_TRIM(rowLabels(jRow))
IF (widthRowLabel .GT. maxWidthRowLabel) THEN
maxWidthRowLabel = widthRowLabel
END IF
END DO
END IF
! output depending on style of format
SELECT CASE (TableStyle(iStyle))
CASE (tableStyleComma,tableStyleTab)
! column headers
DO jRow = 1, maxNumColLabelRows
outputLine = curDel ! one leading delimiters on column header lines
DO iCol = 1, colsColumnLabels
outputLine = TRIM(outputLine) // curDel // TRIM(ADJUSTL(colLabelMulti(jRow, iCol)))
END DO
WRITE(curFH,fmta) TRIM(InsertCurrencySymbol(outputLine,.FALSE.))
END DO
! body with row headers
DO jRow = 1, rowsBody
outputLine = curDel // TRIM(rowLabels(jRow)) !one leading delimiters on table body lines
DO iCol = 1, colsBody
outputLine = TRIM(outputLine) // curDel // TRIM(ADJUSTL(body(jRow, iCol)))
END DO
WRITE(curFH,fmta) TRIM(InsertCurrencySymbol(outputLine,.FALSE.))
END DO
IF (PRESENT(footnoteText)) THEN
IF (LEN_TRIM(footnoteText) .GT. 0) THEN
WRITE(curFH, fmta) TRIM(footnoteText)
END IF
END IF
WRITE(curFH,fmta) ''
WRITE(curFH,fmta) ''
CASE (tableStyleFixed)
! column headers
DO jRow = 1, maxNumColLabelRows
outputLine = blank ! spaces(:maxWidthRowLabel+2) !two extra spaces and leave blank area for row labels
col1start=max(maxWidthRowLabel+2,3)
DO iCol = 1, colsColumnLabels
if (iCol /= 1) then
outputLine = TRIM(outputLine) // ' '// ADJUSTR(colLabelMulti(jRow, iCol)(1:widthColumn(iCol)))
else
outputLine(col1start:) = ' '// ADJUSTR(colLabelMulti(jRow, iCol)(1:widthColumn(iCol)))
endif
END DO
WRITE(curFH,fmta) TRIM(InsertCurrencySymbol(outputLine,.FALSE.))
END DO
! body with row headers
DO jRow = 1, rowsBody
outputLine = ' ' // ADJUSTR(rowLabels(jRow)(:maxWidthRowLabel)) !two blank spaces on table body lines
col1start=max(len_trim(outputLine)+2,maxWidthRowLabel+2)
DO iCol = 1, colsBody
if (iCol /= 1) then
outputLine = TRIM(outputLine) // ' '// ADJUSTR(body(jRow, iCol)(1:widthColumn(iCol)))
else
outputLine(col1start:)= ' '// ADJUSTR(body(jRow, iCol)(1:widthColumn(iCol)))
endif
END DO
WRITE(curFH,fmta) TRIM(InsertCurrencySymbol(outputLine,.FALSE.))
END DO
IF (PRESENT(footnoteText)) THEN
IF (LEN_TRIM(footnoteText) .GT. 0) THEN
WRITE(curFH, fmta) TRIM(footnoteText)
END IF
END IF
WRITE(curFH,fmta) ''
WRITE(curFH,fmta) ''
CASE (tableStyleHTML)
! set up it being a table
WRITE(curFH,fmta) '<table border="1" cellpadding="4" cellspacing="0">'
! column headers
WRITE(curFH,fmta) ' <tr><td></td>' !start new row and leave empty cell
DO iCol = 1, colsColumnLabels
outputLine = ' <td align="right">'
DO jRow = 1, maxNumColLabelRows
outputLine = TRIM(outputLine) // TRIM(colLabelMulti(jRow, iCol))
IF (jRow .LT. maxNumColLabelRows) THEN
outputLine = TRIM(outputLine) // '<br>'
END IF
END DO
WRITE(curFH,fmta) TRIM(InsertCurrencySymbol(outputLine,.TRUE.)) // '</td>'
END DO
WRITE(curFH,fmta) ' </tr>'
! body with row headers
DO jRow = 1, rowsBody
WRITE(curFH,fmta) ' <tr>'
IF (TRIM(rowLabels(jRow)) .NE. '') THEN
WRITE(curFH,fmta) ' <td align="right">' // TRIM(InsertCurrencySymbol(rowLabels(jRow),.TRUE.)) // '</td>'
ELSE
WRITE(curFH,fmta) ' <td align="right"> </td>'
ENDIF
DO iCol = 1, colsBody
IF (TRIM(body(jRow,iCol)) .NE. '') THEN
WRITE(curFH,fmta) ' <td align="right">' // TRIM(InsertCurrencySymbol(body(jRow, iCol),.TRUE.)) // '</td>'
ELSE
WRITE(curFH,fmta) ' <td align="right"> </td>'
ENDIF
END DO
WRITE(curFH,fmta) ' </tr>'
END DO
! end the table
WRITE(curFH,fmta) '</table>'
IF (PRESENT(footnoteText)) THEN
IF (LEN_TRIM(footnoteText) .GT. 0) THEN
WRITE(curFH, fmta) '<i>' // TRIM(footnoteText) // '</i>'
END IF
END IF
WRITE(curFH,fmta) '<br><br>'
CASE (tableStyleXML)
!check if entire table is blank and it if is skip generating anything
isTableBlank = .TRUE.
DO jRow = 1, rowsBody
DO iCol = 1, colsBody
IF (LEN_TRIM(body(jRow, iCol)) .GT. 0) THEN
isTableBlank = .FALSE.
EXIT
END IF
END DO
IF (.NOT. isTableBlank) EXIT
END DO
! if non-blank cells in the table body were found create the table.
IF (.NOT. isTableBlank) THEN
!if report name and subtable name the same add "record" to the end
activeSubTableName = ConvertToElementTag(activeSubTableName)
activeReportNameNoSpace = ConvertToElementTag(activeReportName)
IF (SameString(activeSubTableName,activeReportNameNoSpace)) THEN
activeSubTableName = TRIM(activeSubTableName) // 'Record'
END IF
!if no subtable name use the report name and add "record" to the end
IF (LEN_TRIM(activeSubTableName) .EQ. 0) THEN
activeSubTableName = TRIM(activeReportNameNoSpace) // 'Record'
END IF
! if a single column table, transpose it automatically
IF ((colsBody .EQ. 1) .AND. (rowsBody .GT. 1)) THEN
doTransposeXML = .TRUE.
END IF
! first convert all row and column headers into tags compatible with XML strings
DO jRow = 1, rowsBody
rowLabelTags(jRow) = ConvertToElementTag(rowLabels(jRow))
IF (LEN_TRIM(rowLabelTags(jRow)) .EQ. 0) THEN
rowLabelTags(jRow) = "none"
END IF
rowUnitStrings(jRow) = GetUnitSubString(rowLabels(jRow))
IF (SameString(rowUnitStrings(jRow),'Invalid/Undefined')) THEN
rowUnitStrings(jRow) = ''
END IF
END DO
DO iCol = 1, colsBody
columnLabelTags(iCol) = ConvertToElementTag(columnLabels(iCol))
IF (LEN_TRIM(columnLabelTags(iCol)) .EQ. 0) THEN
columnLabelTags(iCol) = "none"
END IF
columnUnitStrings(iCol) = GetUnitSubString(columnLabels(iCol))
IF (SameString(columnUnitStrings(iCol),'Invalid/Undefined')) THEN
columnUnitStrings(iCol) = ''
END IF
END DO
! convert entire table body to one with escape characters (no " ' < > &)
DO jRow = 1, rowsBody
DO iCol = 1, colsBody
bodyEsc(jRow,iCol) = ConvertToEscaped(body(jRow,iCol))
END DO
END DO
IF (.NOT. doTransposeXML) THEN
! body with row headers
DO jRow = 1, rowsBody
!check if record is blank and it if is skip generating anything
isRecordBlank = .TRUE.
DO iCol = 1, colsBody
IF (LEN_TRIM(bodyEsc(jRow, iCol)) .GT. 0) THEN
isRecordBlank = .FALSE.
EXIT
END IF
END DO
IF (.NOT. isRecordBlank) THEN
WRITE(curFH,fmta) ' <' // TRIM(activeSubTableName) // '>'
IF (LEN_TRIM(rowLabelTags(jRow)) .GT. 0) THEN
WRITE(curFH, fmta) ' <name>' // TRIM(rowLabelTags(jRow)) // '</name>'
ENDIF
DO iCol = 1, colsBody
IF (LEN_TRIM(ADJUSTL(bodyEsc(jRow, iCol))) .GT. 0) THEN !skip blank cells
tagWithAttrib = '<' // TRIM(columnLabelTags(iCol))
IF (LEN_TRIM(columnUnitStrings(iCol)) .GT. 0) THEN
tagWithAttrib = TRIM(tagWithAttrib) // &
' units=' // CHAR(34) // TRIM(columnUnitStrings(iCol)) // CHAR(34) &
// '>' !if units are present add them as an attribute
ELSE
tagWithAttrib = TRIM(tagWithAttrib) // '>'
ENDIF
WRITE(curFH, fmta) ' ' // TRIM(tagWithAttrib) // &
TRIM(ADJUSTL(bodyEsc(jRow, iCol))) // &
'</' // TRIM(columnLabelTags(iCol)) // '>'
END IF
END DO
WRITE(curFH,fmta) ' </' // TRIM(activeSubTableName) // '>'
END IF
END DO
ELSE !transpose XML table
! body with row headers
DO iCol = 1, colsBody
!check if record is blank and it if is skip generating anything
isRecordBlank = .TRUE.
DO jRow = 1, rowsBody
IF (LEN_TRIM(bodyEsc(jRow, iCol)) .GT. 0) THEN
isRecordBlank = .FALSE.
EXIT
END IF
END DO
IF (.NOT. isRecordBlank) THEN
WRITE(curFH,fmta) ' <' // TRIM(activeSubTableName) // '>'
! if the column has units put them into the name tag
IF (LEN_TRIM(columnLabelTags(iCol)) .GT. 0) THEN
IF (LEN_TRIM(columnUnitStrings(iCol)) .GT. 0) THEN
WRITE(curFH, fmta) ' <name units=' // CHAR(34) // TRIM(columnUnitStrings(iCol)) // CHAR(34) &
// '>' // TRIM(columnLabelTags(iCol)) // '</name>'
ELSE
WRITE(curFH, fmta) ' <name>' // TRIM(columnLabelTags(iCol)) // '</name>'
END IF
ENDIF
DO jRow = 1, rowsBody
IF (LEN_TRIM(bodyEsc(jRow, iCol)) .GT. 0) THEN !skip blank cells
tagWithAttrib = '<' // TRIM(rowLabelTags(jRow))
IF (LEN_TRIM(rowUnitStrings(jRow)) .GT. 0) THEN
tagWithAttrib = TRIM(tagWithAttrib) // &
' units=' // CHAR(34) // TRIM(rowUnitStrings(jRow)) // CHAR(34) &
// '>' !if units are present add them as an attribute
ELSE
tagWithAttrib = TRIM(tagWithAttrib) // '>'
ENDIF
WRITE(curFH, fmta) ' ' // TRIM(tagWithAttrib) // &
TRIM(ADJUSTL(bodyEsc(jRow, iCol))) // &
'</' // TRIM(rowLabelTags(jRow)) // '>'
END IF
END DO
WRITE(curFH,fmta) ' </' // TRIM(activeSubTableName) // '>'
END IF
END DO
END IF
IF (PRESENT(footnoteText)) THEN
IF (LEN_TRIM(footnoteText) .GT. 0) THEN
WRITE(curFH, fmta) ' <footnote>' // TRIM(footnoteText) // '</footnote>'
END IF
END IF
END IF
CASE DEFAULT
END SELECT
END DO
DEALLOCATE(colLabelMulti)
DEALLOCATE(rowLabelTags)
DEALLOCATE(columnLabelTags)
DEALLOCATE(rowUnitStrings)
DEALLOCATE(columnUnitStrings)
DEALLOCATE(bodyEsc)
RETURN
END SUBROUTINE WriteTable