Télécharger la plaquette Cast3M


fr en

Télécharger prfuse.eso

Retour à la liste

Numérotation des lignes : 

prfuse

  1. C PRFUSE    SOURCE    PV090527  23/12/15    21:15:04     11810          
  2.       SUBROUTINE PRFUSE
  3.  
  4. *=============================================================
  5. *
  6. * Interface entre la directive "ET" et le sous-programme "FUSE"
  7. *
  8. *=============================================================
  9. *
  10. * Modifications :
  11. *
  12. *   PM 09/10/2007 : fusion de deux LISTCHPOs
  13. *   PM 09/10/2007 : respect de l'ordre des opérandes
  14. *   CB 23/01/2017 : ET entre un LISTMOT et un MOT
  15. *
  16. *=============================================================
  17. *
  18. * Remarques :
  19. *
  20. *=============================================================
  21.  
  22.       IMPLICIT INTEGER(I-N)
  23.       IMPLICIT REAL*8(A-H,O-Z)
  24.  
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC SMTABLE
  29. -INC CCNOYAU
  30. -INC CCASSIS
  31. -INC SMELEME
  32. -INC SMLMOTS
  33. -INC CCGEOME
  34. -INC SMLREEL
  35. -INC SMLENTI
  36. -INC SMANNOT
  37. -INC SMLOBJE
  38.  
  39.       EXTERNAL        LONG
  40.  
  41.       LOGICAL         IR1,IR2,IR3,LTELQ
  42.       CHARACTER*(8)   CTYP,CTYP1,CTYP2,ICHAT,TYPRET,TYPRE1
  43.       CHARACTER*(LOCHAI) LEMOT,LEMOT1,LEMOT2
  44.       REAL*8 XVAL
  45.       CHARACTER*4     LISTMO(1)
  46.       DATA            LISTMO / 'TELQ' /
  47.  
  48.       IP0 = 0
  49.       IP1 = 0
  50.       IP2 = 0
  51. *     Recherche préalable du mot-clef 'TELQUEL' éventuel
  52.       CALL LIRMOT(LISTMO,1,IRE2,0)
  53.       IF (IERR.NE.0) RETURN
  54.       LTELQ = (IRE2.EQ.1)
  55.  
  56. *     Lecture du premier objet
  57. *     ------------------------
  58.       CALL MESLIR(-225)
  59.       CALL QUETYP(CTYP,0,IRETOU)
  60.       IF(IRETOU.EQ.0) THEN
  61. *       Cet opérateur a encore besoin d'un opérande.
  62.          CALL ERREUR (533)
  63.          RETURN
  64.       ENDIF
  65.  
  66.       IF(CTYP.EQ.'LOGIQUE ') THEN
  67.          CALL MESLIR(-225)
  68.          CALL LIRLOG(IR1,1,IRETOU)
  69.          CALL MESLIR(-223)
  70.          CALL LIRLOG(IR2,1,IRETOU)
  71.          IF(IERR.NE.0) RETURN
  72.          GOTO 213
  73.  
  74.       ELSE IF(CTYP.EQ.'MOT     ') THEN
  75.          CALL LIRCHA(LEMOT1,1,IRET1)
  76.          IF (IERR.NE.0) RETURN
  77.  
  78.          CALL QUETYP(CTYP2,0,IRETOU)
  79.          IF(IRETOU.EQ.0) THEN
  80. *          Cet opérateur a encore besoin d'un opérande.
  81.             CALL ERREUR (533)
  82.             RETURN
  83.          ENDIF
  84.          IF(CTYP2 .EQ. 'LISTMOTS') THEN
  85.            CALL LIROBJ('LISTMOTS',IP2,1,IRETOU)
  86.            IF(IERR.NE.0) RETURN
  87.            GOTO 222
  88.  
  89.          ELSE
  90.            CALL LIRCHA(LEMOT2,1,IRET2)
  91.            IF( IERR.NE.0) RETURN
  92.            IF (LTELQ) THEN
  93. *            Concaténation avec respect des espaces avant et après
  94.            ELSE
  95. *            Suppressions des espaces en fin de mot
  96.              IRET1=LONG(LEMOT1)
  97.              IRET2=LONG(LEMOT2)
  98.            ENDIF
  99.            GOTO 225
  100.          ENDIF
  101.  
  102.       ELSE IF(CTYP.EQ.'FLOTTANT') THEN
  103.          CALL LIRREE(XVAL1,1,IRETOU)
  104.          IF(IERR.NE.0) RETURN
  105.          CTYP='LISTREEL'
  106.          II=16
  107.          GOTO 24
  108.  
  109.       ELSE IF(CTYP.EQ.'ENTIER  ') THEN
  110.          CALL LIRENT(IP1,1,IRETOU)
  111.          IF(IERR.NE.0) RETURN
  112. *       suivant que l'objet suivant est un ENTIER/LISTENTI ou pas,
  113. *       on considère cette entrée comme un FLOTTANT
  114.          CALL QUETYP(CTYP,1,IRETOU)
  115.          IF(IERR.NE.0) RETURN
  116.          IF(CTYP.NE.'ENTIER  '.AND.CTYP.NE.'LISTENTI') THEN
  117.             XVAL1=FLOAT(IP1)
  118.             IP1=0
  119.             CTYP='LISTREEL'
  120.             II=16
  121.          ELSE
  122.             CALL CRELEC(IP1)
  123.             CTYP='LISTENTI'
  124.             II=17
  125.          ENDIF
  126.          GOTO 24
  127.  
  128.       ELSE
  129.          MOTERR(1:8)=CTYP
  130.          CALL MESLIR(-222)
  131.          CALL LIROBJ(CTYP,IP1,1,IRETOU)
  132.          IF(CTYP.EQ.'POINT   ') THEN
  133.             II = 1
  134.             GOTO 24
  135.          ENDIF
  136.          IF(CTYP.EQ.'MAILLAGE') THEN
  137.             II = 2
  138.             GOTO 24
  139.          ENDIF
  140.          IF(CTYP.EQ.'CHPOINT ') THEN
  141.             CALL ACTOBJ(CTYP,IP1,1)
  142.             II = 3
  143.             GOTO 24
  144.          ENDIF
  145.          IF(CTYP.EQ.'MCHAML  ') THEN
  146.             CALL ACTOBJ(CTYP,IP1,1)
  147.             II = 20
  148.             GOTO 24
  149.          ENDIF
  150.          IF(CTYP.EQ.'RIGIDITE') THEN
  151.             II = 4
  152.             GOTO 24
  153.          ENDIF
  154.          IF(CTYP.EQ.'EVOLUTIO') THEN
  155.             II = 18
  156.             GOTO 24
  157.          ENDIF
  158.          IF(CTYP.EQ.'CHARGEME') THEN
  159.             II = 15
  160.             GOTO 24
  161.          ENDIF
  162.          IF(CTYP.EQ.'STRUCTUR') THEN
  163.             II = 5
  164.             GOTO 24
  165.          ENDIF
  166.          IF(CTYP.EQ.'SOLUTION') THEN
  167.             II = 6
  168.             GOTO 24
  169.          ENDIF
  170.          IF(CTYP.EQ.'ATTACHE ') THEN
  171.             II = 7
  172.             GOTO 24
  173.          ENDIF
  174.          IF(CTYP.EQ.'ELEMSTRU') THEN
  175.             II = 10
  176.             GOTO 24
  177.          ENDIF
  178.          IF(CTYP.EQ.'BLOQSTRU') THEN
  179.             II = 11
  180.             GOTO 24
  181.          ENDIF
  182.          IF(CTYP.EQ.'BASEMODA') THEN
  183.             II = 12
  184.             GOTO 24
  185.          ENDIF
  186.          IF(CTYP.EQ.'DEFORME ') THEN
  187.             II = 13
  188.             GOTO 24
  189.          ENDIF
  190.          IF(CTYP.EQ.'VECTEUR ') THEN
  191.             II = 14
  192.             GOTO 24
  193.          ENDIF
  194.          IF(CTYP.EQ.'LISTREEL') THEN
  195.             II = 16
  196.             GOTO 24
  197.          ENDIF
  198.          IF(CTYP.EQ.'LISTENTI') THEN
  199.             II = 17
  200.             GOTO 24
  201.          ENDIF
  202.          IF(CTYP.EQ.'MMODEL  ') THEN
  203.             CALL ACTOBJ(CTYP,IP1,1)
  204.             II = 19
  205.             GOTO 24
  206.          ENDIF
  207.          IF(CTYP.EQ.'LISTMOTS') THEN
  208.             II = 21
  209.             GOTO 24
  210.          ENDIF
  211.          IF(CTYP.EQ.'NUAGE   ') THEN
  212.             II = 22
  213.             GOTO 24
  214.          ENDIF
  215.          IF(CTYP.EQ.'MATRIK') THEN
  216.             II = 23
  217.             GOTO 24
  218.          ENDIF
  219.          IF(CTYP.EQ.'LISTCHPO') THEN
  220.             II = 24
  221.             GOTO 24
  222.          ENDIF
  223.          IF(CTYP.EQ.'ANNOTATI') THEN
  224.             II = 25
  225.             GOTO 24
  226.          ENDIF
  227.          IF(CTYP.EQ.'LISTOBJE') THEN
  228.             II = 26
  229.             GOTO 24
  230.          ENDIF
  231.  
  232.          IF(CTYP.EQ.'TABLE') THEN
  233.             MTABLE = IP1
  234.             CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  235.      >           'MOT',ID3,RR1,LEMOT,IR1,ID2)
  236.             IF (LEMOT.EQ.'LIAISONS_STATIQUES'.OR.
  237.      >           LEMOT.EQ.'BASE_MODALE') GOTO 2000
  238.             GOTO 1000
  239.          ENDIF
  240.  
  241.          GOTO 999
  242.  
  243.       ENDIF
  244.  
  245.  
  246. *     ================
  247. *     Première syntaxe
  248. *     ================
  249.  
  250. *     Lecture deuxième objet, lui aussi avec pointeur
  251. *     -----------------------------------------------
  252.  24   CONTINUE
  253.  
  254.       ICODE=1
  255. *     pour les fusions mixtes, on est encore indécis sur le type du
  256. *     deuxième objet.
  257.       IF(CTYP.EQ.'POINT   '.OR.CTYP.EQ.'MAILLAGE'.OR.
  258.      &   CTYP.EQ.'LISTENTI'.OR.CTYP.EQ.'LISTREEL'.OR.
  259.      &   CTYP.EQ.'LISTMOTS'.OR.
  260.      &   CTYP.EQ.'CHPOINT '.OR.CTYP.EQ.'LISTCHPO'.OR.
  261.      &   CTYP.EQ.'LISTOBJE') ICODE=0
  262.  
  263. *     on lit a priori un objet de même type que le premier
  264.       CALL QUETYP(CTYP2 , ICODE , IRETOU )
  265. *     cas où on a un LISTOBJE uniquement, on fait la 2eme syntaxe
  266.       IF (CTYP.EQ.'LISTOBJE'.AND.IRETOU.EQ.0) GOTO 1010
  267.       IF (CTYP.EQ.'LISTOBJE'.OR.CTYP2.EQ.'LISTOBJE') THEN
  268.          CALL LIROBJ(CTYP2,IP2,1,IRETOU)
  269.          IF(IERR.NE.0) RETURN
  270.          II = 26
  271.          IF (CTYP.NE.'LISTOBJE') THEN
  272.             IPX = IP2
  273.             IP2 = IP1
  274.             IP1 = IPX
  275.             CTYP1 = CTYP2
  276.             CTYP2 = CTYP
  277.             CTYP  = CTYP1
  278.          ENDIF
  279.       ELSE
  280.          MOTERR(1:8)=CTYP
  281.          CALL MESLIR(-221)
  282.          CALL LIROBJ(CTYP,IP2,ICODE,IRETOU)
  283.          IF(IRETOU .EQ. 1) CALL ACTOBJ(CTYP,IP2,1)
  284.          IF(IERR.NE.0) RETURN
  285.       ENDIF
  286.  
  287.       GOTO ( 1,2,3,4,205,206,207,999,999,210,211,212,214,215,216,
  288.      $     217,218,219,220,221,222,223,224,226,227,228),II
  289.  
  290. *--   Création maillage
  291.  1    CONTINUE
  292.       CALL CRELEM(IP1)
  293.  2    CONTINUE
  294.       IF (CTYP.NE.'POINT   '.AND.CTYP.NE.'MAILLAGE') GOTO 999
  295.       IF(IRETOU.EQ.1.AND.CTYP.EQ.'POINT   ') THEN
  296. *       on a deux points
  297.          CALL CRELEM(IP2)
  298.       ENDIF
  299.       IF(IRETOU.EQ.0) THEN
  300. *       on a lu des objets de types différents mais compatibles
  301.          CALL MESLIR(-220)
  302.          IF(CTYP.EQ.'POINT   ') CALL LIROBJ('MAILLAGE',IP2,1,IRETAU)
  303.          IF(CTYP.EQ.'MAILLAGE') THEN
  304.             CALL LIROBJ('POINT   ',IP2,1,IRETAU)
  305.             IF(IRETAU.EQ.1) CALL CRELEM(IP2)
  306.          ENDIF
  307.          IF(IERR.NE.0) RETURN
  308.       ENDIF
  309.       CTYP='MAILLAGE'
  310.       CALL FUSE(IP1,IP2,IRETOU,LTELQ)
  311.       GOTO 100
  312.  
  313. *--   Création CHPOINT
  314.     3 CONTINUE
  315.       IF(IRETOU.EQ.1) THEN
  316. *       La concaténation de deux champ-points donne un champ-point
  317.          IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  318.          CALL FUCHPO(IP1,IP2,IRETOU)
  319.          IF (IRETOU.NE.IP1.AND.IRETOU.NE.IP2)
  320.      &       CALL ACTOBJ('CHPOINT ',IRETOU,1)
  321.          GOTO 100
  322.       ELSE
  323. *PM     autrement, on peut obtenir une liste de chpoints
  324.          CALL CRLCHP(IP1)
  325.          GOTO 226
  326.       ENDIF
  327.  
  328. *--   Création RIGIDITE
  329.     4 CONTINUE
  330.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  331.       CALL FUSRIG(IP1,IP2,IRETOU)
  332.       GOTO 100
  333. *--   Création STRUCTURE
  334.  205  CONTINUE
  335.       CALL FUSTRU(IP1,IP2,IRETOU)
  336.       GOTO 100
  337. *--   Création SOLUTION
  338.  206  CONTINUE
  339.       CALL FUSOLU(IP1,IP2,IRETOU)
  340.       GOTO 100
  341. *--   Création ATTACHE
  342.  207  CONTINUE
  343.       CALL FUSATT(IP1,IP2,IRETOU)
  344.       GOTO 100
  345. *--   Création ELEMSTRU
  346.  210  CONTINUE
  347.       CALL FUSELS(IP1,IP2,IRETOU)
  348.       GOTO 100
  349. *--   Création BLOQSTRU
  350.  211  CONTINUE
  351.       CALL FUSCLS(IP1,IP2,IRETOU)
  352.       GOTO 100
  353. *--   Création BASE MODALE
  354.  212  CONTINUE
  355.       CALL FUSBAS(IP1,IP2,IRETOU)
  356.       GOTO 100
  357. *--   Opération LOGIQUE
  358.  213  CONTINUE
  359.       IR3=IR1.AND.IR2
  360. *  lecture optionnelle d'autres logiques
  361.       do i=1,1000
  362.        call lirlog(ir2,0,iretou)
  363.        if(iretou.eq.0) goto 2130
  364.        ir3=ir3.and.ir2
  365.       enddo
  366.  2130 continue
  367.       CALL ECRLOG(IR3)
  368.       RETURN
  369. *--   Création DEFORMEE
  370.  214  CONTINUE
  371.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  372.       CALL FUSDEF(IP1,IP2,IRETOU)
  373.       GOTO 100
  374. *--   Création VECTEUR
  375.  215  CONTINUE
  376.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  377.       CALL FUSVEC (IP1,IP2,IRETOU)
  378.       GOTO 100
  379. *--   Création CHARGEMENT
  380.  216  CONTINUE
  381.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  382.       CALL FUSCHA(IP1,IP2,IRETOU)
  383.       GOTO 100
  384.  
  385. *--   Création LISTREEL
  386.  217  CONTINUE
  387.       IF(IP1 .NE. 0)THEN
  388. C       On a lu un LISTREEL en 1er argument
  389.         IF(IRETOU.EQ.0) THEN
  390. C         On n'a pas lu un LISTREEL en 2eme argument
  391.           CALL QUETYP(CTYP,1,IRETOU)
  392.           IF(IERR.NE.0) RETURN
  393.           IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  394. C         On a lu des objets de types différents mais compatibles
  395.           IF (CTYP.EQ.'ENTIER  ') THEN
  396.              CALL LIRENT(IVAL2,1,IRETOU)
  397.              XVAL2=FLOAT(IVAL2)
  398.           ELSE
  399.              CALL LIRREE(XVAL2,1,IRETOU)
  400.           ENDIF
  401.           IF(IERR.NE.0) RETURN
  402.  
  403.           MLREE2=IP1
  404.           SEGACT,MLREE2
  405.           JG1=MLREE2.PROG(/1)
  406.           JG =JG1 + 1
  407.           SEGINI,MLREE1
  408.           MLREE1.PROG(JG)=XVAL2
  409.           IF(JG1 .GT. 0)THEN
  410. C           Recopie en FORTRAN
  411.             CALL OPTABJ(1,1,3,1,
  412.      &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
  413.      &                  JG1           ,JG1           ,JG1,
  414.      &                  1,0,0.D0,IRETOU)
  415.           ENDIF
  416.         ELSE
  417. C         On a lu un LISTREEL en 2eme argument
  418.           CALL FUSPRO(IP1,IP2,IRETOU)
  419.           MLREE1=IRETOU
  420.         ENDIF
  421.       ELSE
  422. C       On n'a pas lu un LISTREEL en 1er argument
  423.         IF(IRETOU.EQ.0) THEN
  424. C         On n'a pas lu un LISTREEL en 2eme argument
  425.           CALL QUETYP(CTYP,1,IRETOU)
  426.           IF(IERR.NE.0) RETURN
  427.           IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  428. C         On a lu des objets de types différents mais compatibles
  429.           IF (CTYP.EQ.'ENTIER  ') THEN
  430.              CALL LIRENT(IVAL2,1,IRETOU)
  431.              XVAL2=FLOAT(IVAL2)
  432.           ELSE
  433.              CALL LIRREE(XVAL2,1,IRETOU)
  434.           ENDIF
  435.           IF(IERR.NE.0) RETURN
  436.           JG=2
  437.           SEGINI,MLREE1
  438.           MLREE1.PROG(1)=XVAL1
  439.           MLREE1.PROG(2)=XVAL2
  440.         ELSE
  441. C         On a lu un LISTREEL en 2eme argument
  442.           MLREE2=IP2
  443.           SEGACT,MLREE2
  444.           JG1=MLREE2.PROG(/1)
  445.           JG =JG1 + 1
  446.           SEGINI,MLREE1
  447.           MLREE1.PROG(1)=XVAL1
  448.           IF(JG1 .GT. 0) THEN
  449. C           Recopie en FORTRAN
  450.             CALL OPTABJ(1,1,3,1,
  451.      &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
  452.      &                  JG1           ,JG1           ,JG1,
  453.      &                  1,0,0.D0,IRETOU)
  454.           ENDIF
  455.         ENDIF
  456.       ENDIF
  457.       CTYP='LISTREEL'
  458.       SEGACT,MLREE1*NOMOD
  459.       IRETOU=MLREE1
  460.       GOTO 100
  461.  
  462. *--   Création LISTENTI
  463.  218  CONTINUE
  464.       IF(IRETOU.EQ.0) THEN
  465. *       on n'a pas lu un LISTENTI
  466.          CALL QUETYP(CTYP,1,IRETOU)
  467.          IF(IERR.NE.0) RETURN
  468.          IF(CTYP.NE.'ENTIER  ') GOTO 999
  469.          CALL LIRENT(IP2,1,IRETOU)
  470.          IF(IERR.NE.0) RETURN
  471.          CALL CRELEC(IP2)
  472.       ENDIF
  473.       CTYP='LISTENTI'
  474.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  475.       CALL FUSLEC(IP1,IP2,IRETOU)
  476.       GOTO 100
  477.  
  478. *--   Création EVOLUTION
  479.  219  CONTINUE
  480.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  481.       CALL FUEVOL(IP1,IP2,IRETOU)
  482.       GOTO 100
  483. *--   Création MODELE
  484.  220  CONTINUE
  485.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  486.       CALL FUSMOD(IP1,IP2,IRETOU)
  487.       GOTO 100
  488. *--   Création MCHAML
  489.  221  CONTINUE
  490.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  491.       CALL ETMCHL(IP1,IP2,IRETOU)
  492.       GOTO 100
  493.  
  494. *--   Création LISTMOTS
  495.  222  CONTINUE
  496.       IF    (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
  497. C       LISTMOTS 'ET' LISTMOTS
  498.         CALL FUSMOT(IP1,IP2,IRETOU)
  499.  
  500.       ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
  501. C       LISTMOTS 'ET' MOT
  502.         CALL QUETYP(CTYP2,0,IRETOU)
  503.         IF(CTYP2 .EQ. 'MOT') THEN
  504.           CALL LIRCHA(LEMOT1,1,IRET1)
  505.           IF (IERR.NE.0) RETURN
  506.           MLMOT1=IP1
  507.           SEGACT,MLMOT1
  508.           JGN=MLMOT1.MOTS(/1)
  509.           JGM=MLMOT1.MOTS(/2)+1
  510.           SEGINI,MLMOT2
  511.           IRETOU=MLMOT2
  512.           DO III=1,JGM-1
  513.             MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
  514.           ENDDO
  515.           MLMOT2.MOTS(JGM)=LEMOT1
  516.           SEGDES,MLMOT1,MLMOT2
  517.         ELSE
  518.           GOTO 999
  519.         ENDIF
  520.  
  521.       ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
  522. C       MOT 'ET' LISTMOTS
  523.         IF(CTYP .EQ. 'MOT') THEN
  524.           CTYP = CTYP2
  525.           MLMOT1=IP2
  526.           SEGACT,MLMOT1
  527.           JGN=MLMOT1.MOTS(/1)
  528.           JGM=MLMOT1.MOTS(/2)+1
  529.           SEGINI,MLMOT2
  530.           IRETOU=MLMOT2
  531.           MLMOT2.MOTS(1)=LEMOT1(1:JGN)
  532.           DO III=2,JGM
  533.             MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
  534.           ENDDO
  535.           SEGDES,MLMOT1,MLMOT2
  536.         ELSE
  537.           GOTO 999
  538.         ENDIF
  539.       ENDIF
  540.       GOTO 100
  541. *--   Création NUAGE
  542.  223  CONTINUE
  543.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  544.       CALL FUSNUA(IP1,IP2,IRETOU)
  545.       GOTO 100
  546. *--   Création MATRIK
  547.  224  CONTINUE
  548.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  549.       CALL FUSMTK(IP1,IP2,IRETOU)
  550.       GOTO 100
  551. *--   Création LISTCHPO
  552.  226  CONTINUE
  553.       IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
  554.       IF(IRETOU.EQ.0) THEN
  555. *       on a lu des objets de types différents mais compatibles
  556. *       (le cas de 2 champ-points est traité ailleurs)
  557.          CALL MESLIR(-221)
  558.          IF(CTYP.EQ.'CHPOINT ') THEN
  559.             CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
  560.             CALL ACTOBJ('LISTCHPO',IP2,1)
  561.          ELSE
  562.             CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
  563.             CALL ACTOBJ('CHPOINT ',IP2,1)
  564.             CALL CRLCHP(IP2)
  565.          ENDIF
  566.          IF(IERR.NE.0) RETURN
  567.       ENDIF
  568.       CTYP='LISTCHPO'
  569.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  570.       CALL FUSSUI(IP1,IP2,IRETOU)
  571.       GOTO 100
  572. *--   Création ANNOTATI
  573.  227  CONTINUE
  574.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  575.       MANNO1=IP1
  576.       MANNO2=IP2
  577.       SEGACT,MANNO1,MANNO2
  578.       NBANN1=MANNO1.ICLAS(/1)
  579.       NBANN2=MANNO2.ICLAS(/1)
  580.       NBANNO=NBANN1+NBANN2
  581.       SEGINI,MANNO3
  582.       DO K1=1,NBANN1
  583.           MANNO3.ICLAS(K1) = MANNO1.ICLAS(K1)
  584.           MANNO3.ISEGT(K1) = MANNO1.ISEGT(K1)
  585.       ENDDO
  586.       DO K2=1,NBANN2
  587.           MANNO3.ICLAS(NBANN1+K2) = MANNO2.ICLAS(K2)
  588.           MANNO3.ISEGT(NBANN1+K2) = MANNO2.ISEGT(K2)
  589.       ENDDO
  590.       IRETOU=MANNO3
  591.       GOTO 100
  592. *--   Creation LISTOBJE
  593.  228  CONTINUE
  594. C     On a forcément un LISTOBJE en premier argument
  595.       IF (CTYP.NE.CTYP2) THEN
  596. C     LISTOBJE ET "un autre objet"
  597.          MLOBJ1 = IP1
  598.          SEGACT,MLOBJ1
  599.          CTYP1 = MLOBJ1.TYPOBJ
  600.          NBOB1 = MLOBJ1.LISOBJ(/1)
  601.          IF (CTYP1.NE.CTYP2.AND.NBOB1.NE.0) THEN
  602.             CTYP = CTYP2
  603.             GOTO 999
  604.          ENDIF
  605.          NOBJ = 1
  606.          SEGINI,MLOBJE
  607.          TYPOBJ    = CTYP2
  608.          LISOBJ(1) = IP2
  609.          IP2 = MLOBJE
  610.       ENDIF
  611.       CALL FUSLOB(IP1,IP2,IRETOU)
  612.       IF (IERR.NE.0) RETURN
  613.       GOTO 100
  614.  
  615. *     Sortie sans problème, écriture résultat
  616.  100  CONTINUE
  617.       CALL ACTOBJ(CTYP,IRETOU,1)
  618.       CALL ECROBJ(CTYP,IRETOU)
  619.       RETURN
  620.  
  621. *     Fusion de chaines, limitation à 512 caractères
  622.  225  CONTINUE
  623.       IRET=IRET1+IRET2
  624.       IF(IRET.GT.512) THEN
  625.          CALL ERREUR(1110)
  626.          RETURN
  627.       ENDIF
  628.       LEMOT(1:IRET1) = LEMOT1(1:IRET1)
  629.       LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
  630.       CALL ECRCHA(LEMOT(1:IRET))
  631.       RETURN
  632.  
  633.  
  634. *     ================
  635. *     Deuxième syntaxe
  636. *     ================
  637. *     Fusion de tous les indices d'une table
  638.  
  639.  1000 CONTINUE
  640.       MTABLE=IP1
  641.       IF (IRETOU.EQ.1) THEN
  642. *        ET DE TABLES ESCLAVE
  643. *        WRITE(IOIMP,*) ' TABLE ESCLAVE DANS ET'
  644. *        IF (LODESL) THEN
  645. *           WRITE(IOIMP,*) ' LODESL REMIS À FAUX DANS PRFUSE '
  646. *           LODESL=.FALSE.
  647. *           CALL ABORT
  648. *        ENDIF
  649.          CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  650.      >        'MOT',ID3,RR1,CTYP,IR1,ID2)
  651.          IF (CTYP.NE.'ESCLAVE') THEN
  652. *           Donnez une TABLE de sous-type %m1:8
  653.             MOTERR(1:8)='ESCLAVE'
  654.             CALL ERREUR(-173)
  655. *           Le sous-type de la table est incorrect
  656.             CALL ERREUR(648)
  657.             RETURN
  658.          ENDIF
  659.          SEGACT MTABLE
  660.          ML=MLOTAB
  661. *        L'INDICE 1 EST LE SOUSTYPE, l'INDICE 2 EST LE CREATEUR
  662.          IND=MTABII(3)
  663.          CTYP=' '
  664.          CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  665.      >        CTYP,ID3,RR1,TYPRET,IR1,ID1)
  666.          IRETOU=ID1
  667.          IF (CTYP.EQ.'POINT') THEN
  668.             NBNN=1
  669.             NBSOUS=0
  670.             NBREF=0
  671.             NBELEM=ML-2
  672.             SEGINI MELEME
  673.             ITYPEL=1
  674.             NUM(1,1)=ID1
  675.             ICOLOR(1)=IDCOUL
  676.             DO I=4,ML
  677.                IND=MTABII(I)
  678.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  679.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  680.                IF (IERR.NE.0) RETURN
  681.                NUM(1,I-2)=ID2
  682.                ICOLOR(I-2)=IDCOUL
  683.             ENDDO
  684.             IRETOU=MELEME
  685.             CTYP='MAILLAGE'
  686.          ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  687.             JG=ML-2
  688.             SEGINI,MLREE1
  689.             MLREE1.PROG(1)=RR1
  690.             DO I=4,ML
  691.                IND=MTABII(I)
  692.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  693.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  694.                IF (IERR.NE.0) RETURN
  695.                MLREE1.PROG(I-2)=RR1
  696.             ENDDO
  697.             IRETOU= MLREE1
  698.             CTYP  ='LISTREEL'
  699.          ELSEIF (CTYP.EQ.'ENTIER') THEN
  700.             JG=ML-2
  701.             SEGINI,MLENT1
  702.             MLENT1.LECT(1)=ID3
  703.             DO I=4,ML
  704.                IND=MTABII(I)
  705.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  706.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  707.                IF (IERR.NE.0) RETURN
  708.                MLENT1.LECT(I-2)=ID3
  709.             ENDDO
  710.             IRETOU= MLENT1
  711.             CTYP  ='LISTENTI'
  712.          ELSEIF (CTYP.EQ.'MAILLAGE') THEN
  713.             DO I=4,ML
  714.                IND=MTABII(I)
  715.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  716.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  717.                IF (IERR.NE.0) RETURN
  718.                CALL FUSE(ID1,ID2,IRETOU,LTELQ)
  719.                IF (IERR.NE.0) RETURN
  720.                ID1=IRETOU
  721.             ENDDO
  722.          ELSEIF (CTYP.EQ.'MCHAML') THEN
  723.             DO I=4,ML
  724.                IND=MTABII(I)
  725.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  726.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  727.                IF (IERR.NE.0) RETURN
  728.                CALL FUSCHL(ID1,ID2,IRETOU)
  729.                IF (IERR.NE.0) RETURN
  730.                ID1=IRETOU
  731.             ENDDO
  732.          ELSEIF (CTYP.EQ.'CHPOINT ') THEN
  733.             DO I=4,ML
  734.                IND=MTABII(I)
  735.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  736.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  737.                IF (IERR.NE.0) RETURN
  738.                CALL FUCHPO(ID1,ID2,IRETOU)
  739.                IF (IERR.NE.0) RETURN
  740.                ID1=IRETOU
  741.             ENDDO
  742.          ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  743.             DO I=4,ML
  744.                IND=MTABII(I)
  745.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  746.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  747.                IF (IERR.NE.0) RETURN
  748.                CALL FUSRIG(ID1,ID2,IRETOU)
  749.                IF (IERR.NE.0) RETURN
  750.                ID1=IRETOU
  751.             ENDDO
  752.          ELSEIF (CTYP.EQ.'MATRIK  ') THEN
  753.             DO I=4,ML
  754.                IND=MTABII(I)
  755.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  756.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  757.                IF (IERR.NE.0) RETURN
  758.                CALL FUSMTK(ID1,ID2,IRETOU)
  759.                IF (IERR.NE.0) RETURN
  760.                ID1=IRETOU
  761.             ENDDO
  762.          ELSEIF (CTYP.EQ.'MMODEL') THEN
  763.             DO I=4,ML
  764.                IND=MTABII(I)
  765.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  766.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  767.                IF (IERR.NE.0) RETURN
  768.                CALL FUSMOD(ID1,ID2,IRETOU)
  769.                IF (IERR.NE.0) RETURN
  770.                ID1=IRETOU
  771.             ENDDO
  772.          ELSEIF (CTYP.EQ.'LISTREEL') THEN
  773.             DO I=4,ML
  774.                IND=MTABII(I)
  775.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  776.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  777.                IF (IERR.NE.0) RETURN
  778.                CALL FUSPRO(ID1,ID2,IRETOU)
  779.                IF (IERR.NE.0) RETURN
  780.                ID1=IRETOU
  781.             ENDDO
  782.          ELSEIF (CTYP.EQ.'LISTENTI') THEN
  783.             DO I=4,ML
  784.                IND=MTABII(I)
  785.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  786.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  787.                IF (IERR.NE.0) RETURN
  788.                CALL FUSLEC(ID1,ID2,IRETOU)
  789.                IF (IERR.NE.0) RETURN
  790.                ID1=IRETOU
  791.             ENDDO
  792.          ELSEIF (CTYP.EQ.'EVOLUTIO') THEN
  793.             DO I=4,ML
  794.                IND=MTABII(I)
  795.                CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  796.      >              CTYP,ID3,RR1,' ',IR1,ID2)
  797.                IF (IERR.NE.0) RETURN
  798.                CALL FUEVOL(ID1,ID2,IRETOU)
  799.                IF (IERR.NE.0) RETURN
  800.                ID1=IRETOU
  801.             ENDDO
  802.          ELSE
  803. *    On ne veut pas d'objet de type %m1:8
  804.             MOTERR(1:8)=CTYP
  805.             CALL ERREUR(39)
  806.             RETURN
  807.          ENDIF
  808.          SEGDES,MTABLE
  809.          GOTO 100
  810.       ENDIF
  811. *     Fusion de tous les indices d'un LISTOBJE (copié sur les TABLES)
  812.  
  813.  1010 CONTINUE
  814.       MLOBJE=IP1
  815.       SEGACT MLOBJE
  816.       CTYP=' '
  817.       CTYP=TYPOBJ
  818.       ML=LISOBJ(/1)
  819.       ID1=LISOBJ(1)
  820.       IF (CTYP.EQ.'POINT') THEN
  821.          NBNN=1
  822.          NBSOUS=0
  823.          NBREF=0
  824.          NBELEM=ML
  825.          SEGINI MELEME
  826.          ITYPEL=1
  827.          DO I=1,ML
  828.             NUM(1,I)=LISOBJ(I)
  829.             ICOLOR(I)=IDCOUL
  830.          ENDDO
  831.          IRETOU=MELEME
  832.          CTYP='MAILLAGE'
  833.       ELSEIF (CTYP.EQ.'ENTIER') THEN
  834.          JG=ML
  835.          SEGINI,MLENT1
  836.          DO I=1,ML
  837.             MLENT1.LECT(I)=LISOBJ(I)
  838.          ENDDO
  839.          IRETOU= MLENT1
  840.          CTYP  ='LISTENTI'
  841.       ELSEIF (CTYP.EQ.'MAILLAGE') THEN
  842.          DO I=2,ML
  843.             ID2=LISOBJ(I)
  844.             CALL FUSE(ID1,ID2,IRETOU,LTELQ)
  845.             IF (IERR.NE.0) RETURN
  846.             ID1=IRETOU
  847.          ENDDO
  848.       ELSEIF (CTYP.EQ.'MCHAML') THEN
  849.          DO I=2,ML
  850.             ID2=LISOBJ(I)
  851.             CALL FUSCHL(ID1,ID2,IRETOU)
  852.             IF (IERR.NE.0) RETURN
  853.             ID1=IRETOU
  854.          ENDDO
  855.       ELSEIF (CTYP.EQ.'CHPOINT ') THEN
  856.          DO I=2,ML
  857.             ID2=LISOBJ(I)
  858.             CALL FUCHPO(ID1,ID2,IRETOU)
  859.             IF (IERR.NE.0) RETURN
  860.             ID1=IRETOU
  861.          ENDDO
  862.       ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  863.          DO I=2,ML
  864.             ID2=LISOBJ(I)
  865.             CALL FUSRIG(ID1,ID2,IRETOU)
  866.             IF (IERR.NE.0) RETURN
  867.             ID1=IRETOU
  868.          ENDDO
  869.       ELSEIF (CTYP.EQ.'MATRIK  ') THEN
  870.          DO I=2,ML
  871.             ID2=LISOBJ(I)
  872.             CALL FUSMTK(ID1,ID2,IRETOU)
  873.             IF (IERR.NE.0) RETURN
  874.             ID1=IRETOU
  875.          ENDDO
  876.       ELSEIF (CTYP.EQ.'MMODEL') THEN
  877.          DO I=2,ML
  878.             ID2=LISOBJ(I)
  879.             CALL FUSMOD(ID1,ID2,IRETOU)
  880.             IF (IERR.NE.0) RETURN
  881.             ID1=IRETOU
  882.          ENDDO
  883.       ELSEIF (CTYP.EQ.'LISTREEL') THEN
  884.          DO I=2,ML
  885.             ID2=LISOBJ(I)
  886.             CALL FUSPRO(ID1,ID2,IRETOU)
  887.             IF (IERR.NE.0) RETURN
  888.             ID1=IRETOU
  889.          ENDDO
  890.       ELSEIF (CTYP.EQ.'LISTENTI') THEN
  891.          DO I=2,ML
  892.             ID2=LISOBJ(I)
  893.             CALL FUSLEC(ID1,ID2,IRETOU)
  894.             IF (IERR.NE.0) RETURN
  895.             ID1=IRETOU
  896.          ENDDO
  897.       ELSEIF (CTYP.EQ.'EVOLUTIO') THEN
  898.          DO I=2,ML
  899.             ID2=LISOBJ(I)
  900.             CALL FUEVOL(ID1,ID2,IRETOU)
  901.             IF (IERR.NE.0) RETURN
  902.             ID1=IRETOU
  903.          ENDDO
  904.       ELSE
  905. *    On ne veut pas d'objet de type %m1:8
  906.          MOTERR(1:8)=CTYP
  907.          CALL ERREUR(39)
  908.          RETURN
  909.       ENDIF
  910.       GOTO 100
  911.  
  912. *     =================
  913. *     Troisième syntaxe
  914. *     =================
  915. *     FUSION TABLE DE MODES
  916.  
  917.  2000 CONTINUE
  918.  
  919.       CALL CRTABL(IPTAB2)
  920.       IPOUT = IPTAB2
  921.       IL = 0
  922.       IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  923.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  924.      &        'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
  925.       ELSE
  926.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  927.      &        'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
  928.          CALL CRTABL(IPTAB3)
  929.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
  930.      &        'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
  931.          IPTAB2 = IPTAB3
  932.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  933.      &        'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
  934.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  935.      &        'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
  936. cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
  937.          CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
  938.      >        'TABLE',ID3,RR1,' ',.TRUE.,IP1)
  939.          IF (IERR.NE.0) RETURN
  940.          MTABLE = IP1
  941.          CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  942.      >        'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
  943.          IF (IERR.NE.0) RETURN
  944.       ENDIF
  945.  
  946. c  ---copie de la IKO ieme table (IKO=1,2)
  947.       IKO = 0
  948.  2100 IKO = IKO + 1
  949.       SEGACT MTABLE
  950.  
  951. c  ---boucle sur les modes ou les solutions statiques
  952.       IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  953.          IMA = MLOTAB - 1
  954.       ELSE
  955.          IMA = MLOTAB - 2
  956.       ENDIF
  957.       IM = 0
  958.  2160 IM = IM + 1
  959.       CTYP=' '
  960.       CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
  961. c      >     'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
  962.      >     CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
  963.       IF(CTYP.NE.'TABLE') GOTO 2161
  964.       IF (ITMOD.GT.0)  THEN
  965.          IL = IL + 1
  966.          CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
  967.      &        'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  968.       ENDIF
  969.  2161 CONTINUE
  970.       IF (IM.LT.IMA) GOTO 2160
  971. c  ---fin de boucle sur les modes ou les solutions statiques
  972.  
  973.       SEGDES MTABLE
  974.       IF (IKO.EQ.1) THEN
  975.          IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  976.             CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
  977.             IF (IRETOU.EQ.0) GOTO 2300
  978.             MTABLE = IP1
  979.          ELSE
  980.             CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
  981.             IF (IRETOU.EQ.0) GOTO 2300
  982.             CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  983.      >           'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
  984. c           fusion des 2 maillages
  985.             CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  986.      >           'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
  987.             CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
  988. *  A qoi sert cet appel a uniq?
  989. **            iordre=0
  990. **            CALL UNIQMA(IPT3,NBDIF,iordre)
  991.             CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  992.      &        'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
  993.          ENDIF
  994.          GOTO 2100
  995.       ENDIF
  996. c  ---fin de boucle sur les tables IKO=1,2
  997.  
  998.  2300 CALL ECROBJ('TABLE   ',ipout)
  999.       RETURN
  1000.  
  1001.  
  1002. *     =========
  1003. *     ERREUR 39
  1004. *     =========
  1005.  999  CONTINUE
  1006. *     On ne veut pas d'objet de type %m1:8
  1007.       MOTERR(1:8)=CTYP
  1008.       CALL ERREUR(39)
  1009.       END
  1010.  
  1011.  
  1012.  
  1013.  

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