📄 vfeap.f90
字号:
! ================================================================
! 通用结构分析程序——VFEAP v3.0
! 程序以中文Windows3.1和Fortran90(Fortran Power Station V4)
! 为平台, 采用波阵解法求解方程；采用波阵逆迭代法求解特征值问题. 求
! 解规模受内外存限制. 可调数组的使用使得内存空间得到充分利用, 动态
! 连接库的使用使得程序模块化, 宏命令有效地组织各种有限元算法. 浙江
! 大学岩土工程研究所凌道盛对本程序拥有所有权. 版权所有, 不得复制.
! ================================================================
INTEGER * 4 FUNCTION WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow )
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
!DEC$ ELSE
!DEC$ ATTRIBUTES STDCALL, ALIAS : 'WinMain' :: WinMain
!DEC$ END IF
USE USEr32
USE kernel32
USE dflogm
USE dfcom
USE dfauto
USE VFEAPGlobals
IMPLICIT NONE
INTEGER * 4 hInstance
INTEGER * 4 hPrevInstance
INTEGER * 4 lpszCmdLine
INTEGER * 4 nCmdShow
INCLUDE 'resource.fd'
! Variables
TYPE (T_MSG) mesg
INTEGER * 4 ret
LOGICAL * 4 lret
gpSetRunFlag = 0
ghInstance = hInstance
ghModule = GetModuleHandle(NULL)
ghInstVFEAPCom = LoadLibrary( "VFEAPCom.dll" )
ret = GetLastError()
ghWndMain = NULL
CALL COMINITIALIZE(ret)
lret = DlgInit(IDD_VFEAP_DIALOG, gdlg)
IF( lret == .TRUE. ) THEN
lret = DlgModeless( gdlg, nCmdShow )
IF( lret == .TRUE. ) THEN
ghWndMain = gDlg%hWnd
CALL ShowMessage( '欢迎使用VFEAP...' )
IF( gpSetRunFlag .EQ. 0 .AND. ghInstVFEAPCom .NE. 0 ) THEN
gpSetRunFlag = GetProcAddress( ghInstVFEAPCom, "SetRunFlag"C )
END IF
IF( gpSetRunFlag .NE. 0 ) CALL SetRunFlag( 1 )
CALL VFEAP
IF( gpSetRunFlag .NE. 0 ) CALL SetRunFlag( 0 )
IF( ghInstVFEAPCom .NE. 0 ) THEN
lRet = FreeLibrary( ghInstVFEAPCom )
END IF
CALL PostQuitMessage( 0 )
DO WHILE( GetMessage( mesg, NULL, 0, 0 ) )
IF( DlgIsDlgMessage(mesg) .EQV. .FALSE. ) THEN
lret = TranslateMessage( mesg )
ret = DispatchMessage( mesg )
END IF
END DO
CALL DlgUninit(gdlg)
CALL COMUNINITIALIZE()
WinMain = mesg.wParam
RETURN
END IF
END IF
ret = MessageBox( ghwndMain, "VFEAP初始化错误!"C, "错误"C, MB_OK )
CALL COMUNINITIALIZE()
WinMain = 0
END
SUBROUTINE VFEAP
USE CtrlData
USE MeshData
USE CentData
USE LoadData
USE FrontData
USE ResolveData
USE AutoMeshData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
nerrc = 0
CALL RunTime( 1 )
CALL OpenFile
CALL InitCtrl
CALL InitMesh
CALL InitCent
CALL InitLoad
CALL InitFront
CALL InitAutoMesh
CALL InitReSolve
CALL InitMemory
CALL Input
CALL Execute
CALL ErrorMsg
CALL RunTime( 2 )
CALL CloseFile
CALL DelMesh
CALL DelCent
CALL DelLoad
CALL DelFront
CALL DelReSolve
CALL DelAutoMesh
CALL DelCtrl
RETURN
END
SUBROUTINE OpenFile
!........
! 模块功能
! 打开输入,输出文件,读入控制信息.
!........
USE CtrlData
USE FileData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
!.......
CALL FileName
!.......打开文件.
OPEN( 11, FILE = sdatf, STATUS = 'OLD' )
OPEN( 12, FILE = soutf, STATUS = 'UNKNOWN' )
OPEN( 13, FILE = smacf, STATUS = 'OLD' )
OPEN( 14, FILE = sinif, STATUS = 'UNKNOWN' )
OPEN( 15, FILE = smshf, STATUS = 'UNKNOWN' )
OPEN( 16, FILE = sdisf, STATUS = 'UNKNOWN' )
OPEN( 17, FILE = sstrf, STATUS = 'UNKNOWN' )
OPEN( 18, FILE = ssavf, FORM = 'UNFORMATTED' )
OPEN( 19, FILE = sdsvf, FORM = 'UNFORMATTED' )
OPEN( 20, FILE = sstaf, STATUS = 'UNKNOWN' )
OPEN( 21, FILE = shisf, STATUS = 'UNKNOWN' )
OPEN( 22, FILE = spref, STATUS = 'UNKNOWN' )
OPEN( 23, FILE = strnf, STATUS = 'UNKNOWN' )
CALL ShowMessage( '读入网格数据...' )
CALL ShowMessage( '读控制信息...' )
WRITE( 12, 2000 )
READ( 11, 2200 ) title
WRITE( 12, 2400 ) title
CALL ShowTitle( title )
READ( 11, 2600 ) ntypc, npoin, nelem, ndime, &
mdofn, nmats, nload, nslnt
READ( 11, 2600 ) mnode, nnodp, nnodg, nprop, &
mnodf, medgf, mplnf, nprnc
READ( 11, 2600 ) nmssp, nstfp, ndmpp, nmode, &
nlnkc, nfmtc
IF( ntypc .LE. 6 .AND. ntypc .GE. 0 ) THEN
WRITE( 15, 2600 ) ntypc
IF( nprnc .NE. 0 .AND. ntypc .EQ. 0 ) WRITE( 12, 2800 )
IF( nprnc .NE. 0 .AND. ntypc .EQ. 1 ) WRITE( 12, 2801 )
IF( nprnc .NE. 0 .AND. ntypc .EQ. 2 ) WRITE( 12, 2802 )
IF( nprnc .NE. 0 .AND. ntypc .EQ. 3 ) WRITE( 12, 2803 )
IF( nprnc .NE. 0 .AND. ntypc .EQ. 4 ) WRITE( 12, 2804 )
IF( nprnc .NE. 0 .AND. ntypc .EQ. 5 ) WRITE( 12, 2805 )
IF( nprnc .NE. 0 .AND. ntypc .EQ. 6 ) WRITE( 12, 2806 )
ELSE
nerrc = 1
RETURN
END IF
IF( nprnc .NE. 0 ) THEN
WRITE( 12, 3200 ) npoin, nelem, ndime, mdofn
WRITE( 12, 3400 ) nmats, nload, mnode, nslnt
WRITE( 12, 3600 ) nnodp, nnodg, nprop, mnodf
WRITE( 12, 3800 ) medgf, mplnf, nmssp, nstfp
WRITE( 12, 4000 ) ndmpp, nmode
IF( nlnkc .EQ. 0 ) WRITE( 12, 4200 )
IF( nlnkc .NE. 0 ) WRITE( 12, 4201 )
END IF
RETURN
200 nerrc = 5235
RETURN
2000 FORMAT( // 30x, '通用结构分析程序'// &
10x, ' ____ ____ _____ ' / &
10x, ' || || / \ / \ / \ ' / &
10x, ' || || || / \ || ||' / &
10x, ' || || \____ ||______|| ||_____/ ' / &
10x, ' || || \ || || || ' / &
10x, ' || || || || || || ' / &
10x, ' \______/ \____/ || || || ' / )
2200 FORMAT( a70 )
2400 FORMAT( //2x, 70( '=' ) // 2x, a70 // 2x, 70( '=' ) // )
2600 FORMAT( 10I5 )
2800 FORMAT( 2x, '问题类型 : 静力分析' )
2801 FORMAT( 2x, '问题类型 : 动特性分析' )
2802 FORMAT( 2x, '问题类型 : 动响应分析' )
2803 FORMAT( 2x, '问题类型 : 稳定性分析' )
2804 FORMAT( 2x, '问题类型 : 阻尼动特性分析' )
2805 FORMAT( 2x, '问题类型 : 阻尼动响应分析' )
2806 FORMAT( 2x, '问题类型 : 阻尼动稳定性分析' )
3200 FORMAT( 2x, '节点总数 : ', I5, 10x, '单元总数: ', I5 / &
2x, '问题维数 : ', I5, 10x, '节点自由度: ', I5 )
3400 FORMAT( 2x, '材料总数 : ', I5, 10x, '载荷工况数: ', I5 / &
2x, '单元节点数: ', I5, 10x, '斜自由度数: ', I5 )
3600 FORMAT( 2x, '面载节点数: ', I5, 10x, '线载节点数: ', I5 / &
2x, '材性参数数: ', I5, 10x, '集中载荷数: ', i5 )
3800 FORMAT( 2x, '线布载荷数: ', I5, 10x, '面布载荷数: ', i5 / &
2x, '集中质量数: ', I5, 10x, '集中刚度数: ', I5 )
4000 FORMAT( 2x, '集中阻尼数: ', I5, 10x, '最大模态数: ', I5 )
4200 FORMAT(/2x, '注意: @坐标相同或相近的节点将不被自动连接@' / )
4201 FORMAT(/2x, '注意: @坐标相同或相近的节点将被自动连接@' / )
RETURN
END
SUBROUTINE CloseFile
WRITE( 16, 2000 ) 0
WRITE( 17, 2000 ) 0
WRITE( 20, 2000 ) 0
WRITE( 23, 2000 ) 0
CLOSE( 11 )
CLOSE( 12 )
CLOSE( 13 )
CLOSE( 14 )
CLOSE( 15 )
CLOSE( 16 )
CLOSE( 17 )
CLOSE( 18 )
CLOSE( 19 )
CLOSE( 20 )
CLOSE( 21 )
CLOSE( 22 )
CLOSE( 23 )
2000 FORMAT( I5 )
RETURN
END
SUBROUTINE ErrorMsg
!.......
! 模块功能
! 输出错误信息.
!........
USE CtrlData
CHARACTER * 20 strng
IF( nerrc .LE. 0 ) RETURN
WRITE( strng, '( "错误：序号", I10 )' ) nerrc
CALL ShowMessage( strng )
RETURN
END
SUBROUTINE RunTime( iswth )
!........
! 模块功能
! 确定当时时刻.
!........
CHARACTER * 26 ctime
INTEGER * 2 year, month, date
INTEGER * 2 hour, minute, second, hundred
COMMON /rtime/ ctime
IF( iswth .EQ. 2 ) THEN
WRITE( 12, * )
WRITE( 12, * ) ' ==========================================='
WRITE( 12, * )
WRITE( 12, * ) ' 运 行 时 间'
WRITE( 12, * )
WRITE( 12, * ) ' ==========================================='
WRITE( 12, * )
WRITE( 12, '( 2X, A20, A26 )' ) '本程序工作起始时刻: ', ctime
END IF
CALL GETDAT( year, month, date )
CALL GETTIM( hour, minute, second,hundred )
WRITE( ctime( 1:4 ), '( I4 )' ) year
WRITE( ctime( 5:6 ), '( A2 )' ) '年'
WRITE( ctime( 7:8 ), '( I2 )' ) month
WRITE( ctime( 9:10 ), '( A2 )' ) '月'
WRITE( ctime( 11:12 ), '( I2 )' ) date
WRITE( ctime( 13:14 ), '( A2 )' ) '日'
WRITE( ctime( 15:16 ), '( I2 )' ) hour
WRITE( ctime( 17:18 ), '( A2 )' ) '时'
WRITE( ctime( 19:20 ), '( I2 )' ) minute
WRITE( ctime( 21:22 ), '( A2 )' ) '分'
WRITE( ctime( 23:24 ), '( I2 )' ) second
WRITE( ctime( 25:26 ), '( A2 )' ) '秒'
IF( month .LT. 10 ) ctime( 7:7 ) = '0'
IF( date .LT. 10 ) ctime( 11:11 ) = '0'
IF( hour .LT. 10 ) ctime( 15:15 ) = '0'
IF( minute .LT. 10 ) ctime( 19:19 ) = '0'
IF( second .LT. 10 ) ctime( 23:23 ) = '0'
IF( iswth .EQ. 2 ) &
WRITE( 12, '( 2X, A20, A26 )' ) '本程序工作终止时刻: ', ctime
RETURN
END
SUBROUTINE ChangeToWorkDir
USE DFPort
USE Kernel32
USE FileData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
CHARACTER * 64 lpszDrive, lpszExt
CHARACTER * 256 lpszFileName, lpszDir
CHARACTER * 256 lpszExecFile
IF( GetFileName( lpszFileName, 1 ) .EQ. 0 ) i = GetModuleFileName( NULL, lpszFileName, 256 )
i = SplitPathQQ( lpszFileName, lpszDrive, lpszDir, lpszExecFile, lpszExt )
i = ChDir( TRIM( lpszDrive ) // TRIM( lpszDir ) )
END⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -