facadi.F90

Go to the documentation of this file.

! Feb-2013 P. Marguinaud Use JNGEOM & JNEXPL parameters
!                        Reallocate cadre when redefinition happens
! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE facadi_fort                                           &
&                   (fa, krep, cdnomc, ktyptr, pslapo, pclopo,   &
&                    pslopo,                                     &
&                    pcodil, ktronc, knlati, knxlon, knlopa,     &
&                    knozpa, psinla, kniver, prefer, pahybr,     &
&                    pbhybr, ldmodc, ldredf, kphase, krangc,     &
&                    klnomc, kgarde)
USE fa_mod, ONLY : fa_com, new_cadre, free_cadre, jpniil, jngeom, jnexpl
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Sous-programme A USAGE INTERNE AU LOGICIEL. Fait la plupart
!     des controles en vue de Definir un CADre, voire le redefinir.
!        En mode multi-taches, il doit y avoir verrouillage global
!     de la zone d'appel au sous-programme.
!**
!        Arguments : KREP   ==> Code-reponse du sous-programme;
!                    CDNOMC ==> Nom symbolique du cadre;
!  (tous d'Entree)   KTYPTR ==> Type de transformation horizontale;
!   sauf KRANGC      PSLAPO ==> Sinus de la latitude du pole d'interet;
!     et KLNOMC)     PCLOPO ==> Cosinus " " longitude "   "       "   ;
!                    PSLOPO ==> Sinus   " " longitude "   "       "   ;
!                    PCODIL ==> Coefficient de dilatation;
!                    KTRONC ==> Troncature;
!                    KNLATI ==> Nombre de latitudes (de pole a pole);
!                    KNXLON ==> Nombre maxi de longitudes par parallele;
!         (Tableau)  KNLOPA ==> Nombre de longitudes par parallele;
!                               (du pole nord vers l'equateur seulement)
!         (Tableau)  KNOZPA ==> Nombre d'onde zonal maxi par parallele;
!                               (du pole nord vers l'equateur seulement)
!         (Tableau)  PSINLA ==> Sinus des latitudes de l'hemisphere nord
!                               (du pole nord vers l'equateur seulement)
!                    KNIVER ==> Nombre de niveaux verticaux;
!                    PREFER ==> Pression de reference (facteur multipli-
!                               catif de la premiere fonction de la
!                               coordonnee hybride)
!         (Tableau)  PAHYBR ==> Valeurs de la fonction "A" de la coordo-
!                               nnee hybride AUX LIMITES DE COUCHES;
!         (Tableau)  PBHYBR ==> Valeurs de la fonction "B" de la coordo-
!                               nnee hybride AUX LIMITES DE COUCHES;
!                    LDMODC ==> Vrai s'il y a modification d'un cadre
!                               deja defini au prealable;
!                    LDREDF ==> Vrai s'il y a redefinition d'un cadre
!                               au sens large du terme (avec ou sans
!                               modification).
!                    KPHASE ==> Indique quelle(s) phase(s) du sous-prog.
!                               on doit executer:
!                               0 ==> Toutes,
!                               1 ==> Controle des variables simples,
!                               2 ==> Controle des tableaux,
!                               3 ==> Definition du cadre seule.
!        (Sortie)    KRANGC ==> Rang du cadre dans les tables.
! (Sortie si phase 1,KLNOMC ==> Longueur en caracteres du nom de cadre.
!  Entree sinon ! )
!                    KGARDE ==> Option de conservation du cadre
!                               apres la fermeture du dernier fichier
!                               qui s'y rattache. A noter que lors dans
!                               le cas d'une definition dynamique de
!                               cadre (appel par FAITOU, avec KGARDE=1),
!                               une redefinition de cadre n'est toleree
!                               qu'a l'identique.
!
!     N.B. :    En mode multi-taches, si l'on appelle le sous-programme
!            avec KPHASE=0 ou KPHASE=3, on doit verrouiller dans le
!            programme appelant l'appel au sous-programme.
!               Par ailleurs, LDMODC et LDREDF ne sont definis que si
!            KPHASE=0 ou KPHASE=3.
!*
!        La "redefinition" d'un cadre est possible a l'une de ces
!     conditions:
!
!     - le cadre a ete defini, mais n'a aucun fichier qui s'y rattache;
!     - le cadre defini a au moins un fichier qui s'y rattache, et les
!       nouveaux parametres de definition sont identiques a ceux deja
!       definis (a l'exception de l'option de conservation).
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KTYPTR, KTRONC, KNLATI
INTEGER (KIND=JPLIKB) KNXLON, KNIVER, KREP, KPHASE
INTEGER (KIND=JPLIKB) KRANGC, KLNOMC, KGARDE
!
INTEGER (KIND=JPLIKB) KNLOPA (fa%jpxpah), KNOZPA (fa%jpxind)
!
REAL (KIND=JPDBLR) PSLAPO, PCLOPO, PSLOPO, PCODIL, PREFER
!
REAL (KIND=JPDBLR) PSINLA (fa%jpxgeo), PAHYBR (0:kniver)
REAL (KIND=JPDBLR) PBHYBR (0:kniver)
REAL (KIND=JPDBLR),PARAMETER ::  ZEPS=1.e-15_jpdblr
!
CHARACTER CDNOMC*(*)
!
LOGICAL LDREDF, LDMODC
!
INTEGER (KIND=JPLIKB) INPAHE
INTEGER (KIND=JPLIKB) ILCDNO, J, IPREC, ICOMPT, IMSMAX
INTEGER (KIND=JPLIKB) ISFLAM, JL, IK, INIMES, INUMER, ILNOMC
!
INTEGER (KIND=JPLIKB) IESN0 (0:fa%jpxtro)
INTEGER (KIND=JPLIKB) IKNTMP(0:fa%jpxtro)
INTEGER (KIND=JPLIKB) IKMTMP(0:fa%jpxtro)
INTEGER (KIND=JPLIKB) ICPL4N(0:fa%jpxtro)
!
REAL (KIND=JPDBLR) ZMIN, ZPMIN, ZPMAX, ZPMINP, ZPMAXP
!
LOGICAL LLMLAM
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     0.  -  AIGUILLAGE EN FONCTION DE *KPHASE*.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FACADI_MT',0,zhook_handle)

clacti=''
krep=0
ldredf=.false.
ldmodc=.false.
!
IF (ktyptr .LE. 0 ) THEN
   llmlam = .true.
ELSE
   llmlam = .false.
ENDIF
!
inpahe=(1+knlati)/2
!
IF (kphase.EQ.2) THEN
  GOTO 200
ELSEIF (kphase.EQ.3) THEN
  GOTO 300
ELSEIF (kphase.LT.0.OR.kphase.GT.3) THEN
  krep=-66
  GOTO 1001
ENDIF
!**
!     1.  -  CONTROLE DES VARIABLES SIMPLES (SYNTAXE ET COHERENCE).
!            (sauf pression de reference)
!-----------------------------------------------------------------------
!
ilcdno=int(len(cdnomc), jplikb)
klnomc=1
!
IF (ilcdno.LE.0) THEN
  krep=-65
  GOTO 1001
ELSEIF (cdnomc.EQ.' ') THEN
  krep=-68
  GOTO 1001
ELSEIF (kgarde.LT.0.OR.kgarde.GT.2) THEN
  krep=-66
  GOTO 1001
ENDIF
!
DO j=ilcdno,1,-1
!
IF (cdnomc(j:j).NE.' ') THEN
  klnomc=j
  GOTO 102
ENDIF
!
ENDDO
!
102 CONTINUE
!
IF (klnomc.GT.fa%NCPCAD) THEN
  krep=-65
  GOTO 1001
ENDIF
!
IF (ktronc.LE.0.OR.ktronc.GT.fa%NXTRON) THEN
  krep=-70
  GOTO 1001
ELSEIF (knlati.LE.0.OR.knlati.GT.fa%NXLATI) THEN
  krep=-71
  GOTO 1001
ELSEIF (kniver.LE.0.OR.kniver.GT.fa%NXNIVV) THEN
  krep=-72
  GOTO 1001
ELSEIF (knxlon.LE.0.OR.knxlon.GT.fa%NXLONG) THEN
  krep=-83
  GOTO 1001
ENDIF

IF (llmlam) THEN
!        IF (-2*KTYPTR+1.GT.KNXLON) THEN
!          KREP=-115
!          GOTO 1001
!        ELSEIF (2*KTRONC+1.GT.KNLATI) THEN
!          KREP=-116
!          GOTO 1001
!        ENDIF
ELSE
  IF (pcodil.LT.1._jpdblr) THEN
    krep=-73
    GOTO 1001
  ELSEIF (ktyptr.LE.0.OR.ktyptr.GT.fa%NTYPTX) THEN
    krep=-109
    GOTO 1001
  ELSEIF (max(abs(pslapo),abs(pclopo),abs(pslopo)) &
&          .GT.1._jpdblr) THEN
    krep=-100
    GOTO 1001
  ELSEIF (abs(1._jpdblr-(pclopo**2+pslopo**2)) &
&          .GT.1.e-5_jpdblr) THEN
    krep=-101
    GOTO 1001
  ELSEIF (2*ktronc+1.GT.knxlon) THEN
    krep=-84
    GOTO 1001
  ELSEIF (2*ktronc+1.GT.4*(knlati/2)) THEN
!
!       Le test ci-dessus est "dur" car il fait l'hypothese que,
!     dans le cas ou KNLATI est impair, la grille comporte les poles.
!
    krep=-79
    GOTO 1001
  ENDIF
ENDIF
!
IF (kphase.EQ.1) THEN
  GOTO 1001
ENDIF
!**
!     2.  -  CONTROLE DES TABLEAUX (SYNTAXE ET COHERENCE).
!            (et de la pression de reference)
!-----------------------------------------------------------------------
!
200 CONTINUE
!
!
IF (prefer.LT.0._jpdblr.OR.                     &
&    prefer.GT.real(10*fa%MPRESX, jpdblr)) THEN
  krep=-108
  GOTO 1001
ENDIF
!
!     No Mount Everest test
!
IF (.false.) THEN
DO j=0,kniver
iprec=max(0_jplikb ,j-1)
zmin=min(pahybr(j),pbhybr(j))
zpmin=prefer*pahybr(j)+fa%SPSMIN*pbhybr(j)
zpmax=prefer*pahybr(j)+fa%SPSMAX*pbhybr(j)
zpminp=prefer*pahybr(iprec)+fa%SPSMIN*pbhybr(iprec)
zpmaxp=prefer*pahybr(iprec)+fa%SPSMAX*pbhybr(iprec)
!
IF (zmin.LT.0._jpdblr.OR.pbhybr(j).GT.1._jpdblr) THEN
  krep=-80
  GOTO 1001
ELSEIF (j.NE.0.AND.(pbhybr(j).LT.pbhybr(iprec).OR.         &
&                 zpmin.LE.zpminp.OR.zpmax.LE.zpmaxp)) THEN
  krep=-81
  GOTO 1001
ENDIF
!
ENDDO
ENDIF ! No Mount Everest test
!
IF (.NOT.llmlam) THEN
!
   DO j=1,inpahe
   iprec=max(1_jplikb ,j-1)
!
   IF (knlopa(j).LE.0.OR.knlopa(j).GT.knxlon) THEN
     krep=-74
     GOTO 1001
   ELSEIF (knlopa(j).LT.knlopa(iprec)) THEN
     krep=-75
     GOTO 1001
   ELSEIF (knozpa(j).LT.0.OR.knozpa(j).GT.ktronc) THEN
     krep=-76
     GOTO 1001
   ELSEIF (knozpa(j).LT.knozpa(iprec)) THEN
     krep=-77
     GOTO 1001
   ELSEIF ((2*knozpa(j)+1).GT.knlopa(j)) THEN
     krep=-78
     GOTO 1001
   ELSEIF (abs(psinla(j)).GT.1._jpdblr) THEN
     krep=-102
     GOTO 1001
   ELSEIF (psinla(j).GE.psinla(iprec).AND.j.NE.1) THEN
     krep=-103
     GOTO 1001
   ENDIF
!
   ENDDO
!
ELSE
!
!        *****  ERROR HANDLING FOR LAM CASE
!
   IF (abs(knlopa(2)).GT.1) THEN
     krep=-117
     GOTO 1001
   ELSEIF (knlopa(3).LE.0.OR.knlopa(3).GT.knxlon) THEN
     krep=-118
     GOTO 1001
   ELSEIF (knlopa(4).LT.knlopa(3).OR.knlopa(4).GT.knxlon) THEN
     krep=-119
     GOTO 1001
   ELSEIF (knlopa(5).LE.0.OR.knlopa(5).GT.knlati) THEN
     krep=-120
     GOTO 1001
   ELSEIF (knlopa(6).LE.knlopa(5).OR.knlopa(6).GT.knlati) THEN
     krep=-121
     GOTO 1001
   ELSEIF (2*knlopa(7).GT.(knlopa(4)-knlopa(3))) THEN
     krep=-122
     GOTO 1001
   ELSEIF (2*knlopa(8).GT.(knlopa(6)-knlopa(5))) THEN
     krep=-123
     GOTO 1001
   ENDIF
!
ENDIF
!
IF (kphase.EQ.2) GOTO 1001
!**
!     3.  -  CONTROLES LIES A LA DEFINITION DU CADRE PROPREMENT DITE.
!-----------------------------------------------------------------------
!
300 CONTINUE
!
!        Le nom de cadre specifie est-il deja defini ?
!
CALL fanuca_fort                          &
&               (fa, cdnomc,krangc,.false.)
ldredf=krangc.NE.0
IF (ldredf) GOTO 500
!
!        En arrivant ici, il s'agit donc d'un nouveau cadre.
!
IF (fa%NCADEF.GE.fa%JPNXCA) THEN
!
!        Trop de cadres deja definis pour en stocker un de plus.
!
  krep=-56
  GOTO 1001
ENDIF
!
!       Recherche d'un emplacement disponible dans les tables de cadres,
!     lequel devrait en bonne logique exister...
!
DO j=1,fa%JPNXCA
!
IF (fa%CADRE(j)%CNOMCA.EQ.' ') THEN
  krangc=j
  GOTO 303
ENDIF
!
ENDDO
!
krep=-66
GOTO 1001
!
303 CONTINUE
!
!           Nouveau cadre, mise a jour des tables partagees de cadres.
!
fa%NCADEF=fa%NCADEF+1
fa%NCAIND(fa%NCADEF)=krangc

400 CONTINUE

CALL new_cadre (fa%CADRE(krangc), ktyptr, knlati, ktronc, kniver)

fa%CADRE(krangc)%CNOMCA=cdnomc
fa%CADRE(krangc)%NLCCAD=klnomc
!**
!     4.  -  STOCKAGE DES PARAMETRES DU CADRE (NOUVEAU, OU REDEFINI).
!-----------------------------------------------------------------------
!
fa%CADRE(krangc)%NULCAD=0
fa%CADRE(krangc)%NTYPTR=ktyptr
fa%CADRE(krangc)%MTRONC=ktronc
fa%CADRE(krangc)%NNIVER=kniver
fa%CADRE(krangc)%NLATIT=knlati
fa%CADRE(krangc)%NXLOPA=knxlon
fa%CADRE(krangc)%SSLAPO=pslapo
fa%CADRE(krangc)%SCLOPO=pclopo
fa%CADRE(krangc)%SSLOPO=pslopo
fa%CADRE(krangc)%SCODIL=pcodil
fa%CADRE(krangc)%SPREFE=prefer
!
fa%CADRE(krangc)%LIMLAM=llmlam
fa%CADRE(krangc)%NSFLAM=0
!
IF (.NOT.ldredf.OR.kgarde.NE.1) fa%CADRE(krangc)%NGARDE=kgarde
!
IF (.NOT.llmlam) THEN
   icompt=0
!
   DO j=1,inpahe
   icompt=icompt+knlopa(j)
   fa%CADRE(krangc)%NLOPAR(j)=knlopa(j)
   fa%CADRE(krangc)%NOZPAR(j)=knozpa(j)
   fa%CADRE(krangc)%SINLAT(j)=psinla(j)
   ENDDO
!
   IF (knlati.EQ.2*inpahe) THEN
     fa%CADRE(krangc)%NVAPDG=icompt*2
   ELSE
     fa%CADRE(krangc)%NVAPDG=icompt*2-knlopa(inpahe)
   ENDIF
!
ELSE
! *****  CALCULATION OF KNOZPA(), THEN ALSO SETTING OF FACOM1-TABLES  *****
!
   imsmax = -ktyptr
   isflam = 0
   CALL ellips64  (ktronc,imsmax,ikntmp,ikmtmp)
!DP      CALL ELLIPS(IMSMAX,KTRONC,IKNTMP,IKMTMP)
!
! Initialisation de FA%NOMPAR (du module FAMODU)
!
   fa%CADRE(krangc)%NOMPAR(2) = 0
   DO jl=0,imsmax
     fa%CADRE(krangc)%NOMPAR(2*jl+3) = fa%CADRE(krangc)%NOMPAR(2*jl+2) + 1
     fa%CADRE(krangc)%NOMPAR(2*jl+4) = fa%CADRE(krangc)%NOMPAR(2*jl+3) &
&                             + 4*(ikntmp(jl)+1) -1
   ENDDO
   fa%CADRE(krangc)%NOMPAR(1) = ktronc
   fa%CADRE(krangc)%NOMPAR(2) = imsmax
!
   DO jl=0,ktronc
      ik=ikmtmp(jl)
!DP         IK=IKNTMP(JL)
      icpl4n(jl)=4*(ik+1)
      isflam = isflam + 4*(ik+1)
   ENDDO
!
   iesn0(0)=1
!
   DO j=1,ktronc
      iesn0(j)=iesn0(j-1)+icpl4n(j-1)
   ENDDO
!
! -----  NOW SETTING OF TABLES  -----
   DO j=1,jnexpl
      fa%CADRE(krangc)%NLOPAR(j)=knlopa(j)
   ENDDO
   fa%CADRE(krangc)%SINLAT = 0._jpdblr
   DO j=1,jngeom
      fa%CADRE(krangc)%SINLAT(j)=psinla(j)
   ENDDO
   fa%CADRE(krangc)%NOZPAR(1)=ktronc
   fa%CADRE(krangc)%NOZPAR(2)=imsmax
!
   DO j=0,ktronc
      fa%CADRE(krangc)%NOZPAR(2*j+3)=iesn0(j)
      fa%CADRE(krangc)%NOZPAR(2*j+4)=iesn0(j)+icpl4n(j)-1
   ENDDO
  
   IF (fa%CADRE(krangc)%NOZPAR(2*ktronc+4).NE. &
&       fa%CADRE(krangc)%NOMPAR(2*imsmax+4))    &
&   THEN
     krep=-127
     GOTO 1001
   ENDIF
!
   fa%CADRE(krangc)%NSFLAM=isflam
!
! *****  DETERMINATION OF FA%NVAPDG()  *****
!
   fa%CADRE(krangc)%NVAPDG=knlati*knxlon
!
ENDIF
!
DO j=0,kniver
fa%CADRE(krangc)%SFOHYB(1,j)=pahybr(j)
fa%CADRE(krangc)%SFOHYB(2,j)=pbhybr(j)
ENDDO
!
GOTO 1001
!**
!     5.  -  TENTATIVE DE REDEFINITION D'UN CADRE. CONTROLES AD HOC.
!-----------------------------------------------------------------------
!
500 CONTINUE
!
IF (fa%CADRE(krangc)%MTRONC.NE.ktronc)        GOTO 505
IF (fa%CADRE(krangc)%NNIVER.NE.kniver)        GOTO 505
IF (fa%CADRE(krangc)%NLATIT.NE.knlati)        GOTO 505
IF (fa%CADRE(krangc)%NXLOPA.NE.knxlon)        GOTO 505
IF (fa%CADRE(krangc)%NTYPTR.NE.ktyptr)        GOTO 505
IF (abs(real(fa%CADRE(krangc)%SSLAPO, jpdblr)-real(pslapo, jpdblr))>zeps) GOTO 505
IF (abs(real(fa%CADRE(krangc)%SCLOPO, jpdblr)-real(pclopo, jpdblr))>zeps) GOTO 505
IF (abs(real(fa%CADRE(krangc)%SSLOPO, jpdblr)-real(pslopo, jpdblr))>zeps) GOTO 505
IF (abs(real(fa%CADRE(krangc)%SCODIL, jpdblr)-real(pcodil, jpdblr))>zeps) GOTO 505
IF (abs(real(fa%CADRE(krangc)%SPREFE, jpdblr)-real(prefer, jpdblr))>zeps) GOTO 505
!
IF (.NOT.llmlam) THEN
   DO j=1,inpahe
     IF (fa%CADRE(krangc)%NLOPAR(j).NE.knlopa(j))        GOTO 505
     IF (fa%CADRE(krangc)%NOZPAR(j).NE.knozpa(j))        GOTO 505
     IF (abs(REAL (FA%CADRE(KRANGC)%SINLAT(J), JPDBLR) - REAL (PSINLA(J), JPDBLR))>zeps) goto 505
   ENDDO
ELSE
   DO j=1,jnexpl
   IF (fa%CADRE(krangc)%NLOPAR(j).NE.knlopa(j)) GOTO 505
   ENDDO
   DO j=1,jngeom
   IF (abs(REAL (FA%CADRE(KRANGC)%SINLAT(J), JPDBLR)-REAL (PSINLA(J), jpdblr))>zeps) goto 505
   ENDDO
ENDIF
!
DO j=0,kniver
IF (abs(REAL (FA%CADRE(KRANGC)%SFOHYB(1,J), JPDBLR)-REAL (PAHYBR(J), jpdblr))>zeps) goto 505
IF (abs(REAL (FA%CADRE(KRANGC)%SFOHYB(2,J), JPDBLR)-REAL (PBHYBR(J), jpdblr))>zeps) goto 505
ENDDO
!
!        Si on arrive ici, il y a redefinition a l'identique,
!     du moins pour les parametres numeriques.
!        L'option de conservation du cadre peut, elle, etre modifiee
!     dans le cas d'une definition non dynamique.
!
IF (kgarde.NE.1) fa%CADRE(krangc)%NGARDE=kgarde
GOTO 1001
!
505 CONTINUE
ldmodc=.true.
!
!        Il y a donc redefinition avec changement de parametre(s),
!     ce qui n'est possible que s'il n'y a pas de fichier rattache,
!     et s'il ne s'agit pas d'une definition dynamique de cadre
!     (appel par FAITOU avec KGARDE=1).
!
IF (kgarde.EQ.1) THEN
  krep=-58
ELSEIF (fa%CADRE(krangc)%NULCAD.NE.0) THEN
  krep=-59
ELSE
  CALL free_cadre (fa%CADRE(krangc))
  GOTO 400
ENDIF
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE EVENTUELLE,
!            VIA LE sous-programme "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
!
llfata=krep.NE.0.AND.fa%NRFAGA.NE.2
!
IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FACADI'
  inumer=jpniil
!
  IF (krep.EQ.-65.AND.ilcdno.LE.0) THEN
    ilnomc=8
    clacti(1:ilnomc)=fa%CHAINC(:ilnomc)
  ELSE
    ilnomc=min(klnomc,fa%NCPCAD,int(len(clacti), jplikb))
    clacti(1:ilnomc)=cdnomc(1:ilnomc)
  ENDIF
!
  WRITE (unit=clmess,fmt='(''ARGUM.SIMPLES='',I4,'','''''',A, &
&         '''''''',4('','',F7.4),4('','',I4),'','',F10.3,      &
&         2('','',L1),2('','',I2),'','',I3,'','',I1)')         &
&  krep,clacti(1:ilnomc),pslapo,pclopo,pslopo,pcodil,          &
&  ktronc,knlati,knxlon,kniver,prefer,ldmodc,ldredf,kphase,    &
&  krangc,klnomc,kgarde
  CALL faipar_fort                                      &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,clacti(1:ilnomc),.false.)
ELSEIF (ktronc.LE.fa%NSTROI.AND.(kphase.EQ.0.OR.kphase.EQ.1)) THEN
  inimes=1
  clnspr='FACADI'
  inumer=jpniil
  ilnomc=min(klnomc,fa%NCPCAD)
  WRITE (unit=clmess,                                              &
&         fmt='(''TRONCATURE ('',I2,'') INFERIEURE '',              &
& ''OU EGALE A LA SOUS-TRONCATURE "NON COMPACTEE" IMPLICITE ('',I2, &
& ''), CADRE '''''',A,'''''''')') ktronc,fa%NSTROI,cdnomc(1:ilnomc)
  CALL faipar_fort                                      &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,clacti,.false.)
ENDIF
!
IF (lhook) CALL dr_hook('FACADI_MT',1,zhook_handle)
END SUBROUTINE facadi_fort