* PACKAGE GTSCAT !" 散布図 A.Numaguti *" for dcl-5.0 : 95/05/31 S.Takehiro *" miner bugfix: 96/09/06 S.Takehiro ******************************************************************* PROGRAM GTSCAT * #ifdef SYS_IBMS INCLUDE (GTSINC) INCLUDE (GZSIZE) #else #include "gtsinc.F" #include "gzsize.F" #endif PARAMETER ( NFILE=10, NIDX=24 ) COMMON /GMWORK/ MWORK REAL MWORK ( IJKDIM ) * CHARACTER HHEAD ( NDC )*(NCC) REAL GDATA ( IJKDIM ) CHARACTER HHEADX( NDC )*(NCC) REAL GDATAX( IJKDIM ) * INTEGER IFILE( NFILE ) DATA IFILE / 50,51,52,53,54,55,56,57,58,59 / PARAMETER (NFM1=NFILE-1) CHARACTER HFILE( NFILE ) *(NFILN) DATA HFILE / '$GTTMPDIR/gtool.out',NFM1*' ' / * INTEGER X, Y, Z DATA X, Y, Z / 3*-1 / INTEGER OVERLAY DATA OVERLAY / 1 / CHARACTER MTITEM *(NCC) DATA MTITEM / 'ITEM' / LOGICAL MTITL DATA MTITL / .TRUE. / REAL DIVX ( 2 ) DATA DIVX / -999.,-999. / REAL DIVY ( 2 ) DATA DIVY / -999.,-999. / REAL RANGEX( 2 ) DATA RANGEX/ -999.,-999. / REAL RANGEY( 2 ) DATA RANGEY/ -999.,-999. / PARAMETER (NIDM1=NIDX-1,NIDM4=NIDX-4,NIDM12=NIDX-12) INTEGER MIDX( NIDX ), MTYPE( NIDX ) DATA MIDX / 2,NIDM1*-1 / DATA MTYPE / 1,2,3,4,5,6,7,8,9,10,11,12,NIDM12*-1 / DATA RSIZE / 0.005 / INTEGER LAY DATA LAY / 1 / INTEGER WSN DATA WSN / 0 / LOGICAL MONO, PRINT DATA MONO, PRINT / 2*.FALSE. / CHARACTER PS *(NFILN) DATA PS / '$GTTMPDIR/sgks.ps' / LOGICAL TICK , ATTL DATA TICK , ATTL / .FALSE., .TRUE. / INTEGER STR, END, STEP DATA STR, END, STEP / 1, 999999, 1 / LOGICAL EXCH DATA EXCH /.FALSE./ INTEGER STYPEX DATA STYPEX / 0 / INTEGER STYPEY DATA STYPEY / 0 / 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. / * NAMELIST /OPTION/ X, Y, Z, DIVX, DIVY, RANGEX, RANGEY, & OVERLAY, MIDX, MTYPE, MTITEM, MTITL, RSIZE, & LAY , WSN, MONO, PRINT, PS, TICK, ATTL, & STR, END, STEP, EXCH , STYPEX, STYPEY, & ITEM, UNIT, TITLE, DSET, EDIT, ETTL, GRESET, & HELP, HFILE * CALL OPTARG ( 91, 'OPTION', 'HFILE', NOPT, NFILES ) 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 ( HHEADX, IJKDIM ) CALL GMSIZE ( IJKDIM ) * IF ( WSN .LE. 0 ) THEN IF ( PRINT ) THEN WSN = 2 IF ( PS .NE. ' ' ) THEN CALL GUNENV( PS, '.', .FALSE. ) CALL SWCSET( 'PSFILE', PS ) IP=LENC(PS) WRITE (6,*) 'ps='//PS(1:IP) ENDIF ELSE WSN = 1 ENDIF ENDIF CALL GGOPEN ( WSN ) * NFL = 1 IF( NFILES .EQ. 0 ) NFILES = 1 DO 300 IFL = 1, NFILES IF ( HFILE(IFL) .NE. ' ' ) THEN CALL GFROPN ( IFILE(IFL), HFILE(IFL) ) NFL = IFL ENDIF 300 CONTINUE * OVERLAY = MAX( OVERLAY, NFL ) STEP = MAX( STEP, 1 ) * NMIDX = 1 NMTYPE = 1 DO 500 ID = 1, NIDX IF ( MIDX(ID) .NE. -1 ) NMIDX = ID IF ( MTYPE(ID) .NE. -1 ) NMTYPE = ID 500 CONTINUE * IF ( BITLEN .GT. 0 ) THEN CALL SGPSET( 'BITLEN', BITLEN ) ENDIF CALL CUPPER( MTITEM ) CALL GGCSET( 'LTITEM', MTITEM ) CALL GGPSET( 'LLINT' , MTITL ) * II = 0 IID = 0 1100 CONTINUE IFILEX = IFILE( MOD(II,NFL)+1 ) CALL GFREAD O ( HHEAD , GDATA , IEOD , I IFILEX, 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 * 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 , Z , I ' ' , ' ' ) ENDIF 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 , Y , I ' ' , ' ' ) ENDIF IF ( X .EQ. 0 ) THEN CALL GMXAVG I ( HHEAD , GDATA , I 'XM' , 'zonal mean' ) ELSE IF ( X .GT. 0 ) THEN CALL GMXSEL I ( HHEAD , GDATA , X , I ' ' , ' ' ) ENDIF * 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 * IF ( MOD(II-1,NFL) .EQ. 0 ) THEN CALL GPFSET( HHEAD, GDATA,' ',' ', HHEADX, GDATAX ) IF ( STYPEX .NE. 0 ) THEN CALL GHPSET ( HHEADX, 'STYP', STYPEX ) ENDIF IF ( DIVX( 1 ) .GT. 0. ) THEN CALL GHPSET( HHEADX, 'DIVS', DIVX( 1 ) ) ENDIF IF ( DIVX( 2 ) .GT. 0. ) THEN CALL GHPSET( HHEADX, 'DIVL', DIVX( 2 ) ) ENDIF IF ( RANGEX(1) .NE. -999. ) THEN CALL GHPSET( HHEADX, 'DMIN', RANGEX(1) ) ENDIF IF ( RANGEX(2) .NE. -999. ) THEN CALL GHPSET( HHEADX, 'DMAX', RANGEX(2) ) ENDIF IF ( II .LT. END ) GOTO 1100 * ELSE IID = IID + 1 IF ( STYPEY .NE. 0 ) THEN CALL GHPSET ( HHEAD, 'STYP', STYPEY ) ENDIF IF ( DIVY( 1 ) .GT. 0. ) THEN CALL GHPSET( HHEAD, 'DIVS', DIVY( 1 ) ) ENDIF IF ( DIVY( 2 ) .GT. 0. ) THEN CALL GHPSET( HHEAD, 'DIVL', DIVY( 2 ) ) ENDIF IF ( RANGEY(1) .NE. -999. ) THEN CALL GHPSET( HHEAD, 'DMIN', RANGEY(1) ) ENDIF IF ( RANGEY(2) .NE. -999. ) THEN CALL GHPSET( HHEAD, 'DMAX', RANGEY(2) ) ENDIF ENDIF * IF ( MOD(IID-1,OVERLAY) .EQ. 0 ) THEN IF ( LAY .EQ. 2 ) THEN CALL GGLAY2 ( HHEADX ) ELSE IF ( LAY .EQ. 3 ) THEN CALL GGLAY3 ( HHEADX ) ELSE CALL GGLAY1 ( HHEADX ) ENDIF IF ( .NOT. TICK ) THEN CALL GGCSET( 'CXSIDET', ' ' ) CALL GGCSET( 'CYSIDET', ' ' ) ENDIF IF ( .NOT. ATTL ) THEN CALL GGCSET( 'CXSIDEL', ' ' ) CALL GGCSET( 'CYSIDEL', ' ' ) ENDIF ENDIF * MI = MOD( IID-1,OVERLAY )+1 MIDXS = MIDX ( MOD( MI-1,NMIDX )+1 ) MTYPS = MTYPE( MOD( MI-1,NMTYPE )+1 ) * IF ( MIDXS .GT. 0 ) THEN CALL SGSPMI ( MIDXS ) CALL SGSPMT ( MTYPS ) CALL SGSPMS ( RSIZE ) IF ( .NOT. EXCH ) THEN CALL GGSCAT ( HHEADX, GDATAX, & HHEAD , GDATA , 'Y' ) ELSE CALL GGSCAT ( HHEAD , GDATA , & HHEADX, GDATAX, 'X' ) ENDIF ENDIF * ENDIF IF ( II .LT. END ) GOTO 1100 ENDIF * CALL GGCLSE * STOP END