      SUBROUTINE FACOCH ( KREP, KNUME1, KNUME2, CDPREF, KNIVAU, CDSUFF )
#include "facom0.h"
C****
C      Sous-programme de reCOpie d'un Champ Horizontal d'un fichier
C     ARPEGE sur un autre.
C**
C    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
C                KNUME1 (Entree) ==> Numero d'unite logique en entree;
C                KNUME2 (Entree) ==> Numero d'unite logique en sortie;
C                CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
C                KNIVAU (Entree) ==> Niveau vertical eventuel;
C                CDSUFF (Entree) ==> Suffixe eventuel du nom d'article.
C
C     Modifications
C     -------------
C
C  Avril 2004, D. Paradis, DSI/DEV:
C    -Declaration IVALCO en ALLOCATABLE (gain memoire)
C  Juin  2004, D. Paradis, DSI/DEV:
C    -Prise en compte des codages type -1 et 3
C
#include "precision.h"
C
#include "facomp.h"
#include "facom1.h"
C
      INTEGER KREP, KNUME1, KNUME2, KNIVAU
C
      INTEGER IREP, ILPRFU, ILSUFU, ILNOMU, ILONGA, IRANC1, IRANC2
      INTEGER INIMES, J, INUMFI, IPOSEX, INPAHE, INPAHEL, JLAT, IZPAHEL
      INTEGER ISPAHEL, JNIV, ILPREF, ILSUFF, INUMRO, IRANG2, IGRIB
C
      INTEGER (KIND=JPDBLE), ALLOCATABLE :: IVALCO(:)
      INTEGER IRANG (2), INUMER (2), IB1PAR (3)
C
      LOGICAL LLVERF (2), LLRLFI, LLCOSP, LLMESS, LLNOMU
      LOGICAL LLMLAM1, LLMLAM2
C
      CHARACTER CDPREF*(*), CDSUFF*(*)
      CHARACTER CLAUXI*(JPXNOM), CLPREF*(JPXNOM), CLSUFF*(JPXSUF)
C
#include "facom2.h"
C**
C     1.  -  CONTROLES ET INITIALISATIONS.
C-----------------------------------------------------------------------
C
      LLRLFI=.FALSE.
      LLMESS=.FALSE.
      LLNOMU=.FALSE.
      ILPRFU=LEN (CDPREF)
      ILSUFU=LEN (CDSUFF)
      IRANC1=0
      IRANC2=0
      INUMER(1)=KNUME1
      INUMER(2)=KNUME2
      LLVERF(1)=.FALSE.
      LLVERF(2)=.FALSE.
      IRANG(2)=0
C
      DO 101 J=1,2
      INUMFI=J
      CALL FANUMU (INUMER(J),IRANG(J))
C
      IF (IRANG(J).EQ.0) THEN
        IREP=-51
        GOTO 1001
      ENDIF
C
C         Verrouillage eventuel du fichier.
C
      IF (LFAMUL) CALL LFIVER (VRFICH(IRANG(J)),'ON')
      LLVERF(J)=LFAMUL
C
      IF (LCREAF(IRANG(J))) THEN
        IREP=-85
        GOTO 1001
      ENDIF
C*
C       FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR"
C            ( controles de CDPREF, KNIVAU, CDSUFF inclus )
C
      CALL FANFAR (IREP,IRANG(J),CDPREF,KNIVAU,CDSUFF,CLNOMA,IB1PAR,
     S             ILPRFU,ILSUFU,ILNOMU)
      IF (IREP.NE.0) GOTO 1001
  101 CONTINUE
C
      LLNOMU=.TRUE.
C**
C     2.  -  LECTURE DE L'ARTICLE SUR LE FICHIER, CONTROLES.
C-----------------------------------------------------------------------
C
      CALL LFINFO (IREP,KNUME1,CLNOMA(1:ILNOMU),ILONGA,IPOSEX)
C
      IF (IREP.NE.0) THEN
        LLRLFI=.TRUE.
        GOTO 1001
      ELSEIF (ILONGA.EQ.0) THEN
        IREP=-89
        GOTO 1001
      ELSEIF (ILONGA.GT.JPXCHA+2) THEN
        IREP=-90
        GOTO 1001
      ENDIF
C
      ALLOCATE (IVALCO (ILONGA))
      CALL LFILEC (IREP,KNUME1,CLNOMA(1:ILNOMU),IVALCO,ILONGA)
      LLRLFI=IREP.NE.0
      IF (LLRLFI) GOTO 1001
C
      IF (IVALCO(1).LT.-1.OR.IVALCO(1).GT.3.OR.
     S    IVALCO(2).LT.0 .OR.IVALCO(2).GT.1.OR.
     S    (IVALCO(1).GT.0.AND.IVALCO(2).EQ.1.AND.IVALCO(4).LT.0)) THEN
        IREP=-91
        GOTO 1001
      ELSE
        LLCOSP=IVALCO(2).EQ.1
      ENDIF
C**
C     3.  -  CONTROLE DE COHERENCE ENTRE LES FICHIERS, VIS-A-VIS DU TYPE
C            DE DONNEES LUES (points de grille/coefficients spectraux).
C-----------------------------------------------------------------------
C
      IRANC1=NUCADR(IRANG(1))
      IRANC2=NUCADR(IRANG(2))
      INPAHE=(1+NLATIT(IRANC1))/2
      LLMLAM1=NTYPTR(IRANC1).LE. -1
      LLMLAM2=NTYPTR(IRANC2).LE. -1
C
      IF (IRANC1.NE.IRANC2) THEN
C
C         On a pris ici une optique souple: n'est fatale qu'une erreur
C     vraiment grossiere. Toute autre discordance est signalee par un
C     message global de niveau 1.
C
        IF ( (LLMLAM1.AND..NOT.LLMLAM2).OR.
     S       (LLMLAM2.AND..NOT.LLMLAM1).OR.
     S       (LLCOSP.AND.((.NOT.LLMLAM1.AND..NOT.LLMLAM2.AND.
     S                     MTRONC(IRANC1).NE.MTRONC(IRANC2)) .OR.
     S                    (LLMLAM1.AND.LLMLAM2.AND.
     S                     MTRONC(IRANC1).NE.MTRONC(IRANC2).AND.
     S                     NTYPTR(IRANC1).NE.NTYPTR(IRANC2) ))     ).OR.
     S       (.NOT.LLCOSP.AND.(NLATIT(IRANC1).NE.NLATIT(IRANC2).OR.
     S                         NVAPDG(IRANC1).NE.NVAPDG(IRANC2))   )
     S     ) THEN
          IREP=-112
          GOTO 1001
C
        ELSEIF (.NOT.LLCOSP) THEN
C
          IF (.NOT.LLMLAM1.AND..NOT.LLMLAM2) THEN
             INPAHEL=INPAHE
          ELSE
             INPAHEL=8
          ENDIF
          DO 301 JLAT=1,INPAHEL
          LLMESS=LLMESS.OR.NLOPAR(JLAT,IRANC1).NE.NLOPAR(JLAT,IRANC2)
  301     CONTINUE
C
          IF (LLMESS) THEN
            IREP=-112
            GOTO 1001
          ENDIF
C
        ENDIF
C
        LLMESS=MTRONC(IRANC1).NE.MTRONC(IRANC2).OR.
     S         NTYPTR(IRANC1).NE.NTYPTR(IRANC2).OR.
     S       (KNIVAU.GT.0.AND.(NNIVER(IRANC1).NE.NNIVER(IRANC2)).OR.
     S                        (SPREFE(IRANC1).NE.SPREFE(IRANC2))).OR.
     S         NLATIT(IRANC1).NE.NLATIT(IRANC2).OR.
     S         SSLAPO(IRANC1).NE.SSLAPO(IRANC2).OR.
     S         SCLOPO(IRANC1).NE.SCLOPO(IRANC2).OR.
     S         SSLOPO(IRANC1).NE.SSLOPO(IRANC2).OR.
     S         SCODIL(IRANC1).NE.SCODIL(IRANC2)
C
        IF (.NOT.LLMESS) THEN
C
          IF (.NOT.LLMLAM1.AND..NOT.LLMLAM2) THEN
             INPAHEL=INPAHE
             IZPAHEL=INPAHE
             ISPAHEL=INPAHE
          ELSE
             INPAHEL=8
             IZPAHEL=0
             ISPAHEL=18
          ENDIF
          DO 302 JLAT=1,INPAHEL
          LLMESS=NLOPAR(JLAT,IRANC1).NE.NLOPAR(JLAT,IRANC2).OR.LLMESS
  302     CONTINUE
          DO 312 JLAT=1,IZPAHEL
          LLMESS=NOZPAR(JLAT,IRANC1).NE.NOZPAR(JLAT,IRANC2).OR.LLMESS
  312     CONTINUE
          DO 322 JLAT=1,ISPAHEL
          LLMESS=SINLAT(JLAT,IRANC1).NE.SINLAT(JLAT,IRANC2).OR.LLMESS
  322     CONTINUE
C
          IF (.NOT.LLMESS.AND.KNIVAU.GT.0) THEN
C
            DO 303 JNIV=0,NNIVER(IRANC1)
            LLMESS=SFOHYB(1,JNIV,IRANC1).NE.SFOHYB(1,JNIV,IRANC2).OR.
     S      LLMESS.OR.SFOHYB(2,JNIV,IRANC1).NE.SFOHYB(2,JNIV,IRANC2)
  303       CONTINUE
C
          ENDIF
C
        ENDIF
C
      ENDIF
C**
C     4.  -  ECRITURE DE L'ARTICLE "CHAMP" SUR LE FICHIER.
C-----------------------------------------------------------------------
C
C        Deverrouillage eventuel de l'unite logique d'entree.
C
      IF (LLVERF(1)) CALL LFIVER (VRFICH(IRANG(1)),'OFF')
      LLVERF(1)=.FALSE.
C
      CALL LFIECR (IREP,KNUME2,CLNOMA(1:ILNOMU),IVALCO,ILONGA)
      INUMFI=2
      LLRLFI=IREP.NE.0
      IF (LLRLFI) GOTO 1001
C
C  Controle de l'homogeneite du type de rangement de coeff. spectraux
C  parmi les champs lus/ecrits: ces champs compactes avec
C  IGRIB=-1 ou 3 doivent etre ranges comme dans le modele ("verticalement"
C  soit selon des colonnes JM=cst consecutives) et contrairement si compactes
C  avec IGRIB= 0,1 ou 2.
C
      IRANG2 = IRANG(2)
      IGRIB = IVALCO(1)
      IF (LLCOSP) THEN
        IF (IGRIB.EQ.-1 .OR. IGRIB.EQ.3) THEN
          NRASVE(IRANG2)=NRASVE(IRANG2)+1
          IF (NRASVE(IRANG2).EQ.1 .AND. NRASHO(IRANG2).GT.0) THEN
            WRITE(0,*)'------------------------------------------------'
            WRITE(0,*)' FACOCH : WARNING !!!!!           '
            WRITE(0,*)' Un champ de coef. spect. avec rangt type modele'
            WRITE(0,*)' va etre ecrit sur l''unite ',KNUME2,
     S                ' alors que'
            WRITE(0,*)' d''autres champs y ont un rangement different.'
            WRITE(0,*)'------------------------------------------------'
          ENDIF
        ELSEIF (IGRIB.GE.0 .AND. IGRIB.LE.2) THEN
          NRASHO(IRANG2)=NRASHO(IRANG2)+1
          IF (NRASHO(IRANG2).EQ.1 .AND. NRASVE(IRANG2).GT.0) THEN
            WRITE(0,*)'------------------------------------------------'
            WRITE(0,*)' FACOCH : WARNING !!!!!           '
            WRITE(0,*)' Un champ de coef. spect. avec rangt autre que'
            WRITE(0,*)' celui du modele va etre ecrit sur l''unite ',
     S                KNUME2
            WRITE(0,*)' alors que d''autres champs y ont le rangt'//
     S                ' modele'
            WRITE(0,*)'------------------------------------------------'
          ENDIF
        ENDIF
      ENDIF
C
C**
C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
C            VIA LE SOUS-PROGRAMME "FAIPAR" .
C-----------------------------------------------------------------------
C
 1001 CONTINUE
      IF (ALLOCATED( IVALCO )) DEALLOCATE ( IVALCO )
      KREP=IREP
      LLFATA=LLMOER (IREP,IRANG(INUMFI))
C
C        Deverrouillage eventuel des fichiers.
C
      IF (LLVERF(1)) CALL LFIVER (VRFICH(IRANG(1)),'OFF')
      IF (LLVERF(2)) CALL LFIVER (VRFICH(IRANG(2)),'OFF')
C
      CLNSPR='FACOCH'
C
C        Messages d'avertissement eventuels.
C
      IF (NIMSGA.NE.0.AND.IREP.EQ.0) THEN
C
        IF (LLMESS) THEN
          INIMES=1
          WRITE (UNIT=CLMESS,FMT='(''*ATTENTION* - LES UNITES'',I3,
     S   '' ET'',I3,'' ONT DES CARACTERISTIQUES "CADRE" DIFFERENTES'')')
     S    KNUME1,KNUME2
          CALL FAIPAR (JPNIIL,INIMES,IREP,.FALSE.,CLMESS,CLNSPR,CLACTI,
     S                 .FALSE.)
        ELSEIF (IRANC1.NE.IRANC2) THEN
          INIMES=1
          WRITE (UNIT=CLMESS,FMT='(''REMARQUE: CADRES '''''',A,
     S           '''''' ET '''''',A,
     S           '''''' DISTINCTS MAIS DE CONTENU IDENTIQUE (UNITES'',
     S           I3,'' ET'',I3,'' )'')')
     S      CNOMCA(IRANC1)(1:NLCCAD(IRANC1)),
     S      CNOMCA(IRANC2)(1:NLCCAD(IRANC2)),KNUME1,KNUME2
          CALL FAIPAR (JPNIIL,INIMES,IREP,.FALSE.,CLMESS,CLNSPR,CLACTI,
     S                 .FALSE.)
        ENDIF
C
      ENDIF
C
      IF (LLFATA) THEN
        INIMES=2
      ELSE
        INIMES=IXNVMS(IRANG(INUMFI))
      ENDIF
C
      IF (.NOT.LLFATA.AND.INIMES.NE.2) RETURN
C
      IF (ILPRFU.GE.1) THEN
        ILPREF=MIN (ILPRFU,LEN (CLPREF))
        CLPREF(1:ILPREF)=CDPREF(1:ILPREF)
      ELSE
        ILPREF=8
        CLPREF(1:ILPREF)=CHAINC(:ILPREF)
      ENDIF
C
      IF (ILSUFU.GE.1) THEN
        ILSUFF=MIN (ILSUFU,LEN (CLSUFF))
        CLSUFF(1:ILSUFF)=CDSUFF(1:ILSUFF)
      ELSE
        ILSUFF=8
        CLSUFF(1:ILSUFF)=CHAINC(:ILSUFF)
      ENDIF
C
      IF (.NOT.LLNOMU) THEN
        ILNOMU=MIN (ILPREF,NCPCAD)
        CLNOMA(1:ILNOMU)=CLPREF(1:ILPREF)
      ENDIF
C
      WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUME1='',I3,
     S       '', KNUME2='',I3,'', CDPREF='''''',A,'''''', KNIVAU='',I6,
     S       '', CDSUFF='''''',A,'''''''')') KREP,KNUME1,KNUME2,
     S   CLPREF(1:ILPREF),KNIVAU,CLSUFF(1:ILSUFF)
C
      IF (IREP.EQ.-112) THEN
        INUMRO=1000*KNUME1+KNUME2
      ELSE
        INUMRO=INUMER(INUMFI)
      ENDIF
C
      CALL FAIPAR (INUMRO,INIMES,IREP,LLFATA,CLMESS,CLNSPR,
     S             CLNOMA(1:ILNOMU),LLRLFI)
C
      RETURN
      END
