Numérotation des lignes :

extrap
1. C EXTRAP SOURCE CHAT 05/01/12 23:53:57 5004
2. SUBROUTINE EXTRAP(SHPTOT,NBPGAU,NBNN,NBNO)
3. C================================================================
4. C CALCULE LES FONCTIONS D EXTRAPOLATIONS A PARTIR DES FONCTIONS
5. C D INTERPOLATIONS
6. C ENTREES
7. C SHPTOT(6,NBNO,NBPGAU) = FONCTIONS D INTERPOLATIONS
8. C NBPGAU = NOMBRE DE POINTS DE GAUSS
9. C NBNN = NOMBRE DE NOEUDS
10. C NBNO = NOMBRE DE FONCTIONS D'INTERPOLATION
11. C SORTIES
12. C SHPTOT(6,NBNO,NBPGAU) = FONCTIONS D EXTRAPOLATIONS STOKEES
13. C SUR LA 6 IEME LIGNE
14. C EBERSOLT NOVEMBRE 86 PAS PLUS DE 30 NOEUDS
15. C================================================================
16. IMPLICIT INTEGER(I-N)
17. IMPLICIT REAL*8(A-H,O-Z)
18. PARAMETER(XZER=0.D0,UN=1.D0)
19. DIMENSION SHPTOT(6,NBNO,*)
20. DIMENSION XMAT(30,30),XVEC(30)
21. C
22. C PROTECTION PROVISOIRE
23. IF(NBNN.NE.NBNO) RETURN
24. C
25. C UN SEUL POINT DE GAUSS
26. C
27. IF(NBPGAU.EQ.1) THEN
28. DO 50 IA=1,NBNO
29. SHPTOT(6,IA,1)=UN
30. 50 CONTINUE
31. C
32. C PLUS D UN POINT DE GAUSS
33. C
34. ELSE IF(NBPGAU.GT.1) THEN
35. CALL ZERO(XMAT,30,30)
36. C
37. C TRANSPOSE( A ) * A
38. C
39. DO 100 IA=1,NBNN
40. DO 100 IB=1,NBNN
41. CC = XZER
42. DO 300 IC=1,NBPGAU
43. CC = CC + SHPTOT(1,IA,IC)*SHPTOT(1,IB,IC)
44. 300 CONTINUE
45. XMAT(IA,IB)=CC
46. 100 CONTINUE
47. C
48. C NOMBRE DE POINTS DE GAUSS DIFFERENTS DU NOMBRE DE NOEUDS
49. C
50. IF(NBPGAU.NE.NBNN) THEN
51. C
52. C SI ON A MOINS DE POINTS DE GAUSS QUE DE NOEUDS ON RAJOUTE
53. C UN PEU DE PENALISATION EMPECHANT D OSCILLER SUR LES NOEUDS
54. C
55. IF(NBPGAU.LT.NBNN) THEN
56. DO 705 IA=1,NBNN
57. CALL ZERO(XVEC,30,1)
58. XVEC(IA)=NBNN
59. DO 706 IB=1,NBNN
60. XVEC(IB)=XVEC(IB)-UN
61. 706 CONTINUE
62. C
63. C ON LE DEFLATIONNE DE SES COMPOSANTES PARRALELLES AUX H
64. C
65. DO 710 IB=1,NBPGAU
66. SCAL=XZER
67. XXNORM=XZER
68. DO 730 IC=1,NBNN
69. SCAL=SCAL+SHPTOT(1,IC,IB)*XVEC(IC)
70. XXNORM=XXNORM+SHPTOT(1,IC,IB)*SHPTOT(1,IC,IB)
71. 730 CONTINUE
72. IF(XXNORM.LT.1.E-7) GOTO 700
73. SCAL=SCAL/XXNORM
74. C
75. DO 720 IC=1,NBNN
76. XVEC(IC)=XVEC(IC)-SCAL*SHPTOT(1,IC,IB)
77. 720 CONTINUE
78. 710 CONTINUE
79. C
80. C ON RAJOUTE CES VECTEURS DANS LA PENALISATION
81. C
82. DO 750 IB=1,NBNN
83. DO 750 IC=1,NBNN
84. XMAT(IB,IC)= XVEC(IB)*XVEC(IC)+XMAT(IB,IC)
85. 750 CONTINUE
86. C
87. 700 CONTINUE
88. 705 CONTINUE
89. C
90. ENDIF
91. C
92. C ( T A P A ) ** -1 ALGO WILSON
93. C
94. DO 400 IEQ=1,NBNN
95. DD = UN / XMAT(IEQ,IEQ)
96. DO 410 IA=1,NBNN
97. XMAT(IEQ,IA)=-XMAT(IEQ,IA)*DD
98. 410 CONTINUE
99. C
100. DO 420 IA=1,NBNN
101. IF(IA.EQ.IEQ) GOTO 420
102. DO 430 IB=1,NBNN
103. IF(IB.EQ.IEQ) GOTO 430
104. XMAT(IA,IB)=XMAT(IA,IB)+XMAT(IA,IEQ)*XMAT(IEQ,IB)
105. 430 CONTINUE
106. 420 CONTINUE
107. C
108. DO 440 IA=1,NBNN
109. XMAT(IA,IEQ)= XMAT(IA,IEQ)*DD
110. 440 CONTINUE
111. XMAT(IEQ,IEQ)= DD
112. 400 CONTINUE
113. C
114. C (( T A . A ) ** -1 ) * ( T . A )
115. C
116. DO 500 IA=1,NBNN
117. DO 510 IB=1,NBPGAU
118. CC=XZER
119. DO 520 IC=1,NBNN
120. CC=CC+XMAT(IA,IC)*SHPTOT(1,IC,IB)
121. 520 CONTINUE
122. SHPTOT(6,IA,IB)=CC
123. 510 CONTINUE
124. 500 CONTINUE
125. C
126. C NOMBRE DE POINTS DE GAUSS EGAL AUX NOMBRE DE NOEUDS
127. C
128. ELSE IF(NBNN.EQ.NBPGAU) THEN
129. DO 600 IA=1,NBNN
130. DO 600 IB=1,NBNN
131. SHPTOT(6,IA,IB)=XMAT(IA,IB)
132. 600 CONTINUE
133. ENDIF
134. ENDIF
135. RETURN
136. END
137.
138.

© Cast3M 2003 - Tous droits réservés.
Mentions légales