* PACKAGE  GTSLP !" ³¤ÌÌ¹¹Àµµ¤°µ
***********************************************************************
      PROGRAM GTSLP
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
      COMMON     /GMWORK/ MWORK
      REAL       MWORK  ( IJKDIM )
*
      CHARACTER  HHEADP( NDC )*(NCC)
      REAL       GDATAP( IJKDIM )
      CHARACTER  HHEADT( NDC )*(NCC)
      REAL       GDATAT( IJKDIM )
      CHARACTER  HHEADZ( NDC )*(NCC)
      REAL       GDATAZ( IJKDIM )
      CHARACTER  HITEZ  *(NCC)
*
      DATA       IFILP / 50 /
      DATA       IFILT / 51 /
      DATA       IFILZ / 52 /
      DATA       JFILE / 60 /
*
      DATA       GRAV  /  9.8 /
*
      CHARACTER  PS     *(NFILN)
      DATA       PS     / 'Ps' /
      CHARACTER  T      *(NFILN)
      DATA       T      / 'T' /
      CHARACTER  ZS     *(NFILN)
      DATA       ZS     / 'ZS' /
      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  / 'SLP' /
      DATA       TITLE / 'Sea Level Pressure' /
      DATA       UNIT, DSET, EDIT, ETTL / 4*' '/
      LOGICAL    GRESET
      DATA       GRESET / .FALSE. /
      LOGICAL    HELP
      DATA       HELP   / .FALSE. /
*
      EXTERNAL   CALSLP
*     
      NAMELIST  /OPTION/ PS  , T   , ZS   , 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 ( HHEADP, IJKDIM )
      CALL GTSIZE ( HHEADT, IJKDIM )
      CALL GTSIZE ( HHEADZ, IJKDIM )
      CALL GMSIZE ( IJKDIM  )
*
      CALL GURNTF ( PS, OUT  , '$GTTMPDIR/gtool.in' )
      CALL GURNTF ( T , OUT  , '$GTTMPDIR/gtool.in' )
      CALL GURNTF ( ZS, OUT  , '$GTTMPDIR/gtool.in' )
*
      CALL GFROPN ( IFILEP, PS   )
      CALL GFROPN ( IFILET, T    )
      CALL GFROPN ( IFILEZ, ZS   )
      CALL GFOOPN ( JFILE ,  OUT , APND )
*
      CALL GUNENV( OUT,'.',.FALSE. )
      IL=LENC(OUT)
      WRITE (6,*) 'output='//OUT(1:IL)
*
      CALL   GFREAD
     O        ( HHEADZ, GDATAZ, IEODZ ,
     I          IFILEZ, 1               )
*
      IF ( IEODZ .NE. 0 ) THEN
         CALL MSGDMP('E','GTSLP','ZS FILE NOT FOUND' )
      ENDIF
*
      CALL GHCGET( HHEADZ, 'ITEM', HITEZ )
      IF ( HITEZ .EQ. 'GPHIS' ) THEN
         CALL GMFFCT
     I        ( HHEADZ, GDATAZ, 1./GRAV ,
     I          '  '  , '  '              )
      ENDIF
*
 1100 CONTINUE
         CALL   GFREAD
     O        ( HHEADP, GDATAP, IEODP ,
     I          IFILEP, 1               )
         CALL   GFREAD
     O        ( HHEADT, GDATAT, IEODT ,
     I          IFILET, 1               )
*
         IF ( MAX(IEODP,IEODT) .EQ.0 ) THEN
            CALL GMCAL3
     I         ( CALSLP,
     M           HHEADP, GDATAP,
     I           HHEADT, GDATAT,
     I           HHEADZ, GDATAZ,
     I           EDIT  , ETTL  )
*
            IF ( ITEM .NE. ' ' ) THEN
               CALL GHCSET( HHEADP, 'ITEM', ITEM )
            ENDIF
            IF ( UNIT .NE. ' ' ) THEN
               CALL GHCSET( HHEADP, 'UNIT', UNIT )
            ENDIF
            IF ( TITLE .NE. ' ' ) THEN
               CALL GHCSTS( HHEADP, 'TITL', TITLE )
            ENDIF
            IF ( DSET .NE. ' ' ) THEN
               CALL GHCSET( HHEADP, 'DSET', DSET )
            ENDIF
            IF ( GRESET ) THEN
               CALL GHRSGP( HHEADP )
            ENDIF
*
            CALL  GFWRIT
     I                 ( HHEADP, GDATAP,
     I                   JFILE , 1     , 0       )
*
      GOTO 1100
         ENDIF
*
      STOP
      END
********************************************************************
      SUBROUTINE CALSLP
     I         ( HPS   , PS    ,
     I           HT    , T     ,
     I           HZS   , ZS    ,
     O           HSLP  , SLP   ,
     D           IMAX  , JMAX  , KMAX ,
     D           IMAX2 , JMAX2 , KMAX2,
     D           IMAX3 , JMAX3 , KMAX3  )
*
      CHARACTER  HPS ( * )*(*)
      REAL       PS  ( IMAX, JMAX )
      CHARACTER  HT  ( * )*(*)
      REAL       T   ( IMAX2, JMAX2, KMAX2 )
      CHARACTER  HZS ( * )*(*)
      REAL       ZS  ( IMAX3, JMAX3 )
      CHARACTER  HSLP( * )*(*)
      REAL       SLP ( IMAX, JMAX )
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
      CHARACTER  HHS ( NDC )*(NCC)
      PARAMETER  ( KMAXD = 100 )
      REAL       SIG  ( KMAXD )
*
      IF ( KMAX .GT. KMAXD ) THEN
         CALL MSGDMP( 'E','SLP','WORK AREA TOO SMALL' )
      ENDIF
      CALL GTSIZE ( HHS  ,  KMAXD   )
      CALL GUQAXV
     I            ( HT    , 3     , 'LOC',
     O              HHS   , SIG   , IEOD  )
*
      CALL PS2SLP
     I           ( ZS  , T   , PS  , SIG ,
     I             IMAX, JMAX,
     O             SLP                     )
*
      RETURN
      END
******************************************************************
      SUBROUTINE PS2SLP
     I           ( Z     , T     , PS    , SIG   ,
     I             IMAX  , JMAX  ,
     O             RSLP                            )
* ---------------------------------------
*  CALCULATE SEA LEVEL PRESSURE
*
* [INPUT]
*   Z    : SURFACE ALTITUDE
*   T    : TEMPERATURE AT SIGMA LEVEL 1
*   PS   : SURFACE AIR PRESSURE
*   SIG  : SIGMA LEVEL AT EACH LAYER
* [OUTPUT]
*   RSLP : SEA LEVEL PRESSURE
* [INTERNAL]
*   RZ   : ALTITUDE AT SIGMA LEVEL 1
*   P    : AIR PRESSURE AT SIGMA LEVEL 1
* ---------------------------------------
      REAL       Z     ( IMAX*JMAX )
      REAL       T     ( IMAX*JMAX )
      REAL       PS    ( IMAX*JMAX )
      REAL       SIG   ( 1 )
      REAL       RSLP  ( IMAX*JMAX )
*
      DATA       RAIR  /287.04/
      DATA       GRAV  /  9.8 /
*
* EVALUATE Z(LEVEL1) USING HYDROSTATIC RELATION
*
      DO 100 IJ = 1, IMAX*JMAX
         RZ = Z(IJ) - LOG( SIG(1) ) * RAIR * T(IJ) / GRAV
*
* SEA LEVEL PRESSURE
*
         RSLP(IJ) = PS(IJ) + DELTAP( RZ, T(IJ), PS(IJ)*SIG(1) )
  100 CONTINUE 
*
      RETURN
      END
**********************************************************************
      REAL FUNCTION DELTAP
     I              ( Z, T, P )
* ---------------------------------------------------------------
*  ( SEA LEVEL PRESSURE ) - ( SURFACE PRESSURE )
*
*  THIS METHOD HAVE USED BY THE OBSERVATION SECTION
*                        IN THE JAPANESE METEOROLOGICAL AGENCY.
* [INPUT]
*   Z   : ALTITUDE
*   T   : TEMPERATURE
*   P   : AIR PRESSURE
* [INTERNAL]
*   TM  : MEAN TEMPERATURE IN THE DESTINATION AIR COLUMN
*   EM  : EFFECT ON AIR MOISTURE
*   TVM : MEAN VIRTUAL TEMPERATURE IN THE DESTINATION AIR COLUMN
* ---------------------------------------------------------------
      DATA T00    /273.15 /
      DATA GRAV   /  9.8  /
      DATA RAIR   /287.05 /
      DATA TLAPS  /  0.005/
*
      TM  = ( T -T00 ) + TLAPS / 2. * Z
      EM  = EPSM( TM )
      TVM = T00 + TM + EM
*
      DELTAP = P * ( EXP( GRAV * Z / ( RAIR * TVM ) ) - 1. )
*
      RETURN
      END
*********************************************************************
      REAL FUNCTION EPSM(TM)
* ---------------------------------------
*  EFFECT ON AIR MOISTURE
*   (MEAN STATE OF LOWER LAYER IN JAPAN)
* ---------------------------------------
      IF(TM.LT.-30.) THEN
         EPSM = 0.09
         RETURN
       ELSE IF((-30..LE.TM).AND.(TM.LT.0.)) THEN
         A = 0.000489
         B = 0.0300
         C = 0.550
       ELSE IF((0..LE.TM).AND.(TM.LT.20.)) THEN
         A = 0.002850
         B = 0.0165
         C = 0.550
       ELSE IF((20..LE.TM).AND.(TM.LT.33.8)) THEN
         A =-0.006933
         B = 0.4687
         C =-4.580
       ELSE
         EPSM = 3.34
         RETURN
      ENDIF
*
      EPSM = ( A * TM + B ) * TM + C
*
      RETURN
      END
