Sources Esope | Cast3M

acquer
C ACQUER    SOURCE    PV        22/12/12    21:15:01     11523          
 
      SUBROUTINE ACQUER(IBRUT)
* SG
* IBRUT est un entier valant 1 si l'option 'BRUT' a été lue et 0 sinon
* Si IBRUT vaut 1, un traitement particulier est effectué dans
* pilot pour ne pas interpréter la ligne lue (comme avec CHAI et MOT)
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCNOYAU
-INC CCOPTIO
-INC CCASSIS
-INC CCREDLE
 
-INC SMLENTI
-INC SMLREEL
 
      EXTERNAL LONG
      LOGICAL LOGI
      REAL*8 XPO
      CHARACTER*8  CHAR
      CHARACTER*(LONOM) CHARB
      CHARACTER*26 MINU,MAJU
      CHARACTER*4  MOAST(1)
      CHARACTER*4  MOBRUT(1)
 
C TAILLE D'UN ENREGISTREMENT DU FICHIER IOACQ : NCARMAX CARACTERES
C La taille est limitee a LOCHAI (dimension de TEXT dans SREDLE : voir PPARAM.INC).
      PARAMETER (NCARMAX = 256 , NCARFIN = NCARMAX+1)
*     PARAMETER (NCARMAX = 72 , NCARFIN = NCARMAX+1)
C MOT pouvant etre lu dans un enregistrement
      CHARACTER*(NCARMAX) CHARMO
C Moins de limitation dans l'option 'BRUT'
      CHARACTER*(LOCHAI) CHARM2
 
      DATA MINU / 'abcdefghijklmnopqrstuvwxyz' /
      DATA MAJU / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
      DATA MOAST / '*   ' /
      DATA MOBRUT/ 'BRUT' /
C FORMAT DE LECTURE D'UN ENREGISTREMENT DU FICHIER IOACQ
 3000 FORMAT(A256)
*3000 FORMAT(A72)
C FORMAT pour l'option BRUT
 3002 FORMAT(A512)
*  sauver lmnnom maintenant au cas ou on soit en erreur
      LMNSAU=LMNNOM
*
      CALL LIRMOT(MOBRUT,1,IBRUT,0)
* Cas : chaine = ACQU 'BRUT' ;
      IF (IBRUT.EQ.1) THEN
* Initialise SREDLE a 0 pour garder le traitement d'erreur normal au
* label 21
         SREDLE=0
         READ(IOACQ,FMT=3002,END=21,ERR=21) CHARM2
         LONCHA=LONG(CHARM2)
         CALL ECRCHA(CHARM2(1:LONCHA))
         RETURN
      ENDIF
*
      CALL POSCHA('NON',IPONON)
      IF (IERR.NE.0) RETURN
 
      IPASS=1
 
      SREDLE=0
      CALL INIRED(SREDLE)
      IPREC =1
      NRAN  =0
      ICOUR =NCARMAX
      IFINAN=NCARFIN
 
*  sauver lmnnom car prenom va l'augmenter
      LMNSAU=LMNNOM
 
 1    CONTINUE
      CALL QUETYP(CHAR,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 200
C Lecture du NOM Gibiane (CHARB) de l'objet a acquerir
      CALL LIROBJ(CHAR,IPO,0,IRETOU)
      CALL QUENOM(CHARB)
      IF (IIMPI.EQ.1754) THEN
        WRITE(IOIMP,FMT='('' TYPE LU : '',A8)') CHAR
        WRITE(IOIMP,FMT='('' NOM LU : '',A24)') CHARB
      ENDIF
C On veut savoir si l'objet a acquerir doit avoir un TYPE ('*....')
      CALL QUETYP(CHAR,0,iretou)
      IVAL=0
      IF (CHAR.EQ.'MOT     ') CALL LIRMOT(MOAST,1,IVAL,0)
      IF (IIMPI.EQ.1754) THEN
        IF (IVAL.EQ.0) THEN
          WRITE(IOIMP,FMT='(''  PAS D ASTERISQUE TOUVEE '')')
        ELSE
          WRITE(IOIMP,FMT='(''   ASTERISQUE TOUVEE '')')
        ENDIF
      ENDIF
C CHAR contient le type demande de l'objet (=' 'si aucun + IVAL=0)
      CHAR='        '
      IF (IVAL.NE.0) THEN
C Lecture du TYPE de l'objet a acquerir demande par l'utilisateur
        CALL LIRCHA(CHAR,1,IRETOU)
        IF (IERR.NE.0) GOTO 200
        IF (IIMPI.EQ.1754)WRITE(IOIMP,FMT='('' TYPE ATTENDU '',A8)')CHAR
C
C CAS DES LISTENTI  ET DES LISTREEL
C
        IF (CHAR.EQ.'LISTENTI'.OR.CHAR.EQ.'LISTREEL') THEN
          CALL LIRENT(JG,1,IRETOU)
          IF (IERR.NE.0) GOTO 200
          IOP = 0
          IF (CHAR.EQ.'LISTENTI') THEN
            SEGINI MLENTI
            IF (IPASS.EQ.0) GOTO 202
            SEPARA=.FALSE.
 201        CONTINUE
            NRAN=0
            ICOUR =NCARMAX
            IFINAN=NCARFIN
            READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
 202        CONTINUE
            CALL REDLEC(sredle)
            IF (IRE.EQ.0) GOTO 201
            IOP=IOP+1
            IF (IRE.NE.1) THEN
              CALL ERREUR(8)
              GOTO 200
            ENDIF
            LECT(IOP)=NFIX
            IF (IOP.LT.JG) GOTO 202
            SEGDES,MLENTI
            CALL NOMOBJ('LISTENTI',CHARB,MLENTI)
C*        ELSE IF (CHAR.EQ.'LISTREEL') THEN
          ELSE
            SEGINI,MLREEL
            IF (IPASS.EQ.0) GOTO 302
            SEPARA=.FALSE.
 301        CONTINUE
            NRAN=0
            ICOUR =NCARMAX
            IFINAN=NCARFIN
            READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
 302        CALL REDLEC(sredle)
            IF (IRE.EQ.0) GOTO 301
            IOP=IOP+1
            IF (IRE.EQ.1) THEN
              PROG(IOP)=NFIX
            ELSE IF (IRE.EQ.2) THEN
              PROG(IOP)=FLOT
            ELSE
              CALL ERREUR(15)
              GOTO 200
            ENDIF
            IF (IOP.LT.JG) GOTO 302
            SEGDES,MLREEL
            CALL NOMOBJ('LISTREEL',CHARB,MLREEL)
          ENDIF
          IPASS=0
          GOTO 1
        ENDIF
      ENDIF
C
C  AUTRES CAS   ENTIER  FLOTTANT  MOT  LOGIQUE
C
      IF (IPASS.EQ.0) GOTO 25
      SEPARA=.FALSE.
 20   CONTINUE
      NRAN=0
      ICOUR =NCARMAX
      IFINAN=NCARFIN
      READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
 25   CONTINUE
      CALL REDLEC(sredle)
      IF (IRE.EQ.0) GOTO 20
*  PASSAGE EN MAJUSCULE SI UN MOT EST LU
      IF (IRE.EQ.3) THEN
        DO 123 IAUX=1, NCAR
          IRAL=INDEX(MINU,MOT(IAUX:IAUX))
          IF (IRAL.NE.0) MOT(IAUX:IAUX)=MAJU(IRAL:IRAL)
 123    CONTINUE
      ENDIF
      IAVA=0
      CALL PRENOM(IPLAMO,IAVA,SREDLE)
      IF (IIMPI.EQ.1754) THEN
        WRITE(IOIMP,654) INOOB1(IPLAMO),INOOB2(IPLAMO)
        WRITE(IOIMP,657) CHAR
      ENDIF
 654  FORMAT(' DANS ACQUER )  ',A8,2X,A8,2X,A4)
 657  FORMAT(' DANS ACQUER  TYPE ATTENDU  ',A8)
C
C  **** DECODAGE DE LA LECTURE ET VERIF DU TYPE
C
      IF (INOOB1(IPLAMO).EQ.IPONON) THEN
        CHAR='NON'
        CALL NOMCHA(CHARB,CHAR)
        GOTO 200
      ENDIF
      IF (CHAR.EQ.'        ') CHAR=INOOB2(IPLAMO)
      IOO=IOUEP2(IPLAMO)
      IF (CHAR.EQ.'FLOTTANT'.AND.INOOB2(IPLAMO).EQ.'ENTIER  ') THEN
        XPO=IOO
        CALL NOMREE(CHARB,XPO)
        GO TO 465
      ENDIF
      IF (CHAR.NE.INOOB2(IPLAMO)) THEN
C- ERREUR : donnee lue pas du TYPE demande
        MOTERR(1:8)=INOOB2(IPLAMO)
        CALL ERREUR(39)
        GOTO 200
      ENDIF
      if (nbesc.ne.0) segact ipiloc
      IF (CHAR.EQ.'ENTIER  ') THEN
        IVAL=IOO
        CALL NOMENT(CHARB,IVAL)
      ELSE IF (CHAR.EQ.'FLOTTANT') THEN
        XPO=XIFLOT(IOO)
        CALL NOMREE(CHARB,XPO)
      ELSE IF (CHAR.EQ.'MOT    ') THEN
        ID=IPCHAR(IOO)
        IFI=IPCHAR(IOO+1)
        IF1=IFI-ID
        IF1=MIN(IF1,NCARMAX)
        CHARMO(1:IF1)=ICHARA(ID:IFI-1)
        CALL NOMCHA(CHARB,CHARMO(1:IF1))
      ELSE IF (CHAR.EQ.'LOGIQUE ')  THEN
        LOGI=IPLOGI(IOO)
        CALL NOMLOG(CHARB,LOGI)
      ELSE
        CALL NOMOBJ(CHAR,CHARB,IOO)
      ENDIF
      if (nbesc.ne.0) SEGDES,IPILOC
 465  CONTINUE
      IPASS=0
      GOTO 1
 
C- ERREUR : Fin du fichier atteinte pendant la lecture d'une donnee
 21   CONTINUE
      CALL ERREUR(4)
      GOTO 200
 
C- FIN de l'acquisition (normale ou avec erreur)
 200  CONTINUE
* On peut avoir SREDLE=0 (option brut par exemple)
      IF (SREDLE.NE.0) SEGSUP,SREDLE
*  srestaurer lmnnom
      LMNNOM=LMNSAU
 
      RETURN
      END