1 : C ACQUER SOURCE GOUNAND 14/02/11 21:15:01 7955 2 : 3 : SUBROUTINE ACQUER(IBRUT) 4 : * SG 5 : * IBRUT est un entier valant 1 si l'option 'BRUT' a été lue et 0 sinon 6 : * Si IBRUT vaut 1, un traitement particulier est effectué dans 7 : * pilot pour ne pas interpréter la ligne lue (comme avec CHAI et MOT) 8 : * 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : 12 : -INC CCNOYAU 13 : -INC CCOPTIO 14 : -INC CCASSIS 15 : -INC CCREDLE 16 : 17 : -INC SMLENTI 18 : -INC SMLREEL 19 : 20 : EXTERNAL LONG 21 : LOGICAL LOGI 22 : REAL*8 XPO 23 : CHARACTER*8 CHAR,CHARB 24 : CHARACTER*26 MINU,MAJU 25 : CHARACTER*4 MOAST(1) 26 : CHARACTER*4 MOBRUT(1) 27 : 28 : C TAILLE D'UN ENREGISTREMENT DU FICHIER IOACQ : NCARMAX CARACTERES 29 : C La taille est limitee a 500 (dimension de TEXT dans SREDLE). 30 : PARAMETER (NCARMAX = 256 , NCARFIN = NCARMAX+1) 31 : * PARAMETER (NCARMAX = 72 , NCARFIN = NCARMAX+1) 32 : C MOT pouvant etre lu dans un enregistrement 33 : CHARACTER*(NCARMAX) CHARMO 34 : C Moins de limitation dans l'option 'BRUT' 35 : CHARACTER*512 CHARM2 36 : 37 : DATA MINU / 'abcdefghijklmnopqrstuvwxyz' / 38 : DATA MAJU / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' / 39 : DATA MOAST / '* ' / 40 : DATA MOBRUT/ 'BRUT' / 41 : C FORMAT DE LECTURE D'UN ENREGISTREMENT DU FICHIER IOACQ 42 : 3000 FORMAT(A256) 43 : *3000 FORMAT(A72) 44 : C FORMAT pour l'option BRUT 45 : 3002 FORMAT(A512) 46 : * 46 : CALL LIRMOT(MOBRUT,1,IBRUT,0) 47 : * Cas : chaine = ACQU 'BRUT' ; 48 : IF (IBRUT.EQ.1) THEN 49 : * Initialise SREDLE a 0 pour garder le traitement d'erreur normal au 50 : * label 21 51 : SREDLE=0 52 : READ(IOACQ,FMT=3002,END=21) CHARM2 53 : LONCHA=LONG(CHARM2) 53 : CALL ECRCHA(CHARM2(1:LONCHA)) 54 : RETURN 55 : ENDIF 56 : * 56 : CALL POSCHA('NON',IPONON) 57 : IF (IERR.NE.0) RETURN 58 : 59 : IPASS=1 60 : 61 : SREDLE=0 61 : CALL INIRED(SREDLE) 62 : IPREC =1 63 : NRAN =0 64 : ICOUR =NCARMAX 65 : IFINAN=NCARFIN 66 : 67 : 1 CONTINUE 67 : CALL QUETYP(CHAR,0,IRETOU) 68 : IF (IRETOU.EQ.0) GOTO 200 69 : C Lecture du NOM Gibiane (CHARB) de l'objet a acquerir 69 : CALL LIROBJ(CHAR,IPO,0,IRETOU) 69 : CALL QUENOM(CHARB) 70 : IF (IIMPI.EQ.1754) THEN 71 : WRITE(IOIMP,FMT='('' TYPE LU : '',A8)') CHAR 72 : WRITE(IOIMP,FMT='('' NOM LU : '',A8)') CHARB 73 : ENDIF 74 : C On veut savoir si l'objet a acquerir doit avoir un TYPE ('*....') 74 : CALL QUETYP(CHAR,0,iretou) 75 : IVAL=0 75 : IF (CHAR.EQ.'MOT ') CALL LIRMOT(MOAST,1,IVAL,0) 76 : IF (IIMPI.EQ.1754) THEN 77 : IF (IVAL.EQ.0) THEN 78 : WRITE(IOIMP,FMT='('' PAS D ASTERISQUE TOUVEE '')') 79 : ELSE 80 : WRITE(IOIMP,FMT='('' ASTERISQUE TOUVEE '')') 81 : ENDIF 82 : ENDIF 83 : C CHAR contient le type demande de l'objet (=' 'si aucun + IVAL=0) 84 : CHAR=' ' 85 : IF (IVAL.NE.0) THEN 86 : C Lecture du TYPE de l'objet a acquerir demande par l'utilisateur 86 : CALL LIRCHA(CHAR,1,IRETOU) 87 : IF (IERR.NE.0) GOTO 200 88 : IF (IIMPI.EQ.1754)WRITE(IOIMP,FMT='('' TYPE ATTENDU '',A8)')CHAR 89 : C 90 : C CAS DES LISTENTI ET DES LISTREEL 91 : C 92 : IF (CHAR.EQ.'LISTENTI'.OR.CHAR.EQ.'LISTREEL') THEN 92 : CALL LIRENT(JG,1,IRETOU) 93 : IF (IERR.NE.0) GOTO 200 94 : IOP = 0 95 : IF (CHAR.EQ.'LISTENTI') THEN 96 : SEGINI MLENTI 97 : IF (IPASS.EQ.0) GOTO 202 98 : SEPARA=.FALSE. 99 : 201 CONTINUE 100 : NRAN=0 101 : ICOUR =NCARMAX 102 : IFINAN=NCARFIN 103 : READ(IOACQ,FMT=3000,END=21) TEXT 104 : 202 CONTINUE 104 : CALL REDLEC(sredle) 105 : IF (IRE.EQ.0) GOTO 201 106 : IOP=IOP+1 107 : IF (IRE.NE.1) THEN 107 : CALL ERREUR(8) 108 : GOTO 200 109 : ENDIF 110 : LECT(IOP)=NFIX 111 : IF (IOP.LT.JG) GOTO 202 112 : SEGDES,MLENTI 112 : CALL NOMOBJ('LISTENTI',CHARB,MLENTI) 113 : C* ELSE IF (CHAR.EQ.'LISTREEL') THEN 114 : ELSE 115 : SEGINI,MLREEL 116 : IF (IPASS.EQ.0) GOTO 302 117 : SEPARA=.FALSE. 118 : 301 CONTINUE 119 : NRAN=0 120 : ICOUR =NCARMAX 121 : IFINAN=NCARFIN 122 : READ(IOACQ,FMT=3000,END=21) TEXT 122 : 302 CALL REDLEC(sredle) 123 : IF (IRE.EQ.0) GOTO 301 124 : IOP=IOP+1 125 : IF (IRE.EQ.1) THEN 126 : PROG(IOP)=NFIX 127 : ELSE IF (IRE.EQ.2) THEN 128 : PROG(IOP)=FLOT 129 : ELSE 129 : CALL ERREUR(15) 130 : GOTO 200 131 : ENDIF 132 : IF (IOP.LT.JG) GOTO 302 133 : SEGDES,MLREEL 133 : CALL NOMOBJ('LISTREEL',CHARB,MLREEL) 134 : ENDIF 135 : IPASS=0 136 : GOTO 1 137 : ENDIF 138 : ENDIF 139 : C 140 : C AUTRES CAS ENTIER FLOTTANT MOT LOGIQUE 141 : C 142 : IF (IPASS.EQ.0) GOTO 25 143 : SEPARA=.FALSE. 144 : 20 CONTINUE 145 : NRAN=0 146 : ICOUR =NCARMAX 147 : IFINAN=NCARFIN 148 : READ(IOACQ,FMT=3000,END=21) TEXT 149 : 25 CONTINUE 149 : CALL REDLEC(sredle) 150 : IF (IRE.EQ.0) GOTO 20 151 : * PASSAGE EN MAJUSCULE SI UN MOT EST LU 152 : IF (IRE.EQ.3) THEN 153 : DO 123 IAUX=1, NCAR 154 : IRAL=INDEX(MINU,MOT(IAUX:IAUX)) 155 : IF (IRAL.NE.0) MOT(IAUX:IAUX)=MAJU(IRAL:IRAL) 156 : 123 CONTINUE 157 : ENDIF 158 : IAVA=0 158 : CALL PRENOM(IPLAMO,IAVA,SREDLE) 159 : IF (IIMPI.EQ.1754) THEN 160 : WRITE(IOIMP,654) INOOB1(IPLAMO),INOOB2(IPLAMO) 161 : WRITE(IOIMP,657) CHAR 162 : ENDIF 163 : 654 FORMAT(' DANS ACQUER ) ',A8,2X,A8,2X,A4) 164 : 657 FORMAT(' DANS ACQUER TYPE ATTENDU ',A8) 165 : C 166 : C **** DECODAGE DE LA LECTURE ET VERIF DU TYPE 167 : C 168 : IF (INOOB1(IPLAMO).EQ.IPONON) THEN 169 : CHAR='NON' 169 : CALL NOMCHA(CHARB,CHAR) 170 : GOTO 200 171 : ENDIF 172 : IF (CHAR.EQ.' ') CHAR=INOOB2(IPLAMO) 173 : IOO=IOUEP2(IPLAMO) 174 : IF (CHAR.EQ.'FLOTTANT'.AND.INOOB2(IPLAMO).EQ.'ENTIER ') THEN 175 : XPO=IOO 175 : CALL NOMREE(CHARB,XPO) 176 : GO TO 465 177 : ENDIF 178 : IF (CHAR.NE.INOOB2(IPLAMO)) THEN 179 : C- ERREUR : donnee lue pas du TYPE demande 180 : MOTERR(1:8)=INOOB2(IPLAMO) 180 : CALL ERREUR(39) 181 : GOTO 200 182 : ENDIF 183 : if (nbesc.ne.0) segact ipiloc 184 : IF (CHAR.EQ.'ENTIER ') THEN 185 : IVAL=IOO 185 : CALL NOMENT(CHARB,IVAL) 186 : ELSE IF (CHAR.EQ.'FLOTTANT') THEN 187 : XPO=XIFLOT(IOO) 187 : CALL NOMREE(CHARB,XPO) 188 : ELSE IF (CHAR.EQ.'MOT ') THEN 189 : ID=IPCHAR(IOO) 190 : IFI=IPCHAR(IOO+1) 191 : IF1=IFI-ID 192 : IF1=MIN(IF1,NCARMAX) 193 : CHARMO(1:IF1)=ICHARA(ID:IFI-1) 193 : CALL NOMCHA(CHARB,CHARMO(1:IF1)) 194 : ELSE IF (CHAR.EQ.'LOGIQUE ') THEN 195 : LOGI=IPLOGI(IOO) 195 : CALL NOMLOG(CHARB,LOGI) 196 : ELSE 196 : CALL NOMOBJ(CHAR,CHARB,IOO) 197 : ENDIF 198 : if (nbesc.ne.0) segdes ipiloc 199 : 465 CONTINUE 200 : IPASS=0 201 : GOTO 1 202 : 203 : C- ERREUR : Fin du fichier atteinte pendant la lecture d'une donnee 204 : 21 CONTINUE 204 : CALL ERREUR(4) 205 : GOTO 200 206 : 207 : C- FIN de l'acquisition (normale ou avec erreur) 208 : 200 CONTINUE 209 : * On peut avoir SREDLE=0 (option brut par exemple) 210 : IF (SREDLE.NE.0) SEGSUP,SREDLE 211 : RETURN 212 : END 213 : 214 : 215 :
© Cast3M 2003 - All rights reserved.
Disclaimer