data.f90

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

          CALL InitFloat( react, ndofs, 0.0D0 )
          CALL InitFloat( aitkn, ndofs, 0.0D0 )
          CALL InitFloat( vlmts, mdofn * 2, 0.0D0 )
          CALL InitFloat( strss, npoin * 7, 0.0D0 )
          CALL InitFloat( strns, npoin * 7, 0.0D0 )
          CALL InitFloat( disps, ndofs * nload, 0.0D0 )
          CALL InitFloat( distm, ndofs * nload, 0.0D0 )
          CALL InitFloat( disph, ndofs * nload, 0.0D0 )
          CALL InitFloat( dspis, ndofs * nload, 0.0D0 )
!.........
          IF( nmode .GT. 0 ) THEN
            ALLOCATE( shmod( ndofs, nmode ), freqs( nmode ),                   &
                      STAT = ierro )
            IF( ierro .GT. 0 ) nerrc = 4
            IF( nerrc .GT. 0 ) RETURN
            CALL InitFloat( freqs, nmode, 0.0D0 )
            CALL InitFloat( shmod, ndofs * nmode, 0.0D0 )
          END IF
!.........
          IF( ntypc .EQ. 2 ) THEN
            ALLOCATE( veloc( ndofs, nload ), veltm( ndofs, nload ),            &
                      acctm( ndofs, nload ), accel( ndofs, nload ),            &
                      STAT = ierro )
            CALL InitFloat( veltm, ndofs * nload, 0.0D0 )
            CALL InitFloat( acctm, ndofs * nload, 0.0D0 )
            CALL InitFloat( veloc, ndofs * nload, 0.0D0 )
            CALL InitFloat( accel, ndofs * nload, 0.0D0 )
          END IF
          END SUBROUTINE InitGlob

          SUBROUTINE DelGlob
            USE CtrlData
            IF( ALLOCATED( histr ) ) DEALLOCATE( histr )
            IF( ALLOCATED( shmod ) ) DEALLOCATE( shmod )
            IF( ALLOCATED( freqs ) ) DEALLOCATE( freqs )
            IF( ALLOCATED( veloc ) ) DEALLOCATE( veloc )
            IF( ALLOCATED( veltm ) ) DEALLOCATE( veltm )
            IF( ALLOCATED( accel ) ) DEALLOCATE( accel )
            IF( ALLOCATED( acctm ) ) DEALLOCATE( acctm )
            IF( ALLOCATED( aitkn ) ) DEALLOCATE( aitkn )
            IF( ALLOCATED( disps ) ) DEALLOCATE( disps )
            IF( ALLOCATED( dspis ) ) DEALLOCATE( dspis )
            IF( ALLOCATED( distm ) ) DEALLOCATE( distm )
            IF( ALLOCATED( strss ) ) DEALLOCATE( strss )
            IF( ALLOCATED( strns ) ) DEALLOCATE( strns )
            IF( ALLOCATED( react ) ) DEALLOCATE( react )
            IF( ALLOCATED( vlmts ) ) DEALLOCATE( vlmts )
            IF( ALLOCATED( llmts ) ) DEALLOCATE( llmts )
            IF( ALLOCATED( lsmts ) ) DEALLOCATE( lsmts )
            IF( ALLOCATED( wsmts ) ) DEALLOCATE( wsmts )
            IF( ALLOCATED( vsmts ) ) DEALLOCATE( vsmts )
            IF( ALLOCATED( luses ) ) DEALLOCATE( luses )
            IF( ALLOCATED( disph ) ) DEALLOCATE( disph )
            IF( ALLOCATED( lstat ) ) DEALLOCATE( lstat )
            IF( ALLOCATED( ldofs ) ) DEALLOCATE( ldofs )
            IF( ALLOCATED( strsh ) ) DEALLOCATE( strsh )
          END SUBROUTINE DelGlob
        END MODULE GlobData

        MODULE SolvData
!........
!       模块内容：
!           本模块包含程序运算过程中的求解工作参数，并负责对它们初始化。
!........
        IMPLICIT DOUBLE PRECISION( a-h, o-z )

        ALLOCATABLE buffs(:), diagm(:)
        ALLOCATABLE diagd(:), diagk(:)
        ALLOCATABLE fstrs(:), fstrt(:)
        ALLOCATABLE fwork(:), twork(:)
        ALLOCATABLE statf(:), vunts(:)
        ALLOCATABLE vslvs(:), vslvt(:), vslvi(:)
        ALLOCATABLE forcs(:), frctm(:), sprts(:,:)

        SAVE vslvi, vslvt
        SAVE buffs, diagm, diagd, diagk, fstrs, fstrt, sprts
        SAVE fwork, twork, statf, vslvs, forcs, frctm, vunts

        CONTAINS
        SUBROUTINE InitSolv
          USE CtrlData
          IF( nerrc .GT. 0 ) RETURN
          ALLOCATE( buffs( nbufs ), diagm( ndofs ), diagd( ndofs ),            &
                    diagk( ndofs ), forcs( ndofs ), frctm( ndofs ),            &
                    fstrs( ndofs ), fstrt( ndofs ), fwork( ndofs ),            &
                    twork( ndofs ), statf( ndofs ), vslvs( ndofs ),            &
                    vunts( ndofs ), vslvi( ndofs ), vslvt( ndofs ),            &
					sprts( mdofn, npoin ), STAT = ierro )
          IF( ierro .GT. 0 ) nerrc = 4
          IF( nerrc .GT. 0 ) RETURN
          CALL InitFloat( diagm, ndofs, 0.0D0 )
          CALL InitFloat( diagk, ndofs, 0.0D0 )
          CALL InitFloat( diagd, ndofs, 0.0D0 )
          CALL InitFloat( forcs, ndofs, 0.0D0 )
          CALL InitFloat( frctm, ndofs, 0.0D0 )
          CALL InitFloat( fstrs, ndofs, 0.0D0 )
          CALL InitFloat( fstrt, ndofs, 0.0D0 )
          CALL InitFloat( fwork, ndofs, 0.0D0 )
          CALL InitFloat( twork, ndofs, 0.0D0 )
          CALL InitFloat( statf, ndofs, 0.0D0 )
          CALL InitFloat( vslvs, ndofs, 0.0D0 )
          CALL InitFloat( vslvi, ndofs, 0.0D0 )
          CALL InitFloat( vslvt, ndofs, 0.0D0 )
          CALL InitFloat( vunts, ndofs, 1.0D0 )
          CALL InitFloat( sprts, mdofn * npoin, 0.0D0 )
        END SUBROUTINE InitSolv

        SUBROUTINE DelSolv
          IF( ALLOCATED( buffs ) ) DEALLOCATE( buffs )
          IF( ALLOCATED( diagm ) ) DEALLOCATE( diagm )
          IF( ALLOCATED( diagk ) ) DEALLOCATE( diagk )
          IF( ALLOCATED( diagd ) ) DEALLOCATE( diagd )
          IF( ALLOCATED( forcs ) ) DEALLOCATE( forcs )
          IF( ALLOCATED( frctm ) ) DEALLOCATE( frctm )
          IF( ALLOCATED( fstrs ) ) DEALLOCATE( fstrs )
          IF( ALLOCATED( fstrt ) ) DEALLOCATE( fstrt )
          IF( ALLOCATED( fwork ) ) DEALLOCATE( fwork )
          IF( ALLOCATED( twork ) ) DEALLOCATE( twork )
          IF( ALLOCATED( statf ) ) DEALLOCATE( statf )
          IF( ALLOCATED( vslvs ) ) DEALLOCATE( vslvs )
          IF( ALLOCATED( vunts ) ) DEALLOCATE( vunts )
          IF( ALLOCATED( sprts ) ) DEALLOCATE( sprts )
        END SUBROUTINE DelSolv

        SUBROUTINE Limit
          USE CtrlData
          USE GlobData
          DO idofn = 1, mdofn
            IF( llmts( 1, idofn ) .EQ. 1 ) THEN
              vmini = vlmts( 1, idofn )
              DO ipoin = 1, npoin
                idofs = ( ipoin - 1 ) * mdofn + idofn
                IF( vslvs( idofs ) .LT. vmini ) vslvs( idofs ) = vmini
              END DO
            END IF
            IF( llmts( 2, idofn ) .EQ. 1 ) THEN
              vmaxi = vlmts( 2, ipoin )
              DO ipoin = 1, npoin
                idofs = ( ipoin - 1 ) * mdofn + idofn
                IF( vslvs( idofs ) .GT. vmaxi ) vslvs( idofs ) = vmaxi
              END DO
            END IF
          END DO
        END SUBROUTINE Limit
        END MODULE SolvData

        MODULE FrontData
!........
!       模块内容：
!           本模块包含波前法需要的所有参数，并负责对它们初始化。
!.........
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        INTEGER mdofw, mstfw, nbcks, mpntw
        INTEGER nexch, ndata, nrcrd, nuseb

        ALLOCATABLE lpnte(:), stifw(:), lposw(:)
        ALLOCATABLE lopts(:), fbcks(:), lbcks(:,:)
        ALLOCATABLE lwave(:), lpntw(:), lrcrd(:,:)

        SAVE mdofw, mstfw, nbcks, mpntw, lrcrd
        SAVE lopts, fbcks, lbcks, lpnte, stifw, lposw
        SAVE nexch, ndata, nrcrd, nuseb, lwave, lpntw

        CONTAINS
          SUBROUTINE InitFront
            USE CtrlData
            IF( nerrc .GT. 0 ) RETURN
            ALLOCATE( lpnte( npoin ), lopts( nelem ), lpntw(    npoin ),       &
                      lwave( mnode ), lposw( npoin ), lbcks( 4, npoin ),       &
                      STAT = ierro )
            IF( ierro .GT. 0 ) nerrc = 4
            IF( nerrc .GT. 0 ) RETURN
          END SUBROUTINE InitFront

          SUBROUTINE InitWave
            USE CtrlData
            IF( nerrc .GT. 0 ) RETURN
            ALLOCATE( stifw( mstfw ), lrcrd( 3, nrcrd ),                       &
                      fbcks( nbcks ), STAT = ierro )
            IF( ierro .GT. 0 ) nerrc = 4
            IF( nerrc .GT. 0 ) RETURN
          END SUBROUTINE InitWave

          SUBROUTINE DelFront
            IF( ALLOCATED( lpnte ) ) DEALLOCATE( lpnte )
            IF( ALLOCATED( lopts ) ) DEALLOCATE( lopts )
            IF( ALLOCATED( lpntw ) ) DEALLOCATE( lpntw )
            IF( ALLOCATED( lwave ) ) DEALLOCATE( lwave )
            IF( ALLOCATED( lposw ) ) DEALLOCATE( lposw )
            IF( ALLOCATED( lbcks ) ) DEALLOCATE( lbcks )
          END SUBROUTINE DelFront

          SUBROUTINE DelWave
            IF( ALLOCATED( stifw ) ) DEALLOCATE( stifw )
            IF( ALLOCATED( lrcrd ) ) DEALLOCATE( lrcrd )
            IF( ALLOCATED( fbcks ) ) DEALLOCATE( fbcks )
          END SUBROUTINE DelWave
        END MODULE FrontData

        MODULE ReSolveData
!........
!       模块内容：
!           本模块包含波前法需要的所有参数，并负责对它们初始化。
!.........
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        INTEGER ndofr, nequr, nstfr, mbndr
        ALLOCATABLE ldofr(:), lposr(:)
        ALLOCATABLE stifr(:), forcr(:), lequr(:,:)

        SAVE ndofr, nequr, nstfr, mbndr
        SAVE ldofr, lposr, stifr, lequr

        CONTAINS
          SUBROUTINE InitResolve
          USE CtrlData
          IMPLICIT DOUBLE PRECISION( a-h, o-z )
!...............................................
          ndofr = 0
!...............................................
          IF( ndofr .EQ. 0 ) RETURN
          ALLOCATE( ldofr( ndofr ), lequr( ndofr, npoin ),                     &
                    STAT = ierro )
          IF( ierro .GT. 0 ) nerrc = 294535
          IF( nerrc .GT. 0 ) RETURN
          CALL InitInteger( ldofr, ndofr, 0 )
          CALL InitInteger( lequr, ndofr * npoin, 0 )
          END SUBROUTINE InitResolve

          SUBROUTINE InitReSolveData
          USE CtrlData
          USE MeshData
          IMPLICIT DOUBLE PRECISION( a-h, o-z )
          IF( ndofr .EQ. 0 ) RETURN

          nequr = 0
          DO ipoin = 1, npoin
            DO idofr = 1, ndofr
              idofn = ldofr( idofr )
              ifixs = lfixs( idofn, ipoin )
              IF( ifixs .NE. 0 ) THEN
                lequr( idofr, ipoin ) = 0
              ELSE
                nequr = nequr + 1
                lequr( idofr, ipoin ) = nequr
              END IF
            END DO
          END DO

          ALLOCATE( lposr( nequr ), forcr( nequr ), STAT = ierro )
          IF( ierro .GT. 0 ) nerrc = 24835
          IF( nerrc .GT. 0 ) RETURN
          CALL InitInteger( lposr, nequr, 0 )
          CALL InitFloat( forcr, nequr, 0.0D0 )

          DO ielem = 1, nelem
            DO inode = 1, mnode
              ipoin = lnods( inode, ielem )
              DO idofr = 1, ndofr
                iequr = lequr( idofr, ipoin )
                DO jnode = 1, mnode
                  jpoin = lnods( jnode, ielem )
                  DO jdofr = 1, ndofr
                    jequr = lequr( jdofr, jpoin )
                    iband = iequr - jequr
                    IF( iequr .NE. 0 .AND. jequr .NE. 0 .AND.                  &
                        iband .GT. lposr( iequr ) ) THEN
                      lposr( iequr ) = iband
                    END IF
                  END DO
                END DO
              END DO
            END DO
          END DO

          mbndr = 0
          lposr( 1 ) = 1
          DO iequr = 2, nequr
            IF( mbndr .LT. lposr( iequr ) ) mbndr = lposr( iequr )
            lposr( iequr ) = lposr( iequr ) + lposr( iequr - 1 ) + 1
          END DO
          mbndr = mbndr + 1
          nstfr = lposr( nequr )

          ALLOCATE( stifr( nstfr ), STAT = ierro )
          IF( ierro .GT. 0 ) nerrc = 38543
          IF( nerrc .GT. 0 ) RETURN
          END SUBROUTINE InitResolveData

          SUBROUTINE DelResolve
          IMPLICIT DOUBLE PRECISION( a-h, o-z )
          IF( ALLOCATED( ldofr ) ) DEALLOCATE( ldofr )
          IF( ALLOCATED( lequr ) ) DEALLOCATE( lequr )