SUBROUTINE LWPRNUAGE &
 & (KLON,K_IR,K_NBATM,K_NBNEUR,K_NCOU,K_NBNEURMAX,K_NBR, &
 & P_WNELN,PYNXN1,PSORTIENO )  

!**** *LWPRNUAGE*   - COMPUTATION FOR LW RADIATION
!                         (CLOUDY ATMOSPHERE)

!     PURPOSE.
!     --------  

!**   INTERFACE.
!     ----------

!        *LWPRNUAGE* IS CALLED FROM LWINTERF

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

!     INPUT PARAMETERS (REAL):

! PYNXN1 : (KLON,0:NBNEURMAX,0:NCOU)

!     OUTPUT PARAMETERS (REAL):

! PSORTIENO : (KLON,NBNEURMAX)

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

!     METHOD.
!     -------

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

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

!     AUTHORS.
!     --------
!        F. CHEVALLIER          *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 99-05
!        M.Hamrud     01-Oct-2003 CY28 Cleaning
!        J .Hague     15-Mar-2005 CY29R1 Tuning
!-----------------------------------------------------------------------

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_NCOU 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_NBNEURMAX 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_NBR 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_IR 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_NBATM 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_NBNEUR(0:K_NCOU,K_NBR) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_WNELN(0:K_NBNEURMAX,K_NBNEURMAX,K_NCOU,K_NBR) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PYNXN1(KLON,0:K_NBNEURMAX,0:K_NCOU) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSORTIENO(KLON,K_NBNEURMAX) 
!-------------------------------------------------------------------

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

REAL(KIND=JPRB) :: ZSN(KLON)
REAL(KIND=JPRB) :: ZJP(KLON)
REAL(KIND=JPRB) :: ZJN(KLON)
REAL(KIND=JPRB) :: Z1(KLON)
REAL(KIND=JPRB) :: Z2(KLON)

INTEGER(KIND=JPIM) :: ILEN

INTEGER(KIND=JPIM) :: ILN,IATM
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

!*         1.

IF (LHOOK) CALL DR_HOOK('LWPRNUAGE',0,ZHOOK_HANDLE)
ZJP = 0.0_JPRB
ZJN = 0.0_JPRB
DO ILN=1,K_NBNEUR(1,K_IR)

  CALL DGEMV('N',K_NBATM,K_NBNEUR(0,K_IR)+1,1.0_JPRB,PYNXN1(1,0,0), &
     & KLON,P_WNELN(0,ILN,1,K_IR),1,0.0_JPRB,ZSN,1)

  IF(N_VMASS == 0) THEN ! DO NOT USE VECTOR MASS

    DO IATM = 1,K_NBATM
      PYNXN1(IATM,ILN,1)=TANH(ZSN(IATM))
    ENDDO

  ELSE !  USE VECTOR MASS

    ILEN=K_NBATM
    DO IATM = 1,K_NBATM
      ZJP(IATM)= ZSN(IATM)
      ZJN(IATM)=-ZSN(IATM)
    ENDDO
    CALL VEXP(Z1,ZJP,ILEN)
    CALL VEXP(Z2,ZJN,ILEN)
    DO IATM = 1,K_NBATM
      PYNXN1(IATM,ILN,1)=(Z1(IATM)-Z2(IATM))/(Z1(IATM)+Z2(IATM))
    ENDDO

  ENDIF
ENDDO

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

!*         2.

CALL DGEMM('N','N',K_NBATM,K_NBNEUR(2,K_IR),K_NBNEUR(1,K_IR)+1, &
  & 1.0_JPRB,PYNXN1(1,0,1),KLON,P_WNELN(0,1,2,K_IR),K_NBNEURMAX+1,0.0_JPRB,PSORTIENO,KLON)

IF (K_NBNEUR(0,1) == 98) THEN
  DO ILN=1,K_NBNEUR(2,K_IR)
    DO IATM = 1,K_NBATM
      PSORTIENO(IATM,ILN) = TANH(PSORTIENO(IATM,ILN))
    ENDDO
  ENDDO
ENDIF

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

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