Télécharger la plaquette Cast3M


fr en

Télécharger ordonn.eso

Retour à la liste

Numérotation des lignes : 

ordonn

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

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