SUBROUTINE CARNAK(KLNKH2B,POBHDR,KOBODY,POBODY,KOB1,KOB2,KOB3,KINDSIZ,&
 & KPRE,KTYP)  
!****-------------------------------------------------------------------
!****   CARNAK : Controle de qualite des observations par coherence spatiale
!****   ------   (called by CAVODK)
!****
!****   auteur : P. Caille   F.Taillefer CMAFOC --> ODB
!****-------------------------------------------------------------------

!  Arguments d'entree :
!  ------------------
!    KLNKH2B : equivalent MLNKH2B pour les obs de mon processeur
!    POBHDR  : equivalent ROBHDR pour les obs de mon processeur
!    KOBODY  : equivalent ROBODY pour les obs de mon processeur
!    POBODY  : equivalent ROBODY pour les obs de mon processeur
!    KOB1    : 2eme dimension POBHDR
!    KOB2    : 2eme dimension KOBODY
!    KOB3    : 2eme dimension POBODY
!    KINDSIZ : tableau de 2 valeurs correspondant a la 1ere dimension des 4
!              premiers tableaux passes en argument
!    KPRE    : nombre maximum de predicteurs a traiter
!    KTYP    : tableau du type des NOBTOT observations

!  Algorithme :
!  ----------
!   Chargement en memoire de toutes les observations (depuis ODB - 12/2000).
!   Boucle sur les obs puis les parametres associes de mon processeur.

!   On trie les predicteurs selon le modele statistique qui leur est associe
!   On procede a la selection geographique, puis apres en regroupant ZUV on
!   procede a la selection statistique par verticale et a l'analyse par niveau
!   On utilise le fait qu'il y a autant de U que de V et aux memes niveaux.
!   Pour les epaisseurs on fait l'analyse du geopotentiel haut et bas.
!   Si toutes les variables regroupees pour une analyse ont ete declarees
!   mauvaises (ICFINA<=2) precedemment, on autorise l'utilisation des OBS.
!   declarees mauvaises (ICFINA>=2 voir CASPIA) afin de pouvoir les "racheter".

!   Le "flag de checking" est positionne selon la valeur du rapport :

!               ABS( increment analyse - residu observe )
!     ZRAPPW = ------------------------------------------
!                          ecart-type d'erreur
! si ZRAPPW =< coef1                            IFLAGW = 5  parametre correct
! si           coef1 < ZRAPPW < coef2           IFLAGW = 3  parametre douteux
! si                            coef2 =< ZRAPPW IFLAGW = 2  parametre incorrect
! si ZVARAN > 0.9 * ZVAGUE ou pas de controle   IFLAGW = 0
!-----------------------------------------------------------------------
! interdistance minimale entre deux niveaux selectionnes d'un meme message
! correlation minimale pour la selection d'un predicteur
! coefficients intervenant dans l'evaluation de la qualite de la valeur observee
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE PARDIMO  , ONLY : JPNOTP
USE YOMCT0   , ONLY : LELAM
USE YOMANCS  , ONLY : RMDI
USE YOMDIMO  , ONLY : NOBTOT
USE QALORI   , ONLY : QCAOBS
USE QAPAVU   , ONLY : JPNVX    ,JPPXZ    ,JPPXT    ,JPPXU    ,&
 & JPPXV    ,JPPXDZ   ,JPPXHU   ,JPPXST   ,JPPXSN   ,&
 & JPPXT2   ,JPPXH2   ,JPPXU1   ,JPPXV1   ,JPPXQ  
USE QAKEKI   , ONLY : NCQFPI   ,NCQKCO   ,NCQKPC   ,NCQKPI   ,NCQKIN
USE QAPREX   , ONLY : JPCHEK   ,NJPP     ,NPREK    ,NBPREK   ,&
 & NKZV     ,NKTT     ,NKHU     ,NKDZ     ,NKST     ,&
 & NKSN     ,NKT2     ,NKH2     ,NKV1     ,NKQQ  
USE QADORE   , ONLY : MINM     ,NMXGSL   ,NMXGQ    ,QDISTR   ,QDISTV
USE QACOST   , ONLY : QPOVZ
USE QAMCOK   , ONLY : RCOEFK
USE QAVARA   , ONLY : NVXINV

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KOB1 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOB2 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOB3 
INTEGER(KIND=JPIM),INTENT(IN)    :: KINDSIZ(3) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLNKH2B(KINDSIZ(3)) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: POBHDR(KINDSIZ(1),KOB1) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KOBODY(KINDSIZ(2),KOB2) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: POBODY(KINDSIZ(2),KOB3) 
INTEGER(KIND=JPIM)               :: KPRE ! Argument NOT used
INTEGER(KIND=JPIM),INTENT(IN)    :: KTYP(NOBTOT) 
REAL(KIND=JPRB) :: PPECNIV
REAL(KIND=JPRB) :: PPRMIN

PARAMETER ( PPECNIV = 1000._JPRB, PPRMIN = 0.1_JPRB)

! petit rappel sur le contenu des tableaux locaux d'observations

!   1. POBHDR (infos relatives aux obs, reel): 
!        - latitude transformee
!        - latitude
!        - longitude
!   2. KOBODY (infos relatives aux parametres, entier):
!        - numero de variable
!        - flag d'analyse
!   3. POBODY (infos relatives aux parametres, reel):
!        - ecart-type d'erreur du guess
!        - pression d'utilisation (ou pression haut couche)
!        - pression bas couche
!        - ecart-type d'erreur du guess bas couche
!        - ecart-type d'erreur d'observation
!        - ecart-type d'erreur de representativite
!        - difference (obs-guess)
!        - valeur analysee lors du controle de qualite

!  INWAG1 : nombre de wagons pour un modele statistique donne
!  IJW    : numero du wagon retenu comme Neme pour un modele statistique donne
!  IADW   : adresse de ce wagon
!  INWAG2 : nombre de wagons pour un analyse donnee
!  IINMS  : numero des modeles statistiques des predictands pour une analyse
!  INBMS  : nombre de ces modeles statistiques
!  INPBYP : nombre de predicteurs a retenir pour un type de predictand
!  LLOK   = .TRUE. si il y a des variables associees a ce modele statistique

INTEGER(KIND=JPIM) :: INWAG1(JPNVX), IJW(KPRE,JPNVX), IADW(KPRE,JPNVX)
INTEGER(KIND=JPIM) :: INWAG2(JPCHEK), IINMS(JPNVX), INBMS, INPBYP(JPNVX)
LOGICAL :: LLOK(JPCHEK)

!  IPOS   : position du jeme wagon pour l'analyse (type de modele stats, niveau)
!  IFLAGW : "flag" du controle de qualite
!  ZNIV   : pressions des predictands
!  ZSIGG  : ecarts-types d'erreur du guess
!  ZRESA  : residus analyses par CANEVA
!  ZSIGA  : ecarts-types d'erreur d'analyse associes
!  ZSTRET : parametres pour tenir compte de l'etirement

INTEGER(KIND=JPIM) :: IPOS(KPRE), IFLAGW(KPRE), INPR(KPRE)
REAL(KIND=JPRB) :: ZNIV(KPRE), ZSIGG(KPRE*2), ZRESA(KPRE*2), ZSIGA(KPRE*2)
REAL(KIND=JPRB) :: ZSTRET(2)

INTEGER(KIND=JPIM) :: I, I2, IBP, IFINA, IFLAG, IFLG, IGPTSK, II, IJWFLG, ILEN, &
 & INBNIV, INLV, IPABON, IPPXX, IQUOI, &
 & ITYP, IVNM, IW, IWAG, IWU, IWV, IX, &
 & Ixx(JPNOTP), JJ, JJK, JW, JOBS  

REAL(KIND=JPRB) :: ZKZ, ZLAT(1), ZLON(1), ZRAPPW, ZVAGUE, ZVARAN, ZVAROB, Zxxx(JPNOTP)
REAL(KIND=JPRB) :: ZDUM
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "canaco.intfb.h"
#include "caneva.intfb.h"

#include "qastat.h"
#include "qavari.h"
#include "qabitu.h"

!--------------------------------------------------------------------
!  - 1 -  Chargement global des observations
!         ----------------------------------

IF (LHOOK) CALL DR_HOOK('CARNAK',0,ZHOOK_HANDLE)
CALL CANACO(-1)

!--------------------------------------------------------------------
!  - 2 -  Boucle sur les observations de mon processeur
!         ---------------------------------------------

DO JOBS = 1 , NOBTOT

  IF (LELAM .AND. POBHDR(JOBS,1) == RMDI) CYCLE
  INLV      = KLNKH2B(JOBS+1)-KLNKH2B(JOBS)
  ZSTRET(1) = QCAOBS(1,JOBS)
  ZSTRET(2) = QCAOBS(2,JOBS)
  ZLAT(1)     = POBHDR(JOBS,2)
  ZLON(1)     = POBHDR(JOBS,3)

  INWAG1 = 0
  IGPTSK = 1
  ILEN   = 1

!--------------------------------------------------------------------
!  - 3 -  Preparation du controle
!         -----------------------

!  selection des parametres pouvant etre controles
  DO JW = 1 , INLV
    IWAG = KLNKH2B(JOBS)+JW-1
    IVNM = KOBODY(IWAG,1)
    IX   = NVXINV(IVNM)
    IF ( POBODY(IWAG,1) == RMDI .OR. IX == 0 ) THEN
!         pas de controle  : IFLAG en NFLGK1 mis a 0.
      IFLAGW(JW) = 0
    ELSE
      INWAG1(IX)          = INWAG1(IX) + 1
      IJW(INWAG1(IX),IX)  = JW
      IADW(INWAG1(IX),IX) = IWAG
    ENDIF
  ENDDO

  IF (INWAG1(JPPXU) /= INWAG1(JPPXV)) CALL ABOR1('Pb Nb U <> Nb V')
  INWAG2(NKZV) = INWAG1(JPPXZ) + INWAG1(JPPXU) + INWAG1(JPPXV)
  INWAG2(NKTT) = INWAG1(JPPXT)
  INWAG2(NKHU) = INWAG1(JPPXHU)
  INWAG2(NKDZ) = INWAG1(JPPXDZ)
  INWAG2(NKST) = INWAG1(JPPXST)
  INWAG2(NKSN) = INWAG1(JPPXSN)
  INWAG2(NKQQ) = INWAG1(JPPXQ)
  INWAG2(NKT2) = INWAG1(JPPXT2)
  INWAG2(NKH2) = INWAG1(JPPXH2)
  INWAG2(NKV1) = INWAG1(JPPXU1) + INWAG1(JPPXV1)
  LLOK(NKZV)   = INWAG2(NKZV)  >  0
  LLOK(NKTT)   = INWAG2(NKTT)  >  0
  LLOK(NKHU)   = INWAG2(NKHU)  >  0
  LLOK(NKDZ)   = INWAG2(NKDZ)  >  0
  LLOK(NKST)   = INWAG2(NKST)  >  0
  LLOK(NKSN)   = INWAG2(NKSN)  >  0
  LLOK(NKQQ)   = INWAG2(NKQQ)  >  0
  LLOK(NKT2)   = INWAG2(NKT2)  >  0
  LLOK(NKH2)   = INWAG2(NKH2)  >  0
  LLOK(NKV1)   = INWAG2(NKV1)  >  0

!-----------------------------------------------------------------------
!  - 4 -  Selection geographique
!         ----------------------

  IF ( LLOK(NKZV) .OR. LLOK(NKTT) .OR. LLOK(NKHU) .OR. &
     & LLOK(NKDZ) .OR. LLOK(NKST) .OR. LLOK(NKSN) .OR. &
     & LLOK(NKT2) .OR. LLOK(NKH2) .OR. LLOK(NKV1) .OR. LLOK(NKQQ) ) THEN  
    IQUOI = 0
    CALL CANEVA (IQUOI,KTYP(JOBS),IGPTSK,QDISTR(1,KTYP(JOBS)),&
     & QDISTV(1,KTYP(JOBS)),ZDUM,NMXGSL(1,KTYP(JOBS)),&
     & NMXGQ(1,KTYP(JOBS)),ZDUM,ZSTRET,ZLAT,ZLON,Zxxx,&
     & 1,1,Ixx,1,Ixx,1,Ixx,Zxxx,Zxxx,Zxxx,INPR)  
  ENDIF

!-----------------------------------------------------------------------
!  - 5 -  Boucle sur les classes de parametres
!         ------------------------------------

  DO JJK = 1 , JPCHEK
    IF ( .NOT. LLOK(JJK) ) CYCLE
    IPABON = 0

!  - 5.1 -  determination des modeles statistiques associes aux predictands

    INBMS = 0
    IPPXX = NJPP(JJK)

    IF ( INWAG1(IPPXX) > 0 ) THEN
      INBMS         = INBMS + 1
      IINMS(INBMS)  = IPPXX
!lg        
!      IF ( JJK == NKSN ) IINMS(INBMS) = JPPXHU
      INPBYP(INBMS) = MINM(IPPXX,KTYP(JOBS))
    ENDIF

    IF ( JJK == NKZV ) THEN
      IF ( INWAG1(JPPXU) > 0 ) THEN
        INBMS         = INBMS + 1
        IINMS(INBMS)  = JPPXU
        INPBYP(INBMS) = MINM(JPPXU,KTYP(JOBS))
        INBMS         = INBMS + 1
        IINMS(INBMS)  = JPPXV
        INPBYP(INBMS) = MINM(JPPXV,KTYP(JOBS))
      ENDIF
    ENDIF
    IF ( JJK == NKV1 ) THEN
      IF ( INWAG1(JPPXV1) > 0 ) THEN
        INBMS = INBMS+1
        IINMS(INBMS) = JPPXV1
        INPBYP(INBMS) = MINM(JPPXV1,KTYP(JOBS))
      ENDIF
    ENDIF

!  - 5.2 -  determination des niveaux (on a toujours U et V au meme niveau)

    INBNIV = INWAG1(IPPXX)
    DO JW = 1 , INBNIV
      IW = IJW(JW,IPPXX)
      IPOS(IW) = 1 + INBMS * (JW-1)
      ZNIV(JW) = POBODY(IADW(JW,IPPXX),2)
      ZSIGG(IPOS(IW)) = POBODY(IADW(JW,IPPXX),1)
      IFLG  = KOBODY(IADW(JW,IPPXX),2)
      IFINA = KBITLU(IFLG,NCQFPI,ILEN)
      IF ( IFINA == 1 ) IPABON = IPABON + 1
    ENDDO

    IF ( JJK == NKZV ) THEN

      IF ( INBMS == 3 ) THEN
        DO JJ = 1,INWAG1(JPPXZ)
          ZSIGG(2+INBMS*(JJ-1)) = 0.0_JPRB
          ZSIGG(3+INBMS*(JJ-1)) = 0.0_JPRB
        ENDDO
      ENDIF

      DO JW = 1 , INWAG1(JPPXU)
        IWU = IJW(JW,JPPXU)
        IWV = IJW(JW,JPPXV)

        DO JJ = 1 , INWAG1(JPPXZ)
          IF ( POBODY(IADW(JW,JPPXU),2) == ZNIV(JJ) ) THEN
            IPOS(IWU) = 2 + INBMS * (JJ-1)
            IPOS(IWV) = 3 + INBMS * (JJ-1)
            GOTO 304
          ENDIF
        ENDDO

        INBNIV = INBNIV + 1
!  on remplit par la fin pour le cas ou INBMS vaut 2 !!!
        IPOS(IWU) = INBMS * INBNIV - 1
        IPOS(IWV) = INBMS * INBNIV
        ZNIV(INBNIV)=POBODY(IADW(JW,JPPXU),2)
        IF ( INBMS == 3 ) ZSIGG(INBMS*INBNIV - 2) = 0.0_JPRB
        304 CONTINUE
        ZSIGG(IPOS(IWU)) = POBODY(IADW(JW,JPPXU),1)
        ZSIGG(IPOS(IWV)) = POBODY(IADW(JW,JPPXV),1)
        IFLG  = KOBODY(IADW(JW,JPPXU),2)
        IFINA = KBITLU(IFLG,NCQFPI,ILEN)
        IF ( IFINA == 1 ) IPABON = IPABON + 2
      ENDDO

    ENDIF

    IF (JJK == NKDZ) THEN
      IINMS(1) = JPPXZ

      LOOP_WAG: DO JW = 1 , INWAG1(JPPXDZ)
        IW = IJW(JW,JPPXDZ)

        DO JJ = 1 , INBNIV
          IF ( POBODY(IADW(JW,JPPXDZ),3) == ZNIV(JJ) ) THEN
            IPOS(INWAG1(JPPXDZ)+IW) = JJ
            CYCLE LOOP_WAG
          ENDIF
        ENDDO

        INBNIV = INBNIV + 1
        IPOS(INWAG1(JPPXDZ)+IW) = INBNIV
        ZNIV(INBNIV) =POBODY(IADW(JW,JPPXDZ),3)
        ZSIGG(INBNIV)=POBODY(IADW(JW,JPPXDZ),4)
      ENDDO LOOP_WAG

    ENDIF

    IF ( JJK == NKV1) THEN
      IF (INWAG1(JPPXU1) /= INWAG1(JPPXV1))&
       & CALL ABOR1('nwag(u)<>nwag(v)')  
      DO JW = 1,INBNIV
        IWV = IJW(JW,JPPXV1)
        IPOS(IWV) = 2 + INBMS * (JW - 1)
        ZSIGG(IPOS(IWV)) = POBODY(IADW(JW,JPPXV1),1)
        IFLG = KOBODY(IADW(JW,JPPXV1),2)
        IFINA = KBITLU(IFLG,NCQFPI,ILEN)
        IF (IFINA == 1 ) IPABON = IPABON + 1
      ENDDO
    ENDIF

!  - 5.3 -  ityp est incremente de 10 si on veut utiliser les obs. douteuses

    IF ( IPABON == INWAG2(JJK) )  THEN
      ITYP = KTYP(JOBS) + 10
    ELSE
      ITYP = KTYP(JOBS)
    ENDIF

!  - 5.4 -  selection statisque par verticale et analyse par niveau

    IQUOI = -2

    CALL CANEVA (IQUOI,ITYP,IGPTSK,Zxxx,&
     & QDISTV(1,KTYP(JOBS)),PPECNIV,Ixx,Ixx,&
     & PPRMIN,ZSTRET,ZLAT,ZLON,ZNIV(1),1,INBNIV,&
     & IINMS(1),INBMS,NPREK(1,JJK),NBPREK(JJK),&
     & INPBYP(1),ZSIGG(1),ZRESA(1),ZSIGA(1),INPR)  

!  - 5.5 -  calcul des residus et ecart-types analyses pour chaque wagon

    308 CONTINUE
    DO JW = 1 , INWAG1(IPPXX)
      IW     = IJW(JW,IPPXX)
      I      = IADW(JW,IPPXX)
      ZVAROB = POBODY(I,5)**2 + POBODY(I,6)**2
      II     = IPOS(IW)
      ZRAPPW = RMDI

      IF ( JJK == NKDZ ) THEN
        I2     = IPOS(INWAG1(JPPXDZ)+IW)
        ZKZ    = ( QPOVZ(II,IGPTSK) + QPOVZ(I2,IGPTSK) ) * 0.5_JPRB
        ZVARAN = FSIGDZ(ZSIGA(II),ZSIGA(I2),ZNIV(II),ZNIV(I2),ZKZ)**2
        ZRAPPW = ABS(ZRESA(II)-ZRESA(I2)-POBODY(I,7)) &
         & / SQRT(ZVAROB+ZVARAN)  
        ZVAGUE = FSIGDZ(POBODY(I,1),POBODY(I,4),&
         & ZNIV(II),ZNIV(I2),ZKZ)**2  
      ELSE
        ZVARAN = ZSIGA(II)**2
        ZRAPPW = ABS(ZRESA(II)-POBODY(I,7))/SQRT(ZVAROB+ZVARAN)
        ZVAGUE = POBODY(I,1)**2
      ENDIF

      POBODY(I,8) = ZRAPPW

      IF ( ZVARAN > 0.9_JPRB*ZVAGUE ) THEN
        IFLAGW(IW) = 0
      ELSEIF ( ZRAPPW <= 0.7_JPRB*RCOEFK(KTYP(JOBS),IPPXX) ) THEN
        IFLAGW(IW) = 5
      ELSEIF ( ZRAPPW <= RCOEFK(KTYP(JOBS),IPPXX) ) THEN
        IFLAGW(IW) = 3
      ELSE
        IFLAGW(IW) = 2
      ENDIF
    ENDDO

    IF ( JJK == NKZV .AND. IPPXX == JPPXZ ) THEN
      IPPXX = JPPXU
      GOTO 308
    ELSEIF ( JJK == NKZV .AND. IPPXX == JPPXU ) THEN
      IPPXX = JPPXV
      GOTO 308
    ELSEIF ( JJK == NKZV .AND. IPPXX == JPPXV ) THEN
! if we reject one wind component the other is probably incorrect too
      DO JW = 1,INWAG1(JPPXU)
        IWU = IJW(JW,JPPXU)
        IWV = IJW(JW,JPPXV)
        IF (IFLAGW(IWU) <= 3 .OR. IFLAGW(IWV) <= 3) THEN
          IFLAGW(IWU) = MIN(IFLAGW(IWU),IFLAGW(IWV))
          IFLAGW(IWV) = MIN(IFLAGW(IWU),IFLAGW(IWV))
        ENDIF
      ENDDO
    ELSEIF (JJK == NKV1.AND.IPPXX == JPPXU1) THEN
      IPPXX = JPPXV1
      GOTO 308
    ELSEIF (JJK == NKV1.AND.IPPXX == JPPXV1) THEN
! if we reject one wind component the other is probably incorrect too
      DO JW = 1,INWAG1(JPPXU1)
        IWU = IJW(JW,JPPXU1)
        IWV = IJW(JW,JPPXV1)
        IF (IFLAGW(IWU) <= 3 .OR. IFLAGW(IWV) <= 3) THEN
          IFLAGW(IWU) = MIN(IFLAGW(IWU),IFLAGW(IWV))
          IFLAGW(IWV) = MIN(IFLAGW(IWU),IFLAGW(IWV))
        ENDIF
      ENDDO
    ENDIF
  ENDDO

!-----------------------------------------------------------------------
!  - 6 -  Saisie du code controle de coherence spatiale
!         ---------------------------------------------

  DO JW = 1 , INLV
    IJWFLG = KLNKH2B(JOBS)+JW-1
    IFLG   = KOBODY(IJWFLG,2)
    IFLAG  = 0
    IFLG   = KBIT1OU0(IFLG,IFLAG,NCQKCO)
    IFLG   = KBIT1OU0(IFLG,IFLAG,NCQKPC)
    IFLG   = KBIT1OU0(IFLG,IFLAG,NCQKPI)
    IFLG   = KBIT1OU0(IFLG,IFLAG,NCQKIN)

    IF ( IFLAGW(JW) == 0 ) THEN
      IBP = NCQKIN
    ELSEIF ( IFLAGW(JW) == 5 ) THEN
      IBP = NCQKCO
    ELSEIF ( IFLAGW(JW) == 3 ) THEN
      IBP = NCQKPC
    ELSEIF ( IFLAGW(JW) == 2 ) THEN
      IBP = NCQKPI
    ELSE
      CYCLE
    ENDIF

    IFLAG = 1
    IFLG  = KBIT1OU0(IFLG,IFLAG,IBP)

    KOBODY(IJWFLG,2) = IFLG
  ENDDO

!-----------------------------------------------------------------------
!  - 7 -  Fin boucle sur les obs a controler
!         ----------------------------------

ENDDO

!-----------------------------------------------------------------------
!  - 8 -  Relachement des observations
!         ----------------------------

CALL CANACO(-2)

!-----------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('CARNAK',1,ZHOOK_HANDLE)
END SUBROUTINE CARNAK
