Télécharger ch1ch2.eso

Retour à la liste

Numérotation des lignes :

  1. C CH1CH2 SOURCE AM 16/04/18 21:15:02 8911
  2. SUBROUTINE CH1CH2(MELE,MINTE,MINTE1,NBPTEL,NBPGA1,NBNN,SWORK,
  3. > KERRE)
  4. C----------------------------------------------------------------------
  5. C
  6. C PASSAGE DES VALEURS D'UN JEU DE POINTS DE GAUSS A UN AUTRE
  7. C
  8. C----------------------------------------------------------------------
  9. C MINTE POINTEUR SUR LES POINTS ET POIDS DE CH2
  10. C MINTE1 POINTEUR SUR LES POINTS ET POIDS DE CH1
  11. C NBPTEL NBRE DE POINTS DE GAUSS DE CH2
  12. C NBPGA1 NBRE DE POINTS DE GAUSS DE CH1
  13. C NBNN NBRE DE NOEUDS DE L'ELEMENT
  14. C SWORK SEGMENT DE TRAVAIL
  15. C KERRE EN ENTREE : DIMENSION
  16. C EN SORTIE : CODE D'ERREUR ( 0 SI OK )
  17. C----------------------------------------------------------------------
  18. IMPLICIT INTEGER(I-N)
  19. IMPLICIT REAL*8(A-H,O-Z)
  20. -INC CCOPTIO
  21. -INC SMINTE
  22. SEGMENT/SWORK/(VAL1(NBPGA1)*D,VAL2(NBPTEL)*D,VALN(NBNN)*D,
  23. . SHP(6,NBNN)*D,XE(3,NBNN)*D)
  24. SEGMENT/AMOI/(AM(NBNN,NBNN)*D,BM(NBNN)*D,CM(NBNN)*D)
  25. C= Quelques constantes (2.Pi et 4.Pi)
  26. PARAMETER (X2Pi=6.283185307179586476925286766559D0)
  27. PARAMETER (X4Pi=12.566370614359172953850573533118D0)
  28. C
  29. XCOEF=1.d0
  30. IF( mele.ge.85.and.mele.le.90) xcoef = 0.5d0
  31. if( mele.ge.108.and.mele.le.110) xcoef=0.5D0
  32. if(mele.eq.12.or.mele.eq.13) xcoef=0.5D0
  33. if(mele.ge.18.and.mele.le.21) xcoef=0.5D0
  34. if(mele.ge.185.and.mele.le.190) xcoef=0.5D0
  35. C
  36. JDIM=KERRE
  37. IF(JDIM.EQ.0) THEN
  38. KERRE=29
  39. RETURN
  40. ENDIF
  41. C
  42. KERRE=0
  43. IF(NBPGA1.EQ.1) THEN
  44. DO 10 IA=1,NBNN
  45. VALN(IA)=VAL1(1)
  46. 10 CONTINUE
  47. DO 11 IB=1,NBPTEL
  48. VAL2(IB)=VAL1(1)
  49. 11 CONTINUE
  50. C
  51. ELSE IF(NBPGA1.GT.1) THEN
  52. IF(IIMPI.EQ.529) WRITE(6,77883) NBPGA1,NBNN
  53. 77883 FORMAT('0 NB DE POINTS DE GAUSS ',I4,2X,
  54. . 'NB DE NOEUDS ' ,I4/)
  55. SEGINI AMOI
  56. VV=0.D0
  57. DO 30 IC=1,NBPGA1
  58. C
  59. C CALCUL DU JACOBIEN
  60. C
  61. if(iimpi.eq.529) write(6,*) ' mele ifour ',mele , ifour
  62. IFR = IFOUR+4
  63. GO TO (81,81,81,81,81,82,83,83,83,83,
  64. . 83,83,83,83,83,83,83,83,83),IFR
  65. 89 KERRE=29
  66. GO TO 99
  67. 81 IDK=3
  68. GO TO 86
  69. 82 IDK=4
  70. GO TO 86
  71. 83 IDK=2
  72. 86 CONTINUE
  73. DO 33 ID=1,IDK
  74. DO 331 IE=1,NBNN
  75. SHP(ID,IE)=MINTE1.SHPTOT(ID,IE,IC)
  76. 331 CONTINUE
  77. 33 CONTINUE
  78. CALL GTEMRD(XE,SHP,JDIM,NBNN,DJAC)
  79. DJAC=DJAC*MINTE1.POIGAU(IC)
  80. IF(IFR.EQ.4.OR.IFR.EQ.5) THEN
  81. CALL DISTRR(XE,SHP,NBNN,RR)
  82. IF(IFR.EQ.4.OR.(IFR.EQ.5.AND.
  83. + NIFOUR.EQ.0)) THEN
  84. DJAC=DJAC*RR*2*XPI
  85. ELSE
  86. DJAC=DJAC*RR*XPI
  87. ENDIF
  88. ELSE IF (IFR.GE.16.AND.IFR.LE.18) THEN
  89. CALL DISTRR(XE,SHP,NBNN,RR)
  90. DJAC=X2Pi*DJAC*RR
  91. ELSE IF (IFR.EQ.19) THEN
  92. CALL DISTRR(XE,SHP,NBNN,RR)
  93. DJAC=X4Pi*DJAC*RR
  94. ENDIF
  95. VV=VV+DJAC
  96. C
  97. C CALCUL DE LA MATRICE ET DU SECOND MEMBRE
  98. C
  99. DO 20 IA=1,NBNN
  100. DO 21 IB=1,NBNN
  101. AM(IA,IB)=AM(IA,IB)+SHP(1,IA)*SHP(1,IB)*DJAC
  102. 21 CONTINUE
  103. BM(IA)=BM(IA)+SHP(1,IA)*VAL1(IC)*DJAC
  104. 20 CONTINUE
  105. 30 CONTINUE
  106. * dans le cas du tri6, on impose les noeuds milieux par penalisation
  107. if (mele.eq.6) then
  108. call chnsng(am,nbnn,2,1,3)
  109. call chnsng(am,nbnn,4,3,5)
  110. call chnsng(am,nbnn,6,5,1)
  111. endif
  112. * dans le cas du tet10, on impose les noeuds milieux par penalisation
  113. if (mele.eq.24) then
  114. call chnsng(am,nbnn,2,1,3)
  115. call chnsng(am,nbnn,4,3,5)
  116. call chnsng(am,nbnn,6,5,1)
  117. call chnsng(am,nbnn,7,1,10)
  118. call chnsng(am,nbnn,8,3,10)
  119. call chnsng(am,nbnn,9,5,10)
  120. endif
  121. * dans le cas du pr15, on impose certains noeuds milieux par penalisation
  122. if (mele.eq.17) then
  123. call chnsng(am,nbnn,2,1,3)
  124. call chnsng(am,nbnn,4,3,5)
  125. call chnsng(am,nbnn,6,5,1)
  126. call chnsng(am,nbnn,11,10,12)
  127. call chnsng(am,nbnn,13,12,14)
  128. call chnsng(am,nbnn,15,14,10)
  129. endif
  130. *
  131. C
  132. DO 62 IA=1,NBNN
  133. CM(IA)=AM(IA,IA)
  134. 62 CONTINUE
  135. SOM=0.D0
  136. DO 63 IA=1,NBNN
  137. SOM=SOM+CM(IA)
  138. 63 CONTINUE
  139. IF(SOM.EQ.0.D0) THEN
  140. KERRE=358
  141. GO TO 61
  142. ENDIF
  143. IF(IIMPI.EQ.529) WRITE(6,77884)((AM(I,J),J=1,NBNN),I=1,NBNN)
  144. 77884 FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/))
  145. PREC=SOM*1.D-10/NBNN
  146. CALL INVALM(AM,NBNN,NBNN,KERRE,PREC)
  147. 61 IF(KERRE.NE.0) THEN
  148. C
  149. C A EST SINGULIERE - ON MOYENNE |
  150. C
  151. KERRE=0
  152. IF(IIMPI.GE.529) WRITE(6,77854)
  153. 77854 FORMAT(' A EST SINGULIERE - ON MOYENNE ' /)
  154. SOM=0.D0
  155. DO 64 IC=1,NBPGA1
  156. SOM=SOM+VAL1(IC)
  157. 64 CONTINUE
  158. SOM=SOM/NBPGA1
  159. DO 65 IA=1,NBNN
  160. VALN(IA)=SOM
  161. 65 CONTINUE
  162. C
  163. ELSE
  164. DO 40 IA=1,NBNN
  165. VA=0.D0
  166. DO 41 IB=1,NBNN
  167. VA=VA+AM(IA,IB)*BM(IB)
  168. 41 CONTINUE
  169. VALN(IA)=VA
  170. 40 CONTINUE
  171. ENDIF
  172. C
  173. C CALCUL DES VALEURS AUX POINTS DE GAUSS
  174. C
  175. * AM 18/4/16
  176. MELGEO=NUMGEO(MELE)
  177. IDECA=0
  178. IF(MELGEO.EQ.29) IDECA=2
  179. IF(MELGEO.EQ.30) IDECA=3
  180. IF(MELGEO.EQ.31) IDECA=4
  181. NBNOU=NBNN-IDECA
  182. *
  183. DO 50 IB=1,NBPTEL
  184. VA=0.D0
  185. DO 51 IC=1,NBNOU
  186. VA=VA+SHPTOT(1,IC,IB)*VALN(IC)
  187. 51 CONTINUE
  188. VAL2(IB)=VA*xcoef
  189. 50 CONTINUE
  190. C
  191. 99 CONTINUE
  192. SEGSUP AMOI
  193. ENDIF
  194. C
  195. RETURN
  196. END
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  

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