Class | Dcl_Automatic |
In: |
dcl_auto.f90
|
Dclf90 の描画を自動で行うモジュール
Subroutine : | |||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
zg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
zp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
|
2 次元で 2 変数を等値線とカラーシェードで描画する.
subroutine Dcl_2D_cont_shade( outname, x, y, contour, shade, cont_int, shade_int, axis_title, form_type, viewx_int, viewy_int, c_num, xg, yg, zg, xp, yp, zp, mono, mono_val, mono_lev, trigleg, no_tone, no_frame, l_idx, l_typ, p_idx, p_typ, p_siz ) ! 2 次元で 2 変数を等値線とカラーシェードで描画する. use dcl implicit none character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! x 方向の格子点座標 real, intent(in) :: y(:) ! y 方向の格子点座標 real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: zg(:,:) ! グリッド線が値をもっていればその値. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラー折れ線を描くモードに移行する. real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: zp(:,:) ! マーカーが値をもっていればその値. ! これらの指定方法は線と同じ. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラーマーカーを描くモードに移行する. logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ. ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xg, yg で描くマーカーのタイプ. real, intent(in), optional :: p_siz(:) ! xg, yg で描くマーカーのサイズ. ! デフォルトは 0.01. !-- 以上, 引数 real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: undef, RMISS logical :: monoto, no_tone_flag, no_frame_flag nx=size(x) ny=size(y) !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if !-- 処理ここまで --- call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( x(1), x(nx), y(1), y(ny) ) if(present(zg))then call color_line( 's', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 's', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if call DclSetParm( 'GRAPH:LCLIP', .true. ) if(present(zg).or.present(zp))then write(*,*) "shade drawing is nothing." else if(monoto.eqv..true.)then call DclShadeContour( shade ) else call DclShadeContourEx( shade ) end if end if CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawScaledAxis call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) !!-- Contour color changing !! call DclSetContourLine( -10.0, index=999 ) !! call DclSetContourLine( -8.0, index=999 ) !! call DclSetContourLine( -6.0, index=999 ) !! call DclSetContourLine( -4.0, index=999 ) !! call DclSetContourLine( -2.0, index=999 ) !! call DclSetContourLine( 0.0, index=999 ) !! call DclSetContourLine( 2.0, index=999 ) !! call DclSetContourLine( 4.0, index=999 ) !! call DclSetContourLine( 6.0, index=999 ) !! call DclSetContourLine( 8.0, index=999 ) !! call DclSetContourLine( 10.0, index=999 ) call DclDrawContour( contour ) if(present(zg))then call color_line( 'l', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 'p', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if end if if(no_tone_flag.eqv..false.)then if(present(trigleg))then call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
map_pro : | integer, intent(in)
| ||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
zg(:,:) : | real, intent(in), optional
| ||
long(:,:) : | real, intent(in), optional
| ||
latg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
zp(:,:) : | real, intent(in), optional
| ||
lonp(:,:) : | real, intent(in), optional
| ||
latp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
mlitv : | real, intent(in), optional
| ||
mlidx : | integer, intent(in), optional
| ||
coast : | character(5), intent(in), optional
| ||
border : | character(5), intent(in), optional
| ||
blidx : | integer, intent(in), optional
| ||
bltyp : | integer, intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
m_idx(:) : | integer, intent(in), optional
| ||
m_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
| ||
mp_idx(:) : | integer, intent(in), optional
| ||
mp_typ(:) : | integer, intent(in), optional
| ||
mp_siz(:) : | real, intent(in), optional
| ||
t_posi(3) : | real, intent(in), optional
| ||
lon_wnd(:,:) : | real, intent(in), optional
| ||
lat_wnd(:,:) : | real, intent(in), optional
|
2 次元で 2 変数を等値線とカラーシェードで描画する. 引数 map_pro で地図番号を選択し, 地図投影モードに切り替える.
subroutine Dcl_2D_cont_shade_MapPro( map_pro, outname, x, y, contour, shade, cont_int, shade_int, axis_title, form_type, viewx_int, viewy_int, c_num, xg, yg, zg, long, latg, xp, yp, zp, lonp, latp, mono, mono_val, mono_lev, trigleg, mlitv, mlidx, coast, border, blidx, bltyp, no_tone, no_frame, l_idx, l_typ, m_idx, m_typ, p_idx, p_typ, p_siz, mp_idx, mp_typ, mp_siz, t_posi, lon_wnd, lat_wnd ) ! 2 次元で 2 変数を等値線とカラーシェードで描画する. ! 引数 map_pro で地図番号を選択し, 地図投影モードに切り替える. use dcl implicit none integer, intent(in) :: map_pro ! DCL の地図変換関数番号 character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! x 方向の格子点座標 [deg] real, intent(in) :: y(:) ! y 方向の格子点座標 [deg] real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: zg(:,:) ! グリッド線が値をもっていればその値. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラー折れ線を描くモードに移行する. real, intent(in), optional :: long(:,:) ! lon 座標で入れるグリッド線 real, intent(in), optional :: latg(:,:) ! lat 座標で入れるグリッド線 real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: zp(:,:) ! マーカーが値をもっていればその値. ! これらの指定方法は線と同じ. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラーマーカーを描くモードに移行する. logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: lonp(:,:) ! lon 座標で入れるマーカー real, intent(in), optional :: latp(:,:) ! lat 座標で入れるマーカー real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. real, intent(in), optional :: mlitv ! メジャーライン, 目盛の表示間隔 [degree]. デフォルトは 1 degree. integer, intent(in), optional :: mlidx ! メジャーライン, 目盛のインデックス. ! デフォルトは 1. character(5), intent(in), optional :: coast ! 海岸線選択引数 ! ['japan'] = 日本域詳細版 ! ['world'] = 全球版 ! default = 'world' character(5), intent(in), optional :: border ! 国, 州, 県境描画 ! ['japan'] = 日本県境 ! ['world'] = 世界国境 ! ['state'] = 米国州境 ! default = 描画しない. integer, intent(in), optional :: blidx ! 海岸線, 国境のインデックス. ! デフォルトは 3. integer, intent(in), optional :: bltyp ! 海岸線, 国境のタイプ. ! デフォルトは 1. logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ. ! デフォルトは 1. integer, intent(in), optional :: m_idx(:) ! long, latg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: m_typ(:) ! long, latg で描く線のタイプ. ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xg, yg で描くマーカーのタイプ. ! デフォルトは 1. real, intent(in), optional :: p_siz(:) ! xg, yg で描くマーカーの大きさ. ! デフォルトは 0.01. integer, intent(in), optional :: mp_idx(:) ! lonp, latp で描くマーカーのインデックス integer, intent(in), optional :: mp_typ(:) ! lonp, latp で描くマーカーのインデックス real, intent(in), optional :: mp_siz(:) ! lonp, latp で描くマーカーのインデックス real, intent(in), optional :: t_posi(3) ! map optiona がランベルトの場合 ! t_posi=(/lat1, lat2, lon1/) で設定. ! 単位は degree real, intent(in), optional :: lon_wnd(:,:) ! メルカトル系以外で矩形領域を設定 ! する場合の各座標系経緯度. この値が設定されるとき, ! x, y には, デカルト系での距離を与えておくこと. real, intent(in), optional :: lat_wnd(:,:) ! メルカトル系以外で矩形領域を設定 ! する場合の各座標系経緯度. この値が設定されるとき, ! x, y には, デカルト系での距離を与えておくこと. !-- 以上, 引数 real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 real, parameter :: pi=3.14159265 real, parameter :: radius=6.38e6 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: uratio real :: undef, RMIS real :: map_lat_min, map_lat_max, map_lon_min, map_lon_max real :: lat_min, lat_max, lon_min, lon_max real :: mlat2dis_min, mlat2dis_max, mlon2dis_min, mlon2dis_max, mditv, mid_p integer :: mdidx, bdidx, bdtyp real, dimension(2) :: vx_new, vy_new character(20) :: coast_sel character(20) :: border_sel logical :: monoto, no_tone_flag, no_frame_flag, bord_flag nx=size(x) ny=size(y) coast_sel='' border_sel='' bord_flag=.false. !-- 引数を rad 単位に変換 map_lon_min=x(1)*pi/180.0 map_lon_max=x(nx)*pi/180.0 map_lat_min=y(1)*pi/180.0 map_lat_max=y(ny)*pi/180.0 select case (map_pro) case (11) mlon2dis_min=map_lon_min mlon2dis_max=map_lon_max mlat2dis_min=log(tan(0.25*pi+0.5*map_lat_min)) mlat2dis_max=log(tan(0.25*pi+0.5*map_lat_max)) case (22) mlon2dis_min=x(1) mlon2dis_max=x(nx) mlat2dis_min=y(1) mlat2dis_max=y(ny) end select !-- C 座標系の計算 if(present(lon_wnd))then lon_min=lon_wnd(1,1) lon_max=lon_wnd(nx,1) lat_min=lat_wnd(1,1) lat_max=lat_wnd(1,ny) end if !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) !-- 地図独自のオプション --- !-- MapFit ルーチンを用いると, 地図の vp が強制的に変更されるので, !-- その修正を行う. !-- u 座標系でのアスペクト比をとり, 長さの長い方の vp を基準にして, !-- 短い方の vp を修正する. uratio=(mlat2dis_max-mlat2dis_min)/(mlon2dis_max-mlon2dis_min) ! u 座標系での ratio if( uratio>1.0 )then ! y 軸の方が長いので, vratio で vxmin, vxmax を中点基準に修正. ! 修正公式は以下のとおり (mid は中点座標) : ! vxmax+vxmin=2.0*mid, vxmax-vxmin=(vymax-vymin)/uratio ! これをそれぞれ解くと, vymax, vymin は基準系なので引数のものを使用し, ! vxmax=mid+0.5*(vymax-vymin)/uratio ! vxmin=mid-0.5*(vymax-vymin)/uratio mid_p=0.5*(vx_min+vx_max) vx_max=mid_p+0.5*(vy_max-vy_min)/uratio vx_min=mid_p-0.5*(vy_max-vy_min)/uratio else ! x 軸の方が長いので, vratio で vymin, vymax を中点基準に修正. ! 修正公式は以下のとおり (mid は中点座標) : ! vymax+vymin=2.0*mid, vymax-vymin=uratio*(vxmax-vxmin) ! これをそれぞれ解くと, vxmax, vxmin は基準系なので引数のものを使用し, ! vymax=mid+0.5*(uratio*(vxmax-vxmin) ! vymin=mid-0.5*(uratio*(vxmax-vxmin) mid_p=0.5*(vy_min+vy_max) vy_max=mid_p+0.5*uratio*(vx_max-vx_min) vy_min=mid_p-0.5*uratio*(vx_max-vx_min) end if if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if if(present(mlitv))then mditv=mlitv else mditv=1.0 end if if(present(mlidx))then mdidx=mlidx else mdidx=1 end if if(present(coast))then coast_sel='coast_'//coast else coast_sel='coast_world' end if if(present(border))then select case (trim(border)) case ('japan') bord_flag=.true. border_sel='pref_japan' case ('world') bord_flag=.true. border_sel='border_world' case ('state') bord_flag=.true. border_sel='state_usa' end select end if if(present(blidx))then bdidx=blidx else bdidx=3 end if if(present(bltyp))then bdtyp=bltyp else bdtyp=1 end if if(present(lon_wnd))then call udlset('LMSG',.false.) end if !-- 処理ここまで --- !-- contour を axis の前に描くので, 下に contour interval が表示されない !-- ようにするルーチン. contour interval は別途設定. call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetParm( 'MAP:LGRIDMN', .false. ) call DclSetParm( 'MAP:INDEXMJ', mdidx ) call DclSetParm( 'MAP:dgridmj', mditv ) call DclSetParm( 'MAP:INDEXBND', bdidx ) call DclSetParm( 'MAP:INDEXOUT', bdidx ) call DclSetParm( 'MAP:ITYPEOUT', bdtyp ) write(*,*) "window set", x(1), x(nx), y(1), y(ny) call DclSetWindow( x(1), x(nx), y(1), y(ny) ) if(present(zg))then call color_line( 's', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 's', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if end if write(*,*) "viewport set", vx_min, vx_max, vy_min, vy_max call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) if(present(lon_wnd))then call DclSetTransNumber( 1 ) else call DclSetTransNumber( map_pro ) call DclFitMapParm end if call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if if(map_pro==11)then call DclSetParm( 'GRAPH:LCLIP', .true. ) end if ! call DclDrawViewPortFrame( 1 ) ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if if(present(zg).or.present(zp))then write(*,*) "shade drawing is nothing." else if(monoto.eqv..true.)then call DclShadeContour( shade ) else call DclShadeContourEx( shade ) end if end if if(present(lon_wnd))then ! call DclDrawAxis( 'b', mditv, 0.5*mditv ) ! call DclDrawAxis( 'l', mditv, 0.5*mditv ) call Dcl_Special_Axis( 'bl', map_pro, mditv, (/vx_min, vx_max/), (/vy_min, vy_max/), t_posi, lon_wnd, lat_wnd, (/trim(x_title), trim(y_title)/) ) ! call DclDrawTitle( 'b', trim(x_title), 0.0 ) ! call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) if(map_pro/=11)then if(present(zg))then call color_line( 'l', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 'p', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end if end if end if call DclNewFig ! call g2qctm( lon_min, lon_max, lat_min, lat_max ) if(present(t_posi))then call SGRSET( 'STLAT1', t_posi(1) ) call SGRSET( 'STLAT2', t_posi(2) ) call UMSCNT( t_posi(3), t_posi(1), 0.0 ) end if write(*,*) "window set", lon_min, lon_max, lat_min, lat_max write(*,*) "viewport set", vx_min, vx_max, vy_min, vy_max CALL UMSPNT( 4, (/lon_wnd(1,1), lon_wnd(nx,1), lon_wnd(1,ny), lon_wnd(nx,ny)/), (/lat_wnd(1,1), lat_wnd(nx,1), lat_wnd(1,ny), lat_wnd(nx,ny)/) ) ! call DclSetWindow( lon_min, lon_max, lat_min, lat_max ) if(present(long))then do i=1,size(long,2) call DclScalingPoint( long(:,i), latg(:,i) ) end do end if if(present(lonp))then do i=1,size(lonp,2) call DclScalingPoint( lonp(:,i), latp(:,i) ) end do end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransNumber( map_pro ) call DclFitMapParm call DclSetTransFunction end if CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) if(present(lon_wnd))then ! call DclDrawAxis( 'b', mditv, 0.5*mditv ) ! call DclDrawAxis( 'l', mditv, 0.5*mditv ) write(*,*) "dummy" else call DclDrawAxis( 'bt', mditv, 0.5*mditv ) call DclDrawAxis( 'rl', mditv, 0.5*mditv ) ! call DclDrawScaledAxis call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) end if call DclDrawMap( trim(coast_sel) ) if(present(border))then if(bord_flag.eqv..true.)then call DclDrawMap( border_sel(1:len_trim(border_sel)) ) else write(*,*) "*** MESSAGE (Dcl_2D_cont_shade_MapPro) ***" write(*,*) "'border' argument is invalid." end if end if call DclDrawGlobe() if(map_pro==11)then if(present(zg))then call color_line( 'l', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 'p', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if end if else if(present(long))then do i=1,size(long,2) if(present(m_idx))then call DclSetLineIndex( m_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(m_typ))then call DclSetLineType( m_typ(i) ) end if call DclDrawLine( long(:,i), latg(:,i) ) end do end if if(present(lonp))then do i=1,size(lonp,2) if(present(mp_idx))then call DclSetMarkerIndex( mp_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(mp_typ))then call DclSetMarkerType( mp_typ(i) ) end if if(present(mp_siz))then call DclSetMarkerSize( mp_siz(i) ) end if call DclDrawMarker( lonp(:,i), latp(:,i) ) end do end if end if if(present(lon_wnd))then write(*,*) "contour interval already is written before." else call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) end if CALL SGQVPT( vx_new(1), vx_new(2), vy_new(1), vy_new(2) ) if(no_tone_flag.eqv..false.)then if(present(trigleg))then call tone_bar( color_num, (/shade_min, shade_max/), (/vx_new(2)+0.05, vx_new(2)+0.075/), vy_new, trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_new(2)+0.05, vx_new(2)+0.075/), vy_new, trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
date : | type(dcl_date), intent(in)
| ||
days : | integer, intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
zg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
zp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
|
2 次元で 2 変数を等値線とカラーシェードで描画する. calender 対応
subroutine Dcl_2D_cont_shade_calendar( outname, x, y, contour, shade, cont_int, shade_int, axis_title, date, days, form_type, viewx_int, viewy_int, c_num, xg, yg, zg, xp, yp, zp, mono, mono_val, mono_lev, trigleg, no_tone, no_frame, l_idx, l_typ, p_idx, p_typ, p_siz ) ! 2 次元で 2 変数を等値線とカラーシェードで描画する. calender 対応 use dcl implicit none character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! x 方向の格子点座標 real, intent(in) :: y(:) ! y 方向の格子点座標 real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title type(dcl_date), intent(in) :: date ! 開始日付 [yyyy:mm:dd] integer, intent(in) :: days ! 描画日数 [day] character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: zg(:,:) ! グリッド線が値をもっていればその値. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラー折れ線を描くモードに移行する. real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: zp(:,:) ! マーカーが値をもっていればその値. ! これらの指定方法は線と同じ. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラーマーカーを描くモードに移行する. logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xp, yp で描くマーカーのタイプ real, intent(in), optional :: p_siz(:) ! xp, yp で描くマーカーの大きさ !-- 以上, 引数 real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: undef, RMISS logical :: monoto, no_tone_flag, no_frame_flag nx=size(x) ny=size(y) !-- 日付が与えられているかを表示 write(*,*) "start day is", date%year, date%month, date%day !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if !-- 処理ここまで --- call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( 0.0, real(days), y(1), y(ny) ) if(present(zg))then call color_line( 's', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 's', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if if(present(zg).or.present(zp))then write(*,*) "shade drawing is nothing." else if(monoto.eqv..true.)then call DclShadeContour( shade ) else call DclShadeContourEx( shade ) end if end if CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawAxisCalendar( 'bt', date, nd=days ) call DclDrawScaledAxis( 'lr' ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) if(present(zg))then call color_line( 'l', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), xg(:,i) ) end do end if end if if(present(zp))then call color_line( 'p', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if end if if(no_tone_flag.eqv..false.)then if(present(trigleg))then call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
rg(:,:) : | real, intent(in), optional
| ||
tg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
rp(:,:) : | real, intent(in), optional
| ||
tp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
r_idx(:) : | integer, intent(in), optional
| ||
r_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
| ||
rp_idx(:) : | integer, intent(in), optional
| ||
rp_typ(:) : | integer, intent(in), optional
| ||
rp_siz(:) : | real, intent(in), optional
|
2 次元で 2 変数を等値線とカラーシェードで描画する.
subroutine Dcl_2D_cont_shade_polar( outname, x, y, contour, shade, cont_int, shade_int, axis_title, form_type, viewx_int, viewy_int, c_num, xg, yg, rg, tg, xp, yp, rp, tp, mono, mono_val, mono_lev, trigleg, no_tone, no_frame, l_idx, l_typ, r_idx, r_typ, p_idx, p_typ, p_siz, rp_idx, rp_typ, rp_siz ) ! 2 次元で 2 変数を等値線とカラーシェードで描画する. use dcl implicit none character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! 動径方向の格子点座標 real, intent(in) :: y(:) ! 同位角方向の格子点座標 [degree] real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: rg(:,:) ! 極座標系における r 軸に入れるグリッド線の座標 real, intent(in), optional :: tg(:,:) ! 極座標系における theta 軸に入れるグリッド線の座標 ! これらのデータの与え方は xg, yg と同様. real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: rp(:,:) ! r 方向にマーカーを入れる r 座標 real, intent(in), optional :: tp(:,:) ! t 方向にマーカーを入れる t 座標 logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: r_idx(:) ! rg, tg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: r_typ(:) ! rg, tg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xp, yp で描くマーカーのタイプ real, intent(in), optional :: p_siz(:) ! xp, yp で描くマーカーの大きさ integer, intent(in), optional :: rp_idx(:) ! rp, tp で描くマーカーのインデックス integer, intent(in), optional :: rp_typ(:) ! rp, tp で描くマーカーのタイプ real, intent(in), optional :: rp_siz(:) ! rp, tp で描くマーカーの大きさ !-- 以上, 引数 real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: undef, RMISS logical :: monoto, no_tone_flag, no_frame_flag nx=size(x) ny=size(y) !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if !-- 処理ここまで --- call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( x(1), x(nx), y(1), y(ny) ) if(present(rg))then do i=1,size(rg,2) call DclScalingPoint( rg(:,i), tg(:,i) ) end do end if if(present(rp))then do i=1,size(rp,2) call DclScalingPoint( rp(:,i), tp(:,i) ) end do end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call SGSSIM( 0.5*(vx_max-vx_min)/x(nx), 0.0, 0.0 ) call DclSetTransNumber(5) ! 極座標変換 call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if if(monoto.eqv..true.)then call DclShadeContour( shade ) else call DclShadeContourEx( shade ) end if call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) if(present(rg))then do i=1,size(rg,2) if(present(r_idx))then call DclSetLineIndex( r_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(r_typ))then call DclSetLineType( r_typ(i) ) end if call DclDrawLine( rg(:,i), tg(:,i) ) end do end if if(present(rp))then do i=1,size(rp,2) if(present(rp_idx))then call DclSetMarkerIndex( rp_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(rp_typ))then call DclSetMarkerType( rp_typ(i) ) end if if(present(rp_siz))then call DclSetMarkerSize( rp_siz(i) ) end if call DclDrawMarker( rp(:,i), tp(:,i) ) end do end if !-- 以上で極座標描画終了 !-- 以下, デカルト系で再変換 CALL GRFIG call DclSetWindow( -x(nx), x(nx), -x(nx), x(nx) ) if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransNumber(1) ! デカルト座標変換 call DclSetTransFunction CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawScaledAxis call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), yg(:,i) ) end do end if if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if if(no_tone_flag.eqv..false.)then if(present(trigleg))then call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
centp(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
rg(:,:) : | real, intent(in), optional
| ||
tg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
rp(:,:) : | real, intent(in), optional
| ||
tp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
r_idx(:) : | integer, intent(in), optional
| ||
r_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
| ||
rp_idx(:) : | integer, intent(in), optional
| ||
rp_typ(:) : | integer, intent(in), optional
| ||
rp_siz(:) : | real, intent(in), optional
|
2 次元で 2 変数を等値線とカラーシェードで描画する. 地図情報を入れ込み.
subroutine Dcl_2D_cont_shade_polar_Map( outname, x, y, contour, shade, cont_int, shade_int, centp, axis_title, form_type, viewx_int, viewy_int, c_num, xg, yg, rg, tg, xp, yp, rp, tp, mono, mono_val, mono_lev, trigleg, no_tone, no_frame, l_idx, l_typ, r_idx, r_typ, p_idx, p_typ, p_siz, rp_idx, rp_typ, rp_siz ) ! 2 次元で 2 変数を等値線とカラーシェードで描画する. ! 地図情報を入れ込み. use dcl implicit none character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! 動径方向の格子点座標 [m] ! 地図投影で使用 real, intent(in) :: y(:) ! 同位角方向の格子点座標 [degree] real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] real, intent(in) :: centp(2) ! 極座標系の中心が位置する緯度経度 [degree] ! centp(1) = 緯度, centp(2) = 経度 character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: rg(:,:) ! 極座標系における r 軸に入れるグリッド線の座標 real, intent(in), optional :: tg(:,:) ! 極座標系における theta 軸に入れるグリッド線の座標 ! これらのデータの与え方は xg, yg と同様. real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: rp(:,:) ! r 方向にマーカーを入れる r 座標 real, intent(in), optional :: tp(:,:) ! t 方向にマーカーを入れる t 座標 logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: r_idx(:) ! rg, tg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: r_typ(:) ! rg, tg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xp, yp で描くマーカーのタイプ real, intent(in), optional :: p_siz(:) ! xp, yp で描くマーカーの大きさ integer, intent(in), optional :: rp_idx(:) ! rp, tp で描くマーカーのインデックス integer, intent(in), optional :: rp_typ(:) ! rp, tp で描くマーカーのタイプ real, intent(in), optional :: rp_siz(:) ! rp, tp で描くマーカーの大きさ !-- 以上, 引数 real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: undef, RMISS, mditv real, parameter :: req=4.0e7 ! 地球半径 real, parameter :: pi=3.14159 ! 地球半径 real, parameter :: rcoe=pi/180.0 real, parameter :: mcoe=2.0*pi/req logical :: monoto, no_tone_flag, no_frame_flag type(map) :: mcenter, msw, mne type(cartesian) :: ccenter, csw, cne nx=size(x) ny=size(y) !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if !-- 処理ここまで --- call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( x(1), x(nx), y(1), y(ny) ) if(present(rg))then do i=1,size(rg,2) call DclScalingPoint( rg(:,i), tg(:,i) ) end do end if if(present(rp))then do i=1,size(rp,2) call DclScalingPoint( rp(:,i), tp(:,i) ) end do end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call SGSSIM( 0.5*(vx_max-vx_min)/x(nx), 0.0, 0.0 ) call DclSetTransNumber(5) ! 極座標変換 call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if if(monoto.eqv..true.)then call DclShadeContour( shade ) else call DclShadeContourEx( shade ) end if call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) if(present(rg))then do i=1,size(rg,2) if(present(r_idx))then call DclSetLineIndex( r_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(r_typ))then call DclSetLineType( r_typ(i) ) end if call DclDrawLine( rg(:,i), tg(:,i) ) end do end if if(present(rp))then do i=1,size(rp,2) if(present(rp_idx))then call DclSetMarkerIndex( rp_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(rp_typ))then call DclSetMarkerType( rp_typ(i) ) end if if(present(rp_siz))then call DclSetMarkerSize( rp_siz(i) ) end if call DclDrawMarker( rp(:,i), tp(:,i) ) end do end if !-- 以上で極座標描画終了 !-- 以下, メルカトル系で再変換 !-- ただし, メルカトル変換の定義から 緯度, 経度は rad, 距離は赤道 4 万 km を !-- 2 pi rad で変換しているので, 以下ではその変換を行う. !-- 変換係数は距離については !-- (1) 中心点の緯度経度からデカルト系座標を出す. mcenter%lat=centp(1)*rcoe mcenter%lon=centp(2)*rcoe ccenter=DclMercator_F(mcenter) !-- (2) 中心点のデカルト座標から 西に -x(nx), 南に -x(nx) の南西端と ! 東に x(nx), 北に x(nx) の北東端におけるメルカトルの緯度経度を出す. csw%x=ccenter%x-x(nx)*mcoe csw%y=ccenter%y-x(nx)*mcoe cne%x=ccenter%x+x(nx)*mcoe cne%y=ccenter%y+x(nx)*mcoe msw=DclMercator_B(csw) mne=DclMercator_B(cne) msw%lon=msw%lon/rcoe msw%lat=msw%lat/rcoe mne%lon=mne%lon/rcoe mne%lat=mne%lat/rcoe CALL GRFIG call DclSetWindow( msw%lon, mne%lon, msw%lat, mne%lat ) if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransNumber(11) ! メルカトル系変換. ここは固定. ! これ以外の地図には対応しない. 面倒くさい. call DclFitMapParm call DclSetTransFunction call DclSetParm( 'GRAPH:LCLIP', .true. ) CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) ! call DclDrawScaledAxis mditv=1.0 ! とりあえず固定. call DclDrawAxis( 'bt', mditv, 0.5*mditv ) call DclDrawAxis( 'rl', mditv, 0.5*mditv ) call DclDrawMap( 'coast_japan' ) ! call DclDrawGlobe() call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), yg(:,i) ) end do end if if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if if(no_tone_flag.eqv..false.)then if(present(trigleg))then call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
grid_point(size(x),size(y)) : | real, intent(inout)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
zg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
zp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
trn_paint : | logical, intent(in), optional
| ||
trn_col : | integer, intent(in), optional
| ||
layer_line : | logical, intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
|
2 次元で 2 変数を等値線とカラーシェードで描画する. terrain following 版
subroutine Dcl_2D_cont_shade_terrain( outname, x, y, grid_point, contour, shade, cont_int, shade_int, axis_title, form_type, viewx_int, viewy_int, c_num, xg, yg, zg, xp, yp, zp, mono, mono_val, mono_lev, trigleg, trn_paint, trn_col, layer_line, no_tone, no_frame, l_idx, l_typ, p_idx, p_typ, p_siz ) ! 2 次元で 2 変数を等値線とカラーシェードで描画する. ! terrain following 版 use dcl implicit none character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! x 方向の格子点座標 real, intent(in) :: y(:) ! y 方向の格子点座標 real, intent(inout) :: grid_point(size(x),size(y)) ! terrain following 座標 real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: zg(:,:) ! グリッド線が値をもっていればその値. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラー折れ線を描くモードに移行する. real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: zp(:,:) ! マーカーが値をもっていればその値. ! これらの指定方法は線と同じ. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラーマーカーを描くモードに移行する. logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. logical, intent(in), optional :: trn_paint ! 地形に色を塗るか. [def:.false.] integer, intent(in), optional :: trn_col ! 地形に塗る色のカラー番号 logical, intent(in), optional :: layer_line ! 各層の格子線を表示する. [def:.false.] logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xp, yp で描くマーカーのタイプ real, intent(in), optional :: p_siz(:) ! xp, yp で描くマーカーの大きさ !-- 以上, 引数 real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: undef, RMISS, interc logical :: monoto, no_tone_flag, no_frame_flag real :: cx(size(x),size(y)), cy(size(x),size(y)) real :: trn(size(x)+2), trn_x(size(x)+2) real :: cxmax, cxmin, cymax, cymin character(10) :: val_c integer :: maxcy, maxcx, trn_color nx=size(x) ny=size(y) !-- c 座標系への変換 do j=1,ny do i=1,nx cx(i,j)=x(i) cy(i,j)=grid_point(i,j) end do end do !-- c 座標系極値の計算 cxmin=x(1) cxmax=x(nx) cymin=cy(1,1) cymax=cy(1,ny) do i=2,nx if(cymin>cy(i,1))then cymin=cy(i,1) end if if(cymax<cy(i,ny))then cymax=cy(i,ny) end if end do !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if !-- 処理ここまで --- !-- contour を axis の前に描くので, 下に contour interval が表示されない !-- ようにするルーチン. contour interval は別途設定. call udlset('LMSG',.false.) call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( x(1), x(nx), y(1), y(ny) ) if(present(zg))then call color_line( 's', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 's', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransNumber(51) call g2sctr(nx, ny, x, y, cx, cy ) call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclSetParm('ENABLE_SOFTFILL',.true.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if call uelset('ltone',.true.) ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if if(present(zg).or.present(zp))then write(*,*) "shade drawing is nothing." else ! if(monoto.eqv..true.)then ! call DclShadeContour( shade ) ! else call DclShadeContour( shade ) ! end if end if call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) call g2qctm( cxmin, cxmax, cymin, cymax ) call DclSetWindow( cxmin, cxmax, cymin, cymax ) call DclSetTransNumber(1) call DclSetTransFunction CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawScaledAxis call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) !-- 地形領域に色塗り if(present(trn_paint))then if(trn_paint.eqv..true.)then if(present(trn_col))then trn_color=trn_col else trn_color=1999 end if do i=1,nx trn(i)=grid_point(i,1) trn_x(i)=x(i) ! if(bot(i)==trn(i))then ! call DclShadeRegion( ) ! end if end do trn(nx+1)=cymin trn(nx+2)=cymin trn_x(nx+1)=x(nx) trn_x(nx+2)=x(1) call DclShadeRegion( trn_x(1:nx+2), trn(1:nx+2), trn_color) end if end if ! call DclSetContourLabelFormat(form_typec) ! call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/c_num ) ! call DclDrawContour( contour ) interc=DclGetContourInterval(1) write(*,*) interc write(val_c,'(E10.3)') interc call DclDrawTitle('b','_CONTOUR INTERVAL ='//val_c//'"',0.0,1) if(present(zg))then call color_line( 'l', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), xg(:,i) ) end do end if end if if(present(zp))then call color_line( 'p', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if end if if(present(layer_line))then if(layer_line.eqv..true.)then do i=1,ny call DclDrawLine( x, grid_point(:,i) ) end do end if end if if(no_tone_flag.eqv..false.)then if(present(trigleg))then call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min, vy_max/), trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
vecx(size(x),size(y)) : | real, intent(inout)
| ||
vecy(size(x),size(y)) : | real, intent(inout)
| ||
vn(2) : | integer, intent(in)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
zg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
zp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
unitv : | logical, intent(in), optional
| ||
vfact(2) : | real, intent(in), optional
| ||
unit_fact_sign : | logical, intent(in), optional
| ||
unit_fact(2) : | real, intent(in), optional
| ||
unit_title(2) : | character(*), intent(in), optional
| ||
unit_posi(2) : | real, intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
|
2 次元で 3 変数を等値線, カラーシェード, ベクトルで描画する. 最大 4 変数同時描画が可能となる. 基本的に右にカラーバーがつくので, ユニットベクトルは コンターインターバルの下に文字で表示される.
subroutine Dcl_2D_cont_shade_vec( outname, x, y, contour, shade, vecx, vecy, vn, cont_int, shade_int, axis_title, form_type, viewx_int, viewy_int, c_num, xg, yg, zg, xp, yp, zp, mono, mono_val, mono_lev, trigleg, unitv, vfact, unit_fact_sign, unit_fact, unit_title, unit_posi, no_tone, no_frame, l_idx, l_typ, p_idx, p_typ, p_siz ) ! 2 次元で 3 変数を等値線, カラーシェード, ベクトルで描画する. ! 最大 4 変数同時描画が可能となる. ! 基本的に右にカラーバーがつくので, ユニットベクトルは ! コンターインターバルの下に文字で表示される. use dcl implicit none character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! x 方向の格子点座標 real, intent(in) :: y(:) ! y 方向の格子点座標 real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(inout) :: vecx(size(x),size(y)) ! x 方向のベクトル real, intent(inout) :: vecy(size(x),size(y)) ! x 方向のベクトル integer, intent(in) :: vn(2) ! ベクトル格子点 (間引き使用) ! vn(1)=vnx, vn(2)=vny real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: zg(:,:) ! グリッド線が値をもっていればその値. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラー折れ線を描くモードに移行する. real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: zp(:,:) ! マーカーが値をもっていればその値. ! これらの指定方法は線と同じ. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラーマーカーを描くモードに移行する. logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. logical, intent(in), optional :: unitv ! 単位ベクトルを描くかどうか. default = .true. real, intent(in), optional :: vfact(2) ! x,y 方向のスケーリングファクター ! この値を指定すると, 内部的に決められないので, ベクトルが格子以上に ! 伸びる可能性がある. ! 設定しない場合は, x, y の水平スケールと V 系のアスペクト比を考慮 ! して, vfact と一致させるようにする. logical, intent(in), optional :: unit_fact_sign ! unitv = .true. のとき, ! .true. = u, v の U 座標系での値を unit_fact に与えると, ! unit_fact はその値を単位ベクトルの単位として表示する. ! unit の V 座標系の値は u, v の大きい方を 0.1 として表示する. real, intent(in), optional :: unit_fact(2) ! x,y の単位ベクトルの v 座標系での長さ ! default = (0.1,0.1) character(*), intent(in), optional :: unit_title(2) ! x,y の単位ベクトルのタイトル ! default = 描かない. real, intent(in), optional :: unit_posi(2) ! 単位ベクトルを描き始める原点座標 (V 系) ! default = カラーバーの左端と同じで, 図の右下端から開始. ! カラーバーはこれにぶつからないように自動的に短くする. logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xp, yp で描くマーカーのタイプ real, intent(in), optional :: p_siz(:) ! xp, yp で描くマーカーの大きさ !-- 以上, 引数 integer :: vnx ! x 方向のベクトル格子点 (間引き使用) integer :: vny ! y 方向のベクトル格子点 (間引き使用) real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: factx, facty real, dimension(size(x),size(y)) :: um, vm ! ベクトル間引き後の値を代入 real :: vvx_min, vvx_max, vvy_min, vvy_max real :: unitvp(2), unitvl(2), unit_auto_fact(2) real :: undef, RMISS intrinsic :: nint logical :: monoto, unitvs, no_tone_flag, no_frame_flag nx=size(x) ny=size(y) !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え vnx=vn(1) vny=vn(2) cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) !-- エラー処理 if(nx<vnx.or.ny<vny)then write(*,*) "*****ERROR***** : vnx > nx or vny > ny." stop end if if(nx<2.or.vnx<2.or.ny<2.or.vny<2)then write(*,*) "*****ERROR***** : nx or ny or vnx or vny is less than 2." stop end if !-- 警告 if(mod((nx-1),(vnx-1))/=0.and.mod((ny-1),(vny-1))/=0)then write(*,*) "****WARNING**** : vnx or vny is not the factor of nx and ny." else if(mod((nx-1),(vnx-1))/=0.or.mod((ny-1),(vny-1))/=0)then if(mod((nx-1),(vnx-1))/=0)then write(*,*) "****WARNING**** : vnx is not the factor of nx." else write(*,*) "****WARNING**** : vny is not the factor of ny." end if end if end if !-- ベクトル場の間引き factx=real(nx-1)/real(vnx-1) facty=real(ny-1)/real(vny-1) um=0.0 vm=0.0 !-- 起点を 1 から始める um(1,1)=vecx(1,1) vm(1,1)=vecy(1,1) do i=2,vnx um(1+nint(factx*(i-1)),1)=vecx(1+nint(factx*(i-1)),1) vm(1+nint(factx*(i-1)),1)=vecy(1+nint(factx*(i-1)),1) end do do j=2,vny um(1,1+nint((j-1)*facty))=vecx(1,1+nint((j-1)*facty)) vm(1,1+nint((j-1)*facty))=vecy(1,1+nint((j-1)*facty)) end do do j=2,vny do i=2,vnx um(1+nint(factx*(i-1)),1+nint(facty*(j-1))) =vecx(1+nint(factx*(i-1)),1+nint(facty*(j-1))) vm(1+nint(factx*(i-1)),1+nint(facty*(j-1))) =vecy(1+nint(factx*(i-1)),1+nint(facty*(j-1))) end do end do if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if !-- 処理ここまで --- call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( x(1), x(nx), y(1), y(ny) ) if(present(zg))then call color_line( 's', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 's', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if end if !-- ベクトルスケールについての設定 if(present(unit_fact_sign))then if(unit_fact_sign.eqv..true.)then if(present(unit_fact))then unit_auto_fact(1)=unit_fact(1) unit_auto_fact(2)=unit_fact(2) else write(*,*) "### ERROR ### : unit_fact_sign is .true. then," write(*,*) " unit_fact must configure." write(*,*) "STOP." stop end if else unit_auto_fact(1)=1.0 unit_auto_fact(2)=1.0 end if else unit_auto_fact(1)=1.0 unit_auto_fact(2)=1.0 end if if(present(vfact))then call DclSetParm( 'VECTOR:LNRMAL', .false. ) call DclSetParm( 'VECTOR:XFACT1', vfact(1) ) call DclSetParm( 'VECTOR:YFACT1', vfact(2) ) unit_auto_fact(1)=unit_auto_fact(1)*vfact(1) unit_auto_fact(2)=unit_auto_fact(2)*vfact(2) else call DclSetParm( 'VECTOR:LNRMAL', .true.) call DclSetParm( 'VECTOR:XFACT1', unitvl(1) ) call DclSetParm( 'VECTOR:YFACT1', unitvl(2) ) unit_auto_fact(1)=unit_auto_fact(1)*unitvl(1) unit_auto_fact(2)=unit_auto_fact(2)*unitvl(2) unitvl=0.0 end if !-- ユニットベクトルについての設定 if(present(unitv))then unitvs=unitv else unitvs=.true. end if if(unitvs.eqv..true.)then call DclSetParm( 'VECTOR:LUNIT', unitvs ) !-- 単位ベクトルの長さ if(present(unit_fact))then if(present(unit_fact_sign))then if(unit_fact_sign.eqv..true.)then unitvl(:)=unit_auto_fact(:) else unitvl(:)=unit_fact(:) end if else unitvl(:)=unit_fact(:) end if else unitvl=(/0.1, 0.1/) end if !-- 単位ベクトルの書き始めの位置 if(present(unit_posi))then vvx_min=unit_posi(1) vvy_min=unit_posi(2) else vvx_min=vx_max+0.05 vvy_min=vy_min end if vvy_max=vvy_min+unitvl(2)+0.05 call DclSetParm( 'VECTOR:VXUNIT', unitvl(1) ) call DclSetParm( 'VECTOR:VYUNIT', unitvl(2) ) call DclSetParm( 'VECTOR:VXULOC', vvx_min ) call DclSetParm( 'VECTOR:VYULOC', vvy_min ) !-- タイトルを書くかどうか if(present(unit_title))then call DclSetUnitVectorTitle( 'X', trim(unit_title(1)) ) call DclSetUnitVectorTitle( 'Y', trim(unit_title(2)) ) call DclSetParm( 'VECTOR:LUMSG', .false. ) else ! タイトルを書かないなら, グラフの下部にスケーリングファクターを明記 call DclSetParm( 'VECTOR:LUMSG', .true. ) end if else call DclSetParm( 'VECTOR:LUNIT', unitvs ) vvx_min=0.0 vvx_max=0.0 vvy_min=0.0 vvy_max=vy_min end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if if(present(zg).or.present(zp))then write(*,*) "shade drawing is nothing." else if(monoto.eqv..true.)then call DclShadeContour( shade ) else call DclShadeContourEx( shade ) end if end if CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawScaledAxis call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) call DclDrawVectors( um, vm ) if(present(zg))then call color_line( 'l', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), xg(:,i) ) end do end if end if if(present(zp))then call color_line( 'p', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if end if if(no_tone_flag.eqv..false.)then if(present(trigleg))then !-- 単位ベクトルの表記を考え, vvy_max がトーンバーの下端 call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vvy_max, vy_max/), trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vvy_max, vy_max/), trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
contour(size(x),size(y)) : | real, intent(inout)
| ||
shade(size(x),size(y)) : | real, intent(inout)
| ||
vecx(size(x),size(y)) : | real, intent(inout)
| ||
vecy(size(x),size(y)) : | real, intent(inout)
| ||
vn(2) : | integer, intent(in)
| ||
cont_int(2) : | real, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
date : | type(dcl_date), intent(in)
| ||
days : | integer, intent(in)
| ||
form_type(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
c_num(2) : | integer, intent(in), optional
| ||
xg(:,:) : | real, intent(in), optional
| ||
yg(:,:) : | real, intent(in), optional
| ||
zg(:,:) : | real, intent(in), optional
| ||
xp(:,:) : | real, intent(in), optional
| ||
yp(:,:) : | real, intent(in), optional
| ||
zp(:,:) : | real, intent(in), optional
| ||
mono : | logical, intent(in), optional
| ||
mono_val(:) : | real, intent(in), optional
| ||
mono_lev(:) : | integer, intent(in), optional
| ||
trigleg : | character(1), intent(in), optional
| ||
unitv : | logical, intent(in), optional
| ||
vfact(2) : | real, intent(in), optional
| ||
unit_fact_sign : | logical, intent(in), optional
| ||
unit_fact(2) : | real, intent(in), optional
| ||
unit_title(2) : | character(*), intent(in), optional
| ||
unit_posi(2) : | real, intent(in), optional
| ||
no_tone : | logical, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(:) : | integer, intent(in), optional
| ||
l_typ(:) : | integer, intent(in), optional
| ||
p_idx(:) : | integer, intent(in), optional
| ||
p_typ(:) : | integer, intent(in), optional
| ||
p_siz(:) : | real, intent(in), optional
|
2 次元で 3 変数を等値線, カラーシェード, ベクトルで描画する. 最大 4 変数同時描画が可能となる. 基本的に右にカラーバーがつくので, ユニットベクトルは コンターインターバルの下に文字で表示される.
subroutine Dcl_2D_cont_shade_vec_calendar( outname, x, y, contour, shade, vecx, vecy, vn, cont_int, shade_int, axis_title, date, days, form_type, viewx_int, viewy_int, c_num, xg, yg, zg, xp, yp, zp, mono, mono_val, mono_lev, trigleg, unitv, vfact, unit_fact_sign, unit_fact, unit_title, unit_posi, no_tone, no_frame, l_idx, l_typ, p_idx, p_typ, p_siz ) ! 2 次元で 3 変数を等値線, カラーシェード, ベクトルで描画する. ! 最大 4 変数同時描画が可能となる. ! 基本的に右にカラーバーがつくので, ユニットベクトルは ! コンターインターバルの下に文字で表示される. use dcl implicit none character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! x 方向の格子点座標 real, intent(in) :: y(:) ! y 方向の格子点座標 real, intent(inout) :: contour(size(x),size(y)) ! 等値線に描く配列 real, intent(inout) :: shade(size(x),size(y)) ! カラーシェードに描く配列 real, intent(inout) :: vecx(size(x),size(y)) ! x 方向のベクトル real, intent(inout) :: vecy(size(x),size(y)) ! x 方向のベクトル integer, intent(in) :: vn(2) ! ベクトル格子点 (間引き使用) ! vn(1)=vnx, vn(2)=vny real, intent(in) :: cont_int(2) ! 等値線の上下端 ! [cont_int(1)=cont_min, cont_int(2)=cont_max] real, intent(in) :: shade_int(2) ! 等値線の上下端 [shade_int(1)=shade_min, ! shade_int(2)=shade_max] character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title, axis_title(2)=y_title type(dcl_date), intent(in) :: date ! 開始日付 [yyyy:mm:dd] integer, intent(in) :: days ! 描画日数 [day] character(*), intent(in) :: form_type(2) ! フォーマット ! form_type(1)=form_typec, form_type(2)=form_types real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max integer, intent(in), optional :: c_num(2) ! コンター・シェードの数 ! c_num(1)=cont_num, c_num(2)=color_num ! character(2), intent(in), optional :: nongrid ! 不等間隔格子にするか. ! nongrid = 'ox' で判断. ! 1 文字目が横軸, 2 文字目が縦軸. ! o = 不等間隔, x = 等間隔. ! デフォルトでは 'xx'. real, intent(in), optional :: xg(:,:) ! x 軸に入れるグリッド線の座標 real, intent(in), optional :: yg(:,:) ! y 軸に入れるグリッド線の座標 ! 第一要素が線の位置データで, 複数本描く場合は, ! 第二要素を 2 個以上にして描く. ! 配列に入れるデータ次第で直線ではなく, 曲線グリッドを ! 描くことも可能. ! 3 本の線を描く場合は, xg(:,1) と yg(:,1) で 1 本の ! 線を表すように指定すること. real, intent(in), optional :: zg(:,:) ! グリッド線が値をもっていればその値. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラー折れ線を描くモードに移行する. real, intent(in), optional :: xp(:,:) ! x 方向にマーカーを入れる x 座標 real, intent(in), optional :: yp(:,:) ! y 方向にマーカーを入れる y 座標 real, intent(in), optional :: zp(:,:) ! マーカーが値をもっていればその値. ! これらの指定方法は線と同じ. ! このオプションが選択された場合, 自動的に変数 shade は ! 使用されずに, shade 関連の設定変数はすべてこの値を ! リファレンスとしてカラーマーカーを描くモードに移行する. logical, intent(in), optional :: mono ! モノトーンの階調にする [.true.] ! デフォルトは .false. real, intent(in), optional :: mono_val(:) ! 階調の境界値. ! mono=.true. のときに必ず設定しないとエラーを返す. ! 値は mono_lev + 1 成分存在しなければならない. integer, intent(in), optional :: mono_lev(:) ! トーンマップ番号. dcl の 3 桁 ! mono=.true. のときに設定しないとエラーを返す. character(1), intent(in), optional :: trigleg ! トーンバーの三角形オプション. ! オプションの値は, tone_bar ルーチンの trigle と同じ. logical, intent(in), optional :: unitv ! 単位ベクトルを描くかどうか. default = .true. real, intent(in), optional :: vfact(2) ! x,y 方向のスケーリングファクター ! この値を指定すると, 内部的に決められないので, ベクトルが格子以上に ! 伸びる可能性がある. ! 設定しない場合は, x, y の水平スケールと V 系のアスペクト比を考慮 ! して, vfact と一致させるようにする. logical, intent(in), optional :: unit_fact_sign ! unitv = .true. のとき, ! .true. = u, v の U 座標系での値を unit_fact に与えると, ! unit_fact はその値を単位ベクトルの単位として表示する. ! unit の V 座標系の値は u, v の大きい方を 0.1 として表示する. real, intent(in), optional :: unit_fact(2) ! x,y の単位ベクトルの v 座標系での長さ ! default = (0.1,0.1) character(*), intent(in), optional :: unit_title(2) ! x,y の単位ベクトルのタイトル ! default = 描かない. real, intent(in), optional :: unit_posi(2) ! 単位ベクトルを描き始める原点座標 (V 系) ! default = カラーバーの左端と同じで, 図の右下端から開始. ! カラーバーはこれにぶつからないように自動的に短くする. logical, intent(in), optional :: no_tone ! トーンバーを作成しないオプション ! .false. = 作成する. .true. = 作成しない. ! デフォルトは .false. logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(:) ! xg, yg で描く線のインデックス ! デフォルトは 1. integer, intent(in), optional :: l_typ(:) ! xg, yg で描く線のタイプ ! デフォルトは 1. integer, intent(in), optional :: p_idx(:) ! xp, yp で描くマーカーのインデックス integer, intent(in), optional :: p_typ(:) ! xp, yp で描くマーカーのタイプ real, intent(in), optional :: p_siz(:) ! xp, yp で描くマーカーの大きさ !-- 以上, 引数 integer :: vnx ! x 方向のベクトル格子点 (間引き使用) integer :: vny ! y 方向のベクトル格子点 (間引き使用) real :: cont_min ! 等値線を描く最小値 real :: cont_max ! 等値線を描く最大値 real :: shade_min ! シェードを描く最小値 real :: shade_max ! シェードを描く最大値 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル character(10) :: form_typec ! contour 用のフォーマット character(10) :: form_types ! shade 用のフォーマット real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 integer :: cont_num ! 等値線の数 integer :: color_num ! カラーの数 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny real :: factx, facty real, dimension(size(x),size(y)) :: um, vm ! ベクトル間引き後の値を代入 real :: vvx_min, vvx_max, vvy_min, vvy_max real :: unitvp(2), unitvl(2), unit_auto_fact(2) real :: undef, RMISS intrinsic :: nint logical :: monoto, unitvs, no_tone_flag, no_frame_flag nx=size(x) ny=size(y) !-- 日付が与えられているかを表示 write(*,*) "start day is", date%year, date%month, date%day !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(c_num))then cont_num=c_num(1) color_num=c_num(2) else cont_num=10 color_num=56 end if if(present(no_tone))then no_tone_flag=no_tone else no_tone_flag=.false. end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え vnx=vn(1) vny=vn(2) cont_min=cont_int(1) cont_max=cont_int(2) shade_min=shade_int(1) shade_max=shade_int(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) form_typec=trim(form_type(1)) form_types=trim(form_type(2)) !-- エラー処理 if(nx<vnx.or.ny<vny)then write(*,*) "*****ERROR***** : vnx > nx or vny > ny." stop end if if(nx<2.or.vnx<2.or.ny<2.or.vny<2)then write(*,*) "*****ERROR***** : nx or ny or vnx or vny is less than 2." stop end if !-- 警告 if(mod((nx-1),(vnx-1))/=0.and.mod((ny-1),(vny-1))/=0)then write(*,*) "****WARNING**** : vnx or vny is not the factor of nx and ny." else if(mod((nx-1),(vnx-1))/=0.or.mod((ny-1),(vny-1))/=0)then if(mod((nx-1),(vnx-1))/=0)then write(*,*) "****WARNING**** : vnx is not the factor of nx." else write(*,*) "****WARNING**** : vny is not the factor of ny." end if end if end if !-- ベクトル場の間引き factx=real(nx-1)/real(vnx-1) facty=real(ny-1)/real(vny-1) um=0.0 vm=0.0 !-- 起点を 1 から始める um(1,1)=vecx(1,1) vm(1,1)=vecy(1,1) do i=2,vnx um(1+nint(factx*(i-1)),1)=vecx(1+nint(factx*(i-1)),1) vm(1+nint(factx*(i-1)),1)=vecy(1+nint(factx*(i-1)),1) end do do j=2,vny um(1,1+nint((j-1)*facty))=vecx(1,1+nint((j-1)*facty)) vm(1,1+nint((j-1)*facty))=vecy(1,1+nint((j-1)*facty)) end do do j=2,vny do i=2,vnx um(1+nint(factx*(i-1)),1+nint(facty*(j-1))) =vecx(1+nint(factx*(i-1)),1+nint(facty*(j-1))) vm(1+nint(factx*(i-1)),1+nint(facty*(j-1))) =vecy(1+nint(factx*(i-1)),1+nint(facty*(j-1))) end do end do if(present(mono))then if(present(mono_val).and.present(mono_lev))then if(size(mono_val)-1==size(mono_lev))then monoto=mono else write(*,*) "*** ERROR ***" write(*,*) "[array number] : mono_val = mono_lev + 1" write(*,*) "STOP" stop end if else write(*,*) "*** ERROR ***" write(*,*) "When option MONO is true, MONO_VAL and MONO_LEV must be specified." write(*,*) "STOP" stop end if else monoto=.false. end if !-- 処理ここまで --- call undef_CReSS2Dcl( nx, ny, 1, contour) call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( 0.0, real(days), y(1), y(ny) ) if(present(zg))then call color_line( 's', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) call DclScalingPoint( xg(:,i), yg(:,i) ) end do end if end if if(present(zp))then call color_line( 's', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) call DclScalingPoint( xp(:,i), yp(:,i) ) end do end if end if !-- ベクトルスケールについての設定 if(present(unit_fact_sign))then if(unit_fact_sign.eqv..true.)then if(present(unit_fact))then unit_auto_fact(1)=unit_fact(1) unit_auto_fact(2)=unit_fact(2) else write(*,*) "### ERROR ### : unit_fact_sign is .true. then," write(*,*) " unit_fact must configure." write(*,*) "STOP." stop end if else unit_auto_fact(1)=1.0 unit_auto_fact(2)=1.0 end if else unit_auto_fact(1)=1.0 unit_auto_fact(2)=1.0 end if if(present(vfact))then call DclSetParm( 'VECTOR:LNRMAL', .false. ) call DclSetParm( 'VECTOR:XFACT1', vfact(1) ) call DclSetParm( 'VECTOR:YFACT1', vfact(2) ) unit_auto_fact(1)=unit_auto_fact(1)*vfact(1) unit_auto_fact(2)=unit_auto_fact(2)*vfact(2) else call DclSetParm( 'VECTOR:LNRMAL', .true.) call DclSetParm( 'VECTOR:XFACT1', unitvl(1) ) call DclSetParm( 'VECTOR:YFACT1', unitvl(2) ) unit_auto_fact(1)=unit_auto_fact(1)*unitvl(1) unit_auto_fact(2)=unit_auto_fact(2)*unitvl(2) unitvl=0.0 end if !-- ユニットベクトルについての設定 if(present(unitv))then unitvs=unitv else unitvs=.true. end if if(unitvs.eqv..true.)then call DclSetParm( 'VECTOR:LUNIT', unitvs ) !-- 単位ベクトルの長さ if(present(unit_fact))then if(present(unit_fact_sign))then if(unit_fact_sign.eqv..true.)then unitvl(:)=unit_auto_fact(:) else unitvl(:)=unit_fact(:) end if else unitvl(:)=unit_fact(:) end if else unitvl=(/0.1, 0.1/) end if !-- 単位ベクトルの書き始めの位置 if(present(unit_posi))then vvx_min=unit_posi(1) vvy_min=unit_posi(2) else vvx_min=vx_max+0.05 vvy_min=vy_min end if vvy_max=vvy_min+unitvl(2)+0.05 call DclSetParm( 'VECTOR:VXUNIT', unitvl(1) ) ! call DclSetParm( 'VECTOR:VYUNIT', unitvl(2) ) call DclSetParm( 'VECTOR:VYUNIT', 0.0 ) ! y 方向には書かない call DclSetParm( 'VECTOR:VXULOC', vvx_min ) call DclSetParm( 'VECTOR:VYULOC', vvy_min ) !-- タイトルを書くかどうか if(present(unit_title))then call DclSetUnitVectorTitle( 'X', trim(unit_title(1)) ) ! call DclSetUnitVectorTitle( 'Y', trim(unit_title(2)) ) call DclSetParm( 'VECTOR:LUMSG', .false. ) else ! タイトルを書かないなら, グラフの下部にスケーリングファクターを明記 call DclSetParm( 'VECTOR:LUMSG', .true. ) end if else call DclSetParm( 'VECTOR:LUNIT', unitvs ) vvx_min=0.0 vvx_max=0.0 vvy_min=0.0 vvy_max=vy_min end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransFunction if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) call DclClearShadeLevel call DclSetShadeLevel( mono_val, mono_lev ) else call DclSetParm('ENABLE_SOFTFILL',.false.) ! call DclClearShadeLevel ! call DclSetShadeLevel( shade_min, shade_max, & ! & (shade_max-shade_min)/s_num ) end if ! if(present(nongrid))then ! if(nongrid(1:1)=='o')then call DclSetXGrid( x ) ! end if ! if(nongrid(2:2)=='o')then call DclSetYgrid( y ) ! end if ! end if if(present(zg).or.present(zp))then write(*,*) "shade drawing is nothing." else if(monoto.eqv..true.)then call DclShadeContour( shade ) else call DclShadeContourEx( shade ) end if end if CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawAxisCalendar( 'bt', date, nd=days ) call DclDrawScaledAxis( 'lr' ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) call DclSetContourLabelFormat(trim(form_typec)) call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/cont_num ) call DclDrawContour( contour ) call DclDrawVectors( um, vm ) if(present(zg))then call color_line( 'l', xg, yg, zg, color_num, (/shade_min, shade_max/) ) else if(present(xg))then do i=1,size(xg,2) if(present(l_idx))then call DclSetLineIndex( l_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(l_typ))then call DclSetLineType( l_typ(i) ) end if call DclDrawLine( xg(:,i), xg(:,i) ) end do end if end if if(present(zp))then call color_line( 'p', xp, yp, zp, color_num, (/shade_min, shade_max/) ) else if(present(xp))then do i=1,size(xp,2) if(present(p_idx))then call DclSetMarkerIndex( p_idx(i) ) ! この設定, 後まで引きずるかも end if if(present(p_typ))then call DclSetMarkerType( p_typ(i) ) end if if(present(p_siz))then call DclSetMarkerSize( p_siz(i) ) end if call DclDrawMarker( xp(:,i), yp(:,i) ) end do end if end if if(no_tone_flag.eqv..false.)then if(present(trigleg))then call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min+0.05, vy_max/), trim(form_types), mono_log=monoto, trigle=trigleg ) else call tone_bar( color_num, (/shade_min, shade_max/), (/vx_max+0.05, vx_max+0.075/), (/vy_min+0.05, vy_max/), trim(form_types), mono_log=monoto ) end if end if end subroutine
Subroutine : | |||
judge : | character(1), intent(in)
| ||
outname : | character(*), intent(in)
| ||
xline(:,:) : | real, intent(in)
| ||
yline(size(xline,1),size(xline,2)) : | real, intent(in)
| ||
xpoint(:,:) : | real, intent(in)
| ||
ypoint(size(xpoint,1),size(xpoint,2)) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
x_int(2) : | real, intent(in), optional
| ||
y_int(2) : | real, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
xylog(2) : | logical, intent(in), optional
| ||
l_idx(size(xline,2)) : | integer, intent(in), optional
| ||
l_typ(size(xline,2)) : | integer, intent(in), optional
| ||
p_idx(size(xpoint,2)) : | integer, intent(in), optional
| ||
p_typ(size(xpoint,2)) : | integer, intent(in), optional
| ||
p_siz(size(xpoint,2)) : | real, intent(in), optional
| ||
zline(size(xline,1),size(xline,2)) : | real, intent(in), optional
| ||
zpoint(size(xpoint,1),size(xpoint,2)) : | real, intent(in), optional
| ||
cl_val(:) : | real, intent(in), optional
| ||
cl_idx(:) : | integer, intent(in), optional
| ||
cp_val(:) : | real, intent(in), optional
| ||
cp_idx(:) : | integer, intent(in), optional
|
2 次元平面内において複数の曲線, ポイントで描画する. 与える曲線とポイントはそれぞれ別個の配列で定義されており, 曲線については, x, y 座標の 2 種類, ポイントについても同様の 2 種類, さらに曲線の x, y 座標用配列は第一要素で 1 本の曲線の連続を 第二要素で曲線の本数を設定. ポイントについても同様. つまり, 例として以下のように配列を用意する. 3 本の曲線, 5 種類のポイントを描きたく, 曲線については 1 本の曲線を 描くためには 1000 個の点の連続で描かれ, ポイントについては 1 種類の ポイントを 100 個描きたいとすると, xline(1000, 3), yline(1000, 3), xpoint(100, 5), y(100, 5) として引数に読み込ませればよい. このとき, 上の引数に対応する関係は以下のとおりである. lnum = 3, pnum = 5, lstep = 1000, pstep = 100
subroutine Dcl_PL( judge, outname, xline, yline, xpoint, ypoint, axis_title, viewx_int, viewy_int, x_int, y_int, no_frame, xylog, l_idx, l_typ, p_idx, p_typ, p_siz, zline, zpoint, cl_val, cl_idx, cp_val, cp_idx ) ! 2 次元平面内において複数の曲線, ポイントで描画する. ! 与える曲線とポイントはそれぞれ別個の配列で定義されており, ! 曲線については, x, y 座標の 2 種類, ポイントについても同様の 2 種類, ! さらに曲線の x, y 座標用配列は第一要素で 1 本の曲線の連続を ! 第二要素で曲線の本数を設定. ポイントについても同様. ! つまり, 例として以下のように配列を用意する. ! 3 本の曲線, 5 種類のポイントを描きたく, 曲線については 1 本の曲線を ! 描くためには 1000 個の点の連続で描かれ, ポイントについては 1 種類の ! ポイントを 100 個描きたいとすると, ! xline(1000, 3), yline(1000, 3), xpoint(100, 5), y(100, 5) ! として引数に読み込ませればよい. ! このとき, 上の引数に対応する関係は以下のとおりである. ! lnum = 3, pnum = 5, lstep = 1000, pstep = 100 use dcl implicit none character(1), intent(in) :: judge ! グラフの種類 ! 'p' = ポイントのみ描画, 'l' = ラインのみ, 'a' = 両方描画. ! 片方しか描画しない場合でも, ダミー配列を読み込ませる必要あり. character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: xline(:,:) ! 曲線群の x 座標 real, intent(in) :: yline(size(xline,1),size(xline,2)) ! 曲線群の y 座標 real, intent(in) :: xpoint(:,:) ! ポイント群の x 座標 real, intent(in) :: ypoint(size(xpoint,1),size(xpoint,2)) ! ポイント群の y 座標 character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title,axis_title(2)=y_title real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max real, intent(in), optional :: x_int(2) ! x 方向のグラフ両端 ! x_int(1)=xmin, x_int(2)=xmax real, intent(in), optional :: y_int(2) ! y 方向のグラフ両端 ! y_int(1)=ymin, y_int(2)=ymax logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. logical, intent(in), optional :: xylog(2) ! 対数スケールで軸を書くフラグ. ! .true. で描く, default はどちらも .false. integer, intent(in), optional :: l_idx(size(xline,2)) ! 各線の種類を明示的に与える. integer, intent(in), optional :: l_typ(size(xline,2)) ! 各線の種類を明示的に与える. integer, intent(in), optional :: p_idx(size(xpoint,2)) ! 各点の種類を明示的に与える. integer, intent(in), optional :: p_typ(size(xpoint,2)) ! 各点の種類を明示的に与える. real, intent(in), optional :: p_siz(size(xpoint,2)) ! 各点の種類を明示的に与える. real, intent(in), optional :: zline(size(xline,1),size(xline,2)) ! カラーラインモードの xline, yline に伴う値. real, intent(in), optional :: zpoint(size(xpoint,1),size(xpoint,2)) ! カラーラインモードの xpoint, ypoint に伴う値. real, intent(in), optional :: cl_val(:) ! カラーの値 (ライン) integer, intent(in), optional :: cl_idx(:) ! カラー番号 (ライン) real, intent(in), optional :: cp_val(:) ! カラーの値 (マーカー) integer, intent(in), optional :: cp_idx(:) ! カラー番号 (マーカー) !-- 以上, 引数 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer, parameter :: lim=890 ! ラインインデックスの最大値 integer :: nnum, lstep, pstep, lnum, pnum integer :: trans_num logical :: no_frame_flag logical :: xlogf, ylogf lstep=size(xline,1) pstep=size(xpoint,1) lnum=size(xline,2) pnum=size(xpoint,2) !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if if(present(xylog))then xlogf=xylog(1) ylogf=xylog(2) else xlogf=.false. ylogf=.false. end if !-- 引数の置き換え用変数に置き換え x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) !-- 処理ここまで --- call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if if(present(x_int).and.present(y_int))then call DclSetWindow( x_int(1), x_int(2), y_int(1), y_int(2) ) else if(judge=='p'.or.judge=='a')then if(present(zpoint))then call color_line( 's', xpoint, ypoint, zpoint, 0, (/0.0, 0.0/), col_val=cp_val, col_idx=cp_idx ) else do j=1,pnum call DclScalingPoint( xpoint(:,j), ypoint(:,j) ) end do end if end if if(judge=='l'.or.judge=='a')then if(present(zline))then call color_line( 's', xline, yline, zline, 0, (/0.0, 0.0/), col_val=cl_val, col_idx=cl_idx ) else do j=1,lnum call DclScalingPoint( xline(:,j), yline(:,j) ) end do end if end if call DclFitScalingParm end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) if(xlogf.eqv..true.)then if(ylogf.eqv..true.)then trans_num=4 else trans_num=3 end if else if(ylogf.eqv..true.)then trans_num=2 else trans_num=1 end if end if call DclSetTransNumber(trans_num) call DclSetTransFunction ! call DclShadeContourEx( shade ) CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawScaledAxis call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) !-- ポイントと曲線の設定 --- !-- num 数に応じて do ループで回すので, num 数は任意で OK. !-- num = 1 の場合は黒色で固定 if(present(zpoint))then call color_line( 'p', xpoint, ypoint, zpoint, 0, (/0.0, 0.0/), col_val=cp_val, col_idx=cp_idx ) else if(judge=='p'.or.judge=='a')then if(present(p_idx))then do j=1,pnum call DclDrawMarker( xpoint(:,j), ypoint(:,j), type=p_idx(j) ) end do else if(pnum==1)then call DclDrawMarker( xpoint(:,1), ypoint(:,1) ) else do j=1,pnum call DclDrawMarker( xpoint(:,j), ypoint(:,j), type=j ) end do end if end if end if end if if(present(zline))then call color_line( 'l', xline, yline, zline, 0, (/0.0, 0.0/), col_val=cl_val, col_idx=cl_idx ) else if(judge=='l'.or.judge=='a')then do j=1,lnum if(present(l_idx))then call DclSetLineIndex( l_idx(j) ) else if(lnum/=1)then nnum=lim/lnum call DclSetLineIndex( 100+nnum*(j-1)+1 ) end if end if if(present(l_typ))then call DclSetLineType( l_typ(j) ) end if call DclDrawLine( xline(:,j), yline(:,j) ) end do end if end if ! call DclSetContourLabelFormat(form_typec) ! call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/10 ) ! call DclDrawContour( contour ) ! call DclDrawVectors( um, vm ) end subroutine
Subroutine : | |||
judge : | character(1), intent(in)
| ||
outname : | character(*), intent(in)
| ||
xline(:,:) : | real, intent(in)
| ||
yline(size(xline,1),size(xline,2)) : | real, intent(in)
| ||
xpoint(:,:) : | real, intent(in)
| ||
ypoint(size(xpoint,1),size(xpoint,2)) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
date : | type(dcl_date), intent(in)
| ||
days : | integer, intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
x_int(2) : | real, intent(in), optional
| ||
y_int(2) : | real, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
l_idx(size(xline,2)) : | integer, intent(in), optional
| ||
l_typ(size(xline,2)) : | integer, intent(in), optional
| ||
p_idx(size(xpoint,2)) : | integer, intent(in), optional
| ||
p_typ(size(xpoint,2)) : | integer, intent(in), optional
| ||
p_siz(size(xpoint,2)) : | real, intent(in), optional
| ||
zline(size(xline,1),size(xline,2)) : | real, intent(in), optional
| ||
zpoint(size(xpoint,1),size(xpoint,2)) : | real, intent(in), optional
| ||
cl_val(:) : | real, intent(in), optional
| ||
cl_idx(:) : | integer, intent(in), optional
| ||
cp_val(:) : | real, intent(in), optional
| ||
cp_idx(:) : | integer, intent(in), optional
|
2 次元平面内において複数の曲線, ポイントで描画する. 与える曲線とポイントはそれぞれ別個の配列で定義されており, 曲線については, x, y 座標の 2 種類, ポイントについても同様の 2 種類, さらに曲線の x, y 座標用配列は第一要素で 1 本の曲線の連続を 第二要素で曲線の本数を設定. ポイントについても同様. つまり, 例として以下のように配列を用意する. 3 本の曲線, 5 種類のポイントを描きたく, 曲線については 1 本の曲線を 描くためには 1000 個の点の連続で描かれ, ポイントについては 1 種類の ポイントを 100 個描きたいとすると, xline(1000, 3), yline(1000, 3), xpoint(100, 5), y(100, 5) として引数に読み込ませればよい. このとき, 上の引数に対応する関係は以下のとおりである. lnum = 3, pnum = 5, lstep = 1000, pstep = 100
subroutine Dcl_PL_calendar( judge, outname, xline, yline, xpoint, ypoint, axis_title, date, days, viewx_int, viewy_int, x_int, y_int, no_frame, l_idx, l_typ, p_idx, p_typ, p_siz, zline, zpoint, cl_val, cl_idx, cp_val, cp_idx ) ! 2 次元平面内において複数の曲線, ポイントで描画する. ! 与える曲線とポイントはそれぞれ別個の配列で定義されており, ! 曲線については, x, y 座標の 2 種類, ポイントについても同様の 2 種類, ! さらに曲線の x, y 座標用配列は第一要素で 1 本の曲線の連続を ! 第二要素で曲線の本数を設定. ポイントについても同様. ! つまり, 例として以下のように配列を用意する. ! 3 本の曲線, 5 種類のポイントを描きたく, 曲線については 1 本の曲線を ! 描くためには 1000 個の点の連続で描かれ, ポイントについては 1 種類の ! ポイントを 100 個描きたいとすると, ! xline(1000, 3), yline(1000, 3), xpoint(100, 5), y(100, 5) ! として引数に読み込ませればよい. ! このとき, 上の引数に対応する関係は以下のとおりである. ! lnum = 3, pnum = 5, lstep = 1000, pstep = 100 use dcl implicit none character(1), intent(in) :: judge ! グラフの種類 ! 'p' = ポイントのみ描画, 'l' = ラインのみ, 'a' = 両方描画. ! 片方しか描画しない場合でも, ダミー配列を読み込ませる必要あり. character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: xline(:,:) ! 曲線群の x 座標 real, intent(in) :: yline(size(xline,1),size(xline,2)) ! 曲線群の y 座標 real, intent(in) :: xpoint(:,:) ! ポイント群の x 座標 real, intent(in) :: ypoint(size(xpoint,1),size(xpoint,2)) ! ポイント群の y 座標 character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title,axis_title(2)=y_title type(dcl_date), intent(in) :: date ! 開始日付 [yyyy:mm:dd] integer, intent(in) :: days ! 描画日数 [day] real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max real, intent(in), optional :: x_int(2) ! x 方向のグラフ両端 ! x_int(1)=xmin, x_int(2)=xmax real, intent(in), optional :: y_int(2) ! y 方向のグラフ両端 ! y_int(1)=ymin, y_int(2)=ymax logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. integer, intent(in), optional :: l_idx(size(xline,2)) ! 各線の種類を明示的に与える. integer, intent(in), optional :: l_typ(size(xline,2)) ! 各線の種類を明示的に与える. integer, intent(in), optional :: p_idx(size(xpoint,2)) ! 各点の種類を明示的に与える. integer, intent(in), optional :: p_typ(size(xpoint,2)) ! 各点の種類を明示的に与える. real, intent(in), optional :: p_siz(size(xpoint,2)) ! 各点の種類を明示的に与える. real, intent(in), optional :: zline(size(xline,1),size(xline,2)) ! カラーラインモードの xline, yline に伴う値. real, intent(in), optional :: zpoint(size(xpoint,1),size(xpoint,2)) ! カラーラインモードの xpoint, ypoint に伴う値. real, intent(in), optional :: cl_val(:) ! カラーの値 (ライン) integer, intent(in), optional :: cl_idx(:) ! カラー番号 (ライン) real, intent(in), optional :: cp_val(:) ! カラーの値 (マーカー) integer, intent(in), optional :: cp_idx(:) ! カラー番号 (マーカー) !-- 以上, 引数 character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer, parameter :: lim=890 ! ラインインデックスの最大値 integer :: nnum integer :: lstep, pstep, lnum, pnum logical :: no_frame_flag lstep=size(xline,1) pstep=size(xpoint,1) lnum=size(xline,2) pnum=size(xpoint,2) !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if !-- 引数の置き換え用変数に置き換え x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) !-- 処理ここまで --- call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if if(present(x_int).and.present(y_int))then call DclSetWindow( x_int(1), x_int(2), y_int(1), y_int(2) ) else if(judge=='p'.or.judge=='a')then if(present(zpoint))then call color_line( 's', xpoint, ypoint, zpoint, 0, (/0.0, 0.0/), col_val=cp_val, col_idx=cp_idx ) else do i=1,pnum call DclScalingPoint( xpoint(:,j), ypoint(:,j) ) end do end if end if if(judge=='l'.or.judge=='a')then if(present(zline))then call color_line( 's', xline, yline, zline, 0, (/0.0, 0.0/), col_val=cl_val, col_idx=cl_idx ) else do j=1,lnum call DclScalingPoint( xline(:,j), yline(:,j) ) end do end if end if call DclFitScalingParm end if call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) call DclSetTransFunction ! call DclShadeContourEx( shade ) CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawAxisCalendar( 'bt', date, nd=days ) call DclDrawScaledAxis( 'lr' ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) !-- ポイントと曲線の設定 --- !-- num 数に応じて do ループで回すので, num 数は任意で OK. !-- num = 1 の場合は黒色で固定 if(present(zpoint))then call color_line( 'p', xpoint, ypoint, zpoint, 0, (/0.0, 0.0/), col_val=cp_val, col_idx=cp_idx ) else if(judge=='p'.or.judge=='a')then if(present(p_idx))then do j=1,pnum call DclDrawMarker( xpoint(:,j), ypoint(:,j), type=p_idx(j) ) end do else if(pnum==1)then call DclDrawMarker( xpoint(:,1), ypoint(:,1) ) else do j=1,pnum call DclDrawMarker( xpoint(:,j), ypoint(:,j), type=j ) end do end if end if end if end if if(present(zline))then call color_line( 'l', xline, yline, zline, 0, (/0.0, 0.0/), col_val=cl_val, col_idx=cl_idx ) else if(judge=='l'.or.judge=='a')then do j=1,lnum if(present(l_idx))then call DclSetLineIndex( l_idx(j) ) else if(lnum/=1)then nnum=lim/lnum call DclSetLineIndex( 100+nnum*(j-1)+1 ) end if end if if(present(l_typ))then call DclSetLineType( l_typ(j) ) end if call DclDrawLine( xline(:,j), yline(:,j) ) end do end if end if ! call DclSetContourLabelFormat(form_typec) ! call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/10 ) ! call DclDrawContour( contour ) ! call DclDrawVectors( um, vm ) end subroutine
Subroutine : | |||
judge : | character(1), intent(in)
| ||
outname : | character(*), intent(in)
| ||
x(:) : | real, intent(in)
| ||
y(:) : | real, intent(in)
| ||
xline(:,:) : | real, intent(in)
| ||
yline(size(xline,1),size(xline,2)) : | real, intent(in)
| ||
xpoint(:,:) : | real, intent(in)
| ||
ypoint(size(xpoint,1),size(xpoint,2)) : | real, intent(in)
| ||
vecx(size(x),size(y)) : | real, intent(in)
| ||
vecy(size(x),size(y)) : | real, intent(in)
| ||
vn(2) : | integer, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
| ||
viewx_int(2) : | real, intent(in), optional
| ||
viewy_int(2) : | real, intent(in), optional
| ||
no_frame : | logical, intent(in), optional
| ||
xylog(2) : | logical, intent(in), optional
| ||
l_idx(size(xline,2)) : | integer, intent(in), optional
| ||
l_typ(size(xline,2)) : | integer, intent(in), optional
| ||
p_idx(size(xpoint,2)) : | integer, intent(in), optional
| ||
p_typ(size(xpoint,2)) : | integer, intent(in), optional
| ||
p_siz(size(xpoint,2)) : | real, intent(in), optional
| ||
zline(size(xline,1),size(xline,2)) : | real, intent(in), optional
| ||
zpoint(size(xpoint,1),size(xpoint,2)) : | real, intent(in), optional
| ||
cl_val(:) : | real, intent(in), optional
| ||
cl_idx(:) : | integer, intent(in), optional
| ||
cp_val(:) : | real, intent(in), optional
| ||
cp_idx(:) : | integer, intent(in), optional
|
2 次元平面内においてベクトルと複数の曲線, ポイントで描画する. 与える曲線とポイントはそれぞれ別個の配列で定義されており, 曲線については, x, y 座標の 2 種類, ポイントについても同様の 2 種類, さらに曲線の x, y 座標用配列は第一要素で 1 本の曲線の連続を 第二要素で曲線の本数を設定. ポイントについても同様. つまり, 例として以下のように配列を用意する. 3 本の曲線, 5 種類のポイントを描きたく, 曲線については 1 本の曲線を 描くためには 1000 個の点の連続で描かれ, ポイントについては 1 種類の ポイントを 100 個描きたいとすると, xline(1000, 3), yline(1000, 3), xpoint(100, 5), y(100, 5) として引数に読み込ませればよい. このとき, 上の引数に対応する関係は以下のとおりである. lnum = 3, pnum = 5, lstep = 1000, pstep = 100
subroutine Dcl_PL_vec( judge, outname, x, y, xline, yline, xpoint, ypoint, vecx, vecy, vn, axis_title, viewx_int, viewy_int, no_frame, xylog, l_idx, l_typ, p_idx, p_typ, p_siz, zline, zpoint, cl_val, cl_idx, cp_val, cp_idx ) ! 2 次元平面内においてベクトルと複数の曲線, ポイントで描画する. ! 与える曲線とポイントはそれぞれ別個の配列で定義されており, ! 曲線については, x, y 座標の 2 種類, ポイントについても同様の 2 種類, ! さらに曲線の x, y 座標用配列は第一要素で 1 本の曲線の連続を ! 第二要素で曲線の本数を設定. ポイントについても同様. ! つまり, 例として以下のように配列を用意する. ! 3 本の曲線, 5 種類のポイントを描きたく, 曲線については 1 本の曲線を ! 描くためには 1000 個の点の連続で描かれ, ポイントについては 1 種類の ! ポイントを 100 個描きたいとすると, ! xline(1000, 3), yline(1000, 3), xpoint(100, 5), y(100, 5) ! として引数に読み込ませればよい. ! このとき, 上の引数に対応する関係は以下のとおりである. ! lnum = 3, pnum = 5, lstep = 1000, pstep = 100 use dcl implicit none character(1), intent(in) :: judge ! グラフの種類 ! 'p' = ポイントのみ描画, 'l' = ラインのみ, 'a' = 両方描画. ! 片方しか描画しない場合でも, ダミー配列を読み込ませる必要あり. character(*), intent(in) :: outname ! グラフのタイトル real, intent(in) :: x(:) ! x 方向の格子点座標 real, intent(in) :: y(:) ! y 方向の格子点座標 real, intent(in) :: xline(:,:) ! 曲線群の x 座標 real, intent(in) :: yline(size(xline,1),size(xline,2)) ! 曲線群の y 座標 real, intent(in) :: xpoint(:,:) ! ポイント群の x 座標 real, intent(in) :: ypoint(size(xpoint,1),size(xpoint,2)) ! ポイント群の y 座標 real, intent(in) :: vecx(size(x),size(y)) ! x 方向のベクトル real, intent(in) :: vecy(size(x),size(y)) ! x 方向のベクトル integer, intent(in) :: vn(2) ! ベクトル格子点 (間引き使用) ! vn(1)=vnx, vn(2)=vny character(*), intent(in) :: axis_title(2) ! 座標軸のタイトル ! axis_title(1)=x_title,axis_title(2)=y_title real, intent(in), optional :: viewx_int(2) ! ビューポートの x 方向の両端 ! viewx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in), optional :: viewy_int(2) ! ビューポートの y 方向の両端 ! viewy_int(1)=vy_min, vy_int(2)=vy_max logical, intent(in), optional :: no_frame ! NewFrame を呼ばない ! .false. = 呼ぶ. .true. = 呼ばずに NewFig. ! デフォルトは .false. logical, intent(in), optional :: xylog(2) ! 対数スケールで軸を書くフラグ. ! .true. で描く, default はどちらも .false. integer, intent(in), optional :: l_idx(size(xline,2)) ! 各線の種類を明示的に与える. integer, intent(in), optional :: l_typ(size(xline,2)) ! 各線の種類を明示的に与える. integer, intent(in), optional :: p_idx(size(xpoint,2)) ! 各点の種類を明示的に与える. integer, intent(in), optional :: p_typ(size(xpoint,2)) ! 各点の種類を明示的に与える. real, intent(in), optional :: p_siz(size(xpoint,2)) ! 各点の種類を明示的に与える. real, intent(in), optional :: zline(size(xline,1),size(xline,2)) ! カラーラインモードの xpoint, ypoint に伴う値. real, intent(in), optional :: zpoint(size(xpoint,1),size(xpoint,2)) ! カラーラインモードの xpoint, ypoint に伴う値. real, intent(in), optional :: cl_val(:) ! カラーの値 (ライン) integer, intent(in), optional :: cl_idx(:) ! カラー番号 (ライン) real, intent(in), optional :: cp_val(:) ! カラーの値 (マーカー) integer, intent(in), optional :: cp_idx(:) ! カラー番号 (マーカー) !-- 以上, 引数 integer :: vnx ! x 方向のベクトル格子点 (間引き使用) integer :: vny ! y 方向のベクトル格子点 (間引き使用) character(100) :: x_title ! x 軸のタイトル character(100) :: y_title ! y 軸のタイトル real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 !-- 以上, 引数の置き換え用変数 integer :: i, j, k ! 作業用添字 integer :: nx, ny integer, parameter :: lim=890 integer :: lstep, pstep, lnum, pnum, nnum integer :: trans_num real :: factx, facty real, dimension(size(x),size(y)) :: um, vm ! ベクトル間引き後の値を代入 real :: undef, RMISS logical :: no_frame_flag logical :: xlogf, ylogf nx=size(x) ny=size(y) lstep=size(xline,1) pstep=size(xpoint,1) lnum=size(xline,2) pnum=size(xpoint,2) !-- optional 引数の処理 --- if(present(viewx_int))then vx_min=viewx_int(1) vx_max=viewx_int(2) else vx_min=0.2 vx_max=0.8 end if if(present(viewy_int))then vy_min=viewy_int(1) vy_max=viewy_int(2) else vy_min=0.2 vy_max=0.8 end if if(present(no_frame))then no_frame_flag=no_frame else no_frame_flag=.false. end if if(present(xylog))then xlogf=xylog(1) ylogf=xylog(2) else xlogf=.false. ylogf=.false. end if !-- 引数の置き換え用変数に置き換え vnx=vn(1) vny=vn(2) x_title=trim(axis_title(1)) y_title=trim(axis_title(2)) !-- エラー処理 if(nx<vnx.or.ny<vny)then write(*,*) "*****ERROR***** : vnx > nx or vny > ny." stop end if !-- 警告 if(mod(nx,(vnx-1))/=0.or.mod(ny,(vny-1))/=0)then write(*,*) "****WARNING**** : vnx or vny is not the factor of nx or ny." end if !-- ベクトル場の間引き factx=real(nx)/real(vnx-1) facty=real(ny)/real(vny-1) um=0.0 vm=0.0 !-- 起点を 1 から始める um(1,1)=vecx(1,1) vm(1,1)=vecy(1,1) do i=2,vnx um(1+nint(factx*(i-1)),1)=vecx(1+nint(factx*(i-1)),1) vm(1+nint(factx*(i-1)),1)=vecy(1+nint(factx*(i-1)),1) end do do j=2,vny um(1,1+nint((j-1)*facty))=vecx(1,1+nint((j-1)*facty)) vm(1,1+nint((j-1)*facty))=vecy(1,1+nint((j-1)*facty)) end do do j=2,vny do i=2,vnx um(1+nint(factx*(i-1)),1+nint(facty*(j-1))) =vecx(1+nint(factx*(i-1)),1+nint(facty*(j-1))) vm(1+nint(factx*(i-1)),1+nint(facty*(j-1))) =vecy(1+nint(factx*(i-1)),1+nint(facty*(j-1))) end do end do !-- 処理ここまで --- ! call undef_CReSS2Dcl( nx, ny, 1, contour) ! call undef_CReSS2Dcl( nx, ny, 1, shade) call UWSGXZ(.FALSE.) call UWSGYZ(.FALSE.) if(no_frame_flag.eqv..true.)then call DclNewFig else call DclNewFrame end if call DclSetWindow( x(1), x(nx), y(1), y(ny) ) call DclSetViewPort( vx_min, vx_max, vy_min, vy_max ) if(xlogf.eqv..true.)then if(ylogf.eqv..true.)then trans_num=4 else trans_num=3 end if else if(ylogf.eqv..true.)then trans_num=2 else trans_num=1 end if end if call DclSetTransNumber(trans_num) call DclSetTransFunction ! call DclShadeContourEx( shade ) CALL UZLSET( 'LABELYL', .TRUE. ) CALL UZLSET( 'LABELYR', .FALSE. ) call DclDrawScaledAxis call DclDrawTitle( 'b', trim(x_title), 0.0 ) call DclDrawTitle( 'l', trim(y_title), 0.0 ) call DclDrawTitle( 't', trim(outname), 0.0, 2 ) !-- ポイントと曲線の設定 --- !-- num 数に応じて do ループで回すので, num 数は任意で OK. !-- num = 1 の場合は黒色で固定 if(present(zpoint))then call color_line( 'p', xpoint, ypoint, zpoint, 0, (/0.0, 0.0/), col_val=cp_val, col_idx=cp_idx ) else if(judge=='p'.or.judge=='a')then if(present(p_idx))then do j=1,pnum call DclDrawMarker( xpoint(:,j), ypoint(:,j), type=p_idx(j) ) end do else if(pnum==1)then call DclDrawMarker( xpoint(:,1), ypoint(:,1) ) else do j=1,pnum call DclDrawMarker( xpoint(:,j), ypoint(:,j), type=j ) end do end if end if end if end if if(present(zline))then call color_line( 'l', xline, yline, zline, 0, (/0.0, 0.0/), col_val=cl_val, col_idx=cl_idx ) else if(judge=='l'.or.judge=='a')then do j=1,lnum if(present(l_idx))then call DclSetLineIndex( l_idx(j) ) else if(lnum/=1)then nnum=lim/lnum call DclSetLineIndex( 100+nnum*(j-1)+1 ) end if end if if(present(l_typ))then call DclSetLineType( l_typ(j) ) end if call DclDrawLine( xline(:,j), yline(:,j) ) end do end if end if ! call DclSetContourLabelFormat(form_typec) ! call DclSetContourLevel( cont_min, cont_max, (cont_max-cont_min)/10 ) ! call DclDrawContour( contour ) call DclDrawVectors( um, vm ) end subroutine
Subroutine : | |||
space : | character(*), intent(in)
| ||
map_pro : | integer, intent(in)
| ||
mlitv : | real, intent(in)
| ||
vx_int(2) : | real, intent(in)
| ||
vy_int(2) : | real, intent(in)
| ||
t_posi(3) : | real, intent(in)
| ||
lon_int(:,:) : | real, intent(in)
| ||
lat_int(:,:) : | real, intent(in)
| ||
axis_title(2) : | character(*), intent(in)
|
直交しない地図座標において, 直交座標系での地図軸を描画するルーチン デフォルトの DCL の場合, メルカトル以外の地図描画では, 軸の描画ルーチンが, 緯度経度でしか描画できないので, デカルト系で 地図投影した場合の地図の度数軸を描くためのもの.
subroutine Dcl_Special_Axis( space, map_pro, mlitv, vx_int, vy_int, t_posi, lon_int, lat_int, axis_title ) ! 直交しない地図座標において, 直交座標系での地図軸を描画するルーチン ! デフォルトの DCL の場合, メルカトル以外の地図描画では, ! 軸の描画ルーチンが, 緯度経度でしか描画できないので, デカルト系で ! 地図投影した場合の地図の度数軸を描くためのもの. use dcl implicit none character(*), intent(in) :: space ! 座標軸を描く場所 "btrl" で表記. integer, intent(in) :: map_pro ! 用いている地図番号 real, intent(in) :: mlitv ! 軸にラベルを貼るときの間隔 [degree] real, intent(in) :: vx_int(2) ! x 方向の v 座標系 real, intent(in) :: vy_int(2) ! y 方向の v 座標系 real, intent(in) :: t_posi(3) ! 地図投影時の正軸 t_posi=(/lat1, lat2, lon/) real, intent(in) :: lon_int(:,:) ! デカルト系の各格子点に与えられている経度 real, intent(in) :: lat_int(:,:) ! デカルト系の各格子点に与えられている緯度 ! ともに [degree] character(*), intent(in) :: axis_title(2) ! axis title real, allocatable, dimension(:) :: lon_tranc, lat_tranc integer :: i, j, k, i_lon, i_lat integer :: nc, nx, ny, nlon, nlat, nlonb, nlatb real :: map_min_lon, map_max_lon, map_min_lat, map_max_lat real :: uratio, vratio real :: tmp_x(2), tmp_y(2), label_v real :: ref_x_min, ref_x_max, ref_y_min, ref_y_max, rho0 character(10) :: label !-- 文関数用変数 real :: rho, rhon, var, var1, var2, s, sn real, parameter :: pi=3.141592 !-- function rho(var,var1,s)=cos(var1*pi/180.0)*(tan(0.25*pi-0.5*var*pi/180.0))**s /(s*(tan(0.25*pi-0.5*var1*pi/180.0))**s) rhon(var1,var2)=log(cos(var1*pi/180.0)/cos(var2*pi/180.0)) /log(tan(0.25*pi-0.5*var1*pi/180.0)/tan(0.25*pi-0.5*var2*pi/180.0)) !-- 地図をデカルト系で四角に囲む call Dcl_Square_Normal( vx_int, vy_int, 4, 0 ) nc=len_trim(adjustl(space)) nx=size(lon_int,1) ny=size(lon_int,2) !-- 基準座標点でのパラメータ計算 sn=rhon(t_posi(1),t_posi(2)) rho0=cos(t_posi(1))/sn !-- 基準座標点での v 座標系の相対位置 !-- この点を用いて, 最終的に平行移動させる. ref_x_min=rho(lat_int(1,1),t_posi(1),sn)*sin(sn*(lon_int(1,1)-t_posi(3))*pi/180.0) ref_x_max=rho(lat_int(nx,1),t_posi(1),sn)*sin(sn*(lon_int(nx,1)-t_posi(3))*pi/180.0) ref_y_min=rho0-rho(lat_int(1,1),t_posi(1),sn)*cos(sn*(lon_int(1,1)-t_posi(3))*pi/180.0) ref_y_max=rho0-rho(lat_int(1,ny),t_posi(1),sn)*cos(sn*(lon_int(1,ny)-t_posi(3))*pi/180.0) uratio=(vx_int(2)-vx_int(1))/(ref_x_max-ref_x_min) vratio=(vy_int(2)-vy_int(1))/(ref_y_max-ref_y_min) !-- map におけるラベルの終端位置の計算 map_min_lon=(aint(lon_int(1,1)/mlitv)+1.0)*mlitv map_min_lat=(aint(lat_int(1,1)/mlitv)+1.0)*mlitv map_max_lon=(aint(lon_int(nx,1)/mlitv))*mlitv map_max_lat=(aint(lat_int(1,ny)/mlitv))*mlitv if(map_min_lon-mlitv>=lon_int(1,1))then map_min_lon=map_min_lon-mlitv end if if(map_min_lat-mlitv>=lat_int(1,1))then map_min_lat=map_min_lat-mlitv end if if(map_max_lon+mlitv<=lon_int(nx,1))then map_max_lon=map_max_lon+mlitv end if if(map_max_lat+mlitv<=lat_int(1,ny))then map_max_lat=map_max_lat+mlitv end if !-- ここまで終端位置の計算 !-- ラベルを描くのに必要な配列要素の数 nlon=int((map_max_lon-map_min_lon)/mlitv)+1 nlat=int((map_max_lat-map_min_lat)/mlitv)+1 allocate(lon_tranc(nlon)) allocate(lat_tranc(nlat)) !-- 実際の各ラベルでの計算 !-- 計算の順序は以下のとおり. ! (1) 軸でラベルを描く点を決める. このときの軸を便宜上「軸1」とする. ! (2) その点での v 座標系の値を決めるには, その点の経緯度が必要. ! (3) ラベルを描く軸1 は自由に決められるがそのときもう片方の軸2 の度は ! 得られないので, 軸1 で描く場所の軸1 についての隣接点から内挿する. ! 隣接点は 2 次元データで与えられる経緯度なので, これらの値から ! v 座標が得られるので, これらをもとに, v 系で内挿を行う. ! と思ったが, 隣接点の lon, lat から得られた v 系の値を内挿しても ! それほど変化しないのではないかと思ったので, 今はこの方法で計算している. call DclSetParm( 'GRAPH:LCLIP', .false. ) select case (map_pro) case (22) ! conical do j=1,nc select case (space(j:j)) case ('b') nlonb=1 nlatb=1 do i=1,nlon lon_tranc(i)=map_min_lon+(i-1)*mlitv call val_estimate( lon_int(:,nlatb), lon_tranc(i), i_lon ) tmp_x(1)=rho(lat_int(i_lon,nlatb), t_posi(1),sn) *sin(sn*(lon_int(i_lon,nlatb)-t_posi(3))*pi/180.0) tmp_x(2)=rho(lat_int(i_lon+1,nlatb), t_posi(1),sn) *sin(sn*(lon_int(i_lon+1,nlatb)-t_posi(3))*pi/180.0) label_v=(tmp_x(1)-ref_x_min+(tmp_x(2)-tmp_x(1)) /(lon_int(i_lon+1,nlatb)-lon_int(i_lon,nlatb)) *(lon_tranc(i)-lon_int(i_lon,nlatb)))*uratio+vx_int(1) write(label,'(f5.1)') lon_tranc(i) call DclDrawTextNormalized( label_v, vy_int(1)-0.01, trim(adjustl(label)), height=0.01 ) end do call DclDrawTextNormalized( (vx_int(1)+vx_int(2))*0.5, vy_int(1)-0.03, trim(axis_title(1)), height=0.02 ) case ('t') nlonb=1 nlatb=ny do i=1,nlon lon_tranc(i)=map_min_lon+(i-1)*mlitv call val_estimate( lon_int(:,nlatb), lon_tranc(i), i_lon ) tmp_x(1)=rho(lat_int(i_lon,nlatb), t_posi(1),sn) *sin(sn*(lon_int(i_lon,nlatb)-t_posi(3))*pi/180.0) tmp_x(2)=rho(lat_int(i_lon+1,nlatb), t_posi(1),sn) *sin(sn*(lon_int(i_lon+1,nlatb)-t_posi(3))*pi/180.0) label_v=(tmp_x(1)-ref_x_min+(tmp_x(2)-tmp_x(1)) /(lon_int(i_lon+1,nlatb)-lon_int(i_lon,nlatb)) *(lon_tranc(i)-lon_int(i_lon,nlatb)))*uratio+vx_int(1) write(label,'(f5.1)') lon_tranc(i) call DclDrawTextNormalized( lon_tranc(i), vy_int(2)+0.01, trim(adjustl(label)), height=0.01 ) end do case ('l') nlonb=1 nlatb=1 do i=1,nlat lat_tranc(i)=map_min_lat+(i-1)*mlitv call val_estimate( lat_int(nlonb,:), lat_tranc(i), i_lat ) tmp_y(1)=-rho(lat_int(nlonb,i_lat), t_posi(1),sn) *cos(sn*(lon_int(nlonb,i_lat)-t_posi(3))*pi/180.0) tmp_y(2)=-rho(lat_int(nlonb,i_lat+1), t_posi(1),sn) *cos(sn*(lon_int(nlonb,i_lat+1)-t_posi(3))*pi/180.0) label_v=(rho0+tmp_y(1)-ref_y_min+(tmp_y(2)-tmp_y(1)) /(lat_int(nlonb,i_lat+1)-lat_int(nlonb,i_lat)) *(lat_tranc(i)-lat_int(nlonb,i_lat)))*vratio+vy_int(1) write(label,'(f5.1)') lat_tranc(i) call DclDrawTextNormalized( vx_int(1)-0.02, label_v, trim(adjustl(label)), height=0.01 ) end do call DclDrawTextNormalized( vx_int(1)-0.05, (vy_int(2)+vy_int(1))*0.5, trim(axis_title(2)), angle=90.0, height=0.02 ) end select end do end select call DclSetParm( 'GRAPH:LCLIP', .true. ) end subroutine
Subroutine : | |||
viewx_int(2) : | real, intent(in)
| ||
viewy_int(2) : | real, intent(in)
| ||
line : | integer, intent(in)
| ||
color : | integer, intent(in)
|
正規化座標系において, 四角領域を作成し, 任意の色と線で塗りつぶす. color = 0 なら塗りつぶさず, 枠を書くだけ.
subroutine Dcl_Square_Normal( viewx_int, viewy_int, line, color ) ! 正規化座標系において, 四角領域を作成し, 任意の色と線で塗りつぶす. ! color = 0 なら塗りつぶさず, 枠を書くだけ. use dcl implicit none real, intent(in) :: viewx_int(2) ! x 方向の正規座標 real, intent(in) :: viewy_int(2) ! x 方向の正規座標 integer, intent(in) :: line ! 枠線の色と太さ(DCL の index, type に従う) integer, intent(in) :: color ! 四角を塗りつぶす色(DCL のカラーマップに従う) real :: vx(5), vy(5) vx(:)=(/viewx_int(1), viewx_int(2), viewx_int(2), viewx_int(1), viewx_int(1)/) vy(:)=(/viewy_int(1), viewy_int(1), viewy_int(2), viewy_int(2), viewy_int(1)/) if(color/=0)then call DclShadeRegionNormalized( vx, vy, color ) end if call DclDrawLineNormalized( vx, vy, index=line ) end subroutine
Subroutine : | |||
head : | character(*), intent(in)
| ||
time : | integer, intent(in)
| ||
title : | character(*), intent(inout)
| ||
forma : | character(6), intent(in), optional
| ||
factor : | integer, intent(in), optional
| ||
unite : | character(*), intent(in), optional
|
時間発展する場合, 自動的にグラフのタイトルを作成する
subroutine auto_title( head, time, title, forma, factor, unite ) ! 時間発展する場合, 自動的にグラフのタイトルを作成する implicit none character(*), intent(in) :: head ! タイトルヘッダ integer, intent(in) :: time ! 時刻 character(*), intent(inout) :: title ! 生成されるタイトル character(6), intent(in), optional :: forma ! オプションとしてフォーマット integer, intent(in), optional :: factor ! time factor character(*), intent(in), optional :: unite ! unit character(6) :: formb character(8) :: tmpname integer :: facttime, len_num real :: facttime_f if(present(forma))then formb=forma else formb='(i8.8)' end if if(present(factor))then if(mod(time,factor)/=0)then facttime_f=real(time)/real(factor) write(tmpname,formb) facttime_f write(*,*) "######## facttime", tmpname, facttime_f else if(formb(2:2)=='f')then ! フォーマットが実数で与えられている facttime=time/factor write(tmpname,formb) real(facttime) else facttime=time/factor write(tmpname,formb) facttime end if end if else facttime=time write(*,*) "facttiem", facttime, time, formb write(tmpname,formb) time end if len_num=len_trim(tmpname) if(present(unite))then title=trim(head)//'_(t='//tmpname(1:len_num)//trim(unite)//')"' else title=trim(head)//'_(t='//tmpname(1:len_num)//'[s])"' end if end subroutine
Subroutine : | |||
length(2) : | real, intent(in)
| ||
v_length(2) : | real, intent(in)
| ||
vx_scale : | real, intent(in)
| ||
vy_scale : | real, intent(inout)
|
風速ベクトルを描画アスペクト比に合わせるための V 座標系における単位ベクトル を計算するルーチン. x 方向の値を指定し, そのときの y 方向のスケールを決める. 計算方法は以下のとおり. U 座標系で (uu, uv) のベクトルを V 座標系で (vu,vv) にしたい. (vu, vv)=(vx_scale*uu, vy_scale*uv) という関係をもつ. 一方, グラフの描画領域の幅を U, V 座標系でそれぞれ ux, uy, vx, vy とすると, x 方向を基準に y 方向の伸縮を決めるとき, v 座標系では, vy/vx=v_asp 倍だけ y 方向ベクトルにかけ, u 座標系では, 1/(uy/ux)=1/u_asp 倍だけ y 方向ベクトルにかけるので, (vu, vv)=(vx_scale*uu, (v_asp/u_asp)*vy_scale*vy) という関係をもてばよい. これについての詳しい概念図は Tex ファイル参照. よって, vx_scale, vy_scale が同じ比率で変化するとき, (つまり, 風速ベクトルとして変化するとき) vy_scale=vx_scale*v_asp*u_asp となる.
subroutine calc_vscale( length, v_length, vx_scale, vy_scale ) ! 風速ベクトルを描画アスペクト比に合わせるための V 座標系における単位ベクトル ! を計算するルーチン. x 方向の値を指定し, そのときの y 方向のスケールを決める. ! 計算方法は以下のとおり. ! U 座標系で (uu, uv) のベクトルを V 座標系で (vu,vv) にしたい. ! (vu, vv)=(vx_scale*uu, vy_scale*uv) という関係をもつ. ! 一方, グラフの描画領域の幅を U, V 座標系でそれぞれ ux, uy, vx, vy とすると, ! x 方向を基準に y 方向の伸縮を決めるとき, ! v 座標系では, vy/vx=v_asp 倍だけ y 方向ベクトルにかけ, ! u 座標系では, 1/(uy/ux)=1/u_asp 倍だけ y 方向ベクトルにかけるので, ! (vu, vv)=(vx_scale*uu, (v_asp/u_asp)*vy_scale*vy) という関係をもてばよい. ! これについての詳しい概念図は Tex ファイル参照. ! よって, vx_scale, vy_scale が同じ比率で変化するとき, ! (つまり, 風速ベクトルとして変化するとき) ! vy_scale=vx_scale*v_asp*u_asp となる. implicit none real, intent(in) :: length(2) ! 描画距離 [m] real, intent(in) :: v_length(2) ! V 系での描画範囲 real, intent(in) :: vx_scale ! x 方向のスケーリングファクター real, intent(inout) :: vy_scale ! y 方向のスケーリングファクター !-- 以上, 引数 real :: x_length ! 横方向の描画距離 [m] real :: y_length ! 縦方向の描画距離 [m] real :: vx_length ! 縦方向の V 系での描画範囲 real :: vy_length ! 横方向の V 系での描画範囲 !-- 以上, 引数の置き換え用変数 real :: u_asp, v_asp !-- 引数の置き換え用変数に置き換え x_length=length(1) y_length=length(2) vx_length=v_length(1) vy_length=v_length(2) u_asp=y_length/x_length v_asp=vy_length/vx_length vy_scale=(v_asp/u_asp)*vx_scale end subroutine
Subroutine : | |||
sub_idx : | character(1), intent(in)
| ||
linex(:,:) : | real, intent(in)
| ||
liney(size(linex,1),size(linex,2)) : | real, intent(in)
| ||
valz(size(linex,1),size(linex,2)) : | real, intent(in)
| ||
c_num : | integer, intent(in)
| ||
c_itv(2) : | real, intent(in)
| ||
tri_col(2) : | integer, intent(in), optional
| ||
col_val(:) : | real, intent(in), optional
| ||
col_idx(:) : | integer, intent(in), optional
|
直線を valz をもとにカラー表示するルーチン
subroutine color_line( sub_idx, linex, liney, valz, c_num, c_itv, tri_col, col_val, col_idx ) ! 直線を valz をもとにカラー表示するルーチン use dcl implicit none character(1), intent(in) :: sub_idx ! どのルーチンを呼び出すか. ! [s] = DclScalingPoint ! [l] = DclDrawLine ! [p] = DclDrawMark real, intent(in) :: linex(:,:) ! x 軸の直線座標 real, intent(in) :: liney(size(linex,1),size(linex,2)) ! y 軸の直線座標 real, intent(in) :: valz(size(linex,1),size(linex,2)) ! 直線での値 integer, intent(in) :: c_num ! 用いるカラー数 real, intent(in) :: c_itv(2) ! 自動カラーを設定するときの最大最小値. integer, intent(in), optional :: tri_col(2) ! valz が c_itv を越えたときの ! 設定カラー番号 real, intent(in), optional :: col_val(:) ! valz に関連付けられるカラーの境界値 integer, intent(in), optional :: col_idx(:) ! c_val に対応するカラー番号 integer :: nlx, nly, ncl, itmp, tmp_i, i, j, counter real, allocatable, dimension(:) :: c_val integer, allocatable, dimension(:) :: c_idx integer :: ci_itv(2), over_col(2), ccnum, tmpci real :: tmp1_itv(2), tmp2_itv(2) real :: defun, tmpcmin, tmpcmax integer :: ci_min, ci_max, aidx, ltyp, mtyp real :: msiz call GLRGET( 'RMISS', defun ) nlx=size(linex,1) nly=size(linex,2) if(present(col_val))then ncl=size(col_val)-1 allocate(c_val(ncl+1)) allocate(c_idx(ncl+1)) do i=1,ncl+1 c_val(i)=col_val(i) c_idx(i)=col_idx(i) end do else ! col_val が設定されていない場合は今の color_setting の値を用いる. ncl=c_num allocate(c_val(ncl+1)) allocate(c_idx(ncl+1)) ccnum=DclGetShadeLevelNumber() if(ccnum==0)then ci_min=15 ci_max=85 else do i=1,ccnum call DclGetShadeLevel( i, tmpcmin, tmpcmax, tmpci ) ! if(tmpcmin==c_itv(1))then ! ci_min=tmpci/1000 ! 下 3 桁は 999 で設定されているはず. ! setc_check(1)=.true. ! end if ! if(tmpcmax==c_itv(2))then ! ci_max=tmpci/1000 ! 下 3 桁は 999 で設定されているはず. ! setc_check=.true. ! end if if(tmpcmin==defun)then ! 下三角の色 over_col(1)=tmpci/1000 end if if(tmpcmax==defun)then ! 上三角の色 over_col(2)=tmpci/1000 end if if(tmpcmax/=defun)then ! col_val, col_idx 設定 c_val(i)=tmpcmax c_idx(i)=tmpci/1000 end if end do end if select case (sub_idx) case('s') ! ここでの値は使わない. aidx=DclGetLineIndex() case('l') aidx=DclGetLineIndex() case('p') aidx=DclGetMarkerIndex() end select do i=1,ncl+1 if(ccnum==0)then c_val(i)=c_itv(1)+(c_itv(2)-c_itv(1))/real(c_num)*(i-1) c_idx(i)=(ci_min+int(real(ci_max-ci_min)/real(c_num)*real(i-1)))*10+aidx ! index はデフォルトで設定されている値を参照する. else c_idx(i)=c_idx(i)*10+aidx end if end do end if ! get marker size and line type (developing) select case (sub_idx) case('l') ltyp=DclGetLineType() case('p') msiz=DclGetMarkerSize() mtyp=DclGetMarkerType() end select if(present(tri_col))then over_col(1)=tri_col(1) over_col(2)=tri_col(2) end if over_col(1)=over_col(1)*10+aidx over_col(2)=over_col(2)*10+aidx do j=1,nly if(valz(1,j)/=defun)then call val_estimate( c_val, valz(1,j), itmp ) counter=1 else itmp=-1 counter=0 end if if(nlx>1)then do i=2,nlx if(valz(i,j)/=defun)then call val_estimate( c_val, valz(i,j), tmp_i ) else tmp_i=-1 end if if(itmp/=tmp_i.and.i-counter>0.and.itmp/=-1)then select case (sub_idx) case ('s') call DclScalingPoint( linex(counter:i,j), liney(counter:i,j) ) case ('l') if(itmp==0)then call DclDrawLine( linex(counter:i,j), liney(counter:i,j), index=over_col(1), type=ltyp ) end if if(itmp==ncl+1)then call DclDrawLine( linex(counter:i,j), liney(counter:i,j), index=over_col(2), type=ltyp ) end if if(itmp/=0.and.itmp/=ncl+1)then call DclDrawLine( linex(counter:i,j), liney(counter:i,j), index=c_idx(itmp), type=ltyp ) end if case ('p') if(itmp==0)then call DclDrawMarker( linex(counter:i,j), liney(counter:i,j), index=over_col(1), type=mtyp, height=msiz ) else if(itmp==ncl+1)then call DclDrawMarker( linex(counter:i,j), liney(counter:i,j), index=over_col(2), type=mtyp, height=msiz ) else if(itmp/=0.and.itmp/=ncl+1)then call DclDrawMarker( linex(counter:i,j), liney(counter:i,j), index=c_idx(itmp), type=mtyp, height=msiz ) end if end select itmp=tmp_i counter=i else if(i==nlx.and.nlx-counter>1.and.itmp/=-1)then select case (sub_idx) case ('s') call DclScalingPoint( linex(counter:nlx,j), liney(counter:nlx,j) ) case ('l') if(itmp==0)then call DclDrawLine( linex(counter:nlx,j), liney(counter:nlx,j), index=over_col(1), type=ltyp ) else if(itmp==ncl+1)then call DclDrawLine( linex(counter:nlx,j), liney(counter:nlx,j), index=over_col(2), type=ltyp ) else if(itmp/=0.and.itmp/=ncl+1)then call DclDrawLine( linex(counter:nlx,j), liney(counter:nlx,j), index=c_idx(itmp), type=ltyp ) end if case ('p') if(itmp==0)then call DclDrawMarker( linex(counter:nlx,j), liney(counter:nlx,j), index=over_col(1), type=mtyp, height=msiz ) else if(itmp==ncl+1)then call DclDrawMarker( linex(counter:nlx,j), liney(counter:nlx,j), index=over_col(2), type=mtyp, height=msiz ) else if(itmp/=0.and.itmp/=ncl+1)then call DclDrawMarker( linex(counter:nlx,j), liney(counter:nlx,j), index=c_idx(itmp), type=mtyp, height=msiz ) end if end select end if end if end do else if(itmp>0)then select case (sub_idx) case ('s') call DclScalingPoint( linex(1:1,j), liney(1:1,j) ) write(*,*) "*** WARNING *** (color_line:dcl_automatic)" write(*,*) "the array number of each line or marker is 1." case ('p') if(itmp==0)then call DclDrawMarker( linex(1:1,j), liney(1:1,j), index=over_col(1), type=mtyp, height=msiz ) else if(itmp==ncl+1)then call DclDrawMarker( linex(1:1,j), liney(1:1,j), index=over_col(2), type=mtyp, height=msiz ) else if(itmp/=0.and.itmp/=ncl+1)then call DclDrawMarker( linex(1:1,j), liney(1:1,j), index=c_idx(itmp), type=mtyp, height=msiz ) end if end select end if end if end do end subroutine
Subroutine : | |||
color_num : | integer, intent(in)
| ||
val_int(2) : | real, intent(in)
| ||
col_tab : | integer, intent(in), optional
| ||
col_max : | integer, intent(in), optional
| ||
col_min : | integer, intent(in), optional
| ||
col_bg : | logical, intent(in), optional
| ||
reverse : | logical, intent(in), optional
| ||
min_tab : | integer, intent(in), optional
| ||
max_tab : | integer, intent(in), optional
| ||
log_flag : | logical, intent(in), optional
| ||
col_spec(color_num) : | integer, intent(in), optional
| ||
val_spec(color_num+1) : | real, intent(in), optional
|
カラーマップの色と数値を対応させる自動ルーチン
subroutine color_setting( color_num, val_int, col_tab, col_max, col_min, col_bg, reverse, min_tab, max_tab, log_flag, col_spec, val_spec ) ! カラーマップの色と数値を対応させる自動ルーチン use dcl implicit none integer, intent(in) :: color_num ! 使用するカラーの種類 real, intent(in) :: val_int(2) ! 描くカラーの上下端 ! val_int(1)=val_min, val_int(2)=val_max integer, intent(in), optional :: col_tab ! dcl のカラーテーブル integer, intent(in), optional :: col_min ! 使用するカラー番号の最小値(上2桁) integer, intent(in), optional :: col_max ! 使用するカラー番号の最大値(上2桁) logical, intent(in), optional :: col_bg ! 背景色の入れ替え デフォルトなし. integer :: map_num ! カラーマップのマップ番号指定 (optional 属性をつけること) integer :: i, j, k ! 作業用添字 logical, intent(in), optional :: reverse ! カラー番号を反転させる. integer, intent(in), optional :: min_tab ! val_min 以下の値に対応するカラー番号, デフォルトは黒 integer, intent(in), optional :: max_tab ! val_max 以上の値に対応するカラー番号, デフォルトは黒 logical, intent(in), optional :: log_flag ! スケールを対数化するか. デフォルトは .false. integer, intent(in), optional :: col_spec(color_num) ! val_spec で指定された値に対応したカラー番号 real, intent(in), optional :: val_spec(color_num+1) ! カラーに対応する数値を陽的に指定する. !-- 以上, 引数 real :: val_min ! 描くカラーの最小値 real :: val_max ! 描くカラーの最大値 !-- 以上, 引数の置き換え用変数 integer :: ipat, iws real :: dv ! カラーマップに対応する値の幅 integer :: cmap_min, cmap_max real :: tlev1, tlev2 logical :: rev, log_f, lfcart real :: white_min, black_max real :: RMISS integer :: white, black, ITON !-- 引数の置き換え用変数に置き換え val_min=val_int(1) val_max=val_int(2) !-- Dcl 側の undef 値セット CALL GLRGET( 'RMISS', RMISS ) CALL GLLSET( 'LMISS', .TRUE. ) !-- カラーマップチェンジのフラグ CALL SWLSET( 'LCMCH', .TRUE. ) if(present(col_tab))then map_num=col_tab else map_num=1 end if if(present(col_min))then cmap_min=col_min else cmap_min=14 end if if(present(col_max))then cmap_max=col_max else cmap_max=85 end if if(present(col_bg))then call SWpSET( 'LFGBG', col_bg ) end if if(present(reverse))then rev=reverse else rev=.false. end if if(present(min_tab))then white=min_tab else white=999 end if if(present(max_tab))then black=max_tab else black=1999 end if !-- back color is white flag. Ver.5.4.2 ! if(black==999.or.white==999)then ! call DclSetParm( 'LCLCNV' , .FALSE. ) ! end if if(black==999)then call SGIGET( 'IBGCLI', black ) black=black*1000+999 end if if(white==999)then call SGIGET( 'IBGCLI', white ) white=white*1000+999 end if call sgscmn(map_num) call UEITLV !-- 対数化するかのフラグ if(present(log_flag))then log_f=log_flag else log_f=.false. end if if(log_f.eqv..true.)then if(val_min<0.0.or.val_max<0.0)then write(*,*) "### ERROR ### (color_setting)" write(*,*) "val_min and val_max must be more than zero." write(*,*) "STOP" stop end if end if !-- val_max 以上を black で塗る TLEV1=RMISS TLEV2=val_min IPAT=white CALL DclSetShadeLevel( TLEV1, TLEV2, IPAT ) ! CALL UEQTLV( TLEV1, TLEV2, IPAT, color_num+2 ) ! write(*,*) TLEV1, TLEV2, IPAT if(log_f.eqv..true.)then dv=(log10(val_max)-log10(val_min))/color_num else dv=(val_max-val_min)/color_num end if if(rev.eqv..true.)then do k=1,color_num if(log_f.eqv..true.)then TLEV1=val_min*10.0**(dv*(k-1)) TLEV2=val_min*10.0**(dv*(k)) ! TLEV2=TLEV1*dv else TLEV1=val_min+(k-1)*dv TLEV2=TLEV1+dv end if IPAT=(cmap_min+int((color_num-k)*(real(cmap_max-cmap_min)/real(color_num-1))))*1000+999 CALL DclSetShadeLevel( TLEV1, TLEV2, IPAT ) ! CALL UEQTLV( TLEV1, TLEV2, IPAT, k ) ! write(*,*) TLEV1, TLEV2, IPAT end do else do k=1,color_num if(present(val_spec))then TLEV1=val_spec(k) TLEV2=val_spec(k+1) if(present(col_spec))then IPAT=col_spec(k) else IPAT=(cmap_min+int((k-1)*(real(cmap_max-cmap_min)/real(color_num-1))))*1000+999 end if else if(log_f.eqv..true.)then TLEV1=val_min*10.0**(dv*(k-1)) TLEV2=val_min*10.0**(dv*(k)) ! TLEV2=TLEV1*dv else TLEV1=val_min+(k-1)*dv TLEV2=TLEV1+dv end if IPAT=(cmap_min+int((k-1)*(real(cmap_max-cmap_min)/real(color_num-1))))*1000+999 end if CALL DclSetShadeLevel( TLEV1, TLEV2, IPAT ) ! CALL UEQTLV( TLEV1, TLEV2, IPAT, k ) ! write(*,*) TLEV1, TLEV2, IPAT end do end if TLEV1=val_max TLEV2=RMISS IPAT=black CALL DclSetShadeLevel( TLEV1, TLEV2, IPAT ) ! CALL UEQTLV( TLEV1, TLEV2, IPAT, color_num+1 ) write(*,*) TLEV1, TLEV2, IPAT end subroutine
Subroutine : | |||
val_type : | character(1), intent(in)
| ||
order_num : | character(1), intent(in)
| ||
form_name : | character(*), intent(out) | ||
frac_num : | character(1), intent(in), optional
|
数値ラベル用フォーマット作成ルーチン
subroutine format_make( val_type, order_num, form_name, frac_num ) ! 数値ラベル用フォーマット作成ルーチン implicit none character(1), intent(in) :: val_type ! ラベル化する変数の型 : f = 実数(オプションも指定する), i = 整数 character(1), intent(in) :: order_num ! 表示する桁数 character(1), intent(in), optional :: frac_num ! 実数指定のときのみ, 小数桁 character(*), intent(out) :: form_name select case(val_type) case('f') form_name='('//val_type//order_num//'.'//frac_num//')' form_name=trim(form_name) case('F') form_name='('//val_type//order_num//'.'//frac_num//')' form_name=trim(form_name) case('i') form_name='('//val_type//order_num//')' form_name=trim(form_name) case('I') form_name='('//val_type//order_num//')' form_name=trim(form_name) end select end subroutine format_make
Subroutine : | |||
ton_tab : | integer, intent(in), optional
| ||
val_int(2) : | real, intent(in)
| ||
nega_ton_tab : | integer, intent(in), optional
| ||
full_tone : | logical, intent(in), optional
|
color_setting のモノトーンバージョン トーンテーブルは白を抜いて 5 種類しかないので, val_min, val_max を強制的に 5 分割し, トーンを当てはめる. また, nega_ton_tab が指定されていれば, 10 分割する.
subroutine monotone_setting( ton_tab, val_int, nega_ton_tab, full_tone ) ! color_setting のモノトーンバージョン ! トーンテーブルは白を抜いて 5 種類しかないので, val_min, val_max を強制的に 5 分割し, トーンを当てはめる. ! また, nega_ton_tab が指定されていれば, 10 分割する. use dcl implicit none integer, intent(in), optional :: ton_tab ! dcl のトーンテーブル real, intent(in) :: val_int(2) ! 描くカラーの上下端 ! val_int(1)=val_min, val_int(2)=val_max integer, intent(in), optional :: nega_ton_tab ! トーンテーブルを 2 枚使うとき, 値の小さい領域に向かって濃くしていく場合に指定. このトーンを 0 から負方向に濃くしていく. logical, intent(in), optional :: full_tone ! 白を合わせると, 各トーンで 6 段階あるので, val_min, val_max の差を強制的に 6 分割してトーンを割り当てる. ただし, これをすると, トーンの境界値が切りのよい数値にならない時がある. 値は .true. で有効となる. !-- 以上, 引数 real :: val_min ! 描くカラーの最小値 real :: val_max ! 描くカラーの最大値 !-- 以上, 引数の置き換え用変数 integer :: map_num ! カラーマップのマップ番号指定 (optional 属性をつけること) integer :: i, j, k ! 作業用添字 integer :: ipat, itvtone, tone_mapping real :: dv ! カラーマップに対応する値の幅 integer :: cmap_min, cmap_max real :: tlev1, tlev2 !-- 引数の置き換え用変数に置き換え val_min=val_int(1) val_max=val_int(2) call UEITLV if(present(nega_ton_tab))then if(present(full_tone))then if(full_tone.eqv..true.)then itvtone=12 else itvtone=10 end if else itvtone=10 end if else if(present(full_tone))then if(full_tone.eqv..true.)then itvtone=6 else itvtone=5 end if else itvtone=5 end if end if dv=(val_max-val_min)/real(itvtone) if(itvtone==10.or.itvtone==12)then tone_mapping=itvtone/2 else tone_mapping=itvtone end if if(itvtone==tone_mapping)then do k=1,tone_mapping TLEV1=val_min+(k-1)*dv TLEV2=TLEV1+dv IPAT=100*ton_tab+k CALL UESTLV( TLEV1, TLEV2, IPAT ) end do else do k=1,tone_mapping TLEV1=0.5*(val_max+val_min)+(k-1)*dv TLEV2=TLEV1+dv IPAT=100*ton_tab+k CALL UESTLV( TLEV1, TLEV2, IPAT ) write(*,*) "tlev", tlev1, tlev2 end do do k=1,tone_mapping TLEV1=0.5*(val_max+val_min)-k*dv TLEV2=TLEV1+dv IPAT=100*nega_ton_tab+k CALL UESTLV( TLEV1, TLEV2, IPAT ) write(*,*) "bgtlev", tlev1, tlev2 end do end if end subroutine
Subroutine : | |||
nx : | integer, intent(in)
| ||
ny : | integer, intent(in)
| ||
nz : | integer, intent(in)
| ||
undef : | real, intent(in)
| ||
val(nx,ny,nz) : | real, intent(inout)
|
val の中の nan 値を undef に入れ替える. 引数の配列は 3 次元であるが, その前の要素数を 1 などに設定することで, 1, 2 次元の配列に対しても変換可能.
subroutine nan_val( nx, ny, nz, undef, val ) ! val の中の nan 値を undef に入れ替える. ! 引数の配列は 3 次元であるが, その前の要素数を 1 などに設定することで, ! 1, 2 次元の配列に対しても変換可能. implicit none integer, intent(in) :: nx ! 第 1 要素の要素数 integer, intent(in) :: ny ! 第 2 要素の要素数 integer, intent(in) :: nz ! 第 3 要素の要素数 real, intent(in) :: undef ! 代入する未定義値 real, intent(inout) :: val(nx,ny,nz) ! 変換する配列 integer :: i, j, k ! 作業用配列 do k=1,nz do j=1,ny do i=1,nx !! if(isnan(val(i,j,k)))then if(val(i,j,k)/=val(i,j,k))then ! isnan 関数がないことを考慮. val(i,j,k)=undef end if end do end do end do end subroutine
Subroutine : | |||
color_num : | integer, intent(in)
| ||
shade_int(2) : | real, intent(in)
| ||
vx_int(2) : | real, intent(in)
| ||
vy_int(2) : | real, intent(in)
| ||
form_types : | character(6), intent(in)
| ||
mono_log : | logical, intent(in), optional | ||
trigle : | character(1), intent(in), optional
| ||
tricmin : | integer, intent(in), optional
| ||
tricmax : | integer, intent(in), optional
| ||
trifact : | real, intent(in), optional
| ||
col_mem_num : | integer, intent(in), optional
| ||
log_flag : | logical, intent(in), optional
| ||
val_spec(color_num+1) : | real, intent(in), optional
| ||
dir : | character(1), intent(in), optional
| ||
title : | character(*), intent(in), optional
| ||
titles : | character(1), intent(in), optional
| ||
titlep : | real, intent(in), optional
|
トーンバーを自動生成する.
subroutine tone_bar( color_num, shade_int, vx_int, vy_int, form_types, mono_log, trigle, tricmin, tricmax, trifact, col_mem_num, log_flag, val_spec, dir, title, titles, titlep ) ! トーンバーを自動生成する. use dcl implicit none integer, intent(in) :: color_num ! 使用する色の数 real, intent(in) :: shade_int(2) ! カラーの上下端 ! shade_int(1)=shade_min, shade_int(2)=shade_max real, intent(in) :: vx_int(2) ! ビューポートの x 方向の両端 ! vx_int(1)=vx_min, vx_int(2)=vx_max real, intent(in) :: vy_int(2) ! ビューポートの y 方向の両端 ! vy_int(1)=vy_min, vy_int(2)=vy_max character(6), intent(in) :: form_types ! ラベルフォーマット logical, intent(in), optional :: mono_log character(1), intent(in), optional :: trigle ! grads 風な三角形を出すかどうか ! [u] = 上だけ, [d] = 下だけ, [a] = 両方, デフォルトでは描かない integer, intent(in), optional :: tricmin ! 下端三角に描くカラーマップ番号 5 桁 integer, intent(in), optional :: tricmax ! 上端三角に描くカラーマップ番号 5 桁 ! これらの色は設定されていなければ, color_setting でセットされている色を使うようにする. real, intent(in), optional :: trifact ! 三角形の高さ (横辺と同じ長さを 1 としてその factor 倍する比率. デフォルトは 1.) integer, intent(in), optional :: col_mem_num ! トーンバーの目盛の数 logical, intent(in), optional :: log_flag ! スケールを対数化するか. デフォルトは .false. real, intent(in), optional :: val_spec(color_num+1) ! カラーに対応する数値を陽的に指定する. character(1), intent(in), optional :: dir ! トーンバーの向き ! 'y' = 横向き, 't' = 縦向き. ! デフォルト = 't'. character(*), intent(in), optional :: title ! カラーバーに描くタイトル. character(1), intent(in), optional :: titles ! タイトルを描く側. ! 't', 'b', 'r', 'l' = 上, 下, 右, 左 ! デフォルトは 縦の場合は右, 横の場合は下. real, intent(in), optional :: titlep ! タイトルを描く位置. ! dcl のタイトル位置の値と同じ. !-- 以上, 引数 real :: shade_min ! 最小値 real :: shade_max ! 最大値 real :: vx_min ! ビューポートの x 方向の最小値 real :: vx_max ! ビューポートの x 方向の最大値 real :: vy_min ! ビューポートの y 方向の最小値 real :: vy_max ! ビューポートの y 方向の最大値 !-- 以上, 引数の置き換え用変数 real, parameter :: RMISS=999.0 integer :: k real :: pi(2,color_num+1), pir(color_num+1,2) real :: dp, dp_mem real :: coldim1(color_num+1), coldim2(color_num/2+1) real, allocatable :: col_mem_dim1(:), col_mem_dim2(:) logical :: monoto ! モノトーンの処理 real, dimension(4) :: triux, triuy, tridx, tridy real :: factoru, clev1, clev2 integer :: tricmin_num, tricmax_num ! 多角形領域の指定では, 三角形の頂点位置座標がわかればよいので, ! 各座標配列は 3 つ必要 real :: vpx_min, vpx_max, vpy_min, vpy_max ! 実際にとる viewport, trigle 用バッファ. real :: bart logical :: log_f character(1) :: direction, barp call DclSetParm( 'GRAPH:LCLIP', .false. ) !-- 引数の置き換え用変数に置き換え shade_min=shade_int(1) shade_max=shade_int(2) vx_min=vx_int(1) vx_max=vx_int(2) vy_min=vy_int(1) vy_max=vy_int(2) !-- オプションの処理 if(present(mono_log))then monoto=mono_log else monoto=.false. end if if(present(dir))then direction(1:1)=dir(1:1) else direction(1:1)='t' end if if(present(trigle))then if(present(trifact))then factoru=trifact else factoru=1.0 end if if(present(tricmin))then tricmin_num=tricmin else CALL DclGetShadeLevel( 1, clev1, clev2, tricmin_num ) write(*,*) "### downer color is", tricmin_num end if if(present(tricmax))then tricmax_num=tricmax else CALL DclGetShadeLevel( color_num+2, clev1, clev2, tricmax_num ) write(*,*) "### upper color is", tricmax_num end if if(direction=='t')then select case(trigle) case('a') triux(1)=vx_min triux(2)=(vx_max+vx_min)*0.5 triux(3)=vx_max triux(4)=triux(1) triuy(1)=vy_max-factoru*(vx_max-vx_min) triuy(2)=vy_max triuy(3)=triuy(1) triuy(4)=triuy(1) tridx=triux tridy(1)=vy_min+factoru*(vx_max-vx_min) tridy(2)=vy_min tridy(3)=tridy(1) tridy(4)=tridy(1) vpy_min=tridy(1) vpy_max=triuy(1) case('u') triux(1)=vx_min triux(2)=(vx_max+vx_min)*0.5 triux(3)=vx_max triux(4)=triux(1) triuy(1)=vy_max-factoru*(vx_max-vx_min) triuy(2)=vy_max triuy(3)=triuy(1) triuy(4)=triuy(1) vpy_min=vy_min vpy_max=triuy(1) case('d') tridx(1)=vx_min tridx(2)=(vx_max+vx_min)*0.5 tridx(3)=vx_max tridx(4)=tridx(1) tridy(1)=vy_min+factoru*(vx_max-vx_min) tridy(2)=vy_min tridy(3)=tridy(1) tridy(4)=tridy(1) vpy_min=tridy(1) vpy_max=vy_max case default vpy_min=vy_min vpy_max=vy_max end select vpx_min=vx_min vpx_max=vx_max else select case(trigle) case('a') triuy(1)=vy_min triuy(2)=(vy_max+vy_min)*0.5 triuy(3)=vy_max triuy(4)=triuy(1) triux(1)=vx_max-factoru*(vy_max-vy_min) triux(2)=vx_max triux(3)=triux(1) triux(4)=triux(1) tridy=triuy tridx(1)=vx_min+factoru*(vy_max-vy_min) tridx(2)=vx_min tridx(3)=tridx(1) tridx(4)=tridx(1) vpx_min=tridx(1) vpx_max=triux(1) case('u') triuy(1)=vy_min triuy(2)=(vy_max+vy_min)*0.5 triuy(3)=vy_max triuy(4)=triuy(1) triux(1)=vx_max-factoru*(vy_max-vy_min) triux(2)=vx_max triux(3)=triux(1) triux(4)=triux(1) vpx_min=vx_min vpx_max=triux(1) case('d') tridy(1)=vy_min tridy(2)=(vy_max+vy_min)*0.5 tridy(3)=vy_max tridy(4)=tridy(1) tridx(1)=vx_min+factoru*(vy_max-vy_min) tridx(2)=vx_min tridx(3)=tridx(1) tridx(4)=tridx(1) vpx_min=tridx(1) vpx_max=vx_max case default vpx_min=vx_min vpx_max=vx_max end select vpy_min=vy_min vpy_max=vy_max end if else vpx_min=vx_min vpx_max=vx_max vpy_min=vy_min vpy_max=vy_max end if if(present(log_flag))then log_f=log_flag else log_f=.false. end if if(present(dir))then direction=dir(1:1) else direction='t' end if if(present(titles))then barp=titles(1:1) else if(direction=='t')then barp='l' else barp='b' end if end if if(present(titlep))then bart=titlep else bart=0.0 end if !-- 処理ここまで call DclNewFig if(direction=='t')then call DclSetWindow( 0.0, 1.0, shade_min, shade_max ) else call DclSetWindow( shade_min, shade_max, 0.0, 1.0 ) end if call DclSetViewPort( vpx_min, vpx_max, vpy_min, vpy_max ) if(log_f.eqv..true.)then if(direction=='t')then call GRSTRN(2) ! 縦の場合は y 軸対数 else call GRSTRN(3) ! 横の場合は x 軸対数 end if !-- 配色の設定 dp = (log10(shade_max)-log10(shade_min))/color_num do k=1,color_num+1 PI(1,K) = shade_min * 10.0**(DP*(K-1)) PI(2,K) = PI(1,K) end do else call GRSTRN(1) !-- 配色の設定 dp = (shade_max-shade_min)/color_num do k=1,color_num+1 PI(1,K) = shade_min + DP * (K-1) PI(2,K) = PI(1,K) end do end if if(present(val_spec))then do k=1,color_num+1 PI(1,k)=val_spec(k) PI(2,k)=val_spec(k) end do end if call DclSetTransFunction if(direction=='y')then ! 横の場合, 配列を入れ替える PIr(:,1)=PI(1,:) PIr(:,2)=PI(2,:) end if if(direction=='t')then call DclSetXGrid( (/0.0,1.0/) ) call DclSetYGrid( PI(1,:) ) else call DclSetXGrid( PI(1,:) ) call DclSetYGrid( (/0.0,1.0/) ) end if if(monoto.eqv..true.)then call DclSetParm('ENABLE_SOFTFILL',.true.) if(direction=='t')then call DclShadeContour( PI ) else call DclShadeContour( PIr ) end if else call DclSetParm('ENABLE_SOFTFILL',.false.) if(direction=='t')then call DclShadeContourEx( PI ) else call DclShadeContourEx( PIr ) end if end if CALL SLPVPR( 3 ) CALL UZLSET( 'LABELYR', .TRUE. ) CALL UZLSET( 'LABELYL', .FALSE. ) CALL UYSFMT( form_types ) !-- トーンの目盛を描くための配列を調整. if(present(col_mem_num))then allocate(col_mem_dim1(col_mem_num+1)) allocate(col_mem_dim2(col_mem_num/2+1)) if(log_f.eqv..true.)then dp_mem=(log10(shade_max)-log10(shade_min))/col_mem_num do k=1,col_mem_num+1 col_mem_dim1(k)=shade_min*10.0**(dp_mem*(k-1)) end do do k=1,col_mem_num/2+1 col_mem_dim2(k)=shade_min*10.0**(dp_mem*(2*(k-1))) end do else dp_mem=(shade_max-shade_min)/col_mem_num do k=1,col_mem_num+1 col_mem_dim1(k)=shade_min+(k-1)*dp_mem end do do k=1,col_mem_num/2+1 col_mem_dim2(k)=shade_min+2*(k-1)*dp_mem end do end if if(direction=='t')then CALL UYAXNM( 'R', col_mem_dim1, col_mem_num+1, col_mem_dim2, col_mem_num/2+1 ) CALL UYAXNM( 'L', col_mem_dim1, col_mem_num+1, col_mem_dim2, col_mem_num/2+1 ) else CALL UXAXNM( 'T', col_mem_dim1, col_mem_num+1, col_mem_dim2, col_mem_num/2+1 ) CALL UXAXNM( 'B', col_mem_dim1, col_mem_num+1, col_mem_dim2, col_mem_num/2+1 ) end if deallocate(col_mem_dim1) deallocate(col_mem_dim2) else if(present(val_spec))then do k=1,color_num+1 coldim1(k)=val_spec(k) end do do k=1,color_num/2+1 coldim2(k)=val_spec(2*k-1) end do else do k=1,color_num+1 coldim1(k)=PI(1,k) end do do k=1,color_num/2+1 coldim2(k)=PI(1,2*k-1) end do end if if(direction=='t')then CALL UYAXNM( 'R', coldim1, color_num+1, coldim2, color_num/2+1 ) CALL UYAXNM( 'L', coldim1, color_num+1, coldim2, color_num/2+1 ) else CALL UXAXNM( 'T', coldim1, color_num+1, coldim2, color_num/2+1 ) CALL UXAXNM( 'B', coldim1, color_num+1, coldim2, color_num/2+1 ) end if end if !-- 実際に三角形領域を描く if(present(trigle))then select case(trigle) case('a') call DclShadeRegionNormalized( triux, triuy, tricmax_num ) call DclShadeRegionNormalized( tridx, tridy, tricmin_num ) call DclDrawLineNormalized( triux, triuy, index=13 ) call DclDrawLineNormalized( tridx, tridy, index=13 ) case('u') call DclShadeRegionNormalized( triux, triuy, tricmax_num ) call DclDrawLineNormalized( triux, triuy, index=13 ) case('d') call DclShadeRegionNormalized( tridx, tridy, tricmin_num ) call DclDrawLineNormalized( tridx, tridy, index=13 ) end select write(*,*) "Map case check, triux, triuy, tridx, tridy" write(*,*) triux, triuy, tridx, tridy end if if(present(title))then call DclDrawTitle( barp, trim(title), bart ) end if ! CALL UYAXDV( 'R', (shade_max-shade_min)/real(color_num), (shade_max-shade_min)/real(0.5*color_num) ) ! CALL UYAXDV( 'L', (shade_max-shade_min)/real(color_num), (shade_max-shade_min)/real(0.5*color_num) ) end subroutine
Subroutine : | |||
nx : | integer, intent(in)
| ||
ny : | integer, intent(in)
| ||
nz : | integer, intent(in)
| ||
val(nx,ny,nz) : | real, intent(inout)
|
CReSS の未定義値を Dcl の未定義値に変換するルーチン 引数の配列は 3 次元であるが, その前の要素数を 1 などに設定することで, 1, 2 次元の配列に対しても変換可能.
subroutine undef_CReSS2Dcl( nx, ny, nz, val ) ! CReSS の未定義値を Dcl の未定義値に変換するルーチン ! 引数の配列は 3 次元であるが, その前の要素数を 1 などに設定することで, ! 1, 2 次元の配列に対しても変換可能. use dcl implicit none integer, intent(in) :: nx ! 第 1 要素の要素数 integer, intent(in) :: ny ! 第 2 要素の要素数 integer, intent(in) :: nz ! 第 3 要素の要素数 real, intent(inout) :: val(nx,ny,nz) ! 変換する配列 integer :: i, j, k ! 作業用配列 real :: RMISS, undef ! 各未定義値 !-- 欠損値処理 --- !-- Dcl 側の undef 値セット CALL GLRGET( 'RMISS', RMISS ) CALL GLLSET( 'LMISS', .TRUE. ) !-- CReSS 側の undef 値セット call undef_get( undef ) !write(*,*) "undef=", undef do k=1,nz do j=1,ny do i=1,nx if(val(i,j,k)/=val(i,j,k))then val(i,j,k)=-999.0 else if(val(i,j,k)==undef)then val(i,j,k)=-999.0 ! val(i,j,k)=RMISS end if end do end do end do end subroutine
Subroutine : | |||
undef : | real, intent(inout)
|
CReSS のデフォルトの未定義値を取得するルーチン
subroutine undef_get( undef ) ! CReSS のデフォルトの未定義値を取得するルーチン implicit none real, intent(inout) :: undef ! 未定義値 undef = -1.0e+35 end subroutine
Subroutine : | |
c_val(:) : | real, intent(in) |
val : | real, intent(in) |
idx : | integer, intent(inout) |
val が c_val のどの範囲に存在するかを求める.
subroutine val_estimate( c_val, val, idx ) ! val が c_val のどの範囲に存在するかを求める. implicit none real, intent(in) :: c_val(:) real, intent(in) :: val integer, intent(inout) :: idx integer :: i idx=0 do i=1,size(c_val) if(c_val(i)<=val)then idx=i else exit end if end do end subroutine
Subroutine : | |||
vs : | real, intent(in)
| ||
vd : | real, intent(in)
| ||
vox : | real, intent(in)
| ||
voy : | real, intent(in)
|
V 座標系で 1 つの矢羽を描く. 風速 vs (単位 knot) と風向 vd (単位 deg) で 現在, デカルト座標系のみ対応. vd は北を 0 (360) deg として時計回りにとる. 方向は風が「吹いてくる」方向. つまり, 北風なら, vd = 0.0. DCL への移植を考慮して階層構造で表現する. このルーチンを直接使用することは多分ないはず.
subroutine wverbd( vs, vd, vox, voy ) ! V 座標系で 1 つの矢羽を描く. ! 風速 vs (単位 knot) と風向 vd (単位 deg) で ! 現在, デカルト座標系のみ対応. ! vd は北を 0 (360) deg として時計回りにとる. ! 方向は風が「吹いてくる」方向. ! つまり, 北風なら, vd = 0.0. ! DCL への移植を考慮して階層構造で表現する. ! このルーチンを直接使用することは多分ないはず. implicit none real, intent(in) :: vs ! wind speed [knot] real, intent(in) :: vd ! wind direction [deg] real, intent(in) :: vox ! the origin of x-direction [V-coord.] real, intent(in) :: voy ! the origin of y-direction [V-coord.] real, parameter :: vfact=0.05, pi=3.14159265, verbangle=120.0 real, parameter, dimension(4) :: verbel=(/2.0, 5.0, 10.0, 50.0 /) integer :: i, counter, vounter integer, dimension(4) :: iblev logical, parameter :: verbflag=.true. ! 旗 or 複数羽 (NOTE "counter") real :: vx, vy, vp, vinterval, vwidth, coe, verbi, vcoe real, dimension(30) :: vxtraj, vytraj real, dimension(10) :: vvxtraj, vvytraj iblev=(/0,0,0,0/) vinterval=0.5*vfact*0.2 vwidth=0.5*vfact coe=pi/180.0 verbi=180.0-verbangle vcoe=(vd+verbi)*coe vx=sin(vd*coe)*vfact vy=cos(vd*coe)*vfact vp=vs !-- 何本, 何種類の羽を描くか決定 if(verbflag.eqv..true.)then do while (vp>verbel(4)) iblev(4)=iblev(4)+1 vp=vp-verbel(4) end do end if do while (vp>verbel(3)) iblev(3)=iblev(3)+1 vp=vp-verbel(3) end do do while (vp>verbel(2)) iblev(2)=iblev(2)+1 vp=vp-verbel(2) end do !-- 描く線の軌跡を計算. vxtraj(1)=vox vytraj(1)=voy vxtraj(2)=vxtraj(1)+vx vytraj(2)=vytraj(1)+vy vvxtraj(1)=vxtraj(2)+vx vvytraj(1)=vytraj(2)+vy counter=2 vounter=1 if(iblev(4)>0)then do i=1,iblev(4) counter=counter+1 vounter=vounter+1 vxtraj(counter)=vxtraj(counter-1)+sin(vcoe)*vwidth vytraj(counter)=vytraj(counter-1)+cos(vcoe)*vwidth vvxtraj(vounter)=vvxtraj(vounter-1)+sin(vcoe)*vwidth vvytraj(vounter)=vvytraj(vounter-1)+cos(vcoe)*vwidth counter=counter+1 vounter=vounter+1 vxtraj(counter)=vxtraj(counter-2)-sin(vd*coe)*vinterval vytraj(counter)=vytraj(counter-2)-cos(vd*coe)*vinterval vvxtraj(vounter)=vvxtraj(vounter-2)-sin(vd*coe)*vinterval vvytraj(vounter)=vvytraj(vounter-2)-cos(vd*coe)*vinterval vounter=vounter+1 vvxtraj(vounter)=vvxtraj(vounter-3) vvytraj(vounter)=vvytraj(vounter-3) end do end if if(iblev(3)>0)then do i=1,iblev(3) counter=counter+1 vxtraj(counter)=vxtraj(counter-1)+sin(vcoe)*vwidth vytraj(counter)=vytraj(counter-1)+cos(vcoe)*vwidth counter=counter+1 vxtraj(counter)=vxtraj(counter-2) vytraj(counter)=vytraj(counter-2) counter=counter+1 vxtraj(counter)=vxtraj(counter-1)-sin(vd*coe)*vinterval vytraj(counter)=vytraj(counter-1)-cos(vd*coe)*vinterval end do end if if(iblev(2)>0)then do i=1,iblev(2) counter=counter+1 if(counter==3)then vxtraj(counter)=vxtraj(counter-1)-sin(vd*coe)*vinterval vytraj(counter)=vytraj(counter-1)-cos(vd*coe)*vinterval counter=counter+1 vxtraj(counter)=vxtraj(counter-1)+sin(vcoe)*vwidth*0.5 vytraj(counter)=vytraj(counter-1)+cos(vcoe)*vwidth*0.5 else vxtraj(counter)=vxtraj(counter-1)+sin(vcoe)*vwidth*0.5 vytraj(counter)=vytraj(counter-1)+cos(vcoe)*vwidth*0.5 end if end do end if if(iblev(4)>0)then call SGTNZV( vounter, vvxtraj(1:vounter), vvytraj(1:vounter), 999 ) end if call SGPLV( counter, vxtraj(1:counter), vytraj(1:counter) ) write(*,*) "check", vounter, vvxtraj(1:vounter), vvytraj(1:vounter) end subroutine wverbd
Subroutine : | |||
ux : | real, intent(in)
| ||
uy : | real, intent(in)
| ||
vx : | real, intent(in)
| ||
vy : | real, intent(in)
|
— For Cartesian
subroutine wvrbxy( ux, uy, vx, vy ) !-- For Cartesian implicit none real, intent(in) :: ux ! wind component of x-coord [knot] real, intent(in) :: uy ! wind component of y-coord [knot] real, intent(in) :: vx ! the origin of x [vcoord] real, intent(in) :: vy ! the origin of y [vcoord] real, parameter :: pi=3.141592653 real :: vs, vd, rcoe rcoe=180.0/pi vs=sqrt(ux*ux+uy*uy) if(vs/=0.0)then if(uy==0.0)then vd=acos(ux/vs)*rcoe+180.0 else vd=asin(uy/vs)*rcoe+180.0 end if call wverbd( vs, vd, vx, vy ) end if end subroutine wvrbxy