* PACKAGE P2SFCM  
*"                   Ishiwatari (97/10/31) 係数出力
***********************************************************************
      SUBROUTINE SFCUVT           
     M         ( UFLUX , VFLUX , TFLUX , QFLUX ,
     M           UMTXS , TMTXS , QMTXS ,
     I           GDU   , GDV   , GDT   , GDTM  , GDTG  , GDQ   ,
     I           GDP   , GDPM  , GDZ   ,
     I           GRBET , GRZ0  , IDSFC                          )
*
*   [PARAM] 





* PACKAGE  ZXT10L32 !" 格子点数，波数 X-Z
*
      INTEGER     IMAX           !" 経度格子数
      INTEGER     JMAX           !" 緯度格子数
      INTEGER     IDIM           !" 経度配列サイズ
      INTEGER     JDIM           !" 緯度配列サイズ
      INTEGER     MMAX           !" 最大東西波数
      INTEGER     LMAX           !" 最大南北波数
      INTEGER     NMAX           !" 最大全波数
      INTEGER     MINT           !" 東西波数間隔
      INTEGER     KMAX           !" 鉛直層数
      INTEGER     KDIM           !" 鉛直配列サイズ
      INTEGER     NMDIM          !" 水平波数成分数
      INTEGER     JMXHF          !" JMAX/2+1
      INTEGER     NWORK          !" ワーク領域大きさ
*
      PARAMETER ( IMAX  = 32,     JMAX =  1,
     &            IDIM  = IMAX+1, JDIM = JMAX,
     &            MMAX  = 10,     LMAX =  0,    NMAX = MMAX, MINT = 1,
     &            KMAX  = 32,     KDIM = KMAX,
     &            NMDIM = (MMAX/MINT+1)*(2*(NMAX+1)-MMAX)
     &                  - (NMAX-LMAX)/MINT*(NMAX-LMAX+1),
     &            JMXHF = JMAX/2+1,
     &            NWORK = IDIM*JDIM*KMAX*12                       )

* PACKAGE ZHDIM  !" 標準物理定数(common)  
*
*"  [HIS]  90/08/31(numaguti)
*
      ReaL*8       ER             !" 地球半径
      ReaL*8       GRAV                        !" 重力加速度
      ReaL*8       CP                          !" 大気定圧比熱
      ReaL*8       RAIR                        !" 大気気体定数
      ReaL*8       EL                          !" 水の凝結の潜熱
      ReaL*8       CPVAP                       !" 水蒸気定圧比熱
      ReaL*8       RVAP                        !" 水蒸気気体定数
      ReaL*8       DH2O                        !" 水の密度
      ReaL*8       EPSV                        !" 水と大気の分子量比ε
      ReaL*8       ES0                         !" ０℃飽和蒸気圧：Ｐａ
      ReaL*8       STB                         !" Stefan-Boltzman
      ReaL*8       FKARM                       !" Karman 定数
      ReaL*8       EPSVT                       !" 1/ε-1
*
      COMMON   /COMCON/
     &          ER    , GRAV  ,
     &          CP    , RAIR  ,
     &          EL    , CPVAP , RVAP  , DH2O  , EPSV  , ES0   ,
     &          STB   , FKARM , EPSVT

*
*   [MODIFY] 
      ReaL*8       UFLUX ( IDIM*JDIM, KMAX+1 ) 
      ReaL*8       VFLUX ( IDIM*JDIM, KMAX+1 ) 
      ReaL*8       TFLUX ( IDIM*JDIM, KMAX+1 ) 
      ReaL*8       QFLUX ( IDIM*JDIM, KMAX+1 ) 
*
      ReaL*8       UMTXS ( IDIM*JDIM )             
      ReaL*8       TMTXS ( IDIM*JDIM , 0:1, -1:1 ) 
      ReaL*8       QMTXS ( IDIM*JDIM , 0:1, -1:1 ) 
*
*   [INPUT] 
      ReaL*8       GDU   ( IDIM*JDIM, KMAX )   
      ReaL*8       GDV   ( IDIM*JDIM, KMAX )   
      ReaL*8       GDT   ( IDIM*JDIM, KMAX )   
c      ReaL*8       GDTM  ( IDIM*JDIM, KMAX )   
      ReaL*8       GDTM  ( IDIM*JDIM, KMAX+1 )   
      ReaL*8       GDTG  ( IDIM*JDIM       )   
      ReaL*8       GDQ   ( IDIM*JDIM, KMAX )   
      ReaL*8       GDP   ( IDIM*JDIM, KMAX )   
c      ReaL*8       GDPM  ( IDIM*JDIM, KMAX )   
      ReaL*8       GDPM  ( IDIM*JDIM, KMAX+1 )   
      ReaL*8       GDZ   ( IDIM*JDIM, KMAX )   
*
      ReaL*8       GRBET ( IDIM*JDIM )         
      ReaL*8       GRZ0  ( IDIM*JDIM )         
      INTEGER    IDSFC ( IDIM*JDIM )         
*
*   [INTERNAL PARM] 
      ReaL*8       P00, THS
      ReaL*8       URMIN
      ReaL*8       USMINM, USMINH, USMINE
      ReaL*8       USMAXM, USMAXH, USMAXE
      DATA       P00   / 100000. /
      DATA       THS   / 300.    /            
      DATA       URMIN / 0.01    /            
      DATA       USMINM/ 0.01    /            
      DATA       USMINH/ 0.01    /            
      DATA       USMINE/ 0.01    /            
      DATA       USMAXM/ 1000.   /            
      DATA       USMAXH/ 1000.   /            
      DATA       USMAXE/ 1000.   /            
*
      NAMELIST  /NMSFCM/ THS   , URMIN ,
     &                   USMINM, USMAXM,
     &                   USMINH, USMAXH,
     &                   USMINE, USMAXE
*
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      SAVE
*
*   [INTERNAL WORK] 
      COMMON    /COMWRK/
     &           EXNER , VABS  , RIB   ,
     &           CMV   , CHV   , CEV   ,
     &           QSAT  , DQSAT
      ReaL*8       EXNER ( IDIM*JDIM )         
      ReaL*8       VABS  ( IDIM*JDIM )         
      ReaL*8       RIB   ( IDIM*JDIM )         
      ReaL*8       CMV   ( IDIM*JDIM )         
      ReaL*8       CHV   ( IDIM*JDIM )         
      ReaL*8       CEV   ( IDIM*JDIM )         
      ReaL*8       QSAT  ( IDIM*JDIM )         
      ReaL*8       DQSAT ( IDIM*JDIM )         
*
      INTEGER    IJ
      INTEGER    IFPAR, JFPAR
      ReaL*8       AKAPPA
*




* PACKAGE ZQSAT     !" Clausis-Clapeyron の式(文関数)
*
*"    QSAT:  saturation water vapour mixing ratio
*"    DQSAT: d(QSAT)/d(T)
*
      ReaL*8       FQSAT
      ReaL*8       FDQSAT
      ReaL*8       T, P, QS
*
c$$$      FQSAT ( T,P )    = EPSV * ES0
c$$$     &                   * EXP( EL/RVAP *( 1./273. - 1./T ) )
c$$$     &                   / P
      FQSAT ( T,P )    = EPSV
     &                   * 1.4E+11* EXP( - 5250.87/T )
     &                   / P
*"         <---------  Nakajima version
      FDQSAT( T,QS )   = EL * QS / ( RVAP * T*T )

*
      IF ( OFIRST ) THEN
         WRITE ( 6,* ) ' SURFACE FLUX - P2.1a DATE=92/04/17'
         OFIRST = .FALSE.
*
         CALL   REWNML ( IFPAR , JFPAR )
         READ   ( IFPAR, NMSFCM, END=190 )
  190    WRITE  ( JFPAR, NMSFCM )
*
         CALL GZDBGT ( 'MISS', VMISS )
*
         CALL HISTRG
     I       ( 'CDM' , 'Bulk coef (mom)       ' ,'m^2/s    ', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
         CALL HISTRG
     I       ( 'CDH' , 'Bulk coef (heat)      ' ,'m^2/s    ', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
         CALL HISTRG
     I       ( 'CDE' , 'Bulk coef (q)         ' ,'m^2/s    ', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
         CALL HISTRG
     I       ( 'CRM' , 'Bulk coef * rho( mom) ' ,'Kg m/s    ', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
         CALL HISTRG
     I       ( 'CRH' , 'Bulk coef * rho (heat)' ,'Kg m/s    ', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
         CALL HISTRG
     I       ( 'CRE' , 'Bulk coef * rho (q)   ' ,'Kg m/s    ', 'ASFC',
     I          VMISS  , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'X'     ,'(1PE12.3)' )
*
      ENDIF
*
      AKAPPA = RAIR / CP
      DO 100 IJ = 1, IDIM*JDIM
         EXNER ( IJ ) = ( GDP ( IJ,1 )/GDPM( IJ,1 ) ) ** AKAPPA
  100 CONTINUE
*
*"         < 1. バルクＲｉ数 >
*
      DO 1100 IJ = 1, IDIM*JDIM
         VABS ( IJ ) = SQRT( GDU( IJ,1 )**2+GDV( IJ,1 )**2 )
         RIB  ( IJ ) = GRAV / THS
     &                * (   GDT ( IJ,1 )/EXNER ( IJ ) 
     &                    - GDTG( IJ   )              )
     &                / MAX( VABS( IJ ), URMIN )**2 * GDZ( IJ,1 )
 1100 CONTINUE
*
*"         < 3. バルク係数 >
*
      CALL BLKCOF
     O         ( CMV   , CHV   , CEV   ,
     I           RIB   , VABS  , GRZ0  , GRZ0  , GDZ   )
*
      CALL HISTIN ( CMV  , 'CDM'  )
      CALL HISTIN ( CHV  , 'CDH'  )
      CALL HISTIN ( CEV  , 'CDE'  )
*
*"         < 4. バルク輸送係数 >
*
      DO 4100 IJ = 1, IDIM*JDIM
         CMV  ( IJ ) = CMV ( IJ )
     &                 * GDPM( IJ,1 ) / ( RAIR * GDTM( IJ,1 ) )
     &                 * MIN( MAX ( VABS( IJ ), USMINM ), USMAXM )
         CHV  ( IJ ) = CHV ( IJ )
     &                 * GDPM( IJ,1 ) / ( RAIR * GDTM( IJ,1 ) )
     &                 * MIN( MAX ( VABS( IJ ), USMINH ), USMAXH )
         CEV  ( IJ ) = CEV ( IJ )
     &                 * GDPM( IJ,1 ) / ( RAIR * GDTM( IJ,1 ) )
     &                 * MIN( MAX ( VABS( IJ ), USMINE ), USMAXE )
 4100 CONTINUE
*
      CALL HISTIN ( CMV  , 'CRM'  )
      CALL HISTIN ( CHV  , 'CRH'  )
      CALL HISTIN ( CEV  , 'CRE'  )
*
*"         < 5. 飽和比湿  >
*
      DO 5100 IJ = 1, IDIM*JDIM
         QSAT ( IJ ) = FQSAT ( GDTG( IJ ), GDPM( IJ,1 ) )
         DQSAT( IJ ) = FDQSAT( GDTG( IJ ), QSAT( IJ )   )
 5100 CONTINUE
*
*"         < 6. フラックス >
*
      DO 6100 IJ = 1, IDIM*JDIM
         UFLUX( IJ,1 ) = UFLUX( IJ,1 )
     &                         - CMV ( IJ ) * GDU( IJ,1 )
         VFLUX( IJ,1 ) = VFLUX( IJ,1 )
     &                         - CMV ( IJ ) * GDV( IJ,1 )
         TFLUX( IJ,1 ) = TFLUX( IJ,1 )
     &                   + CP *  CHV ( IJ )
     &                        *(   GDTG( IJ )
     &                           - GDT ( IJ,1 )/EXNER ( IJ )   )
         QFLUX( IJ,1 ) = QFLUX( IJ,1 )
     &                   + EL *  CEV ( IJ ) * GRBET( IJ )
     &                        *( QSAT( IJ ) - GDQ ( IJ,1 ) )
 6100 CONTINUE
*
*"       < 7. 陰解用行列 >
*
      CALL RESET ( TMTXS, IDIM*JDIM*6 )
      CALL RESET ( QMTXS, IDIM*JDIM*6 )
*
      DO 7100 IJ = 1, IDIM*JDIM
         UMTXS( IJ )      =         CMV( IJ )
*
         TMTXS( IJ,1,0  ) =    CP * CHV( IJ ) / EXNER( IJ )
         TMTXS( IJ,0,1  ) =  - CP * CHV( IJ ) / EXNER( IJ )
*
         QMTXS( IJ,1,0  ) =    CP * CEV( IJ ) * GRBET( IJ )
         QMTXS( IJ,0,1  ) =  - CP * CEV( IJ ) * GRBET( IJ )
*
         IF ( IDSFC( IJ ) .GE. 1 ) THEN
*
            TMTXS( IJ,1,-1 ) = - CP * CHV( IJ )
            TMTXS( IJ,0,0  ) =   CP * CHV( IJ )
*
            QMTXS( IJ,1,-1 ) = - EL * CEV( IJ ) * GRBET( IJ )
     &                                          * DQSAT( IJ )
            QMTXS( IJ,0,0  ) =   EL * CEV( IJ ) * GRBET( IJ )
     &                                          * DQSAT( IJ )
         ENDIF
*
 7100 CONTINUE
*
      RETURN
      END
