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