* PACKAGE !" 等値線図, トーン A.Numaguti *" for dcl-5.0 : 95/05/26 S.Takehiro *" clipping changes : 96/06/21 S.Takehiro ****************************************************************** PROGRAM GTCONT * #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 ) * PARAMETER ( NTMX=20 ) DATA IFILE / 50 / CHARACTER HFILE( 1 ) *(NFILN) DATA HFILE / 'gtool.out' / * REAL XMIN, XMAX, YMIN, YMAX !" 地図投影の描画位置 DATA XMIN, XMAX / 0.2, 0.8 / DATA YMIN, YMAX / 0.10, 0.55 / REAL TXLOC, TYLOC, TXWDH, TYWDH !" トーンスケール位置, 幅 DATA TXLOC, TYLOC / 0.05, 0.05 / DATA TXWDH, TYWDH / 0.25, 0.025 / * REAL ALAT, ALON !" 投影中心緯度経度 * *" [オプション] * INTEGER PRJ !" 投影法 DATA PRJ / 0 / REAL POSI(2), ROTA , MAG !" 投影中心経度緯度,回転,拡大率 DATA POSI, ROTA, MAG/ 180.,0., 0., 1./ INTEGER X, Y, Z DATA X, Y, Z / 3*-1 / REAL CONT ( 2 ) DATA CONT / -999.,-999. / INTEGER CCYCLE DATA CCYCLE / 5 / REAL RANGE ( 2 ) DATA RANGE / -999.,-999. / INTEGER CIDX ( 2 ) DATA CIDX / 1, 3 / LOGICAL CLABEL DATA CLABEL / .TRUE. / REAL TONE ( NTMX+1 ) DATA TONE / -999.,NTMX*-999. / INTEGER PAT ( NTMX ) DATA PAT / NTMX*-1 / INTEGER MAP , MAPIDX DATA MAP , MAPIDX / 0, 1 / CHARACTER MFILE * (NFILN) DATA MFILE /'coast_world'/ 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 / LOGICAL EXCH DATA EXCH /.FALSE./ INTEGER COLOR DATA COLOR / 0 / INTEGER CPAT ( 2 ) DATA CPAT / 18999, -99999 / LOGICAL NOCONT DATA NOCONT /.FALSE./ LOGICAL SOFTF DATA SOFTF /.FALSE./ INTEGER TLNUM DATA TLNUM / 6 / 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/ PRJ, POSI, ROTA, MAG, & X, Y, Z, & CONT, CCYCLE, RANGE, CIDX, CLABEL, & TONE, PAT, MAP, MAPIDX, MFILE, & LAY, WSN, MONO, PRINT, & STR, END, STEP, EXCH, TLNUM, NOCONT, SOFTF, & COLOR, CPAT, & ITEM, UNIT, TITLE, DSET, EDIT, ETTL, GRESET, & HELP, HFILE * *" < 1. コマンドライン解析 > * 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 GMSIZE ( IJKDIM ) * IF ( WSN .LE. 0 ) THEN IF ( PRINT ) THEN WSN = 2 ELSE WSN = 1 ENDIF ENDIF * CALL GGOPEN ( WSN ) * *" 描画位置設定 * CALL GGPSET( 'TXSLOC', TXLOC ) CALL GGPSET( 'TYSLOC', TYLOC ) CALL GGPSET( 'TXSWDH', TXWDH ) CALL GGPSET( 'TYSWDH', TYWDH ) * CALL GFROPN ( IFILE, HFILE( 1 ) ) * DO 80 ITN = 1, NTMX IF ( PAT(ITN) .LT. 0 ) THEN NTON = ITN-1 GOTO 90 ENDIF 80 CONTINUE NTON = NTMX 90 CONTINUE * IF ( X.LT.0 .AND. Y.LT.0 .AND. Z.LT.0 ) Z = 0 IF ( STEP .LE. 1 ) STEP = 1 * 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 * ALON = POSI(1) !" 地図投影中心位置 ALAT = POSI(2) * * *" < 2. データ読み込み, 加工 > * II = 0 1100 CONTINUE CALL GFREAD O ( HHEAD , GDATA , 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 * 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 ' ' , ' ' ) ELSE IF ( Y .EQ. 0 ) THEN CALL GMYAVG I ( HHEAD , GDATA , I 'YM' , 'merid mean' ) ELSE IF ( Y .GT. 0 ) THEN CALL GMYSEL I ( HHEAD , GDATA , Y , I ' ' , ' ' ) ELSE IF ( Z .EQ. 0 ) THEN CALL GMZAVG I ( HHEAD , GDATA , I 'ZM' , 'vert mean' ) ELSE IF ( Z .GT. 0 ) THEN CALL GMZSEL I ( HHEAD , GDATA , Z , I ' ' , ' ' ) ENDIF * CALL GMXCYC I ( HHEAD , GDATA ) * IF ( EXCH ) THEN CALL GMEYXZ I ( HHEAD , GDATA , 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 * 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 * *" < 3. 表題 > * IF( (PRJ .GE. 5 .AND. PRJ .LE. 7) & .OR.(PRJ .GE. 10 .AND. PRJ .LE. 13) & .OR.(PRJ .GE. 20 .AND. PRJ .LE. 23) & .OR.(PRJ .GE. 30 .AND. PRJ .LE. 33) )THEN CALL GGPSET( 'VXMIN', XMIN ) CALL GGPSET( 'VXMAX', XMAX ) CALL GGPSET( 'VYMIN', YMIN ) CALL GGPSET( 'VYMAX', YMAX ) ENDIF * IF ( LAY .EQ. 2 ) THEN CALL GGLAY2 ( HHEAD ) ELSE IF ( LAY .EQ. 3 ) THEN CALL GGLAY3 ( HHEAD ) ELSE CALL GGLAY1 ( HHEAD ) ENDIF * *" < 4. 地図投影 > * CALL GGPSET( 'MAPPRJ', PRJ ) CALL GGPSET( 'MAPLAT', ALAT ) CALL GGPSET( 'MAPLON', ALON ) CALL GGPSET( 'MAPROT', ROTA ) CALL GGPSET( 'MAPFAC', MAG ) * CALL GGAXES ( HHEAD ) * *" < 5. トーン > * 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 ( HHEAD , GDATA , I TONE , PAT , NTON ) ENDIF * *" < 6. コンター > * CALL UDPSET ( 'LABEL', CLABEL ) CALL UDPSET ( 'INDXMJ', CIDX(2) ) CALL UDPSET ( 'INDXMN', CIDX(1) ) * CALL SGPSET( 'LCLIP', .TRUE. ) IF ( .NOT. NOCONT .AND. (CIDX(1) .GT. 0) ) THEN CALL GGCNTR ( HHEAD , GDATA ) ENDIF * *" < 7. 地図, 緯度経度線 > * IF ( MAP .GE.1 ) THEN CALL GGMAPS( MFILE ) ENDIF IF( (PRJ .GE. 10 .AND. PRJ .LE. 13) & .OR.(PRJ .GE. 20 .AND. PRJ .LE. 23) & .OR.(PRJ .GE. 30 .AND. PRJ .LE. 33) )THEN CALL UMPGRD ENDIF CALL SGPSET( 'LCLIP', .FALSE. ) * ENDIF GOTO 1100 ENDIF * CALL GFCLSE ( IFILE ) * CALL GGCLSE * STOP END