SUBROUTINE CANADA (KQUOI,  KANTY,  KTASK,  PDISTR, PDELTA, PDELPI,&
 & KMXGSL, KMXGQ,  PCORMIN,PSTRET,&
 & PLATA,  PLONA,  PRESSS, KNBPH, KNBPV,&
 & KNX,    KNLX,   LDFLAI, LDFLAJ, KNM,&
 & PSIGPS, PRESIA, PSIGA,  KNPR)  
!-----------------------------------------------------------------------
!   CANADA : Pour une liste de variables en un ensemble de points,
!   ------   selection geographique, statistique et/ou analyse

!   auteur : YD 09/89
!-----------------------------------------------------------------------
!  ENTREES:
!  -------
!    KQUOI   : -3 a 3 (>=0 GEO, 3 STA+ANA VERT, 2 STA VERT ANA, 1 STA+ANA)
!    KTYPA   : type d'analyse (0 ou 1-20 si controle du type d'obs 1-10)
!    KTASK   : numero de la tache
!    PDISTR  : distance horizontale max. de recherche des obs.
!    PDELTA  : distance verticale max. (en Pa) de recherche des predicteurs
!    PDELPI  : interdistances vert. min. entre les predicteurs d'une meme obs.
!    KMXGSL  : nombre maximum d'obs. par type
!    KMXGQ   : nombre maximum d'obs. par type et par secteur
!    PCORMIN : correlation min. pour qu'un predicteur soit retenu
!    PSTRET  : fonction de stretching pour les portees horizontales
!    PLAT    : latitude en radian sur la sphere reelle
!    PLON    : longitude en radian sur la sphere reelle
!    PRESSS  : pression des points a analyser
!    KNBPH   : nombre de points sur l'horizontale
!    KNBPV   : nombre de points sur la verticale
!    KNX     : numero des modeles statistiques des predictants
!    KNLX    : nombre de types de predictants (taille de KNX)
!    LDFLAI  : indicateur logique des types de predictants a analyser
!    LDFLAJ  : indicateur logique des types de predicteurs admis
!    KNM     : tableau du nombre max. de predicteurs par predictants
!    PSIGPS  : ecart-type d'erreur de l'ebauche

!  SORTIES:
!  -------
!    PRESIA  : residus analyses
!    PSIGA   : ecart-type d'erreur d'analyse
!    KNPR    : nombre de predicteurs utilises en un point

!  SOUS-PROGRAMMES: CASGVA, CASSVA, CATRMA, CALINA, CAIMMA
!  ---------------  CAINSU, MXMAOP, RDOT

!  MODIFICATIONS: MCP 02/90, VC 03/92, 08/92, 08/94, PM 01/93, Ph.C 03/96
!  -------------  FT  11/00  CMAFOC --> ODB
!        M.Hamrud      01-Oct-2003 CY28 Cleaning

!  REMARQUES:
!  ---------
!   KQUOI = 1,2 ou 3 ou bien KQUOI = 0 puis -1,-2 ou -3
!   Le common QACOSS rempli par CAINSU sert a garder les parametres du modele
!   statistique.
!-------------------------------------------------------------------

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

USE QAPABL   , ONLY : JPNPM    ,JPKZMA   ,JPNPM2
USE QAPAVU   , ONLY : JPNVX    ,JPNVY    ,JPNINV   ,JPPXZ   ,&
 & JPPXT    ,JPPXU    ,JPPXV    ,JPPXHU  ,JPPXT2   ,&
 & JPPXH2   ,JPPXU1   ,JPPXV1   ,JPPXST  ,JPPXSN  
USE PARDIMO  , ONLY : JPNOTP
USE YOMDB
USE YOMOBA   , ONLY : MUTILW
USE YOMLUN   , ONLY : NULOUT
USE QACOST   , ONLY : QPOHZ    ,QRNU     ,QPOVZ
USE QAKEKI   , ONLY : NCUPS    ,NCUUVT   ,NCUHU    ,NCUT2M   ,&
 & NCUH2M   ,NCUV10   ,NCUSST   ,NCUSN  

IMPLICIT NONE

!     EXTERNAL REAL FUNCTIONS
INTEGER(KIND=JPIM),INTENT(IN)    :: KNBPH 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNBPV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNLX 
INTEGER(KIND=JPIM),INTENT(IN)    :: KQUOI 
INTEGER(KIND=JPIM),INTENT(IN)    :: KANTY 
INTEGER(KIND=JPIM),INTENT(IN)    :: KTASK 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDISTR(JPNOTP) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDELTA(JPNOTP) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDELPI 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMXGSL(JPNOTP) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMXGQ(JPNOTP) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCORMIN 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSTRET(2,KNBPH) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLATA(KNBPH) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLONA(KNBPH) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESSS(KNBPH,KNBPV) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNX(KNLX) 
LOGICAL           ,INTENT(IN)    :: LDFLAI(0:JPNVX) 
LOGICAL           ,INTENT(IN)    :: LDFLAJ(0:JPNINV) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNM(KNLX) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSIGPS(KNBPH,KNLX,KNBPV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PRESIA(KNBPH,KNLX,KNBPV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSIGA(KNBPH,KNLX,KNBPV) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KNPR(KNBPH,KNBPV) 
REAL(KIND=JPRB), EXTERNAL :: RDOT

INTEGER(KIND=JPIM) :: IZNM(KNLX)
REAL(KIND=JPRB) ::    ZPRESS(KNBPV), ZSIGP(JPNVX,KNBPV)
REAL(KIND=JPRB) ::    ZDXMB(JPNPM,KNLX,KNBPV*2), ZPOIDS(JPNPM2,KNLX,KNBPV)
REAL(KIND=JPRB) ::    ZDXMBV(JPNPM,KNLX,KNBPV*2)

!  Variables statiques sauvegardees
!     1) resultats de la selection statistique
!     2) constituant du systeme lineaire
!     3) matrice du systeme lineaire et residus observes
!     4) indicateur de sortie de message sur le listing
! 1)
INTEGER(KIND=JPIM) :: IASELV(JPNVY, JPKZMA), INSELV(JPNVY)
INTEGER(KIND=JPIM) :: IOSELV(JPNVY, JPKZMA), INPRV
REAL(KIND=JPRB) ::    ZDSELV(JPNVY ,JPKZMA)
! 2)
INTEGER(KIND=JPIM) :: IASELS(JPNVY, JPKZMA), INSELS(JPNVY)
INTEGER(KIND=JPIM) :: IOSELS(JPNVY, JPKZMA), INPRS
REAL(KIND=JPRB) ::    ZDSELS(JPNVY ,JPKZMA)
! 3)
REAL(KIND=JPRB) ::    ZMATBI(JPNPM2,JPNPM2), ZRESID(JPNPM2)

INTEGER(KIND=JPIM) :: IAD, IBP, IFLAG, IFLG, IITER, IIV, INUW,&
 & JH, JO, JSEL, JV, JVAR, JX  

REAL(KIND=JPRB) :: ZA2, ZKZ, ZNU2, ZVAR
REAL(KIND=JPRB) :: ZHOOK_HANDLE

INTERFACE
#include "mxmaop.h"
END INTERFACE

#include "abor1.intfb.h"
#include "caimma.intfb.h"
#include "cainsu.intfb.h"
#include "calina.intfb.h"
#include "camera.intfb.h"
#include "casgva.intfb.h"
#include "cassva.intfb.h"
#include "catrma.intfb.h"

#include "qabitu.h"
#include "qavari.h"
#include "openmp_obs.h"

!--------------------------------------------------------------------
!  - 1 -  Initialisations
!         ---------------

! attention : si 1.5 change, il convient de le changer dans CANEVA

IF (LHOOK) CALL DR_HOOK('CANADA',0,ZHOOK_HANDLE)
IF ( IABS(KQUOI) == 2 ) THEN

  DO JX = 1 , KNLX
    IZNM(JX) = KNM(JX) * 1.5_JPRB
  ENDDO

ENDIF

INPRS = 0
INPRV = 0

!-----------------------------------------------------------------------
!  - 2 -  Pour chaque point sur l'horizontale
!         -----------------------------------

DO JH = 1 , KNBPH

!=========================
!  TRAVAIL PAR VERTICALE
!=========================

!  - 2.1 - selection geographique par verticale
!          ------------------------------------

  IF ( KQUOI >= 0 ) THEN
    CALL CASGVA (KANTY, PDISTR, KMXGSL, KMXGQ, PLATA(JH),&
     & PLONA(JH), JH, KTASK)  
  ENDIF

!  - 2.2 - initialisation du tableau ZPRESS (pressions predictants)
!          definition de ZSIGP (ecarts-types d'erreur du guess)
!          + modif PSIGPS eventuelle

  IF ( KQUOI /= 0 ) THEN

    DO JV = 1 , KNBPV
      ZPRESS(JV) = PRESSS(JH,JV)
    ENDDO

    CALL CAINSU (PLATA(JH),ZPRESS,PSTRET(1,JH),KNBPV,KTASK)

    DO JV = 1 , KNBPV

      DO JX = 1 , KNLX
        ZSIGP(KNX(JX),JV) = PSIGPS(JH,JX,JV)
      ENDDO

      IF ( KANTY == 0 ) THEN
        ZA2  = QPOHZ(JV,KTASK) ** 2
        ZNU2 = QRNU(JV,KTASK) ** 2
        ZKZ  = QPOVZ(JV,KTASK)

! modif des ecart-types d'erreur pour les composantes du vent et la temperature

        IF ( LDFLAI(JPPXU) ) ZSIGP(JPPXU,JV)=FSIGU(ZSIGP(JPPXU,JV),ZA2,ZNU2)
        IF ( LDFLAI(JPPXV) ) ZSIGP(JPPXV,JV)=FSIGU(ZSIGP(JPPXV,JV),ZA2,ZNU2)
        IF ( LDFLAI(JPPXT) ) ZSIGP(JPPXT,JV)=FSIGT(ZSIGP(JPPXT,JV),ZKZ)

        DO JX = 1 , KNLX
          PSIGPS(JH,JX,JV) = ZSIGP(KNX(JX),JV)
        ENDDO

      ENDIF

    ENDDO

  ENDIF

!  - 2.3 - selection statistique par verticale et mise a jour des flags

  IF ( IABS(KQUOI) == 2 .OR. IABS(KQUOI) == 3 ) THEN

!  ZDXMBV contient les covariances normees (le second membre)
!  et les valeurs absolues des correlations

    CALL CASSVA (KTASK, KANTY, JH, LDFLAI, LDFLAJ,&
     & KNLX, KNM, PDELTA, PDELPI, PCORMIN,&
     & PLATA(JH), PLONA(JH), ZPRESS, ZSIGP,&
     & KNBPV, 0, IASELV(1,1), IOSELV(1,1),&
     & ZDSELV(1,1), INSELV, ZDXMBV, INPRV)  

!  initialisation du code d'utilisation et fabrication de la matrice 
!  du systeme lineaire par verticale

    IF ( IABS(KQUOI) == 3 .AND. INPRV /= 0 ) THEN

      IF ( KANTY == 0 ) THEN
        IFLAG  = 1

        IF ( LDFLAI(JPPXZ) ) THEN
          IBP = NCUPS
        ELSEIF ( LDFLAI(JPPXT) .OR. LDFLAI(JPPXU) .OR.LDFLAI(JPPXV) ) THEN
          IBP = NCUUVT
        ELSEIF ( LDFLAI(JPPXHU) ) THEN
          IBP = NCUHU
        ELSEIF ( LDFLAI(JPPXT2) ) THEN
          IBP = NCUT2M 
        ELSEIF ( LDFLAI(JPPXH2) ) THEN
          IBP = NCUH2M
        ELSEIF ( LDFLAI(JPPXU1) .OR. LDFLAI(JPPXV1) ) THEN
          IBP = NCUV10
        ELSEIF ( LDFLAI(JPPXST) ) THEN
          IBP = NCUSST
        ELSEIF ( LDFLAI(JPPXSN) ) THEN
          IBP = NCUSN 
        ELSE
          GOTO 233
        ENDIF

        DO JVAR = 1 , JPNVY
          DO JSEL = 1 , INSELV(JVAR)
            IAD  = IASELV(JVAR,JSEL)
            IFLG = ROBODY(IAD,MDBFLG)
            IFLG = KBIT1OU0(IFLG,IFLAG,IBP)
            ROBODY(IAD,MDBFLG) = IFLG
            INUW = ROBODY(IAD,MDBESQN)
            MUTILW(INUW) = MUTILW(INUW) + 1
          ENDDO
        ENDDO

        233 CONTINUE
      ENDIF

      CALL CATRMA (KTASK, IASELV(1,1), IOSELV(1,1), INSELV(1),&
       & INPRV, ZMATBI(1,1), ZRESID(1), 0)  
    ENDIF

  ENDIF

!  - 2.4 -  analyse par verticale

  IF ( IABS(KQUOI) == 3 ) THEN

!  saisie du nombre de predicteurs utilises

    DO JV = 1 , KNBPV
      KNPR(JH,JV) = INPRV
    ENDDO

!  resolution du systeme lineaire (initialisation de IITER )

    IF ( INPRV == 0 ) THEN

      DO JX = 1 , KNLX
        DO JV = 1 , KNBPV
          PRESIA(JH,JX,JV) = 0.0_JPRB
          PSIGA(JH,JX,JV) = PSIGPS(JH,JX,JV)
        ENDDO
      ENDDO

    ELSE
      IITER = 0
      CALL CALINA (ZMATBI(1,1), ZDXMBV, ZPOIDS, JPNPM2,&
       & JPNPM, JPNPM2, INPRV, KNLX*KNBPV, IITER)  

      IF ( IITER < 1 ) THEN
        WRITE (NULOUT,501)
        WRITE (NULOUT,502) PLATA(JH),PLONA(JH),KNLX,KNX
        WRITE (NULOUT,503) KNBPV
        WRITE (NULOUT,*)   (PRESSS(JH,JV),JV=1,KNBPV)
        CALL CAIMMA (ZMATBI(1,1), JPNPM2, ZDXMBV, JPNPM,INPRV, KNLX*KNBPV)
        CALL ABOR1 (' Pbs dans CANADA: systeme lineaire ')
      ELSEIF ( IITER > 1 ) THEN
        WRITE(NULOUT,505) IITER
        WRITE(NULOUT,502) PLATA(JH),PLONA(JH),KNLX,KNX
        WRITE(NULOUT,503) KNBPV
        WRITE(NULOUT,*)   (PRESSS(JH,JV),JV=1,KNBPV)
      ENDIF

!  calcul des variances d'erreurs d'analyse

      DO JV = 1 , KNBPV
        DO JX = 1 , KNLX
          ZVAR = PSIGPS(JH,JX,JV)**2 &
           & - RDOT(INPRV,ZPOIDS(1,JX,JV),1,ZDXMBV(1,JX,JV),1)  
          IF ( ZVAR  <  0.0_JPRB ) THEN
            WRITE (NULOUT,*) ' CANADA: variance analysee <0 ',&
             & ZVAR,PLATA(JH),PLONA(JH),KNX(JX),INPRV  
            PSIGA(JH,JX,JV) = PSIGPS(JH,JX,JV)
          ELSE
            PSIGA(JH,JX,JV) = SQRT(ZVAR)
          ENDIF
        ENDDO
      ENDDO

!  calcul des residus analyses

      CALL MXMAOP(ZPOIDS, JPNPM2, 1, ZRESID(1), 1, 1,&
       & PRESIA(JH,1,1), KNBPH, 1, KNLX*KNBPV, INPRV, 1)  
    ENDIF

  ELSEIF ( IABS(KQUOI) == 1 .OR. IABS(KQUOI) == 2 ) THEN

!-----------------------------------------------------------------------
!  - 3 -  Pour chaque point sur la verticale
!         ----------------------------------

!===========================
!  TRAVAIL POINT PAR POINT
!===========================

    DO JV = 1 , KNBPV

!  - 3.1 - selection statistique point par point et mise a jour des flags

      IF ( IABS(KQUOI) == 1 ) THEN
        IIV = JV

!  selection statistique par points
!  ZDXMB  contient les covariances normees (le second membre)
!  et les valeurs absolues des correlations

        CALL CASSVA (KTASK, KANTY, JH, LDFLAI, LDFLAJ, KNLX,&
         & KNM, PDELTA, PDELPI, PCORMIN, PLATA(JH),&
         & PLONA(JH), ZPRESS(JV), ZSIGP(1,JV), 1,JV,&
         & IASELS(1,1), IOSELS(1,1), ZDSELS(1,1),&
         & INSELS(1), ZDXMB(1,1,JV), INPRS)  

      ELSEIF ( IABS(KQUOI) == 2 ) THEN
        IIV = -JV

        IF ( INPRV > 0 ) THEN

          DO JVAR = 1 , JPNVY
            INSELS(JVAR) = INSELV(JVAR)
          ENDDO
          DO JVAR = 1 , JPNVY
            DO JX = 1 , INSELV(JVAR)
              IASELS(JVAR,JX) = IASELV(JVAR,JX)
              IOSELS(JVAR,JX) = IOSELV(JVAR,JX)
              ZDSELS(JVAR,JX) = ZDSELV(JVAR,JX)
            ENDDO
          ENDDO

!  extraction parmis les predicteurs retenus des meilleurs pour le point donne

          CALL CAMERA (IASELS(1,1),IOSELS(1,1),ZDSELS(1,1),&
           & INSELS(1),ZDXMBV(1,1,JV),&
           & ZDXMBV(1,1,JV+KNBPV),&
           & PCORMIN,IZNM,JPNPM,KNLX,1,INPRS)  

          DO JX = 1 , KNLX
            DO JO = 1 , INPRS
              ZDXMB(JO,JX,JV) = ZDXMBV(JO,JX,JV)
            ENDDO
          ENDDO

        ELSE
          INPRS = 0
        ENDIF

      ENDIF

!  initialisation du code d'utilisation et fabrication de la matrice 
!  du systeme lineaire

      IF ( INPRS /= 0 ) THEN

        IF ( KANTY == 0 ) THEN
          IFLAG  = 1

          IF ( LDFLAI(JPPXZ) ) THEN
            IBP = NCUPS
          ELSEIF ( LDFLAI(JPPXT) .OR. LDFLAI(JPPXU) .OR. LDFLAI(JPPXV)) THEN
            IBP = NCUUVT
          ELSEIF ( LDFLAI(JPPXHU) ) THEN
            IBP = NCUHU
          ELSEIF ( LDFLAI(JPPXST) ) THEN
            IBP = NCUSST
          ELSEIF ( LDFLAI(JPPXT2) ) THEN
            IBP = NCUT2M
          ELSEIF ( LDFLAI(JPPXH2) ) THEN
            IBP = NCUH2M
          ELSEIF ( LDFLAI(JPPXU1) .OR. LDFLAI(JPPXV1) ) THEN
            IBP = NCUV10
          ELSEIF ( LDFLAI(JPPXSN) ) THEN
            IBP = NCUSN
          ELSE
            GOTO 318
          ENDIF
          DO JVAR = 1 , JPNVY
            DO JSEL = 1 , INSELS(JVAR)
              IAD  = IASELS(JVAR,JSEL)
              IFLG = ROBODY(IAD,MDBFLG)
              IFLG = KBIT1OU0(IFLG,IFLAG,IBP)
              ROBODY(IAD,MDBFLG) = IFLG
              INUW = ROBODY(IAD,MDBESQN)
              MUTILW(INUW) = MUTILW(INUW) + 1
            ENDDO
          ENDDO
          318 CONTINUE
        ENDIF

        CALL CATRMA (KTASK,IASELS(1,1),IOSELS(1,1),INSELS(1),&
         & INPRS,ZMATBI(1,1),ZRESID(1),IIV)  
      ENDIF

!  - 3.2 - analyse point par point

!   saisie du nombre de predicteurs utilises

      KNPR(JH,JV) = INPRS

!  resolution du systeme lineaire si il y a lieu

      IF ( INPRS == 0 ) THEN

        DO JX = 1,KNLX
          PRESIA(JH,JX,JV) = 0.0_JPRB
          PSIGA(JH,JX,JV) = PSIGPS(JH,JX,JV)
        ENDDO

      ELSE
        IITER = 0
        CALL CALINA (ZMATBI(1,1), ZDXMB(1,1,JV), ZPOIDS(1,1,JV),&
         & JPNPM2, JPNPM, JPNPM2, INPRS, KNLX, IITER)  

        IF ( IITER < 1 ) THEN
          WRITE (NULOUT,501)
          WRITE (NULOUT,502) PLATA(JH),PLONA(JH),KNLX,KNX
          WRITE (NULOUT,504) PRESSS(JH,JV)
          CALL CAIMMA (ZMATBI(1,1),JPNPM2,ZDXMB(1,1,JV),JPNPM,INPRS,KNLX)
          CALL ABOR1 ('Erreur dans CANADA - syst. lineaire')
        ELSEIF ( IITER > 1 ) THEN
          WRITE (NULOUT,505) IITER
          WRITE (NULOUT,502) PLATA(JH),PLONA(JH),KNLX,KNX
          WRITE (NULOUT,504) PRESSS(JH,JV)
        ENDIF

!  calcul des variances d'erreur d'analyse sur ce point

        DO JX = 1 , KNLX
          ZVAR = PSIGPS(JH,JX,JV) **2 &
           & - RDOT(INPRS,ZPOIDS(1,JX,JV),1,ZDXMB(1,JX,JV),1)  
          IF ( ZVAR < 0.0_JPRB ) THEN
            WRITE(NULOUT,*) 'CANADA: variance analysee <0 ',&
             & ZVAR,PLATA(JH),PLONA(JH),&
             & PRESSS(JH,JV),KNX(JX),INPRS  
            PSIGA(JH,JX,JV) = PSIGPS(JH,JX,JV)
          ELSE
            PSIGA(JH,JX,JV) = SQRT(ZVAR)
          ENDIF
        ENDDO

!  calcul des residus analyses

        CALL MXMAOP(ZPOIDS(1,1,JV), JPNPM2, 1, ZRESID(1), 1, 1,&
         & PRESIA(JH,1,JV), KNBPH, 1, KNLX, INPRS, 1)  
      ENDIF

!-----------------------------------------------------------------------
!  - 4 -  Fin des boucles
!         ---------------

    ENDDO

  ENDIF

ENDDO

!-----------------------------------------------------------------------
!  - 5 -  Formats
!         -------

501 FORMAT(' ! CANADA: divergence de l''algorithme de resolution ',&
 & 'du systeme lineaire')  
502 FORMAT(' lat:',F7.2,' lon:',F7.2,I3,' mod.stat:',10I4)
503 FORMAT(' verticale a analyser:',I3,' niveaux de pressions:')
504 FORMAT(' pression du point:',F10.2)
505 FORMAT(' ! CANADA: il a fallu',I2,' iterations pour resoudre ',&
 & 'le systeme lineaire')  

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