regrot_lonlat_rot.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
!     #################################################################################
SUBROUTINE regrot_lonlat_rot(PXREG,PYREG,PXROT,PYROT,KXDIM,KYDIM,KX,KY, &
                         pxcen,pycen,kcall)  
!     #################################################################################
!
!!    PURPOSE
!!    -------
!!
!!    CONVERSION BETWEEN REGULAR AND ROTATED SPHERICAL COORDINATES.
!!
!!    PXREG     LONGITUDES OF THE REGULAR COORDINATES
!!    PYREG     LATITUDES OF THE REGULAR COORDINATES
!!    PXROT     LONGITUDES OF THE ROTATED COORDINATES
!!    PYROT     LATITUDES OF THE ROTATED COORDINATES
!!              ALL COORDINATES GIVEN IN DEGREES N (NEGATIVE FOR S)
!!              AND DEGREES E (NEGATIVE VALUES FOR W)
!!    KXDIM     DIMENSION OF THE GRIDPOINT FIELDS IN THE X-DIRECTION
!!    KYDIM     DIMENSION OF THE GRIDPOINT FIELDS IN THE Y-DIRECTION
!!    KX        NUMBER OF GRIDPOINT IN THE X-DIRECTION
!!    KY        NUMBER OF GRIDPOINTS IN THE Y-DIRECTION
!!    PXCEN     REGULAR LONGITUDE OF THE SOUTH POLE OF THE ROTATED GRID
!!    PYCEN     REGULAR LATITUDE OF THE SOUTH POLE OF THE ROTATED GRID
!!
!!    KCALL=-1: FIND REGULAR AS FUNCTIONS OF ROTATED COORDINATES.
!!    KCALL= 1: FIND ROTATED AS FUNCTIONS OF REGULAR COORDINATES.
!!
!!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!    J.E. HAUGEN   HIRLAM   JUNE -92
!!
!!    AUTHOR
!!    ------
!!     U. Andrae
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    10/2007
!!------------------------------------------------------------------
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
IMPLICIT NONE

!
!-----------------------------------------------------------------------
!
INTEGER kxdim,kydim,kx,ky,kcall
REAL pxreg(kxdim,kydim),pyreg(kxdim,kydim), &
            pxrot(kxdim,kydim),pyrot(kxdim,kydim), &
            pxcen,pycen  
!
!-----------------------------------------------------------------------
!
REAL pi,zrad,zsycen,zcycen,zxmxc,zsxmxc,zcxmxc,zsyreg,zcyreg, &
      zsyrot,zcyrot,zcxrot,zsxrot,zradi  
INTEGER jy,jx
REAL(KIND=JPRB) :: zhook_handle
!
!-----------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('REGROT_LONLAT_ROT',0,zhook_handle)
pi = 4.*atan(1.)
zrad = pi/180.
zradi = 1./zrad
zsycen = sin(zrad*(pycen+90.))
zcycen = cos(zrad*(pycen+90.))
!
IF (kcall.EQ.1) THEN
!
  DO jy = 1,ky
    DO jx = 1,kx
!
      zxmxc  = zrad*(pxreg(jx,jy) - pxcen)
      zsxmxc = sin(zxmxc)
      zcxmxc = cos(zxmxc)
      zsyreg = sin(zrad*pyreg(jx,jy))
      zcyreg = cos(zrad*pyreg(jx,jy))
      zsyrot = zcycen*zsyreg - zsycen*zcyreg*zcxmxc
      zsyrot = max(zsyrot,-1.0)
      zsyrot = min(zsyrot,+1.0)
!
      pyrot(jx,jy) = asin(zsyrot)*zradi
!
      zcyrot = cos(pyrot(jx,jy)*zrad)
      zcxrot = (zcycen*zcyreg*zcxmxc +     &
                 zsycen*zsyreg)/zcyrot  
      zcxrot = max(zcxrot,-1.0)
      zcxrot = min(zcxrot,+1.0)
      zsxrot = zcyreg*zsxmxc/zcyrot
!
      pxrot(jx,jy) = acos(zcxrot)*zradi
!
      IF (zsxrot.LT.0.0) pxrot(jx,jy) = -pxrot(jx,jy)
!
    ENDDO
  ENDDO
!
ELSEIF (kcall.EQ.-1) THEN
!
  DO jy = 1,ky
    DO jx = 1,kx
!
      zsxrot = sin(zrad*pxrot(jx,jy))
      zcxrot = cos(zrad*pxrot(jx,jy))
      zsyrot = sin(zrad*pyrot(jx,jy))
      zcyrot = cos(zrad*pyrot(jx,jy))
      zsyreg = zcycen*zsyrot + zsycen*zcyrot*zcxrot
      zsyreg = max(zsyreg,-1.0)
      zsyreg = min(zsyreg,+1.0)
!
      pyreg(jx,jy) = asin(zsyreg)*zradi
!
      zcyreg = cos(pyreg(jx,jy)*zrad)
      zcxmxc = (zcycen*zcyrot*zcxrot -     &
                       zsycen*zsyrot)/zcyreg  
      zcxmxc = max(zcxmxc,-1.0)
      zcxmxc = min(zcxmxc,+1.0)
      zsxmxc = zcyrot*zsxrot/zcyreg
      zxmxc  = acos(zcxmxc)*zradi
      IF (zsxmxc.LT.0.0) zxmxc = -zxmxc
!
      pxreg(jx,jy) = zxmxc + pxcen
!
  ENDDO
ENDDO
!
ELSE
  WRITE(6,'(1X,''INVALID KCALL IN REGROT_LONLAT_ROT'')')
  CALL abort
ENDIF
IF (lhook) CALL dr_hook('REGROT_LONLAT_ROT',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
END SUBROUTINE regrot_lonlat_rot
!