Télécharger xtx4.eso

Retour à la liste

Numérotation des lignes :

  1. C XTX4 SOURCE PV 09/03/12 21:37:31 6325
  2. SUBROUTINE XTX4(IPCHE1,IPCHE2,FLO1,FLO2,XDRET,IRET)
  3. *_______________________________________________________________________
  4. *
  5. * OPERATEUR XTX
  6. *
  7. * ENTREES :
  8. * ---------
  9. * IPCHE1 POINTEUR SUR UN CHAMELEM
  10. * IPCHE2 POINTEUR SUR UN CHAMELEM
  11. * FLO1 FLOTTANT
  12. * FLO2 FLOTTANT
  13. *
  14. *
  15. * SORTIES :
  16. * ---------
  17. * XDRET XTX = FLO1 * ICH1 + FLO2 * FLO2
  18. * IRET 1 SI SUCCES 0 SINON
  19. *
  20. * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 02/91
  21. *
  22. *_______________________________________________________________________
  23. *
  24. IMPLICIT INTEGER(I-N)
  25. IMPLICIT REAL*8(A-H,O-Z)
  26. *
  27. -INC CCOPTIO
  28. -INC SMELEME
  29. -INC SMCHAML
  30. -INC SMINTE
  31. -INC SMLREEL
  32. *
  33. C CHARACTER*8 MOT1,MOT3
  34. CHARACTER*16 CONCH1,CONCH2
  35. PARAMETER(XZER=0.D0)
  36. DIMENSION ITR(40)
  37. PARAMETER(NINF=3)
  38. DIMENSION INFOS(NINF)
  39. *
  40. XDRET=XZER
  41. IRET=1
  42. *
  43. MCHEL1=IPCHE1
  44. MCHEL2=IPCHE2
  45. *
  46. SEGACT MCHEL1,MCHEL2
  47. *
  48. * LES CHAMELEMS SONT ILS COMPATIBLES ??
  49. *
  50. NSOUS1=MCHEL1.ICHAML(/1)
  51. NSOUS2=MCHEL2.ICHAML(/1)
  52. IF (NSOUS1.NE.NSOUS2) GOTO 166
  53. *
  54. IFO1=MCHEL1.IFOCHE
  55. IFO2=MCHEL2.IFOCHE
  56. IF (IFO1.NE.IFO2) GOTO 166
  57. *
  58. GOTO 20
  59. *
  60. * GESTION DE L ERREUR
  61. *
  62. 166 CONTINUE
  63. C MOTERR(1:16)=MOT1//MOT3
  64. CALL ERREUR(329)
  65. GOTO 666
  66. *
  67. 20 CONTINUE
  68. N31=MCHEL1.INFCHE(/2)
  69. N32=MCHEL2.INFCHE(/2)
  70. N33=MAX(N31,N32)
  71. *
  72. DO 100 ISOUS=1,NSOUS1
  73. IPMAI1=MCHEL1.IMACHE(ISOUS)
  74. CONCH1=MCHEL1.CONCHE(ISOUS)
  75. DO 110 ISOUS2=1,NSOUS2
  76. IBB=ISOUS2
  77. IPMAI2=MCHEL2.IMACHE(ISOUS2)
  78. CONCH2=MCHEL2.CONCHE(ISOUS2)
  79. IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  80. *
  81. * Verification pour les INFCHEs
  82. *
  83. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  84. IF (IRTD.EQ.0) GOTO 166
  85. DO 21 IN3=1,N33
  86. IF (IN3.GT.N31) THEN
  87. INF1=0
  88. ELSE
  89. INF1=MCHEL1.INFCHE(ISOUS,IN3)
  90. ENDIF
  91. IF (IN3.GT.N32) THEN
  92. INF2=0
  93. ELSE
  94. INF2=MCHEL2.INFCHE(IBB ,IN3)
  95. ENDIF
  96. IF (IN3.EQ.4) THEN
  97. IF (INF1.EQ.INF2) GOTO 21
  98. IF (N31.GE.6) INF1=MCHEL1.INFCHE(ISOUS,6)
  99. IF (N32.GE.6) INF2=MCHEL2.INFCHE(IBB ,6)
  100. IF (INF1.EQ.0) INF1=1
  101. IF (INF2.EQ.0) INF1=1
  102. IF (INF1.EQ.INF2) GOTO 21
  103. GOTO 166
  104. ELSE IF (IN3.EQ.6) THEN
  105. IF (INF1.EQ.0) INF1=1
  106. IF (INF2.EQ.0) INF1=1
  107. IF (INF1.EQ.INF2) GOTO 21
  108. GOTO 166
  109. ELSE
  110. IF (INF1.EQ.INF2) GOTO 21
  111. GOTO 166
  112. ENDIF
  113. 21 CONTINUE
  114. GOTO 120
  115. ENDIF
  116. 110 CONTINUE
  117. GOTO 166
  118. *
  119. 120 CONTINUE
  120. *
  121. * ACTIVATION DU MELEME
  122. *
  123. MELEME=IPMAI1
  124. SEGACT MELEME
  125. NBELEM=NUM(/2)
  126. *
  127. MINTE=0
  128. IF (N31.GE.4) MINTE=MCHEL1.INFCHE(ISOUS,4)
  129. IF (MINTE.EQ.0.AND.N32.GE.4) MINTE=MCHEL2.INFCHE(ISOUS2,4)
  130. IF (MINTE.EQ.0) THEN
  131. NBPGAU=NUM(/1)
  132. ELSE
  133. SEGACT MINTE
  134. NBPGAU=POIGAU(/1)
  135. SEGDES MINTE
  136. ENDIF
  137. SEGDES MELEME
  138. *
  139. MCHAM1=MCHEL1.ICHAML(ISOUS )
  140. MCHAM2=MCHEL2.ICHAML(IBB )
  141. SEGACT MCHAM1,MCHAM2
  142. *
  143. NCOMP1=MCHAM1.IELVAL(/1)
  144. NCOMP2=MCHAM2.IELVAL(/1)
  145. IF (NCOMP1.NE.NCOMP2) THEN
  146. CALL ERREUR (103)
  147. GOTO 667
  148. ENDIF
  149. *
  150. DO 150 ICOMP=1,NCOMP1
  151. CALL PLACE(MCHAM2.NOMCHE,NCOMP2,IPLAC,MCHAM1.NOMCHE(ICOMP))
  152. IF (IPLAC.EQ.0) THEN
  153. MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  154. MOTERR(5:8)=MCHEL1.TITCHE
  155. CALL ERREUR (77)
  156. GOTO 667
  157. ENDIF
  158. *
  159. MELVA1=MCHAM1.IELVAL(ICOMP)
  160. MELVA2=MCHAM2.IELVAL(IPLAC)
  161. SEGACT MELVA1,MELVA2
  162. IF ( MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8'.AND.
  163. & MCHAM2.TYPCHE(IPLAC).EQ.'REAL*8' ) THEN
  164. DO 300 IB=1,NBELEM
  165. IBMN1=MIN(IB,MELVA1.VELCHE(/2))
  166. IBMN2=MIN(IB,MELVA2.VELCHE(/2))
  167. DO 400 IGAU=1,NBPGAU
  168. IGMN1=MIN(IGAU,MELVA1.VELCHE(/1))
  169. IGMN2=MIN(IGAU,MELVA2.VELCHE(/1))
  170. XXT1=MELVA1.VELCHE(IGMN1,IBMN1)
  171. XXT2=MELVA2.VELCHE(IGMN2,IBMN2)
  172. XX = FLO1*XXT1 + FLO2*XXT2
  173. XDRET = XDRET + XX*XX
  174. 400 CONTINUE
  175. 300 CONTINUE
  176. ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL'.AND.
  177. & MCHAM2.TYPCHE(IPLAC).EQ.'POINTEURLISTREEL' ) THEN
  178. DO 301 IB=1,NBELEM
  179. IBMN1=MIN(IB,MELVA1.IELCHE(/2))
  180. IBMN2=MIN(IB,MELVA2.IELCHE(/2))
  181. DO 401 IGAU=1,NBPGAU
  182. IGMN1=MIN(IGAU,MELVA1.IELCHE(/1))
  183. IGMN2=MIN(IGAU,MELVA2.IELCHE(/1))
  184. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  185. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  186. SEGACT MLREE1,MLREE2
  187. JG1=MLREE1.PROG(/1)
  188. JG2=MLREE2.PROG(/1)
  189. IF (JG1.NE.JG2) THEN
  190. SEGDES MLREE1,MLREE2
  191. MOTERR(1:4)='XTX '
  192. MOTERR(5:12)='MLREEL'
  193. CALL ERREUR (125)
  194. GOTO 668
  195. ENDIF
  196. DO 200 IPROG=1,JG1
  197. XXT1=MLREE1.PROG(IPROG)
  198. XXT2=MLREE2.PROG(IPROG)
  199. XX = FLO1*XXT1 + FLO2*FLO2
  200. XDRET = XDRET + XX*XX
  201. 200 CONTINUE
  202. SEGDES MLREE1,MLREE2
  203. 401 CONTINUE
  204. 301 CONTINUE
  205. ELSE
  206. MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  207. CALL ERREUR (197)
  208. GOTO 668
  209. ENDIF
  210. SEGDES MELVA1,MELVA2
  211. 150 CONTINUE
  212. SEGDES MCHAM1,MCHAM2
  213. 100 CONTINUE
  214. SEGDES MCHEL1,MCHEL2
  215. RETURN
  216. *
  217. 668 CONTINUE
  218. SEGDES MELVA1,MELVA2
  219. *
  220. 667 CONTINUE
  221. SEGDES MCHAM1,MCHAM2
  222. *
  223. 666 CONTINUE
  224. SEGDES MCHEL1,MCHEL2
  225. IRET=0
  226. RETURN
  227. END
  228.  
  229.  
  230.  
  231.  
  232.  

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