      SUBROUTINE XTTEMI2(XEMIS,X2DEMISA,X2DEMISS,X2DEMISK,X2DEMISF,
     1                   FBBCROW,FAIRROW,PRESSG,DSHJ,ZF,ZFS,ZTMST,LEVWF,
     2                   LEVAIR,IL1,IL2,LEV,ILG,ILEV,NTRAC)
C
C     * APR 28/2012 - K.VONSALZEN/ NEW VERSION FOR GCM16:
C     *               M.LAZARE.    - INITIALIZE LLOW AND LHGH TO
C     *                              ILEV INSTEAD OF ZERO, TO
C     *                              AVOID POSSIBLE INVALID 
C     *                              MEMORY REFERENCES.
C     *                            - BUGFIX FOR INCORRECT MEMORY
C     *                              REFERENCE: LLOW(L)->LLOW(IL).
C     *                            - ELIMINATE RESETTING OF LLOW TO
C     *                              ILEV IF RLH IS NOT POSITIVE.
C     * APR 26/2010 - K.VONSALZEN: PREVIOUS VERSION XTTEMI FOR GCM15H.
C
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N) 
C
      REAL, INTENT(IN), DIMENSION(ILG) :: PRESSG
      REAL, INTENT(IN), DIMENSION(ILG,ILEV)  :: DSHJ,ZF
      REAL, INTENT(IN), DIMENSION(ILG,ILEV+1):: ZFS
      REAL, INTENT(IN), DIMENSION(ILG,LEVWF) :: FBBCROW
      REAL, INTENT(IN), DIMENSION(ILG,LEVAIR):: FAIRROW
      REAL, INTENT(IN), DIMENSION(ILG,NTRAC) :: X2DEMISA,X2DEMISS,
     1                                          X2DEMISK,X2DEMISF
      REAL, INTENT(OUT), DIMENSION(ILG,ILEV,NTRAC) :: XEMIS
C
      INTEGER, DIMENSION(ILG) ::  LLOW,LHGH
C      INTEGER, DIMENSION(2000) ::  LLOW,LHGH
      REAL, DIMENSION(6) :: ZWF
      DATA ZWF /100., 500., 1000., 2000., 3000., 6000./
      REAL, DIMENSION(25) :: ZAIR
      DATA ZAIR / 610., 1220., 1830., 2440., 3050., 3660., 4270., 
     1           4880., 5490., 6100., 6710., 7320., 7930., 8540.,
     2           9150., 9760.,10370.,10980.,11590.,12200.,12810.,
     3          13420.,14030.,14640.,15250. /
C
      COMMON /PARAMS/ WW,     TW,    A,     ASQ,  GRAV, RGAS,  RGOCP,
     1                RGOASQ, CPRES, RGASV, CPRESV
C
C-------------------------------------------------------------------
C     * CHECK DIMENSIONS.
C
      IF ( LEVWF  /= 6  ) CALL XIT("XTTEMI2",-1)
      IF ( LEVAIR /= 25 ) CALL XIT("XTTEMI2",-2)
C
C-------------------------------------------------------------------
C     * SURFACE EMISSIONS. INSERT 2D EMISSIONS INTO FIRST MODEL LAYER
C     * ABOVE GROUND.
C
      DO N=1,NTRAC
      DO IL=IL1,IL2
        FACT = ZTMST*GRAV/(DSHJ(IL,ILEV)*PRESSG(IL))
        XEMIS(IL,ILEV,N)=XEMIS(IL,ILEV,N)+FACT*X2DEMISS(IL,N)
      ENDDO
      ENDDO
C
C-------------------------------------------------------------------
C     * DETERMINE LAYER CORRESPONDING TO STACK EMISSIONS (100-300M).
C
      ZMIN=100.
      ZMAX=300.
      DZ=ZMAX-ZMIN
      LLOW(IL1:IL2) = ILEV
      LHGH(IL1:IL2) = ILEV
      DO L=ILEV,1,-1
      DO IL=IL1,IL2
        IF(ZF(IL,L) .LE. ZMIN) LLOW(IL)=L
        IF(ZF(IL,L) .LE. ZMAX) LHGH(IL)=L
      ENDDO
      ENDDO
C
C     * STACK EMISSIONS.
C
      DO L=1,ILEV
      DO IL=IL1,IL2
        FACT = ZTMST*GRAV/(DSHJ(IL,L)*PRESSG(IL))
        IF ( L.EQ.LLOW(IL) .AND. L.EQ.LHGH(IL) ) THEN
          WGT=1.
        ELSE IF ( L.EQ.LHGH(IL) ) THEN
          WGT=(ZMAX-ZF(IL,L))/DZ
        ELSE IF ( L.GT.LHGH(IL) .AND. L.LT.LLOW(IL) .AND. L.GT.1 ) THEN
          WGT=(ZF(IL,L-1)-ZF(IL,L))/DZ
        ELSE IF ( L.EQ.LLOW(IL) .AND. L.GT. 1 ) THEN
          WGT=(ZF(IL,L-1)-ZMIN)/DZ
        ELSE
          WGT=0.
        ENDIF
        DO N=1,NTRAC
          EMITMP=X2DEMISK(IL,N)
          XEMIS(IL,L,N)=XEMIS(IL,L,N)+WGT*EMITMP*FACT
        ENDDO
      ENDDO
      ENDDO
C
C-------------------------------------------------------------------
C     * WILD FIRE EMISSIONS.
C
      DO K=1,LEVWF
        RUH = ZWF(K)
        IF(K.EQ.1) THEN
          RLH = 0.
        ELSE
          RLH = ZWF(K-1)
        ENDIF
        DUL = RUH-RLH
C
C       * DETERMINE LAYER CORRESPONDING TO EMISSIONS.
C
        LLOW(IL1:IL2) = ILEV
        LHGH(IL1:IL2) = ILEV
C
        DO L=ILEV,1,-1
        DO IL=IL1,IL2
          IF( ZF(IL,L) .LE. RLH)   LLOW(IL)=L
          IF( ZF(IL,L) .LE. RUH)   LHGH(IL)=L
        ENDDO
        ENDDO
        DO L=1,ILEV
        DO IL=IL1,IL2
          FACT=ZTMST*GRAV/(DSHJ(IL,L)*PRESSG(IL))
          IF ( L.EQ.LLOW(IL) .AND. L.EQ.LHGH(IL) ) THEN
            WGT=1.
          ELSE IF( L.EQ.LHGH(IL) ) THEN
            WGT=( RUH-ZF(IL,L) )/DUL
          ELSE IF( L.GT.LHGH(IL) .AND. L.LT.LLOW(IL) .AND. L.GT.1 ) THEN
            WGT=(ZF(IL,L-1)-ZF(IL,L))/DUL
          ELSE IF( L.EQ.LLOW(IL) .AND. L.GT.1 ) THEN
            WGT=( ZF(IL,L-1)-RLH )/DUL
          ELSE
            WGT=0.
          ENDIF
          DO N=1,NTRAC
            EMITMP=FBBCROW(IL,K)*X2DEMISF(IL,N)
            XEMIS(IL,L,N)=XEMIS(IL,L,N)+WGT*EMITMP*FACT
          ENDDO
        ENDDO
        ENDDO
      ENDDO
C
C-------------------------------------------------------------------
C     * AIRCRAFT EMISSIONS.
C
      DO K=1,LEVAIR
        RUH = ZAIR(K)
        IF(K.EQ.1) THEN
          RLH = 0.
        ELSE
          RLH = ZAIR(K-1)
        ENDIF
        DUL = RUH-RLH
C
C       * DETERMINE LAYER CORRESPONDING TO EMISSIONS.
C
        LLOW(IL1:IL2) = ILEV
        LHGH(IL1:IL2) = ILEV
C
        DO L=ILEV+1,1,-1
        DO IL=IL1,IL2
          IF( ZFS(IL,L) .LE. RLH)   LLOW(IL)=L
          IF( ZFS(IL,L) .LE. RUH)   LHGH(IL)=L
        ENDDO
        ENDDO
        DO L=1,ILEV
        DO IL=IL1,IL2
          FACT=ZTMST*GRAV/(DSHJ(IL,L)*PRESSG(IL))
          IF ( L.EQ.LLOW(IL) .AND. L.EQ.LHGH(IL) ) THEN
            WGT=1.
          ELSE IF( L.EQ.LHGH(IL) ) THEN
            WGT=( RUH-ZFS(IL,L) )/DUL
          ELSE IF( L.GT.LHGH(IL) .AND. L.LT.LLOW(IL) .AND. L.GT.1 ) THEN
            WGT=(ZFS(IL,L-1)-ZFS(IL,L))/DUL
          ELSE IF( L.EQ.LLOW(IL) .AND. L.GT.1 ) THEN
            WGT=( ZFS(IL,L-1)-RLH )/DUL
          ELSE
            WGT=0.
          ENDIF
          DO N=1,NTRAC
            EMITMP=FAIRROW(IL,K)*X2DEMISA(IL,N)
            XEMIS(IL,L,N)=XEMIS(IL,L,N)+WGT*EMITMP*FACT
          ENDDO
        ENDDO
        ENDDO
      ENDDO
C
      RETURN
      END 
