Télécharger operdi.eso

Retour à la liste

operdi
C OPERDI    SOURCE    FD218221  26/09/25    21:15:05     12655          
      SUBROUTINE OPERDI
C_______________________________________________________________________
C
C     DIVISE    UN LISTREEL PAR UN FLOTTANT (OU UN ENTIER)
C     DIVISE    UN LISTREEL PAR UN LISTREEL (OU UN LISTENTI) : Terme � terme
C     DIVISE    UN CHAMPS PAR ELEMENT PAR UN FLOTTANT (OU 1 ENTIER)
C     DIVISE    UN OBJET RIGIDITE PAR UN FLOTTANT (OU UN ENTIER)
C     DIVISE    UN CHPOINT PAR UN CHPOINT
C     DIVISE    UN CHPOINT PAR UN FLOTTANT (OU UN ENTIER)
C     DIVISE    2 NOMBRES (FLOTTANT OU ENTIER)
C     DIVISE    UN POINT PAR UN NOMBRE
C     DIVISE    UN OBJET EVOLUTIO PAR UN FLOTTANT (OU UN ENTIER) : Ordonnee
C     DIVISE    UN OBJET EVOLUTIO PAR UN OBJET EVOLUTIO
C     DIVISE    UNE TABLE SOUSTYPE VECTEUR PAR UN REEL
C
C   PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 12/90
C
C_______________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
-INC CCREEL
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMTABLE
-INC SMLENTI
-INC SMLREEL
-INC SMLMOTS
-INC SMLCHPO
 
      PARAMETER (NCLEVO = 2)
C
      CHARACTER*4 CLEVO(NCLEVO)
      CHARACTER*8 CTYP,COMP
 
       INTEGER ICH1
       INTEGER IOPERA
       INTEGER IARGU
       INTEGER I1
       REAL*8 FLO
       INTEGER ICHR
       INTEGER IRET
 
      DATA CLEVO/'ABSC','ORDO'/
 
       ICH1   = 0
       IOPERA = 0
       IARGU  = 0
       I1     = 0
       ICHR   = 0
       IRET   = 0
       FLO    = 0.D0
       XUN    = 1.D0
C_______________________________________________________________________
C
C   RECHERCHE DU TYPE DU PREMIER ARGUMENT
C_______________________________________________________________________
      CALL QUETYP(CTYP,0,IRETOU)
 
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ DEUX MCHAML
C_______________________________________________________________________
C
      CALL LIROBJ('MMODEL  ',IPMODL,0,IRETOU)
      IF (IRETOU.EQ.0) IPMODL=0
      IF(IPMODL .NE. 0) CALL ACTOBJ('MMODEL  ',IPMODL,1)
      CALL LIROBJ('MCHAML  ',IPCHE1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 101
      CALL ACTOBJ('MCHAML  ',IPCHE1,1)
      CALL LIROBJ('MCHAML  ',IPCHE2,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 101
       ENDIF
      CALL ACTOBJ('MCHAML  ',IPCHE2,1)
C
      LMOT1 = -1
      LMOT2 = -1
      LMOT3 = -1
      ILREE = -1
      CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
      IF ( IRETOU .EQ. 1) THEN
         CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
         IF (IERR .NE. 0) RETURN
         CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
         IF (IERR .NE. 0) RETURN
         CALL LIROBJ('LISTREEL',ILREE,0,IRETOU)
         IF (IERR .NE. 0) RETURN
      ENDIF
C
      CALL MUCHSC(IPMODL,IPCHE1,IPCHE2,IPCHDI,LMOT1,LMOT2,LMOT3,ILREE,
     $     -1)
      IF(IERR.NE.0) RETURN
C
      IF (IPCHDI.NE.0) THEN
         CALL ACTOBJ('MCHAML  ',IPCHDI,1)
         CALL ECROBJ('MCHAML  ',IPCHDI)
      ELSE
         CALL ERREUR(26)
      ENDIF
      RETURN
 
 101  CONTINUE
      IF (IERR.NE.0) RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN MCHAML ET UN FLOTTANT
C_______________________________________________________________________
C
      CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 102
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 102
      ENDIF
      CALL ACTOBJ('MCHAML  ',ICH1,1)
C     IOPERA= 5 pour l'operation DIVISION
      IOPERA= 5
      IF (CTYP .EQ. 'MCHAML') THEN
C       IARGU = 2  pour MCHAML / FLOTTANT
        IARGU = 2
      ELSE
C       IARGU = 21 pour FLOTTANT / MCHAML
        IARGU = 21
      ENDIF
      I1    = 0
      ICHR = 0
      IRET = 0
      CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('MCHAML  ',ICHR,1)
        CALL ECROBJ('MCHAML  ',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIRE DEUX CHPOINT
C_______________________________________________________________________
C
  102 CALL LIROBJ('CHPOINT ',ICHP1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 103
      CALL ACTOBJ('CHPOINT ',ICHP1,1)
 
      CALL LIROBJ('CHPOINT ',ICHP2,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 103
      ENDIF
      CALL ACTOBJ('CHPOINT ',ICHP2,1)
      CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
      IF ( IRETOU .EQ. 1) THEN
        CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
        IF (IERR .NE. 0) RETURN
 
        CALL LIROBJ('LISTMOTS',MLMOT3,1,IRETOU)
        IF (IERR .NE. 0) RETURN
 
        CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
        IF (IERR .NE. 0) RETURN
        IF(IRETOU .EQ. 1)THEN
          SEGACT,MLREE1
        ENDIF
 
        SEGACT,MLMOT1,MLMOT2,MLMOT3
        CALL MUCHP1(ICHP1,ICHP2,MLMOT1,MLMOT2,MLMOT3,MLREE1,-1,IRET)
 
      ELSE
        CALL MUPOSC(ICHP1,ICHP2,-1,IRET)
      ENDIF
 
      IF (IERR .NE. 0) RETURN
      IF (IRET.NE.0) THEN
        CALL ACTOBJ('CHPOINT ',IRET,1)
        CALL ECROBJ('CHPOINT ',IRET)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN CHPOINT ET UN FLOTTANT
C_______________________________________________________________________
C
  103 CALL LIROBJ('CHPOINT ',ICH,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 104
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 104
      ENDIF
      CALL ACTOBJ('CHPOINT ',ICH,1)
C     IOPERA= 5 pour l'operation DIVISION
      IOPERA= 5
      IF (CTYP .EQ. 'CHPOINT') THEN
C       IARGU = 2  pour CHPOINT / FLOTTANT
        IARGU = 2
      ELSE
C       IARGU = 21 pour FLOTTANT / CHPOINT
        IARGU = 21
      ENDIF
      I1    = 0
      CALL OPCHP1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('CHPOINT ',ICHR,1)
        CALL ECROBJ('CHPOINT ',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN OBJET DE TYPE RIGIDITE ET UN FLOTTANT
C_______________________________________________________________________
C
  104 CALL LIROBJ('RIGIDITE',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 1041
      IF (CTYP .EQ. 'ENTIER') THEN
        CALL REFUS
        GOTO 1041
      ENDIF
      IF (CTYP .EQ. 'FLOTTANT') THEN
        CALL REFUS
        GOTO 1041
      ENDIF
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 1041
      ENDIF
      IF (FLO.EQ.0.) GOTO 5000
      CALL MUFLRI(IPO1,FLO,IRET,-1)
      CALL ECROBJ('RIGIDITE',IRET)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN OBJET DE TYPE MATRIK ET UN FLOTTANT
C_______________________________________________________________________
C
 1041 CALL LIROBJ('MATRIK  ',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 105
      IF (CTYP .EQ. 'ENTIER') THEN
        CALL REFUS
        GOTO 105
      ENDIF
      IF (CTYP .EQ. 'FLOTTANT') THEN
        CALL REFUS
        GOTO 105
      ENDIF
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 105
      ENDIF
      IF (ABS(FLO).LT.XPETIT) GOTO 5000
      CALL PRDMF(1.D0/FLO,IPO1,IRET)
      IF (IRET.NE.0) CALL ECROBJ('MATRIK  ',IRET)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN OBJET DE TYPE EVOLUTIO ET UN FLOTTANT
C_______________________________________________________________________
C
  105 CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 106
      CALL ACTOBJ('EVOLUTIO',ICH,1)
      CALL LIRENT(I1,0,IREENT)
      IF(IREENT.EQ.0) THEN
        I1 = 0
        CALL LIRREE(FLO,0,IREFLO)
        IF(IREFLO.EQ.0) THEN
          CALL REFUS
          GOTO 106
        ELSE
          IF (CTYP .EQ. 'EVOLUTIO') THEN
C           IARGU = 2  pour EVOLUTIO - FLOTTANT
            IARGU = 2
          ELSE
C           IARGU = 21 pour FLOTTANT - EVOLUTIO
            IARGU = 21
          ENDIF
        ENDIF
      ELSE
        FLO = 0.D0
        IF (CTYP .EQ. 'EVOLUTIO') THEN
C         IARGU = 1  pour EVOLUTIO - ENTIER
          IARGU = 1
        ELSE
C         IARGU = 11 pour ENTIER   - EVOLUTIO
          IARGU = 11
        ENDIF
      ENDIF
C     IOPERA= 5 pour l'operation DIVISION
      IOPERA= 5
      ICLE = 0
      CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
      IF (ICLE.EQ.0) ICLE = 2
      CALL OPEVO1(ICH,IOPERA,IARGU,ICLE,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('EVOLUTIO',ICHR,1)
        CALL ECROBJ('EVOLUTIO',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     EVOLUTIO / EVOLUTIO
C_______________________________________________________________________
C
  106 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 107
      CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 107
      ENDIF
      CALL ACTOBJ('EVOLUTIO',IPO1,1)
      CALL ACTOBJ('EVOLUTIO',IPO2,1)
      CALL PUIS(IPO1,IPO2,IRET,-1)
      CALL ACTOBJ('EVOLUTIO',IRET,1)
      CALL ECROBJ('EVOLUTIO',IRET)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN LISTREEL ET UN LISTREEL
C_______________________________________________________________________
C
  107 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 1071
      CALL ACTOBJ('LISTREEL',ICH1,1)
      CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 1071
      ENDIF
      CALL ACTOBJ('LISTREEL',ICHR,1)
C     IOPERA= 5 pour l'operation DIVISION
      IOPERA= 5
      IARGU = 0
      I1    = 0
      FLO   = 0.D0
      CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('LISTREEL',ICHR,1)
        CALL ECROBJ('LISTREEL',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN LISTREEL ET UN LISTENTI
C_______________________________________________________________________
C
 1071 CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 1072
      CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 1072
      ENDIF
      SEGACT MLREE1,MLENT1
      JG=MLENT1.LECT(/1)
      IF(MLREE1.PROG(/1).NE.JG) THEN
         CALL ERREUR (217)
         RETURN
      ENDIF
 
      SEGINI MLREE2
      DO I=1,JG
        IF(CTYP .EQ. 'LISTENTI') THEN
          X2 = MLREE1.PROG(I)
          IF(X2.EQ.0.D0) GOTO 5000
          MLREE2.PROG(I)=REAL(MLENT1.LECT(I))/X2
        ELSE
          X2 = REAL(MLENT1.LECT(I))
          IF(X2.EQ.0.) GOTO 5000
          MLREE2.PROG(I)=MLREE1.PROG(I)/X2
        ENDIF
      ENDDO
      SEGACT,MLREE2*NOMOD
      CALL ECROBJ('LISTREEL',MLREE2)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN LISTENTI ET UN LISTENTI
C_______________________________________________________________________
C
 1072 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 108
      CALL LIROBJ('LISTENTI',MLENT2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 108
      ENDIF
      SEGACT,MLENT1,MLENT2
      JG=MLENT2.LECT(/1)
      IF(MLENT1.LECT(/1) .NE. JG) THEN
         CALL ERREUR (217)
         RETURN
      ENDIF
      SEGINI,MLENT3
      DO I=1,JG
        I1 = MLENT2.LECT(I)
        IF(I1 .EQ. 0 ) GOTO 5000
        MLENT3.LECT(I)=MLENT1.LECT(I)/I1
      ENDDO
      SEGACT,MLENT3*NOMOD
      CALL ECROBJ('LISTENTI',MLENT3)
      RETURN
C_______________________________________________________________________
C
C     LISTREEL / FLOTTANT OU ENTIER
C_______________________________________________________________________
C
  108 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 1081
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 1081
      ENDIF
C     IOPERA= 5 pour l'operation DIVISION
      IOPERA= 5
      IF (CTYP .EQ. 'LISTREEL') THEN
C       IARGU = 2  pour LISTREEL / FLOTTANT
        IARGU = 2
      ELSE
C       IARGU = 21 pour FLOTTANT / LISTREEL (terme a terme)
        IARGU = 21
      ENDIF
      I1    = 0
      CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        MLREEL=ICHR
        SEGACT,MLREEL*NOMOD
        CALL ECROBJ('LISTREEL',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     LISTENTI / FLOTTANT OU ENTIER
C_______________________________________________________________________
C
 1081 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 109
      IF (CTYP .EQ. 'ENTIER') THEN
        CALL REFUS
        GOTO 109
      ENDIF
      IF (CTYP .EQ. 'FLOTTANT') THEN
        CALL REFUS
        GOTO 109
      ENDIF
      CALL LIRENT(I1,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          GOTO 1082
      ELSE
        IF (CTYP .EQ. 'ENTIER') GOTO 109
        IF(I1.EQ.0) GOTO 5000
        SEGACT,MLENT1
        JG=MLENT1.LECT(/1)
 
        SEGINI,MLENT2
        DO I=1, JG
          MLENT2.LECT(I)=MLENT1.LECT(I)/I1
        ENDDO
        SEGACT,MLENT2*NOMOD
        CALL ECROBJ('LISTENTI',MLENT2)
        RETURN
      ENDIF
 
 1082 CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 109
      ELSE
        IF(ABS(FLO).LT.XPETIT) GOTO 5000
        SEGACT,MLENT1
        JG=MLENT1.LECT(/1)
 
        SEGINI,MLREE1
        DO I=1, JG
          MLREE1.PROG(I)=REAL(MLENT1.LECT(I))/FLO
        ENDDO
        SEGACT,MLREE1*NOMOD
        CALL ECROBJ('LISTREEL',MLREE1)
        RETURN
      ENDIF
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 2 ENTIERS
C_______________________________________________________________________
C
  109 CALL LIRENT(I1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 110
      CALL LIRENT(I2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 110
      ENDIF
 
C     Cas de la division de 2 ENTIERS
      IF(I2 .EQ. 0) GOTO 5000
      CALL ECRENT(I1/I2)
      RETURN
C_______________________________________________________________________
C
C   CHERCHE A LIRE DEUX FLOTTANTS
C_______________________________________________________________________
 
  110 CALL LIRREE(X1,0,IRETOU)
      IF ( IRETOU.EQ.0) GOTO 111
      CALL LIRREE(X2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 111
      ENDIF
 
C     Cas de la division de 2 FLOTTANTS
      IF(ABS(X2) .LT. XPETIT) GOTO 5000
*sg      IF(ABS(X2).LT.1.D0.AND.ABS(X1).GT.XGRAND*ABS(X2)) THEN
      IF (ABS(X2).LT.1.D0) THEN
         IF (ABS(X1).GT.XGRAND*ABS(X2)) THEN
            XFLO = SIGN(XUN,X1)*SIGN(XUN,X2)*XGRAND
            GOTO 1101
         ENDIF
      ENDIF
*sg      ELSEIF(ABS(X1).LT.XUN.AND.ABS(X2).GT.XGRAND*ABS(X1)) THEN
      IF (ABS(X1).LT.XUN) THEN
         IF (ABS(X2).GT.XGRAND*ABS(X1)) THEN
            XFLO = 0.D0
            GOTO 1101
         ENDIF
      ENDIF
      XFLO = X1/X2
 1101 CONTINUE
      CALL ECRREE(XFLO)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ UN POINT ET UN FLOTTANT
C_______________________________________________________________________
C
 111  CALL LIROBJ('POINT   ',IP1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 112
      IF (CTYP .EQ. 'ENTIER') THEN
        CALL REFUS
        GOTO 112
      ENDIF
      IF (CTYP .EQ. 'FLOTTANT') THEN
        CALL REFUS
        GOTO 112
      ENDIF
      CALL LIRREE(X2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 112
      ENDIF
      IF(ABS(X2).LT.XPETIT) GOTO 5000
      SEGACT MCOORD*MOD
      ID=IDIM+1
      IREF=ID*(IP1-1)
      DO 11 I=1,IDIM
      XCOOR(**)=XCOOR(IREF+I)/X2
  11  CONTINUE
      XCOOR(**)=XCOOR(IREF+ID)
      nbpts=nbpts+1
      IR=nbpts
      CALL ECROBJ('POINT   ',IR)
      RETURN
C_______________________________________________________________________
C
C  CHERCHE A LIRE UNE TABLE SOUSTYPE VECTEUR ET UN FLOTTANT
C_______________________________________________________________________
C
  112 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 113
      IF (CTYP .EQ. 'ENTIER') THEN
        CALL REFUS
        GOTO 113
      ENDIF
      IF (CTYP .EQ. 'FLOTTANT') THEN
        CALL REFUS
        GOTO 113
      ENDIF
      CALL LIRREE(X2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 113
      ENDIF
      IF(ABS(X2).LT.XPETIT) GOTO 5000
      SEGINI,MTABLE=MTAB1
      DO 701 I=1,MLOTAB
      IF (MTABTV(I).EQ.'FLOTTANT') THEN
         RMTABV(I)=RMTABV(I)/X2
      ELSEIF (MTABTV(I).EQ.'ENTIER  ') THEN
         RMTABV(I)=MTABIV(I)/X2
         MTABTV(I)='FLOTTANT'
      ENDIF
 701  CONTINUE
      SEGDES MTABLE,MTAB1
      CALL ECROBJ('TABLE',MTABLE)
      RETURN
C_______________________________________________________________________
C
C  LISTCHPO / LISTREEL
C_______________________________________________________________________
C
 113  CALL LIROBJ('LISTCHPO',LIPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 114
      CALL LIROBJ('LISTREEL',LREE1,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 114
      ENDIF
      mlreel = lree1
      mlchp1 = lipo1
      segact mlchp1,mlreel
      jg = prog(/1)
      n1 = mlchp1.ichpoi(/1)
      if (jg.ne.n1) call erreur(3)
      if (ierr.ne.0) return
      segini mlchpo
      do ic = 1,n1
         flo = prog(ic)
         ipo1 = mlchp1.ichpoi(ic)
        IF(ABS(FLO).LT.XPETIT) GOTO 5000
        FLD=FLO
        CALL MUCHPO(IPO1,FLD,IRET,-1)
        IF(IRET.EQ.0) RETURN
         ichpoi(ic) = iret
      enddo
      CALL ACTOBJ('LISTCHPO',mlchpo,1)
      CALL ECROBJ('LISTCHPO',mlchpo)
      RETURN
 
C_______________________________________________________________________
C
C     NUAGE / ENTIER
C_______________________________________________________________________
C
  114 CALL LIROBJ('NUAGE   ',ICH1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 115
      CALL LIRENT(I1,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 115
      ENDIF
      IF (I1.EQ.0) GOTO 5000
      CALL ACTOBJ('NUAGE   ',ICH1,1)
      IF (IERR.NE.0) RETURN
C     IOPERA= 5 pour l'operation DIVISION
      IOPERA= 5
      IF (CTYP .EQ. 'NUAGE   ') THEN
C       IARGU = 1  pour NUAGE    / FLOTTANT
        IARGU = 1
      ELSE
C       IARGU = 11 pour FLOTTANT / NUAGE    (terme a terme)
        IARGU = 11
      ENDIF
      FLO   = 0.D0
C     Lecture du nom de la composante
      CALL LIRCHA(COMP,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL OPNUA1(ICH1,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
      IF (IERR.NE.0) RETURN
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('NUAGE   ',ICHR,1)
        CALL ECROBJ('NUAGE   ',ICHR)
      ELSE
C       ERREUR 5 car erreurs gerees dans OPNUA1
        CALL ERREUR(5)
      ENDIF
      RETURN
 
C_______________________________________________________________________
C
C     NUAGE / FLOTTANT 
C_______________________________________________________________________
C
  115 CALL LIROBJ('NUAGE   ',ICH1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 120
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 120
      ENDIF
      IF (ABS(FLO).LT.XPETIT) GOTO 5000
      CALL ACTOBJ('NUAGE   ',ICH1,1)
      IF (IERR.NE.0) RETURN
C     IOPERA= 5 pour l'operation DIVISION
      IOPERA= 5
      IF (CTYP .EQ. 'NUAGE   ') THEN
C       IARGU = 2  pour NUAGE    / FLOTTANT
        IARGU = 2
      ELSE
C       IARGU = 21 pour FLOTTANT / NUAGE    (terme a terme)
        IARGU = 21
      ENDIF
      I1    = 0
C     Lecture du nom de la composante
      CALL LIRCHA(COMP,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL OPNUA1(ICH1,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
      IF (IERR.NE.0) RETURN
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('NUAGE   ',ICHR,1)
        CALL ECROBJ('NUAGE   ',ICHR)
      ELSE
C       ERREUR 5 car erreurs gerees dans OPNUA1
        CALL ERREUR(5)
      ENDIF
      RETURN
 
C_______________________________________________________________________
C
C   ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
C_______________________________________________________________________
C
 120  CONTINUE
      CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF(IRETOU.NE.0) THEN
         CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
         CALL QUETYP(MOTERR(9:16),0,IRETOU)
         IF (IRETOU.EQ.0)  MOTERR(9:16) = '  ????  '
         CALL ERREUR(532)
      ELSE
         CALL ERREUR(533)
      ENDIF
      RETURN
 5000 CONTINUE
      CALL ERREUR(835)
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 

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