Télécharger crevec.eso

Retour à la liste

Numérotation des lignes :

  1. C CREVEC SOURCE BP208322 12/05/10 21:15:00 7368
  2. C CE SOUS-PROGRAMME CREE LES CHAMPS DE COORDONNEES ASSOCIES AUX
  3. C VECTEURS. IL ACTUALISE LES ELEMENTS SUR CES CHAMPS
  4. C
  5. SUBROUTINE CREVEC(MELE,ICPR,KABCOR,LABCO2,MVECTE,IDEF)
  6. IMPLICIT INTEGER(I-N)
  7. -INC CCOPTIO
  8. -INC SMELEME
  9. -INC SMCOORD
  10. -INC SMCHPOI
  11. -INC SMVECTE
  12. SEGMENT KABCOR(1)
  13. SEGMENT KABCO2(2,NVEC)
  14. SEGMENT LABCO2(3,1)
  15. SEGMENT XCOR(IDIM,NCO)
  16. SEGMENT XCO2(IDIM,NCO)
  17. SEGMENT ICO2(NCO)
  18. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  19. SEGACT MCOORD
  20. SEGACT MVECTE
  21. NVEC=AMPF(/1)
  22. SEGINI KABCO2
  23. IF (IDEF.NE.0) LABCO2(1,IDEF)=KABCO2
  24. IF (IDEF.EQ.0) THEN
  25. SEGINI ICPR,KABCOR,LABCO2
  26. LABCO2(1,1)=KABCO2
  27. LABCO2(3,1)=MVECTE
  28. NCO=0
  29. C ON COMMENCE PAR REMPLIR ICPR AVEC LE MELEME
  30. DO 10 I=1,XCOOR(/1)/(IDIM+1)
  31. ICPR(I)=0
  32. 10 CONTINUE
  33. MELEME=MELE
  34. SEGACT MELEME
  35. NBSOUS=LISOUS(/1)
  36. IPT1=MELEME
  37. DO 20 ISOUS=1,MAX(1,NBSOUS)
  38. IF (NBSOUS.NE.0) THEN
  39. IPT1=LISOUS(ISOUS)
  40. SEGACT IPT1
  41. ENDIF
  42. DO 22 I=1,IPT1.NUM(/1)
  43. DO 22 J=1,IPT1.NUM(/2)
  44. IP=IPT1.NUM(I,J)
  45. IF (ICPR(IP).NE.0) GOTO 22
  46. NCO=NCO+1
  47. ICPR(IP)=NCO
  48. 22 CONTINUE
  49. 20 CONTINUE
  50. C PUIS ON COMPLETE AVEC LE SUPPORT DE CHAQUE CHAMPOIN
  51. DO 200 IVEC=1,NVEC
  52. MCHPOI=ICHPO(IVEC)
  53. SEGACT MCHPOI
  54. NSOUPO=IPCHP(/1)
  55. DO 24 ISOUP=1,NSOUPO
  56. MSOUPO=IPCHP(ISOUP)
  57. SEGACT MSOUPO
  58. IPT1=IGEOC
  59. SEGACT IPT1
  60. DO 27 J=1,IPT1.NUM(/2)
  61. IP=IPT1.NUM(1,J)
  62. IF (ICPR(IP).NE.0) GOTO 27
  63. NCO=NCO+1
  64. ICPR(IP)=NCO
  65. 27 CONTINUE
  66. 24 CONTINUE
  67. 200 CONTINUE
  68. SEGINI XCOR
  69. KABCOR(1)=XCOR
  70. C MAINTENANT INITIALISER XCOR
  71. DO 220 I=1,XCOOR(/1)/(IDIM+1)
  72. IP=ICPR(I)
  73. IF (IP.EQ.0) GOTO 220
  74. DO 221 J=1,IDIM
  75. XCOR(J,IP)=XCOOR((I-1)*(IDIM+1)+J)
  76. 221 CONTINUE
  77. 220 CONTINUE
  78. ELSE
  79. XCOR=KABCOR(IDEF)
  80. NCO=XCOR(/2)
  81. ENDIF
  82. C MAINTENANT CREER LES COORDONNEES DEFORMES XCO2
  83. DO 300 IVEC=1,NVEC
  84. SEGINI ICO2,XCO2
  85. KABCO2(2,IVEC)=ICO2
  86. KABCO2(1,IVEC)=XCO2
  87. DO 230 I=1,XCOOR(/1)/(IDIM+1)
  88. IP=ICPR(I)
  89. IF (IP.EQ.0) GOTO 230
  90. DO 231 J=1,IDIM
  91. XCO2(J,IP)=XCOR(J,IP)
  92. 231 CONTINUE
  93. 230 CONTINUE
  94. IF (NOCOVE(IVEC,1).EQ.'SI11'.OR.NOCOVE(IVEC,1).EQ.
  95. & 'SI22'.OR.NOCOVE(IVEC,1).EQ.'SI33') THEN
  96. *
  97. * Cas des contraintes principales
  98. *
  99. AMP=AMPF(IVEC)
  100. MCHPOI=ICHPO(IVEC)
  101. SEGACT MCHPOI
  102. MSOUPO=IPCHP(1)
  103. SEGACT MSOUPO
  104. MPOVAL=IPOVAL
  105. SEGACT MPOVAL
  106. IPT2=IGEOC
  107. SEGACT IPT2
  108. *
  109. DO 600 IEL=1,IPT2.NUM(/2)
  110. IP=ICPR(IPT2.NUM(1,IEL))
  111. IF (IP.EQ.0) GOTO 600
  112. IF (VPOCHA(IEL,IDIM+1).EQ.0.D0) THEN
  113. ICO2(IP)=1
  114. ELSE
  115. ICO2(IP)=-1
  116. ENDIF
  117. DO 500 INUM=1,IDIM
  118. XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  119. 500 CONTINUE
  120. 600 CONTINUE
  121. SEGDES IPT2,MPOVAL,MSOUPO,MCHPOI
  122. *
  123. ELSE IF (NOCOVE(IVEC,1).EQ.'FIS1'.OR.NOCOVE(IVEC,1).EQ.
  124. & 'FIS2'.OR.NOCOVE(IVEC,1).EQ.'FIS3') THEN
  125. *
  126. * Cas des fissures
  127. *
  128. AMP=AMPF(IVEC)
  129. MCHPOI=ICHPO(IVEC)
  130. SEGACT MCHPOI
  131. MSOUPO=IPCHP(1)
  132. SEGACT MSOUPO
  133. MPOVAL=IPOVAL
  134. SEGACT MPOVAL
  135. IPT2=IGEOC
  136. SEGACT IPT2
  137. *
  138. DO 700 IEL=1,IPT2.NUM(/2)
  139. IP=ICPR(IPT2.NUM(1,IEL))
  140. IF (IP.EQ.0) GOTO 700
  141. SCOS = 0.D0
  142. DO 710 II = 1,IDIM
  143. SCOS = SCOS + ABS(VPOCHA(IEL,II))
  144. 710 CONTINUE
  145. IF (SCOS.LT.1.E-7) THEN
  146. ICO2(IP)=-1
  147. ELSE
  148. ICO2(IP)=1
  149. ENDIF
  150. DO 720 INUM=1,IDIM
  151. XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  152. 720 CONTINUE
  153. 700 CONTINUE
  154. SEGDES IPT2,MPOVAL,MSOUPO,MCHPOI
  155. *
  156. c debut ajout BP
  157. ELSEIF (NOCOVE(IVEC,1).EQ.'VEC1'.OR.NOCOVE(IVEC,1).EQ.
  158. & 'VEC2'.OR.NOCOVE(IVEC,1).EQ.'VEC3') THEN
  159. *
  160. * Cas des vecteurs construit depouis chamelem + listmots (vecte4)
  161. *
  162. AMP=AMPF(IVEC)
  163. MCHPOI=ICHPO(IVEC)
  164. SEGACT MCHPOI
  165. MSOUPO=IPCHP(1)
  166. SEGACT MSOUPO
  167. MPOVAL=IPOVAL
  168. SEGACT MPOVAL
  169. IPT2=IGEOC
  170. SEGACT IPT2
  171. *
  172. DO 666 IEL=1,IPT2.NUM(/2)
  173. IP=ICPR(IPT2.NUM(1,IEL))
  174. IF (IP.EQ.0) GOTO 666
  175. ICO2(IP)=1
  176. DO 555 INUM=1,IDIM
  177. XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  178. 555 CONTINUE
  179. 666 CONTINUE
  180. SEGDES IPT2,MPOVAL,MSOUPO,MCHPOI
  181. c fin ajout BP
  182.  
  183. ELSE
  184. *
  185. * Cas des vecteurs
  186. *
  187. AMP=AMPF(IVEC)
  188. MCHPOI=ICHPO(IVEC)
  189. SEGACT MCHPOI
  190. NSOUPO=IPCHP(/1)
  191. DO 60 ISOUP=1,NSOUPO
  192. MSOUPO=IPCHP(ISOUP)
  193. SEGACT MSOUPO
  194. MPOVAL=IPOVAL
  195. SEGACT MPOVAL
  196. IPT2=IGEOC
  197. SEGACT IPT2
  198. *
  199. NC=NOCOMP(/2)
  200. DO 70 INUM=1,IDIM
  201. DO 80 IC=1,NC
  202. IF (NOCOMP(IC).EQ.NOCOVE(IVEC,INUM)) GOTO 81
  203. 80 CONTINUE
  204. GOTO 70
  205. 81 CONTINUE
  206. DO 90 IEL=1,IPT2.NUM(/2)
  207. IP=ICPR(IPT2.NUM(1,IEL))
  208. IF (IP.EQ.0) GOTO 90
  209. XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,IC)
  210. ICO2(IP)=1
  211. 90 CONTINUE
  212. 70 CONTINUE
  213. SEGDES IPT2,MPOVAL,MSOUPO
  214. 60 CONTINUE
  215. SEGDES MCHPOI
  216. *+*
  217. ENDIF
  218. 300 CONTINUE
  219. SEGDES MVECTE
  220. RETURN
  221. END
  222.  
  223.  
  224.  
  225.  

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