📄 execute.f90
字号:
SUBROUTINE Exec060
!........
! 模块功能
! 本模块负责执行命令编号在81-100之间的各条宏命令.
!........
USE CtrlData
USE MeshData
USE CentData
USE LoadData
USE GlobData
USE SolvData
USE ExtraMesh
USE FrontData
USE MacroData
USE ReSolveData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
ncomm = lmacr( 1, kmacr )
para1 = pmacr( 1, kmacr )
para2 = pmacr( 2, kmacr )
para3 = pmacr( 3, kmacr )
para4 = pmacr( 4, kmacr )
para5 = pmacr( 5, kmacr )
npar1 = pmacr( 1, kmacr ) + 0.5D0
npar2 = pmacr( 2, kmacr ) + 0.5D0
npar3 = pmacr( 3, kmacr ) + 0.5D0
npar4 = pmacr( 4, kmacr ) + 0.5D0
npar5 = pmacr( 5, kmacr ) + 0.5D0
IF( ncomm .EQ. 41 ) THEN
!.........宏命令solve
kmacr = lmacr( 2, kmacr )
IF( nfrcc .EQ. 0 ) nerrc = 1455
IF( ldecc( 1 ) .EQ. 0 ) nerrc = 5001
IF( ntypc .EQ. 2 .AND. nshfc .EQ. 0 ) nerrc = 5001
IF( nerrc .GT. 0 ) RETURN
!.........更新迭代步
DO idofs = 1, ndofs
dspis( idofs, kload ) = disps( idofs, kload )
END DO
!.........参数设定
nfrcc = 0
nupdc = 0
nrsdc = 0
nreac = 0
iswth = 13
IF( ldecc( 1 ) .EQ. 1 ) THEN
ldecc( 1 ) = 2
CALL DealFix( 1 )
CALL DeComp( 1, npar1 )
END IF
CALL BckSub( 1 )
CALL LinkNode
IF( npar2 .EQ. 1 ) CALL Aitken( vslvs )
!.........自由度光滑处理和交换
IF( nsmts .GT. 0 ) CALL Smooth
CALL Exchang( 1 )
CALL GetExtraDisp
CALL BackSolveResult( 1 )
END IF
IF( ncomm .EQ. 42 ) THEN
!.........宏命令shift
kflag =-1
IF( para1 .LT. 0 ) kflag = 1
IF( npar2 .EQ. 0 ) THEN
para1 = para1 * 8.0D0 * DATAN( 1.0D0 )
para1 = para1 * para1
END IF
shift( 1 ) = 1.0D0
shift( 2 ) = para1 * kflag
DO ishft = 3, 10
shift( ishft ) = 0.0D0
END DO
DO imatx = 1, 2
IF( lsavc( imatx ) .NE. 0 .AND. &
ldecc( imatx ) .NE. 1 ) THEN
nerrc = 2334
RETURN
END IF
END DO
CALL ShftMat
kmacr = lmacr( 2, kmacr )
END IF
IF( ncomm .EQ. 43 ) THEN
!.........宏命令Wilson
ndync = 1
CALL Wilson
kmacr = lmacr( 2, kmacr )
END IF
IF( ncomm .EQ. 44 ) THEN
!.........宏命令Newmark
ndync = 2
CALL Newmark
kmacr = lmacr( 2, kmacr )
END IF
IF( ncomm .EQ. 45 ) THEN
!.........宏命令eigenpair
iswth = 1
kmacr = lmacr( 2, kmacr )
IF( para1 .LE. 1.0D-12 ) para1 = 1.0D-5
IF( ldecc( 1 ) .EQ. 0 ) THEN
WRITE( 12, 2000 )
nerrc = 1324
RETURN
END IF
IF( ldecc( 2 ) .NE. 1 ) THEN
WRITE( 12, 2200 )
nerrc = 1325
RETURN
END IF
IF( ntypc .GT. 3 .AND. ldecc( 3 ) .NE. 1 ) THEN
WRITE( 12, 2400 )
nerrc = 1326
RETURN
END IF
IF( ldecc( 1 ) .EQ. 1 ) THEN
index = 0
ldecc( 1 ) = 2
CALL DealFix( 1 )
CALL DeComp( 1, index )
END IF
CALL InitFloat( fstrs, ndofs, 0.0D0 )
CALL EigenP( para1, npar2 )
CALL GetExtraDisp
END IF
IF( ncomm .EQ. 46 ) THEN
!.........宏命令accel
IF( nfrcc .EQ. 0 ) nerrc = 36509
IF( nerrc .GT. 0 ) RETURN
nfrcc = 0
nupdc = 0
kmacr = lmacr( 2, kmacr )
IF( lsavc( 3 ) .NE. 0 ) THEN
iswth = 3
IF( ldecc( 3 ) .NE. 1 ) nerrc = 213256
IF( nerrc .GT. 0 ) RETURN
DO idofs = 1, ndofs
vslvs( idofs ) = -vslvs( idofs )
END DO
CALL DotMat( veloc, vslvs, iswth, kload, nload )
IF( nerrc .GT. 0 ) RETURN
DO idofs = 1, ndofs
vslvs( idofs ) = -vslvs( idofs )
END DO
END IF
DO idofs = 1, ndofs
accel( idofs, kload ) = 0.0D0
END DO
iswth = 2
IF( ldecc( 2 ) .EQ. 0 ) THEN
nerrc = 435467
RETURN
END IF
IF( ldecc( 2 ) .EQ. 1 ) THEN
index = 0
ldecc( 2 ) = 2
CALL DealFix( 2 )
CALL DeComp( 2, index )
END IF
CALL BckSub( 2 )
CALL Exchang( 2 )
IF( npar1 .NE. 0 ) CALL PrntDsp( 1, npoin, 1, 2 )
END IF
IF( ncomm .EQ. 47 ) THEN
kmacr = lmacr( 2, kmacr )
CALL OptStep( npar1, npar2 )
END IF
IF( ncomm .EQ. 48 ) THEN
!.........宏命令initial
kmacr = lmacr( 2, kmacr )
CALL Initial
END IF
IF( ncomm .EQ. 49 ) THEN
!.........宏命令update
kmacr = lmacr( 2, kmacr )
IF( nhstr .GT. 0 ) CALL ElmLib( fwork, react, 11 )
CALL Update
CALL BackSolveResult( 2 )
CALL ShowTime( timec )
END IF
IF( ncomm .EQ. 50 ) THEN
!.........宏命令Resolve
kmacr = lmacr( 2, kmacr )
CALL ReSolveStif
CALL ReDecomp
CALL ReBakSub
CALL ReExchang
END IF
IF( ncomm .EQ. 51 ) THEN
!.........宏命令crank
ndync = 3
CALL Crank
kmacr = lmacr( 2, kmacr )
END IF
IF( ncomm .GT. 51 ) THEN
WRITE( 12, 8000 ) ncomm
nerrc = 45496
END IF
RETURN
2000 FORMAT( //2x, '错误: 特征对分析前先计算刚度阵！' )
2200 FORMAT( //2x, '错误: 特征对分析前先计算质量阵！' )
2400 FORMAT( //2x, '错误: 特征对分析前先计算阻尼阵！' )
8000 FORMAT( //2x, '致命错误: 没有开发的宏命令', I5 )
END
SUBROUTINE Exec080
!........
! 模块功能
! 本模块负责执行命令编号在61-80之间的各条宏命令.
!........
USE CtrlData
USE MeshData
USE CentData
USE LoadData
USE GlobData
USE MacroData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
CHARACTER * 60 strng
ncomm = lmacr( 1, kmacr )
para1 = pmacr( 1, kmacr )
para2 = pmacr( 2, kmacr )
para3 = pmacr( 3, kmacr )
para4 = pmacr( 4, kmacr )
para5 = pmacr( 5, kmacr )
npar1 = pmacr( 1, kmacr ) + 0.5D0
npar2 = pmacr( 2, kmacr ) + 0.5D0
npar3 = pmacr( 3, kmacr ) + 0.5D0
npar4 = pmacr( 4, kmacr ) + 0.5D0
npar5 = pmacr( 5, kmacr ) + 0.5D0
IF( ncomm .EQ. 61 ) THEN
!.........宏命令printdisp
kmacr = lmacr( 2, kmacr )
CALL PrntDsp( npar1, npar2, npar3, 0 )
ELSE IF( ncomm .EQ. 62 ) THEN
!.........宏命令printvel
kmacr = lmacr( 2, kmacr )
IF( ntypc .EQ. 2 ) &
CALL PrntDsp( npar1, npar2, npar3, 1 )
ELSE IF( ncomm .EQ. 63 ) THEN
!.........宏命令printacc
kmacr = lmacr( 2, kmacr )
IF( ntypc .EQ. 2 ) &
CALL PrntDsp( npar1, npar2, npar3, 2 )
ELSE IF( ncomm .EQ. 64 ) THEN
!.........宏命令plotmesh
kmacr = lmacr( 2, kmacr )
CALL PrntPlt( 0, npar1 )
ELSE IF( ncomm .EQ. 65 ) THEN
!.........宏命令trace
kmacr = lmacr( 2, kmacr )
IF( ntypc .EQ. 0 ) THEN
IF( npar1 .GT. 1 ) nerrc = 3294
IF( nerrc .GT. 0 ) RETURN
CALL Trace( npar1, npar2, npar3 )
ELSE IF( ntypc .EQ. 2 ) THEN
CALL Trace( npar1, npar2, npar3 )
END IF
ELSE IF( ncomm .EQ. 66 ) THEN
!.........宏命令echoon
kmacr = lmacr( 2, kmacr )
necho = 1
ELSE IF( ncomm .EQ. 67 ) THEN
!.........宏命令echooff
kmacr = lmacr( 2, kmacr )
necho = 0
ELSE IF( ncomm .EQ. 68 ) THEN
!.........宏命令echodisp
kmacr = lmacr( 2, kmacr )
IF( npar1 .GT. 0 .AND. npar1 .LE. npoin ) THEN
IF( npar2 .GT. 0 .AND. npar2 .LE. mdofn ) THEN
idofs = ( npar1 - 1 ) * mdofn + npar2
WRITE( strng, 2000 ) npar1, npar2, disps( idofs, kload )
END IF
END IF
ELSE IF( ncomm .EQ. 69 ) THEN
!.........宏命令echovelo
kmacr = lmacr( 2, kmacr )
IF( npar1 .GT. 0 .AND. npar1 .LE. npoin ) THEN
IF( npar2 .GT. 0 .AND. npar2 .LE. mdofn ) THEN
idofs = ( npar1 - 1 ) * mdofn + npar2
WRITE( strng, 2200 ) npar1, npar2, veloc( idofs, kload )
CALL ShowMessage( strng )
END IF
END IF
ELSE IF( ncomm .EQ. 70 ) THEN
!.........宏命令echoacc
kmacr = lmacr( 2, kmacr )
IF( npar1 .GT. 0 .AND. npar1 .LE. npoin ) THEN
IF( npar2 .GT. 0 .AND. npar2 .LE. mdofn ) THEN
idofs = ( npar1 - 1 ) * mdofn + npar2
WRITE( strng, 2400 ) npar1, npar2, accel( idofs, kload )
CALL ShowMessage( strng )
END IF
END IF
ELSE IF( ncomm .EQ. 71 ) THEN
!.........宏命令echotime
kmacr = lmacr( 2, kmacr )
IF( DABS( para1 ) .LT. 1.0D-12 ) para1 = 1.0D0
WRITE( strng, 2600 ) timec / para1
CALL ShowMessage( strng )
ELSE IF( ncomm .EQ. 72 ) THEN
!.........宏命令echofctor
kmacr = lmacr( 2, kmacr )
WRITE( strng, 2800 ) fctor
CALL ShowMessage( strng )
ELSE IF( ncomm .EQ. 73 ) THEN
!.........宏命令echotol
kmacr = lmacr( 2, kmacr )
WRITE( strng, 3000 ) dtolc, ftolc
CALL ShowMessage( strng )
ELSE IF( ncomm .EQ. 75 ) THEN
!.........宏命令plotdisp
kmacr = lmacr( 2, kmacr )
CALL PrntPlt( 1, npar1 )
ELSE IF( ncomm .EQ. 76 ) THEN
!.........宏命令plotstrs
kmacr = lmacr( 2, kmacr )
CALL PrntPlt( 2, npar1 )
ELSE IF( ncomm .EQ. 77 ) THEN
!.........宏命令printstat
kmacr = lmacr( 2, kmacr )
CALL PrntStat
ELSE IF( ncomm .EQ. 78 ) THEN
!.........宏命令plotstate
kmacr = lmacr( 2, kmacr )
CALL PlotStat
ELSE IF( ncomm .EQ. 79 ) THEN
idofs = ( npar2 - 1 ) * mdofn + npar3
IF( npar2 .LE. 0 .OR. npar2 .GT. npoin ) THEN
nerrc = 469578
RETURN
END IF
IF( npar3 .LE. 0 .OR. npar3 .GT. mdofn ) THEN
nerrc = 469578
RETURN
END IF
IF( npar1 .EQ. 0 .OR. npar1 .EQ. 1 ) THEN
value = disps( idofs, kload )
ELSE IF( npar2 .EQ. 2 ) THEN
value = veloc( idofs, kload )
ELSE
value = accel( idofs, kload )
END IF
CALL ShowShown( npar1, npar2, npar3 )
CALL ShowGraph( timec, value, 1 )
kmacr = lmacr( 2, kmacr )
ELSE IF( ncomm .EQ. 80 ) THEN
idofs = ( npar2 - 1 ) * mdofn + npar3
IF( npar1 .EQ. 0 .OR. npar1 .EQ. 1 ) THEN
value = disps( idofs, kload )
ELSE IF( npar2 .EQ. 2 ) THEN
value = veloc( idofs, kload )
ELSE
value = accel( idofs, kload )
END IF
CALL ShowShown( npar1, npar2, npar3 )
CALL ShowGraph( kload, value, 1 )
kmacr = lmacr( 2, kmacr )
ELSE
WRITE( 12, 8000 ) ncomm
nerrc = 45496
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -