Télécharger la plaquette Cast3M


fr en

Télécharger operad.eso

Retour à la liste

Numérotation des lignes : 

operad

  1. C OPERAD    SOURCE    PASCAL    22/11/21    21:15:04     11502          
  2.       SUBROUTINE OPERAD
  3. C_______________________________________________________________________
  4. C
  5. C     ADDITIONNE 2 NOMBRES  (ENTIER OU FLOTTANT)
  6. C                2 CHPS/ELMTS
  7. C                2 CHPS/POINT
  8. C                2 EVOLUTIONS
  9. C                2 LISTES REELLES
  10. C                2 LISTES ENTIERES
  11. C                2 TABLES SOUS-TYPE VECTEUR
  12. C
  13. C     PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 29 10 90
  14. C
  15. C_______________________________________________________________________
  16. C
  17.       IMPLICIT INTEGER(I-N)
  18.       IMPLICIT real*8 (a-h,o-z)
  19. C
  20.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMTABLE
  24. -INC SMLENTI
  25. -INC SMLREEL
  26.  
  27.       PARAMETER (NCLEVO = 2)
  28. C
  29.       LOGICAL ir1
  30.       CHARACTER*8 CHA1,CHA2,CTYP,COMP
  31.       CHARACTER*4 CLEVO(NCLEVO)
  32.       REAL*8  FLOT1
  33.       REAL*8  FLOTTO
  34.       REAL*8 X1,X2
  35.       INTEGER ENTI1
  36.       INTEGER ENTITO
  37.  
  38.       INTEGER ICH1
  39.       INTEGER IOPERA
  40.       INTEGER IARGU
  41.       INTEGER I1
  42.       REAL*8 FLO
  43.       INTEGER ICHR
  44.       INTEGER IR2
  45.       INTEGER IRET
  46.       INTEGER IRETOU
  47.       INTEGER IREFLO
  48.  
  49.       DATA CLEVO/'ABSC','ORDO'/
  50.  
  51.       ICH1 = 0
  52.       IOPERA = 0
  53.       IARGU = 0
  54.       I1 = 0
  55.       FLO = 0.D0
  56.       ICHR = 0
  57.       IRET = 0
  58.  
  59.  
  60.       CHA1   = '        '
  61.       CHA2   = '        '
  62.       CTYP   = '        '
  63. C_______________________________________________________________________
  64. C
  65. C   RECHERCHE DU TYPE DU PREMIER ARGUMENT
  66. C_______________________________________________________________________
  67.       CALL QUETYP(CTYP,0,IRETOU)
  68.       IRETOU = 0
  69.  
  70. C_______________________________________________________________________
  71. C
  72. C     CHERCHE A LIRE DEUX MCHAML OU MCHAML ET FLOTTANT
  73. C_______________________________________________________________________
  74.       CALL LIROBJ('MCHAML  ',ICH1,0,IRETOU)
  75.       IF (IRETOU.EQ.0) GOTO 102
  76.       CALL ACTOBJ('MCHAML  ',ICH1,1)
  77.       CALL LIROBJ('MCHAML  ',ICH2,0,IRETOU)
  78.       IF (IRETOU .EQ. 0) THEN
  79.         CALL LIRREE(FLO,0,IRETOU)
  80.         IF(IRETOU.EQ.0) THEN
  81.             CALL REFUS
  82.             GOTO 102
  83.         ENDIF
  84. C       IOPERA= 3 pour l'operation ADDITION
  85.         IOPERA= 3
  86. C       IARGU = 2  pour MCHAML + FLOTTANT
  87.         IARGU = 2
  88.         I1    = 0
  89.         ICHR = 0
  90.         IRET = 0
  91.         CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  92.         IF(IRET.NE.0) THEN
  93.           CALL ACTOBJ('MCHAML  ',ICHR,1)
  94.           CALL ECROBJ('MCHAML  ',ICHR)
  95.         ELSE
  96.           CALL ERREUR(26)
  97.         ENDIF
  98.  
  99.       ELSE
  100.         CALL ACTOBJ('MCHAML  ',ICH2,1)
  101.         CALL ADCHEL(ICH1,ICH2,IPCHAD,1)
  102.         IF (IPCHAD .EQ. 0) RETURN
  103.         CALL ACTOBJ('MCHAML  ',IPCHAD,1)
  104.         CALL ECROBJ('MCHAML  ',IPCHAD)
  105.       ENDIF
  106.       RETURN
  107. C_______________________________________________________________________
  108. C
  109. C     CHERCHE A LIRE DES CHPOINT
  110. C_______________________________________________________________________
  111.   102 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
  112.       IF (IRETOU.EQ.0) GOTO 103
  113.       CALL ACTOBJ('CHPOINT ',IPO1,1)
  114.       CALL LIROBJ('CHPOINT ',IPO2,0,IRETOU)
  115.       IF(IRETOU.EQ.0) THEN
  116.           CALL REFUS
  117.           GO TO 103
  118.       ENDIF
  119.       CALL ACTOBJ('CHPOINT ',IPO2,1)
  120.       CALL ADCHPO(IPO1,IPO2,IRET,1D0,1D0)
  121.       IF(IRET.EQ.0) RETURN
  122.       CALL ACTOBJ('CHPOINT ',IRET,1)
  123.       CALL ECROBJ('CHPOINT ',IRET)
  124.       RETURN
  125. C_______________________________________________________________________
  126. C
  127. C     CHERCHE A LIRE UN CHPOINT ET UN FLOTTANT
  128. C_______________________________________________________________________
  129.   103 CALL LIROBJ('CHPOINT ',ICH1,0,IRETOU)
  130.       IF (IRETOU.EQ.0) GOTO 104
  131.       CALL ACTOBJ('CHPOINT ',ICH1,1)
  132.       CALL LIRREE(FLO,0,IRETOU)
  133.       IF (IRETOU.EQ.0) THEN
  134.            CALL REFUS
  135.            GO TO 104
  136.       ENDIF
  137. C     IOPERA= 3 pour l'operation ADDITION
  138. C     IARGU = 2 pour FLOTTANT
  139.       IOPERA= 3
  140.       IARGU = 2
  141.       I1    = 0
  142.       CALL OPCHP1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  143.       IF(IRET.NE.0) THEN
  144.         CALL ACTOBJ('CHPOINT ',ICHR,1)
  145.         CALL ECROBJ('CHPOINT ',ICHR)
  146.       ELSE
  147.         CALL ERREUR(26)
  148.       ENDIF
  149.       RETURN
  150. C_______________________________________________________________________
  151. C
  152. C     CHERCHE A LIROBJ DES EVOLUTIO
  153. C_______________________________________________________________________
  154.   104 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
  155.       IF(IRETOU.EQ.0) GOTO 105
  156.       CALL ACTOBJ('EVOLUTIO',IPO1,1)
  157.       CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
  158.       IF(IRETOU.EQ.0) THEN
  159.            CALL REFUS
  160.            GO TO 105
  161.       ENDIF
  162.       CALL ACTOBJ('EVOLUTIO',IPO2,1)
  163.       CALL ADEVOL(IPO1,IPO2,IRET,1)
  164.       IF(IRET.EQ.0) RETURN
  165.       CALL ACTOBJ('EVOLUTIO',IRET,1)
  166.       CALL ECROBJ('EVOLUTIO',IRET)
  167.       RETURN
  168. C_______________________________________________________________________
  169. C
  170. C     CHERCHE A LIROBJ DES LISTREEL
  171. C_______________________________________________________________________
  172.   105 CALL LIROBJ('LISTREEL',ICH,0,IRETOU)
  173.       IF(IRETOU.EQ.0) GOTO 106
  174.       MLREEL=ICH
  175.       SEGACT,MLREEL
  176.       CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
  177.       IF(IRETOU.EQ.0) THEN
  178.            CALL REFUS
  179.            GO TO 106
  180.       ENDIF
  181.       MLREEL=ICHR
  182.       SEGACT,MLREEL
  183. C     Addition entre LISTREEL et LISTREEL terme a terme
  184. C     IOPERA= 3 pour l'operation ADDITION
  185. C     IARGU = 0 pour ne pas utiliser I1 et FLO
  186.       IOPERA= 3
  187.       IARGU = 0
  188.       I1    = 0
  189.       FLO   = REAL(0.D0)
  190.       CALL OPLRE1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  191.       IF(IRET.NE.0) THEN
  192.         MLREEL=ICHR
  193.         SEGACT,MLREEL*NOMOD
  194.         CALL ECROBJ('LISTREEL',ICHR)
  195.       ELSE
  196.         CALL ERREUR(26)
  197.       ENDIF
  198.       RETURN
  199. C_______________________________________________________________________
  200. C
  201. C     CHERCHE A LIROBJ DES LISTENTI
  202. C_______________________________________________________________________
  203.  106  CALL LIROBJ('LISTENTI',IPO1,0,IRETOU)
  204.       IF(IRETOU.EQ.0) GOTO 1061
  205.       MLENTI=IPO1
  206.       SEGACT,MLENTI
  207.       CALL LIROBJ('LISTENTI',IPO2,0,IRETOU)
  208.       IF(IRETOU.EQ.0) THEN
  209.            CALL REFUS
  210.            GO TO 1061
  211.       ENDIF
  212.       MLENTI=IPO2
  213.       SEGACT,MLENTI
  214.       CALL ADLISE(IPO1,IPO2,IRET,1)
  215.       IF(IRET.EQ.0) RETURN
  216.       MLENTI=IRET
  217.       SEGACT,MLENTI*NOMOD
  218.       CALL ECROBJ('LISTENTI',IRET)
  219.       RETURN
  220. C_______________________________________________________________________
  221. C
  222. C     CHERCHE A LIROBJ 1 LISTREEL ET 1 LISTE ENTIER
  223. C_______________________________________________________________________
  224.  1061 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
  225.       IF(IRETOU.EQ.0) GOTO 1062
  226.       MLREEL=IPO1
  227.       SEGACT,MLREEL
  228.       CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
  229.       IF(IRETOU.EQ.0) THEN
  230.         CALL REFUS
  231.         GO TO 1062
  232.       ELSE
  233. C     Conversion du LISTENTI en LISTREEL
  234.         SEGACT MLENTI
  235.         JG=LECT(/1)
  236.         SEGINI MLREEL
  237.         DO IG=1,JG
  238.           FLOT1   = REAL(LECT(IG))
  239.           PROG(IG)= FLOT1
  240.         ENDDO
  241.       ENDIF
  242.  
  243.       CALL ADLISR(IPO1,MLREEL,IRET,1)
  244.       IF(IRET.EQ.0) RETURN
  245.       MLREEL=IRET
  246.       SEGACT,MLREEL*NOMOD
  247.       CALL ECROBJ('LISTREEL',IRET)
  248.       RETURN
  249. C_______________________________________________________________________
  250. C
  251. C     CHERCHE A LIROBJ 1 LISTREEL ET 1 ENTIER / FLOTTANT
  252. C_______________________________________________________________________
  253.  1062 CALL LIROBJ('LISTREEL',ICH,0,IRETOU)
  254.       IF(IRETOU.EQ.0) GOTO 1063
  255.       MLREEL=ICH
  256.       SEGACT,MLREEL
  257.       CALL LIRREE(FLO,0,IRETOU)
  258.       IF(IRETOU.EQ.0) THEN
  259.         CALL REFUS
  260.         GO TO 1063
  261.       ENDIF
  262. C     Addition entre l'ENTIER/FLOTTANT et tous les indices du LISTREEL
  263. C     IOPERA= 3 pour l'operation ADDITION
  264. C     IARGU = 2 pour FLOTTANT
  265.       IOPERA= 3
  266.       IARGU = 2
  267.       I1    = 0
  268.       CALL OPLRE1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  269.       IF(IRET.NE.0) THEN
  270.         MLREEL=ICHR
  271.         SEGACT,MLREEL*NOMOD
  272.         CALL ECROBJ('LISTREEL',ICHR)
  273.       ELSE
  274.         CALL ERREUR(26)
  275.       ENDIF
  276.       RETURN
  277. C_______________________________________________________________________
  278. C
  279. C     CHERCHE A LIROBJ 1 LISTENTI ET 1 ENTIER / FLOTTANT
  280. C_______________________________________________________________________
  281.  1063 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  282.       IF(IRETOU.EQ.0) GOTO 107
  283.  
  284.       CALL LIRENT(I1,0,IRET1)
  285.       CALL LIRREE(X1,0,IR2)
  286.  
  287.       IF( (IRET1.EQ.0) .AND. (IR2.EQ.0)) THEN
  288.         CALL REFUS
  289.         GO TO 107
  290.       ELSE
  291. C     Addition entre l''ENTIER/FLOTTANT et tous les indices du LISTENTIER
  292.         SEGACT MLENT1
  293.         JG=MLENT1.LECT(/1)
  294.         IF (IRET1 .NE. 0) THEN
  295. C         Cas de la Addition avec un ENTIER
  296.           SEGINI MLENT2
  297.           DO IG=1,JG
  298.             IENT1   = I1 + MLENT1.LECT(IG)
  299.             MLENT2.LECT(IG)= IENT1
  300.           ENDDO
  301.           CALL ECROBJ('LISTENTI',MLENT2)
  302.         ELSEIF (IR2 .NE. 0) THEN
  303. C         Cas de l''Addition avec un FLOTTANT
  304.           SEGINI MLREE2
  305.           DO IG=1,JG
  306.             FLOT1   = X1 + REAL(MLENT1.LECT(IG))
  307.             MLREE2.PROG(IG)= FLOT1
  308.           ENDDO
  309.           SEGACT,MLREE2*NOMOD
  310.           CALL ECROBJ('LISTREEL',MLREE2)
  311.         ENDIF
  312.       ENDIF
  313.       RETURN
  314. C_______________________________________________________________________
  315. C
  316. C     CHERCHE A LIRE   2 NOMBRES ENTIERS
  317. C_______________________________________________________________________
  318.   107 CALL LIRENT(I1,0,IRETOU)
  319.       IF (IRETOU.EQ.0) GOTO 108
  320.       CALL LIRENT(I2,0,IRETOU)
  321.       IF (IRETOU.EQ.0) THEN
  322.            CALL REFUS
  323.            GO TO 108
  324.       ENDIF
  325.       CALL ECRENT(I1+I2)
  326.       RETURN
  327. C_______________________________________________________________________
  328. C
  329. C     CHERCHE A LIRE   2 NOMBRES FLOTTANTS
  330. C_______________________________________________________________________
  331.  108  CALL LIRREE(X1,0,IRETOU)
  332.       IF (IRETOU.EQ.0) GOTO 109
  333.       CALL LIRREE(X2,0,IRETOU)
  334.       IF (IRETOU.EQ.0) THEN
  335.            CALL REFUS
  336.            GO TO 109
  337.       ENDIF
  338.       CALL ECRREE(X1+X2)
  339.       RETURN
  340. C_______________________________________________________________________
  341. C
  342. C     CHERCHE A LIROBJ 2 TABLES SOUS-TYPE VECTEUR
  343. C_______________________________________________________________________
  344.   109 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
  345.       IF(IRETOU.EQ.0) GO TO 110
  346.       CALL QUENOM(MOTERR(1:8))
  347.       CALL LIRTAB('VECTEUR',MTAB2,0,IRETOU)
  348.       IF (IRETOU.EQ.0) THEN
  349.            CALL REFUS
  350.            GO TO 110
  351.       ENDIF
  352.       CALL QUENOM(MOTERR(9:16))
  353.       SEGINI,MTABLE=MTAB1
  354.       SEGACT MTAB2
  355.       DO 71 J=1,MTAB2.MLOTAB
  356.        CHA1=MTAB2.MTABTI(J)
  357.        X1=MTAB2.RMTABI(J)
  358.        IVA1=MTAB2.MTABII(J)
  359.        DO 72 I=1,MLOTAB
  360.         IF (CHA1.NE.MTABTI(I)) GOTO 72
  361.         IF (CHA1.EQ.'FLOTTANT') THEN
  362.           IF (X1.NE.RMTABI(I)) GOTO 72
  363.         ELSE
  364.           IF (IVA1.NE.MTABII(I)) GOTO 72
  365.         ENDIF
  366. C  ON A UN INDICE COMMUN ON REGARDE SI LE TYPE DE LA DONNEE EST SOMMABLE
  367.         CHA2=MTAB2.MTABTV(J)
  368.         IF (CHA2.EQ.'FLOTTANT') THEN
  369.          IF (MTABTV(I).EQ.'FLOTTANT') THEN
  370.             RMTABV(I)=RMTABV(I)+MTAB2.RMTABV(J)
  371.          ELSEIF (MTABTV(I).EQ.'ENTIER  ') THEN
  372.             MTABTV(I)='FLOTTANT'
  373.             RMTABV(I)=MTABIV(I)+MTAB2.RMTABV(J)
  374.          ELSE
  375.             CALL ERREUR(135)
  376.          ENDIF
  377.         ELSEIF (CHA2.EQ.'ENTIER  ') THEN
  378.          IF (MTABTV(I).EQ.'ENTIER  ') THEN
  379.             MTABIV(I)=MTABIV(I)+MTAB2.MTABIV(J)
  380.          ELSEIF (MTABTV(I).EQ.'FLOTTANT') THEN
  381.             RMTABV(I)=RMTABV(I)+MTAB2.MTABIV(J)
  382.          ELSE
  383.             CALL ERREUR(135)
  384.          ENDIF
  385.         ELSE
  386.            IF (MTABTV(I).NE.CHA2.OR.MTABTV(I).NE.MTAB2.MTABTV(J))
  387.      #          CALL ERREUR(135)
  388.         ENDIF
  389. C  C'EST PASSE OU CA A CASSE ON SORT
  390.         IF (IERR.NE.0) RETURN
  391.         GOTO 71
  392.   72    CONTINUE
  393. C  ON RAJOUTE LE MTAB2(J) A MTABL
  394.         MLOTAB=MLOTAB+1
  395.         M=MTABII(/1)
  396.         IF (M.LT.MLOTAB) THEN
  397.          M=M+100
  398.          SEGADJ MTABLE
  399.         ENDIF
  400.         MTABII(MLOTAB)=MTAB2.MTABII(J)
  401.         MTABTI(MLOTAB)=MTAB2.MTABTI(J)
  402.         RMTABI(MLOTAB)=MTAB2.RMTABI(J)
  403.         MTABIV(MLOTAB)=MTAB2.MTABIV(J)
  404.         MTABTV(MLOTAB)=MTAB2.MTABTV(J)
  405.         RMTABV(MLOTAB)=MTAB2.RMTABV(J)
  406.   71  CONTINUE
  407.       SEGDES MTABLE,MTAB1,MTAB2
  408.       CALL ECROBJ('TABLE',MTABLE)
  409.       RETURN
  410. C_______________________________________________________________________
  411. C
  412. C   EST CE UNE TABLE ESCLAVE DE MCHAML
  413. C_______________________________________________________________________
  414.   110 CONTINUE
  415.       CALL LIRTAB('ESCLAVE',MTABle,0,IRETOU)
  416.       if (iretou.eq.0) goto 111
  417.       segact mtable
  418.       ml=mlotab
  419. C  l'indice 1 est le sous type
  420.       ind=mtabii(3)
  421.       ctyp=' '
  422.       call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  423.      >          CTYP,enti1,flot1,' ',ir1,id1)
  424.       iretou=id1
  425.       CALL ACTOBJ(CTYP,ID1,1)
  426.       if (CTYP.eq.'MCHAML') then
  427.        do i=4,ml
  428.         ind=mtabii(i)
  429.         call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  430.      >          CTYP,id3,rr1,' ',ir1,id2)
  431.         if (ierr.ne.0) return
  432.         call ADCHEL(ID1,ID2,IRETOU,1)
  433.         id1=iretou
  434.        enddo
  435.       elseif (CTYP.eq.'CHPOINT ') then
  436.        do i=4,ml
  437.         ind=mtabii(i)
  438.         call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  439.      >          CTYP,id3,rr1,' ',ir1,id2)
  440.         if (ierr.ne.0) return
  441.         call ADCHPO(ID1,ID2,IRETOU,1D0,1D0)
  442.         id1=iretou
  443.        enddo
  444.       elseif (CTYP.eq.'LISTREEL') then
  445.         IOPERA= 3
  446.         IARGU = 0
  447.         iretou=id1
  448.         I1    = 0
  449.         FLO   = REAL(0.D0)
  450.         iret=0
  451.         do i=4,ml
  452.         ind=mtabii(i)
  453.         call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  454.      >          CTYP,id3,rr1,' ',ir1,id2)
  455.         if (ierr.ne.0) return
  456.         MLREEL=ID2
  457.         SEGACT,MLREEL
  458.         CALL OPLRE1(ID2,IOPERA,IARGU,I1,FLO,IRETOU,IRET)
  459.         enddo
  460.       elseif (CTYP.eq.'LISTENTI') then
  461.        do i=4,ml
  462.         ind=mtabii(i)
  463.         call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  464.      >          CTYP,id3,rr1,' ',ir1,id2)
  465.         if (ierr.ne.0) return
  466.         MLENTI=ID2
  467.         SEGACT,MLENTI
  468.         CALL ADLISE(ID1,ID2,IRETOU,1)
  469.         id1=iretou
  470.        enddo
  471.       elseif (CTYP.eq.'EVOLUTIO') then
  472.        do i=4,ml
  473.         ind=mtabii(i)
  474.         call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  475.      >          CTYP,id3,rr1,' ',ir1,id2)
  476.         if (ierr.ne.0) return
  477.         CALL ACTOBJ('EVOLUTIO',ID2,1)
  478.         CALL ADEVOL(ID1,ID2,IRETOU,1)
  479.         id1=iretou
  480.        enddo
  481.       elseif (CTYP.eq.'ENTIER') then
  482.         ENTITO=MTABLE.MTABIV(3)
  483.        do i=4,ml
  484.         ENTITO=ENTITO+MTABLE.MTABIV(I)
  485.        enddo
  486.       CALL ECRENT(ENTITO)
  487.       return
  488.       elseif (CTYP.eq.'FLOTTANT') then
  489.         FLOTTO=RMTABV(3)
  490.         do i=4,ml
  491.         FLOTTO=FLOTTO+MTABLE.RMTABV(I)
  492.         enddo
  493.         CALL ECRREE(FLOTTO)
  494.         return
  495.       else
  496.        moterr(1:8)='MCHAML  '
  497.        call erreur(-173)
  498.        call erreur(648)
  499.        return
  500.       endif
  501.       segdes mtable
  502.  100  continue
  503.       if (ierr.ne.0) return
  504.       CALL ACTOBJ(ctyp,iretou,1)
  505.       call ecrobj(ctyp,iretou)
  506.       return
  507. C_______________________________________________________________________
  508. C
  509. C     CHERCHE A LIROBJ 1 EVOLUTIO ET 1 ENTIER / FLOTTANT
  510. C_______________________________________________________________________
  511.  111  CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
  512.       IF(IRETOU.EQ.0) GOTO 112
  513.       CALL ACTOBJ('EVOLUTIO',ICH,1)
  514.       CALL LIRENT(I1,0,IREENT)
  515.       IF(IREENT.EQ.0) THEN      
  516.         CALL LIRREE(FLO,0,IREFLO)
  517.         IF(IREFLO.EQ.0) THEN      
  518.           CALL REFUS
  519.           GOTO 112
  520.         ELSE
  521. C         IARGU = 2 pour FLOTTANT
  522.           IARGU = 2
  523.         ENDIF
  524.       ELSE
  525. C       IARGU = 1 pour ENTIER
  526.         IARGU = 1
  527.       ENDIF
  528. C     Lecture facultative des mots-cles ABSC/ORDO
  529.       ICLE = 0
  530.       CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
  531.       IF (ICLE.EQ.0) ICLE = 2
  532. C     Addition entre l'ENTIER/FLOTTANT et tous les indices du EVOLUTIO
  533. C     IOPERA= 3 pour l'operation ADDITION
  534.       IOPERA= 3
  535.       CALL OPEVO1(ICH,IOPERA,IARGU,ICLE,I1,FLO,ICHR,IRET)
  536.       IF(IRET.NE.0) THEN
  537.         CALL ACTOBJ('EVOLUTIO',ICHR,1)
  538.         CALL ECROBJ('EVOLUTIO',ICHR)
  539.       ELSE
  540.         CALL ERREUR(26)
  541.       ENDIF
  542.       RETURN
  543. C_______________________________________________________________________
  544. C
  545. C     CHERCHE A LIROBJ 1 NUAGE ET 1 ENTIER / FLOTTANT ET 1 MOT
  546. C_______________________________________________________________________
  547.  112  CALL LIROBJ('NUAGE   ',ICH,0,IRETOU)
  548.       IF(IRETOU.EQ.0) GOTO 120
  549.       CALL ACTOBJ('NUAGE   ',ICH,1)
  550.       CALL LIRENT(I1,0,IREENT)
  551.       IF(IREENT.EQ.0) THEN
  552.         CALL LIRREE(FLO,0,IREFLO)
  553.         IF(IREFLO.EQ.0) THEN
  554.           CALL REFUS
  555.           GOTO 120
  556.         ELSE
  557. C         IARGU = 2 pour FLOTTANT
  558.           IARGU = 2
  559.         ENDIF
  560.       ELSE
  561. C       IARGU = 1 pour ENTIER
  562.         IARGU = 1
  563.       ENDIF
  564. C     Lecture du nom de la composante
  565.       CALL LIRCHA(COMP,1,IRETOU)
  566.       IF (IERR.NE.0) RETURN
  567. C     Addition entre l'ENTIER/FLOTTANT et les valeurs du NUAGE
  568. C     IOPERA= 3 pour l'operation ADDITION
  569.       IOPERA= 3
  570.       CALL OPNUA1(ICH,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
  571.       IF (IERR.NE.0) RETURN
  572.       IF (IRET.NE.0) THEN
  573.         CALL ACTOBJ('NUAGE   ',ICHR,1)
  574.         CALL ECROBJ('NUAGE   ',ICHR)
  575.       ELSE
  576. C       ERREUR 5 car erreurs gerees dans OPNUA1
  577.         CALL ERREUR(5)
  578.       ENDIF
  579.       RETURN
  580. C_______________________________________________________________________
  581. C
  582. C   ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
  583. C_______________________________________________________________________
  584.   120 CONTINUE
  585.       CALL QUETYP(MOTERR(1:8),0,IRETOU)
  586.       IF(IRETOU.NE.0) THEN
  587.          CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
  588.          CALL QUETYP(MOTERR(9:16),0,IRETOU)
  589.          IF (IRETOU.EQ.0)  MOTERR(9:16) = '  ????  '
  590.          CALL ERREUR(532)
  591.       ELSE
  592.          CALL ERREUR(533)
  593.       ENDIF
  594.  
  595.       END
  596.  
  597.  
  598.  
  599.  
  600.  

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