Télécharger elchpo.eso

Retour à la liste

Numérotation des lignes :

  1. C ELCHPO SOURCE PV 18/10/23 21:15:00 9974
  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(NNINR,NNNOER)
  39. REAL*8 TBB(NNINR,NNNOER)
  40. ENDSEGMENT
  41. SEGMENT MTR3
  42. INTEGER TGEO(TGEOD)
  43. ENDSEGMENT
  44. SEGMENT MTR3I
  45. INTEGER ITGEO(ITGEOD)
  46. ENDSEGMENT
  47. SEGMENT MTR4
  48. INTEGER THARM(0)
  49. ENDSEGMENT
  50. SEGMENT MTR5
  51. INTEGER ICO(NC)
  52. ENDSEGMENT
  53. INTEGER TGEOD
  54.  
  55. PARAMETER (Epsi=1.D-30)
  56. CHARACTER*4 cmot
  57. LOGICAL FLAG
  58.  
  59. MCHPOI=IP1
  60. SEGACT,MCHPOI
  61.  
  62. C verification de la compatibilite des natures
  63. NAT=JATTRI(/1)
  64. NATU=NAT
  65. IF (NATU.GT.0) THEN
  66. NATU=JATTRI(1)
  67. ENDIF
  68. C la nature est indeterminee on ne peut rien faire
  69. IF (NATU.EQ.0) THEN
  70. Iratt=2
  71. RETURN
  72. ENDIF
  73.  
  74. c on eclate le champ par point dans le segment mtrav
  75. NNINR=10
  76. NNNOER=10000
  77. NNIN=0
  78. NNNOE=0
  79. TGEOD =1000
  80. ITGEOD=1000
  81. SEGINI,MTR1,MTR2,MTR3,MTR3I,MTR4
  82.  
  83. c boucle sur les msoupo
  84. c
  85. DO 60 i=1,IPCHP(/1)
  86. MSOUPO=IPCHP(i)
  87. SEGACT,MSOUPO
  88. MPOVAL=IPOVAL
  89. IF (MPOVAL.EQ.0) THEN
  90. SEGSUP,MTR1,MTR2,MTR3,MTR3I,MTR4
  91. SEGDES,MSOUPO,MCHPOI
  92. RETURN
  93. ENDIF
  94. c
  95. c boucle sur les composantes
  96. c on remplit tinco avec le nom des composantes
  97. NC=NOCOMP(/2)
  98. SEGINI,MTR5
  99. DO 20 j=1,NC
  100. cmot=NOCOMP(j)
  101. DO k=1,NNIN
  102. IF (TINCO(k).EQ.cmot) THEN
  103. ICO(j)=k
  104. GOTO 20
  105. ENDIF
  106. ENDDO
  107. c il y une inconnue de plus dans tinco
  108. NNIN=NNIN+1
  109. ICO(j)=NNIN
  110. SEGADJ,MTR1
  111. TINCO(NNIN)=cmot
  112. THARM(**)=NOHARM(j)
  113. 20 CONTINUE
  114. c
  115. c boucle sur les noeuds du msoupo
  116. MELEME=IGEOC
  117. SEGACT,MELEME
  118. NOE=NUM(/2)
  119. DO 40 j=1,NOE
  120. c pour savoir si le noeud j appartient a geo
  121. jnoe=NUM(1,j)
  122. if (jnoe.gt.ITGEOD) then
  123. ITGEOD=jnoe*2
  124. segadj mtr3i
  125. endif
  126. IF (itgeo(jnoe).ne.0) goto 40
  127. c le noeud n'etait pas dans la pile
  128. NNNOE=NNNOE+1
  129. if (nnnoe.gt.tgeod) then
  130. tgeod=nnnoe*2
  131. segadj mtr3
  132. endif
  133. TGEO(nnnoe)=jnoe
  134. itgeo(jnoe)=nnnoe
  135. 40 CONTINUE
  136. c
  137. c encore une boucle sur les noeuds pour remplir tbb avec les valeurs
  138. c ico et ino servent pour retrouver les numeros dans tgeo et tinco
  139. if (nnin.gt.nninr) then
  140. nninr=nnin+10
  141. endif
  142. if (nnnoe.gt.nnnoer) then
  143. nnnoer=nnnoe+10000
  144. endif
  145. if (nninr.ne.tibin(/1).or.nnnoer.ne.tibin(/2)) SEGADJ,MTR2
  146. SEGACT,MPOVAL
  147. DO k=1,NC
  148. FLAG=.TRUE.
  149. icok=ICO(k)
  150. DO j=1,NUM(/2)
  151. c il s'agit d'un point double
  152. inoj=itgeo(num(1,j))
  153. IF (TIBIN(icok,inoj).NE.0) THEN
  154. IF (NATU.EQ.2) THEN
  155. c le champ est discret on additionne
  156. TBB(icok,inoj)=TBB(icok,inoj)+VPOCHA(j,k)
  157. ELSE
  158. c le champ est diffus il faut l'egalite
  159. V1=TBB(icok,inoj)
  160. V2=VPOCHA(j,k)
  161. VMOY=0.5*(V1+V2)+Epsi
  162. c test sur la difference relative
  163. c on commence par chercher un ordre de grandeur de la
  164. c composante sur la sous zone pour faire un test sur la
  165. c valeur absolue de la difference
  166. IF (ABS(V2-V1).GT.(1.D-4*ABS(VMOY))) THEN
  167. IF (FLAG) THEN
  168. THEMAX=0.
  169. DO l=1,NUM(/2)
  170. THEMAX=MAX(ABS(VPOCHA(l,k)),THEMAX)
  171. ENDDO
  172. FLAG=.FALSE.
  173. ENDIF
  174. c il n'y a pas egalite : erreur
  175. IF (ABS(V2-V1).GT.(1.D-4*THEMAX)) THEN
  176. Iratt=2
  177. c les lignes suivantes sont en commentaire de facon
  178. c a traiter quand meme les champ par point diffus dont les
  179. c valeurs sont distinctes: on prend la moyenne
  180. c SEGDES,MPOVAL,MSOUPO,MELEME
  181. c SEGSUP,mtr1,mtr2,mtr3,mtr4,mtr5,mtr6
  182. c RETURN
  183. ENDIF
  184. ENDIF
  185. c on affecte la valeur moyenne dans tous les cas
  186. TBB(icok,inoj)=VMOY
  187. ENDIF
  188. ELSE
  189. TBB(icok,inoj)=VPOCHA(j,k)
  190. TIBIN(icok,inoj)=1
  191. ENDIF
  192. ENDDO
  193. ENDDO
  194. SEGDES,MPOVAL
  195. SEGDES,MELEME
  196. SEGSUP,MTR5
  197. SEGDES,MSOUPO
  198. 60 CONTINUE
  199.  
  200. C= Remplissage du segment MTRAV (ITRAV)
  201. SEGINI,MTRAV
  202. DO i=1,NNIN
  203. INCO(i)=TINCO(i)
  204. C*OF NHAR(i)=THARM(i)
  205. ENDDO
  206. C*OF IF temporaire en attendant operateur remplacant procedure creer_3D
  207. IF (IFOMOD.EQ.1) THEN
  208. DO i=1,NNIN
  209. NHAR(i)=THARM(i)
  210. ENDDO
  211. ENDIF
  212. DO j=1,NNNOE
  213. IGEO(j)=TGEO(j)
  214. DO i=1,NNIN
  215. BB(i,j)=TBB(i,j)
  216. IBIN(i,j)=TIBIN(i,j)
  217. ENDDO
  218. ENDDO
  219. ITRAV=MTRAV
  220.  
  221. c reconstuction de la partition
  222. CALL CRECHP(ITRAV,ICHP)
  223. c on ajuste le contenu du chapeau
  224. MCHPO1=ICHP
  225. SEGACT,MCHPO1
  226. NSOUPO=MCHPO1.IPCHP(/1)
  227. SEGADJ,MCHPOI
  228. DO i=1,NSOUPO
  229. IPCHP(i)=MCHPO1.IPCHP(i)
  230. ENDDO
  231.  
  232. SEGSUP,MCHPO1
  233. SEGSUP,MTR1,MTR2,MTR3,MTR3I,MTR4,MTRAV
  234.  
  235. RETURN
  236. END
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  

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