SUBROUTINE WRRADCOEF (KSTA,KEND,KJUMP,&
 & KFIELDSS,&
 & PRAB3C,PRAB3N,PRAB4C,PRAB4N,PRAB6C,PRAB6N,&
 & PRAT1C,PRAT1N,PRAT2C,PRAT2N,PRAT3C,PRAT3N,&
 & PRAT4C,PRAT4N,PRAT5C,PRAT5N,PCOR,PAC)  

!**** *WRRADCOF* - Write out the constants for solar and thermal radiation

!     Purpose.  Write out the constants for solar and thermal radiation
!     --------  (grid-point transmission coefficients) from work file.

!**   Interface.
!     ----------
!        *CALL* *WRRADCOEF(...)*

!        Explicit arguments :  KSTA     - start adress         (input)
!                              KEND     - end adress           (input)
!                              KJUMP    - offset into gp array (input)
!                              KFIELDSS - number of fields     (input)
!                              PRAB3C to PAC: grid-point transmission
!                                       coefficients to be written
!                                       (inout for PAC; input for other ones)

!        Implicit arguments :  None
!        --------------------

!     Method.
!     -------

!     Externals. FILLB    - interface to packing routines
!     ---------- 

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        M. Janiskova

!     Modifications.
!     --------------
!        Original : 99-02-05
!        Modified :
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning

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

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NFLEVG   ,NPROMA
USE YOMRCOEF , ONLY : LGLOBRAD &
 & , NLENGSRB ,SOLRAD &
 & , NLENGTRB ,THERRAD &
 & , NPCKFSR  ,NEXPBSR &
 & , NPCKFTHR ,NEXPBTHR &
 & , NLATWR   ,TRWEIGHT ,TRMATSUM  

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

IMPLICIT NONE

! * INPUT:
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KEND 
INTEGER(KIND=JPIM),INTENT(IN)    :: KJUMP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFIELDSS 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAB3C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAB3N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAB4C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAB4N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAB6C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAB6N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT1C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT1N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT2C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT2N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT3C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT3N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT4C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT4N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT5C(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRAT5N(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOR(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PAC(NFLEVG+1,NFLEVG+1) 
! * INPUT/OUTPUT:
INTEGER(KIND=JPIM) :: IBLOCKSS, IJUMP, ILENBS, ILENBT, IPCKUNITS, ISTAGPSB, &
 & ISTAGPTB, IWORDS, IWORDT, JF, JJ, JK  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "fillb.intfb.h"

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

!*       1.    WRITE OUT GRIDPOINT ARRAY.
!              --------------------------

IF (LHOOK) CALL DR_HOOK('WRRADCOEF',0,ZHOOK_HANDLE)
NLATWR=NLATWR+1

!*       1.1       CALCULATE LENGTHS

IWORDS = KEND-KSTA+1
IWORDT = NFLEVG+1

!*       1.2       WRITE OUT BUFFER

ILENBS   = NLENGSRB
ILENBT   = (NFLEVG+1)*(NFLEVG+1)

IJUMP=KJUMP-1

IF (NPCKFSR == 1) THEN
  ISTAGPSB = 1+IJUMP*KFIELDSS
ELSE
  IBLOCKSS=IJUMP/NPROMA
  IF (IBLOCKSS*NPROMA /= IJUMP)&
   & CALL ABOR1('SOLRAD: INCONSISTENT WRITING OF PACKED DATA')  
  IPCKUNITS = (NPROMA+NPCKFSR-1)/NPCKFSR
  ISTAGPSB = 1+IPCKUNITS*IBLOCKSS*KFIELDSS
ENDIF

IF (NPCKFTHR == 1) THEN
  ISTAGPTB = 1
ELSE
  CALL ABOR1('THERRAD: NPCKFTHR CANNOT BE DIFFERENT THAN 1')
ENDIF

!        1.3      SOLAR RADIATION COEFFICIENTS, CORRECTION FACTOR
!                 FOR THERMAL RADIATION AND MATRIX OF THERMAL
!                 RADIATION COEFFICIENTS

DO JF=1,NFLEVG
  CALL FILLB(IWORDS,PRAB3C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAB3N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAB4C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAB4N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAB6C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAB6N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  

  CALL FILLB(IWORDS,PRAT1C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT1N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT2C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT2N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT3C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT3N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT4C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT4N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT5C(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
  CALL FILLB(IWORDS,PRAT5N(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  

  CALL FILLB(IWORDS,PCOR(KSTA,JF),SOLRAD(:),&
   & ILENBS,ISTAGPSB,NPCKFSR,NEXPBSR)  
ENDDO

IF (LGLOBRAD) THEN
  IF (NLATWR == NLENGTRB) THEN
    DO JJ=1,NFLEVG+1
      DO JK=1,NFLEVG+1
        PAC(JJ,JK)=TRMATSUM(JJ,JK)/TRWEIGHT(JJ,JK)
      ENDDO
    ENDDO
    DO JF=1,NFLEVG+1
      CALL FILLB(IWORDT,PAC(1,JF),THERRAD(1,:),&
       & ILENBT,ISTAGPTB,NPCKFTHR,NEXPBTHR)  
    ENDDO
  ENDIF
ELSE
  DO JF=1,NFLEVG+1
    CALL FILLB(IWORDT,PAC(1,JF),THERRAD(NLATWR,:),&
     & ILENBT,ISTAGPTB,NPCKFTHR,NEXPBTHR)  
  ENDDO
ENDIF

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

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

