Télécharger adchve.eso

Retour à la liste

Numérotation des lignes :

  1. C ADCHVE SOURCE CB215821 18/09/10 21:15:05 9912
  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,MLREEL
  102. ENDIF
  103. IELCHE(IGAU,IB)=MLREEL
  104. 1 CONTINUE
  105.  
  106. ELSE IF (ICOD.EQ.2) THEN
  107. IDIMP1 = IDIM + 1
  108. SEGACT,MCOORD*MOD
  109. NBPTS = XCOOR(/1) / IDIMP1
  110.  
  111. DO 3 IB=1,N2EL
  112. IBMN1 = MIN(IB ,NEL1)
  113. IBMN2 = MIN(IB ,NEL2)
  114.  
  115. DO 3 IGAU=1,N2PTEL
  116. IGMN1 = MIN(IGAU,NBP1)
  117. IGMN2 = MIN(IGAU,NBP2)
  118. *
  119. IP1 = MELVA1.IELCHE(IGMN1,IBMN1)
  120. IP2 = MELVA2.IELCHE(IGMN2,IBMN2)
  121. *
  122. IF (IP1.EQ.0) THEN
  123. NUMNOE = IP2
  124. ELSE IF (IP2.EQ.0) THEN
  125. NUMNOE = IP1
  126. ELSE
  127. NUMNOE = MIN(IP1,IP2)
  128. C- Si les numeros des points sont differents, on va tester s'ils
  129. C- n'ont pas les memes coordonnees. Si non, on cree un nouveau point
  130. C- mais risque de probleme en //...
  131. IF (IP1.NE.IP2) THEN
  132. IREF1 = (IP1-1) * IDIMP1
  133. IREF2 = (IP2-1) * IDIMP1
  134. i_z = 0
  135. DO IC = 1, IDIM
  136. r_z1 = MAX( ABS(XCOOR(IREF1+IC)) ,
  137. & ABS(XCOOR(IREF2+IC)) )
  138. r_z2 = ABS( XCOOR(IREF1+IC) - XCOOR(IREF2+IC) )
  139. IF (r_z2 .GT. 1.D-9*r_z1) i_z = i_z + 1
  140. ENDDO
  141. *
  142. * ON CREE UN NOUVEAU POINT :
  143. *
  144. IF (i_z.GT.0) THEN
  145. IREFC = NBPTS * IDIMP1
  146. NBPTS = NBPTS + 1
  147. SEGADJ,MCOORD
  148. DO 4 IC = 1, IDIMP1
  149. XCOOR(IREFC+IC) = XCOOR(IREF1+IC)
  150. & +XX * XCOOR(IREF2+IC)
  151. 4 CONTINUE
  152. NUMNOE = NBPTS
  153. ENDIF
  154. ENDIF
  155. ENDIF
  156. IELCHE(IGAU,IB) = NUMNOE
  157. 3 CONTINUE
  158. SEGDES,MCOORD
  159.  
  160. ELSE IF (ICOD.EQ.3) THEN
  161. I_XX = INT(XX)
  162. DO 6 IB=1,N2EL
  163. IBMN1 = MIN(IB ,NEL1)
  164. IBMN2 = MIN(IB ,NEL2)
  165.  
  166. DO 6 IGAU=1,N2PTEL
  167. IGMN1 = MIN(IGAU,NBP1)
  168. IGMN2 = MIN(IGAU,NBP2)
  169. *
  170. MEVOL1 = MELVA1.IELCHE(IGMN1,IBMN1)
  171. MEVOL2 = MELVA2.IELCHE(IGMN2,IBMN2)
  172. CALL ADEVOL(MEVOL1,MEVOL2,IPEVAD,I_XX)
  173. IF (IPEVAD.EQ.0) IRET=1
  174. IELCHE(IGAU,IB) = IPEVAD
  175. 6 CONTINUE
  176.  
  177. ELSE
  178. *
  179. * Y-A-T'IL UN DES DEUX POINTEURS NUL ?
  180. *
  181. DO IB=1,N2EL
  182. IBMN1 = MIN(IB ,NEL1)
  183. IBMN2 = MIN(IB ,NEL2)
  184.  
  185. DO IGAU=1,N2PTEL
  186. IGMN1 = MIN(IGAU,NBP1)
  187. IGMN2 = MIN(IGAU,NBP2)
  188.  
  189. IEL1=MELVA1.IELCHE(IGMN1,IBMN1)
  190. IEL2=MELVA2.IELCHE(IGMN2,IBMN2)
  191. IF (IEL1.EQ.0)THEN
  192. IELCHE(IGAU,IB)=IEL2
  193. ELSEIF(IEL2.EQ.0)THEN
  194. IELCHE(IGAU,IB)=IEL1
  195. ELSE
  196. *
  197. * NOM DE COMPOSANTE NON RECONNU
  198. *
  199. IRET=197
  200. SEGSUP MELVAL
  201. RETURN
  202. ENDIF
  203. ENDDO
  204. ENDDO
  205. ENDIF
  206.  
  207. IMELVA=MELVAL
  208.  
  209. ELSE
  210. NBP1=MELVA1.VELCHE(/1)
  211. NBP2=MELVA2.VELCHE(/1)
  212. NEL1=MELVA1.VELCHE(/2)
  213. NEL2=MELVA2.VELCHE(/2)
  214. N1PTEL=MAX(NBP1,NBP2)
  215. N1EL =MAX(NEL1,NEL2)
  216. N2PTEL=0
  217. N2EL =0
  218. SEGINI MELVAL
  219. DO 50 IB=1,N1EL
  220. IBMN1 = MIN(IB ,NEL1)
  221. IBMN2 = MIN(IB ,NEL2)
  222.  
  223. DO 51 IGAU=1,N1PTEL
  224. IGMN1 = MIN(IGAU,NBP1)
  225. IGMN2 = MIN(IGAU,NBP2)
  226. VELCHE(IGAU,IB)= MELVA1.VELCHE(IGMN1,IBMN1)+
  227. & XX*MELVA2.VELCHE(IGMN2,IBMN2)
  228. 51 CONTINUE
  229. 50 CONTINUE
  230. IMELVA=MELVAL
  231.  
  232. ENDIF
  233.  
  234. SEGDES MELVAL
  235. *
  236. RETURN
  237. END
  238.  
  239.  
  240.  
  241.  
  242.  

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