Télécharger manuc8.eso

Retour à la liste

Numérotation des lignes :

  1. C MANUC8 SOURCE BP208322 16/11/18 21:19:02 9177
  2. SUBROUTINE MANUC8
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. -INC CCGEOME
  6. -INC CCOPTIO
  7. -INC SMCHAML
  8. -INC SMLREEL
  9. -INC SMEVOLL
  10. -INC SMTABLE
  11. * attention la dimension de infos doit etre suppereiur a
  12. * deuxieme dimension de infche
  13. dimension infos(20)
  14. SEGMENT IDONN
  15. REAL*8 XABS(NDI)
  16. INTEGER IPC(NDI)
  17. ENDSEGMENT
  18. SEGMENT ITAFF
  19. INTEGER JTAFF(NNSO,NNCH)
  20. ENDSEGMENT
  21. CHARACTER*72 MOT
  22. CHARACTER*16 CONCH1,CONCH2
  23. CHARACTER*16 NCOPO,NOMCH1
  24. *
  25. * LECTURE DES DONNEES
  26. *
  27. CALL LIRCHA(NCOPO,1,ILO)
  28. IF(IERR.NE.0) RETURN
  29. *
  30. * LECTURE EVENTUELLE D'UNE TABLE et traitement
  31. *
  32. CALL LIROBJ('TABLE ',MTABLE,0,IRETOU)
  33. IF(IRETOU.NE.0) THEN
  34. SEGACT MTABLE
  35. NDI = MLOTAB
  36. SEGINI IDONN
  37. NVR=0
  38. DO 7003 I=1,MLOTAB
  39. IF(MTABTI(I).NE.'ENTIER '.AND.MTABTI(I).NE.'FLOTTANT')
  40. $ GO TO 7003
  41. IF(MTABTV(I).NE.'MCHAML ') GO TO 7003
  42. NVR=NVR+1
  43. IF(MTABTI(I).EQ.'ENTIER ') THEN
  44. XABS(NVR)=MTABII(I)
  45. ELSE
  46. XABS(NVR)= RMTABI(I)
  47. ENDIF
  48. IPC(NVR)=MTABIV(I)
  49. 7003 CONTINUE
  50. NDI=NVR
  51. IF(NDI.NE.MLOTAB) SEGADJ IDONN
  52. ELSE
  53. *
  54. * LECTURE DES COUPLES ( FLOT MCHAML)
  55. *
  56. NVR=0
  57. NDI=20
  58. SEGINI IDONN
  59. 7001 CONTINUE
  60. CALL LIRREE(XVAL,0,IRETOU)
  61. IF( IRETOU.EQ.0) GO TO 7002
  62. CALL LIROBJ('MCHAML ',IPCH,1,IRETOU)
  63. IF(IERR.NE.0) RETURN
  64. NVR=NVR+1
  65. IF(NVR.GT.NDI) THEN
  66. NDI = NDI +20
  67. SEGADJ IDONN
  68. ENDIF
  69. XABS(NVR)=XVAL
  70. IPC(NVR)=IPCH
  71. GO TO 7001
  72. 7002 CONTINUE
  73. NDI=NVR
  74. IF(NDI.NE.IPC(/1))SEGADJ IDONN
  75. ENDIF
  76. *
  77. * fabrication du listreel
  78. *
  79. JG = NDI
  80. SEGINI MLREEL
  81. DO 7020 I=1,NDI
  82. PROG(I)=XABS(I)
  83. 7020 CONTINUE
  84. MLABS=MLREEL
  85. SEGDES MLREEL
  86.  
  87. * on connait la liste XABS (I), IPC(I) quelques verification
  88. *
  89. MCHEL1=IPC(1)
  90. SEGACT MCHEL1
  91. if( mchel1.infche(/2).gt.20) then
  92. write(6,*) 'MANUC8 :probleme de dimension tableau infos '
  93. call erreur (5)
  94. return
  95. endif
  96. DO 7009 IK=1,MCHEL1.ICHAML(/1)
  97. MCHAML=MCHEL1.ICHAML(IK)
  98. SEGACT MCHAML
  99. IF(IELVAL(/1).NE.1) THEN
  100. CALL ERREUR (21)
  101. ENDIF
  102. 7009 CONTINUE
  103. NOMCH1=NOMCHE(1)
  104. DO 7100 I=2,IPC(/1)
  105. MCHEL2=IPC(I)
  106. SEGACT MCHEL2
  107. if( mchel2.infche(/2).gt.20) then
  108. write(6,*) 'MANUC8 :probleme de dimension tableau infos '
  109. call erreur (5)
  110. return
  111. endif
  112. IF(MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
  113. *
  114. * ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS
  115. * DE SS TYPE DIFFERENTS
  116. *
  117. MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  118. CALL ERREUR(99)
  119. RETURN
  120. ENDIF
  121. DO 7004 IK=1,MCHEL2.ICHAML(/1)
  122. MCHAML=MCHEL2.ICHAML(IK)
  123. SEGACT MCHAML
  124. IF(IELVAL(/1).NE.1) THEN
  125. CALL ERREUR (21)
  126. ENDIF
  127. IF(NOMCHE(1).NE.NOMCH1) THEN
  128. CALL ERREUR (21)
  129. ENDIF
  130. 7004 CONTINUE
  131. 7100 CONTINUE
  132. MOT=MCHEL1.TITCHE
  133. L1=MCHEL1.TITCHE(/1)
  134. N3=MCHEL1.INFCHE(/2)
  135. NSOUS1=MCHEL1.ICHAML(/1)
  136. *
  137. * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE
  138. *
  139. NNCH=IPC(/1)
  140. NNSO=NSOUS1
  141. SEGINI ITAFF
  142. DO 7005 IKK=2,NNCH
  143. MCHEL2=IPC(IKK)
  144. IF( MCHEL2.ICHAML(/1).NE.NSOUS1) THEN
  145. CALL ERREUR(19)
  146. RETURN
  147. ENDIF
  148. 7005 CONTINUE
  149. DO 17 ISOUS1=1,NSOUS1
  150. IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  151. CONCH1 = MCHEL1.CONCHE(ISOUS1)
  152. MCHAML=MCHEL1.ICHAML(ISOUS1)
  153. JTAFF(ISOUS1,1)=IELVAL(1)
  154. DO 7006 IK=2,IPC(/1)
  155. MCHEL2=IPC(IK)
  156. DO 18 ISOUS2=1,NSOUS1
  157. ISOUS=ISOUS2
  158. IPMAI2= MCHEL2.IMACHE(ISOUS)
  159. CONCH2= MCHEL2.CONCHE(ISOUS)
  160. IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  161. *
  162. * VERIFICATION POUR LES INFCHE
  163. *
  164. CALL IDENT (IPMAI1,CONCH1,mchel1,mchel2,INFOS,IRTD)
  165. IF (IRTD.EQ.0) GOTO 18
  166. IMINT1=0
  167. IMINT2=0
  168. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  169. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  170. IF (IMINT1.EQ.IMINT2) GOTO 171
  171. IMINT1=1
  172. IMINT2=1
  173. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  174. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  175. IF (IMINT1.EQ.0) IMINT1=1
  176. IF (IMINT2.EQ.0) IMINT2=1
  177. IF (IMINT1.EQ.IMINT2) GOTO 171
  178. *
  179. * ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS
  180. * DE SS TYPE DIFFERENTS
  181. *
  182. MOTERR(1:8)=MCHEL1.TITCHE
  183. MOTERR(9:16)=MCHEL2.TITCHE
  184. CALL ERREUR(329)
  185. SEGDES MCHEL1,MCHEL2
  186. SEGSUP ITAFF
  187. RETURN
  188. ENDIF
  189. 18 CONTINUE
  190. SEGSUP ITAFF
  191. CALL ERREUR(19)
  192. RETURN
  193. *
  194. 171 CONTINUE
  195. MCHAML= MCHEL2.ICHAML(ISOUS)
  196. JTAFF(ISOUS1,IK)=IELVAL(1)
  197. 7006 CONTINUE
  198. 17 CONTINUE
  199. *
  200. * ON A TROUVE UNE BIJECTION ET ON VECTORISE
  201. *
  202. N1=NSOUS1
  203. N1PTEL=0
  204. N1EL=0
  205. N=1
  206. SEGINI KEVOLL
  207. NUMEVY='REEL'
  208. TYPX='LISTREEL'
  209. TYPY='LISTREEL'
  210. NOMEVX=NCOPO
  211. NOMEVY=NOMCH1
  212. IPROGX=MLABS
  213. NUMEVX=IDCOUL
  214. KEVOL1=KEVOLL
  215. SEGINI MCHELM
  216. TITCHE=MOT
  217. IFOCHE=IFOUR
  218. DO 400 ISOUS=1,NSOUS1
  219. IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  220. CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  221. DO 401 N33=1,N3
  222. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  223. 401 CONTINUE
  224. MCHAM1=MCHEL1.ICHAML(ISOUS)
  225. SEGINI,MCHAML=MCHAM1
  226. ICHAML(ISOUS)=MCHAML
  227. TYPCHE='POINTEUREVOLUTIO'
  228. MELVA1=MCHAM1.IELVAL(1)
  229. SEGACT MELVA1
  230. N2PTEL=MELVA1.VELCHE(/1)
  231. N2EL=MELVA1.VELCHE(/2)
  232. SEGINI MELVAL
  233. IELVAL(1)=MELVAL
  234. SEGDES MCHAML
  235. DO 7021 I=1,NNCH
  236. MELVA1=JTAFF(ISOUS,I)
  237. SEGACT MELVA1
  238. 7021 CONTINUE
  239. DO 7010 IAEL=1,N2EL
  240. DO 7010 IAPT=1,N2PTEL
  241. SEGINI MEVOLL
  242. ITYEVO='REEL'
  243. IELCHE(IAPT,IAEL)=MEVOLL
  244. SEGINI,KEVOLL=KEVOL1
  245. SEGINI MLREEL
  246. IPROGY=MLREEL
  247. IEVOLL(1)= KEVOLL
  248. DO 7011 I=1,NNCH
  249. MELVA1=JTAFF(ISOUS,I)
  250. PROG(I)= MELVA1.VELCHE(IAPT,IAEL)
  251. 7011 CONTINUE
  252. SEGDES MLREEL
  253. SEGDES KEVOLL,MEVOLL
  254. 7010 CONTINUE
  255. DO 7022 I=1,NNCH
  256. MELVA1=JTAFF(ISOUS,I)
  257. SEGDES MELVA1
  258. 7022 CONTINUE
  259. SEGDES MELVAL
  260. 400 CONTINUE
  261. SEGDES MCHELM
  262. MRES=MCHELM
  263. *
  264. * desactivation
  265. *
  266. SEGSUP ITAFF
  267. DO 7030 I=1,IPC(/1)
  268. MCHELM=IPC(I)
  269. DO 7031 IK=1,ICHAML(/1)
  270. MCHAML=ICHAML(IK)
  271. SEGDES MCHAML
  272. 7031 CONTINUE
  273. SEGDES MCHELM
  274. 7030 CONTINUE
  275. SEGSUP IDONN
  276. CALL ECROBJ('MCHAML ',MRES)
  277. RETURN
  278. END
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  

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