📄 print.f90
字号:
SUBROUTINE PrntDsp( ipbeg, ipend, ipstp, iswth )
!........
! 模块功能
! 打印节点位移.
!........
USE CtrlData
USE GlobData
USE EarthQuake
USE ExtraMesh
IMPLICIT DOUBLE PRECISION( a-h, o-z )
DIMENSION vprin( 100 )
IF( nerrc .GT. 0 ) RETURN
IF( ipend .EQ. 0 ) ipend = ipbeg
IF( ipbeg .EQ. 0 ) ipbeg = 1
IF( ipstp .EQ. 0 ) ipstp = 1
IF( ipend .EQ. 0 ) ipend = npoin
IF( iswth .EQ. 0 ) THEN
WRITE( 12, 2000 ) kload, timec, fctor
DO ipoin = ipbeg, ipend, ipstp
DO idofn = 1, mdofn
idofs = ( ipoin - 1 ) * mdofn + idofn
vprin( idofn ) = disps( idofs, kload )
END DO
WRITE( 12, 2200 ) ipoin, ( vprin( idofn ), &
idofn = 1, mdofn )
END DO
IF( ( ipend - ipbeg ) / ipstp + 1 .EQ. npoin ) THEN
DO inodx = 1, nnodx
ipoin = inodx + npoin
DO idofn = 1, mdofn
idofx = ( inodx - 1 ) * mdofn + idofn
vprin( idofn ) = dispx( idofx, kload )
END DO
WRITE( 12, 2200 ) ipoin, ( vprin( idofn ), &
idofn = 1, mdofn )
END DO
END IF
ELSE IF( iswth .EQ. 1 ) THEN
WRITE( 12, 2001 ) kload, timec, fctor
DO ipoin = ipbeg, ipend, ipstp
DO idofn = 1, mdofn
idofs = ( ipoin - 1 ) * mdofn + idofn
vprin( idofn ) = veloc( idofs, kload )
END DO
WRITE( 12, 2200 ) ipoin, ( vprin( idofn ), &
idofn = 1, mdofn )
END DO
ELSE IF( iswth .EQ. 2 ) THEN
WRITE( 12, 2002 ) kload, timec, fctor
DO ipoin = ipbeg, ipend, ipstp
DO idofn = 1, mdofn
idofs = ( ipoin - 1 ) * mdofn + idofn
vprin( idofn ) = accel( idofs, kload )
END DO
IF( nearc .EQ. 1 ) THEN
DO idofn = 1, mdofn
vprin( idofn ) = vprin( idofn ) + &
ampeq( idofn ) * acurp
END DO
END IF
WRITE( 12, 2200 ) ipoin, ( vprin( idofn ), &
idofn = 1, mdofn )
END DO
ELSE IF( iswth .EQ. 3 ) THEN
WRITE( 12, 2003 ) kload, timec, fctor
DO ipoin = ipbeg, ipend, ipstp
idofs = ( ipoin - 1 ) * mdofn + 1
jdofs = ipoin * mdofn
WRITE( 12, 2200 ) ipoin, (-react( kdofs ), &
kdofs = idofs, jdofs )
END DO
END IF
2000 FORMAT( //2x, 60('=')//2x, '节点位移(工况', I2, ')', 5x, &
'时间', E15.5, 2x, '载荷因子', E15.5 //2x, 60('=')// )
2001 FORMAT( //2x, 60('=')//2x, '节点速度(工况', I2, ')', 5x, &
'时间', E15.5, 2x, '载荷因子', E15.5 //2x, 60('=')// )
2002 FORMAT( //2x, 60('=')//2x, '节点加速度(工况', I2, ')', 5x, &
'时间', E15.5, 2x, '载荷因子', E15.5 //2x, 60('=')// )
2003 FORMAT( //2x, 60('=')//2x, '节点反力(工况', I2, ')', 5x, &
'时间', E15.5, 2x, '载荷因子', E15.5 //2x, 60('=')// )
2200 FORMAT( 2X, I5, 4E15.6 / ( 7X, 4E15.6 ) )
RETURN
END
SUBROUTINE PrntStrs( npar1, npar2, npar3 )
USE CtrlData
USE GlobData
USE MeshData
USE ExtraMesh
DO ipoin = npoin, 1, -1
jpoin = llnks( ipoin )
IF( strss( 7, ipoin ) .GT. 1.0D-16 ) THEN
IF( jpoin .NE. ipoin ) THEN
DO istrs = 1, 7
strss( istrs, jpoin ) = strss( istrs, jpoin ) + &
strss( istrs, ipoin )
strns( istrs, jpoin ) = strns( istrs, jpoin ) + &
strns( istrs, ipoin )
END DO
ELSE
DO istrs = 1, 6
strss( istrs, ipoin ) = strss( istrs, ipoin ) / &
strss( 7, ipoin )
strns( istrs, ipoin ) = strns( istrs, ipoin ) / &
strns( 7, ipoin )
END DO
END IF
END IF
END DO
DO ipoin = 1, npoin
jpoin = llnks( ipoin )
IF( ipoin .NE. jpoin ) THEN
DO istrs = 1, 7
strss( istrs, ipoin ) = strss( istrs, jpoin )
strns( istrs, ipoin ) = strns( istrs, jpoin )
END DO
END IF
END DO
DO inodx = 1, nnodx
IF( strsx( 7, inodx ) .GT. 1.0D-8 ) THEN
DO istrs = 1, 6
strsx( istrs, inodx ) = strsx( istrs, inodx ) / &
strsx( 7, inodx )
strnx( istrs, inodx ) = strnx( istrs, inodx ) / &
strnx( 7, inodx )
END DO
END IF
END DO
WRITE( 12, 2000 )
DO ipoin = npar1, npar2, npar3
WRITE( 12, 2200 ) ipoin, ( strss( istrs, ipoin ), &
istrs = 1, 6 )
END DO
IF( ( npar2 - npar1 ) / npar3 + 1 .EQ. npoin ) THEN
DO inodx = 1, nnodx
ipoin = inodx + npoin
WRITE( 12, 2200 ) ipoin, ( strsx( istrs, inodx ), &
istrs = 1, 6 )
WRITE( 12, 2400 ) ( strnx( istrs, inodx ), istrs = 1, 6 )
END DO
END IF
2000 FORMAT( /// 10x, ' 节 点 应 力 ' // &
' Sigma-x Sigma-y Sigma-z Tao-yz ', &
' Tao-zx Tao-xy' / &
' Epson-x Epson-y Epson-z Gama-yz ', &
' Gama-zx Gama-xy' )
2200 FORMAT( I5, 6E15.5 )
2400 FORMAT( 5X, 6E15.5 )
RETURN
END
SUBROUTINE PrntPlt( iswth, ndofo )
!........
! 模块功能
! 输出图形数据文件.
!........
USE CtrlData
USE MeshData
USE GlobData
USE ExtraMesh
IMPLICIT DOUBLE PRECISION( a-h, o-z )
DIMENSION point( 6 ), lfixn( 6 ), ldofc( 6 )
DO idime = 1, 6
point( idime ) = 0.0D0
ldofc( idime ) = idime
IF( idime .GT. mdofn ) ldofc( idime ) = 0
END DO
DO idofn = 1, 6
lfixn( idofn ) = 0
END DO
IF( ndofo .GT. 0 ) THEN
nwork = 4
nswth = 10
IF( iswth .EQ. 0 ) nwork = 6
IF( mdofn .GE. 10 ) nswth = 100
DO idime = 1, nwork
jdime = nwork - idime
ldofc( idime ) = ndofo / nswth ** jdime
ndofo = ndofo - ldofc( idime ) * nswth ** jdime
IF( ldofc( idime ) .GT. mdofn ) nerrc = 24325
IF( ldofc( idime ) .LT. 0 ) nerrc = 32435
END DO
IF( nerrc .GT. 0 ) RETURN
END IF
IF( iswth .EQ. 0 ) THEN
DO ipoin = 1, npoin
DO idime = 1, ndime
point( idime ) = coord( idime, ipoin )
END DO
DO idofn = 1, 6
lfixn( idofn ) = 0
jdofn = ldofc( idofn )
IF( jdofn .LT. mdofn .AND. jdofn .GT. 0 ) THEN
lfixn( idofn ) = lfixs( jdofn, ipoin )
END IF
END DO
WRITE( 15, 2000 ) ipoin, lfixn, ( point( idime ), &
idime = 1, 3 )
END DO
DO idofn = 1, 6
lfixn( idofn ) = 0
END DO
DO inodx = 1, nnodx
ipoin = npoin + inodx
DO idime = 1, ndime
point( idime ) = coorx( idime, inodx )
END DO
WRITE( 15, 2000 ) ipoin, lfixn, ( point( idime ), &
idime = 1, 3 )
END DO
WRITE( 15, 2000 ) 0
DO ielem = 1, nelem
CALL ElmOpt( ielem, 9 )
END DO
WRITE( 15, 2000 ) 0
ELSE IF( iswth .EQ. 1 ) THEN
kmode = 1
IF( ntypc .EQ. 1 ) kmode = nmode
IF( ntypc .EQ. 3 ) kmode = nmode + 1
DO imode = 1, kmode
ctime = timec
kpdis = kpdis + 1
IF( ntypc .EQ. 1 ) THEN
ctime = freqs( imode )
ELSE IF( ntypc .EQ. 3 ) THEN
IF( imode .EQ. 1 ) ctime = 0.0D0
IF( imode .GT. 1 ) ctime = freqs( imode - 1 )
END IF
WRITE( 16, 2400 ) kpdis, ctime
DO ipoin = 1, npoin
DO idofn = 1, 4
jdofn = ldofc( idofn )
IF( jdofn .GT. 0 ) THEN
idofs = ( ipoin - 1 ) * mdofn + jdofn
IF( ntypc .EQ. 1 ) THEN
point( idofn ) = shmod( idofs, imode )
ELSE IF( ntypc .EQ. 3 ) THEN
IF( imode .EQ. 1 ) THEN
point( idofn ) = disps( idofs, kload )
ELSE
point( idofn ) = shmod( idofs, imode - 1 )
END IF
ELSE
point( idofn ) = disps( idofs, kload )
END IF
ELSE
point( idofn ) = 0.0D0
END IF
IF( DABS( point( idofn ) ) .LT. 1.0D-10 ) &
point( idofn ) = 0.0D0
END DO
WRITE( 16, 2400 ) ipoin, ( point( idime ), idime = 1, 4 )
END DO
DO inodx = 1, nnodx
DO idofn = 1, 4
jdofn = ldofc( idofn )
IF( jdofn .GT. 0 ) THEN
idofx = ( inodx - 1 ) * mdofn + jdofn
IF( ntypc .EQ. 1 ) THEN
point( idofn ) = smodx( idofx, imode )
ELSE IF( ntypc .EQ. 3 ) THEN
IF( imode .EQ. 1 ) THEN
point( idofn ) = dispx( idofx, kload )
ELSE
point( idofn ) = smodx( idofx, imode - 1 )
END IF
ELSE
point( idofn ) = dispx( idofx, kload )
END IF
ELSE
point( idofn ) = 0.0D0
END IF
IF( DABS( point( idofn ) ) .LT. 1.0D-16 ) &
point( idofn ) = 0.0D0
END DO
WRITE( 16, 2400 ) inodx + npoin, &
( point( idime ), idime = 1, 4 )
END DO
WRITE( 16, 2000 ) 0
END DO
ELSE IF( iswth .EQ. 2 ) THEN
kpstr = kpstr + 1
WRITE( 17, 2400 ) kpstr, timec
WRITE( 23, 2400 ) kpstr, timec
DO ipoin = 1, npoin
WRITE( 17, 2600 ) ipoin, ( strss( istrs, ipoin ), &
istrs = 1, 6 )
WRITE( 23, 2600 ) ipoin, ( strns( istrs, ipoin ), &
istrs = 1, 6 )
END DO
DO inodx = 1, nnodx
WRITE( 17, 2600 ) inodx + npoin, ( strsx( istrs, inodx ), &
istrs = 1, 6 )
WRITE( 23, 2600 ) inodx + npoin, ( strnx( istrs, inodx ), &
istrs = 1, 6 )
END DO
WRITE( 17, 2600 ) 0
WRITE( 23, 2600 ) 0
END IF
2000 FORMAT( I5, 1X, 6I1, 2X, 3F15.5 )
2400 FORMAT( I5, 1X, 4E15.5 )
2600 FORMAT( I5, 1X, 6E15.5 )
RETURN
END
SUBROUTINE PrntStat
USE CtrlData
USE GlobData
nstat = nstat + 1
WRITE( 12, 2000 ) timec
WRITE( 12, 2200 ) ( ielem, lstat( ielem ), ielem = 1, nelem )
WRITE( 12, 2200 ) 0
2000 FORMAT( //15x, '时间', F15.5, '，单元状态' // )
2200 FORMAT( 4( 2I5, 5X ) )
RETURN
END
SUBROUTINE PlotStat
USE CtrlData
USE GlobData
nstat = nstat + 1
WRITE( 20, 2000 ) nstat, timec
WRITE( 20, 2200 ) ( ielem, lstat( ielem ), ielem = 1, nelem )
WRITE( 20, 2200 ) 0
2000 FORMAT( I5, F15.5 )
2200 FORMAT( 4( 2I5, 5X ) )
RETURN
END
SUBROUTINE linkNode
USE CtrlData
USE GlobData
USE SolvData
USE MeshData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
!.......处理连接点
DO ipoin = 1, npoin
jpoin = llnks( ipoin )
IF( ipoin .NE. jpoin ) THEN
DO idofn = 1, mdofn
idofs = ( ipoin - 1 ) * mdofn + idofn
jdofs = ( jpoin - 1 ) * mdofn + idofn
vslvs( idofs ) = vslvs( jdofs )
END DO
END IF
END DO
RETURN
END
SUBROUTINE Exchang( iswth )
!........
! S U B R O U T I N E
! To get displacement or accelerate from force( the right hand )
!........
USE CtrlData
USE GlobData
USE SolvData
USE MeshData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
IF( iswth .EQ. 1 ) THEN
dtolc = 0.0D0
dmaxp = 0.0D0
!.........迭代步位移累加, 计算相对误差.
IF( nincc .EQ. 2 ) THEN
DO idofs = 1, ndofs
vslvs( idofs ) = vslvs( idofs ) + disps( idofs, kload )
END DO
ELSE IF( nincc .EQ. 3 ) THEN
DO idofs = 1, ndofs
vslvs( idofs ) = vslvs( idofs ) + distm( idofs, kload )
END DO
END IF
DO idofs = 1, ndofs
disps( idofs, kload ) = vslvs( idofs )
END DO
IF( ntypc .EQ. 2 ) CALL DynSlv
CALL Limit
idofs = 0
DO ipoin = 1, npoin
DO idofn = 1, mdofn
idofs = idofs + 1
fwdof = wdofs( idofn )
ftotl = disps( idofs, kload )
fincr = disps( idofs, kload ) - dspis( idofs, kload )
dtolc = dtolc + fincr * fincr * fwdof
dmaxp = dmaxp + ftotl * ftotl * fwdof
END DO
END DO
IF( dmaxp .LT. 1.0D-20 ) dtolc = DSQRT( dtolc )
IF( dmaxp .GE. 1.0D-20 ) dtolc = DSQRT( dtolc / dmaxp )
ELSE IF( iswth .EQ. 2 ) THEN
DO idofs = 1, ndofs
accel( idofs, kload ) = vslvs( idofs )
END DO
END IF
RETURN
END
SUBROUTINE Trace( iswth, ipoin, idofn )
USE CtrlData
USE GlobData
USE EarthQuake
IMPLICIT DOUBLE PRECISION( a-h, o-z )
CHARACTER * 256 filen
jpoin = ipoin
jdofn = idofn
IF( ipoin .LE. 0 ) jpoin = npoin
IF( ipoin .LE. 0 ) ipoin = 1
IF( iswth .LE. 3 ) THEN
IF( idofn .LE. 0 ) jdofn = mdofn
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -