*"   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 ,
     C          SIG   , SIGM )
*   [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 )   !" 
      REAL       SIG   ( KMAX )              !" $B&R%l%Y%k(B($B@0?t(B)
      REAL       SIGM  (KMAX+1)              !" $B&R%l%Y%k(B($BH>@0?t(B)
*
*   [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       PIB    ( IDIM*JDIM, KMAX+1 ) !" $B&P#B!a&R#T(B**4
      REAL       PIBGND ( IDIM*JDIM )         !" $BCOI=$N&P#B(B
      INTEGER    LFNMAX ( IDIM*JDIM ) !" 
*
*   [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       RUFLUX  ( IDIM*JDIM, KMAX+1 )   !" $BD9GH%U%i%C%/%9(B
      REAL       RDFLUX  ( IDIM*JDIM, KMAX+1 )   !" $BD9GH%U%i%C%/%9(B
*
*   [INTERNAL WORK] 
      REAL       ZZ
      REAL       ZZB
      REAL       GDTM  ( IDIM*JDIM, KMAX+1 ) !" $B29EY(B($BH>@0?t%l%Y%k(B)
      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=KMAX,1,-1
            IF( RFLUX( IJ,K ) .LT. RFLUX( IJ,K+1 ) ) THEN
               LFNMAX(IJ) = K+1
               GOTO 9999
            END IF
 2000    CONTINUE 
 9999    CONTINUE 
 2100 CONTINUE 
*
      DO 2200 IJ=1, IDIM*JDIM
         TRPLEV ( IJ ) = LFNMAX ( IJ ) 
 2200 CONTINUE 
*
*"         < 3. $BHyD4@0(B >
*
         CALL UDFLUX
     O         ( RUFLUX , RDFLUX )
*
         CALL TINTP    !" $B29EY$N1tD>Jd4V(B
     O         ( GDTM  ,
     I           GDT   ,
     C           SIG   , SIGM  )
*
      DO 3100 IJ = 1, IDIM*JDIM
 123     CONTINUE 
*
*"         <3.1 $B&S$N:F7W;;(B>
*
         CALL STRTAU
     O        ( TAUQ, TAUA,
     I          GDQ, GDPM ,
     I          TRPLEV )
*
         PIB ( IJ,TRPLEV(IJ) ) = (  RUFLUX ( IJ,TRPLEV(IJ) )
     &              - STB*GDTM( IJ,TRPLEV(IJ) )**4 )
     &                  * (1.5*TAUQ( IJ,TRPLEV(IJ) ) + 1.0 )
         ZZ = PIB ( IJ,TRPLEV(IJ) ) 
     &        - STB *  GDTM( IJ,TRPLEV( IJ ) )**4
         IF( ZZ .GT. 0.0 .AND. TRPLEV(IJ) .NE. 1) THEN
            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
         DO 4000 K = TRPLEV(IJ), KMAX+1
            RFLUX( IJ,K ) = 2.0 * STB 
     &                  * ( GDTM( 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 5200 K = TRPLEV(IJ),KMAX+1
            PIB ( IJ,K ) = RFLUX ( IJ,K ) /2.0
     &                    * (  1.5*TAUQ( IJ,K ) + 1.0 )
 5200    CONTINUE 
         DO 5000 K=TRPLEV(IJ),KMAX
            GDT ( IJ,K ) = ( (PIB( IJ,K )+PIB( IJ,K+1))/2.0
     &                          /STB )**0.25
*"                  $B@5$7$/Jd4V$9$Y$7(B
c$$$            GDT ( IJ,K ) = ( PIB( IJ,K )/STB )**0.25
            GDQ ( IJ,K ) = GDQ ( IJ,TRPLEV ( IJ ) )
*"                   Q $B$NJ}$O$3$l$G(BO.K.
 5000    CONTINUE 
 5100 CONTINUE 
*

      RETURN
      END

