Option Explicit On
Option Strict On
Public Class Form3
    Private KTE As Integer = 10000
    Private KTJ As Integer = 10000
    Private KED As Integer = 10000
    Private KCM As Integer = 100


    Private Sub Form3_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Call QUAD()

        Dim fm4 As New Form4()
        fm4.Show()
        Me.Close()
    End Sub


    Private Sub QUAD()
        Dim NODE As Integer
        Dim NELM As Integer

        Dim mtj(,) As Integer
        Dim px() As Double
        Dim py() As Double
        Dim ifix() As Integer
        Dim jac(,) As Integer
        Dim idm() As Integer
        Dim mmtj(,) As Integer
        Dim kv() As Integer
        Dim id() As Integer
        Dim map() As Integer

        ReDim mtj(KTE, 9)
        ReDim px(KTJ)
        ReDim py(KTJ)
        ReDim ifix(KTJ)
        ReDim jac(KTE, 4)
        ReDim idm(KTE)
        ReDim mmtj(KTE, 4)
        ReDim kv(KTE)
        ReDim id(KTE)
        ReDim map(KTE)

        Call QUINPUT(NODE, NELM, mtj, jac, idm, ifix, px, py)
        Call QUEXELM(NODE, NELM, mtj, jac, kv, idm, map, px, py)
        Call QUISOGEN(NODE, NELM, mtj, jac, px, py, id, mmtj, ifix, idm)
        Call QUDATA(NODE, NELM, mmtj, px, py, ifix)

    End Sub


    Private Sub QUINPUT(ByRef NODE As Integer, ByRef NELM As Integer, ByRef mtj(,) As Integer, _
    ByRef jac(,) As Integer, ByRef idm() As Integer, ByRef ifix() As Integer, ByRef px() As Double, ByRef py() As Double)
        Dim sr As System.IO.StreamReader
        Dim dat As String
        Dim sbuf() As String
        Dim delim() As Char = {","c}
        Dim fname1 As String
        Dim i As Integer

        fname1 = My.Forms.Form1.Label1.Text
        fname1 = System.IO.Path.GetDirectoryName(fname1)
        fname1 = fname1 & "\workf2.csv"
        sr = New System.IO.StreamReader(fname1, System.Text.Encoding.Default)
        dat = sr.ReadLine() : sbuf = dat.Split(delim)
        NODE = CInt(sbuf(0))
        NELM = CInt(sbuf(1))
        For i = 1 To NELM
            dat = sr.ReadLine() : sbuf = dat.Split(delim)
            mtj(i, 1) = CInt(sbuf(0))
            mtj(i, 2) = CInt(sbuf(1))
            mtj(i, 3) = CInt(sbuf(2))
            jac(i, 1) = CInt(sbuf(3))
            jac(i, 2) = CInt(sbuf(4))
            jac(i, 3) = CInt(sbuf(5))
            idm(i) = CInt(sbuf(6))
        Next i
        For i = 1 To NODE
            dat = sr.ReadLine() : sbuf = dat.Split(delim)
            px(i) = CDbl(sbuf(0))
            py(i) = CDbl(sbuf(1))
            ifix(i) = CInt(sbuf(2))
        Next i
        sr.Close()

    End Sub


    Private Sub QUEXELM(ByRef NODE As Integer, ByRef NELM As Integer, ByRef mtj(,) As Integer, _
    ByRef jac(,) As Integer, ByRef kv() As Integer, ByRef idm() As Integer, ByRef map() As Integer, _
    ByRef px() As Double, ByRef py() As Double)
        Dim i As Integer
        Dim j As Integer
        Dim iv As Integer
        Dim ip As Integer
        Dim jn As Integer
        Dim ie1 As Integer
        Dim ie2 As Integer
        Dim ie3 As Integer
        Dim ia As Integer
        Dim ib As Integer
        Dim ic As Integer
        Dim jacia As Integer
        Dim jacib As Integer
        Dim inn1 As Integer
        Dim inn2 As Integer
        Dim ien1 As Integer
        Dim ien2 As Integer
        Dim pxa As Double
        Dim pya As Double
        Dim pxb As Double
        Dim pyb As Double
        Dim pxc As Double
        Dim pyc As Double
        Dim px12 As Double
        Dim py12 As Double
        Dim px23 As Double
        Dim py23 As Double
        Dim pl12 As Double
        Dim pl23 As Double
        Dim pl(3) As Double

        iv = 0
        For i = 1 To NELM
            If mtj(i, 1) = 0 Then GoTo quexelm10
            If mtj(i, 4) <> 0 Then GoTo quexelm10
            pxa = px(mtj(i, 1)) - px(mtj(i, 2))
            pya = py(mtj(i, 1)) - py(mtj(i, 2))
            pxb = px(mtj(i, 2)) - px(mtj(i, 3))
            pyb = py(mtj(i, 2)) - py(mtj(i, 3))
            pxc = px(mtj(i, 3)) - px(mtj(i, 1))
            pyc = py(mtj(i, 3)) - py(mtj(i, 1))
            pl(1) = pxa * pxa + pya * pya
            pl(2) = pxb * pxb + pyb * pyb
            pl(3) = pxc * pxc + pyc * pyc
            For j = 1 To 3
                If (pl((j Mod 3) + 1) < pl(j)) And (pl(((j + 1) Mod 3) + 1) < pl(j)) Then
                    ip = j
                    GoTo quexelm30
                End If
            Next j
quexelm30:
            jn = jac(i, ip)
            If idm(i) <> idm(jn) Then GoTo quexelm10
            If mtj(jn, 4) <> 0 Then GoTo quexelm10
            If jn = 0 Then GoTo quexelm10
            Call QUEDGE(jn, i, jac, ie1)
            ie2 = (ie1 Mod 3) + 1
            ie3 = (ie2 Mod 3) + 1
            px12 = px(mtj(jn, ie2)) - px(mtj(jn, ie3))
            py12 = py(mtj(jn, ie2)) - py(mtj(jn, ie3))
            px23 = px(mtj(jn, ie3)) - px(mtj(jn, ie1))
            py23 = py(mtj(jn, ie3)) - py(mtj(jn, ie1))
            pl12 = px12 * px12 + py12 * py12
            pl23 = px23 * px23 + py23 * py23
            If (pl(ip) < pl12) Or (pl(ip) < pl23) Then GoTo quexelm10

            ia = mtj(i, (ip Mod 3) + 1)
            ib = mtj(i, ((ip + 1) Mod 3) + 1)
            ic = mtj(i, ip)
            jacia = jac(i, (ip Mod 3) + 1)
            jacib = jac(i, ((ip + 1) Mod 3) + 1)
            mtj(i, 1) = ia
            mtj(i, 2) = ib
            mtj(i, 3) = ic
            mtj(i, 4) = mtj(jn, ie3)
            jac(i, 1) = jacia
            jac(i, 2) = jacib
            inn1 = jac(jn, ie2)
            inn2 = jac(jn, ie3)

            If inn1 <> 0 Then
                Call QUEDGE(inn1, jn, jac, ien1)
                jac(inn1, ien1) = i
            End If

            If inn2 <> 0 Then
                Call QUEDGE(inn2, jn, jac, ien2)
                jac(inn2, ien2) = i
            End If
            jac(i, 3) = inn1
            jac(i, 4) = inn2

            For k = 1 To 3
                mtj(jn, k) = 0
                jac(jn, k) = 0
                idm(jn) = 0
            Next k
            iv = iv + 1
            kv(iv) = jn
quexelm10:
        Next i

        Call QUDELETE(NELM, mtj, jac, idm, iv, kv, map)

    End Sub


    Private Sub QUDELETE(ByRef NELM As Integer, ByRef mtj(,) As Integer, ByRef jac(,) As Integer, _
    ByRef idm() As Integer, ByRef iv As Integer, ByRef kv() As Integer, ByRef map() As Integer)
        Dim i As Integer
        Dim m As Integer
        Dim n As Integer
        Dim ia As Integer

        m = 0
        n = 0
        For i = 1 To NELM
            map(i) = 1
        Next i
        For i = 1 To iv
            map(kv(i)) = 0
        Next i
        For i = 1 To NELM
            If map(i) <> 0 Then
                m = m + 1
                map(i) = m
            End If
        Next i

        For i = 1 To NELM
            If map(i) <> 0 Then
                n = n + 1
                For ia = 1 To 4
                    mtj(n, ia) = mtj(i, ia)
                    idm(n) = idm(i)
                    If jac(i, ia) = 0 Then
                        jac(n, ia) = 0
                    Else
                        jac(n, ia) = map(jac(i, ia))
                    End If
                Next ia
            End If
        Next i

        For i = n + 1 To NELM
            For ia = 1 To 4
                mtj(i, ia) = 0
                jac(i, ia) = 0
                idm(i) = 0
            Next ia
        Next i

        NELM = NELM - iv

    End Sub


    Private Sub QUISOGEN(ByRef NODE As Integer, ByRef NELM As Integer, ByRef mtj(,) As Integer, ByRef jac(,) As Integer, _
    ByRef px() As Double, ByRef py() As Double, ByRef id() As Integer, ByRef mmtj(,) As Integer, _
    ByRef ifix() As Integer, ByRef idm() As Integer)
        Dim i As Integer
        Dim j As Integer
        Dim k As Integer
        Dim jn As Integer
        Dim ien As Integer
        Dim pxx As Double
        Dim pyy As Double

        For i = 1 To NELM
            If mtj(i, 4) = 0 Then
                id(i) = 3
                mtj(i, 5) = mtj(i, 3)
                mtj(i, 3) = mtj(i, 2)
                mtj(i, 2) = 0
            Else
                id(i) = 4
                mtj(i, 7) = mtj(i, 4)
                mtj(i, 5) = mtj(i, 3)
                mtj(i, 4) = 0
                mtj(i, 3) = mtj(i, 2)
                mtj(i, 2) = 0
            End If
        Next i

        For i = 1 To NELM
            For j = 1 To id(i)
                If mtj(i, 2 * j) <> 0 Then GoTo quisogen30
                NODE = NODE + 1
                mtj(i, 2 * j) = NODE
                px(NODE) = (px(mtj(i, 2 * j - 1)) + px(mtj(i, ((2 * j) Mod (2 * id(i)) + 1)))) / 2.0
                py(NODE) = (py(mtj(i, 2 * j - 1)) + py(mtj(i, ((2 * j) Mod (2 * id(i)) + 1)))) / 2.0
                If jac(i, j) = 0 Then
                    ifix(NODE) = 1
                    GoTo quisogen30
                End If
                jn = jac(i, j)
                Call QUEDGE(jn, i, jac, ien)
                If mtj(jn, 2 * ien) <> 0 Then GoTo quisogen30
                mtj(jn, 2 * ien) = NODE
                If idm(i) <> idm(jn) Then ifix(NODE) = 1
quisogen30:
            Next j

            NODE = NODE + 1
            mtj(i, 2 * id(i) + 1) = NODE
            pxx = 0.0
            pyy = 0.0
            For k = 1 To id(i)
                pxx = pxx + px(mtj(i, 2 * k))
                pyy = pyy + py(mtj(i, 2 * k))
            Next k
            px(NODE) = pxx / CDbl(id(i))
            py(NODE) = pyy / CDbl(id(i))
        Next i

        Call QUSQUARE(NODE, NELM, mtj, px, py, id, mmtj)

    End Sub


    Private Sub QUEDGE(ByRef l As Integer, ByRef k As Integer, ByRef jac(,) As Integer, ByRef iedge As Integer)
        Dim i As Integer

        iedge = -1
        For i = 1 To 4
            If jac(l, i) = k Then
                iedge = i
                Exit For
            End If
        Next i
        'ERRORメッセージ＆実行中止
        If iedge = -1 Then
            MessageBox.Show("ERROR IN SUB QUEDGE", "Error終了")
            Me.Close()
            Form1.Close()
        End If
    End Sub


    Private Sub QUSQUARE(ByRef NODE As Integer, ByRef NELM As Integer, ByRef mtj(,) As Integer, _
    ByRef px() As Double, ByRef py() As Double, ByRef id() As Integer, ByRef mmtj(,) As Integer)
        Dim i As Integer
        Dim j As Integer
        Dim nelm1 As Integer

        nelm1 = 0
        For i = 1 To NELM
            If mtj(i, 9) = 0 Then
                For j = 1 To id(i)
                    nelm1 = nelm1 + 1
                    mmtj(nelm1, 1) = mtj(i, ((2 * j + 3) Mod 6) + 1)
                    mmtj(nelm1, 2) = mtj(i, 2 * j - 1)
                    mmtj(nelm1, 3) = mtj(i, 2 * j)
                    mmtj(nelm1, 4) = mtj(i, 7)
                Next j
            Else
                For j = 1 To id(i)
                    nelm1 = nelm1 + 1
                    mmtj(nelm1, 1) = mtj(i, ((2 * j + 5) Mod 8) + 1)
                    mmtj(nelm1, 2) = mtj(i, 2 * j - 1)
                    mmtj(nelm1, 3) = mtj(i, 2 * j)
                    mmtj(nelm1, 4) = mtj(i, 9)
                Next j
            End If
        Next i

        NELM = nelm1

    End Sub


    Private Sub QUDATA(ByRef NODE As Integer, ByRef NELM As Integer, ByRef mmtj(,) As Integer, _
    ByRef px() As Double, ByRef py() As Double, ByRef ifix() As Integer)
        Dim sw As System.IO.StreamWriter
        Dim dat As String
        Dim fname2 As String
        Dim i As Integer

        fname2 = My.Forms.Form1.Label1.Text
        fname2 = System.IO.Path.GetDirectoryName(fname2)
        fname2 = fname2 & "\workf3.csv"
        sw = New System.IO.StreamWriter(fname2, False, System.Text.Encoding.Default)
        dat = NODE.ToString & "," & NELM.ToString : sw.WriteLine(dat)
        For i = 1 To NELM
            dat = mmtj(i, 1).ToString & "," & mmtj(i, 2).ToString & "," & mmtj(i, 3).ToString & "," & mmtj(i, 4).ToString
            sw.WriteLine(dat)
        Next i
        For i = 1 To NODE
            dat = px(i).ToString("0.000") & "," & py(i).ToString("0.000") & "," & ifix(i).ToString
            sw.WriteLine(dat)
        Next i
        sw.Close()

    End Sub

End Class