Télécharger extrap.eso

Retour à la liste

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