* PACKAGE !" 等値線図, トーン 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' / * *" [オプション] * INTEGER PRJ !" 投影法 DATA PRJ / 0 / * INTEGER X, Y, Z !" 平均フラッグ(0 で平均) DATA X, Y, Z / 3*-1 / !" 切りだし位置(0 でない場合) * LOGICAL EXCH !" 縦横座標交換スイッチ DATA EXCH /.FALSE./ LOGICAL GRESET !" 描画パラメターリセットスイッチ DATA GRESET / .FALSE. / REAL CONTP ( 2 ) !" 等値線間隔 DATA CONTP / -999.,-999. / REAL CONTT ( 2 ) !" 等値線間隔 DATA CONTT / -999.,-999. / INTEGER CCYCLE !" コンターラベルをつける間隔 DATA CCYCLE / 5 / REAL RANGEP ( 2 ) !" 等値線を引く範囲(最小, 最大) DATA RANGEP / -999.,-999. / REAL RANGET ( 2 ) !" 等値線を引く範囲(最小, 最大) 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) !" 識別名称(変数名) 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 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. コマンドライン解析 > * 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 ) * *" デフォルト値を設定 * 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 * *" トーン設定 * CALL SETTON O ( NTONP , I PATP , COLORP , CPATP ) * CALL SETTON O ( NTONT , I PATT , COLORT , CPATT ) * *" < 2. データ読み込み, 加工 > * CALL GGOPEN ( WSN ) CALL GFROPN ( IFILE, HFILE( 1 ) ) * II = 0 1100 CONTINUE CALL GFREAD * CALL ZFREAD !" 倍精度対応読み込み 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 !" 表題その他の変更 M ( HEADP , I ITEM , UNIT , TITLE , DSET ) CALL SETTTL !" 表題その他の変更 M ( HEADT , I ITEM , UNIT , TITLE , DSET ) * CALL EXTAVR !" データ取り出し, 平均 M ( HEADP , GDPSI , I X , Y , Z ) CALL EXTAVR !" データ取り出し, 平均 M ( HEADT , GDT , I X , Y , Z ) * CALL SETDRW !" 描画パラメター設定 M ( HEADP , GDPSI , I EXCH , GRESET , I CCYCLE , CONTP , RANGEP ) CALL SETDRW !" 描画パラメター設定 M ( HEADT , GDT , I EXCH , GRESET , I CCYCLE , CONTT , RANGET ) * *" < 3. 表示 > * 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 !" コンター, トーン描画 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. 描画位置設定 > * CALL GRFIG CALL GGAXRS CALL AXSRST I ( HHEAD , OPAGE1 ) CALL GGAXES ( HHEAD ) * *" < 2. トーン > * 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. コンター > * 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 !" データ取り出し, 平均 M ( HHEAD , GDATA , I X , Y , Z ) * CHARACTER HHEAD ( * )*( * ) REAL GDATA ( * ) * INTEGER X, Y, Z !" 平均フラッグ(0 で平均) * !" 切りだし位置(0 でない場合) * IF ( X .EQ. 0 ) THEN CALL GMXAVG !" X 軸平均 M ( HHEAD , GDATA , I 'XM' , 'zonal mean' ) ELSE IF ( X .GT. 0 ) THEN CALL GMXSEL !" X 軸切りだし 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 ( * )*(*) !" ヘッダー * CHARACTER ITEM * (*) !" 識別名称(変数名) CHARACTER UNIT * (*) !" 単位 CHARACTER TITLE * (*) !" 表題 CHARACTER DSET * (*) !" データセット名 * 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 !" 縦横座標交換スイッチ LOGICAL GRESET !" 描画パラメターリセットスイッチ * !" TRUE:各ページ毎に描画パラメターを設定 REAL CONT ( * ) !" 等値線間隔 INTEGER CCYCLE !" コンターラベルをつける間隔 REAL RANGE ( * ) !" 等値線を引く範囲(最小, 最大) * * CALL GMXCYC !" サイクリック座標に対処 I ( HHEAD , GDATA ) * IF ( EXCH ) THEN !" 縦横座標軸交換 CALL GMEYXZ M ( HHEAD , GDATA , I ' ' , ' ' ) 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 * RETURN END ********************************************************************* SUBROUTINE AXSRST !" ワークステーション変換再設定 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 !" 座標軸最大最小取得 I ( HHEAD , IAXIS , O AXMIN , AXMAX ) * CHARACTER HHEAD ( * )*(*) !" ヘッダー INTEGER IAXIS !" 第何番目の軸か? * REAL AXMIN , AXMAX !" 軸描画範囲(最小最大) * #ifdef SYS_IBMS INCLUDE (GZSIZE) !" NCC, NDC INCLUDE (GZIWRK) !" NW: 軸ワークの大きさ #else #include "gzsize.F" !" NCC, NDC #include "gziwrk.F" !" NW: 軸ワークの大きさ #endif CHARACTER HHEADZ( NDC )*(NCC) REAL AXISZ ( NW ) LOGICAL OSUBCK INTEGER IASTR , IAEND * *" < 1. 軸ファイルの読み込み > * CALL GTPGET ( 'SUBCHK', OSUBCK ) CALL GTSIZE ( HHEADZ , NW ) CALL GUQAXV I ( HHEAD , IAXIS , 'LOC' , O HHEADZ, AXISZ , IEOD ) CALL GTPSET ( 'SUBCHK', OSUBCK ) * *" < 2. 範囲 > * CALL GHPGET ( HHEADZ , 'ASTR1', IASTR ) CALL GHPGET ( HHEADZ , 'AEND1', IAEND ) * AXMIN = AXISZ( IASTR ) AXMAX = AXISZ( IAEND ) * RETURN END