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    SP204843  26/02/03    21:15:33     12461          
  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. C     write(6,*) 'prfuse:CTYP=',CTYP
  66.  
  67.       IF(CTYP.EQ.'LOGIQUE ') THEN
  68.          CALL MESLIR(-225)
  69.          CALL LIRLOG(IR1,1,IRETOU)
  70.          CALL MESLIR(-223)
  71.          CALL LIRLOG(IR2,1,IRETOU)
  72.          IF(IERR.NE.0) RETURN
  73.          GOTO 213
  74.  
  75.       ELSE IF(CTYP.EQ.'MOT     ') THEN
  76.          CALL LIRCHA(LEMOT1,1,IRET1)
  77.          IF (IERR.NE.0) RETURN
  78.  
  79.          CALL QUETYP(CTYP2,0,IRETOU)
  80.          IF(IRETOU.EQ.0) THEN
  81. *          Cet opérateur a encore besoin d'un opérande.
  82.             CALL ERREUR (533)
  83.             RETURN
  84.          ENDIF
  85.          IF(CTYP2 .EQ. 'LISTMOTS') THEN
  86.            CALL LIROBJ('LISTMOTS',IP2,1,IRETOU)
  87.            IF(IERR.NE.0) RETURN
  88.            GOTO 222
  89.  
  90.          ELSE
  91.            CALL LIRCHA(LEMOT2,1,IRET2)
  92.            IF( IERR.NE.0) RETURN
  93.            IF (LTELQ) THEN
  94. *            Concaténation avec respect des espaces avant et après
  95.            ELSE
  96. *            Suppressions des espaces en fin de mot
  97.              IRET1=LONG(LEMOT1)
  98.              IRET2=LONG(LEMOT2)
  99.            ENDIF
  100.            GOTO 225
  101.          ENDIF
  102.  
  103.       ELSE IF(CTYP.EQ.'FLOTTANT') THEN
  104.          CALL LIRREE(XVAL1,1,IRETOU)
  105.          IF(IERR.NE.0) RETURN
  106.          CTYP='LISTREEL'
  107.          II=16
  108.          GOTO 24
  109.  
  110.       ELSE IF(CTYP.EQ.'ENTIER  ') THEN
  111.          CALL LIRENT(IP1,1,IRETOU)
  112.          IF(IERR.NE.0) RETURN
  113. *       suivant que l'objet suivant est un ENTIER/LISTENTI ou pas,
  114. *       on considère cette entrée comme un FLOTTANT
  115.          CALL QUETYP(CTYP,1,IRETOU)
  116.          IF(IERR.NE.0) RETURN
  117.          IF(CTYP.NE.'ENTIER  '.AND.CTYP.NE.'LISTENTI') THEN
  118.             XVAL1=FLOAT(IP1)
  119.             IP1=0
  120.             CTYP='LISTREEL'
  121.             II=16
  122.          ELSE
  123.             CALL CRELEC(IP1)
  124.             CTYP='LISTENTI'
  125.             II=17
  126.          ENDIF
  127.          GOTO 24
  128.  
  129.       ELSE
  130.          MOTERR(1:8)=CTYP
  131.          CALL MESLIR(-222)
  132.          CALL LIROBJ(CTYP,IP1,1,IRETOU)
  133.          IF(CTYP.EQ.'POINT   ') THEN
  134.             II = 1
  135.             GOTO 24
  136.          ENDIF
  137.          IF(CTYP.EQ.'MAILLAGE') THEN
  138.             II = 2
  139.             GOTO 24
  140.          ENDIF
  141.          IF(CTYP.EQ.'CHPOINT ') THEN
  142.             CALL ACTOBJ(CTYP,IP1,1)
  143.             II = 3
  144.             GOTO 24
  145.          ENDIF
  146.          IF(CTYP.EQ.'MCHAML  ') THEN
  147.             CALL ACTOBJ(CTYP,IP1,1)
  148.             II = 20
  149.             GOTO 24
  150.          ENDIF
  151.          IF(CTYP.EQ.'RIGIDITE') THEN
  152.             II = 4
  153.             GOTO 24
  154.          ENDIF
  155.          IF(CTYP.EQ.'EVOLUTIO') THEN
  156.             II = 18
  157.             GOTO 24
  158.          ENDIF
  159.          IF(CTYP.EQ.'CHARGEME') THEN
  160.             II = 15
  161.             GOTO 24
  162.          ENDIF
  163.          IF(CTYP.EQ.'STRUCTUR') THEN
  164.             II = 5
  165.             GOTO 24
  166.          ENDIF
  167.          IF(CTYP.EQ.'SOLUTION') THEN
  168.             II = 6
  169.             GOTO 24
  170.          ENDIF
  171.          IF(CTYP.EQ.'ATTACHE ') THEN
  172.             II = 7
  173.             GOTO 24
  174.          ENDIF
  175.          IF(CTYP.EQ.'ELEMSTRU') THEN
  176.             II = 10
  177.             GOTO 24
  178.          ENDIF
  179.          IF(CTYP.EQ.'BLOQSTRU') THEN
  180.             II = 11
  181.             GOTO 24
  182.          ENDIF
  183.          IF(CTYP.EQ.'BASEMODA') THEN
  184.             II = 12
  185.             GOTO 24
  186.          ENDIF
  187.          IF(CTYP.EQ.'DEFORME ') THEN
  188.             II = 13
  189.             GOTO 24
  190.          ENDIF
  191.          IF(CTYP.EQ.'VECTEUR ') THEN
  192.             II = 14
  193.             GOTO 24
  194.          ENDIF
  195.          IF(CTYP.EQ.'LISTREEL') THEN
  196.             II = 16
  197.             GOTO 24
  198.          ENDIF
  199.          IF(CTYP.EQ.'LISTENTI') THEN
  200.             II = 17
  201.             GOTO 24
  202.          ENDIF
  203.          IF(CTYP.EQ.'MMODEL  ') THEN
  204.             CALL ACTOBJ(CTYP,IP1,1)
  205.             II = 19
  206.             GOTO 24
  207.          ENDIF
  208.          IF(CTYP.EQ.'LISTMOTS') THEN
  209.             II = 21
  210.             GOTO 24
  211.          ENDIF
  212.          IF(CTYP.EQ.'NUAGE   ') THEN
  213.             II = 22
  214.             GOTO 24
  215.          ENDIF
  216.          IF(CTYP.EQ.'MATRIK') THEN
  217.             II = 23
  218.             GOTO 24
  219.          ENDIF
  220.          IF(CTYP.EQ.'LISTCHPO') THEN
  221.             II = 24
  222.             GOTO 24
  223.          ENDIF
  224.          IF(CTYP.EQ.'ANNOTATI') THEN
  225.             II = 25
  226.             GOTO 24
  227.          ENDIF
  228.          IF(CTYP.EQ.'LISTOBJE') THEN
  229.             II = 26
  230.             GOTO 24
  231.          ENDIF
  232.  
  233.          IF(CTYP.EQ.'TABLE') THEN
  234.             MTABLE = IP1
  235.             CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  236.      >           'MOT',ID3,RR1,LEMOT,IR1,ID2)
  237.             IF (LEMOT.EQ.'LIAISONS_STATIQUES'.OR.
  238.      >           LEMOT.EQ.'BASE_MODALE') GOTO 2000
  239.             GOTO 1000
  240.          ENDIF
  241.  
  242.          GOTO 999
  243.  
  244.       ENDIF
  245.  
  246.  
  247. *     ================
  248. *     Première syntaxe
  249. *     ================
  250.  
  251. *     Lecture deuxième objet, lui aussi avec pointeur
  252. *     -----------------------------------------------
  253.  24   CONTINUE
  254.  
  255.       ICODE=1
  256. *     pour les fusions mixtes, on est encore indécis sur le type du
  257. *     deuxième objet.
  258.       IF(CTYP.EQ.'POINT   '.OR.CTYP.EQ.'MAILLAGE'.OR.
  259.      &   CTYP.EQ.'LISTENTI'.OR.CTYP.EQ.'LISTREEL'.OR.
  260.      &   CTYP.EQ.'LISTMOTS'.OR.
  261.      &   CTYP.EQ.'CHPOINT '.OR.CTYP.EQ.'LISTCHPO'.OR.
  262.      &   CTYP.EQ.'LISTOBJE') ICODE=0
  263.  
  264. *     on lit a priori un objet de même type que le premier
  265.       CALL QUETYP(CTYP2 , ICODE , IRETOU )
  266. *     cas où on a un LISTOBJE uniquement, on fait la 2eme syntaxe
  267.       IF (CTYP.EQ.'LISTOBJE'.AND.IRETOU.EQ.0) GOTO 1010
  268.       IF (CTYP.EQ.'LISTOBJE'.OR.CTYP2.EQ.'LISTOBJE') THEN
  269.          CALL LIROBJ(CTYP2,IP2,1,IRETOU)
  270.          IF(IERR.NE.0) RETURN
  271.          II = 26
  272.          IF (CTYP.NE.'LISTOBJE') THEN
  273.             IPX = IP2
  274.             IP2 = IP1
  275.             IP1 = IPX
  276.             CTYP1 = CTYP2
  277.             CTYP2 = CTYP
  278.             CTYP  = CTYP1
  279.          ENDIF
  280.       ELSE
  281.          MOTERR(1:8)=CTYP
  282.          CALL MESLIR(-221)
  283.          CALL LIROBJ(CTYP,IP2,ICODE,IRETOU)
  284.          IF(IRETOU .EQ. 1) CALL ACTOBJ(CTYP,IP2,1)
  285.          IF(IERR.NE.0) RETURN
  286.       ENDIF
  287.  
  288. C     write(6,*) '2prfuse:CTYP,II=',CTYP,II
  289.       GOTO ( 1,2,3,4,205,206,207,999,999,210,211,212,214,215,216,
  290.      $     217,218,219,220,221,222,223,224,226,227,228),II
  291.  
  292. *--   Création maillage
  293.  1    CONTINUE
  294.       CALL CRELEM(IP1)
  295.  2    CONTINUE
  296.       IF (CTYP.NE.'POINT   '.AND.CTYP.NE.'MAILLAGE') GOTO 999
  297.       IF(IRETOU.EQ.1.AND.CTYP.EQ.'POINT   ') THEN
  298. *       on a deux points
  299.          CALL CRELEM(IP2)
  300.       ENDIF
  301.       IF(IRETOU.EQ.0) THEN
  302. *       on a lu des objets de types différents mais compatibles
  303.          CALL MESLIR(-220)
  304.          IF(CTYP.EQ.'POINT   ') CALL LIROBJ('MAILLAGE',IP2,1,IRETAU)
  305.          IF(CTYP.EQ.'MAILLAGE') THEN
  306.             CALL LIROBJ('POINT   ',IP2,1,IRETAU)
  307.             IF(IRETAU.EQ.1) CALL CRELEM(IP2)
  308.          ENDIF
  309.          IF(IERR.NE.0) RETURN
  310.       ENDIF
  311.       CTYP='MAILLAGE'
  312.       CALL FUSE(IP1,IP2,IRETOU,LTELQ)
  313.       GOTO 100
  314.  
  315. *--   Création CHPOINT
  316.     3 CONTINUE
  317.       IF(IRETOU.EQ.1) THEN
  318. *       La concaténation de deux champ-points donne un champ-point
  319.          IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  320.          CALL FUCHPO(IP1,IP2,IRETOU)
  321.          IF (IRETOU.EQ.0) RETURN
  322.          IF (IRETOU.NE.IP1.AND.IRETOU.NE.IP2)
  323.      &       CALL ACTOBJ('CHPOINT ',IRETOU,1)
  324.          GOTO 100
  325.       ELSE
  326. *PM     autrement, on peut obtenir une liste de chpoints
  327.          CALL CRLCHP(IP1)
  328.          GOTO 226
  329.       ENDIF
  330.  
  331. *--   Création RIGIDITE
  332.     4 CONTINUE
  333.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  334.       CALL FUSRIG(IP1,IP2,IRETOU)
  335.       GOTO 100
  336. *--   Création STRUCTURE
  337.  205  CONTINUE
  338.       CALL FUSTRU(IP1,IP2,IRETOU)
  339.       GOTO 100
  340. *--   Création SOLUTION
  341.  206  CONTINUE
  342.       CALL FUSOLU(IP1,IP2,IRETOU)
  343.       GOTO 100
  344. *--   Création ATTACHE
  345.  207  CONTINUE
  346.       CALL FUSATT(IP1,IP2,IRETOU)
  347.       GOTO 100
  348. *--   Création ELEMSTRU
  349.  210  CONTINUE
  350.       CALL FUSELS(IP1,IP2,IRETOU)
  351.       GOTO 100
  352. *--   Création BLOQSTRU
  353.  211  CONTINUE
  354.       CALL FUSCLS(IP1,IP2,IRETOU)
  355.       GOTO 100
  356. *--   Création BASE MODALE
  357.  212  CONTINUE
  358.       CALL FUSBAS(IP1,IP2,IRETOU)
  359.       GOTO 100
  360. *--   Opération LOGIQUE
  361.  213  CONTINUE
  362.       IR3=IR1.AND.IR2
  363. *  lecture optionnelle d'autres logiques
  364.       do i=1,1000
  365.        call lirlog(ir2,0,iretou)
  366.        if(iretou.eq.0) goto 2130
  367.        ir3=ir3.and.ir2
  368.       enddo
  369.  2130 continue
  370.       CALL ECRLOG(IR3)
  371.       RETURN
  372. *--   Création DEFORMEE
  373.  214  CONTINUE
  374.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  375.       CALL FUSDEF(IP1,IP2,IRETOU)
  376.       GOTO 100
  377. *--   Création VECTEUR
  378.  215  CONTINUE
  379.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  380.       CALL FUSVEC (IP1,IP2,IRETOU)
  381.       GOTO 100
  382. *--   Création CHARGEMENT
  383.  216  CONTINUE
  384.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  385.       CALL FUSCHA(IP1,IP2,IRETOU)
  386.       GOTO 100
  387.  
  388. *--   Création LISTREEL
  389.  217  CONTINUE
  390.       IF(IP1 .NE. 0)THEN
  391. C       On a lu un LISTREEL en 1er argument
  392.         IF(IRETOU.EQ.0) THEN
  393. C         On n'a pas lu un LISTREEL en 2eme argument
  394.           CALL QUETYP(CTYP,1,IRETOU)
  395.           IF(IERR.NE.0) RETURN
  396.           IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  397. C         On a lu des objets de types différents mais compatibles
  398.           IF (CTYP.EQ.'ENTIER  ') THEN
  399.              CALL LIRENT(IVAL2,1,IRETOU)
  400.              XVAL2=FLOAT(IVAL2)
  401.           ELSE
  402.              CALL LIRREE(XVAL2,1,IRETOU)
  403.           ENDIF
  404.           IF(IERR.NE.0) RETURN
  405.  
  406.           MLREE2=IP1
  407.           SEGACT,MLREE2
  408.           JG1=MLREE2.PROG(/1)
  409.           JG =JG1 + 1
  410.           SEGINI,MLREE1
  411.           MLREE1.PROG(JG)=XVAL2
  412.           IF(JG1 .GT. 0)THEN
  413. C           Recopie en FORTRAN
  414.             CALL OPTABJ(1,1,3,1,
  415.      &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
  416.      &                  JG1           ,JG1           ,JG1,
  417.      &                  1,0,0.D0,IRETOU)
  418.           ENDIF
  419.         ELSE
  420. C         On a lu un LISTREEL en 2eme argument
  421.           CALL FUSPRO(IP1,IP2,IRETOU)
  422.           MLREE1=IRETOU
  423.         ENDIF
  424.       ELSE
  425. C       On n'a pas lu un LISTREEL en 1er argument
  426.         IF(IRETOU.EQ.0) THEN
  427. C         On n'a pas lu un LISTREEL en 2eme argument
  428.           CALL QUETYP(CTYP,1,IRETOU)
  429.           IF(IERR.NE.0) RETURN
  430.           IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  431. C         On a lu des objets de types différents mais compatibles
  432.           IF (CTYP.EQ.'ENTIER  ') THEN
  433.              CALL LIRENT(IVAL2,1,IRETOU)
  434.              XVAL2=FLOAT(IVAL2)
  435.           ELSE
  436.              CALL LIRREE(XVAL2,1,IRETOU)
  437.           ENDIF
  438.           IF(IERR.NE.0) RETURN
  439.           JG=2
  440.           SEGINI,MLREE1
  441.           MLREE1.PROG(1)=XVAL1
  442.           MLREE1.PROG(2)=XVAL2
  443.         ELSE
  444. C         On a lu un LISTREEL en 2eme argument
  445.           MLREE2=IP2
  446.           SEGACT,MLREE2
  447.           JG1=MLREE2.PROG(/1)
  448.           JG =JG1 + 1
  449.           SEGINI,MLREE1
  450.           MLREE1.PROG(1)=XVAL1
  451.           IF(JG1 .GT. 0) THEN
  452. C           Recopie en FORTRAN
  453.             CALL OPTABJ(1,1,3,1,
  454.      &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
  455.      &                  JG1           ,JG1           ,JG1,
  456.      &                  1,0,0.D0,IRETOU)
  457.           ENDIF
  458.         ENDIF
  459.       ENDIF
  460.       CTYP='LISTREEL'
  461.       SEGACT,MLREE1*NOMOD
  462.       IRETOU=MLREE1
  463.       GOTO 100
  464.  
  465. *--   Création LISTENTI
  466.  218  CONTINUE
  467.       IF(IRETOU.EQ.0) THEN
  468. *       on n'a pas lu un LISTENTI
  469.          CALL QUETYP(CTYP,1,IRETOU)
  470.          IF(IERR.NE.0) RETURN
  471.          IF(CTYP.NE.'ENTIER  ') GOTO 999
  472.          CALL LIRENT(IP2,1,IRETOU)
  473.          IF(IERR.NE.0) RETURN
  474.          CALL CRELEC(IP2)
  475.       ENDIF
  476.       CTYP='LISTENTI'
  477.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  478.       CALL FUSLEC(IP1,IP2,IRETOU)
  479.       GOTO 100
  480.  
  481. *--   Création EVOLUTION
  482.  219  CONTINUE
  483.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  484.       CALL FUEVOL(IP1,IP2,IRETOU)
  485.       GOTO 100
  486. *--   Création MODELE
  487.  220  CONTINUE
  488.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  489.       CALL FUSMOD(IP1,IP2,IRETOU)
  490.       GOTO 100
  491. *--   Création MCHAML
  492.  221  CONTINUE
  493.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  494.       CALL ETMCHL(IP1,IP2,IRETOU)
  495.       GOTO 100
  496.  
  497. *--   Création LISTMOTS
  498.  222  CONTINUE
  499.       IF    (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
  500. C       LISTMOTS 'ET' LISTMOTS
  501.         CALL FUSMOT(IP1,IP2,IRETOU)
  502.  
  503.       ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
  504. C       LISTMOTS 'ET' MOT
  505.         CALL QUETYP(CTYP2,0,IRETOU)
  506.         IF(CTYP2 .EQ. 'MOT') THEN
  507.           CALL LIRCHA(LEMOT1,1,IRET1)
  508.           IF (IERR.NE.0) RETURN
  509.           MLMOT1=IP1
  510.           SEGACT,MLMOT1
  511.           JGN=MLMOT1.MOTS(/1)
  512.           JGM=MLMOT1.MOTS(/2)+1
  513.           SEGINI,MLMOT2
  514.           IRETOU=MLMOT2
  515.           DO III=1,JGM-1
  516.             MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
  517.           ENDDO
  518.           MLMOT2.MOTS(JGM)=LEMOT1
  519.           SEGDES,MLMOT1,MLMOT2
  520.         ELSE
  521.           GOTO 999
  522.         ENDIF
  523.  
  524.       ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
  525. C       MOT 'ET' LISTMOTS
  526.         IF(CTYP .EQ. 'MOT') THEN
  527.           CTYP = CTYP2
  528.           MLMOT1=IP2
  529.           SEGACT,MLMOT1
  530.           JGN=MLMOT1.MOTS(/1)
  531.           JGM=MLMOT1.MOTS(/2)+1
  532.           SEGINI,MLMOT2
  533.           IRETOU=MLMOT2
  534.           MLMOT2.MOTS(1)=LEMOT1(1:JGN)
  535.           DO III=2,JGM
  536.             MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
  537.           ENDDO
  538.           SEGDES,MLMOT1,MLMOT2
  539.         ELSE
  540.           GOTO 999
  541.         ENDIF
  542.       ENDIF
  543.       GOTO 100
  544. *--   Création NUAGE
  545.  223  CONTINUE
  546.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  547.       CALL FUSNUA(IP1,IP2,IRETOU)
  548.       GOTO 100
  549. *--   Création MATRIK
  550.  224  CONTINUE
  551.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  552.       CALL FUSMTK(IP1,IP2,IRETOU)
  553.       GOTO 100
  554. *--   Création LISTCHPO
  555.  226  CONTINUE
  556.       IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
  557.       IF(IRETOU.EQ.0) THEN
  558. *       on a lu des objets de types différents mais compatibles
  559. *       (le cas de 2 champ-points est traité ailleurs)
  560.          CALL MESLIR(-221)
  561.          IF(CTYP.EQ.'CHPOINT ') THEN
  562.             CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
  563.             CALL ACTOBJ('LISTCHPO',IP2,1)
  564.          ELSE
  565.             CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
  566.             CALL ACTOBJ('CHPOINT ',IP2,1)
  567.             CALL CRLCHP(IP2)
  568.          ENDIF
  569.          IF(IERR.NE.0) RETURN
  570.       ENDIF
  571.       CTYP='LISTCHPO'
  572.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  573.       CALL FUSSUI(IP1,IP2,IRETOU)
  574.       GOTO 100
  575. *--   Création ANNOTATI
  576.  227  CONTINUE
  577.       IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  578.       MANNO1=IP1
  579.       MANNO2=IP2
  580.       SEGACT,MANNO1,MANNO2
  581.       NBANN1=MANNO1.ICLAS(/1)
  582.       NBANN2=MANNO2.ICLAS(/1)
  583.       NBANNO=NBANN1+NBANN2
  584.       SEGINI,MANNO3
  585.       DO K1=1,NBANN1
  586.           MANNO3.ICLAS(K1) = MANNO1.ICLAS(K1)
  587.           MANNO3.ISEGT(K1) = MANNO1.ISEGT(K1)
  588.       ENDDO
  589.       DO K2=1,NBANN2
  590.           MANNO3.ICLAS(NBANN1+K2) = MANNO2.ICLAS(K2)
  591.           MANNO3.ISEGT(NBANN1+K2) = MANNO2.ISEGT(K2)
  592.       ENDDO
  593.       IRETOU=MANNO3
  594.       GOTO 100
  595. *--   Creation LISTOBJE
  596.  228  CONTINUE
  597. C     On a forcément un LISTOBJE en premier argument
  598.       IF (CTYP.NE.CTYP2) THEN
  599. C     LISTOBJE ET "un autre objet"
  600.          MLOBJ1 = IP1
  601.          SEGACT,MLOBJ1
  602.          CTYP1 = MLOBJ1.TYPOBJ
  603.          NBOB1 = MLOBJ1.LISOBJ(/1)
  604.          NBRE1 = MLOBJ1.RLIREE(/1)
  605.          NBEL1 = MAX(NBOB1,NBRE1)
  606.          IF (CTYP1.NE.CTYP2.AND.NBEL1.NE.0) THEN
  607.             CTYP = CTYP2
  608.             GOTO 999
  609.          ENDIF
  610.          IK = 1
  611.          IF (CTYP2.EQ.'FLOTTANT') IK = 2
  612.          IF (IK.EQ.1) THEN
  613.            NOBJ = 1
  614.            NREE = 0
  615.            SEGINI,MLOBJE
  616.            TYPOBJ    = CTYP2
  617.            LISOBJ(1) = IP2
  618.          ELSE IF (IK.EQ.2) THEN
  619.            NOBJ = 0
  620.            NREE = 1
  621.            SEGINI,MLOBJE
  622.            TYPOBJ    = CTYP2
  623.            RLIREE(1) = XVAL1
  624.          ENDIF
  625.          IP2 = MLOBJE
  626.       ENDIF
  627.       CALL FUSLOB(IP1,IP2,IRETOU)
  628.       IF (IERR.NE.0) RETURN
  629.       GOTO 100
  630.  
  631. *     Sortie sans problème, écriture résultat
  632.  100  CONTINUE
  633.       CALL ACTOBJ(CTYP,IRETOU,1)
  634.       CALL ECROBJ(CTYP,IRETOU)
  635.       RETURN
  636.  
  637. *     Fusion de chaines, limitation à 512 caractères
  638.  225  CONTINUE
  639.       IRET=IRET1+IRET2
  640.       IF(IRET.GT.512) THEN
  641.          CALL ERREUR(1110)
  642.          RETURN
  643.       ENDIF
  644.       LEMOT(1:IRET1) = LEMOT1(1:IRET1)
  645.       LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
  646.       CALL ECRCHA(LEMOT(1:IRET))
  647.       RETURN
  648.  
  649.  
  650. *     ================
  651. *     Deuxième syntaxe
  652. *     ================
  653. *     Fusion de tous les indices d'une table
  654.  
  655.  1000 CONTINUE
  656.  1010 CONTINUE
  657. *      WRITE(IOIMP,*) 'Utilisez ETG please'
  658. *      CALL ERREUR(5)
  659. * Plus sympa
  660.       CALL REFUS
  661.       CALL ETG
  662.       RETURN
  663.  
  664. *     =================
  665. *     Troisième syntaxe
  666. *     =================
  667. *     FUSION TABLE DE MODES
  668.  
  669.  2000 CONTINUE
  670.  
  671.       CALL CRTABL(IPTAB2)
  672.       IPOUT = IPTAB2
  673.       IL = 0
  674.       IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  675.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  676.      &        'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
  677.       ELSE
  678.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  679.      &        'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
  680.          CALL CRTABL(IPTAB3)
  681.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
  682.      &        'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
  683.          IPTAB2 = IPTAB3
  684.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  685.      &        'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
  686.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  687.      &        'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
  688. cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
  689.          CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
  690.      >        'TABLE',ID3,RR1,' ',.TRUE.,IP1)
  691.          IF (IERR.NE.0) RETURN
  692.          MTABLE = IP1
  693.          CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  694.      >        'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
  695.          IF (IERR.NE.0) RETURN
  696.       ENDIF
  697.  
  698. c  ---copie de la IKO ieme table (IKO=1,2)
  699.       IKO = 0
  700.  2100 IKO = IKO + 1
  701.       SEGACT MTABLE
  702.  
  703. c  ---boucle sur les modes ou les solutions statiques
  704.       IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  705.          IMA = MLOTAB - 1
  706.       ELSE
  707.          IMA = MLOTAB - 2
  708.       ENDIF
  709.       IM = 0
  710.  2160 IM = IM + 1
  711.       CTYP=' '
  712.       CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
  713. c      >     'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
  714.      >     CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
  715.       IF(CTYP.NE.'TABLE') GOTO 2161
  716.       IF (ITMOD.GT.0)  THEN
  717.          IL = IL + 1
  718.          CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
  719.      &        'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  720.       ENDIF
  721.  2161 CONTINUE
  722.       IF (IM.LT.IMA) GOTO 2160
  723. c  ---fin de boucle sur les modes ou les solutions statiques
  724.  
  725.       SEGDES MTABLE
  726.       IF (IKO.EQ.1) THEN
  727.          IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  728.             CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
  729.             IF (IRETOU.EQ.0) GOTO 2300
  730.             MTABLE = IP1
  731.          ELSE
  732.             CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
  733.             IF (IRETOU.EQ.0) GOTO 2300
  734.             CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  735.      >           'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
  736. c           fusion des 2 maillages
  737.             CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  738.      >           'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
  739.             CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
  740. *  A qoi sert cet appel a uniq?
  741. **            iordre=0
  742. **            CALL UNIQMA(IPT3,NBDIF,iordre)
  743.             CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  744.      &        'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
  745.          ENDIF
  746.          GOTO 2100
  747.       ENDIF
  748. c  ---fin de boucle sur les tables IKO=1,2
  749.  
  750.  2300 CALL ECROBJ('TABLE   ',ipout)
  751.       RETURN
  752.  
  753.  
  754. *     =========
  755. *     ERREUR 39
  756. *     =========
  757.  999  CONTINUE
  758. *     On ne veut pas d'objet de type %m1:8
  759.       MOTERR(1:8)=CTYP
  760.       CALL ERREUR(39)
  761.       END
  762.  
  763.  
  764.  

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