* PACKAGE     !" $BEyCM@~?^(B, $B%H!<%s(B                      A.Numaguti
*"                             for dcl-5.0  : 95/05/26 S.Takehiro
*"                             for bsnsq_2d : 96/03/01 S.Takehiro
******************************************************************
      PROGRAM BSNCNT
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
      COMMON     /GMWORK/ MWORK
      REAL       MWORK  ( IJKDIM )
*
      CHARACTER  HEADP ( NDC )*(NCC)
      CHARACTER  HEADZ ( NDC )*(NCC)
      CHARACTER  HEADT ( NDC )*(NCC)
      REAL       GDPSI  ( IJKDIM )
      REAL       GDZETA ( IJKDIM )
      REAL       GDT    ( IJKDIM )
*
      PARAMETER  ( NTMX=20 )
      DATA       IFILE / 50 /
      CHARACTER  HFILE( 1 )  *(NFILN)
      DATA       HFILE / 'gtool.out' /
*
*" [$B%*%W%7%g%s(B]
*
      INTEGER    PRJ                   !" $BEj1FK!(B
        DATA       PRJ / 0 /
*
      INTEGER    X, Y, Z               !" $BJ?6Q%U%i%C%0(B(0 $B$GJ?6Q(B)
        DATA       X, Y, Z / 3*-1 /    !" $B@Z$j$@$70LCV(B(0 $B$G$J$$>l9g(B)
*
      LOGICAL    EXCH                        !" $B=D2#:BI88r49%9%$%C%A(B
        DATA       EXCH  /.FALSE./
      LOGICAL    GRESET         !" $BIA2h%Q%i%a%?!<%j%;%C%H%9%$%C%A(B
        DATA       GRESET / .FALSE. /
      REAL       CONTP  ( 2 )           !" $BEyCM@~4V3V(B
        DATA       CONTP  / -999.,-999. /
      REAL       CONTT  ( 2 )           !" $BEyCM@~4V3V(B
        DATA       CONTT  / -999.,-999. /
      INTEGER    CCYCLE                !" $B%3%s%?!<%i%Y%k$r$D$1$k4V3V(B
        DATA       CCYCLE / 5 /
      REAL       RANGEP ( 2 )           !" $BEyCM@~$r0z$/HO0O(B($B:G>.(B, $B:GBg(B)
        DATA       RANGEP / -999.,-999. /
      REAL       RANGET ( 2 )           !" $BEyCM@~$r0z$/HO0O(B($B:G>.(B, $B:GBg(B)
        DATA       RANGET / -999.,-999. /
*
      INTEGER    CIDX ( 2 )
        DATA       CIDX  / 1, 3 /
      LOGICAL    CLABEL
        DATA       CLABEL / .TRUE. /
      REAL       TONEP ( NTMX+1 )
        DATA       TONEP / -999.,NTMX*-999. /
      REAL       TONET( NTMX+1 )
        DATA       TONET / -999.,NTMX*-999. /
      INTEGER    PATP  ( NTMX )
        DATA       PATP  / NTMX*-1 /
      INTEGER    PATT  ( NTMX )
        DATA       PATT  / NTMX*-1 /
      INTEGER    WSN
        DATA       WSN / 0 /
      LOGICAL    MONO, PRINT
        DATA       MONO, PRINT / 2*.FALSE. /
      INTEGER    LAY
        DATA       LAY / 1 /
      INTEGER    STR, END, STEP
        DATA       STR, END, STEP / 1, 999999, 1 /
      INTEGER    COLORP, COLORT
        DATA       COLORP, COLORT / 0, 0 /
      INTEGER    CPATP ( 2 )
        DATA       CPATP / 18999, -99999 /
      INTEGER    CPATT ( 2 )
        DATA       CPATT / 18999, -99999 /
      LOGICAL    NOCNTP, NOCNTT
        DATA       NOCNTP, NOCNTT /.FALSE., .FALSE./
      LOGICAL    SOFTF
        DATA       SOFTF /.FALSE./
      INTEGER    TLNUM
        DATA       TLNUM / 6 /
      CHARACTER  ITEM   *(NCC)            !" $B<1JLL>>N(B($BJQ?tL>(B)  
      CHARACTER  UNIT   *(NCC)            !" $BC10L(B              
      CHARACTER  TITLE  *(NCC*2)          !" $BI=Bj(B              
      CHARACTER  DSET   *(NCC)            !" $B%G!<%?%;%C%HL>(B    
      CHARACTER  EDIT   *(NCC)
      CHARACTER  ETTL   *(NCC)
        DATA       ITEM, UNIT, TITLE, DSET, EDIT, ETTL /6*' '/
      LOGICAL    HELP
        DATA       HELP   / .FALSE. /
*
      LOGICAL   OFIRST
        DATA    OFIRST /.TRUE./
*
      NAMELIST /OPTION/  PRJ, 
     &                   X, Y, Z, CCYCLE ,
     &                   CONTP, RANGEP, CIDXP, PATP, NOCNTP, 
     &                   COLORP, CPATP,
     &                   CONTT, RANGET, CIDXT, PATT, NOCNTT, 
     &                   COLORT, CPATT,
     &                   CLABEL, CCYCLE, TONE, 
     &                   LAY, WSN, MONO, PRINT,
     &                   STR, END, STEP, EXCH, TLNUM, SOFTF,
     &                   ITEM, UNIT, TITLE, DSET, EDIT, ETTL, GRESET,
     &                   HELP, HFILE
*
*" < 1. $B%3%^%s%I%i%$%s2r@O(B >
*
      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 ( HEADP , IJKDIM )
      CALL GTSIZE ( HEADZ , IJKDIM )
      CALL GTSIZE ( HEADT , IJKDIM )
      CALL GMSIZE ( IJKDIM  )
*
*"         $B%G%U%)%k%HCM$r@_Dj(B
*
      IF ( WSN .LE. 0 ) THEN
         IF ( PRINT ) THEN
            WSN = 2
         ELSE
            WSN = 1
         ENDIF
      ENDIF
*
      IF ( X.LT.0 .AND. Y.LT.0 .AND. Z.LT.0 ) Z = 0
      IF ( STEP .LE. 1 ) STEP = 1
*
*"        $B%H!<%s@_Dj(B
*
      CALL SETTON
     O     ( NTONP ,
     I       PATP  , COLORP , CPATP  )
*
      CALL SETTON
     O     ( NTONT ,
     I       PATT  , COLORT , CPATT  )
*
*"  < 2. $B%G!<%?FI$_9~$_(B, $B2C9)(B >
*
      CALL GGOPEN ( WSN )
      CALL GFROPN ( IFILE, HFILE( 1 ) )
*
      II = 0
 1100 CONTINUE
         CALL GFREAD 
*         CALL ZFREAD               !" $BG\@:EYBP1~FI$_9~$_(B
     O            ( HEADP , GDPSI , IEOD  ,
     I              IFILE , 1               )
         CALL GFREAD 
*         CALL ZFREAD
     O            ( HEADZ , GDZETA, IEOD  ,
     I              IFILE , 1               )
         CALL GFREAD 
*         CALL ZFREAD
     O            ( HEADT , GDT   , IEOD  ,
     I              IFILE , 1               )
*
         IF ( IEOD .EQ. 0 ) THEN
*
            II = II + 1
            IF ( ( II.GE.STR ).AND.( II.LE.END ).AND.
     &           ( MOD( II-STR,STEP ).EQ.0 )          ) THEN         
*
               CALL SETTTL              !" $BI=Bj$=$NB>$NJQ99(B
     M              ( HEADP , 
     I                ITEM  , UNIT , TITLE  , DSET  )
               CALL SETTTL              !" $BI=Bj$=$NB>$NJQ99(B
     M              ( HEADT , 
     I                ITEM  , UNIT , TITLE  , DSET  )
*
               CALL EXTAVR              !" $B%G!<%?<h$j=P$7(B, $BJ?6Q(B
     M              ( HEADP , GDPSI , 
     I                X , Y , Z       )
               CALL EXTAVR              !" $B%G!<%?<h$j=P$7(B, $BJ?6Q(B
     M              ( HEADT , GDT   , 
     I                X , Y , Z       )
*
               CALL SETDRW              !" $BIA2h%Q%i%a%?!<@_Dj(B
     M            ( HEADP  , GDPSI  ,
     I              EXCH   , GRESET , 
     I              CCYCLE , CONTP   , RANGEP  )
               CALL SETDRW              !" $BIA2h%Q%i%a%?!<@_Dj(B
     M            ( HEADT  , GDT    ,
     I              EXCH   , GRESET , 
     I              CCYCLE , CONTT   , RANGET  )
*
*"  < 3. $BI=<((B >
*
               IF      ( LAY .EQ. 2 ) THEN
                  CALL GGLAY2  ( HEADP )
               ELSE IF ( LAY .EQ. 3 ) THEN
                  CALL GGLAY3  ( HEADP )
               ELSE
                  CALL GGLAY1  ( HEADP )
               ENDIF
*
               CALL TONCNT
     I              ( HEADP , GDPSI , 
     I                .TRUE., 
     I                SOFTF , TLNUM , COLORP , NOCNTP,
     I                NTONP , TONE  , PATP   , 
     I                CLABEL, CIDX                )
*
               CALL TONCNT
     I              ( HEADT , GDT , 
     I                .FALSE., 
     I                SOFTF , TLNUM , COLORT , NOCNTT, 
     I                NTONT , TONE  , PATT   , 
     I                CLABEL, CIDX                )
*
            ENDIF
      GOTO 1100
         ENDIF
*
      CALL GFCLSE ( IFILE )
*
      CALL GGCLSE
*
      STOP
      END
**********************************************************************
      SUBROUTINE SETTON
     O            ( NTON ,
     I              PAT  , COLOR , CPAT  )
*
      INTEGER    NTON
      INTEGER    PAT  ( * )
      INTEGER    COLOR
      INTEGER    CPAT  ( * )
*      
      DO 80 ITN = 1, NTMX
         IF ( PAT(ITN) .LT. 0 ) THEN
            NTON = ITN-1
            GOTO 90
         ENDIF
 80   CONTINUE
      NTON = NTMX
 90   CONTINUE
*
      IF ( COLOR .GT.1 ) THEN
         CALL GGPSET ( 'NTONE',   COLOR   )
         IF ( CPAT(1) .GT. 0 ) THEN
            CALL GGPSET ( 'TONEPAT', CPAT(1) )
         ENDIF
         IF ( CPAT(2) .GT. 0 ) THEN
            CALL GGPSET ( 'TONEINC', CPAT(2) )
         ELSE IF ( CPAT(2) .LT. 0 ) THEN
            CALL GGPGET ( 'TONEPAT', IPAT1 )
            IF ( -CPAT(2) .GT. 1000 ) THEN
               IPINC = INT((-CPAT(2)-IPAT1)/COLOR/1000) * 1000
            ELSE
               IPINC = INT((-CPAT(2)-IPAT1)/COLOR)
            ENDIF
            CALL GGPSET ( 'TONEINC', IPINC )
         ENDIF
      ENDIF
*
      RETURN
      END
**********************************************************************
      SUBROUTINE TONCNT         !" $B%3%s%?!<(B, $B%H!<%sIA2h(B
     I            ( HHEAD , GDATA , 
     I              OPAGE1, 
     I              SOFTF , TLNUM , COLOR , NOCONT , 
     I              NTON  , TONE  , PAT   , 
     I              CLABEL, CIDX                )
*
      CHARACTER  HHEAD ( * )*(*)
      REAL       GDATA ( * )
      LOGICAL    OPAGE1 
*
      LOGICAL    SOFTF
      INTEGER    TLNUM
      INTEGER    COLOR
      LOGICAL    NOCONT
      INTEGER    NTON
      REAL       TONE ( * )
      INTEGER    PAT  ( * )
      LOGICAL    CLABEL
      INTEGER    CIDX ( * )
*
*" < 1. $BIA2h0LCV@_Dj(B >
*
      CALL GRFIG
      CALL GGAXRS
      CALL AXSRST
     I     ( HHEAD , OPAGE1 )
      CALL GGAXES  ( HHEAD )
*
*"  < 2. $B%H!<%s(B >
*
      IF ( SOFTF ) THEN
         CALL  SGPSET( 'LSOFTF', .TRUE. )
      ENDIF
      IF ( TLNUM .GE. 0 ) THEN
         CALL GGPSET  ( 'TLNUM', TLNUM )
      ENDIF
      IF ( COLOR .GT.1 ) THEN
         CALL GGSTON ( HHEAD, GDATA )
      ENDIF
      IF ( COLOR .GT. 1 .OR. NTON .GE. 1 ) THEN
         CALL GGTONE  
     I        ( HHEAD , GDATA ,
     I          TONE  , PAT   , NTON  )
      ENDIF
*
*"  < 3. $B%3%s%?!<(B > 
*
      CALL UDPSET  ( 'LABEL',  CLABEL )
      CALL UDPSET  ( 'INDXMJ', CIDX(2) )
      CALL UDPSET  ( 'INDXMN', CIDX(1) )
      IF ( .NOT. NOCONT .AND. (CIDX(1) .GT. 0) ) THEN
         CALL SGPSET( 'LCLIP', .TRUE. )
         CALL GGCNTR  ( HHEAD , GDATA )
         CALL SGPSET( 'LCLIP', .FALSE. )
      ENDIF
*
      RETURN
      END
**********************************************************************
      SUBROUTINE EXTAVR         !" $B%G!<%?<h$j=P$7(B, $BJ?6Q(B
     M            ( HHEAD , GDATA , 
     I              X , Y , Z       )
*
      CHARACTER  HHEAD ( * )*( * )
      REAL       GDATA ( * )
*
      INTEGER    X, Y, Z        !" $BJ?6Q%U%i%C%0(B(0 $B$GJ?6Q(B)
*                               !" $B@Z$j$@$70LCV(B(0 $B$G$J$$>l9g(B)
*
      IF      ( X .EQ. 0 ) THEN
         CALL GMXAVG            !" X $B<4J?6Q(B
     M        ( HHEAD , GDATA ,
     I          'XM'  , 'zonal mean'  )
      ELSE IF ( X .GT. 0 ) THEN
         CALL GMXSEL            !" X $B<4@Z$j$@$7(B
     M        ( HHEAD , GDATA ,
     I          X   ,
     I          '  '  , ' '           )
      ELSE IF ( Y .EQ. 0 ) THEN
         CALL GMYAVG
     M        ( HHEAD , GDATA ,
     I          'YM'  , 'merid mean'  )
      ELSE IF ( Y .GT. 0 ) THEN
         CALL GMYSEL
     M        ( HHEAD , GDATA , 
     I          Y   ,
     I          '  '  , '  '          )
      ELSE IF ( Z .EQ. 0 ) THEN
         CALL GMZAVG
     M        ( HHEAD , GDATA ,
     I          'ZM'  , 'vert mean'   )
      ELSE IF ( Z .GT. 0 ) THEN
         CALL GMZSEL
     M        ( HHEAD , GDATA , 
     I          Z  ,
     I          ' '   , ' '           )
      ENDIF
*
      RETURN
      END
**********************************************************************
      SUBROUTINE  SETTTL
     M            ( HHEAD , 
     I              ITEM  , UNIT , TITLE  , DSET  )
*
      CHARACTER  HHEAD ( * )*(*)    !" $B%X%C%@!<(B
*
      CHARACTER  ITEM   * (*)       !" $B<1JLL>>N(B($BJQ?tL>(B)
      CHARACTER  UNIT   * (*)       !" $BC10L(B
      CHARACTER  TITLE  * (*)       !" $BI=Bj(B
      CHARACTER  DSET   * (*)       !" $B%G!<%?%;%C%HL>(B
*
      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
*
      RETURN
      END
**********************************************************************
      SUBROUTINE SETDRW
     M            ( HHEAD  , GDATA  ,
     I              EXCH   , GRESET , 
     I              CCYCLE , CONT   , RANGE  )
*
      CHARACTER  HHEAD ( * )*( * )
      REAL       GDATA ( * )
*
      LOGICAL    EXCH           !" $B=D2#:BI88r49%9%$%C%A(B
      LOGICAL    GRESET         !" $BIA2h%Q%i%a%?!<%j%;%C%H%9%$%C%A(B
*                               !" TRUE:$B3F%Z!<%8Kh$KIA2h%Q%i%a%?!<$r@_Dj(B
      REAL       CONT  ( * )    !" $BEyCM@~4V3V(B
      INTEGER    CCYCLE         !" $B%3%s%?!<%i%Y%k$r$D$1$k4V3V(B
      REAL       RANGE ( * )    !" $BEyCM@~$r0z$/HO0O(B($B:G>.(B, $B:GBg(B)
*
*
      CALL GMXCYC               !" $B%5%$%/%j%C%/:BI8$KBP=h(B
     I     ( HHEAD , GDATA )
*
      IF ( EXCH ) THEN          !" $B=D2#:BI8<48r49(B
         CALL GMEYXZ
     M        ( HHEAD , GDATA ,
     I          '  ' , '  '     )
      ENDIF
*
      IF ( GRESET ) THEN
         CALL GHRSGP( HHEAD  )  !" $BIA2h%Q%i%a%?!<%j%;%C%H(B
      ENDIF
*
      CALL GGPSET( 'ICYCLE', CCYCLE )
*
      IF ( CONT(1) .GT. 0. ) THEN
         CALL GHPSET( HHEAD, 'DIVS', CONT(1) )
      ENDIF
      IF ( CONT(2) .GT. 0. ) THEN
         CALL GHPSET( HHEAD, 'DIVL', CONT(2) )
      ENDIF
*
      IF ( RANGE(1) .NE. -999. ) THEN
         CALL GHPSET( HHEAD, 'DMIN', RANGE(1) )
      ENDIF
      IF ( RANGE(2) .NE. -999. ) THEN
         CALL GHPSET( HHEAD, 'DMAX', RANGE(2) )
      ENDIF
*
      RETURN
      END
*********************************************************************
      SUBROUTINE AXSRST             !" $B%o!<%/%9%F!<%7%g%sJQ49:F@_Dj(B
     I            ( HHEAD , OPAGE1 )
*
      CHARACTER  HHEAD ( * )*(*)
      LOGICAL    OPAGE1
      REAL       VXMIN, VXMAX, VYMIN, VYMAX 
*
      REAL       XMIN, XMAX, YMIN, YMAX
      REAL       XLNGTH, YLNGTH, ASPCT
      REAL       VVXMIN, VVXMAX, VVYMIN, VVYMAX 
*
      CALL GGPGET ( 'VXMIN'  , VXMIN  )
      CALL GGPGET ( 'VXMAX'  , VXMAX  )
      CALL GGPGET ( 'VYMIN'  , VYMIN  )
      CALL GGPGET ( 'VYMAX'  , VYMAX  )
*
      VASPCT  = (VYMAX-VYMIN) / (VXMAX-VXMIN)
*
      CALL AXMNMX
     I     ( HHEAD , 1 , 
     O       XMIN , XMAX   )
*
      CALL AXMNMX
     I     ( HHEAD , 2 , 
     O       YMIN , YMAX   )
*
      XLNGTH = XMAX - XMIN
      YLNGTH = YMAX - YMIN
      ASPCT  = YLNGTH / XLNGTH
*
      IF ( ASPCT .GT. VASPCT ) THEN
         IF ( OPAGE1 )THEN
            VXMAX = ( VXMIN + VXMAX )/2 
         ELSE
            VXMIN = ( VXMIN + VXMAX )/2 
         ENDIF
         VVXMIN = ( VXMIN+VXMAX )/2 - (VYMAX-VYMIN)/ASPCT/2
         VVXMAX = ( VXMIN+VXMAX )/2 + (VYMAX-VYMIN)/ASPCT/2
         VVYMIN = VYMIN 
         VVYMAX = VYMAX 
      ELSE
         IF ( OPAGE1 )THEN
            VYMIN = ( VYMIN + VYMAX )/2 
         ELSE
            VYMAX = ( VYMIN + VYMAX )/2 
         ENDIF
         VVXMIN = VXMIN
         VVXMAX = VXMAX
         VVYMIN = ( VYMIN+VYMAX )/2 - (VXMAX-VXMIN)*ASPCT/2
         VVYMAX = ( VYMIN+VYMAX )/2 + (VXMAX-VXMIN)*ASPCT/2
      ENDIF
*     
      CALL SGSVPT ( VVXMIN, VVXMAX , VVYMIN , VVYMAX )
      CALL SGSWND ( 0.   , 1.    , 0.    , 1.  )
      CALL SGSTRN (1)
      CALL SGSTRF
*
      RETURN
      END
*********************************************************************
      SUBROUTINE AXMNMX             !" $B:BI8<4:GBg:G>.<hF@(B
     I         ( HHEAD , IAXIS , 
     O           AXMIN , AXMAX   )
*
      CHARACTER  HHEAD ( * )*(*)         !" $B%X%C%@!<(B
      INTEGER    IAXIS                   !" $BBh2?HVL\$N<4$+(B?
*
      REAL       AXMIN , AXMAX           !" $B<4IA2hHO0O(B($B:G>.:GBg(B)
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)                !" NCC, NDC
      INCLUDE    (GZIWRK)                !" NW: $B<4%o!<%/$NBg$-$5(B
#else
#include         "gzsize.F"              !" NCC, NDC
#include         "gziwrk.F"              !" NW: $B<4%o!<%/$NBg$-$5(B
#endif
      CHARACTER  HHEADZ( NDC )*(NCC)
      REAL       AXISZ ( NW )
      LOGICAL    OSUBCK
      INTEGER    IASTR , IAEND
*
*"         < 1. $B<4%U%!%$%k$NFI$_9~$_(B >
*
      CALL GTPGET ( 'SUBCHK', OSUBCK )
      CALL GTSIZE ( HHEADZ  ,  NW     )
      CALL GUQAXV
     I            ( HHEAD , IAXIS , 'LOC' ,
     O              HHEADZ, AXISZ , IEOD   )
      CALL GTPSET ( 'SUBCHK', OSUBCK )
*
*"         < 2. $BHO0O(B >
*
      CALL GHPGET ( HHEADZ , 'ASTR1', IASTR )
      CALL GHPGET ( HHEADZ , 'AEND1', IAEND )
*
      AXMIN = AXISZ( IASTR )
      AXMAX = AXISZ( IAEND )
*
      RETURN
      END
