*"   PACKAGE  TRPPAS       !"  kenkaimen
*"   
*"      Tue May 10 17:52:16 1994        Ishiwatari Masaki
***********************************************************************
      SUBROUTINE TRPPAS
     M        ( GDT, GDQ,
     O          TRPLEV,
     I          GDTG  ,
     I          GDPM, 
     I          RFLUX )
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" $B3J;RE@?t!$GH?t(B
      INCLUDE   (ZCCOM)                      !" $BI8=`J*M}Dj?t(B
#else
#include        "zcdim.F"                    !" $B3J;RE@?t!$GH?t(B
#include        "zccom.F"                    !" $BI8=`J*M}Dj?t(B
#endif
*
*   [MODIFY] 
*
      REAL       GDT    ( IDIM*JDIM, KMAX )   !" 
      REAL       GDQ    ( IDIM*JDIM, KMAX )   !" 
      REAL       GDTG   ( IDIM*JDIM )   !" 
*   [OUTPUT] 
      INTEGER    TRPLEV ( IDIM*JDIM )            !" $B7w3&LL$N9b$5(B
*
*   [INPUT] 
      REAL       RFLUX  ( IDIM*JDIM, KMAX+1 )   !" $BD9GH%U%i%C%/%9(B
      REAL       GDPM   ( IDIM*JDIM, KMAX+1 )   !" 
*
*   [INTERNAL WORK] 
c$$$      COMMON    /COMWRK/
c$$$     &           TAUQ  , TAUA   , TRNSM1, TRNSM2, TRANS ,
c$$$     &           PIB   , PIBGND , SECZET
      REAL       TAUQ   ( IDIM*JDIM, KMAX+1 ) !" $B8w3XE*8|$5!'?e(B
      REAL       TAUA   ( IDIM*JDIM, KMAX+1 ) !" $B8w3XE*8|$5!'6u5$(B
      REAL       UQ   ( IDIM*JDIM, KMAX+1 ) !" $B8wO)D9!'?e(B
      REAL       UA   ( IDIM*JDIM, KMAX+1 ) !" $B8wO)D9!'6u5$(B
      REAL       LFNMAX ( IDIM*JDIM ) !" 
      REAL       PIB    ( IDIM*JDIM, KMAX+1 ) !" $B&P#B!a&R#T(B**4
      REAL       PIBGND ( IDIM*JDIM )         !" $BCOI=$N&P#B(B
*
*   [WORK] 
      REAL       TRNSM1 ( IDIM*JDIM, KMAX+1 ) !" 1/2 $B%l%Y%k$+$i$NF)2a78?t(B
      REAL       TRNSM2 ( IDIM*JDIM, KMAX+1 ) !" 3/2 $B%l%Y%k$+$i$NF)2a78?t(B
*                                                !" $BJ]:d(B 93/08/29 $BDI2C(B
      REAL       TRANS  ( IDIM*JDIM, KMAX+1 ) !" $BF)2a78?t(B
      REAL       WPIB   ( IDIM*JDIM, KMAX+1 ) !" $B&P#B!a&R#T(B**4
      REAL       WPIBG  ( IDIM*JDIM )         !" $BCOI=$N&P#B(B
      REAL       DRFLUX ( IDIM*JDIM, KMAX+1, 0:1 )!" $BD9GHCOI=29EYJQ2=(B
*
*   [INTERNAL WORK] 
      REAL       ZZ
      REAL       ZZB
      INTEGER    IJ, K
*
*          < 1. $B%Q%i%a!<%?@_Dj(B >
*
      DO 1000 IJ = 1, IDIM*JDIM
         LFNMAX ( IJ ) =   1
 1000 CONTINUE
*
*          < 2. $B%U%i%C%/%9$N:GBgCM$r8+$D$1$k(B >
*
      DO 2100 IJ=1, IDIM*JDIM
         DO 2000 K=1,KMAX+1
            IF( RFLUX( IJ,K ) .GE. RFLUX( IJ,LFNMAX(IJ) ) ) THEN
               LFNMAX(IJ) = K
            END IF
 2000    CONTINUE 
 2100 CONTINUE 
      DO 2200 IJ=1, IDIM*JDIM
         TRPLEV ( IJ ) = LFNMAX ( IJ )
         write (6,*) 'in trppas:the level of max rflux'
         write (6,*) ij, trplev(ij)
 2200 CONTINUE 
*
*"         < 3. $BHyD4@0(B >
*
         write (6,*) 'in p2trpn: before correction'
         do 1, ij=1, idim*jdim
            do 1 k = 1,kmax+1
               write (6,*) 'flux:ij,k,net:', ij,k,rflux(ij,k)
 1       continue 
      DO 3100 IJ = 1, IDIM*JDIM
         write (6,*) 'in p2trop: top of correction loop, ij'
         write (6,*) ij
 123     CONTINUE 
*
c$$$            write (6,*) 'before strtau'
c$$$            write (6,*) ij, trplev(ij)
*
*"          $B&S$N:F7W;;(B
         CALL STRTAU
     O        ( TAUQ, TAUA,
     I          GDQ, GDPM ,
     I          TRPLEV )
c$$$            write (6,*) 'after strtau'
c$$$            write (6,*) ij, trplev(ij)
*
*"     $B8wO)D9$N7W;;(B
c$$$      CALL RESET ( UQ ( 1,KMAX+1 ), IDIM*JDIM )
c$$$      CALL RESET ( UA ( 1,KMAX+1 ), IDIM*JDIM )
c$$$         DO 1120  K = KMAX, TRPLEV(IJ), -1
c$$$            UQ ( IJ,K ) = UQ ( IJ,K+1 )
c$$$     &                       + GDQ( IJ,TRPLEV( IJ ) )
c$$$     &                         * ( GDPM( IJ,K )-GDPM( IJ,K+1 ) )/ GRAV
c$$$ 1120    CONTINUE 
c$$$         DO 1130  K = TRPLEV(IJ)-1, 1, -1
c$$$            UQ ( IJ,K ) = UQ ( IJ,K+1 )
c$$$     &                       + GDQ( IJ,K )
c$$$     &                         * ( GDPM( IJ,K )-GDPM( IJ,K+1 ) )/ GRAV
c$$$ 1130    CONTINUE 
c$$$*
c$$$         CALL LNGFLX
c$$$     O         ( RFLUX , DRFLUX,
c$$$     I           GDT   , GDTG  , UQ  , UA  ,
c$$$     W           TRNSM1, TRNSM2, TRANS , WPIB   , WPIBG  )
*
         PIB ( IJ,TRPLEV(IJ) ) = RFLUX ( IJ,TRPLEV(IJ) ) /2.0
     &                  * (1.5*TAUQ( IJ,TRPLEV(IJ) ) + 1.0 )
         ZZ = PIB ( IJ,TRPLEV(IJ) ) - STB * GDT( IJ,TRPLEV( IJ ) )**4
         write (6,*) 'in trppas:trplev,rflux,tauq,pib,stb*T^4,zz'
         write (6,*) TRPLEV(IJ), rflux ( IJ,TRPLEV(IJ) ),
     &               tauq( IJ,TRPLEV(IJ) )
         write (6,*) '  ', pib ( ij,TRPLEV(IJ) ), 
     &               stb * gdt( IJ,TRPLEV( IJ ) )**4,zz
c$$$            write (6,*) 'before if(zz > 0)'
c$$$            write (6,*) ij, trplev(ij)
          IF( ZZ .GT. 0.0 .AND. TRPLEV(IJ) .NE. 1) THEN
c          IF( ZZ .GT. 0.0 ) THEN
c$$$            write (6,*) 'correction:zz'
c$$$            write (6,*) ij, zz,trplev(ij)
            TRPLEV( IJ ) = TRPLEV( IJ ) - 1
            ZZB = ZZ
            GOTO 123
         END IF
         IF ( ABS(ZZ) .GT. ABS(ZZB) 
     &         .AND. TRPLEV(IJ) .LT. LFNMAX(IJ)) THEN
            TRPLEV (IJ) = TRPLEV ( IJ ) + 1
*
            CALL STRTAU
     O        ( TAUQ, TAUA,
     I          GDQ, GDPM ,
     I          TRPLEV )
         END IF

 3100 CONTINUE 
*
*"        < 4. $B@.AX7w$N>e8~$-%U%i%C%/%97hDj(B >
*
      DO 4100 IJ = 1, IDIM*JDIM
         write (6,*) 'in trppas:the tropopause level'
         write (6,*) ij, trplev(ij)
         DO 4000 K = TRPLEV(IJ), KMAX+1
            RFLUX( IJ,K ) = 2.0 * STB 
     &                  * ( GDT( IJ,TRPLEV( IJ ) ) )**4
     &                  /(1.5 * TAUQ( IJ,TRPLEV( IJ ) ) + 1.0)
 4000    CONTINUE 
 4100 CONTINUE 
*
*"        < 5. $B@.AX7w$N29EY9=B$(B >
*
      DO 5100 IJ = 1, IDIM*JDIM
         DO 5000 K=TRPLEV(IJ),KMAX
            PIB ( IJ,K ) = RFLUX ( IJ,K ) /2.0
     &                       * (1.5*TAUQ( IJ,K ) + 1.0 )
            GDT ( IJ,K ) = ( PIB( IJ,K )/STB )**0.25
            GDQ ( IJ,K ) = GDQ ( IJ,TRPLEV ( IJ ) )
 5000    CONTINUE 
 5100 CONTINUE 
*

      RETURN
      END
