* PACKAGE  GTTHETAE  !" ΑκΕφ²Ή°Μ
***********************************************************************
      PROGRAM GTTHTE
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
      COMMON     /GMWORK/ MWORK
      REAL       MWORK  ( IJKDIM )
*
      CHARACTER  HHEADT( NDC )*(NCC)
      REAL       GDATAT( IJKDIM )
      CHARACTER  HHEADQ( NDC )*(NCC)
      REAL       GDATAQ( IJKDIM )
      CHARACTER  HHEADP( NDC )*(NCC)
      REAL       GDATAP( IJKDIM )
*
      DATA       IFILT / 50 /
      DATA       IFILQ / 51 /
      DATA       IFILP / 52 /
      DATA       JFILE / 60 /
*
      CHARACTER  T      *(NFILN)
      DATA       T      / 'T' /
      CHARACTER  Q      *(NFILN)
      DATA       Q      / 'q' /
      CHARACTER  PS     *(NFILN)
      DATA       PS     / 'Ps' /
      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   / 'THETAE' /
      DATA       UNIT   / ' ' /
      DATA       TITLE  / 'Equiv. Pot. Temp.' /
      DATA       DSET, EDIT, ETTL /3*' '/
      LOGICAL    GRESET
      DATA       GRESET / .TRUE. /
      LOGICAL    HELP
      DATA       HELP   / .FALSE. /
*
      EXTERNAL   THETAE
*     
      NAMELIST  /OPTION/ T, Q, PS, 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 GTSIZE ( HHEADP, IJKDIM )
      CALL GMSIZE ( IJKDIM  )
*
      CALL GURNTF ( T , OUT  , '$GTTMPDIR/gtool.in' )
      CALL GURNTF ( Q , OUT  , '$GTTMPDIR/gtool.in' )
      CALL GURNTF ( PS, OUT  , '$GTTMPDIR/gtool.in' )
*
      CALL GFROPN ( IFILET, T     )
      CALL GFROPN ( IFILEQ, Q     )
      CALL GFROPN ( IFILEP, PS    )
      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               )
         CALL   GFREAD
     O        ( HHEADP, GDATAP, IEODP ,
     I          IFILEP, 1               )
*
         IF ( MAX(IEODQ,IEODT,IEODP) .EQ.0 ) THEN
            CALL GMCAL3
     I         ( THETAE,
     M           HHEADT, GDATAT,
     I           HHEADQ, GDATAQ,
     I           HHEADP, GDATAP,
     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 THETAE
     I         ( HHEADT, T     ,
     I           HHEADQ, Q     ,
     I           HHEADP, PS    ,
     O           HHEADE, THE   ,
     D           IXDIM , IYDIM , IZDIM ,
     D           IXDIM2, IYDIM2, IZDIM2,
     D           IXDIM3, IYDIM3, IZDIM3 )
*
      CHARACTER  HHEADT ( * ) *(*)
      CHARACTER  HHEADQ ( * ) *(*)
      CHARACTER  HHEADP ( * ) *(*)
      CHARACTER  HHEADE ( * ) *(*)
      REAL       T  ( IXDIM , IYDIM , IZDIM  )
      REAL       Q  ( IXDIM2, IYDIM2, IZDIM2 )
      REAL       PS ( IXDIM3, IYDIM3         )
      REAL       THE( IXDIM , IYDIM , IZDIM  )
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
      PARAMETER  ( KDIMD = 100 )
      REAL       SIG ( KDIMD )
* 
      DATA       P00  / 1000. /
      DATA       RAIR / 287.04 /
      DATA       CP   / 1004.6 /
      DATA       EL   / 2.5E6  /
*
      IF ( IZDIM .GT. KDIMD ) THEN
         CALL MSGDMP( 'E','THETAE','WORK AREA TOO SMALL' )
      ENDIF
*
      CALL GUQAXP
     I         ( HHEADT, 3     , 'LOC',
     O           SIG   , IEOD  , KDIMD  )
*
      AKAPPA = RAIR / CP
*
      DO 1100 K = 1, IZDIM
         DO 1100 J = 1, IYDIM
            DO 1100 I = 1, IXDIM
                  THE( I,J,K ) = ( T ( I,J,K ) + EL/CP * Q ( I,J,K ) )
     &                         / ( PS( I,J )*SIG( K )/ P00 )** AKAPPA
 1100 CONTINUE
*
      RETURN
      END