Télécharger ch1ch2.eso

Retour à la liste

Numérotation des lignes :

  1. C CH1CH2 SOURCE CB215821 19/12/20 21:15:09 10444
  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 q8ri, on impose les noeuds milieux par penalisation
  125. if (mele.eq.184) then
  126. call chnsng(am,nbnn,2,1,3)
  127. call chnsng(am,nbnn,4,3,5)
  128. call chnsng(am,nbnn,6,5,7)
  129. call chnsng(am,nbnn,8,7,1)
  130. endif
  131. * dans le cas du tet10, on impose les noeuds milieux par penalisation
  132. if (mele.eq.24) then
  133. call chnsng(am,nbnn,2,1,3)
  134. call chnsng(am,nbnn,4,3,5)
  135. call chnsng(am,nbnn,6,5,1)
  136. call chnsng(am,nbnn,7,1,10)
  137. call chnsng(am,nbnn,8,3,10)
  138. call chnsng(am,nbnn,9,5,10)
  139. endif
  140. * dans le cas du pr15, on impose certains noeuds milieux par penalisation
  141. if (mele.eq.17) then
  142. call chnsng(am,nbnn,2,1,3)
  143. call chnsng(am,nbnn,4,3,5)
  144. call chnsng(am,nbnn,6,5,1)
  145. call chnsng(am,nbnn,11,10,12)
  146. call chnsng(am,nbnn,13,12,14)
  147. call chnsng(am,nbnn,15,14,10)
  148. endif
  149. *
  150. C
  151. DO 62 IA=1,NBNN
  152. CM(IA)=AM(IA,IA)
  153. 62 CONTINUE
  154.  
  155. SOM=0.D0
  156. DO 63 IA=1,NBNN
  157. SOM=SOM+CM(IA)
  158. 63 CONTINUE
  159. IF(SOM.EQ.0.D0) THEN
  160. KERRE=358
  161. GO TO 61
  162. ENDIF
  163. IF(IIMPI.EQ.529) WRITE(6,77884)((AM(I,J),J=1,NBNN),I=1,NBNN)
  164. 77884 FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/))
  165. PREC=SOM*1.D-10/NBNN
  166. CALL INVALM(AM,NBNN,NBNN,KERRE,PREC)
  167. 61 IF(KERRE.NE.0) THEN
  168. C
  169. C A EST SINGULIERE - ON MOYENNE |
  170. C
  171. KERRE=0
  172. IF(IIMPI.GE.529) WRITE(6,77854)
  173. 77854 FORMAT(' A EST SINGULIERE - ON MOYENNE ' /)
  174. SOM=0.D0
  175. DO 64 IC=1,NBPGA1
  176. SOM=SOM+VAL1(IC)
  177. 64 CONTINUE
  178. SOM=SOM/NBPGA1
  179. DO 65 IA=1,NBNN
  180. VALN(IA)=SOM
  181. 65 CONTINUE
  182. C
  183. ELSE
  184. CALL ZERO(VALN(1),NBNN,1)
  185. DO 40 IB=1,NBNN
  186. XBM1=BM(IB)
  187. DO 41 IA=1,NBNN
  188. VALN(IA)=VALN(IA)+AM(IA,IB)*XBM1
  189. 41 CONTINUE
  190. 40 CONTINUE
  191. ENDIF
  192. C
  193. C CALCUL DES VALEURS AUX POINTS DE GAUSS
  194. C
  195. * AM 18/4/16
  196. MELGEO=NUMGEO(MELE)
  197. IDECA=0
  198. IF(MELGEO.EQ.29) IDECA=2
  199. IF(MELGEO.EQ.30) IDECA=3
  200. IF(MELGEO.EQ.31) IDECA=4
  201. NBNOU=NBNN-IDECA
  202. *
  203. DO 50 IB=1,NBPTEL
  204. VA=0.D0
  205. DO 51 IC=1,NBNOU
  206. VA=VA+SHPTOT(1,IC,IB)*VALN(IC)
  207. 51 CONTINUE
  208. VAL2(IB)=VA*xcoef
  209. 50 CONTINUE
  210. C
  211. 99 CONTINUE
  212. ENDIF
  213.  
  214. END
  215.  
  216.  

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