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

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