*"表題 トーンスケール  GTOOL3(GGTONS)
*
*"履歴 90/10/01 沼口  敦
*"     92/07/08 沼口  敦
*"     95/05/26 竹広真一 for dcl-5.z.7
*"     96/01/10 竹広真一 for dcl-5.0
*"     97/12/01 竹広真一 SET -> STX
*
*********************************************************************
*"         << トーンスケール >>
*********************************************************************
      SUBROUTINE GGTONS
     I         ( HHEAD )
*
      CHARACTER  HHEAD ( * )*(*)         !" ヘッダー
*
      PARAMETER ( NHC=10, NTONL=10, NTONS=100 )
      CHARACTER  HL  (NTONL)*(NHC)
      REAL       UX2 (NTONL)
      REAL       UX1 (NTONS)
      REAL       UPX ( 4 )
      REAL       UPY ( 4 )
      CHARACTER  CSGI                    !" FUNCTION
*                                                 !" 正規化変換記憶用
      INTEGER    ITR                              !" 変換番号
      REAL       VXMIN , VXMAX , VYMIN , VYMAX    !" ビューポート
      REAL       UXMIN , UXMAX , UYMIN , UYMAX    !" 
      REAL       RADI  , VXOFF , VYOFF
      REAL       ALON  , ALAT  , ROT 
      REAL       ROFFXB                           !" 軸からのラベルの距離
*
*"         < 1. 正規化変換セーブ >
*
      CALL SGQTRN ( ITR )
      CALL SGQVPT ( VXMIN , VXMAX , VYMIN , VYMAX )
*
      IF ( ( 1. LE. ITR ) .AND. ( ITR .LE. 4 ) ) THEN
         CALL SGQWND ( UXMIN , UXMAX , UYMIN , UYMAX )
      ELSEIF ( ( 5. LE. ITR ) .AND. ( ITR .LE. 6 ) ) THEN
         CALL SGQSIM ( RADI , VXOFF , VYOFF )
      ELSEIF ( ( 10. LE. ITR ) .AND. ( ITR .LE. 33 ) ) THEN
         CALL SGQMPL ( ALON , ALAT , ROT )
      ENDIF
*
      CALL UZPGET ( 'ROFFXB', ROFFXB )
*
*"         < 2. トーンスケール用正規化変換設定 >
*
      CALL UEQNTL ( NTON )                            !" トーンレベル数
*
      CALL GGPGET ( 'TXSLOC', VXLOC )                 !" トーンスケールの位置(x)
      CALL GGPGET ( 'TYSLOC', VYLOC )                 !" トーンスケールの位置(y)
      CALL GGPGET ( 'TXSWDH', VXWDH )                 !" トーンスケールの幅(x)
      CALL GGPGET ( 'TYSWDH', VYWDH )                 !" トーンスケールの幅(y)
      CALL GGPGET ( 'TLNUM' , ITONL )                 !" トーンラベルの数
      IF ( ITONL .GT. NTONL ) THEN
         CALL MSGDMP( 'W', 'GGTONS', 'TONE LABEL NUMBER IS REDUCED.' )
         ITONL = NTONL
      ENDIF
      ITONL = MAX( ITONL, 1 )
*
      CALL SGSVPT ( VXLOC , VXLOC+VXWDH ,
     &              VYLOC , VYLOC+VYWDH   )
      CALL SGSWND ( 1.    , REAL(NTON+1), 0.    , 1.  )
      CALL SGSTRN ( 1 )
      CALL SGSTRF
*
      CALL UZPSTX ( 'ROFFXB', 0 )                     !" 座標軸からのラベルの距離
*
*"         < 3. スケール描画 >
*
      UPY ( 1 ) = 0.
      UPY ( 2 ) = 1.
      UPY ( 3 ) = 1.
      UPY ( 4 ) = 0.
      DO 3100 IT = 1, NTON
         UPX ( 1 ) = REAL( IT )
         UPX ( 2 ) = REAL( IT )
         UPX ( 3 ) = REAL( IT+1 )
         UPX ( 4 ) = REAL( IT+1 )
         CALL UEQTLV ( TLEV1, TLEV2, IPAT, IT )       !" トーンレベルの属性
         CALL SGTNZU ( 4, UPX, UPY,  IPAT )           !" 箱の塗りつぶし
 3100 CONTINUE
*
*"         < 4. スケール目盛 >
*
      CALL GHPGET ( HHEAD, 'MISS', VMISS )
      CALL GGPGET ( 'SREMK'  , SREMK )                !" 注記文字高さ
      CALL UZPSTX ( 'RSIZEL1', SREMK )                !" ラベル文字高さ設定
      CALL UZPSTX ( 'INNER'  , 1     )                !" 内向きに目盛を打つ
*
      IF ( (NTON+1) .GT. NTONS ) THEN
         CALL MSGDMP ( 'W', 'GGTONS', ' TOO MANY TONE LEVEL FOR SCALE' )
      ENDIF
      DO 4100 IT = 1, MIN( NTON+1, NTONS )
         UX1 ( IT ) = REAL ( IT )
 4100 CONTINUE
*
      UX2 (1) = 1.
      CALL UEQTLV ( TLEV1, TLEV2, IPAT, 1 )
      IF ( TLEV1 .NE. VMISS ) THEN
         CALL CHVAL  ( 'D', TLEV1, HL(1) )
      ELSE
         HL(1) = '-'//CSGI(189)                            !" -∞
      ENDIF
*
      IL = 1
      ITINT = NTON/ITONL + 1
      DO 4200 IT = ITINT+1, NTON-ITINT+1, ITINT
         IL = IL + 1
         UX2 ( IL ) = REAL( IT )
         CALL UEQTLV ( TLEV1, TLEV2, IPAT, IT )
         CALL CHVAL  ( 'D', TLEV1, HL(IL) )
 4200 CONTINUE
*
      IL = IL + 1
      UX2 ( IL ) = REAL( NTON+1 )
      CALL UEQTLV ( TLEV1, TLEV2, IPAT, NTON )
      IF ( TLEV2 .NE. VMISS ) THEN
         CALL CHVAL  ( 'D', TLEV2, HL(IL) )
      ELSE
         HL(IL) = CSGI(189)                                !" ∞
      ENDIF
*
      CALL UXAXLB( 'B', UX1, NTON+1, UX2, HL, NHC, IL )    !" 座標軸を描く
*
*"         < 5. 正規化変換を戻す >
*
      CALL SGSVPT ( VXMIN , VXMAX , VYMIN , VYMAX )
*
      IF ( ( 1. LE. ITR ) .AND. ( ITR .LE. 4 ) ) THEN
         CALL SGSWND ( UXMIN , UXMAX , UYMIN , UYMAX )
      ELSEIF ( ( 5. LE. ITR ) .AND. ( ITR .LE. 6 ) ) THEN
         CALL SGSSIM ( RADI , VXOFF , VYOFF )
      ELSEIF ( ( 10. LE. ITR ) .AND. ( ITR .LE. 33 ) ) THEN
         CALL SGSMPL ( ALON , ALAT , ROT )
      ENDIF
*
      CALL SGSTRN ( ITR )
      CALL SGSTRF
*
      CALL UZPSTX ( 'ROFFXB', ROFFXB )
*
      RETURN
      END
