|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 C Jan-2011 P. Marguinaud Thread-safe LFI 00002 SUBROUTINE LFIFER_MT (LFI, KREP, KNUMER, CDSTTC ) 00003 USE LFIMOD, ONLY : LFICOM 00004 USE PARKIND1, ONLY : JPRB 00005 USE YOMHOOK , ONLY : LHOOK, DR_HOOK 00006 C**** 00007 C SOUS-PROGRAMME DE FERMETURE D'UN FICHIER INDEXE AU SENS DU 00008 C LOGICIEL DE FICHIERS INDEXES LFI. 00009 C CETTE FERMETURE EST VITALE SI LE FICHIER A ETE MODIFIE DEPUIS 00010 C LA DERNIERE OUVERTURE, ET EST DE TOUTE MANIERE CHAUDEMENT 00011 C RECOMMANDEE AVANT DE SORTIR DU PROGRAMME UTILISATEUR. 00012 C 00013 C De maniere generale, il vaut mieux fermer une unite logique 00014 C des que l'on n'en a plus besoin, de maniere a ne pas bloquer un 00015 C espace dans les tables qui pourrait faire defaut lors d'une 00016 C ouverture ulterieure, particulierement pour un fichier "multiple" 00017 C qui a besoin d'espace CONTIGU dans les tables des unites logiques. 00018 C Par ailleurs, tout fichier ouvert (au sens FORTRAN du terme cette 00019 C fois) "occupe" generalement un morceau de la memoire du programme. 00020 C** 00021 C ARGUMENTS : KREP (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME; 00022 C KNUMER (ENTREE) ==> LFI%NUMERO DE L'UNITE LOGIQUE; 00023 C CDSTTC (ENTREE) ==> "STATUS" EVENTUEL POUR "CLOSE". 00024 C 00025 C Modifications: 00026 C 00027 C 02/06/97, Jean Clochard. 00028 C 00029 C -Modification des impressions pour que l'annee puisse 00030 C etre imprimee avec 4 chiffres. 00031 C 00032 #ifndef f77 00033 #include "precision.h" 00034 #endif 00035 C 00036 TYPE(LFICOM) :: LFI 00037 CHARACTER CDSTTC*(*), CLSTTC*(LFI%JPLSTX), CLAUXI*3 00038 C 00039 #ifndef f77 00040 INTEGER (KIND=JPDBLE) ITAMPO (LFI%JPLARX) 00041 #else 00042 INTEGER ITAMPO (LFI%JPLARX) 00043 #endif 00044 INTEGER KREP, KNUMER, IEXPLO (LFI%JPNPIA+LFI%JPNPIS) 00045 INTEGER ILSTTU, IREPX, INAPHY, IRANG, IREP, ILSTTC, IREC, INPPIM 00046 INTEGER IFACTM, ILARPH, INALPP, INBALO, INTPPI, INTRLZ, IDECAL, J 00047 INTEGER IPOTZC, IRGPFC, IRGPMC, ILFORC, INPILE, INIMES, IPOTZS, JJ 00048 INTEGER IRGPFS, IPOTZE, IRGPMS, INTCON, IPOSFE, JNPAGE, IRGPFE, JR 00049 INTEGER IRGPME, IRANGM, IDECDB, INBARE, IRGPC2, IRGPS2, IDECDC 00050 INTEGER INBARC, IDECDS, INBARS, INBART, INTPPN, ILOMIN, ILOMAX 00051 INTEGER IRPIFN, INPIME, IDEBEX, IRGPIM, IRGPIF, INLNOM, IDEBUT 00052 INTEGER ILONGA, INALDO, IPOSNU, IRANIE, IRETIN, IAUXIL 00053 C 00054 LOGICAL LLSTTU, LLVERF, LLVERG, LLECRD, LLIMST 00055 C 00056 #include "lficom2.h" 00057 #include "lficom_mt.h" 00058 C** 00059 C 1. - CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS. 00060 C----------------------------------------------------------------------- 00061 C 00062 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00063 IF (LHOOK) CALL DR_HOOK('LFIFER_MT',0,ZHOOK_HANDLE) 00064 IF (LFI%LMISOP) WRITE (UNIT=LFI%NULOUT,FMT=*)'DEBUT LFIFER' 00065 CLNSPR='LFIFER' 00066 ILSTTU=MIN0 (LEN (CLSTTC), LEN (CDSTTC)) 00067 CLSTTC=CDSTTC(:ILSTTU) 00068 IREPX=0 00069 INAPHY=0 00070 LLVERF=.FALSE. 00071 LLVERG=.FALSE. 00072 CALL LFINUM_MT (LFI, KNUMER,IRANG) 00073 C 00074 IF (IRANG.EQ.0) THEN 00075 IREP=-1 00076 GOTO 1001 00077 ENDIF 00078 C 00079 IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'ON') 00080 LLVERF=LFI%LMULTI 00081 C 00082 IF (CDSTTC.EQ.'KEEP'.AND.LFI%CSTAOP(IRANG).EQ.'SCRATCH') THEN 00083 IREP=-19 00084 LLFATA=LLMOER (IREP,IRANG) 00085 C 00086 IF (LLFATA) THEN 00087 GOTO 1001 00088 ELSE 00089 C 00090 C SI L'ERREUR (-19) N'EST PAS FATALE, ON FERME L'UNITE LOGIQUE, 00091 C MAIS SANS PRECISER DE DIRECTIVE "STATUS" DANS LE "CLOSE". 00092 C 00093 LLSTTU=.FALSE. 00094 GOTO 105 00095 ENDIF 00096 C 00097 ELSE 00098 LLSTTU=CDSTTC.EQ.'KEEP'.OR.CDSTTC.EQ.'DELETE' 00099 C 00100 IF (LLSTTU) THEN 00101 ILSTTC=INDEX (CDSTTC,' ')-1 00102 IF (ILSTTC.GT.0) ILSTTU=ILSTTC 00103 CLSTTC=CDSTTC(:ILSTTU) 00104 ELSE 00105 CLSTTC=LFI%CHINCO(:ILSTTU) 00106 ENDIF 00107 C 00108 ENDIF 00109 C 00110 IREP=0 00111 C 00112 105 CONTINUE 00113 IREPX=IREP 00114 INPPIM=LFI%NPPIMM(IRANG) 00115 IFACTM=LFI%MFACTM(IRANG) 00116 ILARPH=LFI%JPLARD*IFACTM 00117 INALPP=LFI%JPNAPP*IFACTM 00118 INBALO=LFI%MDES1D(IXM(LFI%JPNALO,IRANG)) 00119 INTPPI=(INBALO-1+INALPP)/INALPP 00120 C** 00121 C 2. - TRAITEMENT D'EVENTUELS "TROUS" D'INDEX DE LONGUEUR ZERO. 00122 C CES "PARASITES" PEUVENT AVOIR ETE CREES PAR LE RECYCLAGE 00123 C DE TROUS DANS LE FICHIER; ON VA LES SUPPRIMER. 00124 C 00125 C L'ALGORITHME CHOISI N'EST PEUT-ETRE PAS LE PLUS EFFICACE; 00126 C MAIS A PARTIR DU MOMENT OU LA PROBABILITE DE GENERER DES TROUS 00127 C DE LONGUEUR NULLE EST FAIBLE, ET OU ON NE LES RETASSE 00128 C QU'A LA FERMETURE, IL N'Y A PAS LIEU DE RAFFINER A OUTRANCE ! 00129 C----------------------------------------------------------------------- 00130 C 00131 INTRLZ=LFI%NTRULZ(IRANG) 00132 IF (INTRLZ.EQ.0) GOTO 300 00133 C 00134 IDECAL=0 00135 IPOTZC=LFI%NRFPTZ(IRANG) 00136 IRGPFC=1+(IPOTZC-1)/INALPP 00137 C* 00138 C 2.1 - MISE EN MEMOIRE DE LA PREMIERE P.A.I. AYANT UN TEL TROU. 00139 C----------------------------------------------------------------------- 00140 C 00141 DO 211 J=1,INPPIM 00142 IRGPMC=LFI%MRGPIM(J,IRANG) 00143 C 00144 IF (LFI%MRGPIF(IRGPMC).EQ.IRGPFC) THEN 00145 C 00146 IF (.NOT.LFI%LPHASP(IRGPMC)) THEN 00147 C 00148 CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPMC,IRETIN) 00149 C 00150 IF (IRETIN.EQ.1) THEN 00151 GOTO 903 00152 ELSEIF (IRETIN.EQ.2) THEN 00153 GOTO 904 00154 ELSEIF (IRETIN.NE.0) THEN 00155 GOTO 1001 00156 ENDIF 00157 C 00158 ENDIF 00159 C 00160 GOTO 220 00161 C 00162 ENDIF 00163 C 00164 211 CONTINUE 00165 C 00166 ILFORC=IRGPFC+1 00167 INPILE=2 00168 CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPMC,IRGPFC, 00169 S ILFORC,INPILE,IRETIN) 00170 C 00171 IF (IRETIN.EQ.1) THEN 00172 GOTO 903 00173 ELSEIF (IRETIN.EQ.2) THEN 00174 GOTO 904 00175 ELSEIF (IRETIN.NE.0) THEN 00176 GOTO 1001 00177 ENDIF 00178 C 00179 INPPIM=MAX0 (INPPIM,IRANGM) 00180 C 00181 220 CONTINUE 00182 C* 00183 C 2.2 - AMORCAGE DE LA RECHERCHE DU NOMBRE DE TROUS NULS CONSECUTIFS 00184 C ET DE L'EVENTUEL TROU NUL "SUIVANT" CE PAQUET. 00185 C----------------------------------------------------------------------- 00186 C 00187 IPOTZS=IPOTZC+IDECAL 00188 IRGPFS=1+(IPOTZS-1)/INALPP 00189 IPOTZE=IPOTZS 00190 IRGPMS=0 00191 C 00192 C ON ELIMINE LES CAS "TRIVIAUX" 00193 C 00194 IF (INTRLZ.EQ.1.OR.IPOTZE+INTRLZ.GT.INBALO) THEN 00195 INTCON=INTRLZ 00196 IPOSFE=INBALO 00197 GOTO 250 00198 ENDIF 00199 C* 00200 C 2.3 - DECOMPTE DU NOMBRE DE TROUS NULS CONSECUTIFS. 00201 C----------------------------------------------------------------------- 00202 C 00203 DO 235 JNPAGE=IRGPFS,INTPPI 00204 IRGPFE=JNPAGE 00205 C 00206 DO 231 J=1,INPPIM 00207 IRGPME=LFI%MRGPIM(J,IRANG) 00208 C 00209 IF (LFI%MRGPIF(IRGPME).EQ.IRGPFE) THEN 00210 C 00211 IF (.NOT.LFI%LPHASP(IRGPME)) THEN 00212 C 00213 CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPME,IRETIN) 00214 C 00215 IF (IRETIN.EQ.1) THEN 00216 GOTO 903 00217 ELSEIF (IRETIN.EQ.2) THEN 00218 GOTO 904 00219 ELSEIF (IRETIN.NE.0) THEN 00220 GOTO 1001 00221 ENDIF 00222 C 00223 ENDIF 00224 C 00225 GOTO 233 00226 C 00227 ENDIF 00228 C 00229 231 CONTINUE 00230 C 00231 INPILE=2 00232 CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPME, 00233 S IRGPFE,IRGPFC,INPILE,IRETIN) 00234 C 00235 IF (IRETIN.EQ.1) THEN 00236 GOTO 903 00237 ELSEIF (IRETIN.EQ.2) THEN 00238 GOTO 904 00239 ELSEIF (IRETIN.NE.0) THEN 00240 GOTO 1001 00241 ENDIF 00242 C 00243 INPPIM=MAX0 (INPPIM,IRANGM) 00244 C 00245 233 CONTINUE 00246 IF (IRGPMS.EQ.0) IRGPMS=IRGPME 00247 IDECDB=IPOTZE-1-(IRGPFE-1)*INALPP 00248 INBARE=MIN0 (INBALO,IRGPFE*INALPP)-IPOTZE+1 00249 INTCON=0 00250 C 00251 DO 234 J=1,INBARE 00252 C 00253 IF (LFI%MLGPOS(IXM(2*(J+IDECDB)-1,IRGPME)).NE.0) THEN 00254 INTCON=INTCON+J-1 00255 GOTO 240 00256 ENDIF 00257 C 00258 234 CONTINUE 00259 C 00260 INTCON=INTCON+INBARE 00261 IPOTZE=IPOTZE+INBARE 00262 235 CONTINUE 00263 C* 00264 C 2.4 - RECHERCHE DU PROCHAIN TROU NUL, APRES LE PAQUET TROUVE. 00265 C----------------------------------------------------------------------- 00266 C 00267 240 CONTINUE 00268 IPOTZE=IPOTZE+INTCON 00269 C 00270 C D'ABORD, ELIMINATION DES CAS "TRIVIAUX" 00271 C 00272 IF (INTCON.EQ.INTRLZ) THEN 00273 C 00274 C ON A TROUVE TOUS LES TROUS NULS RESTANT. 00275 C 00276 IPOSFE=INBALO 00277 ELSEIF (INTCON.EQ.(INTRLZ-1)) THEN 00278 C 00279 C PLUS QU'UN SEUL TROU NUL... CE SERA DONC CELUI DE RANG MAXIMUM. 00280 C 00281 IPOSFE=LFI%NRFDTZ(IRANG)-1 00282 ELSE 00283 C 00284 C CAS GENERAL. 00285 C 00286 DO 245 JNPAGE=IRGPFE,INTPPI 00287 C 00288 IF (JNPAGE.NE.IRGPFE) THEN 00289 C 00290 DO 241 J=1,INPPIM 00291 IRGPME=LFI%MRGPIM(J,IRANG) 00292 C 00293 IF (LFI%MRGPIF(IRGPME).EQ.JNPAGE) THEN 00294 C 00295 IF (.NOT.LFI%LPHASP(IRGPME)) THEN 00296 C 00297 CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPME,IRETIN) 00298 C 00299 IF (IRETIN.EQ.1) THEN 00300 GOTO 903 00301 ELSEIF (IRETIN.EQ.2) THEN 00302 GOTO 904 00303 ELSEIF (IRETIN.NE.0) THEN 00304 GOTO 1001 00305 ENDIF 00306 C 00307 ENDIF 00308 C 00309 GOTO 243 00310 C 00311 ENDIF 00312 C 00313 241 CONTINUE 00314 C 00315 INPILE=2 00316 CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPME,JNPAGE, 00317 S IRGPFC,INPILE,IRETIN) 00318 C 00319 IF (IRETIN.EQ.1) THEN 00320 GOTO 903 00321 ELSEIF (IRETIN.EQ.2) THEN 00322 GOTO 904 00323 ELSEIF (IRETIN.NE.0) THEN 00324 GOTO 1001 00325 ENDIF 00326 C 00327 INPPIM=MAX0 (INPPIM,IRANGM) 00328 ENDIF 00329 C 00330 243 CONTINUE 00331 IDECDB=IPOTZE-1-(JNPAGE-1)*INALPP 00332 INBARE=MIN0 (INBALO,JNPAGE*INALPP)-IPOTZE+1 00333 C 00334 DO 244 J=1,INBARE 00335 C 00336 IF (LFI%MLGPOS(IXM(2*(J+IDECDB)-1,IRGPME)).EQ.0) THEN 00337 IPOSFE=(JNPAGE-1)*INALPP+J-1 00338 GOTO 250 00339 ENDIF 00340 C 00341 244 CONTINUE 00342 C 00343 245 CONTINUE 00344 C 00345 ENDIF 00346 C 00347 250 CONTINUE 00348 C* 00349 C 2.5 - RETASSAGE "A GAUCHE" D'UNE PARTIE DE L'INDEX. 00350 C----------------------------------------------------------------------- 00351 C 00352 IDECAL=IDECAL+INTCON 00353 C 00354 251 CONTINUE 00355 IPOTZS=IPOTZC+IDECAL 00356 IRGPC2=1+(IPOTZC-1)/INALPP 00357 IRGPS2=1+(IPOTZS-1)/INALPP 00358 C 00359 IF (IRGPC2.NE.IRGPFC) THEN 00360 IRGPFC=IRGPC2 00361 C 00362 DO 252 J=2,INPPIM 00363 IRGPMC=LFI%MRGPIM(J,IRANG) 00364 C 00365 IF (LFI%MRGPIF(IRGPMC).EQ.IRGPFC) THEN 00366 C 00367 IF (.NOT.LFI%LPHASP(IRGPMC)) THEN 00368 C 00369 CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPMC,IRETIN) 00370 C 00371 IF (IRETIN.EQ.1) THEN 00372 GOTO 903 00373 ELSEIF (IRETIN.EQ.2) THEN 00374 GOTO 904 00375 ELSEIF (IRETIN.NE.0) THEN 00376 GOTO 1001 00377 ENDIF 00378 C 00379 ENDIF 00380 C 00381 GOTO 254 00382 C 00383 ENDIF 00384 C 00385 252 CONTINUE 00386 C 00387 INPILE=2 00388 CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPMC,IRGPFC, 00389 S IRGPS2,INPILE,IRETIN) 00390 C 00391 IF (IRETIN.EQ.1) THEN 00392 GOTO 903 00393 ELSEIF (IRETIN.EQ.2) THEN 00394 GOTO 904 00395 ELSEIF (IRETIN.NE.0) THEN 00396 GOTO 1001 00397 ENDIF 00398 C 00399 INPPIM=MAX0 (INPPIM,IRANGM) 00400 ENDIF 00401 C 00402 254 CONTINUE 00403 C 00404 IF (IRGPS2.NE.IRGPFS) THEN 00405 IRGPFS=IRGPS2 00406 C 00407 DO 255 J=2,INPPIM 00408 IRGPMS=LFI%MRGPIM(J,IRANG) 00409 C 00410 IF (LFI%MRGPIF(IRGPMS).EQ.IRGPFS) THEN 00411 C 00412 IF (.NOT.LFI%LPHASP(IRGPMS)) THEN 00413 C 00414 CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPMS,IRETIN) 00415 C 00416 IF (IRETIN.EQ.1) THEN 00417 GOTO 903 00418 ELSEIF (IRETIN.EQ.2) THEN 00419 GOTO 904 00420 ELSEIF (IRETIN.NE.0) THEN 00421 GOTO 1001 00422 ENDIF 00423 C 00424 ENDIF 00425 C 00426 GOTO 257 00427 C 00428 ENDIF 00429 C 00430 255 CONTINUE 00431 C 00432 INPILE=2 00433 CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPMS,IRGPFS, 00434 S IRGPFC,INPILE,IRETIN) 00435 C 00436 IF (IRETIN.EQ.1) THEN 00437 GOTO 903 00438 ELSEIF (IRETIN.EQ.2) THEN 00439 GOTO 904 00440 ELSEIF (IRETIN.NE.0) THEN 00441 GOTO 1001 00442 ENDIF 00443 C 00444 INPPIM=MAX0 (INPPIM,IRANGM) 00445 ENDIF 00446 C 00447 257 CONTINUE 00448 IDECDC=IPOTZC-1+(IRGPFC-1)/INALPP 00449 INBARC=MIN0 (INBALO-IDECAL,IRGPFC*INALPP)-IPOTZC+1 00450 IDECDS=IPOTZS-1+(IRGPFS-1)/INALPP 00451 INBARS=MIN0 (INBALO,IRGPFS*INALPP)-IPOTZS+1 00452 INBART=MIN0 (INBARC,INBARS) 00453 C 00454 DO 258 J=1,INBART 00455 LFI%CNOMAR(IXC(IDECDC+J,IRGPMC))=LFI%CNOMAR(IXC(IDECDS+J,IRGPMS)) 00456 258 CONTINUE 00457 C 00458 DO 259 J=1,2*INBART 00459 LFI%MLGPOS(IXM(2*IDECDC+J,IRGPMC))= 00460 S LFI%MLGPOS(IXM(2*IDECDS+J,IRGPMS)) 00461 259 CONTINUE 00462 C 00463 IPOTZC=IPOTZC+INBART 00464 C 00465 IF (IPOTZS+INBART.LT.IPOSFE) THEN 00466 GOTO 251 00467 ELSEIF (IPOSFE.LT.INBALO) THEN 00468 GOTO 220 00469 ENDIF 00470 C* 00471 C 2.6 - MISE A JOUR DE CERTAINES TABLES. 00472 C----------------------------------------------------------------------- 00473 C 00474 LFI%NBTROU(IRANG)=LFI%NBTROU(IRANG)-IDECAL 00475 INBALO=INBALO-IDECAL 00476 LFI%MDES1D(IXM(LFI%JPNALO,IRANG))=INBALO 00477 INTPPN=(INBALO-1+INALPP)/INALPP 00478 LFI%NALDPI(IRANG)=INBALO-(INTPPN-1)*INALPP 00479 C 00480 IF (INTPPN.NE.INTPPI) THEN 00481 C 00482 C ON A DONC LAISSE DES P.P.I. "PARASITES" EN MEMOIRE. 00483 C A PRIORI CE N'EST PAS GENANT, CAR ON VA BIENTOT RELACHER 00484 C TOUTES CELLES RELATIVES AU FICHIER QUE L'ON TRAITE. 00485 C NEANMOINS IL EST PREFERABLE DE REDEFINIR LE RANG EN MEMOIRE 00486 C DE LA DERNIERE P.P.I. DU FICHIER. 00487 C 00488 LFI%NPODPI(IRANG)=IRGPMC 00489 INTPPI=INTPPN 00490 ENDIF 00491 C 00492 300 CONTINUE 00493 C** 00494 C 3. - CAS OU IL FAUT RECALCULER LES LONGUEURS EXTREMES DES 00495 C ARTICLES DE DONNEES. 00496 C----------------------------------------------------------------------- 00497 C 00498 IF (.NOT.LFI%LMIMAL(IRANG)) GOTO 400 00499 C* 00500 C 3.1 - EXPLORATION DES P.P.I., PUIS EVENTUELLEMENT DES P.A.I. . 00501 C----------------------------------------------------------------------- 00502 C 00503 ILOMIN=0 00504 ILOMAX=0 00505 IRPIFN=1 00506 INPIME=0 00507 C 00508 IF (LFI%NPODPI(IRANG).EQ.2) THEN 00509 IDEBEX=3 00510 ELSE 00511 IDEBEX=2 00512 ENDIF 00513 C 00514 DO 317 JNPAGE=1,INTPPI 00515 C 00516 IF (JNPAGE.LE.INPPIM) THEN 00517 C 00518 C IL S'AGIT D'UNE EXPLORATION EN MEMOIRE ( PAGES D'INDEX ). 00519 C 00520 IRGPIM=LFI%MRGPIM(JNPAGE,IRANG) 00521 IRGPIF=LFI%MRGPIF(IRGPIM) 00522 INPIME=INPIME+1 00523 IEXPLO(INPIME)=IRGPIF 00524 IF (IRGPIF.EQ.(IRPIFN+1)) IRPIFN=IRGPIF 00525 C 00526 IF (.NOT.LFI%LPHASP(IRGPIM)) THEN 00527 C 00528 CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPIM,IRETIN) 00529 C 00530 IF (IRETIN.EQ.1) THEN 00531 GOTO 903 00532 ELSEIF (IRETIN.EQ.2) THEN 00533 GOTO 904 00534 ELSEIF (IRETIN.NE.0) THEN 00535 GOTO 1001 00536 ENDIF 00537 C 00538 ENDIF 00539 C 00540 ELSE 00541 C 00542 C IL S'AGIT D'UNE EXPLORATION "HORS MEMOIRE"; 00543 C ON CHERCHE LA PROCHAINE P.A.I. NON EXPLOREE . 00544 C 00545 IF (JNPAGE.EQ.INPPIM+1) IRGPIF=IRPIFN 00546 C 00547 311 CONTINUE 00548 IRGPIF=IRGPIF+1 00549 C 00550 DO 312 J=IDEBEX,INPIME 00551 IF (IEXPLO(J).EQ.IRGPIF) GOTO 311 00552 312 CONTINUE 00553 C 00554 ILFORC=1 00555 INPILE=2 00556 CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPIM,IRGPIF, 00557 S ILFORC,INPILE,IRETIN) 00558 C 00559 IF (IRETIN.EQ.1) THEN 00560 GOTO 903 00561 ELSEIF (IRETIN.EQ.2) THEN 00562 GOTO 904 00563 ELSEIF (IRETIN.NE.0) THEN 00564 GOTO 1001 00565 ENDIF 00566 C 00567 ENDIF 00568 C 00569 INBART=MIN0 (INALPP,INBALO-(IRGPIF-1)*INALPP) 00570 C 00571 IF (ILOMIN.EQ.0) THEN 00572 C 00573 DO 314 J=1,INBART 00574 C 00575 IF (LFI%CNOMAR(IXC(J,IRGPIM)).NE.' ') THEN 00576 ILOMIN=LFI%MLGPOS(IXM(2*J-1,IRGPIM)) 00577 ILOMAX=ILOMIN 00578 IDEBUT=J+1 00579 GOTO 315 00580 ENDIF 00581 C 00582 314 CONTINUE 00583 C 00584 GOTO 317 00585 ELSE 00586 IDEBUT=1 00587 ENDIF 00588 C 00589 315 CONTINUE 00590 C 00591 DO 316 J=IDEBUT,INBART 00592 C 00593 IF (LFI%CNOMAR(IXC(J,IRGPIM)).NE.' ') THEN 00594 ILONGA=LFI%MLGPOS(IXM(2*J-1,IRGPIM)) 00595 ILOMIN=MIN0 (ILONGA,ILOMIN) 00596 ILOMAX=MAX0 (ILONGA,ILOMAX) 00597 ENDIF 00598 C 00599 316 CONTINUE 00600 C 00601 317 CONTINUE 00602 C* 00603 C 3.2 - MISE A JOUR DES TABLES CONCERNEES. 00604 C----------------------------------------------------------------------- 00605 C 00606 LFI%MDES1D(IXM(LFI%JPLNAL,IRANG))=ILOMIN 00607 LFI%MDES1D(IXM(LFI%JPLXAL,IRANG))=ILOMAX 00608 C 00609 400 CONTINUE 00610 C** 00611 C 4. - "VIDAGE" SUR FICHIER DES PAGES RESTANT A ECRIRE. 00612 C----------------------------------------------------------------------- 00613 C* 00614 C 4.1 - PAGES DE *DONNEES* RESTANT A ECRIRE. 00615 C----------------------------------------------------------------------- 00616 C 00617 DO 411 J=0,LFI%JPNPDF-1 00618 C 00619 IF (LFI%LECRPD(J,IRANG)) THEN 00620 C 00621 CALL LFIVID_MT (LFI, IREP,IRANG,J,ITAMPO(1),IRETIN) 00622 C 00623 IF (IRETIN.EQ.1) THEN 00624 GOTO 903 00625 ELSEIF (IRETIN.EQ.2) THEN 00626 GOTO 904 00627 ELSEIF (IRETIN.NE.0) THEN 00628 GOTO 1001 00629 ENDIF 00630 C 00631 ENDIF 00632 C 00633 411 CONTINUE 00634 C* 00635 C 4.2 - (PAIRES DE) PAGES D'*INDEX* RESTANT A ECRIRE. 00636 C----------------------------------------------------------------------- 00637 C 00638 INPPIM=LFI%NPPIMM(IRANG) 00639 C 00640 DO 423 J=1,INPPIM 00641 IRGPIM=LFI%MRGPIM(J,IRANG) 00642 IRGPIF=LFI%MRGPIF(IRGPIM) 00643 CALL LFIREC_MT (LFI, IRGPIF,IRANG,IREC) 00644 C 00645 IF (LFI%LECRPI(IRGPIM,1)) THEN 00646 C 00647 IF (J.EQ.LFI%NPODPI(IRANG).AND.LFI%NALDPI(IRANG).NE.INALPP) THEN 00648 C 00649 C COMPLEMENT DE LA DERNIERE PAGE D'INDEX NOMS AVEC UN NOM 00650 C CONVENTIONNEL. 00651 C 00652 DO 421 JJ=LFI%NALDPI(IRANG)+1,LFI%JPNXNA*IFACTM 00653 LFI%CNOMAR(IXC(JJ,IRGPIM))='**FIN D''INDEX**' 00654 421 CONTINUE 00655 C 00656 ENDIF 00657 C 00658 INAPHY=IREC 00659 CALL LFIECC_MT (LFI, IREP,KNUMER,IREC,LFI%CNOMAR(IXC(1,IRGPIM)), 00660 S LFI%NBWRIT(IRANG),IFACTM,IRETIN) 00661 C 00662 IF (IRETIN.EQ.1) THEN 00663 GOTO 903 00664 ELSEIF (IRETIN.NE.0) THEN 00665 GOTO 1001 00666 ENDIF 00667 C 00668 LFI%LECRPI(IRGPIM,1)=.FALSE. 00669 ENDIF 00670 C 00671 IF (LFI%LECRPI(IRGPIM,2).AND.LFI%LPHASP(IRGPIM)) THEN 00672 C 00673 IF (J.EQ.LFI%NPODPI(IRANG).AND.LFI%NALDPI(IRANG).NE.INALPP) THEN 00674 C 00675 C COMPLEMENT DE LA DERNIERE PAGE D'INDEX LONGUEUR/POSITION 00676 C AVEC DES ZEROS. 00677 C 00678 DO 422 JJ=2*LFI%NALDPI(IRANG)+1,ILARPH 00679 LFI%MLGPOS(IXM(JJ,IRGPIM))=0 00680 422 CONTINUE 00681 C 00682 ENDIF 00683 C 00684 INAPHY=IREC+1 00685 CALL LFIEDO_MT (LFI, IREP,KNUMER,IREC+1, 00686 S LFI%MLGPOS(IXM(1,IRGPIM)), 00687 S LFI%NBWRIT(IRANG),IFACTM,IRETIN) 00688 C 00689 IF (IRETIN.EQ.1) THEN 00690 GOTO 903 00691 ELSEIF (IRETIN.NE.0) THEN 00692 GOTO 1001 00693 ENDIF 00694 C 00695 LFI%LECRPI(IRGPIM,2)=.FALSE. 00696 ENDIF 00697 C 00698 423 CONTINUE 00699 C* 00700 C 4.3 - CAS DE L'ARTICLE DOCUMENTAIRE, SI NECESSAIRE. 00701 C----------------------------------------------------------------------- 00702 C 00703 LLECRD=LFI%LMODIF(IRANG).OR.LFI%NBWRIT(IRANG).NE.0 00704 C 00705 IF (LLECRD) THEN 00706 C 00707 C AU PREALABLE, MISE A JOUR DE CET ARTICLE DOCUMENTAIRE. 00708 C 00709 IAUXIL=IXM(LFI%JPNRES,IRANG) 00710 LFI%MDES1D(IAUXIL)=LFI%MDES1D(IAUXIL)+LFI%NREESP(IRANG) 00711 IAUXIL=IXM(LFI%JPNREC,IRANG) 00712 LFI%MDES1D(IAUXIL)=LFI%MDES1D(IAUXIL)+LFI%NREECO(IRANG) 00713 IAUXIL=IXM(LFI%JPNREL,IRANG) 00714 LFI%MDES1D(IAUXIL)=LFI%MDES1D(IAUXIL)+LFI%NREELO(IRANG) 00715 IAUXIL=IXM(LFI%JPNTRU,IRANG) 00716 LFI%MDES1D(IAUXIL)=LFI%MDES1D(IAUXIL)+LFI%NBTROU(IRANG) 00717 CALL LFIDAH_MT (LFI, LFI%MDES1D(IXM(LFI%JPDDMG,IRANG)), 00718 S LFI%MDES1D(IXM(LFI%JPHDMG,IRANG))) 00719 IREC=1 00720 INAPHY=IREC 00721 CALL LFIEDO_MT (LFI, IREP,KNUMER,IREC,LFI%MDES1D(IXM(1,IRANG)), 00722 S LFI%NBWRIT(IRANG),IFACTM,IRETIN) 00723 C 00724 IF (IRETIN.EQ.1) THEN 00725 GOTO 903 00726 ELSEIF (IRETIN.NE.0) THEN 00727 GOTO 1001 00728 ENDIF 00729 C 00730 ENDIF 00731 C** 00732 C 5. - FERMETURE EFFECTIVE (*CLOSE*) DU FICHIER. 00733 C----------------------------------------------------------------------- 00734 C 00735 INALDO=INBALO-LFI%MDES1D(IXM(LFI%JPNTRU,IRANG)) 00736 INAPHY=0 00737 C 00738 IF (LLSTTU) THEN 00739 CLOSE (UNIT=KNUMER,STATUS=CLSTTC,ERR=905,IOSTAT=IREP) 00740 ELSE 00741 C 00742 IF (INALDO.EQ.0) THEN 00743 C 00744 C SI ON SE RETROUVE AVEC UN FICHIER "VIDE" ET QUE L'ON N'A PAS DE 00745 C PARAMETRE "STATUS" POUR LE "CLOSE", ON VA ESSAYER DE RELACHER LE 00746 C FICHIER, AFIN DE NE PAS LAISSER TRAINER UN TEL FICHIER "ZOMBIE". 00747 C ( "VIDE" = SANS ARTICLE LOGIQUE DE DONNEES ) 00748 C ON N'A PAS DE GARANTIE D'Y ARRIVER, DANS LA MESURE OU ON N'EST 00749 C PAS SUR D'AVOIR DES DROITS D'ACCES SUFFISANTS. 00750 C 00751 CLOSE (UNIT=KNUMER,STATUS='DELETE',ERR=511) 00752 CLSTTC='DELETE' 00753 LLSTTU=.TRUE. 00754 GOTO 600 00755 ENDIF 00756 C 00757 511 CONTINUE 00758 C 00759 CLOSE (UNIT=KNUMER,ERR=905,IOSTAT=IREP) 00760 C 00761 ENDIF 00762 C 00763 600 CONTINUE 00764 C** 00765 C 6. - IMPRESSION EVENTUELLE DE STATISTIQUES D'UTILISATION. 00766 C----------------------------------------------------------------------- 00767 C 00768 LFI%NDEROP(IRANG)=9 00769 LFI%NDERCO(IRANG)=IREP 00770 LLIMST=LFI%NISTAG.EQ.2.OR.(LFI%NISTAG.EQ.1.AND.LFI%LISTAT(IRANG)) 00771 IF (LLIMST) CALL LFIIST_MT (LFI, IRANG,.TRUE.) 00772 C** 00773 C 7. - "NETTOYAGE" DES TABLES AYANT PERMIS DE GERER LE FICHIER. 00774 C ( AU MOINS CELLES AYANT UN CARACTERE "GLOBAL"; A NOTER 00775 C TOUTEFOIS QU'ON NE TOUCHE PAS AUX CARACTERISTIQUES DES 00776 C PAGES D'INDEX PREAFFECTEES ) 00777 C----------------------------------------------------------------------- 00778 C 00779 IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERGLA,'ON') 00780 LLVERG=LFI%LMULTI 00781 C 00782 DO 702 J=2,MIN0 (INPPIM,LFI%JPNPIA) 00783 IRGPIM=LFI%MRGPIM(J,IRANG) 00784 C 00785 DO 701 JR=IRGPIM,IRGPIM+IFACTM-1 00786 LFI%MRGPIF(JR)=LFI%JPNIL 00787 701 CONTINUE 00788 C 00789 702 CONTINUE 00790 C 00791 DO 704 J=LFI%JPNPIA+1,INPPIM 00792 IRGPIM=LFI%MRGPIM(J,IRANG) 00793 C 00794 DO 703 JR=IRGPIM,IRGPIM+IFACTM-1 00795 LFI%MCOPIF(JR)=LFI%JPNIL 00796 LFI%MRGPIF(JR)=LFI%JPNIL 00797 703 CONTINUE 00798 C 00799 704 CONTINUE 00800 C 00801 LFI%NPISAF=LFI%NPISAF-MAX0 (0,(INPPIM-LFI%JPNPIA)*IFACTM) 00802 C 00803 DO 705 JR=IRANG,IRANG+IFACTM-1 00804 LFI%NUMERO(JR)=LFI%JPNIL 00805 705 CONTINUE 00806 C 00807 DO 706 J=1,LFI%NBFIOU 00808 C 00809 IF (LFI%NUMIND(J).EQ.IRANG) THEN 00810 IPOSNU=J 00811 GOTO 707 00812 ENDIF 00813 C 00814 706 CONTINUE 00815 C 00816 IREP=-16 00817 GOTO 1001 00818 C 00819 707 CONTINUE 00820 C 00821 LFI%NBFIOU=LFI%NBFIOU-1 00822 LFI%NFACTM=LFI%NFACTM-IFACTM 00823 C 00824 DO 708 J=IPOSNU,LFI%NBFIOU 00825 LFI%NUMIND(J)=LFI%NUMIND(J+1) 00826 708 CONTINUE 00827 C* 00828 C 7.1 - ASPECTS SPECIFIQUES AUX TABLES D'IMPORT/EXPORT. 00829 C----------------------------------------------------------------------- 00830 C 00831 IF (LFI%NEXPOR(IRANG).GT.0.OR.LFI%NIMPOR(IRANG).GT.0) THEN 00832 IRANIE=MAX0 (LFI%NEXPOR(IRANG),LFI%NIMPOR(IRANG)) 00833 INIMES=IXNIMS (IRANG) 00834 C 00835 IF (INIMES.GE.1) THEN 00836 WRITE (UNIT=CLMESS,FMT='(''KNUMER=' 00837 ',I3, S '', ATTENTION: IMPORT/EXPORT NON TERMINE'')') KNUMER 00838 CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,.FALSE., 00839 S CLMESS,CLNSPR,CLACTI) 00840 ENDIF 00841 C 00842 DO 711 J=1,LFI%NUIMEX 00843 C 00844 IF (LFI%NINIEX(J).EQ.IRANIE) THEN 00845 IPOSNU=J 00846 GOTO 712 00847 ENDIF 00848 C 00849 711 CONTINUE 00850 C 00851 IREP=-16 00852 GOTO 1001 00853 C 00854 712 CONTINUE 00855 C 00856 LFI%MNUIEX(IRANG)=LFI%JPNIL 00857 LFI%NUIMEX=LFI%NUIMEX-1 00858 C 00859 DO 713 J=IPOSNU,LFI%NUIMEX 00860 LFI%NINIEX(J)=LFI%NINIEX(J+1) 00861 713 CONTINUE 00862 C 00863 ENDIF 00864 C 00865 IF (LFI%LMULTI) THEN 00866 CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'OFF') 00867 CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'REL') 00868 ENDIF 00869 C 00870 LLVERF=.FALSE. 00871 IREP=IREPX 00872 GOTO 1001 00873 C** 00874 C 9. - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S. 00875 C----------------------------------------------------------------------- 00876 C 00877 903 CONTINUE 00878 CLACTI='WRITE' 00879 GOTO 909 00880 C 00881 904 CONTINUE 00882 CLACTI='READ' 00883 GOTO 909 00884 C 00885 905 CONTINUE 00886 CLACTI='CLOSE' 00887 C 00888 909 CONTINUE 00889 IF (INAPHY.NE.0) LFI%NUMAPH(IRANG)=INAPHY 00890 C 00891 C AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF. 00892 C 00893 IREP=IABS (IREP) 00894 C** 00895 C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL, 00896 C VIA LE SOUS-PROGRAMME "LFIEMS" . 00897 C----------------------------------------------------------------------- 00898 C 00899 1001 CONTINUE 00900 KREP=IREP 00901 LLFATA=LLMOER (IREP,IRANG) 00902 C 00903 IF (LLFATA) THEN 00904 INIMES=2 00905 ELSE 00906 INIMES=IXNIMS (IRANG) 00907 ENDIF 00908 C 00909 IF (LLVERF) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'OFF') 00910 IF (LLVERG) CALL LFIVER_MT (LFI, LFI%VERGLA,'OFF') 00911 C 00912 IF (.NOT.LLFATA.AND.INIMES.EQ.0) THEN 00913 IF (LHOOK) CALL DR_HOOK('LFIFER_MT',1,ZHOOK_HANDLE) 00914 RETURN 00915 ENDIF 00916 C 00917 IF (INIMES.EQ.2) THEN 00918 WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER=' 00919 ',I3, S '', CDSTTC='''''',A,'''''''')') 00920 S KREP,KNUMER,CLSTTC(:ILSTTU) 00921 CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,LLFATA, 00922 S CLMESS,CLNSPR,CLACTI) 00923 ENDIF 00924 C 00925 C LA MESSAGERIE QUI SUIT N'EST PAS EMISE EN CAS D'ERREUR FATALE. 00926 C 00927 IF (INIMES.GE.1.AND.(IREP.EQ.0.OR.IREP.EQ.-19)) THEN 00928 CLAUXI=' ' 00929 C 00930 IF (LFI%LFRANC) THEN 00931 WRITE (UNIT=CLMESS,FMT='(''Unite' 00932 ',I3, S '' traitee, Fichier'',A)') 00933 S KNUMER,CLAUXI 00934 ELSE 00935 WRITE (UNIT=CLMESS,FMT='(''Unit' 00936 ',I3, S '' processed, File'',A)') 00937 S KNUMER,CLAUXI 00938 ENDIF 00939 C 00940 IDECAL=INDEX (CLMESS,CLAUXI) 00941 C 00942 IF (INBALO.EQ.0) THEN 00943 C 00944 IF (LFI%LFRANC) THEN 00945 CLMESS(IDECAL+1:)='*VIDE*'//CLAUXI 00946 ELSE 00947 CLMESS(IDECAL+1:)='*EMPTY*'//CLAUXI 00948 ENDIF 00949 C 00950 IDECAL=IDECAL+INDEX (CLMESS(IDECAL+1:),CLAUXI) 00951 ENDIF 00952 C 00953 IF (LFI%LFRANC) THEN 00954 C 00955 IF (LFI%LNOUFI(IRANG)) THEN 00956 CLMESS(IDECAL+1:)='$CREE$ &'//CLAUXI 00957 ELSEIF (LLECRD) THEN 00958 CLMESS(IDECAL+1:)='$MODIFIE$ &'//CLAUXI 00959 ELSE 00960 CLMESS(IDECAL+1:)='non modifie &'//CLAUXI 00961 ENDIF 00962 C 00963 IDECAL=IDECAL+INDEX (CLMESS(IDECAL+1:),CLAUXI) 00964 C 00965 IF (.NOT.LLSTTU) THEN 00966 CLMESS(IDECAL+1:)='FERME'//CLAUXI 00967 ELSEIF (CLSTTC.EQ.'KEEP') THEN 00968 CLMESS(IDECAL+1:)='GARDE'//CLAUXI 00969 ELSE 00970 CLMESS(IDECAL+1:)='*RELACHE*'//CLAUXI 00971 ENDIF 00972 C 00973 IF (LFI%LNOUFI(IRANG).OR.LLECRD) THEN 00974 IDECAL=IDECAL+INDEX (CLMESS(IDECAL+1:),CLAUXI) 00975 WRITE (UNIT=CLMESS(IDECAL+1:), 00976 S FMT='(''a'',I9.6,''_' 00977 ',I6.6, S '','',I7,'' Articles de donnees,'',I9,'' mots en tout'')') 00978 S LFI%MDES1D(IXM(LFI%JPDDMG,IRANG)), 00979 S LFI%MDES1D(IXM(LFI%JPHDMG,IRANG)), 00980 S INALDO,ILARPH*LFI%MDES1D(IXM(LFI%JPNAPH,IRANG)) 00981 ENDIF 00982 C 00983 ELSE 00984 C 00985 IF (LFI%LNOUFI(IRANG)) THEN 00986 CLMESS(IDECAL+1:)='$CREATED$ &'//CLAUXI 00987 ELSEIF (LLECRD) THEN 00988 CLMESS(IDECAL+1:)='$MODIFIED$ &'//CLAUXI 00989 ELSE 00990 CLMESS(IDECAL+1:)='not modified &'//CLAUXI 00991 ENDIF 00992 C 00993 IDECAL=IDECAL+INDEX (CLMESS(IDECAL+1:),CLAUXI) 00994 C 00995 IF (.NOT.LLSTTU) THEN 00996 CLMESS(IDECAL+1:)='CLOSED'//CLAUXI 00997 ELSEIF (CLSTTC.EQ.'KEEP') THEN 00998 CLMESS(IDECAL+1:)='KEPT'//CLAUXI 00999 ELSE 01000 CLMESS(IDECAL+1:)='*RELEASED*'//CLAUXI 01001 ENDIF 01002 C 01003 IF (LFI%LNOUFI(IRANG).OR.LLECRD) THEN 01004 IDECAL=IDECAL+INDEX (CLMESS(IDECAL+1:),CLAUXI) 01005 WRITE (UNIT=CLMESS(IDECAL+1:),FMT='(''at'',I9.6,''_' 01006 ', S I6.6,'','',I7,'' data Records,'',I9,'' words for a whole'')') 01007 S LFI%MDES1D(IXM(LFI%JPDDMG,IRANG)), 01008 S LFI%MDES1D(IXM(LFI%JPHDMG,IRANG)), 01009 S INALDO,ILARPH*LFI%MDES1D(IXM(LFI%JPNAPH,IRANG)) 01010 ENDIF 01011 C 01012 ENDIF 01013 C 01014 CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,.FALSE., 01015 S CLMESS,CLNSPR,CLACTI) 01016 C 01017 IF (LFI%LFRANC) THEN 01018 INLNOM=MIN0 (LFI%NLNOMF(IRANG),LFI%JPLFIX,LEN (CLMESS)-6) 01019 CLMESS='Nom='''//LFI%CNOMFI(IRANG)(1:INLNOM)//'''' 01020 ELSE 01021 INLNOM=MIN0 (LFI%NLNOMF(IRANG),LFI%JPLFIX,LEN (CLMESS)-7) 01022 CLMESS='Name='''//LFI%CNOMFI(IRANG)(1:INLNOM)//'''' 01023 ENDIF 01024 C 01025 CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,.FALSE., 01026 S CLMESS,CLNSPR,CLACTI) 01027 C 01028 IF (LFI%CNOMSY(IRANG)(1:LFI%NLNOMS(IRANG)).NE. 01029 S LFI%CNOMFI(IRANG)(1:LFI%NLNOMF(IRANG))) THEN 01030 C 01031 IF (LFI%LFRANC) THEN 01032 INLNOM=MIN0 (LFI%NLNOMS(IRANG),LFI%JPLFIX, 01033 S LEN (CLMESS)-14) 01034 CLMESS='Nom SYSTEME='''// 01035 S LFI%CNOMSY(IRANG)(1:INLNOM)//'''' 01036 ELSE 01037 INLNOM=MIN0 (LFI%NLNOMS(IRANG),LFI%JPLFIX, 01038 S LEN (CLMESS)-14) 01039 CLMESS='SYSTEM Name='''// 01040 S LFI%CNOMSY(IRANG)(1:INLNOM)//'''' 01041 ENDIF 01042 C 01043 CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,.FALSE., 01044 S CLMESS,CLNSPR,CLACTI) 01045 ENDIF 01046 C 01047 ENDIF 01048 C 01049 IF (LHOOK) CALL DR_HOOK('LFIFER_MT',1,ZHOOK_HANDLE) 01050 END 01051
1.8.0
