      SUBROUTINE FAXION ( PCHAME, KPUISS, KDIMNC, KLCHAM, PMIN, PMAX,
     S                    KNBITS, LDARPE, PEPSIL, PCHAMS, PECART,
     S                    KECART, LDMLAM, KNOZPA, KSTROF, KTRONC,
     S                    KXLOPA )
#include "facom0.h"
C****
C        Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
C     calcul de l'erreur relative maximum commise par le codage GRIB
C     sur un champ en coefficients spectraux, en mode "complex packing".
C**
C    Arguments :
C    ( Tableau ) PCHAME (Entree) ==> Champ en coef. spectraux en entree;
C                KPUISS (Entree) ==> Puissance de laplacien a utiliser;
C                KDIMNC (Entree) ==> Taille de la zone non codee;
C                KLCHAM (Entree) ==> Longueur totale du champ en c.spx.;
C                PMIN   (Entree) ==> Minimum precalcule du champ module;
C                PMAX   (Entree) ==> Maximum      "      "    "     "  ;
C                KNBITS (Entree) ==> Nombre de bits par valeur a coder;
C                LDARPE (Entree) ==> Vrai si GRIB non standard;
C                PEPSIL (Entree) ==> Valeur de surete pour la division;
C    ( Tableau ) PCHAMS (Sortie) ==> Champ d'erreur relative;
C                PECART (Sortie) ==> Erreur relative maximum commise,
C                                    en valeur absolue;
C                KECART (Sortie) ==> Indice ou PECART est atteint.
C                LDMLAM (Entree) ==> Vrai si fichier aladin
C    (Tableau)   KNOZPA (Entree) ==> Nombre d'onde zonal maxi par parallele;
C                                    (du pole nord vers l'equateur seulement)
C                KSTROF (Entree) ==> Sous-troncature non compactee EFFECTIVE (coef. spectraux)
C                KTRONC (Entree) ==> Troncature (NS pour Aladin)
C                KXLOPA (Entree) ==> Nombre maximum de longitudes par cercle de latitudes
C
C     Modifications
C     -------------
C
C  Juillet 1998, J. Clochard, SCEM/TTI/DAO:
C
C    -Le critere a minimiser est mis sous la forme de fonctions
C    -Pour le cas LDARPE=.TRUE., utilisation des memes gardes-fous
C     que dans CODEGA.
C
C  Septem. 2000, D. Paradis, SCEM/TTI/DEV:
C
C    -Ajustement de la puissance Dolby pour des nb d'onde (JN)
C     uniquement inferieurs a MIN(MTRONC(),(NXLOPA()-1)/3): on
C     s'affranchit de l'influence des grands nb d'onde sur des
C     grilles lineaires pour le choix du Dolby.
C
C  Mars 2003, R. El Khatib CNRM/GMAP:
C
C    -Optimisation : ISAMAX remplace par MAXLOC
C
      USE FAMODU   , ONLY : XLAP2D   ,XLAP2DA
C
#include "precision.h"
C
#include "facomp.h"
#include "facom1.h"
C
      INTEGER KPUISS, KDIMNC, KLCHAM, KNBITS, KECART, KSTROF
      INTEGER KTRONC, KXLOPA
C
      INTEGER KNOZPA (JPXIND)
      INTEGER ILOC(1)
C
      REAL (KIND=JPDBLR) PMIN, PMAX, PEPSIL, PECART
      REAL (KIND=JPDBLR) PCHAME (KLCHAM), PCHAMS (KLCHAM)
C
      LOGICAL LDARPE, LDMLAM
C
      INTEGER JN, JIND, ISCALE, J, INDICE, IPUISX, IOFF, IM
      INTEGER INDLAP, IRAPOR, IPUISR, IMLIM, IEXP, IMANT, IPUIS2, ISCALX
      INTEGER IZZZZZ, IDEB, IFIN, ITRDOL, ILCHADO
C
      REAL (KIND=JPDBLR) ZREFER, ZDIFFR, ZCOMPA, ZAUXI1, ZAUXI2, ZS
      REAL (KIND=JPDBLR) ZYPR, ZYP0, ZCRITR, ZCRIT0, ZCOEFF, ZEPSIL
C
      INTEGER KECART_LOC
      REAL (KIND=JPDBLR) PECART_LOC
C
      LOGICAL LLPREA
C
      SAVE LLPREA, ISCALX, ZEPSIL
C
      DATA LLPREA / .TRUE. /
C
C       Fonctions intermediaires utilisees pour alleger l'ecriture.
C
      ZYPR ( IZZZZZ ) = ZREFER + ZAUXI2 * ANINT ( 
     S                  ZAUXI1 * ( PCHAME(IZZZZZ)/ZCOEFF - ZREFER ) )
C
      ZYP0 ( IZZZZZ ) = ZREFER + ZAUXI2 * ANINT (
     S                  ZAUXI1 * ( PCHAME(IZZZZZ) - ZREFER ) )
C
C       Fonction "critere" a minimiser lorsque la modulation de la
C       puissance de laplacien est possible.
C
      ZCRITR ( IZZZZZ ) = ( ZYPR(IZZZZZ)*ZCOEFF - PCHAME(IZZZZZ) ) ** 2
     S                    / MAX ( PEPSIL, ABS (PCHAME(IZZZZZ)) )
C
C       Meme chose, mais pour la puissance 0.
C
      ZCRIT0 ( IZZZZZ ) = ( ZYP0(IZZZZZ) - PCHAME(IZZZZZ) ) ** 2
     S                    / MAX ( PEPSIL, ABS (PCHAME(IZZZZZ)) )
C**
C     0.  -  INITIALISATIONS FAITES AU PREMIER APPEL DU SOUS-PROGRAMME.
C-----------------------------------------------------------------------
C
      IF (LLPREA) THEN
        ZEPSIL=TINY(ZEPSIL)
        ISCALX=99
        LLPREA=.FALSE.
      ENDIF
C**
C     1.  -  CALCUL DIRECT, EN ESSAYANT DE MINIMISER LES OPERATIONS.
C            ( a l'aide des puissances precalculees dans XLAP2D )
C-----------------------------------------------------------------------
C
      IF (LDARPE) THEN
C
        ZDIFFR=PMAX-PMIN
C
        IF ( ZDIFFR .LE. ZEPSIL ) THEN
          ZAUXI1=MIN ( ABS (PMIN), ABS (PMAX) )
          IF ( ZAUXI1 .LE. ZEPSIL ) ZAUXI1=0.
          PMAX=SIGN (ZAUXI1,PMAX)
          PMIN=PMAX
          ZAUXI1=0.
          ZAUXI2=0.
        ELSE
          ZCOMPA=2**KNBITS-1
          ZAUXI1=ZCOMPA/ZDIFFR
          ZAUXI2=ZDIFFR/ZCOMPA
        ENDIF
C
        ZREFER=PMIN
C
      ELSE
C
        CALL CONFI (PMIN,IEXP,IMANT,ZREFER)
        ZS = (PMAX-ZREFER)/(2**(KNBITS+1)-1)
        ZAUXI1=1.
        ZAUXI2=2.
        IF (ZS.NE.0.) ZS = LOG(ZS)/LOG(ZAUXI2) + ZAUXI2
        ISCALE = MIN(INT(ZS),INT(ZS+SIGN(ZAUXI1,ZS)))
        ISCALE = MAX(-ISCALX,MIN(ISCALX,ISCALE))
        ZAUXI1 = ZAUXI2**(-ISCALE)
        ZAUXI2 = ZAUXI2**ISCALE
C
      ENDIF
C
C  Calcul de la borne superieure de la plage des nb d'onde
C  servant pour l'ajustement du Dolby (borne inferieure=KSTROF)
C  valable uniquement dans le cas Arpege pour ne pas prendre
C  en compte les coeff spectraux relatifs aux nb d'onde non
C  quadratiques (grille lineaire).
C
      IF (LDARPE.AND..NOT.LDMLAM) THEN
          ITRDOL = MIN ( KTRONC , (KXLOPA-1)/3 )
          ILCHADO = (ITRDOL+1)**2
      ENDIF
C
      IF (KPUISS.EQ.0) THEN
C
        IF (LDMLAM) THEN 
!$OMP PARALLEL DO PRIVATE(JN,JIND)
          DO 1010 JN=0,KTRONC
          DO 1010 JIND=KNOZPA(2*JN+3),KNOZPA(2*JN+4)
          PCHAMS(JIND)=ZCRIT0(JIND)
 1010     CONTINUE
!$OMP END PARALLEL DO
        ELSE
          DO 101 J=KDIMNC+1,ILCHADO
          PCHAMS(J)=ZCRIT0(J)
  101     CONTINUE
        ENDIF
C
      ELSE
        IPUISX=IABS (KPUISS)
C
        IF (KPUISS.GT.0) THEN
          INDICE=1
        ELSE
          INDICE=0
        ENDIF
C
        IF (IPUISX.LE.JPUILA) THEN
C
C        Dans ce cas precis, on pourrait aussi remplacer la division
C     par ZCOEFF par une multiplication par XLAP2D(J,IPUISX,1-INDICE).
C     Il y aurait gain en calcul, mais reference memoire supplementaire.
C
          IF (LDMLAM) THEN
#if !defined(RS6K)
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP,ZCOEFF)
#endif
            DO 1020 JN=1,KTRONC
            DO 1020 JIND=KNOZPA(2*JN+3)+4,KNOZPA(2*JN+4)
            IOFF=JIND-KNOZPA(2*JN+3)
            IM=IOFF/4 
            INDLAP=((JN-1)*JPXTRO)+IM
            ZCOEFF=XLAP2DA(INDLAP,IPUISX,INDICE)
            PCHAMS(JIND)=ZCRITR(JIND)
 1020       CONTINUE
#if !defined(RS6K)
!$OMP END PARALLEL DO
#endif
          ELSE
            DO 102 J=KDIMNC+1,ILCHADO
            ZCOEFF=XLAP2D(J,IPUISX,INDICE)
            PCHAMS(J)=ZCRITR(J)
  102       CONTINUE
          ENDIF
C
        ELSEIF (IPUISX.LE.2*JPUILA) THEN
          IPUIS2=IPUISX/2
C
          IF (IPUISX.EQ.2*IPUIS2) THEN
C
            IF (LDMLAM) THEN
#if !defined(RS6K)
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP,ZCOEFF)
#endif
              DO 1030 JN=1,KTRONC
              DO 1030 JIND=KNOZPA(2*JN+3)+4,KNOZPA(2*JN+4)
              IOFF=JIND-KNOZPA(2*JN+3)
              IM=IOFF/4 
              INDLAP=((JN-1)*JPXTRO)+IM
              ZCOEFF=XLAP2DA(INDLAP,IPUIS2,INDICE)**2
              PCHAMS(JIND)=ZCRITR(JIND)
 1030         CONTINUE
#if !defined(RS6K)
!$OMP END PARALLEL DO
#endif
            ELSE
              DO 103 J=KDIMNC+1,ILCHADO
              ZCOEFF=XLAP2D(J,IPUIS2,INDICE)**2
              PCHAMS(J)=ZCRITR(J)
  103         CONTINUE
            ENDIF
C
          ELSE
C
          IF (LDMLAM) THEN
#if !defined(RS6K)
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP,ZCOEFF)
#endif
             DO 1040 JN=1,KTRONC
             DO 1040 JIND=KNOZPA(2*JN+3)+4,KNOZPA(2*JN+4)
              IOFF=JIND-KNOZPA(2*JN+3)
              IM=IOFF/4 
              INDLAP=((JN-1)*JPXTRO)+IM
              ZCOEFF=XLAP2DA(INDLAP,JPUILA,INDICE)
     S             *XLAP2DA(INDLAP,IPUISX-JPUILA,INDICE)
              PCHAMS(JIND)=ZCRITR(JIND)
 1040         CONTINUE
#if !defined(RS6K)
!$OMP END PARALLEL DO
#endif
          ELSE
              DO 104 J=KDIMNC+1,ILCHADO
              ZCOEFF=XLAP2D(J,JPUILA,INDICE)
     S             *XLAP2D(J,IPUISX-JPUILA,INDICE)
              PCHAMS(J)=ZCRITR(J)
  104       CONTINUE
          ENDIF
C
          ENDIF
C
        ELSE
          IRAPOR=1+(IPUISX-1)/JPUILA
          IPUISR=IPUISX/IRAPOR
C
          IF (IPUISX.EQ.IRAPOR*IPUISR) THEN
C
            IF (LDMLAM) THEN
#if !defined(RS6K)
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP,ZCOEFF)
#endif
              DO 1050 JN=1,KTRONC
              DO 1050 JIND=KNOZPA(2*JN+3)+4,KNOZPA(2*JN+4)
              IOFF=JIND-KNOZPA(2*JN+3)
              IM=IOFF/4 
              INDLAP=((JN-1)*JPXTRO)+IM
              ZCOEFF=XLAP2DA(INDLAP,IPUISR,INDICE)**IRAPOR
              PCHAMS(JIND)=ZCRITR(JIND)
 1050         CONTINUE
#if !defined(RS6K)
!$OMP END PARALLEL DO
#endif
            ELSE
              DO 105 J=KDIMNC+1,ILCHADO
              ZCOEFF=XLAP2D(J,IPUISR,INDICE)**IRAPOR
              PCHAMS(J)=ZCRITR(J)
  105         CONTINUE
            ENDIF
C
          ELSE
C
           IF (LDMLAM) THEN
#if !defined(RS6K)
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP,ZCOEFF)
#endif
              DO 1060 JN=1,KTRONC
              DO 1060 JIND=KNOZPA(2*JN+3)+4,KNOZPA(2*JN+4)
              IOFF=JIND-KNOZPA(2*JN+3)
              IM=IOFF/4 
              INDLAP=((JN-1)*JPXTRO)+IM
              ZCOEFF=XLAP2DA(INDLAP,JPUILA,INDICE)**(IRAPOR-1)
     S            *XLAP2DA(INDLAP,IPUISX-JPUILA*(IRAPOR-1),INDICE)
              PCHAMS(JIND)=ZCRITR(JIND)
 1060         CONTINUE
#if !defined(RS6K)
!$OMP END PARALLEL DO
#endif
           ELSE
              DO 106 J=KDIMNC+1,ILCHADO
              ZCOEFF=XLAP2D(J,JPUILA,INDICE)**(IRAPOR-1)
     S            *XLAP2D(J,IPUISX-JPUILA*(IRAPOR-1),INDICE)
              PCHAMS(J)=ZCRITR(J)
  106         CONTINUE
            ENDIF
C
          ENDIF
C
        ENDIF
C
      ENDIF
C
      IF (LDMLAM) THEN
        PECART=-1.
!$OMP PARALLEL
!$OMP&PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,PECART_LOC,KECART_LOC)
        PECART_LOC=-1.
!$OMP DO
        DO 1070 JN=1,KTRONC
        IMLIM=KSTROF-JN
        IDEB=MAX(KNOZPA(2*JN+3)+4,KNOZPA(2*JN+3)+4*(IMLIM)+4)
        IFIN=KNOZPA(2*JN+4)
         DO 1071 JIND=IDEB,IFIN
           PECART_LOC=MAX (PECART_LOC,ABS(PCHAMS(JIND)))
 1071   CONTINUE
        DO 1072 JIND=IDEB,IFIN
           IF (ABS(PCHAMS(JIND)).EQ.PECART_LOC) KECART_LOC=JIND
 1072   CONTINUE
C
 1070   CONTINUE
!$OMP END DO NOWAIT
!$OMP CRITICAL
        IF (PECART_LOC > PECART) THEN
          PECART = PECART_LOC
          KECART = KECART_LOC
        END IF
!$OMP END CRITICAL
!$OMP END PARALLEL
      ELSE
        ILOC=MAXLOC(PCHAMS(KDIMNC+1:ILCHADO))
        KECART=KDIMNC+ILOC(1)
        PECART=ABS (PCHAMS(KECART))
      ENDIF
C
      IF (LFAMOP) THEN
        IF (LDARPE.AND..NOT.LDMLAM) THEN
          PRINT *,'FAXION: KPUISS=', KPUISS,', KDIMNC=',KDIMNC,
     S           ', KLCHAM=', KLCHAM, ', ITRDOL=', ITRDOL, ', ILCHADO=',
     S           ILCHADO, ', PMIN=', PMIN, ', PMAX=', PMAX
        ELSE
          PRINT *,'FAXION: KPUISS=', KPUISS,', KDIMNC=',KDIMNC,
     S           ', KLCHAM=', KLCHAM,
     S           ', PMIN=', PMIN, ', PMAX=', PMAX
        ENDIF
        PRINT *,'FAXION: PECART=', PECART, ', KECART=', KECART
        PRINT *,'FAXION: PCHAME/PCHAMS=', PCHAME(KECART), PCHAMS(KECART)
      ENDIF
C
      RETURN
      END
