SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/LFI/mt/lfiecx

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFIECX_MT (LFI, KREP, KRANG, KREC, KZONE, 
00003      S                      LDADON, KRETIN )
00004       USE LFIMOD, ONLY : LFICOM
00005       USE PARKIND1, ONLY : JPRB
00006       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00007 C****
00008 C        SOUS-PROGRAMME *INTERNE* DU LOGICIEL DE FICHIERS INDEXES LFI
00009 C     ECRITURE SUR FICHIER D'UNE PAGE DE DONNEES OU D'INDEX LONG./POS.,
00010 C     EN "BOUCHANT LES TROUS" SI ON N'ECRIT PAS A LA SUITE DU DERNIER
00011 C     ARTICLE PRESENT SUR LE FICHIER, ET EN ESSAYANT D'ECRIRE DES ARTI-
00012 C     CLES ADJACENTS SI ON N'ECRIT PAS UN ARTICLE (PHYSIQUE) "NOUVEAU".
00013 C        CE S/P MET A JOUR LE NOMBRE D'ARTICLES PHYSIQUES DU FICHIER,
00014 C     ET DANS LE CAS D'UN ARTICLE PHYSIQUE DE DONNEES, LE LFI%NUMERO MAXI.
00015 C     D'ARTICLE PHYSIQUE DE DONNEES DU FICHIER.
00016 C**
00017 C    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DE L'ECRITURE FORTRAN;
00018 C                KRANG  (ENTREE) ==> RANG EN MEMOIRE DE L'UNITE LOGIQUE;
00019 C                KREC   (ENTREE) ==> LFI%NUMERO D'ENREGISTREMENT A ECRIRE;
00020 C                KZONE  (ENTREE) ==> PREMIER MOT A ECRIRE;
00021 C                LDADON (ENTREE) ==> VRAI SI ARTICLE DE DONNEES;
00022 C                KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
00023 C
00024 #ifndef f77
00025 #include "precision.h"
00026 #endif
00027 C
00028       TYPE(LFICOM) :: LFI
00029 #ifndef f77
00030       INTEGER (KIND=JPDBLE) KZONE (LFI%JPLARX)
00031 #else
00032       INTEGER KZONE (LFI%JPLARX)
00033 #endif
00034       INTEGER KREP, KRANG, KREC, KRETIN
00035       INTEGER INADJA (2), IPOSAD (LFI%JPNPDF), IMDESC, 
00036      S        INUMER, INPPIM, JREC
00037       INTEGER IPODPI, IFACTM, ILARPH, INALPP, INBPIR, INDIK1, INDIK2, J
00038       INTEGER INDIC1, INDIC2, INUMPD, INAPHY, IJ, IRGPIM, IRGPIF, IDEBSE
00039       INTEGER INDIS1, INDIS2, JSENS, ISENS, IREC, INUMAP, IRECX, INIMES
00040       INTEGER IRETOU, IRETIN
00041 C
00042       LOGICAL LDADON, LLSAUT, LLFILT, LLLOIN
00043 C
00044 #include "lficom2.h"
00045 #include "lficom_mt.h"
00046 C**
00047 C     1.  -  CONTROLES ET INITIALISATIONS.
00048 C-----------------------------------------------------------------------
00049 C
00050       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00051       IF (LHOOK) CALL DR_HOOK('LFIECX_MT',0,ZHOOK_HANDLE)
00052       IF (KRANG.LE.0.OR.KRANG.GT.LFI%JPNXFI) THEN
00053         INUMER=LFI%JPNIL
00054       ELSE
00055         INUMER=LFI%NUMERO(KRANG)
00056       ENDIF
00057 C
00058       IRETOU=0
00059 C
00060       IF (INUMER.EQ.LFI%JPNIL) THEN
00061         KREP=-14
00062         GOTO 1001
00063       ENDIF
00064 C
00065       INAPHY=0
00066       LLSAUT=.FALSE.
00067       INPPIM=LFI%NPPIMM(KRANG)
00068       IPODPI=LFI%NPODPI(KRANG)
00069       IFACTM=LFI%MFACTM(KRANG)
00070       ILARPH=LFI%JPLARD*IFACTM
00071       INALPP=LFI%JPNAPP*IFACTM
00072       INBPIR=LFI%MDES1D(IXM(LFI%JPNPIR,KRANG))
00073       LLLOIN=KREC.GT.LFI%MDES1D(IXM(LFI%JPNAPH,KRANG))
00074 C
00075       IF (LLLOIN) THEN
00076 C**
00077 C     2.  -  CAS OU L'ON ECRIT PLUS LOIN QUE LE DERNIER ARTICLE
00078 C            EFFECTIVEMENT ECRIT SUR LE FICHIER.
00079 C-----------------------------------------------------------------------
00080 C
00081         INDIK1=1
00082         INDIK2=LFI%JPNPDF
00083 C*
00084 C     2.1 -  ECRITURE D'EVENTUELS ARTICLES ENTRE LE DERNIER PRESENT
00085 C            SUR LE FICHIER, ET CELUI QUE L'ON DOIT ECRIRE.
00086 C-----------------------------------------------------------------------
00087 C
00088         DO 214 JREC=LFI%MDES1D(IXM(LFI%JPNAPH,KRANG))+1,KREC-1
00089 C
00090         IF (LLSAUT) THEN
00091           LLSAUT=.FALSE.
00092           GOTO 213
00093         ENDIF
00094 C
00095         INDIC1=INDIK1
00096         INDIC2=INDIK2
00097 C
00098         DO 211 J=INDIC1,INDIC2
00099         INUMPD=MOD (LFI%NDERPD(KRANG)+J,LFI%JPNPDF)
00100 C
00101         IF (LFI%NUMAPD(INUMPD,KRANG).EQ.JREC) THEN
00102           IF (J.EQ.INDIK1) INDIK1=INDIK1+1
00103           IF (J.EQ.INDIK2) INDIK2=INDIK2-1
00104           IF (LFI%LMISOP) WRITE (UNIT=LFI%NULOUT,FMT=*)
00105      S          '$$$ LFIECX - INUMPD= ',INUMPD,
00106      S          ', INDIK1= ', INDIK1,', INDIK2= ',INDIK2,' $$$'
00107 C
00108 C          ARTICLE PHYSIQUE TROUVE DANS LES PAGES DE DONNEES;
00109 C       IL S'AGIT DONC D'UNE PAGE DE DONNEES NON ENCORE ECRITE,
00110 C       ET FORCEMENT COMPLETE DANS CE CAS.
00111 C
00112           IF (.NOT.LFI%LECRPD(INUMPD,KRANG)
00113      S        .OR.LFI%NLONPD(INUMPD,KRANG).NE.ILARPH) THEN
00114             KREP=-16
00115             GOTO 1001
00116           ENDIF
00117 C
00118           INAPHY=JREC
00119           CALL LFIEDO_MT (LFI, KREP,INUMER,JREC,
00120      &                    LFI%MTAMPD(IXT(1,INUMPD,KRANG)),
00121      S                    LFI%NBWRIT(KRANG),IFACTM,IRETIN)
00122 C
00123           IF (IRETIN.EQ.1) THEN
00124             GOTO 903
00125           ELSEIF (IRETIN.NE.0) THEN
00126             GOTO 1001
00127           ENDIF
00128 C
00129           LFI%LECRPD(INUMPD,KRANG)=.FALSE.
00130           GOTO 213
00131         ELSEIF (LFI%NUMAPD(INUMPD,KRANG).LT.JREC) THEN
00132           IF (J.EQ.INDIK1) INDIK1=INDIK1+1
00133           IF (J.EQ.INDIK2) INDIK2=INDIK2-1
00134         ENDIF
00135 C
00136   211   CONTINUE
00137 C
00138 C        CAS OU L'ARTICLE N'A PAS ETE TROUVE DANS LES PAGES DE DONNEES;
00139 C        IL S'AGIT DONC D'UN ARTICLE D'INDEX "EXCEDENTAIRE", NON ENCORE
00140 C        ECRIT, ET EN FAIT IL Y A DEUX ARTICLES CONSECUTIFS A ECRIRE.
00141 C
00142         DO 212 J=1,INPPIM
00143 C
00144 C       ON COMMENCE EN FAIT LA RECHERCHE PAR LA DERNIERE P.P.I., CAR IL
00145 C       Y A PRATIQUEMENT TOUTES LES CHANCES QUE CE SOIT CELLE CHERCHEE.
00146 C       ( LA PREMIERE EST, PAR CONSTRUCTION, NON EXCEDENTAIRE )
00147 C
00148         IF (J.EQ.1) THEN
00149           IJ=IPODPI
00150         ELSEIF (J.EQ.IPODPI) THEN
00151           GOTO 212
00152         ELSE
00153           IJ=J
00154         ENDIF
00155 C
00156         IRGPIM=LFI%MRGPIM(IJ,KRANG)
00157         IRGPIF=LFI%MRGPIF(IRGPIM)
00158         IF (IRGPIF.LE.INBPIR) GOTO 212
00159         CALL LFIREC_MT (LFI, IRGPIF,KRANG,IREC)
00160 C
00161         IF (IREC.EQ.JREC) THEN
00162 C
00163           IF (.NOT.LFI%LECRPI(IRGPIM,1).OR.
00164      S        .NOT.LFI%LECRPI(IRGPIM,2)) THEN
00165             KREP=-16
00166             GOTO 1001
00167           ENDIF
00168 C
00169           INAPHY=JREC
00170           CALL LFIECC_MT (LFI, KREP,INUMER,JREC,
00171      S                    LFI%CNOMAR(IXC(1,IRGPIM)),
00172      S                    LFI%NBWRIT(KRANG),IFACTM,IRETIN)
00173 C
00174           IF (IRETIN.EQ.1) THEN
00175             GOTO 903
00176           ELSEIF (IRETIN.NE.0) THEN
00177             GOTO 1001
00178           ENDIF
00179 C
00180           INAPHY=JREC+1
00181           CALL LFIEDO_MT (LFI, KREP,INUMER,JREC+1,
00182      S                    LFI%MLGPOS(IXM(1,IRGPIM)),
00183      S                    LFI%NBWRIT(KRANG),IFACTM,IRETIN)
00184 C
00185           IF (IRETIN.EQ.1) THEN
00186             GOTO 903
00187           ELSEIF (IRETIN.NE.0) THEN
00188             GOTO 1001
00189           ENDIF
00190 C
00191           LFI%LECRPI(IRGPIM,1)=IJ.NE.IPODPI.OR.
00192      S                         LFI%NALDPI(KRANG).EQ.INALPP
00193           LFI%LECRPI(IRGPIM,2)=LFI%LECRPI(IRGPIM,1)
00194           LLSAUT=.TRUE.
00195           GOTO 213
00196         ENDIF
00197 C
00198   212   CONTINUE
00199 C
00200         WRITE (UNIT=LFI%NULOUT,FMT=*)
00201      S              '$$$ LFIECX - APRES ETIQUETTE 212, JREC= ',
00202      S              JREC,' NON TROUVE $$$'
00203         KREP=-16
00204         GOTO 1001
00205 C
00206   213   CONTINUE
00207 C
00208   214   CONTINUE
00209 C
00210         IDEBSE=2
00211 C
00212       ELSE
00213 C
00214 C       CAS OU L'ARTICLE PHYSIQUE A ECRIRE EXISTE DEJA SUR LE FICHIER.
00215 C
00216         IDEBSE=1
00217 C
00218       ENDIF
00219 C**
00220 C     3.  -  CAS "GENERAL" .
00221 C-----------------------------------------------------------------------
00222 C*
00223 C     3.1 -  RECHERCHE D'ARTICLES PHYSIQUES ADJACENTS A ECRIRE,
00224 C            PARMI LES PAGES DE DONNEES *COMPLETES* EXCLUSIVEMENT.
00225 C-----------------------------------------------------------------------
00226 C
00227       INDIS1=0
00228       INDIS2=LFI%JPNPDF-1
00229 C
00230       DO 313 JSENS=IDEBSE,2
00231       ISENS=2*JSENS-3
00232       INADJA(JSENS)=(LFI%JPNPDF+1)*(JSENS-1)
00233       IF (.NOT.LDADON.AND.JSENS.EQ.2) GOTO 320
00234       INDIK1=INDIS1
00235       INDIK2=INDIS2
00236       IREC=KREC
00237 C
00238   311 CONTINUE
00239       IREC=IREC+ISENS
00240       INDIC1=INDIK1
00241       INDIC2=INDIK2
00242 C
00243       DO 312 J=INDIC1,INDIC2
00244       INUMAP=LFI%NUMAPD(J,KRANG)
00245       LLFILT=LFI%LECRPD(J,KRANG).AND.LFI%NLONPD(J,KRANG).EQ.ILARPH
00246 C
00247       IF (LLFILT.AND.INUMAP.EQ.IREC) THEN
00248         INADJA(JSENS)=INADJA(JSENS)-ISENS
00249         IPOSAD(INADJA(JSENS))=J
00250         IF (J.EQ.INDIK1) INDIK1=INDIK1+1
00251         IF (J.EQ.INDIK2) INDIK2=INDIK2-1
00252         IF (J.EQ.INDIS1) INDIS1=INDIS1+1
00253         IF (J.EQ.INDIS2) INDIS2=INDIS2-1
00254         GOTO 311
00255       ELSEIF(.NOT.LLFILT.OR.INUMAP.EQ.KREC
00256      S       .OR.IABS (INUMAP-KREC).GT.LFI%JPNPDF) THEN
00257         IF (J.EQ.INDIS1) INDIS1=INDIS1+1
00258         IF (J.EQ.INDIS2) INDIS2=INDIS2-1
00259       ELSEIF(INUMAP*ISENS.LT.IREC*ISENS) THEN
00260         IF (J.EQ.INDIK1) INDIK1=INDIK1+1
00261         IF (J.EQ.INDIK2) INDIK2=INDIK2-1
00262       ENDIF
00263 C
00264   312 CONTINUE
00265 C
00266   313 CONTINUE
00267 C*
00268 C     3.2 -  ECRITURE DES (EVENTUELS) ARTICLES ADJACENTS DE LFI%NUMERO
00269 C            *INFERIEUR* A CELUI QUE LE SOUS-PROGRAMME DOIT ECRIRE.
00270 C-----------------------------------------------------------------------
00271 C
00272   320 CONTINUE
00273 C
00274       IF (.NOT.LLLOIN) THEN
00275         IREC=KREC-INADJA(1)
00276 C
00277         DO 321 J=INADJA(1),1,-1
00278         IJ=IPOSAD(J)
00279         INAPHY=IREC
00280         CALL LFIEDO_MT (LFI, KREP,INUMER,IREC,
00281      S                  LFI%MTAMPD(IXT(1,IJ,KRANG)),
00282      S                  LFI%NBWRIT(KRANG),IFACTM,IRETIN)
00283 C
00284         IF (IRETIN.EQ.1) THEN
00285           GOTO 903
00286         ELSEIF (IRETIN.NE.0) THEN
00287           GOTO 1001
00288         ENDIF
00289 C
00290         LFI%LECRPD(IJ,KRANG)=.FALSE.
00291         IREC=IREC+1
00292   321   CONTINUE
00293 C
00294       ENDIF
00295 C*
00296 C     3.3 -  ECRITURE DE L'ARTICLE DEMANDE.
00297 C-----------------------------------------------------------------------
00298 C
00299       INAPHY=KREC
00300       CALL LFIEDO_MT (LFI, KREP,INUMER,KREC,KZONE,
00301      S                LFI%NBWRIT(KRANG),IFACTM,IRETIN)
00302 C
00303       IF (IRETIN.EQ.1) THEN
00304         GOTO 903
00305       ELSEIF (IRETIN.NE.0) THEN
00306         GOTO 1001
00307       ENDIF
00308 C
00309 C*
00310 C     3.4 -  ECRITURE DES (EVENTUELS) ARTICLES ADJACENTS DE LFI%NUMERO
00311 C            *SUPERIEUR* A CELUI QUE LE SOUS-PROGRAMME DOIT ECRIRE.
00312 C-----------------------------------------------------------------------
00313 C
00314       IREC=KREC
00315 C
00316       DO 341 J=LFI%JPNPDF,INADJA(2),-1
00317       IREC=IREC+1
00318       IJ=IPOSAD(J)
00319       INAPHY=IREC
00320       CALL LFIEDO_MT (LFI, KREP,INUMER,IREC,LFI%MTAMPD(IXT(1,IJ,KRANG)),
00321      S             LFI%NBWRIT(KRANG),IFACTM,IRETIN)
00322 C
00323       IF (IRETIN.EQ.1) THEN
00324         GOTO 903
00325       ELSEIF (IRETIN.NE.0) THEN
00326         GOTO 1001
00327       ENDIF
00328 C
00329       LFI%LECRPD(IJ,KRANG)=.FALSE.
00330   341 CONTINUE
00331 C
00332       IRECX=KREC+LFI%JPNPDF-INADJA(2)+1
00333 C**
00334 C     4.  -  DANS LE CAS D'UN ARTICLE DE DONNEES, MISE A JOUR DU LFI%NUMERO
00335 C            MAXI D'ENREGISTREMENT DE CES ARTICLES PHYSIQUES, ET DANS
00336 C            TOUS LES CAS MISE A JOUR DU NOMBRE D'ARTICLES PHYSIQUES.
00337 C-----------------------------------------------------------------------
00338 C
00339       IF (LDADON) THEN
00340         IMDESC=LFI%MDES1D(IXM(LFI%JPAXPD,KRANG))
00341         LFI%MDES1D(IXM(LFI%JPAXPD,KRANG))=MAX0 (IMDESC,IRECX)
00342       ENDIF
00343 C
00344       IMDESC=LFI%MDES1D(IXM(LFI%JPNAPH,KRANG))
00345       LFI%MDES1D(IXM(LFI%JPNAPH,KRANG))=MAX0 (IMDESC,IRECX)
00346       KREP=0
00347       GOTO 1001
00348 C**
00349 C     9.  - CI-DESSOUS, ETIQUETTE DE BRANCHEMENT EN CAS D'ERREUR ECR.
00350 C           ON FORCE LE CODE DE RETOUR A ETRE POSITIF.
00351 C-----------------------------------------------------------------------
00352 C
00353   903 CONTINUE
00354       IRETOU=1
00355       CLACTI='WRITE'
00356       KREP=IABS (KREP)
00357       LFI%NUMAPH(KRANG)=INAPHY
00358 C**
00359 C    10.  -  PHASE TERMINALE : MESSAGERIE INTERNE EVENTUELLE,
00360 C            VIA LE SOUS-PROGRAMME "LFIEMS", PUIS RETOUR.
00361 C-----------------------------------------------------------------------
00362 C
00363  1001 CONTINUE
00364       LLFATA=LLMOER (KREP,KRANG)
00365 C
00366       IF (KREP.EQ.0) THEN
00367         KRETIN=0
00368       ELSEIF (KREP.GT.0) THEN
00369         KRETIN=IRETOU
00370       ELSE
00371         KRETIN=3
00372       ENDIF
00373 C
00374       IF (LFI%LMISOP.OR.LLFATA) THEN
00375         INIMES=2
00376         CLNSPR='LFIECX'
00377         WRITE (UNIT=CLMESS,FMT='(''KREP='',I5,'', KRANG='
00378 ',I3,     S       '', KREC='',I6,'', LDADON='',L2,'', KRETIN='',I2)')
00379      S    KREP,KRANG,KREC,LDADON,KRETIN
00380         CALL LFIEMS_MT (LFI, INUMER,INIMES,KREP,.FALSE.,CLMESS,
00381      S                  CLNSPR,CLACTI)
00382       ENDIF
00383 C
00384       IF (LHOOK) CALL DR_HOOK('LFIECX_MT',1,ZHOOK_HANDLE)
00385       END
00386