Télécharger la plaquette Cast3M


fr en

Télécharger opermu.eso

Retour à la liste

Numérotation des lignes : 

opermu

  1. C OPERMU    SOURCE    FD218221  26/09/25    21:15:06     12655          
  2.       SUBROUTINE OPERMU
  3. C_______________________________________________________________________
  4. C
  5. C     multiplie un champ par point par un objet rigidite.
  6. C     multiplie un listreel par un flottant (ou un entier)
  7. C     multiplie un listreel par un listreel terme a terme.
  8. C     multiplie un objet rigidite par un flottant (ou 1 entier)
  9. C     multiplie un champs par elemt par un flottant (ou 1 entier)
  10. C     multiplie un champ par element par un autre champ par element
  11. C     multiplie un champ par element par une evolution
  12. C     multiplie un champ par point   par un autre champ par point
  13. C     multiplie un champ par point par un flottant (ou 1 entier)
  14. C     multiplie un champ par point par une evolution
  15. C     multiplie 2 nombres (flottant ou entier)
  16. C     multiplie un point par un nombre
  17. C     multiplie un objet evolutio (ordonnees) par un flottant
  18. C                                               (ou un entier)
  19. C     multiplie un objet evolutio par un objet evolutio
  20. C     multiplie une table soustype vecteur par un reel
  21. C     multiplie une table soustype LIAISONS_STATIQUES ou
  22. C            BASE_DE_MODES par une rigidite
  23. C
  24. C     passage aux nouveaux MCHAML par jm campenon le 29 10 90
  25. C
  26. C_______________________________________________________________________
  27. C
  28.       IMPLICIT INTEGER(I-N)
  29.       IMPLICIT REAL*8 (A-H,O-Z)
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC SMCOORD
  34. -INC SMLENTI
  35. -INC SMLREEL
  36. -INC SMTABLE
  37. -INC SMLMOTS
  38.  
  39.  
  40.       PARAMETER (NCLEVO = 2)
  41. C
  42.       CHARACTER*8 COMP
  43.       CHARACTER*4 CLEVO(NCLEVO)
  44.        INTEGER ICH1
  45.        INTEGER IOPERA
  46.        INTEGER IARGU
  47.        INTEGER I1
  48.        REAL*8 FLO
  49.        INTEGER ICHR
  50.        INTEGER IRET
  51.       DATA CLEVO/'ABSC','ORDO'/
  52.  
  53.        ICH1 = 0
  54.        IOPERA = 0
  55.        IARGU = 0
  56.        I1 = 0
  57.        FLO = 0.D0
  58.        ICHR = 0
  59.        IRET = 0
  60. C_______________________________________________________________________
  61. C
  62. C  produit de deux CHPOINT
  63. C_______________________________________________________________________
  64. C
  65.       CALL LIROBJ('CHPOINT',ICHP1,0,IRETOU)
  66.       IF (IRETOU.EQ.0) GOTO 1
  67.       CALL ACTOBJ('CHPOINT ',ICHP1,1)
  68.  
  69.       CALL LIROBJ('CHPOINT',ICHP2,0,IRETOU)
  70.       IF (IRETOU.EQ.0) THEN
  71.           CALL REFUS
  72.           GOTO 1
  73.       ENDIF
  74.       CALL ACTOBJ('CHPOINT ',ICHP2,1)
  75.  
  76.       CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
  77.       IF ( IRETOU .EQ. 1) THEN
  78.         CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  79.         IF (IERR .NE. 0) RETURN
  80.  
  81.         CALL LIROBJ('LISTMOTS',MLMOT3,1,IRETOU)
  82.         IF (IERR .NE. 0) RETURN
  83.  
  84.         CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
  85.         IF (IERR .NE. 0) RETURN
  86.         IF(IRETOU .EQ. 1)THEN
  87.           SEGACT,MLREE1
  88.         ENDIF
  89.  
  90.         SEGACT,MLMOT1,MLMOT2,MLMOT3
  91.         CALL MUCHP1(ICHP1,ICHP2,MLMOT1,MLMOT2,MLMOT3,MLREE1,1,IRET)
  92.       ELSE
  93.  
  94.         CALL MUPOSC(ICHP1,ICHP2,1,IRET)
  95.       ENDIF
  96.  
  97.       IF (IERR .NE. 0) RETURN
  98.       IF (IRET.NE.0) THEN
  99.          CALL ACTOBJ('CHPOINT ',IRET,1)
  100.          CALL ECROBJ('CHPOINT ',IRET)
  101.       ENDIF
  102.       RETURN
  103. C
  104.    1  CONTINUE
  105.       IF (IERR .NE. 0) RETURN
  106. C_______________________________________________________________________
  107. C
  108. C  multiplication de deux ENTIER
  109. C_______________________________________________________________________
  110. C
  111.       CALL LIRENT(IRE1,0,IRETOU)
  112.       IF (IRETOU.EQ.0) GOTO 2
  113.       CALL LIRENT(IRE2,0,IRETOU)
  114.       IF (IRETOU.EQ.0) THEN
  115.           CALL REFUS
  116.           GOTO 2
  117.       ENDIF
  118.  
  119. C     Cas du produit de 2 ENTIERS
  120.       CALL ECRENT(IRE1*IRE2)
  121.       RETURN
  122. C
  123.    2  CONTINUE
  124.       IF (IERR .NE. 0) RETURN
  125. C_______________________________________________________________________
  126. C
  127. C  multiplication de deux FLOTTANT
  128. C_______________________________________________________________________
  129. C
  130.       CALL LIRREE(FLO1,0,IRETOU)
  131.       IF (IRETOU.EQ.0) GOTO 3
  132.       CALL LIRREE(FLO2,0,IRETOU)
  133.       IF (IRETOU.EQ.0) THEN
  134.           CALL REFUS
  135.           GOTO 3
  136.       ENDIF
  137.       CALL ECRREE(FLO1*FLO2)
  138.       RETURN
  139. C
  140.    3  CONTINUE
  141.       IF (IERR .NE. 0) RETURN
  142. C_______________________________________________________________________
  143. C
  144. C  produit d'un FLOTTANT par un POINT
  145. C_______________________________________________________________________
  146. C
  147.       CALL LIRREE(FLO1,0,IRETOU)
  148.       IF (IRETOU.EQ.0) GOTO 4
  149.       CALL LIROBJ('POINT',IPT,0,IRETOU)
  150.       IF (IRETOU.EQ.0) THEN
  151.           CALL REFUS
  152.           GOTO 4
  153.       ENDIF
  154.       SEGACT MCOORD*MOD
  155.       nbpts=nbpts+1
  156.       segadj mcoord
  157.       DO ILDIM=1,IDIM
  158.         XCOOR((nbpts-1)*(idim+1)+ildim)=
  159.      >        XCOOR((IPT-1)*(IDIM+1)+ILDIM)*FLO1
  160.       ENDDO
  161.       XCOOR((nbpts-1)*(idim+1)+idim+1) = XCOOR((IPT-1)*(IDIM+1)+IDIM+1)
  162.       IRET=nbpts
  163.       SEGACT MCOORD*NOMOD
  164.       CALL ECROBJ('POINT',IRET)
  165.       RETURN
  166. C
  167.    4  CONTINUE
  168.       IF (IERR .NE. 0) RETURN
  169. C_______________________________________________________________________
  170. C
  171. C  produit d'un CHPOINT par un FLOTTANT
  172. C_______________________________________________________________________
  173. C
  174.       CALL LIRREE(FLO,0,IRETOU)
  175.       IF (IRETOU.EQ.0) GOTO 5
  176.       CALL LIROBJ('CHPOINT',ICH1,0,IRETOU)
  177.       IF (IRETOU.EQ.0) THEN
  178.           CALL REFUS
  179.           GOTO 5
  180.       ENDIF
  181.       CALL ACTOBJ('CHPOINT ',ICH1,1)
  182. C     IOPERA= 2 pour l'operation PRODUIT
  183. C     IARGU = 2 pour FLOTTANT
  184.       IOPERA= 2
  185.       IARGU = 2
  186.       I1    = 0
  187.       CALL OPCHP1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  188.       IF(IRET.NE.0) THEN
  189.         CALL ACTOBJ('CHPOINT ',ICHR,1)
  190.         CALL ECROBJ('CHPOINT ',ICHR)
  191.       ELSE
  192.         CALL ERREUR(26)
  193.       ENDIF
  194.       RETURN
  195. C
  196.    5  CONTINUE
  197.       IF (IERR .NE. 0) RETURN
  198. C_______________________________________________________________________
  199. C
  200. C  produit d'un MCHAML par un FLOTTANT
  201. C_______________________________________________________________________
  202. C
  203.       CALL LIRREE(FLO,0,IRETOU)
  204.       IF (IRETOU.EQ.0) GOTO 6
  205.       CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
  206.       IF (IRETOU.EQ.0) THEN
  207.           CALL REFUS
  208.           GOTO 6
  209.       ENDIF
  210.       CALL ACTOBJ('MCHAML  ',ICH1,1)
  211. C     IOPERA= 2 pour l'operation PRODUIT
  212. C     IARGU = 2 pour FLOTTANT
  213.       IOPERA= 2
  214.       IARGU = 2
  215.       I1    = 0
  216.       ICHR = 0
  217.       IRET = 0
  218.       CALL ACTOBJ('MCHAML',ICH1,1)
  219.       CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  220.       IF(IRET.NE.0) THEN
  221.         CALL ACTOBJ('MCHAML  ',ICHR,1)
  222.         CALL ECROBJ('MCHAML  ',ICHR)
  223.       ELSE
  224.         CALL ERREUR(26)
  225.       ENDIF
  226.       RETURN
  227. C
  228.    6  CONTINUE
  229.       IF (IERR .NE. 0) RETURN
  230. C_______________________________________________________________________
  231. C
  232. C  produit d'une RIGIDITE par un FLOTTANT
  233. C_______________________________________________________________________
  234. C
  235.       CALL LIRREE(FLO,0,IRETOU)
  236.       IF (IRETOU.EQ.0) GOTO 7
  237.       CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
  238.       IF (IRETOU.EQ.0) THEN
  239.           CALL REFUS
  240.           GOTO 7
  241.       ENDIF
  242.       CALL MUFLRI(IRIG,FLO,IRET,1)
  243.       IF (IRET.NE.0) CALL ECROBJ('RIGIDITE',IRET)
  244.       RETURN
  245. C
  246.    7  CONTINUE
  247.       IF (IERR .NE. 0) RETURN
  248. C_______________________________________________________________________
  249. C
  250. C  produit d'un MATRIK par un FLOTTANT
  251. C_______________________________________________________________________
  252. C
  253.       CALL LIRREE(FLO,0,IRETOU)
  254.       IF (IRETOU.EQ.0) GOTO 71
  255.       CALL LIROBJ('MATRIK  ',IRIG,0,IRETOU)
  256.       IF (IRETOU.EQ.0) THEN
  257.           CALL REFUS
  258.           GOTO 71
  259.       ENDIF
  260.       CALL PRDMF(FLO,IRIG,IRET)
  261.       IF (IRET.NE.0) CALL ECROBJ('MATRIK  ',IRET)
  262.       RETURN
  263. C
  264.  71   CONTINUE
  265.       IF (IERR .NE. 0) RETURN
  266. C_______________________________________________________________________
  267. C
  268. C  produit d'une RIGIDITE par un CHPOINT
  269. C_______________________________________________________________________
  270. C
  271.       CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
  272.       IF (IRETOU.EQ.0) GOTO 8
  273.       CALL ACTOBJ('CHPOINT ',ICHP,1)
  274.       CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
  275.       IF (IRETOU.EQ.0) THEN
  276.           CALL REFUS
  277.           GOTO 8
  278.       ENDIF
  279.       CALL MUCPRI(ICHP,IRIG,ICHR)
  280.       CALL ACTOBJ('CHPOINT ',ICHR,1)
  281.       CALL ECROBJ('CHPOINT ',ICHR)
  282.       RETURN
  283. C
  284.    8  CONTINUE
  285.       IF (IERR .NE. 0) RETURN
  286. C_______________________________________________________________________
  287. C
  288. C  produit d'un MATRIK par un CHPOINT
  289. C_______________________________________________________________________
  290. C
  291.       CALL LIROBJ('CHPOINT ',ICHP,0,IRETOU)
  292.       IF (IRETOU.EQ.0) GOTO 9
  293.       CALL ACTOBJ('CHPOINT ',ICHP,1)
  294.       CALL LIROBJ('MATRIK  ',IRIG,0,IRETOU)
  295.       IF (IRETOU.EQ.0) THEN
  296.           CALL REFUS
  297.           GOTO 9
  298.       ENDIF
  299.       CALL PRDMCP(IRIG,ICHP,ICHR)
  300.       CALL ACTOBJ('CHPOINT ',ICHR,1)
  301.       CALL ECROBJ('CHPOINT ',ICHR)
  302.       RETURN
  303. C
  304.  9    CONTINUE
  305.       IF (IERR .NE. 0) RETURN
  306.  
  307. C_______________________________________________________________________
  308. C
  309. C  produit de deux MCHAML
  310. C_______________________________________________________________________
  311. C
  312.       CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
  313.       IF (IRETOU.EQ.0) IPMODL=0
  314.       IF(IPMODL .NE. 0) CALL ACTOBJ('MMODEL  ',IPMODL,1)
  315.       CALL LIROBJ('MCHAML',ICHP1,0,IRETOU)
  316.       IF (IRETOU.EQ.0) GOTO 10
  317.       CALL ACTOBJ('MCHAML  ',ICHP1,1)
  318.       CALL LIROBJ('MCHAML',ICHP2,0,IRETOU)
  319.       IF (IRETOU.EQ.0) THEN
  320.          CALL REFUS
  321.          GOTO 10
  322.       ENDIF
  323.       CALL ACTOBJ('MCHAML  ',ICHP2,1)
  324. C
  325.       LMOT1 = -1
  326.       LMOT2 = -1
  327.       LMOT3 = -1
  328.       ILREE = -1
  329.       CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
  330.       IF ( IRETOU .EQ. 1) THEN
  331.         CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
  332.         IF (IERR .NE. 0) RETURN
  333.         CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
  334.         IF (IERR .NE. 0) RETURN
  335.         CALL LIROBJ('LISTREEL',ILREE,0,IRETOU)
  336.         IF (IERR .NE. 0) RETURN
  337.       ENDIF
  338. C
  339.       CALL MUCHSC(IPMODL,ICHP1,ICHP2,IPCHMU,LMOT1,LMOT2,LMOT3,ILREE,1)
  340.       IF(IERR.NE.0) RETURN
  341. C
  342.       IF (IPCHMU.NE.0) THEN
  343.          CALL ACTOBJ('MCHAML  ',IPCHMU,1)
  344.          CALL ECROBJ('MCHAML  ',IPCHMU)
  345.       ELSE
  346.          CALL ERREUR(26)
  347.       ENDIF
  348.       RETURN
  349.  
  350.   10  CONTINUE
  351.       IF (IERR .NE. 0) RETURN
  352. C_______________________________________________________________________
  353. C
  354. C  produit ENTIER EVOLUTION
  355. C_______________________________________________________________________
  356. C
  357.       CALL LIRENT(I1,0,IRETOU)
  358.       IF (IRETOU.EQ.0) GOTO 101
  359.       CALL LIROBJ('EVOLUTIO',ICH1,0,IRETOU)
  360.       IF (IRETOU.EQ.0) THEN
  361.           CALL REFUS
  362.           GOTO 101
  363.       ENDIF
  364.       CALL ACTOBJ('EVOLUTIO',ICH1,1)
  365. C     IOPERA= 2 pour l'operation PRODUIT
  366. C     IARGU = 1 pour ENTIER
  367.       IOPERA= 2
  368.       IARGU = 1
  369.       FLO   = 0.D0
  370.       ICLE = 0
  371.       CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
  372.       IF (ICLE.EQ.0) ICLE = 2
  373.       CALL OPEVO1(ICH1,IOPERA,IARGU,ICLE,I1,FLO,ICHR,IRET)
  374.       IF(IRET.NE.0) THEN
  375.         CALL ACTOBJ('EVOLUTIO',ICHR,1)
  376.         CALL ECROBJ('EVOLUTIO',ICHR)
  377.       ELSE
  378.         CALL ERREUR(26)
  379.       ENDIF
  380.       RETURN
  381. C
  382.   101 CONTINUE
  383.       IF (IERR .NE. 0) RETURN
  384. C_______________________________________________________________________
  385. C
  386. C  produit FLOTTANT EVOLUTION
  387. C_______________________________________________________________________
  388. C
  389.       CALL LIRREE(FLO,0,IRETOU)
  390.       IF (IRETOU.EQ.0) GOTO 11
  391.       CALL LIROBJ('EVOLUTIO',ICH1,0,IRETOU)
  392.       IF (IRETOU.EQ.0) THEN
  393.           CALL REFUS
  394.           GOTO 11
  395.       ENDIF
  396.       CALL ACTOBJ('EVOLUTIO',ICH1,1)
  397. C     IOPERA= 2 pour l'operation PRODUIT
  398. C     IARGU = 2 pour FLOTTANT
  399.       IOPERA= 2
  400.       IARGU = 2
  401.       I1    = 0
  402.       ICLE = 0
  403.       CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
  404.       IF (ICLE.EQ.0) ICLE = 2
  405.       CALL OPEVO1(ICH1,IOPERA,IARGU,ICLE,I1,FLO,ICHR,IRET)
  406.       IF(IRET.NE.0) THEN
  407.         CALL ACTOBJ('EVOLUTIO',ICHR,1)
  408.         CALL ECROBJ('EVOLUTIO',ICHR)
  409.       ELSE
  410.         CALL ERREUR(26)
  411.       ENDIF
  412.       RETURN
  413. C
  414.   11  CONTINUE
  415.       IF (IERR .NE. 0) RETURN
  416. C_______________________________________________________________________
  417. C
  418. C  produit de deux EVOLUTIO
  419. C_______________________________________________________________________
  420. C
  421.       CALL LIROBJ('EVOLUTIO',IEVOL1,0,IRETOU)
  422.       IF (IRETOU.EQ.0) GOTO 12
  423.       CALL ACTOBJ('EVOLUTIO',IEVOL1,1)
  424.       CALL LIROBJ('EVOLUTIO',IEVOL2,0,IRETOU)
  425.       IF (IRETOU.EQ.0) THEN
  426.           CALL REFUS
  427.           GOTO 12
  428.       ENDIF
  429.       CALL ACTOBJ('EVOLUTIO',IEVOL2,1)
  430.       CALL PUIS(IEVOL1,IEVOL2,ICHR,1)
  431.       CALL ACTOBJ('EVOLUTIO',ICHR,1)
  432.       CALL ECROBJ('EVOLUTIO',ICHR)
  433.       RETURN
  434. C
  435.   12  CONTINUE
  436.       IF (IERR .NE. 0) RETURN
  437. C_______________________________________________________________________
  438. C
  439. C  produit FLOTTANT LISTREEL
  440. C_______________________________________________________________________
  441. C
  442.       CALL LIRREE(FLO,0,IRETOU)
  443.       IF (IRETOU.EQ.0) GOTO 13
  444.       CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  445.       IF (IRETOU.EQ.0) THEN
  446.           CALL REFUS
  447.           GOTO 13
  448.       ENDIF
  449.       MLREEL=ICH1
  450.       SEGACT,MLREEL
  451. C     IOPERA= 2 pour l'operation PRODUIT
  452. C     IARGU = 2 pour FLOTTANT
  453.       IOPERA= 2
  454.       IARGU = 2
  455.       I1    = 0
  456.       CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  457.       IF(IRET.NE.0) THEN
  458.         MLREEL=ICHR
  459.         SEGACT,MLREEL*NOMOD
  460.         CALL ECROBJ('LISTREEL',ICHR)
  461.       ELSE
  462.         CALL ERREUR(26)
  463.       ENDIF
  464.       RETURN
  465. C
  466.   13  CONTINUE
  467.       IF (IERR .NE. 0) RETURN
  468. C_______________________________________________________________________
  469. C
  470. C  produit CHPOINT EVOLUTION
  471. C_______________________________________________________________________
  472. C
  473.       CALL LIROBJ('CHPOINT ',ICHP,0,IRETOU)
  474.       IF (IRETOU.EQ.0) GOTO 14
  475.       CALL ACTOBJ('CHPOINT ',ICHP,1)
  476.       CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU)
  477.       IF (IRETOU.EQ.0) THEN
  478.           CALL REFUS
  479.           GOTO 14
  480.       ENDIF
  481.       CALL ACTOBJ('EVOLUTIO',IEVOL,1)
  482.       CALL VARCHP(ICHP,IEVOL,IRET,IRETOU)
  483.       IF (IRETOU.NE.0) THEN
  484.         CALL ACTOBJ('CHPOINT ',IRET,1)
  485.         CALL ECROBJ('CHPOINT ',IRET)
  486.       ENDIF
  487.       RETURN
  488. C
  489.   14  CONTINUE
  490.       IF (IERR .NE. 0) RETURN
  491. C_______________________________________________________________________
  492. C
  493. C  produit MCHAML EVOLUTION
  494. C_______________________________________________________________________
  495. C
  496.       CALL LIROBJ('MCHAML  ',IPCHP,0,IRETOU)
  497.       IF (IRETOU.EQ.0) GOTO 15
  498.       CALL ACTOBJ('MCHAML  ',IPCHP,1)
  499.       CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU)
  500.       IF (IRETOU.EQ.0) THEN
  501.           CALL REFUS
  502.           GOTO 15
  503.       ENDIF
  504.       CALL ACTOBJ('EVOLUTIO',IEVOL,1)
  505.       CALL VARCHE(IPCHP,IEVOL,IPCHMU,IRETOU)
  506. C
  507.       IF (IRETOU.NE.0) THEN
  508.         CALL ACTOBJ('MCHAML  ',IPCHMU,1)
  509.         CALL ECROBJ('MCHAML  ',IPCHMU)
  510.       ENDIF
  511.       RETURN
  512. C
  513.   15  CONTINUE
  514.       IF (IERR .NE. 0) RETURN
  515. C_______________________________________________________________________
  516. C
  517. C  produit LISTREEL LISTREEL
  518. C_______________________________________________________________________
  519. C
  520.       CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  521.       IF(IRETOU.EQ.0)  GOTO 16
  522.       MLREEL=ICH1
  523.       SEGACT,MLREEL*NOMOD
  524.       CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
  525.       IF (IRETOU.EQ.0) THEN
  526.           CALL REFUS
  527.           GOTO 16
  528.       ENDIF
  529.       MLREEL=ICHR
  530.       SEGACT,MLREEL*NOMOD
  531. C     IOPERA= 2 pour l'operation PRODUIT
  532. C     IARGU = 0
  533.       IOPERA= 2
  534.       IARGU = 0
  535.       I1    = 0
  536.       FLO   = 0.D0
  537.       CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  538.       IF(IRET.NE.0) THEN
  539.         MLREEL=ICHR
  540.         SEGACT,MLREEL*NOMOD
  541.         CALL ECROBJ('LISTREEL',ICHR)
  542.       ELSE
  543.         CALL ERREUR(26)
  544.       ENDIF
  545.       RETURN
  546. C
  547.   16  CONTINUE
  548.       IF (IERR .NE. 0) RETURN
  549. C_______________________________________________________________________
  550. C
  551. C  produit LISTENTI ENTIER
  552. C_______________________________________________________________________
  553. C
  554.       CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  555.       IF(IRETOU.EQ.0)  GOTO 17
  556.       SEGACT,MLENT1
  557.       CALL LIRENT(IVA,0,IRETOU)
  558.       IF (IRETOU.EQ.0) THEN
  559.           CALL REFUS
  560.           GOTO 17
  561.       ENDIF
  562.       JG=MLENT1.LECT(/1)
  563.       SEGINI,MLENTI
  564.       DO 160 I=1,JG
  565.         LECT(I)=MLENT1.LECT(I)*IVA
  566.   160 CONTINUE
  567.       SEGACT,MLENTI*NOMOD
  568.       CALL ECROBJ('LISTENTI',MLENTI)
  569.       RETURN
  570. C
  571.    17 CONTINUE
  572.       IF (IERR .NE. 0) RETURN
  573. C_______________________________________________________________________
  574. C
  575. C  produit LISTENTI FLOTTANT
  576. C_______________________________________________________________________
  577. C
  578.       CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  579.       IF(IRETOU.EQ.0)  GOTO 18
  580.       SEGACT,MLENT1
  581.       CALL LIRREE(XVA,0,IRETOU)
  582.       IF (IRETOU.EQ.0) THEN
  583.           CALL REFUS
  584.           GOTO 18
  585.       ENDIF
  586.       JG=MLENT1.LECT(/1)
  587.       SEGINI,MLREEL
  588.       DO 170 I=1,JG
  589.         PROG(I)=REAL(MLENT1.LECT(I))*XVA
  590.   170 CONTINUE
  591.       SEGACT,MLREEL*NOMOD
  592.       CALL ECROBJ('LISTREEL',MLREEL)
  593.       RETURN
  594. C
  595.    18 CONTINUE
  596.       IF (IERR .NE. 0) RETURN
  597. C_______________________________________________________________________
  598. C
  599. C  produit LISTENTI LISTENTI
  600. C_______________________________________________________________________
  601. C
  602.       CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  603.       IF(IRETOU.EQ.0)  GOTO 19
  604.       SEGACT,MLENT1
  605.       CALL LIROBJ('LISTENTI',MLENT2,0,IRETOU)
  606.       IF (IRETOU.EQ.0) THEN
  607.           CALL REFUS
  608.           GOTO 19
  609.       ENDIF
  610.       SEGACT,MLENT2
  611.       JG=MLENT2.LECT(/1)
  612.       IF(MLENT1.LECT(/1).NE.JG) THEN
  613.           CALL ERREUR (217)
  614.           RETURN
  615.       ENDIF
  616.       SEGINI MLENTI
  617.       DO 180 I=1,JG
  618.         LECT(I)=MLENT1.LECT(I)*MLENT2.LECT(I)
  619.   180 CONTINUE
  620.       SEGACT,MLENTI*NOMOD
  621.       CALL ECROBJ('LISTENTI',MLENTI)
  622.       RETURN
  623. C
  624.   19  CONTINUE
  625.       IF (IERR .NE. 0) RETURN
  626. C_______________________________________________________________________
  627. C
  628. C  produit TABLE-VECTEUR FLOTTANT
  629. C_______________________________________________________________________
  630. C
  631.       CALL LIRREE(FLO1,0,IRETOU)
  632.       IF(IRETOU.EQ.0)  GOTO 20
  633.       CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
  634.       IF (IRETOU.EQ.0) THEN
  635.           CALL REFUS
  636.           GOTO 20
  637.       ENDIF
  638.       SEGINI,MTABLE=MTAB1
  639.       DO 200 I=1,MLOTAB
  640.           IF (MTABTV(I).EQ.'FLOTTANT') THEN
  641.             RMTABV(I)=RMTABV(I)*FLO1
  642.           ELSE IF (MTABTV(I).EQ.'ENTIER  ') THEN
  643.             RMTABV(I)=REAL(MTABIV(I))*FLO1
  644.             MTABTV(I)='FLOTTANT'
  645.           ENDIF
  646.  200  CONTINUE
  647.       SEGDES,MTABLE,MTAB1
  648.       CALL ECROBJ('TABLE   ',MTABLE)
  649.       RETURN
  650. C
  651.   20  CONTINUE
  652.       IF (IERR .NE. 0) RETURN
  653. C_______________________________________________________________________
  654. C
  655. C  produit d'une RIGIDITE par un CHPOINT
  656. C_______________________________________________________________________
  657. C
  658.       CALL LIROBJ('LISTCHPO',ILCHP,0,IRETOU)
  659.       IF (IRETOU.EQ.0) GOTO 21
  660.       CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
  661.       IF (IRETOU.EQ.0) THEN
  662.           CALL REFUS
  663.           GOTO 21
  664.       ENDIF
  665.       CALL MUCPLI(ILCHP,IRIG,IRET)
  666.       CALL ECROBJ('LISTCHPO',IRET)
  667.       RETURN
  668. C
  669.  21   CONTINUE
  670.       IF (IERR .NE. 0) RETURN
  671.  
  672. C_______________________________________________________________________
  673. C
  674. C  produit table-liaisons_statiques RIGIDITE
  675. C_______________________________________________________________________
  676. C
  677.       CALL LIRTAB('LIAISONS_STATIQUES',ITBST,0,IRETOU)
  678.       IF(IRETOU.EQ.0) CALL LIRTAB('BASE_DE_MODES',ITBST,0,IRETOU)
  679.       IF(IRETOU.EQ.0)  GOTO 22
  680.       call lirobj('RIGIDITE',ir1,1,iretou)
  681.       IF (IRETOU.EQ.0) THEN
  682.           CALL REFUS
  683.           GOTO 22
  684.       ENDIF
  685.          call prmu(ir1,itbst)
  686.       RETURN
  687. C
  688.  
  689.  22   CONTINUE
  690.       IF (IERR .NE. 0) RETURN
  691. C_______________________________________________________________________
  692. C
  693. C  produit LISTREEL LISTENTI
  694. C_______________________________________________________________________
  695. C
  696.       CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
  697.       IF(IRETOU.EQ.0)  GOTO 23
  698.       SEGACT,MLREE1
  699.       CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  700.       IF (IRETOU.EQ.0) THEN
  701.           CALL REFUS
  702.           GOTO 23
  703.       ENDIF
  704.       SEGACT,MLENT1
  705.       JG=MLENT1.LECT(/1)
  706.       IF(MLREE1.PROG(/1).NE.JG) THEN
  707.           CALL ERREUR (217)
  708.           RETURN
  709.       ENDIF
  710.       SEGINI,MLREEL
  711.       DO 220 I=1,JG
  712.         PROG(I)=MLREE1.PROG(I)*REAL(MLENT1.LECT(I))
  713.   220 CONTINUE
  714.       SEGACT,MLREEL*NOMOD
  715.       CALL ECROBJ('LISTREEL',MLREEL)
  716.       RETURN
  717.  
  718.   23  CONTINUE
  719.       IF (IERR .NE. 0) RETURN
  720. C_______________________________________________________________________
  721. C
  722. C  produit ENTIER NUAGE
  723. C_______________________________________________________________________
  724. C
  725.       CALL LIRENT(I1,0,IRETOU)
  726.       IF (IRETOU.EQ.0) GOTO 24
  727.       CALL LIROBJ('NUAGE   ',ICH1,0,IRETOU)
  728.       IF (IRETOU.EQ.0) THEN
  729.           CALL REFUS
  730.           GOTO 24
  731.       ENDIF
  732.       CALL ACTOBJ('NUAGE   ',ICH1,1)
  733.       IF (IERR.NE.0) RETURN
  734. C     IOPERA= 2 pour l'operation PRODUIT
  735. C     IARGU = 1 pour ENTIER
  736.       IOPERA= 2
  737.       IARGU = 1
  738.       FLO   = 0.D0
  739. C     Lecture du nom de la composante
  740.       CALL LIRCHA(COMP,1,IRETOU)
  741.       IF (IERR.NE.0) RETURN
  742.       CALL OPNUA1(ICH1,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
  743.       IF (IERR.NE.0) RETURN
  744.       IF(IRET.NE.0) THEN
  745.         CALL ACTOBJ('NUAGE   ',ICHR,1)
  746.         CALL ECROBJ('NUAGE   ',ICHR)
  747.       ELSE
  748. C       ERREUR 5 car erreurs gerees dans OPNUA1
  749.         CALL ERREUR(5)
  750.       ENDIF
  751.       RETURN
  752.  
  753.   24  CONTINUE
  754.       IF (IERR .NE. 0) RETURN
  755. C_______________________________________________________________________
  756. C
  757. C  produit FLOTTANT NUAGE
  758. C_______________________________________________________________________
  759. C
  760.       CALL LIRREE(X1,0,IRETOU)
  761.       IF (IRETOU.EQ.0) GOTO 30
  762.       CALL LIROBJ('NUAGE   ',ICH1,0,IRETOU)
  763.       IF (IRETOU.EQ.0) THEN
  764.           CALL REFUS
  765.           GOTO 30
  766.       ENDIF
  767.       CALL ACTOBJ('NUAGE   ',ICH1,1)
  768.       IF (IERR.NE.0) RETURN
  769. C     IOPERA= 2 pour l'operation PRODUIT
  770. C     IARGU = 1 pour ENTIER
  771.       IOPERA= 2
  772.       IARGU = 2
  773.       I1    = 0
  774. C     Lecture du nom de la composante
  775.       CALL LIRCHA(COMP,1,IRETOU)
  776.       IF (IERR.NE.0) RETURN
  777.       CALL OPNUA1(ICH1,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
  778.       IF (IERR.NE.0) RETURN
  779.       IF(IRET.NE.0) THEN
  780.         CALL ACTOBJ('NUAGE   ',ICHR,1)
  781.         CALL ECROBJ('NUAGE   ',ICHR)
  782.       ELSE
  783. C       ERREUR 5 car erreurs gerees dans OPNUA1
  784.         CALL ERREUR(5)
  785.       ENDIF
  786.       RETURN
  787.  
  788. C_______________________________________________________________________
  789. C
  790. C   ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
  791. C_______________________________________________________________________
  792. C
  793.  30   CONTINUE
  794.       IF (IERR .NE. 0) RETURN
  795.       CALL QUETYP(MOTERR(1:8),0,IRETOU)
  796.       IF(IRETOU.NE.0) THEN
  797.           CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
  798.           CALL QUETYP(MOTERR(9:16),0,IRETOU)
  799.           IF (IRETOU.EQ.0)  MOTERR(9:16) = '  ????  '
  800.           CALL ERREUR(532)
  801.       ELSE
  802.           CALL ERREUR(533)
  803.       ENDIF
  804.  
  805.       RETURN
  806.       END
  807.  
  808.  
  809.  
  810.  
  811.  
  812.  
  813.  
  814.  
  815.  
  816.  
  817.  
  818.  
  819.  

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