📄 execute.f90
字号:
END IF
RETURN
2000 FORMAT( '第', I5, '节点第', I2, '自由度位移为', G15.6 )
2200 FORMAT( '第', I5, '节点第', I2, '自由度速度为', G15.6 )
2400 FORMAT( '第', I5, '节点第', I2, '自由度加速度为', G15.6 )
2600 FORMAT( '当步时间为：', G15.6 )
2800 FORMAT( '载荷因子为：', G15.6 )
3000 FORMAT( '位移增量二模', E15.6, '，内力残差二模', E15.6 )
8000 FORMAT( //2x, '致命错误: 没有开发的宏命令', I5 )
END
SUBROUTINE Exec120
!........
! 模块功能
! 本模块负责执行命令编号在81-120之间的各条宏命令.
!........
USE CtrlData
USE MeshData
USE CentData
USE LoadData
USE GlobData
USE MacroData
USE FactorData
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
SELECT CASE( ncomm )
CASE( 81 )
!...........宏命令timestep
kmacr = lmacr( 2, kmacr )
tstep = para1
CASE( 82 )
!...........宏命令loadcase
kload = npar1
CALL ShowPhase( kload )
kmacr = lmacr( 2, kmacr )
CASE( 83 )
!...........宏命令nextload
kload = kload + 1
CALL ShowPhase( kload )
kmacr = lmacr( 2, kmacr )
CASE( 84 )
!...........宏命令alpha
kmacr = lmacr( 2, kmacr )
alpha = para1
CASE( 85 )
!...........宏命令belta
kmacr = lmacr( 2, kmacr )
belta = para1
CASE( 86 )
!...........宏命令theta
kmacr = lmacr( 2, kmacr )
theta = para1
CASE( 87 )
!...........宏命令dispstep
kmacr = lmacr( 2, kmacr )
dstep = para1
CASE( 88 )
!...........宏命令lockdof
kmacr = lmacr( 2, kmacr )
! CALL LckDOF( npar2, kdofc, npar1 )
CASE( 89 )
!...........宏命令lockpromp
kmacr = lmacr( 2, kmacr )
CALL LockPromp( npar1 )
CASE( 90 )
!...........宏命令prompt
kmacr = lmacr( 2, kmacr )
CALL SetPromp( npar1, para2 )
CASE( 91 )
!...........宏命令quake
CALL ReadQuake
kmacr = lmacr( 2, kmacr )
CASE( 92 )
!...........宏命令normalize
nuntc = 1
kmacr = lmacr( 2, kmacr )
CASE( 93 )
!...........宏命令lowlimit
IF( npar1 .GT. mdofn ) nerrc = 35345
IF( npar1 .LT. 0 ) nerrc = 35345
IF( nerrc .GT. 0 ) RETURN
llmts( 1, npar1 ) = 1
kmacr = lmacr( 2, kmacr )
vlmts( 1, npar1 ) = para2
CASE( 94 )
!...........宏命令uplimit
IF( npar1 .GT. mdofn ) nerrc = 35345
IF( npar1 .LT. 0 ) nerrc = 35345
IF( nerrc .GT. 0 ) RETURN
llmts( 2, npar1 ) = 1
kmacr = lmacr( 2, kmacr )
vlmts( 2, npar1 ) = para2
CASE( 95 )
!...........宏命令smooth
IF( npar1 .GT. mdofn ) nerrc = 35345
IF( npar1 .LE. 0 ) nerrc = 35345
IF( nerrc .GT. 0 ) RETURN
lsmts( npar1 ) = 1
nsmts = 1
kmacr = lmacr( 2, kmacr )
CASE( 96 )
!...........宏命令construct
kmacr = lmacr( 2, kmacr )
CALL UpdateStructure
IF( nerrc .NE. 0 ) RETURN
IF( npar1 .EQ. 0 ) RETURN
IF( npar3 .EQ. 0 ) npar3 = 1
IF( npar2 .EQ. 0 ) npar2 = npar1
DO ielem = npar1, npar2, npar3
luses( ielem ) = 1
END DO
CASE( 97 )
!...........宏命令destruct
kmacr = lmacr( 2, kmacr )
CALL UpdateStructure
IF( nerrc .NE. 0 ) RETURN
IF( npar1 .EQ. 0 ) RETURN
IF( npar3 .EQ. 0 ) npar3 = 1
IF( npar2 .LE. 0 ) npar2 = npar1
DO ielem = npar1, npar2, npar3
luses( ielem ) = 0
DO ipres = 1, nstrh
strsh( ipres, ielem ) = 0.0D0
END DO
END DO
CASE( 98 )
!...........宏命令free
kmacr = lmacr( 2, kmacr )
CALL UpdateStructure
IF( nerrc .NE. 0 ) RETURN
IF( npar2 .EQ. 0 ) RETURN
IF( npar1 .LE. 0 .OR. npar1 .GT. mdofn ) RETURN
IF( npar3 .EQ. 0 ) npar3 = npar2
IF( npar4 .EQ. 0 ) npar4 = 1
DO ipoin = npar2, npar3, npar4
lfixs( npar1, ipoin ) = 0
END DO
CASE( 99 )
!...........宏命令fix
kmacr = lmacr( 2, kmacr )
CALL UpdateStructure
IF( nerrc .NE. 0 ) RETURN
IF( npar2 .EQ. 0 ) RETURN
IF( npar1 .LE. 0 .OR. npar1 .GT. mdofn ) RETURN
IF( npar3 .EQ. 0 ) npar3 = npar2
IF( npar4 .EQ. 0 ) npar4 = 1
DO ipoin = npar2, npar3, npar4
lfixs( npar1, ipoin ) = 1
END DO
CASE( 100 )
!...........宏命令setmat
kmacr = lmacr( 2, kmacr )
CALL UpdateStructure
IF( nerrc .NE. 0 ) RETURN
CASE( 101 )
!...........宏命令time
kmacr = lmacr( 2, kmacr )
timec = para1
CASE( 102 )
!...........宏命令DOFWeight
kmacr = lmacr( 2, kmacr )
IF( npar1 .GE. 1 .AND. npar1 .LE. mdofn ) THEN
wdofs( npar1 ) = para2
ELSE
nerrc = 565677
END IF
CASE DEFAULT
WRITE( 12, 8000 ) ncomm
nerrc = 45496
END SELECT
RETURN
8000 FORMAT( //2x, '致命错误: 没有开发的宏命令', I5 )
END
SUBROUTINE Exec140
!........
! 模块功能
! 本模块负责执行命令编号在121-140之间的各条宏命令.
!........
USE CtrlData
USE MeshData
USE CentData
USE LoadData
USE GlobData
USE SolvData
USE FrontData
USE MacroData
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. 121 ) THEN
!.........宏命令backup
kmacr = lmacr( 2, kmacr )
CALL Backup
ELSE IF( ncomm .EQ. 122 ) THEN
!.........宏命令restore
kmacr = lmacr( 2, kmacr )
CALL Restore
ELSE IF( ncomm .EQ. 123 ) THEN
kmacr = lmacr( 2, kmacr )
CALL SaveDisp
ELSE IF( ncomm .EQ. 124 ) THEN
kmacr = lmacr( 2, kmacr )
CALL ReadDisp
ELSE IF( ncomm .EQ. 125 ) THEN
kmacr = lmacr( 2, kmacr )
CALL SaveHistory()
ELSE IF( ncomm .EQ. 126 ) THEN
kmacr = lmacr( 2, kmacr )
CALL ReadHistory()
ELSE IF( ncomm .EQ. 127 ) THEN
kmacr = lmacr( 2, kmacr )
CALL ReadPrestress
ELSE IF( ncomm .EQ. 128 ) THEN
!.........宏命令savepres
kmacr = lmacr( 2, kmacr )
CALL UpdateStructure
CALL SaveAsPrestress
ELSE
WRITE( 12, 8000 ) ncomm
nerrc = 45496
END IF
RETURN
8000 FORMAT( //2x, '致命错误: 没有开发的宏命令', I5 )
END
SUBROUTINE AddCnt( iswth )
USE CtrlData
USE CentData
USE SolvData
USE MeshData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
IF( iswth .EQ. 1 ) THEN
DO istfp = 1, nstfp
ipoin = lstfp( 1, istfp )
idofn = lstfp( 2, istfp )
ipoin = llnks( ipoin )
idofs = ipoin * mdofn + idofn - mdofn
diagk( idofs ) = diagk( idofs ) + vstfp( istfp )
END DO
ELSE IF( iswth .EQ. 2 ) THEN
DO imssp = 1, nmssp
ipoin = lmssp( 1, imssp )
idofn = lmssp( 2, imssp )
ipoin = llnks( ipoin )
idofs = ipoin * mdofn + idofn - mdofn
diagm( idofs ) = diagm( idofs ) + vmssp( imssp )
END DO
ELSE IF( iswth .EQ. 3 ) THEN
DO idmpp = 1, ndmpp
ipoin = ldmpp( 1, idmpp )
idofn = ldmpp( 2, idmpp )
ipoin = llnks( ipoin )
idofs = ipoin * mdofn + idofn - mdofn
diagd( idofs ) = diagd( idofs ) + vdmpp( idmpp )
END DO
END IF
RETURN
END
SUBROUTINE Aitken( vslvs )
USE CtrlData
USE MeshData
USE GlobData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
DIMENSION vslvs( ndofs )
kaitk = kaitk + 1
IF( kaitk .EQ. 1 ) THEN
DO idofs = 1, ndofs
aitkn( idofs ) = vslvs( idofs )
END DO
ELSE IF( kaitk .EQ. 2 ) THEN
kaitk = 0
cnst1 = 0.0D0
cnst2 = 0.0D0
DO ipoin = 1, npoin
DO idofn = 1, mdofn
idofs = ipoin * mdofn - mdofn + idofn
ifixs = lfixs( idofn, ipoin )
IF( ifixs .EQ. 0 ) THEN
const = aitkn( idofs ) - vslvs( idofs )
cnst1 = cnst1 + const * const
cnst2 = cnst2 + const * aitkn( idofs )
END IF
END DO
END DO
const = cnst2 / cnst1
DO ipoin = 1, npoin
DO idofn = 1, mdofn
idofs = ipoin * mdofn - mdofn + idofn
ifixs = lfixs( idofn, ipoin )
IF( ifixs .EQ. 0 ) vslvs( idofs ) = &
const * vslvs( idofs )
END DO
END DO
END IF
RETURN
END
FUNCTION GetError()
USE CtrlData
USE GlobData
USE SolvData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
idofs = 0
twrkc = 0.0D0
dwrkc = 0.0D0
DO ipoin = 1, npoin
DO idofn = 1, mdofn
idofs = idofs + 1
twrkc = twrkc + forcs( idofs ) * disps( idofs, kload ) * wdofs( idofn )
dwrkc = dwrkc + forcs( idofs ) * dspis( idofs, kload ) * wdofs( idofn )
END DO
END DO
IF( DABS( twrkc ) + DABS( dwrkc ) .LT. 1.0D-10 ) THEN
GetError = DABS( dwrkc - twrkc )
ELSE IF( DABS( twrkc ) .LT. 1.0D-10 ) THEN
GetError = DABS( ( twrkc - dwrkc ) / dwrkc )
ELSE
GetError = DABS( ( twrkc - dwrkc ) / twrkc )
END IF
END
SUBROUTINE BackSolveResult( iflag )
USE CtrlData
USE SolvData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
IF( iflag .EQ. 1 ) THEN
DO idofs = 1, ndofs
vslvi( idofs ) = vslvs( idofs )
END DO
ELSE
DO idofs = 1, ndofs
vslvt( idofs ) = vslvi( idofs )
END DO
END IF
END⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -