susat.F90

Go to the documentation of this file.

SUBROUTINE susat

!**** *SUSAT*   - INITIALIZE COMMON YOESAT

!     PURPOSE.
!     --------
!           INITIALIZE YOESAT, THE COMMON THAT CONTROLS THE
!           SIMULATION OF SATELLITE RADIANCES

!**   INTERFACE.
!     ----------
!        *CALL* *SUSAT

!        EXPLICIT ARGUMENTS :
!        --------------------
!            NONE

!        IMPLICIT ARGUMENTS :
!        --------------------
!        COMMON YOESAT

!     METHOD.
!     -------
!        SEE DOCUMENTATION

!     EXTERNALS.
!     ----------
!        NONE

!     REFERENCE.
!     ----------
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE
!     "IN CORE MODEL"

!     AUTHOR.
!     -------
!        JEAN-JACQUES MORCRETTE  *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 88-12-15
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE yomlun_ifsaux   , ONLY : nulout
USE yomcst          , ONLY : rpi
USE yoesat          , ONLY : ngeo     ,rgalt    ,rgnad    ,rgnor    ,&
 & rgsou    ,rgwst    ,rgeas    ,lgeose   ,lgeosw   ,&
 & lgms     ,lindsa   ,lmto  

IMPLICIT NONE

INTEGER(KIND=JPIM) :: ISATEL, JSATEL

REAL(KIND=JPRB) :: ZDEGRAD
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!*CALL COMDOC
!----------------------------------------------------------------------

!*       1.    SET DEFAULT VALUES.
!              -------------------

IF (lhook) CALL dr_hook('SUSAT',0,zhook_handle)
isatel=5
DO jsatel = 1 , isatel
  rgalt(jsatel) = 0.0_jprb
  rgnad(jsatel) = 0.0_jprb
  rgnor(jsatel) = 0.0_jprb
  rgsou(jsatel) = 0.0_jprb
  rgwst(jsatel) = 0.0_jprb
  rgeas(jsatel) = 0.0_jprb
ENDDO

IF (ngeo /= 0) THEN

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

!*       2.    MODIFY DEFAULT VALUES FOR THE VARIOUS GEO.SATELLITES
!              ----------------------------------------------------

  isatel = 0
  zdegrad = rpi / 180._jprb

  WRITE(unit=nulout,fmt='('' COMMON YOESAT '')')
  WRITE(unit=nulout,fmt='('' NGEO  = '',I1 )') ngeo
!      ----------------------------------------------------------------

!*       2.1   GOES EAST SATELLITE
!              -------------------

  IF (lgeose) THEN
    isatel = isatel + 1
    rgalt(isatel) = 0.0_jprb
    rgalt(isatel) = 35793000._jprb
    rgnad(isatel) = 285._jprb * zdegrad
    rgnor(isatel) = +70._jprb * zdegrad
    rgsou(isatel) = -70._jprb * zdegrad
    rgwst(isatel) = rgnad(isatel) -70._jprb * zdegrad
    rgeas(isatel) = rgnad(isatel) +70._jprb * zdegrad
    WRITE(unit=nulout,fmt='('' LGOESE = '',L5 &
     & ,'' ALTITUDE  ='',F10.0 &
     & ,'' LONG.NADIR='',F9.6 &
     & ,'' LIMFOV N. ='',F9.6 &
     & ,'' S. ='',F9.6 &
     & ,'' W. ='',F9.6 &
     & ,'' E. ='',F9.6 &
     & )')&
     & lgeose,rgalt(isatel),rgnad(isatel)&
     & ,rgnor(isatel),rgsou(isatel),rgwst(isatel),rgeas(isatel)  
  ENDIF

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

!*       2.2   GOES WEST SATELLITE
!              -------------------

  IF (lgeosw) THEN
    isatel = isatel + 1
    rgalt(isatel) = 0.0_jprb
    rgalt(isatel) = 35793000._jprb
    rgnad(isatel) = 225._jprb * zdegrad
    rgnor(isatel) = +70._jprb * zdegrad
    rgsou(isatel) = -70._jprb * zdegrad
    rgwst(isatel) = rgnad(isatel) -70._jprb * zdegrad
    rgeas(isatel) = rgnad(isatel) +70._jprb * zdegrad
    WRITE(unit=nulout,fmt='('' LGEOSW = '',L5 &
     & ,'' ALTITUDE  ='',F10.0 &
     & ,'' LONG.NADIR='',F9.6 &
     & ,'' LIMFOV N. ='',F9.6 &
     & ,'' S. ='',F9.6 &
     & ,'' W. ='',F9.6 &
     & ,'' E. ='',F9.6 &
     & )')&
     & lgeosw,rgalt(isatel),rgnad(isatel)&
     & ,rgnor(isatel),rgsou(isatel),rgwst(isatel),rgeas(isatel)  
  ENDIF

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

!*       2.3   G.M.S. SATELLITE
!              ----------------

  IF (lgms) THEN
    isatel = isatel + 1
    rgalt(isatel) = 0.0_jprb
    rgalt(isatel) = 35793000._jprb
    rgnad(isatel) = 140._jprb * zdegrad
    rgnor(isatel) = +70._jprb * zdegrad
    rgsou(isatel) = -70._jprb * zdegrad
    rgwst(isatel) = rgnad(isatel) -70._jprb * zdegrad
    rgeas(isatel) = rgnad(isatel) +70._jprb * zdegrad
    WRITE(unit=nulout,fmt='('' LGMS   = '',L5 &
     & ,'' ALTITUDE  ='',F10.0 &
     & ,'' LONG.NADIR='',F9.6 &
     & ,'' LIMFOV N. ='',F9.6 &
     & ,'' S. ='',F9.6 &
     & ,'' W. ='',F9.6 &
     & ,'' E. ='',F9.6 &
     & )')&
     & lgms,rgalt(isatel),rgnad(isatel)&
     & ,rgnor(isatel),rgsou(isatel),rgwst(isatel),rgeas(isatel)  
  ENDIF

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

!*       2.4   INDSAT SATELLITE
!              ----------------

  IF (lindsa) THEN
    isatel = isatel + 1
    rgalt(isatel) = 0.0_jprb
    rgalt(isatel) = 35793000._jprb
! ????      RGNAD(ISATEL) = 70. * ZDEGRAD
    rgnad(isatel) = 0.0_jprb
    rgnor(isatel) = +70._jprb * zdegrad
    rgsou(isatel) = -70._jprb * zdegrad
    rgwst(isatel) = 0.0_jprb
    rgeas(isatel) = 0.0_jprb
    WRITE(unit=nulout,fmt='('' LINDSA = '',L5 &
     & ,'' ALTITUDE  ='',F10.0 &
     & ,'' LONG.NADIR='',F9.6 &
     & ,'' LIMFOV N. ='',F9.6 &
     & ,'' S. ='',F9.6 &
     & ,'' W. ='',F9.6 &
     & ,'' E. ='',F9.6 &
     & )')&
     & lindsa,rgalt(isatel),rgnad(isatel)&
     & ,rgnor(isatel),rgsou(isatel),rgwst(isatel),rgeas(isatel)  
  ENDIF

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

!*       2.5   METEOSAT SATELLITE
!              ------------------

  IF (lmto) THEN
    isatel = isatel + 1
    rgalt(isatel) = 35793000._jprb
    rgnad(isatel) = 0.0_jprb * zdegrad
    rgnor(isatel) = +70._jprb * zdegrad
    rgsou(isatel) = -70._jprb * zdegrad
    rgwst(isatel) = 2.0_jprb * rpi - 70._jprb * zdegrad
    rgeas(isatel) = +70._jprb * zdegrad
    WRITE(unit=nulout,fmt='('' LMTO   = '',L5 &
     & ,'' ALTITUDE  ='',F10.0 &
     & ,'' LONG.NADIR='',F9.6 &
     & ,'' LIMFOV N. ='',F9.6 &
     & ,'' S. ='',F9.6 &
     & ,'' W. ='',F9.6 &
     & ,'' E. ='',F9.6 &
     & )')&
     & lmto,rgalt(isatel),rgnad(isatel)&
     & ,rgnor(isatel),rgsou(isatel),rgwst(isatel),rgeas(isatel)  
  ENDIF

ENDIF

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

IF (lhook) CALL dr_hook('SUSAT',1,zhook_handle)
END SUBROUTINE susat