print.f90

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

          IF( idofn .LE. 0 ) idofn = 1
        ELSE
          IF( idofn .LE. 0 ) jdofn = 6
          IF( idofn .LE. 0 ) idofn = 1
        END IF
        IF( iswth .EQ. 0 .OR. iswth .EQ. 1 ) THEN
          DO kpoin = ipoin, jpoin
            DO kdofn = idofn, jdofn
              CALL HisFile( filen, iswth, kpoin, kdofn )
              OPEN( 25, file = filen, ACCESS = 'APPEND' )
              kdofs = ( kpoin - 1 ) * mdofn + kdofn
              WRITE( 25, 2000 ) timec, disps( kdofs, kload )
            END DO
          END DO
        END IF
        IF( iswth .EQ. 0 .OR. iswth .EQ. 2 ) THEN
          DO kpoin = ipoin, jpoin
            DO kdofn = idofn, jdofn
              CALL HisFile( filen, iswth, kpoin, kdofn )
              OPEN( 25, file = filen, ACCESS = 'APPEND' )
              kdofs = ( kpoin - 1 ) * mdofn + kdofn
              WRITE( 25, 2000 ) timec, veloc( kdofs, kload )
            END DO
          END DO
        END IF
        IF( iswth .EQ. 0 .OR. iswth .EQ. 3 ) THEN
          DO kpoin = ipoin, jpoin
            DO kdofn = idofn, jdofn
              CALL HisFile( filen, iswth, kpoin, kdofn )
              OPEN( 25, file = filen, ACCESS = 'APPEND' )
              kdofs = ( kpoin - 1 ) * mdofn + kdofn
              IF( nearc .EQ. 0 ) THEN
                WRITE( 25, 2000 ) timec, accel( kdofs, kload )
              ELSE
                WRITE( 25, 2000 ) timec,  accel( kdofs, kload ) +              &
                                  acurp * ampeq( kdofn )
              END IF
            END DO
          END DO
        END IF
        IF( iswth .EQ. 4 ) THEN
          DO kpoin = ipoin, jpoin
            DO kdofn = idofn, jdofn
              CALL HisFile( filen, iswth, kpoin, kdofn )
              OPEN( 25, file = filen, ACCESS = 'APPEND' )
              WRITE( 25, 2000 ) timec, strss( kdofn, kpoin )
            END DO
          END DO
        END IF
        CLOSE( 25 )
2000    FORMAT( E15.8, 2X, E15.8 )
        RETURN
        END

        SUBROUTINE Backup
!........
!       模块功能
!           保存当前状态.
!........
        USE CtrlData
        USE SolvData
        USE GlobData
        USE FrontData
        USE MacroData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
!.......保存控制变量
        WRITE( 18 ) nload, kload, ndofs
        WRITE( 18 ) alpha, belta, theta
        WRITE( 18 ) ntypc, kmacr, nmacr, nmode
        WRITE( 18 ) lsavc, ldecc, shift, nshfc
        WRITE( 18 ) timec, tstep, fctor, nbufs
        WRITE( 18 ) nfrcc, ndync, nupdc, nrsdc
!.......保存宏命令
        DO imacr = 1, nmacr
          WRITE( 18 ) ( lmacr( ipara, imacr ), ipara = 1, 7 )
        END DO
!.......保存静态量
        WRITE( 18 ) ( forcs( idofs ), idofs = 1, ndofs )
        WRITE( 18 ) ( vslvs( idofs ), idofs = 1, ndofs )
        WRITE( 18 ) ( fstrs( idofs ), idofs = 1, ndofs )
        WRITE( 18 ) ( statf( idofs ), idofs = 1, ndofs )
        WRITE( 18 ) ( diagk( idofs ), idofs = 1, ndofs )
        WRITE( 18 ) ( fbcks( ibcks ), ibcks = 1, nbcks )
        WRITE( 18 ) ( stifw( istfw ), istfw = 1, mstfw )
        WRITE( 18 ) ( buffs( ibufs ), ibufs = 1, nbufs )
        DO iload = 1, nload
          WRITE( 18 ) ( disps( idofs, iload ), idofs = 1, ndofs )
          WRITE( 18 ) ( distm( idofs, iload ), idofs = 1, ndofs )
        END DO
!.......保存历史量
        IF( nhstr .GT. 0 ) THEN
          DO ielem = 1, nelem
            WRITE( 18 ) ( histr( ihstr, ielem ), ihstr = 1, nhstr )
          END DO
        END IF
!.......保存动态量
        IF( ntypc .EQ. 2 ) THEN
          WRITE( 18 ) ( diagd( idofs ), idofs = 1, ndofs )
          WRITE( 18 ) ( diagm( idofs ), idofs = 1, ndofs )
          WRITE( 18 ) ( frctm( idofs ), idofs = 1, ndofs )
          WRITE( 18 ) ( fstrt( idofs ), idofs = 1, ndofs )
          DO iload = 1, nload
            WRITE( 18 ) ( veloc( idofs, iload ), idofs = 1, ndofs )
            WRITE( 18 ) ( veltm( idofs, iload ), idofs = 1, ndofs )
            WRITE( 18 ) ( accel( idofs, iload ), idofs = 1, ndofs )
            WRITE( 18 ) ( acctm( idofs, iload ), idofs = 1, ndofs )
          END DO
        END IF
!.......保存模态信息
        DO imode = 1, nmode
          WRITE( 18 )   freqs( imode )
          WRITE( 18 ) ( shmod( idofs, imode ), idofs = 1, ndofs )
        END DO
!.......关闭文件并退出
        REWIND( 18 )
        RETURN
        END

        SUBROUTINE Restore
!........
!       模块功能
!           恢复当前状态.
!........
        USE CtrlData
        USE SolvData
        USE GlobData
        USE FrontData
        USE MacroData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
!.......保存控制变量
        READ( 18 ) nload, kload, ndofs
        READ( 18 ) alpha, belta, theta
        READ( 18 ) ntypc, kmacr, nmacr, nmode
        READ( 18 ) lsavc, ldecc, shift, nshfc
        READ( 18 ) timec, tstep, fctor, nbufs
        READ( 18 ) nfrcc, ndync, nupdc, nrsdc
!.......保存宏命令
        DO imacr = 1, nmacr
          READ( 18 ) ( lmacr( ipara, imacr ), ipara = 1, 7 )
        END DO
!.......保存静态量
        READ( 18 ) ( forcs( idofs ), idofs = 1, ndofs )
        READ( 18 ) ( vslvs( idofs ), idofs = 1, ndofs )
        READ( 18 ) ( fstrs( idofs ), idofs = 1, ndofs )
        READ( 18 ) ( statf( idofs ), idofs = 1, ndofs )
        READ( 18 ) ( diagk( idofs ), idofs = 1, ndofs )
        READ( 18 ) ( fbcks( ibcks ), ibcks = 1, nbcks )
        READ( 18 ) ( stifw( istfw ), istfw = 1, mstfw )
        READ( 18 ) ( buffs( ibufs ), ibufs = 1, nbufs )
        DO iload = 1, nload
          READ( 18 ) ( disps( idofs, iload ), idofs = 1, ndofs )
          READ( 18 ) ( distm( idofs, iload ), idofs = 1, ndofs )
        END DO
!.......保存历史量
        IF( nhstr .GT. 0 ) THEN
          DO ielem = 1, nelem
            READ( 18 ) ( histr( ihstr, ielem ), ihstr = 1, nhstr )
          END DO
        END IF
!.......保存动态量
        IF( ntypc .EQ. 2 ) THEN
          READ( 18 ) ( diagd( idofs ), idofs = 1, ndofs )
          READ( 18 ) ( diagm( idofs ), idofs = 1, ndofs )
          READ( 18 ) ( frctm( idofs ), idofs = 1, ndofs )
          READ( 18 ) ( fstrt( idofs ), idofs = 1, ndofs )
          DO iload = 1, nload
            READ( 18 ) ( veloc( idofs, iload ), idofs = 1, ndofs )
            READ( 18 ) ( veltm( idofs, iload ), idofs = 1, ndofs )
            READ( 18 ) ( accel( idofs, iload ), idofs = 1, ndofs )
            READ( 18 ) ( acctm( idofs, iload ), idofs = 1, ndofs )
          END DO
        END IF
!.......保存模态信息
        DO imode = 1, nmode
          READ( 18 )   freqs( imode )
          READ( 18 ) ( shmod( idofs, imode ), idofs = 1, ndofs )
        END DO
!.......关闭文件并退出
        REWIND( 18 )
        RETURN
        END

        SUBROUTINE SaveDisp
        USE CtrlData
        USE GlobData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        WRITE( 19, ERR = 200 ) ndofs, nload, ntypc
        DO iload = 1, nload
          DO idofs = 1, ndofs
            WRITE( 19, ERR = 200 ) disps( idofs, iload )
            WRITE( 19, ERR = 200 ) distm( idofs, iload )
          END DO
        END DO
        IF( ntypc .EQ. 2 ) THEN
          DO iload = 1, nload
            DO idofs = 1, ndofs
              WRITE( 19, ERR = 200 ) veloc( idofs, iload )
              WRITE( 19, ERR = 200 ) veltm( idofs, iload )
              WRITE( 19, ERR = 200 ) accel( idofs, iload )
              WRITE( 19, ERR = 200 ) acctm( idofs, iload )
            END DO
          END DO
        END IF
        REWIND( 19 )
        RETURN
200     WRITE( 12, 2000 )
        nerrc = 20356
2000    FORMAT( //2x, '致命错误: 写位移文件出错' )
        RETURN
        END

        SUBROUTINE ReadDisp
        USE CtrlData
        USE GlobData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        READ( 19, ERR = 200 ) idofs, iload, itype
        IF( idofs .NE. ndofs .OR. iload .NE. nload .OR.                        &
            itype .NE. ntypc ) THEN
          WRITE( 12, 2000 )
          nerrc = 49607
          RETURN
        END IF
        DO iload = 1, nload
          DO idofs = 1, ndofs
            READ( 19, ERR = 200 ) disps( idofs, iload )
            READ( 19, ERR = 200 ) distm( idofs, iload )
          END DO
        END DO
        IF( ntypc .EQ. 2 ) THEN
          DO iload = 1, nload
            DO idofs = 1, ndofs
              READ( 19, ERR = 200 ) veloc( idofs, iload )
              READ( 19, ERR = 200 ) veltm( idofs, iload )
              READ( 19, ERR = 200 ) accel( idofs, iload )
              READ( 19, ERR = 200 ) acctm( idofs, iload )
            END DO
          END DO
        END IF
        REWIND( 19 )
        RETURN
200     WRITE( 12, 2200 )
        nerrc = 203535
2000    FORMAT( //2x, '致命错误: 位移文件不匹配' )
2200    FORMAT( //2x, '致命错误: 读位移文件出错' )
        END

        SUBROUTINE SaveHistory()
        USE CtrlData
        USE GlobData
        USE ExtraMesh
        IMPLICIT DOUBLE PRECISION( a-h, o-z )

        REWIND( 21 )
        IF( nhstr .GT. 0 ) THEN
          DO ielem = 1, nelem
            WRITE( 21, 2000 ) ielem, ( histr( ihstr, ielem ),                  &
                              ihstr =  1, nhstr )
          END DO
          IF( nelmx .GT. 0 ) THEN
            DO ielmx = 1, nelmx
              WRITE( 21, 2000 ) ielmx, ( histx( ihstr, ielmx ),                &
                                ihstr =  1, nhstr )
            END DO
          END IF
        END IF
2000    FORMAT( I5, 4E15.5 / 5x, 4E15.5 )
        RETURN
        END

        SUBROUTINE ReadHistory()
        USE CtrlData
        USE GlobData
        USE ExtraMesh
        IMPLICIT DOUBLE PRECISION( a-h, o-z )

        REWIND( 21 )
        IF( nhstr .GT. 0 ) THEN
          DO ielem = 1, nelem
            READ( 21, 2000 ) jelem, ( histr( ihstr, jelem ),                   &
                             ihstr =  1, nhstr )
          END DO
          IF( nelmx .GT. 0 ) THEN
            DO ielmx = 1, nelmx
              READ( 21, 2000 ) jelmx, ( histx( ihstr, jelmx ),                 &
                               ihstr =  1, nhstr )
            END DO
          END IF
        END IF

2000    FORMAT( I5, 4E15.5 / 5x, 4E15.5 )
        RETURN
        END

        SUBROUTINE ReadPrestress
        USE CtrlData
        USE GlobData
        USE ElmtData
        USE ExtraMesh
        IMPLICIT DOUBLE PRECISION( a-h, o-z )

        REWIND( 22 )
        IF( nstrh .GT. 0 ) THEN
          ielem = 1
          DO WHILE( ielem .GT. 0 )
            READ( 22, 2000 ) ielem, ibloc, strhe
            IF( ielem .GT. 0 ) THEN
              IF( ibloc .EQ. 0 ) THEN
                DO istrh = 1, nstrh
                  strsh( istrh, ielem ) = strhe( istrh )
                END DO
              ELSE
                ielmx = lprtx( ielem ) + ibloc - 1
                DO istrh = 1, nstrh
                  strhx( istrh, ielmx ) = strhe( istrh )
                END DO
              END IF
            END IF
          END DO
        END IF

        ipoin = 1
        DO WHILE( ipoin .GT. 0 )
          READ( 22, 2200 ) ipoin, ( dispe( idofn ), idofn = 1, mdofn )
          IF( ipoin .GT. 0 ) THEN
            DO idofn = 1, mdofn
              idofs = ( ipoin - 1 ) * mdofn + idofn
              disph( idofs, kload ) = dispe( idofn )
            END DO
          END IF
        END DO

2000    FORMAT( 2I5, 4E15.5 / ( 10x, 4E15.5 ) )
2200    FORMAT(  I5, 4E15.5 / (  5x, 4E15.5 ) )
        END

        SUBROUTINE SaveAsPrestress
        USE CtrlData
        USE GlobData
        USE ElmtData
        USE ExtraMesh
        IMPLICIT DOUBLE PRECISION( a-h, o-z )

        REWIND( 22 )

        IF( nstrh .GT. 0 ) THEN
          DO ielem = 1, nelem
            IF( nelmx .LT. 1 ) THEN
              nbloc = -1
            ELSE IF( ielem .LT. nelem ) THEN
              nbloc = lprtx( ielem + 1 ) - lprtx( ielem )
            ELSE
              nbloc = nelmx - lprtx( ielem )
            END IF
            IF( nbloc .LE. 0 ) THEN
              WRITE( 22, 2000 ) ielem, 0, ( strsh( istrh, ielem ),             &
                                istrh = 1, nstrh )
            ELSE
              DO ibloc = 1, nbloc
                ielmx = lprtx( ielem ) + ibloc - 1
                WRITE( 22, 2000 ) ielem, ibloc, ( strhx( istrh, ielmx ),       &
                                  istrh = 1, nstrh )
              END DO
            END IF
          END DO
          WRITE( 22, 2000 ) 0, 0, ( 0.0, istrh = 1, nstrh )
        END IF

        DO ipoin = 1, npoin
          jdofs = ( ipoin - 1 ) * mdofn + 1
          kdofs = ( ipoin - 1 ) * mdofn + mdofn
          WRITE( 22, 2200 ) ipoin, ( disph( idofs, kload ),                    &
                            idofs = jdofs, kdofs )
        END DO
        WRITE( 22, 2200 ) 0, ( 0.0, idofs = 1, mdofn )
2000    FORMAT( 2I5, 4E15.5 / ( 10x, 4E15.5 ) )
2200    FORMAT(  I5, 4E15.5 / (  5x, 4E15.5 ) )
        END

        SUBROUTINE InitHis( ktype, kpoin, kdofn )
        USE CtrlData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        CHARACTER * 256 filen
        IF( kpoin * kdofn .EQ. 0 ) RETURN
        CALL HisFile( filen, ktype, kpoin, kdofn )
        OPEN( 25, FILE = filen )
        CLOSE( 25, STATUS = 'DELETE' )
        RETURN
        END

        SUBROUTINE HisFile( filen, ktype, kpoin, kdofn )
        USE FileData
        CHARACTER * 256 filen
        DO ichar = 1, 256
          filen( ichar:ichar ) = ' '
        END DO
        filen = soutf
        IF( kpoin * kdofn .GT. 0 ) THEN
          locat = 256
          DO WHILE( locat .GT. 0 .AND. filen( locat:locat ) .NE. '\' )
            IF( filen( locat:locat ) .NE. '\' ) THEN
              filen( locat:locat ) = ' '
              locat = locat - 1
            END IF
          END DO
          filen( locat+1:locat+1 ) = 'H'
          IF( ktype .LE. 1 ) filen( locat+2:locat+2 ) = 'D'
          IF( ktype .EQ. 2 ) filen( locat+2:locat+2 ) = 'V'
          IF( ktype .EQ. 3 ) filen( locat+2:locat+2 ) = 'A'
          IF( ktype .EQ. 4 ) filen( locat+2:locat+2 ) = 'S'
          WRITE( filen( locat+3:locat+7 ), '(I5)' ) kpoin
          DO ichar = locat + 3, locat + 7
            IF( filen(ichar:ichar) .EQ. ' ' )                                  &
                filen(ichar:ichar) = '0'
          END DO
          WRITE( filen( locat+8:locat+8 ), '(I1)' ) kdofn
          filen( locat+9:locat+12 ) = '.DAT'
        END IF
        RETURN
        END