eggmlt.F90

Go to the documentation of this file.

SUBROUTINE eggmlt (PRPI, KDLUX, KDLUN, KDGUX, KDGUN, KULOUT,&
 & KPRINT, PRPK, PLON0U, PLON1U, PLON2U, KSOTRP, PLAT1R, PLAT2R,&
 & PHSUD,PBETA)  

!--------------------------------------------------------------------------
!     GEOGRAPHY OF GRID-POINTS AUXILLARY ROUTINE
!     LATITUDE FOR ISOTROPIC GRID
!     ARPEGE-ALADIN
!     ------------------------------------------

!     GIVEN THE PROJECTION PARAMETER (PRPK), THE LONGITUDES AND
!     ONE LATITUDE, EGGMLT PROVIDES THE OTHER LATITUDE IN SUCH A WAY
!     THAT THE GRID SIZE WILL BE THE SAME FOLLOWING X AND Y

!     THIS ROUTINE IS CALLED AND CAN BE USED ONLY IN CONNECTION WITH
!     SUBROUTINE EGGX

!     INPUT PARAMETERS
!     ----------------
!      PRPI :  PI
!      KDLUN, KDLUX : ADRESSES OF EXTREME POINTS OF USEFUL DOMAIN IN X
!      KDGUN, KDGUX :                                                Y
!      KULOUT : OUTPUT FILE UNIT
!      KPRINT : IMPRESSIONS SEULEMENT SI KPRINT = 1
!      PRPK : PROJECTION PARAMETER, SEE EGGX
!      PLON0U : REFERENCE LONGITUDE (MODIFIED FOR DOMAINS ASTRIDE GREEWICH)
!      PLON1U : LONGITUDE OF SW CORNER (EQUALLY MODIFIED)
!      PLON2U : LONGITUDE OF NE CORNER
!      KSOTRP = 0, PLAT1R, PLAT2R KNOWN : EGGMLT SHOULD NOT BE CALLED
!             = 1, PLAT1R KNOWN, EGGMLT COMPUTES PLAT2R
!             = 2, PLAT2R KONWN, EGGMLT COMPUTES PLAT1R
!      PLAT1R : LATITUDE OF SW CORNER
!      PLAT2R : LATITUDE OF NE CORNER
!      PHSUD  = 1., NORTH HEMISPHERE MAPPING OR MERCATOR
!             = -1., SOUTH HEMISPHERE MAPPING
!      PBETA  : ANGLE BETWEEN X-AXIS AND LATITUDE AT PLON0

!     OUTPUT PARAMETERS
!     -----------------
!      EITHER PLAT1R IF KSOTRP = 2
!      OR     PLAT2R IF KSOTRP = 1

!     WRITTEN BY
!     ---------- ALAIN JOLY

!     ORIGINAL NORTHERN HEMISPHERE VERSION : 31/1/92
!     SOUTH HEMISPEHER VERSION : 27/1/93
!--------------------------------------------------------------------------

USE parkind1  ,ONLY : jpim     ,jprb
USE yomhook   ,ONLY : lhook,   dr_hook

!--------------------------------------------------------------------------

IMPLICIT NONE

REAL(KIND=JPRB)   ,INTENT(IN)    :: PRPI 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDLUX 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDLUN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGUX 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGUN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KULOUT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPRINT 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRPK 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLON0U 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLON1U 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLON2U 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSOTRP 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PLAT1R 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PLAT2R 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PHSUD 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PBETA 

!--------------------------------------------------------------------------

REAL(KIND=JPRB) :: ZCS, ZCS1, ZCS2, ZDCLA1, ZDCLA2, ZPIS2, ZPIS4,&
 & ZRAPP, ZTG1, ZTG2, ZTGK1, ZTGK2  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!--------------------------------------------------------------------------
IF (lhook) CALL dr_hook('EGGMLT',0,zhook_handle)
!--------------------------------------------------------------------------

IF ( kprint == 1 ) THEN
  WRITE (kulout,*) ' '
  WRITE (kulout,*) ' --- EGGMLT --- '
  WRITE (kulout,*) ' '
ENDIF
zpis2 = prpi*0.5_jprb
zpis4 = prpi*0.25_jprb

IF ( ksotrp >= 1.AND. prpk /= 0.0_jprb ) THEN

  ! * STEREO LAMBERT PROJECTION
  zrapp = phsud*(REAL( kdlux-kdlun ,jprb)/REAL( kdgux-kdgun ,jprb))
  zcs1 = cos( prpk*(plon1u-plon0u)-pbeta )*zrapp +&
   & sin( prpk*(plon1u-plon0u)-pbeta )  
  IF ( kprint == 1 ) THEN
    WRITE (kulout,*) ' ZRAPP = ',zrapp
    WRITE (kulout,*) ' PLON1U = ',plon1u,' 0U = ',plon0u
    WRITE (kulout,*) ' PLON1U-PLON0U ',plon1u-plon0u
  ENDIF
  zcs2 = cos( prpk*(plon2u-plon0u)-pbeta )*zrapp +&
   & sin( prpk*(plon2u-plon0u)-pbeta )  
  IF ( ksotrp == 1 ) THEN
    zdcla1 = zpis4 - 0.5_jprb*plat1r
    ztgk1 = tan( zdcla1 )**prpk
    ztg2 = ( ztgk1*zcs1/zcs2 )**(1.0_jprb/prpk)
    plat2r = zpis2 - 2.0_jprb*atan( ztg2 )
    IF ( kprint == 1 ) THEN
      WRITE (kulout,*) ' '
      WRITE (kulout,*) ' NE LATITUDE PLAT2 MODIFIED '
      WRITE (kulout,*) ' ZTGK1 = ',ztgk1
      WRITE (kulout,*) ' ZCS1 = ',zcs1
      WRITE (kulout,*) ' ZCS2 = ',zcs2
      WRITE (kulout,*) ' ROTATED LATITUDE LAT2 R = ',plat2r
    ENDIF
  ENDIF
  IF ( ksotrp == 2 ) THEN
    zdcla2 = zpis4 - 0.5_jprb*plat2r
    ztgk2 = tan( zdcla2 )**prpk
    ztg1 = ( ztgk2*zcs2/zcs1 )**(1.0_jprb/prpk)
    plat1r = zpis2 - 2.0_jprb*atan( ztg1 )
    IF ( kprint == 1 ) THEN
      WRITE (kulout,*) ' '
      WRITE (kulout,*) ' NE LATITUDE PLAT1 MODIFIED '
      WRITE (kulout,*) ' ROTATED LATITUDE LAT1 R = ',plat1r
    ENDIF
  ENDIF
ELSEIF ( ksotrp >= 1.AND. prpk == 0.0_jprb ) THEN

  ! * MERCATOR PROJECTION
  zrapp = REAL( kdgux-kdgun ,jprb)/REAL( kdlux-kdlun ,jprb)
  zcs = ( plon2u - plon1u )*(zrapp*cos(pbeta)+sin(pbeta))&
   & /(cos(pbeta)-zrapp*sin(pbeta))  
  IF ( ksotrp == 1 ) THEN
    zdcla1 = zpis4 - 0.5_jprb*plat1r
    ztgk1 = log( tan( zdcla1 ) )
    ztg2 = exp( ztgk1 - zcs )
    plat2r = zpis2 - 2.0_jprb*atan( ztg2 )
    IF ( kprint == 1 ) THEN
      WRITE (kulout,*) ' '
      WRITE (kulout,*) ' NE LATITUDE PLAT2 MODIFIED '
      WRITE (kulout,*) ' ROTATED LATITUDE LAT2 R = ',plat2r
    ENDIF
  ENDIF
  IF ( ksotrp == 2 ) THEN
    zdcla2 = zpis4 - 0.5_jprb*plat2r
    ztgk2 = log( tan( zdcla2 ) )
    ztg1 = exp( ztgk2 + zcs )
    plat1r = zpis2 - 2.0_jprb*atan( ztg1 )
    IF ( kprint == 1 ) THEN
      WRITE (kulout,*) ' '
      WRITE (kulout,*) ' NE LATITUDE PLAT1 MODIFIED '
      WRITE (kulout,*) ' ROTATED LATITUDE LAT1 R = ',plat1r
    ENDIF
  ENDIF
ELSEIF (ksotrp == 0 ) THEN
  WRITE (kulout,*) ' EGGMLT USELESSLY CALLED '
ENDIF

IF ( kprint == 1 ) THEN
  WRITE (kulout,*) ' EGGMLT OVER '
  WRITE (kulout,*) ' '
ENDIF

!--------------------------------------------------------------------------
IF (lhook) CALL dr_hook('EGGMLT',1,zhook_handle)
END SUBROUTINE eggmlt