Télécharger ch1ch2.eso

Retour à la liste

Numérotation des lignes :

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

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