SUBROUTINE TRARECA (PSLAC,PSLOC,PCLOC,PSLAR,PSLOR,PCLOR,KLEN,&
 & PSLAP,PCLAP,PSLOP,PCLOP,PFACDI,KTYP)  

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!                                                                      C
!     ROUTINE DE PASSAGE DE LA SPHERE REELLE A LA SPHERE DE CALCUL     C
!     ------- -- ------- -- -- ------ ------ - -- ------ -- ------     C
!                                                                      C
!           VERSION 1.0   J.-F. GELEYN   18/01/88  (RETOCA)            C
!        MODIF 07/02/91  Y. BOUTELOUP  ----->  SUPPRESSION DU COMMON   C
!        Modif 05/06/91  Y. Bouteloup  ----->  Suppression de la       C
!                                              derniere rotation       C
!        Modified 05/11/95 M.Hamrud  -----> security for PSLAC if      C
!                                           KTYP=1                     C
!        Modified 20/11/00 R. El Khatib ---> security PSLOC/PCLOC      C
!                                            at pole of interest       C
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

!     FONCTION
!     --------

!     TRANSFORME UN VECTEUR DE LONGUEUR KLEN DE POINTS DE LA SPHERE
!  REELLE EN UN VECTEUR DE MEME LONGUEUR DE POINTS DE LA SPHERE ASSOCIEE
!  A LA GRILLE DE COLLOCATION DU MODELE. LES POINTS SONT CARACTERISES
!  SUR CHAQUE SPHERE PAR LE SINUS DE LA LATITUDE, LE SINUS DE LA
!  LONGITUDE ET LE COSINUS DE LA LONGITUDE.
!  LA SPHERE DE CALCUL EST DEFINIE DE LA MANIERE SUIVANTE : LE POLE DE
!  DILATATION EST SITUE A LA LONGITUDE PI SUR UN EQUATEUR TANGENT A LA
!  COURBE TRANSFORMEE DU PARALLELE REEL EN CE POINT, LES DEUX DIRECTIONS
!  POSITIVES (OUEST-EST) COINCIDANT.
!  LA TRANSFORMATION CONFORME DE SPHERE A SPHERE EST DEFINIE PAR LES
!  SINUS ET COSINUS DE LA LATITUDE ET DE LA LONGITUDE DU POLE DE
!  DILATATION ET PAR LE FACTEUR DE DILATATION (SUPERIEUR OU EGAL A UN).

!     VARIABLES D'ENTREE
!     --------- --------

!  PSLAR = SINUS DE LA LATITUDE REELLE
!  PSLOR = SINUS DE LA LONGITUDE REELLE
!  PCLOR = COSINUS DE LA LONGITUDE REELLE

!     VARIABLE DE CONTROLE
!     -------- -- --------

!  KLEN = LONGUEUR DES VECTEURS D'ENTREE ET DE SORTIE

!     VARIABLES DE SORTIE
!     --------- -- ------

!  PSLAC = SINUS DE LA PSEUDO-LATITUDE SUR LA SPHERE DE CALCUL
!  PSLOC = SINUS DE LA PSEUDO-LONGITUDE SUR LA SPHERE DE CALCUL
!  PCLOC = COSINUS DE LA PSEUDO-LONGITUDE SUR LA SPHERE DE CALCUL

!     PARAMETRES DE LA TRANSFORMATION
!     ---------- -- -- --------------

!  PSLAP  = SINUS DE LA LATITUDE REELLE DU POLE DE DILATATION
!  PCLAP  = COSINUS DE LA LATITUDE REELLE DU POLE DE DILATATION
!  PSLOP  = SINUS DE LA LONGITUDE REELLE DU POLE DE DILATATION
!  PCLOP  = COSINUS DE LA LONGITUDE REELLE DU POLE DE DILATATION
!  PFACDI = FACTEUR DE DILATATION
!  KTYP   = TYPE DE LA TRANSFORMATION   KTYP=1 -->  SCHMIDT SEULE
!                                       KTYP=2 -->  ARPEGE COMPLETE
!     CONSTANTE DE CALCUL
!     --------- -- ------

!  ZEPS = VALEUR DE SECURITE NUMERIQUE

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSLAC(KLEN) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSLOC(KLEN) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCLOC(KLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSLAR(KLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSLOR(KLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLOR(KLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSLAP 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLAP 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSLOP 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLOP 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFACDI 
INTEGER(KIND=JPIM),INTENT(IN)    :: KTYP 
INTEGER(KIND=JPIM) :: JL

REAL(KIND=JPRB) :: ZA, ZB, ZC2M1, ZC2P1, ZCLAR, ZCRAP, ZDBLC, ZEPS
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

IF (LHOOK) CALL DR_HOOK('TRARECA',0,ZHOOK_HANDLE)
ZDBLC=2.0_JPRB*PFACDI
ZC2P1=PFACDI*PFACDI+1.0_JPRB
ZC2M1=PFACDI*PFACDI-1.0_JPRB
ZCRAP=-ZC2M1/ZC2P1
ZEPS=1.E-12_JPRB

!  -------------------------------------------------------
!       TRANSFORMATION ARPEGE COMPLETE

IF (KTYP == 2) THEN
  DO JL=1,KLEN
    ZCLAR=SQRT(1.0_JPRB-PSLAR(JL)*PSLAR(JL))
    ZA=PSLAP*PSLAR(JL)+PCLAP*ZCLAR*(PCLOP*PCLOR(JL)+PSLOP*PSLOR(JL))
    PSLAC(JL)=(ZCRAP+ZA)/(1.0_JPRB+ZA*ZCRAP)
    ZB=1.0_JPRB/(SQRT(MAX(ZEPS,1.0_JPRB-ZA*ZA)))
    PCLOC(JL)=(PCLAP*PSLAR(JL)-PSLAP*ZCLAR*(PCLOP*PCLOR(JL)+PSLOP &
     & *PSLOR(JL)) ) * ZB  
    PSLOC(JL)=ZCLAR*(PSLOP*PCLOR(JL)-PCLOP*PSLOR(JL)) * ZB
    PSLAC(JL)=MAX(-1.0_JPRB, MIN(1.0_JPRB,PSLAC(JL)))
    PCLOC(JL)=MAX(-1.0_JPRB, MIN(1.0_JPRB,PCLOC(JL)))
    PSLOC(JL)=MAX(-1.0_JPRB, MIN(1.0_JPRB,PSLOC(JL)))
  ENDDO
  DO JL=1,KLEN
    IF (PCLOC(JL)**2+PSLOC(JL)**2 < 0.5_JPRB ) THEN
      PSLOC(JL)=1.0_JPRB
      PCLOC(JL)=0.0_JPRB
    ENDIF
  ENDDO

!     ------------------------------------------------------------------
!    TRANSFORMATION DE SCHMIDT SEULE

ELSEIF (KTYP == 1) THEN
  DO JL=1,KLEN
    PSLOC(JL)=PSLOR(JL)
    PCLOC(JL)=PCLOR(JL)
    PSLAC(JL)=(ZC2P1*PSLAR(JL)-ZC2M1)/(ZC2P1-ZC2M1*PSLAR(JL))
    PSLAC(JL)=MAX(-1.0_JPRB,MIN(1.0_JPRB,PSLAC(JL)))
  ENDDO
ELSE
  CALL ABOR1('TRARECA: ABOR1 CALLED')
ENDIF

IF (LHOOK) CALL DR_HOOK('TRARECA',1,ZHOOK_HANDLE)
END SUBROUTINE TRARECA

