* PACKAGE XMKSST  !" 境界温度の作成
*
*"  [HIS] 92/09/11(takepiro)
* 
**************************************************************************
      PROGRAM MKSST
*
*   [PARAM] 
#if   SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 格子点数, 波数
      INCLUDE   (ZHDIM)                      !" 文字列文字数
#else
#include        "zcdim.F"                    !" 格子点数, 波数
#include        "zhdim.F"                    !" 文字列文字数
#endif
*
*"  [VAR] 
      REAL        GTTOP ( IDIM , JDIM  )     !" 上面温度
      REAL        GTBTM ( IDIM , JDIM  )     !" 下面温度
      REAL        ALON  ( IDIM )             !" 緯度
      REAL        ALAT  ( IDIM )             !" 経度
      REAL        ARAD  ( KMAX )             !" ｒレベル
      REAL        DLON  ( IDIM )             !" 緯度荷重
      REAL        DLAT  ( IDIM )             !" 経度荷重
      REAL        DRAD  ( KMAX )             !" Δｒ
*
*   [INTERNAL PARM] 
      CHARACTER  HITEMT*(NCC), HITEML*(NCC)
      DATA       HITEMT, HITEML / 'GTTOP', 'GTBTM' /
      CHARACTER  HTITLT*(NCC), HTITLL*(NCC)
      DATA       HTITLT, HTITLL 
     &              / 'top temperature', 'bot. temperature' /
      CHARACTER  HUNIT*(NCC)
      DATA       HUNIT / 'K' /
*
      INTEGER    IT
      INTEGER    IDATE(6)
      INTEGER    ISTEP
      INTEGER    ITDUR
      INTEGER    IOMODE
      INTEGER    NOEND
      DATA       IT    / 0 /
      DATA       IDATE / 1991, 1, 1, 0, 0, 0 /
      DATA       ISTEP  / 0 /
      DATA       ITDUR  / 1 /
      DATA       IOMODE / 1 /
      DATA       NOEND  / 0 /
*
      NAMELIST  /NMDATE/ IT, IDATE, ISTEP
*
      CHARACTER  DDSET *(NCC)
      DATA       DDSET / ' ' /
      CHARACTER  HDFMT *(NCC)
      DATA       HDFMT  / 'UR4' /
      REAL       TEQ                       !" 赤道下面温度
      REAL       DTH, DTV                  !" 水平, 鉛直温度差
      DATA       TEQ   , DTH  , DTV
     &         / 302.  ,  0.  , 30.  /
*
      NAMELIST  /NMSST/ TEQ , DTH , DTV 
*
*   [INTERNAL WORK] 
      INTEGER    JFILE
*
      CALL YPREP
      CALL PCONST
      CALL GTOPEN
*
      WRITE ( 6,*      ) ' DATASET NAME? '
      READ  ( 5,'(A)'  ) DDSET
      CALL GFWOPQ ( JFILE, 'BOUNDARY TEMP. OUTPUT' )
*
      WRITE ( 6,NMSST  )
      WRITE ( 6,*      ) ' ENTER NAMELST NMSST?'
      READ  ( 5,NMSST,  END=1900  )
 1900 CONTINUE
c$$$      WRITE ( 6,NMDATE )
c$$$      WRITE ( 6,*      ) ' ENTER NAMELST NMDATE?'
c$$$      READ  ( 5,NMDATE, END=1910 )
 1910 CONTINUE
*
      CALL GTCSET( 'DDSET' , DDSET    )
*
      CALL SETCOR
     O         ( ALON  , DLON  ,
     O           ALAT  , DLAT  ,
     O           ARAD  , DRAD    )
*
      CALL CALTMP
     O         ( GTTOP , GTBTM, 
     I           ALAT  , 
     I           TEQ   , DTH   , DTV   ,
     I           IDIM  , JDIM             )
*
      CALL GDWRIT
     O         ( GTTOP ,
     I           HITEMT, HTITLT, HUNIT ,
     I           IT    , IDATE , ISTEP , ITDUR ,
     I           JFILE , IOMODE, NOEND , 'ASFC', HDFMT  )
*
      CALL GDWRIT
     O         ( GTBTM ,
     I           HITEML, HTITLL, HUNIT ,
     I           IT    , IDATE , ISTEP , ITDUR ,
     I           JFILE , IOMODE, NOEND , 'ASFC', HDFMT  )
*
      CALL YFINE
*
      STOP
      END
***********************************************************************
      SUBROUTINE CALTMP        !" 境界温度計算
     O         ( GTTOP , GTBTM , 
     I           ALAT  ,
     I           TEQ   , DTH   , DTV   , 
     I           IDIM  , JDIM              )
*
*   [PARAM] 
      INTEGER    IDIM, JDIM
*
*   [OUTPUT] 
      REAL       GTTOP  ( IDIM, JDIM )
      REAL       GTBTM  ( IDIM, JDIM )
*
*   [INPUT] 
      REAL       ALAT  ( JDIM )
      REAL       TEQ
      REAL       DTH , DTV
*
*   [INTERNAL WORK]       
      REAL       PI, PHI, GTEMP, ALAT0
      DATA       ALAT0   / 0./
      INTEGER    I, J
*
*" << CRSST : SSTの計算作成 >> 
*
      PI   = ATAN( 1. ) * 4.  
*
      DO 2100 J = 1, JDIM
*
         PHI   = ABS( ALAT( J ) - ALAT0 *PI/180. )
         GTEMP = TEQ - DTH * ( 1 - COS ( PHI ) ) 
*
         DO 2110 I = 1, IDIM
            GTTOP( I,J ) = GTEMP + DTV
            GTBTM( I,J ) = GTEMP
 2110    CONTINUE
*
 2100 CONTINUE
*
      RETURN
      END