SUBROUTINE EPS_deformation
USE PrecTypes
USE GlobalData
USE EPS_sharedModule
IMPLICIT NONE
!
! NAME: EPS_deformation
! PARENT: EPSoutput
! STATUS: Current
! OWNER: Toshiro Matsumoto
! TEXT: Output the deformation diagram to an EPS (Encapsulated PostScript) 将变形图输出到EPS（Encapsulated PostScript）文件
! file.
! REVISION DATE: 16-Jul-2009
!
! プログラム名: EPS_deformation
! 親プログラム: EPSoutput
! 状 態: 開発中
! 所有者: 松本 敏郎
! 説 明: 変形図をEPS形式 (Encapsulated PostScript) のファイルとして出力．
! 修正日: 16-Jul-2009
!
INTEGER :: i,j,k,ii,jj
INTEGER(i4b) :: p1, p2, p3, p4, pp1, pp2
CHARACTER(len=50) :: chr,chr1,chr2,chr3,chr4
REAL(dp) :: annotationAreaWidth=130.0, dy=30.0
REAL(dp) :: xb, yb
! 変形図用のファイルの出力
OPEN (UNIT=ddev, FILE=deformDataFileName, STATUS='UNKNOWN', ACTION='WRITE', ERR=100)
WRITE(ddev,'(I6)') -pcode
WRITE(ddev,'(I6)') node
DO i=1,node
WRITE(ddev,'(I7,2(2X,E15.8))') i, x(i), y(i)
END DO
WRITE(ddev,'(I5)') ne
DO i=1,ne
WRITE(ddev,'(I7,1X,I3,4(1X,I7))') i, etype(i), (elm(i,j),j=1,etype(i))
END DO
DO i=1,node
WRITE(ddev,'(I5,2X,2(E15.8,1X))') i,(u(i,j),j=1,dir)
END DO
CLOSE(ddev)
!
DO i=1,ne
DO j=1,etype(i)
eline(i,j,3) = 0
END DO
END DO
! 出力用のファイルのオープン
OPEN (UNIT=edev, FILE=dispFileName, STATUS='UNKNOWN', ACTION='WRITE', ERR=100)
! バウンディングボックス
boundLBx = 0.0_DP
boundLBy = 0.0_DP
boundTRx = boxWidth + annotationAreaWidth
boundTRy = boxHeight
! EPSヘッダとマクロコマンドの出力
chr1=''
chr2=''
chr3=''
chr4=''
WRITE(edev,'(A)') '%!PS-Adobe-3.1 EPSF-3.0'
WRITE(chr1,*) boundLBx
WRITE(chr2,*) boundLBy
WRITE(chr3,*) boundTRx
WRITE(chr4,*) boundTRy
WRITE(edev,'(A)') '%%BoundingBox: ' // trim(adjustl(chr1)) // ' ' // &
& trim(adjustl(chr2)) // ' ' // trim(adjustl(chr3)) // ' ' // trim(adjustl(chr4))
WRITE(edev,'(A)') '%%Title: displacement.eps'
WRITE(edev,'(A)') '%%Creator: Feritas'
WRITE(edev,'(A)') '%%DocumentNeededResources: font Times-Roman'
WRITE(edev,'(A)') '%%DocumentFonts: Times-Roman'
WRITE(edev,'(A)') '%%Copyright: Copyright (C) 2009 Toshiro Matsumoto. All Rights Reserved.'
WRITE(edev,'(A)') '%%EndComments'
WRITE(edev,'(A)') '/S {stroke} def'
WRITE(edev,'(A)') '/NP {newpath} def'
WRITE(edev,'(A)') '/SL {setlinewidth} def'
WRITE(edev,'(A)') '/C {setrgbcolor} def'
WRITE(edev,'(A)') '/SG {setgray} def'
WRITE(edev,'(A)') '/MT {moveto} def'
WRITE(edev,'(A)') '/LT {lineto} def'
WRITE(edev,'(A)') '/RT {rlineto} def'
WRITE(edev,'(A)') '/A {arc} def'
WRITE(edev,'(A)') '/F {fill} def'
WRITE(edev,'(A)') '/LJ {setlinejoin} def'
WRITE(edev,'(A)') '/CL {closepath} def'
WRITE(edev,'(A)') '/SP {showpage} def'
WRITE(edev,'(A)') '/SW {show} def'
WRITE(edev,'(A,1X,I2,1X,A)') '/DC { 0 360 A S } def' ! 円の描画マクロ
WRITE(edev,'(A,1X,I2,1X,A)') '/FC { 0 360 A F } def' ! 円塗りつぶしの描画マクロ
WRITE(edev,'(1X,I2,1X,A)') linejoin, 'LJ'
! 変形前の要素の描画
IF (dispMeshShowSwitch == 1) THEN
! まず塗りつぶす
WRITE(edev,'(A)') 'NP'
DO i=1,ne
p1 = elm(i,1)
p2 = elm(i,2)
p3 = elm(i,3)
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') px(p1),py(p1),'MT'
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') px(p2),py(p2),'LT'
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') px(p3),py(p3),'LT'
if (etype(i) == 4) then
p4 = elm(i,4)
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') px(p4),py(p4),'LT'
end if
WRITE(edev,'(A)') 'CL'
WRITE(edev,'(3(F6.3,1X),A)') dispElmColor(1),dispElmColor(2),dispElmColor(3),'C'
WRITE(edev,'(A)') 'F'
end do
WRITE(edev,'(A)') 'S'
! 変形前の要素の線を描画する
DO i=1,ne
DO j=1,etype(i)
eline(i,j,3) = 0
END DO
END DO
WRITE(edev,'(A)') 'NP'
WRITE(edev,'(F6.3,1X,A)') dispMeshLineThickness, 'SL' ! 線幅
WRITE(edev,'(3(F6.3,1X),A)') (dispMeshLineColor(k),k=1,3), 'C'
DO i=1,ne
DO j=1,etype(i)
p1 = elm(i,j)
IF (j<etype(i)) THEN
p2 = elm(i,j+1)
ELSE
p2 = elm(i,1)
END IF
IF (eline(i,j,3)==0) THEN
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') px(p1), py(p1), 'MT'
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') px(p2), py(p2), 'LT'
eline(i,j,3) = 1
SEARCH2: DO ii=1,ne
DO jj=1,etype(ii)
pp1 = elm(ii,jj)
IF (jj<etype(ii)) THEN
pp2 = elm(ii,jj+1)
ELSE
pp2 = elm(ii,1)
END IF
IF (pp1==p2 .AND. pp2==p1) THEN
eline(ii,jj,3) = 1
EXIT SEARCH2
END IF
END DO
END DO SEARCH2
END IF
END DO
END DO
WRITE(edev,'(A)') 'S'
END IF
! 変形後の形を描画
DO i=1,ne
DO j=1,etype(i)
eline(i,j,3) = 0
END DO
END DO
WRITE(edev,'(F6.3,1X,A)') dispLineThickness, 'SL' ! 線幅
WRITE(edev,'(3(F6.3,1X),A)') (dispLineColor(k),k=1,3), 'C'
DO i=1,ne
DO j=1,etype(i)
p1 = elm(i,j)
IF (j<etype(i)) THEN
p2 = elm(i,j+1)
ELSE
p2 = elm(i,1)
END IF
IF (eline(i,j,3)==0) THEN
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') pux(p1), puy(p1), 'MT'
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') pux(p2), puy(p2), 'LT'
eline(i,j,3) = 1
SEARCH3: DO ii=1,ne
DO jj=1,etype(ii)
pp1 = elm(ii,jj)
IF (jj<etype(ii)) THEN
pp2 = elm(ii,jj+1)
ELSE
pp2 = elm(ii,1)
END IF
IF (pp1==p2 .AND. pp2==p1) THEN
eline(ii,jj,3) = 1
EXIT SEARCH3
END IF
END DO
END DO SEARCH3
END IF
END DO
END DO
WRITE(edev,'(A)') 'S'
! 最大値・最小値の表示
xb = boxWidth
yb = yMargin + oy + scaledHeight - 20.0*point
dy = dy * point
WRITE(edev,'(A)') '/Helvetica findfont 7 scalefont setfont'
WRITE(edev,'(A)') '0.0 SG'
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') xb, yb,'MT'
WRITE(edev,'(A,E11.4,A)') '(Rate of magnification: (x)',uscale,') SW'
yb = yb - 1.5*dy
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') xb, yb,'MT'
WRITE(edev,'(A,E11.4,A)') '(Max.Abs.u=',umax,') SW'
WRITE(edev,'(E11.4,1X,E11.4,1X,A)') xb, yb-dy,'MT'
WRITE(edev,'(A,E11.4,A)') '(Max.Abs.v=',vmax,') SW'
WRITE(edev,'(A)') 'SP'
CLOSE(edev)
! 正常終了時はここでリターン
RETURN
! エラー発生時の処理
! ここにジャンプしたときはファイルオープン時にエラーが発生
100 CONTINUE
! エラーレポートの出力
WRITE(*,'(A)') 'Error in opening output file'
WRITE(*,'(A,A)') 'Error, cannot open file: ', dispFileName
STOP
END SUBROUTINE EPS_deformation