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

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