* PACKAGE  GTTV  !" ²¾²¹ÅÙ
***********************************************************************
      PROGRAM GTTV
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
      COMMON     /GMWORK/ MWORK
      REAL       MWORK  ( IJKDIM )
*
      CHARACTER  HHEADQ( NDC )*(NCC)
      REAL       GDATAQ( IJKDIM )
      CHARACTER  HHEADT( NDC )*(NCC)
      REAL       GDATAT( IJKDIM )
*
      DATA       IFILT / 51 /
      DATA       IFILQ / 50 /
      DATA       JFILE / 60 /
*
      CHARACTER  T      *(NFILN)
      DATA       T      / 'T' /
      CHARACTER  Q      *(NFILN)
      DATA       Q      / 'q' /
      CHARACTER  OUT    *(NFILN)
      DATA       OUT    / '$GTTMPDIR/gtool.out' /
      LOGICAL    APND
      DATA       APND   / .FALSE. /
      CHARACTER  ITEM   *(NCC)
      CHARACTER  UNIT   *(NCC)
      CHARACTER  TITLE  *(NCC*2)
      CHARACTER  DSET   *(NCC)
      CHARACTER  EDIT   *(NCC)
      CHARACTER  ETTL   *(NCC)
      DATA       ITEM   / 'TV' /
      DATA       UNIT   / 'K' /
      DATA       TITLE  / 'virtual temperature' /
      DATA       DSET, EDIT, ETTL /3*' '/
      LOGICAL    GRESET
      DATA       GRESET / .FALSE. /

      LOGICAL    HELP
      DATA       HELP   / .FALSE. /
*
      EXTERNAL   TVERT
*     
      NAMELIST  /OPTION/ T, Q, OUT, APND,
     &                   ITEM, UNIT, TITLE, DSET, EDIT, ETTL, GRESET,
     &                   HELP
*
      CALL OPTARG ( 91, 'OPTION', 'HFILE', NOPT, NFILE )
      READ (91,OPTION,IOSTAT=IOS)
      CLOSE(91)
      IF ( IOS.NE.0 .OR. HELP ) THEN
         WRITE(6,OPTION)
         STOP
      ENDIF
*
      CALL GTOPEN
      CALL GTSIZE ( HHEADT, IJKDIM )
      CALL GTSIZE ( HHEADQ, IJKDIM )
      CALL GMSIZE ( IJKDIM  )
*
      CALL GURNTF ( T, OUT  , '$GTTMPDIR/gtool.in' )
      CALL GURNTF ( Q, OUT  , '$GTTMPDIR/gtool.in' )
*
      CALL GFROPN ( IFILET, T     )
      CALL GFROPN ( IFILEQ, Q     )
      CALL GFOOPN ( JFILE ,  OUT , APND )
*
      CALL GUNENV( OUT,'.',.FALSE. )
      IL=LENC(OUT)
      WRITE (6,*) 'output='//OUT(1:IL)
*
 1100 CONTINUE
         CALL   GFREAD
     O        ( HHEADT, GDATAT, IEODT  ,
     I          IFILET , 1               )
         CALL   GFREAD
     O        ( HHEADQ, GDATAQ, IEODQ  ,
     I          IFILEQ, 1               )
*
         IF ( MAX(IEODQ,IEODT) .EQ.0 ) THEN
            CALL GMCAL2
     I         ( TVERT,
     M           HHEADT, GDATAT,
     I           HHEADQ, GDATAQ,
     I           EDIT  , ETTL  )
*
            IF ( ITEM .NE. ' ' ) THEN
               CALL GHCSET( HHEADT, 'ITEM', ITEM )
            ENDIF
            IF ( UNIT .NE. ' ' ) THEN
               CALL GHCSET( HHEADT, 'UNIT', UNIT )
            ENDIF
            IF ( TITLE .NE. ' ' ) THEN
               CALL GHCSTS( HHEADT, 'TITL', TITLE )
            ENDIF
            IF ( DSET .NE. ' ' ) THEN
               CALL GHCSET( HHEADT, 'DSET', DSET )
            ENDIF
            IF ( GRESET ) THEN
               CALL GHRSGP( HHEADT  )
            ENDIF
*
            CALL  GFWRIT
     I                 ( HHEADT, GDATAT,
     I                   JFILE , 1     , 0       )
*
      GOTO 1100
         ENDIF
*
      STOP
      END
********************************************************************
      SUBROUTINE TVERT
     I         ( HHEADT, T     ,
     I           HHEADQ, Q     ,
     O           HHEADV, TV    ,
     D           IXDIM , IYDIM , IZDIM ,
     D           IXDIM2, IYDIM2, IZDIM2 )
*
      CHARACTER  HHEADT ( * ) *(*)
      CHARACTER  HHEADQ ( * ) *(*)
      CHARACTER  HHEADV ( * ) *(*)
      REAL       T  ( IXDIM , IYDIM , IZDIM  )
      REAL       Q  ( IXDIM2, IYDIM2, IZDIM2 )
      REAL       TV ( IXDIM , IYDIM , IZDIM  )
*
      DATA       RAIR / 287.04 /
      DATA       RVAP / 461. /
*
      EPSV   = RAIR / RVAP
      EPSVT  = 1.0/EPSV - 1.0
*
      DO 1100 IZ = 1, IZDIM
         DO 1110 IY = 1, IYDIM
            DO 1120 IX = 1, IXDIM
               TV ( IX,IY,IZ ) = T ( IX,IY,IZ )
     &                         * ( 1.+ EPSVT * Q ( IX,IY,IZ ) )
 1120       CONTINUE
 1110    CONTINUE
 1100 CONTINUE
*
      RETURN
      END