* PACKAGE P2DADJ      
*
*"  [HIS] 90/05/19(numaguti)
*
**********************************************************************
      SUBROUTINE DADJST   
     M         ( GDT   ,
     I           GDP   , GDPM  , DELTA  )
*
*   [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       GDT   ( IDIM*JDIM, KMAX )   
*
*   [INPUT] 
      ReaL*8       GDP   ( IDIM*JDIM, KMAX )   
      ReaL*8       GDPM  ( IDIM*JDIM, KMAX+1 ) 
      ReaL*8       DELTA                       
*
*   [INTERNAL PARM] 
      INTEGER    ITRMAX
      PARAMETER (ITRMAX=10)
      ReaL*8       EPST ( ITRMAX )             
      DATA       EPST / 0.01  , 0.02  , 0.02  , 0.05  , 0.05  ,
     &                  0.10  , 0.10  , 0.20  , 0.20  , 0.40    /
*
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      SAVE
*
*   [INTERNAL WORK] 
      COMMON    /COMWRK/
     &           ADJDA , ADJDB ,
     &           DELP  , DPDP  , DPPMK
      ReaL*8       ADJDA ( IDIM*JDIM )         
      ReaL*8       ADJDB ( IDIM*JDIM )         
      ReaL*8       DELP  ( IDIM*JDIM, KMAX )   
      ReaL*8       DPDP  ( IDIM*JDIM, KMAX )   
      ReaL*8       DPPMK ( IDIM*JDIM, KMAX )   
      INTEGER    I, J, IJ, K, ITR
      ReaL*8       ST, DT, ADJPTS
*
*   [ONCE] 
      IF ( OFIRST ) THEN
         WRITE ( 6,* ) ' DRY CONVENCIVE ADJUSTMENT P2.1 DATE=90/08/31'
         OFIRST = .FALSE.
      ENDIF
*
*"      < 1. ファクター計算 >
*
      DO 1100 K = 1, KMAX
         DO 1100 IJ = 1, IDIM*JDIM
            DELP  ( IJ,K ) = GDPM( IJ,K   ) - GDPM( IJ,K+1 )
 1100 CONTINUE
*
      DO 1200 K = 2, KMAX
         DO 1200 IJ = 1, IDIM*JDIM
            DPDP  ( IJ,K ) = DELP( IJ,K ) / DELP( IJ,K-1 )
            DPPMK ( IJ,K ) = RAIR / CP
     &                       * ( GDP ( IJ,K-1 ) - GDP ( IJ,K   ) )
     &                       / ( DELP( IJ,K-1 ) + DELP( IJ,K   ) )
     &                       /   GDPM( IJ,K   )
 1200 CONTINUE
*
*"      < 2. 調節 >
*
      CALL RESET ( ADJDB,  IDIM*JDIM )
      DO 2000 I = 1, IMAX
         DO 2000 J = 1, JMAX
            ADJDB( IDIM*(J-1)+I ) = 1.  
 2000 CONTINUE
*
*"          < イテレーション >
*
      DO 2100 ITR = 1, ITRMAX
*
         CALL RESET ( ADJDA, IDIM*JDIM )
*
         DO 2120 K = 2, KMAX
*
            DO 2130 IJ = 1, IDIM*JDIM
*
               IF ( ADJDB( IJ ) .GT. 0.9   ) THEN
                  ST   =   GDT ( IJ,K-1 ) - GDT ( IJ,K )
     &                   - DPPMK ( IJ,K )
     &                     * (  DELP( IJ,K-1 ) * GDT ( IJ,K-1 )
     &                        + DELP( IJ,K   ) * GDT ( IJ,K   ) )
*
                  IF ( ST .GT. EPST( ITR ) ) THEN
                     DT = ST / ( 1. + DPDP( IJ,K ) )
                     GDT  ( IJ,K   ) = GDT( IJ,K   ) + DT
                     GDT  ( IJ,K-1 ) = GDT( IJ,K-1 ) - DT * DPDP( IJ,K )
                     ADJDA( IJ )     = 1.  
                  ENDIF
*
               ENDIF
 2130       CONTINUE
*
 2120    CONTINUE
*
         ADJPTS = 0.
         DO 2140 IJ = 1, IDIM*JDIM
            ADJDB( IJ ) = ADJDA( IJ )
            ADJPTS = ADJPTS + ADJDA( IJ )
 2140    CONTINUE
*
         IF ( ADJPTS .LT. 1. ) GOTO 2200
*"                                  exit
*
 2100 CONTINUE
*
 2200 CONTINUE
*
      RETURN
      END
