Télécharger la plaquette Cast3M


fr en

Télécharger erre.eso

Retour à la liste

Numérotation des lignes : 

erre

  1. C ERRE      SOURCE    FANDEUR   22/06/30    21:15:01     11390          
  2.       SUBROUTINE ERRE
  3. C_______________________________________________________________________
  4. C
  5. C                 OPERATEUR ERRE
  6. C                 --------------
  7. C
  8. C  PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 02/91
  9. C
  10. C_______________________________________________________________________
  11. C
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8(A-H,O-Z)
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC CCNOYAU
  18.  
  19. -INC SMLREEL
  20. -INC SMLENTI
  21. -INC SMLMOTS
  22. -INC SMLCHPO
  23.  
  24.       CHARACTER*(LOCHAI) AUX
  25.       CHARACTER*(8)      CTYP
  26.       CHARACTER*(1000)   CHLU(2)
  27.       CHARACTER*(2000)   CHLUS
  28.       CHARACTER*(1)      CH1
  29.       CHARACTER*(11)     DIGIT
  30.  
  31.       LOGICAL ZAVEC,BOOL
  32.       SEGMENT,IPODEB(0),IPOFIN(0)
  33.  
  34.       DATA DIGIT/'1234567890:'/
  35.  
  36.       CHARACTER*(1)  CFMT0
  37.       CHARACTER*(4)  CFMT1
  38.       CHARACTER*(9)  CFMT2
  39.       CHARACTER*(21) CFMT3
  40.  
  41.       EXTERNAL LONG
  42.  
  43.       MOTERR = ' '
  44.  
  45.       AUX = ' '
  46.       ZAVEC = .FALSE.
  47.  
  48. C     ==========================
  49. C     DECLENCHEMENT D'UNE ERREUR
  50. C     ==========================
  51.  
  52. C     SYNTAXE1 => on fournit un message que l'on affiche juste avant
  53. C                 de declencher l'erreur 308
  54.       CALL LIRCHA(AUX,0,IRETOU)
  55.       IF (IRETOU.EQ.0) GOTO 250
  56.       CALL LENCHA(AUX,LAUX)
  57.       ZAVEC = AUX(1:LAUX).EQ.'AVEC'
  58.       if (laux.ne.4) zavec=.false.
  59.       IF (ZAVEC) GOTO 250
  60.  
  61.  100  CONTINUE
  62. C     Determination du FORMAT d'affichage exact
  63.       IVAL=INT(LOG10(REAL(LAUX)))+1
  64.       IVAL=MAX(1,IVAL)
  65.       WRITE(CFMT0,'(I1)')IVAL
  66.       CFMT1='(I'//CFMT0//')'
  67.       WRITE(CFMT2,CFMT1) MAX(1,LAUX)
  68.       CFMT3='(/,(1X,A'//CFMT2(1:IVAL)//'),/)'
  69.       WRITE(IOIMP,CFMT3) AUX
  70.       CALL ERREUR(308)
  71.       RETURN
  72. C
  73. C     SYNTAXE2 => on remplit MOTERR, INTERR, REAERR et BOOERR avant
  74. C                 de declencher une erreur quelconque de GIBI.ERREUR
  75.  250  CONTINUE
  76. C
  77.       CALL LIRENT (KENT,0,IRETOU)
  78.       IF (IRETOU.EQ.0) THEN
  79.         IF (ZAVEC) GOTO 100
  80.         GOTO 255
  81.       END IF
  82.  
  83.       MOTERR = ' '
  84.       IF (ZAVEC) THEN
  85.  
  86. C         -------------------------------------------------------------
  87. C         EN PREAMBULE : ON VA REMPLIR IPODEB ET IPOFIN AVEC LES BORNES
  88. C         (DANS MOTERR) DE CHACUN DES MOTIFS %m OU %M
  89. C         -------------------------------------------------------------
  90.  
  91. C         ON PLACE DANS CHLU(1) ET CHLU(2) LE CONTENU DU MESSAGE D'ERREUR
  92.           CALL ERREU1(KENT,CHLU,NIVEAU,NBL)
  93.           IF (IERR.NE.0) RETURN
  94.           II=0
  95.           CHLUS(1:1000)=CHLU(1)
  96.           IF (NBL.EQ.1) THEN
  97.               CHLUS(1001:2000)=' '
  98.           ELSE
  99.               CHLUS(1001:2000)=CHLU(2)
  100.           ENDIF
  101.           IIMAX=LONG(CHLUS)
  102.           SEGINI,IPODEB,IPOFIN
  103.  
  104. C         BOUCLE 2501 => ON CHERCHE UN MOTIF %m OU %M
  105.  2501     II=II+1
  106.           IF (II.GT.IIMAX) GOTO 2504
  107.           CH1=CHLUS(II:II)
  108.           IF (CH1.NE.'%') GOTO 2501
  109.           II=II+1
  110.           CH1=CHLUS(II:II)
  111.           IF (CH1.NE.'m'.AND.CH1.NE.'M') GOTO 2501
  112.           IPOS=0
  113.           ICOM=0
  114.  
  115. C         BOUCLE 2502 => ON CHERCHE LES BORNES DU MOTIF
  116.  2502     II=II+1
  117.           CH1=CHLUS(II:II)
  118.           IPO=INDEX(DIGIT,CH1)
  119.           IF (IPO.GE.1.AND.IPO.LE.10) THEN
  120.               IPOS=IPOS*10
  121.               IF (IPO.LT.10) IPOS=IPOS+IPO
  122.           ELSEIF (IPO.EQ.11) THEN
  123.               IF (ICOM.EQ.0) THEN
  124.                   IF (IPOS.EQ.0) GOTO 2501
  125.                   IDEB=IPOS
  126.                   IPOS=0
  127.                   ICOM=1
  128.                   GOTO 2502
  129.               ELSE
  130.                   GOTO 2503
  131.               ENDIF
  132.           ELSE
  133.               IF (ICOM.EQ.0.OR.IPOS.EQ.0) GOTO 2501
  134.               GOTO 2503
  135.           ENDIF
  136.           GOTO 2502
  137.  
  138. C         ETIQUETTE 2503 => ON A BIEN LU DEUX NOMBRES ENTIERS NON NULS
  139.  2503     IFIN=IPOS
  140.           CALL AJOU(IPODEB,IDEB)
  141.           CALL AJOU(IPOFIN,IFIN)
  142.           II=II-1
  143.           GOTO 2501
  144.  2504     CONTINUE
  145.  
  146.           NBMOT=IPODEB(/1)
  147.  
  148. C         ----------------------------------------------------------
  149. C         ON PEUT DESORMAIS REMPLIR MOTERR, INTERR, REAERR ET BOOERR
  150. C         ----------------------------------------------------------
  151.           MOTERR = ' '
  152.           DO ii = 1, 11
  153.             INTERR(ii) = 0
  154.           END DO
  155.           DO ii = 1, 10
  156.             REAERR(ii) = 0.D0
  157.           END DO
  158.           DO ii = 1, 10
  159.             BOOERR(ii) = .FALSE.
  160.           END DO
  161.  
  162.           IMOT=0
  163.           IENT=0
  164.           IFLO=0
  165.           ILOG=0
  166.  
  167. C Cas particulier erreur 308
  168.           IF (KENT.EQ.308) THEN
  169.             CALL LIRCHA(AUX,0,IRETOU)
  170.             IF (IRETOU.EQ.0) GOTO 252
  171.             CALL LENCHA(AUX,LAUX)
  172.             SEGSUP,IPODEB,IPOFIN
  173.             GOTO 100
  174.           END IF
  175.  
  176. C Boucle de lecture des elements du message %_
  177.  251      CALL QUETYP(CTYP,0,IRET)
  178.           IF (IRET.EQ.0) GOTO 252
  179.  
  180. C         MOT ---> MOTERR
  181.           IF (CTYP.EQ.'MOT') THEN
  182.               CALL LIRCHA(AUX,1,LCH)
  183.               IF (IERR.NE.0) RETURN
  184.               IF (IMOT.LT.NBMOT) THEN
  185.                   IMOT=IMOT+1
  186.                   IDEB=IPODEB(IMOT)
  187.                   IFIN=IPOFIN(IMOT)
  188.                   LON=MIN(IFIN-IDEB+1,LCH)
  189.                   MOTERR(IDEB:IFIN)=AUX(1:LON)
  190.               ENDIF
  191.  
  192. C         LISTMOTS ---> MOTERR
  193.           ELSEIF (CTYP.EQ.'LISTMOTS') THEN
  194.               CALL LIROBJ('LISTMOTS',IOB,1,IRET)
  195.               IF (IERR.NE.0) RETURN
  196.               MLMOT1=IOB
  197.               SEGACT,MLMOT1
  198.               JGN=MLMOT1.MOTS(/1)
  199.               JGM=MLMOT1.MOTS(/2)
  200.               DO K=1,JGM
  201.                   AUX=MLMOT1.MOTS(K)
  202.                   LCH=LONG(AUX)
  203.                   IF (IMOT.LT.NBMOT) THEN
  204.                       IMOT=IMOT+1
  205.                       IDEB=IPODEB(IMOT)
  206.                       IFIN=IPOFIN(IMOT)
  207.                       LON=MIN(IFIN-IDEB+1,LCH)
  208.                       MOTERR(IDEB:IFIN)=AUX(1:LON)
  209.                   ENDIF
  210.               ENDDO
  211.  
  212. C         ENTIER ---> INTERR
  213.           ELSEIF (CTYP.EQ.'ENTIER') THEN
  214.               CALL LIRENT(IVAL,1,IRET)
  215.               IF (IERR.NE.0) RETURN
  216.               IF (IENT.LT.9) THEN
  217.                   IENT=IENT+1
  218.                   INTERR(IENT)=IVAL
  219.               ENDIF
  220.  
  221. C         LISTENTI ---> INTERR
  222.           ELSEIF (CTYP.EQ.'LISTENTI') THEN
  223.               CALL LIROBJ('LISTENTI',IOB,1,IRET)
  224.               IF (IERR.NE.0) RETURN
  225.               MLENT1=IOB
  226.               SEGACT,MLENT1
  227.               JG=MLENT1.LECT(/1)
  228.               DO K=1,JG
  229.                   IF (IENT.LT.9) THEN
  230.                       IENT=IENT+1
  231.                       INTERR(IENT)=MLENT1.LECT(K)
  232.                   ENDIF
  233.               ENDDO
  234.  
  235. C         FLOTTANT ---> REAERR
  236.           ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  237.               CALL LIRREE(XVAL,1,IRET)
  238.               IF (IERR.NE.0) RETURN
  239.               IF (IFLO.LT.9) THEN
  240.                   IFLO=IFLO+1
  241.                   REAERR(IFLO)=XVAL
  242.               ENDIF
  243.  
  244. C         LISTREEL ---> REAERR
  245.           ELSEIF (CTYP.EQ.'LISTREEL') THEN
  246.               CALL LIROBJ('LISTREEL',IOB,1,IRET)
  247.               IF (IERR.NE.0) RETURN
  248.               MLREE1=IOB
  249.               SEGACT,MLREE1
  250.               JG=MLREE1.PROG(/1)
  251.               DO K=1,JG
  252.                   IF (IFLO.LE.9) THEN
  253.                       IFLO=IFLO+1
  254.                       REAERR(IFLO)=MLREE1.PROG(K)
  255.                   ENDIF
  256.               ENDDO
  257.  
  258. C         LOGIQUE ---> BOOERR
  259.           ELSEIF (CTYP.EQ.'LOGIQUE') THEN
  260.               CALL LIRLOG(BOOL,1,IRET)
  261.               IF (IERR.NE.0) RETURN
  262.               IF (ILOG.LT.9) THEN
  263.                   ILOG=ILOG+1
  264.                   BOOERR(ILOG)=BOOL
  265.               ENDIF
  266.  
  267. C         Objet de type incorrect
  268.           ELSE
  269.               MOTERR = ' '
  270.               MOTERR(1:8)=CTYP
  271.               CALL ERREUR(39)
  272.               RETURN
  273.           ENDIF
  274.  
  275.           GOTO 251
  276.  
  277.  252      CONTINUE
  278.           SEGSUP,IPODEB,IPOFIN
  279.           IF (IMOT.EQ.0.AND.IENT.EQ.0.AND.IFLO.EQ.0.AND.ILOG.EQ.0) THEN
  280.             MOTERR = ' '
  281.             MOTERR(1:4)='AVEC'
  282.             CALL ERREUR(166)
  283.             RETURN
  284.           ENDIF
  285.  
  286.       ENDIF
  287.  
  288.       CALL ERREUR(KENT)
  289.       RETURN
  290.  
  291. C     ===============
  292. C     CALCUL D'ERREUR
  293. C     ===============
  294.  
  295.  255  CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
  296.       IF (IRETOU.EQ.0) GOTO 256
  297.       CALL LIROBJ('CHPOINT ',IPO2,1,IRETOU)
  298.       IF (IERR.NE.0) RETURN
  299.       CALL ADCHPO(IPO1,IPO2,IRET,1D0,-1D0)
  300.       IF (IRET.EQ.0) RETURN
  301.       call ecrCHA('ABS')
  302.       CALL ECROBJ('CHPOINT ',IRET)
  303.       CALL MAXIMU(1)
  304.       RETURN
  305.  
  306.  256  CALL LIROBJ('LISTCHPO',IPO1,0,IRETOU)
  307.       IF (IRETOU.EQ.0) GOTO 260
  308.       CALL LIROBJ('LISTCHPO',IPO2,1,IRETOU)
  309.       IF (IERR.NE.0) RETURN
  310.  
  311.       mlchp1 = ipo1
  312.       mlchp2 = ipo2
  313.       segact mlchp1, mlchp2
  314.       if (mlchp1.ichpoi(/1).ne.mlchp2.ichpoi(/1)) then
  315.         call erreur(3)
  316.         return
  317.       end if
  318.       JG = mlchp1.ichpoi(/1)
  319.       segini mlreel
  320.       do ii = 1 ,jg
  321.         ipo1 = mlchp1.ichpoi(ii)
  322.         ipo2 = mlchp2.ichpoi(ii)
  323.         CALL ADCHPO(IPO1,IPO2,IRET,1D0,-1D0)
  324.         IF (IRET.EQ.0) RETURN
  325.         call ecrCHA('ABS')
  326.         CALL ECROBJ('CHPOINT ',IRET)
  327.         CALL MAXIMU(1)
  328.         call lirree(xx,1,iretou)
  329.         if (ierr.ne.0) return
  330.         prog(ii) = xx
  331.       enddo
  332.  
  333.       call ECROBJ('LISTREEL',mlreel)
  334.       RETURN
  335.  
  336. C_______________________________________________________________________
  337. C
  338. C  CALCUL D'ERREUR   ( VERSION BARZIC ET RICHARD )
  339. C_______________________________________________________________________
  340. C
  341.  260  CONTINUE
  342.       CALL LIROBJ('MMODEL  ',IPMODL,1,IRETM)
  343.       CALL ACTOBJ('MMODEL  ',IPMODL,1)
  344.       IF (IERR.NE.0) RETURN
  345. C
  346.       CALL LIROBJ('MCHAML',IPIN,1,IRETOU)
  347.       CALL ACTOBJ('MCHAML',IPIN,1)
  348.       IF (IERR.NE.0)RETURN
  349.       CALL REDUAF(IPIN,IPMODL,IPCHE1,0,IR,KER)
  350.       IF(IR   .NE. 1) CALL ERREUR(KER)
  351.       IF(IERR .NE. 0) RETURN
  352.  
  353.       CALL LIROBJ('MCHAML',IPIN,1,IRETOU)
  354.       CALL ACTOBJ('MCHAML',IPIN,1)
  355.       IF (IERR.NE.0) RETURN
  356.       CALL REDUAF(IPIN,IPMODL,IPCHE2,0,IR,KER)
  357.       IF(IR   .NE. 1) CALL ERREUR(KER)
  358.       IF(IERR .NE. 0) RETURN
  359. C
  360.       CALL RNGCHA (IPCHE1,IPCHE2,'CONTRAINTES','CARACTERISTIQUES'
  361.      1                   ,IPCH1,IPCH2)
  362.       IF(IPCH1.EQ.0.OR.IPCH2.EQ.0)THEN
  363.          IF(IPCH1.EQ.0)THEN
  364.              MOTERR(1:16)='CONTRAINTES     '
  365.          ELSE
  366.              MOTERR(1:16)='CARACTERISTIQUES'
  367.          ENDIF
  368.          CALL ERREUR(565)
  369.          RETURN
  370.       ENDIF
  371. C
  372.       CALL ERRARE(IPMODL,IPCH1,IPCH2,XERR,IPCHRR)
  373. C
  374.       IF (IPCHRR.NE.0) THEN
  375.          CALL ACTOBJ('MCHAML  ',IPCHRR,1)
  376.          CALL ECROBJ('MCHAML  ',IPCHRR)
  377.          CALL ECRREE(XERR)
  378.       ENDIF
  379.  
  380.       RETURN
  381.       END
  382.  
  383.  
  384.  

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