Télécharger crevec.eso

Retour à la liste

Numérotation des lignes :

  1. C CREVEC SOURCE CB215821 19/08/20 21:16:29 10287
  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. *
  122. ELSE IF (NOCOVE(IVEC,1).EQ.'FIS1'.OR.NOCOVE(IVEC,1).EQ.
  123. & 'FIS2'.OR.NOCOVE(IVEC,1).EQ.'FIS3') THEN
  124. *
  125. * Cas des fissures
  126. *
  127. AMP=AMPF(IVEC)
  128. MCHPOI=ICHPO(IVEC)
  129. SEGACT MCHPOI
  130. MSOUPO=IPCHP(1)
  131. SEGACT MSOUPO
  132. MPOVAL=IPOVAL
  133. SEGACT MPOVAL
  134. IPT2=IGEOC
  135. SEGACT IPT2
  136. *
  137. DO 700 IEL=1,IPT2.NUM(/2)
  138. IP=ICPR(IPT2.NUM(1,IEL))
  139. IF (IP.EQ.0) GOTO 700
  140. SCOS = 0.D0
  141. DO 710 II = 1,IDIM
  142. SCOS = SCOS + ABS(VPOCHA(IEL,II))
  143. 710 CONTINUE
  144. IF (SCOS.LT.1.E-7) THEN
  145. ICO2(IP)=-1
  146. ELSE
  147. ICO2(IP)=1
  148. ENDIF
  149. DO 720 INUM=1,IDIM
  150. XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  151. 720 CONTINUE
  152. 700 CONTINUE
  153. *
  154. c debut ajout BP
  155. ELSEIF (NOCOVE(IVEC,1).EQ.'VEC1'.OR.NOCOVE(IVEC,1).EQ.
  156. & 'VEC2'.OR.NOCOVE(IVEC,1).EQ.'VEC3') THEN
  157. *
  158. * Cas des vecteurs construit depouis chamelem + listmots (vecte4)
  159. *
  160. AMP=AMPF(IVEC)
  161. MCHPOI=ICHPO(IVEC)
  162. SEGACT MCHPOI
  163. MSOUPO=IPCHP(1)
  164. SEGACT MSOUPO
  165. MPOVAL=IPOVAL
  166. SEGACT MPOVAL
  167. IPT2=IGEOC
  168. SEGACT IPT2
  169. *
  170. DO 666 IEL=1,IPT2.NUM(/2)
  171. IP=ICPR(IPT2.NUM(1,IEL))
  172. IF (IP.EQ.0) GOTO 666
  173. ICO2(IP)=1
  174. DO 555 INUM=1,IDIM
  175. XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  176. 555 CONTINUE
  177. 666 CONTINUE
  178. c fin ajout BP
  179.  
  180. ELSE
  181. *
  182. * Cas des vecteurs
  183. *
  184. AMP=AMPF(IVEC)
  185. MCHPOI=ICHPO(IVEC)
  186. SEGACT MCHPOI
  187. NSOUPO=IPCHP(/1)
  188. DO 60 ISOUP=1,NSOUPO
  189. MSOUPO=IPCHP(ISOUP)
  190. SEGACT MSOUPO
  191. MPOVAL=IPOVAL
  192. SEGACT MPOVAL
  193. IPT2=IGEOC
  194. SEGACT IPT2
  195. *
  196. NC=NOCOMP(/2)
  197. DO 70 INUM=1,IDIM
  198. DO 80 IC=1,NC
  199. IF (NOCOMP(IC).EQ.NOCOVE(IVEC,INUM)) GOTO 81
  200. 80 CONTINUE
  201. GOTO 70
  202. 81 CONTINUE
  203. DO 90 IEL=1,IPT2.NUM(/2)
  204. IP=ICPR(IPT2.NUM(1,IEL))
  205. IF (IP.EQ.0) GOTO 90
  206. XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,IC)
  207. ICO2(IP)=1
  208. 90 CONTINUE
  209. 70 CONTINUE
  210. 60 CONTINUE
  211. *+*
  212. ENDIF
  213. 300 CONTINUE
  214. SEGDES MVECTE
  215. END
  216.  
  217.  
  218.  

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