* PACKAGE  GTS2P  !" ¦Ò-> p
***********************************************************************
      PROGRAM GTS2P
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
      COMMON     /GMWORK/ MWORK
      REAL       MWORK  ( IJKDIM )
*
      CHARACTER  HHEAD( NDC )*(NCC)
      REAL       GDATA( IJKDIM )
      CHARACTER  HHEADP( NDC )*(NCC)
      REAL       GDATAP( IJKDIM )
*
      CHARACTER  HFILE( 1 ) *(NFILN)
      DATA       HFILE   / '$GTTMPDIR/gtool.out' /
      DATA       IFILE / 50 /
      DATA       IFILP / 51 /
      DATA       JFILE / 60 /
*
      CHARACTER  PLEV   *(NCC)
      DATA       PLEV   / 'STDPLEV' /
      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, UNIT, TITLE, DSET, EDIT, ETTL / 6*' '/
      LOGICAL    GRESET
      DATA       GRESET / .FALSE. /
      LOGICAL    HELP
      DATA       HELP   / .FALSE. /
*
      EXTERNAL   S2P
*     
      NAMELIST  /OPTION/ PLEV, PS, OUT, APND,
     &                   ITEM, UNIT, TITLE, DSET, EDIT, ETTL, GRESET,
     &                   HELP, HFILE
*
      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 ( HHEAD, IJKDIM )
      CALL GTSIZE ( HHEADP, IJKDIM )
      CALL GMSIZE ( IJKDIM  )
*
      CALL GURNTF ( HFILE( 1 ), OUT  , '$GTTMPDIR/gtool.in' )
      CALL GURNTF ( PS        , OUT  , '$GTTMPDIR/gtool.in' )
*
      CALL GFROPN ( IFILE , HFILE( 1 ) )
      CALL GFROPN ( IFILEP, PS    )
      CALL GFOOPN ( JFILE ,  OUT , APND )
*
      CALL GUNENV( OUT,'.',.FALSE. )
      IL=LENC(OUT)
      WRITE (6,*) 'output='//OUT(1:IL)
*
      CALL  SETPLV ( PLEV )
*
 1100 CONTINUE
         CALL   GFREAD
     O        ( HHEAD , GDATA , IEOD  ,
     I          IFILE , 1               )
         CALL   GFREAD
     O        ( HHEADP, GDATAP, IEODP ,
     I          IFILEP, 1               )
*
         IF ( MAX(IEOD,IEODP) .EQ.0 ) THEN
            CALL GMCAL2
     I         ( S2P,
     M           HHEAD , GDATA ,
     I           HHEADP, GDATAP,
     I           EDIT  , ETTL  )
*
            IF ( ITEM .NE. ' ' ) THEN
               CALL GHCSET( HHEAD , 'ITEM', ITEM )
            ENDIF
            IF ( UNIT .NE. ' ' ) THEN
               CALL GHCSET( HHEAD , 'UNIT', UNIT )
            ENDIF
            IF ( TITLE .NE. ' ' ) THEN
               CALL GHCSTS( HHEAD , 'TITL', TITLE )
            ENDIF
            IF ( DSET .NE. ' ' ) THEN
               CALL GHCSET( HHEAD , 'DSET', DSET )
            ENDIF
            IF ( GRESET ) THEN
               CALL GHRSGP( HHEAD  )
            ENDIF
*
            CALL  GFWRIT
     I                 ( HHEAD , GDATA ,
     I                   JFILE , 1     , 0       )
*
      GOTO 1100
         ENDIF
*
      STOP
      END
********************************************************************
      SUBROUTINE S2P
     I         ( HDS   , DS     ,
     I           HPS   , PS    ,
     O           HDP   , DP    ,
     D           IMAX  , JMAX  , KMAX ,
     D           IMAX2 , JMAX2 , KMAX2 )
*
      CHARACTER  HDS ( * )*(*)
      REAL       DS ( IMAX, JMAX, KMAX )
      CHARACTER  HPS ( * )*(*)
      REAL       PS ( IMAX2, JMAX2 )
      CHARACTER  HDP ( * )*(*)
      REAL       DP ( IMAX, JMAX, KMAX )
*
      CHARACTER  HPLEVZ *(*)
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
      CHARACTER  HHS ( NDC )*(NCC)
      CHARACTER  HHP ( NDC )*(NCC)
      PARAMETER  ( KMAXD = 100 )
      REAL       SIG  ( KMAXD )
      REAL       PLEVS( KMAXD )
      CHARACTER  HPLEV *(NCC)
*
      DATA       P00  / 1000. /
      DATA       RAIR / 287.04 /
      DATA       CP   / 1004.6 /
*
      IF ( KMAX .GT. KMAXD ) THEN
         CALL MSGDMP( 'E','S2P','WORK AREA TOO SMALL' )
      ENDIF
*
      AKAPPA = RAIR / CP
      CALL GHPGET( HDS,'MISS',VMISS )
* 
      CALL GTSIZE ( HHP  ,  KMAXD   )
      CALL GTSIZE ( HHS  ,  KMAXD   )
      CALL GUQAXV
     I            ( HDS   , 3     , 'LOC',
     O              HHS   , SIG   , IEOD  )
      CALL GUQAXS
     I            ( HPLEV , 'LOC',
     O              HHP   , PLEVS, IEOD  )
      CALL GUQTSZ ( HHP, LMAX )
*
      CALL SINTRP
     I           ( PS  , SIG , DS  , PLEVS,
     I             IMAX, JMAX, KMAX, LMAX, VMISS,
     O             DP                            )
*
      CALL GHCSET( HDP, 'AITM3', HPLEV  )
      CALL GHPSET( HDP, 'ASTR3', 1      )
      CALL GHPSET( HDP, 'AEND3', LMAX   )
*
      RETURN
*=====================================================================
      ENTRY      SETPLV
     I         ( HPLEVZ )
      HPLEV = HPLEVZ
      RETURN
      END
***********************************************************************
      SUBROUTINE SINTRP
     I           ( PS  , SIG, XSIG,  PLEV,
     I             IMAX, JMAX, KMAX, LMAX, VMISS,
     O             XPRES                                 )
*
* INTERPOLATION FROM SIGMA LEVEL TO STD-PRESSURE LEVEL
*
*     created  by kuma 
*     modified by numaguti 92/07/06
*
      REAL     PS    (IMAX*JMAX)      ! PRESSURE
      REAL     SIG   (KMAX)           ! SIG
      REAL     XSIG  (IMAX*JMAX,KMAX) ! DATA OF SIGMA-CORDINATE
      REAL     XPRES (IMAX*JMAX,LMAX) ! DATA OF PRESSURE-CORDINATE
      REAL     PLEV  (LMAX)           ! INTERPOLATE IN THESE PRESSURE LEVELS
*
      PARAMETER  ( KMAXD = 100 )
      REAL     PLN   (KMAXD)
      REAL     Z     (KMAXD)
      REAL     PILN  (KMAXD)
      REAL     ZI    (KMAXD)
*
      DO 50 K = 1, LMAX
         PILN(K) = LOG(PLEV(K))
   50 CONTINUE 
*
      DO 100 IJ=1,IMAX*JMAX
         DO 110 K=1,KMAX
            PLN (K) = LOG(PS(IJ)*SIG(K))
            Z(K)=XSIG(IJ,K)
  110    CONTINUE
         CALL SPLINE(ZI,PILN,LMAX,Z,PLN,KMAX,VMISS)
         DO 120 L=1,LMAX
            XPRES(IJ,L)=ZI(L)
  120    CONTINUE
  100 CONTINUE
*
      RETURN
      END
* ---------------------------------------------------------------------
C     INTERPOLATION USING A CUBIC NONPERIODIC SPLINE
C     ZI(I)........INTERPOLATED VALUE AT PILN(I)
C     PILN(I)......LN(P) COORDINATE IN DECREASING ORDER
C     LMAX.........NUMBER OF INTERPOLATION POINTS
C     Z(I).........DATA AT PLN(I)
C     PLN(I).......LN(P) COORDINATE  IN DECREASING ORDER
C     IMAX.........NUMBER OF DATA POINTS
C     SM(I)........SECOND DERIVATIVES AT DATA POINTS
* ---------------------------------------------------------------------
* LAST MODIFIED ON 1992/07/06
*   PRESSURE-CORDINATE DATA UNDER THE GROUND ARE BLACKOUTED.
*   (THE BLACKOUTED AREAS ARE FILLED WITH BLKOUT)
*     created  by kuma 
*     modified by numaguti 92/07/06
*
      SUBROUTINE SPLINE
     O           (ZI,
     I            PILN,LMAX,Z,PLN,KMAX,BLKOUT)
*
      PARAMETER  ( KMAXD = 100 )
      REAL      ZI  (LMAX)
      REAL      PILN(LMAX)
      REAL      Z   (KMAX)
      REAL      PLN (KMAX)
      REAL      SM  (KMAXD)
      REAL      H   (KMAXD)
      REAL      AL  (KMAXD)
      REAL      AM  (KMAXD)
      REAL      AP  (KMAXD)
      REAL      C   (KMAXD)
*
      DO 110 K=2,KMAX
         H(K) = PLN(K)-PLN(K-1)
  110 CONTINUE
      DO 120 K=2, KMAX-1
         AL(K) = 0.5*H(K+1) / ( H(K)+H(K+1) )
         AM(K) = 0.5 - AL(K)
  120 CONTINUE
      AL(1)    = 0.
      AM(KMAX) = 0.
      AL(KMAX) = 0.
      DO 130 K=2, KMAX
         AP(K) = 1.0/( 1.0-AL(K-1)*AM(K) )
         AL(K) = AL(K)*AP(K)
  130 CONTINUE
*
      C(1)    = 0.
      C(KMAX) = 0.
      DO 160 K=2, KMAX-1
         C(K) = 3.0*( (Z(K+1)-Z(K))/H(K+1) - (Z(K)-Z(K-1))/H(K) )
     &            / ( H(K)+H(K+1) )
  160 CONTINUE
*
* FORWARD SUBSTITUTION
*
      DO 200 K=2,KMAX
         C(K)=( C(K)-C(K-1)*AM(K) )*AP(K)
  200 CONTINUE
      SM(KMAX)=C(KMAX)
*
*     BACKWARD SUBSTUTUTION
*
      DO 220 K=KMAX-1,K,-1
         SM(K) = C(K)-AL(K)*SM(K+1)
  220 CONTINUE
*
*     INTERPOLATION
*
      KU = 1
      DO 500 L=1,LMAX
         P=PILN(L)
*
         DO 300 K=KU, KMAX-1
            IF( P .GE. PLN(K) ) THEN
               KU = K
               GOTO 310
            ENDIF
  300    CONTINUE
         KU = KMAX
  310    CONTINUE
*
         IF( KU .EQ. 1 ) THEN
            ZI(L)=BLKOUT
         ELSE
            ZI(L)=( PLN(KU)-P    )/H(KU)
     &              *( Z(KU-1) - SM(KU-1)/6.
     &                        * ( P-PLN(KU-1) )*( H(KU)+PLN(KU)-P   ) )
     &            +( P-PLN(KU-1) )/H(KU)
     &              *( Z(KU)   - SM(KU)/6.
     &                        * ( PLN(KU)-P   )*( H(KU)+P-PLN(KU-1) ) )
         ENDIF
  500 CONTINUE
*
      RETURN
      END
