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

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