Télécharger pileps.eso

Retour à la liste

Numérotation des lignes :

  1. C PILEPS SOURCE PV 09/03/12 21:30:12 6325
  2. SUBROUTINE PILEPS
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. *
  6. * but : soit deux champs de epsilon il faut trouver le lambda max
  7. * tel que: eps1 + lambda*eps2 = signe(eps2) * crit
  8. *
  9. -INC SMCHAML
  10. -INC SMLREEL
  11. -INC CCOPTIO
  12. SEGMENT MZONG
  13. INTEGER NZONG(0)
  14. ENDSEGMENT
  15. SEGMENT MZON1
  16. INTEGER NZON1(0)
  17. ENDSEGMENT
  18. SEGMENT MZON2
  19. INTEGER NZON2(0)
  20. ENDSEGMENT
  21. SEGMENT ITAFF
  22. INTEGER JTAFF(0)
  23. ENDSEGMENT
  24. SEGMENT NOMID
  25. CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
  26. ENDSEGMENT
  27. SEGMENT MPTVAL
  28. INTEGER IPOS(NS) ,NSOF(NS)
  29. INTEGER IVAL(NCOSOU)
  30. CHARACTER*16 TYVAL(NCOSOU)
  31. ENDSEGMENT
  32. PARAMETER ( NINF=3 )
  33. INTEGER INFOS(NINF)
  34. CHARACTER*72 MOT
  35. CHARACTER*16 CONCH1,CONCH2
  36. * lecture des champs et du flottant
  37. CALL LIROBJ('MCHAML ',IPCHE1,1,IRETOU)
  38. IF(IERR.NE.0) RETURN
  39. CALL LIROBJ('MCHAML ',IPCHE2,1,IRETOU)
  40. IF(IERR.NE.0) RETURN
  41. CALL LIRREE(XCRIT,1,IRETOU)
  42. IF(IERR.NE.0) RETURN
  43. * fin de lecture
  44. XLAMB=1.D30
  45. IF(IPCHE1.NE.IPCHE2) GOTO 1000
  46. *
  47. * SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL
  48. *
  49. MCHELM=IPCHE1
  50. SEGACT MCHELM
  51. NSOUS = IMACHE(/1)
  52. *
  53. DO 110 IA=1,NSOUS
  54. MCHAML=ICHAML(IA)
  55. SEGACT MCHAML
  56. ICHAML(IA)=MCHAML
  57. DO 111 ICOMP=1,IELVAL(/1)
  58. MELVAL = IELVAL(ICOMP)
  59. SEGACT MELVAL
  60. N1PTEL=VELCHE(/1)
  61. IF (N1PTEL.EQ.0) THEN
  62. CALL ERREUR(19)
  63. SEGDES MELVAL,MCHAML, MCHELM
  64. RETURN
  65. ELSE
  66. N1EL=VELCHE(/2)
  67. DO 5 IGAU=1,N1PTEL
  68. XLA = 1.D50
  69. DO 5 IB=1,N1EL
  70. IF( VELCHE(IGAU,IB) .NE. 0. )
  71. * XLA=(SIGN( XCRIT,VELCHE(IGAU,IB))- VELCHE(IGAU,IB))
  72. * /VELCHE(IGAU,IB)
  73. IF ( XLA.LE.XLAMB ) XLAMB = XLA
  74. 5 CONTINUE
  75. ENDIF
  76. SEGDES MELVAL
  77. 111 CONTINUE
  78. SEGDES MCHAML
  79. 110 CONTINUE
  80. SEGDES MCHELM
  81. GOTO 777
  82. *
  83. * CAS GENERAL
  84. *
  85. 1000 CONTINUE
  86. MCHEL1=IPCHE1
  87. MCHEL2=IPCHE2
  88. SEGACT MCHEL1
  89. SEGACT MCHEL2
  90. IF(MCHEL1.IFOCHE.EQ.MCHEL2.IFOCHE) GOTO 3000
  91. *
  92. * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  93. * DE SS TYPE DIFFERENTS
  94. *
  95. MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  96. CALL ERREUR(99)
  97. IPCHAD=0
  98. GOTO 666
  99. *_______________________________________________________________________
  100. *
  101. * CAS GENERAL
  102. *_______________________________________________________________________
  103. *
  104. 3000 CONTINUE
  105. N3=MCHEL1.INFCHE(/2)
  106. NSOUS1=MCHEL1.ICHAML(/1)
  107. NSOUS2=MCHEL2.ICHAML(/1)
  108. *
  109. * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE
  110. *
  111. IF(NSOUS1.NE.NSOUS2) GOTO 4000
  112. *
  113. SEGINI ITAFF
  114. DO 17 ISOUS1=1,NSOUS1
  115. IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  116. CONCH1 = MCHEL1.CONCHE(ISOUS1)
  117. DO 18 ISOUS2=1,NSOUS2
  118. ISOUS=ISOUS2
  119. IPMAI2= MCHEL2.IMACHE(ISOUS)
  120. CONCH2= MCHEL2.CONCHE(ISOUS)
  121. IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  122. *
  123. * VERIFICATION POUR LES INFCHE
  124. *
  125. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  126. IF (IRTD.EQ.0) GOTO 18
  127. IMINT1=0
  128. IMINT2=0
  129. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  130. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  131. IF (IMINT1.EQ.IMINT2) GOTO 171
  132. IMINT1=1
  133. IMINT2=1
  134. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  135. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  136. IF (IMINT1.EQ.0) IMINT1=1
  137. IF (IMINT2.EQ.0) IMINT2=1
  138. IF (IMINT1.EQ.IMINT2) GOTO 171
  139. *
  140. * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  141. * DE SS TYPE DIFFERENTS
  142. *
  143. CALL ERREUR(19)
  144. SEGDES MCHEL1,MCHEL2
  145. SEGSUP ITAFF
  146. RETURN
  147. ENDIF
  148. 18 CONTINUE
  149. SEGSUP ITAFF
  150. GOTO 4000
  151. *
  152. 171 CONTINUE
  153. JTAFF(**)=MCHEL2.ICHAML(ISOUS)
  154. 17 CONTINUE
  155. *
  156. * ON A TROUVE UNE BIJECTION ET ON VECTORISE
  157. *
  158. N1=NSOUS1
  159. DO 400 ISOUS=1,NSOUS1
  160.  
  161. MCHAML=MCHEL1.ICHAML(ISOUS)
  162. *
  163. SEGACT MCHAML
  164. IPCHA=MCHAML
  165. *
  166. MCHAM2=JTAFF(ISOUS)
  167. SEGACT MCHAM2
  168. IPCHA2=MCHAM2
  169. *
  170. CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT)
  171. IF (IPCHA.EQ.0) THEN
  172. SEGSUP ITAFF
  173. GOTO 9990
  174. ENDIF
  175. *
  176. SEGDES MCHAML,MCHAM2
  177. 400 CONTINUE
  178. SEGDES MCHEL1,MCHEL2
  179. SEGSUP ITAFF
  180. GOTO 777
  181. *_______________________________________________________________________
  182. *
  183. * ON A PAS TROUVE DE BIJECTION
  184. *_______________________________________________________________________
  185. *
  186. 4000 CONTINUE
  187. SEGINI MZONG,MZON1,MZON2
  188. DO 500 ISOUS1=1,NSOUS1
  189. NZONG(**)=MCHEL1.IMACHE(ISOUS1)
  190. NZON1(**)=ISOUS1
  191. NZON2(**)=0
  192. 500 CONTINUE
  193. IWRN=0
  194. DO 510 ISOUS2=1,NSOUS2
  195. IPMAI2 = MCHEL2.IMACHE(ISOUS2)
  196. CONCH2 = MCHEL2.CONCHE(ISOUS2)
  197. DO 520 ISOUS1=1,NSOUS1
  198. IPMAI1= MCHEL1.IMACHE(ISOUS1)
  199. CONCH1= MCHEL1.CONCHE(ISOUS1)
  200. IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN
  201. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  202. IF (IRTD.EQ.0) GOTO 520
  203. *
  204. * VERIFICATION POUR LES MINTES
  205. *
  206. IF ( MCHEL1.INFCHE(ISOUS1,4).EQ.
  207. & MCHEL2.INFCHE(ISOUS2,4) ) GOTO 530
  208. *
  209. * ERREUR SUR LES SUPPORTS DES MCHAML
  210. *
  211. CALL ERREUR(19)
  212. SEGDES MCHEL1,MCHEL2
  213. SEGSUP MZONG,MZON1,MZON2
  214. RETURN
  215. *
  216. ENDIF
  217. 520 CONTINUE
  218. IWRN=1
  219. NZONG(**)=IPMAI2
  220. NZON1(**)=0
  221. NZON2(**)=ISOUS2
  222. GOTO 510
  223. *
  224. 530 CONTINUE
  225. NZON2(ISOUS1)=ISOUS2
  226. 510 CONTINUE
  227. *
  228. * WARNING LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
  229. *
  230. IF(IWRN.EQ.1) CALL ERREUR(103)
  231. NSOUS=NZONG(/1)
  232. N1=NSOUS
  233. *
  234. DO 540 ISOUS=1,NSOUS
  235. IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
  236. *
  237. IF(NZON1(ISOUS).NE.0) THEN
  238. MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) )
  239. SEGACT MCHAML
  240. ENDIF
  241. IF(NZON2(ISOUS).NE.0) THEN
  242. MCHAML=MCHEL2.ICHAML( NZON2(ISOUS) )
  243. SEGACT MCHAML
  244. ENDIF
  245. *
  246. *
  247. GOTO 540
  248. *
  249. 550 CONTINUE
  250. MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) )
  251. SEGACT MCHAML
  252. IPCHAD=MCHAML
  253. MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  254. SEGACT MCHAM2
  255. IPCHA2=MCHAM2
  256. *
  257. CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT)
  258. IF (IPCHA.EQ.0) THEN
  259. SEGSUP MZONG,MZON1,MZON2
  260. GOTO 9990
  261. ENDIF
  262. *
  263. SEGDES MCHAML,MCHAM2
  264. 540 CONTINUE
  265. *
  266. SEGSUP MZONG,MZON1,MZON2
  267. GOTO 666
  268. *
  269. 9990 CONTINUE
  270. *
  271. * ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  272. *
  273. SEGDES MCHEL1,MCHEL2,MCHAM2, MCHAML
  274. SEGSUP ITAFF
  275.  
  276. RETURN
  277. *
  278. 666 CONTINUE
  279. SEGDES MCHEL1,MCHEL2
  280. 777 CONTINUE
  281. CALL ECRREE ( XLAMB)
  282. RETURN
  283. END
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  

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