!WRF:MODEL_RA:RADIATION
!
#define FERRIER_GFDL

MODULE MODULE_RA_GFDLETA 5
      USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE
      USE MODULE_MODEL_CONSTANTS
#ifdef FERRIER_GFDL
      USE MODULE_MP_ETANEW, ONLY : FPVS,GPVS
#endif
      INTEGER,PARAMETER :: NL=81
      INTEGER,PARAMETER :: NBLY=15
      REAL,PARAMETER :: RTHRESH=1.E-15,RTD=1./DEGRAD

      INTEGER, SAVE, DIMENSION(3)     :: LTOP
      REAL   , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
      REAL   , SAVE, DIMENSION(NL)    :: PRGFDL
      REAL   , SAVE                   :: AB15WD,SKO2D,SKC1R,SKO3R

      REAL   , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180),     &
                           TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
                           SOURCE(28,NBLY), DSRCE(28,NBLY)

      REAL   ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
      REAL   ,SAVE                 :: R1,RSIN1,RCOS1,RCOS2
! Created by CO2 initialization
      REAL,   SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,&
                                           C2D58,CO258
      REAL,   SAVE, ALLOCATABLE, DIMENSION(:)   :: STEMP,GTEMP,CO231,CO238, &
                                           C2D31,C2D38,CDT31,CDT38, &
                                           CO271,CO278,C2D71,C2D78, &
                                           CDT71,CDT78
      REAL,   SAVE, ALLOCATABLE, DIMENSION(:)   :: CO2M51,CO2M58,CDTM51,CDTM58, &
                                           C2DM51,C2DM58
      CHARACTER(256) :: ERRMESS

! Used by CO2 initialization
!     COMMON/PRESS/PA(109)
!     COMMON/TRAN/ TRANSA(109,109)
!     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
      REAL   ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV
      REAL   ,SAVE, DIMENSION(109,109) :: TRANSA
      REAL   ,SAVE  :: CORE,UEXP,SEXP

      EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) 
      EQUIVALENCE (EM3V(1),EM3(1,1))
      EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
                  (T4(1),TABLE3(1,1))
      REAL,SAVE,DIMENSION(4) :: PTOPC
!
!--- Used for Gaussian look up tables
!
      REAL, PRIVATE,PARAMETER :: XSDmax=3.1, DXSD=.01
      INTEGER, PRIVATE,PARAMETER :: NXSD=XSDmax/DXSD
      REAL, DIMENSION(NXSD),PRIVATE,SAVE :: AXSD
      REAL, PRIVATE :: RSQR
      LOGICAL, PRIVATE,SAVE :: SDprint=.FALSE.


      REAL, PRIVATE, PARAMETER :: RHgrd=1.0
      REAL, PRIVATE, PARAMETER :: T_ice=-40.0

!
!--- Important parameters for cloud properties - see extensive comments in
!    DO 580 loop within subroutine RADTN 
!
      REAL, PARAMETER ::  &
     &   TRAD_ice=0.5*T_ice      & !--- Very tunable parameter
     &,  ABSCOEF_W=800.          & !--- Very tunable parameter
     &,  ABSCOEF_I=500.          & !--- Very tunable parameter
     &,  SECANG=-1.66            & !--- Very tunable parameter
!!     &,  SECANG=-0.75            & !--- Very tunable parameter
     &,  CLDCOEF_LW=1.5          & !--- Enhance LW cloud depths
     &,  ABSCOEF_LW=SECANG*CLDCOEF_LW  & !--- Final factor for cloud emissivities
     &,  Qconv=0.1e-3            & !--- Very tunable parameter
     &,  CTauCW=ABSCOEF_W*Qconv  &
     &,  CTauCI=ABSCOEF_I*Qconv
!

CONTAINS

!-----------------------------------------------------------------------

      SUBROUTINE GFDLETAINIT(EMISS,SFULL,SHALF,PPTOP,                   & 2,7
     &                       JULYR,MONTH,IDAY,GMT,                      &
     &                       CONFIG_FLAGS,ALLOWED_TO_READ,              &
     &                       IDS, IDE, JDS, JDE, KDS, KDE,              &
     &                       IMS, IME, JMS, JME, KMS, KME,              &
     &                       ITS, ITE, JTS, JTE, KTS, KTE              )
!-----------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------------------------------
      TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS
      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
      INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY
      REAL,INTENT(IN) :: GMT,PPTOP
      REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF
      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EMISS
      LOGICAL,INTENT(IN) :: ALLOWED_TO_READ
!
      INTEGER :: I,IHRST,J,N
      REAL :: PCLD,XSD,PI,SQR2PI
      REAL :: SSLP=1013.25
      REAL, PARAMETER :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642.,       &
     &                   PLBTM=105000.
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!
!--- In case ETAMPNEW microphysics is not called, initialize lookup tables for
!    saturation vapor pressures (only FPVS is used in radiation, which calculates
!    vapor pressure w/r/t water for T>=0C and w/r/t ice for T<0C).
!
      CALL GPVS

!***  INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS.
!
      LTOP(1)=0
      LTOP(2)=0
      LTOP(3)=0
!
      DO N=1,KTE
        PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10.
        IF(PCLD>=PTOP_LO)LTOP(1)=N
        IF(PCLD>=PTOP_MID)LTOP(2)=N
        IF(PCLD>=PTOP_HI)LTOP(3)=N
!       PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
      ENDDO
!***  
!***  ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES
!***
      PTOPC(1)=PLBTM
      PTOPC(2)=PTOP_LO*100.
      PTOPC(3)=PTOP_MID*100.
      PTOPC(4)=PTOP_HI*100.
!
!***  USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS
!***  OTHERWISE CALL CO2O3.
!
      IF(ALLOWED_TO_READ)THEN
        IF(CONFIG_FLAGS%CO2TF==1)THEN
          CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
        ELSE
          CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
        ENDIF
!
        CALL O3CLIM
        CALL TABLE
        IHRST=NINT(GMT)
!       WRITE(0,*)'into solard ',gmt,ihrst
        CALL SOLARD(IHRST,IDAY,MONTH,JULYR)
      ENDIF
!
!***  FOR NOW, GFDL RADIATION ASSUMES EMISSIVITY = 1.0
!
      DO J=JTS,JTE
      DO I=ITS,ITE
        EMISS(I,J) = 1.0
      ENDDO
      ENDDO
!
!---  Calculate the area under the Gaussian curve at the start of the
!---  model run and build the look up table AXSD
!
      PI=ACOS(-1.)
      SQR2PI=SQRT(2.*PI)
      RSQR=1./SQR2PI
      DO I=1,NXSD
        XSD=REAL(I)*DXSD
        AXSD(I)=GAUSIN(XSD)
        if (SDprint) print *,'I, XSD, AXSD =',I,XSD,AXSD(I)
      ENDDO
!
!-----------------------------------------------------------------------
      END SUBROUTINE GFDLETAINIT
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------

      SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D       &  6,3
     &                ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T                   &
     &                ,QV,QW,QI,QS                                      & 
     &                ,TSK2D,GLW,RSWIN,GSW,RSWINC                       &
     &                ,RSWTOA,RLWTOA,CZMEAN                             & 
     &                ,GLAT,GLON,HTOP,HBOT,HTOPR,HBOTR,ALBEDO,CUPPT     &
     &                ,VEGFRA,SNOW,G,GMT                                &
!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
     &                ,NSTEPRA,NPHS,ITIMESTEP                           &
     &                ,XTIME,JULIAN                                     &
     &                ,JULYR,JULDAY,GFDL_LW,GFDL_SW                     &
     &                ,CFRACL,CFRACM,CFRACH                             &
     &                ,ACFRST,NCFRST,ACFRCV,NCFRCV                      &
     &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
     &                ,IMS,IME,JMS,JME,KMS,KME                          &
     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
!-----------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------------------------------
      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
     &                     ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP           &
     &                     ,NPHS,NSTEPRA
 
      INTEGER,INTENT(IN) :: julyr,julday   
      INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST        & !Added
                                                         ,NCFRCV          !Added
      REAL,INTENT(IN) :: DT,GMT,G,XTIME,JULIAN

      REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme)::         &
                                    THRATEN,THRATENLW,THRATENSW,CLDFRA  !Added CLDFRA
      REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w,   &
     &                                                      rho_phy,    &
     &                                                      p_phy,      &
     &                                                      PI3D
      REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW,      &
     &                                                TSK2D,VEGFRA,     &
     &                                                XLAND
      REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON
      REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,HTOPR,HBOTR,CUPPT
      REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA,        & !Added
     &                                                   RLWTOA,        & !Added
     &                                                   ACFRST,        & !Added
     &                                                   ACFRCV
      REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW
      REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN             &
     &                                           ,RSWIN,RSWINC        &
     &                                           ,CFRACL,CFRACM,CFRACH
      REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QS,QV,   &
     &                                                         QW,T
      LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
      REAL, OPTIONAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI

      REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP,  &
     &                                             QWFLIP,TFLIP
      REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP
      REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
      REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT
      INTEGER :: IDAT(3),IHOUR,Jmonth,Jday
      INTEGER :: I,J,K,KFLIP,IHRST

! begin debugging radiation
      integer :: imd,jmd
      real :: FSWrat
! end debugging radiation
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
      IF(GFDL_LW.AND.GFDL_SW )GO TO 100
!
      DO J=JMS,JME
        DO K=KMS,KME
          DO I=IMS,IME
            CLDFRA(I,K,J)=0.
          ENDDO
        ENDDO
      ENDDO
!
      DO K=KMS,KME
         KFLIP=KME+1-K
         DO J=JTS,JTE
         DO I=ITS,ITE
           P8WFLIP(I,K,J)=P8W(I,KFLIP,J)
         ENDDO
         ENDDO
      ENDDO
!
!- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25)
!
      DO K=KTS,KTE
        KFLIP=KTE+1-K
        DO J=JTS,JTE
        DO I=ITS,ITE
          TFLIP (I,K,J)=T(I,KFLIP,J)
          QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J)))
          QWFLIP(I,K,J)=MAX(QW(I,KFLIP,J),0.)      !Modified
! Note that QIFLIP will contain QS+QI if both are passed in, otherwise just QS 
!     Eta MP now outputs QS instead of QI (JD 2006-05-12)
          QIFLIP(I,K,J)=MAX(QS(I,KFLIP,J),0.)      !Added QS
          IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J)      !Added QI
          PFLIP (I,K,J)=P_PHY(I,KFLIP,J)
!
!***  USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL
!
        ENDDO
        ENDDO
      ENDDO
!
      DO J=JTS,JTE
      DO I=ITS,ITE
        CUBOT(I,J)=KTE+1-HBOT(I,J)
        CUTOP(I,J)=KTE+1-HTOP(I,J)
      ENDDO
      ENDDO
!
      CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)     
!
      IDAT(1)=JMONTH
      IDAT(2)=JDAY
      IDAT(3)=JULYR
      IHRST  =NINT(GMT)

      IHOUR  =MOD((IHRST+NINT(XTIME/60.0)),24)
!     write(0,*)' before SOLARD in ETARA ', IHOUR,JDAY,JMONTH,JULYR
      CALL SOLARD(IHOUR,JDAY,JMONTH,JULYR)
!-----------------------------------------------------------------------
      CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP,                         &
     &            PFLIP,P8WFLIP,XLAND,TSK2D,                            &
     &            GLAT,GLON,CUTOP,CUBOT,ALBEDO,CUPPT,                   &
     &            ACFRCV,NCFRCV,ACFRST,NCFRST,                          &
     &            VEGFRA,SNOW,GLW,GSW,RSWIN,RSWINC,                     &
!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
     &            IDAT,IHRST,XTIME,JULIAN,                              &
     &            NSTEPRA,NSTEPRA,NPHS,ITIMESTEP,                       &
     &            TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN,              &
     &            CFRACL,CFRACM,CFRACH,                                 &
     &            IDS,IDE,JDS,JDE,KDS,KDE,                              &
     &            IMS,IME,JMS,JME,KMS,KME,                              &
     &            ITS,ITE,JTS,JTE,KTS,KTE                              )
!-----------------------------------------------------------------------
! begin debugging radiation
!     imd=(ims+ime)/2
!     jmd=(jms+jme)/2
!     FSWrat=0.
!     if (RSWIN(imd,jmd) .gt. 0.)   &
!        FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
!     write(6,"(2a,2i5,5f9.2,f8.4,i3,2f8.4)") & 
!       '{rad4 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
!      ,'ACFRCV,NCFRCV,ALBEDO,RSWOUT/RSWIN = '   &
!      ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd)  &
!      ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
!      ,ACFRCV(imd,jmd),NCFRCV(imd,jmd),ALBEDO(imd,jmd),FSWrat
! end debugging radiation
!
!--- Need to save LW & SW tendencies since radiation calculates both and this block
!    is skipped when GFDL SW is called, both only if GFDL LW is also called
!    
      IF(GFDL_LW)THEN
        DO J=JTS,JTE
        DO K = KTS,KTE
          KFLIP=KTE+1-K
          DO I=ITS,ITE
            THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J)
            THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
            THRATEN(I,K,J)  =THRATEN(I,K,J) + THRATENLW(I,K,J)
          ENDDO
        ENDDO
        ENDDO
      ENDIF
!
!*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER.
!    Only gets executed if a different LW scheme (not GFDL) is called
!
      IF(GFDL_SW)THEN
        DO J=JTS,JTE
        DO K=KTS,KTE
          KFLIP=KTE+1-K
          DO I=ITS,ITE
            THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
          ENDDO
        ENDDO
        ENDDO
      ENDIF
!
!***  RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP
!***  FOR NEXT INTERVAL BETWEEN RADIATION CALLS
!
      DO J=JTS,JTE
      DO I=ITS,ITE
! SAVE VALUE USED BY RADIATION BEFORE RESETTING HTOP AND HBOT
        HBOTR(I,J)=HBOT(I,J)
        HTOPR(I,J)=HTOP(I,J)
        HBOT(I,J)=REAL(KTE+1)
        HTOP(I,J)=0.
        CUPPT(I,J)=0.
      ENDDO
      ENDDO
!
  100 IF(GFDL_SW)THEN
        DO J=JTS,JTE
        DO K=KTS,KTE
          KFLIP=KTE+1-K
          DO I=ITS,ITE
            THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J)
          ENDDO
        ENDDO
        ENDDO
      ENDIF
!
  END SUBROUTINE ETARA
!
!-----------------------------------------------------------------------

      SUBROUTINE RADTN(DT,T,Q,QCW,QICE,                                 & 2,9
     &                 PFLIP,P8WFLIP,XLAND,TSK2D,                       &
     &                 GLAT,GLON,CUTOP,CUBOT,ALB,CUPPT,                 &
     &                 ACFRCV,NCFRCV,ACFRST,NCFRST,                     &
     &                 VEGFRC,SNO,GLW,GSW,RSWIN,RSWINC,                 & 
!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
     &                 IDAT,IHRST,XTIME,JULIAN,                         &
     &                 NRADS,NRADL,NPHS,NTSD,                           &
     &                 TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN,         &
     &                 CFRACL,CFRACM,CFRACH,                            &
     &                 ids,ide, jds,jde, kds,kde,                       &
     &                 ims,ime, jms,jme, kms,kme,                       &
     &                 its,ite, jts,jte, kts,kte                       )
!-----------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------------------------------

! GLAT : geodetic latitude in radians of the mass points on the computational grid.

! CZEN : instantaneous cosine of the solar zenith angle.

! CUTOP : (REAL) model layer number that is highest in the atmosphere
!        in which convective cloud occurred since the previous call to the
!        radiation driver.

! CUBOT : (REAL) model layer number that is lowest in the atmosphere
!        in which convective cloud occurred since the previous call to the
!        radiation driver.

! ALB  : is no longer used in the operational radiation.  Prior to 24 July 2001
!        ALB was the climatological albedo that was modified within RADTN to
!        account for vegetation fraction and snow.
!
! ALB  : reintroduced as the dynamic albedo from LSM

! CUPPT: accumulated convective precipitation (meters) since the
!        last call to the radiation.

! TSK2D : skin temperature

! IHE and IHW are relative location indices needed to locate neighboring
!       points on the Eta's Arakawa E grid since arrays are indexed locally on
!       each MPI task rather than globally.  IHE refers to the adjacent grid
!       point (a V point) to the east of the mass point being considered.  IHW
!       is the adjacent grid point to the west of the given mass point.

! IRAD is a relic from older code that is no longer needed.

! ACFRCV : sum of the convective cloud fractions that were computed
!          during each call to the radiation between calls to the subroutines that
!          do the forecast output.

! NCFRCV : the total number of times in which the convective cloud
!          fraction was computed to be greater than zero in the radiation between
!          calls to the output routines.  In the post-processor, ACFRCV is divided
!          by NCFRCV to yield an average convective cloud fraction.

!          ACFRST and NCFRST are the analogs for stratiform cloud cover.

!          VEGFRC is the fraction of the gridbox with vegetation.

!          LVL holds the number of model layers that lie below the ground surface
!          at each point.  Clearly for sigma coordinates LVL is zero everywhere.

! CTHK  :  an assumed maximum thickness of stratiform clouds currently set
!          to 20000 Pascals.  I think this is relevant for computing "low",
!          "middle", and "high" cloud fractions which are post-processed but which
!          do not feed back into the integration.

! IDAT  : a 3-element integer array holding the month, day, and year,
!        respectively, of the date for the start time of the free forecast.

! ABCFF : holds coefficients for various absorption bands.  You can see
!         where they are set in GFDLRD.F.

! LTOP  : a 3-element integer array holding the model layer that is at or
!         immediately below the specified pressure levels for the tops 
!         of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa) 
!         stratiform clouds.  These are for the diagnostic cloud layers 
!         needed in the output but not in the integration.

! NRADS : integer number of fundamental timesteps (our smallest
!         timestep, i.e., the one for inertial gravity wave adjustment) 
!         between updates of the shortwave tendencies.  

! NRADL : integer number of fundamental timesteps between updates of
!         the longwave tendencies.  

! NTSD   : integer counter of the fundamental timesteps that have
!         elapsed since the start of the forecast.

! GLW : incoming longwave radiation at the surface
! GSW : NET (down minus up, or incoming minus outgoing) all-sky shortwave radiation at the surface
! RSWIN  : total (clear + cloudy sky) incoming (downward) solar radiation at the surface
! RSWINC : clear sky incoming (downward) solar radiation at the surface

! TENDS,TENDL : shortwave,longwave (respectively) temperature tendency

! CLDFRA : 3D cloud fraction

! RSWTOA, RLWTOA : outgoing shortwave, longwave (respectively) fluxes at top of atmosphere

! CZMEAN : time-average cosine of the zenith angle

! CFRACL,CFRACM,CFRACH : low, middle, & high (diagnosed) cloud fractions

! XTIME : time since simulation start (minutes)
                                                                                                                                              
! JULIAN: Day of year (0.0 at 00Z Jan 1st)

!**********************************************************************
!****************************** NOTE **********************************
!**********************************************************************
!*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD
!*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY
!*** THAN LONGWAVE.
!**********************************************************************
!****************************** NOTE **********************************
!**********************************************************************
!-----------------------------------------------------------------------
!     INTEGER, PARAMETER         :: NL=81
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,         &
     &                              ims,ime, jms,jme, kms,kme ,         &
     &                              its,ite, jts,jte, kts,kte
      INTEGER, INTENT(IN)        :: NRADS,NRADL,NTSD,NPHS 
!     LOGICAL, INTENT(IN)        :: RESTRT
      REAL   , INTENT(IN)        :: DT,XTIME,JULIAN
!     REAL   , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
      INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
!-----------------------------------------------------------------------
      INTEGER            :: LM1,LP1,LM
      INTEGER, INTENT(IN)               :: IHRST
!     REAL,    INTENT(IN), DIMENSION(NL)    :: PRGFDL
!
      REAL, PARAMETER :: EPSQ1=1.E-5,EPSQ=1.E-12,EPSO3=1.E-10,H0=0.     &
     &, H1=1.,HALF=.5,T0C=273.15,CUPRATE=24.*1000.,HPINC=HALF*1.E1      &
!------------------------ For Clouds ----------------------------------
     &, CLFRmin=0.01, TAUCmax=4.161                                     &
!--- Parameters used for new cloud cover scheme
     &, XSDmin=-XSDmax, DXSD1=-DXSD, STSDM=0.01, CVSDM=.04              &
     &, DXSD2=HALF*DXSD, DXSD2N=-DXSD2, PCLDY=0.25
!
      INTEGER, PARAMETER :: NB=12,KSMUD=0
      INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15)
      REAL (KIND=K15) :: DDX,EEX,PROD
!     REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
!-----------------------------------------------------------------------
      LOGICAL :: SHORT,LONG
      LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITCP1,BITSP1
      LOGICAL, SAVE :: CNCLD=.TRUE.
      LOGICAL :: NEW_CLOUD
!-----------------------------------------------------------------------
      REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D
      REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW,   &
     &                                                         QICE,T,  &
     &                                                         PFLIP,   &
     &                                                         P8WFLIP

!     REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE
      REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN   &
     &                                                ,RSWIN,RSWINC     & !Added
     &                                                ,CFRACL,CFRACM    &
     &                                                ,CFRACH
      REAL, INTENT(OUT),DIMENSION(ims:ime,kms:kme,jms:jme) :: CLDFRA   !added

!     REAL,   INTENT(IN), DIMENSION(kms:kme)   :: ETAD
!     REAL,   INTENT(IN), DIMENSION(kms:kme)   :: AETA
!-----------------------------------------------------------------------
      REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: CUTOP,CUBOT,CUPPT
      REAL,   INTENT(IN   ), DIMENSION(ims:ime,jms:jme)  :: ALB,SNO
!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
      REAL,   INTENT(IN   ), DIMENSION(ims:ime,jms:jme)  :: GLAT,GLON
!-----------------------------------------------------------------------
      REAL,   DIMENSION(ims:ime,jms:jme)  :: CZEN
      INTEGER, DIMENSION(its:ite, jts:jte):: LMH
!-----------------------------------------------------------------------
!     INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW
!-----------------------------------------------------------------------
      REAL,   INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST &
                                                          ,RSWTOA,RLWTOA
      INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST
!-----------------------------------------------------------------------
      REAL,   INTENT(IN),   DIMENSION(ims:ime,jms:jme) :: VEGFRC
      REAL,   INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
     &                                                            TENDS
!-----------------------------------------------------------------------
      REAL :: CTHK(3)
      DATA CTHK/20000.0,20000.0,20000.0/

      REAL,DIMENSION(10),SAVE :: CC,PPT
!-----------------------------------------------------------------------
      REAL,SAVE :: ABCFF(NB)
      INTEGER,DIMENSION(its:ite,jts:jte) :: LVL
      REAL,   DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL
      REAL,   DIMENSION(  0:kte)  :: CLDAMT
      REAL,   DIMENSION(its:ite,3):: CLDCFR
      INTEGER,   DIMENSION(its:ite,3):: MBOT,MTOP
      REAL,   DIMENSION(its:ite)  :: PSFC,TSKN,ALBEDO,XLAT,COSZ,        &
     &                               SLMSK,FLWUP,                       &
     &                               FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS,  &
     &                               FLWUPS,FSWDNSC

      REAL,   DIMENSION(its:ite,kts:kte) :: PMID,TMID
      REAL,   DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN
      REAL,   DIMENSION(its:ite,jts:jte) :: TOT 

      REAL,   DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT
      INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
      INTEGER,DIMENSION(its:ite)   :: NCLDS,KCLD 
      REAL,   DIMENSION(its:ite)   :: TAUDAR
      REAL,   DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL

      REAL,   DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID
!!      &                                     ,QOVRCST                  ! Added
      REAL,SAVE :: P400=40000.
      INTEGER,SAVE :: NFILE=14

!-----------------------------------------------------------------------
      REAL    :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG
      REAL    :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2
      REAL    :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX
      REAL    :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF
      REAL    :: BB,GG,FCTR,PDSLIJ,CFRAVG,SNOMM
      REAL    :: THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD
      REAL    :: RHtot,SDM
      REAL    :: TauC,CTauL,CTauS,  CFSmax,CFCmax
      INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW,    &
     &           JD,II
      INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL
      INTEGER :: LCNVB,LCNVT
      INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP
      INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1

      INTEGER :: INDEXS,IXSD
      DATA    CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/
      DATA    PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./
      DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989.,      &
     &           2706.,39011./
! begin debugging radiation
      integer :: imd,jmd, Jndx
      real :: FSWrat
      imd=(ims+ime)/2
      jmd=(jms+jme)/2
! end debugging radiation
!
!=======================================================================
!
      MYJS=jts
      MYJE=jte
      MYIS=its
      MYIE=ite
      MYJS1=jts !????
      MYJE1=jte
      MYJS2=jts
      MYJE2=jte
      LM=kte
      LM1=LM-1
      LP1=LM+1
!
      DO J=JTS,JTE
      DO I=ITS,ITE
        LMH(I,J)=KME-1
        LVL(I,J)=0
      ENDDO
      ENDDO
!**********************************************************************
!***  THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED.
!**********************************************************************
!----------------------CONVECTION--------------------------------------
!  NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP
!     FOR RADIATION
!   NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS
!         THEY ARE INTEGER MULTIPLES OF EACH OTHER
!  CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD
!
      NTSPH=NINT(3600./DT)
      NRADPP=MIN(NRADS,NRADL)
      CLSTP=1.0*NRADPP/NTSPH
      CONVPRATE=CUPRATE/CLSTP
!----------------------CONVECTION--------------------------------------
!***
!***  STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE.
!***
      SHORT=.TRUE. 
      LONG=.TRUE. 
      ITIMSW=0
      ITIMLW=0
      IF(SHORT)ITIMSW=1
      IF(LONG) ITIMLW=1
!***
!***  FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE 
!***  BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS
!***  CALLED.  ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON.
!***
!     TIME=NTSD*DT
      TIME=XTIME*60.
!-----------------------------------------------------------------------
      CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN,             &
     &            MYIS,MYIE,MYJS,MYJE,                                  &
     &            ids,ide, jds,jde, kds,kde,                            &
     &            ims,ime, jms,jme, kms,kme,                            &
     &            its,ite, jts,jte, kts,kte                             ) 
!-----------------------------------------------------------------------
!     write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS)
      ADDL=0.
      IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
      RANG=PI2*(DAYI-RLAG)/(365.+ADDL)
      RSIN1=SIN(RANG)
      RCOS1=COS(RANG)
      RCOS2=COS(2.*RANG)
!
!-----------------------------------------------------------------------
      IF(SHORT)THEN
        DO J=MYJS,MYJE
        DO I=MYIS,MYIE
          CZMEAN(I,J)=0.
          TOT(I,J)=0.
        ENDDO
        ENDDO
!
        DO II=0,NRADS,NPHS
          TIMES=XTIME*60.+II*DT
          CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN,        &
     &                MYIS,MYIE,MYJS,MYJE,                              &
     &                ids,ide, jds,jde, kds,kde,                        &
     &                ims,ime, jms,jme, kms,kme,                        &
     &                its,ite, jts,jte, kts,kte                         ) 
!         write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),&
!    &                II,NRADS,NPHS,NTSD,DT
          DO J=MYJS,MYJE
          DO I=MYIS,MYIE
            IF(CZEN(I,J).GT.0.)THEN
              CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
              TOT(I,J)=TOT(I,J)+1.
            ENDIF
          ENDDO
          ENDDO
        ENDDO
        DO J=MYJS,MYJE
        DO I=MYIS,MYIE
          IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
        ENDDO
        ENDDO
      ENDIF

!
!
!***  Do not modify pressure for ozone concentrations below the top layer
!***
      DO L=2,LM
      DO I=MYIS,MYIE
        POZN(I,L)=H1
      ENDDO
      ENDDO
!-----------------------------------------------------------------------
!
!***********************************************************************
!***  THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN
!***********************************************************************
!                        *********************
                         DO 700 J = MYJS, MYJE
!                        *********************
!
      DO 125 L=1,LM
      DO I=MYIS,MYIE
        TMID(I,L)=T(I,1,J)
        QMID(I,L)=EPSQ
        QWMID(I,L)=0.
        QIMID(I,L)=0.
        CSMID(I,L)=0.
        CCMID(I,L)=0.
        OZN(I,L)=EPSO3
        TENDS(I,L,J)=0.
        TENDL(I,L,J)=0.
      ENDDO
  125 CONTINUE
!
      DO 140 N=1,3
      DO I=MYIS,MYIE
        CLDCFR(I,N)=0.
        MTOP(I,N)=0
        MBOT(I,N)=0
      ENDDO
  140 CONTINUE
!***
!***  FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT
!***  ARE ACTUALLY AT ETA LEVEL L=LMH.
!***
      DO 200 I=MYIS,MYIE
!     IR=IRAD(I)
      LML=LMH(I,J)
      LVLIJ=LVL(I,J)
!
      DO L=1,LML
        PMID(I,L+LVLIJ)=PFLIP(I,L,J)
        PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J)
        EXNER=(1.E5/PMID(I,L+LVLIJ))**RCP
        TMID(I,L+LVLIJ)=T(I,L,J)
        THMID(I,L+LVLIJ)=T(I,L,J)*EXNER
        QMID(I,L+LVLIJ)=MAX(EPSQ, Q(I,L,J))
!--- Note that rain is ignored, only effects from cloud water and 
!    ice (cloud ice + snow) are considered
        QWMID(I,L+LVLIJ)=QCW(I,L,J)
        QIMID(I,L+LVLIJ)=QICE(I,L,J)
      ENDDO
!***
!***  FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN.
!***  PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA.
!***  TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1.
!***
      IF(LVLIJ.GT.0)THEN
        KNTLYR=0
!
        DO L=LVLIJ,1,-1
          KNTLYR=KNTLYR+1
          PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*HPINC
          PINT(I,L+1)=PMID(I,L)+HPINC
          EXNER=(1.E5/PMID(I,L))**RCP
          THMID(I,L)=TMID(I,L)*EXNER
        ENDDO
      ENDIF
!
      IF(LVLIJ.EQ.0) THEN
         PINT(I,1)=P8WFLIP(I,1,J)
      ELSE
         PINT(I,1)=PMID(I,1)-HPINC
      ENDIF
  200 CONTINUE
!***
!***  FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE,
!***  ZENITH ANGLE, SEA MASK, AND ALBEDO.  THE SKIN TEMPERATURE IS
!***  NEGATIVE OVER WATER.
!***
      DO 250 I=MYIS,MYIE
      PSFC(I)=P8WFLIP(I,KME,J)
      APES=(PSFC(I)*1.E-5)**RCP
!     TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J))
      IF((XLAND(I,J)-1.5).GT.0.)THEN
        TSKN(I)=-TSK2D(I,J)
      ELSE
        TSKN(I)=TSK2D(I,J)
      ENDIF

!     TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.))
!     SLMSK(I)=SM(I,J)
      SLMSK(I)=XLAND(I,J)-1.
!
!     SNO(I,J)=AMAX1(SNO(I,J),0.)
!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
      SNOMM=AMAX1(SNO(I,J),0.)
      SNOFAC=AMIN1(SNOMM/0.02, 1.0)
!!!!  ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J))
      ALBEDO(I)=ALB(I,J)
!
      XLAT(I)=GLAT(I,J)*RTD
      COSZ(I)=CZMEAN(I,J)
  250 CONTINUE
!-----------------------------------------------------------------------
!---  COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION  (Ferrier, Nov '04)
!
!--- Assumes Gaussian-distributed probability density functions (PDFs) for
!    total relative humidity (RHtot) within the grid for convective and
!    grid-scale cloud processes.  The standard deviation of RHtot is assumed
!    to be larger for convective clouds than grid-scale (stratiform) clouds.
!-----------------------------------------------------------------------
!
      DO I=MYIS,MYIE
        LML=LMH(I,J)
        LVLIJ=LVL(I,J)
        DO 255 L=1,LML
            LL=L+LVLIJ
            WV=QMID(I,LL)/(1.-QMID(I,LL))       !--- Water vapor mixing ratio
            QCLD=QWMID(I,LL)+QIMID(I,LL)        !--- Total cloud water + ice mixing ratio
            IF (QCLD .LE. EPSQ) GO TO 255       !--- Skip if no condensate is present
            CLFR=H0
            WV=QMID(I,LL)/(1.-QMID(I,LL))       !--- Water vapor mixing ratio
               
    !
    !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C )
    !
#ifdef FERRIER_GFDL
            ESAT=1000.*FPVS(TMID(I,LL))         !--- Saturation vapor pressure (Pa)
#else
            ESAT=FPVS_new(TMID(I,LL))           !--- Saturation vapor pressure (Pa)
#endif
            QSAT=EP_2*ESAT/(PMID(I,LL)-ESAT)    !--- Saturation mixing ratio
            RHUM=WV/QSAT                        !--- Relative humidity
    !
    !--- Revised cloud cover parameterization (temporarily ignore rain)
    !
            RHtot=(WV+QCLD)/QSAT                !--- Total relative humidity
            LCNVT=NINT(CUTOP(I,J))+LVLIJ
            LCNVT=MIN(LM,LCNVT)
            LCNVB=NINT(CUBOT(I,J))+LVLIJ
            LCNVB=MIN(LM,LCNVB)
            IF (LL.GE.LCNVT .AND. LL.LE.LCNVB) THEN
               SDM=CVSDM
            ELSE
               SDM=STSDM
            ENDIF
            ARG=(RHtot-RHgrd)/SDM
            IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) THEN
               CLFR=HALF
            ELSE IF (ARG .GT. DXSD2) THEN
               IF (ARG .GE. XSDmax) THEN
                  CLFR=H1
               ELSE
                  IXSD=INT(ARG/DXSD+HALF)
                  IXSD=MIN(NXSD, MAX(IXSD,1))
                  CLFR=HALF+AXSD(IXSD)
                  if (SDprint)                                          &
     & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)")                 &
     & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot     &
     & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
               ENDIF              !--- End IF (ARG .GE. XSDmax)
            ELSE
               IF (ARG .LE. XSDmin) THEN
                  CLFR=H0
               ELSE
                  IXSD=INT(ARG/DXSD1+HALF)
                  IXSD=MIN(NXSD, MAX(IXSD,1))
                  CLFR=HALF-AXSD(IXSD)
                  if (SDprint)                                          &
     & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)")                 &
     & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot     &
     & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
                  IF (CLFR .LT. CLFRmin) CLFR=H0
               ENDIF        !--- End IF (ARG .LE. XSDmin) 
            ENDIF           !--- IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N)
            CSMID(I,LL)=CLFR
255       CONTINUE         !--- End DO L=1,LML
      ENDDO                !--- End DO I=MYIS,MYIE
!
!***********************************************************************
!******************  END OF GRID-SCALE CLOUD FRACTIONS  ****************
!
!---  COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION 
!
!--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is 
!    used for convective cloud fraction as a function of precipitation 
!    rate.  Cloud fractions have been increased by 20% for each rainrate
!    interval so that shallow, nonprecipitating convection is ascribed a
!    constant cloud fraction of 0.1  (Ferrier, Feb '02).
!***********************************************************************
!
      IF (CNCLD) THEN
        DO I=MYIS,MYIE
!
!***  CLOUD TOPS AND BOTTOMS COME FROM CUCNVC
!     Convective clouds need to be at least 2 model layers thick
!
          IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) THEN
 !--- Compute convective cloud fractions if appropriate  (Ferrier, Feb '02)
            CLFR=CC(1)
            PMOD=CUPPT(I,J)*CONVPRATE
            IF (PMOD .GT. PPT(1)) THEN
              DO NC=1,10
                IF(PMOD.GT.PPT(NC)) NMOD=NC
              ENDDO
              IF (NMOD .GE. 10) THEN
                CLFR=CC(10)
              ELSE
                CC1=CC(NMOD)
                CC2=CC(NMOD+1)
                P1=PPT(NMOD)
                P2=PPT(NMOD+1)
                CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1)
              ENDIF      !--- End IF (NMOD .GE. 10) ...
              CLFR=MIN(H1, CLFR)
            ENDIF        !--- End IF (PMOD .GT. PPT(1)) ...
  !
  !***  ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS
  !
            LVLIJ=LVL(I,J)
            LCNVT=NINT(CUTOP(I,J))+LVLIJ
            LCNVT=MIN(LM,LCNVT)
            LCNVB=NINT(CUBOT(I,J))+LVLIJ
            LCNVB=MIN(LM,LCNVB)
!! !
!! !---- For debugging
!! !
!!      WRITE(6,"(2(A,I3),2(A,I2),2(A,F5.2),2(A,I2),A,F6.4)") 
!!     & ' J=',J,' I=',I,' LCNVB=',LCNVB,' LCNVT=',LCNVT
!!     &, ' CUBOT=',CUBOT(I,J),' CUTOP=',CUTOP(I,J)
!!     &,' LVL=',LVLIJ,' LMH=',LMH(I,J),' CCMID=',CLFR
!! !
   !
   !--- Build in small amounts of subgrid-scale convective condensate 
   !    (simple assumptions), but only if the convective cloud fraction 
   !    exceeds that of the grid-scale cloud fraction
   !
            DO LL=LCNVT,LCNVB
              ARG=MAX(H0, H1-CSMID(I,LL))
              CCMID(I,LL)=MIN(ARG,CLFR)
            ENDDO           !--- End DO LL=LCNVT,LCNVB
          ENDIF             !--- IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) ...
        ENDDO               !--- End DO I loop
      ENDIF                 !--- End IF (CNCLD) ...
!
!*********************************************************************
!***************  END OF CONVECTIVE CLOUD FRACTIONS  *****************
!*********************************************************************
!***
!***  DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID
!***  AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL
!***
!***  NOTE: THIS IS FOR DIAGNOSTICS ONLY!!!
!***
!***
       DO 500 I=MYIS,MYIE
!!
       DO L=0,LM
         CLDAMT(L)=0.
       ENDDO
!!  
!!***  NOW GOES LOW, MIDDLE, HIGH
!!
       DO 480 NLVL=1,3
       CLDMAX=0.
       MALVL=LM
       LLTOP=LM+1-LTOP(NLVL)+LVL(I,J)
!!***
!!***  GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN
!!***  QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND.
!!***
       IF(LLTOP.GE.LM)GO TO 480
!!
       IF(NLVL.GT.1)THEN
         LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J)
         LLBOT=MIN(LLBOT,LM1)
       ELSE
         LLBOT=LM1
       ENDIF
!!
       DO 435 L=LLTOP,LLBOT
       CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L))
       IF(CLDAMT(L).GT.CLDMAX)THEN
         MALVL=L
         CLDMAX=CLDAMT(L)
       ENDIF
   435 CONTINUE
!!*********************************************************************
!! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN
!! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992).
!! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE
!! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED.
!! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST
!! CONTINUING CLOUD LAYERS IN THE DOMAIN.
!!*********************************************************************
       CL1=0.0
       CL2=0.0
       KBT1=LLBOT
       KBT2=LLBOT
       KTH1=0
       KTH2=0
!!
       DO 450 LL=LLTOP,LLBOT
       L=LLBOT-LL+LLTOP
       BIT1=.FALSE.
       CR1=CLDAMT(L)
       BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND.                           &
      &     (PINT(I,L).LT.PTOPC(NLVL)).AND.                             &
      &     (CLDAMT(L).GT.0.0)
       BIT1=BIT1.OR.BITX
       IF(.NOT.BIT1)GO TO 450
!!***
!!***  BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER
!!***  NOTE:  WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE
!!***         DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR
!!***         HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY
!!***         WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE
!!***         NEEDED IN THE FUTURE.
!!***
       BITY=BITX.AND.(KTH2.LE.0)
       BITZ=BITX.AND.(KTH2.GT.0)
!!
       IF(BITY)THEN
         KBT2=L
         KTH2=1
       ENDIF
!!
       IF(BITZ)THEN
         KTOP1=KBT2-KTH2+1
         DPCL=PMID(I,KBT2)-PMID(I,KTOP1)
         IF(DPCL.LT.CTHK(NLVL))THEN
           KTH2=KTH2+1
         ELSE
           KBT2=KBT2-1
         ENDIF
       ENDIF
       IF(BITX)CL2=AMAX1(CL2,CR1)
!!***
!!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP.
!!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD
!!*** LAYER IN THAT DOMAIN.
!!***
       BIT2=.FALSE.
       BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. &
            PINT(I,L-1).LT.PTOPC(NLVL+1))
       BITZ=BITY.AND.CL1.GT.0.0
       BITW=BITY.AND.CL1.LE.0.0
       BIT2=BIT2.OR.BITY
       IF(.NOT.BIT2)GO TO 450
!!
       IF(BITZ)THEN
         KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2))
         KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1
         CL1=CL1+CL2-CL1*CL2
       ENDIF
!!
       IF(BITW)THEN
         KBT1=KBT2
         KTH1=KTH2
         CL1=CL2
       ENDIF
!!
       IF(BITY)THEN
         KBT2=LLBOT
         KTH2=0
         CL2=0.0
       ENDIF
   450 CONTINUE
!
       CLDCFR(I,NLVL)=AMIN1(1.0,CL1)
       MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1)
       MBOT(I,NLVL)=KBT1
   480 CONTINUE
   500 CONTINUE

!***
!***  SET THE UN-NEEDED TAUDAR TO ONE
!***
      DO I=MYIS,MYIE
        TAUDAR(I)=1.0
      ENDDO
!----------------------------------------------------------------------
! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982),
! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993).
! 
! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO 
!         CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL
!         LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED
!         IN THIS CALCULATIONS.
!
!                                     QINGYUN ZHAO   95-3-22
!
!----------------------------------------------------------------------
!
!***
!*** INITIALIZE ARRAYS FOR USES LATER
!***

      DO 600 I=MYIS,MYIE
      LML=LMH(I,J)
      LVLIJ=LVL(I,J)
!
!***
!*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD
!***       LAYER ABOVE THE SURFACE AND SO ON.
!***
      EMIS(I,1)=1.0
      KTOP(I,1)=LP1
      KBTM(I,1)=LP1
      CAMT(I,1)=1.0
      KCLD(I)=2
!
      DO NBAND=1,NB
        RRCL(I,NBAND,1)=0.0
        TTCL(I,NBAND,1)=1.0
      ENDDO
!
      DO 510 L=2,LP1
      CAMT(I,L)=0.0
      KTOP(I,L)=1
      KBTM(I,L)=1
      EMIS(I,L)=0.0
!
      DO NBAND=1,NB
        RRCL(I,NBAND,L)=0.0
        TTCL(I,NBAND,L)=1.0
      ENDDO
  510 CONTINUE

!### End changes so far
!***
!*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER
!*** CLOUD TYPE=1: STRATIFORM CLOUD
!***       TYPE=2: CONVECTIVE CLOUD
!*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT,
!*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION.
!*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS.
!*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN.
!*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS
!*** OF MODEL LEVEL.
!***
      NEW_CLOUD=.TRUE.
!
      DO L=2,LML
        LL=LML-L+1+LVLIJ                        !-- Model layer
        CLFR=MAX(CCMID(I,LL),CSMID(I,LL))       !-- Cloud fraction in layer
        CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1))  !-- Cloud fraction in lower layer
!-------------------
        IF (CLFR .GE. CLFRMIN) THEN
!--- Cloud present at level
          IF (NEW_CLOUD) THEN
!--- New cloud layer
            IF(L==2.AND.CLFR1>=CLFRmin)THEN
              KBTM(I,KCLD(I))=LL+1
              CAMT(I,KCLD(I))=CLFR1
            ELSE
              KBTM(I,KCLD(I))=LL
              CAMT(I,KCLD(I))=CLFR
            ENDIF
            NEW_CLOUD=.FALSE.
          ELSE
!--- Existing cloud layer
            CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR)
          ENDIF        ! End IF (NEW_CLOUD .EQ. 0) ...
        ELSE IF (CLFR1 .GE. CLFRMIN) THEN
!--- Cloud is not present at level but did exist at lower level, then ...
          IF (L .EQ. 2) THEN
!--- For the case of ground fog
            KBTM(I,KCLD(I))=LL+1
            CAMT(I,KCLD(I))=CLFR1
          ENDIF
          KTOP(I,KCLD(I))=LL+1
          NEW_CLOUD=.TRUE.
          KCLD(I)=KCLD(I)+1
          CAMT(I,KCLD(I))=0.0
        ENDIF
!-------------------
      ENDDO      !--- End DO L loop
!***
!*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND;
!*** THE LAST IS THE SKY):
!***
      NCLDS(I)=KCLD(I)-2
      NCLD=NCLDS(I)
!***
!***  NOW CALCULATE CLOUD RADIATIVE PROPERTIES
!***
      IF(NCLD.GE.1)THEN
!***
!*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!!
!***
        DO 580 NC=2,NCLD+1
!
        TauC=0.    !--- Total optical depth for each cloud layer (solar & longwave)
        QSUM=0.0
        NKTP=LP1
        NBTM=0
        BITX=CAMT(I,NC).GE.CLFRMIN
        NKTP=MIN(NKTP,KTOP(I,NC))
        NBTM=MAX(NBTM,KBTM(I,NC))
!
        DO LL=NKTP,NBTM
          IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN
            PRS1=PINT(I,LL)*0.01
            PRS2=PINT(I,LL+1)*0.01
            DELP=PRS2-PRS1
            TCLD=TMID(I,LL)-T0C
            QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2)                       &     
     &           /(120.1612*SQRT(TMID(I,LL)))
!
!***********************************************************************
!****  IMPORTANT NOTES concerning input cloud optical properties  ******
!***********************************************************************
!
!--- The simple optical depth parameterization from eq. (1) of Harshvardhan
!    et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship)
!    is used for convective cloud properties with some simple changes.
!
!--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are
!    described below.
!      1) CTau=0.08*(Qc/Q0) for cloud water mixing ratio (Qc), where
!         Q0 is assumed to be the threshold mixing ratio for "thick anvils",
!         as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al.
!         (1989).  A value of Q0=0.1 g/kg is assumed based on experience w/
!         cloud observations, and it is intended only to be a crude scaling
!         factor for "order of magnitude" effects.  The functional dependence
!         on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7).
!         Result: CTau=800.*Qc => note that the "800." factor is referred to
!         as an absorption coefficient
!      2) For an assumed value of Q0=1 g/kg for "thick anvils", then 
!         CTau=80.*Qc, or an absorption coefficient that is an order of 
!         magnitude less.
!      => ABSCOEF_W can vary from 100. to 1000. !!
!      3) From p. 3105 of Dudhia (1989), values of 
!         0.14 (m**2/g) * 1000 (g/kg) / 9.81 (m/s**2) = 14.27 /Pa
!         => 14.27 (/Pa) * 100 (Pa/mb) = 1427 /mb
!      4) From Dudhia's SW radiation, ABSCOEF_W ~ 1000.  after units conversion
!      5) Again from p. 3105 of Dudhia (1989), he notes that ice absorption 
!         coefficients are roughly half those of cloud water, it was decided
!         to keep this simple and assume half that of water.
!      => ABSCOEF_I=0.5*ABSCOEF_W
!
!--- For convection, the following is assumed:
!      1) A characteristic water/ice mixing ratio (Qconv)
!      2) A temperature threshold for water or ice (TRAD_ice)
!
!-----------------------------------------------------------------------
!
            CTau=0.
!-- For crude estimation of convective cloud optical depths
            IF (CCMID(I,LL) .GE. CLFRmin) THEN
              IF (TCLD .GE. TRAD_ice) THEN
                CTau=CTauCW            !--- Convective cloud water
              ELSE
                CTau=CTauCI            !--- Convective ice
              ENDIF
!              CTau=CTau*CCMID(I,LL)    !--- Reduce by convective cloud fraction
            ENDIF
!
!-- For crude estimation of grid-scale cloud optical depths
!
!--   => The following 2 lines were intended to reduce cloud optical depths further 
!        than what's parameterized in the NAM and what's theoretically justified
!            CTau=CTau+CSMID(I,LL)*   &
!     &           ( ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) )
            CTau=CTau+ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL)
            TauC=TauC+DELP*CTau
          ENDIF      !--- End IF(LL.GE.KTOP(I,NC) ....
        ENDDO        !--- End DO LL
!
        IF(BITX)EMIS(I,NC)=1.0-EXP(ABSCOEF_LW*TauC)
        IF(QSUM.GE.EPSQ1)THEN
!
          DO 570 NBAND=1,NB
          IF(BITX)THEN
            PROD=ABCFF(NBAND)*QSUM
            DDX=TauC/(TauC+PROD)
            EEX=1.0-DDX
            IF(ABS(EEX).GE.1.E-8)THEN
              DD=DDX
              EE=EEX
              FF=1.0-DD*0.85
              AA=MIN(50.0,SQRT(3.0*EE*FF)*TauC)
              AA=EXP(-AA)
              BB=FF/EE
              GG=SQRT(BB)
              DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA
              RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD)
              TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD)
            ENDIF
          ENDIF
  570     CONTINUE
        ENDIF
  580   CONTINUE
!
      ENDIF
!
  600 CONTINUE
!*********************************************************************
!******************  COMPUTE OZONE AT MIDLAYERS  *********************
!*********************************************************************
!
!***  MODIFY PRESSURE AT THE TOP MODEL LAYER TO ACCOUNT FOR THE TOTAL
!***  OZONE FROM MODEL TOP (PINT_1) TO THE TOP OF THE ATMOSPHERE (0 MB)
!
      DO I=MYIS,MYIE
        FCTR=PINT(I,2)/(PINT(I,2)-PINT(I,1))
        POZN(I,1)=FCTR*(PMID(I,1)-PINT(I,1))
      ENDDO
!
      CALL OZON2D(LM,POZN,XLAT,OZN,                                &
                  MYIS,MYIE,                                       &
                  ids,ide, jds,jde, kds,kde,                       &
                  ims,ime, jms,jme, kms,kme,                       &
                  its,ite, jts,jte, kts,kte                        )
!
!***  
!***  NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED.
!***
!----------------------------------------------------------------------
!***
!***  CALL THE GFDL RADIATION DRIVER
!***
!***
      Jndx=J
      CALL RADFS &
     &     (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT         &
!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
     &,     CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL                         &
     &,     COSZ,TAUDAR,1                                               &
     &,     1,0                                                         &
     &,     ITIMSW,ITIMLW                                               &
     &,     TENDS(ITS,KTS,J),TENDL(ITS,KTS,J)                           &
     &,     FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC       &
     &,     ids,ide, jds,jde, kds,kde                                   &
     &,     ims,ime, jms,jme, kms,kme                                   &
! begin debugging radiation
     &,     its,ite, jts,jte, kts,kte                                   &
     &,     imd,jmd, Jndx                                       )
! end debugging radiation
!----------------------------------------------------------------------
      IF(LONG)THEN
!
!--  All fluxes in W/m**2
!--- GLW    => downward longwave at the surface (formerly RLWIN) 
!--- RLWTOA => outgoing longwave at the top of the atmosphere
!-- Note:  RLWOUT & SIGT4 have been removed because they are no longer being used!
!
        DO I=MYIS,MYIE
          GLW(I,J)=FLWDNS(I)
          RLWTOA(I,J)=FLWUP(I)
        ENDDO
      ENDIF
!
      IF(SHORT)THEN
!
!--  All fluxes in W/m**2
!--- GSW    => NET shortwave at the surface 
!--- RSWIN  => incoming shortwave at the surface (all sky)
!--- RSWINC => clear-sky incoming shortwave at the surface
!--- RSWTOA => outgoing (reflected) shortwave at the top of the atmosphere 
!
        DO I=MYIS,MYIE
          GSW(I,J)=FSWDNS(I)-FSWUPS(I)
          RSWIN(I,J) =FSWDNS(I)
          RSWINC(I,J)=FSWDNSC(I)
          RSWTOA(I,J)=FSWUP(I)
        ENDDO
      ENDIF
!
!***  ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND
!***  CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY. 
!***  ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL.
!
!***  ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS.
!
!***  UPDATE NEW 3D CLOUD FRACTION (CLDFRA)
!
      DO I=MYIS,MYIE
        CFRACL(I,J)=CLDCFR(I,1)
        CFRACM(I,J)=CLDCFR(I,2)
        CFRACH(I,J)=CLDCFR(I,3)
        IF(CNCLD)THEN
          CFSmax=0.   !-- Maximum cloud fraction (stratiform component)
          CFCmax=0.   !-- Maximum cloud fraction (convective component)
          DO L=1,LMH(I,J)
            LL=L+LVL(I,J)
            CFSmax=MAX(CFSmax, CSMID(I,LL) )
            CFCmax=MAX(CFCmax, CCMID(I,LL) )
          ENDDO
          ACFRST(I,J)=ACFRST(I,J)+CFSmax
          NCFRST(I,J)=NCFRST(I,J)+1
          ACFRCV(I,J)=ACFRCV(I,J)+CFCmax
          NCFRCV(I,J)=NCFRCV(I,J)+1
        ELSE
  !--- Count only locations with grid-scale cloudiness, ignore convective clouds
  !    (option not used, but if so set to the total cloud fraction)
          CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J))
          ACFRST(I,J)=ACFRST(I,J)+CFRAVG
          NCFRST(I,J)=NCFRST(I,J)+1
        ENDIF
!--- Flip 3D cloud fractions in the vertical and save time
        LML=LMH(I,J)
        DO L=1,LML
          LL=LML-L+1+LVL(I,J)
          CLDFRA(I,L,J)=MAX(CCMID(I,LL),CSMID(I,LL))
        ENDDO
      ENDDO      !-- I index
!***
!***  THIS ROW IS FINISHED. GO TO NEXT
!***
!                        *********************
  700                          CONTINUE
!                        *********************
!----------------------------------------------------------------------
!***
!***  CALLS TO RADIATION THIS TIME STEP ARE COMPLETE.
!***
!----------------------------------------------------------------------
! begin debugging radiation
!     FSWrat=0.
!     if (RSWIN(imd,jmd) .gt. 0.)  &
!        FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
!     write(6,"(2a,2i5,7f9.2)") &
!       '{rad3 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
!      ,'ALBEDO,RSWOUT/RSWIN = '&
!      ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd)  &
!      ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
!      ,ALB(imd,jmd),FSWrat
! end debugging radiation
!----------------------------------------------------------------------
!
!--- Need to save LW & SW tendencies since radiation calculates both and this block

      END SUBROUTINE RADTN

!----------------------------------------------------------------------


      REAL FUNCTION GAUSIN(xsd) 1
      REAL, PARAMETER :: crit=1.e-3
      REAL A1,A2,RN,B1,B2,B3,SUM
!
!  This function calculate area under the Gaussian curve between mean
!  and xsd # of standard deviation (03/22/2004  Hsin-mu Lin)
!
      a1=xsd*RSQR
      a2=exp(-0.5*xsd**2)
      rn=1.
      b1=1.
      b2=1.
      b3=1.
      sum=1.
      do while (b2 .gt. crit)
         rn=rn+1.
         b2=xsd**2/(2.*rn-1.)
         b3=b1*b2
         sum=sum+b3
         b1=b3
      enddo
      GAUSIN=a1*a2*sum
      RETURN
      END FUNCTION GAUSIN

!----------------------------------------------------------------------


      SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN,     & 6
                        MYIS,MYIE,MYJS,MYJE,                           &
                        IDS,IDE, JDS,JDE, KDS,KDE,                     &
                        IMS,IME, JMS,JME, KMS,KME,                     &
                        ITS,ITE, JTS,JTE, KTS,KTE                      )
!----------------------------------------------------------------------
      IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: IDS,IDE, JDS,JDE, KDS,KDE ,        &
                                    IMS,IME, JMS,JME, KMS,KME ,        &
                                    ITS,ITE, JTS,JTE, KTS,KTE
      INTEGER, INTENT(IN)        :: MYJS,MYJE,MYIS,MYIE

      REAL,    INTENT(IN)        :: TIMES
      REAL,    INTENT(OUT)       :: HOUR,DAYI
      INTEGER, INTENT(IN)        :: IHRST

      INTEGER, INTENT(IN), DIMENSION(3) :: IDAT 
      REAL,    INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON
      REAL,    INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN

      REAL,    PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866,    &
                            GSTC3=9.3104E-2,GSTC4=-6.2E-6,             &
                            PI=3.1415926,PI2=2.*PI,PIH=0.5*PI,         &
!#$                         DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD,    &
                            DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, &
                            ZEROJD=2451545.0

      REAL    :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM,   &
                 ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG
      REAL    :: HRLCL,SINALT
      INTEGER :: KMNTH,KNT,IDIFYR,J,I
      LOGICAL :: LEAP
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
      INTEGER :: MONTH (12)
!-----------------------------------------------------------------------
      DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
!***********************************************************************
!     SAVE MONTH
      DAY=0.
      LEAP=.FALSE.
      IF(MOD(IDAT(3),4).EQ.0)THEN
        MONTH(2)=29
        LEAP=.TRUE.
      ENDIF
      IF(IDAT(1).GT.1)THEN
        KMNTH=IDAT(1)-1
        DO 10 KNT=1,KMNTH
        DAY=DAY+REAL(MONTH(KNT))
   10   CONTINUE
      ENDIF
!***
!***  CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO
!***  FORECAST TIME OF INTEREST 
!***
      DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24.
      DAYI=REAL(INT(DAY)+1)
      HOUR=(DAY-DAYI+1.)*24.
      YFCTR=2000.-IDAT(3)
!-----------------------------------------------------------------------
!***
!***  FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND
!***  RIGHT ASCENSION.
!***
!-----------------------------------------------------------------------
      IDIFYR=IDAT(3)-2000
!***
!***  FIND JULIAN DATE OF START OF THE RELEVANT YEAR
!***  ADDING IN LEAP DAYS AS NEEDED
!***
      IF(IDIFYR.LT.0)THEN
        ADDDAY=REAL(IDIFYR/4)
      ELSE
        ADDDAY=REAL((IDIFYR+3)/4)
      ENDIF
      STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5
!***
!***  THE JULIAN DATE OF THE TIME IN QUESTION
!***
      DATJUL=STARTYR+DAY
!
!***  DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE
!***  AT 00H 1 January 2000
!
      DIFJD=DATJUL-ZEROJD
!
!***  MEAN GEOMETRIC LONGITUDE OF THE SUN
!
      SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2
!
!***  THE MEAN ANOMOLY
!
      ANOM=(357.528+0.9856003*DIFJD)*DEG2RD
!
!***  APPARENT GEOMETRIC LONGITUDE OF THE SUN
!
      SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD
      IF(SLON.GT.PI2)SLON=SLON-PI2
!
!***  DECLINATION AND RIGHT ASCENSION
! 
      DEC=ASIN(SIN(SLON)*SIN(OBLIQ))
      RA=ACOS(COS(SLON)/COS(DEC))
      IF(SLON.GT.PI)RA=PI2-RA
!***
!***  FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR
!***  HOUR ANGLE.
!***
      DATJ0=STARTYR+DAYI-1.
      TU=(DATJ0-2451545.)/36525.
      STIM0=GSTC1+TU*(GSTC2+GSTC3*TU+GSTC4*TU*TU)
      SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR
      SIDTIM=SIDTIM*15.*DEG2RD
      IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2
      IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2
      HRANG=SIDTIM-RA
!
      DO 100 J=MYJS,MYJE
      DO 100 I=MYIS,MYIE
!     HRLCL=HRANG-GLON(I,J)
      HRLCL=HRANG+GLON(I,J)+PI2
!***
!***  THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE
!***  COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE.
!***
      SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* &
       COS(GLAT(I,J))
      IF(SINALT.LT.0.)SINALT=0.
      CZEN(I,J)=SINALT
  100 CONTINUE
!***
!***  IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME,
!***  RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE
!***  RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED).
!***
      IF(DAYI.GT.365.)THEN
        IF(.NOT.LEAP)THEN
          DAYI=DAYI-365.
        ELSEIF(LEAP.AND.DAYI.GT.366.)THEN
          DAYI=DAYI-366.
        ENDIF
      ENDIF
!
      END SUBROUTINE ZENITH
!-----------------------------------------------------------------------


  SUBROUTINE OZON2D (LK,POZN,XLAT,QO3,                                & 2
                     MYIS,MYIE,                                       &
                     ids,ide, jds,jde, kds,kde,                       &
                     ims,ime, jms,jme, kms,kme,                       &
                     its,ite, jts,jte, kts,kte                        )
!----------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte  
      INTEGER, INTENT(IN)        :: LK,MYIS,MYIE
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN
      REAL,    INTENT(IN), DIMENSION(its:ite)  :: XLAT
      REAL,    INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3
!----------------------------------------------------------------------
      INTEGER, PARAMETER ::  NL=81,NLP1=NL+1,LNGTH=37*NL

!     REAL,    INTENT(IN),  DIMENSION(37,NL) :: XDUO3N,XDO3N4,XDO3N2,XDO3N3
!     REAL,    INTENT(IN), DIMENSION(NL)    :: PRGFDL
!----------------------------------------------------------------------
!----------------------------------------------------------------------
      INTEGER,DIMENSION(its:ite)    :: JJROW
      REAL,   DIMENSION(its:ite)    :: TTHAN
      REAL,   DIMENSION(its:ite,NL) :: QO3O3

      INTEGER :: I,K,NUMITR,ILOG,IT,NHALF
      REAL    :: TH2,DO3V,DO3VP,APHI,APLO
!----------------------------------------------------------------------
      DO I=MYIS,MYIE
        TH2=0.2*XLAT(I)
        JJROW(I)=19.001-TH2
        TTHAN(I)=(19-JJROW(I))-TH2
      ENDDO
!
!***  SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
!
      DO K=1,NL
      DO I=MYIS,MYIE
        DO3V=XDUO3N(JJROW(I),K)+RSIN1*XDO3N2(JJROW(I),K)  &
                   +RCOS1*XDO3N3(JJROW(I),K)  &
                   +RCOS2*XDO3N4(JJROW(I),K)
        DO3VP=XDUO3N(JJROW(I)+1,K)+RSIN1*XDO3N2(JJROW(I)+1,K) &
                    +RCOS1*XDO3N3(JJROW(I)+1,K) &
                    +RCOS2*XDO3N4(JJROW(I)+1,K)
!
!***  NOW LATITUDINAL INTERPOLATION
!***  AND CONVERT O3 INTO MASS MIXING RATIO (ORIG DATA MPY BY 1.E4)
! 
        QO3O3(I,K)=1.E-4*(DO3V+TTHAN(I)*(DO3VP-DO3V))
      ENDDO
      ENDDO
!***
!***  VERTICAL INTERPOLATION FOR EACH GRIDPOINT (LINEAR IN LN P)
!***
      NUMITR=0
      ILOG=NL
   20 CONTINUE
      ILOG=(ILOG+1)/2
        IF(ILOG.EQ.1)GO TO 25
        NUMITR=NUMITR+1
        GO TO 20
   25 CONTINUE
!
      DO 60 K=1,LK
!
      NHALF=(NL+1)/2
      DO I=MYIS,MYIE
        JJROW(I)=NHALF
      ENDDO
!
      DO 40 IT=1,NUMITR
      NHALF=(NHALF+1)/2
      DO I=MYIS,MYIE
        IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN
          JJROW(I)=JJROW(I)-NHALF
        ELSEIF(POZN(I,K).GE.PRGFDL(JJROW(I)))THEN
          JJROW(I)=JJROW(I)+NHALF
        ENDIF
        JJROW(I)=MIN(JJROW(I),NL)
        JJROW(I)=MAX(JJROW(I),2)
      ENDDO
   40 CONTINUE
!
      DO 50 I=MYIS,MYIE
      IF(POZN(I,K).LT.PRGFDL(1))THEN
        QO3(I,K)=QO3O3(I,1)
      ELSE IF(POZN(I,K).GT.PRGFDL(NL))THEN
        QO3(I,K)=QO3O3(I,NL)
      ELSE
        APLO=ALOG(PRGFDL(JJROW(I)-1))
        APHI=ALOG(PRGFDL(JJROW(I)))
        QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ &
                   (APLO-APHI)* &
                   (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I)))
      ENDIF
   50 CONTINUE
!
   60 CONTINUE

  END SUBROUTINE OZON2D
!-----------------------------------------------------------------------

! SUBROUTINE ZERO2(ARRAY, &
!                  ids,ide, jds,jde, kds,kde,                         &
!                  ims,ime, jms,jme, kms,kme,                         &
!                  its,ite, jts,jte, kts,kte                          )
!----------------------------------------------------------------------
!IMPLICIT NONE
!----------------------------------------------------------------------
!     INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
!                                   ims,ime, jms,jme, kms,kme ,      &
!                                   its,ite, jts,jte, kts,kte
!     REAL, INTENT(INOUT), DIMENSION(its:ite,jts:jte) :: ARRAY
!     INTEGER :: I,J
!----------------------------------------------------------------------
!     DO J=jts,jte
!     DO I=its,ite
!       ARRAY(I,J)=0.
!     ENDDO
!     ENDDO

! END SUBROUTINE ZERO2

!----------------------------------------------------------------


      SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, & 2
                 ids,ide, jds,jde, kds,kde,            &
                 ims,ime, jms,jme, kms,kme,            &
                 its,ite, jts,jte, kts,kte             )
!----------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte

!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .                                       .
! SUBPROGRAM:    O3INT       COMPUTE ZONAL MEAN OZONE FOR ETA LYRS
!   PRGMMR: KENNETH CAMPANA  ORG: W/NMC23    DATE: 89-07-07
!           MICHAEL BALDWIN  ORG: W/NMC22    DATE: 92-06-08
!
! ABSTRACT: THIS CODE WRITTEN AT GFDL...
!   CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE,
!   FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4
!   CODE IS CALLED ONLY ONCE.
!
! PROGRAM HISTORY LOG:
!   84-01-01  FELS AND SCHWARZKOPF,GFDL.
!   89-07-07  K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE.
!   92-06-08  M. BALDWIN - UPDATE TO RUN IN ETA MODEL
!
! USAGE:    CALL O3INT(O3,SIGL) OLD
!   INPUT ARGUMENT LIST:
!     PHALF    - MID LAYER PRESSURE (K=LM+1 IS MODEL SURFACE)
!   OUTPUT ARGUMENT LIST:
!     DDUO3N   - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4)
!     DDO3N2     DIMENSIONED(L,N),WHERE L(=37) IS LATITUDE BETWEEN
!     DDO3N3     N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR)
!     DDO3N4     AND SEASON-WIN,SPR,SUM,FALL.
!        IN COMMON
!
!   OUTPUT FILES:
!     OUTPUT   - PRINT FILE.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 200.
!
!$$$
!....     PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3
!..    OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE)
!-----------------------------------------------------------------------
!      INCLUDE "parmeta"
!-----------------------------------------------------------------------
!     *********************************************************

      INTEGER :: N,NP,NP2,NM1

!     PARAMETER (N=LM,NP=N+1,NP2=N+2,NM1=N-1)
!     *********************************************************
!-----------------------------------------------------------------------
!***
!***  SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
!***  CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
!***  DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
!***
      REAL, INTENT(OUT), DIMENSION(37,kte):: DDUO3N,DDO3N2,DDO3N3,DDO3N4

!                        C O M M O N /SAVMEM/
!       ...WINTER....  ...SPRING....  ...SUMMER....  ....FALL.....
!    1  DDUO3N(37,LM), DDO3N2(37,LM), DDO3N3(37,LM), DDO3N4(37,LM)
!          ..... K.CAMPANA   OCTOBER 1988
!CCC  DIMENSION T41(NP2,2),O3O3(37,N,4)
!     DIMENSION SIGL(N)
!     *********************************************************
      REAL ::   QI(82)
      REAL ::   DDUO3(19,kts:kte),RO31(10,41),RO32(10,41),DUO3N(19,41)
      REAL ::   TEMPN(19)
      REAL ::   O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), &
                O3LO4(10,16)
      REAL ::   O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33)
      REAL ::   O35DEG(37,kts:kte)
      REAL ::   RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), &
                PHALF(kts:kte+1),P(81),PH(82)

      INTEGER :: NKK,NK,NKP,K,L,NCASE,ITAPE,IPLACE,NKMM,NKM,KI,KK,KQ,JJ,KEN
      REAL :: O3RD,O3TOT,O3DU

      EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17))
      EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46))
      EQUIVALENCE (P1(1),P(1)),(P2(1),P(49))
      DATA PH1/      0., &
           0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
           0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
           0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
           0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
           0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
           0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
           0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
           0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
           0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
           0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
           0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
      DATA PH2/ &
           0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
           0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
           0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
           0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
           0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
           0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
           0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
           0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
           0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
           0.1000000E+01/
      DATA P1/ &
           0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
           0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
           0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
           0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
           0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
           0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
           0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
           0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
           0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
           0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
           0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
           0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
      DATA P2/ &
           0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
           0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
           0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
           0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
           0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
           0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
           0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
           0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
           0.1000000E+01/
      DATA O3HI1/ &
       .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
       .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
       .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
       .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
       .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
       .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
       .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
       .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
       1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
       1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
       1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
       2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
       2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
       2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
       2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
       3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
      DATA O3HI2/ &
       3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
       3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
       4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
       5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
       6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
       9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
       12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
       14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
       14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
      DATA O3LO1/ &
       14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
       14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
       11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
       7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
       4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
       1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
       0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
       .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
       .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
       .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
       .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
       .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
       .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
       .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
       .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
       .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
      DATA O3LO2/ &
       14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
       13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
       10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
       7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
       3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
       1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
       .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
       .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
       .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
       .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
       .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
       .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
       .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
       .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
       .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
       .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
      DATA O3LO3/ &
       14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
       13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
       10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
       7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
       4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
       1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
       .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
       .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
       .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
       .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
       .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
       .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
       .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
       .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
       .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
       .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
      DATA O3LO4/ &
       14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
       12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
       10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
       7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
       4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
       2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
       0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
       .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
       .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
       .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
       .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
       .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
       .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
       .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
       .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
       .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/

!!!!!
!     PSS=101325.
!     PDIF=PSS-PT
!
!     DO L=1,LM1
!       PHALF(L+1)=AETA(L)*PDIF+PT
!     ENDDO
!
!     PHALF(1)=0.
!     PHALF(LP1)=PSS
!!!!
      N=kte;NP=N+1;NP2=N+2;NM1=N-1

      NKK=41
      NK=81
      NKP=NK+1
      DO 24 K=1,NP
!  24 PHALF(K)=PHALF(K)*1.0E 03
   24 PHALF(K)=PHALF(K)*0.01*1.0E+03
!  24 PSTD(K)=PSTD(K+1)*1.0E 03
      DO 25 K=1,NK
      PH(K)=PH(K)*1013250.
   25 P(K)=P(K)*1013250.
      PH(NKP)=PH(NKP)*1013250.
!KAC  WRITE (6,3) PH
!KAC  WRITE (6,3) P
!     WRITE (6,3) (PHALF(K),K=1,NP)
!     WRITE (6,3) (PSTD(K),K=1,NP)
!***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM.
      DO 1010 K=1,25
      DO 1010 L=1,10
        RO31(L,K)=O3HI(L,K)
        RO32(L,K)=O3HI(L,K)
1010  CONTINUE
!
      DO 3000 NCASE=1,4
      ITAPE=NCASE+50
      IPLACE=2
      IF (NCASE.EQ.2) IPLACE=4
      IF (NCASE.EQ.3) IPLACE=1
      IF (NCASE.EQ.4) IPLACE=3
!***NCASE=1: SPRING (IN N.H.)
!***NCASE=2: FALL   (IN N.H.)
!***NCASE=3: WINTER (IN N.H.)
!***NCASE=4: SUMMER (IN N.H.)
      IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN
         DO 1011 K=26,41
         DO 1011 L=1,10
           RO31(L,K)=O3LO1(L,K-25)
           RO32(L,K)=O3LO2(L,K-25)
1011     CONTINUE
      ENDIF
      IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN
         DO 1031 K=26,41
         DO 1031 L=1,10
           RO31(L,K)=O3LO3(L,K-25)
           RO32(L,K)=O3LO4(L,K-25)
1031     CONTINUE
      ENDIF
      DO 30 KK=1,NKK
      DO 31 L=1,10
      DUO3N(L,KK)=RO31(11-L,KK)
   31 DUO3N(L+9,KK)=RO32(L,KK)
      DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK))
   30 CONTINUE
!***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
      IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN
         DO 1024 KK=1,NKK
         DO 1025 L=1,19
           TEMPN(L)=DUO3N(20-L,KK)
1025     CONTINUE
         DO 1026 L=1,19
           DUO3N(L,KK)=TEMPN(L)
1026     CONTINUE
1024     CONTINUE
      ENDIF
!***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE
!      LEVELS
!KAC  WRITE (6,800) DUO3N
!***BEGIN LATITUDE (10 DEG) LOOP
      DO 33 L=1,19
      DO 22 KK=1,NKK
   22 RSTD(KK)=DUO3N(L,KK)
      NKM=NK-1
      NKMM=NK-3
!     BESSELS HALF-POINT INTERPOLATION FORMULA
      DO 60 K=4,NKMM,2
      KI=K/2
   60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ &
      RSTD(KI-1))/16.
      RDATA(2)=.5*(RSTD(2)+RSTD(1))
      RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1))
!     PUT UNCHANGED DATA INTO NEW ARRAY
      DO 61 K=1,NK,2
      KQ=(K+1)/2
   61 RDATA(K)=RSTD(KQ)
!---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT
!     WRITE (6,798) RDATA
!     CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL
      DO 99 KK=1,N
      RBAR(KK)=0.
!     LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN
      DO 98 K=1,NK
      IF(PH(K+1).LT.PHALF(KK)) GO TO 98
      IF(PH(K).GT.PHALF(KK+1)) GO TO 98
      IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK &
      )+RDATA(K)*(PH(K+1)-PHALF(KK))
      IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(KK &
      )+RDATA(K)*(PH(K+1)-PH(K))
      IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(KK &
      )+RDATA(K)*(PHALF(KK+1)-PH(K))
   98 CONTINUE
      RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK))
      IF(RBAR(KK).GT..0000) GO TO 99
!     CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE
!     OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND
!     PHALF(KK).   PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM
!     RDATA
      DO 29 K=1,NK
      IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K)
   29 CONTINUE
   99 CONTINUE
!     CALCULATE TOTAL OZONE
      O3RD=0.
      DO 89 KK=1,80
   89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK))
      O3RD=O3RD+RDATA(81)*(P(81)-PH(81))
      O3RD=O3RD/980.
      O3TOT=0.
      DO 88 KK=1,N
   88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK))
      O3TOT=O3TOT/980.
!     UNITS ARE MICROGRAMS/CM**2
      O3DU=O3TOT/2.144
!     O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM)
!--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT
!     WRITE (6,796) O3RD,O3TOT,O3DU
      DO 23 KK=1,N
   23 DDUO3(L,KK)=RBAR(KK)*.01
   33 CONTINUE
!***END OF LATITUDE LOOP
!
!***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
!      10 DEG VALUES
      DO 1060 KK=1,N
        DO 1061 L=1,19
          O35DEG(2*L-1,KK)=DDUO3(L,KK)
1061    CONTINUE
        DO 1062 L=1,18
          O35DEG(2*L,KK)=0.5*(DDUO3(L,KK)+DDUO3(L+1,KK))
1062    CONTINUE
1060  CONTINUE
!***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE
!O222  ***************************************************
!C          WRITE (66) O35DEG
      IF (IPLACE.EQ.1) THEN
      DO 302 JJ=1,37
       DO 302 KEN=1,N
        DDUO3N(JJ,KEN) = O35DEG(JJ,KEN)
  302 CONTINUE
      ELSE IF (IPLACE.EQ.2) THEN
      DO 312 JJ=1,37
       DO 312 KEN=1,N
        DDO3N2(JJ,KEN) = O35DEG(JJ,KEN)
  312 CONTINUE
      ELSE IF (IPLACE.EQ.3) THEN
      DO 322 JJ=1,37
       DO 322 KEN=1,N
        DDO3N3(JJ,KEN) = O35DEG(JJ,KEN)
  322 CONTINUE
      ELSE IF (IPLACE.EQ.4) THEN
      DO 332 JJ=1,37
       DO 332 KEN=1,N
        DDO3N4(JJ,KEN) = O35DEG(JJ,KEN)
  332 CONTINUE
      END IF
!O222  ***************************************************
3000  CONTINUE
!***END OF LOOP OVER CASES
      RETURN
   1  FORMAT(10F4.2)
    2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X)
   3  FORMAT(10E12.5)
  797 FORMAT(10F7.2)
  799 FORMAT(19F6.4)
  800 FORMAT(19F6.2)
  102 FORMAT(' O3 IPLACE=',I4)
 1033 FORMAT(19F6.5)
  101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, &
      1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,)
      
      END SUBROUTINE O3INT
!----------------------------------------------------------------


  SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP                  & 2
      ,          ids,ide, jds,jde, kds,kde                      &
      ,          ims,ime, jms,jme, kms,kme                      &
      ,          its,ite, jts,jte, kts,kte                      )
!----------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte
!----------------------------------------------------------------------

!     ************************************************************
!     *                                                          *
!     * THIS SUBROUTINE WAS MODIFIED TO BE USED IN THE ETA MODEL *
!     *                                                          *
!     *                            Q. ZHAO    95-3-22            *
!     *                                                          *
!     ************************************************************

      REAL,    INTENT(OUT),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
      INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
      INTEGER, INTENT(IN), DIMENSION(its:ite)           :: NCLDS

      REAL,    DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
      REAL,    DIMENSION(kts:kte+1) :: CLDROW
      INTEGER:: IQ,ITOP,I,J,JTOP,IR,IP,K1,K2,KB,K,KP,KT,NC
      REAL   :: XCLD

      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE

    !  DIMENSION CLDIPT(LP1,LP1, 64 )
    !  DIMENSION NCLDS(IDIM1:IDIM2),KTOP(IDIM1:IDIM2,LP1), &
    !            KBTM(IDIM1:IDIM2,LP1)
    !  DIMENSION CLDROW(LP1)
    !  DIMENSION CAMT(IDIM1:IDIM2,LP1),CLDFAC(IDIM1:IDIM2,LP1,LP1)

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3
      LM1=L-1;  LM2=L-2;  LM3=L-3
      MYIS=its; MYIE=ite

!
      DO 1 IQ=MYIS,MYIE,64
      ITOP=IQ+63
      IF(ITOP.GT.MYIE) ITOP=MYIE
      JTOP=ITOP-IQ+1
      DO 11 IP=1,JTOP
      IR=IQ+IP-1
      IF (NCLDS(IR).EQ.0) THEN
        DO 25 J=1,LP1
        DO 25 I=1,LP1
        CLDIPT(I,J,IP)=1.
25      CONTINUE
      ENDIF
      IF (NCLDS(IR).GE.1) THEN
          XCLD=1.-CAMT(IR,2)
           K1=KTOP(IR,2)+1
           K2=KBTM(IR,2)
          DO 27 J=1,LP1
              CLDROW(J)=1.
27        CONTINUE
          DO 29 J=1,K2
              CLDROW(J)=XCLD
29        CONTINUE
          KB=MAX(K1,K2+1)
          DO 33 K=KB,LP1
          DO 33 KP=1,LP1
               CLDIPT(KP,K,IP)=CLDROW(KP)
33        CONTINUE
          DO 37 J=1,LP1
              CLDROW(J)=1.
37        CONTINUE
          DO 39 J=K1,LP1
              CLDROW(J)=XCLD
39        CONTINUE
          KT=MIN(K1-1,K2)
          DO 43 K=1,KT
          DO 43 KP=1,LP1
              CLDIPT(KP,K,IP)=CLDROW(KP)
43        CONTINUE
          IF(K2+1.LE.K1-1) THEN
            DO 31 J=K2+1,K1-1
            DO 31 I=1,LP1
                CLDIPT(I,J,IP)=1.
31          CONTINUE
          ELSE IF(K1.LE.K2) THEN
            DO 32 J=K1,K2
            DO 32 I=1,LP1
                CLDIPT(I,J,IP)=XCLD
32          CONTINUE
          ENDIF
      ENDIF

      IF (NCLDS(IR).GE.2) THEN
        DO 21 NC=2,NCLDS(IR)
          XCLD=1.-CAMT(IR,NC+1)
           K1=KTOP(IR,NC+1)+1
           K2=KBTM(IR,NC+1)
          DO 47 J=1,LP1
              CLDROW(J)=1.
47        CONTINUE
          DO 49 J=1,K2
              CLDROW(J)=XCLD
49        CONTINUE
          KB=MAX(K1,K2+1)
          DO 53 K=KB,LP1
          DO 53 KP=1,LP1
               CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
53        CONTINUE
          DO 57 J=1,LP1
              CLDROW(J)=1.
57        CONTINUE
          DO 59 J=K1,LP1
              CLDROW(J)=XCLD
59        CONTINUE
          KT=MIN(K1-1,K2)
          DO 63 K=1,KT
          DO 63 KP=1,LP1
              CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
63        CONTINUE
          IF(K1.LE.K2) THEN
            DO 52 J=K1,K2
            DO 52 I=1,LP1
                CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD
52          CONTINUE
          ENDIF
21        CONTINUE
      ENDIF
11    CONTINUE
      DO 71 J=1,LP1
      DO 71 I=1,LP1
      DO 71 IP=1,JTOP
      IR=IQ+IP-1
      CLDFAC(IR,I,J)=CLDIPT(I,J,IP)
71    CONTINUE
1     CONTINUE

  END SUBROUTINE CLO89
!----------------------------------------------------------------
!     SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX,                         &
!                      PRESS,TEMP,RH2O,QO3,CLDFAC,                   &
!                      CAMT,NCLDS,KTOP,KBTM,                         &
!!                     BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V,       &
!                      BO3RND,AO3RND, &
!                      APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
!                      ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
!                      GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
!                      P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
!                      TEN,HP1,FOUR,HM1EZ,SKO3R,                     &
!                      AB15WD,SKC1R,RADCON,QUARTR,TWO,               &
!                      HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
!                      RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
!                      ids,ide, jds,jde, kds,kde,                    &
!                      ims,ime, jms,jme, kms,kme,                    &
!                      its,ite, jts,jte, kts,kte                     )


      SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX,                         & 2,2
                       PRESS,TEMP,RH2O,QO3,CLDFAC,                   &
                       CAMT,NCLDS,KTOP,KBTM,                         &
!                      BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V,       &
                       BO3RND,AO3RND, &
                       APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
                       ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
                       GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
                       P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
                       TEN,HP1,FOUR,HM1EZ,                           &
                       RADCON,QUARTR,TWO,                            &
                       HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
                       RADCON1,H16E1, H28E1,H44194M2,H1P41819,       &
                       ids,ide, jds,jde, kds,kde,                    &
                       ims,ime, jms,jme, kms,kme,                    &
                       its,ite, jts,jte, kts,kte                     )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
!     INTEGER, PARAMETER :: NBLY=15

      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte  
      REAL,    INTENT(IN)        :: ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR
      REAL,    INTENT(IN)        :: GINV,H3M4,BETINW,RATH2OMW,GP0INV
      REAL,    INTENT(IN)        :: P0XZP8,P0XZP2,H3M3,P0,H1M3
      REAL,    INTENT(IN)        :: H1M2,H25E2,B0,B1,B2,B3,HAF
!     REAL,    INTENT(IN)        :: TEN,HP1,FOUR,HM1EZ,SKO3R
      REAL,    INTENT(IN)        :: TEN,HP1,FOUR,HM1EZ         
!     REAL,    INTENT(IN)        :: AB15WD,SKC1R,RADCON,QUARTR,TWO
      REAL,    INTENT(IN)        :: RADCON,QUARTR,TWO
      REAL,    INTENT(IN)        :: HM6666M2,HMP66667,HMP5, HP166666,H41666M2
!     REAL,    INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D
      REAL,    INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819
!----------------------------------------------------------------------
      REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
!     REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
!     REAL, INTENT(IN), DIMENSION(5040) :: EM3V
      REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
                                         BCOMB,BETACM

      REAL,    INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
      INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
      INTEGER, INTENT(IN), DIMENSION(its:ite)           :: NCLDS
     
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte)   :: RH2O,QO3
      REAL,    INTENT(OUT), DIMENSION(its:ite,kts:kte)   :: HEATRA
      REAL,    INTENT(OUT), DIMENSION(its:ite)           :: GRNFLX,TOPFLX

!     REAL,    DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT

!     Include co2 data from a file, which needs to have exactly vertical
!     dimension of the model.
      

!!! ??? co2 table
!     REAL,    DIMENSION(kts:kte+1,kts:kte+1) :: CO251,CDT51,CDT58,C2D51,&
!                                                C2D58,CO258
!     REAL,    DIMENSION(kts:kte+1)           :: STEMP,GTEMP,CO231,CO238, &
!                                                C2D31,C2D38,CDT31,CDT38, &
!                                                CO271,CO278,C2D71,C2D78, &
!                                                CDT71,CDT78
!     REAL,    DIMENSION(kts:kte)             :: CO2M51,CO2M58,CDTM51,CDTM58, &
!                                                C2DM51,C2DM58
!!! end co2 table

!     REAL,    DIMENSION(kts:kte+1) :: CLDROW

      REAL,    DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,&
                                               TPHIO3,TOTVO2,TSTDAV,TDAV, & 
                                               VSUM3,CO2R1,D2CD21,DCO2D1, &
                                               CO2R2,D2CD22,DCO2D2,CO2SP1,&
                                               CO2SP2,CO2R,DCO2DT,D2CDT2, &
                                               TLSQU,DIFT
      REAL,    DIMENSION(its:ite,kts:kte)   :: DELP2,DELP,CO2NBL,&
                                               QH2O,VV,VAR1,VAR2,VAR3,VAR4
      REAL,    DIMENSION(its:ite,kts:kte+1) :: P,T
      REAL,    DIMENSION(its:ite,kts:kte)   :: CO2MR,CO2MD,CO2M2D
      REAL,    DIMENSION(its:ite,kts:kte*2+1):: EMPL

      REAL,    DIMENSION(its:ite)           :: EMX1,EMX2,VSUM1,VSUM2,A1,A2 
      REAL,    DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21

   !  COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1),
   !  DIMENSION CO21(IDIM1:IDIM2,LP1,LP1),CO2NBL(IDIM1:IDIM2,L)
   !  DIMENSION CO2R(IDIM1:IDIM2,LP1),DIFT(IDIM1:IDIM2,LP1)
   ! 1   CO2M2D(IDIM1:IDIM2,L)
   !  DIMENSION CO2MR(IDIM1:IDIM2,L),CO2MD(IDIM1:IDIM2,L),
   ! 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L),
   ! 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L),
   !  COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1),
   ! 1 CDT38(LP1),C2D31(LP1),C2D38(LP1)
   !  DIMENSION CO2R1(IDIM1:IDIM2,LP1),DCO2D1(IDIM1:IDIM2,LP1)
   !  DIMENSION D2CD21(IDIM1:IDIM2,LP1),D2CD22(IDIM1:IDIM2,LP1)
   ! 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3
   ! 1 VV(IDIM1:IDIM2,L),VSUM3(IDIM1:IDIM2,LP1),VSUM1(IDIM1:IDIM2),
   ! 2 VSUM2(IDIM1:IDIM2)
   !  DIMENSION TDAV(IDIM1:IDIM2,LP1),TSTDAV(IDIM1:IDIM2,LP1),
   !  LLP1=LL+1, LL = 2L
   !  EMX2(IDIM1:IDIM2),EMPL(IDIM1:IDIM2,LLP1)
   !  DIMENSION TPHIO3(IDIM1:IDIM2,LP1),
   !  DIMENSION TEXPSL(IDIM1:IDIM2,LP1)
   !  DIMENSION QH2O(IDIM1:IDIM2,L)
   !  DIMENSION DELP2(IDIM1:IDIM2,L)
   !  DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L),
   ! 1   VAR3(IDIM1:IDIM2,L),VAR4(IDIM1:IDIM2,L)
   ! 1 VV(IDIM1:IDIM2,L)
   !  DIMENSION CNTVAL(IDIM1:IDIM2,LP1)
   !  DIMENSION TOTO3(IDIM1:IDIM2,LP1)
   !  DIMENSION EMX1(IDIM1:IDIM2),

   !  DIMENSION PRESS(IDIM1:IDIM2,LP1),TEMP(IDIM1:IDIM2,LP1), &
   !     RH2O(IDIM1:IDIM2,L),QO3(IDIM1:IDIM2,L)
   !  DIMENSION HEATRA(IDIM1:IDIM2,L),GRNFLX(IDIM1:IDIM2),    &
   !     TOPFLX(IDIM1:IDIM2)

!
!
!****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP)
!****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE
!    CORRECTIONS (TEXPSL)
    
      INTEGER :: K, I,KP
      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
      LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
      MYIS=its; MYIE=ite


      DO 103 K=2,L
      DO 103 I=MYIS,MYIE
      P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K))
      T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K))
103   CONTINUE
      DO 105 I=MYIS,MYIE
      P(I,1)=ZERO
      P(I,LP1)=PRESS(I,LP1)
      T(I,1)=TEMP(I,1)
      T(I,LP1)=TEMP(I,LP1)
105   CONTINUE
      DO 107 K=1,L
      DO 107 I=MYIS,MYIE
      DELP2(I,K)=P(I,K+1)-P(I,K)
      DELP(I,K)=ONE/DELP2(I,K)
107   CONTINUE
!****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF.
!    (THIS IS 1800.(1./TEMP-1./296.))
      DO 125 K=1,LP1
      DO 125 I=MYIS,MYIE
      TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108
!...THEN TAKE EXPONENTIAL
      TEXPSL(I,K)=EXP(TEXPSL(I,K))
125   CONTINUE
!***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY
!   APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE
!   UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4).
!   THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND
!   VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND
!   O3,RESPECTIVELY.
!
      DO 131 K=1,L
      DO 131 I=MYIS,MYIE
      QH2O(I,K)=RH2O(I,K)*DIFFCTR
!---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS
!   THE LEVEL PRESSURE (PRESS)
      VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV
      VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV
      VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV
      VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4)
      VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3)
!  COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS.
!  (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR
!  (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE
!  USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT
!  SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF
!  AN ANGULAR INTEGRATION IS SEVERE.
!
      CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ &
                   (RH2O(I,K)+RATH2OMW)
131   CONTINUE
!   COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM
      DO 201 I=MYIS,MYIE
      TOTPHI(I,1)=ZERO
      TOTO3(I,1)=ZERO
      TPHIO3(I,1)=ZERO
      TOTVO2(I,1)=ZERO
201   CONTINUE
      DO 203 K=2,LP1
      DO 203 I=MYIS,MYIE
      TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1)
      TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1)
      TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1)
      TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1)
203   CONTINUE
!---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
!   P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS.
!---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
!   P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1.
!
      DO 801 I=MYIS,MYIE
      EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV
      EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV
801   CONTINUE
!---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1)
!   OR TO PRESS(K+1) (INDEX LP2-LL)
      DO 811 K=1,L
      DO 811 I=MYIS,MYIE
      EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV
811   CONTINUE
      DO 812 K=1,LM1
      DO 812 I=MYIS,MYIE
      EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) &
                     *GP0INV
812   CONTINUE
      DO 821 I=MYIS,MYIE
      EMPL(I,1)=VAR2(I,L)
      EMPL(I,LLP1)=EMPL(I,LL)
821   CONTINUE
!***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS
!   FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD.
!   TEMP. SOUNDING (DIFT)
      DO 161 I=MYIS,MYIE
      TSTDAV(I,1)=ZERO
      TDAV(I,1)=ZERO
161   CONTINUE
      DO 162 K=1,LP1
      DO 162 I=MYIS,MYIE
      VSUM3(I,K)=TEMP(I,K)-STEMP(K)
162   CONTINUE
      DO 163 K=1,L
      DO 165 I=MYIS,MYIE
      VSUM2(I)=GTEMP(K)*DELP2(I,K)
      VSUM1(I)=VSUM2(I)*VSUM3(I,K)
      TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I)
      TDAV(I,K+1)=TDAV(I,K)+VSUM1(I)
165   CONTINUE
163   CONTINUE
!
!****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2)
      DO 171 I=MYIS,MYIE
      A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2
      A2(I)=(P0-PRESS(I,LP1))/P0XZP2
171   CONTINUE
!***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION
!   FUNCTIONS AND TEMP. DERIVATIVES
!---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE
!   STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME)
      DO 184 K=1,LP1
      DO 184 I=MYIS,MYIE
        CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K)
        D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K))
        DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K))
        CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K)
        D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K))
        DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K))
184   CONTINUE
      DO 190 K=1,L
      DO 190 I=MYIS,MYIE
        CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K)
        CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K))
        CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K))
190   CONTINUE
!***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT
!
!   THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING
!   3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS
!   CALCULATION IS FOR (I,KP,1)
      DO 211 KP=2,LP1
      DO 211 I=MYIS,MYIE
      DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP)
211   CONTINUE
      DO 212 I=MYIS,MYIE
      CO21(I,1,1)=1.0
      CO2SP1(I,1)=1.0
      CO2SP2(I,1)=1.0
212   CONTINUE
      DO 215 KP=2,LP1
      DO 215 I=MYIS,MYIE
!---CALCULATIONS FOR KP>1 FOR K=1
      CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1)
      DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1))
      D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1))
      CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
                   HAF*DIFT(I,KP)*D2CDT2(I,KP))
!---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE
!   SAME VALUE OF DIFT DUE TO SYMMETRY
      CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP)
      DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP))
      D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP))
      CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
                   HAF*DIFT(I,KP)*D2CDT2(I,KP))
215   CONTINUE
!   THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW.
!---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS
!    INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1))
      DO 250 K=2,LP1
      DO 250 I=MYIS,MYIE
      CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* &
       D2CD21(I,K))
      CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* &
       D2CD22(I,K))
250   CONTINUE
!
!   NEXT THE CASE WHEN K=2...L
      DO 220 K=2,L
      DO 222 KP=K+1,LP1
      DO 222 I=MYIS,MYIE
      DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ &
                    (TSTDAV(I,KP)-TSTDAV(I,K))
      CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
      DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K))
      D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K))
      CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
                   HAF*DIFT(I,KP)*D2CDT2(I,KP))
      CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP)
      DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP))
      D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP))
      CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
                   HAF*DIFT(I,KP)*D2CDT2(I,KP))
222   CONTINUE
220   CONTINUE
!   FINALLY THE CASE WHEN K=KP,K=2..LP1
      DO 206 K=2,LP1
      DO 206 I=MYIS,MYIE
      DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1))
      CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K)
      DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K))
      D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K))
      CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ &
                   HAF*DIFT(I,K)*D2CDT2(I,K))
206   CONTINUE
!--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS .
      DO 260 K=1,L
      DO 260 I=MYIS,MYIE
      CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* &
       VSUM3(I,K)*CO2M2D(I,K))
260   CONTINUE
!***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2)
      DO 264 K=1,LP1
      DO 264 I=MYIS,MYIE
      IF (T(I,K).LE.H25E2) THEN
         TLSQU(I,K)=B0+(T(I,K)-H25E2)* &
                            (B1+(T(I,K)-H25E2)* &
                         (B2+B3*(T(I,K)-H25E2)))
      ELSE
         TLSQU(I,K)=B0
      ENDIF
264   CONTINUE
!***APPLY TO ALL CO2 TFS
      DO 280 K=1,LP1
      DO 282 KP=1,LP1
      DO 282 I=MYIS,MYIE
      CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP)
282   CONTINUE
280   CONTINUE
      DO 284 K=1,LP1
      DO 286 I=MYIS,MYIE
      CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
      CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
286   CONTINUE
284   CONTINUE
      DO 288 K=1,L
      DO 290 I=MYIS,MYIE
      CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K)
290   CONTINUE
288   CONTINUE
!     CALL FST88(HEATRA,GRNFLX,TOPFLX, &
!                QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
!                CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
!                CO21,CO2NBL,CO2SP1,CO2SP2, &
!                VAR1,VAR2,VAR3,VAR4,CNTVAL, &
!                TOTO3,TPHIO3,TOTPHI,TOTVO2, &
!                EMX1,EMX2,EMPL, &
!
!                BO3RND,AO3RND, &
!!               T1,T2,T4 , EM1V,EM1VW, EM3V, &
!                APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
!                TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
!                AB15WD,SKC1R,RADCON,QUARTR,TWO, &
!                HM6666M2,HMP66667,HMP5, &
!                HP166666,H41666M2,RADCON1, &
!                H16E1, H28E1, H25E2, H44194M2,H1P41819, &
!                SKO2D,                                        &
!                ids,ide, jds,jde, kds,kde,                    &
!                ims,ime, jms,jme, kms,kme,                    &
!                its,ite, jts,jte, kts,kte                     )

      CALL FST88(HEATRA,GRNFLX,TOPFLX, &
                 QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
                 CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
                 CO21,CO2NBL,CO2SP1,CO2SP2, &
                 VAR1,VAR2,VAR3,VAR4,CNTVAL, &
                 TOTO3,TPHIO3,TOTPHI,TOTVO2, &
                 EMX1,EMX2,EMPL, &
!
                 BO3RND,AO3RND, &
!                T1,T2,T4 , EM1V,EM1VW, EM3V, &
                 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
                 TEN,HP1,HAF,ONE,FOUR,HM1EZ,       &
                 RADCON,QUARTR,TWO,  &
                 HM6666M2,HMP66667,HMP5, &
                 HP166666,H41666M2,RADCON1, &
                 H16E1, H28E1, H25E2, H44194M2,H1P41819, &
                 ids,ide, jds,jde, kds,kde,                    &
                 ims,ime, jms,jme, kms,kme,                    &
                 its,ite, jts,jte, kts,kte                     )

  END SUBROUTINE LWR88
!---------------------------------------------------------------------
! SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
!                      QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
!                      CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
!                      CO21,CO2NBL,CO2SP1,CO2SP2, &
!                      VAR1,VAR2,VAR3,VAR4,CNTVAL, &
!                      TOTO3,TPHIO3,TOTPHI,TOTVO2, &
!                      EMX1,EMX2,EMPL, &
!                      BO3RND,AO3RND, &
!!                     T1,T2,T4 , EM1V,EM1VW, EM3V, &
!                      APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
!                      TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
!                      AB15WD,SKC1R,RADCON,QUARTR,TWO, &
!                      HM6666M2,HMP66667,HMP5, &
!                      HP166666,H41666M2,RADCON1, &
!                      H16E1, H28E1, H25E2, H44194M2,H1P41819, &
!                      SKO2D,                                        &
!                      ids,ide, jds,jde, kds,kde,                    &
!                      ims,ime, jms,jme, kms,kme,                    &
!                      its,ite, jts,jte, kts,kte                     )


  SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, & 2,10
                       QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
                       CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
                       CO21,CO2NBL,CO2SP1,CO2SP2, &
                       VAR1,VAR2,VAR3,VAR4,CNTVAL, &
                       TOTO3,TPHIO3,TOTPHI,TOTVO2, &
                       EMX1,EMX2,EMPL, &
                       BO3RND,AO3RND, &
!                      T1,T2,T4 , EM1V,EM1VW, EM3V, &
                       APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
                       TEN,HP1,HAF,ONE,FOUR,HM1EZ,       &
                       RADCON,QUARTR,TWO, &
                       HM6666M2,HMP66667,HMP5, &
                       HP166666,H41666M2,RADCON1, &
                       H16E1, H28E1, H25E2, H44194M2,H1P41819, &
                       ids,ide, jds,jde, kds,kde,                    &
                       ims,ime, jms,jme, kms,kme,                    &
                       its,ite, jts,jte, kts,kte                     )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
!     INTEGER, PARAMETER :: NBLY=15

      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte

!     REAL,    INTENT(IN)        :: TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R
      REAL,    INTENT(IN)        :: TEN,HP1,HAF,ONE,FOUR,HM1EZ
!     REAL,    INTENT(IN)        :: AB15WD,SKC1R,RADCON,QUARTR,TWO
      REAL,    INTENT(IN)        :: RADCON,QUARTR,TWO
      REAL,    INTENT(IN)        :: HM6666M2,HMP66667,HMP5
      REAL,    INTENT(IN)        :: HP166666,H41666M2,RADCON1,H16E1, H28E1 
!     REAL,    INTENT(IN)        :: H25E2,H44194M2,H1P41819,SKO2D
      REAL,    INTENT(IN)        :: H25E2,H44194M2,H1P41819

      REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
                                         BCOMB,BETACM

!     REAL, INTENT(IN), DIMENSION(5040) :: T1,T2,T4,EM1V,EM1VW
!     REAL, INTENT(IN), DIMENSION(5040) :: EM3V
      REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: EMPL
      REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TOTO3,TPHIO3,TOTPHI,CNTVAL,&
                                                        CO2SP1,CO2SP2   

      REAL,    INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT,TOTVO2
      INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
      INTEGER, INTENT(IN), DIMENSION(its:ite)           :: NCLDS
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte)   :: QH2O
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
      REAL,    INTENT(OUT), DIMENSION(its:ite,kts:kte)  :: HEATRA
      REAL,    INTENT(OUT), DIMENSION(its:ite)          :: GRNFLX,TOPFLX
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: P,T
      REAL,    INTENT(INOUT), DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte)   :: CO2NBL,DELP2, &
                                                           DELP,&
                                               VAR1,VAR2,VAR3,VAR4
      REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
      REAL, INTENT(IN), DIMENSION(its:ite)   :: EMX1,EMX2
      
      REAL, DIMENSION(its:ite,kts:kte*2+1) :: TPL,EMD,ALP,C,CSUB,CSUB2
      REAL, DIMENSION(its:ite,kts:kte*2+1) :: C2
      INTEGER, DIMENSION(its:ite,kts:kte+1) :: IXO
      REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, &
                                            SS1,CSOUR,TC,OSS,CSS,DTC,SS2,&
                                            AVEPHI,E1CTS1,E1FLX,  &
                                            E1CTW1,DSORC,EMISS,FAC1,&
                                            TO3SP,OVER1D,CNTTAU,TOTEVV,&
                                            CO2SP,FLX,AVMO3, &
                                            AVPHO3,AVVO2,CONT1D,TO31D,EMISDG,&
                                            DELPR1
      REAL, DIMENSION(its:ite,kts:kte+1) :: EMISSB,DELPR2,CONTDG,TO3DG,HEATEM,&
                                            VSUM1,FLXNET,Z1

      REAL, DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
      REAL, DIMENSION(its:ite,kts:kte)   :: E1CTS2,E1CTW2,TO3SPC,RLOG,EXCTS,&
                                            CTSO3,CTS
      REAL, DIMENSION(its:ite)   :: GXCTS,FLX1E1
      REAL, DIMENSION(its:ite)   :: PTOP,PBOT,FTOP,FBOT,DELPTC
      REAL, DIMENSION(its:ite,2) :: FXOSP,DTSP,EMSPEC
!     REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE
      INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
      LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
      LLM2 = LL-2; LLM1=LL-1
      MYIS=its; MYIE=ite

!
      DO 101 K=1,LP1
      DO 101 I=MYIS,MYIE
!---TEMP. INDICES FOR E1,SOURCE
      VTMP3(I,K)=AINT(TEMP(I,K)*HP1)
      FXO(I,K)=VTMP3(I,K)-9.
      DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K)
!---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY)
      IXO(I,K)=FXO(I,K)
101   CONTINUE
      DO 103 k=1,L
      DO 103 I=MYIS,MYIE
!---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS)
      VTMP3(I,K)=AINT(T(I,K+1)*HP1)
      FXOE2(I,K)=VTMP3(I,K)-9.
      DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K)
103   CONTINUE
!---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS.
      DO 105 I=MYIS,MYIE
      FXOE2(I,LP1)=FXO(I,L)
      DTE2(I,LP1)=DT(I,L)
      FXOSP(I,1)=FXOE2(I,LM1)
      FXOSP(I,2)=FXO(I,LM1)
      DTSP(I,1)=DTE2(I,LM1)
      DTSP(I,2)=DT(I,LM1)
105   CONTINUE
!
!---SOURCE FUNCTION FOR COMBINED BAND 1
      DO 4114 I=MYIS,MYIE
      DO 4114 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),1)
        DSORC(I,K)=DSRCE(IXO(I,K),1)
4114   CONTINUE
      DO 4112 K=1,LP1
      DO 4112 I=MYIS,MYIE
      SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4112   CONTINUE
!---SOURCE FUNCTION FOR COMBINED BAND 2
      DO 4214 I=MYIS,MYIE
      DO 4214 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),2)
        DSORC(I,K)=DSRCE(IXO(I,K),2)
4214   CONTINUE
      DO 4212 K=1,LP1
      DO 4212 I=MYIS,MYIE
      SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4212   CONTINUE
!---SOURCE FUNCTION FOR COMBINED BAND 3
      DO 4314 I=MYIS,MYIE
      DO 4314 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),3)
        DSORC(I,K)=DSRCE(IXO(I,K),3)
4314   CONTINUE
      DO 4312 K=1,LP1
      DO 4312 I=MYIS,MYIE
      SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4312   CONTINUE
!---SOURCE FUNCTION FOR COMBINED BAND 4
      DO 4414 I=MYIS,MYIE
      DO 4414 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),4)
        DSORC(I,K)=DSRCE(IXO(I,K),4)
4414   CONTINUE
      DO 4412 K=1,LP1
      DO 4412 I=MYIS,MYIE
      SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4412   CONTINUE
!---SOURCE FUNCTION FOR COMBINED BAND 5
      DO 4514 I=MYIS,MYIE
      DO 4514 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),5)
        DSORC(I,K)=DSRCE(IXO(I,K),5)
4514   CONTINUE
      DO 4512 K=1,LP1
      DO 4512 I=MYIS,MYIE
      SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4512   CONTINUE
!---SOURCE FUNCTION FOR COMBINED BAND 6
      DO 4614 I=MYIS,MYIE
      DO 4614 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),6)
        DSORC(I,K)=DSRCE(IXO(I,K),6)
4614   CONTINUE
      DO 4612 K=1,LP1
      DO 4612 I=MYIS,MYIE
      SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4612   CONTINUE
!---SOURCE FUNCTION FOR COMBINED BAND 7
      DO 4714 I=MYIS,MYIE
      DO 4714 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),7)
        DSORC(I,K)=DSRCE(IXO(I,K),7)
4714   CONTINUE
      DO 4712 K=1,LP1
      DO 4712 I=MYIS,MYIE
      SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4712   CONTINUE
!---SOURCE FUNCTION FOR COMBINED BAND 8
      DO 4814 I=MYIS,MYIE
      DO 4814 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),8)
        DSORC(I,K)=DSRCE(IXO(I,K),8)
4814   CONTINUE
      DO 4812 K=1,LP1
      DO 4812 I=MYIS,MYIE
      SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4812   CONTINUE
!---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1)
      DO 4914 I=MYIS,MYIE
      DO 4914 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),9)
        DSORC(I,K)=DSRCE(IXO(I,K),9)
4914   CONTINUE
      DO 4912 K=1,LP1
      DO 4912 I=MYIS,MYIE
      SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
4912   CONTINUE
!---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1)
      DO 5014 I=MYIS,MYIE
      DO 5014 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),10)
        DSORC(I,K)=DSRCE(IXO(I,K),10)
5014  CONTINUE
      DO 5012 K=1,LP1
      DO 5012 I=MYIS,MYIE
      SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
5012   CONTINUE
!---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1)
      DO 5114 I=MYIS,MYIE
      DO 5114 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),11)
        DSORC(I,K)=DSRCE(IXO(I,K),11)
5114   CONTINUE
      DO 5112 K=1,LP1
      DO 5112 I=MYIS,MYIE
      SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
5112   CONTINUE
!---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1)
      DO 5214 I=MYIS,MYIE
      DO 5214 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),12)
        DSORC(I,K)=DSRCE(IXO(I,K),12)
5214   CONTINUE
      DO 5212 K=1,LP1
      DO 5212 I=MYIS,MYIE
      SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
5212   CONTINUE
!---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1)
      DO 5314 I=MYIS,MYIE
      DO 5314 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),13)
        DSORC(I,K)=DSRCE(IXO(I,K),13)
5314   CONTINUE
      DO 5312 K=1,LP1
      DO 5312 I=MYIS,MYIE
      SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
5312   CONTINUE
!---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1)
      DO 5414 I=MYIS,MYIE
      DO 5414 K=1,LP1
        VTMP3(I,K)=SOURCE(IXO(I,K),14)
        DSORC(I,K)=DSRCE(IXO(I,K),14)
5414   CONTINUE
      DO 5412 K=1,LP1
      DO 5412 I=MYIS,MYIE
      SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
5412   CONTINUE
!
!        THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2
!
!
!     CALL NLTE
!
!
!---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR)
!   AND THE WINDOW REGION (SS1)
      DO 131 K=1,LP1
      DO 131 I=MYIS,MYIE
      SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14)
131   CONTINUE
      DO 143 K=1,LP1
      DO 143 I=MYIS,MYIE
      CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10)
143   CONTINUE
!
!---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES
!   (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA-
!   TIONS.
!
      DO 901 K=1,LP1
      DO 901 I=MYIS,MYIE
      TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K)
901   CONTINUE
      DO 903 K=1,L
      DO 903 I=MYIS,MYIE
      OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13)
      CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K)
      DTC(I,K+1)=TC(I,K+1)-TC(I,K)
      SS2(I,K+1)=SS1(I,K+1)-SS1(I,K)
903   CONTINUE
!
!
!---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO
!    (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS
!    ON THE FOLLOWING PRINCIPLES:
!
!          LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL
!          THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K))
!               OVER ALL KP'S, FROM 1 TO LP1.
!
!          WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS:
!
!          FOR ALL K'S K=1 TO LP1:
!              FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K))  (1)
!                      OVER ALL KP'S, FROM K+1 TO LP1
!          AND
!              FOR KP FROM K+1 TO LP1:
!                 FLUX(KP) = DELTAB(K)*TAU(K,KP)              (2)
!
!          NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS)
!          WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM
!          K+1 TO LP1, EACH TIME K IS INCREMENTED.
!          EQUATIONS (1) AND (2) THEN BECOME:
!
!             TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K)
!             FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP))   (3)
!             FLUX(KP) = DELTAB(K)*TAU1D(KP)                   (4)
!
!         THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR
!         NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND
!         WITH CARE.
!
!      COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR
!      THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO,
!      THE
!      STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI
!---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY
!   AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY
!   MAY BE EXTRACTED HERE.
      DO 3021 K=1,L
      DO 3021 I=MYIS,MYIE
      AVEPHI(I,K)=TOTPHI(I,K+1)
3021  CONTINUE
!---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1)
!   LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES
!   A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE
!   (OTHERWISE VACANT) LP1'TH POSITION
!
      DO 803 I=MYIS,MYIE
      AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
803   CONTINUE
!   COMPUTE FLUXES FOR K=1
      CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, &
                  FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T,         &
!                 T1,T2,T4 ,EM1V,EM1VW,                    &
                  H16E1,TEN,HP1,H28E1,HAF,                 &
                  ids,ide, jds,jde, kds,kde,               &
                  ims,ime, jms,jme, kms,kme,               &
                  its,ite, jts,jte, kts,kte                )

      DO 302 K=1,L
      DO 302 I=MYIS,MYIE
      FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1)
      TO3SPC(I,K)=HAF*(FAC1(I,K)* &
          (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE))
!   FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS
!   CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY.
      TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1)))
      OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ &
                  SKC1R*TOTVO2(I,K+1)))
!---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE
!  2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH
!  OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU
      CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1))
      TOTEVV(I,K)=1./CNTTAU(I,K)
302   CONTINUE
      DO 3022 K=1,L
      DO 3022 I=MYIS,MYIE
      CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1)
3022  CONTINUE
      DO 3023 K=1,L
      DO 3023 I=MYIS,MYIE
      CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K)
3023  CONTINUE
!---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
      DO 1808 I=MYIS,MYIE
      RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1)
1808  CONTINUE
!---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH
!   THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN
!   THE OTHER CALCULATIONS
      DO 305 K=2,LP1
      DO 305 I=MYIS,MYIE
      FLX(I,K)= (TC(I,1)*E1FLX(I,K) &
                +SS1(I,1)*CNTTAU(I,K-1) &
                +SORC(I,1,13)*TO3SP(I,K-1) &
                +CSOUR(I,1)*CO2SP(I,K)) &
                *CLDFAC(I,1,K)
305   CONTINUE
      DO 307 I=MYIS,MYIE
      FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) &
                +CSOUR(I,1)
307   CONTINUE
!---THE KP TERMS FOR K=1...
      DO 303 KP=2,LP1
      DO 303 I=MYIS,MYIE
      FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) &
                        +SS2(I,KP)*CNTTAU(I,KP-1) &
                        +CSS(I,KP)*CO21(I,KP,1) &
                        +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1)
303   CONTINUE
!          SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER
!     CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS.
!
      CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
                 CLDFAC,TEMP,PRESS,VAR1,VAR2, &
                 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
                 CO2SP1,CO2SP2,CO2SP,              &
                 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
                 H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO,    &
!                SKO2D,RADCON,                                 &
                 RADCON,                                 &
                 ids,ide, jds,jde, kds,kde,                    &
                 ims,ime, jms,jme, kms,kme,                    &
                 its,ite, jts,jte, kts,kte                     )

!
!    THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2
!    EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800-
!    990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE
!    CONTAINED IN CTSO3, COMPUTED IN SPA88.
!
      DO 998 I=MYIS,MYIE
      VTMP3(I,1)=1.
998   CONTINUE
      DO 999 K=1,L
      DO 999 I=MYIS,MYIE
      VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1)
999   CONTINUE
      DO 1001 K=1,L
      DO 1001 I=MYIS,MYIE
      CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* &
           (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + &
            SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K)))
1001  CONTINUE
!
      DO 1011 K=1,L
      DO 1011 I=MYIS,MYIE
      VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - &
                        CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K)))
1011  CONTINUE
      DO 1012 I=MYIS,MYIE
      FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* &
                (E1CTS1(I,LP1)-E1CTW1(I,LP1))
1012  CONTINUE
      DO 1014 K=1,L
      DO 1013 I=MYIS,MYIE
      FLX1E1(I)=FLX1E1(I)+VTMP3(I,K)
1013  CONTINUE
1014  CONTINUE
!
!---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1  CASES.
!   CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL
!   EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS.
!
      DO 321 K=2,LM1
      KLEN=K
!
      DO 3218 KK=1,LP1-K
      DO 3218 I=MYIS,MYIE
      AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K)
3218  CONTINUE
      DO 1803 I=MYIS,MYIE
      AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
1803   CONTINUE
!---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT
!   WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL
!   AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS
!   BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE
!    THEIR FLUXES SEPARASTELY.
!
      CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2,  &
!                      T1,T2,T4,                      &
                       H16E1,HP1,H28E1,HAF,TEN,       &
                       ids,ide, jds,jde, kds,kde,     &
                       ims,ime, jms,jme, kms,kme,     &
                       its,ite, jts,jte, kts,kte      )

      DO 322 KK=1,LP1-K
      DO 322 I=MYIS,MYIE
      AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K)
      AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K)
      AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K)
      CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1)
322   CONTINUE
!
      DO 3221 KK=1,LP1-K
      DO 3221 I=MYIS,MYIE
      FAC1(I,K+KK-1)=BO3RND(2)*AVPHO3(I,K+KK-1)/AVMO3(I,K+KK-1)
      VTMP3(I,K+KK-1)=HAF*(FAC1(I,K+KK-1)* &
        (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,K+KK-1))/ &
         FAC1(I,K+KK-1))-ONE))
      TO31D(I,K+KK-1)=EXP(HM1EZ*(VTMP3(I,K+KK-1) &
                         +SKO3R*AVVO2(I,K+KK-1)))
      OVER1D(I,K+KK-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,K+KK-1))+ &
                  SKC1R*AVVO2(I,K+KK-1)))
      CO21(I,K+KK,K)=OVER1D(I,K+KK-1)*CO21(I,K+KK,K)
3221  CONTINUE
      DO 3223 KP=K+1,LP1
      DO 3223 I=MYIS,MYIE
      CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP)
3223  CONTINUE
!---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
      DO 1804 I=MYIS,MYIE
      RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K)
1804  CONTINUE
!---THE KP TERMS FOR ARBIRRARY K..
      DO 3423 KP=K+1,LP1
      DO 3423 I=MYIS,MYIE
      FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) &
                        +SS2(I,KP)*CONT1D(I,KP-1) &
                        +CSS(I,KP)*CO21(I,KP,K) &
                        +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K)
3423  CONTINUE
      DO 3425 KP=K+1,LP1
      DO 3425 I=MYIS,MYIE
      FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) &
                         +SS2(I,K)*CONT1D(I,KP-1) &
                         +CSS(I,K)*CO21(I,K,KP) &
                         +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP)
3425  CONTINUE
321   CONTINUE
!
      DO 821 I=MYIS,MYIE
      TPL(I,1)=TEMP(I,L)
      TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L))
      TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L))
821   CONTINUE
      DO 823 K=2,L
      DO 823 I=MYIS,MYIE
      TPL(I,K)=T(I,K)
      TPL(I,K+L)=T(I,K)
823   CONTINUE
!
!---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES,
!   DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1)
      DO 833 I=MYIS,MYIE
      AVEPHI(I,1)=VAR2(I,L)
      AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L)
833   CONTINUE
      CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP,                          &
!                     T1,T2,T4, &
                      H16E1,TEN,H28E1,HP1,                          &
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
                      its,ite, jts,jte, kts,kte                     )

!
!     CALL E3V88 FOR NBL H2O TRANSMISSIVITIES
!          CALL E3V88(EMD,TPL,EMPL,EM3V, &
           CALL E3V88(EMD,TPL,EMPL, &
                      TEN,HP1,H28E1,H16E1,  &
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
                      its,ite, jts,jte, kts,kte                     )
!
!   COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS
!    USING METHODS FOR H2O GIVEN IN REF. (4)
      DO 851 K=2,L
      DO 851 I=MYIS,MYIE
      EMISDG(I,K)=EMD(I,K+L)+EMD(I,K)
851   CONTINUE
!
!   NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN
!   LWR88
      DO 861 I=MYIS,MYIE
      EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ &
       EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2))
      EMISDG(I,LP1)=TWO*EMD(I,LP1)
      EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ &
       EMX2(I)
861   CONTINUE
      DO 331 I=MYIS,MYIE
      FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L)
      VTMP3(I,L)=HAF*(FAC1(I,L)* &
          (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE))
      TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L)))
      OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ &
                  SKC1R*CNTVAL(I,L)))
      CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1)
      RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L)
331   CONTINUE
      DO 618 K=1,L
      DO 618 I=MYIS,MYIE
      RLOG(I,K)=LOG(RLOG(I,K))
618   CONTINUE
      DO 601 K=1,LM1
      DO 601 I=MYIS,MYIE
      DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1))
      ALP(I,LP1+K-1)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1)
601   CONTINUE
      DO 603 K=1,L
      DO 603 I=MYIS,MYIE
      DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K))
      ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K)
603   CONTINUE
      DO 625 I=MYIS,MYIE
      ALP(I,LL)=-RLOG(I,L)
      ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1)))
625   CONTINUE
!        THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE
!     FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION.
!
!       PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND
!***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY
!   EVALUATED.
      DO 631 K=1,LLP1
      DO 631 I=MYIS,MYIE
      C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2))
631   CONTINUE
      DO 641 I=MYIS,MYIE
      CO21(I,LP1,LP1)=ONE+C(I,L)
      CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* &
       C(I,LLM1))/(P(I,LP1)-PRESS(I,L))
      CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- &
       (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1))
641   CONTINUE
      DO 643 K=2,L
      DO 643 I=MYIS,MYIE
      CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1))
643   CONTINUE
!
!    COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE
!    ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS
!    USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4).
      DO 651 K=1,LM1
      DO 651 I=MYIS,MYIE
      CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1)
      CSUB(I,LP1+K-1)=CNTVAL(I,K)*DELPR2(I,K+1)
651   CONTINUE
!---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED
      DO 655 K=1,LLM2
      DO 655 I=MYIS,MYIE
      CSUB2(I,K+1)=SKO3R*CSUB(I,K+1)
      C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* &
                (HP166666-CSUB(I,K+1)*H41666M2))
      C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* &
                 (HP166666-CSUB2(I,K+1)*H41666M2))
655   CONTINUE
      DO 661 I=MYIS,MYIE
      CONTDG(I,LP1)=1.+C(I,LLM1)
      TO3DG(I,LP1)=1.+C2(I,LLM1)
661   CONTINUE
      DO 663 K=2,L
      DO 663 I=MYIS,MYIE
      CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K))
      TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K))
663   CONTINUE
!---NOW OBTAIN FLUXES
!
!    FOR THE DIAGONAL TERMS...
      DO 871 K=2,LP1
      DO 871 I=MYIS,MYIE
      FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) &
                       +SS2(I,K)*CONTDG(I,K) &
                       +OSS(I,K)*TO3DG(I,K) &
                       +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K)
871   CONTINUE
!     FOR THE TWO OFF-DIAGONAL TERMS...
      DO 873 I=MYIS,MYIE
      FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) &
                        +DTC(I,LP1)*EMSPEC(I,2) &
                        +OSS(I,LP1)*TO31D(I,L) &
                        +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L)
      FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) &
                            +OSS(I,L)*TO31D(I,L) &
                            +SS2(I,L)*CONT1D(I,L) &
                            +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1)
873   CONTINUE
!
!     FINAL SECTION OBTAINS EMISSIVITY HEATING RATES,
!     TOTAL HEATING RATES AND THE FLUX AT THE GROUND
!
!     .....CALCULATE THE EMISSIVITY HEATING RATES
      DO 1101 K=1,L
      DO 1101 I=MYIS,MYIE
      HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K)
1101  CONTINUE
!     .....CALCULATE THE TOTAL HEATING RATES
      DO 1103 K=1,L
      DO 1103 I=MYIS,MYIE
      HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K)
1103  CONTINUE
!     .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE
!    TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1)
      DO 1111 K=1,L
      DO 1111 I=MYIS,MYIE
      VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1
1111  CONTINUE
      DO 1115 I=MYIS,MYIE
      TOPFLX(I)=FLX1E1(I)+GXCTS(I)
      FLXNET(I,1)=TOPFLX(I)
1115  CONTINUE
!---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS
!    THE THICK CLOUD SECTION IS INVOKED.
      DO 1123 K=2,LP1
      DO 1123 I=MYIS,MYIE
      FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1)
1123  CONTINUE
      DO 1125 I=MYIS,MYIE
      GRNFLX(I)=FLXNET(I,LP1)
1125  CONTINUE
!
!     THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD
!     FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT,
!     FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED.
!***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE
!   ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS.
      ICNT=0
      DO 1301 I=MYIS,MYIE
      ICNT=ICNT+NCLDS(I)
1301  CONTINUE
      IF (ICNT.EQ.0) GO TO 6999
!---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW
      KCLDS=NCLDS(MYIS)
      DO 2106 I=MYIS,MYIE
      KCLDS=MAX(NCLDS(I),KCLDS)
2106  CONTINUE
!
!
!***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF
!   THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE
!   BEEN DEFINED!).
      DO 1361 KK=1,KCLDS
      KMIN=LP1
      KMAX=0
      DO 1362 I=MYIS,MYIE
        J1=KTOP(I,KK+1)
!       IF (J1.EQ.1) GO TO 1362
        J3=KBTM(I,KK+1)
        IF (J3.GT.J1) THEN
          PTOP(I)=P(I,J1)
          PBOT(I)=P(I,J3+1)
          FTOP(I)=FLXNET(I,J1)
          FBOT(I)=FLXNET(I,J3+1)
!***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC)
          DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I))
          KMIN=MIN(KMIN,J1)
          KMAX=MAX(KMAX,J3)
        ENDIF
1362  CONTINUE
      KMIN=KMIN+1
!***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR
!   ALL LEVELS.
      DO 1365 K=KMIN,KMAX
      DO 1363 I=MYIS,MYIE
!       IF (KTOP(I,KK+1).EQ.1) GO TO 1363
        IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN
          Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I)
!ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) +
!ORIGINAL1            Z1(I,K)*CAMT(I,KK+1)
          FLXNET(I,K)=Z1(I,K)
        ENDIF
1363  CONTINUE
1365  CONTINUE
1361  CONTINUE
!***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN
!   THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY
!    THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED.
!     DO 6051 K=1,LP1
!     DO 6051 I=MYIS,MYIE
!     FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) +
!    1            Z1(I,K)*CAMT(I,NC)
!051  CONTINUE
!***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS.
!     DO 1401 K=1,LP1
!     DO 1401 I=MYIS,MYIE
!     IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I)
!    1  .AND.  (NC-1).LE.NCLDS(I))  THEN
!          FLXNET(I,K)=FLXTHK(I,K)
!     ENDIF
!401  CONTINUE
!
!******END OF CLOUD LOOP*****
6001  CONTINUE
6999  CONTINUE
!***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE
!   REVISED FLUXES:
      DO 6101 K=1,L
      DO 6101 I=MYIS,MYIE
      HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K)
6101  CONTINUE
!     THE THICK CLOUD SECTION ENDS HERE.

  END SUBROUTINE FST88

!----------------------------------------------------------------------


  SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2,      & 2
                       AVEPHI,TEMP,T,                                &
!                      T1,T2,T4,EM1V,EM1VW,                          &
                       H16E1,TEN,HP1,H28E1,HAF,                      &
                       ids,ide, jds,jde, kds,kde,                    &
                       ims,ime, jms,jme, kms,kme,                    &
                       its,ite, jts,jte, kts,kte                     )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte
      REAL,INTENT(IN) :: H16E1,TEN,HP1,H28E1,HAF

      REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS
      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: FXOE1,DTE1,FXOE2,DTE2
      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,TEMP,T
      REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte)   :: G2,G5
!     REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4 ,EM1V,EM1VW

      REAL,DIMENSION(its:ite,kts:kte+1) :: TMP3,DU,FYO,WW1,WW2
      INTEGER,DIMENSION(its:ite,kts:kte*3+2)   :: IT1
      INTEGER,DIMENSION(its:ite,kts:kte+1) :: IVAL

!     REAL,DIMENSION(28,180):: EM1,EM1WDE,TABLE1,TABLE2, &
!                              TABLE3
!     EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
!     EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
!      (T4(1),TABLE3(1,1))

      INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
      LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
      LLM2 = LL-2; LLM1=LL-1
      MYIS=its; MYIE=ite

!---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
!   (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
!   THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN
!   OBTAINED IN FST88, FOR CONVENIENCE.
!
!---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY--
!
!---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS
!   THE SPECIAL CASE FOR THE LP1TH LAYER.

      DO 1322 K=1,LP1
      DO 1322 I=MYIS,MYIE
      TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
      FYO(I,K)=AINT(TMP3(I,K)*TEN)
      DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
      FYO(I,K)=H28E1*FYO(I,K)
      IVAL(I,K)=FYO(I,K)+FXOE2(I,K)
      EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
                              +DTE2(I,K)*T4(IVAL(I,K))
1322  CONTINUE
!
!---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
!   BY AVERAGING THE VALUES FOR L AND LP1:
      DO 1344 I=MYIS,MYIE
      EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
1344  CONTINUE
!
!   CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS
!   THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE
!   TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING
!   TO THE FLUXES AT OTHER LEVELS.
!
!***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY
!    DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE
!    SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE
!    BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED
!    IN THE E2 CALCS.,WITH K=1).
!
!
!   FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE
!   USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT
!    THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE
!   INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED.
      DO 208 I=MYIS,MYIE
      IT1(I,1)=FXOE1(I,1)
      WW1(I,1)=TEN-DTE1(I,1)
      WW2(I,1)=HP1
208   CONTINUE
      DO 209 K=1,L
      DO 209 I=MYIS,MYIE
      IT1(I,K+1)=FYO(I,K)+FXOE1(I,K+1)
      IT1(I,LP2+K-1)=FYO(I,K)+FXOE1(I,K)
      WW1(I,K+1)=TEN-DTE1(I,K+1)
      WW2(I,K+1)=HP1-DU(I,K)
209   CONTINUE
      DO 211 KP=1,L
      DO 211 I=MYIS,MYIE
      IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1)
211   CONTINUE
!
!
!  G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG)
      DO 230 I=MYIS,MYIE
      G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ &
              WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1)
      G3(I,1)=G1(I,1)
230   CONTINUE
      DO 240 K=1,L
      DO 240 I=MYIS,MYIE
      G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ &
              WW2(I,K+1)*DTE1(I,K+1)*EM1V(IT1(I,K+1)+1)+ &
              WW1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+28)+ &
              DTE1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+29)
      G2(I,K)=WW1(I,K)*WW2(I,K+1)*EM1V(IT1(I,K+LP2-1))+ &
              WW2(I,K+1)*DTE1(I,K)*EM1V(IT1(I,K+LP2-1)+1)+ &
              WW1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+28)+ &
              DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29)
240   CONTINUE
      DO 241 KP=2,LP1
      DO 241 I=MYIS,MYIE
      G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ &
              WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ &
              WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ &
              DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29)
241   CONTINUE
!
      DO 244 I=MYIS,MYIE
      G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ &
              WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1)
244   CONTINUE
      DO 242 K=1,L
      DO 242 I=MYIS,MYIE
      G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ &
              WW2(I,K+1)*DTE1(I,K+1)*EM1VW(IT1(I,K+1)+1)+ &
              WW1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+28)+ &
              DTE1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+29)
      G5(I,K)=WW1(I,K)*WW2(I,K+1)*EM1VW(IT1(I,K+LP2-1))+ &
              WW2(I,K+1)*DTE1(I,K)*EM1VW(IT1(I,K+LP2-1)+1)+ &
              WW1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+28)+ &
              DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29)
242   CONTINUE
!
  END SUBROUTINE E1E290

!----------------------------------------------------------------------


 SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR,                      & 2
                       CLDFAC,TEMP,PRESS,VAR1,VAR2,                  &
                       P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC,             &
                       CO2SP1,CO2SP2,CO2SP,                          &
                       APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
                       H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO,    &
!                      SKO2D,RADCON,                                 &
                       RADCON,                                 &
                       ids,ide, jds,jde, kds,kde,                    &
                       ims,ime, jms,jme, kms,kme,                    &
                       its,ite, jts,jte, kts,kte                     )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
!     INTEGER, PARAMETER :: NBLY=15
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte

      REAL,INTENT(IN) :: H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
                         RADCON
!                        SKO2D,RADCON

      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: CSOUR
      REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte)  :: CTSO3
      REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte)  :: EXCTS
      REAL,INTENT(OUT),DIMENSION(its:ite)          :: GXCTS
      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
      REAL,INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP

      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: VAR1,VAR2 
      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: P
      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte)   :: DELP,DELP2,TO3SPC
      REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) ::TOTVO2,TO3SP,CO2SP1,&
                                                     CO2SP2,CO2SP
      REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
                                         BCOMB,BETACM

      REAL,DIMENSION(its:ite,kts:kte+1) ::CTMP,CTMP2,CTMP3
      REAL,DIMENSION(its:ite,kts:kte)   ::X,Y,FAC1,FAC2,F,FF,AG,AGG, &
                                          PHITMP,PSITMP,TOPM,TOPPHI,TT

      INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
      LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
      LLM2 = LL-2; LLM1=LL-1
      MYIS=its; MYIE=ite

!--!COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM

      DO 101 K=1,L
      DO 101 I=MYIS,MYIE
      X(I,K)=TEMP(I,K)-H25E2
      Y(I,K)=X(I,K)*X(I,K)
101   CONTINUE
!---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE
!   TRANSMISSION FCTNS AT THE TOP.
      DO 345 I=MYIS,MYIE
      CTMP(I,1)=ONE
      CTMP2(I,1)=1.
      CTMP3(I,1)=1.
345   CONTINUE
!***BEGIN LOOP ON FREQUENCY BANDS (1)***
!
!---CALCULATION FOR BAND 1 (COMBINED BAND 1)
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 301 K=1,L
      DO 301 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
301   CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 315 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
315   CONTINUE
      DO 319 K=2,L
      DO 317 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
317   CONTINUE
319   CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 321 K=1,L
      DO 321 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(1)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
321   CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 353 K=1,L
      DO 353 I=MYIS,MYIE
      EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K))
353   CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 361 I=MYIS,MYIE
      GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,1)-SORC(I,L,1)))
361   CONTINUE
!
!
!-----CALCULATION FOR BAND 2 (COMBINED BAND 2)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 401 K=1,L
      DO 401 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
401   CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 415 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
415   CONTINUE
      DO 419 K=2,L
      DO 417 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
417   CONTINUE
419   CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 421 K=1,L
      DO 421 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(2)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
421   CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 453 K=1,L
      DO 453 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* & 
                   (CTMP(I,K+1)-CTMP(I,K))
453   CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 461 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,2)-SORC(I,L,2)))
461   CONTINUE
!
!-----CALCULATION FOR BAND 3 (COMBINED BAND 3)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 501 K=1,L
      DO 501 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
501   CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 515 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
515   CONTINUE
      DO 519 K=2,L
      DO 517 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
517   CONTINUE
519   CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 521 K=1,L
      DO 521 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(3)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
521   CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 553 K=1,L
      DO 553 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* &
                   (CTMP(I,K+1)-CTMP(I,K))
553   CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 561 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,3)-SORC(I,L,3)))
561   CONTINUE
!
!-----CALCULATION FOR BAND 4 (COMBINED BAND 4)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 601 K=1,L
      DO 601 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
601   CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 615 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
615   CONTINUE
      DO 619 K=2,L
      DO 617 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
617   CONTINUE
619   CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 621 K=1,L
      DO 621 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(4)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
621   CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 653 K=1,L
      DO 653 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* &
                   (CTMP(I,K+1)-CTMP(I,K))
653   CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 661 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,4)-SORC(I,L,4)))
661   CONTINUE
!
!-----CALCULATION FOR BAND 5 (COMBINED BAND 5)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 701 K=1,L
      DO 701 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
701   CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 715 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
715   CONTINUE
      DO 719 K=2,L
      DO 717 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
717   CONTINUE
719   CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 721 K=1,L
      DO 721 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(5)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(5)*TOTVO2(I,K+1)*SKO2D))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
721   CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 753 K=1,L
      DO 753 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* &
                   (CTMP(I,K+1)-CTMP(I,K))
753   CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 761 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,5)-SORC(I,L,5)))
761   CONTINUE
!
!-----CALCULATION FOR BAND 6 (COMBINED BAND 6)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 801 K=1,L
      DO 801 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
801   CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 815 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
815   CONTINUE
      DO 819 K=2,L
      DO 817 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
817   CONTINUE
819   CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 821 K=1,L
      DO 821 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(6)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(6)*TOTVO2(I,K+1)*SKO2D))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
821   CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 853 K=1,L
      DO 853 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* &
                   (CTMP(I,K+1)-CTMP(I,K))
853   CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 861 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,6)-SORC(I,L,6)))
861   CONTINUE
!
!-----CALCULATION FOR BAND 7 (COMBINED BAND 7)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 901 K=1,L
      DO 901 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
901   CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 915 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
915   CONTINUE
      DO 919 K=2,L
      DO 917 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
917   CONTINUE
919   CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 921 K=1,L
      DO 921 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(7)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(7)*TOTVO2(I,K+1)*SKO2D))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
921   CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 953 K=1,L
      DO 953 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)* &
                   (CTMP(I,K+1)-CTMP(I,K))
953   CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 961 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,7)-SORC(I,L,7)))
961   CONTINUE
!
!-----CALCULATION FOR BAND 8 (COMBINED BAND 8)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 1001 K=1,L
      DO 1001 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1001  CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 1015 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
1015  CONTINUE
      DO 1019 K=2,L
      DO 1017 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1017  CONTINUE
1019  CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 1021 K=1,L
      DO 1021 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(8)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(8)*TOTVO2(I,K+1)*SKO2D))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1021  CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 1053 K=1,L
      DO 1053 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* &
                   (CTMP(I,K+1)-CTMP(I,K))
1053  CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 1061 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,8)-SORC(I,L,8)))
1061  CONTINUE
!
!-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 1101 K=1,L
      DO 1101 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1101  CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 1115 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
1115  CONTINUE
      DO 1119 K=2,L
      DO 1117 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1117  CONTINUE
1119  CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 1121 K=1,L
      DO 1121 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(9)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1)
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1121  CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 1153 K=1,L
      DO 1153 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* &
                   (CTMP(I,K+1)-CTMP(I,K))
1153  CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 1161 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,9)-SORC(I,L,9)))
1161  CONTINUE
!
!-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 1201 K=1,L
      DO 1201 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1201  CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 1215 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
1215  CONTINUE
      DO 1219 K=2,L
      DO 1217 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1217  CONTINUE
1219  CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 1221 K=1,L
      DO 1221 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(10)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1)
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1221  CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 1253 K=1,L
      DO 1253 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* &
                   (CTMP(I,K+1)-CTMP(I,K))
1253  CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 1261 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,10)-SORC(I,L,10)))
1261  CONTINUE
!
!-----CALCULATION FOR BAND 11 (800-900 CM-1)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 1301 K=1,L
      DO 1301 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1301  CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 1315 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
1315  CONTINUE
      DO 1319 K=2,L
      DO 1317 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1317  CONTINUE
1319  CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 1321 K=1,L
      DO 1321 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(11)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(11)*TOTVO2(I,K+1)*SKO2D))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1321  CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 1353 K=1,L
      DO 1353 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* &
                   (CTMP(I,K+1)-CTMP(I,K))
1353  CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 1361 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,11)-SORC(I,L,11)))
1361  CONTINUE
!
!-----CALCULATION FOR BAND 12 (900-990 CM-1)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 1401 K=1,L
      DO 1401 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1401  CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 1415 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
1415  CONTINUE
      DO 1419 K=2,L
      DO 1417 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1417  CONTINUE
1419  CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 1421 K=1,L
      DO 1421 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(12)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(12)*TOTVO2(I,K+1)*SKO2D))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1421  CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 1453 K=1,L
      DO 1453 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* &
                   (CTMP(I,K+1)-CTMP(I,K))
1453  CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 1461 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,12)-SORC(I,L,12)))
1461  CONTINUE
!
!-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3))
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 1501 K=1,L
      DO 1501 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1501  CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 1515 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
1515  CONTINUE
      DO 1519 K=2,L
      DO 1517 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1517  CONTINUE
1519  CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 1521 K=1,L
      DO 1521 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(13)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K)))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1521  CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 1553 K=1,L
      DO 1553 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* &
                   (CTMP(I,K+1)-CTMP(I,K))
1553  CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 1561 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,13)-SORC(I,L,13)))
1561  CONTINUE
!
!-----CALCULATION FOR BAND 14 (1070-1200 CM-1)
!
!
!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
!   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
!   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
      DO 1601 K=1,L
      DO 1601 I=MYIS,MYIE
      F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K))
      FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K))
      AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
      AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
      PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
      PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1601  CONTINUE
!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
!   P(K) (TOPM,TOPPHI)
      DO 1615 I=MYIS,MYIE
      TOPM(I,1)=PHITMP(I,1)
      TOPPHI(I,1)=PSITMP(I,1)
1615  CONTINUE
      DO 1619 K=2,L
      DO 1617 I=MYIS,MYIE
      TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
      TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1617  CONTINUE
1619  CONTINUE
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
      DO 1621 K=1,L
      DO 1621 I=MYIS,MYIE
      FAC1(I,K)=ACOMB(14)*TOPM(I,K)
      FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K))
      TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
                 BETACM(14)*TOTVO2(I,K+1)*SKO2D))
      CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1621  CONTINUE
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
      DO 1653 K=1,L
      DO 1653 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* &
                   (CTMP(I,K+1)-CTMP(I,K))
1653  CONTINUE
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
      DO 1661 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ &
         (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
         TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
         (SORC(I,LP1,14)-SORC(I,L,14)))
1661  CONTINUE
!
!
!   OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND
!   USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE
!   THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT
!   BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS
!   REDUCING COMPUTATIONS!
      DO 1731 K=1,L
      DO 1731 I=MYIS,MYIE
      GXCTS(I)=GXCTS(I)-EXCTS(I,K)
1731  CONTINUE
!
!   NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE
!   FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON)
      DO 1741 K=1,L
      DO 1741 I=MYIS,MYIE
      EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K)
1741  CONTINUE
!---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT
!   EXCTS HAS ITS APPROPRIATE VALUE.
!
!*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
!     (CTSO3)
      DO 1711 K=1,L
      DO 1711 I=MYIS,MYIE
      CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1)
      CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1)
1711  CONTINUE
      DO 1701 K=1,L
      DO 1701 I=MYIS,MYIE
      CTSO3(I,K)=RADCON*DELP(I,K)* &
           (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + &
            SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)))
1701  CONTINUE

 END SUBROUTINE SPA88
!----------------------------------------------------------------------


 SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, & 2
!                      T1,T2,T4,                                     &
                       H16E1,HP1,H28E1,HAF,TEN,                      &
                       ids,ide, jds,jde, kds,kde,                    &
                       ims,ime, jms,jme, kms,kme,                    &
                       its,ite, jts,jte, kts,kte                     )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte
      INTEGER, INTENT(IN)        :: KLEN
      REAL, INTENT(IN) :: H16E1,HP1,H28E1,HAF ,TEN
      REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: EMISSB
      REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,FXOE2,DTE2

!     REAL, INTENT(IN ), DIMENSION(5040) :: T1,T2,T4

      REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1) :: EMISS

      REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,DT,FYO,DU
      INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL

!     REAL,    DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
!     EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
!                 (T4(1),TABLE3(1,1))
!     EQUIVALENCE (TMP3,DT)

      INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
      LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
      LLM2 = LL-2; LLM1=LL-1
      MYIS=its; MYIE=ite


!---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
!   (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
!   THUS GENERATES THE E2 FUNCTION.
!
!---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL
!   CASE: RESULTS ARE IN EMISS



      DO 132 K=1,LP2-KLEN
      DO 132 I=MYIS,MYIE
      TMP3(I,K)=LOG10(AVEPHI(I,KLEN+K-1))+H16E1
      FYO(I,K)=AINT(TMP3(I,K)*TEN)
      DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
      FYO(I,K)=H28E1*FYO(I,K)
      IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN+K-1)
      EMISS(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) & 
                                 +DTE2(I,KLEN+K-1)*T4(IVAL(I,K))
132   CONTINUE
!---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
!   BY AVERAGING THE VALUES FOR L AND LP1:
      DO 1344 I=MYIS,MYIE
      EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
1344  CONTINUE
!---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT.
!
!---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB.
!  IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING
!  FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH
!  THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT
!  INVOLVED HERE.
!     (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN
!   EMISSB(I,(KLEN) TO L)
      DO 142 K=1,LP1-KLEN
      DO 142 I=MYIS,MYIE
      DT(I,K)=DTE2(I,KLEN-1)
      IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1)
142   CONTINUE
!
      DO 234 K=1,LP1-KLEN
      DO 234 I=MYIS,MYIE
      EMISSB(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
                                      +DT(I,K)*T4(IVAL(I,K))
234   CONTINUE

 END SUBROUTINE E290

!---------------------------------------------------------------------


  SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP,                         & 2
!                      T1,T2,T4,                                     &
                       H16E1,TEN,H28E1,HP1,                          &
                       ids,ide, jds,jde, kds,kde,                    &
                       ims,ime, jms,jme, kms,kme,                    &
                       its,ite, jts,jte, kts,kte                     )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte
      REAL,INTENT(IN ) :: H16E1,TEN,H28E1,HP1  
      REAL,INTENT(INOUT),DIMENSION(its:ite,kts:kte+1) :: EMISS
      REAL,INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI
      REAL,INTENT(IN ),DIMENSION(its:ite,2) :: FXOSP,DTSP

!     REAL, INTENT(IN ),DIMENSION(5040) :: T1,T2,T4

!     REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
!     EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
!                 (T4(1),TABLE3(1,1))

      INTEGER :: K,I,MYIS,MYIE

      REAL,    DIMENSION(its:ite,kts:kte+1) :: TMP3,FYO,DU
      INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL

      MYIS=its
      MYIE=ite

      DO 132 K=1,2
      DO 132 I=MYIS,MYIE
      TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
      FYO(I,K)=AINT(TMP3(I,K)*TEN)
      DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
      IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K)
      EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ &
                               DTSP(I,K)*T4(IVAL(I,K))
132   CONTINUE

  END SUBROUTINE E2SPEC

!---------------------------------------------------------------------

! SUBROUTINE E3V88(EMV,TV,AV,EM3V,            &

  SUBROUTINE E3V88(EMV,TV,AV, & 2
                       TEN,HP1,H28E1,H16E1,  &
                       ids,ide, jds,jde, kds,kde,                    &
                       ims,ime, jms,jme, kms,kme,                    &
                       its,ite, jts,jte, kts,kte                     )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte
      REAL,    INTENT(IN)  :: TEN,HP1,H28E1,H16E1 
!-----------------------------------------------------------------------
      REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV
      REAL, INTENT(IN),  DIMENSION(its:ite,kts:kte*2+1) :: TV,AV
!     REAL, INTENT(IN),  DIMENSION(5040) :: EM3V

      REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,&
                                            FYO
!     REAL, DIMENSION(5040) :: EM3V

!     EQUIVALENCE (EM3V(1),EM3(1,1))

      INTEGER,DIMENSION(its:ite,kts:kte*2+1) ::IT

      INTEGER :: LLP1,I,K,MYIS,MYIE ,L
      L = kte
      LLP1 = 2*L + 1
      MYIS=its; MYIE=ite

!---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND
!   K (1-LLP1)

      DO 203 K=1,LLP1
      DO 203 I=MYIS,MYIE
        FXO(I,K)=AINT(TV(I,K)*HP1)
        TMP3(I,K)=LOG10(AV(I,K))+H16E1
        DT(I,K)=TV(I,K)-TEN*FXO(I,K)
        FYO(I,K)=AINT(TMP3(I,K)*TEN)
        DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
!---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE
!   DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K.
        IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1
        WW1(I,K)=TEN-DT(I,K)
        WW2(I,K)=HP1-DU(I,K)
        EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ &
                 WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ & 
                 WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ & 
                 DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20)
203   CONTINUE

  END SUBROUTINE E3V88
!-----------------------------------------------------------------------


  SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,             & 2
                       DFSWL,                                         &
                       PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3,     &
                       NCLDS,KTOPSW,KBTMSW,CAMT,CRR,CTT,              &
                       ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND,   &
!                      UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2,                &
                       ABCFF,PWTS,                                    &
                       H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,     &
                       HP816,RRAYAV,GINV,CFCO2,CFO3,                  &
                       TWO,H235M3,HP26,H129M2,H75826M4,H1036E2,       &
                       H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,    &
                       H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON,    &
                       ids,ide, jds,jde, kds,kde,                     &
                       ims,ime, jms,jme, kms,kme,                     &
                       its,ite, jts,jte, kts,kte                      )
!----------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte
      REAL,INTENT(IN) :: RRCO2,SSOLAR
      REAL,INTENT(IN) :: H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,HP816,RRAYAV,&
                         GINV,CFCO2,CFO3
      REAL,INTENT(IN) :: TWO,H235M3,HP26,H129M2,H75826M4,H1036E2  
      REAL,INTENT(IN) :: H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,H323M4,HM1EZ
      REAL,INTENT(IN) :: DIFFCTR,O3DIFCTR,FIFTY,RADCON
!----------------------------------------------------------------------
      INTEGER, PARAMETER :: NB=12
      REAL,    INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: PRESS,CAMT
      REAL,    INTENT(IN ),DIMENSION(its:ite,kts:kte) :: RH2O,QO3
      REAL,    INTENT(IN ),DIMENSION(its:ite) :: COSZRO,TAUDAR,ALVB,ALVD,ALNB,ALND
      INTEGER, INTENT(IN ),DIMENSION(its:ite) :: NCLDS
      INTEGER, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) ::KTOPSW,KBTMSW
      REAL, INTENT(IN ),DIMENSION(its:ite,NB,kts:kte+1) ::CRR,CTT
           
      REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) ::     &
                                       FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL
      REAL, INTENT(OUT),DIMENSION(its:ite) :: GDFVB,GDFVD,GDFNB,GDFND
      REAL, INTENT(IN), DIMENSION(NB) :: ABCFF,PWTS

!     REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
!     REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1)   :: TUCO2,TUO3,TDO3,TDCO2

      REAL, DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
      REAL, DIMENSION(its:ite,kts:kte+1)   :: TUCO2,TUO3,TDO3,TDCO2

      REAL, DIMENSION(its:ite,kts:kte*2+2) :: TCO2,TO3
      REAL, DIMENSION(its:ite,kts:kte+1) :: PP,DP,PR2,DU,DUCO2,DUO3,UD,TTD
      REAL, DIMENSION(its:ite,kts:kte+1) :: UDCO2,UDO3,UR,URCO2,URO3,TTU
      REAL, DIMENSION(its:ite,kts:kte+1) :: DFN,UFN
      REAL, DIMENSION(its:ite,kts:kte+1) :: XAMT,FF,FFCO2,FFO3,CR,CT
      REAL, DIMENSION(its:ite,kts:kte+1) :: PPTOP,DPCLD,TTDB1,TTUB1
      REAL, DIMENSION(its:ite,kts:kte+1) :: TDCL1,TUCL1,TDCL2,DFNTRN,  &
                                            UFNTRN,TCLU,TCLD,ALFA,ALFAU, &
                                            UFNCLU,DFNCLU

      REAL, DIMENSION(its:ite,NB) :: DFNTOP
      REAL, DIMENSION(its:ite) :: SECZ,TMP1,RRAY,REFL,REFL2,CCMAX

!                    EQUIVALENCE &
!       (UDO3,UO3(its,1),DFNCLU), (URO3,UO3(its,kte+2), UFNCLU) &
!     , (UDCO2,UCO2(its,1),TCLD), (URCO2,UCO2(its,kte+2), TCLU) &
!     , (TDO3 ,TO3(its,1),DFNTRN),(TUO3,TO3(its,kte+2), UFNTRN) &
!     , (TDCO2,TCO2(its,1)      ),(TUCO2,TCO2(its,kte+2)        ) &
!     , (FF   , ALFA ),   (FFCO2 , ALFAU ),   (FFO3  , TTDB1 ) &
!     , (DU   , TTUB1),   (DUCO2 , TUCL1 ),   (DUO3  , TDCL1 ) &
!     , (PR2  , TDCL2)

!                    EQUIVALENCE &
!       (UDO3,DFNCLU), (URO3,UFNCLU) &
!     , (UDCO2,TCLD ), (URCO2,TCLU) &
!     , (TDO3 ,DFNTRN),(TUO3,UFNTRN) &
!!    , (TDCO2,TCO2(its,1)      ),(TUCO2,TCO2(its,kte+2)        ) &
!     , (FF   , ALFA ),   (FFCO2 , ALFAU ),   (FFO3  , TTDB1 ) &
!     , (DU   , TTUB1),   (DUCO2 , TUCL1 ),   (DUO3  , TDCL1 ) &
!     , (PR2  , TDCL2)

      INTEGER :: K,I,KP,N,IP,MYIS1,KCLDS,NNCLDS,JTOP,KK,J2,J3,J1
      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
      REAL    :: DENOM,HTEMP,TEMPF,TEMPG

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
      LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
      MYIS=its; MYIE=ite
      MYIS1=MYIS+1    ! ??

      DO 100 I=MYIS,MYIE
        SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE)
        PP(I,1)   = ZERO
        PP(I,LP1) = PRESS(I,LP1)
        TMP1(I)  = ONE/PRESS(I,LP1)
100   CONTINUE
      DO 110 K=1,LM1
      DO 110 I=MYIS,MYIE
        PP(I,K+1) = HAF*(PRESS(I,K+1)+PRESS(I,K))
110   CONTINUE
      DO 120 K=1,L
      DO 120 I=MYIS,MYIE
        DP (I,K) = PP(I,K+1)-PP(I,K)
        PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1))
120   CONTINUE
      DO 130 K=1,L
      DO 130 I=MYIS,MYIE
        PR2(I,K) = PR2(I,K)*TMP1(I)
130   CONTINUE
!     CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS)
      DO 140 N=1,NB
      DO 140 IP=MYIS,MYIE
        DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N)
140   CONTINUE
!     EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION
!     FOR THE VISIBLE BAND
      DO 150 I=MYIS,MYIE
        RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
        REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ &
                  (ONE-ALVD(I)*RRAYAV)
150   CONTINUE
      DO 155 I=MYIS,MYIE
        RRAY(I) = 0.104/(ONE+4.8*COSZRO(I))
        REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ &
                  (ONE-ALVD(I)*0.093)
155   CONTINUE
!     CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER
!     IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2.
!     DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3.
      DO 160 K=1,L
      DO 160 I=MYIS,MYIE
        DU   (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K)
        DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K)
        DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K)
160   CONTINUE
!
!                 CALCULATE CLEAR SKY SW FLUX
!
!     OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE
!     FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD
!     PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING
!     QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3.
      DO 200 IP=MYIS,MYIE
        UD   (IP,1) = ZERO
        UDCO2(IP,1) = ZERO
        UDO3 (IP,1) = ZERO
! SH
        UO3  (IP,1) = UDO3 (IP,1)
        UCO2 (IP,1) = UDCO2(IP,1)

200   CONTINUE
      DO 210 K=2,LP1
      DO 210 I=MYIS,MYIE
        UD   (I,K) = UD   (I,K-1)+DU   (I,K-1)*SECZ(I)
        UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I)
        UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I)
! SH
        UO3  (I,K) = UDO3 (I,K)
        UCO2 (I,K) = UDCO2(I,K)

210   CONTINUE
      DO 220 IP=MYIS,MYIE
        UR   (IP,LP1) = UD   (IP,LP1)
        URCO2(IP,LP1) = UDCO2(IP,LP1)
        URO3 (IP,LP1) = UDO3 (IP,LP1)
! SH
        UO3  (IP,LP1+LP1) = URO3 (IP,LP1) 
        UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)

220   CONTINUE
      DO 230 K=L,1,-1
      DO 230 IP=MYIS,MYIE
        UR   (IP,K) = UR   (IP,K+1)+DU   (IP,K)*DIFFCTR
        URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
        URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
! SH
        UO3 (IP,LP1+K) = URO3 (IP,K)
        UCO2(IP,LP1+K) = URCO2(IP,K)

230   CONTINUE
!     CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED
!     BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED
!     BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX,
!     AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT
!     OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2.
!       SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE
!     VALUES ACTUALLY STORED IN TCO2.
      DO 240 K=1,LL
      DO 240 I=MYIS,MYIE
       TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
                             -H75826M4)
240   CONTINUE

! SH
      DO 241 K=1,L
      DO 241 I=MYIS,MYIE
        TDCO2(I,K+1)=TCO2(I,K+1)
241   CONTINUE
      DO 242 K=1,L
      DO 242 I=MYIS,MYIE
        TUCO2(I,K)=TCO2(I,LP1+K)
242   CONTINUE

!     NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN
!     THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS
!     50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED
!     BY 2. THE TRANSMISSIONS ARE STORED IN TO3.
      HTEMP = H1036E2*H1036E2*H1036E2
      DO 250 K=1,LL
      DO 250 I=MYIS,MYIE
        TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
                  (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
                  H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
                  H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
250   CONTINUE

! SH
      DO 251 K=1,L
      DO 251 I=MYIS,MYIE
        TDO3(I,K+1)=TO3(I,K+1)
251   CONTINUE
      DO 252 K=1,L
      DO 252 I=MYIS,MYIE
        TUO3(I,K)=TO3(I,LP1+K)
252   CONTINUE


!   START FREQUENCY LOOP (ON N) HERE
!
!--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION
      DO 260 K=1,L
      DO 260 I=MYIS,MYIE
        TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
        TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
        DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1)
        UFN(I,K) = TTU(I,K)*TUO3(I,K)
260   CONTINUE
      DO 270 I=MYIS,MYIE
        DFN(I,1)   = ONE
        UFN(I,LP1) = DFN(I,LP1)
270   CONTINUE
!     SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE
!     ATMOSPHERE (DFNTOP(I,1))
!     DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS
      DO 280  K=1,LP1
      DO 280  I=MYIS,MYIE
        DFSWL(I,K) =         DFN(I,K)*DFNTOP(I,1)
        UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1)
280   CONTINUE
      DO 285 I=MYIS,MYIE
        GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I))
        GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - &
                    (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I))
        GDFNB(I) = ZERO
        GDFND(I) = ZERO
285   CONTINUE
!---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
!   AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
!   TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS
!   RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
      DO 350 N=2,NB
        IF (N.EQ.2) THEN
!   THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
!   THAT OF BAND 1 (SAVED AS TTD,TTU)
!--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION
          DO 290 K=1,L
          DO 290 I=MYIS,MYIE
            DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1)
            UFN(I,K) = TTU(I,K)*TUCO2(I,K)
290       CONTINUE
        ELSE
!   CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED
!   BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH
!   IS THE SAME FOR ALL INFRARED BANDS.
          DO 300 K=1,L
          DO 300 I=MYIS,MYIE
            DFN(I,K+1)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) &
                       *TDCO2(I,K+1)
            UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) &
                     *TUCO2(I,K)
300       CONTINUE
        ENDIF
!---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR
!   ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS.
        DO 310 I=MYIS,MYIE
          DFN(I,1)   = ONE
          UFN(I,LP1) = DFN(I,LP1)
310     CONTINUE
!     SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP
!     AND SUM OVER BANDS
        DO 320 K=1,LP1
        DO 320 I=MYIS,MYIE
          DFSWL(I,K) = DFSWL(I,K) +         DFN(I,K)*DFNTOP(I,N)
          UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N)
320     CONTINUE
        DO 330 I=MYIS,MYIE
          GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N)
330     CONTINUE
350   CONTINUE
      DO 360 K=1,LP1
      DO 360 I=MYIS,MYIE
        FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K)
360   CONTINUE
      DO 370 K=1,L
      DO 370 I=MYIS,MYIE
        HSWL(I,K)=RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K)
370   CONTINUE
!
!---END OF FREQUENCY LOOP (OVER N)
!
!                 CALCULATE CLOUDY SKY SW FLUX
!
      KCLDS=NCLDS(MYIS)
      DO 400 I=MYIS1,MYIE
        KCLDS=MAX(NCLDS(I),KCLDS)
400   CONTINUE
        DO 410 K=1,LP1
        DO 410 I=MYIS,MYIE
          DFSWC(I,K) = DFSWL(I,K)
          UFSWC(I,K) = UFSWL(I,K)
          FSWC (I,K) = FSWL (I,K)
410     CONTINUE
        DO 420 K=1,L
        DO 420 I=MYIS,MYIE
          HSWC(I,K) = HSWL(I,K)
420     CONTINUE
!*******************************************************************
      IF (KCLDS .EQ. 0)  RETURN
!*******************************************************************
      DO 430 K=1,LP1
      DO 430 I=MYIS,MYIE
        XAMT(I,K) = CAMT(I,K)
430   CONTINUE
      DO 470 I=MYIS,MYIE
        NNCLDS   = NCLDS(I)
        CCMAX(I) = ZERO
        IF (NNCLDS .LE. 0) GO TO 470
        CCMAX(I) = ONE
        DO 450 K=1,NNCLDS
          CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1))
450     CONTINUE
        CCMAX(I) = ONE - CCMAX(I)
        IF (CCMAX(I) .GT. ZERO) THEN
          DO 460 K=1,NNCLDS
            XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I)
460       CONTINUE
        END IF
470   CONTINUE
      DO 480 K=1,LP1
      DO 480 I=MYIS,MYIE
        FF   (I,K) = DIFFCTR
        FFCO2(I,K) = DIFFCTR
        FFO3 (I,K) = O3DIFCTR
480   CONTINUE
      DO 490 IP=MYIS,MYIE
        JTOP = KTOPSW(IP,NCLDS(IP)+1)
      DO 490 K=1,JTOP
        FF   (IP,K) = SECZ(IP)
        FFCO2(IP,K) = SECZ(IP)
        FFO3 (IP,K) = SECZ(IP)
490   CONTINUE
      DO 500 I=MYIS,MYIE
        RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
        REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ &
                  (ONE-ALVD(I)*RRAYAV)
500   CONTINUE
      DO 510 IP=MYIS,MYIE
        UD   (IP,1) = ZERO
        UDCO2(IP,1) = ZERO
        UDO3 (IP,1) = ZERO
! SH
        UO3  (IP,1) = UDO3 (IP,1)
        UCO2 (IP,1) = UDCO2(IP,1)

510   CONTINUE
      DO 520 K=2,LP1
      DO 520 I=MYIS,MYIE
        UD   (I,K) = UD   (I,K-1)+DU   (I,K-1)*FF   (I,K)
        UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K)
        UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K)
! SH
        UO3 (I,K)  = UDO3 (I,K)
        UCO2(I,K)  = UDCO2(I,K)

520   CONTINUE
      DO 530 IP=MYIS,MYIE
        UR   (IP,LP1) = UD   (IP,LP1)
        URCO2(IP,LP1) = UDCO2(IP,LP1)
        URO3 (IP,LP1) = UDO3 (IP,LP1)
! SH
        UO3  (IP,LP1+LP1) = URO3 (IP,LP1)
        UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)

530   CONTINUE
      DO 540 K=L,1,-1
      DO 540 IP=MYIS,MYIE
        UR   (IP,K) = UR   (IP,K+1)+DU   (IP,K)*DIFFCTR
        URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
        URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
! SH
        UO3 (IP,LP1+K) = URO3 (IP,K)
        UCO2(IP,LP1+K) = URCO2(IP,K)

540   CONTINUE
      DO 550 K=1,LL
      DO 550 I=MYIS,MYIE
        TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
                              -H75826M4)
550   CONTINUE
! SH
      DO 551 K=1,L
      DO 551 I=MYIS,MYIE
        TDCO2(I,K+1)=TCO2(I,K+1)
551   CONTINUE
      DO 552 K=1,L
      DO 552 I=MYIS,MYIE
        TUCO2(I,K)=TCO2(I,LP1+K)
552   CONTINUE

      DO 560 K=1,LL
      DO 560 I=MYIS,MYIE
        TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
                 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
                H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
                H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
560   CONTINUE
! SH
      DO 561 K=1,L
      DO 561 I=MYIS,MYIE
        TDO3(I,K+1)=TO3(I,K+1)
561   CONTINUE
      DO 562 K=1,L
      DO 562 I=MYIS,MYIE
        TUO3(I,K)=TO3(I,LP1+K)
562   CONTINUE

!********************************************************************
!---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN
!   BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!).
!********************************************************************
      DO 570 I=MYIS,MYIE
        CR(I,1) = REFL(I)
570   CONTINUE
!***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR
!   REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND
!---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES
!   EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE).
      DO 581 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 581
      DO 580 KK=2,KCLDS+1
        CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK)
        CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK)
580   CONTINUE
581   CONTINUE
!---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF
!   "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED
!   LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL
!   FREQUENCY BANDS.
      DO 591 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 591
      DO 590 KK=1,KCLDS
        IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN
           PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1))
           DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1)))
        ENDIF
590   CONTINUE
591   CONTINUE
      DO 600 K=1,L
      DO 600 I=MYIS,MYIE
        TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
        TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
        TTD  (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1)
        TTU  (I,K) = TTUB1(I,K)*TUO3(I,K)
600   CONTINUE
      DO 610 I=MYIS,MYIE
        TTD(I,1)   = ONE
        TTU(I,LP1) = TTD(I,LP1)
610   CONTINUE
!***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
!   TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
!   EACH BAND N. THE REQUIRED QUANTITIES ARE:
!      TTD(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
!      TTU(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
!      TTD(I,KBTMSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
!      AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE
!      STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY,
!      AS THEY HAVE MULTIPLE USE IN THE PGM.
!---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
      DO 620 I=MYIS,MYIE
        TDCL1 (I,1) = TTD(I,LP1)
        TUCL1 (I,1) = TTU(I,LP1)
        TDCL2 (I,1) = TDCL1(I,1)
        DFNTRN(I,1) = ONE/TDCL1(I,1)
        UFNTRN(I,1) = DFNTRN(I,1)
620   CONTINUE
      DO 631 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 631
      DO 630 KK=2,KCLDS+1
        TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
        TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
        TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
630   CONTINUE
631   CONTINUE
!---COMPUTE INVERSES
      DO 641 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 641
! SH
      DO 640 KK=2,KCLDS+1
        DFNTRN(I,KK) = ONE/TDCL1(I,KK)
        UFNTRN(I,KK) = ONE/TUCL1(I,KK)
640   CONTINUE
641   CONTINUE
!---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE
!   TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS
!   QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY
!   FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH
!   ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K).
      DO 651 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 651
      DO 650 KK=1,KCLDS
        TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
        TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
650   CONTINUE
651   CONTINUE
!***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
!   COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
!   FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
!   THE CLOUD IN QUESTION.
!---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION
      DO 660 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 660
        ALFA (I,1)=CR(I,1)
        ALFAU(I,1)=ZERO
660   CONTINUE
!---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
      DO 671 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 671
      DO 670 KK=2,KCLDS+1
        ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ &
              (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
        ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK)
670   CONTINUE
671   CONTINUE
!     CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
!---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
!   OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
!   AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST
!   CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
!   HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
!   EQUALS ALFA. THIS IS ALSO CORRECT.
      DO 680 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 680
        UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
        DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
680   CONTINUE
!---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED
!  ABOVE
      DO 691 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 691
      DO 690 KK=KCLDS,1,-1
        UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* &
                       TCLU(I,KK))
        DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK)
690   CONTINUE
691   CONTINUE
      DO 701 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 701
      DO 700 KK=1,KCLDS+1
        UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
        DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
700   CONTINUE
701   CONTINUE
!---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD)
      DO 720 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 720
        J2=KBTMSW(I,2)
        DO 710 K=J2,LP1
          UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
          DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
710     CONTINUE
720   CONTINUE
!---REMAINING LEVELS (IF ANY!)
      DO 760 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 760
      DO 755 KK=2,KCLDS+1
        J1=KTOPSW(I,KK)
        J2=KBTMSW(I,KK+1)
        IF (J1.EQ.1) GO TO 755
        DO 730 K=J2,J1
          UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
          DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
730     CONTINUE
!---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD
!   LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY
!   TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX).
        J3=KBTMSW(I,KK)
        IF ((J3-J1).GT.1) THEN
          TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
          TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
          DO 740 K=J1+1,J3-1
            UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
            DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
740       CONTINUE
        ENDIF
755   CONTINUE
760   CONTINUE
      DO 770 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 770
      DO 771 K=1,LP1
        DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1)
        UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1)
771   CONTINUE
770   CONTINUE
      DO 780 I=MYIS,MYIE
      KCLDS=NCLDS(I)
      IF(KCLDS.EQ.0) GO TO 780
        TMP1(I) = ONE - CCMAX(I)
        GDFVB(I) = TMP1(I)*GDFVB(I)
        GDFNB(I) = TMP1(I)*GDFNB(I)
        GDFVD(I) = TMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1)
780   CONTINUE
!---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
!   AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
!   TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS
!   RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
!
      DO 1000 N=2,NB
!YH93
        DO 791 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 791
        DO 790 K=1,KCLDS+1
          CR(I,K) = CRR(I,N,K)*XAMT(I,K)
          CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K)
790     CONTINUE
791     CONTINUE
!YH93
        IF (N.EQ.2) THEN
!   THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
!   THAT OF BAND 1 (SAVED AS TTDB1,TTUB1)
          DO 800 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 800
        DO 801 KK=2,LP1
            TTD(I,KK) = TTDB1(I,KK)*TDCO2(I,KK)
801     CONTINUE
        DO 802 KK=1,L
            TTU(I,KK) = TTUB1(I,KK)*TUCO2(I,KK)
802     CONTINUE
800       CONTINUE
        ELSE
          DO 810 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 810
        DO 811 KK=2,LP1
            TTD(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,KK))) &
                     * TDCO2(I,KK)
811     CONTINUE
        DO 812 KK=1,L
            TTU(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,KK))) &
                     * TUCO2(I,KK)
812     CONTINUE
810       CONTINUE
        ENDIF
!---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR
!   ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS.
        DO 820 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 820
          TTU(I,LP1) = TTD(I,LP1)
          TTD(I,1)   = ONE
820     CONTINUE
!***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
!   TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
!   EACH BAND N. THE REQUIRED QUANTITIES ARE:
!      TTD(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
!      TTD(I,KBTMSW(I,K),N)  K RUNS FROM 2 TO NCLDS(I)+1:
!      TTU(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
!      AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED
!      IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS
!      THEY HAVE MULTIPLE USE IN THE PGM.
!---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
        DO 830 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 830
          TDCL1 (I,1) = TTD(I,LP1)
          TUCL1 (I,1) = TTU(I,LP1)
          TDCL2 (I,1) = TDCL1(I,1)
          DFNTRN(I,1) = ONE/TDCL1(I,1)
          UFNTRN(I,1) = DFNTRN(I,1)
830     CONTINUE
        DO 841 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 841
        DO 840 KK=2,KCLDS+1
          TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
          TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
          TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
840     CONTINUE
841     CONTINUE
        DO 851 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 851
        DO 850 KK=2,KCLDS+1
          DFNTRN(I,KK) = ONE/TDCL1(I,KK)
          UFNTRN(I,KK) = ONE/TUCL1(I,KK)
850     CONTINUE
851     CONTINUE
        DO 861 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 861
        DO 860 KK=1,KCLDS
          TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
          TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
860     CONTINUE
861     CONTINUE
!***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
!   COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
!   FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
!   THE CLOUD IN QUESTION.
        DO 870 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 870
          ALFA (I,1) = CR(I,1)
          ALFAU(I,1) = ZERO
870     CONTINUE
!---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
        DO 881 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 881
        DO 880 KK=2,KCLDS+1
          ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - &
                   TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
          ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK)
880     CONTINUE
881     CONTINUE
!     CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
!---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
!   OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
!   AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST
!   CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
!   HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
!   EQUALS ALFA. THIS IS ALSO CORRECT.
        DO 890 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 890
          UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
          DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
890     CONTINUE
        DO 901 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 901
        DO 900 KK=KCLDS,1,-1
!
!***  ACCOUNT FOR UNREALISTICALLY SMALL CLOUD AMOUNT
!
        DENOM=ALFA(I,KK+1)*TCLU(I,KK)
        IF(DENOM.GT.RTHRESH)THEN
          UFNCLU(I,KK)=UFNCLU(I,KK+1)*ALFAU(I,KK+1)/DENOM
        ELSE
          UFNCLU(I,KK)=0.
        ENDIF
        IF(ALFA(I,KK).GT.RTHRESH)THEN
          DFNCLU(I,KK)=UFNCLU(I,KK)/ALFA(I,KK)
        ELSE
          DFNCLU(I,KK)=0.
        ENDIF
900     CONTINUE
901     CONTINUE
!     NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS
        DO 911 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 911
        DO 910 KK=1,KCLDS+1
          UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
          DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
910     CONTINUE
911     CONTINUE
        DO 930 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 930
          J2=KBTMSW(I,2)
          DO 920 K=J2,LP1
            UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
            DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
920       CONTINUE
930     CONTINUE
        DO 970  I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 970
        DO 965  KK=2,KCLDS+1
          J1 = KTOPSW(I,KK)
          J2 = KBTMSW(I,KK+1)
          IF (J1.EQ.1) GO TO 965
          DO 940 K=J2,J1
            UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
            DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
940       CONTINUE
          J3 = KBTMSW(I,KK)
          IF ((J3-J1).GT.1) THEN
            TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
            TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
            DO 950 K=J1+1,J3-1
              UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
              DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
950         CONTINUE
          ENDIF
965     CONTINUE
970     CONTINUE
        DO 980 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 980
        DO 981 K=1,LP1
          DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N)
          UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N)
981     CONTINUE
980     CONTINUE
        DO 990 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 990
          GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N)
990     CONTINUE
1000  CONTINUE
      DO 1100 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 1100
      DO 1101 K=1,LP1
        DFSWC(I,K) = TMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K)
        UFSWC(I,K) = TMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K)
1101  CONTINUE
1100  CONTINUE
      DO 1200 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 1200
        DO 1201 KK=1,LP1
        FSWC(I,KK) = UFSWC(I,KK)-DFSWC(I,KK)
1201    CONTINUE
1200  CONTINUE
      DO 1250 I=MYIS,MYIE
        KCLDS=NCLDS(I)
        IF(KCLDS.EQ.0) GO TO 1250
        DO 1251 KK=1, L
        HSWC(I,KK) = RADCON*(FSWC(I,KK+1)-FSWC(I,KK))/DP(I,KK)
1251    CONTINUE
1250  CONTINUE

  END SUBROUTINE SWR93
!-----------------------------------------------------------------------


  SUBROUTINE RADFS &  2,8

!     *****************************************************************
!     *                                                               *
!     *   THE INTERNAL DRIVE FOR GFDL RADIATION                       *
!     *   THIS SUBROUTINE WAS FROM Y.H AND K.A.C (1993)               *
!     *   AND MODIFIED BY Q. ZHAO FOR USE IN THE ETA MODEL            *
!     *                   NOV. 18,  1993                              *
!     *                                                               *
!     * UPDATE: THIS SUBROUTINE WAS MODIFIED TO USE CLOUD FRACTION    *
!     *         ON EACH MODEL LAYER.                                  *
!     *                                QINGYUN  ZHAO   95-3-22        *
!     *****************************************************************
!***
!***  REQUIRED INPUT:
!***
                (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
      ,          CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL &
      ,          COSZRO,TAUDAR,IBEG &
      ,          KO3,KALB &
      ,          ITIMSW,ITIMLW &
!***************************************************************************
!*              IX IS THE LENGTH OF A ROW IN THE DOMAIN
!
!*   QS(IX):		THE SURFACE PRESSURE (PA)
!*   PP(IX,L):		THE MIDLAYER PRESSURES (PA)  (L IS THE VERT. DIMEN.)
!*   PPI(IX,LP1)	THE INTERFACE PRESSURES (PA)
!*   QQH2O(IX,L):	THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG)
!*   TT(IX,L):		THE MIDLAYER TEMPERATURE (K)
!*   O3QO3(IX,L):	THE MIDLAYER OZONE MIXING RATIO
!*   TSFC(IX):		THE SKIN TEMP. (K); NEGATIVE OVER WATER
!*   SLMSK(IX):		THE SEA MASK (LAND=0,SEA=1)
!*   ALBEDO(IX):	THE SURFACE ALBEDO (EXPRESSED AS A FRACTION)
!*   XLAT(IX):		THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES
!*				(N.H.> 0)
!* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
!*                      LAYER=1:SURFACE
!*                      LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON
!*   CAMT(IX,LP1):      CLOUD FRACTION OF EACH CLOUD LAYER
!*   ITYP(IX,LP1):      CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE)
!*   KTOP(IX,LP1):      HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL)
!*   KBTM(IX,LP1):      BOTTOM OF EACH CLOUD LAYER
!*   NCLDS(IX):         NUMBER OF CLOUD LAYERS
!*   EMCLD(IX,LP1):     CLOUD EMISSIVITY
!*   RRCL(IX,NB,LP1)    CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS
!*   TTCL(IX,NB,LP1)    CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS
!* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
!*
!*   COSZRO(IX):	THE COSINE OF THE SOLAR ZENITH ANGLE
!*   TAUDAR:		=1.0
!*   IBEG:		=1
!*   KO3:		=1 ( READ IN THE QZONE DATA)
!*   KALB:		=0
!*   ITIMSW:		=1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED)
!*   ITIMLW:		=1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED)
!************************************************************************
!***
!*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL
!***
      ,          SWH,HLW &
      ,          FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC  &
      ,          ids,ide, jds,jde, kds,kde                      &
      ,          ims,ime, jms,jme, kms,kme                      &
! begin debugging radiation
      ,          its,ite, jts,jte, kts,kte                      &
      ,          imd,jmd, Jndx                                  )
! end debugging radiation
!************************************************************************
!*    SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S.
!*         SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM).
!*    HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S.
!*         HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM).
!*  FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
!*         FLWUP IS A REAL ARRAY DIMENSIONED (NCOL).
!*  FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
!*         FSWUP IS A REAL ARRAY DIMENSIONED (NCOL).
!*  FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
!*         FSWDN IS A REAL ARRAY DIMENSIONED (NCOL).
!* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
!*         FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
!* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
!*         FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
!* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
!*         FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
!* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
!*         FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
!* FSWDNSC: CLEAR-SKY DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
!*         FSWDNSC IS A REAL ARRAY DIMENSIONED (NCOL).
!************************************************************************
!***
!*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL
!***
!----------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
!INTEGER, PARAMETER :: NBLY=15
 INTEGER, PARAMETER :: NB=12
 INTEGER, PARAMETER :: NBLX=47
 INTEGER , PARAMETER:: NBLW = 163

 REAL,PARAMETER ::      AMOLWT=28.9644
 REAL,PARAMETER ::      CSUBP=1.00484E7
 REAL,PARAMETER ::      DIFFCTR=1.66
 REAL,PARAMETER ::      G=980.665
 REAL,PARAMETER ::      GINV=1./G
 REAL,PARAMETER ::      GRAVDR=980.0
 REAL,PARAMETER ::      O3DIFCTR=1.90
 REAL,PARAMETER ::      P0=1013250.
 REAL,PARAMETER ::      P0INV=1./P0
 REAL,PARAMETER ::      GP0INV=GINV*P0INV
 REAL,PARAMETER ::      P0XZP2=202649.902
 REAL,PARAMETER ::      P0XZP8=810600.098
 REAL,PARAMETER ::      P0X2=2.*1013250.
 REAL,PARAMETER ::      RADCON=8.427
 REAL,PARAMETER ::      RADCON1=1./8.427
 REAL,PARAMETER ::      RATCO2MW=1.519449738
 REAL,PARAMETER ::      RATH2OMW=.622
 REAL,PARAMETER ::      RGAS=8.3142E7
 REAL,PARAMETER ::      RGASSP=8.31432E7
 REAL,PARAMETER ::      SECPDA=8.64E4
!
!******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
!        ARRANGED IN DECREASING ORDER
 REAL,PARAMETER ::      HUNDRED=100.
 REAL,PARAMETER ::      HNINETY=90.
 REAL,PARAMETER ::      HNINE=9.0
 REAL,PARAMETER ::      SIXTY=60.
 REAL,PARAMETER ::      FIFTY=50.
 REAL,PARAMETER ::      TEN=10.
 REAL,PARAMETER ::      EIGHT=8.
 REAL,PARAMETER ::      FIVE=5.
 REAL,PARAMETER ::      FOUR=4.
 REAL,PARAMETER ::      THREE=3.
 REAL,PARAMETER ::      TWO=2.
 REAL,PARAMETER ::      ONE=1.
 REAL,PARAMETER ::      HAF=0.5
 REAL,PARAMETER ::      QUARTR=0.25
 REAL,PARAMETER ::      ZERO=0.
!
!******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
!       ARRANGED IN DECREASING ORDER
 REAL,PARAMETER ::      H83E26=8.3E26
 REAL,PARAMETER ::      H71E26=7.1E26
 REAL,PARAMETER ::      H1E15=1.E15
 REAL,PARAMETER ::      H1E13=1.E13
 REAL,PARAMETER ::      H1E11=1.E11
 REAL,PARAMETER ::      H1E8=1.E8
 REAL,PARAMETER ::      H2E6=2.0E6
 REAL,PARAMETER ::      H1E6=1.0E6
 REAL,PARAMETER ::      H69766E5=6.97667E5
 REAL,PARAMETER ::      H4E5=4.E5
 REAL,PARAMETER ::      H165E5=1.65E5
 REAL,PARAMETER ::      H5725E4=57250.
 REAL,PARAMETER ::      H488E4=48800.
 REAL,PARAMETER ::      H1E4=1.E4
 REAL,PARAMETER ::      H24E3=2400.
 REAL,PARAMETER ::      H20788E3=2078.8
 REAL,PARAMETER ::      H2075E3=2075.
 REAL,PARAMETER ::      H18E3=1800.
 REAL,PARAMETER ::      H1224E3=1224.
 REAL,PARAMETER ::      H67390E2=673.9057
 REAL,PARAMETER ::      H5E2=500.
 REAL,PARAMETER ::      H3082E2=308.2
 REAL,PARAMETER ::      H3E2=300.
 REAL,PARAMETER ::      H2945E2=294.5
 REAL,PARAMETER ::      H29316E2=293.16
 REAL,PARAMETER ::      H26E2=260.0
 REAL,PARAMETER ::      H25E2=250.
 REAL,PARAMETER ::      H23E2=230.
 REAL,PARAMETER ::      H2E2=200.0
 REAL,PARAMETER ::      H15E2=150.
 REAL,PARAMETER ::      H1386E2=138.6
 REAL,PARAMETER ::      H1036E2=103.6
 REAL,PARAMETER ::      H8121E1=81.21
 REAL,PARAMETER ::      H35E1=35.
 REAL,PARAMETER ::      H3116E1=31.16
 REAL,PARAMETER ::      H28E1=28.
 REAL,PARAMETER ::      H181E1=18.1
 REAL,PARAMETER ::      H18E1=18.
 REAL,PARAMETER ::      H161E1=16.1
 REAL,PARAMETER ::      H16E1=16.
 REAL,PARAMETER ::      H1226E1=12.26
 REAL,PARAMETER ::      H9P94=9.94
 REAL,PARAMETER ::      H6P08108=6.081081081
 REAL,PARAMETER ::      H3P6=3.6
 REAL,PARAMETER ::      H3P5=3.5
 REAL,PARAMETER ::      H2P9=2.9
 REAL,PARAMETER ::      H2P8=2.8
 REAL,PARAMETER ::      H2P5=2.5
 REAL,PARAMETER ::      H1P8=1.8
 REAL,PARAMETER ::      H1P4387=1.4387
 REAL,PARAMETER ::      H1P41819=1.418191
 REAL,PARAMETER ::      H1P4=1.4
 REAL,PARAMETER ::      H1P25892=1.258925411
 REAL,PARAMETER ::      H1P082=1.082
 REAL,PARAMETER ::      HP816=0.816
 REAL,PARAMETER ::      HP805=0.805
 REAL,PARAMETER ::      HP8=0.8
 REAL,PARAMETER ::      HP60241=0.60241
 REAL,PARAMETER ::      HP602409=0.60240964
 REAL,PARAMETER ::      HP6=0.6
 REAL,PARAMETER ::      HP526315=0.52631579
 REAL,PARAMETER ::      HP518=0.518
 REAL,PARAMETER ::      HP5048=0.5048
 REAL,PARAMETER ::      HP3795=0.3795
 REAL,PARAMETER ::      HP369=0.369
 REAL,PARAMETER ::      HP26=0.26
 REAL,PARAMETER ::      HP228=0.228
 REAL,PARAMETER ::      HP219=0.219
 REAL,PARAMETER ::      HP166666=.166666
 REAL,PARAMETER ::      HP144=0.144
 REAL,PARAMETER ::      HP118666=0.118666192
 REAL,PARAMETER ::      HP1=0.1
!        (NEGATIVE EXPONENTIALS BEGIN HERE)
 REAL,PARAMETER ::      H658M2=0.0658
 REAL,PARAMETER ::      H625M2=0.0625
 REAL,PARAMETER ::      H44871M2=4.4871E-2
 REAL,PARAMETER ::      H44194M2=.044194
 REAL,PARAMETER ::      H42M2=0.042
 REAL,PARAMETER ::      H41666M2=0.0416666
 REAL,PARAMETER ::      H28571M2=.02857142857
 REAL,PARAMETER ::      H2118M2=0.02118
 REAL,PARAMETER ::      H129M2=0.0129
 REAL,PARAMETER ::      H1M2=.01
 REAL,PARAMETER ::      H559M3=5.59E-3
 REAL,PARAMETER ::      H3M3=0.003
 REAL,PARAMETER ::      H235M3=2.35E-3
 REAL,PARAMETER ::      H1M3=1.0E-3
 REAL,PARAMETER ::      H987M4=9.87E-4
 REAL,PARAMETER ::      H323M4=0.000323
 REAL,PARAMETER ::      H3M4=0.0003
 REAL,PARAMETER ::      H285M4=2.85E-4
 REAL,PARAMETER ::      H1M4=0.0001
 REAL,PARAMETER ::      H75826M4=7.58265E-4
 REAL,PARAMETER ::      H6938M5=6.938E-5
 REAL,PARAMETER ::      H394M5=3.94E-5
 REAL,PARAMETER ::      H37412M5=3.7412E-5
 REAL,PARAMETER ::      H15M5=1.5E-5
 REAL,PARAMETER ::      H1439M5=1.439E-5
 REAL,PARAMETER ::      H128M5=1.28E-5
 REAL,PARAMETER ::      H102M5=1.02E-5
 REAL,PARAMETER ::      H1M5=1.0E-5
 REAL,PARAMETER ::      H7M6=7.E-6
 REAL,PARAMETER ::      H4999M6=4.999E-6
 REAL,PARAMETER ::      H451M6=4.51E-6
 REAL,PARAMETER ::      H25452M6=2.5452E-6
 REAL,PARAMETER ::      H1M6=1.E-6
 REAL,PARAMETER ::      H391M7=3.91E-7
 REAL,PARAMETER ::      H1174M7=1.174E-7
 REAL,PARAMETER ::      H8725M8=8.725E-8
 REAL,PARAMETER ::      H327M8=3.27E-8
 REAL,PARAMETER ::      H257M8=2.57E-8
 REAL,PARAMETER ::      H1M8=1.0E-8
 REAL,PARAMETER ::      H23M10=2.3E-10
 REAL,PARAMETER ::      H14M10=1.4E-10
 REAL,PARAMETER ::      H11M10=1.1E-10
 REAL,PARAMETER ::      H1M10=1.E-10
 REAL,PARAMETER ::      H83M11=8.3E-11
 REAL,PARAMETER ::      H82M11=8.2E-11
 REAL,PARAMETER ::      H8M11=8.E-11
 REAL,PARAMETER ::      H77M11=7.7E-11
 REAL,PARAMETER ::      H72M11=7.2E-11
 REAL,PARAMETER ::      H53M11=5.3E-11
 REAL,PARAMETER ::      H48M11=4.8E-11
 REAL,PARAMETER ::      H44M11=4.4E-11
 REAL,PARAMETER ::      H42M11=4.2E-11
 REAL,PARAMETER ::      H37M11=3.7E-11
 REAL,PARAMETER ::      H35M11=3.5E-11
 REAL,PARAMETER ::      H32M11=3.2E-11
 REAL,PARAMETER ::      H3M11=3.0E-11
 REAL,PARAMETER ::      H28M11=2.8E-11
 REAL,PARAMETER ::      H24M11=2.4E-11
 REAL,PARAMETER ::      H23M11=2.3E-11
 REAL,PARAMETER ::      H2M11=2.E-11
 REAL,PARAMETER ::      H18M11=1.8E-11
 REAL,PARAMETER ::      H15M11=1.5E-11
 REAL,PARAMETER ::      H14M11=1.4E-11
 REAL,PARAMETER ::      H114M11=1.14E-11
 REAL,PARAMETER ::      H11M11=1.1E-11
 REAL,PARAMETER ::      H1M11=1.E-11
 REAL,PARAMETER ::      H96M12=9.6E-12
 REAL,PARAMETER ::      H93M12=9.3E-12
 REAL,PARAMETER ::      H77M12=7.7E-12
 REAL,PARAMETER ::      H74M12=7.4E-12
 REAL,PARAMETER ::      H65M12=6.5E-12
 REAL,PARAMETER ::      H62M12=6.2E-12
 REAL,PARAMETER ::      H6M12=6.E-12
 REAL,PARAMETER ::      H45M12=4.5E-12
 REAL,PARAMETER ::      H44M12=4.4E-12
 REAL,PARAMETER ::      H4M12=4.E-12
 REAL,PARAMETER ::      H38M12=3.8E-12
 REAL,PARAMETER ::      H37M12=3.7E-12
 REAL,PARAMETER ::      H3M12=3.E-12
 REAL,PARAMETER ::      H29M12=2.9E-12
 REAL,PARAMETER ::      H28M12=2.8E-12
 REAL,PARAMETER ::      H24M12=2.4E-12
 REAL,PARAMETER ::      H21M12=2.1E-12
 REAL,PARAMETER ::      H16M12=1.6E-12
 REAL,PARAMETER ::      H14M12=1.4E-12
 REAL,PARAMETER ::      H12M12=1.2E-12
 REAL,PARAMETER ::      H8M13=8.E-13
 REAL,PARAMETER ::      H46M13=4.6E-13
 REAL,PARAMETER ::      H36M13=3.6E-13
 REAL,PARAMETER ::      H135M13=1.35E-13
 REAL,PARAMETER ::      H12M13=1.2E-13
 REAL,PARAMETER ::      H1M13=1.E-13
 REAL,PARAMETER ::      H3M14=3.E-14
 REAL,PARAMETER ::      H15M14=1.5E-14
 REAL,PARAMETER ::      H14M14=1.4E-14
!
!******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
!          ARRANGED IN DESCENDING ORDER
 REAL,PARAMETER ::      HM2M2=-.02
 REAL,PARAMETER ::      HM6666M2=-.066667
 REAL,PARAMETER ::      HMP5=-0.5
 REAL,PARAMETER ::      HMP575=-0.575
 REAL,PARAMETER ::      HMP66667=-.66667
 REAL,PARAMETER ::      HMP805=-0.805
 REAL,PARAMETER ::      HM1EZ=-1.
 REAL,PARAMETER ::      HM13EZ=-1.3
 REAL,PARAMETER ::      HM19EZ=-1.9
 REAL,PARAMETER ::      HM1E1=-10.
 REAL,PARAMETER ::      HM1597E1=-15.97469413
 REAL,PARAMETER ::      HM161E1=-16.1
 REAL,PARAMETER ::      HM1797E1=-17.97469413
 REAL,PARAMETER ::      HM181E1=-18.1
 REAL,PARAMETER ::      HM8E1=-80.
 REAL,PARAMETER ::      HM1E2=-100.
!
 REAL,PARAMETER ::      H1M16=1.0E-16
 REAL,PARAMETER ::      H1M20=1.E-20
 REAL,PARAMETER ::      Q19001=19.001
 REAL,PARAMETER ::      DAYSEC=1.1574E-5
 REAL,PARAMETER ::      HSIGMA=5.673E-8
 REAL,PARAMETER ::      TWENTY=20.0
 REAL,PARAMETER ::      HP537=0.537
 REAL,PARAMETER ::      HP2=0.2
 REAL,PARAMETER ::      RCO2=3.3E-4
 REAL,PARAMETER ::      H3M6=3.0E-6
 REAL,PARAMETER ::      PI=3.1415927
 REAL,PARAMETER ::      DEGRAD1=180.0/PI
 REAL,PARAMETER ::      H74E1=74.0
 REAL,PARAMETER ::      H15E1=15.0

 REAL, PARAMETER:: B0 = -.51926410E-4
 REAL, PARAMETER:: B1 = -.18113332E-3
 REAL, PARAMETER:: B2 = -.10680132E-5
 REAL, PARAMETER:: B3 = -.67303519E-7
 REAL, PARAMETER:: AWIDE = 0.309801E+01
 REAL, PARAMETER:: BWIDE = 0.495357E-01
 REAL, PARAMETER:: BETAWD = 0.347839E+02
 REAL, PARAMETER:: BETINW = 0.766811E+01


      INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
                                    ims,ime, jms,jme, kms,kme ,      &
                                    its,ite, jts,jte, kts,kte
      INTEGER, INTENT(IN)        :: IBEG,KO3,KALB,ITIMSW,ITIMLW
!----------------------------------------------------------------------
!      ****************************************************************
!      *  GENERALIZED FOR PLUG-COMPATIBILITY -                        *
!      *    ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..*
!......*  EXAMPLE FOR MRF:                                            *
!      *    KO3  =0  AND O3QO3=DUMMY ARRAY.   (GFDL CLIMO O3 USED)    *
!      *    KEMIS=0  AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)*
!      *    KALB =0  AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... *
!      *    KCCO2=0,CO2 OBTAINED FROM BLOCK DATA                      *
!      *         =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET...     *
!      *  UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92      *
!      *    OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE           *
!      *       COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE)   *
!      *       SLMSK = 0.                                             *
!      *    SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH   *
!      *       ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR     *
!      *       COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92      *
!      *       ALBEDO GE .5                                           *
!      *   UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR        *
!      *       CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92       *
!      *       SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 .......      *
!      *  UPDATED FOR USE NEW CLD SCHEME      ......YH  DEC 92        *
!      *    INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT)  *
!      *       OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY)       *
!      *    IEMIS=0  USE THE ORG. CLD EMIS SCHEME                     *
!      *         =1  USE TEMP DEP. CLD EMIS SCHEME                    *
!      *  UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE *
!      *    INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0'  *
!      *                                      ......YH FEB 93         *
!      ****************************************************************
!--------------------------------
!     INTEGER, PARAMETER:: LNGTH=37*kte
!--------------------------------
     
!     REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D

      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O
      REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD
      REAL,    INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT
      REAL,    INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR
      REAL,    INTENT(OUT), DIMENSION(its:ite):: FLWUPS
      INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS
      INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM
      REAL,    INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL
      REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3
!     REAL,  INTENT(IN),  DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
!     REAL,  INTENT(IN),  DIMENSION(5040) :: EM3V

!     REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR

! TABLE ???

      REAL,  DIMENSION(3) :: BO3RND,AO3RND
      REAL,  DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
                                BCOMB,BETACM

      DATA AO3RND / 0.543368E+02,  0.234676E+04,  0.384881E+02/ 
      DATA BO3RND / 0.526064E+01,  0.922424E+01,  0.496515E+01/

      DATA ACOMB  / &
         0.152070E+05,  0.332194E+04,  0.527177E+03,  0.163124E+03, &
         0.268808E+03,  0.534591E+02,  0.268071E+02,  0.123133E+02, &
         0.600199E+01,  0.640803E+00,  0.501549E-01,  0.167961E-01, &
         0.178110E-01,  0.170166E+00,  0.537083E-02/
      DATA BCOMB  / &
         0.152538E+00,  0.118677E+00,  0.103660E+00,  0.100119E+00, &
         0.127518E+00,  0.118409E+00,  0.904061E-01,  0.642011E-01, &
         0.629660E-01,  0.643346E-01,  0.717082E-01,  0.629730E-01, &
         0.875182E-01,  0.857907E-01,  0.214005E+00/
      DATA APCM   / &
        -0.671879E-03,  0.654345E-02,  0.143657E-01,  0.923593E-02, &
         0.117022E-01,  0.159596E-01,  0.181600E-01,  0.145013E-01, &
         0.170062E-01,  0.233303E-01,  0.256735E-01,  0.274745E-01, &
         0.279259E-01,  0.197002E-01,  0.349782E-01/
      DATA BPCM   / &
        -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, &
        -0.361981E-04, -0.145117E-04,  0.198349E-04, -0.486529E-04, &
        -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
        -0.982953E-04, -0.772497E-04, -0.748263E-04/
      DATA ATPCM  / &
        -0.106346E-02,  0.641531E-02,  0.137362E-01,  0.922513E-02, &
         0.136162E-01,  0.169791E-01,  0.206959E-01,  0.166223E-01, &
         0.171776E-01,  0.229724E-01,  0.275530E-01,  0.302731E-01, &
         0.281662E-01,  0.199525E-01,  0.370962E-01/
      DATA BTPCM  / &
        -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, &
        -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, &
        -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
        -0.933645E-04, -0.664045E-04, -0.115290E-03/
      DATA BETACM / &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.188625E+03,  0.144293E+03,  0.174098E+03,  0.909366E+02, &
         0.497489E+02,  0.221212E+02,  0.113124E+02,  0.754174E+01, &
         0.589554E+01,  0.495227E+01,  0.000000E+00/


!        *********************************************
!====>   *   OUTPUT TO CALLING PROGRAM               *
!        *********************************************

       REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW
       REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, &
                           FSWDNS,FLWUP,FLWDNS,FSWDNSC
      
!        *********************************************
!====>   *   POSSIBLE OUTPUT TO CALLING PROGRAM      *
!        *********************************************

      REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR

!        ************************************************************
!====>   *   ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) *
!        ************************************************************

      REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL

!        ******************************************************
!====>   *   ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB *
!        ******************************************************

       REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC
       REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF
       REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA
       REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX
       REAL, DIMENSION(kts:kte+1)::PHALF
!..... ADD PRESSURE INTERFACE

       REAL,    DIMENSION(NB) :: ABCFF,PWTS

       DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., &
                  989.,2706.,39011./
       DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, &
                 .001467,.002342,.001075/

       REAL     :: CFCO2,CFO3,REFLO3,RRAYAV

       DATA CFCO2,CFO3/508.96,466.64/
       DATA REFLO3/1.9/
       DATA RRAYAV/0.144/

!        *********************************************
!====>   *   VECTOR TEMPORARIES FOR CLOUD CALC.      *
!        *********************************************

       REAL,    DIMENSION(its:ite):: TTHAN
       REAL,    DIMENSION(its:ite,kts:kte):: DO3V,DO3VP
       INTEGER, DIMENSION(its:ite):: JJROW

!====>    **************************************************************
!--     SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
!             CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
!         DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
!         COMMON /SAVMEM/ &
!-       ...WINTER....  ...SPRING....  ...SUMMER....  ....FALL.....
!        DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L)

       REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4

!====>    **************************************************************
!
      REAL,   DIMENSION(21,20) :: ALBD
      REAL,   DIMENSION(20)    :: ZA
      REAL,   DIMENSION(21)    :: TRN
      REAL,   DIMENSION(19)    :: DZA

      REAL    :: YEAR,TPI,SSOLAR,DATE,TH2,ZEN,DZEN,ALB1,ALB2
      INTEGER :: IR,IQ,JX
      DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, &
               .70,.75,.80,.85,.90,.95,1.00/

      REAL ::  ALB11(21,7),ALB22(21,7),ALB33(21,6)

      EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), &
                  (ALB33(1,1),ALBD(1,15))
      DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
       .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
       .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
       .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
       .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
       .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
       .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
       .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
       .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
       .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
       .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
       .246,.235,.222,.211,.205,.200/
      DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
       .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
       .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
       .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
       .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
       .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
       .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
       .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
       .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
       .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
       .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
       .058,.055,.054,.053,.052,.052/
      DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
       .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
       .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
       .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
       .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
       .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
       .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
       .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
       .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
       .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/
      DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., &
              50.,40.,30.,20.,10.,0.0/
      DATA DZA/8*2.0,6*4.0,5*10.0/

!    ***********************************************************
!

       REAL,    DIMENSION(its:ite)        :: ALVB,ALNB,ALVD,ALND, &
                                             GDFVB,   &
                                             GDFNB,GDFVD,GDFND,   &
                                             SFCALB

       REAL    :: RRVCO2,RRCO2,TDUM
       REAL    :: ALBD0,ALVD1,ALND1
       INTEGER :: N
!
!***  The following two lines are for debugging.
       integer :: imd,jmd, Jndx
       real :: FSWrat,FSWrat1,FSWDNS1
!***

!====>    BEGIN HERE             .......................
!
!--- SSOLAR IS THE SOLAR CONSTANT SCALED TO A MORE CURRENT VALUE;
!          I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN.
      REAL,PARAMETER :: H196=1.96

      INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
      INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN

      L=kte
      LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
      LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
      LLM2 = LL-2; LLM1=LL-1
      MYIS=its; MYIE=ite

!******ZHAO
!  NOTE: XLAT IS IN DEGREE HERE
!*****ZHAO
!-- Formerly =>  SOLC=2./(R1*R1), SSOLAR=0.98*SOLC
      SSOLAR=H196/(R1*R1)
!*********************************************************
! Special note: The solar constant is reduced extra 3 percent to account
!               for the lack of aerosols in the shortwave radiation
!               parameterization.       Q. Zhao    96-7-23
! ### May also be due not accounting for reduction in solar constant due to
!     absorption by ozone above the top of the model domain (Ferrier, Apr-2005)
!*********************************************************
      SSOLAR=SSOLAR*0.97
!
      DO 40 I=MYIS,MYIE
        IR = I + IBEG - 1
        TH2=HP2*XLAT(IR)
        JJROW(I)=Q19001-TH2
        TTHAN(I)=(19-JJROW(I))-TH2
!.....  NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN
!          CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS
        SFCALB(I) = ALBEDO(IR)
!.....  NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK...
!***ZHAO
!  NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA
!        THE UNIT FOR PRESS IS MICRO BAR 
!        SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL
!***ZHAO
        PRESS(I,LP1)=QS(IR)*10.0
        TEMP(I,LP1)=ABS(TSFC(IR))
        COSZEN(I) = COSZRO(IR)
        TAUDA(I) = TAUDAR(IR)
   40 CONTINUE
!***ZHAO
!.....  ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC
!       ETA MODEL HAS THE SAME STRUCTURE
!***ZHAO
      DO 50 K=1,L
       DO 50 I=MYIS,MYIE
        IR = I + IBEG - 1
!.....  NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK..........
        TEMP(I,K) = TT(IR,K)
        PRESS(I,K) = 10.0 * PP(IR,K)
!.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK
        RH2O(I,K)=QQH2O(IR,K)
        IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6
   50 CONTINUE
!...    *************************
      IF (KO3.EQ.0) GO TO 65
!...    *************************
      DO 60 K=1,L
       DO 60 I=MYIS,MYIE
        QO3(I,K) = O3QO3(I+IBEG-1,K)
   60 CONTINUE
   65 CONTINUE
!...   ************************************
      IF (KALB.GT.0) GO TO 110
!...   ************************************
!..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF
!         1) OPEN SEA POINT (SLMSK=1);2) KALB=0
      IQ=INT(TWENTY*HP537+ONE)
      DO 105 I=MYIS,MYIE
         IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN
           ZEN=DEGRAD1*ACOS(MAX(COSZEN(I),0.0))
           IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE)
           IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) &
              JX=INT(QUARTR*(H74E1-ZEN)+HNINE)
           IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1)
           DZEN=-(ZEN-ZA(JX))/DZA(JX)
           ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX))
           ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX))
           SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ))
         ENDIF
  105 CONTINUE
  110 CONTINUE
!        **********************************
      IF (KO3.GT.0) GO TO 135
!        **********************************
!.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE,
!....   SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
      DO 125 I=MYIS,MYIE

         PHALF(1)=0.
         PHALF(LP1)=PPI(I,kme)
         DO K=1,LM1
            PHALF(K+1)=PP(I,K) !  AETA(K)*PDIF+PT ! BSF index was erroneously L
         ENDDO

         CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
                 ids,ide, jds,jde, kds,kde,            &
                 ims,ime, jms,jme, kms,kme,            &
                 its,ite, jts,jte, kts,kte             )

         DO 130 K=1,L
          DO3V(I,K)  = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) &
                      +RCOS1*DDO3N3(JJROW(I),K) &
                      +RCOS2*DDO3N4(JJROW(I),K)
          DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) &
                     +RCOS1*DDO3N3(JJROW(I)+1,K) &
                     +RCOS2*DDO3N4(JJROW(I)+1,K)
!...   NOW LATITUDINAL INTERPOLATION, AND
!          CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4)
          QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K)))
  130   CONTINUE
  125 CONTINUE
  135 CONTINUE
!.............
      DO 195 I=MYIS,MYIE
!.....     VISIBLE AND NEAR IR DIFFUSE ALBEDO
        ALVD(I) = SFCALB(I)
        ALND(I) = SFCALB(I)
!.....     VISIBLE AND NEAR IR DIRECT BEAM ALBEDO
        ALVB(I) = SFCALB(I)
        ALNB(I) = SFCALB(I)
!
!--- Remove diurnal variation of land surface albedos (Ferrier, 6/28/05)
!--- Turn back on to mimic NAM 8/17/05
!
!.....     VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW
!        ..FUNCTION OF COSINE SOLAR ZENITH ANGLE..
        IF (SLMSK(I+IBEG-1).LT.0.5) THEN
         IF (SFCALB(I).LE.0.5) THEN
          ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI)
          ALBD0 = EXP (ALBD0)
          ALVD1 = (ALVD(I) - 0.054313) / 0.945687
          ALND1 = (ALND(I) - 0.054313) / 0.945687
          ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0
          ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0
 !-- Put in an upper limit on beam albedos
          ALVB(I) = MIN(0.5,ALVB(I))
          ALNB(I) = MIN(0.5,ALNB(I))
         END IF
        END IF
  195 CONTINUE
!.....SURFACE VALUES OF RRCL AND TTCL
      DO 200 N=1,2
        DO 200 I=MYIS,MYIE
      RRCL(I,N,1)=ALVD(I)
      TTCL(I,N,1)=ZERO
  200 CONTINUE
      DO 220 N=3,NB
      DO 220 I=MYIS,MYIE
         RRCL(I,N,1)=ALND(I)
         TTCL(I,N,1)=ZERO
  220 CONTINUE
!...     **************************
!...     *  END OF CLOUD SECTION  *
!...     **************************
!... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2
!   INTO RRCO2,THE MASS MIXING RATIO.
      RRVCO2=RCO2
      RRCO2=RRVCO2*RATCO2MW
  250 IF(ITIMLW .EQ. 0) GO TO 300
!
!             ***********************
!====>        * LONG WAVE RADIATION *
!             ***********************
!
!....     ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS
      DO 240 K=1,LP1
      DO 240 I=MYIS,MYIE
        EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K)
  240 CONTINUE
!....    GET CLD FACTOR FOR LW CALCULATIONS
!....

! shuhua

      CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, &
                 ids,ide, jds,jde, kds,kde,    &
                 ims,ime, jms,jme, kms,kme,    &
                 its,ite, jts,jte, kts,kte     )

! shuhua
!===>        LONG WAVE RADIATION
!     CALL LWR88(HEATRA,GRNFLX,TOPFLX,         &
!                PRESS,TEMP,RH2O,QO3,CLDFAC,   &
!                EQCMT,NCLDS,KTOP,KBTM,        &
!
!!               BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
!                BO3RND,AO3RND, &
!                APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
!                ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
!                GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
!                P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
!                TEN,HP1,FOUR,HM1EZ,SKO3R,                     &
!                AB15WD,SKC1R,RADCON,QUARTR,TWO,               &
!                HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
!                RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
!                ids,ide, jds,jde, kds,kde,                    &
!                ims,ime, jms,jme, kms,kme,                    &
!                its,ite, jts,jte, kts,kte                    )

      CALL LWR88(HEATRA,GRNFLX,TOPFLX,         &
                 PRESS,TEMP,RH2O,QO3,CLDFAC,   &
                 EQCMT,NCLDS,KTOP,KBTM,        &
!
!                BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
                 BO3RND,AO3RND, &
                 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
                 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
                 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
                 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
                 TEN,HP1,FOUR,HM1EZ,                           &
                 RADCON,QUARTR,TWO,                            &
                 HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
                 RADCON1,H16E1, H28E1,H44194M2,H1P41819,       &
                 ids,ide, jds,jde, kds,kde,                    &
                 ims,ime, jms,jme, kms,kme,                    &
                  its,ite, jts,jte, kts,kte                    )

!....
!================================================================================
!--- IMPORTANT!!  Y.-T Hou advised Ferrier, Mitchell, & Ek on 7/28/05 to use 
!    the following algorithm, because the GFDL code calculates NET longwave flux 
!    (GRNFLX, Up - Down) as its fundamental quantity.  
!
!    1.  Calculate upward LW at surface (FLWUPS)
!    2.  Calculate downward LW at surface (FLWDNS) = FLWUPS - .001*GRNFLX
!
!--- Note:  The following fluxes must be multipled by .001 to convert to mks
!       => GRNFLX, or GRound Net FLuX 
!       => TOPFLX, or top of the atmosphere fluxes (FLWUP)
!
!--- IMPORTANT!!  If the surface emissivity (SFCEMS) differs from 1.0, then 
!    uncomment the line below starting with "!BSF"
!================================================================================
      DO 280 I=MYIS,MYIE
        IR = I + IBEG - 1
        FLWUP(IR) = .001*TOPFLX(I)
!        TDUM=TEMP(I,LP1)
!--- Use an average of the skin & lowest model level temperature
        TDUM=.5*(TEMP(I,LP1)+TEMP(I,L))
        FLWUPS(IR)=HSIGMA*TDUM*TDUM*TDUM*TDUM
!BSF        FLWUPS(IR)=SFCEMS*HSIGMA*TDUM*TDUM*TDUM*TDUM
        FLWDNS(IR)=FLWUPS(IR)-.001*GRNFLX(I)
  280 CONTINUE
!....  Average LW heating/cooling rates over the lowest 2 atmospheric layers,
!      which may be necessary for when dealing with thin layers near the surface
      DO I=MYIS,MYIE
         TDUM=.5*(HEATRA(I,L)+HEATRA(I,LM1))
         HEATRA(I,L)=TDUM
         HEATRA(I,LM1)=TDUM
      ENDDO
!....      CONVERT HEATING RATES TO DEG/SEC
      DO 290 K=1,L
        DO 290 I=MYIS,MYIE
          HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC
  290 CONTINUE
  300 CONTINUE
      IF(ITIMSW .EQ. 0) GO TO 350
!SW
      CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, &
                 PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, &
                 NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, &
                 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
!
!                UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2,                &
                 ABCFF,PWTS,                                    &
                 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,     &
                 HP816,RRAYAV,GINV,CFCO2,CFO3,                  &
                 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2,       &
                 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,    &
                 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON,    &
                 ids,ide, jds,jde, kds,kde,                     &
                 ims,ime, jms,jme, kms,kme,                     &
                 its,ite, jts,jte, kts,kte                      )

!SW
!
!.....    GET SW FLUXES IN WATTS/M**2
      DO 320 I=MYIS,MYIE
       IR = I + IBEG - 1
       FSWUP(IR) = UF(I,1) * 1.E-3
       FSWDN(IR) = DF(I,1) * 1.E-3
       FSWUPS(IR) = UF(I,LP1) * 1.E-3
!-- FSWDNS is more accurate using array DF than summing the GDFxx arrays
!C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3
!!       FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3
       FSWDNS(IR) = DF(I,LP1) * 1.E-3
       FSWDNSC(IR) = DFL(I,LP1) * 1.E-3
!...    DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION
!.....     VISIBLE AND NEAR IR DIFFUSE
       GDFVDR(IR) = GDFVD(I) * 1.E-3
       GDFNDR(IR) = GDFND(I) * 1.E-3
!.....     VISIBLE AND NEAR IR DIRECT BEAM
       GDFVBR(IR) = GDFVB(I) * 1.E-3
       GDFNBR(IR) = GDFNB(I) * 1.E-3
  320 CONTINUE
!....      CONVERT HEATING RATES TO DEG/SEC
      DO 330 K=1,L
        DO 330 I=MYIS,MYIE
          SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC
  330 CONTINUE
  350 CONTINUE
! begin debugging radiation

!     if (Jndx .eq. jmd) then
!       FSWDNS1=(GDFVB(imd)+GDFNB(imd)+GDFVD(imd)+GDFND(imd))*.001
!       write(6,"(3a,2i5,7f9.2)") '{rad2 imd,Jndx,'  &
!      ,'GSW=FSWDNS-FSWUPS,RSWIN=FSWDNS,RSWIN_1=FSWDNS1,' &
!      ,'FSWDNS-FSWDNS1,RSWOUT=FSWUPS,RSWINC=FSWDNSC,GLW=FLWDNS = ' &
!      ,imd,Jndx, FSWDNS(imd)-FSWUPS(imd),FSWDNS(imd),FSWDNS1  &
!      ,FSWDNS(imd)-FSWDNS1,FSWUPS(imd),FSWDNSC(imd),FLWDNS(imd)
!       FSWrat=0.
!       if (FSWDNS(imd) .ne. 0.) FSWrat=FSWUPS(imd)/FSWDNS(imd)
!       FSWrat1=0.
!       if (FSWDNS1 .ne. 0.) FSWrat1=FSWUPS(imd)/FSWDNS1
!       write(6,"(2a,10f8.4)") '{rad2a ALBEDO,SFCALB,ALVD,ALND,ALVB,' &
!      ,'ALNB,CZEN,SLMSK,FSWUPS/FSWDNS,FSWUPS/FSWDNS1 = ' &
!      ,ALBEDO(imd),SFCALB(imd),ALVD(imd),ALND(imd),ALVB(imd)  &
!      ,ALNB(imd),COSZEN(imd),SLMSK(imd),FSWrat,FSWrat1
!     endif
! end debugging radiation
      RETURN
 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', &
                 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2)
 
  END SUBROUTINE RADFS 

!-----------------------------------------------------------------------

    SUBROUTINE O3CLIM 2
!                (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL,         &
!                ids,ide, jds,jde, kds,kde,                   &
!                ims,ime, jms,jme, kms,kme,                   &
!                its,ite, jts,jte, kts,kte                    )
!----------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------
!     INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
!                                   ims,ime, jms,jme, kms,kme ,      &
!                                   its,ite, jts,jte, kts,kte

!     ******************************************************************
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .     
! SUBPROGRAM:    O3CLIM      GENERATE SEASONAL OZONE DISTRIBUTION
!   PRGRMMR: GFDL/CAMPANA    ORG: W/NP22     DATE: ??-??-??
!     
! ABSTRACT:
!     O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING
!     81-LAYER DATA FROM GFDL.
!     
! PROGRAM HISTORY LOG:
!   ??-??-??  GFDL/KC    - ORIGINATOR
!   96-07-26  BLACK      - MODIFIED FOR ETA MODEL
!     
! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN
!   INPUT ARGUMENT LIST:
!     NONE     
!  
!   OUTPUT ARGUMENT LIST: 
!     NONE
!     
!   OUTPUT FILES:
!     NONE
!     
!   SUBPROGRAMS CALLED:
!  
!     UNIQUE:
!        NONE
!  
!     LIBRARY:
!        NONE
!  
!   COMMON BLOCKS: SEASO3
!                  O3DATA
!   
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!   MACHINE : IBM SP
!$$$  
!----------------------------------------------------------------------
!      INTEGER   :: NL,NLP1,NLGTH,NKK,NK,NKP
       INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1
!----------------------------------------------------------------------
!     INCLUDE "SEASO3.comm"
!---------------------------------------------------------------------
!     REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
!     REAL, INTENT(OUT), DIMENSION(NL)    :: PRGFDL

!      COMMON /SEASO3/
!      ...WINTER....  ...SPRING....  ...SUMMER....  ....FALL.....
!    & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL)
!
!    &,PRGFDL(NL)
!---------------------------------------------------------------------
       REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) &
              ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16)
!----------------------------------------------------------------------
       REAL    :: AVG,A1,B1,B2
       INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex
!----------------------------------------------------------------------
       REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) &
      ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) &
      ,DDUO3N(19,NL),DUO3N(19,41) &
      ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) &
      ,O3HI(10,25) &
      ,RSTD(81),RBAR(NL),RDATA(81) &
      ,PHALF(NL),P(81),PH(82)
       REAL   :: PXX(81),PYY(82)                       !  fix for nesting
!----------------------------------------------------------------------
!nesting                         EQUIVALENCE &
!nesting     (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
!nesting    ,(PH1(1),PH(1)),(PH2(1),PH(46)) &
!nesting    ,(P1(1),P(1)),(P2(1),P(49))
                           EQUIVALENCE &
       (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
      ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) &               ! fix for nesting
      ,(P1(1),PXX(1)),(P2(1),PXX(49))                   ! fix for nesting
!----------------------------------------------------------------------
!                          EQUIVALENCE &
!      (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) &
!     ,(XRAD2(1),XDO3N2(1,1)) &
!     ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),)
                           EQUIVALENCE &
       (XRAD1(1),O3O3(1,1,1)) &
      ,(XRAD2(1),O3O3(1,1,2)) &
      ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4))
!----------------------------------------------------------------------
!---------------------------------------------------------------------
      DATA PH1/      0.,     &
           0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04,     &
           0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04,     &
           0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04,     &
           0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03,     &
           0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03,     &
           0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03,     &
           0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03,     &
           0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03,     &
           0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02,     &
           0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02,     &
           0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/     
      DATA PH2/     &
           0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02,     &
           0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01,     &
           0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01,     &
           0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01,     &
           0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01,     &
           0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00,     &
           0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00,     &
           0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00,     &
           0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00,     &
           0.1000000E+01/     
      DATA P1/     &
           0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04,     &
           0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04,     &
           0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04,     &
           0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03,     &
           0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03,     &
           0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03,     &
           0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03,     &
           0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03,     &
           0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02,     &
           0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02,     &
           0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02,     &
           0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/     
      DATA P2/     &
           0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01,     &
           0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01,     &
           0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01,     &
           0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01,     &
           0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00,     &
           0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00,     &
           0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00,     &
           0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00,     &
           0.1000000E+01/     
      DATA O3HI1/     &
       .55,.50,.45,.45,.40,.35,.35,.30,.30,.30,     &
       .55,.51,.46,.47,.42,.38,.37,.36,.35,.35,     &
       .55,.53,.48,.49,.44,.42,.41,.40,.38,.38,     &
       .60,.55,.52,.52,.50,.47,.46,.44,.42,.41,     &
       .65,.60,.55,.56,.53,.52,.50,.48,.45,.45,     &
       .75,.65,.60,.60,.55,.55,.55,.50,.48,.47,     &
       .80,.75,.75,.75,.70,.70,.65,.63,.60,.60,     &
       .90,.85,.85,.80,.80,.75,.75,.74,.72,.71,     &
       1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80,        &
       1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
       1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5,     &
       2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7,     &
       2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0,     &
       2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3,     &
       2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6,     &
       3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/     
      DATA O3HI2/     &
       3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8,     &
       3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2,     &
       4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2,     &
       5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7,     &
       6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2,     &
       9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3,     &
       12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
       14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5,  &
       14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/     
      DATA O3LO1/     &
       14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4,  &
       14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4,   &
       11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2,    &
       7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1,     &
       4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9,     &
       1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1,     &
       0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2,     &
       .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9,     &
       .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5,     &
       .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6,     &
       .05,.05,.06,.09,.20,.40,.70,.80,.90,.90,     &
       .05,.05,.06,.08,.10,.13,.20,.25,.30,.40,     &
       .05,.05,.05,.06,.07,.07,.08,.09,.10,.13,     &
       .05,.05,.05,.05,.06,.06,.06,.06,.07,.07,     &
       .05,.05,.05,.05,.05,.05,.05,.06,.06,.06,     &
       .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/     
      DATA O3LO2/     &
       14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9,   &
       13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6,   &
       10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1,    &
       7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8,     &
       3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5,     &
       1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0,     &
       .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1,     &
       .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0,     &
       .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0,     &
       .05,.05,.06,.12,.15,.30,.60,.70,.80,.80,     &
       .04,.05,.06,.08,.09,.15,.30,.40,.40,.40,     &
       .04,.04,.05,.055,.06,.09,.12,.13,.15,.15,    &
       .03,.03,.045,.052,.055,.06,.07,.07,.06,.07,  &
       .03,.03,.04,.051,.052,.052,.06,.06,.05,.05,  &
       .02,.02,.03,.05,.05,.05,.04,.04,.04,.04,     &
       .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/     
      DATA O3LO3/     &
       14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3,    &
       13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8,     &
       10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7,     &
       7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5,     &
       4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4,     &
       1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2,     &
       .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6,     &
       .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3,     &
       .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0,     &
       .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8,     &
       .04,.04,.04,.08,.20,.30,.55,.60,.75,.90,     &
       .04,.04,.04,.05,.06,.10,.12,.15,.20,.25,     &
       .04,.04,.03,.04,.05,.06,.07,.07,.07,.08,     &
       .03,.03,.04,.05,.05,.05,.05,.05,.05,.05,     &
       .03,.03,.03,.04,.04,.04,.05,.05,.04,.04,     &
       .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/      
      DATA O3LO4/     &
       14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6,  &
       12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1,   &
       10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9,    &
       7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6,     &
       4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3,     &
       2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1,     &
       0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0,     &
       .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5,     &
       .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6,     &
       .07,.08,.10,.14,.20,.50,.70,.90,.90,.80,     &
       .05,.06,.08,.12,.14,.20,.35,.40,.60,.50,     &
       .05,.05,.08,.09,.09,.09,.11,.12,.15,.18,     &
       .04,.05,.06,.07,.07,.08,.08,.08,.08,.08,     &
       .04,.04,.05,.07,.07,.07,.07,.07,.06,.05,     &
       .02,.02,.04,.05,.05,.05,.05,.05,.04,.04,     &
       .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/     
!----------------------------------------------------------------------
!***
!***  COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES
!***  WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3
!***  AND PSFC=1013.25 MB    ......K.A.C. DEC94
!***
      DO K=1,NK
!        PH(K)=PH(K)*1013250.
!        P(K)=P(K)*1013250.
        PH(K)=PYY(K)*1013250.         ! fix for nesting
        P(K)=PXX(K)*1013250.          ! fix for nesting
      ENDDO
!
!      PH(NKP)=PH(NKP)*1013250.
      PH(NKP)=PYY(NKP)*1013250.       ! fix for nesting
!
      DO K=1,NL
        PSTD(K)=P(K)
      ENDDO
!
      DO K=1,25
      DO N=1,10
        RO31(N,K)=O3HI(N,K)
        RO32(N,K)=O3HI(N,K)
      ENDDO
      ENDDO
!----------------------------------------------------------------------
      DO 100 NCASE=1,4
!
!***  NCASE=1: SPRING (IN N.H.)
!***  NCASE=2: FALL   (IN N.H.)
!***  NCASE=3: WINTER (IN N.H.)
!***  NCASE=4: SUMMER (IN N.H.)
!
      IPLACE=2
      IF(NCASE.EQ.2)IPLACE=4
      IF(NCASE.EQ.3)IPLACE=1
      IF(NCASE.EQ.4)IPLACE=3
!
      IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN
        DO K=26,41
        DO N=1,10
          RO31(N,K)=O3LO1(N,K-25)
          RO32(N,K)=O3LO2(N,K-25)
        ENDDO
        ENDDO
      ENDIF
!
      IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN
        DO K=26,41
        DO N=1,10
          RO31(N,K)=O3LO3(N,K-25)
          RO32(N,K)=O3LO4(N,K-25)
        ENDDO
        ENDDO
      ENDIF
!
      DO 25 KK=1,NKK
      DO N=1,10
        DUO3N(N,KK)=RO31(11-N,KK)
        DUO3N(N+9,KK)=RO32(N,KK)
      ENDDO
      DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK))
   25 CONTINUE
!
!***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
!
      IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN
        DO 50 KK=1,NKK
        DO N=1,19
          TEMPN(N)=DUO3N(20-N,KK)
        ENDDO
         DO N=1,19
           DUO3N(N,KK)=TEMPN(N)
         ENDDO
   50   CONTINUE
      ENDIF
!
!***  DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE
!***  LEVELS
!
!***  BEGIN LATITUDE (10 DEG) LOOP
!
      DO 75 N=1,19
!
      DO KK=1,NKK
        RSTD(KK)=DUO3N(N,KK)
      ENDDO
!
      NKM=NK-1
      NKMM=NK-3
!***
!***  BESSELS HALF-POINT INTERPOLATION FORMULA
!***
      DO K=4,NKMM,2
        KI=K/2
        RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) &
                                           -RSTD(KI)+RSTD(KI-1))/16.
      ENDDO
!
      RDATA(2)=0.5*(RSTD(2)+RSTD(1))
      RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1))
!
!***  PUT UNCHANGED DATA INTO NEW ARRAY
!
      DO K=1,NK,2
        KQ=(K+1)/2
        RDATA(K)=RSTD(KQ)
      ENDDO
!
      DO KK=1,NL
        DDUO3N(N,KK)=RDATA(KK)*.01
      ENDDO
!
   75 CONTINUE
!
!***  END OF LATITUDE LOOP
!
!----------------------------------------------------------------------
!***
!***  CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
!***  10 DEG VALUES
!***
      DO 90 KK=1,NL
!
      DO N=1,19
        O35DEG(2*N-1,KK)=DDUO3N(N,KK)
      ENDDO
!
      DO N=1,18
        O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK))
      ENDDO
!
   90 CONTINUE
!
      DO JJ=1,37
      DO KEN=1,NL
        O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN)
      ENDDO
      ENDDO
!
  100 CONTINUE
!----------------------------------------------------------------------
!***  END OF LOOP OVER CASES
!----------------------------------------------------------------------
!***
!***  AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT
!***  TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D)
!***
      DO I=1,NLGTH
        AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I))
        A1=0.5*(XRAD2(I)-XRAD4(I))
        B1=0.5*(XRAD1(I)-XRAD3(I))
        B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I)))

!       XRAD1(I)=AVG
!       XRAD2(I)=A1
!       XRAD3(I)=B1
!       XRAD4(I)=B2

        iindex = 1+mod((I-1),37)
        jindex = 1+(I-1)/37
        XDUO3N(iindex,jindex)=AVG
        XDO3N2(iindex,jindex)=A1
        XDO3N3(iindex,jindex)=B1
        XDO3N4(iindex,jindex)=B2
      ENDDO
!***
!***  CONVERT GFDL PRESSURE (MICROBARS) TO PA 
!***
      DO N=1,NL
        PRGFDL(N)=PSTD(N)*1.E-1
      ENDDO
!
    END SUBROUTINE O3CLIM

!---------------------------------------------------------------------

      SUBROUTINE TABLE  2
!                     (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3,          &
!                      SOURCE,DSRCE                                  )
!---------------------------------------------------------------------
 IMPLICIT NONE
!----------------------------------------------------------------------

!INTEGER, PARAMETER :: NBLY=15
 INTEGER, PARAMETER :: NB=12
 INTEGER, PARAMETER :: NBLX=47
 INTEGER , PARAMETER:: NBLW = 163

 REAL,PARAMETER ::      AMOLWT=28.9644
 REAL,PARAMETER ::      CSUBP=1.00484E7
 REAL,PARAMETER ::      DIFFCTR=1.66
 REAL,PARAMETER ::      G=980.665
 REAL,PARAMETER ::      GINV=1./G
 REAL,PARAMETER ::      GRAVDR=980.0
 REAL,PARAMETER ::      O3DIFCTR=1.90
 REAL,PARAMETER ::      P0=1013250.
 REAL,PARAMETER ::      P0INV=1./P0
 REAL,PARAMETER ::      GP0INV=GINV*P0INV
 REAL,PARAMETER ::      P0XZP2=202649.902
 REAL,PARAMETER ::      P0XZP8=810600.098
 REAL,PARAMETER ::      P0X2=2.*1013250.
 REAL,PARAMETER ::      RADCON=8.427
 REAL,PARAMETER ::      RADCON1=1./8.427
 REAL,PARAMETER ::      RATCO2MW=1.519449738
 REAL,PARAMETER ::      RATH2OMW=.622
 REAL,PARAMETER ::      RGAS=8.3142E7
 REAL,PARAMETER ::      RGASSP=8.31432E7
 REAL,PARAMETER ::      SECPDA=8.64E4
!
!******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
!        ARRANGED IN DECREASING ORDER
 REAL,PARAMETER ::      HUNDRED=100.
 REAL,PARAMETER ::      HNINETY=90.
 REAL,PARAMETER ::      HNINE=9.0
 REAL,PARAMETER ::      SIXTY=60.
 REAL,PARAMETER ::      FIFTY=50.
 REAL,PARAMETER ::      TEN=10.
 REAL,PARAMETER ::      EIGHT=8.
 REAL,PARAMETER ::      FIVE=5.
 REAL,PARAMETER ::      FOUR=4.
 REAL,PARAMETER ::      THREE=3.
 REAL,PARAMETER ::      TWO=2.
 REAL,PARAMETER ::      ONE=1.
 REAL,PARAMETER ::      HAF=0.5
 REAL,PARAMETER ::      QUARTR=0.25
 REAL,PARAMETER ::      ZERO=0.
!
!******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
!       ARRANGED IN DECREASING ORDER
 REAL,PARAMETER ::      H83E26=8.3E26
 REAL,PARAMETER ::      H71E26=7.1E26
 REAL,PARAMETER ::      H1E15=1.E15
 REAL,PARAMETER ::      H1E13=1.E13
 REAL,PARAMETER ::      H1E11=1.E11
 REAL,PARAMETER ::      H1E8=1.E8
 REAL,PARAMETER ::      H2E6=2.0E6
 REAL,PARAMETER ::      H1E6=1.0E6
 REAL,PARAMETER ::      H69766E5=6.97667E5
 REAL,PARAMETER ::      H4E5=4.E5
 REAL,PARAMETER ::      H165E5=1.65E5
 REAL,PARAMETER ::      H5725E4=57250.
 REAL,PARAMETER ::      H488E4=48800.
 REAL,PARAMETER ::      H1E4=1.E4
 REAL,PARAMETER ::      H24E3=2400.
 REAL,PARAMETER ::      H20788E3=2078.8
 REAL,PARAMETER ::      H2075E3=2075.
 REAL,PARAMETER ::      H18E3=1800.
 REAL,PARAMETER ::      H1224E3=1224.
 REAL,PARAMETER ::      H67390E2=673.9057
 REAL,PARAMETER ::      H5E2=500.
 REAL,PARAMETER ::      H3082E2=308.2
 REAL,PARAMETER ::      H3E2=300.
 REAL,PARAMETER ::      H2945E2=294.5
 REAL,PARAMETER ::      H29316E2=293.16
 REAL,PARAMETER ::      H26E2=260.0
 REAL,PARAMETER ::      H25E2=250.
 REAL,PARAMETER ::      H23E2=230.
 REAL,PARAMETER ::      H2E2=200.0
 REAL,PARAMETER ::      H15E2=150.
 REAL,PARAMETER ::      H1386E2=138.6
 REAL,PARAMETER ::      H1036E2=103.6
 REAL,PARAMETER ::      H8121E1=81.21
 REAL,PARAMETER ::      H35E1=35.
 REAL,PARAMETER ::      H3116E1=31.16
 REAL,PARAMETER ::      H28E1=28.
 REAL,PARAMETER ::      H181E1=18.1
 REAL,PARAMETER ::      H18E1=18.
 REAL,PARAMETER ::      H161E1=16.1
 REAL,PARAMETER ::      H16E1=16.
 REAL,PARAMETER ::      H1226E1=12.26
 REAL,PARAMETER ::      H9P94=9.94
 REAL,PARAMETER ::      H6P08108=6.081081081
 REAL,PARAMETER ::      H3P6=3.6
 REAL,PARAMETER ::      H3P5=3.5
 REAL,PARAMETER ::      H2P9=2.9
 REAL,PARAMETER ::      H2P8=2.8
 REAL,PARAMETER ::      H2P5=2.5
 REAL,PARAMETER ::      H1P8=1.8
 REAL,PARAMETER ::      H1P4387=1.4387
 REAL,PARAMETER ::      H1P41819=1.418191
 REAL,PARAMETER ::      H1P4=1.4
 REAL,PARAMETER ::      H1P25892=1.258925411
 REAL,PARAMETER ::      H1P082=1.082
 REAL,PARAMETER ::      HP816=0.816
 REAL,PARAMETER ::      HP805=0.805
 REAL,PARAMETER ::      HP8=0.8
 REAL,PARAMETER ::      HP60241=0.60241
 REAL,PARAMETER ::      HP602409=0.60240964
 REAL,PARAMETER ::      HP6=0.6
 REAL,PARAMETER ::      HP526315=0.52631579
 REAL,PARAMETER ::      HP518=0.518
 REAL,PARAMETER ::      HP5048=0.5048
 REAL,PARAMETER ::      HP3795=0.3795
 REAL,PARAMETER ::      HP369=0.369
 REAL,PARAMETER ::      HP26=0.26
 REAL,PARAMETER ::      HP228=0.228
 REAL,PARAMETER ::      HP219=0.219
 REAL,PARAMETER ::      HP166666=.166666
 REAL,PARAMETER ::      HP144=0.144
 REAL,PARAMETER ::      HP118666=0.118666192
 REAL,PARAMETER ::      HP1=0.1
!        (NEGATIVE EXPONENTIALS BEGIN HERE)
 REAL,PARAMETER ::      H658M2=0.0658
 REAL,PARAMETER ::      H625M2=0.0625
 REAL,PARAMETER ::      H44871M2=4.4871E-2
 REAL,PARAMETER ::      H44194M2=.044194
 REAL,PARAMETER ::      H42M2=0.042
 REAL,PARAMETER ::      H41666M2=0.0416666
 REAL,PARAMETER ::      H28571M2=.02857142857
 REAL,PARAMETER ::      H2118M2=0.02118
 REAL,PARAMETER ::      H129M2=0.0129
 REAL,PARAMETER ::      H1M2=.01
 REAL,PARAMETER ::      H559M3=5.59E-3
 REAL,PARAMETER ::      H3M3=0.003
 REAL,PARAMETER ::      H235M3=2.35E-3
 REAL,PARAMETER ::      H1M3=1.0E-3
 REAL,PARAMETER ::      H987M4=9.87E-4
 REAL,PARAMETER ::      H323M4=0.000323
 REAL,PARAMETER ::      H3M4=0.0003
 REAL,PARAMETER ::      H285M4=2.85E-4
 REAL,PARAMETER ::      H1M4=0.0001
 REAL,PARAMETER ::      H75826M4=7.58265E-4
 REAL,PARAMETER ::      H6938M5=6.938E-5
 REAL,PARAMETER ::      H394M5=3.94E-5
 REAL,PARAMETER ::      H37412M5=3.7412E-5
 REAL,PARAMETER ::      H15M5=1.5E-5
 REAL,PARAMETER ::      H1439M5=1.439E-5
 REAL,PARAMETER ::      H128M5=1.28E-5
 REAL,PARAMETER ::      H102M5=1.02E-5
 REAL,PARAMETER ::      H1M5=1.0E-5
 REAL,PARAMETER ::      H7M6=7.E-6
 REAL,PARAMETER ::      H4999M6=4.999E-6
 REAL,PARAMETER ::      H451M6=4.51E-6
 REAL,PARAMETER ::      H25452M6=2.5452E-6
 REAL,PARAMETER ::      H1M6=1.E-6
 REAL,PARAMETER ::      H391M7=3.91E-7
 REAL,PARAMETER ::      H1174M7=1.174E-7
 REAL,PARAMETER ::      H8725M8=8.725E-8
 REAL,PARAMETER ::      H327M8=3.27E-8
 REAL,PARAMETER ::      H257M8=2.57E-8
 REAL,PARAMETER ::      H1M8=1.0E-8
 REAL,PARAMETER ::      H23M10=2.3E-10
 REAL,PARAMETER ::      H14M10=1.4E-10
 REAL,PARAMETER ::      H11M10=1.1E-10
 REAL,PARAMETER ::      H1M10=1.E-10
 REAL,PARAMETER ::      H83M11=8.3E-11
 REAL,PARAMETER ::      H82M11=8.2E-11
 REAL,PARAMETER ::      H8M11=8.E-11
 REAL,PARAMETER ::      H77M11=7.7E-11
 REAL,PARAMETER ::      H72M11=7.2E-11
 REAL,PARAMETER ::      H53M11=5.3E-11
 REAL,PARAMETER ::      H48M11=4.8E-11
 REAL,PARAMETER ::      H44M11=4.4E-11
 REAL,PARAMETER ::      H42M11=4.2E-11
 REAL,PARAMETER ::      H37M11=3.7E-11
 REAL,PARAMETER ::      H35M11=3.5E-11
 REAL,PARAMETER ::      H32M11=3.2E-11
 REAL,PARAMETER ::      H3M11=3.0E-11
 REAL,PARAMETER ::      H28M11=2.8E-11
 REAL,PARAMETER ::      H24M11=2.4E-11
 REAL,PARAMETER ::      H23M11=2.3E-11
 REAL,PARAMETER ::      H2M11=2.E-11
 REAL,PARAMETER ::      H18M11=1.8E-11
 REAL,PARAMETER ::      H15M11=1.5E-11
 REAL,PARAMETER ::      H14M11=1.4E-11
 REAL,PARAMETER ::      H114M11=1.14E-11
 REAL,PARAMETER ::      H11M11=1.1E-11
 REAL,PARAMETER ::      H1M11=1.E-11
 REAL,PARAMETER ::      H96M12=9.6E-12
 REAL,PARAMETER ::      H93M12=9.3E-12
 REAL,PARAMETER ::      H77M12=7.7E-12
 REAL,PARAMETER ::      H74M12=7.4E-12
 REAL,PARAMETER ::      H65M12=6.5E-12
 REAL,PARAMETER ::      H62M12=6.2E-12
 REAL,PARAMETER ::      H6M12=6.E-12
 REAL,PARAMETER ::      H45M12=4.5E-12
 REAL,PARAMETER ::      H44M12=4.4E-12
 REAL,PARAMETER ::      H4M12=4.E-12
 REAL,PARAMETER ::      H38M12=3.8E-12
 REAL,PARAMETER ::      H37M12=3.7E-12
 REAL,PARAMETER ::      H3M12=3.E-12
 REAL,PARAMETER ::      H29M12=2.9E-12
 REAL,PARAMETER ::      H28M12=2.8E-12
 REAL,PARAMETER ::      H24M12=2.4E-12
 REAL,PARAMETER ::      H21M12=2.1E-12
 REAL,PARAMETER ::      H16M12=1.6E-12
 REAL,PARAMETER ::      H14M12=1.4E-12
 REAL,PARAMETER ::      H12M12=1.2E-12
 REAL,PARAMETER ::      H8M13=8.E-13
 REAL,PARAMETER ::      H46M13=4.6E-13
 REAL,PARAMETER ::      H36M13=3.6E-13
 REAL,PARAMETER ::      H135M13=1.35E-13
 REAL,PARAMETER ::      H12M13=1.2E-13
 REAL,PARAMETER ::      H1M13=1.E-13
 REAL,PARAMETER ::      H3M14=3.E-14
 REAL,PARAMETER ::      H15M14=1.5E-14
 REAL,PARAMETER ::      H14M14=1.4E-14
!
!******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
!          ARRANGED IN DESCENDING ORDER
 REAL,PARAMETER ::      HM2M2=-.02
 REAL,PARAMETER ::      HM6666M2=-.066667
 REAL,PARAMETER ::      HMP5=-0.5
 REAL,PARAMETER ::      HMP575=-0.575
 REAL,PARAMETER ::      HMP66667=-.66667
 REAL,PARAMETER ::      HMP805=-0.805
 REAL,PARAMETER ::      HM1EZ=-1.
 REAL,PARAMETER ::      HM13EZ=-1.3
 REAL,PARAMETER ::      HM19EZ=-1.9
 REAL,PARAMETER ::      HM1E1=-10.
 REAL,PARAMETER ::      HM1597E1=-15.97469413
 REAL,PARAMETER ::      HM161E1=-16.1
 REAL,PARAMETER ::      HM1797E1=-17.97469413
 REAL,PARAMETER ::      HM181E1=-18.1
 REAL,PARAMETER ::      HM8E1=-80.
 REAL,PARAMETER ::      HM1E2=-100.
!
 REAL,PARAMETER ::      H1M16=1.0E-16
 REAL,PARAMETER ::      H1M20=1.E-20
 REAL,PARAMETER ::      HP98=0.98
 REAL,PARAMETER ::      Q19001=19.001
 REAL,PARAMETER ::      DAYSEC=1.1574E-5
 REAL,PARAMETER ::      HSIGMA=5.673E-5
 REAL,PARAMETER ::      TWENTY=20.0
 REAL,PARAMETER ::      HP537=0.537
 REAL,PARAMETER ::      HP2=0.2
 REAL,PARAMETER ::      RCO2=3.3E-4
 REAL,PARAMETER ::      H3M6=3.0E-6
 REAL,PARAMETER ::      PI=3.1415927
 REAL,PARAMETER ::      DEGRAD1=180.0/PI
 REAL,PARAMETER ::      H74E1=74.0
 REAL,PARAMETER ::      H15E1=15.0

 REAL, PARAMETER:: B0 = -.51926410E-4
 REAL, PARAMETER:: B1 = -.18113332E-3
 REAL, PARAMETER:: B2 = -.10680132E-5
 REAL, PARAMETER:: B3 = -.67303519E-7
 REAL, PARAMETER:: AWIDE = 0.309801E+01
 REAL, PARAMETER:: BWIDE = 0.495357E-01
 REAL, PARAMETER:: BETAWD = 0.347839E+02
 REAL, PARAMETER:: BETINW = 0.766811E+01


!     REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
!                          TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
!                          SOURCE(28,NBLY), DSRCE(28,NBLY)

!
      REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW)
      REAL :: BANDLO(NBLW),BANDHI(NBLW)

      INTEGER :: IBAND(40)

      REAL :: BANDL1(64),BANDL2(64),BANDL3(35)
      REAL :: BANDH1(64),BANDH2(64),BANDH3(35) 
!     REAL :: AB15WD,SKO2D,SKC1R,SKO3R

!     REAL :: AWIDE,BWIDE,BETAWD,BETINW

!     DATA AWIDE  / 0.309801E+01/
!     DATA BWIDE  / 0.495357E-01/
!     DATA BETAWD / 0.347839E+02/
!     DATA BETINW / 0.766811E+01/

!
!% #NPADL = #PAGE*#NPAGE -  4*28*180  -  2*181 - 7*28 - 180 ;
!% #NPADL = #NPADL       -  11*28  - 2*180 - 2*30 ;

!     PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW)

      REAL ::  &
               SUM(28,180),PERTSM(28,180),SUM3(28,180),       &
               SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), &
               DBDTNB(28,NBLW)
      REAL ::  &
               ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), &
               TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), &
               SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28),     &
               R1T(28),R2(28),S2(28),T3(28),R1WD(28)
      REAL ::  EXPO(180),FAC(180)
      REAL ::  CNUSB(30),DNUSB(30)
      REAL ::  ALFANB(NBLW),AROTNB(NBLW)
      REAL ::  ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), &
               BETANB(NBLW)

      REAL ::  AB15(2)

      REAL ::   ARNDM1(64),ARNDM2(64),ARNDM3(35)
      REAL ::   BRNDM1(64),BRNDM2(64),BRNDM3(35)
      REAL ::   BETAD1(64),BETAD2(64),BETAD3(35)

      EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), &
                  (ARNDM3(1),ARNDM(129))
      EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), &
                  (BRNDM3(1),BRNDM(129))
      EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), &
                  (BETAD3(1),BETAD(129))

!---------------------------------------------------------------
      REAL    :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp
      INTEGER :: N,I,ICNT,I1,I2E,I2
      INTEGER :: J,JP,NSUBDS,NSB,IA

!---------------------------------------------------------------

      DATA IBAND  / &
          2,   1,   2,   2,   1,   2,   1,   3,   2,   2, &
          3,   2,   2,   4,   2,   4,   2,   3,   3,   2, &
          4,   3,   4,   3,   7,   5,   6,   7,   6,   5, &
          7,   6,   7,   8,   6,   6,   8,   8,   8,   8/

      DATA BANDL1 / &
         0.000000E+00,  0.100000E+02,  0.200000E+02,  0.300000E+02, &
         0.400000E+02,  0.500000E+02,  0.600000E+02,  0.700000E+02, &
         0.800000E+02,  0.900000E+02,  0.100000E+03,  0.110000E+03, &
         0.120000E+03,  0.130000E+03,  0.140000E+03,  0.150000E+03, &
         0.160000E+03,  0.170000E+03,  0.180000E+03,  0.190000E+03, &
         0.200000E+03,  0.210000E+03,  0.220000E+03,  0.230000E+03, &
         0.240000E+03,  0.250000E+03,  0.260000E+03,  0.270000E+03, &
         0.280000E+03,  0.290000E+03,  0.300000E+03,  0.310000E+03, &
         0.320000E+03,  0.330000E+03,  0.340000E+03,  0.350000E+03, &
         0.360000E+03,  0.370000E+03,  0.380000E+03,  0.390000E+03, &
         0.400000E+03,  0.410000E+03,  0.420000E+03,  0.430000E+03, &
         0.440000E+03,  0.450000E+03,  0.460000E+03,  0.470000E+03, &
         0.480000E+03,  0.490000E+03,  0.500000E+03,  0.510000E+03, &
         0.520000E+03,  0.530000E+03,  0.540000E+03,  0.550000E+03, &
         0.560000E+03,  0.670000E+03,  0.800000E+03,  0.900000E+03, &
         0.990000E+03,  0.107000E+04,  0.120000E+04,  0.121000E+04/
      DATA BANDL2 / &
         0.122000E+04,  0.123000E+04,  0.124000E+04,  0.125000E+04, &
         0.126000E+04,  0.127000E+04,  0.128000E+04,  0.129000E+04, &
         0.130000E+04,  0.131000E+04,  0.132000E+04,  0.133000E+04, &
         0.134000E+04,  0.135000E+04,  0.136000E+04,  0.137000E+04, &
         0.138000E+04,  0.139000E+04,  0.140000E+04,  0.141000E+04, &
         0.142000E+04,  0.143000E+04,  0.144000E+04,  0.145000E+04, &
         0.146000E+04,  0.147000E+04,  0.148000E+04,  0.149000E+04, &
         0.150000E+04,  0.151000E+04,  0.152000E+04,  0.153000E+04, &
         0.154000E+04,  0.155000E+04,  0.156000E+04,  0.157000E+04, &
         0.158000E+04,  0.159000E+04,  0.160000E+04,  0.161000E+04, &
         0.162000E+04,  0.163000E+04,  0.164000E+04,  0.165000E+04, &
         0.166000E+04,  0.167000E+04,  0.168000E+04,  0.169000E+04, &
         0.170000E+04,  0.171000E+04,  0.172000E+04,  0.173000E+04, &
         0.174000E+04,  0.175000E+04,  0.176000E+04,  0.177000E+04, &
         0.178000E+04,  0.179000E+04,  0.180000E+04,  0.181000E+04, &
         0.182000E+04,  0.183000E+04,  0.184000E+04,  0.185000E+04/
      DATA BANDL3 / &
         0.186000E+04,  0.187000E+04,  0.188000E+04,  0.189000E+04, &
         0.190000E+04,  0.191000E+04,  0.192000E+04,  0.193000E+04, &
         0.194000E+04,  0.195000E+04,  0.196000E+04,  0.197000E+04, &
         0.198000E+04,  0.199000E+04,  0.200000E+04,  0.201000E+04, &
         0.202000E+04,  0.203000E+04,  0.204000E+04,  0.205000E+04, &
         0.206000E+04,  0.207000E+04,  0.208000E+04,  0.209000E+04, &
         0.210000E+04,  0.211000E+04,  0.212000E+04,  0.213000E+04, &
         0.214000E+04,  0.215000E+04,  0.216000E+04,  0.217000E+04, &
         0.218000E+04,  0.219000E+04,  0.227000E+04/

      DATA BANDH1 / &
         0.100000E+02,  0.200000E+02,  0.300000E+02,  0.400000E+02, &
         0.500000E+02,  0.600000E+02,  0.700000E+02,  0.800000E+02, &
         0.900000E+02,  0.100000E+03,  0.110000E+03,  0.120000E+03, &
         0.130000E+03,  0.140000E+03,  0.150000E+03,  0.160000E+03, &
         0.170000E+03,  0.180000E+03,  0.190000E+03,  0.200000E+03, &
         0.210000E+03,  0.220000E+03,  0.230000E+03,  0.240000E+03, &
         0.250000E+03,  0.260000E+03,  0.270000E+03,  0.280000E+03, &
         0.290000E+03,  0.300000E+03,  0.310000E+03,  0.320000E+03, &
         0.330000E+03,  0.340000E+03,  0.350000E+03,  0.360000E+03, &
         0.370000E+03,  0.380000E+03,  0.390000E+03,  0.400000E+03, &
         0.410000E+03,  0.420000E+03,  0.430000E+03,  0.440000E+03, &
         0.450000E+03,  0.460000E+03,  0.470000E+03,  0.480000E+03, &
         0.490000E+03,  0.500000E+03,  0.510000E+03,  0.520000E+03, &
         0.530000E+03,  0.540000E+03,  0.550000E+03,  0.560000E+03, &
         0.670000E+03,  0.800000E+03,  0.900000E+03,  0.990000E+03, &
         0.107000E+04,  0.120000E+04,  0.121000E+04,  0.122000E+04/
      DATA BANDH2 / &
         0.123000E+04,  0.124000E+04,  0.125000E+04,  0.126000E+04, &
         0.127000E+04,  0.128000E+04,  0.129000E+04,  0.130000E+04, &
         0.131000E+04,  0.132000E+04,  0.133000E+04,  0.134000E+04, &
         0.135000E+04,  0.136000E+04,  0.137000E+04,  0.138000E+04, &
         0.139000E+04,  0.140000E+04,  0.141000E+04,  0.142000E+04, &
         0.143000E+04,  0.144000E+04,  0.145000E+04,  0.146000E+04, &
         0.147000E+04,  0.148000E+04,  0.149000E+04,  0.150000E+04, &
         0.151000E+04,  0.152000E+04,  0.153000E+04,  0.154000E+04, &
         0.155000E+04,  0.156000E+04,  0.157000E+04,  0.158000E+04, &
         0.159000E+04,  0.160000E+04,  0.161000E+04,  0.162000E+04, &
         0.163000E+04,  0.164000E+04,  0.165000E+04,  0.166000E+04, &
         0.167000E+04,  0.168000E+04,  0.169000E+04,  0.170000E+04, &
         0.171000E+04,  0.172000E+04,  0.173000E+04,  0.174000E+04, &
         0.175000E+04,  0.176000E+04,  0.177000E+04,  0.178000E+04, &
         0.179000E+04,  0.180000E+04,  0.181000E+04,  0.182000E+04, &
         0.183000E+04,  0.184000E+04,  0.185000E+04,  0.186000E+04/
      DATA BANDH3 / &
         0.187000E+04,  0.188000E+04,  0.189000E+04,  0.190000E+04, &
         0.191000E+04,  0.192000E+04,  0.193000E+04,  0.194000E+04, &
         0.195000E+04,  0.196000E+04,  0.197000E+04,  0.198000E+04, &
         0.199000E+04,  0.200000E+04,  0.201000E+04,  0.202000E+04, &
         0.203000E+04,  0.204000E+04,  0.205000E+04,  0.206000E+04, &
         0.207000E+04,  0.208000E+04,  0.209000E+04,  0.210000E+04, &
         0.211000E+04,  0.212000E+04,  0.213000E+04,  0.214000E+04, &
         0.215000E+04,  0.216000E+04,  0.217000E+04,  0.218000E+04, &
         0.219000E+04,  0.220000E+04,  0.238000E+04/

!
!***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING
!   THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS
      DATA ARNDM1  / &
         0.354693E+00,  0.269857E+03,  0.167062E+03,  0.201314E+04, &
         0.964533E+03,  0.547971E+04,  0.152933E+04,  0.599429E+04, &
         0.699329E+04,  0.856721E+04,  0.962489E+04,  0.233348E+04, &
         0.127091E+05,  0.104383E+05,  0.504249E+04,  0.181227E+05, &
         0.856480E+03,  0.136354E+05,  0.288635E+04,  0.170200E+04, &
         0.209761E+05,  0.126797E+04,  0.110096E+05,  0.336436E+03, &
         0.491663E+04,  0.863701E+04,  0.540389E+03,  0.439786E+04, &
         0.347836E+04,  0.130557E+03,  0.465332E+04,  0.253086E+03, &
         0.257387E+04,  0.488041E+03,  0.892991E+03,  0.117148E+04, &
         0.125880E+03,  0.458852E+03,  0.142975E+03,  0.446355E+03, &
         0.302887E+02,  0.394451E+03,  0.438112E+02,  0.348811E+02, &
         0.615503E+02,  0.143165E+03,  0.103958E+02,  0.725108E+02, &
         0.316628E+02,  0.946456E+01,  0.542675E+02,  0.351557E+02, &
         0.301797E+02,  0.381010E+01,  0.126319E+02,  0.548010E+01, &
         0.600199E+01,  0.640803E+00,  0.501549E-01,  0.167961E-01, &
         0.178110E-01,  0.170166E+00,  0.273514E-01,  0.983767E+00/
      DATA ARNDM2  / &
         0.753946E+00,  0.941763E-01,  0.970547E+00,  0.268862E+00, &
         0.564373E+01,  0.389794E+01,  0.310955E+01,  0.128235E+01, &
         0.196414E+01,  0.247113E+02,  0.593435E+01,  0.377552E+02, &
         0.305173E+02,  0.852479E+01,  0.116780E+03,  0.101490E+03, &
         0.138939E+03,  0.324228E+03,  0.683729E+02,  0.471304E+03, &
         0.159684E+03,  0.427101E+03,  0.114716E+03,  0.106190E+04, &
         0.294607E+03,  0.762948E+03,  0.333199E+03,  0.830645E+03, &
         0.162512E+04,  0.525676E+03,  0.137739E+04,  0.136252E+04, &
         0.147164E+04,  0.187196E+04,  0.131118E+04,  0.103975E+04, &
         0.621637E+01,  0.399459E+02,  0.950648E+02,  0.943161E+03, &
         0.526821E+03,  0.104150E+04,  0.905610E+03,  0.228142E+04, &
         0.806270E+03,  0.691845E+03,  0.155237E+04,  0.192241E+04, &
         0.991871E+03,  0.123907E+04,  0.457289E+02,  0.146146E+04, &
         0.319382E+03,  0.436074E+03,  0.374214E+03,  0.778217E+03, &
         0.140227E+03,  0.562540E+03,  0.682685E+02,  0.820292E+02, &
         0.178779E+03,  0.186150E+03,  0.383864E+03,  0.567416E+01/ 
      DATA ARNDM3  / &
         0.225129E+03,  0.473099E+01,  0.753149E+02,  0.233689E+02, &
         0.339802E+02,  0.108855E+03,  0.380016E+02,  0.151039E+01, &
         0.660346E+02,  0.370165E+01,  0.234169E+02,  0.440206E+00, &
         0.615283E+01,  0.304077E+02,  0.117769E+01,  0.125248E+02, &
         0.142652E+01,  0.241831E+00,  0.483721E+01,  0.226357E-01, &
         0.549835E+01,  0.597067E+00,  0.404553E+00,  0.143584E+01, &
         0.294291E+00,  0.466273E+00,  0.156048E+00,  0.656185E+00, &
         0.172727E+00,  0.118349E+00,  0.141598E+00,  0.588581E-01, &
         0.919409E-01,  0.155521E-01,  0.537083E-02/
      DATA BRNDM1  / &
         0.789571E-01,  0.920256E-01,  0.696960E-01,  0.245544E+00, &
         0.188503E+00,  0.266127E+00,  0.271371E+00,  0.330917E+00, &
         0.190424E+00,  0.224498E+00,  0.282517E+00,  0.130675E+00, &
         0.212579E+00,  0.227298E+00,  0.138585E+00,  0.187106E+00, &
         0.194527E+00,  0.177034E+00,  0.115902E+00,  0.118499E+00, &
         0.142848E+00,  0.216869E+00,  0.149848E+00,  0.971585E-01, &
         0.151532E+00,  0.865628E-01,  0.764246E-01,  0.100035E+00, &
         0.171133E+00,  0.134737E+00,  0.105173E+00,  0.860832E-01, &
         0.148921E+00,  0.869234E-01,  0.106018E+00,  0.184865E+00, &
         0.767454E-01,  0.108981E+00,  0.123094E+00,  0.177287E+00, &
         0.848146E-01,  0.119356E+00,  0.133829E+00,  0.954505E-01, &
         0.155405E+00,  0.164167E+00,  0.161390E+00,  0.113287E+00, &
         0.714720E-01,  0.741598E-01,  0.719590E-01,  0.140616E+00, &
         0.355356E-01,  0.832779E-01,  0.128680E+00,  0.983013E-01, &
         0.629660E-01,  0.643346E-01,  0.717082E-01,  0.629730E-01, &
         0.875182E-01,  0.857907E-01,  0.358808E+00,  0.178840E+00/
      DATA BRNDM2  / &
         0.254265E+00,  0.297901E+00,  0.153916E+00,  0.537774E+00, &
         0.267906E+00,  0.104254E+00,  0.400723E+00,  0.389670E+00, &
         0.263701E+00,  0.338116E+00,  0.351528E+00,  0.267764E+00, &
         0.186419E+00,  0.238237E+00,  0.210408E+00,  0.176869E+00, &
         0.114715E+00,  0.173299E+00,  0.967770E-01,  0.172565E+00, &
         0.162085E+00,  0.157782E+00,  0.886832E-01,  0.242999E+00, &
         0.760298E-01,  0.164248E+00,  0.221428E+00,  0.166799E+00, &
         0.312514E+00,  0.380600E+00,  0.353828E+00,  0.269500E+00, &
         0.254759E+00,  0.285408E+00,  0.159764E+00,  0.721058E-01, &
         0.170528E+00,  0.231595E+00,  0.307184E+00,  0.564136E-01, &
         0.159884E+00,  0.147907E+00,  0.185666E+00,  0.183567E+00, &
         0.182482E+00,  0.230650E+00,  0.175348E+00,  0.195978E+00, &
         0.255323E+00,  0.198517E+00,  0.195500E+00,  0.208356E+00, &
         0.309603E+00,  0.112011E+00,  0.102570E+00,  0.128276E+00, &
         0.168100E+00,  0.177836E+00,  0.105533E+00,  0.903330E-01, &
         0.126036E+00,  0.101430E+00,  0.124546E+00,  0.221406E+00/ 
      DATA BRNDM3  / &
         0.137509E+00,  0.911365E-01,  0.724508E-01,  0.795788E-01, &
         0.137411E+00,  0.549175E-01,  0.787714E-01,  0.165544E+00, &
         0.136484E+00,  0.146729E+00,  0.820496E-01,  0.846211E-01, &
         0.785821E-01,  0.122527E+00,  0.125359E+00,  0.101589E+00, &
         0.155756E+00,  0.189239E+00,  0.999086E-01,  0.480993E+00, &
         0.100233E+00,  0.153754E+00,  0.130780E+00,  0.136136E+00, &
         0.159353E+00,  0.156634E+00,  0.272265E+00,  0.186874E+00, &
         0.192090E+00,  0.135397E+00,  0.131497E+00,  0.127463E+00, &
         0.227233E+00,  0.190562E+00,  0.214005E+00/ 
      DATA BETAD1  / &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.234879E+03,  0.217419E+03,  0.201281E+03,  0.186364E+03, &
         0.172576E+03,  0.159831E+03,  0.148051E+03,  0.137163E+03, &
         0.127099E+03,  0.117796E+03,  0.109197E+03,  0.101249E+03, &
         0.939031E+02,  0.871127E+02,  0.808363E+02,  0.750349E+02, &
         0.497489E+02,  0.221212E+02,  0.113124E+02,  0.754174E+01, &
         0.589554E+01,  0.495227E+01,  0.000000E+00,  0.000000E+00/ 
      DATA BETAD2  / &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00/ 
      DATA BETAD3  / &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
         0.000000E+00,  0.000000E+00,  0.000000E+00/ 
!---------------------------------------------------------------
!     EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), &
!                 (BANDL3(1),BANDLO(129))

!     L     = kme-1
!     LP1   = L+1
!     LP1V  = LP1*(1+2*L/2)
!     IMAX  = ite
!     LP2   = L + 2
 
      DO I = 1,64
         BANDLO(I)=BANDL1(I)
      ENDDO

      DO I = 65,128
         BANDLO(I)=BANDL2(I-64)
      ENDDO

      DO I = 129,163
         BANDLO(I)=BANDL3(I-128)
      ENDDO

      DO I = 1,64
         BANDHI(I)=BANDH1(I)
      ENDDO

      DO I = 65,128
         BANDHI(I)=BANDH2(I-64)
      ENDDO

      DO I = 129,163
         BANDHI(I)=BANDH3(I-128)
      ENDDO

!****************************************
!***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
!....FOR NARROW-BANDS...
      DO 101 N=1,NBLW
      ANB(N)=ARNDM(N)
      BNB(N)=BRNDM(N)
      CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N))
      DELNB(N)=BANDHI(N)-BANDLO(N)
      BETANB(N)=BETAD(N)
101   CONTINUE
      AB15(1)=ANB(57)*BNB(57)
      AB15(2)=ANB(58)*BNB(58)
!....FOR WIDE BANDS...
      AB15WD=AWIDE*BWIDE
!
!***COMPUTE INDICES: IND,INDX2,KMAXV
!SH   ICNT=0
!SH   DO 113 I1=1,L
!SH     I2E=LP1-I1
!SH     DO 115 I2=1,I2E
!SH       ICNT=ICNT+1
!SH       INDX2(ICNT)=LP1*(I2-1)+LP2*I1
!SH115     CONTINUE
!SH113   CONTINUE
!SH   KMAXV(1)=1
!SH   DO 117 I=2,L
!SH   KMAXV(I)=KMAXV(I-1)+(LP2-I)
117   CONTINUE
!SH   KMAXVM=KMAXV(L)
!***COMPUTE RATIOS OF CONT. COEFFS
      SKC1R=BETAWD/BETINW
      SKO3R=BETAD(61)/BETINW
      SKO2D=ONE/BETINW
!
!****BEGIN TABLE COMPUTATIONS HERE***
!***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES
!---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS
!   WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM
!   100K TO 370K.
!---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF
!   180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS
!   ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS.
      ZMASS(1)=H1M16
      DO 201 J=1,180
      JP=J+1
      ZROOT(J)=SQRT(ZMASS(J))
      ZMASS(JP)=ZMASS(J)*H1P25892
201   CONTINUE
      DO 203 I=1,28
      XTEMV(I)=HNINETY+TEN*I
      TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
      FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I)
203   CONTINUE
!******THE COMPUTATION OF SOURCE,DSRCE IS  NEEDED ONLY
!   FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE
!   MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD)
!   THEN COMBINED (USING IBAND) INTO SOURCE.
      DO 205 N=1,NBLY
      DO 205 I=1,28
      SOURCE(I,N)=ZERO
205   CONTINUE
      DO 207 N=1,NBLX
      DO 207 I=1,28
      SRCWD(I,N)=ZERO
207   CONTINUE
!---BEGIN FREQ. LOOP (ON N)
      DO 211 N=1,NBLX
        IF (N.LE.46) THEN
!***THE 160-1200 BAND CASES
          CENT=CENTNB(N+16)
          DEL=DELNB(N+16)
          BDLO=BANDLO(N+16)
          BDHI=BANDHI(N+16)
        ENDIF
        IF (N.EQ.NBLX) THEN
!***THE 2270-2380 BAND CASE
          CENT=CENTNB(NBLW)
          DEL=DELNB(NBLW)
          BDLO=BANDLO(NBLW)
          BDHI=BANDHI(NBLW)
        ENDIF
!***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE
!  ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS.
      NSUBDS=(DEL-H1M3)/10+1
      DO 213 NSB=1,NSUBDS
      IF (NSB.NE.NSUBDS) THEN
        CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE
        DNUSB(NSB)=TEN
      ELSE
        CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI)
        DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO)
      ENDIF
      C1=(H37412M5)*CNUSB(NSB)**3
!---BEGIN TEMP. LOOP (ON I)
      DO 215 I=1,28
      X(I)=H1P4387*CNUSB(NSB)/XTEMV(I)
      X1(I)=EXP(X(I))
      SRCS(I)=C1/(X1(I)-ONE)
      SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
215   CONTINUE
213   CONTINUE
211   CONTINUE
!***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
!   AND DSRCE
      DO 221 N=1,40
      DO 221 I=1,28
      SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
221   CONTINUE
      DO 223 N=9,NBLY
      DO 223 I=1,28
      SOURCE(I,N)=SRCWD(I,N+32)
223   CONTINUE
      DO 225 N=1,NBLY
      DO 225 I=1,27
      DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1
225   CONTINUE
      DO 231 N=1,NBLW
      ALFANB(N)=BNB(N)*ANB(N)
      AROTNB(N)=SQRT(ALFANB(N))
231   CONTINUE
!***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR
!   USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE
!   BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ.
!   RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT.
!
      DO 301 N=1,NBLW
      CENT=CENTNB(N)
      DEL=DELNB(N)
!---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT
!   IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR
!   THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY.
#if 0
      DO 303 IA=1,3
#else
!jm -- getting floating point exceptions for IA=1, since 2 is only
!      used anyway, I disabled the looping.
      DO 303 IA=2,2
#endif
      ANU=CENT+HAF*(IA-2)*DEL
      C1=(H37412M5)*ANU*ANU*ANU+H1M20
!---TEMPERATURE LOOP---
      DO 305 I=1,28
         X(I)=H1P4387*ANU/XTEMV(I)
         X1(I)=EXP(X(I))
!#$      tmp=max((X1(I)-ONE),H1M20)
!#$      SC(I)=C1/tmp
         SC(I)=C1/((X1(I)-ONE)+H1M20)
!#$      DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1)
         DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
305      CONTINUE
      IF (IA.EQ.2) THEN
         DO 307 I=1,28
         SRC1NB(I,N)=DEL*SC(I)
         DBDTNB(I,N)=DEL*DSC(I)
307      CONTINUE
      ENDIF
303   CONTINUE
301   CONTINUE
!***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION
!   WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A
!   DIFFERENT DEPENDENCE ON (ZMASS).
!---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE
      DO 311 I=1,28
      SUM4(I)=ZERO
      SUM6(I)=ZERO
      SUM7(I)=ZERO
      SUM8(I)=ZERO
      SUM4WD(I)=ZERO
311   CONTINUE
      DO 313 N=1,NBLW
      CENT=CENTNB(N)
!***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4
!   SUM6,SUM7,SUM8
      IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
         DO 315 I=1,28
         SUM4(I)=SUM4(I)+SRC1NB(I,N)
         SUM6(I)=SUM6(I)+DBDTNB(I,N)
         SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N)
         SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N)
315      CONTINUE
      ENDIF
!***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
      IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
         DO 316 I=1,28
         SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
316      CONTINUE
      ENDIF
313   CONTINUE
      DO 317 I=1,28
      R1T(I)=SUM4(I)/TFOUR(I)
      R2(I)=SUM6(I)/FORTCU(I)
      S2(I)=SUM7(I)/FORTCU(I)
      T3(I)=SUM8(I)/FORTCU(I)
      R1WD(I)=SUM4WD(I)/TFOUR(I)
317   CONTINUE
      DO 401 J=1,180
      DO 401 I=1,28
      SUM(I,J)=ZERO
      PERTSM(I,J)=ZERO
      SUM3(I,J)=ZERO
      SUMWDE(I,J)=ZERO
401   CONTINUE
!---FREQUENCY LOOP BEGINS---
      DO 411 N=1,NBLW
      CENT=CENTNB(N)
!***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1
      IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
         DO 413 J=1,180
         X2(J)=AROTNB(N)*ZROOT(J)
         EXPO(J)=EXP(-X2(J))
413      CONTINUE
         DO 415 J=1,180
         IF (X2(J).GE.HUNDRED) THEN
              EXPO(J)=ZERO
         ENDIF
415      CONTINUE
         DO 417 J=121,180
         FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J))
417      CONTINUE
         DO 419 J=1,180
         DO 419 I=1,28
         SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J)
         PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J)
419      CONTINUE
         DO 421 J=121,180
         DO 421 I=1,28
         SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
421      CONTINUE
      ENDIF
!---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
      IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
         DO 420 J=1,180
         DO 420 I=1,28
         SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
420      CONTINUE
      ENDIF
411   CONTINUE
      DO 431 J=1,180
      DO 431 I=1,28
      EM1(I,J)=SUM(I,J)/TFOUR(I)
      TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
431   CONTINUE
      DO 433 J=121,180
      DO 433 I=1,28
      EM3(I,J)=SUM3(I,J)/FORTCU(I)
433   CONTINUE
      DO 441 J=1,179
      DO 441 I=1,28
      TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN
441   CONTINUE
      DO 443 J=1,180
      DO 443 I=1,27
      TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1
443   CONTINUE
      DO 445 I=1,28
      TABLE2(I,180)=ZERO
445   CONTINUE
      DO 447 J=1,180
      TABLE3(28,J)=ZERO
447   CONTINUE
      DO 449 J=1,2
      DO 449 I=1,28
      EM1(I,J)=R1T(I)
449   CONTINUE
      DO 451 J=1,120
      DO 451 I=1,28
      EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT
451   CONTINUE
      DO 453 J=121,180
      DO 453 I=1,28
      EM3(I,J)=EM3(I,J)/ZMASS(J)
453   CONTINUE
!***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
!   WE USE R1WD AND SUMWDE OBTAINED ABOVE.
      DO 501 J=1,180
      DO 501 I=1,28
      EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
501   CONTINUE
      DO 503 J=1,2
      DO 503 I=1,28
      EM1WDE(I,J)=R1WD(I)
503   CONTINUE
   
      END SUBROUTINE TABLE

!---------------------------------------------------------------------

    SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR) 3
!---------------------------------------------------------------------
    IMPLICIT NONE
!---------------------------------------------------------------------
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .                               .
! SUBPROGRAM:    SOLARD      COMPUTE THE SOLAR-EARTH DISTANCE
!   PRGRMMR: Q.ZHAO           ORG: W/NMC2     DATE: 96-7-23       
!     
! ABSTRACT:
!     SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY
!     FOR USE IN SHORT-WAVE RADIATION.
!     
! PROGRAM HISTORY LOG:
!   96-07-23  Q.ZHAO      - ORIGINATOR
!   98-10-09  Q.ZHAO      - CHANGED TO USE IW3JDN IN W3LIB TO
!                           CALCULATE JD.
!   04-11-18  Y.-T. HOU   - FIXED ERROR IN JULIAN DAY CALCULATION
!     
! USAGE: CALL SOLARD FROM SUBROUTINE INIT
!
!   INPUT ARGUMENT LIST:
!       NONE
!  
!   OUTPUT ARGUMENT LIST: 
!       R1   - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH
!              (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER).
!     
!   INPUT FILES:
!     NONE
!        
!   OUTPUT FILES:
!     NONE
!     
!   SUBPROGRAMS CALLED:
!  
!     UNIQUE: NONE
!  
!     LIBRARY: IW3JDN
!  
!   COMMON BLOCKS: CTLBLK
!   
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!   MACHINE : IBM SP
!***********************************************************************
     REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI
!-----------------------------------------------------------------------
!     INTEGER, INTENT(IN ) :: IHRST,IDAT(3)
      INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR
!     REAL   , INTENT(OUT) :: R1
!-----------------------------------------------------------------------
      INTEGER :: NDM(12),JYR19,JMN
      REAL    :: CCR

      DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/
      DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/
 
!.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900
!.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT
!.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT
!
      REAL    :: TPP
      DATA TPP/1.55/

      INTEGER :: JDOR2,JDOR1
      DATA JDOR2/2415020/, JDOR1/2415019/

      REAL    :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1
      INTEGER :: JHR,JD,ITER
!
!     LIBRARY: IW3JDN
!
!    --------------------------------------------------------------------
!     COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT
!     ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100
!     BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN
!     CALENDAR DURING THIS PERIOD
!    --------------------------------------------------------------------

      JHR=IHRST
!
      JD=IDAY-32075                                                     &
             +1461*(JULYR+4800+(MONTH-14)/12)/4                         &
             +367*(MONTH-2-(MONTH-14)/12*12)/12                         &
             -3*((JULYR+4900+(MONTH-14)/12)/100)/4
      IF(JHR.LT.12)THEN
        JD=JD-1
        FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN)
      ELSE
  7     FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN)
      END IF
      DAYINC=JHR/24.0
      FJD1=JD+FJD+DAYINC
      JD=FJD1
      FJD=FJD1-JD
!***
!*** CALCULATE THE SOLAR-EARTH DISTANCE
!***
      DAT=REAL(JD-JDOR2)-TPP+FJD
!***
!    COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH
!***
      T=FLOAT(JD-JDOR2)/36525.E0
!***
!    COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS)
!***
      YEAR=.25964134E0+.304E-5*T
!***
!    COMPUTES ORBIT ECCENTRICITY FROM T
!***
      EC=.01675104E0-(.418E-4+.126E-6*T)*T
      YEAR=YEAR+365.E0
!***
!    DATE=DAYS SINCE LAST PERIHELION PASSAGE
!***
      DATE = MOD(DAT,YEAR)
!***
!    SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD
!***
      EM=PI2*DATE/YEAR
      E=1.E0
      ITER = 0
 31   EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E))
      CR=ABS(E-EP)
      E=EP
      ITER = ITER + 1
      IF(ITER.GT.10) GOTO 1031
      IF(CR.GT.CCR) GO TO 31
 1031 CONTINUE
      R1=1.E0-EC*COS(E)
!
      WRITE(0,1000)JULYR,MONTH,IDAY,IHRST,R1
 1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ &
             'YEAR=',I5,'  MONTH=',I3,'  DAY=',I3,' HOUR=' &
      ,      I3,' R1=',F9.4)
!***
!    RETURN TO RADTN
!***
    END SUBROUTINE SOLARD
!---------------------------------------------------------------------

    SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday)      4
!---------------------------------------------------------------------
    IMPLICIT NONE
!-----------------------------------------------------------------------
    INTEGER, INTENT(IN) :: JULDAY,julyr
    INTEGER, INTENT(OUT) :: Jmonth,Jday
    LOGICAL :: LEAP,NOT_FIND_DATE
    INTEGER :: MONTH (12),itmpday,itmpmon,i
!-----------------------------------------------------------------------
    DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
!***********************************************************************
    NOT_FIND_DATE = .true.

    itmpday = JULDAY
    itmpmon = 1
    LEAP=.FALSE.
    IF(MOD(julyr,4).EQ.0)THEN
      MONTH(2)=29
      LEAP=.TRUE.
    ENDIF

    i = 1
    DO WHILE (NOT_FIND_DATE)
       IF(itmpday.GT.MONTH(i))THEN
         itmpday=itmpday-MONTH(i)
       ELSE
         Jday=itmpday
         Jmonth=i
         NOT_FIND_DATE = .false.
       ENDIF
       i = i+1
    END DO

    END SUBROUTINE CAL_MON_DAY
!!================================================================================
! CO2 initialization code


      FUNCTION ANTEMP(L,Z) 12
      REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
! ************** TROPICAL SOUNDING **************************
      DATA (ZB(N,1),N=1,10)/  2.0,   3.0,   16.5,  21.5,  45.0, &
                              51.0,  70.0,  100.,  200.,  300./
      DATA (C(N,1),N=1,11)/ -6.0,  -4.0,  -6.7,   4.0,   2.2,   &
                         1.0,  -2.8,  -.27,   0.0,   0.0,  0.0/
      DATA (DELTA(N,1),N=1,10)/.5,    .5,    .3,    .5,    1.0, &
                              1.0,   1.0,   1.0,   1.0,    1.0/
! ************** SUB-TROPICAL SUMMER ************************
      DATA (ZB(N,2),N=1,10)/ 1.5,   6.5,  13.0,  18.0,  26.0, &
                              36.0,  48.0,  50.0, 70.0,  100./
      DATA (C(N,2),N=1,11)/ -4.0,  -6.0,  -6.5,   0.0,   1.2, &
                        2.2,   2.5,   0.0,  -3.0,  -0.25,  0.0/
      DATA (DELTA(N,2),N=1,10)/ .5,  1.0,    .5,    .5,   1.0, &
                              1.0,  2.5,    .5,   1.0,   1.0/
! ************** SUB-TROPICAL WINTER ************************
      DATA (ZB(N,3),N=1,10)/ 3.0,  10.0,  19.0,  25.0,  32.0, &
                              44.5, 50.0,  71.0,  98.0,  200.0/
      DATA (C(N,3),N=1,11)/ -3.5,  -6.0,  -0.5,  0.0,   0.4, &
                              3.2,   1.6,  -1.8, -0.7,   0.0,   0.0/
      DATA (DELTA(N,3),N=1,10)/ .5,   .5,  1.0,   1.0,   1.0, &
                              1.0,  1.0,  1.0,   1.0,   1.0/
! *************  SUB-ARCTIC SUMMER *************************
      DATA (ZB(N,4),N=1,10)/ 4.7, 10.0,  23.0,  31.8,  44.0, &
                              50.2, 69.2, 100.0, 102.0, 103.0/
      DATA (C(N,4),N=1,11)/ -5.3, -7.0,   0.0,  1.4,   3.0, &
                               0.7, -3.3,  -0.2,  0.0,   0.0,  0.0/
      DATA (DELTA(N,4),N=1,10)/ .5,   .3,  1.0,   1.0,   2.0, &
                              1.0,  1.5,  1.0,   1.0,   1.0/
! ************ SUB-ARCTIC WINTER *****************************
      DATA (ZB(N,5),N=1,10)/ 1.0,   3.2,   8.5,   15.5,   25.0, &
                              30.0,  35.0,  50.0,  70.0,  100.0/
      DATA (C(N,5),N=1,11)/ 3.0,  -3.2,  -6.8,  0.0,  -0.6, &
                              1.0,   1.2,   2.5, -0.7,  -1.2,  0.0/
      DATA (DELTA(N,5),N=1,10)/ .4,   1.5,    .3 ,   .5,   1.0, &
                              1.0,   1.0,   1.0,   1.0,   1.0/
! ************ US STANDARD 1976 ******************************
      DATA (ZB(N,6),N=1,10)/ 11.0,  20.0,  32.0,  47.0,  51.0, & 
                             71.0,  84.8520,  90.0,  91.0,  92.0/
      DATA (C(N,6),N=1,11)/ -6.5,   0.0,   1.0,   2.80,  0.0, &
                             -2.80, -2.00,  0.0,   0.0,   0.0,  0.0/
      DATA (DELTA(N,6),N=1,10)/ 0.3,   1.0,   1.0,   1.0,   1.0, &
                              1.0,   1.0,   1.0,   1.0,   1.0/
!
! ************ ENLARGED US STANDARD 1976 **********************
      DATA (ZB(N,7),N=1,10)/ 11.0,  20.0,  32.0,  47.0,  51.0, &
                             71.0,  84.8520,  90.0,  91.0,  92.0/
      DATA (C(N,7),N=1,11)/ -6.5,   0.0,   1.0,   2.80,  0.0, &
                             -2.80, -2.00,  0.0,   0.0,   0.0,  0.0/
      DATA (DELTA(N,7),N=1,10)/ 0.3,   1.0,   1.0,   1.0,   1.0, &
                              1.0,   1.0,   1.0,   1.0,   1.0/
!
      DATA TSTAR/ 300.0,  294.0,  272.2,  287.0,  257.1, 2*288.15/
!
      NLAST=10
      TEMP=TSTAR(L)+C(1,L)*Z
      DO 20 N=1,NLAST
      EXPO=(Z-ZB(N,L))/DELTA(N,L)
      EXPP=ZB(N,L)/DELTA(N,L)
!JD single-precision change
!      FAC=EXP(EXPP)+EXP(-EXPP)
!mp	write(6,*) '.........................................'
!mp what in the hell does the next line do?
!mp	
!mp	apparently if statement <0 or =0 then 23, else 24
!mp     IF(ABS(EXPO)-100.0) 23,23,24
!
! changed to a more reasonable value for the workstation	
!
      IF(ABS(EXPO)-50.0) 23,23,24
   23 X=EXP(EXPO)
      Y=X+1.0/X
      ZLOG=ALOG(Y)
      GO TO 25
   24 ZLOG=ABS(EXPO)
!mp   25 IF(EXPP-100.0) 27,27,28
   25 IF(EXPP-50.0) 27,27,28
!JD single-precision change
   27 FAC=EXP(EXPP)+EXP(-EXPP)
      FACLOG=ALOG(FAC)
      GO TO 29
   28 FACLOG=EXPP
!     TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)*
!    1     ALOG((EXP(EXPO)+EXP(-EXPO))/FAC))
   29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* &
           (ZLOG-FACLOG))
!mp	write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L),
!mp     +	ZLOG,FACLOG
   20 CONTINUE
      ANTEMP=TEMP

      END FUNCTION ANTEMP

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc


      SUBROUTINE COEINT(RAT,IR) 2,6
! **********************************************************************
!
!
!            THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO
!       THE  FUNCTIONAL FORM
!                     TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)),
!               WHERE
!                     PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/
!                                 (ETA*(P1+P2+CORE)+(P1-P2))
!
!
!        THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER
!        WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH
!        PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL
!        VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER.
!            SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT
!        VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU
!        ITERATION VALUE OF ETA.
!             DEFINE:
!                PATHA=PATH(P(I),P(I-2),CORE,ETA)
!                PATHB=PATH(P(I),P(I-1),CORE,ETA);
!        THEN
!                R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1)))
!                 = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)),
!        SO THAT
!                R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB).
!        THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T
!        RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE
!        THAN 2 TO GIVE THE ARRAYS X(I) AND C(I).
!             NEWTON S METHOD FOR SOLVING THE EQUATION
!                 F(X)=0
!        MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD).
!        THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE.
!        THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS
!        BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T
!        (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T
!        USED FOR INTERPOLATION.
!           THERE ARE SEVERAL POSSIBLE PITFALLS:
!              1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH
!                 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP
!                 AND AN ERROR MESSAGE IS PRINTED OUT.
!              2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT
!                 BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C
!                 NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF
!                 A WARNING IS PRINTED OUT.
!
!  *********************************************************************
!....
!     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!     COMMON/PRESS/PA(109)
      REAL RAT,SINV
!     REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
      REAL PA2
!     COMMON/TRAN/ TRANSA(109,109)
!     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
      DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109)
      DIMENSION SINV(4)
      INTEGER :: IERR
      DATA SINV/2.74992,2.12731,4.38111,0.0832926/
!NOV89   DIMENSION SINV(3)
!NOV89   DATA SINV/2.74992,2.12731,4.38111/
!O222  OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988
!O222   WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS
      CORE=5.000
      UEXP=0.90
!      P0=0.7
      DO 902 I=1,109
      PA2=PA(I)*PA(I)
      SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25)
902   CONTINUE
      DO 900 I=1,109
      ETA(I)=3.2E-4*EXP(-PA(I)/500.)
      ETAP(I)=ETA(I)
900   CONTINUE
      DO 1200 NP=1,10
      DO 1000 I=3,109
      SEXP=SEXPV(I)
      R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1))
      REXP=R**(UEXP/SEXP)
      arg1=path(pa(i),pa(i-2),core,eta(i))
      arg2=path(pa(i),pa(i-1),core,eta(i))
      PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP
      PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP
      XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA)
      DO 1010 LL=1,20
      F1=DLOG(1.0D0+XX*PATHA)
      F2=DLOG(1.0D0+XX*PATHB)
      F=F1/F2-REXP
      FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ &
          (F2*F2)
      XX=XX-F/FPRIME
      CHECK=1.0D0+XX*PATHA
!!!!  IF (CHECK) 1020,1020,1025
      IF(CHECK.LE.0.)THEN
        WRITE(errmess,360)I,LL,CHECK
        WRITE(errmess,*)' xx=',xx,' patha=',patha
  360   FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10)
        CALL wrf_error_fatal ( errmess )
      ENDIF
 1010 CONTINUE
      CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ &
       (DLOG(1.0D0+XX*PATHA)+1.0D-20)
      XA(I)=XX
1000  CONTINUE
      XA(2)=XA(3)
      XA(1)=XA(3)
      CA(2)=CA(3)
      CA(1)=CA(3)
      DO 1100 I=3,109
      PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP
      PATH0(I)=1.0D0+XA(I)*PATH0(I)
!+++  IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I)
1100  CONTINUE
      DO 1035 I=1,109
      SEXP=SEXPV(I)
      ETAP(I)=ETA(I)
      ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* &
        (CA(I)*XA(I))**(1./UEXP)
1035  CONTINUE
!
!     THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985).
!        THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S)
!      IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND
!      S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND
!       ALSO,THE DENOMINATOR IS MULTIPLIED BY
!      1000 TO PERMIT USE OF MB UNITS FOR PRESSURE.
!        S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN
!      ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL
!      1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS.
!      FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992.
!      (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS)
!      FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731
!      FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111
!      FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926
!      SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2
!        RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV,
!      LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION.
!
!     WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109)
!366   FORMAT (2I4,4E20.12)
1200  CONTINUE
 361  FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ &
       20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6)
      RETURN
      END SUBROUTINE COEINT

!--------------


!CCC  PROGRAM CO2INS

      SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag) 6
!     *********************************************************
!       SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ******
!          ..... K.CAMPANA   MARCH 1988,OCTOBER 1988...
!          ..... K.CAMPANA   DECEMBER 1988-CLEANED UP FOR LAUNCHER
!          ..... K.CAMPANA   NOVEMBER 1989-ALTERED FOR NEW RADIATION
!     *********************************************************
      DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6)
      DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
       CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
       CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
!CC   ITIN=22
!CC   ITIN1=23
!O222  LATEST CODE HAD  IQ=1
!CC      IQ=4
1011  FORMAT (4F20.14)
!CC      READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
!CC      READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
!CC      READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
!CC      READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
!CC      READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
!CC      READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
      DO 300 J=1,LP1
        DO 300 I=1,LP1
          CO2PO(I,J) = T22(I,J,1)
!NOV89
          IF (IQ.EQ.5) GO TO 300
!NOV89
          CO2PO1(I,J) = T22(I,J,2)
          CO2PO2(I,J) = T22(I,J,3)
  300 CONTINUE
      DO 301 J=1,LP1
        DO 301 I=1,LP1
          CO2800(I,J) = T23(I,J,1)
!NOV89
          IF (IQ.EQ.5) GO TO 301
!NOV89
          CO2801(I,J) = T23(I,J,2)
          CO2802(I,J) = T23(I,J,3)
  301 CONTINUE
!***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
!   ARE:
!        IQ=1    560-800     (CONSOL.=490-850)
!        IQ=2    560-670     (CONSOL.=490-670)
!        IQ=3    670-800     (CONSOL.=670-850)
!        IQ=4    560-760 (ORIGINAL CODE)   (CONSOL.=490-850)
!NOV89
!        IQ=5   2270-2380    (CONSOL.=2270-2380)
!NOV89
!  THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
!  USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
!  WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
!NOV89
!      NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE
!  COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY
!  ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES
!  (IQ=1,4).  IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE
!  WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS
!  CALCULATIONS.  ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP.
!  DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED.
!NOV89
      IF (IQ.EQ.1) THEN
         C1=1.5
         C2x=0.5
      ENDIF
      IF (IQ.EQ.2) THEN
        C1=18./11.
        C2x=7./11.
      ENDIF
      IF (IQ.EQ.3) THEN
        C1=18./13.
        C2x=5./13.
      ENDIF
      IF (IQ.EQ.4) THEN
        C1=1.8
        C2x=0.8
      ENDIF
!NOV89
      IF (IQ.EQ.5) THEN
        C1=1.0
        C2x=0.0
      ENDIF
!NOV89
      DO 1021 I=1,LP1
      DO 1021 J=1,LP1
      CO2PO(J,I)=C1*CO2PO(J,I)-C2x
      CO2800(J,I)=C1*CO2800(J,I)-C2x
!NOV89
      IF (IQ.EQ.5) GO TO 1021
!NOV89
      CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
      CO2801(J,I)=C1*CO2801(J,I)-C2x
      CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
      CO2802(J,I)=C1*CO2802(J,I)-C2x
1021  CONTINUE
!NOV89
      IF (IQ.GE.1.AND.IQ.LE.4) THEN
!NOV89
      DO 1 J=1,LP1
      DO 1 I=1,LP1
      DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
      DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
      D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
      D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
1     CONTINUE
!NOV89
      ENDIF
!NOV89
!O222 *********************************************************
!CC       REWIND 66
!        SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE
!CC       WRITE (66) DCDT10
!CC       WRITE (66) CO2PO
!CC       WRITE (66) D2CT10
!CC       WRITE (66) DCDT8
!CC       WRITE (66) CO2800
!CC       WRITE (66) D2CT8
!CC       REWIND 66
!NOV89
      IF (IQ.EQ.1.OR.IQ.EQ.4) THEN
!NOV89
      DO 400 J=1,LP1
       DO 400 I=1,LP1
        T66(I,J,1) = DCDT10(I,J)
        T66(I,J,2) = CO2PO(I,J)
        T66(I,J,3) = D2CT10(I,J)
        T66(I,J,4) = DCDT8(I,J)
        T66(I,J,5) = CO2800(I,J)
        T66(I,J,6) = D2CT8(I,J)
  400 CONTINUE
!NOV89
      ELSE
      DO 409 I=1,LP1
        T66(I,1,2) = CO2PO(1,I)
        T66(I,1,5) = CO2800(1,I)
        IF (IQ.EQ.5) GO TO 409
        T66(I,1,1) = DCDT10(1,I)
        T66(I,1,3) = D2CT10(1,I)
        T66(I,1,4) = DCDT8(1,I)
        T66(I,1,6) = D2CT8(1,I)
  409 CONTINUE
      ENDIF
!NOV89
!O222 *********************************************************
      RETURN
      END SUBROUTINE CO2INS
!O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT)
!NOV89

      SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2) 16,10
!NOV89
!     *********************************************************
!       CHANGES TO DATA READ  AND FORMAT SEE CO222     ***
!          ..... K.CAMPANA   MARCH 1988,OCTOBER 1988
!       CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89
!     *********************************************************
!       CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS
!  FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS
!  HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE
!  USER.
!
!        METHOD:
!
!      CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS-
!  SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND
!  2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY
!  OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE
!  THE DIAGRAM AND DISCUSSION BELOW.
!      CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME.
!
!     LET P BE AN ARRAY OF USER-DEFINED PRESSURES
!     AND PD BE USER-DEFINED PRESSURE LAYERS.
!
!       - - - - - - - - -   PD(I-1) ---
!                                     ^
!       -----------------   P(I)      ^  PRESSURE LAYER I  (PLM(I))
!                                     ^
!       - - - - - - - - -   PD(I)  ---
!                                     ^
!       -----------------   P(I+1)    ^  PRESSURE LAYER I+1 (PLM(I+1))
!                                     ^
!       - - - - - - - - -   PD(I+1)---
!            ...                          (THE NOTATION USED IS
!            ...                          CONSISTENT WITH THE CODE)
!            ...
!      - - - - - - - - -    PD(J-1)
!
!      -----------------    P(J)
!
!      - - - - - - - - -    PD(J)
!
!      PURPOSE 1:   THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES
!      P(I) AND P(J) ,TAU(P(I),P(J))  IS COMPUTED BY THIS PROGRAM.
!      IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD
!      (PD,PLM ARE NOT INPUTTED).
!
!      PURPOSE 2:   THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER-
!      MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY
!         TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL
!
!                           PD(I)
!                           ----
!             1             ^
!        -------------  *   ^   TAU ( P',PLM(J) )  DP'
!        PD(I)-PD(I-1)      ^
!                        ----
!                        PD(I-1)
!
!           THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER.
!        FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE
!        PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)).
!           FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS
!        A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN
!        ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION
!        DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT
!        INPUTTED).
!
!            THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS
!       CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC
!       PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED
!       FOR LAYER-MEAN TRANSMISSIVITIES.
!
!          FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE
!      PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID
!     OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED.
!      THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US
!     STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE
!     SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A
!     TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS)
!     BY 25 DEGREES.
!         THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS
!     AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS-
!     MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S.
!     A LOGARITHMIC INTERPOLATION SCHEME IS USED.
!         THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES
!     GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES
!     OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID.
!     THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO-
!     LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD
!     DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE
!     USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES.
!
!     MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES:
!          THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD,
!     AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES
!     (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE
!     DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO
!     PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J)
!     (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR
!     GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)).
!        NOTE:
!     TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT
!     TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING)
!     DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER
!     (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J).
!     THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN
!     THE FIXED PRESSURE PLM(3)  AND THE PRESSURE LAYER HAVING AN AVERAG
!     PRESSURE OF PLM(2).
!         ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER
!     BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE;
!     TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1.
!
!
!             REFERENCE:
!         S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE
!     ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL
!     OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981.
!        MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS;
!     CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R.
!     IS PLANNED TO DOCUMENT THESE CHANGES.
!
!            AUTHOR:    M.DANIEL SCHWARZKOPF
!
!            DATE:      14 JULY 1983
!
!            ADDRESS:
!
!                      G.F.D.L.
!                      P.O.BOX 308
!                      PRINCETON,N.J.08540
!                      U.S.A.
!            TELEPHONE:  (609) 452-6521
!
!            INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE
!        ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS-
!        MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2
!        CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND
!        1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS:
!          FILE 2   1X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
!          FILE 3   1X,CONSOLIDATED WITH NO WEIGHTING FCTN.
!          FILE 4   2X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
!          FILE 5   2X,CONSOLIDATED WITH NO WEIGHTING FCTN.
!          FILE 6   4X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
!          FILE 7   4X,CONSOLIDATED WITH NO WEIGHTING FCTN.
!            FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING
!        TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE
!        COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES
!        DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED
!        TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER
!        CALCULATIONS.
!
!            PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER
!        AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A
!        CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR
!        ADAPTATIONS TO OTHER MACHINES.
!
!          INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
!
!   UNIT NO    VARIABLES       FORMAT      STATEMENT NO.    TYPE
!      5        P (PURPOSE 1)  (5E16.9)        201         CARDS
!      5        PD (PURPOSE 2) (5E16.9)        201         CARDS
!      5        PLM(PURPOSE 2) (5E16.9)        201         CARDS
!      5        NMETHD         (I3)            202         CARDS
!      20       TRANSA         (4F20.14)       102          TAPE
!NOV89
!      ITAPE    TRANSA         (4F20.14)       102          TAPE
!NOV89
!
!         OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
!
!   UNIT NO    VARIABLES       FORMAT     STATEMENT NO.
!      6         TRNFCT        (1X,8F15.8)     301         PRINT
!      22        TRNFCT        (4F20.14)       102          TAPE
!
!            PARAMETER INPUTS:
!     A) NLEVLS    : NLEVLS IS AN (INTEGER) PARAMETER DENOTING
!        THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1
!        OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO
!        SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT
!        GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2.
!        IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO
!        PRESSURE LAYERS=2,SO NLEVLS=2
!           IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD
!        CHANGE THIS VALUE TO A USER-SPECIFIED VALUE.
!     B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1;
!        NLP2=NLEVLS+2.
!           SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER
!        STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE.
!
!            INPUTS:
!
!     A) TRANSA    : THE 109X109 GRID OF TRANSMISSION FUNCTIONS
!            TRANSA IS A  DOUBLE PRECISION REAL ARRAY.
!
!           TRANSA  IS READ FROM FILE 20. THIS FILE CONTAINS 3
!     RECORDS,AS FOLLOWS:
!        1)   TRANSA, STANDARD TEMPERATURE PROFILE
!        3)   TRANSA, STANDARD TEMPERATURES + 25 DEG
!        5)   TRANSA, STANDARD TEMPERATURES - 25 DEG
!
!     B)   NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS
!       TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR
!       PURPOSE 2).
!
!     C)     P,PD,PLM :
!          P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE
!       GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR
!       PURPOSE 1.THE DIMENSION  OF P IS  IN MILLIBARS.THE
!       FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE
!       IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE
!       LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS.
!         PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE
!       LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE
!       TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS
!       FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
!       LIMITATIONS.
!         PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN
!       PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS
!       FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
!       LIMITATIONS.PD IS READ IN BEFORE PLM.
!
!          NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR
!       PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH.
!
!
!
!
!           LIMITATIONS:
!     1)       P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL
!       MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO.
!       THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO
!       QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS
!       NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J),
!       ONE MUST INCLUDE SUCH A LEVEL.
!     2)      PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB.
!       EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE.
!     3)      IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER,
!       SIMPLY DELETE THE LINE.
!     4)      IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING:
!            1) DELETE ALL PARAMETER STATEMENTS IN CO2INT
!            2) AT THE POINT WHERE NMETHOD IS READ IN,ADD:
!                READ (5,202) NLEVLS
!                NLP1=NLEVLS+1
!                NLP2=NLEVLS+2
!            3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING
!              ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT.
!              THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED
!              IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA,
!              P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2)
!              IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS.
!      5)    PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER
!       STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE
!       SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS
!       PARAMETER   NLEVLS=40
!      6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO
!       REQUIREMENTS OF CDC FORTAN.
!      7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF
!       TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO
!       PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT.
!
!     OUTPUT:
!         A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION
!     FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22.
!     THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE
!     OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14).
!
!         B)  PRINTED  OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN
!     THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY
!     MODIFY OR ELIMINATE THIS AT WILL.
!
!      ************   FUNCTION INTERPOLATER ROUTINE  *****************
!
!
!     ******   THE FOLLOWING PARAMETER GIVES THE NUMBER OF     *******
!     ******           DATA LEVELS IN THE MODEL                *******
!     ****************************************************************
!     ****************************************************************
      COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
!     COMMON/PRESS/PA(109)
!     COMMON/TRAN/ TRANSA(109,109)
!     COMMON / OUTPUT / TRNS(NLP1,NLP1)
!     COMMON/INPUTP/P(NLP1),PD(NLP2)
      DIMENSION TRNS(NLP1,NLP1)
      DIMENSION P(NLP1),PD(NLP2)
      DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1)
      DIMENSION NRTAB(3)
      DIMENSION T15A(NLP2,2),T15B(NLP1)
      DIMENSION T22(NLP1,NLP1,3)
      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
      DATA NRTAB/1,2,4/
!***********************************
!   THE FOLLOWING ARE THE INPUT FORMATS
100   FORMAT (4F20.14)
743   FORMAT (F20.14)
201   FORMAT (5E16.9)
202   FORMAT (I3)
!O222   203   FORMAT (F12.6,I2)
203   FORMAT (F12.6)
!    THE FOLLOWING ARE THE OUTPUT FORMATS
102   FORMAT (4F20.14)
301   FORMAT (1X,8F15.8)
!
!CC   REWIND 15
!CC   REWIND 20
!NOV89
      REWIND ITAPE
!NOV89
!CC   REWIND 22
!
!     CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES
!     NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^
      PA(1)=0.
      FACT15=10.**(1./15.)
      FACT30=10.**(1./30.)
      PA(2)=1.0E-3
      DO 231 I=2,76
      PA(I+1)=PA(I)*FACT15
231   CONTINUE
      DO 232 I=77,108
      PA(I+1)=PA(I)*FACT30
232   CONTINUE
!
      N=25
      NLV=NLEVLS
      NLP1V=NLP1
      NLP2V=NLP2
!     READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX
!     GIVING THE FREQUENCY RANGE OF THE LBL DATA
!O222    READ (5,203) RATIO,IR
!CC         IR = 1
!CC         READ (5,203) RATIO
!O222   ***********************************
!***VALUES FOR IR*****
!          IR=1     CONSOL. LBL TRANS. =490-850
!          IR=2     CONSOL. LBL TRANS. =490-670
!          IR=3     CONSOL. LBL TRANS. =670-850
!          IR=4     CONSOL. LBL TRANS. =2270-2380
!*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK
!     ALSO READ IN THE METHOD NO.(1 OR 2)
!CC         READ (5,202) NMETHD
      IF (RATIO.EQ.1.0) GO TO 621
      CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' )
!NOV89  621   ITAP1=20
621   ITAP1=ITAPE
!NOV89
      NTAP=1
      IF (NMETHD.EQ.2) GO TO 502
!   *****CARDS FOR PURPOSE 1(NMETHD=1)
!CC         READ (15,201) (P(I),I=1,NLP1)
      DO 300 I=1,NLP1
        P(I)=T15B(I)
  300 CONTINUE
      DO 801 I=1,NLP1
      PS(I)=P(I)
801   CONTINUE
      GO TO 503
502   CONTINUE
!  *****CARDS FOR PURPOSE 2(NMETHD=2)
!CC         READ (15,201) (PD(I),I=1,NLP2)
!CC         READ (15,201) (PLM(I),I=1,NLP1)
      DO 303 I=1,NLP2
        PD(I)=T15A(I,1)
  303 CONTINUE
      DO 302 I=1,NLP1
        PLM(I)=T15A(I,2)
  302 CONTINUE
      DO 802 I=1,NLP1
      PDS(I)=PD(I+1)
      PS(I)=PLM(I)
802   CONTINUE
!
503   CONTINUE
!  *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES
!NOV89
!NOV89    DO 400 KKK=1,3
      ICLOOP = 3
      IF (IR.EQ.4) ICLOOP = 1
      DO 400 KKK=1,ICLOOP
!NOV89
!  **********************
      IF (NMETHD.EQ.2) GO TO 505
!   *****CARDS FOR PURPOSE 1(NMETHD=1)
      DO 803 I=1,NLP1
      P(I)=PS(I)
803   CONTINUE
      GO TO 506
505   CONTINUE
!  *****CARDS FOR PURPOSE 2(NMETHD=2)
      DO 804 I=1,NLP1
      PD(I)=PDS(I)
      P(I)=PS(I)
804   CONTINUE
!
506   CONTINUE
      IA=108
      IAP=IA+1
!NOV89   IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109)
!mp       IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109)
        IF (NTAP.EQ.1) THEN
           IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109)
           CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE )
        ENDIF
!mp	IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881
!mp
	do J=109,1,-6
!mp	write(6,697)(TRANSA(I,J),I=5,105,10)
	enddo
! 697	format(11(f5.3,1x))
!mp
!NOV89
      DO 4 I=1,IAP
      TRANSA(I,I)=1.0
    4 CONTINUE
      CALL COEINT(RATIO,IR)
      DO 805 I=1,NLP1
      DO 805 J=1,NLP1
      TRNS(J,I)=1.00
805   CONTINUE
      DO 10 I=1,NLP1
      DO 20 J=1,I
      IF (I.EQ.J) GO TO 20
      P1=P(J)
      P2=P(I)
      CALL SINTR2
      TRNS(J,I)=TRNSLO
20    CONTINUE
10    CONTINUE
      DO 47 I=1,NLP1
      DO 47 J=I,NLP1
      TRNS(J,I)=TRNS(I,J)
47    CONTINUE
!  *****THIS IS THE END OF PURPOSE 1 CALCULATIONS
      IF (NMETHD.EQ.1) GO TO 2872
!
      DO 51 J=1,NLP1
      DO 52 I=2,NLP1
      IA=I
      JA=J
      N=25
      IF (I.NE.J) N=3
      CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
52    CONTINUE
51    CONTINUE
!  *****THIS IS THE END OF PURPOSE 2 CALCULATIONS
2872  CONTINUE
!
!+++  WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
!CC         WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
      DO 304 J=1,NLP1
       DO 304 I=1,NLP1
        T22(I,J,KKK) = TRNS(I,J)
  304 CONTINUE
400   CONTINUE
      RETURN
      END SUBROUTINE CO2INT
!CCC  PROGRAM CO2IN1

      SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1) 2
!    CO2IN1=CO2INS FOR METHOD 1
!     *********************************************************
!       SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ***
!          ..... K.CAMPANA   MARCH 1988,OCTOBER 1988
!          ..... K.CAMPANA   DECEMBER 88 CLEANED UP FOR LAUNCHER
!     *********************************************************
      DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6)
      DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
       CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
       CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
      ITIN=20
      ITIN1=21
!O222 LATEST CODE HAS IQ=1
!CC         IQ=4
1011  FORMAT (4F20.14)
!CC        READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
!CC        READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
!CC        READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
!CC        READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
!CC        READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
!CC        READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
      DO 300 J=1,LP1
        DO 300 I=1,LP1
          CO2PO(I,J) = T20(I,J,1)
!NOV89
          IF (IQ.EQ.5) GO TO 300
!NOV89
          CO2PO1(I,J) = T20(I,J,2)
          CO2PO2(I,J) = T20(I,J,3)
  300 CONTINUE
      DO 301 J=1,LP1
        DO 301 I=1,LP1
          CO2800(I,J) = T21(I,J,1)
!NOV89
          IF (IQ.EQ.5) GO TO 301
!NOV89
          CO2801(I,J) = T21(I,J,2)
          CO2802(I,J) = T21(I,J,3)
  301 CONTINUE
!***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
!   ARE:
!        IQ=1    560-800     (CONSOL.=490-850)
!        IQ=2    560-670     (CONSOL.=490-670)
!        IQ=3    670-800     (CONSOL.=670-850)
!        IQ=4    560-760 (ORIGINAL CODE)   (CONSOL.=490-850)
!NOV89
!        IQ=5   2270-2380    (CONSOL.=2270-2380)
!NOV89
!  THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
!  USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
!  WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
      IF (IQ.EQ.1) THEN
         C1=1.5
         C2x=0.5
      ENDIF
      IF (IQ.EQ.2) THEN
        C1=18./11.
        C2x=7./11.
      ENDIF
      IF (IQ.EQ.3) THEN
        C1=18./13.
        C2x=5./13.
      ENDIF
      IF (IQ.EQ.4) THEN
        C1=1.8
        C2x=0.8
      ENDIF
!NOV89
      IF (IQ.EQ.5) THEN
        C1=1.0
        C2x=0.0
      ENDIF
!NOV89
      DO 1021 I=1,LP1
      DO 1021 J=1,LP1
      CO2PO(J,I)=C1*CO2PO(J,I)-C2x
      CO2800(J,I)=C1*CO2800(J,I)-C2x
!NOV89
      IF (IQ.EQ.5) GO TO 1021
!NOV89
      CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
      CO2801(J,I)=C1*CO2801(J,I)-C2x
      CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
      CO2802(J,I)=C1*CO2802(J,I)-C2x
1021  CONTINUE
!NOV89
      IF (IQ.GE.1.AND.IQ.LE.4) THEN
!NOV89
      DO 1 J=1,LP1
      DO 1 I=1,LP1
      DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
      DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
      D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
      D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
1     CONTINUE
!NOV89
      ENDIF
!NOV89
!O222 *********************************************************
!CC          REWIND 66
!        SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE
!CC          WRITE (66) (DCDT10(I,I+1),I=1,L)
!CC          WRITE (66) (CO2PO(I,I+1),I=1,L)
!CC          WRITE (66) (D2CT10(I,I+1),I=1,L)
!CC          WRITE (66) (DCDT8(I,I+1),I=1,L)
!CC          WRITE (66) (CO2800(I,I+1),I=1,L)
!CC          WRITE (66) (D2CT8(I,I+1),I=1,L)
!CC          REWIND 66
!O222 *********************************************************
      DO 400 I=1,L
        T66(I,2) = CO2PO(I,I+1)
        T66(I,5) = CO2800(I,I+1)
!NOV89
        IF (IQ.EQ.5) GO TO 400
!NOV89
        T66(I,1) = DCDT10(I,I+1)
        T66(I,3) = D2CT10(I,I+1)
        T66(I,4) = DCDT8(I,I+1)
        T66(I,6) = D2CT8(I,I+1)
  400 CONTINUE
      RETURN
      END SUBROUTINE CO2IN1
!CCC  PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987....

      SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & 2,14
                        SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2)
!
! **         THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS
! **         AND O3 MIXING RATIOS BY USING AN ANALYTICAL
! **         FUNCTION WHICH APPROXIMATES
! **         THE US STANDARD (1976).  THIS IS
! **         CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE
! **         MAIN PROGRAM.  THE FORM OF THE ANALYTICAL FUNCTION WAS
! **         SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN.
! ******************************************************************
!         CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222  **
!             ....K. CAMPANA MARCH 88,OCTOBER 88
      DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), &
                T43(NLP2,2),T44(NLP)
      DIMENSION SGLVNU(NLP),SIGLNU(NL)
      DIMENSION SFULL(NLP),SHALF(NL)
! ******************************************************************
!
!*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS
!     QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA-
!     TIONAL RADIATION CODES
!
      CHARACTER*20 PROFIL
      DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP)
      DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2)
      DIMENSION PD(NLP2),GTEMP(NLP)
      DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4)
      DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2)
!
!
      DATA PROFIL/ &
         'US STANDARD 1976'/
      DATA PSMAX/1013.250/
!
! **         NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING
! **        VALUES:    0 =SIGMA LEVELS ARE USED;   1= SKYHI L40 LEVELS
! **        ARE USED;   2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0
!
      NTYPE=0
!O222 READ (*,*) NTYPE
    5 NLEV=NL
      DELZAP=0.5
      R=8.31432
      G0=9.80665
      ZMASS=28.9644
      AA=6356.766
         ALT(1)=0.0
         TEMP(1)=ANTEMP(6,0.0)
!*******DETERMINE THE PRESSURES (PRESS)
      PSTAR=PSMAX
!
!***  LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION
!
      LTOP(1)=0
      LTOP(2)=0
      LTOP(3)=0
      DO 30 N=1,NL
        PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10.
        IF(PCLD.GE.642.)LTOP(1)=N
        IF(PCLD.GE.350.)LTOP(2)=N
        IF(PCLD.GE.150.)LTOP(3)=N
!       PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
   30 CONTINUE
!
!O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP)
!O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP)
!O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP)
!CC----      CALL SIGP(PSTAR,PD,GTEMP)
      NLM=NL-1
      CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
                SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2)
      PD(NLP2)=PSTAR
      DO 40 N=1,NLP
      PRSINT(N)=PD(NLP2+1-N)
 40   CONTINUE
!    *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE
      DO 504 NQ=1,4
      DO 505 N=2,NLP
 505  PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N))
      PRESS(1)=PRSINT(1)
!*********************
      DO 100 N=1,NLEV
!
! **         ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT
! **         INTERVALS OF APPROXIMATELY 'DELZAP' KM.
!
      DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1))
      NINT=DLOGP/DELZAP
      NINT=NINT+1
      ZNINT=NINT
!     G=G0
      DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT)
      HT=ALT(N)
!
! **         CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF
! **                   RUNGE-KUTTA INTEGRATION.
!
      DO 200 M=1,NINT
      RK1=ANTEMP(6,HT)*DZ
      RK2=ANTEMP(6,HT+0.5*RK1)*DZ
      RK3=ANTEMP(6,HT+0.5*RK2)*DZ
      RK4=ANTEMP(6,HT+RK3)*DZ
!mp	write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ
      HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4)
  200 CONTINUE
      ALT(N+1)=HT
      TEMP(N+1)=ANTEMP(6,HT)
  100 CONTINUE
      DO 506 N=1,NLP
      TMPINT(N,NQ)=TEMP(N)
      A(N,NQ)=ALT(N)
506   CONTINUE
504   CONTINUE
!O222   *****************************************************
!***OUTPUT TEMPERATURES
!O222   *****************************************************
      DO 901 N=1,NLP
        SGTEMP(N,1) = TMPINT(NLP2-N,1)
  901 CONTINUE
!O222   *****************************************************
!***OUTPUT GTEMP
!O222   *****************************************************
      DO 902 N=1,NLP
        SGTEMP(N,2) = GTEMP(N)
  902 CONTINUE
!O222   *****************************************************
      RETURN
      END SUBROUTINE CO2PTZ

      FUNCTION PATH(A,B,C,E) 4
!....
!     DOUBLE PRECISION XA,CA
!     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
      PEXP=1./SEXP
      PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.))
      RETURN
      END FUNCTION PATH
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F) 8
!....
!     DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL
      D1=(FP-F0)/(XP-X0)
      D2=(FM-F0)/(XM-X0)
      B=(D1-D2)/(XP-XM)
      A=D1-B*(XP-X0)
      DEL=(X-X0)
      F=F0+DEL*(A+DEL*B)
      RETURN
      END SUBROUTINE QINTRP

      SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS) 2,2
      COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
      DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V)
      DIMENSION WT(101)
      N2=2*N
      N2P=2*N+1
!  *****WEIGHTS ARE CALCULATED
      WT(1)=1.
      DO 21 I=1,N
      WT(2*I)=4.
      WT(2*I+1)=1.
21    CONTINUE
      IF (N.EQ.1) GO TO 25
      DO 22 I=2,N
      WT(2*I-1)=2.
22    CONTINUE
25    CONTINUE
      TRNSNB=0.
      DP=(PD(IA)-PD(IA-1))/N2
      PFIX=P(JA)
      DO 1 KK=1,N2P
      PVARY=PD(IA-1)+(KK-1)*DP
      IF (PVARY.GE.PFIX) P2=PVARY
      IF (PVARY.GE.PFIX) P1=PFIX
      IF (PVARY.LT.PFIX) P1=PVARY
      IF (PVARY.LT.PFIX) P2=PFIX
      CALL SINTR2
      TRNSNB=TRNSNB+TRNSLO*WT(KK)
1     CONTINUE
      TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1)))
      RETURN
      END SUBROUTINE QUADSR
!---------------------------------------------------------------------

      SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & 2
                      SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2)
      DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2)
      DIMENSION SIGLY(KD),SIGLV(KP)
      DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM)
      DIMENSION IDATE(4)
      DIMENSION T41(KP2,2),T42(KP), &
                T43(KP2,2),T44(KP)
!     integer :: retval
!     character(50) :: prsmid='prsmid'
!CC   18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL
!CC   DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, &
!CC          .594,.688,.777,.856,.920,.960,.981,.995/
!     FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1),
!     PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.)
!
!.....   GET NMC SIGMA STRUCTURE
!CC   IF (LREAD.GT.0) GO TO 914
!---   PPTOP IS MODEL TOP PRESSURE IN CB....
!        SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A.....
!cccc PPTOP=5.0
!     READ(11,PPTOP,END=12321)
12321 CONTINUE
!     WRITE(6,88221)PPTOP,KD,KP
!88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2)
!     open(unit=23,file='fort.23',form='unformatted' &
!     ,    access='sequential')
!     REWIND 23
!     READ(23)SIGLY
!     DO KKK=1,KD
!      SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD
!     END DO
!     WRITE(6,88222)
!88222 FORMAT(' READ AETA')
!     DO 37821 LLL=1,KD
!     WRITE(6,37820)LLL,SIGLY(LLL)
!37820 FORMAT(' L=',I2,' AETA=',E12.5)
!37821 CONTINUE
!     READ(23)SIGLV
!     DO KKK=1,KP
!      SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD
!     END DO
!     WRITE(6,88223)
!88223 FORMAT(' READ ETA')
!     PRINT 704,(SIGLY(K),K=1,KD)
!     PRINT 704,(SIGLV(K),K=1,KP)
!      DO 37823 LLL=1,KP
!      WRITE(6,37822)LLL,SIGLV(LLL)
!37822 FORMAT(' L=',I2,' ETA=',E12.5)
!37823 CONTINUE
  701 FORMAT(F6.2)
  702 FORMAT(7F10.6)
      IF (PPTOP.LE.0.) GO TO 708
      PSFC=100.
!--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM
!      VERTICAL LOCATION
      DO 706 K=1,KD
       SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC
  706 CONTINUE
      DO 707 K=1,KP
       SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC
  707 CONTINUE
  708 CONTINUE
!     PRINT 703,PPTOP
!     PRINT 704,(SIGLY(K),K=1,KD)
!     PRINT 704,(SIGLV(K),K=1,KP)
  703 FORMAT(1H ,'PTOP =',F6.2)
  704 FORMAT(1H ,7F10.6)
      DO 913 K=1,KP
       SGLVNU(K) = SIGLV(K)
       IF (K.LE.KD) SIGLNU(K) = SIGLY(K)
  913 CONTINUE
      DO 77 K=1,KD
         Q(K) = SIGLNU(KD+1-K)
   77 CONTINUE
      PSS=    1013250.
      QMH(1)=0.
      QMH(KP)=1.
      DO 1 K=2,KD
      QMH(K)=0.5*(Q(K-1)+Q(K))
1     CONTINUE
      PD(1)=0.
      PD(KP2)=PSS
      DO 2 K=2,KP
      PD(K)=Q(K-1)*PSS
2     CONTINUE
!       call int_get_fresh_handle(retval)
!       close(retval)
!       write(0,*)' before open in CO2O3'
!       open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier)
!       write(0,*)' after open1'
!       do k=1,62
!         write(retval)pd(k)
!       enddo
!       close(retval)
      PLM(1)=0.
      DO 3 K=1,KM
      PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
3     CONTINUE
      PLM(KP)=PSS
      DO 4 K=1,KD
      GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250.
4     CONTINUE
      GTEMP(KP)=0.
!+++  WRITE (6,100) (GTEMP(K),K=1,KD)
!+++  WRITE (6,100) (PD(K),K=1,KP2)
!+++  WRITE (6,100) (PLM(K),K=1,KP)
!***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB)
!  THE FOLLOWING PUTS P-DATA INTO MB
      DO 11 I=1,KP
      PD(I)=PD(I)*1.0E-3
      PLM(I)=PLM(I)*1.0E-3
11    CONTINUE
      PD(KP2)=PD(KP2)*1.0E-3
!CC         WRITE (41,101) (PD(K),K=1,KP2)
!CC         WRITE (41,101) (PLM(K),K=1,KP)
!CC         WRITE (42,101) (PLM(K),K=1,KP)
      DO 300 K=1,KP2
       T41(K,1) = PD(K)
  300 CONTINUE
      DO 301 K=1,KP
       T41(K,2) = PLM(K)
       T42(K) = PLM(K)
  301 CONTINUE
!***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ
      DO 12 I=1,KP2
      PDT(I)=PD(I)
12    CONTINUE
!***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED
      PSS=0.8*1013250.
      QMH(1)=0.
      QMH(KP)=1.
      DO 201 K=2,KD
      QMH(K)=0.5*(Q(K-1)+Q(K))
201   CONTINUE
      PD(1)=0.
      PD(KP2)=PSS
      DO 202 K=2,KP
      PD(K)=Q(K-1)*PSS
202   CONTINUE
      PLM(1)=0.
      DO 203 K=1,KM
      PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
203   CONTINUE
      PLM(KP)=PSS
!+++  WRITE (6,100) (PD(K),K=1,KP2)
!+++  WRITE (6,100) (PLM(K),K=1,KP)
!***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB)
!  THE FOLLOWING PUTS P-DATA INTO MB
      DO 211 I=1,KP
      PD(I)=PD(I)*1.0E-3
      PLM(I)=PLM(I)*1.0E-3
211   CONTINUE
      PD(KP2)=PD(KP2)*1.0E-3
!CC       WRITE (43,101) (PD(K),K=1,KP2)
!CC       WRITE (43,101) (PLM(K),K=1,KP)
!CC       WRITE (44,101) (PLM(K),K=1,KP)
      DO 302 K=1,KP2
       T43(K,1) = PD(K)
  302 CONTINUE
      DO 303 K=1,KP
       T43(K,2) = PLM(K)
       T44(K) = PLM(K)
  303 CONTINUE
!***RESTORE PD
      DO 212 I=1,KP2
      PD(I)=PDT(I)
212   CONTINUE
100   FORMAT (1X,5E20.13)
101   FORMAT (5E16.9)
      RETURN
      END SUBROUTINE SIGP
!---------------------------------------------------------------------

      SUBROUTINE SINTR2 4,8
!....
!     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!     REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
      COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
!     COMMON/PRESS/ PA(109)
!     COMMON/TRAN/ TRANSA(109,109)
!     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
      DO 70 L=1,109
      IP1=L
      IF (P2-PA(L)) 65,65,70
   70 CONTINUE
   65 I=IP1-1
      IF (IP1.EQ.1) IP1=2
      IF (I.EQ.0) I=1
      DO 80 L=1,109
      JP1=L
      IF (P1-PA(L)) 75,75,80
   80 CONTINUE
   75 J=JP1-1
      IF (JP1.EQ.1) JP1=2
      IF (J.EQ.0) J=1
      JJJ=J
      III=I
      J=JJJ
      JP1=J+1
      I=III
      IP1=I+1
!  DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION
!    FOR PETA(=0.5*(P1+P2))
      PETA=P2
      DO 90 L=1,109
      IETAP1=L
      IF (PETA-PA(L)) 85,85,90
90    CONTINUE
85    IETA=IETAP1-1
      IF (IETAP1.EQ.1) IETAP1=2
      IF (IETA.EQ.0) IETA=1
      ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ &
       (PA(IETAP1)-PA(IETA))
      SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- &
       SEXPV(IETA))/ (PA(IETAP1)-PA(IETA))
      PIPMPI=PA(IP1)-PA(I)
      UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP
      IF (I-J) 126,126,127
  126 CONTINUE
      TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP)
      TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP)
      TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI
      GO TO 128
  127 TIJ=TRANSA(I,J)
      TIPJ=TRANSA(I+1,J)
      TIJP=TRANSA(I,J+1)
      TIPJP=TRANSA(I+1,J+1)
      UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP
      UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP
      UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP
      UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP
      PRODI=CA(I)*XA(I)
      PRODIP=CA(I+1)*XA(I+1)
      PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI
      XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI
      CINT=PROD/XINT
      AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP)
      AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP)
      AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP)
      AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP)
      EIJ=TIJ+AIJ
      EIPJ=TIPJ+AIPJ
      EIJP=TIJP+AIJP
      EIPJP=TIPJP+AIPJP
      DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J))
      DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J))
      EPIP1=EIJ+DTDJ*(P1-PA(J))
      EPIPP1=EIPJ+DTDPJ*(P1-PA(J))
      EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI
      TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
      IF (I.GE.108.OR.J.GE.108) GO TO 350
      IF (I-J-2) 350,350,355
355   CONTINUE
      TIP2J=TRANSA(I+2,J)
      TIP2JP=TRANSA(I+2,J+1)
      TI2J2=TRANSA(I+2,J+2)
      TIJP2=TRANSA(I,J+2)
      TIPJP2=TRANSA(I+1,J+2)
      UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP
      UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP
      UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP
      UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP
      UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP
      AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP)
      AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP)
      AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP)
      AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP)
      AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP)
      EIP2J=TIP2J+AIP2J
      EIP2JP=TIP2JP+AIP2JP
      EIJP2=TIJP2+AIJP2
      EIPJP2=TIPJP2+AIPJP2
      EI2J2=TI2J2+AI2J2
      CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI)
      CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP)
      CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2)
      CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL)
      TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
  350 CONTINUE
  128 CONTINUE
  205 CONTINUE
      RETURN
      END SUBROUTINE SINTR2

      SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2) 3,44
!CCC  PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL
!                     CODES TO PRODUCE A FILE OF CO2 HGT DATA
!                     FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE
!                     CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89.
!NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C.
      LOGICAL                 :: opened
      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
      CHARACTER*80 errmess
!     integer :: retval,kk,ka,kb
!     character(50) :: co2='co2'
      INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR
      DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6)
!NOV89
      DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6)
!NOV89
      DIMENSION T41(LP2,2),T42(LP1), &
                T43(LP2,2),T44(LP1)
      DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3)
      DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3)
      DIMENSION SGLVNU(LP1),SIGLNU(L)
      DIMENSION SFULL(LP1),SHALF(L)
!     DIMENSION STEMP(LP1),GTEMP(LP1)
!     DIMENSION CDTM51(L),CO2M51(L),C2DM51(L)
!     DIMENSION CDTM58(L),CO2M58(L),C2DM58(L)
!     DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1)
!     DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1)
!NOV89
!     DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1)
!     DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1)
!     DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1)
!     DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1)
!     DIMENSION CO211(LP1),CO218(LP1)
!     EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2))
!     EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4))
!     EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6))
!     EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2))
!     EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4))
!     EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6))
!     EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5))
!NOV89
!     EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2))
!     EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2))
!     EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4))
!     EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6))
!     EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2))
!     EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4))
!     EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6))

!
!    Deallocate before reading. This is required for nested domain init.
!
      IF(ALLOCATED (CO251))DEALLOCATE(CO251)
      IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
      IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
      IF(ALLOCATED (CO258))DEALLOCATE(CO258)
      IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
      IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
      IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
      IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
      IF(ALLOCATED (CO231))DEALLOCATE(CO231)
      IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
      IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
      IF(ALLOCATED (CO238))DEALLOCATE(CO238)
      IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
      IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
      IF(ALLOCATED (CO271))DEALLOCATE(CO271)
      IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
      IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
      IF(ALLOCATED (CO278))DEALLOCATE(CO278)
      IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
      IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
      IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
      IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
      IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
      IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
      IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
      IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
!
      ALLOCATE(CO251(LP1,LP1))
      ALLOCATE(CDT51(LP1,LP1))
      ALLOCATE(C2D51(LP1,LP1))
      ALLOCATE(CO258(LP1,LP1))
      ALLOCATE(CDT58(LP1,LP1))
      ALLOCATE(C2D58(LP1,LP1))
      ALLOCATE(STEMP(LP1))
      ALLOCATE(GTEMP(LP1))
      ALLOCATE(CO231(LP1))
      ALLOCATE(CDT31(LP1))
      ALLOCATE(C2D31(LP1))
      ALLOCATE(CO238(LP1))
      ALLOCATE(CDT38(LP1))
      ALLOCATE(C2D38(LP1))
      ALLOCATE(CO271(LP1))
      ALLOCATE(CDT71(LP1))
      ALLOCATE(C2D71(LP1))
      ALLOCATE(CO278(LP1))
      ALLOCATE(CDT78(LP1))
      ALLOCATE(C2D78(LP1))
      ALLOCATE(CO2M51(L))
      ALLOCATE(CDTM51(L))
      ALLOCATE(C2DM51(L))
      ALLOCATE(CO2M58(L))
      ALLOCATE(CDTM58(L))
      ALLOCATE(C2DM58(L))
      IF ( wrf_dm_on_monitor() ) THEN
        DO i = 61,99
          INQUIRE ( i , OPENED = opened )
          IF ( .NOT. opened ) THEN
            etarad_unit61 = i
            GOTO 2061
          ENDIF
        ENDDO
        etarad_unit61 = -1
 2061   CONTINUE
        DO i = 62,99
          INQUIRE ( i , OPENED = opened )
          IF ( .NOT. opened ) THEN
            etarad_unit62 = i
            GOTO 2062
          ENDIF
        ENDDO
        etarad_unit62 = -1
 2062   CONTINUE
        DO i = 63,99
          INQUIRE ( i , OPENED = opened )
          IF ( .NOT. opened ) THEN
            etarad_unit63 = i
            GOTO 2063
          ENDIF
        ENDDO
        etarad_unit63 = -1
 2063   CONTINUE
      ENDIF
      CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE )
      IF ( etarad_unit61 < 0 ) THEN
        CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
      ENDIF
      CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE )
      IF ( etarad_unit62 < 0 ) THEN
        CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
      ENDIF
      CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE )
      IF ( etarad_unit63 < 0 ) THEN
        CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
      ENDIF
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(etarad_unit61,FILE='tr49t85',                  &
               FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR)
        ENDIF
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(etarad_unit62,FILE='tr49t67',                  &
               FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR)
        ENDIF
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(etarad_unit63,FILE='tr67t85',                  &
               FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR)
        ENDIF

!===>  GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44....
      LREAD = 0
!     DO KKK=1,L
!JD      READ(23)SIGLNU(KKK)
!      SIGLNU(KKK)=1.-FLOAT(KKK)/LP1
!     END DO
      CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
                  SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2)
!       call int_get_fresh_handle(retval)
!       close(retval)
!       open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier)
!       do kk=1,2
!         write(retval)(sgtemp(k,kk),k=1,61)
!       enddo
      DO K=1,LP1
        STEMP(K)=SGTEMP(K,1)
        GTEMP(K)=SGTEMP(K,2)
      ENDDO
!===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
!         IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE...
!           FOR THE CONSOLIDATED 490-850 CM-1 BAND...
!NOV89
!     ICO2TP=61
      ICO2TP=etarad_unit61
!NOV89
      IR = 1
      RATIO = 1.0
      NMETHD = 2
      CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
      IR = 1
      RATIO = 1.0
      NMETHD = 1
      CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2)
      IR = 1
      RATIO = 1.0
      NMETHD = 2
      CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
      IR = 1
      RATIO = 1.0
      NMETHD = 1
      CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2)
!===>    FILL UP THE CO2D1D ARRAY
!       THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND
!         THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS,
!         WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE
!         ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE
!         ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O..
!
      IQ = 1
      CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1)
!       do kk=1,6
!         write(retval)(co2d1d(k,kk),k=1,60)
!       enddo
      DO K=1,L
        CDTM51(K)=CO2D1D(K,1)
        CO2M51(K)=CO2D1D(K,2)
        C2DM51(K)=CO2D1D(K,3)
        CDTM58(K)=CO2D1D(K,4)
        CO2M58(K)=CO2D1D(K,5)
        C2DM58(K)=CO2D1D(K,6)
      ENDDO
!
!===>    FILL UP THE CO2D2D ARRAY
!    THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
!        FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
!        MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
!        TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A
!        200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
!        SCHWARZKOPF AND FELS (J.G.R.,1985).
!
      CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1)
!       do kk=1,6
!         write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61)
!       enddo
      DO K1=1,LP1
      DO K2=1,LP1
        CDT51(K1,K2)=CO2D2D(K1,K2,1)
        CO251(K1,K2)=CO2D2D(K1,K2,2)
        C2D51(K1,K2)=CO2D2D(K1,K2,3)
        CDT58(K1,K2)=CO2D2D(K1,K2,4)
        CO258(K1,K2)=CO2D2D(K1,K2,5)
        C2D58(K1,K2)=CO2D2D(K1,K2,6)
      ENDDO
      ENDDO
!
!NOV89
!===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
!         IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE...
!           FOR THE CONSOLIDATED 490-670 CM-1 BAND...
!     ICO2TP=62
      ICO2TP=etarad_unit62
      IR = 2
      RATIO = 1.0
      NMETHD = 2
      CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
      CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
      IQ = 2
      CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2)
!       do kk=1,6
!         write(retval)(co2iq2(k,1,kk),k=1,61)
!       enddo
      DO K=1,LP1
        CDT31(K)=CO2IQ2(K,1,1)
        CO231(K)=CO2IQ2(K,1,2)
        C2D31(K)=CO2IQ2(K,1,3)
        CDT38(K)=CO2IQ2(K,1,4)
        CO238(K)=CO2IQ2(K,1,5)
        C2D38(K)=CO2IQ2(K,1,6)
      ENDDO
!===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
!         IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE...
!           FOR THE CONSOLIDATED 670-850 CM-1 BAND...
!     ICO2TP=63
      ICO2TP=etarad_unit63
      IR = 3
      RATIO = 1.0
      NMETHD = 2
      CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
      CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
      IQ = 3
      CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3)
!       do kk=1,6
!         write(retval)(co2iq3(k,1,kk),k=1,61)
!       enddo
!       close(retval)
      DO K=1,LP1
        CDT71(K)=CO2IQ3(K,1,1)
        CO271(K)=CO2IQ3(K,1,2)
        C2D71(K)=CO2IQ3(K,1,3)
        CDT78(K)=CO2IQ3(K,1,4)
        CO278(K)=CO2IQ3(K,1,5)
        C2D78(K)=CO2IQ3(K,1,6)
      ENDDO
!---      FOLLOWING CODE NOT WORKING AND NOT NEEDED YET
!===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
!         IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE...
!           FOR THE 4.3 MICRON BAND...
! NOT USED YET      ICO2TP=65
! NOT USED YET      IR = 4
! NOT USED YET      RATIO = 1.0
! DAN SCHWARZ --- USE 300PPMV  RATIO = 0.9091   (NOT TESTED YET).....
! NOT USED YET      NMETHD = 2
! NOT USED YET      CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD)
! NOT USED YET      CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD)
! NOT USED YET      IQ = 5
! NOT USED YET      CALL CO2INS(T22,T23,CO2IQ5,IQ)
!NOV89
!...     WRITE DATA TO DISK..
!            ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA
!               IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP..

! NOT USED YET      WRITE(66) CO211
! NOT USED YET      WRITE(66) CO218
!NOV89
         IF ( wrf_dm_on_monitor() ) THEN
           CLOSE (etarad_unit61)
           CLOSE (etarad_unit62)
           CLOSE (etarad_unit63)
         ENDIF

      RETURN
9061 CONTINUE
     WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t85 on unit ',etarad_unit61
     write(0,*)' IERROR=',IERROR
     CALL wrf_error_fatal(errmess)
9062 CONTINUE
     WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t67 on unit ',etarad_unit62
     write(0,*)' IERROR=',IERROR
     CALL wrf_error_fatal(errmess)
9063 CONTINUE
     WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr67t85 on unit ',etarad_unit63
     write(0,*)' IERROR=',IERROR
     CALL wrf_error_fatal(errmess)
      END SUBROUTINE CO2O3


!!================================================================================
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE) 2,13
!----------------------------------------------------------------------
!    *******************************************************************
!    *                           C O N R A D                           *
!    *    READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL  *
!    *      COORDINATE TESTS      ...                                  *
!    *    THESE ARRAYS USED TO BE IN BLOCK DATA    ...K.CAMPANA-MAR 90 *
!    *******************************************************************
!
!----------------------------------------------------------------------
      IMPLICIT NONE
!----------------------------------------------------------------------
      INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
!----------------------------------------------------------------------
!
      INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE
      INTEGER,DIMENSION(3) :: RSZE
!
      REAL,DIMENSION(KMS:KME-1,6) :: CO21D
      REAL,DIMENSION(KMS:KME,2) :: SGTMP
      REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7
      REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D
      REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2
      LOGICAL :: OPENED
      LOGICAL,EXTERNAL :: wrf_dm_on_monitor
      CHARACTER*80 errmess
      character*255 message
!
!----------------------------------------------------------------------
!
!                 CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE
!
!   THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION
!       FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND
!       SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985),
!-----  THE 2-DIMENSIONAL ARRAYS ARE
!                    CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
!        FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
!        MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
!        TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A
!        200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
!        SCHWARZKOPF AND FELS (J.G.R.,1985).
!-----  THE 1-DIM ARRAYS ARE
!                  CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
!          FOR TAU(I,I+1),I=1,L,
!            WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE
!            ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES.
!          THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O.
!-----  THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
!         1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW)  L18 DATA LEVELS FOR
!         PSTAR=1013250.
!-----  STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS
!        USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM)
!
!***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
!   AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED
!   ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE
!   DATA ARE IN BLOCK DATA BD3:
!         CO251    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                       WITH P(SFC)=1013.25 MB
!         CO258    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
!                       WITH P(SFC)= 810 MB
!         CDT51    =  FIRST TEMPERATURE DERIVATIVE OF CO251
!         CDT58    =  FIRST TEMPERATURE DERIVATIVE OF CO258
!         C2D51    =  SECOND TEMPERATURE DERIVATIVE OF CO251
!         C2D58    =  SECOND TEMPERATURE DERIVATIVE OF CO251
!         CO2M51   =  TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE
!                        LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR
!                        NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB
!         CO2M58   =  SAME AS CO2M51,WITH P(SFC)= 810 MB
!         CDTM51   =  FIRST TEMPERATURE DERIVATIVE OF CO2M51
!         CDTM58   =  FIRST TEMPERATURE DERIVATIVE OF CO2M58
!         C2DM51   =  SECOND TEMPERATURE DERIVATIVE OF CO2M51
!         C2DM58   =  SECOND TEMPERATURE DERIVATIVE OF CO2M58
!         STEMP    =  STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL
!                        STRUCTURE WITH P(SFC)=1013.25 MB
!         GTEMP    =  WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL
!                        STRUCTURE WITH P(SFC)=1013.25 MB.
!-----       THE FOLLOWING ARE STILL IN BLOCK DATA
!         B0       =  TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN.
!                        CORRECTION FOR T(K). (SEE REF. 4 AND BD3)
!         B1       =  TEMP. COEFFICIENT, USED ALONG WITH B0
!         B2       =  TEMP. COEFFICIENT, USED ALONG WITH B0
!         B3       =  TEMP. COEFFICIENT, USED ALONG WITH B0
!
!***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
!   AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM
!   CO2 BAND.  THESE DATA ARE IN BLOCK DATA BD2.
!     FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE
!     THESE ARE USED FOR CTS COMPUTATIONS.
!         CO231    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                       WITH P(SFC)=1013.25 MB
!         CO238    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
!                       WITH P(SFC)= 810 MB
!         CDT31    =  FIRST TEMPERATURE DERIVATIVE OF CO231
!         CDT38    =  FIRST TEMPERATURE DERIVATIVE OF CO238
!         C2D31    =  SECOND TEMPERATURE DERIVATIVE OF CO231
!         C2D38    =  SECOND TEMPERATURE DERIVATIVE OF CO231
!
!***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
!   AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM
!   CO2 BAND.  THESE DATA ARE IN BLOCK DATA BD4.
!         CO271    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                       WITH P(SFC)=1013.25 MB
!         CO278    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
!                       WITH P(SFC)= 810 MB
!         CDT71    =  FIRST TEMPERATURE DERIVATIVE OF CO271
!         CDT78    =  FIRST TEMPERATURE DERIVATIVE OF CO278
!         C2D71    =  SECOND TEMPERATURE DERIVATIVE OF CO271
!         C2D78    =  SECOND TEMPERATURE DERIVATIVE OF CO271
!
! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION *******
!
! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270-
!       2380 PART OF THE 4.3 UM CO2 BAND.
!              THESE DATA ARE IN BLOCK DATA BD5.
!         CO211    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
!                        WITH P(SFC)=1013.25 MB
!         CO218    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
!                       WITH P(SFC)= 810 MB
!
! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION ***********
!----------------------------------------------------------------------
!
      L=KME-KMS
      LP1=KME-KMS+1
!
!----------------------------------------------------------------------
      IF ( wrf_dm_on_monitor() ) THEN
        DO i = 14,99
      write(message,*)' in CONRAD i=',i,' opened=',opened
      call wrf_debug(1,message)
          INQUIRE ( i , OPENED = opened )
          IF ( .NOT. opened ) THEN
            nunit_co2 = i
            GOTO 2014
          ENDIF
        ENDDO
        nunit_co2 = -1
 2014   CONTINUE
      ENDIF
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(nunit_co2,FILE='co2_trans',                  &
               FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR)
          REWIND NUNIT_CO2
        ENDIF

!----------------------------------------------------------------------
!
!***  READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.
!
      RSZE(1) = LP1
      RSZE(2) = L
      RSZE(3) = LP1*LP1
!----------------------------------------------------------------------
!
      RSIZE = RSZE(1)
!
      DO KK=1,2
        IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE)
        CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE )
      ENDDO
!
!----------------------------------------------------------------------
!
      RSIZE = RSZE(2)
!
      DO KK=1,6
        IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE)
        CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE )
      ENDDO
!
!----------------------------------------------------------------------
!
      RSIZE = RSZE(3)
!
      DO KK=1,6
        IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE)
        CALL wrf_dm_bcast_real( DATA2(1), RSIZE )
        N=0
!
        DO I1=1,LP1
        DO I2=1,LP1
          N=N+1
          CO22D(I1,I2,KK)=DATA2(N)
        ENDDO
        ENDDO
!
      ENDDO

!
!    Deallocate before reading. This is required for nested domain init.
!
      IF(ALLOCATED (CO251))DEALLOCATE(CO251)
      IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
      IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
      IF(ALLOCATED (CO258))DEALLOCATE(CO258)
      IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
      IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
      IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
      IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
      IF(ALLOCATED (CO231))DEALLOCATE(CO231)
      IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
      IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
      IF(ALLOCATED (CO238))DEALLOCATE(CO238)
      IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
      IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
      IF(ALLOCATED (CO271))DEALLOCATE(CO271)
      IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
      IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
      IF(ALLOCATED (CO278))DEALLOCATE(CO278)
      IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
      IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
      IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
      IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
      IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
      IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
      IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
      IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
!
!----------------------------------------------------------------------
!
      RSIZE = RSZE(1)
!
      DO KK=1,6
        IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE)
        CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE )
      ENDDO
!
!----------------------------------------------------------------------
!
      DO KK=1,6
        IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE)
        CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE )
      ENDDO
!
!----------------------------------------------------------------------
      ALLOCATE(CO251(LP1,LP1))
      ALLOCATE(CDT51(LP1,LP1))
      ALLOCATE(C2D51(LP1,LP1))
      ALLOCATE(CO258(LP1,LP1))
      ALLOCATE(CDT58(LP1,LP1))
      ALLOCATE(C2D58(LP1,LP1))
      ALLOCATE(STEMP(LP1))
      ALLOCATE(GTEMP(LP1))
      ALLOCATE(CO231(LP1))
      ALLOCATE(CDT31(LP1))
      ALLOCATE(C2D31(LP1))
      ALLOCATE(CO238(LP1))
      ALLOCATE(CDT38(LP1))
      ALLOCATE(C2D38(LP1))
      ALLOCATE(CO271(LP1))
      ALLOCATE(CDT71(LP1))
      ALLOCATE(C2D71(LP1))
      ALLOCATE(CO278(LP1))
      ALLOCATE(CDT78(LP1))
      ALLOCATE(C2D78(LP1))
      ALLOCATE(CO2M51(L))
      ALLOCATE(CDTM51(L))
      ALLOCATE(C2DM51(L))
      ALLOCATE(CO2M58(L))
      ALLOCATE(CDTM58(L))
      ALLOCATE(C2DM58(L))
!----------------------------------------------------------------------
!
      DO K=1,LP1
        STEMP(K) = SGTMP(K,1)
        GTEMP(K) = SGTMP(K,2)
      ENDDO
!
      DO K=1,L
        CDTM51(K) = CO21D(K,1)
        CO2M51(K) = CO21D(K,2)
        C2DM51(K) = CO21D(K,3)
        CDTM58(K) = CO21D(K,4)
        CO2M58(K) = CO21D(K,5)
        C2DM58(K) = CO21D(K,6)
      ENDDO
!
      DO J=1,LP1
      DO I=1,LP1
        CDT51(I,J) = CO22D(I,J,1)
        CO251(I,J) = CO22D(I,J,2)
        C2D51(I,J) = CO22D(I,J,3)
        CDT58(I,J) = CO22D(I,J,4)
        CO258(I,J) = CO22D(I,J,5)
        C2D58(I,J) = CO22D(I,J,6)
      ENDDO
      ENDDO
!
      DO K=1,LP1
        CDT31(K) = CO21D3(K,1)
        CO231(K) = CO21D3(K,2)
        C2D31(K) = CO21D3(K,3)
        CDT38(K) = CO21D3(K,4)
        CO238(K) = CO21D3(K,5)
        C2D38(K) = CO21D3(K,6)
      ENDDO
!
      DO K=1,LP1
        CDT71(K) = CO21D7(K,1)
        CO271(K) = CO21D7(K,2)
        C2D71(K) = CO21D7(K,3)
        CDT78(K) = CO21D7(K,4)
        CO278(K) = CO21D7(K,5)
        C2D78(K) = CO21D7(K,6)
      ENDDO
!
!----------------------------------------------------------------------
      IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2
   66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2)
!----------------------------------------------------------------------
      IF( wrf_dm_on_monitor() )THEN
        CLOSE(nunit_co2)
      ENDIF
      RETURN
!
9014 CONTINUE
     WRITE(errmess,'(A51,I4)')'module_ra_gfdleta: error reading co2_trans on unit ',nunit_co2
     CALL wrf_error_fatal(errmess)
!----------------------------------------------------------------------
      END SUBROUTINE CONRAD
!+---+-----------------------------------------------------------------+
! Replacement routine to compute saturation vapor pressure over
! water/ice.  This is needed here in case we run microphysics other
! than ETAMPNEW (Ferrier) because it initializes a lookup table to
! facilitate calculations of FVPS.  For speed, we use the polynomial
! expansion of Flatau & Walko, 1989.
!+---+-----------------------------------------------------------------+

      REAL FUNCTION FPVS_new(T) 1,2

      IMPLICIT NONE
      REAL, INTENT(IN):: T

      if (T .ge. 273.16) then
         FPVS_new = e_sub_l(T)
      else
         FPVS_new = e_sub_i(T)
      endif

      END FUNCTION FPVS_new
!
!+---+-----------------------------------------------------------------+
! THIS FUNCTION CALCULATES THE LIQUID SATURATION PRESSURE AS
! A FUNCTION OF TEMPERATURE.
!

      REAL FUNCTION e_sub_l(T) 1

      IMPLICIT NONE
      REAL, INTENT(IN):: T
      REAL:: ESL,X
      REAL, PARAMETER:: C0= .611583699E03
      REAL, PARAMETER:: C1= .444606896E02
      REAL, PARAMETER:: C2= .143177157E01
      REAL, PARAMETER:: C3= .264224321E-1
      REAL, PARAMETER:: C4= .299291081E-3
      REAL, PARAMETER:: C5= .203154182E-5
      REAL, PARAMETER:: C6= .702620698E-8
      REAL, PARAMETER:: C7= .379534310E-11
      REAL, PARAMETER:: C8=-.321582393E-13

      X=AMAX1(-80.,T-273.16)

      ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))

      e_sub_l = ESL

      END FUNCTION e_sub_l
!
!+---+-----------------------------------------------------------------+
! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR PRESSURE AS A
! FUNCTION OF TEMPERATURE.
!

      REAL FUNCTION e_sub_i(T) 1

      IMPLICIT NONE
      REAL, INTENT(IN):: T
      REAL:: ESI,X
      REAL, PARAMETER:: C0= .609868993E03
      REAL, PARAMETER:: C1= .499320233E02
      REAL, PARAMETER:: C2= .184672631E01
      REAL, PARAMETER:: C3= .402737184E-1
      REAL, PARAMETER:: C4= .565392987E-3
      REAL, PARAMETER:: C5= .521693933E-5
      REAL, PARAMETER:: C6= .307839583E-7
      REAL, PARAMETER:: C7= .105785160E-9
      REAL, PARAMETER:: C8= .161444444E-12

      X=AMAX1(-80.,T-273.16)
      ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))

      e_sub_i = ESI

      END FUNCTION e_sub_i

!

!----------------------------------------------------------------------
!
      END MODULE module_RA_GFDLETA
!
!----------------------------------------------------------------------