* PACKAGE P2RADM   !" 物理過程(2) 放射(多色)*
*
*********************************************************************
      SUBROUTINE RADFLX            !" 放射フラックス
     O         ( RFLUX , RMTXS , DRFLUX,
     O           SFLUX ,
     I           GDTM  , GDTG  , GDQ   , GDPM  ,
     I           IT    , IDATE ,
     C           ALON  , ALAT  , GRALB          )
*
*"       ｎ色大気
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 格子点数，波数
      INCLUDE   (ZCCOM)                      !" 標準物理定数
#else
#include        "zcdim.F"                    !" 格子点数，波数
#include        "zccom.F"                    !" 標準物理定数
#endif
*
*   [OUTPUT] 
      REAL       RFLUX  ( IDIM*JDIM, KMAX+1 )     !" 長波フラックス
      REAL       RMTXS  ( IDIM*JDIM,  -1:1 )      !" Ｔ陰解行列：地表
      REAL       DRFLUX ( IDIM*JDIM, KMAX+1, 0:1 )!" 長波地表温度変化
      REAL       SFLUX  ( IDIM*JDIM, KMAX+1 )     !" 日射フラックス
*
*   [INPUT] 
      REAL       GDTM   ( IDIM*JDIM, KMAX+1 ) !" 温度(半整数)
      REAL       GDTG   ( IDIM*JDIM )         !" 地表面温度
      REAL       GDQ    ( IDIM*JDIM, KMAX )   !" 比湿  ｑ
      REAL       GDPM   ( IDIM*JDIM, KMAX+1 ) !" 気圧(半整数)
      INTEGER    IT                           !" 時刻
      INTEGER    IDATE  ( 6 )                 !" 日付
*
      REAL       ALON   ( IDIM )              !" 経度
      REAL       ALAT   ( JDIM )              !" 緯度
      REAL       GRALB  ( IDIM*JDIM )         !" 地表アルベド
*
*   [INTERNAL PARM]
      CHARACTER  TUNIT *4                     !" INTLNG等の単位
      INTEGER    INTLNG                       !" 長波計算間隔
      INTEGER    INTSHT                       !" 短波計算間隔
      DATA       TUNIT  / 'HOUR'/
      DATA       INTLNG / 3     /
      DATA       INTSHT / 1     /
*
      NAMELIST  /NMRADM/ TUNIT , INTLNG, INTSHT
*
*   [INTERNAL SAVE] 
      INTEGER    IORADL                       !" 長波計算間隔：秒
      INTEGER    IORADS                       !" 短波計算間隔：秒
      INTEGER    ITLSTL                       !" 以前長波計算した時刻
      INTEGER    ITLSTS                       !" 以前短波計算した時刻
*
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      SAVE
*
*   [INTERNAL WORK] 
      COMMON    /COMWRK/
     &           TAUQ  , TAUA   , GTRANS, TRANS ,
     &           PIB   , PIBGND , SECZET
      REAL       TAUQ   ( IDIM*JDIM, KMAX+1 ) !" 光学的厚さ：水
      REAL       TAUA   ( IDIM*JDIM, KMAX+1 ) !" 光学的厚さ：空気
      REAL       GTRANS ( IDIM*JDIM, KMAX+1 ) !" 地表からの透過係数
      REAL       TRANS  ( IDIM*JDIM, KMAX+1 ) !" 透過係数
      REAL       PIB    ( IDIM*JDIM, KMAX+1 ) !" πＢ＝σＴ**4
      REAL       PIBGND ( IDIM*JDIM )         !" 地表のπＢ
      REAL       SECZET ( IDIM*JDIM )         !" sec(入射角)
*
      INTEGER    IJ, K
      INTEGER    IFPAR, JFPAR
*
*   [ONCE]
      IF ( OFIRST ) THEN
         WRITE ( 6,* ) ' RADIATION PACKAGE - P2.2a DATE=92/04/17'
         OFIRST = .FALSE.
*
         CALL   REWNML ( IFPAR , JFPAR )
         READ   ( IFPAR, NMRADM, END=190 )
  190    WRITE  ( JFPAR, NMRADM )
*
         CALL ACTIME
     I      ( INTLNG, TUNIT  , '#'    ,
     O        IORADL                    )
         CALL ACTIME
     I      ( INTSHT, TUNIT  , '#'    ,
     O        IORADS                   )
         ITLSTL = IT - IORADL
         ITLSTS = IT - IORADS
      ENDIF
*
*"         < 1. τ の計算 >
*
      CALL RESET ( TAUQ ( 1,KMAX+1 ), IDIM*JDIM )
      CALL RESET ( TAUA ( 1,KMAX+1 ), IDIM*JDIM )
      DO 1110  K = KMAX, 1, -1
         DO 1120 IJ = 1, IDIM*JDIM
            TAUQ ( IJ,K ) = TAUQ ( IJ,K+1 )
     &                       + GDQ( IJ,K )
     &                         * ( GDPM( IJ,K )-GDPM( IJ,K+1 ) )/ GRAV
            TAUA ( IJ,K ) = TAUA ( IJ,K+1 )
     &                       +   ( GDPM( IJ,K )-GDPM( IJ,K+1 ) )/ GRAV
 1120       CONTINUE
 1110    CONTINUE
 1100 CONTINUE
*
*
      IF (  ( IT - ITLSTL ) .GE. IORADL ) THEN
*
         ITLSTL = IT
*
*"         < 2. 長波フラックスの算出 >
*
         CALL LNGFLX
     O         ( RFLUX , DRFLUX,
     I           GDTM  , GDTG  , TAUQ  , TAUA  ,
     W           GTRANS, TRANS , PIB   , PIBGND  )
*
*"         < 3. 長波陰解用行列 >
*
         DO 3000 IJ = 1, IDIM*JDIM
            RMTXS ( IJ,0  ) =   DRFLUX( IJ,1,0 )
            RMTXS ( IJ,1  ) = - DRFLUX( IJ,1,1 )
            RMTXS ( IJ,-1 ) = 0.  
 3000    CONTINUE
*
      ENDIF
*
      IF (  ( IT - ITLSTS ) .GE. IORADS ) THEN
*
         ITLSTS = IT
*
*"         < 4. 短波入射 >
*
         CALL SHTINS
     O         ( SFLUX(1,KMAX+1), SECZET ,
     I           IDATE ,
     C           ALON  , ALAT             )
*
*"         < 5. 短波フラックス >
*
         CALL SHTFLX
     M         ( SFLUX ,
     I           TAUQ  , TAUA  , SECZET,
     C           GRALB                  )
*
      ENDIF
*
      RETURN
      END
************************************************************************
      SUBROUTINE RADCOR             !" 放射フラックス補正
     M         ( RFLUX ,
     I           DRFLUX, GTT   , GTTG  , DELT  )
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                       !" 格子点数，波数
#else
#include        "zcdim.F"                     !" 格子点数，波数
#endif
*
*   [MODIFY] 
      REAL       RFLUX  ( IDIM*JDIM, KMAX+1 )     !" 長波フラックス
*
*   [INPUT] 
      REAL       DRFLUX ( IDIM*JDIM, KMAX+1, 0:1 )!" 長波地表温度変化
      REAL       GTT    ( IDIM*JDIM, KMAX )       !" 温度時間変化項
      REAL       GTTG   ( IDIM*JDIM )             !" 地表温度変化率
      REAL       DELT                             !" 時間刻みΔt
*
*   [INTERNAL WORK] 
      INTEGER    IJ, K
*
*
      DO 1100 K = 1, KMAX+1
         DO 1100 IJ = 1, IDIM*JDIM
            RFLUX ( IJ,K ) = RFLUX ( IJ,K )
     &                     + (   GTTG ( IJ )   * DRFLUX( IJ,K,0 )
     &                         - GTT  ( IJ,1 ) * DRFLUX( IJ,K,1 ) )
     &                      * DELT
 1100 CONTINUE
*
      RETURN
      END
*********************************************************************
      SUBROUTINE RADTND               !" 放射加熱率
     O         ( GTTRL , GTTRS ,
     I           RFLUX , SFLUX , GDPM    )
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                       !" 格子点数，波数
      INCLUDE   (ZCCOM)                       !" 標準物理定数
#else
#include        "zcdim.F"                     !" 格子点数，波数
#include        "zccom.F"                     !" 標準物理定数
#endif
*
*   [OUTPUT] 
      REAL       GTTRL  ( IDIM*JDIM, KMAX   ) !" 長波加熱率
      REAL       GTTRS  ( IDIM*JDIM, KMAX   ) !" 短波加熱率
*
*   [INPUT] 
      REAL       RFLUX  ( IDIM*JDIM, KMAX+1 ) !" 長波フラックス
      REAL       SFLUX  ( IDIM*JDIM, KMAX+1 ) !" 短波フラックス
      REAL       GDPM   ( IDIM*JDIM, KMAX+1 ) !" 気圧
*
*   [INTERNAL WORK] 
      INTEGER    IJ, K
*
*
      DO 1100 K = 1, KMAX
         DO 1110 IJ = 1, IDIM*JDIM
            GTTRL ( IJ,K )
     &         =  (  RFLUX( IJ,K ) - RFLUX( IJ,K+1 )   )
     &           /(  GDPM ( IJ,K ) - GDPM ( IJ,K+1 )   )
     &           / CP * GRAV
 1110    CONTINUE
 1100 CONTINUE
*
      DO 2100 K = 1, KMAX
         DO 2110 IJ = 1, IDIM*JDIM
            GTTRS ( IJ,K )
     &         =  (  SFLUX( IJ,K ) - SFLUX( IJ,K+1 )  )
     &           /(  GDPM ( IJ,K ) - GDPM ( IJ,K+1 )   )
     &           / CP * GRAV
 2110    CONTINUE
 2100 CONTINUE
*
      RETURN
      END
