lfiefr.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
! Sep-2012 P. Marguinaud Add FLUSH stdout
SUBROUTINE lfiefr_fort                                      &
&                     (lfi, knumer, knimes, kcode, ldfata,  &
&                      cdmess, cdnspr, cdacti )
USE lfimod, ONLY : lficom
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE sdl_mod   , ONLY : sdl_srlabort
USE lfi_precision
IMPLICIT NONE
!****
!        CE SOUS-PROGRAMME EST CHARGE DE FAIRE L'IMPRESSION DES MESSAGES
!     STANDARD EMIS PAR LE LOGICIEL DE FICHIERS INDEXES LFI, EN FAISANT
!     SI BESOIN EST L'"ABORT" DU PROGRAMME .
!        Les messages lies au mode "mise au point" sont emis directement
!     par les sous-programmes concernes.
!
!        Ce sous-programme est la V.O. (Version Originale, francaise),
!     et est appele par le sous-programme "chapeau" LFIEMS.
!     Pour la version anglaise, voir LFIENG.
!     ( For english version see subroutine LFIENG )
!**
!        ARGUMENTS : KNUMER ==> Numero eventuel de l'Unite Logique;
!        ( tous                 ( si LFI%JPNIL ==> pas d'Unite Logique )
!         d'Entree ) KNIMES ==> Niveau (0,1,2) du Message;
!                    KCODE  ==> Code correspondant a l'action en cause;
!                    LDFATA ==> Vrai si on doit avorter le programme;
!                    CDMESS ==> Si KNIMES#0, Message a emettre;
!                    CDNSPR ==> Nom du sous-programme appelant LFIEMS;
!                    CDACTI ==> Nom de l'action d'entree/sortie FORTRAN
!                               si KCODE >0), sinon fourre-tout (!) .
!*
!     !----------------------------------------------------------------!
!     ! TABLE DES VALEURS POSSIBLES DES CODES-REPONSES DU LOGICIEL LFI !
!     !----------------------------------------------------------------!
!
!-----------------------------------------------------------------------
!      0 ==> Aucune erreur n'a ete detectee, tout est OK.
!-----------------------------------------------------------------------
! valeur ==> Il s'agit (de la valeur absolue) du code-reponse FORTRAN
! positive   d'une instruction OPEN, READ, WRITE, CLOSE ou INQUIRE; pour
!            le sens exact voir le manuel de reference du constructeur.
!-----------------------------------------------------------------------
!     -1 ==> Unite Logique non ouverte pour le logiciel.
!-----------------------------------------------------------------------
!     -2 ==> Valeur d'un "NIVEAU" hors plage [0-2] .
!-----------------------------------------------------------------------
!     -3 ==> Option de verrou erronee (s/p a usage interne "LFIVER") .
!-----------------------------------------------------------------------
!     -4 ==> Changement explicite de mode Multi-Taches avec au moins une
!            unite logique ouverte-risque de problemes (s/p "LFIINI") .
!-----------------------------------------------------------------------
!     -5 ==> Unite Logique deja ouverte (LFIOUV, LFIAFM, LFISFM) .
!-----------------------------------------------------------------------
!     -6 ==> Pas assez de place dans les tables pour ouvrir l'Unite
!            Logique demandee (LFIOUV) .
!-----------------------------------------------------------------------
!     -7 ==> Argument illicite de "STATUS" pour l'instruction FORTRAN
!            "OPEN" (LFIOUV) .
!-----------------------------------------------------------------------
!     -8 ==> Incompatibilite entre "LDNOMM" et "CDSTTO" (LFIOUV) :
!            un fichier de "STATUS" 'OLD' ou 'NEW' doit etre nomme .
!            (CE CODE-REPONSE N'A PLUS DE SENS ACTUELLEMENT)
!-----------------------------------------------------------------------
!     -9 ==> Incompatibilite entre le "STATUS" 'NEW' ou 'OLD' et (respe-
!            ctivement) l'existence ou non du fichier (LFIOUV) .
!-----------------------------------------------------------------------
!    -10 ==> Le fichier considere n'est pas un fichier de type LFI, ou
!            ne peut pas etre traite par cette version du logiciel.
!            (LFIOUV)
!-----------------------------------------------------------------------
!    -11 ==> Fichier non ferme apres une modification (LFIOUV): cette
!            erreur n'est pas fatale si "LDERFA" est .FALSE., mais alors
!            integrite et coherence des donnees ne sont pas garanties.
!            Noter qu'une fois qu'un fichier a ce type de probleme, ce
!            code-reponse restera meme apres modification ulterieure.
!-----------------------------------------------------------------------
!    -12 ==> Fichier de "STATUS" 'OLD' mais erreur sur la lecture du
!            premier article physique du fichier (LFIOUV) .
!-----------------------------------------------------------------------
!    -13 ==> Fichier deja ouvert pour une autre unite logique LFI.
!            (LFIOUV)
!-----------------------------------------------------------------------
!    -14 ==> Argument d'appel de type ENTIER incorrect (souvent negatif)
!-----------------------------------------------------------------------
!    -15 ==> Argument d'appel de type CARACTERE incorrect (longueur).
!-----------------------------------------------------------------------
!    -16 ==> Incoherence Tables, Fichier, appels s/p internes, logiciel.
!            CETTE ERREUR NE PEUT PAS ETRE FILTREE. EST TOUJOURS FATALE.
!-----------------------------------------------------------------------
!    -17 ==> Trop d'articles logiques sur le fichier pour un de plus.
!            (par articles logiques on entend ceux lisibles par l'utili-
!             sateur, mais aussi les trous reperes dans l'index... qui
!             sont crees lors de reecritures d'articles de donnees ne
!             pouvant se faire sur place, et lors de suppression d'arti-
!             cles; ces trous peuvent etre "recycles" - LFIECR)
!-----------------------------------------------------------------------
!    -18 ==> Nom d'Article logique compose uniquement de BLANCS illicite
!            (pour le fonctionnement interne du logiciel LFI,
!             les trous d'index sont reperes par un nom d'article blanc)
!-----------------------------------------------------------------------
!    -19 ==> Un fichier ouvert avec le "STATUS" 'SCRATCH' ne peut pas
!            etre conserve: "CDSTTC" a 'KEEP' est illicite (LFIFER) .
!            si cette erreur n'est pas fatale, alors on execute un
!            "CLOSE" FORTRAN sans parametre "STATUS", de la meme maniere
!            que lorsque "CDSTTC" n'est ni a 'KEEP' ni a 'DELETE'.
!-----------------------------------------------------------------------
!    -20 ==> L'article logique demande n'existe pas dans le fichier.
!            (LFILEC, LFIREN, LFISUP)
!-----------------------------------------------------------------------
!    -21 ==> L'article logique demande est PLUS LONG sur le fichier;
!            si cette erreur n'est pas fatale, le resultat est une
!            lecture PARTIELLE de l'article, a la longueur demandee.
!            (LFILAP, LFILAS, LFILEC)
!-----------------------------------------------------------------------
!    -22 ==> L'article logique demande est PLUS COURT sur le fichier;
!            meme si cette erreur n'est pas fatale, AUCUNE LECTURE DE
!            DONNEES N'EST FAITE (LFILAP, LFILAS, LFILEC) .
!-----------------------------------------------------------------------
!    -23 ==> Il n'y a pas ou plus d'article "SUIVANT" a lire (LFILAS) .
!-----------------------------------------------------------------------
!    -24 ==> La variable caractere donnee en argument d'appel de sortie
!            est TROP COURTE pour y stocker le NOM de l'article, meme en
!            supprimant d'eventuels caracteres blancs en fin de nom.
!            (LFICAP, LFICAS, LFILAP, LFILAS)
!-----------------------------------------------------------------------
!    -25 ==> Le nouveau nom de l'article logique est (deja) celui d'un
!            autre article logique du fichier (LFIREN).
!-----------------------------------------------------------------------
!    -26 ==> Il n'y a pas ou plus d'article "PRECEDENT" a lire (LFILAP).
!-----------------------------------------------------------------------
!    -27 ==> Espace CONTIGU insuffisant dans les tables pour gerer le
!            fichier "multiple" demande (LFIOUV) .
!-----------------------------------------------------------------------
!    -28 ==> Facteur multiplicatif (de la longueur d'article physique
!            elementaire) trop grand pour la configuration du logiciel.
!            (LFIOUV, LFIAFM, LFIFMD)
!-----------------------------------------------------------------------
!    -29 ==> Pas assez de place dans les tables pour definir le facteur
!            multiplicatif a associer a l'Unite Logique (LFIAFM) .
!-----------------------------------------------------------------------
!    -30 ==> Numero d'Unite Logique FORTRAN illicite.
!-----------------------------------------------------------------------
!    -31 ==> Numero d'Unite Logique sans facteur multiplicatif predefini
!            (LFISFM)
!-----------------------------------------------------------------------
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) KNUMER, KNIMES, KCODE, ILDMES 
INTEGER (KIND=JPLIKB) ILBLAN, INLNOM, INUMER
INTEGER (KIND=JPLIKB) ILACTI, ILACT2 
INTEGER (KIND=JPLIKB) ILNSPR, ILMESU, IJL, J, IJ
INTEGER (KIND=JPLIKB) INBALO, ILMESA, INLIGN, IDECAL
!
LOGICAL LDFATA
!
CHARACTER(LEN=*)  CDNSPR
CHARACTER(LEN=6)  CLJOLI
CHARACTER(LEN=*)  CDMESS
CHARACTER(LEN=80) CLMESA
CHARACTER(LEN=*)  CDACTI
!
CHARACTER(LEN=LFI%JPLMES) CLMESS

!**
!     1.  -  INITIALISATIONS.
!-----------------------------------------------------------------------
!
!        Recherche de la longueur "utile" de l'argument CDACTI.
!        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIEFR_FORT',0,zhook_handle)
ilacti=int(len(trim(cdacti)), jplikb)
!
ilact2=min(ilacti,lfi%JPNCPN)
ilacti=min(ilact2,8_jplikb )
ilnspr=min(int(len(cdnspr), jplikb),lfi%JPLSPX)
!
!        Prefixe (et eventuellement suffixe) pour le(s) message(s).
!
IF (ldfata) THEN
  cljoli=' *****'
ELSEIF (knimes.EQ.0.OR.kcode.NE.0) THEN
  cljoli=' */*/*'
ELSE
  cljoli=' /////'
ENDIF
!
IF (knimes.NE.0) THEN
!**
!     2.  -  ON IMPRIME LE MESSAGE PREPARE PAR LE S/P APPELLANT LFIEMS.
!-----------------------------------------------------------------------
!
  ilmesu=min(int(len(clmess), jplikb)  &
&             -int(len(cljoli), jplikb)  &
&             -ilnspr-4,                   &
&              int(len(cdmess), jplikb))
  clmess=cljoli//' '//cdnspr(1:ilnspr)//' - '// &
&             cdmess(1:ilmesu)
  WRITE (unit=lfi%NULOUT,fmt='(A)') trim(clmess)
ENDIF
!
IF (knimes.EQ.0.OR.ldfata) THEN
!**
!     3.  -  CONSTITUTION D'UN MESSAGE "AD HOC", EN FONCTION DE *KCODE*.
!-----------------------------------------------------------------------
!
!     En preambule, on cherche si l'unite logique concernee correspond
!     ou non a une unite logique ouverte pour le logiciel LFI.
!
  IF (knumer.EQ.lfi%JPNIL) THEN
    ijl=0
  ELSE
!
    DO j=1,lfi%NBFIOU
    ijl=lfi%NUMIND(j)
    IF (knumer.EQ.lfi%NUMERO(ijl)) GOTO 302
    ENDDO
!
    ijl=0
  ENDIF
!
302 CONTINUE
!
  IF (kcode.GT.0) THEN
!
    IF ((cdacti.EQ.'READ'.OR.cdacti.EQ.'WRITE') &
&        .AND.lfi%NUMAPH(ijl).GT.0) THEN
      WRITE (unit=clmess,fmt='(''ERREUR "'',A,''"'',I7,  &
&             '',UNITE'',I3,'',NUM.ART'',I6,'',*'',I6,    &
&             '' MOTS'')') cdacti(1:ilacti),kcode,knumer, &
&                           lfi%NUMAPH(ijl),              &
&                           lfi%JPLARD*lfi%MFACTM(ijl)
    ELSE
      WRITE (unit=clmess,                                         &
&             fmt='(''ERREUR "'',A,''" FORTRAN, CODE=''            &
&             ,I7,'', UNITE='',I3)') cdacti(1:ilacti),kcode,knumer
    ENDIF
!
  ELSEIF (kcode.EQ.-1) THEN
    WRITE (unit=clmess,fmt='(''UNITE LOGIQUE'',I3,         &
&           '' NON OUVERTE POUR LE LOGICIEL LFI'')') knumer
!
  ELSEIF (kcode.EQ.-2) THEN
!
    IF (knumer.EQ.lfi%JPNIL) THEN
      clmess='PARAMETRE DE NIVEAU "KNIVAU" HORS PLAGE [0-2]'
    ELSE
      WRITE (unit=clmess,fmt=                                      &
&   '(''NIVEAU DE MESSAGERIE HORS PLAGE [0-2], UNITE'',I3)') knumer
    ENDIF
!
  ELSEIF (kcode.EQ.-3) THEN
    ildmes=min(8_jplikb ,int(len(cdmess), jplikb))
    clmess='ACTION '''//cdmess(1:ildmes)   &
&           //''' INCONNUE SUR LES VERROUS'
!
  ELSEIF (kcode.EQ.-4) THEN
    clmess='CHANGEMENT MODE MULTI-TACHES AVEC ' &
&               //'UNITE(S) OUVERTE(S)'
!
  ELSEIF (kcode.EQ.-5) THEN
    WRITE (unit=clmess,fmt='(''UNITE LOGIQUE'',I3,                &
&           '' DEJA OUVERTE POUR LFI - NE DEVRAIT PAS.'')') knumer
!
  ELSEIF (kcode.EQ.-6) THEN
    WRITE (unit=clmess,fmt='(I3,'' ENTREES,'',            &
&    '' PLUS ASSEZ DE PLACE DANS LES TABLES, UNITE'',I3)') &
&    lfi%JPNXFI,knumer
!
  ELSEIF (kcode.EQ.-7) THEN
    WRITE (unit=clmess,fmt='(''STATUS FORTRAN '''''',A,          &
&           '''''' INCONNU, UNITE'',I3)') cdacti(1:ilacti),knumer
!
  ELSEIF (kcode.EQ.-8) THEN
    WRITE (unit=clmess,                                            &
&           fmt='(''L''''UNITE'',I3,'' DE STATUS ''''''             &
&,A,'''''' DOIT AVOIR UN NOM EXPLICITE'')') knumer,cdacti(1:ilacti)
!
  ELSEIF (kcode.EQ.-9) THEN
!
  IF (cdacti.EQ.'OLD') THEN
    WRITE (unit=clmess,fmt=                                      &
&'(''STATUS ''''OLD'''' MAIS LE FICHIER N''''EXISTE PAS, UNITE'', &
&      I3)') knumer
  ELSE
    ilblan=int(index(cdacti(1:ilacti),' '), jplikb)
    IF (ilblan.GT.1) ilacti=ilblan-1
    WRITE (unit=clmess,fmt=                                      &
&'(''STATUS '''''',A,'''''' MAIS LE FICHIER EXISTE DEJA, UNITE'', &
&  I3)') cdacti(1:ilacti),knumer
  ENDIF
!
  ELSEIF (kcode.EQ.-10) THEN
    WRITE (unit=clmess,fmt='(''INCOMPATIBILITE'',      &
&           '' FICHIER / LOGICIEL, UNITE'',I3)') knumer
!
  ELSEIF (kcode.EQ.-11) THEN
    WRITE (unit=clmess,                               &
&           fmt='(''UNITE'',I3,'' NON FERMEE APRES '', &
&           ''LA DERNIERE MODIFICATION'')') knumer
!
  ELSEIF (kcode.EQ.-12) THEN
    WRITE (unit=clmess,fmt='(''UNITE'',I3,                       &
&  '' DE STATUS ''''OLD'''' - ERREUR LECTURE PREMIER ARTICLE'')') &
&       knumer
!
  ELSEIF (kcode.EQ.-13) THEN
    inlnom=1
    inumer=lfi%JPNIL
!
    DO j=1,lfi%NBFIOU
    ij=lfi%NUMIND(j)
!
    IF (cdacti.EQ.lfi%CNOMFI(ij)) THEN
      inumer=lfi%NUMERO(ij)
      inlnom=min(lfi%NLNOMF(ij),int(len(clmess), jplikb)-3)
      GOTO 132
    ENDIF
!
    ENDDO
!
132 CONTINUE
    clmess=' '''//cdacti(1:inlnom)//''''
    WRITE (unit=lfi%NULOUT,fmt='(A)') trim(clmess)
    WRITE (unit=clmess,fmt='(''UNITE'',I3,'' - FICHIER '',     &
&           ''DEJA OUVERT POUR L''''UNITE'',I3)') knumer,inumer
!
  ELSEIF (kcode.EQ.-14) THEN
!
    IF (cdnspr.EQ.'LFIECR'.OR.cdnspr.EQ.'LFILEC'.OR.   &
&        cdnspr.EQ.'LFILAS'.OR.cdnspr.EQ.'LFILAP') THEN
      WRITE (unit=clmess,fmt=                                 &
&   '(''LONGUEUR D''''ARTICLE INCORRECTE, UNITE'',I3)') knumer
    ELSEIF (knumer.EQ.lfi%JPNIL) THEN
      clmess='RANG DANS LA TABLE *LFI%NUMERO* INCORRECT'
    ELSE
      WRITE (unit=clmess,fmt=                                  &
&   '(''ARGUMENT DE TYPE ENTIER INCORRECT, UNITE'',I3)') knumer
    ENDIF
!
  ELSEIF (kcode.EQ.-15) THEN
    WRITE (unit=clmess,                              &
&           fmt='(''NOM D''''ARTICLE INCORRECT OU '', &
&           ''TROP LONG, UNITE'',I3)') knumer
!
  ELSEIF (kcode.EQ.-16) THEN
    WRITE (unit=clmess,                                      &
&           fmt='(''INCOHERENCE (TABLES, FICHIER, '',         &
&           ''APPELS S/P INT, LOGICIEL), UNITE'',I3)') knumer
!
  ELSEIF (kcode.EQ.-17) THEN
!
    IF (ijl.NE.0) THEN
      inbalo=lfi%MDES1D(ixm(lfi%JPNALO,ijl))
    ELSE
      inbalo=lfi%JPNIL
    ENDIF
!
    WRITE (unit=clmess,                                &
&           fmt='(I6,'' ARTICLES, INDEX PLEIN, UNITE'', &
&           I3)') inbalo,knumer
!
  ELSEIF (kcode.EQ.-18) THEN
    WRITE (unit=clmess,                             &
&           fmt='(''ARTICLE DE NOM BLANC ILLICITE'', &
&           '', UNITE'',I3)') knumer
!
  ELSEIF (kcode.EQ.-19) THEN
    WRITE (unit=clmess,fmt='(''UNITE'',I3,                        &
&           '' ''''SCRATCH'''', NE PEUT ETRE CONSERVEE'')') knumer
!
  ELSEIF (kcode.EQ.-20) THEN
    WRITE (unit=clmess,fmt='(''ARTICLE "'',A,                    &
&           ''" NON TROUVE, UNITE'',I3)') cdacti(1:ilact2),knumer
!
  ELSEIF (kcode.EQ.-21) THEN
    WRITE (unit=clmess,fmt='(''ARTICLE "'',A, &
&    ''" + *LONG* QUE DEMANDE, UNITE'',I3)')   &
&      cdacti(1:ilact2),knumer
!
  ELSEIF (kcode.EQ.-22) THEN
    WRITE (unit=clmess,fmt='(''ARTICLE "'',A, &
&    ''" + *COURT* QUE DEMANDE, UNITE'',I3)')  &
&      cdacti(1:ilact2),knumer
!
  ELSEIF (kcode.EQ.-23) THEN
    WRITE (unit=clmess,                                &
&           fmt='(''PAS OU PLUS D''''ARTICLE SUIVANT'', &
&    '' A LIRE, UNITE'',I3)') knumer
!
  ELSEIF (kcode.EQ.-24) THEN
    WRITE (unit=clmess,fmt='(''VARIABLE CAR.TROP COURTE '', &
&    ''POUR "'',A,''", UNITE'',I3)')                         &
&      cdacti(1:ilact2),knumer
!
  ELSEIF (kcode.EQ.-25) THEN
    WRITE (unit=clmess,                             &
&           fmt='(''NOUVEAU NOM D''''ARTICLE: "'',A, &
&    ''" DEJA UTILISE, UNITE'',I3)')                 &
&      cdacti(1:ilact2),knumer
!
  ELSEIF (kcode.EQ.-26) THEN
    WRITE (unit=clmess,fmt='(''PAS OU PLUS D''''ARTICLE '', &
&    '' PRECEDENT A LIRE, UNITE'',I3)') knumer
!
  ELSEIF (kcode.EQ.-27) THEN
    WRITE (unit=clmess,                                &
&           fmt='(''ESPACE CONTIGU INSUFFISANT DANS '', &
&    '' LES TABLES, UNITE'',I3)') knumer
!
  ELSEIF (kcode.EQ.-28) THEN
!
    IF (knumer.EQ.lfi%JPNIL) THEN
      WRITE (unit=clmess,fmt='(''FACTEUR MULTIPLICATIF PAR '', &
&      ''DEFAUT SUPERIEUR AU MAXIMUM('',I3,'')'')') lfi%JPFACX
    ELSE
      WRITE (unit=clmess,fmt='(''FACTEUR MULTIPLICATIF '',     &
&      ''DEMANDE SUPERIEUR AU MAXIMUM ('',I3,''), UNITE'',I3)') &
&        lfi%JPFACX,knumer
    ENDIF
!
  ELSEIF (kcode.EQ.-29) THEN
    WRITE (unit=clmess,fmt='(I3,'' ENTREES,'',            &
&    '' PAS DE PLACE POUR FACTEUR MULTIPLIC, UNITE'',I3)') &
&    lfi%JPXUFM,knumer
!
  ELSEIF (kcode.EQ.-30) THEN
    WRITE (unit=clmess,                                    &
&           fmt='(''LFI%NUMERO D''''UNITE LOGIQUE FORTRAN'' &
&           ,I8,'' ILLICITE'')') knumer
!
  ELSEIF (kcode.EQ.-31) THEN
    WRITE (unit=clmess,fmt='(''LFI%NUMERO UNITE LOGIQ'',I3, &
&       '' SANS FACTEUR MULTIPLICATIF PREDEFINI'')') knumer
!
!                  Pour les codes d'erreur non prevus...
!
  ELSEIF (knumer.EQ.lfi%JPNIL) THEN
    WRITE (unit=clmess,                                    &
&           fmt='(''ERREUR GLOBALE *INCONNUE* LFI%NUMERO'', &
&                             I6)') kcode
  ELSE
    WRITE (unit=clmess,                               &
&           fmt='(''ERREUR *INCONNUE* LFI%NUMERO'',I6, &
&           '' SUR UNITE LOGIQUE'',I3)') kcode,knumer
  ENDIF
!
  ilmesa=int(len(clmesa), jplikb)
  ilmesu=ilmesa-1-2*int(len(cljoli), jplikb)-ilnspr-4
  clmesa=cljoli//' '//cdnspr(1:ilnspr)//' - ' &
&         //clmess(1:ilmesu)//cljoli
  WRITE (unit=lfi%NULOUT,fmt='(A)') clmesa
!
!           Si l'unite logique correspond a une unite logique LFI
!     deja ouverte, on en imprime le nom.
!
  IF (ijl.NE.0) THEN
!
    IF (lfi%NLNOMF(ijl).LE.lfi%JPLFTX) THEN
      WRITE (unit=lfi%NULOUT,fmt='(A,/)') cljoli               &
&             //' NOM - APPARENT MAIS'                          &
&             //' COMPLET - DE L''UNITE LOGIQUE LFI CONCERNEE:'
    ELSE
      WRITE (unit=clmess,fmt='(A,                                &
&             '' NOM - APPARENT, ET TRONQUE DE'',I4,              &
&       '' CARACTERES - DE L''''UNITE LOGIQUE LFI CONCERNEE:'')') &
&      cljoli,lfi%NLNOMF(ijl)-lfi%JPLFTX
      WRITE (unit=lfi%NULOUT,fmt='(A,/)') trim(clmess)
    ENDIF
!
    inlign=(lfi%NLNOMF(ijl)-1)/lfi%JPLFIX
    idecal=0
!
    DO j=1,inlign
    WRITE (unit=lfi%NULOUT,fmt='(A)')                         &
&           lfi%CNOMFI(ijl)(idecal+1:idecal+lfi%JPLFIX)//'...'
    idecal=idecal+lfi%JPLFIX
    ENDDO
!
    IF (lfi%NLNOMF(ijl).LE.lfi%JPLFTX) THEN
      WRITE (unit=lfi%NULOUT,fmt='(A,/)')             &
&            lfi%CNOMFI(ijl)(idecal+1:lfi%NLNOMF(ijl))
    ELSE
      WRITE (unit=lfi%NULOUT,fmt='(A,/)')                &
&             lfi%CNOMFI(ijl)(idecal+1:lfi%JPLFTX)//'...'
    ENDIF
!
    IF (lfi%CNOMSY(ijl).NE.lfi%CNOMFI(ijl)) THEN
      WRITE (unit=lfi%NULOUT,fmt='(A,/)') cljoli//              &
& ' NOM *SYSTEME* (APPARENT) DE L''UNITE LOGIQUE LFI CONCERNEE:'
      inlign=(lfi%NLNOMS(ijl)-1)/lfi%JPLFIX
      idecal=0
!
      DO j=1,inlign
      WRITE (unit=lfi%NULOUT,fmt='(A)')                         &
&             lfi%CNOMSY(ijl)(idecal+1:idecal+lfi%JPLFIX)//'...'
      idecal=idecal+lfi%JPLFIX
      ENDDO
!
      WRITE (unit=lfi%NULOUT,fmt='(A,/)')             &
&            lfi%CNOMSY(ijl)(idecal+1:lfi%NLNOMS(ijl))
    ENDIF
!
  ENDIF
!
  WRITE (unit=lfi%NULOUT,fmt='(A)') clmesa
  IF (ldfata.AND.kcode.NE.0) THEN
!
!            Saborde le programme.
!
    CALL flush (int(lfi%NULOUT))
    CALL sdl_srlabort
  ENDIF
!
ENDIF
!
IF (lhook) CALL dr_hook('LFIEFR_FORT',1,zhook_handle)

CONTAINS

#include "lficom2.ixm.h"

END SUBROUTINE lfiefr_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lfiefr64                                       &
&           (knumer, knimes, kcode, ldfata, cdmess, cdnspr, &
&           cdacti)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKB)  KNIMES                                 ! IN   
INTEGER (KIND=JPLIKB)  KCODE                                  ! IN   
LOGICAL                LDFATA                                 ! IN   
CHARACTER (LEN=*)      CDMESS                                 ! IN   
CHARACTER (LEN=*)      CDNSPR                                 ! IN   
CHARACTER (LEN=*)      CDACTI                                 ! IN   

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfiefr_fort                                               &
&           (lfi, knumer, knimes, kcode, ldfata, cdmess, cdnspr, &
&           cdacti)

END SUBROUTINE lfiefr64

SUBROUTINE lfiefr                                         &
&           (knumer, knimes, kcode, ldfata, cdmess, cdnspr, &
&           cdacti)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKM)  KNIMES                                 ! IN   
INTEGER (KIND=JPLIKM)  KCODE                                  ! IN   
LOGICAL                LDFATA                                 ! IN   
CHARACTER (LEN=*)      CDMESS                                 ! IN   
CHARACTER (LEN=*)      CDNSPR                                 ! IN   
CHARACTER (LEN=*)      CDACTI                                 ! IN   

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfiefr_mt                                                 &
&           (lfi, knumer, knimes, kcode, ldfata, cdmess, cdnspr, &
&           cdacti)

END SUBROUTINE lfiefr

SUBROUTINE lfiefr_mt                                           &
&           (lfi, knumer, knimes, kcode, ldfata, cdmess, cdnspr, &
&           cdacti)
USE lfimod, ONLY : lficom
USE lfi_precision
IMPLICIT NONE
! Arguments
type(lficom)          lfi                                    ! INOUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKM)  KNIMES                                 ! IN   
INTEGER (KIND=JPLIKM)  KCODE                                  ! IN   
LOGICAL                LDFATA                                 ! IN   
CHARACTER (LEN=*)      CDMESS                                 ! IN   
CHARACTER (LEN=*)      CDNSPR                                 ! IN   
CHARACTER (LEN=*)      CDACTI                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
INTEGER (KIND=JPLIKB)  INIMES                                 ! IN   
INTEGER (KIND=JPLIKB)  ICODE                                  ! IN   
! Convert arguments

inumer     = int(    knumer, jplikb)
inimes     = int(    knimes, jplikb)
icode      = int(     kcode, jplikb)

CALL lfiefr_fort                                               &
&           (lfi, inumer, inimes, icode, ldfata, cdmess, cdnspr, &
&           cdacti)


END SUBROUTINE lfiefr_mt

!INTF KNUMER        IN    
!INTF KNIMES        IN    
!INTF KCODE         IN    
!INTF LDFATA        IN    
!INTF CDMESS        IN    
!INTF CDNSPR        IN    
!INTF CDACTI        IN