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    GOUNAND   25/05/06    21:15:04     12261          
  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.EQ.0) RETURN
  320.          IF (IRETOU.NE.IP1.AND.IRETOU.NE.IP2)
  321.      &       CALL ACTOBJ('CHPOINT ',IRETOU,1)
  322.          GOTO 100
  323.       ELSE
  324. *PM     autrement, on peut obtenir une liste de chpoints
  325.          CALL CRLCHP(IP1)
  326.          GOTO 226
  327.       ENDIF
  328.  
  329. *--   Création RIGIDITE
  330.     4 CONTINUE
  331.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  332.       CALL FUSRIG(IP1,IP2,IRETOU)
  333.       GOTO 100
  334. *--   Création STRUCTURE
  335.  205  CONTINUE
  336.       CALL FUSTRU(IP1,IP2,IRETOU)
  337.       GOTO 100
  338. *--   Création SOLUTION
  339.  206  CONTINUE
  340.       CALL FUSOLU(IP1,IP2,IRETOU)
  341.       GOTO 100
  342. *--   Création ATTACHE
  343.  207  CONTINUE
  344.       CALL FUSATT(IP1,IP2,IRETOU)
  345.       GOTO 100
  346. *--   Création ELEMSTRU
  347.  210  CONTINUE
  348.       CALL FUSELS(IP1,IP2,IRETOU)
  349.       GOTO 100
  350. *--   Création BLOQSTRU
  351.  211  CONTINUE
  352.       CALL FUSCLS(IP1,IP2,IRETOU)
  353.       GOTO 100
  354. *--   Création BASE MODALE
  355.  212  CONTINUE
  356.       CALL FUSBAS(IP1,IP2,IRETOU)
  357.       GOTO 100
  358. *--   Opération LOGIQUE
  359.  213  CONTINUE
  360.       IR3=IR1.AND.IR2
  361. *  lecture optionnelle d'autres logiques
  362.       do i=1,1000
  363.        call lirlog(ir2,0,iretou)
  364.        if(iretou.eq.0) goto 2130
  365.        ir3=ir3.and.ir2
  366.       enddo
  367.  2130 continue
  368.       CALL ECRLOG(IR3)
  369.       RETURN
  370. *--   Création DEFORMEE
  371.  214  CONTINUE
  372.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  373.       CALL FUSDEF(IP1,IP2,IRETOU)
  374.       GOTO 100
  375. *--   Création VECTEUR
  376.  215  CONTINUE
  377.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  378.       CALL FUSVEC (IP1,IP2,IRETOU)
  379.       GOTO 100
  380. *--   Création CHARGEMENT
  381.  216  CONTINUE
  382.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  383.       CALL FUSCHA(IP1,IP2,IRETOU)
  384.       GOTO 100
  385.  
  386. *--   Création LISTREEL
  387.  217  CONTINUE
  388.       IF(IP1 .NE. 0)THEN
  389. C       On a lu un LISTREEL en 1er argument
  390.         IF(IRETOU.EQ.0) THEN
  391. C         On n'a pas lu un LISTREEL en 2eme argument
  392.           CALL QUETYP(CTYP,1,IRETOU)
  393.           IF(IERR.NE.0) RETURN
  394.           IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  395. C         On a lu des objets de types différents mais compatibles
  396.           IF (CTYP.EQ.'ENTIER  ') THEN
  397.              CALL LIRENT(IVAL2,1,IRETOU)
  398.              XVAL2=FLOAT(IVAL2)
  399.           ELSE
  400.              CALL LIRREE(XVAL2,1,IRETOU)
  401.           ENDIF
  402.           IF(IERR.NE.0) RETURN
  403.  
  404.           MLREE2=IP1
  405.           SEGACT,MLREE2
  406.           JG1=MLREE2.PROG(/1)
  407.           JG =JG1 + 1
  408.           SEGINI,MLREE1
  409.           MLREE1.PROG(JG)=XVAL2
  410.           IF(JG1 .GT. 0)THEN
  411. C           Recopie en FORTRAN
  412.             CALL OPTABJ(1,1,3,1,
  413.      &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
  414.      &                  JG1           ,JG1           ,JG1,
  415.      &                  1,0,0.D0,IRETOU)
  416.           ENDIF
  417.         ELSE
  418. C         On a lu un LISTREEL en 2eme argument
  419.           CALL FUSPRO(IP1,IP2,IRETOU)
  420.           MLREE1=IRETOU
  421.         ENDIF
  422.       ELSE
  423. C       On n'a pas lu un LISTREEL en 1er argument
  424.         IF(IRETOU.EQ.0) THEN
  425. C         On n'a pas lu un LISTREEL en 2eme argument
  426.           CALL QUETYP(CTYP,1,IRETOU)
  427.           IF(IERR.NE.0) RETURN
  428.           IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  429. C         On a lu des objets de types différents mais compatibles
  430.           IF (CTYP.EQ.'ENTIER  ') THEN
  431.              CALL LIRENT(IVAL2,1,IRETOU)
  432.              XVAL2=FLOAT(IVAL2)
  433.           ELSE
  434.              CALL LIRREE(XVAL2,1,IRETOU)
  435.           ENDIF
  436.           IF(IERR.NE.0) RETURN
  437.           JG=2
  438.           SEGINI,MLREE1
  439.           MLREE1.PROG(1)=XVAL1
  440.           MLREE1.PROG(2)=XVAL2
  441.         ELSE
  442. C         On a lu un LISTREEL en 2eme argument
  443.           MLREE2=IP2
  444.           SEGACT,MLREE2
  445.           JG1=MLREE2.PROG(/1)
  446.           JG =JG1 + 1
  447.           SEGINI,MLREE1
  448.           MLREE1.PROG(1)=XVAL1
  449.           IF(JG1 .GT. 0) THEN
  450. C           Recopie en FORTRAN
  451.             CALL OPTABJ(1,1,3,1,
  452.      &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
  453.      &                  JG1           ,JG1           ,JG1,
  454.      &                  1,0,0.D0,IRETOU)
  455.           ENDIF
  456.         ENDIF
  457.       ENDIF
  458.       CTYP='LISTREEL'
  459.       SEGACT,MLREE1*NOMOD
  460.       IRETOU=MLREE1
  461.       GOTO 100
  462.  
  463. *--   Création LISTENTI
  464.  218  CONTINUE
  465.       IF(IRETOU.EQ.0) THEN
  466. *       on n'a pas lu un LISTENTI
  467.          CALL QUETYP(CTYP,1,IRETOU)
  468.          IF(IERR.NE.0) RETURN
  469.          IF(CTYP.NE.'ENTIER  ') GOTO 999
  470.          CALL LIRENT(IP2,1,IRETOU)
  471.          IF(IERR.NE.0) RETURN
  472.          CALL CRELEC(IP2)
  473.       ENDIF
  474.       CTYP='LISTENTI'
  475.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  476.       CALL FUSLEC(IP1,IP2,IRETOU)
  477.       GOTO 100
  478.  
  479. *--   Création EVOLUTION
  480.  219  CONTINUE
  481.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  482.       CALL FUEVOL(IP1,IP2,IRETOU)
  483.       GOTO 100
  484. *--   Création MODELE
  485.  220  CONTINUE
  486.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  487.       CALL FUSMOD(IP1,IP2,IRETOU)
  488.       GOTO 100
  489. *--   Création MCHAML
  490.  221  CONTINUE
  491.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  492.       CALL ETMCHL(IP1,IP2,IRETOU)
  493.       GOTO 100
  494.  
  495. *--   Création LISTMOTS
  496.  222  CONTINUE
  497.       IF    (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
  498. C       LISTMOTS 'ET' LISTMOTS
  499.         CALL FUSMOT(IP1,IP2,IRETOU)
  500.  
  501.       ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
  502. C       LISTMOTS 'ET' MOT
  503.         CALL QUETYP(CTYP2,0,IRETOU)
  504.         IF(CTYP2 .EQ. 'MOT') THEN
  505.           CALL LIRCHA(LEMOT1,1,IRET1)
  506.           IF (IERR.NE.0) RETURN
  507.           MLMOT1=IP1
  508.           SEGACT,MLMOT1
  509.           JGN=MLMOT1.MOTS(/1)
  510.           JGM=MLMOT1.MOTS(/2)+1
  511.           SEGINI,MLMOT2
  512.           IRETOU=MLMOT2
  513.           DO III=1,JGM-1
  514.             MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
  515.           ENDDO
  516.           MLMOT2.MOTS(JGM)=LEMOT1
  517.           SEGDES,MLMOT1,MLMOT2
  518.         ELSE
  519.           GOTO 999
  520.         ENDIF
  521.  
  522.       ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
  523. C       MOT 'ET' LISTMOTS
  524.         IF(CTYP .EQ. 'MOT') THEN
  525.           CTYP = CTYP2
  526.           MLMOT1=IP2
  527.           SEGACT,MLMOT1
  528.           JGN=MLMOT1.MOTS(/1)
  529.           JGM=MLMOT1.MOTS(/2)+1
  530.           SEGINI,MLMOT2
  531.           IRETOU=MLMOT2
  532.           MLMOT2.MOTS(1)=LEMOT1(1:JGN)
  533.           DO III=2,JGM
  534.             MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
  535.           ENDDO
  536.           SEGDES,MLMOT1,MLMOT2
  537.         ELSE
  538.           GOTO 999
  539.         ENDIF
  540.       ENDIF
  541.       GOTO 100
  542. *--   Création NUAGE
  543.  223  CONTINUE
  544.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  545.       CALL FUSNUA(IP1,IP2,IRETOU)
  546.       GOTO 100
  547. *--   Création MATRIK
  548.  224  CONTINUE
  549.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  550.       CALL FUSMTK(IP1,IP2,IRETOU)
  551.       GOTO 100
  552. *--   Création LISTCHPO
  553.  226  CONTINUE
  554.       IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
  555.       IF(IRETOU.EQ.0) THEN
  556. *       on a lu des objets de types différents mais compatibles
  557. *       (le cas de 2 champ-points est traité ailleurs)
  558.          CALL MESLIR(-221)
  559.          IF(CTYP.EQ.'CHPOINT ') THEN
  560.             CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
  561.             CALL ACTOBJ('LISTCHPO',IP2,1)
  562.          ELSE
  563.             CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
  564.             CALL ACTOBJ('CHPOINT ',IP2,1)
  565.             CALL CRLCHP(IP2)
  566.          ENDIF
  567.          IF(IERR.NE.0) RETURN
  568.       ENDIF
  569.       CTYP='LISTCHPO'
  570.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  571.       CALL FUSSUI(IP1,IP2,IRETOU)
  572.       GOTO 100
  573. *--   Création ANNOTATI
  574.  227  CONTINUE
  575.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  576.       MANNO1=IP1
  577.       MANNO2=IP2
  578.       SEGACT,MANNO1,MANNO2
  579.       NBANN1=MANNO1.ICLAS(/1)
  580.       NBANN2=MANNO2.ICLAS(/1)
  581.       NBANNO=NBANN1+NBANN2
  582.       SEGINI,MANNO3
  583.       DO K1=1,NBANN1
  584.           MANNO3.ICLAS(K1) = MANNO1.ICLAS(K1)
  585.           MANNO3.ISEGT(K1) = MANNO1.ISEGT(K1)
  586.       ENDDO
  587.       DO K2=1,NBANN2
  588.           MANNO3.ICLAS(NBANN1+K2) = MANNO2.ICLAS(K2)
  589.           MANNO3.ISEGT(NBANN1+K2) = MANNO2.ISEGT(K2)
  590.       ENDDO
  591.       IRETOU=MANNO3
  592.       GOTO 100
  593. *--   Creation LISTOBJE
  594.  228  CONTINUE
  595. C     On a forcément un LISTOBJE en premier argument
  596.       IF (CTYP.NE.CTYP2) THEN
  597. C     LISTOBJE ET "un autre objet"
  598.          MLOBJ1 = IP1
  599.          SEGACT,MLOBJ1
  600.          CTYP1 = MLOBJ1.TYPOBJ
  601.          NBOB1 = MLOBJ1.LISOBJ(/1)
  602.          IF (CTYP1.NE.CTYP2.AND.NBOB1.NE.0) THEN
  603.             CTYP = CTYP2
  604.             GOTO 999
  605.          ENDIF
  606.          NOBJ = 1
  607.          SEGINI,MLOBJE
  608.          TYPOBJ    = CTYP2
  609.          LISOBJ(1) = IP2
  610.          IP2 = MLOBJE
  611.       ENDIF
  612.       CALL FUSLOB(IP1,IP2,IRETOU)
  613.       IF (IERR.NE.0) RETURN
  614.       GOTO 100
  615.  
  616. *     Sortie sans problème, écriture résultat
  617.  100  CONTINUE
  618.       CALL ACTOBJ(CTYP,IRETOU,1)
  619.       CALL ECROBJ(CTYP,IRETOU)
  620.       RETURN
  621.  
  622. *     Fusion de chaines, limitation à 512 caractères
  623.  225  CONTINUE
  624.       IRET=IRET1+IRET2
  625.       IF(IRET.GT.512) THEN
  626.          CALL ERREUR(1110)
  627.          RETURN
  628.       ENDIF
  629.       LEMOT(1:IRET1) = LEMOT1(1:IRET1)
  630.       LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
  631.       CALL ECRCHA(LEMOT(1:IRET))
  632.       RETURN
  633.  
  634.  
  635. *     ================
  636. *     Deuxième syntaxe
  637. *     ================
  638. *     Fusion de tous les indices d'une table
  639.  
  640.  1000 CONTINUE
  641.  1010 CONTINUE
  642. *      WRITE(IOIMP,*) 'Utilisez ETG please'
  643. *      CALL ERREUR(5)
  644. * Plus sympa
  645.       CALL REFUS
  646.       CALL ETG
  647.       RETURN
  648.  
  649. *     =================
  650. *     Troisième syntaxe
  651. *     =================
  652. *     FUSION TABLE DE MODES
  653.  
  654.  2000 CONTINUE
  655.  
  656.       CALL CRTABL(IPTAB2)
  657.       IPOUT = IPTAB2
  658.       IL = 0
  659.       IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  660.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  661.      &        'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
  662.       ELSE
  663.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  664.      &        'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
  665.          CALL CRTABL(IPTAB3)
  666.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
  667.      &        'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
  668.          IPTAB2 = IPTAB3
  669.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  670.      &        'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
  671.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  672.      &        'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
  673. cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
  674.          CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
  675.      >        'TABLE',ID3,RR1,' ',.TRUE.,IP1)
  676.          IF (IERR.NE.0) RETURN
  677.          MTABLE = IP1
  678.          CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  679.      >        'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
  680.          IF (IERR.NE.0) RETURN
  681.       ENDIF
  682.  
  683. c  ---copie de la IKO ieme table (IKO=1,2)
  684.       IKO = 0
  685.  2100 IKO = IKO + 1
  686.       SEGACT MTABLE
  687.  
  688. c  ---boucle sur les modes ou les solutions statiques
  689.       IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  690.          IMA = MLOTAB - 1
  691.       ELSE
  692.          IMA = MLOTAB - 2
  693.       ENDIF
  694.       IM = 0
  695.  2160 IM = IM + 1
  696.       CTYP=' '
  697.       CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
  698. c      >     'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
  699.      >     CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
  700.       IF(CTYP.NE.'TABLE') GOTO 2161
  701.       IF (ITMOD.GT.0)  THEN
  702.          IL = IL + 1
  703.          CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
  704.      &        'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  705.       ENDIF
  706.  2161 CONTINUE
  707.       IF (IM.LT.IMA) GOTO 2160
  708. c  ---fin de boucle sur les modes ou les solutions statiques
  709.  
  710.       SEGDES MTABLE
  711.       IF (IKO.EQ.1) THEN
  712.          IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  713.             CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
  714.             IF (IRETOU.EQ.0) GOTO 2300
  715.             MTABLE = IP1
  716.          ELSE
  717.             CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
  718.             IF (IRETOU.EQ.0) GOTO 2300
  719.             CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  720.      >           'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
  721. c           fusion des 2 maillages
  722.             CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  723.      >           'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
  724.             CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
  725. *  A qoi sert cet appel a uniq?
  726. **            iordre=0
  727. **            CALL UNIQMA(IPT3,NBDIF,iordre)
  728.             CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  729.      &        'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
  730.          ENDIF
  731.          GOTO 2100
  732.       ENDIF
  733. c  ---fin de boucle sur les tables IKO=1,2
  734.  
  735.  2300 CALL ECROBJ('TABLE   ',ipout)
  736.       RETURN
  737.  
  738.  
  739. *     =========
  740. *     ERREUR 39
  741. *     =========
  742.  999  CONTINUE
  743. *     On ne veut pas d'objet de type %m1:8
  744.       MOTERR(1:8)=CTYP
  745.       CALL ERREUR(39)
  746.       END
  747.  
  748.  

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