设为首页收藏本站联系我们

声振论坛

 找回密码
 我要加入

QQ登录

只需一步，快速开始

声振论坛 › 展示 ›科学计算› 算法编程 › 查看内容

精细时程积分FORTRAN源程序

2015-10-29 01:41| 发布者: aspen| 查看: 1256| 评论: 42|原作者: 风花雪月|来自: 声振论坛

摘要: 主程序main.f90，搞了两个例子进行调用，例子是钟院士那篇文献里的，附后的文献里有的。一个程序是reciseTIM.f90，里面包含了精细时程积分的子程序。 最后的PDF文件是程序说明. 主程序Program Main use Prec ...
主程序main.f90，搞了两个例子进行调用，例子是钟院士那篇文献里的，附后的文献里有的。一个程序是reciseTIM.f90，里面包含了精细时程积分的子程序。

最后的PDF文件是程序说明.

主程序Program Main
  1. use PreciseTimeIntegration

  3. Real(8), Dimension(8, 8) :: K,M,C,INVK
  4. Real(8), Dimension(8, 4) :: R,U,V,A
  5. Real(8) dt
  6. dt=1

  8. R=0
  9. C=0
  10. C(7,7)=5
  11. C(7,8)=-5
  12. C(8,7)=-5
  13. C(8,8)=5
  14. DO i=1,8
  15. M(i,i)=8
  16. END DO
  17. DO i=1,7
  18. K(i,i+1)=-4
  19. k(i+1,i)=-4
  20. END DO
  21. DO i=2,7
  22. k(i,i)=8
  23. END DO
  24. K(1,1)=4
  25. K(8,8)=4
  26. ! WRITE (*,*) M
  27. ! WRITE (*,*) K
  28. ! WRITE (*,*) C
  29. ! INVK=INV(K,8)
  30. ! STOP

  32. U=0
  33. U(8,1)=10
  34. V=0
  35. A=0
  36. call PreciseTIM (M, C, k, R, 8, 4, dt, U, V, A)
  37. write (*,*) U
  38. ! write (*,*) V
  39. ! write (*,*) A

  41. end
复制代码


本程序来自http://bbs.tongji.edu.cn/bbsanc.php?path=%2FPersonalCorpus%2FA%2FABAYA%2FD4F47E4DC%2FA41E7F755

精细时程积分文件：

PreciseTIM.f90

!-----------------------------------------------------------------
    Module PreciseTimeIntegration

    Contains

  2. !//////////////////////////////////////////////////////////////
  3.     Subroutine PreciseTIM (M, G, K, R, N, Nt, tao, X, XX, XXX)
  4. !//////////////////////////////////////////////////////////////
  5. !   精细时程积分法程序，
  6. !       ABAYA，同济大学建筑工程系，2001.7.20
  7. !!//////////////////////////////////////////////////////////////
  8.     Real*8     M(N,N), G(N,N), K(N,N), R(N,Nt), X(N,Nt), &
  9.                XX(N,Nt), XXX(N,Nt), H(2*N,2*N), T(2*N,2*N), &
  10.                R0(2*N,Nt), R1(2*N,Nt), B(N,N), C(N,N), tao
  11.     Call CalH (M, G, K, N, Nt, H, B, C)
  12.     Call CalT (H, tao, N, T)
  13.     Call CalR0R1 (R, R0, R1, N, Nt)
  14.     Call CalX (T, H, R, R0, R1, tao, N, Nt, M, G, B, C, X, XX, XXX)
  15.     End Subroutine PreciseTIM
  16. !//////////////////////////////////////////////////////////////
  17.     Subroutine CalH (M, G, K, N, Nt, H, B, C)
  18.     Real*8     M(N,N), G(N,N), K(N,N), R(N,Nt), INVM(N,N), &
  19.                A(N,N), B(N,N), C(N,N), D(N,N), H(2*N,2*N)
  20.     INVM=INV(M,N)
  21.     A=-0.5*Matmul(INVM,G)
  22.     B=0.25*Matmul(Matmul(G,INVM),G)-K
  23.     C=-0.5*Matmul(G,INVM)
  24.     D=INVM
  25.     H(1:N,1:N)=A
  26.     H(N+1:2*N,1:N)=B
  27.     H(1:N,N+1:2*N)=D
  28.     H(N+1:2*N,N+1:2*N)=C
  29.     End Subroutine CalH
  30. !//////////////////////////////////////////////////////////////
  31.     Subroutine CalT (H, tao, N, T)
  32.     Real*8, Dimension(2*N,2*N) :: H, T, Ta, I
  33.     Real*8 tao, dt
  34.     Integer m
  35.     m=2**20
  36.     dt=tao/m
  37.     I=0; T=0
  38.     Do j=1,2*N
  39.     I(j,j)=1
  40.     End do
  41.     Ta=Matmul(dt*H,(I+0.5*dt*H))
  42.     Do j=1,20
  43.     Ta=2*Ta+Matmul(Ta,Ta)
  44.     End do
  45.     T=I+Ta
  46.     End Subroutine CalT
  47. !//////////////////////////////////////////////////////////////
  48.     Subroutine CalR0R1 (R, R0, R1, N, Nt)
  49.     Real*8 R(N,Nt), R0(2*N,Nt), R1(2*N,Nt)
  50.     R0=0; R1=0;
  51.     R0(N+1:2*N,:)=R
  52.     Do i=2,Nt
  53.     R1(N+1:2*N,i-1)=R(:,i)-R(:,i-1)
  54.     End do
  55.     End Subroutine CalR0R1
  56. !//////////////////////////////////////////////////////////////
  57.     Subroutine CalX (T, H, R, R0, R1, tao, N, Nt, M, G, B, C, X, XX, XXX)
  58.     Real*8     X(N,Nt), XX(N,Nt), XXX(N,Nt), H(2*N,2*N), &
  59.               T(2*N,2*N), R0(2*N,Nt), R1(2*N,Nt), V(2*N,Nt), &
  60.     p(N,Nt), q(N,Nt), R(N,Nt), B(N,N), C(N,N), M(N,N), &
  61.     G(N,N), tao, INVH(2*N,2*N), index
  62.    
  63.     q=X
  64.     p=Matmul(M,XX)+0.5*Matmul(G,X)
  65.     V(1:N,:)=q
  66.     V(N+1:2*N,:)=p
  67.     index=0
  68.     Do i=1,2*N
  69.     Do j=1,Nt
  70.     IF (ABS(R0(i,j)).GT.1E-8) THEN
  71.     index=1; GOTO 10
  72.     END IF
  73.     End do
  74.     End do
  75. 10  If (abs(index).gt.1e-8) then
  76.     INVH=INV(H,2*N)
  77.     Do i=2,Nt
  78.     WRITE (*,'("***********   LOAD STEP: ",I5,"   ***********")') i
  79.     V(:,i)=Matmul(T,(V(:,i-1)+Matmul(INVH,(R0(:,i-1)+ &
  80.            Matmul(INVH,R1(:,i-1))))))-Matmul(INVH &
  81.            ,(R0(:,i-1)+Matmul(INVH,R1(:,i-1))+ &
  82.            tao*R1(:,i-1)))
  83.     End do
  84.     Else
  85.     Do i=2,Nt
  86.     WRITE (*,'("***********   LOAD STEP: ",I5,"   ***********")') i
  87.     V(:,i)=Matmul(T,V(:,i-1))
  88.     End do
  89.     End if

  91.     q=V(1:N,:)
  92.     p=V(N+1:2*N,:)  
  93.     Do i=1,Nt
  94.     X(:,i)=q(:,i)
  95.     XX(:,i)=Matmul(INV(M,N),p(:,i))-0.5*Matmul(Matmul(INV(M,N),G),X(:,i))
  96. XXX(:,i)=Matmul(Matmul(INV(M,N),B),X(:,i))-0.5*Matmul(Matmul(INV(M,N) &
  97. ,G),XX(:,i))+Matmul(Matmul(INV(M,N),C),p(:,i))+Matmul(INV(M,N),R(:,i))
  98.     End do
  99.     End Subroutine CalX
  100. !//////////////////////////////////////////////////////////////
  101.     Function INV (A, N)
  102.     Use Numerical_Libraries
  103.     REAL*8, DIMENSION(N,N) :: A, INV
  104.     INV=0
  105.     CALL DLINRG (N, A, N, INV, N)
  106.     End Function INV
  107. !//////////////////////////////////////////////////////////////
复制代码

    End Module PreciseTimeIntegration
收藏 分享 邀请
上一篇：遗传算法基础知识介绍下一篇：常用算法设计方法
发表评论

最新评论

引用 风花雪月 2005-8-7 16:21
精细时程积分文件：

PreciseTIM.f90

!-----------------------------------------------------------------
    Module PreciseTimeIntegration

    Contains

  2. !//////////////////////////////////////////////////////////////
  3.     Subroutine PreciseTIM (M, G, K, R, N, Nt, tao, X, XX, XXX)
  4. !//////////////////////////////////////////////////////////////
  5. !   精细时程积分法程序，
  6. !       ABAYA，同济大学建筑工程系，2001.7.20
  7. !!//////////////////////////////////////////////////////////////
  8.     Real*8     M(N,N), G(N,N), K(N,N), R(N,Nt), X(N,Nt), &
  9.                XX(N,Nt), XXX(N,Nt), H(2*N,2*N), T(2*N,2*N), &
  10.                R0(2*N,Nt), R1(2*N,Nt), B(N,N), C(N,N), tao
  11.     Call CalH (M, G, K, N, Nt, H, B, C)
  12.     Call CalT (H, tao, N, T)
  13.     Call CalR0R1 (R, R0, R1, N, Nt)
  14.     Call CalX (T, H, R, R0, R1, tao, N, Nt, M, G, B, C, X, XX, XXX)
  15.     End Subroutine PreciseTIM
  16. !//////////////////////////////////////////////////////////////
  17.     Subroutine CalH (M, G, K, N, Nt, H, B, C)
  18.     Real*8     M(N,N), G(N,N), K(N,N), R(N,Nt), INVM(N,N), &
  19.                A(N,N), B(N,N), C(N,N), D(N,N), H(2*N,2*N)
  20.     INVM=INV(M,N)
  21.     A=-0.5*Matmul(INVM,G)
  22.     B=0.25*Matmul(Matmul(G,INVM),G)-K
  23.     C=-0.5*Matmul(G,INVM)
  24.     D=INVM
  25.     H(1:N,1:N)=A
  26.     H(N+1:2*N,1:N)=B
  27.     H(1:N,N+1:2*N)=D
  28.     H(N+1:2*N,N+1:2*N)=C
  29.     End Subroutine CalH
  30. !//////////////////////////////////////////////////////////////
  31.     Subroutine CalT (H, tao, N, T)
  32.     Real*8, Dimension(2*N,2*N) :: H, T, Ta, I
  33.     Real*8 tao, dt
  34.     Integer m
  35.     m=2**20
  36.     dt=tao/m
  37.     I=0; T=0
  38.     Do j=1,2*N
  39.     I(j,j)=1
  40.     End do
  41.     Ta=Matmul(dt*H,(I+0.5*dt*H))
  42.     Do j=1,20
  43.     Ta=2*Ta+Matmul(Ta,Ta)
  44.     End do
  45.     T=I+Ta
  46.     End Subroutine CalT
  47. !//////////////////////////////////////////////////////////////
  48.     Subroutine CalR0R1 (R, R0, R1, N, Nt)
  49.     Real*8 R(N,Nt), R0(2*N,Nt), R1(2*N,Nt)
  50.     R0=0; R1=0;
  51.     R0(N+1:2*N,:)=R
  52.     Do i=2,Nt
  53.     R1(N+1:2*N,i-1)=R(:,i)-R(:,i-1)
  54.     End do
  55.     End Subroutine CalR0R1
  56. !//////////////////////////////////////////////////////////////
  57.     Subroutine CalX (T, H, R, R0, R1, tao, N, Nt, M, G, B, C, X, XX, XXX)
  58.     Real*8     X(N,Nt), XX(N,Nt), XXX(N,Nt), H(2*N,2*N), &
  59.               T(2*N,2*N), R0(2*N,Nt), R1(2*N,Nt), V(2*N,Nt), &
  60.     p(N,Nt), q(N,Nt), R(N,Nt), B(N,N), C(N,N), M(N,N), &
  61.     G(N,N), tao, INVH(2*N,2*N), index
  62.    
  63.     q=X
  64.     p=Matmul(M,XX)+0.5*Matmul(G,X)
  65.     V(1:N,:)=q
  66.     V(N+1:2*N,:)=p
  67.     index=0
  68.     Do i=1,2*N
  69.     Do j=1,Nt
  70.     IF (ABS(R0(i,j)).GT.1E-8) THEN
  71.     index=1; GOTO 10
  72.     END IF
  73.     End do
  74.     End do
  75. 10  If (abs(index).gt.1e-8) then
  76.     INVH=INV(H,2*N)
  77.     Do i=2,Nt
  78.     WRITE (*,'("***********   LOAD STEP: ",I5,"   ***********")') i
  79.     V(:,i)=Matmul(T,(V(:,i-1)+Matmul(INVH,(R0(:,i-1)+ &
  80.            Matmul(INVH,R1(:,i-1))))))-Matmul(INVH &
  81.            ,(R0(:,i-1)+Matmul(INVH,R1(:,i-1))+ &
  82.            tao*R1(:,i-1)))
  83.     End do
  84.     Else
  85.     Do i=2,Nt
  86.     WRITE (*,'("***********   LOAD STEP: ",I5,"   ***********")') i
  87.     V(:,i)=Matmul(T,V(:,i-1))
  88.     End do
  89.     End if

  91.     q=V(1:N,:)
  92.     p=V(N+1:2*N,:)  
  93.     Do i=1,Nt
  94.     X(:,i)=q(:,i)
  95.     XX(:,i)=Matmul(INV(M,N),p(:,i))-0.5*Matmul(Matmul(INV(M,N),G),X(:,i))
  96. XXX(:,i)=Matmul(Matmul(INV(M,N),B),X(:,i))-0.5*Matmul(Matmul(INV(M,N) &
  97. ,G),XX(:,i))+Matmul(Matmul(INV(M,N),C),p(:,i))+Matmul(INV(M,N),R(:,i))
  98.     End do
  99.     End Subroutine CalX
  100. !//////////////////////////////////////////////////////////////
  101.     Function INV (A, N)
  102.     Use Numerical_Libraries
  103.     REAL*8, DIMENSION(N,N) :: A, INV
  104.     INV=0
  105.     CALL DLINRG (N, A, N, INV, N)
  106.     End Function INV
  107. !//////////////////////////////////////////////////////////////
复制代码

    End Module PreciseTimeIntegration
引用 linqus 2005-8-7 18:54
赞一个先,
自己也曾编过线性的wilson时程分析程序.
可以解决剪切层模型问题.没有作验证:)
引用 wgp1976 2005-8-8 15:35
对此比较感兴趣，先睹为快
引用 wangjiaqi4 2005-8-9 14:27
谢谢了，感谢共享这么好的源代码。
引用 simon21 2005-8-9 21:23
谢谢共享
引用 mxtfirst 2005-8-16 10:37
pdf的文档怎么无法下载？
引用 bgzhoumse 2005-8-22 20:39
使用marc进行有限元分析时一定要用fortran语言进行有关的编程吗？可不可以用C语言
引用 NASA 2005-8-22 20:51
Marc的接口是Fortran的，会C语言学Fortran不难
Marc各个版本与fortran版本搭配如下：

marc2003需要fortran6.0以上版本
marc2000以及marc2001需要fortran5.0以上版本
引用 dovenkai 2005-8-23 20:26
ding
引用 liu3806881 2005-8-27 22:39
哈哈，找拉好久的拉
好！！！！
引用 xj2070 2005-8-28 16:09
非常不错的东西，感谢搂住的热心
引用 hit_zzc 2005-8-30 17:22
好咚咚
引用 johhan 2005-8-30 20:40
先看一下,是否有用
引用 jsswdd 2005-9-17 01:34
xiexie
引用 zyzl 2005-9-29 12:31
看看再说
引用 andylei 2005-10-2 11:03
谢了！
引用 qiluin3q 2005-10-7 12:02
精细时程分析？下来看看．
引用 hawking 2005-10-8 22:08
谢谢楼主！
引用 catmagic 2005-10-15 13:05

查看全部评论(42)

相关分类

QQ|小黑屋|Archiver|手机版|联系我们|声振论坛

GMT+8, 2024-11-28 12:30 , Processed in 0.052608 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

返回顶部