st_qaprint_monvol.F File Reference

#include "implicit_f.inc"
#include "com04_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	st_qaprint_monvol (t_monvol, t_monvol_metadata)

Function/Subroutine Documentation

st_qaprint_monvol()

subroutine st_qaprint_monvol	(	type(monvol_struct_), dimension(nvolu), intent(in)	t_monvol,
		type(monvol_metadata_), intent(in)	t_monvol_metadata )

Definition at line 31 of file st_qaprint_monvol.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE qa_out_mod
      USE monvol_struct_mod
      USE names_and_titles_mod , ONLY : nchartitle
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
!     NVOLU
#include "com04_c.inc"
!     nimv
#include "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
      TYPE(MONVOL_METADATA_), INTENT(IN) :: T_MONVOL_METADATA
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: NN, II, JJ, KK, ID
      CHARACTER(LEN = nchartitle) :: TITLE
      CHARACTER(LEN = 255) :: VARNAME
      INTEGER :: NJET, NVENT
      DOUBLE PRECISION :: FVALUE
      INTEGER, DIMENSION(NVOLU) :: IDX, IDS
      LOGICAL :: OK_QA
C-----------------------------------------------
C   S o u r c e   L i n e s
C-----------------------------------------------
      ok_qa = myqakey('/MONVOL')
      IF (ok_qa) THEN
         IF (nvolu > 0) THEN
!     Sort by ID to ensure internal order independnat output
            DO ii = 1, nvolu
               ids(ii) = t_monvol(ii)%ID
               idx(ii) = ii
            ENDDO
            CALL quicksort_i2(ids, idx, 1, nvolu)
!     ICBAG
            DO ii = 1, nicbag
               DO jj = 1, nvolu * nvolu
                  WRITE(varname, '(A, I0, A,  I0)') 'ICBAG_', ii, '_', jj
                  IF (t_monvol_metadata%ICBAG(ii, jj) /= 0) THEN
                     CALL qaprint(varname(1:len_trim(varname)), 
     .                    t_monvol_metadata%ICBAG(ii, jj), 0.0_8)
                  ENDIF
               ENDDO
            ENDDO
!     RCBAG
            DO ii = 1, nicbag
               DO jj = 1, nvolu * nvolu
                  WRITE(varname, '(A, I0, A, I0)') 'RCBAG_', ii, '_', jj
                  IF (t_monvol_metadata%RCBAG(ii, jj) /= zero) THEN
                     fvalue = t_monvol_metadata%RCBAG(ii, jj)
                     CALL qaprint(varname(1:len_trim(varname)), 
     .                    0, fvalue)
                  ENDIF
               ENDDO
            ENDDO
         ENDIF
         DO kk = 1, nvolu
            nn = idx(kk)
            id = t_monvol(nn)%ID
            title = t_monvol(nn)%TITLE
            IF (len_trim(title) == 0) THEN
               title = "MONVOL_FAKE_TITLE"
            ENDIF
            CALL qaprint(title(1:len_trim(title)), id, 0.0_8)
!     IVOLU
            DO ii = 1, nimv
               WRITE(varname, '(A, I0)') 'IVOLU_', ii
               IF (t_monvol(nn)%IVOLU(ii) /= 0) THEN
                  CALL qaprint(varname(1:len_trim(varname)), t_monvol(nn)%IVOLU(ii), 0.0_8)
               ENDIF
            ENDDO
!     IBAGJET
            njet = t_monvol(nn)%NJET
            IF (njet > 0) THEN
               DO ii = 1, nibjet
                  DO jj = 1, njet
                     WRITE(varname, '(A, I0, A, I0)') 'IBAGJET_', ii, '_',  jj
                     IF (t_monvol(nn)%IBAGJET(ii, jj) /= 0) THEN
                        CALL qaprint(varname(1:len_trim(varname)), t_monvol(nn)%IBAGJET(ii, jj), 0.0_8)
                     ENDIF
                  ENDDO
               ENDDO
            ENDIF
!     IBAGHOL
            nvent = t_monvol(nn)%NVENT
            IF (nvent > 0) THEN
               DO ii = 1, nibhol
                  DO jj = 1, nvent
                     WRITE(varname, '(A, I0, A, I0)') 'IBAGHOL_', ii, '_', jj
                     IF (t_monvol(nn)%IBAGHOL(ii, jj) /= 0) THEN
                        CALL qaprint(varname(1:len_trim(varname)), t_monvol(nn)%IBAGHOL(ii, jj), 0.0_8)
                     ENDIF
                  ENDDO
               ENDDO
            ENDIF
!     RVOLU
            DO ii = 1, nrvolu
               WRITE(varname, '(A, I0)') 'RVOLU_', ii
               IF (t_monvol(nn)%RVOLU(ii) /= zero) THEN
                  fvalue = t_monvol(nn)%RVOLU(ii)
                  CALL qaprint(varname(1:len_trim(varname)), 0, fvalue)
               ENDIF
            ENDDO
!     rbagjet
            IF (njet > 0) THEN
               DO ii = 1, nrbjet
                  DO jj = 1, njet
                     WRITE(varname, '(A, I0, A, I0)') 'RBAGJET_', ii, '_', jj
                     IF (t_monvol(nn)%RBAGJET(ii, jj) /= zero) THEN
                        fvalue = t_monvol(nn)%RBAGJET(ii, jj)
                        CALL qaprint(varname(1:len_trim(varname)), 0, fvalue)
                     ENDIF
                  ENDDO
               ENDDO
            ENDIF
!     RBAGHOL
            IF (nvent > 0) THEN
               DO ii = 1, nrbhol
                  DO jj = 1, nvent
                     WRITE(varname, '(A, I0, A, I0)') 'RBAGHOL_', ii, '_', jj
                     IF (t_monvol(nn)%RBAGHOL(ii, jj) /= zero) THEN
                        fvalue = t_monvol(nn)%RBAGHOL(ii, jj)
                        CALL qaprint(varname(1:len_trim(varname)), 0, fvalue)
                     ENDIF
                  ENDDO
               ENDDO
            ENDIF
         ENDDO
      ENDIF
C-----------------------------------------------
C     E n d   o f   S u b r o u t i n e
C-----------------------------------------------