Télécharger la plaquette Cast3M


fr en

Télécharger operdi.eso

Retour à la liste

Numérotation des lignes : 

operdi

  1. C OPERDI    SOURCE    PASCAL    22/11/21    21:15:04     11502          
  2.       SUBROUTINE OPERDI
  3. C_______________________________________________________________________
  4. C
  5. C     DIVISE    UN LISTREEL PAR UN FLOTTANT (OU UN ENTIER)
  6. C     DIVISE    UN LISTREEL PAR UN LISTREEL (OU UN LISTENTI) : Terme à terme
  7. C     DIVISE    UN CHAMPS PAR ELEMENT PAR UN FLOTTANT (OU 1 ENTIER)
  8. C     DIVISE    UN OBJET RIGIDITE PAR UN FLOTTANT (OU UN ENTIER)
  9. C     DIVISE    UN CHPOINT PAR UN CHPOINT
  10. C     DIVISE    UN CHPOINT PAR UN FLOTTANT (OU UN ENTIER)
  11. C     DIVISE    2 NOMBRES (FLOTTANT OU ENTIER)
  12. C     DIVISE    UN POINT PAR UN NOMBRE
  13. C     DIVISE    UN OBJET EVOLUTIO PAR UN FLOTTANT (OU UN ENTIER) : Ordonnee
  14. C     DIVISE    UN OBJET EVOLUTIO PAR UN OBJET EVOLUTIO
  15. C     DIVISE    UNE TABLE SOUSTYPE VECTEUR PAR UN REEL
  16. C
  17. C   PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 12/90
  18. C
  19. C_______________________________________________________________________
  20. C
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23. C
  24. -INC CCREEL
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC SMCOORD
  29. -INC SMTABLE
  30. -INC SMLENTI
  31. -INC SMLREEL
  32. -INC SMLMOTS
  33. -INC SMLCHPO
  34.  
  35.       PARAMETER (NCLEVO = 2)
  36. C
  37.       CHARACTER*4 CLEVO(NCLEVO)
  38.       CHARACTER*8 CTYP,COMP
  39.  
  40.        INTEGER ICH1
  41.        INTEGER IOPERA
  42.        INTEGER IARGU
  43.        INTEGER I1
  44.        REAL*8 FLO
  45.        INTEGER ICHR
  46.        INTEGER IRET
  47.  
  48.       DATA CLEVO/'ABSC','ORDO'/
  49.  
  50.        ICH1   = 0
  51.        IOPERA = 0
  52.        IARGU  = 0
  53.        I1     = 0
  54.        ICHR   = 0
  55.        IRET   = 0
  56.        FLO    = 0.D0
  57.        XUN    = 1.D0
  58. C_______________________________________________________________________
  59. C
  60. C   RECHERCHE DU TYPE DU PREMIER ARGUMENT
  61. C_______________________________________________________________________
  62.       CALL QUETYP(CTYP,0,IRETOU)
  63.  
  64. C_______________________________________________________________________
  65. C
  66. C     CHERCHE A LIROBJ DEUX MCHAML
  67. C_______________________________________________________________________
  68. C
  69.       CALL LIROBJ('MMODEL  ',IPMODL,0,IRETOU)
  70.       IF (IRETOU.EQ.0) IPMODL=0
  71.       IF(IPMODL .NE. 0) CALL ACTOBJ('MMODEL  ',IPMODL,1)
  72.       CALL LIROBJ('MCHAML  ',IPCHE1,0,IRETOU)
  73.       IF(IRETOU.EQ.0) GOTO 101
  74.       CALL ACTOBJ('MCHAML  ',IPCHE1,1)
  75.       CALL LIROBJ('MCHAML  ',IPCHE2,0,IRETOU)
  76.       IF(IRETOU.EQ.0) THEN
  77.           CALL REFUS
  78.           GOTO 101
  79.        ENDIF
  80.       CALL ACTOBJ('MCHAML  ',IPCHE2,1)
  81. C
  82.       LMOT1 = -1
  83.       LMOT2 = -1
  84.       LMOT3 = -1
  85.       ILREE = -1
  86.       CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
  87.       IF ( IRETOU .EQ. 1) THEN
  88.          CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
  89.          IF (IERR .NE. 0) RETURN
  90.          CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
  91.          IF (IERR .NE. 0) RETURN
  92.          CALL LIROBJ('LISTREEL',ILREE,0,IRETOU)
  93.          IF (IERR .NE. 0) RETURN
  94.       ENDIF
  95. C
  96.       CALL MUCHSC(IPMODL,IPCHE1,IPCHE2,IPCHDI,LMOT1,LMOT2,LMOT3,ILREE,
  97.      $     -1)
  98.       IF(IERR.NE.0) RETURN
  99. C
  100.       IF (IPCHDI.NE.0) THEN
  101.          CALL ACTOBJ('MCHAML  ',IPCHDI,1)
  102.          CALL ECROBJ('MCHAML  ',IPCHDI)
  103.       ELSE
  104.          CALL ERREUR(26)
  105.       ENDIF
  106.       RETURN
  107.  
  108.  101  CONTINUE
  109.       IF (IERR.NE.0) RETURN
  110. C_______________________________________________________________________
  111. C
  112. C     CHERCHE A LIROBJ UN MCHAML ET UN FLOTTANT
  113. C_______________________________________________________________________
  114. C
  115.       CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
  116.       IF(IRETOU.EQ.0) GOTO 102
  117.       CALL LIRREE(FLO,0,IRETOU)
  118.       IF(IRETOU.EQ.0) THEN
  119.           CALL REFUS
  120.           GOTO 102
  121.       ENDIF
  122.       CALL ACTOBJ('MCHAML  ',ICH1,1)
  123. C     IOPERA= 5 pour l'operation DIVISION
  124.       IOPERA= 5
  125.       IF (CTYP .EQ. 'MCHAML') THEN
  126. C       IARGU = 2  pour MCHAML / FLOTTANT
  127.         IARGU = 2
  128.       ELSE
  129. C       IARGU = 21 pour FLOTTANT / MCHAML
  130.         IARGU = 21
  131.       ENDIF
  132.       I1    = 0
  133.       ICHR = 0
  134.       IRET = 0
  135.       CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  136.       IF(IRET.NE.0) THEN
  137.         CALL ACTOBJ('MCHAML  ',ICHR,1)
  138.         CALL ECROBJ('MCHAML  ',ICHR)
  139.       ELSE
  140.         CALL ERREUR(26)
  141.       ENDIF
  142.       RETURN
  143. C_______________________________________________________________________
  144. C
  145. C     CHERCHE A LIRE DEUX CHPOINT
  146. C_______________________________________________________________________
  147. C
  148.   102 CALL LIROBJ('CHPOINT ',ICHP1,0,IRETOU)
  149.       IF(IRETOU.EQ.0) GOTO 103
  150.       CALL ACTOBJ('CHPOINT ',ICHP1,1)
  151.  
  152.       CALL LIROBJ('CHPOINT ',ICHP2,0,IRETOU)
  153.       IF(IRETOU.EQ.0) THEN
  154.           CALL REFUS
  155.           GOTO 103
  156.       ENDIF
  157.       CALL ACTOBJ('CHPOINT ',ICHP2,1)
  158.       CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
  159.       IF ( IRETOU .EQ. 1) THEN
  160.         CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  161.         IF (IERR .NE. 0) RETURN
  162.  
  163.         CALL LIROBJ('LISTMOTS',MLMOT3,1,IRETOU)
  164.         IF (IERR .NE. 0) RETURN
  165.  
  166.         CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
  167.         IF (IERR .NE. 0) RETURN
  168.         IF(IRETOU .EQ. 1)THEN
  169.           SEGACT,MLREE1
  170.         ENDIF
  171.  
  172.         SEGACT,MLMOT1,MLMOT2,MLMOT3
  173.         CALL MUCHP1(ICHP1,ICHP2,MLMOT1,MLMOT2,MLMOT3,MLREE1,-1,IRET)
  174.  
  175.       ELSE
  176.         CALL MUPOSC(ICHP1,ICHP2,-1,IRET)
  177.       ENDIF
  178.  
  179.       IF (IERR .NE. 0) RETURN
  180.       IF (IRET.NE.0) THEN
  181.         CALL ACTOBJ('CHPOINT ',IRET,1)
  182.         CALL ECROBJ('CHPOINT ',IRET)
  183.       ENDIF
  184.       RETURN
  185. C_______________________________________________________________________
  186. C
  187. C     CHERCHE A LIROBJ UN CHPOINT ET UN FLOTTANT
  188. C_______________________________________________________________________
  189. C
  190.   103 CALL LIROBJ('CHPOINT ',ICH,0,IRETOU)
  191.       IF(IRETOU.EQ.0) GOTO 104
  192.       CALL LIRREE(FLO,0,IRETOU)
  193.       IF(IRETOU.EQ.0) THEN
  194.           CALL REFUS
  195.           GOTO 104
  196.       ENDIF
  197.       CALL ACTOBJ('CHPOINT ',ICH,1)
  198. C     IOPERA= 5 pour l'operation DIVISION
  199.       IOPERA= 5
  200.       IF (CTYP .EQ. 'CHPOINT') THEN
  201. C       IARGU = 2  pour CHPOINT / FLOTTANT
  202.         IARGU = 2
  203.       ELSE
  204. C       IARGU = 21 pour FLOTTANT / CHPOINT
  205.         IARGU = 21
  206.       ENDIF
  207.       I1    = 0
  208.       CALL OPCHP1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  209.       IF(IRET.NE.0) THEN
  210.         CALL ACTOBJ('CHPOINT ',ICHR,1)
  211.         CALL ECROBJ('CHPOINT ',ICHR)
  212.       ELSE
  213.         CALL ERREUR(26)
  214.       ENDIF
  215.       RETURN
  216. C_______________________________________________________________________
  217. C
  218. C     CHERCHE A LIROBJ UN OBJET DE TYPE RIGIDITE ET UN FLOTTANT
  219. C_______________________________________________________________________
  220. C
  221.   104 CALL LIROBJ('RIGIDITE',IPO1,0,IRETOU)
  222.       IF (IRETOU.EQ.0) GOTO 1041
  223.       IF (CTYP .EQ. 'ENTIER') THEN
  224.         CALL REFUS
  225.         GOTO 1041
  226.       ENDIF
  227.       IF (CTYP .EQ. 'FLOTTANT') THEN
  228.         CALL REFUS
  229.         GOTO 1041
  230.       ENDIF
  231.       CALL LIRREE(FLO,0,IRETOU)
  232.       IF (IRETOU.EQ.0) THEN
  233.           CALL REFUS
  234.           GOTO 1041
  235.       ENDIF
  236.       IF (FLO.EQ.0.) GOTO 5000
  237.       CALL MUFLRI(IPO1,FLO,IRET,-1)
  238.       CALL ECROBJ('RIGIDITE',IRET)
  239.       RETURN
  240. C_______________________________________________________________________
  241. C
  242. C     CHERCHE A LIROBJ UN OBJET DE TYPE MATRIK ET UN FLOTTANT
  243. C_______________________________________________________________________
  244. C
  245.  1041 CALL LIROBJ('MATRIK  ',IPO1,0,IRETOU)
  246.       IF (IRETOU.EQ.0) GOTO 105
  247.       IF (CTYP .EQ. 'ENTIER') THEN
  248.         CALL REFUS
  249.         GOTO 105
  250.       ENDIF
  251.       IF (CTYP .EQ. 'FLOTTANT') THEN
  252.         CALL REFUS
  253.         GOTO 105
  254.       ENDIF
  255.       CALL LIRREE(FLO,0,IRETOU)
  256.       IF (IRETOU.EQ.0) THEN
  257.           CALL REFUS
  258.           GOTO 105
  259.       ENDIF
  260.       IF (ABS(FLO).LT.XPETIT) GOTO 5000
  261.       CALL PRDMF(1.D0/FLO,IPO1,IRET)
  262.       IF (IRET.NE.0) CALL ECROBJ('MATRIK  ',IRET)
  263.       RETURN
  264. C_______________________________________________________________________
  265. C
  266. C     CHERCHE A LIROBJ UN OBJET DE TYPE EVOLUTIO ET UN FLOTTANT
  267. C_______________________________________________________________________
  268. C
  269.   105 CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
  270.       IF (IRETOU.EQ.0) GOTO 106
  271.       CALL ACTOBJ('EVOLUTIO',ICH,1)
  272.       CALL LIRENT(I1,0,IREENT)
  273.       IF(IREENT.EQ.0) THEN
  274.         I1 = 0
  275.         CALL LIRREE(FLO,0,IREFLO)
  276.         IF(IREFLO.EQ.0) THEN
  277.           CALL REFUS
  278.           GOTO 106
  279.         ELSE
  280.           IF (CTYP .EQ. 'EVOLUTIO') THEN
  281. C           IARGU = 2  pour EVOLUTIO - FLOTTANT
  282.             IARGU = 2
  283.           ELSE
  284. C           IARGU = 21 pour FLOTTANT - EVOLUTIO
  285.             IARGU = 21
  286.           ENDIF
  287.         ENDIF
  288.       ELSE
  289.         FLO = 0.D0
  290.         IF (CTYP .EQ. 'EVOLUTIO') THEN
  291. C         IARGU = 1  pour EVOLUTIO - ENTIER
  292.           IARGU = 1
  293.         ELSE
  294. C         IARGU = 11 pour ENTIER   - EVOLUTIO
  295.           IARGU = 11
  296.         ENDIF
  297.       ENDIF
  298. C     IOPERA= 5 pour l'operation DIVISION
  299.       IOPERA= 5
  300.       ICLE = 0
  301.       CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
  302.       IF (ICLE.EQ.0) ICLE = 2
  303.       CALL OPEVO1(ICH,IOPERA,IARGU,ICLE,I1,FLO,ICHR,IRET)
  304.       IF(IRET.NE.0) THEN
  305.         CALL ACTOBJ('EVOLUTIO',ICHR,1)
  306.         CALL ECROBJ('EVOLUTIO',ICHR)
  307.       ELSE
  308.         CALL ERREUR(26)
  309.       ENDIF
  310.       RETURN
  311. C_______________________________________________________________________
  312. C
  313. C     EVOLUTIO / EVOLUTIO
  314. C_______________________________________________________________________
  315. C
  316.   106 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
  317.       IF (IRETOU.EQ.0) GOTO 107
  318.       CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
  319.       IF (IRETOU.EQ.0) THEN
  320.           CALL REFUS
  321.           GOTO 107
  322.       ENDIF
  323.       CALL ACTOBJ('EVOLUTIO',IPO1,1)
  324.       CALL ACTOBJ('EVOLUTIO',IPO2,1)
  325.       CALL PUIS(IPO1,IPO2,IRET,-1)
  326.       CALL ACTOBJ('EVOLUTIO',IRET,1)
  327.       CALL ECROBJ('EVOLUTIO',IRET)
  328.       RETURN
  329. C_______________________________________________________________________
  330. C
  331. C     CHERCHE A LIROBJ UN LISTREEL ET UN LISTREEL
  332. C_______________________________________________________________________
  333. C
  334.   107 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  335.       IF(IRETOU.EQ.0) GOTO 1071
  336.       CALL ACTOBJ('LISTREEL',ICH1,1)
  337.       CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
  338.       IF (IRETOU.EQ.0) THEN
  339.           CALL REFUS
  340.           GOTO 1071
  341.       ENDIF
  342.       CALL ACTOBJ('LISTREEL',ICHR,1)
  343. C     IOPERA= 5 pour l'operation DIVISION
  344.       IOPERA= 5
  345.       IARGU = 0
  346.       I1    = 0
  347.       FLO   = 0.D0
  348.       CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  349.       IF(IRET.NE.0) THEN
  350.         CALL ACTOBJ('LISTREEL',ICHR,1)
  351.         CALL ECROBJ('LISTREEL',ICHR)
  352.       ELSE
  353.         CALL ERREUR(26)
  354.       ENDIF
  355.       RETURN
  356. C_______________________________________________________________________
  357. C
  358. C     CHERCHE A LIROBJ UN LISTREEL ET UN LISTENTI
  359. C_______________________________________________________________________
  360. C
  361.  1071 CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
  362.       IF(IRETOU.EQ.0) GOTO 1072
  363.       CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  364.       IF (IRETOU.EQ.0) THEN
  365.           CALL REFUS
  366.           GOTO 1072
  367.       ENDIF
  368.       SEGACT MLREE1,MLENT1
  369.       JG=MLENT1.LECT(/1)
  370.       IF(MLREE1.PROG(/1).NE.JG) THEN
  371.          CALL ERREUR (217)
  372.          RETURN
  373.       ENDIF
  374.  
  375.       SEGINI MLREE2
  376.       DO I=1,JG
  377.         IF(CTYP .EQ. 'LISTENTI') THEN
  378.           X2 = MLREE1.PROG(I)
  379.           IF(X2.EQ.0.D0) GOTO 5000
  380.           MLREE2.PROG(I)=REAL(MLENT1.LECT(I))/X2
  381.         ELSE
  382.           X2 = REAL(MLENT1.LECT(I))
  383.           IF(X2.EQ.0.) GOTO 5000
  384.           MLREE2.PROG(I)=MLREE1.PROG(I)/X2
  385.         ENDIF
  386.       ENDDO
  387.       SEGACT,MLREE2*NOMOD
  388.       CALL ECROBJ('LISTREEL',MLREE2)
  389.       RETURN
  390. C_______________________________________________________________________
  391. C
  392. C     CHERCHE A LIROBJ UN LISTENTI ET UN LISTENTI
  393. C_______________________________________________________________________
  394. C
  395.  1072 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  396.       IF(IRETOU.EQ.0) GOTO 108
  397.       CALL LIROBJ('LISTENTI',MLENT2,0,IRETOU)
  398.       IF (IRETOU.EQ.0) THEN
  399.           CALL REFUS
  400.           GOTO 108
  401.       ENDIF
  402.       SEGACT,MLENT1,MLENT2
  403.       JG=MLENT2.LECT(/1)
  404.       IF(MLENT1.LECT(/1) .NE. JG) THEN
  405.          CALL ERREUR (217)
  406.          RETURN
  407.       ENDIF
  408.       SEGINI,MLENT3
  409.       DO I=1,JG
  410.         I1 = MLENT2.LECT(I)
  411.         IF(I1 .EQ. 0 ) GOTO 5000
  412.         MLENT3.LECT(I)=MLENT1.LECT(I)/I1
  413.       ENDDO
  414.       SEGACT,MLENT3*NOMOD
  415.       CALL ECROBJ('LISTENTI',MLENT3)
  416.       RETURN
  417. C_______________________________________________________________________
  418. C
  419. C     LISTREEL / FLOTTANT OU ENTIER
  420. C_______________________________________________________________________
  421. C
  422.   108 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  423.       IF(IRETOU.EQ.0) GOTO 1081
  424.       CALL LIRREE(FLO,0,IRETOU)
  425.       IF(IRETOU.EQ.0) THEN
  426.           CALL REFUS
  427.           GOTO 1081
  428.       ENDIF
  429. C     IOPERA= 5 pour l'operation DIVISION
  430.       IOPERA= 5
  431.       IF (CTYP .EQ. 'LISTREEL') THEN
  432. C       IARGU = 2  pour LISTREEL / FLOTTANT
  433.         IARGU = 2
  434.       ELSE
  435. C       IARGU = 21 pour FLOTTANT / LISTREEL (terme a terme)
  436.         IARGU = 21
  437.       ENDIF
  438.       I1    = 0
  439.       CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  440.       IF(IRET.NE.0) THEN
  441.         MLREEL=ICHR
  442.         SEGACT,MLREEL*NOMOD
  443.         CALL ECROBJ('LISTREEL',ICHR)
  444.       ELSE
  445.         CALL ERREUR(26)
  446.       ENDIF
  447.       RETURN
  448. C_______________________________________________________________________
  449. C
  450. C     LISTENTI / FLOTTANT OU ENTIER
  451. C_______________________________________________________________________
  452. C
  453.  1081 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  454.       IF(IRETOU.EQ.0) GOTO 109
  455.       IF (CTYP .EQ. 'ENTIER') THEN
  456.         CALL REFUS
  457.         GOTO 109
  458.       ENDIF
  459.       IF (CTYP .EQ. 'FLOTTANT') THEN
  460.         CALL REFUS
  461.         GOTO 109
  462.       ENDIF
  463.       CALL LIRENT(I1,0,IRETOU)
  464.       IF(IRETOU.EQ.0) THEN
  465.           GOTO 1082
  466.       ELSE
  467.         IF (CTYP .EQ. 'ENTIER') GOTO 109
  468.         IF(I1.EQ.0) GOTO 5000
  469.         SEGACT,MLENT1
  470.         JG=MLENT1.LECT(/1)
  471.  
  472.         SEGINI,MLENT2
  473.         DO I=1, JG
  474.           MLENT2.LECT(I)=MLENT1.LECT(I)/I1
  475.         ENDDO
  476.         SEGACT,MLENT2*NOMOD
  477.         CALL ECROBJ('LISTENTI',MLENT2)
  478.         RETURN
  479.       ENDIF
  480.  
  481.  1082 CALL LIRREE(FLO,0,IRETOU)
  482.       IF(IRETOU.EQ.0) THEN
  483.           CALL REFUS
  484.           GOTO 109
  485.       ELSE
  486.         IF(ABS(FLO).LT.XPETIT) GOTO 5000
  487.         SEGACT,MLENT1
  488.         JG=MLENT1.LECT(/1)
  489.  
  490.         SEGINI,MLREE1
  491.         DO I=1, JG
  492.           MLREE1.PROG(I)=REAL(MLENT1.LECT(I))/FLO
  493.         ENDDO
  494.         SEGACT,MLREE1*NOMOD
  495.         CALL ECROBJ('LISTREEL',MLREE1)
  496.         RETURN
  497.       ENDIF
  498. C_______________________________________________________________________
  499. C
  500. C     CHERCHE A LIROBJ 2 ENTIERS
  501. C_______________________________________________________________________
  502. C
  503.   109 CALL LIRENT(I1,0,IRETOU)
  504.       IF (IRETOU.EQ.0) GOTO 110
  505.       CALL LIRENT(I2,0,IRETOU)
  506.       IF (IRETOU.EQ.0) THEN
  507.           CALL REFUS
  508.           GOTO 110
  509.       ENDIF
  510.  
  511. C     Cas de la division de 2 ENTIERS
  512.       IF(I2 .EQ. 0) GOTO 5000
  513.       CALL ECRENT(I1/I2)
  514.       RETURN
  515. C_______________________________________________________________________
  516. C
  517. C   CHERCHE A LIRE DEUX FLOTTANTS
  518. C_______________________________________________________________________
  519.  
  520.   110 CALL LIRREE(X1,0,IRETOU)
  521.       IF ( IRETOU.EQ.0) GOTO 111
  522.       CALL LIRREE(X2,0,IRETOU)
  523.       IF (IRETOU.EQ.0) THEN
  524.           CALL REFUS
  525.           GOTO 111
  526.       ENDIF
  527.  
  528. C     Cas de la division de 2 FLOTTANTS
  529.       IF(ABS(X2) .LT. XPETIT) GOTO 5000
  530. *sg      IF(ABS(X2).LT.1.D0.AND.ABS(X1).GT.XGRAND*ABS(X2)) THEN
  531.       IF (ABS(X2).LT.1.D0) THEN
  532.          IF (ABS(X1).GT.XGRAND*ABS(X2)) THEN
  533.             XFLO = SIGN(XUN,X1)*SIGN(XUN,X2)*XGRAND
  534.             GOTO 1101
  535.          ENDIF
  536.       ENDIF
  537. *sg      ELSEIF(ABS(X1).LT.XUN.AND.ABS(X2).GT.XGRAND*ABS(X1)) THEN
  538.       IF (ABS(X1).LT.XUN) THEN
  539.          IF (ABS(X2).GT.XGRAND*ABS(X1)) THEN
  540.             XFLO = 0.D0
  541.             GOTO 1101
  542.          ENDIF
  543.       ENDIF
  544.       XFLO = X1/X2
  545.  1101 CONTINUE
  546.       CALL ECRREE(XFLO)
  547.       RETURN
  548. C_______________________________________________________________________
  549. C
  550. C     CHERCHE A LIROBJ UN POINT ET UN FLOTTANT
  551. C_______________________________________________________________________
  552. C
  553.  111  CALL LIROBJ('POINT   ',IP1,0,IRETOU)
  554.       IF (IRETOU.EQ.0) GOTO 112
  555.       IF (CTYP .EQ. 'ENTIER') THEN
  556.         CALL REFUS
  557.         GOTO 112
  558.       ENDIF
  559.       IF (CTYP .EQ. 'FLOTTANT') THEN
  560.         CALL REFUS
  561.         GOTO 112
  562.       ENDIF
  563.       CALL LIRREE(X2,0,IRETOU)
  564.       IF (IRETOU.EQ.0) THEN
  565.           CALL REFUS
  566.           GOTO 112
  567.       ENDIF
  568.       IF(ABS(X2).LT.XPETIT) GOTO 5000
  569.       SEGACT MCOORD*MOD
  570.       ID=IDIM+1
  571.       IREF=ID*(IP1-1)
  572.       DO 11 I=1,ID
  573.       XCOOR(**)=XCOOR(IREF+I)/X2
  574.   11  CONTINUE
  575.       nbpts=nbpts+1
  576.       IR=nbpts
  577.       CALL ECROBJ('POINT   ',IR)
  578.       RETURN
  579. C_______________________________________________________________________
  580. C
  581. C  CHERCHE A LIRE UNE TABLE SOUSTYPE VECTEUR ET UN FLOTTANT
  582. C_______________________________________________________________________
  583. C
  584.   112 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
  585.       IF(IRETOU.EQ.0) GOTO 113
  586.       IF (CTYP .EQ. 'ENTIER') THEN
  587.         CALL REFUS
  588.         GOTO 113
  589.       ENDIF
  590.       IF (CTYP .EQ. 'FLOTTANT') THEN
  591.         CALL REFUS
  592.         GOTO 113
  593.       ENDIF
  594.       CALL LIRREE(X2,0,IRETOU)
  595.       IF (IRETOU.EQ.0) THEN
  596.           CALL REFUS
  597.           GOTO 113
  598.       ENDIF
  599.       IF(ABS(X2).LT.XPETIT) GOTO 5000
  600.       SEGINI,MTABLE=MTAB1
  601.       DO 701 I=1,MLOTAB
  602.       IF (MTABTV(I).EQ.'FLOTTANT') THEN
  603.          RMTABV(I)=RMTABV(I)/X2
  604.       ELSEIF (MTABTV(I).EQ.'ENTIER  ') THEN
  605.          RMTABV(I)=MTABIV(I)/X2
  606.          MTABTV(I)='FLOTTANT'
  607.       ENDIF
  608.  701  CONTINUE
  609.       SEGDES MTABLE,MTAB1
  610.       CALL ECROBJ('TABLE',MTABLE)
  611.       RETURN
  612. C_______________________________________________________________________
  613. C
  614. C  LISTCHPO / LISTREEL
  615. C_______________________________________________________________________
  616. C
  617.  113  CALL LIROBJ('LISTCHPO',LIPO1,0,IRETOU)
  618.       IF(IRETOU.EQ.0) GOTO 114
  619.       CALL LIROBJ('LISTREEL',LREE1,0,IRETOU)
  620.       IF(IRETOU.EQ.0) THEN
  621.           CALL REFUS
  622.           GOTO 114
  623.       ENDIF
  624.       mlreel = lree1
  625.       mlchp1 = lipo1
  626.       segact mlchp1,mlreel
  627.       jg = prog(/1)
  628.       n1 = mlchp1.ichpoi(/1)
  629.       if (jg.ne.n1) call erreur(3)
  630.       if (ierr.ne.0) return
  631.       segini mlchpo
  632.       do ic = 1,n1
  633.          flo = prog(ic)
  634.          ipo1 = mlchp1.ichpoi(ic)
  635.         IF(ABS(FLO).LT.XPETIT) GOTO 5000
  636.         FLD=FLO
  637.         CALL MUCHPO(IPO1,FLD,IRET,-1)
  638.         IF(IRET.EQ.0) RETURN
  639.          ichpoi(ic) = iret
  640.       enddo
  641.       CALL ACTOBJ('LISTCHPO',mlchpo,1)
  642.       CALL ECROBJ('LISTCHPO',mlchpo)
  643.       RETURN
  644.  
  645. C_______________________________________________________________________
  646. C
  647. C     NUAGE / ENTIER
  648. C_______________________________________________________________________
  649. C
  650.   114 CALL LIROBJ('NUAGE   ',ICH1,0,IRETOU)
  651.       IF(IRETOU.EQ.0) GOTO 115
  652.       CALL LIRENT(I1,0,IRETOU)
  653.       IF(IRETOU.EQ.0) THEN
  654.           CALL REFUS
  655.           GOTO 115
  656.       ENDIF
  657.       IF (I1.EQ.0) GOTO 5000
  658.       CALL ACTOBJ('NUAGE   ',ICH1,1)
  659.       IF (IERR.NE.0) RETURN
  660. C     IOPERA= 5 pour l'operation DIVISION
  661.       IOPERA= 5
  662.       IF (CTYP .EQ. 'NUAGE   ') THEN
  663. C       IARGU = 1  pour NUAGE    / FLOTTANT
  664.         IARGU = 1
  665.       ELSE
  666. C       IARGU = 11 pour FLOTTANT / NUAGE    (terme a terme)
  667.         IARGU = 11
  668.       ENDIF
  669.       FLO   = 0.D0
  670. C     Lecture du nom de la composante
  671.       CALL LIRCHA(COMP,1,IRETOU)
  672.       IF (IERR.NE.0) RETURN
  673.       CALL OPNUA1(ICH1,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
  674.       IF (IERR.NE.0) RETURN
  675.       IF(IRET.NE.0) THEN
  676.         CALL ACTOBJ('NUAGE   ',ICHR,1)
  677.         CALL ECROBJ('NUAGE   ',ICHR)
  678.       ELSE
  679. C       ERREUR 5 car erreurs gerees dans OPNUA1
  680.         CALL ERREUR(5)
  681.       ENDIF
  682.       RETURN
  683.  
  684. C_______________________________________________________________________
  685. C
  686. C     NUAGE / FLOTTANT 
  687. C_______________________________________________________________________
  688. C
  689.   115 CALL LIROBJ('NUAGE   ',ICH1,0,IRETOU)
  690.       IF(IRETOU.EQ.0) GOTO 120
  691.       CALL LIRREE(FLO,0,IRETOU)
  692.       IF(IRETOU.EQ.0) THEN
  693.           CALL REFUS
  694.           GOTO 120
  695.       ENDIF
  696.       IF (ABS(FLO).LT.XPETIT) GOTO 5000
  697.       CALL ACTOBJ('NUAGE   ',ICH1,1)
  698.       IF (IERR.NE.0) RETURN
  699. C     IOPERA= 5 pour l'operation DIVISION
  700.       IOPERA= 5
  701.       IF (CTYP .EQ. 'NUAGE   ') THEN
  702. C       IARGU = 2  pour NUAGE    / FLOTTANT
  703.         IARGU = 2
  704.       ELSE
  705. C       IARGU = 21 pour FLOTTANT / NUAGE    (terme a terme)
  706.         IARGU = 21
  707.       ENDIF
  708.       I1    = 0
  709. C     Lecture du nom de la composante
  710.       CALL LIRCHA(COMP,1,IRETOU)
  711.       IF (IERR.NE.0) RETURN
  712.       CALL OPNUA1(ICH1,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
  713.       IF (IERR.NE.0) RETURN
  714.       IF(IRET.NE.0) THEN
  715.         CALL ACTOBJ('NUAGE   ',ICHR,1)
  716.         CALL ECROBJ('NUAGE   ',ICHR)
  717.       ELSE
  718. C       ERREUR 5 car erreurs gerees dans OPNUA1
  719.         CALL ERREUR(5)
  720.       ENDIF
  721.       RETURN
  722.  
  723. C_______________________________________________________________________
  724. C
  725. C   ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
  726. C_______________________________________________________________________
  727. C
  728.  120  CONTINUE
  729.       CALL QUETYP(MOTERR(1:8),0,IRETOU)
  730.       IF(IRETOU.NE.0) THEN
  731.          CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
  732.          CALL QUETYP(MOTERR(9:16),0,IRETOU)
  733.          IF (IRETOU.EQ.0)  MOTERR(9:16) = '  ????  '
  734.          CALL ERREUR(532)
  735.       ELSE
  736.          CALL ERREUR(533)
  737.       ENDIF
  738.       RETURN
  739.  5000 CONTINUE
  740.       CALL ERREUR(835)
  741.       RETURN
  742.       END
  743.  
  744.  
  745.  
  746.  
  747.  
  748.  
  749.  
  750.  
  751.  
  752.  
  753.  

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