swtt1.F90

Go to the documentation of this file.

SUBROUTINE swtt1 ( KIDIA,KFDIA,KLON,KNU,KABS,KIND, PU, PTR )

!**** *SWTT1* - COMPUTES THE SHORTWAVE TRANSMISSION FUNCTIONS

!     PURPOSE.
!     --------
!           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
!     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
!     INTERVALS.

!**   INTERFACE.
!     ----------
!          *SWTT1* IS CALLED FROM *SW1S*.

!        EXPLICIT ARGUMENTS :
!        --------------------
! KNU    :                     ; INDEX OF THE SPECTRAL INTERVAL
! KABS   :                     ; NUMBER OF ABSORBERS
! KIND   : (KABS)              ; INDICES OF THE ABSORBERS
! PU     : (KLON,KABS)         ; ABSORBER AMOUNT
!     ==== OUTPUTS ===
! PTR    : (KLON,KABS)         ; TRANSMISSION FUNCTION

!        IMPLICIT ARGUMENTS :   NONE
!        --------------------

!     METHOD.
!     -------

!          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
!     AND HORNER'S ALGORITHM.

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

!          NONE

!     REFERENCE.
!     ----------

!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS

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

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 95-01-20
!        03-10-10 Deborah Salmond and Marta Janiskova Optimisation
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
   
!-----------------------------------------------------------------------

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

USE yoesw    , ONLY : apad     ,bpad     ,d

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KABS 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNU 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIND(kabs) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PU(klon,kabs) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTR(klon,kabs) 
!-----------------------------------------------------------------------

!*       0.1   ARGUMENTS
!              ---------

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

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

REAL(KIND=JPRB) :: ZR1(klon), ZR2(klon), ZU(klon)
REAL(KIND=JPRB) :: ZRR

INTEGER(KIND=JPIM) :: IA, JA, JL
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

!*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION

IF (lhook) CALL dr_hook('SWTT1',0,zhook_handle)
DO ja = 1,kabs
  ia=kind(ja)
! print *,'SWTT1: KNU', KNU
  DO jl = kidia,kfdia
    zu(jl) = pu(jl,ja)
    zr1(jl) = apad(knu,ia,1) + zu(jl) * (apad(knu,ia,2) + zu(jl)&
     & * ( apad(knu,ia,3) + zu(jl) * (apad(knu,ia,4) + zu(jl)&
     & * ( apad(knu,ia,5) + zu(jl) * (apad(knu,ia,6) + zu(jl)&
     & * ( apad(knu,ia,7) ))))))  
!    print *,'SWTT1 ZU APAD',IA,ZU(JL),APAD(KNU,IA,1),APAD(KNU,IA,2),&
!    &APAD(KNU,IA,3),APAD(KNU,IA,4),APAD(KNU,IA,5),APAD(KNU,IA,6),APAD(KNU,IA,7)

    zr2(jl) = bpad(knu,ia,1) + zu(jl) * (bpad(knu,ia,2) + zu(jl)&
     & * ( bpad(knu,ia,3) + zu(jl) * (bpad(knu,ia,4) + zu(jl)&
     & * ( bpad(knu,ia,5) + zu(jl) * (bpad(knu,ia,6) + zu(jl)&
     & * ( bpad(knu,ia,7) ))))))  
    zrr=1.0_jprb/zr2(jl)

!*         2.      ADD THE BACKGROUND TRANSMISSION

    ptr(jl,ja) = (zr1(jl)*zrr) * (1.0_jprb-d(knu,ia)) + d(knu,ia)
  ENDDO
ENDDO
!WRITE(*,'("---> Dans SWTT1, PTR : "10E12.5)') (PTR(1,JA),JA=1,KABS)

IF (lhook) CALL dr_hook('SWTT1',1,zhook_handle)
END SUBROUTINE swtt1