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

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