Télécharger elchpo.eso

Retour à la liste

Numérotation des lignes :

  1. C ELCHPO SOURCE PASCAL 17/02/09 21:15:01 7876
  2.  
  3. C=======================================================================
  4. c fonction:
  5. c sous routine pour arranger un chpo qui a souffert apres elim
  6. c
  7. c arguments:
  8. c ip1 (e/s) pointeur sur le champ par point / ACTIF en SORTIE
  9. c
  10. c
  11. c variables:
  12. c * mtrav : - bb(i,j) est la valeur de la ieme inconnue de champ pour
  13. c le jieme noeud du tableau igeo .
  14. c - inco(nnin) contient le nom des nnin inconnues differentes
  15. c - ibin(i,j)=1 ou 0 indique que la ieme inconnue du champ
  16. c existe pour le jieme noeud du tableau igeo .
  17. c - igeo(i) est le numero a mettre dans un objet meleme pour
  18. c referencer le ieme noeud .
  19. c
  20. C= A. DE GAYFFIER, le 7 juillet 1994. =
  21. C=======================================================================
  22.  
  23. SUBROUTINE ELCHPO(IP1,iratt)
  24.  
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27.  
  28. -INC CCOPTIO
  29. -INC SMCHPOI
  30. -INC SMELEME
  31. -INC SMCOORD
  32. -INC TMTRAV
  33.  
  34. SEGMENT MTR1
  35. CHARACTER*4 TINCO(NNIN)
  36. ENDSEGMENT
  37. SEGMENT MTR2
  38. INTEGER TIBIN(NNIN,NNNOE)
  39. REAL*8 TBB(NNIN,NNNOE)
  40. ENDSEGMENT
  41. SEGMENT MTR3
  42. INTEGER TGEO(0)
  43. ENDSEGMENT
  44. SEGMENT MTR4
  45. INTEGER THARM(0)
  46. ENDSEGMENT
  47. SEGMENT MTR5
  48. INTEGER ICO(NC)
  49. ENDSEGMENT
  50. SEGMENT MTR6
  51. INTEGER INO(NOE)
  52. ENDSEGMENT
  53.  
  54. PARAMETER (Epsi=1.D-30)
  55. CHARACTER*4 cmot
  56. LOGICAL FLAG
  57.  
  58. MCHPOI=IP1
  59. SEGACT,MCHPOI
  60.  
  61. C verification de la compatibilite des natures
  62. NAT=JATTRI(/1)
  63. NATU=NAT
  64. IF (NATU.GT.0) THEN
  65. NATU=JATTRI(1)
  66. ENDIF
  67. C la nature est indeterminee on ne peut rien faire
  68. IF (NATU.EQ.0) THEN
  69. Iratt=2
  70. RETURN
  71. ENDIF
  72.  
  73. c on eclate le champ par point dans le segment mtrav
  74. NNIN=0
  75. NNNOE=0
  76. SEGINI,MTR1,MTR2,MTR3,MTR4
  77.  
  78. c boucle sur les msoupo
  79. c
  80. DO 60 i=1,IPCHP(/1)
  81. MSOUPO=IPCHP(i)
  82. SEGACT,MSOUPO
  83. MPOVAL=IPOVAL
  84. IF (MPOVAL.EQ.0) THEN
  85. SEGSUP,MTR1,MTR2,MTR3,MTR4
  86. SEGDES,MSOUPO,MCHPOI
  87. RETURN
  88. ENDIF
  89. c
  90. c boucle sur les composantes
  91. c on remplit tinco avec le nom des composantes
  92. NC=NOCOMP(/2)
  93. SEGINI,MTR5
  94. DO 20 j=1,NC
  95. cmot=NOCOMP(j)
  96. DO k=1,NNIN
  97. IF (TINCO(k).EQ.cmot) THEN
  98. ICO(j)=k
  99. GOTO 20
  100. ENDIF
  101. ENDDO
  102. c il y une inconnue de plus dans tinco
  103. NNIN=NNIN+1
  104. ICO(j)=NNIN
  105. SEGADJ,MTR1
  106. TINCO(NNIN)=cmot
  107. THARM(**)=NOHARM(j)
  108. 20 CONTINUE
  109. c
  110. c boucle sur les noeuds du msoupo
  111. MELEME=IGEOC
  112. SEGACT,MELEME
  113. NOE=NUM(/2)
  114. SEGINI,MTR6
  115. DO 40 j=1,NOE
  116. c boucle sur les noeuds du tableau geo
  117. c pour savoir si le noeud j appartient a geo
  118. jnoe=NUM(1,j)
  119. DO k=1,NNNOE
  120. IF (TGEO(k).EQ.jnoe) THEN
  121. INO(j)=k
  122. GOTO 40
  123. ENDIF
  124. ENDDO
  125. c le noeud n'etait pas dans la pile
  126. NNNOE=NNNOE+1
  127. INO(j)=NNNOE
  128. TGEO(**)=jnoe
  129. 40 CONTINUE
  130. c
  131. c encore une boucle sur les noeuds pour remplir tbb avec les valeurs
  132. c ico et ino servent pour retrouver les numeros dans tgeo et tinco
  133. SEGADJ,MTR2
  134. SEGACT,MPOVAL
  135. DO k=1,NC
  136. FLAG=.TRUE.
  137. icok=ICO(k)
  138. DO j=1,NUM(/2)
  139. c il s'agit d'un point double
  140. inoj=INO(j)
  141. IF (TIBIN(icok,inoj).NE.0) THEN
  142. IF (NATU.EQ.2) THEN
  143. c le champ est discret on additionne
  144. TBB(icok,inoj)=TBB(icok,inoj)+VPOCHA(j,k)
  145. ELSE
  146. c le champ est diffus il faut l'egalite
  147. V1=TBB(icok,inoj)
  148. V2=VPOCHA(j,k)
  149. VMOY=0.5*(V1+V2)+Epsi
  150. c test sur la difference relative
  151. c on commence par chercher un ordre de grandeur de la
  152. c composante sur la sous zone pour faire un test sur la
  153. c valeur absolue de la difference
  154. IF (ABS(V2-V1).GT.(1.D-4*ABS(VMOY))) THEN
  155. IF (FLAG) THEN
  156. THEMAX=0.
  157. DO l=1,NUM(/2)
  158. THEMAX=MAX(ABS(VPOCHA(l,k)),THEMAX)
  159. ENDDO
  160. FLAG=.FALSE.
  161. ENDIF
  162. c il n'y a pas egalite : erreur
  163. IF (ABS(V2-V1).GT.(1.D-4*THEMAX)) THEN
  164. Iratt=2
  165. c les lignes suivantes sont en commentaire de facon
  166. c a traiter quand meme les champ par point diffus dont les
  167. c valeurs sont distinctes: on prend la moyenne
  168. c SEGDES,MPOVAL,MSOUPO,MELEME
  169. c SEGSUP,mtr1,mtr2,mtr3,mtr4,mtr5,mtr6
  170. c RETURN
  171. ENDIF
  172. ENDIF
  173. c on affecte la valeur moyenne dans tous les cas
  174. TBB(icok,inoj)=VMOY
  175. ENDIF
  176. ELSE
  177. TBB(icok,inoj)=VPOCHA(j,k)
  178. TIBIN(icok,inoj)=1
  179. ENDIF
  180. ENDDO
  181. ENDDO
  182. SEGDES,MPOVAL
  183. SEGDES,MELEME
  184. SEGSUP,MTR5,MTR6
  185. SEGDES,MSOUPO
  186. 60 CONTINUE
  187.  
  188. C= Remplissage du segment MTRAV (ITRAV)
  189. SEGINI,MTRAV
  190. DO i=1,NNIN
  191. INCO(i)=TINCO(i)
  192. C*OF NHAR(i)=THARM(i)
  193. ENDDO
  194. C*OF IF temporaire en attendant operateur remplacant procedure creer_3D
  195. IF (IFOMOD.EQ.1) THEN
  196. DO i=1,NNIN
  197. NHAR(i)=THARM(i)
  198. ENDDO
  199. ENDIF
  200. DO j=1,NNNOE
  201. IGEO(j)=TGEO(j)
  202. DO i=1,NNIN
  203. BB(i,j)=TBB(i,j)
  204. IBIN(i,j)=TIBIN(i,j)
  205. ENDDO
  206. ENDDO
  207. ITRAV=MTRAV
  208.  
  209. c reconstuction de la partition
  210. CALL CRECHP(ITRAV,ICHP)
  211. c on ajuste le contenu du chapeau
  212. MCHPO1=ICHP
  213. SEGACT,MCHPO1
  214. NSOUPO=MCHPO1.IPCHP(/1)
  215. SEGADJ,MCHPOI
  216. DO i=1,NSOUPO
  217. IPCHP(i)=MCHPO1.IPCHP(i)
  218. ENDDO
  219.  
  220. SEGSUP,MCHPO1
  221. SEGSUP,MTR1,MTR2,MTR3,MTR4,MTRAV
  222.  
  223. RETURN
  224. END
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  

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