extramesh.f90

非线性有限元分析程序

        SUBROUTINE GetExtraMesh
        USE CtrlData
        USE MeshData
        USE ExtraMesh
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        ALLOCATABLE coort(:,:), lnodt(:,:), lprtt(:)
        DIMENSION point( 3 )

        nnodx = 0
        nelmx = 0
        iswth = 21
        CALL ShowMessage( '细剖网格...' )
        OPEN( 25, FORM = 'UNFORMATTED', STATUS = 'SCRATCH' )
        DO ielem = 1, nelem
          CALL ElmOpt( ielem, iswth )
        END DO
        REWIND( 25 )
        IF( nnodx .EQ. 0 .AND. nelmx .EQ. 0 ) RETURN
        IF( nnodx .NE. 0 ) THEN
          ALLOCATE( coort( ndime, nnodx ), STAT = ierro )
          IF( ierro .NE. 0 ) nerrc = 4
          IF( nerrc .GT. 0 ) RETURN
        END IF
        IF( nelmx .NE. 0 ) THEN
          ALLOCATE( lnodt( mnode, nelmx ), lprtt( nelem ),                     &
                    STAT = ierro )
          IF( ierro .NE. 0 ) nerrc = 4
          IF( nerrc .GT. 0 ) RETURN
        END IF
        nnodx = 0
        nelmx = 1
        DO ielem = 1, nelem
          lprtt( ielem ) = nelmx
          READ( 25 ) nelmt
          DO ielmt = 1, nelmt
            READ( 25 ) ( lnodt( inode, nelmx ), inode = 1, mnode )
            DO inode = 1, mnode
              IF( lnodt( inode, nelmx ) .NE. 0 ) THEN
                READ( 25 ) ( point( idime ), idime = 1, ndime )
                iflag = 0
                DO inodx = nnodx, 1, -1
                  IF( iflag .EQ. 0 ) THEN
                    iflag = 1
                    DO idime = 1, ndime
                      dispt = point( idime ) - coort( idime, inodx )
                      IF( DABS( dispt ) .GT. 1.0D-5 ) iflag = 0
                    END DO
                    IF( iflag .EQ. 1 ) lnodt( inode, nelmx ) = inodx
                  END IF
                END DO
                IF( iflag .EQ. 0 ) THEN
                  DO ipoin = 1, npoin
                    IF( iflag .EQ. 0 ) THEN
                      iflag = 1
                      DO idime = 1, ndime
                        dispt = point( idime ) - coord( idime, ipoin )
                        IF( DABS( dispt ) .GT. 1.0D-5 ) iflag = 0
                      END DO
                      IF( iflag .EQ. 1 ) lnodt( inode, nelmx ) =-ipoin
                    END IF
                  END DO
                END IF
                IF( iflag .EQ. 0 ) THEN
                  nnodx = nnodx + 1
                  DO idime = 1, ndime
                    coort( idime, nnodx ) = point( idime )
                  END DO
                  lnodt( inode, nelmx ) = nnodx
                END IF
              END IF
            END DO
            nelmx = nelmx + 1
          END DO
        END DO
        nelmx = nelmx - 1

        CALL InitExtraMesh
        IF( nerrc .GT. 0 ) RETURN
        DO ielem = 1, nelem
          lprtx( ielem ) = lprtt( ielem )
        END DO
        DO ielmx = 1, nelmx
          DO inode = 1, mnode
            lnodx( inode, ielmx ) = lnodt( inode, ielmx )
          END DO
        END DO
        DO inodx = 1, nnodx
          DO idime = 1, ndime
            coorx( idime, inodx ) = coort( idime, inodx )
          END DO
        END DO
        DEALLOCATE( lnodt, coort, lprtt )
        CLOSE( 25 )
        END

        SUBROUTINE GetExtraDisp
        USE CtrlData
        USE ExtraMesh
        iswth = 22
        IF( nnodx .EQ. 0 ) RETURN
        DO ielem = 1, nelem
          CALL ElmOpt( ielem, iswth )
        END DO
        END