Télécharger adchve.eso

Retour à la liste

Numérotation des lignes :

  1. C ADCHVE SOURCE FANDEUR 16/05/25 21:15:01 8930
  2.  
  3. SUBROUTINE ADCHVE(IELVA1,IELVA2,XX,ICOD,IMELVA,IRET)
  4.  
  5. *_______________________________________________________________________
  6. *
  7. * POUR VECTORISER L ADDITION DES CHAMELEMS
  8. *
  9. * ENTREE :
  10. * ________
  11. *
  12. * IELVA1 POINTEUR SUR LE MELVAL DU 1IER CHAMELEM
  13. * IELVA2 POINTEUR SUR LE MELVA DU 2IEME CHAMELEM
  14. * XX COEFFICIENTS MULTIPLICATEUR
  15. * ICOD =1 --> MELVAL DE POINTEUR SUR MLREEL
  16. * =2 --> MELVAL DE POINTEUR SUR UN POINT
  17. * =3 --> MELVAL DE POINTEUR SUR UN EVOLUTIOn
  18. * =0 --> AUTRE CAS
  19. *
  20. *
  21. * SORTIES :
  22. * ---------
  23. *
  24. * IMELVA POINTEUR SUR LE MELVAL RESULTAT
  25. * IRET = 0 SI OK / =1 SINON
  26. * =104 POUR DECLENCHER LE MESSAGE D'ERREUR 104
  27. * =197 POUR DECLENCHER LE MESSAGE D'ERREUR 197
  28. *
  29. * EBERSOLT DECEMBRE 86
  30. *
  31. * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90
  32. * +PP EXTENSION ADDITION P.PEGON 23/11/92
  33. *
  34. *______________________________________________________________________
  35. *
  36. IMPLICIT INTEGER(I-N)
  37. IMPLICIT REAL*8(A-H,O-Z)
  38.  
  39. -INC CCOPTIO
  40.  
  41. -INC SMCHAML
  42. -INC SMLREEL
  43. -INC SMCOORD
  44. -INC SMEVOLL
  45. *
  46. IRET=0
  47. MELVA1=IELVA1
  48. MELVA2=IELVA2
  49. SEGACT MELVA1
  50. SEGACT MELVA2
  51. *
  52. NBP1=MELVA1.VELCHE(/1)
  53. IF (NBP1.EQ.0) THEN
  54. NBP1=MELVA1.IELCHE(/1)
  55. NBP2=MELVA2.IELCHE(/1)
  56. NEL1=MELVA1.IELCHE(/2)
  57. NEL2=MELVA2.IELCHE(/2)
  58. N1PTEL=0
  59. N1EL =0
  60. N2PTEL=MAX(NBP1,NBP2)
  61. N2EL =MAX(NEL1,NEL2)
  62. SEGINI MELVAL
  63. IF (ICOD.EQ.1) THEN
  64. DO 1 IB = 1, N2EL
  65. IBMN1 = MIN(IB ,NEL1)
  66. IBMN2 = MIN(IB ,NEL2)
  67.  
  68. DO 1 IGAU = 1, N2PTEL
  69. IGMN1 = MIN(IGAU,NBP1)
  70. IGMN2 = MIN(IGAU,NBP2)
  71. *
  72. MLREE1 = MELVA1.IELCHE(IGMN1,IBMN1)
  73. MLREE2 = MELVA2.IELCHE(IGMN2,IBMN2)
  74. *
  75. IF (MLREE1.EQ.0) THEN
  76. MLREEL = MLREE2
  77. ELSE IF (MLREE2.EQ.0) THEN
  78. MLREEL = MLREE1
  79. ELSE
  80. SEGACT,MLREE1,MLREE2
  81. JG1 = MLREE1.PROG(/1)
  82. JG2 = MLREE2.PROG(/1)
  83. IJG = MIN(JG1,JG2)
  84. *
  85. JG=MAX(JG1,JG2)
  86. SEGINI MLREEL
  87. DO 2 IPROG=1,IJG
  88. PROG(IPROG)=MLREE1.PROG(IPROG)+XX*MLREE2.PROG(IPROG)
  89. 2 CONTINUE
  90. IF (JG.GT.IJG) THEN
  91. IF (IJG.EQ.JG1) THEN
  92. DO 10 IPROG=IJG+1,JG2
  93. PROG(IPROG)=XX*MLREE2.PROG(IPROG)
  94. 10 CONTINUE
  95. ELSE
  96. DO 20 IPROG=IJG+1,JG1
  97. PROG(IPROG)=MLREE1.PROG(IPROG)
  98. 20 CONTINUE
  99. ENDIF
  100. ENDIF
  101. SEGDES,MLREE1,MLREE2,MLREEL
  102. ENDIF
  103. IELCHE(IGAU,IB)=MLREEL
  104. 1 CONTINUE
  105.  
  106. ELSE IF (ICOD.EQ.2) THEN
  107. IDIMP1 = IDIM + 1
  108. NBPTS = XCOOR(/1) / IDIMP1
  109.  
  110. DO 3 IB=1,N2EL
  111. IBMN1 = MIN(IB ,NEL1)
  112. IBMN2 = MIN(IB ,NEL2)
  113.  
  114. DO 3 IGAU=1,N2PTEL
  115. IGMN1 = MIN(IGAU,NBP1)
  116. IGMN2 = MIN(IGAU,NBP2)
  117. *
  118. IP1 = MELVA1.IELCHE(IGMN1,IBMN1)
  119. IP2 = MELVA2.IELCHE(IGMN2,IBMN2)
  120. *
  121. IF (IP1.EQ.0) THEN
  122. NUMNOE = IP2
  123. ELSE IF (IP2.EQ.0) THEN
  124. NUMNOE = IP1
  125. ELSE
  126. NUMNOE = MIN(IP1,IP2)
  127. C- Si les numeros des points sont differents, on va tester s'ils
  128. C- n'ont pas les memes coordonnees. Si non, on cree un nouveau point
  129. C- mais risque de probleme en //...
  130. IF (IP1.NE.IP2) THEN
  131. IREF1 = (IP1-1) * IDIMP1
  132. IREF2 = (IP2-1) * IDIMP1
  133. i_z = 0
  134. DO IC = 1, IDIM
  135. r_z1 = MAX( ABS(XCOOR(IREF1+IC)) ,
  136. & ABS(XCOOR(IREF2+IC)) )
  137. r_z2 = ABS( XCOOR(IREF1+IC) - XCOOR(IREF2+IC) )
  138. IF (r_z2 .GT. 1.D-9*r_z1) i_z = i_z + 1
  139. ENDDO
  140. *
  141. * ON CREE UN NOUVEAU POINT :
  142. *
  143. IF (i_z.GT.0) THEN
  144. IREFC = NBPTS * IDIMP1
  145. NBPTS = NBPTS + 1
  146. SEGADJ,MCOORD
  147. DO 4 IC = 1, IDIMP1
  148. XCOOR(IREFC+IC) = XCOOR(IREF1+IC)
  149. & +XX * XCOOR(IREF2+IC)
  150. 4 CONTINUE
  151. NUMNOE = NBPTS
  152. ENDIF
  153. ENDIF
  154. ENDIF
  155. IELCHE(IGAU,IB) = NUMNOE
  156. 3 CONTINUE
  157.  
  158. ELSE IF (ICOD.EQ.3) THEN
  159. I_XX = INT(XX)
  160. DO 6 IB=1,N2EL
  161. IBMN1 = MIN(IB ,NEL1)
  162. IBMN2 = MIN(IB ,NEL2)
  163.  
  164. DO 6 IGAU=1,N2PTEL
  165. IGMN1 = MIN(IGAU,NBP1)
  166. IGMN2 = MIN(IGAU,NBP2)
  167. *
  168. MEVOL1 = MELVA1.IELCHE(IGMN1,IBMN1)
  169. MEVOL2 = MELVA2.IELCHE(IGMN2,IBMN2)
  170. CALL ADEVOL(MEVOL1,MEVOL2,IPEVAD,I_XX)
  171. IF (IPEVAD.EQ.0) IRET=1
  172. IELCHE(IGAU,IB) = IPEVAD
  173. 6 CONTINUE
  174.  
  175. ELSE
  176. *
  177. * Y-A-T'IL UN DES DEUX POINTEURS NUL ?
  178. *
  179. DO IB=1,N2EL
  180. IBMN1 = MIN(IB ,NEL1)
  181. IBMN2 = MIN(IB ,NEL2)
  182.  
  183. DO IGAU=1,N2PTEL
  184. IGMN1 = MIN(IGAU,NBP1)
  185. IGMN2 = MIN(IGAU,NBP2)
  186.  
  187. IEL1=MELVA1.IELCHE(IGMN1,IBMN1)
  188. IEL2=MELVA2.IELCHE(IGMN2,IBMN2)
  189. IF (IEL1.EQ.0)THEN
  190. IELCHE(IGAU,IB)=IEL2
  191. ELSEIF(IEL2.EQ.0)THEN
  192. IELCHE(IGAU,IB)=IEL1
  193. ELSE
  194. *
  195. * NOM DE COMPOSANTE NON RECONNU
  196. *
  197. IRET=197
  198. SEGSUP MELVAL
  199. RETURN
  200. ENDIF
  201. ENDDO
  202. ENDDO
  203. ENDIF
  204.  
  205. IMELVA=MELVAL
  206.  
  207. ELSE
  208. NBP1=MELVA1.VELCHE(/1)
  209. NBP2=MELVA2.VELCHE(/1)
  210. NEL1=MELVA1.VELCHE(/2)
  211. NEL2=MELVA2.VELCHE(/2)
  212. N1PTEL=MAX(NBP1,NBP2)
  213. N1EL =MAX(NEL1,NEL2)
  214. N2PTEL=0
  215. N2EL =0
  216. SEGINI MELVAL
  217. DO 5 IB=1,N1EL
  218. IBMN1 = MIN(IB ,NEL1)
  219. IBMN2 = MIN(IB ,NEL2)
  220.  
  221. DO 5 IGAU=1,N1PTEL
  222. IGMN1 = MIN(IGAU,NBP1)
  223. IGMN2 = MIN(IGAU,NBP2)
  224. *
  225. VELCHE(IGAU,IB)=MELVA1.VELCHE(IGMN1,IBMN1)+
  226. & XX*MELVA2.VELCHE(IGMN2,IBMN2)
  227. 5 CONTINUE
  228. IMELVA=MELVAL
  229.  
  230. ENDIF
  231.  
  232. SEGDES MELVAL,MELVA1,MELVA2
  233. *
  234. RETURN
  235. END
  236.  
  237.  
  238.  
  239.  

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