optrec.f90

边界元程序,供力学工作者参考,希望对大家有所帮助

        SUBROUTINE OptRec( buffs, ircrd, iflag, iswth, nexch )
!........
!       模块功能
!           读写记录文件.
!........
!       buffs 内存缓冲区           ircrd 记录号
!       iflag 读写标记 ==1 读      iswth 一致矩阵类
!                      ==2 写      nexch 缓冲区长度
!........
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        CHARACTER  filen * 256
        DIMENSION  buffs( nexch )
        IF( iswth .LT. 1 .OR. iswth .GT. 4 ) RETURN
        CALL TempFileName( ircrd, iswth, filen )
!.......打开文件, 完成读写操作.
        OPEN( 31, FILE = filen, FORM = 'UNFORMATTED' )
        IF( iflag .EQ. 1 ) THEN
          DO iexch = 1, nexch
            READ( 31 ) buffs( iexch )
          END DO
        ELSE
          DO iexch = 1, nexch
            WRITE( 31 ) buffs( iexch )
            buffs( iexch ) = 0.0D0
          END DO
        END IF
        CLOSE( 31 )
        RETURN
        END

        SUBROUTINE TempFileName( ircrd, iswth, filen )
        USE FileData
        CHARACTER * 256 direc, filen
        kswth = iswth
        IF( kswth .EQ. 4 ) kswth = 2             !几何刚度阵
        IF( kswth .LT. 1 .OR. kswth .GT. 4 ) RETURN
        CALL GetTempDirector( direc )
        DO ichar = 1, 256
          filen( ichar:ichar ) = ' '
        END DO
!.......设定文件名.
        kwork = ircrd
        IF( kswth .EQ. 1 ) filen(9:12) = '.stf'
        IF( kswth .EQ. 2 ) filen(9:12) = '.mss'
        IF( kswth .EQ. 3 ) filen(9:12) = '.dmp'
        DO iwork = 1, 8
          jwork = 8 - iwork
          jwork = 10 ** jwork
          idigt = kwork / jwork
          kwork = kwork - idigt * jwork
          WRITE( filen( iwork:iwork ), '( I1 )' ) idigt
        END DO
        filen = TRIM( direc ) // '/' // TRIM( filen )
        END

        SUBROUTINE ShftMat
!........
!
!
!........
        USE CtrlData
        USE SolvData
        USE FrontData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        CHARACTER fmass * 256, fstif * 256, fdamp * 256
!........
        IF( lsavc( 1 ) .EQ. 0 ) THEN
          nerrc = 1234
          RETURN
        END IF
        IF( ldecc( 1 ) .NE. 1 ) THEN
          nerrc = 1235
          RETURN
        END IF
!.......
        vstif = 0.0D0
        vmass = 0.0D0
        vdamp = 0.0D0
        istfc = lsavc( 1 )
        imssc = lsavc( 2 )
        idmpc = lsavc( 3 )
        shftk = shift( 1 )
        shftm = shift( 2 )
        shftd = shift( 3 )
!.......
        DO idofs = 1, ndofs
          IF( istfc .NE. 0 ) vstif = diagk( idofs )
          IF( imssc .NE. 0 ) vmass = diagm( idofs )
          IF( idmpc .NE. 0 ) vdamp = diagd( idofs )
          diagk( idofs ) = vstif * shftk + vmass * shftm +                     &
                           vdamp * shftd
        END DO
        IF( istfc .EQ. 2 ) RETURN
!.......
        vstif = 0.0D0
        vmass = 0.0D0
        vdamp = 0.0D0
!.......
        DO ircrd = 1, nrcrd
          CALL TempFileName( ircrd, 1, fstif )
          CALL TempFileName( ircrd, 2, fmass )
          CALL TempFileName( ircrd, 3, fdamp )
          OPEN( 31, FIlE = fstif, FORM = 'UNFORMATTED' )
          OPEN( 32, FIlE = fmass, FORM = 'UNFORMATTED' )
          OPEN( 33, FIlE = fdamp, FORM = 'UNFORMATTED' )
          DO iexch = 1, nexch
            IF( istfc .EQ. 1 ) READ( 31 ) vstif
            IF( imssc .EQ. 1 ) READ( 32 ) vmass
            IF( idmpc .EQ. 1 ) READ( 33 ) vdamp
            IF( istfc .EQ. 1 ) locat = iexch
            IF( istfc .LT. 0 ) locat = iexch - istfc - 1
            IF( istfc .LT. 0 ) vstif = buffs( iexch - istfc - 1 )
            IF( imssc .LT. 0 ) vmass = buffs( iexch - imssc - 1 )
            IF( idmpc .LT. 0 ) vdamp = buffs( iexch - idmpc - 1 )
            buffs( locat ) = vstif * shftk + vmass * shftm +                   &
                             vdamp * shftd
          END DO
          CLOSE( 31 )
          CLOSE( 32 )
          CLOSE( 33 )
          IF( istfc .EQ. 1 ) CALL OptRec( buffs, ircrd, 2, 1, nexch )
        END DO
        RETURN
        END