* PACKAGE P2ADMN  !" 物理過程(2) メインパート
*
*"履歴 92/04/27 沼口 敦             重力波抵抗(masaaki)の導入
*"履歴 93/08/29 保坂征宏            長波放射変更
*"履歴 97/03/02 堀之内武            長波放射マイナーチェンジ
*"
***********************************************************************
      SUBROUTINE PHYSCS      !" 物理過程メイン
     O         ( GTU   , GTV   , GTT   , GTQ   , 
     M           GDTG  ,
     I           GDU   , GDV   , GDT  , GDPS  , GDQ   ,
     I           GDVOR , GDDIV , 
     I           IT    , IDATE , DELT  , DELTM , 
     C           ALON  , ALAT  ,
     C           SIG   , SIGM  , DSIG  , DSIGM          )
*
*"  物理過程： 多色放射  鉛直拡散 地表 重力波抵抗
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 格子点数，波数
      INCLUDE   (ZCCOM)                      !" 標準物理定数
#else
#include        "zcdim.F"                    !" 格子点数，波数
#include        "zccom.F"                    !" 標準物理定数
#endif
*
*   [OUTPUT] 
      REAL       GTU   ( IDIM, JDIM, KMAX )  !" 東西運動量変化 ＵＡ
      REAL       GTV   ( IDIM, JDIM, KMAX )  !" 南北運動量変化 ＶＡ
      REAL       GTT   ( IDIM, JDIM, KMAX )  !" 温度時間変化項 Ｈ
      REAL       GTQ   ( IDIM, JDIM, KMAX )  !" 比湿時間変化項 Ｒ
      REAL       GTTG  ( IDIM, JDIM )        !" 地表温度変化率
*
*   [INPUT] 
      REAL       GDU   ( IDIM, JDIM, KMAX )  !" 西風  ｕ
      REAL       GDV   ( IDIM, JDIM, KMAX )  !" 南風  ｖ
      REAL       GDT   ( IDIM, JDIM, KMAX )  !" 温度  Ｔ
      REAL       GDPS  ( IDIM, JDIM       )  !" 地表気圧 Ｐｓ
      REAL       GDQ   ( IDIM, JDIM, KMAX )  !" 比湿  ｑ
      REAL       GDVOR ( IDIM, JDIM, KMAX )  !" 渦度  ζ
      REAL       GDDIV ( IDIM, JDIM, KMAX )  !" 発散  Ｄ
      REAL       GDTG  ( IDIM, JDIM )        !" 地表面温度
*
      INTEGER    IT                          !" 通し時間
      INTEGER    IDATE ( * )                 !" 時刻：年月日時分秒
      REAL       DELT                        !" 物理過程時間刻み 2 Δt
      REAL       DELTM                       !" モデル  時間刻み   Δt
*                                                !" 保坂 93/08/29 追加
      REAL       ALON  ( IDIM )              !" 経度
      REAL       ALAT  ( JDIM )              !" 緯度
      REAL       SIG   ( KMAX )              !" σレベル(整数)
      REAL       SIGM  (KMAX+1)              !" σレベル(半整数)
      REAL       DSIG  ( KMAX )              !" Δσ
      REAL       DSIGM (KMAX+1)              !" Δσ(半整数)
*
*   [INTERNAL SAVE] 
      REAL       RFLUX  ( IDIM, JDIM, KMAX+1 )   !" 長波フラックス
      REAL       RFLUXC ( IDIM, JDIM, KMAX+1 )   !" 補正した長波フラックス
*                                                   !" 保坂 93/08/29 追加
*
      REAL       SFLUX  ( IDIM, JDIM, KMAX+1 )   !" 短波フラックス
      REAL       DRFLUX ( IDIM, JDIM, KMAX+1, 0:1 ) !" 長波温度変化
*
      REAL       GRHC   ( IDIM, JDIM )        !" 地表熱容量
      REAL       GRALB  ( IDIM, JDIM )        !" 地表アルベド
      REAL       GRBET  ( IDIM, JDIM )        !" 地表湿潤度
      REAL       GRZ0   ( IDIM, JDIM )        !" 地表粗度長
      REAL       GRZSD  ( IDIM, JDIM )        !" 地表高度分散
      INTEGER    IDSFC  ( IDIM, JDIM )        !" 地表状態
      REAL       GFLUX  ( IDIM, JDIM )        !" 地中熱フラックス
*
      REAL       UFLUX  ( IDIM, JDIM, KMAX+1)      !" Ｕのフラックス
      REAL       VFLUX  ( IDIM, JDIM, KMAX+1)      !" Ｖのフラックス
      REAL       TFLUX  ( IDIM, JDIM, KMAX+1)      !" Ｔのフラックス
      REAL       QFLUX  ( IDIM, JDIM, KMAX+1)      !" ｑのフラックス
      SAVE
*
*   [INTERNAL PARM] 
      LOGICAL    OPBDGT                       !" 収支を出力
      LOGICAL    OFIRST
      DATA       OPBDGT / .TRUE. /
      DATA       OFIRST / .TRUE. /
      SAVE OFIRST, OPBDGT
*
*   [INTERNAL WORK] 
      REAL       UMTX   ( IDIM, JDIM,   KMAX, -1:1 ) !" ｕ陰解行列
      REAL       TMTX   ( IDIM, JDIM, 0:KMAX, -1:1 ) !" Ｔ陰解行列
      REAL       QMTX   ( IDIM, JDIM,   KMAX, -1:1 ) !" ｑ陰解行列
      REAL       UMTXS  ( IDIM, JDIM            ) !" ｕ陰解行列：地表
      REAL       TMTXS  ( IDIM, JDIM, 0:1, -1:1 ) !" Ｔ陰解行列：地表
      REAL       QMTXS  ( IDIM, JDIM, 0:1, -1:1 ) !" ｑ陰解行列：地表
      REAL       RMTXS  ( IDIM, JDIM,      -1:1 ) !" Ｔ陰解行列：放射
*
      REAL       GDTM   ( IDIM, JDIM, KMAX+1)  !" 温度：半整数
      REAL       GDP    ( IDIM, JDIM, KMAX )   !" 気圧  Ｐ
      REAL       GDPM   ( IDIM, JDIM, KMAX+1 ) !" 気圧（半整数）
      REAL       GDZ    ( IDIM, JDIM, KMAX )   !" 高度
      REAL       GDZM   ( IDIM, JDIM, KMAX+1 ) !" 高度（半整数）
      REAL       GTTRL  ( IDIM, JDIM, KMAX )   !" 温度時間変化：長波
      REAL       GTTRS  ( IDIM, JDIM, KMAX )   !" 温度時間変化：短波
      REAL       GTUG   ( IDIM, JDIM, KMAX )   !" 重力波抵抗Ｕ変化
      REAL       GTVG   ( IDIM, JDIM, KMAX )   !" 重力波抵抗Ｖ変化
      REAL       UFLUXG ( IDIM, JDIM, KMAX+1 ) !" 重力波抵抗u-flux
      REAL       VFLUXG ( IDIM, JDIM, KMAX+1 ) !" 重力波抵抗v-flux
*
      REAL       GQPR   ( IDIM, JDIM       )  !" 降水量
      REAL       GQCND  ( IDIM, JDIM, KMAX )  !" 凝結加熱率
      REAL       GSCND  ( IDIM, JDIM, KMAX )  !" 凝結比湿変化
      REAL       GSRMNQ ( IDIM, JDIM, KMAX )  !" 負の比湿除去
*
      INTEGER    I, J, K
*
*   [ONCE] 
      IF ( OFIRST ) THEN
         WRITE ( 6,* ) ' PHYSICS PACKAGE P2.4 DATE=92/04/17'
         OFIRST = .FALSE.
         CALL PHSTRG
      ENDIF
*
*"         < 0. 温度，気圧，高度 >
*
      CALL TINTP
     O         ( GDTM  ,
     I           GDT   ,
     C           SIG   , SIGM  )
*
      CALL PZLEVS
     O         ( GDP   , GDPM , GDZ   , GDZM  ,
     I           GDPS  , GDT  , GDTM  ,
     C           SIG   , SIGM , DSIG  , DSIGM   )
*
*"         < 1. 地表モデル >
*
      CALL PGRNDM
     O         ( GDTG  ,
     O           GRHC  , GRALB , GRBET , GRZ0  , GRZSD , 
     O           IDSFC , GFLUX ,
     I           UFLUX , VFLUX , TFLUX , QFLUX , RFLUX , SFLUX ,
     I           GDU   , GDV   , GDTM  , GDPS  , GDQ   ,
     I           IT    , IDATE , DELT  ,
     C           ALON  , ALAT                                   )
*
*"         < 2. 放射 flux >
*
      CALL RADFLX                                !" 堀之内 97/03/02 変更
     O         ( RFLUX , RMTXS , DRFLUX,
     O           SFLUX ,
     I           GDT   , GDTG  , GDQ   , GDPM  , 
     I           IT    , IDATE ,
     C           ALON  , ALAT  , GRALB          )
*
*"         < 3. 陰解配列初期化 >
*
      CALL PHMTX0
     O         ( UMTX  , TMTX  , QMTX  ,
     O           UFLUX , VFLUX , TFLUX , QFLUX ,
     I           GDPM  , DELT  , GRHC  , IDSFC  )
*
*"         < 4. 鉛直拡散 flux >
*
      CALL VDFUVT
     M         ( UFLUX , VFLUX , TFLUX , QFLUX ,
     M           UMTX  , TMTX  , QMTX  ,
     I           GDU   , GDV   , GDT   , GDTM  , GDQ   ,
     C           GDP   , GDPM  , GDZ   , GDZM            )
*
*"         < 5. 地表 flux >
*
      CALL SFCUVT
     M         ( UFLUX , VFLUX , TFLUX , QFLUX ,
     O           UMTXS , TMTXS , QMTXS ,
     I           GDU   , GDV   , GDT   , GDTM  , GDTG  , GDQ   ,
     I           GDP   , GDPM  , GDZ   ,
     I           GRBET , GRZ0  , IDSFC                           )
*
*"         < 6. 時間変化率の計算 (implicit) >
*
      CALL PHYTND
     O         ( GTU   , GTV   , GTT   , GTTG  , GTQ   ,
     I           UFLUX , VFLUX ,
     I           TFLUX , SFLUX , RFLUX , GFLUX , QFLUX ,
     I           UMTX  , TMTX  , QMTX  ,
     I           UMTXS , TMTXS , QMTXS ,
     I           RMTXS , DELT  , IDSFC                   )
*
*"         < 7. フラックス補正 > 
*
      CALL FLXCOR
     M         ( UFLUX , VFLUX , TFLUX , QFLUX ,
     I           GTU   , GTV   , GTT   , GTTG  , GTQ   ,
     I           UMTX  , TMTX  , QMTX  ,
     I           UMTXS , TMTXS , QMTXS ,
     I           DELT                                    )
*
      CALL RADCOR                               !" 保坂 93/08/29 変更
     O         ( RFLUXC ,
     I           RFLUX  , DRFLUX, GTT   , GTTG  , DELT  )
*
*"         < 8. 放射による温度変化率 >
*
      CALL RADTND
     O         ( GTTRL , GTTRS ,
     I           RFLUXC, SFLUX , GDPM   )       !" 保坂 93/08/29 記号変更
*
*"          < 9. 重力波抵抗 >
*
      CALL GRAVTY 
     O         ( GTUG   , GTVG   , UFLUXG , VFLUXG , 
     I           GRZSD  , IDSFC  , 
     I           GDU    , GDV    , GDT    , GDP    , GDTG   , 
     I           GDZ    , GDTM   , GDPM                       )
*
*"         < 10. 出力 >
*
      CALL HISTIN ( QFLUX , 'EVAP'  )
      CALL HISTIN ( TFLUX , 'SENS'  )
      CALL HISTIN ( UFLUX , 'TAUX'  )
      CALL HISTIN ( VFLUX , 'TAUY'  )
      CALL HISTIN ( GTT   , 'QVDF'  )
      CALL HISTIN ( GTQ   , 'SVDF'  )
      CALL HISTIN ( GTU   , 'FVDFX' )
      CALL HISTIN ( GTV   , 'FVDFY' )
      CALL HISTIN ( GTTRL , 'QRADL' )
      CALL HISTIN ( GTTRS , 'QRADS' )
      CALL HISTIN ( RFLUXC, 'LRAD'  )           !" 保坂 93/08/29 追加
      CALL HISTIN ( RFLUXC(1,1,KMAX+1),'OLR' )  !" 保坂 93/08/29 記号変更
      CALL HISTIN ( RFLUXC,            'SLR' )  !" 保坂 93/08/29 記号変更
      CALL HISTIN ( SFLUX(1,1,KMAX+1), 'OSR' )
      CALL HISTIN ( SFLUX,             'SSR' )
      CALL HISTIN ( GTUG   , 'FGRVX' )
      CALL HISTIN ( GTVG   , 'FGRVY' )
      CALL HISTIN ( UFLUXG , 'TAUGX' )
      CALL HISTIN ( VFLUXG , 'TAUGY' )
*
      DO 9100 K = 1, KMAX
         DO 9100 I = 1, IDIM
            DO 9100 J = 1, JDIM
               GTT ( I,J,K ) = GTT ( I,J,K ) + GTTRL ( I,J,K )
     &                                       + GTTRS ( I,J,K )
               GTU ( I,J,K ) = GTU ( I,J,K ) + GTUG  ( I,J,K )
               GTV ( I,J,K ) = GTV ( I,J,K ) + GTVG  ( I,J,K )
 9100 CONTINUE
*
      IF ( OPBDGT ) THEN                        
         CALL PDIAG
     I         ( TFLUX , QFLUX , RFLUXC, SFLUX ,  !" 保坂 93/08/29 記号変更
     I           GTT   , GTQ   , GTTG  ,
     I           GDT   , GDQ   , GDTG  , GDPM  ,
     C           GRHC                           )
      ENDIF
*
      CALL TGINTG                                !" 堀之内 97/03/02 変更
     M         ( GDTG  ,
     I           GTTG  , DELTM    )
*
      RETURN
*======================================================================
      ENTRY      PADJST       !" 物理調節
     M         ( GDU   , GDV   , GDT   , GDPS  , GDQ   ,
     I           GDVOR , GDDIV ,
     I           DELT  ,
     C           SIG   , SIGM  , DSIG  , DSIGM          )
*
*"         < 1. 温度，気圧，高度 >
*
      CALL TINTP
     O         ( GDTM  ,
     I           GDT   ,
     C           SIG   , SIGM  )
*
      CALL PZLEVS
     O         ( GDP   , GDPM , GDZ   , GDZM  ,
     I           GDPS  , GDT  , GDTM  ,
     C           SIG   , SIGM , DSIG  , DSIGM   )
*
      CALL RESET ( GQPR  , IDIM*JDIM      )
      CALL RESET ( GQCND , IDIM*JDIM*KMAX )
      CALL RESET ( GSCND , IDIM*JDIM*KMAX )
      CALL RESET ( GSRMNQ, IDIM*JDIM*KMAX )
*
*"         < 2. 負の水蒸気除去(1) >
*
      CALL RMNEGQ
     M         ( GDQ   , GSRMNQ,
     I           GDPM  ,
     I           DELT           )
*
*"         < 3. 湿潤過程 >
*
      CALL CUMADJ
     M         ( GDT   , GDQ   ,
     M           GQPR  , GQCND , GSCND ,
     I           GDP   , GDPM  , GDZ   , DELT   )
*
      CALL HISTIN ( GQCND , 'QCNDC'  )
      CALL HISTIN ( GSCND , 'SCNDC'  )
*
      CALL LSCOND
     M         ( GDT   , GDQ   ,
     M           GQPR  , GQCND , GSCND ,
     I           GDP   , GDPM  , DELT   )
*
*"         < 4. 乾燥対流調節 >
*
      CALL DADJST
     M         ( GDT   ,
     I           GDP   , GDPM  , DELT   )
*
*"         < 5. 負の水蒸気除去(2) >
*
      CALL RMNEGQ
     M         ( GDQ   , GSRMNQ,
     I           GDPM  ,
     I           DELT           )
*
*"         < 6. ヒストリー出力 >
*
      CALL HISTIN ( GQPR  , 'RAIN'  )
      CALL HISTIN ( GQCND , 'QCND'  )
      CALL HISTIN ( GSCND , 'SCND'  )
      CALL HISTIN ( GSRMNQ, 'SRMNQ' )
*
      IF ( OPBDGT ) THEN
         CALL PDIAG2
     I         ( GQPR  )
      ENDIF
*
      RETURN
      END
***********************************************************************
      SUBROUTINE PHSTRG    !" 物理過程時間平均出力の登録
*
      INTEGER    ISTYPL
      DATA       ISTYPL / 1 /
      REAL       VMISS
*
      CALL GZDBGT( 'MISS', VMISS )
*
      CALL HISTRG
     I       ( 'RAIN'  , 'precipitation      ' ,'W/m**2', 'ASFC',
     I          0.     , VMISS , 200.  , 1000. , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(F12.3)' )
*
      CALL HISTRG
     I       ( 'EVAP'  , 'latent heat flux   ' ,'W/m**2', 'ASFC',
     I          VMISS  , VMISS , 20.   , 100.  , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(F12.3)' )
*
      CALL HISTRG
     I       ( 'SENS'  , 'sensible heat flux ' ,'W/m**2', 'ASFC',
     I          VMISS  , VMISS , 20.   , 100.  , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(F12.3)' )
*
      CALL HISTRG
     I       ( 'OLR'   , 'outgoing longwave  ' ,'W/m**2', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(F12.3)' )
*
      CALL HISTRG
     I       ( 'SLR'   , 'surface longwave   ' ,'W/m**2', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(F12.3)' )
*
      CALL HISTRG
     I       ( 'OSR'   , 'outgoing shortwave ' ,'W/m**2', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(F12.3)' )
*
      CALL HISTRG
     I       ( 'SSR'   , 'surface shortwave  ' ,'W/m**2', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(F12.3)' )
*
      CALL HISTRG
     I       ( 'TAUX' , 'surface stress(x) '  ,'N/m**2', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'TAUY'  , 'surface stress(y) '  ,'N/m**2', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'QVDF'  , 'diffusive heating  ' ,'K/s   ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'SVDF'  , 'diffusive moistning' ,'1/s   ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'FVDFX' , 'diffusive force(x)'  ,'m/s**2 ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'FVDFY' , 'diffusive force(y)'  ,'m/s**2 ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'QCND'  , 'condensation heating','K/s   ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'SCND'  , 'condensation moistning','1/s   ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'QCNDC' , 'cumulus heating'     ,'K/s   ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'SCNDC' , 'cumulus moistning'   ,'1/s   ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'SRMNQ' , 'remove negative moist','1/s   ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'QRADL' , 'longwave heating   ' ,'K/s    ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'FGRVX' , 'gravity wave u force','m/s**2  ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'FGRVY' , 'gravity wave v force','m/s**2  ', 'ALEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'TAUGX' , 'gravity wave u flux' ,'N/m**2  ', 'AMLEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG
     I       ( 'TAUGY' , 'gravity wave v flux' ,'N/m**2  ', 'AMLEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      CALL HISTRG                              !" 保坂 93/08/29 追加
     I       ( 'LRAD' , 'LONG RADIATION' ,'W/m**2  '     , 'AMLEV',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )

      RETURN
      END
