Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / FM2DIA / jdlfilaf_fuji.f
1       SUBROUTINE JDLFILAF ( KREP, KNUMER, LDTOUT )
2 C****
3 C            !--------------------------------------------------!
4 C            !        Sous-programme du logiciel LFI            !
5 C            ! (Logiciel de Fichiers Indexes par nom d'article) !
6 C            !--------------------------------------------------!
7 C
8 C       - Version originale de LFI: Octobre 1989, auteur:
9 C                                   Jean CLOCHARD, METEO FRANCE.
10 C
11 C       - Aout 1991: Ajout de la notion de "facteur multiplicatif"
12 C         (on sait traiter un fichier dont la longueur d'article
13 C          "physique" est multiple de la longueur elementaire JPLARD),
14 C         et (sur option) toute la messagerie peut etre en anglais.
15 C
16 C       - Janvier 1996 : ajout ecriture dans 1 fichier de nom FICJD
17 C         du numero des enregistrements, de leur nom et de leur longueur
18 C         totale   (CCCCCCCCCCCCCCCCCC JDJD CCCCCCCCCCCCCCCCCCCCCCC)
19 C
20 C
21 C****
22 C        Sous-programme donnant, pour une unite logique ouverte au sens
23 C     du logiciel de fichiers indexes *LFI*, la Liste des Articles logi-
24 C     ques de donnees presents dans le Fichier, liste donnee toutefois
25 C     dans l'ordre PHYSIQUE ou ceux-ci figurent dans le fichier.
26 C        Sur option on donne aussi des renseignements sur les articles
27 C     (physiques) de gestion propres au logiciel, ainsi que sur les
28 C     trous repertories dans l'index.
29 C**
30 C    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
31 C                KNUMER (Entree) ==> Numero de l'unite logique;
32 C                LDTOUT (Entree) ==> Vrai si on doit donner les rensei-
33 C                                    gnements optionnels (qui ne concer-
34 C                                    nent pas directement les articles
35 C                                    logiques de donnees).
36 C
37 C
38 #include "lficom0.h"
39 C
40 C
41 C----- DESCRIPTION DES "PARAMETER" DU LOGICIEL DE FICHIERS INDEXES -----
42 C
43 C     JPDBLE= PRECISION UTILISE POUR LES ENTIERS
44 C                 * SI JPDBLE=8 COMPILER EN INTEGER 32 BITS
45 C                 * SI JPDBLE=4 COMPILER EN INTEGER 64 BITS
46 C
47       INTEGER JPDBLE
48 C
49       PARAMETER (JPDBLE=8)
50 C
51 C--- DESCRIPTIF DES TABLES CONCERNANT LES (PAIRES DE) PAGES D'INDEX ----
52 C                       ( ALIAS "P.P.I." )
53 C
54 C     CNOMAR = TABLE DES PAGES D'INDEX DE TYPE "NOMS D'ARTICLES"
55 C     MLGPOS = TABLE DES PAGES D'INDEX DE TYPE "LONGUEUR/POSITION"
56 C     MRGPIF = TABLE DES RANGS DES P.P.I. DANS LEUR FICHIER RESPECTIF
57 C     MCOPIF = TABLE DE CORRESPONDANCE PAGES D'INDEX/UNITES LOGIQUES
58 C     MRGPIM = TABLE DES RANGS EN MEMOIRE DES P.P.I. AFFECTEES
59 C              ( DANS *MCOPIF,MRGPIF,CNOMAR,MLGPOS,LECRPI,LPHASP* )
60 C     LECRPI = VRAI SI LA PAGE D'INDEX CORRESP. DOIT ETRE (RE)ECRITE
61 C              (.,1) ==> PAGE "NOM", (.,2) ==> PAGE "LONGUEUR/POSITION"
62 C     LPHASP = VRAI SI LA PAGE D'INDEX "LONG/POS" EST PHASEE EN MEMOIRE
63 C              AVEC LA PAGE D'INDEX "NOM" CORRESPONDANTE
64 C
65 C---------------- VARIABLES "SIMPLES" GLOBALES -------------------------
66 C
67 C     NBFIOU = Nombre d'Unites Logiques ouvertes
68 C     NFACTM = Somme des Facteurs Multiplicatifs utilises
69 C     NIMESG = NIVEAU *GLOBAL* DE LA MESSAGERIE
70 C     NERFAG = NIVEAU DE FILTRAGE GLOBAL DES ERREURS FATALES
71 C     NISTAG = NIVEAU D'IMPRESSION GLOBAL DES STATISTIQUES
72 C     NPISAF = NBRE DE PAIRES DE PAGES D'INDEX SUPPLEMENTAIRES AFFECTEES
73 C     LMULTI = VRAI SI ON DOIT TRAVAILLER EN MODE MULTI-TACHES
74 C     LTAMLG = OPTION PAR DEFAUT D'UTILISATION DE LA MEMOIRE TAMPON EN
75 C              LECTURE; VRAIE ==> UTILISATION MAXIMUM
76 C     LTAMEG = CF. CI-DESSUS, EN ECRITURE
77 C     VERGLA = VERROU GLOBAL (EN MULTI-TASKING)
78 C     NULOFM = Nombre d'Unites LOgiques a Facteur Multiplicat. predefini
79 C     CHINCO = Nom par defaut d'une variable qui devrait etre CHaracter
80 C     NUIMEX = Nombre d'Unites LOgiques en cours d'IMport/EXport
81 C
82 C--------- DESCRIPTIF DES ELEMENTS CONCERNANT UNE UNITE LOGIQUE --------
83 C
84 C     NUMIND = TABLE D'ADRESSAGE INDIRECT DANS LES TABLEAUX CI-DESSOUS
85 C     NUMERO = NUMERO DE L'UNITE LOGIQUE
86 C     MFACTM = FACteur Multiplicatif de la longueur physique elementaire
87 C     CNOMFI = NOM eventuel du FIchier associe a l'unite logique
88 C     CNOMSY = Idem pour le systeme, ou a defaut pour l'utilisateur.
89 C     NLNOMF = LONGUEUR (CARACTERES) DU NOM EVENTUEL
90 C     NLNOMS = Longueur (en caracteres) du Nom SYSTEME eventuel
91 C     NDEROP = CODE DE LA DERNIERE ACTION EFFECTUEE
92 C     CSTAOP = 'STATUS' DE L'OUVERTURE
93 C     LNOUFI = VRAI SI LE FICHIER EST NOUVEAU (AU SENS DU LOGICIEL)
94 C     LMODIF =  "   "   "    "    A ETE MODIFIE DEPUIS L'OUVERTURE
95 C     NDERCO = DERNIER CODE-REPONSE (CORRESPONDANT A LA DERNIERE ACTION)
96 C     MTAMPD = PAGES DE DONNEES "TAMPON"
97 C     NUMAPD = NUMERO D'ARTICLE PHYSIQUE CORRESPONDANT A CES PAGES
98 C     LECRPD = VRAI SI LA PAGE DE DONNEES CORRESP. DOIT ETRE ECRITE
99 C     NLONPD = LONGUEUR DE PAGE DE DONNEES REELLEMENT REMPLIE
100 C     NDERPD = NUMERO DE LA DERNIERE PAGE DE DONNEES UTILISEE
101 C     NPODPI = RANG DE LA DERNIERE PAGE D'INDEX DANS LA TABLE *MRGPIM*
102 C     NALDPI = NOMBRE D'ARTICLES LOGIQUES DANS LA DERNIERE PAGE D'INDEX
103 C     NBLECT =    "   DE LECTURES          EFFECTUEES DEPUIS L'OUVERTURE
104 C     NBNECR =    "   "  NOUVELLES ECRITURES    "        "       "
105 C     NREESP =    "   "  "VRAIES" REECRITURES SUR PLACE  "       "
106 C     NREECO =    "   "  REECRITURES PLUS COURTES        "       "
107 C     NREELO =    "   "       "      PLUS LONGUES        "       "
108 C     NBRENO =    "   "  FOIS OU ON A RENOMME UN ARTICLE "       "
109 C     NBSUPP =    "   "   "  " "  " " SUPPRIME "    "    "       "
110 C     NBTROU =    "   "  TROUS D'INDEX CREES             "       "
111 C     NIVMES = NIVEAU DE LA MESSAGERIE
112 C     LERFAT = VRAI SI TOUTE ERREUR DOIT ETRE FATALE
113 C     LISTAT = OPTION D'IMPRESSION DES STATISTIQUES ( A LA FERMETURE )
114 C     VERRUE = VERROU DE L'UNITE LOGIQUE (EN MODE MULTI-TASKING)
115 C     NPPIMM = NBRE DE PAIRES DE PAGES D'INDEX EN MEMOIRE
116 C     MDES1D = TABLE CONTENANT LE 1ER ARTICLE ("DESCRIPTIF")
117 C     NTRULZ = NOMBRE DE TROUS D'INDEX DE LONGUEUR NULLE
118 C     NRFPTZ = RANG PREMIERE ARTICLE AYANT LA CARACTERISTIQUE CI-DESSUS
119 C     NRFDTZ =   "  DERNIER     "    "    "         "         "
120 C     NBREAD = NOMBRE DE "READ" FORTRAN REELLEMENT EXECUTES  (DEPUIS L'
121 C     NBWRIT =    "      "WRITE"   "        "         "       OUVERTURE)
122 C     NBMOLU = NOMBRE DE MOTS UTILISATEUR LUS   CORRECTEMENT (DEPUIS L'
123 C     NBMOEC =    "    "   "       "      ECRITS     "        OUVERTURE)
124 C     LTAMPL = OPTION D'UTILISATION MAXI DE LA MEMOIRE TAMPON EN LECTURE
125 C     LTAMPE =    "   "      "       "   "   "    "      "    " ECRITURE
126 C     NDERGF = RANG DANS LE FICHIER DU DERNIER ARTICLE LOGIQUE LU
127 C              ou dont on a demande les caracteristiques (LFICAS/LFICAP)
128 C     CNDERA = NOM de ce dernier article logique de donnees
129 C     NSUIVF = RANG DANS LE FICHIER DU PROCHAIN ARTICLE LOGIQUE A LIRE
130 C              "SEQUENTIELLEMENT"
131 C     NPRECF = RANG DANS LE FICHIER DU PROCHAIN ARTICLE LOGIQUE
132 C              "PRECEDENT" A LIRE
133 C     LMIMAL = VRAI SI ON DOIT RECALCULER LES LONGUEURS MINI. ET MAXI.
134 C              DES ARTICLES LOGIQUES DE DONNEES
135 C     NUMAPH = NUMero d'Article PHysique (pour messages d'erreur E/S).
136 C     NEXPOR = Rang eventuel (d'EXPORt) dans les tables MNUIEX,NDIMPL,
137 C     NIMPOR =  "      "     (d'IMPORt) NDEXPL,NREXPL,CNEXPL,NIMPEX...
138 C
139 C------------------------ VARIABLES DIVERSES ---------------------------
140 C
141 C     MULOFM = Table des Unites LOgiques avec Facteur Multip. predefini
142 C     MFACTU =   "    "  FActeurs mUltiplicatifs associes a ces Unites
143 C     MNUIEX =   "    "  Numeros d'Unites logiques en Import/EXport
144 C     NINIEX =   "   d'adressage INdirect dans MNUIEX
145 C     NDIMPL = Descripteurs IMPLicites d'import/export en memoire
146 C     NDEXPL =      "       EXPLicites "   "   /  "    "     "
147 C     CNIMPL = Profil des articles a description IMPLicite
148 C     NAEXPL = Nombre d'articles decrits EXPLicitement
149 C     CNEXPL = Noms des articles decrits dans NDEXPL
150 C     NREXPL = Rang  "      "       "      "  NDEXPL
151 C     NIMPEX = Numero d'unite logique associee a l'IMPort ou l'EXport.
152 C     NUTRAV =    "   "   "      "    de TRAVail pour import ou export.
153 C     NLAPFD = Longueur d'Article Physique du fichier d'export/import.
154 C     NXCNLD = Nb.maX. Caracteres/Nom d'article du logiciel LFI Distant.
155 C     NRCFMX = Rang de la config. Imp/eXport dans CFGMXD, NBMOSD, NBCASD
156 C     CFGMXD = ConFiGuration pour iMport/eXport des systemes Distants.
157 C     NBMOSD = Nombre de Bits par MOt       des systemes Distants.
158 C     NBCASD =    "   "    "   "  CAractere  "     "        "    .
159 C     CTYPMX = Liste des types de variables valides pour Import/eXport.
160 C
161       CHARACTER*(JPNCPN) CNOMAR (JPNXNA*JPNXPI), CNDERA (JPNXFI), CHINCO
162       CHARACTER*(JPLFTX) CNOMFI (JPNXFI), CNOMSY (JPNXFI), CLACTI
163       CHARACTER CSTAOP (JPNXFI)*(JPLSTX), CLNSPR*(JPLSPX), CLMESS*132
164       CHARACTER CNEXPL (JPXDAM,JPIMEX)*(JPNCPN), CTYPMX*(JPTYMX)
165       CHARACTER CNIMPL (JPIMEX)*(JPXMET), CFGMXD (0:JPCFMX)*(JPXCCF)
166 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
167       CHARACTER*16 CFICJD,CFICJDOUT
168 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
169 C
170 C
171       COMMON /LFICHA/ CNOMAR, CNDERA, CNOMFI, CNOMSY, CSTAOP, CHINCO
172      S              , CNEXPL, CNIMPL, CFGMXD, CTYPMX
173 C
174       INTEGER NBFIOU, NFACTM, NIMESG, NERFAG, NISTAG, NPISAF, NULOFM
175       INTEGER (KIND=JPDBLE) MLGPOS (JPLARD*JPNXPI)
176       INTEGER (KIND=JPDBLE) MTAMPD (JPLARD*JPNPDF*JPNXFI)
177       INTEGER (KIND=JPDBLE) MDES1D (JPLARD*JPNXFI)
178       INTEGER MRGPIM (JPNPIA+JPNPIS,JPNXFI), NDERPD (JPNXFI)
179       INTEGER MCOPIF (JPNXPI), MRGPIF (JPNXPI), NLNOMS (JPNXFI)
180       INTEGER NUMERO (JPNXFI), NLNOMF (JPNXFI), NDERCO (JPNXFI)
181       INTEGER NPODPI (JPNXFI), NUMAPH (0:JPNXFI)
182       INTEGER NALDPI (JPNXFI), NBLECT (JPNXFI), NBNECR (JPNXFI)
183       INTEGER NREESP (JPNXFI), NREECO (JPNXFI), NREELO (JPNXFI)
184       INTEGER NIVMES (0:JPNXFI), NDEROP (JPNXFI), NPPIMM (JPNXFI)
185       INTEGER NUMAPD (0:JPNPDF-1,JPNXFI), NLONPD (0:JPNPDF-1,JPNXFI)
186       INTEGER NTRULZ (JPNXFI), NRFPTZ (JPNXFI), NRFDTZ (JPNXFI)
187       INTEGER NBTROU (JPNXFI), NUMIND (JPNXFI), NBREAD (JPNXFI)
188       INTEGER NBWRIT (JPNXFI), NBMOLU (JPNXFI), NBMOEC (JPNXFI)
189       INTEGER NDERGF (JPNXFI), NSUIVF (JPNXFI), NPRECF (JPNXFI)
190       INTEGER NBRENO (JPNXFI), NBSUPP (JPNXFI), MFACTM (0:JPNXFI)
191       INTEGER MULOFM (JPXUFM), MFACTU (0:JPXUFM)
192       INTEGER NIMPEX (JPIMEX), NUTRAV (JPIMEX), NBMOSD (0:JPCFMX)
193       INTEGER NBCASD (0:JPCFMX), NLAPFD (JPIMEX)
194       INTEGER MNUIEX (JPIMEX), NINIEX (JPIMEX), NDEXPL (JPDEXP,JPIMEX)
195       INTEGER NDIMPL (JPDIMP,JPIMEX), NXCNLD (JPIMEX), NAEXPL (JPIMEX)
196       INTEGER NEXPOR (JPNXFI), NIMPOR (JPNXFI), NUIMEX, NRCFMX (JPIMEX)
197       INTEGER NREXPL (0:JPXDAM,JPIMEX)
198 C
199       REAL VERRUE (JPNXFI), VERGLA
200 C
201       LOGICAL LLFATA, LMULTI, LTAMLG, LTAMEG, LECRPI (JPNXPI,2)
202       LOGICAL LTAMPL (JPNXFI), LTAMPE (JPNXFI), LMODIF (JPNXFI)
203       LOGICAL LNOUFI (JPNXFI), LERFAT (0:JPNXFI), LISTAT (JPNXFI)
204       LOGICAL LPHASP (JPNXPI), LECRPD (0:JPNPDF-1,JPNXFI)
205       LOGICAL LMIMAL (JPNXFI)
206 C
207       COMMON /LFIDIV/ NBFIOU, NIMESG, NERFAG, NISTAG, NPISAF, LMULTI
208      S              , VERGLA, LTAMLG, LTAMEG, MRGPIM, MRGPIF, NUMIND
209      S              , VERRUE, MLGPOS, MDES1D, MCOPIF, LECRPI, LPHASP
210      S              , NUMERO, NLNOMF, LNOUFI, NDERCO, MTAMPD, NUMAPD
211      S              , NPODPI, NALDPI, NBLECT, NBNECR, NREESP, NREECO
212      S              , NREELO, NIVMES, LERFAT, LISTAT, NDEROP, LMODIF
213      S              , NPPIMM, NRFPTZ, NRFDTZ, NTRULZ, NBREAD, NBWRIT
214      S              , LECRPD, NLONPD, NDERPD, NBTROU, NBMOLU, NBMOEC
215      S              , LTAMPL, LTAMPE, NDERGF, NSUIVF, NBRENO, NBSUPP
216      S              , LMIMAL, NPRECF, MFACTM, NULOFM, MULOFM, MFACTU
217      S              , NLNOMS, NFACTM, NUMAPH, NEXPOR, NIMPOR, NIMPEX
218      S              , NUTRAV, NBMOSD, NBCASD, NLAPFD, NXCNLD, NUIMEX
219      S              , MNUIEX, NINIEX, NDEXPL, NREXPL, NDIMPL, NAEXPL
220      S              , NRCFMX
221 C
222 C
223       INTEGER KREP, KNUMER, IMDESC, IREP, IRANG, INTROU, INBPIR, INBALO
224       INTEGER INALDO, IFACTM, ILARPH, INALPP, INTPPI, INPPIM, INIMES, J
225       INTEGER INAGES, IRESER, INUTIL, IPERTE, IPOSFI, IPOSDE, INEXCE
226       INTEGER INABAL, INALDI, INTROI, INPIMD, INPIMF, INPILE, JRGPIF
227       INTEGER IRGPFS, IRGPIM, IRANGM, IRPIMS, INALPI, ILONGA, IRECPI
228       INTEGER IDERPU, IREC, IRETIN
229 C
230       LOGICAL LDTOUT
231 C
232 C
233 C       FONCTION SERVANT A RENDRE FATALE OU NON UNE ERREUR DETECTEE,
234 C       A L'AIDE DU CODE-REPONSE COURANT, DU NIVEAU DE FILTRAGE GLOBAL,
235 C       ET DE L'OPTION D'ERREUR FATALE PROPRE AU FICHIER.
236 C       S'IL N'Y A PAS DE FICHIER (I5678=0, D'OU DIMENSIONNEMENT DE
237 C          *LERFAT*), LE NIVEAU DE FILTRAGE JOUE LE ROLE PRINCIPAL.
238 C
239       INTEGER IXNIMS, I1234, I5678, I3456, IXC, IXM, IXT, IABCDE, IFGHIJ
240       INTEGER IKLMNO, IPQRST, IUVWXY, IZABCD, IEFGHI
241 C
242       LOGICAL LLMOER
243 C
244       LLMOER (I1234,I5678)=I1234.EQ.-16.OR.
245      S (I1234.NE.0.AND.(NERFAG.EQ.0.OR.(NERFAG.EQ.1.AND.LERFAT(I5678))))
246 C
247 C       FONCTION DONNANT LE PLUS HAUT NIVEAU DE MESSAGERIE ACCEPTABLE
248 C       POUR L'UNITE LOGIQUE DE RANG "I3456" .
249 C       (UTILISATION DES NIVEAUX DE MESSAGERIE GLOBAL ET PROPRE AU
250 C        FICHIER - MEME REMARQUE QUE CI-DESSUS SI I3456=0, POUR NIVMES)
251 C
252       IXNIMS (I3456)=MIN0 (2,2*NIMESG,MAX0 (2*NIMESG-2,NIVMES(I3456)))
253 C
254 C       Fonctions servant a l'adressage 1D dans les tableaux CNOMAR,
255 C     MLGPOS et MDES1D, MTAMPD.
256 C
257       IXC (IABCDE,IFGHIJ) = IABCDE + JPNXNA * ( IFGHIJ - 1 )
258       IXM (IKLMNO,IPQRST) = IKLMNO + JPLARD * ( IPQRST - 1 )
259       IXT (IUVWXY,IZABCD,IEFGHI) = IUVWXY + JPLARD *
260      S ( MFACTM(IEFGHI) * IZABCD + JPNPDF * ( IEFGHI - 1 ) )
261 C
262 C**
263 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
264 C-----------------------------------------------------------------------
265 C
266       IREP=0
267       IRANG=0
268       CLNSPR='LFILAF'
269       print *,' jdlfilaf BALISE 1 KNUMER,IRANG',KNUMER,IRANG
270       CALL LFINUM (KNUMER,IRANG)
271       print *,' jdlfilaf BALISE 1 Bis LMULTI',LMULTI,KNUMER,IRANG
272 C
273       IF (IRANG.EQ.0) THEN
274         IREP=-1
275         GOTO 1001
276       ENDIF
277 C
278       IF (LMULTI) CALL LFIVER (VERRUE(IRANG),'ON')
279       INTROU=MDES1D(IXM(JPNTRU,IRANG))+NBTROU(IRANG)
280       INBPIR=MDES1D(IXM(JPNPIR,IRANG))
281       INBALO=MDES1D(IXM(JPNALO,IRANG))
282       INALDO=INBALO-INTROU
283       print *,' MFACTM(0), MFACTM(1) ',MFACTM(0),MFACTM(1)
284       IFACTM=MFACTM(IRANG)
285       print *,' jdlfilaf BALISE 1 IRANG, IFACTM ',IRANG,IFACTM
286       ILARPH=JPLARD*IFACTM
287       INALPP=JPNAPP*IFACTM
288 C     INALPP=512
289       print *,' jdlfilaf BALISE 1 INALPP',INALPP
290 C     INALPP=1
291       INTPPI=(INBALO-1+INALPP)/INALPP
292       INPPIM=NPPIMM(IRANG)
293 C
294 C         Envoi d'une banniere.
295 C
296       WRITE (UNIT=*,FMT='(///)')
297 C
298       IF (LFRANC) THEN
299         WRITE (UNIT=CLMESS,FMT='(''Catalogue de l''''Unite Logique LFI''
300      S ,I3,'' dans l''''ordre *PHYSIQUE* (sequentiel) des articles'')')
301      S     KNUMER
302       ELSE
303         WRITE (UNIT=CLMESS,FMT='(''Catalog of LFI Logical Unit'',I3,
304      S         '' in *PHYSICAL* (sequential) record order'')') KNUMER
305       ENDIF
306 C
307       INIMES=2
308       LLFATA=.FALSE.
309       CALL LFIEMS (KNUMER,INIMES,IREP,LLFATA,CLMESS,CLNSPR,CLACTI)
310 C**
311 C     2.  -  SUR OPTION, RENSEIGNEMENTS SUR LES ARTICLES "DE GESTION".
312 C            (ARTICLE DOCUMENTAIRE, PAIRES D'ARTICLES D'INDEX)
313 C-----------------------------------------------------------------------
314 C
315       print *,' jdlfilaf BALISE 2'
316       IF (LDTOUT) THEN
317         INAGES=1+2*INBPIR
318         IRESER=ILARPH*INAGES
319 C
320         IF (LFRANC) THEN
321           WRITE (UNIT=*,FMT='(//,TR1,I6,
322      S           '' article(s) "physique(s)" de gestion,'',I6,
323      S           '' mots chacun, occupant donc'',I7,'' mots; detail:'',
324      S /,TR10,''Article documentaire de la position 1 a'',I6,/,TR10,I6,
325      S'' paire(s) d''''articles d''''index prereserves, de la position''
326      S           ,I6,'' a'',I7)')
327      S         INAGES,ILARPH,IRESER,ILARPH,INBPIR,ILARPH+1,IRESER
328         ELSE
329           WRITE (UNIT=*,FMT='(//,TR1,I6,
330      S           '' "physical" records for file handling,'',I6,
331      S           '' words each, occupying then'',I7,'' words; detail:'',
332      S /,TR10,''Documentary record from position 1 to'',I6,/,TR10,I6,
333      S'' pair(s) of pre-reserved index records, from position''
334      S           ,I6,'' to'',I7)')
335      S         INAGES,ILARPH,IRESER,ILARPH,INBPIR,ILARPH+1,IRESER
336         ENDIF
337 C
338         IF (INTPPI.LT.INBPIR) THEN
339           INUTIL=INBPIR-INTPPI
340           IPERTE=ILARPH*INUTIL*2
341 C
342           IF (LFRANC) THEN
343             WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> Il y a'',I3,
344      S '' paire(s) d''''articles d''''index inutilises, representant'',
345      S             I8,'' mots'')') INUTIL,IPERTE
346           ELSE
347             WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> There is (are)'',I3,
348      S '' pair(s) of unused index records, leading to a loss of'',
349      S             I8,'' words'')') INUTIL,IPERTE
350           ENDIF
351 C
352         ELSEIF (INTPPI.EQ.INBPIR) THEN
353 C
354           IF (LFRANC) THEN
355             WRITE (UNIT=*,FMT='(TR15,5(''-''),TR3,''pas de paire '',
356      S        ''d''''articles d''''index inutilises ni excedentaires'',
357      S          TR3,5(''-''))')
358           ELSE
359             WRITE (UNIT=*,FMT='(TR15,5(''-''),TR3,''no pair of '',
360      S        ''unused or overflow pages'',
361      S          TR3,5(''-''))')
362           ENDIF
363 C
364         ELSEIF (INTPPI.EQ.(INBPIR+1)) THEN
365           IPOSFI=ILARPH*(MDES1D(IXM(ILARPH,IRANG))+1)
366           IPOSDE=IPOSFI-2*ILARPH+1
367 C
368           IF (LFRANC) THEN
369             WRITE (UNIT=*,FMT='(TR10,''une paire d''''articles '',
370      S             ''d''''index excedentaires, de la position'',
371      S             I9,'' a'',I9)')
372      S      IPOSDE,IPOSFI
373           ELSE
374             WRITE (UNIT=*,FMT='(TR10,''one pair of overflow index '',
375      S             ''pages ,from position'',
376      S             I9,'' to'',I9)')
377      S      IPOSDE,IPOSFI
378           ENDIF
379 C
380       print *,' jdlfilaf BALISE 3'
381         ELSE
382           INEXCE=INTPPI-INBPIR
383 C
384           IF (LFRANC) THEN
385             WRITE (UNIT=*,FMT='(TR10,I6,'' paires d''''articles '',
386      S           ''d''''index excedentaires, des positions:'')') INEXCE
387 C
388             DO 201 J=1,INEXCE
389             IPOSFI=ILARPH*(MDES1D(IXM(ILARPH+1-J,IRANG))+1)
390             IPOSDE=IPOSFI-2*ILARPH+1
391             WRITE (UNIT=*,FMT='(TR20,I9,'' a'',I9)') IPOSDE,IPOSFI
392   201       CONTINUE
393 C
394           ELSE
395             WRITE (UNIT=*,FMT='(TR10,I6,'' pairs of overflow index '',
396      S           ''pages, from positions:'')') INEXCE
397 C
398             DO 202 J=1,INEXCE
399             IPOSFI=ILARPH*(MDES1D(IXM(ILARPH+1-J,IRANG))+1)
400             IPOSDE=IPOSFI-2*ILARPH+1
401             WRITE (UNIT=*,FMT='(TR20,I9,'' to'',I9)') IPOSDE,IPOSFI
402   202       CONTINUE
403 C
404           ENDIF
405 C
406         ENDIF
407 C
408       ENDIF
409 C
410       WRITE (UNIT=*,FMT='(//)')
411 C**
412 C     3.  -  RENSEIGNEMENTS INDIVIDUALISES SUR LES ARTICLES LOGIQUES.
413 C            (DONNEES, ET SUR OPTION TROUS REPERTORIES DANS L'INDEX)
414 C-----------------------------------------------------------------------
415       print *,' jdlfilaf BALISE 4'
416 C
417       IF (LFRANC) THEN
418 C
419         IF (INBALO.EQ.0) THEN
420           WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> L''''unite logique'',
421      S I3,'' ne contient AUCUN ARTICLE LOGIQUE (ni donnees, ni trous)'',
422      S           //)') KNUMER
423           GOTO 1001
424         ELSEIF (INBALO.EQ.INTROU) THEN
425           WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> L''''unite logique'',
426      S I3,'' ne contient QUE DES TROUS, pas de donnees)'',//)') KNUMER
427           IF (.NOT.LDTOUT) GOTO 1001
428         ENDIF
429 C
430       ELSE
431 C
432         IF (INBALO.EQ.0) THEN
433           WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> The logical unit'',I3,
434      S '' contains NO LOGICAL RECORD AT ALL (neither data, nor holes)'',
435      S           //)') KNUMER
436           GOTO 1001
437         ELSEIF (INBALO.EQ.INTROU) THEN
438           WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> The logical unit'',I3,
439      S '' contains ONLY HOLES, no dat)'',//)') KNUMER
440           IF (.NOT.LDTOUT) GOTO 1001
441         ENDIF
442 C
443       ENDIF
444 C*
445 C     3.1 -  BALAYAGE DES PAIRES D'ARTICLES D'INDEX, PAR ORDRE CROISSANT
446 C-----------------------------------------------------------------------
447 C
448       INABAL=0
449       INALDI=0
450       INTROI=0
451       INPIMD=2
452       INPIMF=INPPIM
453       IF (NPODPI(IRANG).EQ.2) INPIMD=3
454       IF (NPODPI(IRANG).EQ.INPPIM) INPIMF=INPPIM-1
455       INPILE=2
456 C
457       DO 319 JRGPIF=1,INTPPI
458       IRGPFS=JRGPIF+1
459 C
460 C        On fait en sorte que la P.A.I. concernee, ainsi que sa suivante
461 C     eventuelle, soient toutes les deux en memoire.
462 C
463       IF (JRGPIF.EQ.INTPPI) THEN
464         IRGPIM=MRGPIM(NPODPI(IRANG),IRANG)
465         GOTO 314
466 C
467       ELSEIF (JRGPIF.NE.1) THEN
468 C
469 C       Recherche de la P.A.I. dans les Paires de Pages d'Index memoire.
470 C
471         DO 311 J=INPIMD,INPIMF
472         IRGPIM=MRGPIM(J,IRANG)
473 C
474         IF (MRGPIF(IRGPIM).EQ.JRGPIF) THEN
475 C
476           IF (.NOT.LPHASP(IRGPIM)) THEN
477 C
478             CALL LFIPHA (IREP,IRANG,IRGPIM,IRETIN)
479 C
480             IF (IRETIN.EQ.1) THEN
481               GOTO 903
482             ELSEIF (IRETIN.EQ.2) THEN
483               GOTO 904
484             ELSEIF (IRETIN.NE.0) THEN
485               GOTO 1001
486             ENDIF
487 C
488           ENDIF
489 C
490           GOTO 312
491 C
492         ENDIF
493 C
494       print *,' jdlfilaf BALISE 5'
495   311   CONTINUE
496 C
497 C          Mise en memoire de la Paire d'Articles d'Index cherchee.
498 C
499         CALL LFIPIM (IREP,IRANG,IRANGM,IRGPIM,JRGPIF,IRGPFS,INPILE,
500      S               IRETIN)
501 C
502         IF (IRETIN.EQ.1) THEN
503           GOTO 903
504         ELSEIF (IRETIN.EQ.2) THEN
505           GOTO 904
506         ELSEIF (IRETIN.NE.0) THEN
507           GOTO 1001
508         ELSEIF (IRANGM.GT.INPPIM) THEN
509           INPPIM=IRANGM
510           INPIMF=INPPIM
511         ENDIF
512 C
513       ELSE
514         IRGPIM=MRGPIM(1,IRANG)
515 C
516       ENDIF
517 C
518   312 CONTINUE
519 C
520       IF (IRGPFS.EQ.INTPPI) THEN
521         IRPIMS=MRGPIM(NPODPI(IRANG),IRANG)
522 C
523       ELSE
524 C
525 C       Recherche de la P.A.I. dans les Paires de Pages d'Index memoire.
526 C
527         DO 313 J=INPIMD,INPIMF
528         IRPIMS=MRGPIM(J,IRANG)
529 C
530         IF (MRGPIF(IRPIMS).EQ.IRGPFS) THEN
531 C
532           IF (.NOT.LPHASP(IRPIMS)) THEN
533 C
534             CALL LFIPHA (IREP,IRANG,IRPIMS,IRETIN)
535 C
536             IF (IRETIN.EQ.1) THEN
537               GOTO 903
538             ELSEIF (IRETIN.EQ.2) THEN
539               GOTO 904
540             ELSEIF (IRETIN.NE.0) THEN
541               GOTO 1001
542             ENDIF
543 C
544           ENDIF
545 C
546           GOTO 314
547 C
548         ENDIF
549 C
550   313   CONTINUE
551 C
552 C          Mise en memoire de la Paire d'Articles d'Index cherchee.
553 C
554       print *,' jdlfilaf BALISE 6'
555         CALL LFIPIM (IREP,IRANG,IRANGM,IRPIMS,IRGPFS,JRGPIF,INPILE,
556      S               IRETIN)
557 C
558         IF (IRETIN.EQ.1) THEN
559           GOTO 903
560         ELSEIF (IRETIN.EQ.2) THEN
561           GOTO 904
562         ELSEIF (IRETIN.NE.0) THEN
563           GOTO 1001
564         ELSEIF (IRANGM.GT.INPPIM) THEN
565           INPPIM=IRANGM
566           INPIMF=INPPIM
567         ENDIF
568 C
569       ENDIF
570 C
571   314 CONTINUE
572       INALPI=MIN0 (INALPP,INBALO-INABAL)
573 C
574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
575       IF(JRGPIF .EQ. 1)THEN
576         CFICJD='FICJD'
577         CFICJDOUT='FICJDOUT'
578         CALL FMATTR(CFICJD,CFICJDOUT,IFICJD,IREP)
579         OPEN(UNIT=IFICJD,FILE=CFICJD,FORM='FORMATTED')
580       ENDIF
581 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
582 C
583 C
584 C        Balayage de la Paire d'Article d'Index concernee.
585 C
586       DO 318 J=1,INALPI
587 C
588       IF (CNOMAR(IXC(J,IRGPIM)).NE.' ') THEN
589 C
590 C              Il s'agit d'un article logique de donnees; en plus de ses
591 C         caracteristiques tabulees, on verifie s'il n'y a pas de la
592 C         place "perdue" juste derriere les donnees, place recuperable
593 C         eventuellement en cas de reecriture plus longue de l'article
594 C         logique.
595 C
596         INALDI=INALDI+1
597         ILONGA=MLGPOS(IXM(2*J-1,IRGPIM))
598         IPOSDE=MLGPOS(IXM(2*J  ,IRGPIM))
599         IPOSFI=IPOSDE+ILONGA-1
600 C
601         IF (J.EQ.1.AND.JRGPIF.GT.INBPIR) THEN
602 C
603 C          Cas du premier article logique d'une P.A.I. excedentaire;
604 C     dans ce cas, la P.A.I. est situee derriere l'article logique,
605 C     en occupant deux articles physiques.
606 C
607           IRECPI=MDES1D(IXM(ILARPH+1-(JRGPIF-INBPIR),IRANG))
608           IDERPU=ILARPH*(IRECPI-1)
609 C
610         ELSEIF (J.EQ.INALPI.AND.JRGPIF.EQ.INTPPI) THEN
611 C
612 C          Cas du dernier article logique du fichier, sans P.A.I. situee
613 C     derriere: la derniere position utilisable sans modifier le nombre
614 C     d'articles physiques du fichier correspond a la fin du dernier
615 C     article physique contenant des donnees, ou a la fin du dernier
616 C     article physique ecrit sur le fichier.
617 C
618           IMDESC=MDES1D(IXM(JPNAPH,IRANG))
619           IREC=MAX0 (1+(IPOSFI-1)/ILARPH,IMDESC)
620           IDERPU=ILARPH*IREC
621 C
622 C          Si on arrive au test ci-dessous, on est sur que l'article lo-
623 C     gique n'est pas le dernier du fichier.
624 C
625         ELSEIF (J.NE.INALPP) THEN
626 C
627 C          Cas general, ou l'article logique n'est pas le dernier de sa
628 C     (Paire de) Page(s) d'Index.
629 C
630           IDERPU=MLGPOS(IXM(2*J+2,IRGPIM))-1
631 C
632         ELSE
633 C
634 C          Cas particulier ou l'article logique est le dernier de sa
635 C     (Paire de) Page(s) d'Index.
636 C
637           IDERPU=MLGPOS(IXM(2,IRPIMS))-1
638         ENDIF
639 C
640         IF (IDERPU.EQ.IPOSFI) THEN
641 C
642           IF (LFRANC) THEN
643             WRITE (UNIT=*,FMT='(I7,''-eme article de donnees: "'',A,
644      S             ''",'',I7,'' mots, position'',I9,'' a'',I9)')
645      S       INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI
646 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
647             WRITE (UNIT=IFICJD,FMT='(I7,''  '',A,''  '',I8)')
648      S       INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
649 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
650           ELSE
651             WRITE (UNIT=*,FMT='(I7,''-th data record: "'',A,''",'',I7,
652      S             '' words, position'',I9,'' to'',I9)')
653      S       INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI
654 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
655             WRITE (UNIT=IFICJD,FMT='(I7,''  '',A,''  '',I8)')
656      S       INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
657 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
658           ENDIF
659 C
660         ELSE
661 C
662 C           On visualise en plus la place "perdue" derriere l'article.
663 C
664           IF (LFRANC) THEN
665             WRITE (UNIT=*,FMT='(I7,''-eme article de donnees: "'',A,
666      S             ''",'',I7,'' mots, position'',I9,'' a'',I9,'' <'',SP,
667      S             I8,'' >'')')
668      S   INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI,IDERPU-IPOSFI
669 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
670             WRITE (UNIT=IFICJD,FMT='(I7,''  '',A,''  '',I8)')
671      S       INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
672 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
673           ELSE
674             WRITE (UNIT=*,FMT='(I7,''-th data record: "'',A,''",'',I7,
675      S             '' words, position'',I9,'' to'',I9,'' <'',SP,
676      S             I8,'' >'')')
677      S   INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI,IDERPU-IPOSFI
678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
679             WRITE (UNIT=IFICJD,FMT='(I7,''  '',A,''  '',I8)')
680      S       INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
681 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
682
683           ENDIF
684 C
685         ENDIF
686 C
687       ELSEIF (LDTOUT) THEN
688         INTROI=INTROI+1
689         ILONGA=MLGPOS(IXM(2*J-1,IRGPIM))
690         IPOSDE=MLGPOS(IXM(2*J  ,IRGPIM))
691         IPOSFI=IPOSDE+ILONGA-1
692 C
693         IF (LFRANC) THEN
694           WRITE (UNIT=*,FMT='(TR1,5(''=''),''>'',T10,I6,
695      S ''-eme TROU repertorie dans l''''index, longueur reutilisable:'',
696      S         I7,'' mots, position'',I9,'' a'',I9)')
697      S   INTROI,ILONGA,IPOSDE,IPOSFI
698         ELSE
699           WRITE (UNIT=*,FMT='(TR1,5(''=''),''>'',T10,I6,
700      S ''-th HOLE cataloged within index, re-usable length:'',
701      S         I7,'' words, position'',I9,'' to'',I9)')
702      S   INTROI,ILONGA,IPOSDE,IPOSFI
703         ENDIF
704 C
705       ENDIF
706 C
707   318 CONTINUE
708 C
709       INABAL=INABAL+INALPI
710   319 CONTINUE
711 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
712       CLOSE(IFICJD)
713 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
714 CCCCCCCCCCCCCCC didier
715       call FMFREE(CFICJD,CFICJDOUT,IREP)
716 CCCCCCCCCCCCCCC didier
717 C*
718 C     3.2 -  ENVOI DE MESSAGES RECAPITULATIFS.
719 C-----------------------------------------------------------------------
720 C
721       IF (LFRANC) THEN
722 C
723         IF (LDTOUT) THEN
724           WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
725      S           '' articles logiques de donnees et'',I6,
726      S           '' trous repertories listes'',TR3,8(''-''),//)')
727      S    INALDI,INTROI
728         ELSE
729           WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
730      S       '' articles logiques de donnees listes'',TR3,8(''-''),//)')
731      S    INALDI
732         ENDIF
733 C
734       ELSE
735 C
736         IF (LDTOUT) THEN
737           WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
738      S           '' logical records of data and'',I6,
739      S           '' holes within index listed'',TR3,8(''-''),//)')
740      S    INALDI,INTROI
741         ELSE
742           WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
743      S       '' logical records of data listed'',TR3,8(''-''),//)')
744      S    INALDI
745         ENDIF
746 C
747       ENDIF
748 C
749       IF (INALDI.EQ.INALDO.AND.(.NOT.LDTOUT.OR.INTROI.EQ.INTROU)) THEN
750 C
751         IF (LFRANC) THEN
752           WRITE (UNIT=CLMESS,FMT=
753      S     '(''Fin du catalogue de l''''Unite Logique'',I3,'' ---'',I7,
754      S       '' Articles logiques en tout'')') KNUMER,INBALO
755         ELSE
756           WRITE (UNIT=CLMESS,FMT=
757      S     '(''End of catalog of Logical Unit'',I3,'' ---'',I7,
758      S       '' logical Records for whole file'')') KNUMER,INBALO
759         ENDIF
760 C
761         CALL LFIEMS (KNUMER,INIMES,IREP,LLFATA,CLMESS,CLNSPR,CLACTI)
762         WRITE (UNIT=*,FMT='(///)')
763       ELSE
764         IREP=-16
765       ENDIF
766 C
767       GOTO 1001
768 C**
769 C     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
770 C-----------------------------------------------------------------------
771 C
772   903 CONTINUE
773       CLACTI='WRITE'
774       GOTO 909
775 C
776   904 CONTINUE
777       CLACTI='READ'
778 C
779   909 CONTINUE
780 C
781 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
782 C
783       IREP=IABS (IREP)
784 C**
785 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
786 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
787 C-----------------------------------------------------------------------
788 C
789  1001 CONTINUE
790       KREP=IREP
791       LLFATA=LLMOER (IREP,IRANG)
792 C
793       IF (IRANG.NE.0) THEN
794         NDEROP(IRANG)=18
795         NDERCO(IRANG)=IREP
796         IF (LMULTI) CALL LFIVER (VERRUE(IRANG),'OFF')
797       ENDIF
798       print *,' jdlfilaf BALISE 7'
799 C
800       IF (LLFATA.OR.IXNIMS (IRANG).EQ.2) THEN
801         INIMES=2
802       ELSE
803         RETURN
804       ENDIF
805 C
806       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='',I3,
807      S    '', LDTOUT= '',L1)') KREP,KNUMER,LDTOUT
808       CALL LFIEMS (KNUMER,INIMES,IREP,LLFATA,CLMESS,CLNSPR,CLACTI)
809       print *,' jdlfilaf BALISE 8'
810 C
811       RETURN
812       END