📄 execute.f90
字号:
SUBROUTINE Execute
!........
! 模块功能
! 主子模块,负责带宽优化,设定波阵信息,读入宏命令,并执行各条
! 宏命令.
!........
USE CtrlData
USE MeshData
USE LoadData
USE CentData
USE GlobData
USE ElmtData
USE SolvData
USE ExtraMesh
USE FrontData
USE MacroData
USE FactorData
USE EarthQuake
USE ReSolveData
IF( nerrc .GT. 0 ) RETURN
CALL ShowMessage( '开设动态数组' )
!.......设定参数.
CALL InitGlob
CALL InitElmt
CALL InitSolv
CALL InitMacro
CALL InitFactor
CALL InitResolveData
CALL NodDof
CALL WavOpt
CALL SlvOpt
CALL InitWave
CALL SetRec
CALL ReadMacro
CALL GetExtraMesh
CALL ShowPhase( kload )
CALL ShowGraph( 0.0D0, 0.0D0, 0 )
IF( nincc .EQ. 0 ) nincc = 1
!.......依次执行各条宏命令.
DO WHILE( nexec .EQ. 1 .AND. nerrc .EQ. 0 )
CALL ShowMacro
ncomm = lmacr( 1, kmacr )
IF( ncomm .LT. 0 .OR. ncomm .GT. 140 ) nerrc = 3585
IF( ncomm .GE. 0 .AND. ncomm .LE. 20 ) CALL Exec020
IF( ncomm .GT. 20 .AND. ncomm .LE. 40 ) CALL Exec040
IF( ncomm .GT. 40 .AND. ncomm .LE. 60 ) CALL Exec060
IF( ncomm .GT. 60 .AND. ncomm .LE. 80 ) CALL Exec080
IF( ncomm .GT. 80 .AND. ncomm .LE. 120 ) CALL Exec120
IF( ncomm .GT. 120 .AND. ncomm .LE. 140 ) CALL Exec140
END DO
CALL DelWave
CALL DelGlob
CALL DelElmt
CALL DelSolv
CALL DelMacro
CALL DelExtraMesh
CALL DelEarthQuake
RETURN
END
SUBROUTINE Exec020
!........
! 模块功能
! 本模块负责执行命令编号在0-20之间的各条宏命令.
!........
USE CtrlData
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 )
IF( ncomm .EQ. 0 ) THEN
!.........结束宏命令.
nexec = 0
ELSE IF( ncomm .EQ. 1 ) THEN
!.........宏命令loop
nendl = lmacr( 3, kmacr )
pmacr( 1, nendl ) = pmacr( 1, kmacr )
pmacr( 2, nendl ) = pmacr( 2, kmacr )
pmacr( 3, nendl ) = pmacr( 3, kmacr )
kmacr = lmacr( 2, kmacr )
kaitk = 0
ELSE IF( ncomm .EQ. 2 ) THEN
!.........宏命令endloop
dstep = pmacr( 3, kmacr )
pmacr( 1, kmacr ) = pmacr( 1, kmacr ) + dstep
dflag = pmacr( 1, kmacr ) - pmacr( 2, kmacr )
dflag = dflag * dstep / DABS( dstep )
IF( dflag .GT. dstep * 1.0D-5 ) THEN
kmacr = kmacr + 1
ELSE
kmacr = lmacr( 2, kmacr )
END IF
ELSE IF( ncomm .EQ. 3 ) THEN
!.........宏命令tolen
IF( para1 .GE. 1.0D0 ) THEN
para1 =-para1
para1 = 10.0D0 ** para1
END IF
IF( para1 .LT. 1.0D-12 ) para1 = 1.0D-5
IF( para2 .LT. 1.0D-12 ) para2 = para1
!.........以下为新版误差控制
wtolc = GetError()
CALL ShowError( para1, wtolc )
IF( necho .EQ. 1 ) THEN
WRITE( strng, 2000 ) dtolc
CALL ShowMessage( strng )
END IF
IF( wtolc .LT. para1 ) THEN
!...........达到足够的精度.
kmacr = lmacr( 2, kmacr )
ELSE
!...........未达到足够的精度.
kmacr = kmacr + 1
END IF
RETURN
!.........以下为旧版误差控制
dtolm = 1.0D0 / 10.D0 ** npar1
ftolm = 1.0D0 / 10.D0 ** npar2
IF( nincc .LE. 1 .OR. nincc .EQ. 3 ) THEN
IF( necho .EQ. 1 ) THEN
WRITE( strng, 2000 ) dtolc
CALL ShowMessage( strng )
END IF
IF( dtolc .LT. para1 ) THEN
!.............达到足够的精度.
kmacr = lmacr( 2, kmacr )
ELSE
!.............未达到足够的精度.
kmacr = kmacr + 1
END IF
ELSE
IF( necho .EQ. 1 ) THEN
WRITE( strng, 2200 ) dtolc, ftolc
CALL ShowMessage( strng )
END IF
IF( dtolc .LT. para1 .AND. ftolc .LT. para2 ) THEN
!.............达到足够的精度.
kmacr = lmacr( 2, kmacr )
ELSE
!.............未达到足够的精度.
kmacr = kmacr + 1
END IF
END IF
ELSE IF( ncomm .EQ. 4 ) THEN
!.........宏命令nottolen
IF( para1 .GE. 1.0D0 ) THEN
para1 =-para1
para1 = 10.0D0 ** para1
END IF
IF( para1 .LT. 1.0D-12 ) para1 = 1.0D-5
IF( para2 .LT. 1.0D-12 ) para2 = para1
!.........以下为新版误差控制
wtolc = GetError()
CALL ShowError( para1, wtolc )
IF( necho .EQ. 1 ) THEN
WRITE( strng, 2000 ) dtolc
CALL ShowMessage( strng )
END IF
IF( wtolc .LT. para1 ) THEN
!...........达到足够的精度.
kmacr = kmacr + 1
ELSE
!...........未达到足够的精度.
kmacr = lmacr( 2, kmacr )
END IF
RETURN
!.........以下为旧版误差控制
IF( nincc .LE. 1 .OR. nincc .EQ. 3 ) THEN
IF( necho .EQ. 1 ) THEN
WRITE( strng, 2000 ) dtolc
CALL ShowMessage( strng )
END IF
IF( dtolc .LT. para1 ) THEN
!.............达到足够的精度.
kmacr = kmacr + 1
ELSE
!.............未达到足够的精度.
kmacr = lmacr( 2, kmacr )
END IF
ELSE
IF( necho .EQ. 1 ) THEN
WRITE( strng, 2200 ) dtolc, ftolc
CALL ShowMessage( strng )
END IF
IF( dtolc .LT. para1 .AND. ftolc .LT. para2 ) THEN
!.............达到足够的精度.
kmacr = kmacr + 1
ELSE
!.............未达到足够的精度.
kmacr = lmacr( 2, kmacr )
END IF
END IF
ELSE IF( ncomm .EQ. 5 ) THEN
kmacr = lmacr( 2, kmacr )
CALL ShowMessage( '运行暂停，敲回车键继续...' )
READ( *, * )
ELSE
WRITE( 12, 8000 ) ncomm
nerrc = 45496
END IF
RETURN
2000 FORMAT( '位移增量二模', E15.6 )
2200 FORMAT( '位移增量二模', E15.6, '，残差二模', E15.6 )
8000 FORMAT( //2x, '致命错误: 没有开发的宏命令', I5 )
END
SUBROUTINE Exec040
!........
! 模块功能
! 本模块负责执行命令编号在21-40之间的各条宏命令.
!........
USE CtrlData
USE MeshData
USE CentData
USE LoadData
USE GlobData
USE ElmtData
USE SolvData
USE FrontData
USE MacroData
USE ExtraMesh
USE EarthQuake
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. 21 ) THEN
!.........宏命令stiffen
iswth = 1
nrsdc = 1
kmacr = lmacr( 2, kmacr )
IF( nstfc .EQ. 0 ) iswth = 5
IF( npar1 .NE. 0 ) iswth = 5
IF( iswth .EQ. 1 ) nshfc = 0
IF( iswth .EQ. 1 ) ldecc( 1 ) = 1
CALL ElmLib( diagk, fstrs, iswth )
CALL AddCnt( iswth )
ELSE IF( ncomm .EQ. 22 ) THEN
!.........宏命令cmass
iswth = 2
nshfc = 0
kmacr = lmacr( 2, kmacr )
IF( nmssc .NE. 1 ) RETURN
IF( nmssc .EQ. 1 ) ldecc( 2 ) = 1
CALL ElmLib( diagm, fwork, iswth )
CALL AddCnt( iswth )
ELSE IF( ncomm .EQ. 23 ) THEN
!.........宏命令damp
iswth = 3
nshfc = 0
kmacr = lmacr( 2, kmacr )
IF( ndmpc .NE. 1 ) RETURN
IF( ndmpc .EQ. 1 ) ldecc( 3 ) = 1
CALL ElmLib( diagd, fwork, iswth )
CALL AddCnt( iswth )
ELSE IF( ncomm .EQ. 24 ) THEN
!.........宏命令Geometry
iswth = 4
nshfc = 0
kmacr = lmacr( 2, kmacr )
IF( nmssc .NE. 1 ) RETURN
IF( nmssc .EQ. 1 ) ldecc( 2 ) = 1
CALL ElmLib( diagm, fwork, iswth )
ELSE IF( ncomm .EQ. 25 ) THEN
!.........宏命令force
ngaus = 3
nfrcc = 1
iswth = 6
kmacr = lmacr( 2, kmacr )
IF( npar1 .GT. 0 ) kload = npar1
IF( kload .GT. nload ) THEN
nerrc = 1582
RETURN
END IF
CALL ShowPhase( kload )
CALL ElmLib( fwork, forcs, iswth )
CALL Load( forcs )
IF( nearc .EQ. 1 ) THEN
CALL QuakeForce
DO idofs = 1, ndofs
forcs( idofs ) = forcs( idofs ) + frceq( idofs )
END DO
END IF
CALL DynFrc
ELSE IF( ncomm .EQ. 26 ) THEN
!.........宏命令react
iswth = 10
IF( nreac .EQ. 0 ) CALL ElmLib( fwork, react, iswth )
CALL PrntDsp( npar1, npar2, npar3, 3 )
kmacr = lmacr( 2, kmacr )
nreac = 1
ELSE IF( ncomm .EQ. 30 .OR. ncomm .EQ. 31 ) THEN
!.........宏命令stress,nodestrs
kmacr = lmacr( 2, kmacr )
IF( npar2 .EQ. 0 ) npar2 = npar1
IF( npar1 .EQ. 0 ) npar1 = 1
IF( npar3 .EQ. 0 ) npar3 = 1
IF( ncomm .EQ. 30 ) THEN
iswth = 7
WRITE( 12, 2000 )
IF( npar2 .EQ. 0 ) npar2 = nelem
ntmp1 = npar1
ntmp2 = npar2
ntmp3 = npar3
ELSE
iswth = mswth + 7
ntmp1 = 1
ntmp3 = 1
ntmp2 = nelem
WRITE( 12, 2200 )
IF( npar2 .EQ. 0 ) npar2 = npoin
CALL InitFloat( strss, 7 * npoin, 0.0D0 )
CALL InitFloat( strns, 7 * npoin, 0.0D0 )
IF( nnodx .NE. 0 ) THEN
CALL InitFloat( strsx, 7 * nnodx, 0.0D0 )
CALL InitFloat( strnx, 7 * nnodx, 0.0D0 )
END IF
END IF
DO ielem = ntmp1, ntmp2, ntmp3
CALL ElmOpt( ielem, iswth )
IF( nerrc .GT. 0 ) RETURN
END DO
IF( ncomm .EQ. 31 ) CALL PrntStrs( npar1, npar2, npar3 )
ELSE IF( ncomm .EQ. 39 ) THEN
!.........宏命令liquid
iswth = 12
CALL ElmLib( fwork, react, iswth )
kmacr = lmacr( 2, kmacr )
ELSE
WRITE( 12, 8000 ) ncomm
nerrc = 45496
END IF
RETURN
2000 FORMAT( // 2x, 60( '=' ) // 12x, '高 斯 点 应 力', &
// 2x, 60( '=' ) // )
2200 FORMAT( // 2x, 60( '=' ) // 12x, '节 点 应 力', &
// 2x, 60( '=' ) // )
8000 FORMAT( //2x, '致命错误: 没有开发的宏命令', I5 )
END
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -