Télécharger ordonn.eso

Retour à la liste

Numérotation des lignes :

  1. C ORDONN SOURCE JC220346 16/09/19 21:15:01 9094
  2. SUBROUTINE ORDONN
  3. ************************************************************************
  4. *
  5. * O R D O N N
  6. * -----------
  7. *
  8. * SOUS-PROGRAMME ASSOCIE A LA DIRECTIVE "ORDONNER"
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * L'OPERATEUR ORDONNER RANGE LE CONTENU D'UN OBJET ORDONNABLE.
  14. *
  15. *
  16. * PHRASE D'APPEL (EN GIBIANE):
  17. * ----------------------------
  18. *
  19. * Tri d'1 objet LISTENTI, LISTREEL ou LISTMOTS :
  20. *
  21. * OBJ2 = ORDO |('CROI')| ('ABSO') ('NOCA') ('UNIQ' (FLOT1)) OBJ1 ;
  22. * |('DECR')|
  23. *
  24. * ----------
  25. *
  26. * Tri de 1 ou plusieurs objets LISTENTI, LISTREEL et/ou LISTMOTS :
  27. *
  28. * TAB2 = ORDO |('CROI')| ('ABSO') ('NOCA') TAB1 MOT1 ;
  29. * |('DECR')|
  30. *
  31. * RES1 (.. RESN) = ORDO |('CROI')| ('ABSO') ('NOCA') LIS1 (...LISN) ;
  32. * |('DECR')|
  33. * |('COUT' (|'HONG'|) LIS0)|
  34. * |'COMP'|
  35. *
  36. * ----------
  37. *
  38. * Tri d'objets EVOLUTION :
  39.  
  40. * EVOL2 = ORDO |('CROI')| ('ABSO') EVOL1 ;
  41. * |('DECR')|
  42. *
  43. * ----------
  44. *
  45. * Tri d'objets MAILLAGE :
  46. *
  47. * MAIL2 = ORDO MAIL1 ;
  48. *
  49. *
  50. * SOUS-PROGRAMMES APPELES:
  51. * ------------------------
  52. *
  53. * ORDON1, ORDON2, ORDON3 ,ORDON4
  54. *
  55. *
  56. * HISTORIQUE:
  57. * -----------
  58. *
  59. * PASCAL MANIGOT 19 MARS 1985
  60. *
  61. * OPTION "ABSOLU" AJOUTEE LE 23 AVRIL 1985 (P. MANIGOT)
  62. *
  63. * JCARDO 11/09/2012 => ORDO PASSE DE DIRECTIVE A OPERATEUR
  64. *
  65. * JCARDO 15/12/2014 => ACCEPTE LES LISTMOTS, TRI NOMBRE QCQ OBJETS,
  66. * OPTIONS NOCA + FLOT1, MERGE SORT SI N>100
  67. *
  68. * BP 24/06/2016 => AJOUT OPTION COUT POUR LE CALCUL DE LA PERMUTATION
  69. *
  70. ************************************************************************
  71. *
  72. IMPLICIT INTEGER(I-N)
  73. IMPLICIT REAL*8(A-H,O-Z)
  74. -INC PPARAM
  75. -INC CCOPTIO
  76. -INC CCREEL
  77. -INC SMTABLE
  78. -INC SMLREEL
  79. -INC SMLENTI
  80. -INC SMLMOTS
  81. -INC SMEVOLL
  82. -INC SMELEME
  83. *
  84. PARAMETER (NBRTYP = 5)
  85. PARAMETER (NBMOTS = 6)
  86. PARAMETER (NBALGO = 2)
  87. *
  88. CHARACTER*8 LISTYP(NBRTYP),MONTYP,MONTY2,CHA8,COUTYP
  89. CHARACTER*4 LISMOT(NBMOTS),LISALG(NBALGO)
  90. CHARACTER*4 CHA4
  91. *
  92. SEGMENT MPILO
  93. INTEGER ITYOBJ(NBOBJ)
  94. INTEGER IPROBJ(NBOBJ)
  95. ENDSEGMENT
  96. *
  97. LOGICAL CROISS,ABSOLU,STRICT,SENCAS,ZCOUT
  98. *
  99. DATA LISTYP/'LISTREEL','LISTENTI','LISTMOTS','EVOLUTIO',
  100. & 'MAILLAGE'/
  101. DATA LISMOT/'CROI','DECR','ABSO','UNIQ','NOCA','COUT'/
  102. DATA LISALG/'HONG','COMP'/
  103. *
  104. CHARACTER*26 MINU,MAJU
  105. DATA MINU/'abcdefghijklmnopqrstuvwxyz'/
  106. DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  107. *
  108. *
  109. *
  110. * +---------------------------------------------------------------+
  111. * | |
  112. * | L E C T U R E D E S A R G U M E N T S |
  113. * | |
  114. * +---------------------------------------------------------------+
  115. *
  116. CROISS = .TRUE.
  117. ABSOLU = .FALSE.
  118. STRICT = .FALSE.
  119. SENCAS = .TRUE.
  120. ZCOUT = .FALSE.
  121. ICRIT = 0
  122. IALGO = 0
  123. ICROI = 0
  124. *
  125. *
  126. NBOBJ=0
  127. 100 CONTINUE
  128.  
  129. CALL QUETYP(MONTYP,0,IRETOU)
  130. IF (IERR.NE.0) RETURN
  131. IF (IRETOU.EQ.0) GOTO 21
  132.  
  133. * ==========================================================
  134. * MOTS-CLES : 'CROI', 'DECR', 'ABSO', 'UNIQ', 'NOCA', 'COUT'
  135. * ==========================================================
  136.  
  137. IF (MONTYP.EQ.'MOT') THEN
  138. CALL LIRCHA(CHA4,1,LL1)
  139. IF (IERR.NE.0) RETURN
  140. CALL CHRMOT(LISMOT,NBMOTS,CHA4,NUMMOT)
  141. *
  142. * => 'CROI'
  143. IF (NUMMOT.EQ.1) THEN
  144. ICROI = 1
  145. CROISS = .TRUE.
  146. *
  147. * => 'DECR'
  148. ELSEIF (NUMMOT.EQ.2) THEN
  149. CROISS = .FALSE.
  150. *
  151. * => 'ABSO'
  152. ELSEIF (NUMMOT.EQ.3) THEN
  153. ABSOLU = .TRUE.
  154. *
  155. * => 'UNIQ' (FLOT1)
  156. ELSEIF (NUMMOT.EQ.4) THEN
  157. STRICT = .TRUE.
  158. MONTY2 = ' '
  159. CALL QUETYP(MONTY2,0,IRETOU)
  160. IF (IRETOU.EQ.0) GOTO 21
  161. IF (MONTY2.EQ.'FLOTTANT') CALL LIRREE(CRIT,1,ICRIT)
  162. IF (IERR.NE.0) RETURN
  163. *
  164. * => 'NOCA'
  165. ELSEIF (NUMMOT.EQ.5) THEN
  166. SENCAS = .FALSE.
  167. *
  168. * => 'COUT' (ALGO) LISCOU
  169. ELSEIF (NUMMOT.EQ.6) THEN
  170. ZCOUT = .TRUE.
  171. *
  172. * Lecture eventuelle de l'algo : COMPLET, HONGROIS ...
  173. CALL LIRMOT(LISALG,NBALGO,IALGO,0)
  174. *
  175. * Lecture du LISTENTI ou LISTREEL des couts obligatoirement
  176. * juste apres le mot-cle 'COUT'
  177. CALL QUETYP(COUTYP,1,IRETOU)
  178. IF (IRETOU.EQ.0.OR.(COUTYP.NE.'LISTENTI'.AND.
  179. & COUTYP.NE.'LISTREEL')) THEN
  180. * "On attend un des objets : %M1:8 %M9:16 ..."
  181. MOTERR(1:40)='LISTENTI LISTREEL'
  182. CALL ERREUR(471)
  183. RETURN
  184. ENDIF
  185. IF (IERR.NE.0) RETURN
  186. CALL LIROBJ(COUTYP,ICOUT,1,IRET1)
  187. ELSE
  188. * "Syntaxe incorrecte : on attend %m1:30"
  189. MOTERR(1:30)='CROI DECR ABSO UNIQ NOCA COUT'
  190. CALL ERREUR(881)
  191. RETURN
  192. ENDIF
  193. *
  194. *
  195. * ===================================
  196. * LECTURE DU OU DES OBJETS A ORDONNER
  197. * ===================================
  198. *
  199. * ********************************
  200. * Lecture d'un objet de type TABLE
  201. * ********************************
  202. ELSEIF (MONTYP.EQ.'TABLE') THEN
  203. *
  204. IF (NBOBJ.NE.0) THEN
  205. * "On ne veut pas d'objet de type %m1:8"
  206. MOTERR(1:8)='TABLE '
  207. CALL ERREUR(39)
  208. RETURN
  209. ENDIF
  210. *
  211. * LECTURE DE LA TABLE
  212. * -------------------
  213. CALL LIROBJ('TABLE',MTABLE,1,IRETOU)
  214. IF (IERR.NE.0) RETURN
  215.  
  216. * LECTURE DE L'INDICE DE LA LISTE A TRIER
  217. * ---------------------------------------
  218. MONTY2 = ' '
  219. CALL QUETYP(MONTY2,0,IRETOU)
  220. * "Il manque la donnee de l'indice de l'objet TABLE"
  221. IF (IRETOU.EQ.0) CALL ERREUR(1043)
  222. IF (IERR.NE.0) RETURN
  223. IF (MONTY2.EQ.'FLOTTANT') THEN
  224. CALL LIRREE(XINDIC,1,IRETOU)
  225. ELSE
  226. CALL LIROBJ(MONTY2,IINDIC,1,IRETOU)
  227. ENDIF
  228. *
  229. * BOUCLE SUR LES OBJETS DE LA TABLE
  230. * ---------------------------------
  231. SEGACT,MTABLE
  232. NBOBJ=MLOTAB
  233. IF (NBOBJ.EQ.0) THEN
  234. * "La table est vide"
  235. CALL ERREUR(215)
  236. RETURN
  237. ENDIF
  238. SEGINI,MPILO
  239. IINCLE=0
  240. DO I=1,MLOTAB
  241. *
  242. * STOCKAGE DU TYPE DE L'OBJET (SI VALIDE) DANS MPILO
  243. CHA8 = MTABTV(I)
  244. DO J=1,3
  245. IF (CHA8.EQ.LISTYP(J)) THEN
  246. ITYOBJ(I)=J
  247. GOTO 14
  248. ENDIF
  249. ENDDO
  250. * "On ne veut pas d'objet de type %m1:8"
  251. MOTERR(1:8)=CHA8
  252. CALL ERREUR(39)
  253. RETURN
  254. 14 CONTINUE
  255.  
  256. * STOCKAGE DU POINTEUR DE L'OBJET DANS MPILO
  257. IPROBJ(I)=MTABIV(I)
  258. *
  259. * EST-CE LA LISTE A TRIER ?
  260. IF (MTABTI(I).EQ.MONTY2) THEN
  261. IF ((MONTY2.EQ.'FLOTTANT'.AND.RMTABI(I).EQ.XINDIC)
  262. & .OR.MTABII(I).EQ.IINDIC) THEN
  263. * IINCLE = rang de la liste principale dans MPILO
  264. * NUMLIS = type de la liste principale
  265. * IPLIST = pointeur vers la liste principale
  266. IINCLE = I
  267. NUMLIS = J
  268. IPLIST = IPROBJ(I)
  269. ENDIF
  270. ENDIF
  271. *
  272. ENDDO
  273. IF (IINCLE.EQ.0) THEN
  274. * "Erreur dans la recherche de l'indice d'une table"
  275. CALL ERREUR(314)
  276. RETURN
  277. ENDIF
  278. *
  279. * *********************************************
  280. * Autres objets : LISTxxxx, MAILLAGE, EVOLUTION
  281. * *********************************************
  282. ELSE
  283. MTABLE=0
  284. IINCLE=1
  285. *
  286. * LECTURE DE L'OBJET PRINCIPAL
  287. * ----------------------------
  288. IF (NBOBJ.EQ.0) THEN
  289. DO 10 NUMLIS=1,NBRTYP
  290. IF (MONTYP.EQ.LISTYP(NUMLIS)) GOTO 11
  291. 10 CONTINUE
  292. * "On ne veut pas d'objet de type %m1:8"
  293. MOTERR(1:8)=MONTYP
  294. CALL ERREUR(39)
  295. RETURN
  296. 11 CONTINUE
  297. CALL LIROBJ(MONTYP,IPLIST,1,IRETOU)
  298. IF (IERR.NE.0) RETURN
  299. NBOBJ=1
  300. IF (NUMLIS.LE.3) THEN
  301. SEGINI,MPILO
  302. ITYOBJ(1)=NUMLIS
  303. IPROBJ(1)=IPLIST
  304. ENDIF
  305. ELSE
  306. IF (NUMLIS.GT.3) THEN
  307. * "On ne veut pas d'objet de type %m1:8"
  308. MOTERR(1:8)=MONTYP
  309. CALL ERREUR(39)
  310. RETURN
  311. ENDIF
  312. ENDIF
  313. *
  314. * LECTURE D'EVENTUELS OBJETS A ORDONNER EN MEME TEMPS
  315. * ---------------------------------------------------
  316. IF (NUMLIS.LE.3) THEN
  317. 20 CONTINUE
  318. MONTY2 = ' '
  319. CALL QUETYP(MONTY2,0,IRETOU)
  320. IF (IERR.NE.0) RETURN
  321. IF (IRETOU.EQ.0) GOTO 21
  322. IF (MONTY2.EQ.'MOT') GOTO 100
  323. DO 110 NUMLI2=1,3
  324. IF (MONTY2.EQ.LISTYP(NUMLI2)) GOTO 111
  325. 110 CONTINUE
  326. * "On ne veut pas d'objet de type %m1:8"
  327. MOTERR(1:8)=MONTY2
  328. CALL ERREUR(39)
  329. RETURN
  330. 111 CONTINUE
  331. CALL LIROBJ(MONTY2,IPOBJ,1,IRETOU)
  332. IF (IERR.NE.0) RETURN
  333. NBOBJ = NBOBJ + 1
  334. SEGADJ,MPILO
  335. ITYOBJ(NBOBJ) = NUMLI2
  336. IPROBJ(NBOBJ) = IPOBJ
  337. GOTO 20
  338. ENDIF
  339. *
  340. ENDIF
  341. *
  342. * LECTURE DE L'OBJET SUIVANT
  343. GOTO 100
  344.  
  345. 21 CONTINUE
  346.  
  347. * Dans le cas de l'option COUT, le tri porte sur la liste LISCOU et
  348. * non pas sur tous les objets stockes dans IPROBJ
  349. IF (ZCOUT) THEN
  350. NUMLI2 = NUMLIS
  351. IF (COUTYP.EQ.'LISTREEL') NUMLIS = -1
  352. IF (COUTYP.EQ.'LISTENTI') NUMLIS = -2
  353. IINCLE = 0
  354. ENDIF
  355.  
  356. * ERREUR : aucun objet a ordonner n'a ete fourni...
  357. IF (NBOBJ.EQ.0) THEN
  358. * "On attend un des objets : %M1:8 %M9:16 %M17:24 %M25:32 %M33:40"
  359. MOTERR(1:40)='LISTxxxxEVOLUTIOMAILLAGEou TABLE'
  360. CALL ERREUR(471)
  361. RETURN
  362. ENDIF
  363.  
  364. * VERIFICATION DES INCOMPATIBILITES ENTRE OPTIONS ET DONNEES
  365. * **********************************************************
  366. IF (ICROI.EQ.1.AND.(NUMLIS.EQ.5.OR.ZCOUT)) THEN
  367. * "Option %m1:8 incompatible avec les données"
  368. MOTERR(1:8) = 'CROI'
  369. CALL ERREUR(803)
  370. RETURN
  371. ENDIF
  372.  
  373. IF (.NOT.CROISS.AND.(NUMLIS.EQ.5.OR.ZCOUT)) THEN
  374. * "Option %m1:8 incompatible avec les données"
  375. MOTERR(1:8) = 'DECR'
  376. CALL ERREUR(803)
  377. RETURN
  378. ENDIF
  379.  
  380. IF (ABSOLU.AND.(NUMLIS.EQ.3.OR.NUMLIS.EQ.5.OR.ZCOUT)) THEN
  381. * "Option %m1:8 incompatible avec les données"
  382. MOTERR(1:8) = 'ABSO'
  383. CALL ERREUR(803)
  384. RETURN
  385. ENDIF
  386.  
  387. IF (STRICT.AND.(NBOBJ.GT.1.OR.NUMLIS.LT.1.OR.NUMLIS.GT.3)) THEN
  388. * "Option %m1:8 incompatible avec les données"
  389. MOTERR(1:8) = 'UNIQ'
  390. CALL ERREUR(803)
  391. RETURN
  392. ENDIF
  393.  
  394. IF (.NOT.SENCAS.AND.(NUMLIS.NE.3.OR.ZCOUT)) THEN
  395. * "Option %m1:8 incompatible avec les données"
  396. MOTERR(1:8) = 'NOCA'
  397. CALL ERREUR(803)
  398. RETURN
  399. ENDIF
  400.  
  401. IF (ZCOUT.AND.(NUMLI2.LT.1.OR.NUMLI2.GT.3)) THEN
  402. * "Option %m1:8 incompatible avec les données"
  403. MOTERR(1:8) = 'COUT'
  404. CALL ERREUR(803)
  405. RETURN
  406. ENDIF
  407. *
  408. *
  409. *
  410. *
  411. * +---------------------------------------------------------------+
  412. * | |
  413. * | T R I D E S O B J E T S |
  414. * | |
  415. * +---------------------------------------------------------------+
  416. *
  417. *
  418. * +-----------------------------------------------------+
  419. * | O B J E T L I S T x x x x |
  420. * +-----------------------------------------------------+
  421. *
  422. IF (NUMLIS.LE.3) THEN
  423.  
  424. * TRI DU PREMIER OBJET ET MEMORISATION EVENTUELLE DE L'ORDRE...
  425. * =============================================================
  426.  
  427. * Objet LISTREEL
  428. * **************
  429. IF (NUMLIS.EQ.1) THEN
  430. MLREE1 = IPLIST
  431. SEGINI,MLREEL=MLREE1
  432. IPROBJ(IINCLE) = MLREEL
  433.  
  434. LLIST = PROG(/1)
  435. IF (LLIST.EQ.0) THEN
  436. SEGDES,MLREEL
  437. GOTO 150
  438. ENDIF
  439.  
  440. * Creation du LISTREEL ordonne
  441. IF (NBOBJ.GT.1) THEN
  442. IORDRE=1
  443. ELSE
  444. IORDRE=0
  445. ENDIF
  446. CALL ORDON1(MLREEL,CROISS,ABSOLU,IORDRE)
  447. * SEGDES,MLREEL
  448.  
  449. * Memorisation de l'ordre
  450. MLENTI=IORDRE
  451. IF (NBOBJ.GT.1) SEGACT,MLENTI
  452. *
  453. *
  454. * Objet LISTENTI
  455. * **************
  456. ELSEIF (NUMLIS.EQ.2) THEN
  457. MLENT1 = IPLIST
  458. SEGINI,MLENTI=MLENT1
  459. IPROBJ(IINCLE) = MLENTI
  460. *
  461. LLIST = LECT(/1)
  462. IF (LLIST.EQ.0) THEN
  463. SEGDES,MLENTI
  464. GOTO 150
  465. ENDIF
  466. *
  467. * Creation du LISTENTI ordonne
  468. IF (NBOBJ.GT.1) THEN
  469. IORDRE=1
  470. ELSE
  471. IORDRE=0
  472. ENDIF
  473. CALL ORDON2(MLENTI,CROISS,ABSOLU,IORDRE)
  474. * SEGDES,MLENTI
  475.  
  476. * Memorisation de l'ordre
  477. MLENTI=IORDRE
  478. IF (NBOBJ.GT.1) SEGACT,MLENTI
  479. *
  480. *
  481. * Objet LISTMOTS
  482. * **************
  483. ELSEIF (NUMLIS.EQ.3) THEN
  484. MLMOT1 = IPLIST
  485. SEGACT,MLMOT1
  486.  
  487. JGM=MLMOT1.MOTS(/2)
  488. JGN=MLMOT1.MOTS(/1)
  489. LLIST=JGM
  490.  
  491. SEGINI,MLMOTS
  492. IPROBJ(IINCLE)=MLMOTS
  493.  
  494. IF (LLIST.EQ.0) THEN
  495. SEGDES,MLMOTS,MLMOT1
  496. GOTO 150
  497. ENDIF
  498.  
  499. * Creation d'un hash entier pour chaque mot
  500. * en prevision du tri
  501. JG=JGM
  502. SEGINI,MLENT1
  503. DO I=1,JGM
  504. CHA4 = MLMOT1.MOTS(I)
  505. IF (.NOT.SENCAS) THEN
  506. DO J=1,JGN
  507. K=INDEX(MINU,CHA4(J:J))
  508. IF (K.NE.0) CHA4(J:J)=MAJU(K:K)
  509. ENDDO
  510. ENDIF
  511.  
  512. I1=ICHAR(CHA4(1:1))*16777216
  513. I2=ICHAR(CHA4(2:2))*65536
  514. I3=ICHAR(CHA4(3:3))*256
  515. I4=ICHAR(CHA4(4:4))
  516.  
  517. MLENT1.LECT(I)=I1+I2+I3+I4
  518. ENDDO
  519.  
  520. * On ordonne les hashes
  521. IORDRE=1
  522. CALL ORDON2(MLENT1,CROISS,ABSOLU,IORDRE)
  523. IF (.NOT.STRICT) SEGSUP,MLENT1
  524.  
  525. * Creation du LISTMOTS ordonne
  526. MLENTI=IORDRE
  527. SEGACT,MLENTI
  528. DO I=1,JGM
  529. MOTS(I) = MLMOT1.MOTS(LECT(I))
  530. ENDDO
  531.  
  532. IF (.NOT.STRICT) SEGDES,MLMOTS
  533.  
  534. SEGDES,MLMOT1
  535.  
  536.  
  537. * ...OU BIEN TRI SELON UN COUT ET MEMORISATION DE L'ORDRE
  538. * =======================================================
  539.  
  540. * Objet LISTREEL
  541. * **************
  542. ELSEIF(NUMLIS.EQ.-1) THEN
  543.  
  544. * Recuperation et traitement de la matrice des couts
  545. MLREEL=ICOUT
  546. SEGACT,MLREEL
  547. NN2=MLREEL.PROG(/1)
  548.  
  549. * On verifie que NN2 est bien un carre
  550. X1=SQRT(DBLE(NN2))
  551. LLIST=NINT(X1)
  552. IF (ABS(X1-DBLE(LLIST)).GT.XSZPRE) THEN
  553. CALL ERREUR(199)
  554. SEGDES,MLREEL
  555. RETURN
  556. ENDIF
  557.  
  558. * On transpose
  559. JG=NN2
  560. SEGINI,MLREE1
  561. CALL TRSPOD(PROG(1),LLIST,LLIST,MLREE1.PROG(1))
  562. SEGDES,MLREEL
  563. ICOUT=MLREE1
  564.  
  565. * Creation du LISTENTI definissant la permutation
  566. JG=LLIST
  567. SEGINI,MLENTI
  568. IORDRE=MLENTI
  569.  
  570. * On fait le travail
  571. CALL PERMU1(IALGO,ICOUT,LLIST,IORDRE,XCOUT)
  572.  
  573. * On recupere la permutation
  574. MLREEL=ICOUT
  575. SEGSUP,MLREEL
  576. MLENTI=IORDRE
  577.  
  578.  
  579. * Objet LISTENTI
  580. * **************
  581. ELSEIF(NUMLIS.EQ.-2) THEN
  582.  
  583. * Recuperation et traitement de la matrice des couts
  584. MLENTI=ICOUT
  585. SEGACT,MLENTI
  586. NN2=MLENTI.LECT(/1)
  587.  
  588. * On verifie que NN2 est bien un carre
  589. X1=SQRT(DBLE(NN2))
  590. LLIST=NINT(X1)
  591. IF(ABS(X1-DBLE(LLIST)).GT.XSZPRE) THEN
  592. CALL ERREUR(199)
  593. SEGDES,MLENTI
  594. RETURN
  595. ENDIF
  596.  
  597. * On transpose
  598. JG=NN2
  599. SEGINI,MLENT1
  600. CALL TRSPOS(LECT(1),LLIST,LLIST,MLENT1.LECT(1))
  601. SEGDES,MLENTI
  602. ICOUT=MLENT1
  603.  
  604. * Creation du LISTENTI definissant la permutation
  605. JG=LLIST
  606. SEGINI,MLENTI
  607. IORDRE=MLENTI
  608.  
  609. * On fait le travail
  610. CALL PERMU2(IALGO,ICOUT,LLIST,IORDRE,KCOUT)
  611.  
  612. * On recupere la permutation
  613. MLENTI=ICOUT
  614. SEGSUP,MLENTI
  615. MLENTI=IORDRE
  616.  
  617. ELSE
  618. CALL ERREUR(5)
  619. RETURN
  620. ENDIF
  621. *
  622. *
  623. * EVENTUELLEMENT : TRI DES AUTRES OBJETS SUIVANT LE MEME ORDRE
  624. * ============================================================
  625. 150 CONTINUE
  626.  
  627. DO 30 I=1,NBOBJ
  628.  
  629. IF (I.EQ.IINCLE) GOTO 30
  630.  
  631. * Objet LISTREEL
  632. * **************
  633. IF (ITYOBJ(I).EQ.1) THEN
  634. MLREE1 = IPROBJ(I)
  635. SEGACT,MLREE1
  636. JG=MLREE1.PROG(/1)
  637. IF (JG.NE.LLIST) THEN
  638. CALL ERREUR(217)
  639. GOTO 900
  640. ENDIF
  641.  
  642. SEGINI,MLREE2
  643. IF (LLIST.GT.0) THEN
  644. DO J=1,LLIST
  645. MLREE2.PROG(J) = MLREE1.PROG(LECT(J))
  646. ENDDO
  647. ENDIF
  648.  
  649. IPROBJ(I)=MLREE2
  650. SEGDES,MLREE1,MLREE2
  651.  
  652.  
  653. * Objet LISTENTI
  654. * **************
  655. ELSEIF (ITYOBJ(I).EQ.2) THEN
  656. MLENT1 = IPROBJ(I)
  657. SEGACT,MLENT1
  658. JG=MLENT1.LECT(/1)
  659. IF (JG.NE.LLIST) THEN
  660. CALL ERREUR(217)
  661. GOTO 900
  662. ENDIF
  663.  
  664. SEGINI,MLENT2
  665. IF (LLIST.GT.0) THEN
  666. DO J=1,LLIST
  667. MLENT2.LECT(J) = MLENT1.LECT(LECT(J))
  668. ENDDO
  669. ENDIF
  670.  
  671. IPROBJ(I)=MLENT2
  672. SEGDES,MLENT1,MLENT2
  673.  
  674.  
  675. * Objet LISTMOTS
  676. * **************
  677. ELSEIF (ITYOBJ(I).EQ.3) THEN
  678. MLMOT1 = IPROBJ(I)
  679. SEGACT,MLMOT1
  680. JGM=MLMOT1.MOTS(/2)
  681. IF (JGM.NE.LLIST) THEN
  682. CALL ERREUR(217)
  683. GOTO 900
  684. ENDIF
  685. JGN=MLMOT1.MOTS(/1)
  686.  
  687. SEGINI,MLMOT2
  688. IF (LLIST.GT.0) THEN
  689. DO J=1,LLIST
  690. MLMOT2.MOTS(J) = MLMOT1.MOTS(LECT(J))
  691. ENDDO
  692. ENDIF
  693.  
  694. IPROBJ(I)=MLMOT2
  695. SEGDES,MLMOT1,MLMOT2
  696. ENDIF
  697.  
  698. 30 CONTINUE
  699.  
  700. IF (LLIST.GT.0) SEGSUP,MLENTI
  701. *
  702. *
  703. * EVENTUELLEMENT : SUPPRESSION DES DOUBLONS
  704. * =========================================
  705. IF (STRICT.AND.LLIST.GT.1) THEN
  706.  
  707. * Objet LISTREEL
  708. * **************
  709. IF (NUMLIS.EQ.1) THEN
  710. MLREEL = IPROBJ(1)
  711. SEGACT,MLREEL*MOD
  712. NDOUB=0
  713. IF (ICRIT.NE.0) THEN
  714. DO I=2,LLIST
  715. IF (ABS(PROG(I-1)-PROG(I)).GT.CRIT) THEN
  716. IF (NDOUB.GT.0) PROG(I-NDOUB)=PROG(I)
  717. ELSE
  718. NDOUB=NDOUB+1
  719. ENDIF
  720. ENDDO
  721. ELSE
  722. DO I=2,LLIST
  723. IF (PROG(I-1).NE.PROG(I)) THEN
  724. IF (NDOUB.GT.0) PROG(I-NDOUB)=PROG(I)
  725. ELSE
  726. NDOUB=NDOUB+1
  727. ENDIF
  728. ENDDO
  729. ENDIF
  730. JG = LLIST-NDOUB
  731. SEGADJ,MLREEL
  732. SEGDES,MLREEL
  733.  
  734.  
  735. * Objet LISTENTI
  736. * **************
  737. ELSEIF (NUMLIS.EQ.2) THEN
  738. MLENTI = IPROBJ(1)
  739. SEGACT,MLENTI*MOD
  740. NDOUB=0
  741. DO I=2,LLIST
  742. IF (LECT(I-1).NE.LECT(I)) THEN
  743. IF (NDOUB.GT.0) LECT(I-NDOUB)=LECT(I)
  744. ELSE
  745. NDOUB=NDOUB+1
  746. ENDIF
  747. ENDDO
  748. JG = LLIST-NDOUB
  749. SEGADJ,MLENTI
  750. SEGDES,MLENTI
  751.  
  752.  
  753. * Objet LISTMOTS
  754. * **************
  755. ELSEIF (NUMLIS.EQ.3) THEN
  756. SEGACT,MLMOTS*MOD
  757. SEGACT,MLENT1
  758. NDOUB=0
  759. DO I=2,LLIST
  760. IF (MLENT1.LECT(I-1).NE.MLENT1.LECT(I)) THEN
  761. IF (NDOUB.GT.0) MOTS(I-NDOUB)=MOTS(I)
  762. ELSE
  763. NDOUB=NDOUB+1
  764. ENDIF
  765. ENDDO
  766. SEGSUP,MLENT1
  767. JGM = LLIST-NDOUB
  768. SEGADJ,MLMOTS
  769. SEGDES,MLMOTS
  770.  
  771. ENDIF
  772.  
  773. ENDIF
  774. *
  775. *
  776. * ECRITURE DES OBJETS ORDONNES DANS LE BON ORDRE
  777. * ==============================================
  778.  
  779. IF (MTABLE.GT.0) THEN
  780. M = NBOBJ
  781. SEGINI,MTAB1
  782. MTAB1.MLOTAB=M
  783. DO I=1,NBOBJ
  784. IF (MTABTI(I).EQ.'FLOTTANT') THEN
  785. MTAB1.MTABTI(I)='FLOTTANT'
  786. MTAB1.RMTABI(I)=RMTABI(I)
  787. ELSE
  788. MTAB1.MTABTI(I)=MTABTI(I)
  789. MTAB1.MTABII(I)=MTABII(I)
  790. ENDIF
  791. MTAB1.MTABTV(I)=LISTYP(ITYOBJ(I))
  792. MTAB1.MTABIV(I)=IPROBJ(I)
  793. ENDDO
  794. CALL ECROBJ('TABLE',MTAB1)
  795. SEGDES,MTABLE,MTAB1
  796. ELSE
  797. DO I=NBOBJ,1,-1
  798. MONTYP = LISTYP(ITYOBJ(I))
  799. IPOBJ = IPROBJ(I)
  800. CALL ECROBJ(MONTYP,IPOBJ)
  801. ENDDO
  802. ENDIF
  803.  
  804. IF (ZCOUT) THEN
  805. IF (NUMLIS.EQ.-1) CALL ECRREE(XCOUT)
  806. IF (NUMLIS.EQ.-2) CALL ECRENT(KCOUT)
  807. ENDIF
  808.  
  809. 900 CONTINUE
  810. SEGSUP,MPILO
  811.  
  812. *
  813. * +-----------------------------------------------------+
  814. * | O B J E T E V O L U T I O N |
  815. * +-----------------------------------------------------+
  816. *
  817. ELSEIF (NUMLIS.EQ.4) THEN
  818. MEVOL1 = IPLIST
  819. SEGINI,MEVOLL=MEVOL1
  820. IPLIST = MEVOLL
  821. *
  822. CALL ORDON3 (IPLIST,CROISS,ABSOLU)
  823. *
  824. CALL ECROBJ('EVOLUTIO',MEVOLL)
  825. *
  826. * +-----------------------------------------------------+
  827. * | O B J E T M A I L L A G E |
  828. * +-----------------------------------------------------+
  829. *
  830. ELSEIF (NUMLIS.EQ.5) THEN
  831. IPT2 = IPLIST
  832. SEGINI,IPT1=IPT2
  833. IPLIST = IPT1
  834. *
  835. CALL ORDON4 (IPLIST)
  836. *
  837. CALL ECROBJ('MAILLAGE',IPT1)
  838.  
  839. ENDIF
  840.  
  841.  
  842. RETURN
  843.  
  844. END
  845.  
  846.  
  847.  

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