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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFIPXA_MT (LFI, KREP, KNUMER, CDNOMA, CDSTRU, CDSUIV,
00003      S                    KLSUIV )
00004       USE LFIMOD, ONLY : LFICOM
00005       USE PARKIND1, ONLY : JPRB
00006       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00007 C****
00008 C        Sous-programme Preparatoire a l'eXport d'un Article d'un
00009 C     fichier LFI vers un systeme a priori different.
00010 C
00011 C     Il s'agit, en l'occurrence, de decrire la structure interne
00012 C     de cet article en termes de types de variables.  
00013 C**
00014 C    ARGUMENTS : KREP   (Sortie) ==> Code-Reponse du sous-programme;
00015 C                KNUMER (Entree) ==> Numero d'Unite Logique associe;
00016 C                CDNOMA (Entree) ==> Nom de l'article decrit;
00017 C                CDSTRU (Entree) ==> Structure interne de cet article;
00018 C                CDSUIV (Sortie) ==> Nom de l'article suivant sur le
00019 C                                    fichier, s'il en existe;
00020 C                KLSUIV (Sortie) ==> Longueur de cet article.
00021 C
00022 C     (s'il n'y a pas d'article suivant, on retourne CDSUIV=' ' et
00023 C      KLSUIV=0)
00024 C
00025 C     Les syntaxes autorisees pour CDSTRU sont decrites dans le sous-
00026 C     programmes *LFIDST*.
00027 C     
00028 #ifndef f77
00029 #include "precision.h"
00030 #endif
00031 C
00032       TYPE(LFICOM) :: LFI
00033       CHARACTER CDNOMA*(*), CDSUIV*(*), CDSTRU*(*)
00034       CHARACTER*(LFI%JPNCPN) CLNOMA, CLSUIV, CLSTRU
00035 C
00036       INTEGER KREP, KNUMER, KLSUIV
00037       INTEGER ILONEX, ILCLNO, ILCDNO, IRANMX, IDECBL, IPOSBL, ILCDST
00038       INTEGER IRANG, IREP, INBALO, J, IRANIE, INIMES, IARTEX
00039       INTEGER IRGPIM, IRGPIF, IARTIC, IRETIN, ILCDSU, ILCLSU, ILCLST
00040       INTEGER ILUSTR
00041 C
00042       LOGICAL LLVERF, LLOUVR, LLEXUL
00043 C
00044 #include "lficom2.h"
00045 #include "lficom_mt.h"
00046 C**
00047 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
00048 C-----------------------------------------------------------------------
00049 C
00050 C        Appel legerement anticipe a LFINUM, garantissant l'initialisa-
00051 C     tion des variables globales du logiciel a la 1ere utilisation.
00052 C
00053       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00054       IF (LHOOK) CALL DR_HOOK('LFIPXA_MT',0,ZHOOK_HANDLE)
00055       CALL LFINUM_MT (LFI, KNUMER,IRANG)
00056       IREP=0
00057       LLVERF=.FALSE.
00058       ILCDNO=LEN (CDNOMA)
00059       ILCDSU=LEN (CDSUIV)
00060       ILCDST=LEN (CDSTRU)
00061       CLNOMA=' '
00062       ILCLNO=1
00063       CLSTRU=' '
00064       ILCLST=1
00065       CLSUIV=' '
00066       ILCLSU=1
00067       KLSUIV=0
00068 C
00069       IF (ILCDNO.LE.0) THEN
00070         IREP=-15
00071         CLNOMA=LFI%CHINCO(:LFI%JPNCPN)
00072         ILCLNO=LFI%JPNCPN
00073       ELSEIF (CDNOMA.EQ.' ') THEN
00074         IREP=-18
00075       ENDIF
00076 C
00077       IF (ILCDSU.LE.0) THEN
00078         IREP=-15
00079         CLSUIV=LFI%CHINCO(:LFI%JPNCPN)
00080         ILCLSU=LFI%JPNCPN
00081       ENDIF
00082 C
00083       IF (ILCDST.LE.0) THEN
00084         IREP=-15
00085         CLSTRU=LFI%CHINCO(:LFI%JPNCPN)
00086         ILCLST=LFI%JPNCPN
00087       ELSEIF (CDSTRU.EQ.' ') THEN
00088         IREP=-39
00089       ENDIF
00090 C
00091       IF (IREP.NE.0) THEN
00092         GOTO 1001
00093       ELSE
00094         CDSUIV=' '
00095       ENDIF
00096 C
00097 C        Recherche de la longueur "utile" du nom d'article specifie.
00098 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00099 C
00100       IDECBL=0
00101 C
00102   101 CONTINUE
00103       IPOSBL=IDECBL+INDEX (CDNOMA(IDECBL+1:),' ')
00104 C
00105       IF (IPOSBL.LE.IDECBL) THEN
00106         ILCLNO=ILCDNO
00107       ELSEIF (CDNOMA(IPOSBL:).EQ.' ') THEN
00108         ILCLNO=IPOSBL-1
00109       ELSE
00110         IDECBL=IPOSBL
00111         GOTO 101
00112       ENDIF
00113 C
00114       IF (ILCLNO.LE.LFI%JPNCPN) THEN
00115         CLNOMA=CDNOMA(:ILCLNO)
00116       ELSE
00117         CLNOMA=CDNOMA(:LFI%JPNCPN)
00118         ILCLNO=LFI%JPNCPN
00119         IREP=-15
00120         GOTO 1001
00121       ENDIF
00122 C
00123 C        Recherche de la longueur "utile" de la structure specifiee.
00124 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00125 C
00126       IDECBL=0
00127 C
00128   102 CONTINUE
00129       IPOSBL=IDECBL+INDEX (CDSTRU(IDECBL+1:),' ')
00130 C
00131       IF (IPOSBL.LE.IDECBL) THEN
00132         ILUSTR=ILCDST
00133       ELSEIF (CDSTRU(IPOSBL:).EQ.' ') THEN
00134         ILUSTR=IPOSBL-1
00135       ELSE
00136         IDECBL=IPOSBL
00137         GOTO 102
00138       ENDIF
00139 C
00140       ILCLST=MIN0 (ILCLST,ILUSTR)
00141 C
00142       IF (IRANG.EQ.0) THEN
00143         IREP=-1
00144         GOTO 1001
00145       ENDIF
00146 C
00147        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'ON')
00148       LLVERF=LFI%LMULTI
00149       IRANIE=LFI%NEXPOR(IRANG)
00150 C
00151       IF (IRANIE.LE.0) THEN
00152         IREP=-38
00153         CLACTI='EXPORT'
00154         GOTO 1001
00155       ENDIF
00156 C
00157       IRANMX=LFI%NRCFMX(IRANIE)
00158       IARTEX=0
00159       ILONEX=0
00160       INBALO=LFI%MDES1D(IXM(LFI%JPNALO,IRANG))
00161 
00162       IF (INBALO.NE.0) THEN
00163 C**
00164 C     2.  -  EXPLORATION DES (PAIRES DE) PAGES ET ARTICLES D'INDEX,
00165 C            A LA RECHERCHE DE L'ARTICLE LOGIQUE DEMANDE.
00166 C-----------------------------------------------------------------------
00167 C
00168         CALL LFIRAN_MT (LFI, IREP,IRANG,CLNOMA(:ILCLNO),IRGPIM,
00169      S                  IARTEX,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       ENDIF
00180 C
00181       IF (IARTEX.EQ.0) THEN
00182         IREP=-20
00183         CLACTI=CLNOMA(:ILCLNO)
00184         GOTO 1001
00185       ENDIF
00186 C
00187 C        ON COMPLETE LES CARACTERISTIQUES DE L'ARTICLE.
00188 C
00189       IRGPIF=LFI%MRGPIF(IRGPIM)
00190 C
00191       IF (.NOT.LFI%LPHASP(IRGPIM)) THEN
00192 C
00193         CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPIM,IRETIN)
00194 C
00195         IF (IRETIN.EQ.1) THEN
00196           GOTO 903
00197         ELSEIF (IRETIN.EQ.2) THEN
00198           GOTO 904
00199         ELSEIF (IRETIN.NE.0) THEN
00200           GOTO 1001
00201         ENDIF
00202 C
00203       ENDIF
00204 C
00205       ILONEX=LFI%MLGPOS(IXM(2*IARTEX-1,IRGPIM))
00206 C**
00207 C     8.  -  RECHERCHE DE L'ARTICLE LOGIQUE DE DONNEES SUIVANT.
00208 C-----------------------------------------------------------------------
00209 C
00210       CALL LFICAX_MT (LFI, IREP,IRANG,IRGPIM,IARTIC,IRETIN)
00211 C
00212       IF (IRETIN.EQ.1) THEN
00213         GOTO 903
00214       ELSEIF (IRETIN.EQ.2) THEN
00215         GOTO 904
00216       ELSEIF (IRETIN.NE.0.OR.IARTIC.EQ.0) THEN
00217         GOTO 1001
00218       ENDIF
00219 C
00220       IRGPIF=LFI%MRGPIF(IRGPIM)
00221 C
00222       IF (.NOT.LFI%LPHASP(IRGPIM)) THEN
00223 C
00224         CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPIM,IRETIN)
00225 C
00226         IF (IRETIN.EQ.1) THEN
00227           GOTO 903
00228         ELSEIF (IRETIN.EQ.2) THEN
00229           GOTO 904
00230         ELSEIF (IRETIN.NE.0) THEN
00231           GOTO 1001
00232         ENDIF
00233 C
00234       ENDIF
00235 C
00236       KLSUIV=LFI%MLGPOS(IXM(IARTIC,IRGPIM))
00237       CLSUIV=LFI%CNOMAR(IXC(IARTIC,IRGPIM))
00238 C
00239 C        Recherche de la longueur "utile" du nom d'article.
00240 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00241 C
00242       IDECBL=0
00243 C
00244   811 CONTINUE
00245       IPOSBL=IDECBL+INDEX (CLSUIV(IDECBL+1:),' ')
00246 C
00247       IF (IPOSBL.LE.IDECBL) THEN
00248         ILCLSU=LFI%JPNCPN
00249       ELSEIF (CLSUIV(IPOSBL:).EQ.' ') THEN
00250         ILCLSU=IPOSBL-1
00251       ELSE
00252         IDECBL=IPOSBL
00253         GOTO 811
00254       ENDIF
00255 C
00256       IF (ILCDSU.GE.ILCLSU) THEN
00257         CDSUIV=CLSUIV(:ILCLNO)
00258       ELSE
00259         IREP=-24
00260         CLACTI=CLSUIV
00261         GOTO 1001
00262       ENDIF
00263 C
00264       GOTO 1001
00265 C**
00266 C     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
00267 C-----------------------------------------------------------------------
00268 C
00269   901 CONTINUE
00270       CLACTI='INQUIRE'
00271       GOTO 909
00272 C
00273   902 CONTINUE
00274       CLACTI='OPEN'
00275       GOTO 909
00276 C
00277   903 CONTINUE
00278       CLACTI='WRITE'
00279       GOTO 909
00280 C
00281   904 CONTINUE
00282       CLACTI='READ'
00283 C
00284   909 CONTINUE
00285 C
00286 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
00287 C
00288       IREP=IABS (IREP)
00289 C**
00290 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00291 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
00292 C-----------------------------------------------------------------------
00293 C
00294  1001 CONTINUE
00295       KREP=IREP
00296       LLFATA=LLMOER (IREP,IRANG)
00297 C
00298       IF (IRANG.NE.0) THEN
00299         LFI%NDEROP(IRANG)=22
00300         LFI%NDERCO(IRANG)=IREP
00301          IF (LLVERF) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'OFF')
00302       ENDIF
00303 C
00304       IF (LLFATA.OR.IXNIMS (IRANG).EQ.2) THEN
00305         INIMES=2
00306       ELSE
00307         IF (LHOOK) CALL DR_HOOK('LFIPXA_MT',1,ZHOOK_HANDLE)
00308         RETURN
00309       ENDIF
00310 C
00311       CLNSPR='LFIPXA'
00312       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00313 ',I3,     S       '', CDNOMA='''''',A,'''''', CDSTRU='''''
00314 ',A,     S       '''''', CDSUIV='''''',A,'''''', KLSUIV='',I7)')
00315      S     KREP,KNUMER,CLNOMA(:ILCLNO),CLSTRU(:ILCLST),
00316      S     CLSUIV(:ILCDSU),KLSUIV
00317       CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00318      S                CLNSPR,CLACTI)
00319 C
00320       IF (LHOOK) CALL DR_HOOK('LFIPXA_MT',1,ZHOOK_HANDLE)
00321       END
00322