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

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