Embedded Files
7-FEM-Plane-Stress-Analysis(PSA)（平面応力解析）
7-FEM-Plane-Stress-Analysis(PSA)（平面応力解析）
7－FEM-PSA
PSA（Plane Stress Analysis)（平面応力解析）
7－0．有孔平板の問題
7－1．FEM-PSA-Solver-FORTRAN（ソルバ）
7－2．FEM-PSA-pre-processor-FORTRAN（プリ）
7－3．FEM-PSA-Excel-VBA（post processor)（ポスト）
7－3－0．mesh、node number、element number、numberは、
6－FEM-HCA-unsteadyのものが使えます。
7－3－1．Excel-VBA-σX-conta-fig（σXコンタ図）
7－3－2．Excel-VBA-σY-conta-fig（σYコンタ図）
7－3－3．Excel-VBA-σ1-conta-fig（σ1コンタ図）
7－3－4．Excel-VBA-σ2-conta-fig（σ2コンタ図）
7－3－5．Excel-VBA-displacement（変位図）
7－4．FEM PSA 理論
7－5．有孔平板理論解
ここに出ているプログラムをコピー＆ペイスト
すると、1行おきにブランク行が出来るが、
構わず、******.forに保存して、コンパイル、
実行出来ることを確認しました。
7－0．有孔平板の問題
7－0．有孔平板の問題
有孔平板（FEM）の課題と理論解.docx7－1． FEM-PSA-SOLVER（FORTRAN)
7－1． FEM-PSA-SOLVER（FORTRAN)
7－1．FEM-PSA-solver
solverのプログラムリストを掲載します。
5－FDM、6－FEM-HCA、同様にMinGWが必要です。
（以下、Cの書いてある所から下をコピーしてTeraPadに
貼り付け、FEM-PSA-solver.forという名称で保存）
ここからプログラムです。
C program file name FEM-PSA-solver.for
C
C compile方法
C >gfortran FEM-PSA-solver.for -o FEM-PSA-solber.exe
C
C 実行方法
C >FEM-PSA-solver
C input file name ?
C FEM-PSA-input-data.txt
C ・
C ・
C
C ここでpostファイルが作られるので、Excel-VBA-σY-contaなどで
C 処理してください。
C
C
C------------------------------------------------------------------
C 変数名
C X(I) : 節点番号IのX座標
C Y(I) : 節点番号IのY座標
C NELM(I,J) : 要素番号Iの構成節点番号（J=1,2,3)
C KMAT(I,J) : 全体剛性マトリックス
C D(3,3) : Dマトリックス
C B(3,6) : Bマトリックス
C FX(I) : 節点番号IのX方向の外力
C FY(I) : 節点番号IのY方向の外力
C IUO(I) : 節点番号IのX方向の拘束（1:拘束、0=自由）
C IVO(I) : 節点番号IのY方向の拘束（1:拘束、0=自由）
C S : 三角形要素の面積
C EK(6,6) : 要素剛性マトリックス
C E(I) : 要素番号Iのヤング率
C ANU(I) : 要素番号Iのポアソン比
C NALL : 全節点数 （最大２５００節点まで）
C IEALL : 全要素数 （最大５０００要素まで）
C SENERGY(I) : 要素番号Iのひずみエネルギー
C SIGM(1) : SIGMA X (STRESS X)
C SIGM(2) : SIGMA Y (STRESS Y)
C SIGM(3) : TAUXY
C SMAINS(1) : SIGMA-1
C SMAINS(2) : SIGMA-2
C SMAINS(3) : PHI
C SIGM_ELEM(I,6): I:Element No.
C : 1:SIGMA-X 2:SIGMA-Y 3:TAUXY 4:SIGMA-1 5:SIGMA-2
C : 6:PHI
C SIGM_NODE(I,6): I:Node No.
C : 1:SIGMA-X 2:SIGMA-Y 3:TAUXY 4:SIGMA-1 5:SIGMA-2
C : 6:PHI
C : SIGM_NODE(I,J)=approximate(arithmetic mean)
C U(II) : 変位
C （U：（I-1)*2+1 V:I*2 I:NODE NO.)
C-------------------------------------------------------------------
C Main program
C
C
REAL KMAT
COMMON /AAA/KMAT(5000,5001)
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
COMMON /EEE/FX(5000),FY(5000),IUO(5000),IVO(5000)
COMMON /FFF/IEALL,NALL,IBC,NBC
COMMON /GGG/SIGM_ELEM(5000,6),SIGM_NODE(5000,6)
CHARACTER FLOUT*80,FLIN*80,INDEX*4,FLPOST*80
DO 10 I=1,5000
U(I)=0.0
E(I)=0.0
ANU(I)=0.0
X(I)=0.0
Y(I)=0.0
FX(I)=0.0
FY(I)=0.0
IUO(I)=0
IVO(I)=0
DO 12 J=1,5001
KMAT(I,J)=0.0
12 CONTINUE
10 CONTINUE
C 入力データの読み込み
CALL DATARD
C 入力データの書き出し
CALL DATAWR
C 計算
C （剛性マトリックスを作成し、境界条件を設定、方程式を解く）
CALL CALUCL
C 結果の出力
CALL OUTWR
STOP
END
C------------------------------------------------------------------
C INPUT DATA READ
C
SUBROUTINE DATARD
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
COMMON /EEE/FX(5000),FY(5000),IUO(5000),IVO(5000)
COMMON /FFF/IEALL,NALL,IBC,NBC
CHARACTER FLIN*80,INDEX*4
WRITE(6,*)"INPUT FILE NAME?"
READ(5,100)FLIN
100 FORMAT(A)
OPEN(UNIT=2,FILE=FLIN,STATUS='OLD')
READ(2,*)NALL,IEALL
READ(2,1500)INDEX
1500 FORMAT(A4)
DO 10 I=1,NALL
READ(2,*)J,X(J),Y(J),FX(J),FY(J),IUO(J),IVO(J)
10 CONTINUE
READ(2,1500)INDEX
DO 20 I=1,IEALL
READ(2,*)J,NELM(J,1),NELM(J,2),NELM(J,3),E(J),ANU(J),H(J)
20 CONTINUE
CLOSE(2)
RETURN
END
C-----------------------------------------------------------------
C INPUT DATA WRITE
C
SUBROUTINE DATAWR
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
COMMON /EEE/FX(5000),FY(5000),IUO(5000),IVO(5000)
COMMON /FFF/IEALL,NALL,IBC,NBC
CHARACTER FLOUT*80,FLPOST*80
WRITE(6,*)"OUTPUT FILE NAME"
READ(5,100)FLOUT
100 FORMAT(A)
OPEN(UNIT=3,FILE=FLOUT,STATUS='NEW')
WRITE(6,*)'INPUT POST FILE NAME'
READ(5,100)FLPOST
OPEN(UNIT=8,FILE=FLPOST,STATUS='NEW')
WRITE(3,1100)
1100 FORMAT(1H ,'PLANE STRESS BY FEM'//
&1H ,'INPUT DATA'//1H ,'NODE DATA'/
&1H ,'NODE NO.',5X,'X' ,10X,'Y',10X,'FX',9X,'FY',9X,'IUO',9X,'IVO')
DO 70 I=1,NALL
WRITE(3,1110)I,X(I),Y(I),FX(I),FY(I),IUO(I),IVO(I)
1110 FORMAT(1H ,4x,I3,1X,4(F10.3,1X),2(5X,I1,5X))
70 CONTINUE
WRITE(3,1120)
1120 FORMAT(/1H ,'ELEMENT DATA'/
&1H ,'ELEMENT NO.',4X,'I',4X,'J',4X,'K',7X,
&'H(I)',6X,'E(I)',7X,'NU(I)')
DO 80 I=1,IEALL
WRITE(3,1130)I,(NELM(I,J),J=1,3),H(I),E(I),ANU(I)
1130 FORMAT(1H ,7X,I4,3(1X,I4),1X,3(G10.3,1X))
80 CONTINUE
RETURN
END
C--------------------------------------------------------------------
C CALCULATION
C
SUBROUTINE CALUCL
REAL KMAT
COMMON /AAA/KMAT(5000,5001)
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
COMMON /EEE/FX(5000),FY(5000),IUO(5000),IVO(5000)
COMMON /FFF/IEALL,NALL,IBC,NBC
C
C MAKE STIFFNESS MATRIX
C
DO 10 IELM=1,IEALL
C
C make out stiffness matrix of element IELM
C 要素剛性マトリックスの作成
C
CALL ELMK(IELM)
C
C make out all stiffness matrix
C 全体剛性マトリックスの作成
C
CALL ALLK(IELM)
10 CONTINUE
C
C 境界条件の設定
C
CALL BODRYC
IBC=0
DO 40 I=1,NALL
IF(IUO(I).EQ.1)IBC=IBC+1
IF(IVO(I).EQ.1)IBC=IBC+1
40 CONTINUE
NBC=NALL*2-IBC
WRITE(3,1080)NBC
1080 FORMAT(/1H ,'NUMBER OF FORMULATION=',I5)
C
C マトリックスを解く
C
CALL GMAT(KMAT,5000,5001,NBC,1.E-6,ILL)
IF(ILL.EQ.0)GO TO 50
WRITE(3,1020)
1020 FORMAT(1H ,'DON－T SOLVE. MATRIX IS NOT CORRECT')
STOP
50 CONTINUE
RETURN
END
C------------------------------------------------------------------
C 計算結果の出力
C
SUBROUTINE OUTWR
REAL KMAT
COMMON /AAA/KMAT(5000,5001)
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
COMMON /EEE/FX(5000),FY(5000),IUO(5000),IVO(5000)
COMMON /FFF/IEALL,NALL,IBC,NBC
COMMON /GGG/SIGM_ELEM(5000,6),SIGM_NODE(5000,6)
DIMENSION NHITELM(200)
WRITE(3,1000)
1000 FORMAT(/1H ,'SOLLUTION OF DISPLACEMENT'/
&1H ,'NODE NO.',5X,'X',10X,'Y',10X,'DX',10X,'DY')
C
C 境界条件で拘束されていた節点の変位成分は、方程式が消去されていた
C ため、拘束で消去されていた変位項を０．とし配列をシフトさせる。
C
C
DO 10 I=1,NALL*2
U(I)=KMAT(I,NBC+1)
10 CONTINUE
DO 20 I=1,NALL
IF(IUO(I).EQ.0)GO TO 30
I2=(I-1)*2+1
DO 40 J=I2+1,NALL*2
JJ=NALL*2+1-(J-I2)
U(JJ)=U(JJ-1)
40 CONTINUE
U(I2)=0.
30 IF(IVO(I).EQ.0)GO TO 20
I2=I*2
DO 60 J=I2+1,NALL*2
JJ=NALL*2+1-(J-I2)
U(JJ)=U(JJ-1)
60 CONTINUE
U(I2)=0.
20 CONTINUE
C
C 節点番号とX、Y座標と変位の出力
C
DO 70 I=1,NALL
I1=(I-1)*2+1
I2=I*2
WRITE(3,1010)I,X(I),Y(I),U(I1),U(I2)
1010 FORMAT(1H ,4X,I3,4(1X,G10.3))
70 CONTINUE
C
C 応力を計算し出力 (ひずみエネルギーも計算）
C
C SIG-1、SIG-2は、主応力
C PHIは、主応力の向き（RAD）（全体座標系に対して）
C
WRITE(3,1040)
1040 FORMAT(/1H ,'SOLUTION OF STRESS'/
&1H ,'ELM NO.',6X,'SIG-X',6X,'SIG-Y',6X,'TAUXY',6X,'SIG-1',
&6X,'SIG-2',6X,'PHI')
DO 65 IE=1,IEALL
CALL CALSIG(IE)
WRITE(3,1030)IE,(SIGM(J),J=1,3),(SMAINS(J),J=1,3)
1030 FORMAT(1H ,I7,6(1X,G10.3))
DO 300 J=1,3
SIGM_ELEM(IE,J)=SIGM(J)
300 CONTINUE
DO 310 J=1,3
SIGM_ELEM(IE,3+J)=SMAINS(J)
310 CONTINUE
65 CONTINUE
C
C SIGM_NODE(NODE,J) CALCULATION of arithmetic mean
C
DO 2200 IN=1,NALL
NHIT=0
NODENUM=IN
DO 2210 IE=1,IEALL
DO 2212 J=1,3
IF(NODENUM.EQ.NELM(IE,J))THEN
NHIT=NHIT+1
NHITELM(NHIT)=IE
ELSE
ENDIF
2212 CONTINUE
2210 CONTINUE
DO 2220 L2=1,6
SIGA=0.
DO 2230 L=1,NHIT
SIGA=SIGA+SIGM_ELEM(NHITELM(L),L2)
2230 CONTINUE
SIGM_NODE(NODENUM,L2)=SIGA/FLOAT(NHIT)
2220 CONTINUE
2200 CONTINUE
C
C ひずみエネルギーを出力
C
WRITE(3,1050)
1050 FORMAT(/1H ,'SOLUTION OF STRAIN ENERGY')
WRITE(3,1060)(J,SENERGY(J),J=1,IEALL)
1060 FORMAT(1H ,3(1H ,'ELM',I3,1X,G13.6,1X)/1H )
ALLSTE=0.
DO 90 I=1,IEALL
ALLSTE=ALLSTE+SENERGY(I)
90 CONTINUE
WRITE(3,1070)ALLSTE
1070 FORMAT(1H ,'ALL STRAIN ENERGY =',G13.6)
CLOSE(3)
C
C POST FILE WRITE
C
WRITE(8,1100)NALL,IEALL,1,1,1,1,1,1,1,1,1,1,1
1100 FORMAT(12(I11,','),I11)
WRITE(8,1110)
1110 FORMAT('NODE')
DO 100 I=1,NALL
I1=(I-1)*2+1
I2=I*2
WRITE(8,1200)I,X(I),Y(I),U(I1),U(I2),FX(I),FY(I)
1200 FORMAT(I11,',',6(E16.8,','))
100 CONTINUE
WRITE(8,1400)
1400 FORMAT('ELEM')
DO 200 IE=1,IEALL
CALL CALSIG(IE)
WRITE(8,1300)IE,NELM(IE,1),NELM(IE,2),NELM(IE,3),
& (SIGM(J),J=1,3),(SMAINS(J),J=1,3)
1300 FORMAT(4(I11,','),5(E16.8,','),E16.8)
200 CONTINUE
WRITE(8,250)'NSIG'
250 FORMAT(A4)
DO 2300 I=1,NALL
WRITE(8,1310)I,(SIGM_NODE(I,J),J=1,6)
1310 FORMAT(I4,6(',',E16.8))
2300 CONTINUE
CLOSE(8)
RETURN
END
C-----------------------------------------------------------
C 要素剛性マトリックスの作成
C
C IELM : 要素番号
C
SUBROUTINE ELMK(IELM)
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
DIMENSION Q1(6,3),Q2(6,3)
C
C [D] の作成
C
CALL CALD(IELM)
C
C [B] の作成
C
CALL CALB(IELM)
C
C [B]T 転置
C
CALL TENTI(B,3,6,Q1,6,3)
C
C [B]T * [D] = [Q2]
C
CALL MMUL3(Q1,6,3,D,3,3,Q2,6,3)
C
C [Q2] * [B] = [EK]
C
CALL MMUL3(Q2,6,3,B,3,6,EK,6,6)
I=NELM(IELM,1)
J=NELM(IELM,2)
K=NELM(IELM,3)
C S : 要素IELMの面積
S=(X(J)-X(I))*(Y(K)-Y(I))-(X(K)-X(I))*(Y(J)-Y(I))
C 二乗してルートし、絶対値をもとめる。
C I,J,Kの回り方が時計方向、反時計方向の区別を
C 無くす為。逆回転だと負となる。
S=SQRT(S*S)
S=S/2.
DO 10 I=1,6
DO 12 J=1,6
C EK(I,J)=EK(I,J)*S
EK(I,J)=EK(I,J)*S*H(IELM)
12 CONTINUE
10 CONTINUE
C
C [EK] : 要素剛性マトリックス （要素番号IELMの）
C
RETURN
END
C-----------------------------------------------------------------
C [B] の作成サブルーチン
C
SUBROUTINE CALB(IELM)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
I=NELM(IELM,1)
J=NELM(IELM,2)
K=NELM(IELM,3)
S=(X(J)-X(I))*(Y(K)-Y(I))-(X(K)-X(I))*(Y(J)-Y(I))
S=SQRT(S*S)
IF(S.LT.1.E-30)WRITE(3,100)IELM
100 FORMAT(1H ,'要素番号=',I4,' は、面積が０．である')
B(1,1)=(Y(J)-Y(K))/S
B(1,2)=0.
B(1,3)=(Y(K)-Y(I))/S
B(1,4)=0.
B(1,5)=(Y(I)-Y(J))/S
B(1,6)=0.
B(2,1)=0.
B(2,2)=(X(K)-X(J))/S
B(2,3)=0.
B(2,4)=(X(I)-X(K))/S
B(2,5)=0.
B(2,6)=(X(J)-X(I))/S
B(3,1)=B(2,2)
B(3,2)=B(1,1)
B(3,3)=B(2,4)
B(3,4)=B(1,3)
B(3,5)=B(2,6)
B(3,6)=B(1,5)
RETURN
END
C-----------------------------------------------------------------
C [D] の作成サブルーチン
C
C
SUBROUTINE CALD(IELM)
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
A=E(IELM)/(1.-ANU(IELM)*ANU(IELM))
D(1,1)=A
D(1,2)=A*ANU(IELM)
D(1,3)=0.
D(2,1)=D(1,2)
D(2,2)=A
D(3,1)=0.
D(3,2)=0.
D(3,3)=A*(1.-ANU(IELM))/2.
RETURN
END
C----------------------------------------------------------------
C 転置のサブルーチン
C
SUBROUTINE TENTI(B,II,JJ,Q,III,JJJ)
DIMENSION B(II,JJ),Q(III,JJJ)
DO 10 I=1,II
DO 20 J=1,JJ
Q(J,I)=B(I,J)
20 CONTINUE
10 CONTINUE
RETURN
END
C----------------------------------------------------------------
C マトリックスの積
C [C] = [A} * [B]
C
SUBROUTINE MMUL3(A,II,JJ,B,III,JJJ,C,LL,MM)
DIMENSION A(II,JJ),B(III,JJJ),C(LL,MM)
DO 10 I=1,LL
DO 12 J=1,MM
C(I,J)=0.
12 CONTINUE
10 CONTINUE
DO 20 I=1,II
DO 22 J=1,JJJ
DO 24 K=1,JJ
C(I,J)=A(I,K)*B(K,J)+C(I,J)
24 CONTINUE
22 CONTINUE
20 CONTINUE
RETURN
END
C--------------------------------------------------------------
C 全体剛性マトリックスの作成サブルーチン
C
C
SUBROUTINE ALLK(IELM)
REAL KMAT
COMMON /AAA/KMAT(5000,5001)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
DIMENSION IQ(6)
I=NELM(IELM,1)
J=NELM(IELM,2)
K=NELM(IELM,3)
IQ(1)=(I-1)*2+1
IQ(2)=I*2
IQ(3)=(J-1)*2+1
IQ(4)=J*2
IQ(5)=(K-1)*2+1
IQ(6)=K*2
DO 10 I=1,6
DO 12 J=1,6
KMAT(IQ(I),IQ(J))=EK(I,J)+KMAT(IQ(I),IQ(J))
12 CONTINUE
10 CONTINUE
RETURN
END
C--------------------------------------------------------------
C 境界条件の設定のサブルーチン
C
C
SUBROUTINE BODRYC
REAL KMAT
COMMON /AAA/KMAT(5000,5001)
COMMON /EEE/FX(5000),FY(5000),IUO(5000),IVO(5000)
COMMON /FFF/IEALL,NALL,IBC,NBC
C
C 外力FX、FYの設定
C
NF=NALL*2+1
DO 10 I=1,NALL
IF(FX(I).GT.1.E-30.OR.FX(I).LT.-1.E-30)KMAT((I-1)*2+1,NF)=FX(I)
IF(FY(I).GT.1.E-30.OR.FY(I).LT.-1.E-30)KMAT(I*2,NF)=FY(I)
10 CONTINUE
C
C 拘束条件の設定 （IUO、IVO）
C
C
NB=0
DO 20 I=1,NALL
IF(IUO(I).EQ.0)GO TO 30
I2=(I-1)*2+1-NB
DO 40 J=I2+1,NALL*2
DO 42 K=1,NF
KMAT(J-1,K)=KMAT(J,K)
42 CONTINUE
40 CONTINUE
DO 50 K=I2+1,NF
DO 52 J=1,NALL*2
KMAT(J,K-1)=KMAT(J,K)
52 CONTINUE
50 CONTINUE
NB=NB+1
30 IF(IVO(I).EQ.0)GO TO 60
I2=I*2-NB
DO 70 J=I2+1,NALL*2
DO 72 K=1,NF
KMAT(J-1,K)=KMAT(J,K)
72 CONTINUE
70 CONTINUE
DO 80 K=I2+1,NF
DO 82 J=1,NALL*2
KMAT(J,K-1)=KMAT(J,K)
82 CONTINUE
80 CONTINUE
NB=NB+1
60 CONTINUE
20 CONTINUE
RETURN
END
C-------------------------------------------------------------------
C 応力の算出のサブルーチン
C
SUBROUTINE CALSIG(IE)
COMMON /BBB/U(5000),E(5000),ANU(5000),SENERGY(5000)
COMMON /CCC/D(3,3),B(3,6),EK(6,6),SIGM(3),SMAINS(3)
COMMON /DDD/X(5000),Y(5000),NELM(5000,3),H(5000)
DIMENSION UU(6),IQ(6),Q1(3,6),Q2(6,3),Q3(6)
I=NELM(IE,1)
J=NELM(IE,2)
K=NELM(IE,3)
IQ(1)=(I-1)*2+1
IQ(2)=I*2
IQ(3)=(J-1)*2+1
IQ(4)=J*2
IQ(5)=(K-1)*2+1
IQ(6)=K*2
DO 10 I=1,6
UU(I)=U(IQ(I))
10 CONTINUE
CALL CALD(IE)
CALL CALB(IE)
CALL MMUL3(D,3,3,B,3,6,Q1,3,6)
C
C 応力の計算
C
DO 20 I=1,3
SIGM(I)=0.
20 CONTINUE
DO 30 I=1,3
DO 32 J=1,6
SIGM(I)=Q1(I,J)*UU(J)+SIGM(I)
32 CONTINUE
30 CONTINUE
SIGX=SIGM(1)
SIGY=SIGM(2)
TAUXY=SIGM(3)
IF(SIGX.EQ.SIGY)GO TO 40
A=2.*TAUXY/(SIGX-SIGY)
PHI=1./2.*ATAN(A)
GO TO 50
40 PHI=3.1415926/4.
50 C=COS(PHI)
S=SIN(PHI)
SMAINS(1)=SIGX*C*C+2.*TAUXY*C*S+SIGY*S*S
SMAINS(2)=SIGY*C*C-2.*TAUXY*C*S+SIGX*S*S
SMAINS(3)=PHI
C
C ひずみエネルギーの計算
C
CALL TENTI(B,3,6,Q2,6,3)
CALL MMUL3(Q2,6,3,Q1,3,6,EK,6,6)
I=NELM(IE,1)
J=NELM(IE,2)
K=NELM(IE,3)
S=(X(J)-X(I))*(Y(K)-Y(I))-(X(K)-X(I))*(Y(J)-Y(I))
S=SQRT(S*S)
DO 70 I=1,6
Q3(I)=0.
70 CONTINUE
DO 80 I=1,6
DO 82 J=1,6
Q3(I)=UU(J)*EK(I,J)*S/2.+Q3(I)
82 CONTINUE
80 CONTINUE
TOTENR=0.
DO 60 I=1,6
TOTENR=TOTENR+Q3(I)*UU(I)
60 CONTINUE
SENERGY(IE)=TOTENR/2.
RETURN
END
C-----------------------------------------------------------------
C 連立方程式を解く（ガウスの消去法）
C
C
SUBROUTINE GMAT(A,LL,KK,IB,ESP,ILL)
DIMENSION A(LL,KK),JB(5001)
ILL=0
IB1=IB+1
DO 15 I=1,IB
JB(I)=I
15 CONTINUE
DO 10 K=1,IB-1
BMAX=ABS(A(K,K))
IMAX=K
JMAX=K
DO 20 I=K,IB
DO 22 J=K,IB
AA=ABS(A(I,J))
IF(BMAX.GE.AA)GO TO 20
BMAX=AA
IMAX=I
JMAX=J
22 CONTINUE
20 CONTINUE
DO 30 J=1,IB1
AA=A(IMAX,J)
A(IMAX,J)=A(K,J)
A(K,J)=AA
30 CONTINUE
KB=JB(K)
JB(K)=JB(JMAX)
JB(JMAX)=KB
DO 35 I=1,IB
AA=A(I,JMAX)
A(I,JMAX)=A(I,K)
A(I,K)=AA
35 CONTINUE
DO 40 I=K+1,IB
CC=A(I,K)/A(K,K)
DO 42 J=1,IB1
A(I,J)=A(I,J)-CC*A(K,J)
42 CONTINUE
40 CONTINUE
10 CONTINUE
DO 51 KKK=1,IB-1
K=IB1-KKK
DO 50 II=1,K-1
I=K-II
CC=A(I,K)/A(K,K)
DO 52 J=1,IB1
A(I,J)=A(I,J)-CC*A(K,J)
52 CONTINUE
50 CONTINUE
51 CONTINUE
DO 60 K=1,IB
AA=ABS(A(K,K))
IF(AA.LT.ESP) GO TO 70
A(K,IB1)=A(K,IB1)/A(K,K)
60 CONTINUE
DO 65 I=1,IB
DO 66 J=I,IB
KB=JB(J)
IF(KB.EQ.I) GO TO 67
66 CONTINUE
67 CONTINUE
JB(J)=JB(I)
AA=A(KB,IB1)
A(KB,IB1)=A(J,IB1)
A(J,IB1)=AA
65 CONTINUE
GO TO 80
70 ILL=1
80 RETURN
END
7－2．入力データ作成 FEM-PSA プリ・プロセッサ（専用アプリ・有孔平板）（FORTRAN)
7－2．入力データ作成 FEM-PSA プリ・プロセッサ（専用アプリ・有孔平板）（FORTRAN)
7－2．入力データ作成 FEM-PSA-pre-processor
（自分の解こうとしている問題用に加工して使ってね。）
座標は[mm]単位、応力は[Mpa]になっています。
（以下、Cの書いてある所から下をコピーしてTeraPadに
貼り付け、FEM-PSA-pre.forという名称で保存）
ここから、プログラムです。
C pre processer
C program file name FEM-PSA-pre.for
C
C-------------------------------------------------------------
C compile
C >gfortran FEM-PSA-pre.for -o FEM-PSA-pre.exe
C
C-------------------------------------------------------------
C FEM入力データ作成方法
C
C >FEM-PSA-pre
C
C これで、入力データファイルができます。
C input data file name : FEM-PSA-input-data.txt
C
C------------------------------------------------------------
CHARACTER FLOUT*80
DIMENSION X(2500),Y(2500),NELM(5000,3)
DIMENSION FX(2500),FY(2500),IU0(2500),IV0(2500),RR(100)
DIMENSION IALUFA(2500,2),ALUFA(2500)
OPEN(UNIT=2,FILE='FEM-PSA-input-data.txt',STATUS='UNKNOWN')
PAI=3.14159265358979
DO 1500 I=1,2500
FX(I)=0. ! FX(I) NODE NUMBER I X direction force
FY(I)=0. ! FY(I) NODE NUMBER I Y direction force
C !
IU0(I)=0 ! IU0(I) NODE NUMBER I X direction fix displacement
C ! 0 is free 1 is FIX
C
IV0(I)=0 ! IV0(I) NODE NUMBER I Y direction fix displacement
C ! 0 is free 1 is FIX
1500 CONTINUE
DTHETA=PAI/2./14.
RR(1)=10.0
RR(2)=10.5
RR(3)=11.0
RR(4)=12.0
RR(5)=13.0
RR(6)=14.0
RR(7)=15.0
RR(8)=17.0
RR(9)=20.0
RR(10)=25.0
RR(11)=30.0
RR(12)=35.0
RR(13)=40.0
RR(14)=50.0
K=0
DO 10 I=1,14
DO 12 J=1,15
K=K+1
X(K)=RR(I)*COS(DTHETA*FLOAT(J-1))
Y(K)=RR(I)*SIN(DTHETA*FLOAT(J-1))
12 CONTINUE
10 CONTINUE
DO 1600 I=1,7
K=K+1
X(K)=60.0
Y(K)=RR(14)*SIN(DTHETA*FLOAT(I-1))
1600 CONTINUE
K=K+1
X(K)=60.0
Y(K)=60.0
DO 1700 I=1,7
K=K+1
X(K)=RR(14)*COS(DTHETA*FLOAT(I+7))
Y(K)=60.0
1700 CONTINUE
K=K+1
X(K)=45.0
Y(K)=45.0
NODE=K
NEND=K
NELM(1,1)=2
NELM(1,2)=1
NELM(1,3)=16
NELM(2,1)=2
NELM(2,2)=16
NELM(2,3)=17
DO 30 I=3,28
DO 32 J=1,3
NELM(I,J)=NELM(I-2,J)+1
32 CONTINUE
30 CONTINUE
DO 40 I=29,364
DO 42 J=1,3
NELM(I,J)=NELM(I-28,J)+15
42 CONTINUE
40 CONTINUE
DO 1800 I=365,376
DO 1802 J=1,3
NELM(I,J)=NELM(I-28,J)+15
1802 CONTINUE
1800 CONTINUE
DO 1900 I=377,388
DO 1902 J=1,3
NELM(I,J)=NELM(I-24,J)+15
1902 CONTINUE
1900 CONTINUE
K=389
NELM(K,1)=NEND-15-8
NELM(K,2)=NEND-15-9
NELM(K,3)=NEND-9
K=K+1
NELM(K,1)=NEND-15-8
NELM(K,2)=NEND-9
NELM(K,3)=NEND
K=K+1
NELM(K,1)=NEND-15-7
NELM(K,2)=NEND-15-8
NELM(K,3)=NEND
K=K+1
NELM(K,1)=NEND-15-7
NELM(K,2)=NEND
NELM(K,3)=NEND-7
K=K+1
NELM(K,1)=NEND
NELM(K,2)=NEND-9
NELM(K,3)=NEND-8
K=K+1
NELM(K,1)=NEND
NELM(K,2)=NEND-8
NELM(K,3)=NEND-7
NELEM=K
DO 1930 I=1,NEND-14,15
IV0(I)=1 !Y方向拘束=1, 自由=0
1930 CONTINUE
DO 1910 I=15,NEND,15
IU0(I)=1 !X方向拘束=1, 自由=0
1910 CONTINUE
DO 1920 I=NEND-7,NEND-2
X1=X(I-1)
X2=X(I)
X3=X(I+1)
FY(I)=(X1-X3)/2.*9.8 !Y方向外力 (N)
1920 CONTINUE
FY(NEND-8)=(X(NEND-8)-X(NEND-7))/2.*9.8 !Y方向外力 (N)
FY(NEND-1)=(X(NEND-2)-X(NEND-1))/2.*9.8 !Y方向外力 (N)
H=1.0 !板厚（mm）
EE=205800. !ヤング率(MPa)(N/mm2)
ANU=0.3 !ν：ポアソン比
C
C 解析結果の検証 σ：平均応力
C変位DY=応力σ/EE*L
C L=60mm σ=9.8(MPa) EE=205800(MPa) DY=2.85E-3(mm)
C
C
C
WRITE(2,1000)NODE,NELEM
1000 FORMAT(I5,',',I5)
WRITE(2,*)'NODE'
DO 70 I=1,NODE
WRITE(2,1100)I,X(I),Y(I),FX(I),FY(I),IU0(I),IV0(I)
1100 FORMAT(I4,4(',',E16.8),2(',',I4))
70 CONTINUE
WRITE(2,*)'ELEM'
DO 80 I=1,NELEM
WRITE(2,1200)I,(NELM(I,J),J=1,3),EE,ANU,H
1200 FORMAT(I4,3(',',I4),3(',',E16.8))
80 CONTINUE
CLOSE(2)
STOP
END
7－3．ポスト処理 Excel-VBA
7－3．ポスト処理 Excel-VBA
7－3－1．Excel=VBA-σｘーcontaーfig（σxコンタ図）
7－3－1．Excel=VBA-σｘーcontaーfig（σxコンタ図）
7－3．ポスト処理 Excel-VBA
7－3－1．Excel-VBA-σX-conta-fig（σXコンタ図）
postファイルをCTRL+A、CTRL+Cですべてコピーして、
Sheet3を作り、そこの[A2]セルに貼り付けます。
カンマで区切られたデータとして。
マクロを実行で描きます。
ここからVBAです。
Sub draw()
'FEM FIG DRAW
Dim x(5000) As Single
Dim y(5000) As Single
Dim temp(5000) As Single
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim m As Integer
Dim i1 As Integer
Dim j1 As Integer
Dim k1 As Integer
Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single
Dim elm(5000, 3) As Integer
Dim node As Integer
Dim Nelm As Integer
Sheets("sheet3").Select
node = Worksheets("sheet3").Range("A2")
Nelm = Worksheets("sheet3").Range("B2")
[A3].Select
For i = 1 To node
j = ActiveCell.Offset(i, 0).Value
x(j) = ActiveCell.Offset(i, 1).Value
y(j) = ActiveCell.Offset(i, 2).Value
Next i
For i = 1 To Nelm
j = ActiveCell.Offset(i + 1 + node, 0).Value
elm(j, 1) = ActiveCell.Offset(i + 1 + node, 1).Value
elm(j, 2) = ActiveCell.Offset(i + 1 + node, 2).Value
elm(j, 3) = ActiveCell.Offset(i + 1 + node, 3).Value
Next i
For i = 1 To node
j = ActiveCell.Offset(i + 2 + Nelm + node, 0).Value
temp(j) = ActiveCell.Offset(i + 2 + Nelm + node, 1).Value
Next i
Dim xmax As Single
Dim xmin As Single
Dim ymin As Single
Dim ymax As Single
xmax = 0#
xmin = 999#
ymin = 999#
ymax = 0#
For i = 1 To node
If (x(i) <= xmin) Then
xmin = x(i)
Else
End If
If (x(i) >= xmax) Then
xmax = x(i)
Else
End If
If (y(i) <= ymin) Then
ymin = y(i)
Else
End If
If (y(i) >= ymax) Then
ymax = y(i)
Else
End If
Next i
Set RngStart = Worksheets("sheet2").Range("B40")
xs = RngStart.Left
ys = RngStart.Top
Set RngEnd = Worksheets("sheet2").Range("D4")
ye = RngEnd.Top
xe = xs + (ys - ye)
Dim zmax As Single
Dim zmin As Single
zmax = xmax
If (ymax >= zmax) Then
zmax = ymax
Else
End If
zmin = xmin
If (ymin <= zmin) Then
zmin = ymin
Else
End If
dx = (xe - xs) / (zmax - zmin)
dy = (ye - ys) / (zmax - zmin)
xg = (xe - xs) * (-zmin / (zmax - zmin)) + xs
yg = (ye - ys) * (-zmin / (ymax - ymin)) + ys
Sheets("sheet2").Select
'outline draw start
For n = 1 To Nelm
icount = 1
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
'i-j line draw
For m = 1 To Nelm
If (n = m) Then GoTo label4
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (i = i1 And j = k1) Then GoTo label1
If (i = j1 And j = i1) Then GoTo label1
If (i = k1 And j = j1) Then GoTo label1
GoTo label4
label1:
icount = icount + 1
label4:
Next m
If (icount >= 2) Then GoTo label6
x1 = x(i) * dx + xg
y1 = y(i) * dy + yg
x2 = x(j) * dx + xg
y2 = y(j) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label6:
'j-k line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label9
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (j = i1 And k = k1) Then GoTo label2
If (j = j1 And k = i1) Then GoTo label2
If (j = k1 And k = j1) Then GoTo label2
GoTo label9
label2:
icount = icount + 1
label9:
Next m
If (icount >= 2) Then GoTo label10
x1 = x(j) * dx + xg
y1 = y(j) * dy + yg
x2 = x(k) * dx + xg
y2 = y(k) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label10:
'k-i line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label12
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (k = i1 And i = k1) Then GoTo label3
If (k = j1 And i = i1) Then GoTo label3
If (k = k1 And i = j1) Then GoTo label3
GoTo label12
label3:
icount = icount + 1
label12:
Next m
If (icount >= 2) Then GoTo label13
x1 = x(k) * dx + xg
y1 = y(k) * dy + yg
x2 = x(i) * dx + xg
y2 = y(i) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label13:
Next n
'outline draw end
'node number draw
' Dim add_str As String
' Sheets("sheet2").Select
' [G40].Select
' c = ActiveSheet.Range("G40").Select
' Dim tmp_str As String
' tmp_str = Selection.Address
' Dim it As Range
' For n = 1 To node
' xa = x(n) * dx + xg
' ya = y(n) * dy + yg
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=xa, _
' Top:=ya, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = n
' End With
' Next n
'element No. draw
' For n = 1 To Nelm
' i = elm(n, 1)
' j = elm(n, 2)
' k = elm(n, 3)
' xa = ((x(i) + x(j) + x(k)) / 3#) * dx + xg
' ya = ((y(i) + y(j) + y(k)) / 3#) * dy + yg
'element No. WRITE
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=xa, _
' Top:=ya, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = n
' End With
' Next n
'color-conta draw start
Dim myCht As Chart
Dim mySts As Series
Dim Npts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
tmin = 9999#
tmax = -9999#
n1 = 26
For i = 1 To node
If (temp(i) >= tmax) Then
tmax = temp(i)
Else
End If
If (temp(i) <= tmin) Then
tmin = temp(i)
Else
End If
Next i
For n = 1 To Nelm
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
x1 = x(i)
y1 = y(i)
t1 = temp(i)
x2 = x(j)
y2 = y(j)
t2 = temp(j)
x3 = x(k)
y3 = y(k)
t3 = temp(k)
Call sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Next n
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=0, _
Width:=80#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "Sigma-X"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=70, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MAX"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=90, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmax
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=170, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MIN"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmin
' .Size = 0.2
End With
If (tmin < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=10, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(tmin)
' .Size = 0.2
End With
Else
End If
Dim temp2(100)
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp2(i) = tmin + (i - 1) * dtemp
Next i
For i = 1 To n1 - 1
x1 = xmax * dx + xg + 100
y1 = ys - 24 * i
x2 = xmax * dx + xg + 150
y2 = y1
x3 = x2
y3 = ys - 24 * (i - 1)
x4 = x1
y4 = y3
Call poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, i)
Next i
For i = 1 To n1
x1 = xmax * dx + xg + 160
y1 = ys - 24 * (i - 1) - 10
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = temp2(i)
' .Size = 0.2
End With
If (temp2(i) < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1 + 10#, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(temp2(i))
' .Size = 0.2
End With
Else
End If
Next i
'color-conta draw end
MsgBox ("end")
End Sub
Sub sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Dim tt(3) As Single
Dim xx(3) As Single
Dim yy(3) As Single
Dim temp1(101) As Single
Dim xa As Single
Dim ya As Single
Dim xb As Single
Dim yb As Single
Dim xa1 As Single
Dim ya1 As Single
Dim xb1 As Single
Dim yb1 As Single
Dim tq As Single
Dim xq As Single
Dim yq As Single
Dim k1 As Integer
Dim k2 As Integer
Dim k3 As Integer
Dim dtemp As Single
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp1(i) = tmin + (i - 1) * dtemp
Next i
xx(1) = x1
yy(1) = y1
tt(1) = t1
xx(2) = x2
yy(2) = y2
tt(2) = t2
xx(3) = x3
yy(3) = y3
tt(3) = t3
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (tt(j) >= tt(j + 1)) Then
tq = tt(j)
tt(j) = tt(j + 1)
tt(j + 1) = tq
xq = xx(j)
xx(j) = xx(j + 1)
xx(j + 1) = xq
yq = yy(j)
yy(j) = yy(j + 1)
yy(j + 1) = yq
Else
End If
Next j
Next i
x1 = xx(1)
x2 = xx(2)
x3 = xx(3)
y1 = yy(1)
y2 = yy(2)
y3 = yy(3)
j = 0
For i = 1 To n1 - 1
If (tt(1) >= temp1(i) And tt(1) <= temp1(i + 1)) Then
If (j = 0) Then
k1 = i
j = j + 1
Else
End If
Else
End If
Next i
For i = k1 To n1 - 1
If (tt(3) >= temp1(i) And tt(3) <= temp1(i + 1)) Then
k3 = i
Else
End If
Next i
If (k1 = k3) Then
k2 = k1
Else
For i = k1 To k3
If (tt(2) >= temp1(i) And tt(2) <= temp1(i + 1)) Then
k2 = i
Else
End If
Next i
End If
k4 = k3 - k2
k5 = k2 - k1
If (k1 = k3) Then GoTo label200
If (k1 = k2) Then
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = k2 + 1) Then Call poly4(x1, y1, x2, y2, xa, ya, xb, yb, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label300:
Next i
Else
If (k2 = k3) Then
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k2) Then Call poly4(xa, ya, xb, yb, x2, y2, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label310:
Next i
Else
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label320:
Next i
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = 1) Then
icol = 2
Else
icol = i
End If
If (i = k2 + 1) Then Call poly5(xa1, ya1, xb1, yb1, xa, ya, xb, yb, x2, y2, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label330:
Next i
End If
End If
GoTo label400
label200:
If (k1 = 0) Then
icol = 1
Else
icol = k1
End If
Call poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
label400:
End Sub
Sub arctan(x1, y1, phi)
apai = 3.14159265358979
If (x1 = 0#) Then GoTo label500
a = y1 / x1
b = Atn(a)
phi = b
If (x1 <= 0# And y1 <= 0#) Then
phi = b - apai
Else
End If
If (x1 <= 0# And y1 >= 0#) Then
phi = b + apai
Else
End If
GoTo label600
label500:
If (x1 = 0# And y1 >= 0#) Then
phi = apai / 2#
Else
End If
If (x1 = 0# And y1 <= 0#) Then
phi = -apai / 2#
Else
End If
label600:
End Sub
Sub poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
Dim xq3(3) As Single
Dim yq3(3) As Single
Dim theta3(3) As Single
xq3(1) = x1
xq3(2) = x2
xq3(3) = x3
yq3(1) = y1
yq3(2) = y2
yq3(3) = y3
xq = (x1 + x2 + x3) / 3#
yq = (y1 + y2 + y3) / 3#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta3(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta3(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta3(3) = phi
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (theta3(j) <= theta3(j + 1)) Then
ta = theta3(j)
theta3(j) = theta3(j + 1)
theta3(j + 1) = ta
xq = xq3(j)
xq3(j) = xq3(j + 1)
xq3(j + 1) = xq
yq = yq3(j)
yq3(j) = yq3(j + 1)
yq3(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq3(1) * dx + xg
Ynode = yq3(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 3
Xnode = xq3(i) * dx + xg
Ynode = yq3(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4(x1, y1, x2, y2, x3, y3, x4, y4, dx, dy, xg, yg, icol)
Dim xq4(4) As Single
Dim yq4(4) As Single
Dim theta4(4) As Single
xq4(1) = x1
xq4(2) = x2
xq4(3) = x3
yq4(1) = y1
yq4(2) = y2
yq4(3) = y3
xq4(4) = x4
yq4(4) = y4
xq = (x1 + x2 + x3 + x4) / 4#
yq = (y1 + y2 + y3 + y4) / 4#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta4(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta4(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta4(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta4(4) = phi
'quick-sort
For i = 1 To 4
For j = 1 To 3
If (theta4(j) <= theta4(j + 1)) Then
ta = theta4(j)
theta4(j) = theta4(j + 1)
theta4(j + 1) = ta
xq = xq4(j)
xq4(j) = xq4(j + 1)
xq4(j + 1) = xq
yq = yq4(j)
yq4(j) = yq4(j + 1)
yq4(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq4(1) * dx + xg
Ynode = yq4(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4(i) * dx + xg
Ynode = yq4(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly5(x1, y1, x2, y2, x3, y3, x4, y4, x5, y5, dx, dy, xg, yg, icol)
Dim xq5(5) As Single
Dim yq5(5) As Single
Dim theta5(5) As Single
xq5(1) = x1
xq5(2) = x2
xq5(3) = x3
yq5(1) = y1
yq5(2) = y2
yq5(3) = y3
xq5(4) = x4
yq5(4) = y4
xq5(5) = x5
yq5(5) = y5
xq = (x1 + x2 + x3 + x4 + x5) / 5#
yq = (y1 + y2 + y3 + y4 + y5) / 5#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta5(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta5(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta5(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta5(4) = phi
xr = x5 - xq
yr = y5 - yq
Call arctan(xr, yr, phi)
theta5(5) = phi
'quick-sort
For i = 1 To 5
For j = 1 To 4
If (theta5(j) <= theta5(j + 1)) Then
ta = theta5(j)
theta5(j) = theta5(j + 1)
theta5(j + 1) = ta
xq = xq5(j)
xq5(j) = xq5(j + 1)
xq5(j + 1) = xq
yq = yq5(j)
yq5(j) = yq5(j + 1)
yq5(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq5(1) * dx + xg
Ynode = yq5(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 5
Xnode = xq5(i) * dx + xg
Ynode = yq5(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, icol)
Dim xq4_c(4) As Single
Dim yq4_c(4) As Single
xq4_c(1) = x1
xq4_c(2) = x2
xq4_c(3) = x3
xq4_c(4) = x4
yq4_c(1) = y1
yq4_c(2) = y2
yq4_c(3) = y3
yq4_c(4) = y4
Xnode = xq4_c(1)
Ynode = yq4_c(1)
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4_c(i)
Ynode = yq4_c(i)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
7－3－2． Excel-VBA-σyーconta-fig（σyコンタ図）
7－3－2． Excel-VBA-σyーconta-fig（σyコンタ図）
7－3－2．Excel-VBA-σY-conta-fig(σYコンタ図）
postファイルをCTRL+A、CTRL+Cですべてコピーして、
Sheet3を作り、そこの[A2]セルに貼り付けます。
カンマで区切られたデータとして。
マクロを実行で描きます。
ここから、VBAです。
Sub draw()
'FEM FIG DRAW
Dim x(5000) As Single
Dim y(5000) As Single
Dim temp(5000) As Single
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim m As Integer
Dim i1 As Integer
Dim j1 As Integer
Dim k1 As Integer
Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single
Dim elm(5000, 3) As Integer
Dim node As Integer
Dim Nelm As Integer
Sheets("sheet3").Select
node = Worksheets("sheet3").Range("A2")
Nelm = Worksheets("sheet3").Range("B2")
[A3].Select
For i = 1 To node
j = ActiveCell.Offset(i, 0).Value
x(j) = ActiveCell.Offset(i, 1).Value
y(j) = ActiveCell.Offset(i, 2).Value
Next i
For i = 1 To Nelm
j = ActiveCell.Offset(i + 1 + node, 0).Value
elm(j, 1) = ActiveCell.Offset(i + 1 + node, 1).Value
elm(j, 2) = ActiveCell.Offset(i + 1 + node, 2).Value
elm(j, 3) = ActiveCell.Offset(i + 1 + node, 3).Value
Next i
For i = 1 To node
j = ActiveCell.Offset(i + 2 + Nelm + node, 0).Value
temp(j) = ActiveCell.Offset(i + 2 + Nelm + node, 2).Value
Next i
Dim xmax As Single
Dim xmin As Single
Dim ymin As Single
Dim ymax As Single
xmax = 0#
xmin = 999#
ymin = 999#
ymax = 0#
For i = 1 To node
If (x(i) <= xmin) Then
xmin = x(i)
Else
End If
If (x(i) >= xmax) Then
xmax = x(i)
Else
End If
If (y(i) <= ymin) Then
ymin = y(i)
Else
End If
If (y(i) >= ymax) Then
ymax = y(i)
Else
End If
Next i
Set RngStart = Worksheets("sheet2").Range("B40")
xs = RngStart.Left
ys = RngStart.Top
Set RngEnd = Worksheets("sheet2").Range("D4")
ye = RngEnd.Top
xe = xs + (ys - ye)
Dim zmax As Single
Dim zmin As Single
zmax = xmax
If (ymax >= zmax) Then
zmax = ymax
Else
End If
zmin = xmin
If (ymin <= zmin) Then
zmin = ymin
Else
End If
dx = (xe - xs) / (zmax - zmin)
dy = (ye - ys) / (zmax - zmin)
xg = (xe - xs) * (-zmin / (zmax - zmin)) + xs
yg = (ye - ys) * (-zmin / (ymax - ymin)) + ys
Sheets("sheet2").Select
'outline draw start
For n = 1 To Nelm
icount = 1
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
'i-j line draw
For m = 1 To Nelm
If (n = m) Then GoTo label4
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (i = i1 And j = k1) Then GoTo label1
If (i = j1 And j = i1) Then GoTo label1
If (i = k1 And j = j1) Then GoTo label1
GoTo label4
label1:
icount = icount + 1
label4:
Next m
If (icount >= 2) Then GoTo label6
x1 = x(i) * dx + xg
y1 = y(i) * dy + yg
x2 = x(j) * dx + xg
y2 = y(j) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label6:
'j-k line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label9
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (j = i1 And k = k1) Then GoTo label2
If (j = j1 And k = i1) Then GoTo label2
If (j = k1 And k = j1) Then GoTo label2
GoTo label9
label2:
icount = icount + 1
label9:
Next m
If (icount >= 2) Then GoTo label10
x1 = x(j) * dx + xg
y1 = y(j) * dy + yg
x2 = x(k) * dx + xg
y2 = y(k) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label10:
'k-i line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label12
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (k = i1 And i = k1) Then GoTo label3
If (k = j1 And i = i1) Then GoTo label3
If (k = k1 And i = j1) Then GoTo label3
GoTo label12
label3:
icount = icount + 1
label12:
Next m
If (icount >= 2) Then GoTo label13
x1 = x(k) * dx + xg
y1 = y(k) * dy + yg
x2 = x(i) * dx + xg
y2 = y(i) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label13:
Next n
'outline draw end
'color-conta draw start
Dim myCht As Chart
Dim mySts As Series
Dim Npts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
tmin = 9999#
tmax = -9999#
n1 = 26
For i = 1 To node
If (temp(i) >= tmax) Then
tmax = temp(i)
Else
End If
If (temp(i) <= tmin) Then
tmin = temp(i)
Else
End If
Next i
For n = 1 To Nelm
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
x1 = x(i)
y1 = y(i)
t1 = temp(i)
x2 = x(j)
y2 = y(j)
t2 = temp(j)
x3 = x(k)
y3 = y(k)
t3 = temp(k)
Call sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Next n
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=0, _
Width:=80#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "Sigma-Y"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=70, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MAX"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=90, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmax
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=170, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MIN"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmin
' .Size = 0.2
End With
If (tmin < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=10, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(tmin)
' .Size = 0.2
End With
Else
End If
Dim temp2(100)
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp2(i) = tmin + (i - 1) * dtemp
Next i
For i = 1 To n1 - 1
x1 = xmax * dx + xg + 100
y1 = ys - 24 * i
x2 = xmax * dx + xg + 150
y2 = y1
x3 = x2
y3 = ys - 24 * (i - 1)
x4 = x1
y4 = y3
Call poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, i)
Next i
For i = 1 To n1
x1 = xmax * dx + xg + 160
y1 = ys - 24 * (i - 1) - 10
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = temp2(i)
' .Size = 0.2
End With
If (temp2(i) < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1 + 10#, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(temp2(i))
' .Size = 0.2
End With
Else
End If
Next i
'color-conta draw end
MsgBox ("end")
End Sub
Sub sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Dim tt(3) As Single
Dim xx(3) As Single
Dim yy(3) As Single
Dim temp1(101) As Single
Dim xa As Single
Dim ya As Single
Dim xb As Single
Dim yb As Single
Dim xa1 As Single
Dim ya1 As Single
Dim xb1 As Single
Dim yb1 As Single
Dim tq As Single
Dim xq As Single
Dim yq As Single
Dim k1 As Integer
Dim k2 As Integer
Dim k3 As Integer
Dim dtemp As Single
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp1(i) = tmin + (i - 1) * dtemp
Next i
xx(1) = x1
yy(1) = y1
tt(1) = t1
xx(2) = x2
yy(2) = y2
tt(2) = t2
xx(3) = x3
yy(3) = y3
tt(3) = t3
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (tt(j) >= tt(j + 1)) Then
tq = tt(j)
tt(j) = tt(j + 1)
tt(j + 1) = tq
xq = xx(j)
xx(j) = xx(j + 1)
xx(j + 1) = xq
yq = yy(j)
yy(j) = yy(j + 1)
yy(j + 1) = yq
Else
End If
Next j
Next i
x1 = xx(1)
x2 = xx(2)
x3 = xx(3)
y1 = yy(1)
y2 = yy(2)
y3 = yy(3)
j = 0
For i = 1 To n1 - 1
If (tt(1) >= temp1(i) And tt(1) <= temp1(i + 1)) Then
If (j = 0) Then
k1 = i
j = j + 1
Else
End If
Else
End If
Next i
For i = k1 To n1 - 1
If (tt(3) >= temp1(i) And tt(3) <= temp1(i + 1)) Then
k3 = i
Else
End If
Next i
If (k1 = k3) Then
k2 = k1
Else
For i = k1 To k3
If (tt(2) >= temp1(i) And tt(2) <= temp1(i + 1)) Then
k2 = i
Else
End If
Next i
End If
k4 = k3 - k2
k5 = k2 - k1
If (k1 = k3) Then GoTo label200
If (k1 = k2) Then
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = k2 + 1) Then Call poly4(x1, y1, x2, y2, xa, ya, xb, yb, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label300:
Next i
Else
If (k2 = k3) Then
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k2) Then Call poly4(xa, ya, xb, yb, x2, y2, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label310:
Next i
Else
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label320:
Next i
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = 1) Then
icol = 2
Else
icol = i
End If
If (i = k2 + 1) Then Call poly5(xa1, ya1, xb1, yb1, xa, ya, xb, yb, x2, y2, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label330:
Next i
End If
End If
GoTo label400
label200:
If (k1 = 0) Then
icol = 1
Else
icol = k1
End If
Call poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
label400:
End Sub
Sub arctan(x1, y1, phi)
apai = 3.14159265358979
If (x1 = 0#) Then GoTo label500
a = y1 / x1
b = Atn(a)
phi = b
If (x1 <= 0# And y1 <= 0#) Then
phi = b - apai
Else
End If
If (x1 <= 0# And y1 >= 0#) Then
phi = b + apai
Else
End If
GoTo label600
label500:
If (x1 = 0# And y1 >= 0#) Then
phi = apai / 2#
Else
End If
If (x1 = 0# And y1 <= 0#) Then
phi = -apai / 2#
Else
End If
label600:
End Sub
Sub poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
Dim xq3(3) As Single
Dim yq3(3) As Single
Dim theta3(3) As Single
xq3(1) = x1
xq3(2) = x2
xq3(3) = x3
yq3(1) = y1
yq3(2) = y2
yq3(3) = y3
xq = (x1 + x2 + x3) / 3#
yq = (y1 + y2 + y3) / 3#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta3(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta3(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta3(3) = phi
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (theta3(j) <= theta3(j + 1)) Then
ta = theta3(j)
theta3(j) = theta3(j + 1)
theta3(j + 1) = ta
xq = xq3(j)
xq3(j) = xq3(j + 1)
xq3(j + 1) = xq
yq = yq3(j)
yq3(j) = yq3(j + 1)
yq3(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq3(1) * dx + xg
Ynode = yq3(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 3
Xnode = xq3(i) * dx + xg
Ynode = yq3(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4(x1, y1, x2, y2, x3, y3, x4, y4, dx, dy, xg, yg, icol)
Dim xq4(4) As Single
Dim yq4(4) As Single
Dim theta4(4) As Single
xq4(1) = x1
xq4(2) = x2
xq4(3) = x3
yq4(1) = y1
yq4(2) = y2
yq4(3) = y3
xq4(4) = x4
yq4(4) = y4
xq = (x1 + x2 + x3 + x4) / 4#
yq = (y1 + y2 + y3 + y4) / 4#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta4(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta4(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta4(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta4(4) = phi
'quick-sort
For i = 1 To 4
For j = 1 To 3
If (theta4(j) <= theta4(j + 1)) Then
ta = theta4(j)
theta4(j) = theta4(j + 1)
theta4(j + 1) = ta
xq = xq4(j)
xq4(j) = xq4(j + 1)
xq4(j + 1) = xq
yq = yq4(j)
yq4(j) = yq4(j + 1)
yq4(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq4(1) * dx + xg
Ynode = yq4(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4(i) * dx + xg
Ynode = yq4(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly5(x1, y1, x2, y2, x3, y3, x4, y4, x5, y5, dx, dy, xg, yg, icol)
Dim xq5(5) As Single
Dim yq5(5) As Single
Dim theta5(5) As Single
xq5(1) = x1
xq5(2) = x2
xq5(3) = x3
yq5(1) = y1
yq5(2) = y2
yq5(3) = y3
xq5(4) = x4
yq5(4) = y4
xq5(5) = x5
yq5(5) = y5
xq = (x1 + x2 + x3 + x4 + x5) / 5#
yq = (y1 + y2 + y3 + y4 + y5) / 5#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta5(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta5(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta5(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta5(4) = phi
xr = x5 - xq
yr = y5 - yq
Call arctan(xr, yr, phi)
theta5(5) = phi
'quick-sort
For i = 1 To 5
For j = 1 To 4
If (theta5(j) <= theta5(j + 1)) Then
ta = theta5(j)
theta5(j) = theta5(j + 1)
theta5(j + 1) = ta
xq = xq5(j)
xq5(j) = xq5(j + 1)
xq5(j + 1) = xq
yq = yq5(j)
yq5(j) = yq5(j + 1)
yq5(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq5(1) * dx + xg
Ynode = yq5(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 5
Xnode = xq5(i) * dx + xg
Ynode = yq5(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, icol)
Dim xq4_c(4) As Single
Dim yq4_c(4) As Single
xq4_c(1) = x1
xq4_c(2) = x2
xq4_c(3) = x3
xq4_c(4) = x4
yq4_c(1) = y1
yq4_c(2) = y2
yq4_c(3) = y3
yq4_c(4) = y4
Xnode = xq4_c(1)
Ynode = yq4_c(1)
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4_c(i)
Ynode = yq4_c(i)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
7－3－3．Excel-VBA-σ1-conta-fig(σ1コンタ図）
7－3－3．Excel-VBA-σ1-conta-fig(σ1コンタ図）
7－3－3．Excel-VBA-σ1-conta-fig(σ1コンタ図）
postファイルをCTRL+A、CTRL+Cですべてコピーして、
Sheet3を作り、そこの[A2]セルに貼り付けます。
カンマで区切られたデータとして。
マクロを実行で描きます。
ここからVBAです。
Sub draw()
'FEM FIG DRAW
Dim x(5000) As Single
Dim y(5000) As Single
Dim temp(5000) As Single
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim m As Integer
Dim i1 As Integer
Dim j1 As Integer
Dim k1 As Integer
Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single
Dim elm(5000, 3) As Integer
Dim node As Integer
Dim Nelm As Integer
Sheets("sheet3").Select
node = Worksheets("sheet3").Range("A2")
Nelm = Worksheets("sheet3").Range("B2")
[A3].Select
For i = 1 To node
j = ActiveCell.Offset(i, 0).Value
x(j) = ActiveCell.Offset(i, 1).Value
y(j) = ActiveCell.Offset(i, 2).Value
Next i
For i = 1 To Nelm
j = ActiveCell.Offset(i + 1 + node, 0).Value
elm(j, 1) = ActiveCell.Offset(i + 1 + node, 1).Value
elm(j, 2) = ActiveCell.Offset(i + 1 + node, 2).Value
elm(j, 3) = ActiveCell.Offset(i + 1 + node, 3).Value
Next i
For i = 1 To node
j = ActiveCell.Offset(i + 2 + Nelm + node, 0).Value
temp(j) = ActiveCell.Offset(i + 2 + Nelm + node, 4).Value
Next i
Dim xmax As Single
Dim xmin As Single
Dim ymin As Single
Dim ymax As Single
xmax = 0#
xmin = 999#
ymin = 999#
ymax = 0#
For i = 1 To node
If (x(i) <= xmin) Then
xmin = x(i)
Else
End If
If (x(i) >= xmax) Then
xmax = x(i)
Else
End If
If (y(i) <= ymin) Then
ymin = y(i)
Else
End If
If (y(i) >= ymax) Then
ymax = y(i)
Else
End If
Next i
Set RngStart = Worksheets("sheet2").Range("B40")
xs = RngStart.Left
ys = RngStart.Top
Set RngEnd = Worksheets("sheet2").Range("D4")
ye = RngEnd.Top
xe = xs + (ys - ye)
Dim zmax As Single
Dim zmin As Single
zmax = xmax
If (ymax >= zmax) Then
zmax = ymax
Else
End If
zmin = xmin
If (ymin <= zmin) Then
zmin = ymin
Else
End If
dx = (xe - xs) / (zmax - zmin)
dy = (ye - ys) / (zmax - zmin)
xg = (xe - xs) * (-zmin / (zmax - zmin)) + xs
yg = (ye - ys) * (-zmin / (ymax - ymin)) + ys
Sheets("sheet2").Select
'outline draw start
For n = 1 To Nelm
icount = 1
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
'i-j line draw
For m = 1 To Nelm
If (n = m) Then GoTo label4
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (i = i1 And j = k1) Then GoTo label1
If (i = j1 And j = i1) Then GoTo label1
If (i = k1 And j = j1) Then GoTo label1
GoTo label4
label1:
icount = icount + 1
label4:
Next m
If (icount >= 2) Then GoTo label6
x1 = x(i) * dx + xg
y1 = y(i) * dy + yg
x2 = x(j) * dx + xg
y2 = y(j) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label6:
'j-k line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label9
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (j = i1 And k = k1) Then GoTo label2
If (j = j1 And k = i1) Then GoTo label2
If (j = k1 And k = j1) Then GoTo label2
GoTo label9
label2:
icount = icount + 1
label9:
Next m
If (icount >= 2) Then GoTo label10
x1 = x(j) * dx + xg
y1 = y(j) * dy + yg
x2 = x(k) * dx + xg
y2 = y(k) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label10:
'k-i line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label12
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (k = i1 And i = k1) Then GoTo label3
If (k = j1 And i = i1) Then GoTo label3
If (k = k1 And i = j1) Then GoTo label3
GoTo label12
label3:
icount = icount + 1
label12:
Next m
If (icount >= 2) Then GoTo label13
x1 = x(k) * dx + xg
y1 = y(k) * dy + yg
x2 = x(i) * dx + xg
y2 = y(i) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label13:
Next n
'outline draw end
'node number draw
' Dim add_str As String
' Sheets("sheet2").Select
' [G40].Select
' c = ActiveSheet.Range("G40").Select
' Dim tmp_str As String
' tmp_str = Selection.Address
' Dim it As Range
' For n = 1 To node
' xa = x(n) * dx + xg
' ya = y(n) * dy + yg
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=xa, _
' Top:=ya, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = n
' End With
' Next n
'element No. draw
' For n = 1 To Nelm
' i = elm(n, 1)
' j = elm(n, 2)
' k = elm(n, 3)
' xa = ((x(i) + x(j) + x(k)) / 3#) * dx + xg
' ya = ((y(i) + y(j) + y(k)) / 3#) * dy + yg
'element No. WRITE
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=xa, _
' Top:=ya, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = n
' End With
' Next n
'color-conta draw start
Dim myCht As Chart
Dim mySts As Series
Dim Npts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
tmin = 9999#
tmax = -9999#
n1 = 26
For i = 1 To node
If (temp(i) >= tmax) Then
tmax = temp(i)
Else
End If
If (temp(i) <= tmin) Then
tmin = temp(i)
Else
End If
Next i
For n = 1 To Nelm
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
x1 = x(i)
y1 = y(i)
t1 = temp(i)
x2 = x(j)
y2 = y(j)
t2 = temp(j)
x3 = x(k)
y3 = y(k)
t3 = temp(k)
Call sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Next n
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=0, _
Width:=80#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "Sigma-1"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=70, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MAX"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=90, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmax
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=170, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MIN"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmin
' .Size = 0.2
End With
If (tmin < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=10, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(tmin)
' .Size = 0.2
End With
Else
End If
Dim temp2(100)
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp2(i) = tmin + (i - 1) * dtemp
Next i
For i = 1 To n1 - 1
x1 = xmax * dx + xg + 100
y1 = ys - 24 * i
x2 = xmax * dx + xg + 150
y2 = y1
x3 = x2
y3 = ys - 24 * (i - 1)
x4 = x1
y4 = y3
Call poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, i)
Next i
For i = 1 To n1
x1 = xmax * dx + xg + 160
y1 = ys - 24 * (i - 1) - 10
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = temp2(i)
' .Size = 0.2
End With
If (temp2(i) < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1 + 10#, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(temp2(i))
' .Size = 0.2
End With
Else
End If
Next i
'color-conta draw end
MsgBox ("end")
End Sub
Sub sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Dim tt(3) As Single
Dim xx(3) As Single
Dim yy(3) As Single
Dim temp1(101) As Single
Dim xa As Single
Dim ya As Single
Dim xb As Single
Dim yb As Single
Dim xa1 As Single
Dim ya1 As Single
Dim xb1 As Single
Dim yb1 As Single
Dim tq As Single
Dim xq As Single
Dim yq As Single
Dim k1 As Integer
Dim k2 As Integer
Dim k3 As Integer
Dim dtemp As Single
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp1(i) = tmin + (i - 1) * dtemp
Next i
xx(1) = x1
yy(1) = y1
tt(1) = t1
xx(2) = x2
yy(2) = y2
tt(2) = t2
xx(3) = x3
yy(3) = y3
tt(3) = t3
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (tt(j) >= tt(j + 1)) Then
tq = tt(j)
tt(j) = tt(j + 1)
tt(j + 1) = tq
xq = xx(j)
xx(j) = xx(j + 1)
xx(j + 1) = xq
yq = yy(j)
yy(j) = yy(j + 1)
yy(j + 1) = yq
Else
End If
Next j
Next i
x1 = xx(1)
x2 = xx(2)
x3 = xx(3)
y1 = yy(1)
y2 = yy(2)
y3 = yy(3)
j = 0
For i = 1 To n1 - 1
If (tt(1) >= temp1(i) And tt(1) <= temp1(i + 1)) Then
If (j = 0) Then
k1 = i
j = j + 1
Else
End If
Else
End If
Next i
For i = k1 To n1 - 1
If (tt(3) >= temp1(i) And tt(3) <= temp1(i + 1)) Then
k3 = i
Else
End If
Next i
If (k1 = k3) Then
k2 = k1
Else
For i = k1 To k3
If (tt(2) >= temp1(i) And tt(2) <= temp1(i + 1)) Then
k2 = i
Else
End If
Next i
End If
k4 = k3 - k2
k5 = k2 - k1
If (k1 = k3) Then GoTo label200
If (k1 = k2) Then
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = k2 + 1) Then Call poly4(x1, y1, x2, y2, xa, ya, xb, yb, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label300:
Next i
Else
If (k2 = k3) Then
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k2) Then Call poly4(xa, ya, xb, yb, x2, y2, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label310:
Next i
Else
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label320:
Next i
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = 1) Then
icol = 2
Else
icol = i
End If
If (i = k2 + 1) Then Call poly5(xa1, ya1, xb1, yb1, xa, ya, xb, yb, x2, y2, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label330:
Next i
End If
End If
GoTo label400
label200:
If (k1 = 0) Then
icol = 1
Else
icol = k1
End If
Call poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
label400:
End Sub
Sub arctan(x1, y1, phi)
apai = 3.14159265358979
If (x1 = 0#) Then GoTo label500
a = y1 / x1
b = Atn(a)
phi = b
If (x1 <= 0# And y1 <= 0#) Then
phi = b - apai
Else
End If
If (x1 <= 0# And y1 >= 0#) Then
phi = b + apai
Else
End If
GoTo label600
label500:
If (x1 = 0# And y1 >= 0#) Then
phi = apai / 2#
Else
End If
If (x1 = 0# And y1 <= 0#) Then
phi = -apai / 2#
Else
End If
label600:
End Sub
Sub poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
Dim xq3(3) As Single
Dim yq3(3) As Single
Dim theta3(3) As Single
xq3(1) = x1
xq3(2) = x2
xq3(3) = x3
yq3(1) = y1
yq3(2) = y2
yq3(3) = y3
xq = (x1 + x2 + x3) / 3#
yq = (y1 + y2 + y3) / 3#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta3(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta3(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta3(3) = phi
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (theta3(j) <= theta3(j + 1)) Then
ta = theta3(j)
theta3(j) = theta3(j + 1)
theta3(j + 1) = ta
xq = xq3(j)
xq3(j) = xq3(j + 1)
xq3(j + 1) = xq
yq = yq3(j)
yq3(j) = yq3(j + 1)
yq3(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq3(1) * dx + xg
Ynode = yq3(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 3
Xnode = xq3(i) * dx + xg
Ynode = yq3(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4(x1, y1, x2, y2, x3, y3, x4, y4, dx, dy, xg, yg, icol)
Dim xq4(4) As Single
Dim yq4(4) As Single
Dim theta4(4) As Single
xq4(1) = x1
xq4(2) = x2
xq4(3) = x3
yq4(1) = y1
yq4(2) = y2
yq4(3) = y3
xq4(4) = x4
yq4(4) = y4
xq = (x1 + x2 + x3 + x4) / 4#
yq = (y1 + y2 + y3 + y4) / 4#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta4(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta4(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta4(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta4(4) = phi
'quick-sort
For i = 1 To 4
For j = 1 To 3
If (theta4(j) <= theta4(j + 1)) Then
ta = theta4(j)
theta4(j) = theta4(j + 1)
theta4(j + 1) = ta
xq = xq4(j)
xq4(j) = xq4(j + 1)
xq4(j + 1) = xq
yq = yq4(j)
yq4(j) = yq4(j + 1)
yq4(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq4(1) * dx + xg
Ynode = yq4(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4(i) * dx + xg
Ynode = yq4(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly5(x1, y1, x2, y2, x3, y3, x4, y4, x5, y5, dx, dy, xg, yg, icol)
Dim xq5(5) As Single
Dim yq5(5) As Single
Dim theta5(5) As Single
xq5(1) = x1
xq5(2) = x2
xq5(3) = x3
yq5(1) = y1
yq5(2) = y2
yq5(3) = y3
xq5(4) = x4
yq5(4) = y4
xq5(5) = x5
yq5(5) = y5
xq = (x1 + x2 + x3 + x4 + x5) / 5#
yq = (y1 + y2 + y3 + y4 + y5) / 5#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta5(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta5(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta5(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta5(4) = phi
xr = x5 - xq
yr = y5 - yq
Call arctan(xr, yr, phi)
theta5(5) = phi
'quick-sort
For i = 1 To 5
For j = 1 To 4
If (theta5(j) <= theta5(j + 1)) Then
ta = theta5(j)
theta5(j) = theta5(j + 1)
theta5(j + 1) = ta
xq = xq5(j)
xq5(j) = xq5(j + 1)
xq5(j + 1) = xq
yq = yq5(j)
yq5(j) = yq5(j + 1)
yq5(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq5(1) * dx + xg
Ynode = yq5(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 5
Xnode = xq5(i) * dx + xg
Ynode = yq5(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, icol)
Dim xq4_c(4) As Single
Dim yq4_c(4) As Single
xq4_c(1) = x1
xq4_c(2) = x2
xq4_c(3) = x3
xq4_c(4) = x4
yq4_c(1) = y1
yq4_c(2) = y2
yq4_c(3) = y3
yq4_c(4) = y4
Xnode = xq4_c(1)
Ynode = yq4_c(1)
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4_c(i)
Ynode = yq4_c(i)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
7－3－4．Excel-VBA-σ2-conta-fig(σ2コンタ図）
7－3－4．Excel-VBA-σ2-conta-fig(σ2コンタ図）
7－3－4．Excel-VBA-σ2-conta-fig(σ2コンタ図）
postファイルをCTRL+A、CTRL+Cですべてコピーして、
Sheet3を作り、そこの[A2]セルに貼り付けます。
カンマで区切られたデータとして。
マクロを実行で描きます。
ここからVBAです。
Sub draw()
'FEM FIG DRAW
Dim x(5000) As Single
Dim y(5000) As Single
Dim temp(5000) As Single
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim m As Integer
Dim i1 As Integer
Dim j1 As Integer
Dim k1 As Integer
Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single
Dim elm(5000, 3) As Integer
Dim node As Integer
Dim Nelm As Integer
Sheets("sheet3").Select
node = Worksheets("sheet3").Range("A2")
Nelm = Worksheets("sheet3").Range("B2")
[A3].Select
For i = 1 To node
j = ActiveCell.Offset(i, 0).Value
x(j) = ActiveCell.Offset(i, 1).Value
y(j) = ActiveCell.Offset(i, 2).Value
Next i
For i = 1 To Nelm
j = ActiveCell.Offset(i + 1 + node, 0).Value
elm(j, 1) = ActiveCell.Offset(i + 1 + node, 1).Value
elm(j, 2) = ActiveCell.Offset(i + 1 + node, 2).Value
elm(j, 3) = ActiveCell.Offset(i + 1 + node, 3).Value
Next i
For i = 1 To node
j = ActiveCell.Offset(i + 2 + Nelm + node, 0).Value
temp(j) = ActiveCell.Offset(i + 2 + Nelm + node, 5).Value
Next i
Dim xmax As Single
Dim xmin As Single
Dim ymin As Single
Dim ymax As Single
xmax = 0#
xmin = 999#
ymin = 999#
ymax = 0#
For i = 1 To node
If (x(i) <= xmin) Then
xmin = x(i)
Else
End If
If (x(i) >= xmax) Then
xmax = x(i)
Else
End If
If (y(i) <= ymin) Then
ymin = y(i)
Else
End If
If (y(i) >= ymax) Then
ymax = y(i)
Else
End If
Next i
Set RngStart = Worksheets("sheet2").Range("B40")
xs = RngStart.Left
ys = RngStart.Top
Set RngEnd = Worksheets("sheet2").Range("D4")
ye = RngEnd.Top
xe = xs + (ys - ye)
Dim zmax As Single
Dim zmin As Single
zmax = xmax
If (ymax >= zmax) Then
zmax = ymax
Else
End If
zmin = xmin
If (ymin <= zmin) Then
zmin = ymin
Else
End If
dx = (xe - xs) / (zmax - zmin)
dy = (ye - ys) / (zmax - zmin)
xg = (xe - xs) * (-zmin / (zmax - zmin)) + xs
yg = (ye - ys) * (-zmin / (ymax - ymin)) + ys
Sheets("sheet2").Select
'outline draw start
For n = 1 To Nelm
icount = 1
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
'i-j line draw
For m = 1 To Nelm
If (n = m) Then GoTo label4
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (i = i1 And j = k1) Then GoTo label1
If (i = j1 And j = i1) Then GoTo label1
If (i = k1 And j = j1) Then GoTo label1
GoTo label4
label1:
icount = icount + 1
label4:
Next m
If (icount >= 2) Then GoTo label6
x1 = x(i) * dx + xg
y1 = y(i) * dy + yg
x2 = x(j) * dx + xg
y2 = y(j) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label6:
'j-k line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label9
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (j = i1 And k = k1) Then GoTo label2
If (j = j1 And k = i1) Then GoTo label2
If (j = k1 And k = j1) Then GoTo label2
GoTo label9
label2:
icount = icount + 1
label9:
Next m
If (icount >= 2) Then GoTo label10
x1 = x(j) * dx + xg
y1 = y(j) * dy + yg
x2 = x(k) * dx + xg
y2 = y(k) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label10:
'k-i line draw
icount = 1
For m = 1 To Nelm
If (n = m) Then GoTo label12
i1 = elm(m, 1)
j1 = elm(m, 2)
k1 = elm(m, 3)
If (k = i1 And i = k1) Then GoTo label3
If (k = j1 And i = i1) Then GoTo label3
If (k = k1 And i = j1) Then GoTo label3
GoTo label12
label3:
icount = icount + 1
label12:
Next m
If (icount >= 2) Then GoTo label13
x1 = x(k) * dx + xg
y1 = y(k) * dy + yg
x2 = x(i) * dx + xg
y2 = y(i) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
label13:
Next n
'outline draw end
'node number draw
' Dim add_str As String
' Sheets("sheet2").Select
' [G40].Select
' c = ActiveSheet.Range("G40").Select
' Dim tmp_str As String
' tmp_str = Selection.Address
' Dim it As Range
' For n = 1 To node
' xa = x(n) * dx + xg
' ya = y(n) * dy + yg
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=xa, _
' Top:=ya, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = n
' End With
' Next n
'element No. draw
' For n = 1 To Nelm
' i = elm(n, 1)
' j = elm(n, 2)
' k = elm(n, 3)
' xa = ((x(i) + x(j) + x(k)) / 3#) * dx + xg
' ya = ((y(i) + y(j) + y(k)) / 3#) * dy + yg
'element No. WRITE
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=xa, _
' Top:=ya, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = n
' End With
' Next n
'color-conta draw start
Dim myCht As Chart
Dim mySts As Series
Dim Npts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
tmin = 9999#
tmax = -9999#
n1 = 26
For i = 1 To node
If (temp(i) >= tmax) Then
tmax = temp(i)
Else
End If
If (temp(i) <= tmin) Then
tmin = temp(i)
Else
End If
Next i
For n = 1 To Nelm
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
x1 = x(i)
y1 = y(i)
t1 = temp(i)
x2 = x(j)
y2 = y(j)
t2 = temp(j)
x3 = x(k)
y3 = y(k)
t3 = temp(k)
Call sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Next n
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=0, _
Width:=80#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "Sigma-2"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=70, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MAX"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=90, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmax
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=170, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = "MIN"
' .Size = 0.2
End With
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=0, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = tmin
' .Size = 0.2
End With
If (tmin < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=10, _
Top:=190, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(tmin)
' .Size = 0.2
End With
Else
End If
Dim temp2(100)
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp2(i) = tmin + (i - 1) * dtemp
Next i
For i = 1 To n1 - 1
x1 = xmax * dx + xg + 100
y1 = ys - 24 * i
x2 = xmax * dx + xg + 150
y2 = y1
x3 = x2
y3 = ys - 24 * (i - 1)
x4 = x1
y4 = y3
Call poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, i)
Next i
For i = 1 To n1
x1 = xmax * dx + xg + 160
y1 = ys - 24 * (i - 1) - 10
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = temp2(i)
' .Size = 0.2
End With
If (temp2(i) < 0#) Then
ActiveSheet.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x1 + 10#, _
Top:=y1, _
Width:=40#, _
Height:=20#).Select
Selection.Border.LineStyle = xlLineStyleNone
With Selection
.Characters.Text = Abs(temp2(i))
' .Size = 0.2
End With
Else
End If
Next i
'color-conta draw end
MsgBox ("end")
End Sub
Sub sub_color_conta(x1, y1, t1, x2, y2, t2, x3, y3, t3, xg, yg, dx, dy, tmin, tmax, n1)
Dim tt(3) As Single
Dim xx(3) As Single
Dim yy(3) As Single
Dim temp1(101) As Single
Dim xa As Single
Dim ya As Single
Dim xb As Single
Dim yb As Single
Dim xa1 As Single
Dim ya1 As Single
Dim xb1 As Single
Dim yb1 As Single
Dim tq As Single
Dim xq As Single
Dim yq As Single
Dim k1 As Integer
Dim k2 As Integer
Dim k3 As Integer
Dim dtemp As Single
dtemp = (tmax - tmin) / (n1 - 1)
For i = 1 To n1
temp1(i) = tmin + (i - 1) * dtemp
Next i
xx(1) = x1
yy(1) = y1
tt(1) = t1
xx(2) = x2
yy(2) = y2
tt(2) = t2
xx(3) = x3
yy(3) = y3
tt(3) = t3
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (tt(j) >= tt(j + 1)) Then
tq = tt(j)
tt(j) = tt(j + 1)
tt(j + 1) = tq
xq = xx(j)
xx(j) = xx(j + 1)
xx(j + 1) = xq
yq = yy(j)
yy(j) = yy(j + 1)
yy(j + 1) = yq
Else
End If
Next j
Next i
x1 = xx(1)
x2 = xx(2)
x3 = xx(3)
y1 = yy(1)
y2 = yy(2)
y3 = yy(3)
j = 0
For i = 1 To n1 - 1
If (tt(1) >= temp1(i) And tt(1) <= temp1(i + 1)) Then
If (j = 0) Then
k1 = i
j = j + 1
Else
End If
Else
End If
Next i
For i = k1 To n1 - 1
If (tt(3) >= temp1(i) And tt(3) <= temp1(i + 1)) Then
k3 = i
Else
End If
Next i
If (k1 = k3) Then
k2 = k1
Else
For i = k1 To k3
If (tt(2) >= temp1(i) And tt(2) <= temp1(i + 1)) Then
k2 = i
Else
End If
Next i
End If
k4 = k3 - k2
k5 = k2 - k1
If (k1 = k3) Then GoTo label200
If (k1 = k2) Then
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = k2 + 1) Then Call poly4(x1, y1, x2, y2, xa, ya, xb, yb, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label300:
Next i
Else
If (k2 = k3) Then
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k2) Then Call poly4(xa, ya, xb, yb, x2, y2, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label310:
Next i
Else
'side 1-2 - side 1-3 line draw
For i = k1 + 1 To k2
If (tt(3) = tt(1)) Then
ta = 1#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(1) = tt(2)) Then
tb = 1#
Else
tb = (temp1(i) - tt(1)) / (tt(2) - tt(1))
End If
If (i = 1) Then
icol = 2
Else
icol = i
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(1) + (xx(2) - xx(1)) * tb
yb = yy(1) + (yy(2) - yy(1)) * tb
If (i = k1 + 1) Then Call poly3(xa, ya, xb, yb, x1, y1, dx, dy, xg, yg, icol - 1)
If (i > k1 + 1 And i <= k2) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label320:
Next i
'side 1-3 - side 2-3 line draw
For i = k2 + 1 To k3
If (tt(3) = tt(1)) Then
ta = 0#
Else
ta = (temp1(i) - tt(1)) / (tt(3) - tt(1))
End If
If (tt(2) = tt(3)) Then
tb = 0#
Else
tb = (temp1(i) - tt(2)) / (tt(3) - tt(2))
End If
xa = xx(1) + (xx(3) - xx(1)) * ta
ya = yy(1) + (yy(3) - yy(1)) * ta
xb = xx(2) + (xx(3) - xx(2)) * tb
yb = yy(2) + (yy(3) - yy(2)) * tb
If (i = 1) Then
icol = 2
Else
icol = i
End If
If (i = k2 + 1) Then Call poly5(xa1, ya1, xb1, yb1, xa, ya, xb, yb, x2, y2, dx, dy, xg, yg, icol - 1)
If (i > k2 + 1 And i <= k3) Then Call poly4(xa, ya, xb, yb, xa1, ya1, xb1, yb1, dx, dy, xg, yg, icol - 1)
If (i = k3) Then Call poly3(xa, ya, xb, yb, x3, y3, dx, dy, xg, yg, icol)
xa1 = xa
ya1 = ya
xb1 = xb
yb1 = yb
label330:
Next i
End If
End If
GoTo label400
label200:
If (k1 = 0) Then
icol = 1
Else
icol = k1
End If
Call poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
label400:
End Sub
Sub arctan(x1, y1, phi)
apai = 3.14159265358979
If (x1 = 0#) Then GoTo label500
a = y1 / x1
b = Atn(a)
phi = b
If (x1 <= 0# And y1 <= 0#) Then
phi = b - apai
Else
End If
If (x1 <= 0# And y1 >= 0#) Then
phi = b + apai
Else
End If
GoTo label600
label500:
If (x1 = 0# And y1 >= 0#) Then
phi = apai / 2#
Else
End If
If (x1 = 0# And y1 <= 0#) Then
phi = -apai / 2#
Else
End If
label600:
End Sub
Sub poly3(x1, y1, x2, y2, x3, y3, dx, dy, xg, yg, icol)
Dim xq3(3) As Single
Dim yq3(3) As Single
Dim theta3(3) As Single
xq3(1) = x1
xq3(2) = x2
xq3(3) = x3
yq3(1) = y1
yq3(2) = y2
yq3(3) = y3
xq = (x1 + x2 + x3) / 3#
yq = (y1 + y2 + y3) / 3#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta3(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta3(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta3(3) = phi
'quick-sort
For i = 1 To 3
For j = 1 To 2
If (theta3(j) <= theta3(j + 1)) Then
ta = theta3(j)
theta3(j) = theta3(j + 1)
theta3(j + 1) = ta
xq = xq3(j)
xq3(j) = xq3(j + 1)
xq3(j + 1) = xq
yq = yq3(j)
yq3(j) = yq3(j + 1)
yq3(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq3(1) * dx + xg
Ynode = yq3(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 3
Xnode = xq3(i) * dx + xg
Ynode = yq3(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4(x1, y1, x2, y2, x3, y3, x4, y4, dx, dy, xg, yg, icol)
Dim xq4(4) As Single
Dim yq4(4) As Single
Dim theta4(4) As Single
xq4(1) = x1
xq4(2) = x2
xq4(3) = x3
yq4(1) = y1
yq4(2) = y2
yq4(3) = y3
xq4(4) = x4
yq4(4) = y4
xq = (x1 + x2 + x3 + x4) / 4#
yq = (y1 + y2 + y3 + y4) / 4#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta4(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta4(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta4(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta4(4) = phi
'quick-sort
For i = 1 To 4
For j = 1 To 3
If (theta4(j) <= theta4(j + 1)) Then
ta = theta4(j)
theta4(j) = theta4(j + 1)
theta4(j + 1) = ta
xq = xq4(j)
xq4(j) = xq4(j + 1)
xq4(j + 1) = xq
yq = yq4(j)
yq4(j) = yq4(j + 1)
yq4(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq4(1) * dx + xg
Ynode = yq4(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4(i) * dx + xg
Ynode = yq4(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly5(x1, y1, x2, y2, x3, y3, x4, y4, x5, y5, dx, dy, xg, yg, icol)
Dim xq5(5) As Single
Dim yq5(5) As Single
Dim theta5(5) As Single
xq5(1) = x1
xq5(2) = x2
xq5(3) = x3
yq5(1) = y1
yq5(2) = y2
yq5(3) = y3
xq5(4) = x4
yq5(4) = y4
xq5(5) = x5
yq5(5) = y5
xq = (x1 + x2 + x3 + x4 + x5) / 5#
yq = (y1 + y2 + y3 + y4 + y5) / 5#
xr = x1 - xq
yr = y1 - yq
Call arctan(xr, yr, phi)
theta5(1) = phi
xr = x2 - xq
yr = y2 - yq
Call arctan(xr, yr, phi)
theta5(2) = phi
xr = x3 - xq
yr = y3 - yq
Call arctan(xr, yr, phi)
theta5(3) = phi
xr = x4 - xq
yr = y4 - yq
Call arctan(xr, yr, phi)
theta5(4) = phi
xr = x5 - xq
yr = y5 - yq
Call arctan(xr, yr, phi)
theta5(5) = phi
'quick-sort
For i = 1 To 5
For j = 1 To 4
If (theta5(j) <= theta5(j + 1)) Then
ta = theta5(j)
theta5(j) = theta5(j + 1)
theta5(j + 1) = ta
xq = xq5(j)
xq5(j) = xq5(j + 1)
xq5(j + 1) = xq
yq = yq5(j)
yq5(j) = yq5(j + 1)
yq5(j + 1) = yq
Else
End If
Next j
Next i
Xnode = xq5(1) * dx + xg
Ynode = yq5(1) * dy + yg
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 5
Xnode = xq5(i) * dx + xg
Ynode = yq5(i) * dy + yg
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
Sub poly4_scale(x1, y1, x2, y2, x3, y3, x4, y4, icol)
Dim xq4_c(4) As Single
Dim yq4_c(4) As Single
xq4_c(1) = x1
xq4_c(2) = x2
xq4_c(3) = x3
xq4_c(4) = x4
yq4_c(1) = y1
yq4_c(2) = y2
yq4_c(3) = y3
yq4_c(4) = y4
Xnode = xq4_c(1)
Ynode = yq4_c(1)
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For i = 2 To 4
Xnode = xq4_c(i)
Ynode = yq4_c(i)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i
Set myShape = myBuilder.ConvertToShape
With myShape
.Fill.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.ForeColor.RGB = RGB((25 - icol) * 10, 0, (icol - 1) * 10) '
.Line.Weight = 1.5
End With
End Sub
7-3-5. FEM-PSA-VBA-POST-PROCESSER-DISPLACEMENT（変位図）
7-3-5. FEM-PSA-VBA-POST-PROCESSER-DISPLACEMENT（変位図）
7－3－5．FEM-PSA-VBA-POST-PROCESSER-DISPLACEMENT（変位図）
postファイルをCTRL+A、CTRL+Cですべてコピーして、
Sheet3を作り、そこの[A2]セルに貼り付けます。
カンマで区切られたデータとして。
マクロを実行で描きます。
ここからVBAです。
Sub draw()
'FEM FIG DRAW
Dim x(2500) As Single
Dim y(2500) As Single
Dim disp_x(2500) As Single
Dim disp_y(2500) As Single
Dim fx(2500) As Single
Dim fy(2500) As Single
Dim ix0(2500) As Integer
Dim iy0(2500) As Integer
Dim sig(5000, 3) As Single
Dim mainsig(5000, 3) As Single
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim m As Integer
Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single
Dim elm(5000, 3) As Integer
Dim node As Integer
Dim Nelm As Integer
Sheets("sheet3").Select
node = Worksheets("sheet3").Range("A2")
Nelm = Worksheets("sheet3").Range("B2")
[A3].Select
For i = 1 To node
j = ActiveCell.Offset(i, 0).Value
x(j) = ActiveCell.Offset(i, 1).Value
y(j) = ActiveCell.Offset(i, 2).Value
disp_x(j) = ActiveCell.Offset(i, 3).Value
disp_y(j) = ActiveCell.Offset(i, 4).Value
fx(j) = ActiveCell.Offset(i, 5).Value
fy(j) = ActiveCell.Offset(i, 6).Value
Next i
For i = 1 To Nelm
j = ActiveCell.Offset(i + 1 + node, 0).Value
elm(j, 1) = ActiveCell.Offset(i + 1 + node, 1).Value
elm(j, 2) = ActiveCell.Offset(i + 1 + node, 2).Value
elm(j, 3) = ActiveCell.Offset(i + 1 + node, 3).Value
sig(i, 1) = ActiveCell.Offset(i + 1 + node, 4).Value
sig(j, 2) = ActiveCell.Offset(i + 1 + node, 5).Value
sig(j, 3) = ActiveCell.Offset(i + 1 + node, 6).Value
mainsig(j, 1) = ActiveCell.Offset(i + 1 + node, 7).Value
mainsig(j, 2) = ActiveCell.Offset(i + 1 + node, 8).Value
mainsig(j, 3) = ActiveCell.Offset(i + 1 + node, 9).Value
Next i
Dim xmax As Single
Dim xmin As Single
Dim ymin As Single
Dim ymax As Single
xmax = 0#
xmin = 999#
ymin = 999#
ymax = 0#
For i = 1 To node
If (x(i) <= xmin) Then
xmin = x(i)
Else
End If
If (x(i) >= xmax) Then
amax = x(i)
Else
End If
If (y(i) <= ymin) Then
ymin = y(i)
Else
End If
If (y(i) >= ymax) Then
ymax = y(i)
Else
End If
Next i
Set RngStart = Worksheets("sheet2").Range("B40")
xs = RngStart.Left
disp_a = xs * 0.8
xs = xs * 1.5
ys = RngStart.Top
ys = ys * 0.9
Set RngEnd = Worksheets("sheet2").Range("N4")
ye = RngEnd.Top
ye = ye * 1.5
xe = xs + (ys - ye)
Dim zmax As Single
Dim zmin As Single
ActiveCell.Offset(Nelm + 3 + node, 0).Value = xs
ActiveCell.Offset(Nelm + 3 + node, 1).Value = xe
ActiveCell.Offset(Nelm + 3 + node, 2).Value = ys
ActiveCell.Offset(Nelm + 3 + node, 3).Value = ye
zmax = xmax
If (ymax >= zmax) Then
zmax = ymax
Else
End If
zmin = xmin
If (ymin <= zmin) Then
zmin = ymin
Else
End If
dx = (xe - xs) / (zmax - zmin)
dy = (ye - ys) / (zmax - zmin)
xg = (xe - xs) * (-zmin / (zmax - zmin)) + xs
yg = (ye - ys) * (-zmin / (ymax - ymin)) + ys
Sheets("sheet2").Select
For n = 1 To Nelm
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
x1 = x(i) * dx + xg
y1 = y(i) * dy + yg
x2 = x(j) * dx + xg
y2 = y(j) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
x1 = x(j) * dx + xg
y1 = y(j) * dy + yg
x2 = x(k) * dx + xg
y2 = y(k) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
x1 = x(k) * dx + xg
y1 = y(k) * dy + yg
x2 = x(i) * dx + xg
y2 = y(i) * dy + yg
ActiveSheet.Shapes.AddLine x1, y1, x2, y2
Next n
' displacement draw
disp_max = 0#
For i = 1 To node
If (Abs(disp_x(i)) >= disp_max) Then
disp_max = Abs(disp_x(i))
Else
End If
If (Abs(disp_y(i)) >= disp_max) Then
disp_max = Abs(disp_y(i))
Else
End If
Next i
ddx = disp_a / disp_max
For n = 1 To Nelm
i = elm(n, 1)
j = elm(n, 2)
k = elm(n, 3)
x1 = x(i) * dx + xg
y1 = y(i) * dy + yg
x2 = x(j) * dx + xg
y2 = y(j) * dy + yg
x1 = x1 + disp_x(i) * ddx
y1 = y1 - disp_y(i) * ddx
x2 = x2 + disp_x(j) * ddx
y2 = y2 - disp_y(j) * ddx
ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 3
x1 = x(j) * dx + xg
y1 = y(j) * dy + yg
x2 = x(k) * dx + xg
y2 = y(k) * dy + yg
x1 = x1 + disp_x(j) * ddx
y1 = y1 - disp_y(j) * ddx
x2 = x2 + disp_x(k) * ddx
y2 = y2 - disp_y(k) * ddx
ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 3
x1 = x(k) * dx + xg
y1 = y(k) * dy + yg
x2 = x(i) * dx + xg
y2 = y(i) * dy + yg
x1 = x1 + disp_x(k) * ddx
y1 = y1 - disp_y(k) * ddx
x2 = x2 + disp_x(i) * ddx
y2 = y2 - disp_y(i) * ddx
ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 3
Next n
'node number draw
' Dim add_str As String
' Sheets("sheet2").Select
' [G40].Select
' c = ActiveSheet.Range("G40").Select
' Dim tmp_str As String
' tmp_str = Selection.Address
' Dim it As Range
' For n = 1 To node
' xa = x(n) * dx + xg
' ya = y(n) * dy + yg
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=xa, _
' Top:=ya, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = n
' End With
' Next n
'main stress draw
' sigmax = 0#
' For n = 1 To Nelm
' If (Abs(mainsig(n, 1)) >= sigmax) Then
' sigmax = Abs(mainsig(n, 1))
' Else
' End If
' If (Abs(mainsig(n, 2)) >= sigmax) Then
' sigmax = Abs(mainsig(n, 2))
' Else
' End If
' Next n
' dsig = (ye - ys) / sigmax / 30#
'
' For n = 1 To Nelm
' i = elm(n, 1)
' j = elm(n, 2)
' k = elm(n, 3)
' xa = ((x(i) + x(j) + x(k)) / 3#) * dx + xg
' ya = ((y(i) + y(j) + y(k)) / 3#) * dy + yg
' Pi = 3.14159265358979
' If (mainsig(n, 1) >= 0#) Then
' Call arrow2(xa, ya, mainsig(n, 1), mainsig(n, 3), dsig)
' Else
' Call arrow1(xa, ya, mainsig(n, 1), mainsig(n, 3), dsig)
' End If
' If (mainsig(n, 2) >= 0#) Then
' Call arrow2(xa, ya, mainsig(n, 2), mainsig(n, 3) + 90#, dsig)
' Else
' Call arrow1(xa, ya, mainsig(n, 2), mainsig(n, 3) + 90#, dsig)
' End If
' Call arrow2(15#, 325#, sigmax, 90#, dsig)
'
'max main stress WRITE
' ActiveSheet.Shapes.AddTextbox( _
' Orientation:=msoTextOrientationHorizontal, _
' Left:=5#, _
' Top:=350#, _
' Width:=40#, _
' Height:=20#).Select
' Selection.Border.LineStyle = xlLineStyleNone
' With Selection
' .Characters.Text = sigmax
' End With
' Next n
MsgBox ("end")
End Sub
Sub arrow1(x1, y1, sig1, theta, dsig)
Pi = 3.14159265358979
th1 = theta * Pi / 180#
th2 = (theta + 15#) * Pi / 180#
th3 = (theta - 15#) * Pi / 180#
x2 = x1 + sig1 * dsig * Cos(th1)
y2 = y1 + sig1 * dsig * Sin(th1)
x3 = x1 - sig1 * dsig * Cos(th1)
y3 = y1 - sig1 * dsig * Sin(th1)
x4 = x2 - 5# * Cos(th3)
y4 = y2 - 5# * Sin(th3)
x5 = x2 - 5# * Cos(th2)
y5 = y2 - 5# * Sin(th2)
x6 = x3 + 5# * Cos(th3)
y6 = y3 + 5# * Sin(th3)
x7 = x3 + 5# * Cos(th2)
y7 = y3 + 5# * Sin(th2)
ActiveSheet.Shapes.AddLine x4, y4, x2, y2
ActiveSheet.Shapes.AddLine x2, y2, x5, y5
ActiveSheet.Shapes.AddLine x6, y6, x3, y3
ActiveSheet.Shapes.AddLine x3, y3, x7, y7
ActiveSheet.Shapes.AddLine x2, y2, x3, y3
End Sub
Sub arrow2(x1, y1, sig1, theta, dsig)
Pi = 3.14159265358979
th1 = theta * Pi / 180#
th2 = (theta + 15#) * Pi / 180#
th3 = (theta - 15#) * Pi / 180#
x2 = x1 + sig1 * dsig * Cos(th1)
y2 = y1 + sig1 * dsig * Sin(th1)
x3 = x1 - sig1 * dsig * Cos(th1)
y3 = y1 - sig1 * dsig * Sin(th1)
x4 = x2 + 5# * Cos(th2)
y4 = y2 + 5# * Sin(th2)
x5 = x2 + 5# * Cos(th3)
y5 = y2 + 5# * Sin(th3)
x6 = x3 - 5# * Cos(th2)
y6 = y3 - 5# * Sin(th2)
x7 = x3 - 5# * Cos(th3)
y7 = y3 - 5# * Sin(th3)
ActiveSheet.Shapes.AddLine x4, y4, x2, y2
ActiveSheet.Shapes.AddLine x2, y2, x5, y5
ActiveSheet.Shapes.AddLine x6, y6, x3, y3
ActiveSheet.Shapes.AddLine x3, y3, x7, y7
ActiveSheet.Shapes.AddLine x2, y2, x3, y3
End Sub
7－4．FEM理論（Ritz法）（変位法）
7－4．FEM理論（Ritz法）（変位法）
01_Plane_Stress_Analysis_by_FEM.docx7－5．有孔平板理論解導出（C.T。ワン 応用弾性学）
7－5．有孔平板理論解導出（C.T。ワン 応用弾性学）
02_yuukouheibann_stress_concentration_theory_solution.docx7－6．今回の解析例での応力集中を中心断面をX軸にとり、σYを三角形座標の中心にとり、手計算で求めプロットしたものが、下図です。
7－6．今回の解析例での応力集中を中心断面をX軸にとり、σYを三角形座標の中心にとり、手計算で求めプロットしたものが、下図です。
Page updated
Google Sites
Report abuse