Télécharger la plaquette Cast3M


fr en

Télécharger obteni.eso

Retour à la liste

Numérotation des lignes : 

obteni

  1. C OBTENI    SOURCE    JC220346  18/12/04    21:15:53     9991           
  2.       SUBROUTINE OBTENI
  3.       IMPLICIT INTEGER(I-N)
  4.  
  5. -INC PPARAM
  6. -INC CCNOYAU
  7. -INC CCOPTIO
  8. -INC CCREDLE
  9. -INC SMLENTI
  10. -INC SMLREEL
  11. -INC CCASSIS
  12.  
  13.       CHARACTER*(8)     CHAR
  14.       CHARACTER*(LONOM) CHARB,CNOMP
  15.       CHARACTER*(LOCHAI) CHARC
  16. C    CHARACTER*(LOCHAI) CMTEXT
  17.       CHARACTER*4 MOAST(1)
  18.       LOGICAL LOGI
  19.       REAL*8 XPO
  20.       CHARACTER*26 MINU,MAJU
  21.       DATA MINU/'abcdefghijklmnopqrstuvwxyz'/
  22.       DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  23.       DATA MOAST/'*   '/
  24.  
  25.       IPASS=1
  26.       MLENTI=0
  27.       MLREEL=0
  28.     1 CONTINUE
  29.       CALL QUETYP (CHAR,IPASS,IRETOU)
  30.       IF(IERR.NE.0) RETURN
  31.       IF(IRETOU.EQ.0) GO TO 200
  32.       IF(CHAR.EQ.'ENTIER  ')    THEN
  33.           CALL LIRENT(IPO,1,IRETOU)
  34.       ELSEIF(CHAR.EQ.'FLOTTANT')THEN
  35.           CALL LIRREE(XPO,1,IRETOU)
  36.       ELSEIF(CHAR.EQ.'MOT     ')THEN
  37.           CALL LIRCHA(CHAR,1,IRETOU)
  38.       ELSEIF(CHAR.EQ.'LOGIQUE ')THEN
  39.           CALL LIRLOG(LOGI,1,IRETOU)
  40.       ELSE
  41.           CALL LIROBJ(CHAR,IPO,1,IRETOU)
  42.       ENDIF
  43.       CALL QUENOM(CHARB)
  44.       CALL LIRMOT(MOAST,1,IVAL,0)
  45.       CHAR=' '
  46.       IF(IVAL.NE.0) THEN
  47.       CALL LIRCHA(CHAR,1,IRETOU)
  48.       IF(IERR.NE.0) RETURN
  49.       ENDIF
  50.       ICREA=0
  51.       IF(IPASS.NE.1) GO TO 25
  52. C
  53. C  *** SAUVETAGE DE LA LECTURE
  54. C
  55. *        CMTEXT(1:500)=TEXT(1:500)
  56. *        NRAN1=NRAN
  57. *        ICOUR1=ICOUR
  58. *        IFINA1=IFINAN
  59. *        IPREC1=IPREC
  60.          call inired(sredle)
  61.          NRAN= 0
  62.          IPREC=1
  63.    20   CONTINUE
  64.          NRAN=0
  65.          IFINAN=73
  66.          ICOUR=72
  67.          READ(IOTER,FMT='(A72)',END=21) TEXT(1:72)
  68.    25    CALL REDLEC(sredle)
  69.          IF(IRE.EQ.0.AND.CHAR.EQ.'LISTENTI') THEN
  70.            MOTERR(1:8) ='LISTENTI'
  71.            CALL ERREUR(-290)
  72.            READ(IOTER,FMT='(A72)',END=21) TEXT(1:72)
  73.            NRAN=0
  74.            IFINAN=73
  75.            ICOUR=72
  76.            CALL REDLEC(sredle)
  77.            IF(IRE.EQ.0) THEN
  78.              IF(MLENTI.EQ.0) THEN
  79.               CALL NOMOBJ('ANNULE',CHARB,MLENTI)
  80.              ELSE
  81.               SEGDES MLENTI
  82.               CALL NOMOBJ(CHAR,CHARB,MLENTI)
  83.              ENDIF
  84.              GO TO 200
  85.            ENDIF
  86.          ENDIF
  87.          IF(IRE.EQ.0.AND.CHAR.EQ.'LISTREEL') THEN
  88.            MOTERR(1:8) ='LISTREEL'
  89.            CALL ERREUR(-290)
  90.            READ(IOTER,FMT='(A72)',END=21) TEXT(1:72)
  91.            NRAN=0
  92.            IFINAN=73
  93.            ICOUR=72
  94.            CALL REDLEC(sredle)
  95.            IF(IRE.EQ.0) THEN
  96.             IF(MLREEL.EQ.0) THEN
  97.               CALL NOMOBJ('ANNULE',CHARB,MLREEL)
  98.              ELSE
  99.               SEGDES MLREEL
  100.               CALL NOMOBJ(CHAR,CHARB,MLREEL)
  101.              ENDIF
  102.              GO TO 200
  103.            ENDIF
  104.          ENDIF
  105.          IF(IRE.EQ.0) GO TO 21
  106.          IAVA=0
  107.          IF(IRE.EQ.3) THEN
  108.             DO 123 IAUX=1,NCAR
  109. *  PASSAGE EN MAJUSCULE
  110.             IRAL=INDEX(MINU,MOT(IAUX:IAUX))
  111.             IF (IRAL.NE.0) MOT(IAUX:IAUX)=MAJU(IRAL:IRAL)
  112.  123        CONTINUE
  113.          ENDIF
  114.          CALL PRENOM(IPLAMO,IAVA,sredle)
  115.          if(nbesc.ne.0) segact ipiloc
  116.          IP= INOOB1(IPLAMO)
  117.          IDEBCH=IPCHAR(IP)
  118.          IFINCH=IPCHAR(IP+1)-1
  119.           CNOMP=ICHARA(IDEBCH:IFINCH)
  120.          IF(IIMPI.EQ.1754) WRITE(IOIMP,654) CNOMP
  121.      #   ,INOOB2(IPLAMO)
  122.   654 FORMAT(' DANS OBTENI OBJET(1.5)  ',A8,2X,A8,2X,A4)
  123.          IF(IIMPI.EQ.1754) WRITE(IOIMP,657)CHAR
  124.   657  FORMAT(' DANS OBTENI  TYPE ATTENDU  ',A8)
  125.          if(nbesc.ne.0) SEGDES,IPILOC
  126.  
  127. C
  128. C  **** DECODAGE DE LA LECTURE ET VERIF DU TYPE
  129. C
  130.       IF(CNOMP.NE.'NON') GO TO 31
  131.  210  CONTINUE
  132.       CALL NOMOBJ('ANNULE',CHARB,ip1)
  133.       GO TO 200
  134.    31 CONTINUE
  135.       IF(CHAR.EQ.'        ') CHAR=INOOB2(IPLAMO)
  136.       IF(CHAR.EQ.'FLOTTANT'.AND.INOOB2(IPLAMO).EQ.'ENTIER  ') THEN
  137.          IOO=IOUEP2(IPLAMO)
  138.          XPO=IOO
  139.            CALL NOMREE(CHARB,XPO)
  140.          GO TO 465
  141.       ENDIF
  142.       IF(CHAR.EQ.'LISTREEL') THEN
  143.          IF(ICREA.EQ.0) THEN
  144.            JG=0
  145.            SEGINI MLREEL
  146.            ICREA=1
  147.          ENDIF
  148.          IF(INOOB2(IPLAMO) .NE . 'ENTIER  '.AND.
  149.      $    INOOB2(IPLAMO) .NE . 'FLOTTANT' ) GO TO 54
  150.           IOO=IOUEP2(IPLAMO)
  151.          IF (INOOB2(IPLAMO).EQ.'ENTIER  ') THEN
  152.          XPO=IOO
  153.          ELSE
  154.          if(nbesc.ne.0) segact ipiloc
  155.          XPO= XIFLOT(IOO)
  156.          if(nbesc.ne.0) SEGDES,IPILOC
  157.          ENDIF
  158.          JG=JG+1
  159.          SEGADJ MLREEL
  160.          PROG(JG)=XPO
  161.          GO TO 25
  162.       ENDIF
  163.       IF(CHAR.EQ.'LISTENTI') THEN
  164.          IF(ICREA.EQ.0) THEN
  165.            JG=0
  166.            SEGINI MLENTI
  167.            ICREA=1
  168.          ENDIF
  169.          IF(INOOB2(IPLAMO) .NE . 'ENTIER  ') GO TO 52
  170.          JG=JG+1
  171.          SEGADJ MLENTI
  172.          LECT(JG)=IOUEP2(IPLAMO)
  173.          GO TO 25
  174.       ENDIF
  175.       IF(CHAR.NE.INOOB2(IPLAMO)) GO TO 50
  176.       IOO=IOUEP2(IPLAMO)
  177.       if(nbesc.ne.0) segact ipiloc
  178.       IF(CHAR.EQ.'ENTIER  ') THEN
  179.            IVAL=IOO
  180.            CALL NOMENT(CHARB,IVAL)
  181.       ELSEIF(CHAR.EQ.'FLOTTANT') THEN
  182.            XPO= XIFLOT(IOO)
  183.            CALL NOMREE(CHARB,XPO)
  184.       ELSEIF(CHAR.EQ.'MOT    ') THEN
  185.            ID=IPCHAR(IOO)
  186.            IFI=IPCHAR(IOO+1)
  187.            IF1=IFI-ID
  188.            CHARC=' '
  189.            IF1=MIN(IF1,72)
  190.            CHARC(1:IF1)=ICHARA(ID:IFI-1)
  191.            CALL NOMCHA(CHARB,CHARC(1:IF1))
  192.       ELSEIF(CHAR.EQ.'LOGIQUE ')  THEN
  193.            LOGI=IPLOGI(IOO)
  194.            CALL NOMLOG(CHARB,LOGI)
  195.       ELSE
  196.            CALL NOMOBJ(CHAR,CHARB,IOO)
  197.       ENDIF
  198.       if(nbesc.ne.0) SEGDES,IPILOC
  199.   465      CONTINUE
  200.        IPASS=0
  201.        GO TO 1
  202.    50  CONTINUE
  203.        WRITE(IOIMP,51) CHAR
  204.        GO TO 20
  205.    52  CONTINUE
  206.        WRITE(IOIMP,51) 'ENTIER'
  207.        GO TO 20
  208.    54  CONTINUE
  209.        WRITE(IOIMP,51) 'FLOTTANT'
  210.        GO TO 20
  211.    51  FORMAT(' LA QUANTITE LUE N''EST PAS DU TYPE ',A8,
  212.      #' RECOMMENCEZ S''IL VOUS PLAIT')
  213.   200  CONTINUE
  214. C-- ON REMET TEXT EN PLACE
  215. *        TEXT(1:500)=CMTEXT(1:500)
  216. *        IFINAN=IFINA1
  217. *        IPREC=IPREC1
  218. *        ICOUR=ICOUR1
  219. *        NRAN=NRAN1
  220.          segsup sredle
  221.          RETURN
  222.    21    CONTINUE
  223.          IF(IOGRA.EQ.3.OR.IOGRA.EQ.2) THEN
  224. C         REWIND IOTER
  225.          GOTO 210
  226.          ELSE
  227.          CALL ERREUR ( 34 )
  228.          RETURN
  229.          ENDIF
  230.          END
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  

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