📄 data.f90
字号:
IF( ALLOCATED( stifr ) ) DEALLOCATE( stifr )
IF( ALLOCATED( lposr ) ) DEALLOCATE( lposr )
IF( ALLOCATED( forcr ) ) DEALLOCATE( forcr )
END SUBROUTINE DelResolve
END MODULE ReSolveData
MODULE FactorData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
DIMENSION promp( 4, 50 )
INTEGER npmpc
SAVE promp, npmpc
CONTAINS
SUBROUTINE InitFactor
npmpc = 1
CALL InitFloat( promp, 200, 0.0D0 )
promp( 1, 1 ) = 1.0D0
promp( 1, 2 ) = 0.0D0
promp( 2, 2 ) = 1.0D0
promp( 1, 3 ) = 0.0D0
promp( 2, 3 ) = 1.0D0
promp( 3, 3 ) = 1.0D0
promp( 1, 4 ) = 0.0D0
promp( 2, 4 ) = 1.0D0
promp( 3, 4 ) = 1.0D0
promp( 1, 5 ) = 1.0D0
promp( 2, 5 ) = 1.0D0
END SUBROUTINE InitFactor
SUBROUTINE LockPromp( iprom )
USE CtrlData
IF( iprom .GT. 0 .AND. iprom .LE. 50 ) THEN
npmpc = iprom
ELSE
nerrc = 3353
END IF
END SUBROUTINE LockPromp
SUBROUTINE SetPromp( ipara, value )
USE CtrlData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
IF( npmpc .LE. 0 .OR. npmpc .GT. 50 ) nerrc = 33533
IF( ipara .LE. 0 .OR. ipara .GT. 4 ) nerrc = 33534
IF( nerrc .GT. 0 ) RETURN
promp( ipara, npmpc ) = value
END SUBROUTINE SetPromp
SUBROUTINE Factor( ntype )
USE CtrlData
IMPLICIT DOUBLE PRECISION( a-h, o-z )
const = DATAN( 1.0D0 ) * 4.0D0
IF( ntype .EQ. 0 ) THEN
fctor = 1.0D0
ELSE IF( ntype .EQ. 1 ) THEN
fctor = promp( 1, 1 ) * timec
IF( fctor .GT. 1.0D0 ) fctor = 1.0D0
ELSE IF( ntype .EQ. 2 ) THEN
IF( timec .LT. promp( 1, 2 ) ) THEN
fctor = 0.0D0
ELSE IF( timec .LE. promp( 2, 2 ) ) THEN
fctor = 1.0D0
ELSE
fctor = 0.0D0
END IF
ELSE IF( ntype .EQ. 3 ) THEN
IF( timec .LT. promp( 1, 3 ) ) THEN
fctor = 0.0D0
ELSE IF( timec .LE. promp( 2, 3 ) ) THEN
vskip = promp( 2, 3 ) - promp( 1, 3 )
vspac = timec - promp( 1, 3 )
fctor = DSIN( vspac * const / vskip ) * promp( 3, 3 )
ELSE
fctor = 0.0D0
END IF
ELSE IF( ntype .EQ. 4 ) THEN
IF( timec .LT. promp( 1, 4 ) ) THEN
fctor = 0.0D0
ELSE IF( timec .LE. promp( 2, 4 ) ) THEN
fctor = ( timec - promp( 1, 4 ) ) / &
( promp( 2, 4 ) - promp( 1, 4 ) ) * 2.0D0
IF( fctor .GT. 1.0D0 ) fctor = 2.0D0 - fctor
fctor = fctor * promp( 3, 4 )
ELSE
fctor = 0.0D0
END IF
ELSE IF( ntype .EQ. 5 ) THEN
fctor = promp( 2, 5 ) * DSIN( timec * &
promp( 1, 5 ) * const )
ELSE
nerrc = 2465
END IF
END SUBROUTINE Factor
END MODULE FactorData
MODULE EarthQuake
IMPLICIT DOUBLE PRECISION( a-h, o-z )
ALLOCATABLE timeq(:), acceq(:), ampeq(:), frceq(:)
INTEGER naceq, nineq, nspeq, ncurp
DOUBLE PRECISION acurp, vcycl
SAVE timeq, acceq, ampeq, frceq, acurp, vcycl
CONTAINS
SUBROUTINE ReadQuake
USE CtrlData
ncurp = 1
OPEN( 25, FILE = '..\VFEAPDAT\Quake.DAT' )
READ( 25, '(3I5)' ) naceq, nineq, nspeq
ALLOCATE( timeq( naceq ), acceq( naceq ), &
ampeq( mdofn ), frceq( ndofs ), STAT = ierro )
IF( ierro .GT. 0 ) nerrc = 4
IF( nerrc .GT. 0 ) RETURN
READ( 25, '(E15.5)' ) vcycl
READ( 25, '(4E15.5)' ) ( ampeq( idofn ), &
idofn = 1, mdofn )
DO iaceq = 1, naceq
READ( 25, FMT = '(2E15.5)' ) timeq( iaceq ), &
acceq( iaceq )
END DO
nearc = 1
CLOSE( 25 )
CALL InitQuake
END SUBROUTINE ReadQuake
SUBROUTINE InitQuake
vcycl = vcycl / ( timeq( naceq ) - timeq( 1 ) )
END SUBROUTINE InitQuake
SUBROUTINE QuakeForce
USE CtrlData
USE SolvData
CALL CurrentQuake
DO idofs = 1, ndofs
frceq( idofs ) = 0.0D0
END DO
DO ipoin = 1, npoin
DO idofn = 1, mdofn
idofs = ( ipoin - 1 ) * mdofn + idofn
fwork( idofs ) =-ampeq( idofn ) * acurp
END DO
END DO
CALL DotMat( fwork, frceq, 2, 1, 1 )
END SUBROUTINE QuakeForce
SUBROUTINE CurrentQuake
USE CtrlData
IF( timec .LT. timeq( 1 ) ) THEN
acurp = 0.0D0
ELSE IF( timec .GT. timeq( naceq ) ) THEN
acurp = 0.0D0
ELSE
DO WHILE( timec .LT. timeq( ncurp ) )
ncurp = ncurp - 1
END DO
DO WHILE( timec .GT. timeq( ncurp + 1 ) )
ncurp = ncurp + 1
END DO
acurp = acceq( ncurp ) + ( timec - timeq( ncurp ) ) / &
( timeq( ncurp + 1 ) - timeq( ncurp ) ) * &
( acceq( ncurp + 1 ) - acceq( ncurp ) )
END IF
END SUBROUTINE CurrentQuake
SUBROUTINE DelEarthQuake
USE CtrlData
IF( ALLOCATED( timeq ) ) DEALLOCATE( timeq )
IF( ALLOCATED( acceq ) ) DEALLOCATE( acceq )
IF( ALLOCATED( ampeq ) ) DEALLOCATE( ampeq )
IF( ALLOCATED( frceq ) ) DEALLOCATE( frceq )
END SUBROUTINE DelEarthQuake
END MODULE EarthQuake
MODULE FileData
CHARACTER * 256 sdatf, soutf, smacf, sinif, smshf, shisf
CHARACTER * 256 sdisf, sstrf, ssavf, sdsvf, sstaf, spref
CHARACTER * 256 strnf
SAVE sdatf, soutf, smacf, sinif, smshf, shisf
SAVE sdisf, sstrf, ssavf, sdsvf, sstaf, spref, strnf
CONTAINS
SUBROUTINE FileName
CALL InitFileName
CALL ReadFileName
END SUBROUTINE FileName
SUBROUTINE InitFileName
sdatf = 'VFEAP.DAT'
soutf = 'VFEAP.OUT'
smacf = 'VFEAP.MAC'
sinif = 'VFEAP.INI'
smshf = 'VFEAP.MSH'
sdisf = 'VFEAP.DIS'
sstrf = 'VFEAP.STR'
ssavf = 'VFEAP.SAV'
sdsvf = 'VFEAP.DSV'
sstaf = 'VFEAP.STA'
shisf = 'VFEAP.HIS'
spref = 'VFEAP.PRE'
strnf = 'VFEAP.STN'
END SUBROUTINE InitFileName
SUBROUTINE ReadFileName
USE dfwin
USE MSFLib
CHARACTER * 256 drive, exten
CHARACTER * 256 filen, direc
CHARACTER * 256 namef
i = GetModuleFileName( NULL, filen, 256 )
i = SplitPathQQ( filen, drive, direc, namef, exten )
namef = TRIM( drive ) // TRIM( direc ) // 'VFEAP.NAM'
OPEN( 10, FILE = namef, SHARED )
READ( 10, '( A256 )', ERR = 200, END = 200 ) sdatf
READ( 10, '( A256 )', ERR = 200, END = 200 ) soutf
READ( 10, '( A256 )', ERR = 200, END = 200 ) smacf
READ( 10, '( A256 )', ERR = 200, END = 200 ) sinif
READ( 10, '( A256 )', ERR = 200, END = 200 ) smshf
READ( 10, '( A256 )', ERR = 200, END = 200 ) sdisf
READ( 10, '( A256 )', ERR = 200, END = 200 ) sstrf
READ( 10, '( A256 )', ERR = 200, END = 200 ) ssavf
READ( 10, '( A256 )', ERR = 200, END = 200 ) sdsvf
READ( 10, '( A256 )', ERR = 200, END = 200 ) sstaf
READ( 10, '( A256 )', ERR = 200, END = 200 ) shisf
READ( 10, '( A256 )', ERR = 200, END = 200 ) spref
READ( 10, '( A256 )', ERR = 200, END = 200 ) strnf
CLOSE( 10 )
RETURN
200 CALL InitFileName
CLOSE( 10 )
END SUBROUTINE ReadFileName
INTEGER FUNCTION GetFileName( filen, iswth )
USE dfwin
USE MSFLib
CHARACTER * 256 drive, exten
CHARACTER * 256 filen, direc
CHARACTER * 256 namef
i = GetModuleFileName( NULL, filen, 256 )
i = SplitPathQQ( filen, drive, direc, namef, exten )
namef = TRIM( drive ) // TRIM( direc ) // 'VFEAP.NAM'
OPEN( 10, FILE = namef, SHARED )
DO ifile = 1, iswth
READ( 10, '( A256 )', ERR = 200, END = 200 ) filen
END DO
CLOSE( 10 )
GetFileName = 0
RETURN
200 CLOSE( 10 )
GetFileName = 1
RETURN
END FUNCTION GetFileName
SUBROUTINE GetTempDirector( direc )
USE dfwin
USE MSFLib
CHARACTER * 256 drive, exten
CHARACTER * 256 filen, direc
CHARACTER * 256 namef
i = GetModuleFileName( NULL, filen, 256 )
i = SplitPathQQ( filen, drive, direc, namef, exten )
namef = TRIM( drive ) // TRIM( direc ) // 'VFEAP.PTH'
OPEN( 10, FILE = namef, SHARED )
READ( 10, '( A256 )', ERR = 200 ) direc
CLOSE( 10 )
RETURN
200 CLOSE( 10 )
DO ichar = 1, 256
direc( ichar:ichar ) = ' '
END DO
END SUBROUTINE GetTempDirector
END MODULE FileData
SUBROUTINE InitFloat( fvect, ndime, value )
IMPLICIT DOUBLE PRECISION( a-h, o-z )
DIMENSION fvect( ndime )
DO idime = 1, ndime
fvect( idime ) = value
END DO
RETURN
END
SUBROUTINE InitInteger( lvect, ndime, ivalu )
IMPLICIT DOUBLE PRECISION( a-h, o-z )
DIMENSION lvect( ndime )
DO idime = 1, ndime
lvect( idime ) = ivalu
END DO
RETURN
END
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -