SAP2000简单模型输出到MARC

程序编制人：陆新征，清华大学土木工程系

程序分别VB和Fortran编写，很简单，应该不难看懂

VB程序段

VERSION 5.00
Begin VB.Form Form1
Caption = "SAP2K to MARC转换器0.11版本"
ClientHeight = 3195
ClientLeft = 60
ClientTop = 345
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command2
Caption = "退出程序"
Height = 495
Left = 2640
TabIndex = 1
Top = 2160
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "开始转换"
Height = 495
Left = 600
TabIndex = 0
Top = 2160
Width = 1335
End
Begin VB.Label Label2
Caption = "程序作者：清华大学土木工程系，陆新征"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 240
TabIndex = 3
Top = 1200
Width = 4335
End
Begin VB.Label Label1
Caption = "将SAP 2000 v9 以上版本*.s2k程序中的框架和剪力墙信息转换至MSC.MARC2003以上版本。转换得到的MARC输入文件为data.mfd。"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 975
Left = 240
TabIndex = 2
Top = 120
Width = 4215
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
Call SAP2KREAD
End Sub

Public Sub SAP2KREAD()
Dim JointInfo(1 To 1000000, 0 To 3) As Double
Dim FrameInfo(1 To 1000000, 0 To 3) As Double '0 编号，1~2 节点信息，3 截面编号
Dim AreaInfo(1 To 1000000, 0 To 6) As Double '0 编号，1~4 节点信息，5 厚度，6 截面编号
Dim FrameSection$(0 To 10000) '0 截面编号数量，1~ 截面编号名称
Dim AreaSection$(0 To 10000) '0 截面编号数量，1~ 截面编号名称
Dim SectionInfo(1 To 10000, 0 To 6) As Double '0 截面编号，1 fc, 2 fy, 3 t2, 4 t3, 5 cover, 6 rebarsize
Dim WorkArray() As Double

Dim Inside_Table As Integer
Dim Inside_Table_Joint As Integer
Dim Inide_Table_Frame_Con As Integer
Dim Inide_Table_Area_Con As Integer
Dim Inside_Table_Frame_Section As Integer
Dim Inside_Table_Area_Section As Integer
Dim Inside_Table_Concrete As Integer
Dim Inside_Table_FSection_Prop As Integer
Dim Inside_Table_Concrete_Column As Integer
Dim Inside_Table_Area_Prop As Integer

Dim JointNo As Long
Dim FrameNo As Long
Dim AreaNo As Long

Inside_Table = 0 ' 是否属于一个Table
Inside_Table_Joint = 0 '是否在Joint 定义Table里面
JointNo = 0
FrameNo = 0
AreaNo = 0
FrameSection$(0) = "0"
AreaSection$(0) = "0"

File$ = InputBox("请输入SAP2000(*.s2k)文件名称，必须包括后缀名")

Open File$ For Input As #1
Open "debug.txt" For Output As #2
For I = 1 To 1000000
If EOF(1) = True Then
Exit For
End If

Input #1, A$
'Write #2, A$

If Mid(A$, 1, 5) = "TABLE" Then '在table之内
Inside_Table = 0
Else
Inside_Table = 1
End If

If Len(A$) < 2 Then '在table之外
Inside_Table = 0
Inside_Table_Joint = 0
Inide_Table_Frame_Con = 0
Inide_Table_Area_Con = 0
Inside_Table_Frame_Section = 0
Inside_Table_Area_Section = 0
Inside_Table_Concrete = 0
Inside_Table_FSection_Prop = 0
Inside_Table_Concrete_Column = 0
Inside_Table_Area_Prop = 0
End If

If Mid(A$, 10, 40) = "MATERIAL PROPERTIES 04 - DESIGN CONCRETE" Then
Inside_Table_Concrete = 1
End If

If Mid(A$, 10, 37) = "FRAME SECTION PROPERTIES 01 - GENERAL" Then
Inside_Table_FSection_Prop = 1
End If

If Mid(A$, 10, 45) = "FRAME SECTION PROPERTIES 02 - CONCRETE COLUMN" Then
Inside_Table_Concrete_Column = 1
End If

If Mid(A$, 10, 23) = "AREA SECTION PROPERTIES" Then
Inside_Table_Area_Prop = 1
End If
If Mid(A$, 10, 17) = "JOINT COORDINATES" Then
Inside_Table_Joint = 1
End If

If Mid(A$, 10, 20) = "CONNECTIVITY - FRAME" Then
Inide_Table_Frame_Con = 1
End If

If Mid(A$, 10, 19) = "CONNECTIVITY - AREA" Then
Inide_Table_Area_Con = 1
End If

If Mid(A$, 10, 25) = "FRAME SECTION ASSIGNMENTS" Then
Inside_Table_Frame_Section = 1
End If

If Mid(A$, 10, 24) = "AREA SECTION ASSIGNMENTS" Then
Inside_Table_Area_Section = 1
End If

If (Inside_Table = 1 And Inside_Table_Concrete = 1) Then '读取混凝土信息
ReDim WorkArray(0 To 6)
Call ReadConcrete(A$, SectionInfo, WorkArray)
End If

If (Inside_Table = 1 And Inside_Table_FSection_Prop = 1) Then '读取框架截面信息
Call ReadFSectionProp(A$, FrameSection$, SectionInfo)
End If

If (Inside_Table = 1 And Inside_Table_Concrete_Column = 1) Then '读取柱子配筋信息
Call ReadColumnProp(A$, FrameSection$, SectionInfo)
End If

If (Inside_Table = 1 And Inside_Table_Area_Prop = 1) Then ' 读取墙板截面名称
Call ReadAreaProp(A$, AreaSection$)
End If

If (Inside_Table = 1 And Inside_Table_Joint = 1) Then '读取节点坐标
JointNo = JointNo + 1
ReDim WorkArray(0 To 3)
Call ReadJoint(A$, WorkArray)
JointInfo(JointNo, 0) = WorkArray(0): JointInfo(JointNo, 1) = WorkArray(1):
JointInfo(JointNo, 2) = WorkArray(2): JointInfo(JointNo, 3) = WorkArray(3):
Write #2, "读取节点坐标", JointInfo(JointNo, 0), JointInfo(JointNo, 1), JointInfo(JointNo, 2), JointInfo(JointNo, 3)
End If

If (Inside_Table = 1 And Inide_Table_Frame_Con = 1) Then '读取框架节点信息
FrameNo = FrameNo + 1
ReDim WorkArray(0 To 2)
Call ReadFrameCon(A$, WorkArray)
FrameInfo(FrameNo, 0) = WorkArray(0): FrameInfo(FrameNo, 1) = WorkArray(1):
FrameInfo(FrameNo, 2) = WorkArray(2):

Write #2, "读取框架节点信息", FrameInfo(FrameNo, 0), FrameInfo(FrameNo, 1), FrameInfo(FrameNo, 2)
End If

If (Inside_Table = 1 And Inide_Table_Area_Con = 1) Then '读取墙板节点信息
AreaNo = AreaNo + 1
ReDim WorkArray(0 To 5)
Call ReadAreaCon(A$, WorkArray)
AreaInfo(AreaNo, 0) = WorkArray(0): AreaInfo(AreaNo, 1) = WorkArray(1):
AreaInfo(AreaNo, 2) = WorkArray(2): AreaInfo(AreaNo, 3) = WorkArray(3):
AreaInfo(AreaNo, 4) = WorkArray(4): AreaInfo(AreaNo, 5) = WorkArray(5):
Write #2, "读取墙板节点信息", AreaInfo(AreaNo, 0), AreaInfo(AreaNo, 1), AreaInfo(AreaNo, 2), AreaInfo(AreaNo, 3), AreaInfo(AreaNo, 4), AreaInfo(AreaNo, 5)
End If

If (Inside_Table = 1 And Inside_Table_Frame_Section = 1) Then '读取框架截面信息
ReDim WorkArray(0 To 3)
Call ReadFrameSection(A$, FrameSection$, WorkArray)
For J = 1 To 1000000
If FrameInfo(J, 0) = WorkArray(0) Then ' 单元编号相同
FrameInfo(J, 3) = WorkArray(3)
Exit For
End If
Next J
Write #2, "读取框架截面信息", FrameInfo(J, 0), FrameInfo(J, 3)
End If

If (Inside_Table = 1 And Inside_Table_Area_Section = 1) Then '读取墙板截面信息
ReDim WorkArray(0 To 6)
Call ReadAreaSection(A$, AreaSection$, WorkArray)
For J = 1 To 1000000
If AreaInfo(J, 0) = WorkArray(0) Then ' 单元编号相同
AreaInfo(J, 6) = WorkArray(6)
Exit For
End If
Next J
Write #2, "读取墙板截面信息; ", AreaInfo(J, 0), AreaInfo(J, 6)
End If
Next I
For J = 1 To Val(FrameSection$(0))
Write #2, SectionInfo(J, 0), SectionInfo(J, 1), SectionInfo(J, 2), SectionInfo(J, 3), SectionInfo(J, 4), SectionInfo(J, 5), SectionInfo(J, 6)
Next J

Open "out.txt" For Output As #3

Write #3, JointNo
For I = 1 To JointNo
Write #3, JointInfo(I, 0), JointInfo(I, 1), JointInfo(I, 2), JointInfo(I, 3)
Next I

Write #3, FrameNo
For I = 1 To FrameNo
Write #3, FrameInfo(I, 0), FrameInfo(I, 1), FrameInfo(I, 2), FrameInfo(I, 3)
Next I

Write #3, AreaNo
For I = 1 To AreaNo
Write #3, AreaInfo(I, 0), AreaInfo(I, 1), AreaInfo(I, 2), AreaInfo(I, 3), AreaInfo(I, 4), AreaInfo(I, 6)
Next I

Write #3, Val(FrameSection$(0))
For I = 1 To Val(FrameSection$(0))
Write #3, FrameSection(I)
Write #3, SectionInfo(I, 0), SectionInfo(I, 1), SectionInfo(I, 2), SectionInfo(I, 3), SectionInfo(I, 4), SectionInfo(I, 5), SectionInfo(I, 6)
Next I

Write #3, Val(AreaSection$(0))
For I = 1 To Val(AreaSection$(0))
Write #3, AreaSection(I)
Next I
Close #3

Close #1
Close #2

I = WinExec("Makemfd.exe", 1)

End Sub

Public Sub ReadAreaProp(A$, AreaSection$())
'Section=WALL01 Material=CONC MatAngle=0 AreaType=Shell Type=Shell-Thin Thickness=.2 BendThick=.2 Color=Yellow TotalWt=84827.2378139245 TotalMass=8649.97058199665 F11Mod=1 F22Mod=1 F12Mod=1 M11Mod=1 M22Mod=1
For I = 1 To Len(A$)
If Mid(A$, I, 8) = "Section=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 7 + J, 1) = " " Then
N$ = (Mid(A$, I + 7 + 1, J - 1))
Exit For
End If
Next J
End If
Next I
For J = 1 To 10000
If AreaSection$(J) = N$ Then ' 已有截面名称
Exit For
End If
If J > Val(AreaSection$(0)) Then
AreaSection$(0) = Str(Val(AreaSection$(0) + 1))
AreaSection$(J) = N$
Exit For
End If
Next J

End Sub

Public Sub ReadColumnProp(A$, FrameSection$(), SectionInfo)
'SectionName=BEAM ReinfConfig=Rectangular LatReinf=Ties Cover=.05 NumBars3Dir=2 NumBars2Dir=2 BarSize=#9 ReinfType=Check
For I = 1 To Len(A$)
If Mid(A$, I, 12) = "SectionName=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 11 + J, 1) = " " Then
N$ = (Mid(A$, I + 11 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 6) = "Cover=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 5 + J, 1) = " " Then
Cover = Val(Mid(A$, I + 5 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 8) = "BarSize=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 7 + J, 1) = " " Then
Rebar = Val(Mid(A$, I + 7 + 1, J - 1))
Exit For
End If
Next J
End If
Next I
For J = 1 To 10000
If FrameSection$(J) = N$ Then ' 已有截面名称
SectionInfo(J, 0) = J
SectionInfo(J, 5) = Cover
SectionInfo(J, 6) = Rebar
Exit For
End If
If J > Val(FrameSection$(0)) Then
FrameSection$(0) = Str(Val(FrameSection$(0) + 1))
FrameSection$(J) = N$
SectionInfo(J, 0) = J
SectionInfo(J, 5) = Cover
SectionInfo(J, 6) = Rebar

Exit For
End If
Next J

End Sub

Public Sub ReadFSectionProp(A$, FrameSection$(), SectionInfo)
'SectionName=BEAM Material=CONC Shape=Rectangular t3=.4572 t2=.254 Area=.1161288 TorsConst=1.63024133627271E-03 I33=.002022884728416 I22=.0006243471384 AS2=.096774 AS3=.096774 S33=.00884901456 S22=.0049161192
For I = 1 To Len(A$)
If Mid(A$, I, 12) = "SectionName=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 11 + J, 1) = " " Then
N$ = (Mid(A$, I + 11 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 3) = "t3=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 2 + J, 1) = " " Then
t3 = Val(Mid(A$, I + 2 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 3) = "t2=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 2 + J, 1) = " " Then
t2 = Val(Mid(A$, I + 2 + 1, J - 1))
Exit For
End If
Next J
End If
Next I
For J = 1 To 10000
If FrameSection$(J) = N$ Then ' 已有截面名称
SectionInfo(J, 0) = J
SectionInfo(J, 3) = t2
SectionInfo(J, 4) = t3
Exit For
End If
If J > Val(FrameSection$(0)) Then
FrameSection$(0) = Str(Val(FrameSection$(0) + 1))
FrameSection$(J) = N$
SectionInfo(J, 0) = J
SectionInfo(J, 3) = t2
SectionInfo(J, 4) = t3

Exit For
End If
Next J

End Sub
Public Sub ReadConcrete(A$, SectionInfo, WorkArray)
' Material=CONC Fc=27579031.5580631 RebarFy=413685473.370947 RebarFys=275790315.580631 LtWtConc=No LtWtFact=1
For I = 1 To Len(A$)
If Mid(A$, I, 3) = "Fc=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 2 + J, 1) = " " Then
Fc = Val(Mid(A$, I + 2 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 8) = "RebarFy=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 7 + J, 1) = " " Then
Fy = (Mid(A$, I + 7 + 1, J - 1))
Exit For
End If
Next J
End If

Next I
For I = 1 To 10000
SectionInfo(I, 1) = Fc
SectionInfo(I, 2) = Fy
Next I

End Sub
Public Sub ReadAreaSection(A$, AreaSection$(), AreaInfo)
'Area=1 Section=WALL01 MatProp=Default ThickOver=None OffsetOver=None
For I = 1 To Len(A$)
If Mid(A$, I, 5) = "Area=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 4 + J, 1) = " " Then
AreaInfo(0) = Val(Mid(A$, I + 4 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 8) = "Section=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 7 + J, 1) = " " Then
N$ = (Mid(A$, I + 7 + 1, J - 1))
Exit For
End If
Next J
End If

Next I
For J = 1 To 10000
If AreaSection$(J) = N$ Then ' 已有截面名称
AreaInfo(6) = J
Exit For
End If
If J > Val(AreaSection$(0)) Then
AreaSection$(0) = Str(Val(AreaSection$(0) + 1))
AreaSection$(J) = N$
AreaInfo(6) = J
Exit For
End If
Next J
End Sub


Public Sub ReadFrameSection(A$, FrameSection$(), FrameInfo)
'Frame=1 SectionType=Rectangular AutoSelect=N.A. AnalSect=COLUMN DesignSect=COLUMN MatProp=Default
For I = 1 To Len(A$)
If Mid(A$, I, 6) = "Frame=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 5 + J, 1) = " " Then
FrameInfo(0) = Val(Mid(A$, I + 5 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 9) = "AnalSect=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 8 + J, 1) = " " Then
N$ = (Mid(A$, I + 8 + 1, J - 1))
Exit For
End If
Next J
End If

Next I
For J = 1 To 10000
If FrameSection$(J) = N$ Then ' 已有截面名称
FrameInfo(3) = J
Exit For
End If
If J > Val(FrameSection$(0)) Then
FrameSection$(0) = Str(Val(FrameSection$(0) + 1))
FrameSection$(J) = N$
FrameInfo(3) = J
Exit For
End If
Next J
End Sub

Public Sub ReadAreaCon(A$, AreaInfo)
'Area=1 Joint1=4 Joint2=1 Joint3=5 Joint4=2 AreaArea=18 Perimeter=18 Volume=3.6 CentroidX=-9 CentroidY=-3 CentroidZ=1.5
For I = 1 To Len(A$)
If Mid(A$, I, 5) = "Area=" And I < 2 Then
For J = 1 To Len(A$)
If Mid(A$, I + 4 + J, 1) = " " Then
AreaInfo(0) = Val(Mid(A$, I + 4 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 7) = "Joint1=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 6 + J, 1) = " " Then
AreaInfo(1) = Val(Mid(A$, I + 6 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 7) = "Joint2=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 6 + J, 1) = " " Then
AreaInfo(2) = Val(Mid(A$, I + 6 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 7) = "Joint3=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 6 + J, 1) = " " Then
AreaInfo(3) = Val(Mid(A$, I + 6 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 7) = "Joint4=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 6 + J, 1) = " " Then
AreaInfo(4) = Val(Mid(A$, I + 6 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 9) = "AreaArea=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 8 + J, 1) = " " Then
x = Val(Mid(A$, I + 8 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 7) = "Volume=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 6 + J, 1) = " " Then
Y = Val(Mid(A$, I + 6 + 1, J - 1))
AreaInfo(5) = Y / x
Exit For
End If
Next J
End If

Next I
End Sub

Public Sub ReadFrameCon(A$, FrameInfo)
'Frame=1 JointI=1 JointJ=2 IsCurved=No Length=3 CentroidX=-9 CentroidY=-6 CentroidZ=1.5
For I = 1 To Len(A$)
If Mid(A$, I, 6) = "Frame=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 5 + J, 1) = " " Then
FrameInfo(0) = Val(Mid(A$, I + 5 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 7) = "JointI=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 6 + J, 1) = " " Then
FrameInfo(1) = Val(Mid(A$, I + 6 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 7) = "JointJ=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 6 + J, 1) = " " Then
FrameInfo(2) = Val(Mid(A$, I + 6 + 1, J - 1))
Exit For
End If
Next J
End If

Next I
End Sub


Public Sub ReadJoint(A$, JointInfo)
'Joint=1 CoordSys=GLOBAL CoordType=Cartesian XorR=-9 Y=-6 Z=0 SpecialJt=No GlobalX=-9 GlobalY=-6 GlobalZ=0
For I = 1 To Len(A$)
If Mid(A$, I, 6) = "Joint=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 5 + J, 1) = " " Then
JointNo = Val(Mid(A$, I + 5 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 8) = "GlobalX=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 7 + J, 1) = " " Then
JointX = Val(Mid(A$, I + 7 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 8) = "GlobalY=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 7 + J, 1) = " " Then
JointY = Val(Mid(A$, I + 7 + 1, J - 1))
Exit For
End If
Next J
End If
If Mid(A$, I, 8) = "GlobalZ=" Then
For J = 1 To Len(A$)
If Mid(A$, I + 7 + J, 1) = " " Or I + 7 + J > Len(A$) Then
JointZ = Val(Mid(A$, I + 7 + 1, J - 1))
Exit For
End If
Next J
End If

Next I
JointInfo(0) = JointNo
JointInfo(1) = JointX
JointInfo(2) = JointY
JointInfo(3) = JointZ

End Sub

Private Sub Command2_Click()
End
End Sub

Fortran程序段

module TypDef
type :: typ_Node
integer :: ID
real*8 :: Coord(3)
end type
type :: typ_Frame
integer :: ID
integer :: NodeNo(2)
integer :: Inter_NodeNo(2)
integer :: SetNo
end type
type :: typ_Wall
integer :: ID
integer :: NodeNo(4)
integer :: Inter_NodeNo(4)
real*8 :: Thickness
integer :: SetNo
end type
type :: Typ_Frame_Section
character*20 :: Name
real*8 :: Prop(6)
end type
type :: Typ_Area_Section
character*20 :: Name
real*8 :: Prop
end type
end module

program Main
use TypDef
implicit none
integer NNode, NFrame, NWall,NFrameSection,NAreaSection
type(typ_Node) :: Node(1000000)
type(typ_Frame) :: Frame(1000000)
type(typ_Wall) :: Wall(1000000)
type(Typ_Frame_Section) :: FrameSection(1000000)
type(Typ_Area_Section) :: AreaSection(1000000)

integer :: I,J,K,II
integer :: ElemNo
integer :: SetElem(0:10000000), SetNo

open(55,file="out.txt")
open(66,file="Data.mfd")
write(66,'(A38)') "Version : MSC.Marc Mentat 2003 (32bit)"

! Start Transmit Nodes
write(66,'(A18)') "=beg= 102 (nodes)"
read(55,*) NNode
do I=1, NNode
read(55,*) Node(I)%ID, Node(I)%Coord(1:3)
write(66,'(I20, 3E20.5)') I, Node(I)%Coord(1:3)
write(66,'(2I20)') 0,0
end do
write(66,'(A5)') "=end="

! Start Transmit Frames
write(66,'(A21)') "=beg= 203 (elements)"
read(55,*) NFrame
do I=1, NFrame
read(55,*) Frame(I)%ID, Frame(I)%NodeNo(1:2), Frame(I)%SetNo
do II=1, NNode
if(Frame(I)%NodeNo(1)==Node(II)%ID) then
Frame(I)%Inter_NodeNo(1)=II
end if
if(Frame(I)%NodeNo(2)==Node(II)%ID) then
Frame(I)%Inter_NodeNo(2)=II
end if
end do
write(66,'(4I20)') I, 0, 0, 0
write(66,'(4I20)') 0, 0, 0, 2
write(66,'(4I20)') Frame(I)%Inter_NodeNo(1:2),0,0
!write(66,'(I20)') 0
end do

! Start Transmit Area
read(55,*) NWall
do I=1, NWall
read(55,*) Wall(I)%ID, Wall(I)%NodeNo(1:4), Wall(I)%SetNo
do II=1, NNode
if(Wall(I)%NodeNo(1)==Node(II)%ID) then
Wall(I)%Inter_NodeNo(1)=II
end if
if(Wall(I)%NodeNo(2)==Node(II)%ID) then
Wall(I)%Inter_NodeNo(2)=II
end if
if(Wall(I)%NodeNo(3)==Node(II)%ID) then
Wall(I)%Inter_NodeNo(3)=II
end if
if(Wall(I)%NodeNo(4)==Node(II)%ID) then
Wall(I)%Inter_NodeNo(4)=II
end if
end do
write(66,'(4I20)') I+NFrame, 4, 0, 0
write(66,'(4I20)') 0,0,0,4
write(66,'(4I20)') Wall(I)%Inter_NodeNo(1:2),Wall(I)%Inter_NodeNo(4),Wall(I)%Inter_NodeNo(3)
write(66,'(2I20)') 0,0
end do

write(66,'(A5)') "=end="

! Read Frame Section Property
read(55,*) NFrameSection
do I=1, NFrameSection
read(55,*) FrameSection(I)%Name
read(55,*) FrameSection(I)%Prop(1:6)
end do
read(55,*) NAreaSection
do I=1, NAreaSection
read(55,*) AreaSection(I)%Name
end do

write(66,'(A17)') "=beg= 1201 (sets)"
SetNo=0
do I=1, NFrameSection
SetElem(0)=0
K=0
do J=1, NFrame

if(Frame(J)%SetNo==I) then ! 存在单元属于该Set
SetElem(0)=SetElem(0)+1
SetElem(SetElem(0))=J
K=1 ! 本选择集不为空
end if
end do
SetElem(1+ SetElem(0):2*SetElem(0))=0;
SetElem(1+2*SetElem(0):3*SetElem(0))=0;
if (K>0) then
SetNo=SetNo+1
write(66,'(A20)') FrameSection(I)%Name
write(66,'(4I20)') SetNo, 1, SetElem(0),1
write(66,'(4I20)') SetElem(1:3*SetElem(0))
! do J=1,SetElem(0)
! write(*,*) J, I, Frame(SetElem(J))%SetNo
! end do
end if
end do
do I=1, NAreaSection
SetElem(0)=0
K=0
do J=1, NWall
if(Wall(J)%SetNo==I) then ! 存在单元属于该Set
SetElem(0)=SetElem(0)+1
SetElem(SetElem(0))=J+NFrame
K=1 ! 本选择集不为空
end if
end do
SetElem(1+ SetElem(0):2*SetElem(0))=0;
SetElem(1+2*SetElem(0):3*SetElem(0))=0;
if (K>0) then
SetNo=SetNo+1
write(66,'(A20)') AreaSection(I)%Name
write(66,'(4I20)') SetNo, 1, SetElem(0),1
write(66,'(4I20)') SetElem(1:3*SetElem(0))
end if
end do

write(66,'(A5)') "=end="

close (66)
close (55)

stop
end program

个人信息
研究工作
实际工程
论文工作
教学工作
资料下载
专题
其他

 

我们的实验室