* PACKAGE P2RMNQ 
*
*********************************************************************
      SUBROUTINE RMNEGQ    
     M         ( GDQ   , GSRMNQ,
     I           GDPM  ,
     I           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                       )

*
*   [MODIFY]
      ReaL*8       GDQ    ( IDIM*JDIM, KMAX )   
      ReaL*8       GSRMNQ ( IDIM*JDIM, KMAX )   
*
*   [INPUT]     
      ReaL*8       GDPM   ( IDIM*JDIM, KMAX+1 ) 
      ReaL*8       DELTA                        
*
*   [INTERNAL WORK] 
      COMMON    /COMWRK/
     &           GDQB  , DELP  ,
     &           QP    , DQP   ,
     &           QPAV  , DQPAV
      ReaL*8       GDQB  ( IDIM*JDIM, KMAX )   
      ReaL*8       DELP  ( IDIM*JDIM, KMAX )   
      ReaL*8       QP    ( IDIM*JDIM, KMAX )   
      ReaL*8       DQP   ( IDIM*JDIM, KMAX )   
      ReaL*8       QPAV  ( IDIM*JDIM, KMAX )   
      ReaL*8       DQPAV ( IDIM*JDIM, KMAX )   
*
      LOGICAL    ODIAG
      INTEGER    IJ, K
      INTEGER    NPLOCL, NPGLBL
      INTEGER    IMAXD, JMAXD, KMAXD
      INTEGER    JFLDIA, NCOLS, ISTR, IEND, IINT
      ReaL*8       BQ, QPGLB, DQPGLB
      ReaL*8       RRATIO
*
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      SAVE       OFIRST
*
*   [ONCE] 
      IF ( OFIRST ) THEN
         WRITE ( 6,* ) ' ELIMINATE NEGATIVE MOISTURE P2.2 DATE=91/05/13'
         OFIRST = .FALSE.
      ENDIF
*
      DO 1100 K = 1, KMAX
         DO 1110 IJ = 1, IDIM*JDIM
            GDQB( IJ,K ) = GDQ ( IJ,K )
            DELP( IJ,K ) = GDPM( IJ,K ) - GDPM( IJ,K+1 )
 1110    CONTINUE
 1100 CONTINUE
*
      NPLOCL = 0.  
      NPGLBL = 0.  
*
*"         << 2. 局所補正 >>
*
      DO 2100 K = KMAX, 2, -1
         DO 2110 IJ = 1, IDIM*JDIM
            IF ( GDQ ( IJ,K ) .LT. 0.   ) THEN
               BQ = - GDQ( IJ,K ) * DELP( IJ,K ) / DELP( IJ,K-1 )
               GDQ ( IJ,K   ) = 0.  
               GDQ ( IJ,K-1 ) = GDQ( IJ,K-1 ) - BQ
               NPLOCL         = NPLOCL + 1
            ENDIF
 2110    CONTINUE
 2100 CONTINUE
*
*"         << 3. 全球補正 >>
*
      DO 3100 K = 1, KMAX
         DO 3110 IJ = 1, IDIM*JDIM
            QP ( IJ,K ) = GDQ( IJ,K ) * DELP( IJ,K )
            IF ( QP( IJ,K ) .LT. 0.   ) THEN
               DQP( IJ,K ) = - QP( IJ,K )
               NPGLBL      = NPGLBL + 1
            ELSE
               DQP( IJ,K ) = 0.  
            ENDIF
 3110    CONTINUE
 3100 CONTINUE
*
      CALL XYAVR
     I         ( QP    , 'ALEV',
     O           QPAV  , IMAXD , JMAXD , KMAXD  )
*
      CALL XYAVR
     I         ( DQP   , 'ALEV',
     O           DQPAV , IMAXD , JMAXD , KMAXD  )
*
      QPGLB  = 0.  
      DQPGLB = 0.  
      DO 3200 K = 1, KMAX
         QPGLB  = QPGLB  + QPAV ( 1,K )
         DQPGLB = DQPGLB + DQPAV( 1,K )
 3200 CONTINUE
*
      RRATIO = DQPGLB / ( QPGLB + DQPGLB )
*
      DO 3300 K = 1, KMAX
         DO 3310 IJ = 1, IDIM*JDIM
            GDQ( IJ,K ) = ( 1. - RRATIO ) * MAX( GDQ( IJ,K ), 0. )
 3310    CONTINUE
 3300 CONTINUE
*
*"         << 4. モニター >>
*
      DO 4100 K = 1, KMAX
         DO 4110 IJ = 1, IDIM*JDIM
            GSRMNQ( IJ,K ) = GSRMNQ( IJ,K )
     &                     + ( GDQ( IJ,K ) - GDQB( IJ,K ) )/DELTA
 4110    CONTINUE
 4100 CONTINUE
*
      CALL QDIAGP
     O         ( ODIAG , JFLDIA, NCOLS ,
     O           ISTR  , IEND  , IINT  ,
     I           1                       )
*
      IF ( ODIAG )  THEN
         WRITE ( JFLDIA,* )  'REMOVE NEG-Q  NPLOCL, NPGLBL, RRATIO',
     &                       NPLOCL, NPGLBL, RRATIO
      ENDIF
*
      RETURN
      END
