
                        MODULE LONGWAVE_MOD

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

      USE RDPARM_MOD, ONLY: LMAX
      USE RDPARM_MOD, ONLY: LM1,LP1,LP2,LL,LLP1,LLM1,LP1M,LP1V,LL3P
      USE RDPARM_MOD, ONLY: NBLW,NBLX,NBLY,NBLM,INLTE,INLTEP,NNLTE

      USE HCONST_MOD, ONLY: DIFFCTR,GINV,P0,P0INV,GP0INV,P0XZP2,P0XZP8
      USE HCONST_MOD, ONLY: RADCON,RADCON1,RATH2OMW,SECPDA

      Use    FMS_Mod, ONLY:  Error_Mesg, FATAL, NOTE, mpp_pe, &
                             mpp_root_pe, write_version_number

      Use CO2_Data_Mod, ONLY:  CO251,CO258,CDT51,CDT58,C2D51,C2D58, &
                               CO2M51,CO2M58,CDTM51,CDTM58,C2DM51,  &
                               C2DM58, STEMP,GTEMP, B0,B1,B2,B3
      Use CO2_Data_Mod, ONLY:  CO231,CO238,CDT31,CDT38,C2D31,C2D38
      Use CO2_Data_Mod, ONLY:  CO271,CO278,CDT71,CDT78,C2D71,C2D78
      Use CO2_Data_Mod, ONLY:  CO211,CO218


!     -----------------------------------------------------------
implicit none
private

!-----------------------------------------------------------------------
!--------------------- G L O B A L   D A T A ---------------------------
!-----------------------------------------------------------------------
!
!    Random band parameters for the longwave calcualtions using
!    10 cm-1 wide bands. The 15 um co2 complex is 2 bands,
!    560-670 and 670-800 cm-1. Ozone coefficients are in 3 bands,
!    670-800 (14.1 um), 990-1070 and 1070-1200 (9.6 um).
!    The (NBLW) bands now include: 
!
!                56 BANDS, 10  CM-1 WIDE    0  -   560  CM-1
!                 2 BANDS, 15 UM COMPLEX  560  -   670  CM-1
!                                         670  -   800  CM-1
!                 3 "CONTINUUM" BANDS     800  -   900  CM-1
!                                         900  -   990  CM-1
!                                        1070  -   1200 CM-1
!                 1 BAND FOR 9.6 UM BAND  990  -   1070 CM-1
!               100 BANDS, 10 CM-1 WIDE  1200  -   2200 CM-1
!                 1 BAND FOR 4.3 UM SRC  2270  -   2380 CM-1
!
!    Thus NBLW presently equals    163
!    All bands are arranged in order of increasing wavenumbers.
! 
!      ARNDM   =   RANDOM "A" PARAMETER FOR (NBLW) BANDS
!      BRNDM   =   RANDOM "B" PARAMETER FOR (NBLW) BANDS
!      BETAD   =   CONTINUUM COEFFICIENTS FOR (NBLW) BANDS
!      AP,BP   =   CAPPHI COEFFICIENTS FOR (NBLW) BANDS 
!      ATP,BTP =   CAPPSI COEFFICIENTS FOR (NBLW) BANDS 
!      BANDLO  =   LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS 
!      BANDHI  =   HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS
!      AO3RND  =   RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE
!                  BANDS.
!      BO3RND  =   RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE
!                  BANDS
!      AB15    =   THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS
!                  REPRESENTING THE 15 UM BAND COMPLEX OF CO2 
!
!     Data for ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND are obtained
!     by using the AFGL 1982 catalog. Continuum coefficients are from
!     Roberts (1976). This data was formerly in COMMON /BANDTA/.

      REAL  ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW), &
            BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW),    &
            BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2)

!     ----------------------------------------------------------
!     The following data statements are band parameters obtained
!     using the 1982 AFGL catalog on the specified bands.
!     ----------------------------------------------------------

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

      integer :: i
      DATA (ARNDM(i),i=1,64) /                                      &
         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 (ARNDM(i),i=65,128)  /                                   &
         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 (ARNDM(i),i=129,163)  /                                  &
         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 (BRNDM(i),i=1,64)  /                                     &
         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 (BRNDM(i),i=65,128)  /                                   &
         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 (BRNDM(i),i=129,163)  /                                  &
         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 (BANDLO(i),i=1,64)  /                                    &
         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 (BANDLO(i),i=65,128)  /                                  &
         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 (BANDLO(i),i=129,163)  /                                 &
         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 (BANDHI(i),i=1,64)  /                                    &
         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 (BANDHI(i),i=65,128)  /                                  &
         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 (BANDHI(i),i=129,163)  /                                 &
         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/

      DATA (AP(i),i=1,64)  /                                        &
        -0.675950E-02, -0.909459E-02, -0.800214E-02, -0.658673E-02, &
        -0.245580E-02, -0.710464E-02, -0.205565E-02, -0.446529E-02, &
        -0.440265E-02, -0.593625E-02, -0.201913E-02, -0.349169E-02, &
        -0.209324E-02, -0.127980E-02, -0.388007E-02, -0.140542E-02, &
         0.518346E-02, -0.159375E-02,  0.250508E-02,  0.132182E-01, &
        -0.903779E-03,  0.110959E-01,  0.924528E-03,  0.207428E-01, &
         0.364166E-02,  0.365229E-02,  0.884367E-02,  0.617260E-02, &
         0.701340E-02,  0.184265E-01,  0.992822E-02,  0.908582E-02, &
         0.106581E-01,  0.276268E-02,  0.158414E-01,  0.145747E-01, &
         0.453080E-02,  0.214767E-01,  0.553895E-02,  0.195031E-01, &
         0.237016E-01,  0.112371E-01,  0.275977E-01,  0.188833E-01, &
         0.131079E-01,  0.130019E-01,  0.385122E-01,  0.111768E-01, &
         0.622620E-02,  0.194397E-01,  0.134360E-01,  0.207829E-01, &
         0.147960E-01,  0.744479E-02,  0.107564E-01,  0.181562E-01, &
         0.170062E-01,  0.233303E-01,  0.256735E-01,  0.274745E-01, &
         0.279259E-01,  0.197002E-01,  0.140268E-01,  0.185933E-01/
      DATA (AP(i),i=65,128)  /                                      &
         0.169525E-01,  0.214410E-01,  0.136577E-01,  0.169510E-01, &
         0.173025E-01,  0.958346E-02,  0.255024E-01,  0.308943E-01, &
         0.196031E-01,  0.183608E-01,  0.149419E-01,  0.206358E-01, &
         0.140654E-01,  0.172797E-01,  0.145470E-01,  0.982987E-02, &
         0.116695E-01,  0.811333E-02,  0.965823E-02,  0.649977E-02, &
         0.462192E-02,  0.545929E-02,  0.680407E-02,  0.291235E-02, &
        -0.974773E-03,  0.341591E-02,  0.376198E-02,  0.770610E-03, &
        -0.940864E-04,  0.514532E-02,  0.232371E-02, -0.177741E-02, &
        -0.374892E-03, -0.370485E-03, -0.221435E-02, -0.490000E-02, &
         0.588664E-02,  0.931411E-03, -0.456043E-03, -0.545576E-02, &
        -0.421136E-02, -0.353742E-02, -0.174276E-02, -0.361246E-02, &
        -0.337822E-02, -0.867030E-03, -0.118001E-02, -0.222405E-02, &
        -0.725144E-03,  0.118483E-02,  0.995087E-02,  0.273812E-03, &
         0.417298E-02,  0.764294E-02,  0.631568E-02, -0.213528E-02, &
         0.746130E-02,  0.110337E-02,  0.153157E-01,  0.504532E-02, &
         0.406047E-02,  0.192895E-02,  0.202058E-02,  0.126420E-01/
      DATA (AP(i),i=129,163)  /                                     &
         0.310028E-02,  0.214779E-01,  0.560165E-02,  0.661070E-02, &
         0.694966E-02,  0.539194E-02,  0.103745E-01,  0.180150E-01, &
         0.747133E-02,  0.114927E-01,  0.115213E-01,  0.160709E-02, &
         0.154278E-01,  0.112067E-01,  0.148690E-01,  0.154442E-01, &
         0.123977E-01,  0.237539E-01,  0.162820E-01,  0.269484E-01, &
         0.178081E-01,  0.143221E-01,  0.262468E-01,  0.217065E-01, &
         0.107083E-01,  0.281220E-01,  0.115565E-01,  0.231244E-01, &
         0.225197E-01,  0.178624E-01,  0.327708E-01,  0.116657E-01, &
         0.277452E-01,  0.301647E-01,  0.349782E-01/

      DATA (BP(i),i=1,64)  /                                        &
         0.717848E-05,  0.169280E-04,  0.126710E-04,  0.758397E-05, &
        -0.533900E-05,  0.143490E-04, -0.595854E-05,  0.296465E-05, &
         0.323446E-05,  0.115359E-04, -0.692861E-05,  0.131477E-04, &
        -0.624945E-05, -0.756955E-06,  0.107458E-05, -0.159796E-05, &
        -0.290529E-04, -0.170918E-05, -0.193934E-04, -0.707209E-04, &
        -0.148154E-04, -0.383162E-04, -0.186050E-04, -0.951796E-04, &
        -0.210944E-04, -0.330590E-04, -0.373087E-04, -0.408972E-04, &
        -0.396759E-04, -0.827756E-04, -0.573773E-04, -0.325384E-04, &
        -0.449411E-04, -0.271450E-04, -0.752791E-04, -0.549699E-04, &
        -0.225655E-04, -0.102034E-03, -0.740322E-05, -0.668846E-04, &
        -0.106063E-03, -0.304840E-04, -0.796023E-04,  0.504880E-04, &
         0.486384E-04, -0.531946E-04, -0.147771E-03, -0.406785E-04, &
         0.615750E-05, -0.486264E-04, -0.419335E-04, -0.819467E-04, &
        -0.709498E-04,  0.326984E-05, -0.369743E-04, -0.526848E-04, &
        -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
        -0.982953E-04, -0.772497E-04, -0.119430E-05, -0.655187E-04/
      DATA (BP(i),i=65,128)  /                                      &
        -0.339078E-04,  0.716657E-04, -0.335893E-04,  0.220239E-04, &
        -0.491012E-04, -0.393325E-04, -0.626461E-04, -0.795479E-04, &
        -0.599181E-04, -0.578153E-04, -0.597559E-05, -0.866750E-04, &
        -0.486783E-04, -0.580912E-04, -0.647368E-04, -0.350643E-04, &
        -0.566635E-04, -0.385738E-04, -0.463782E-04, -0.321485E-04, &
        -0.177300E-04, -0.250201E-04, -0.365492E-04, -0.165218E-04, &
        -0.649177E-05, -0.218458E-04, -0.984604E-05, -0.120034E-04, &
        -0.110119E-06, -0.164405E-04, -0.141396E-04,  0.315347E-05, &
        -0.141544E-05, -0.297320E-05, -0.216248E-05,  0.839264E-05, &
        -0.178197E-04, -0.106225E-04, -0.468195E-05,  0.997043E-05, &
         0.679709E-05,  0.324610E-05, -0.367325E-05,  0.671058E-05, &
         0.509293E-05, -0.437392E-05, -0.787922E-06, -0.271503E-06, &
        -0.437940E-05, -0.128205E-04, -0.417830E-04, -0.561134E-05, &
        -0.209940E-04, -0.414366E-04, -0.289765E-04,  0.680406E-06, &
        -0.558644E-05, -0.530395E-05, -0.622242E-04, -0.159979E-05, &
        -0.140286E-04, -0.128463E-04, -0.929499E-05, -0.327886E-04/
      DATA (BP(i),i=129,163)  /                                     &
        -0.189353E-04, -0.737589E-04, -0.323471E-04, -0.272502E-04, &
        -0.321731E-04, -0.326958E-04, -0.509157E-04, -0.681890E-04, &
        -0.362182E-04, -0.354405E-04, -0.578392E-04,  0.238627E-05, &
        -0.709028E-04, -0.518717E-04, -0.491859E-04, -0.718017E-04, &
        -0.418978E-05, -0.940819E-04, -0.630375E-04, -0.478469E-04, &
        -0.751896E-04, -0.267113E-04, -0.109019E-03, -0.890983E-04, &
        -0.177301E-04, -0.120216E-03,  0.220464E-04, -0.734277E-04, &
        -0.868068E-04, -0.652319E-04, -0.136982E-03, -0.279933E-06, &
        -0.791824E-04, -0.111781E-03, -0.748263E-04/

      DATA (ATP(i),i=1,64)  /                                       &
        -0.722782E-02, -0.901531E-02, -0.821263E-02, -0.808024E-02, &
        -0.320169E-02, -0.661305E-02, -0.287272E-02, -0.486143E-02, &
        -0.242857E-02, -0.530288E-02, -0.146813E-02, -0.566474E-03, &
        -0.102192E-02,  0.300643E-03, -0.331655E-02,  0.648220E-03, &
         0.552446E-02, -0.933046E-03,  0.205703E-02,  0.130638E-01, &
        -0.229828E-02,  0.715648E-02,  0.444446E-03,  0.193500E-01, &
         0.364119E-02,  0.252713E-02,  0.102420E-01,  0.494224E-02, &
         0.584934E-02,  0.146255E-01,  0.921986E-02,  0.768012E-02, &
         0.916105E-02,  0.276223E-02,  0.125245E-01,  0.131146E-01, &
         0.793016E-02,  0.201536E-01,  0.658631E-02,  0.171711E-01, &
         0.228470E-01,  0.131306E-01,  0.226658E-01,  0.176086E-01, &
         0.149987E-01,  0.143060E-01,  0.313189E-01,  0.117070E-01, &
         0.133522E-01,  0.244259E-01,  0.148393E-01,  0.223982E-01, &
         0.151792E-01,  0.180474E-01,  0.106299E-01,  0.191016E-01, &
         0.171776E-01,  0.229724E-01,  0.275530E-01,  0.302731E-01, &
         0.281662E-01,  0.199525E-01,  0.192588E-01,  0.173220E-01/
      DATA (ATP(i),i=65,128)  /                                     &
         0.195220E-01,  0.169371E-01,  0.193212E-01,  0.145558E-01, &
         0.189654E-01,  0.122030E-01,  0.186206E-01,  0.228842E-01, &
         0.139343E-01,  0.164006E-01,  0.137276E-01,  0.154005E-01, &
         0.114575E-01,  0.129956E-01,  0.115305E-01,  0.929260E-02, &
         0.106359E-01,  0.771623E-02,  0.106075E-01,  0.597630E-02, &
         0.493960E-02,  0.532554E-02,  0.646175E-02,  0.302693E-02, &
         0.150899E-02,  0.310333E-02,  0.533734E-02,  0.239094E-03, &
         0.356782E-02,  0.707574E-02,  0.215758E-02, -0.527589E-03, &
         0.643893E-03, -0.101916E-02, -0.383336E-02, -0.445966E-02, &
         0.880190E-02,  0.245662E-02, -0.560923E-03, -0.582201E-02, &
        -0.323233E-02, -0.454197E-02, -0.240905E-02, -0.343160E-02, &
        -0.335156E-02, -0.623846E-03,  0.393633E-03, -0.271593E-02, &
        -0.675874E-03,  0.920642E-03,  0.102168E-01, -0.250663E-03, &
         0.437126E-02,  0.767434E-02,  0.569931E-02, -0.929326E-03, &
         0.659414E-02,  0.280687E-02,  0.127614E-01,  0.780789E-02, &
         0.374807E-02,  0.274288E-02,  0.534940E-02,  0.104349E-01/
      DATA (ATP(i),i=129,163)  /                                    &
         0.294379E-02,  0.177846E-01,  0.523249E-02,  0.125339E-01, &
         0.548538E-02,  0.577403E-02,  0.101532E-01,  0.170375E-01, &
         0.758396E-02,  0.113402E-01,  0.106960E-01,  0.107782E-01, &
         0.136148E-01,  0.992064E-02,  0.167276E-01,  0.149603E-01, &
         0.136259E-01,  0.234521E-01,  0.166806E-01,  0.298505E-01, &
         0.167592E-01,  0.186679E-01,  0.233062E-01,  0.228467E-01, &
         0.128947E-01,  0.293979E-01,  0.219815E-01,  0.220663E-01, &
         0.272710E-01,  0.237139E-01,  0.331743E-01,  0.208799E-01, &
         0.281472E-01,  0.318440E-01,  0.370962E-01/

      DATA (BTP(i),i=1,64)  /                                       &
         0.149748E-04,  0.188007E-04,  0.196530E-04,  0.124747E-04, &
        -0.215751E-07,  0.128357E-04, -0.265798E-05,  0.606262E-05, &
         0.287668E-05,  0.974612E-05, -0.833451E-05,  0.584410E-05, &
        -0.452879E-05, -0.782537E-05,  0.786165E-05, -0.768351E-05, &
        -0.196168E-04,  0.177297E-06, -0.129258E-04, -0.642798E-04, &
        -0.986297E-05, -0.257145E-04, -0.141996E-04, -0.865089E-04, &
        -0.141691E-04, -0.272578E-04, -0.295198E-04, -0.308878E-04, &
        -0.313193E-04, -0.669272E-04, -0.475777E-04, -0.221332E-04, &
        -0.419930E-04, -0.102519E-04, -0.590184E-04, -0.574771E-04, &
        -0.240809E-04, -0.913994E-04, -0.908886E-05, -0.721074E-04, &
        -0.902837E-04, -0.447582E-04, -0.664544E-04, -0.143150E-04, &
        -0.511866E-05, -0.559352E-04, -0.104734E-03, -0.305206E-04, &
         0.103303E-04, -0.613019E-04, -0.320040E-04, -0.738909E-04, &
        -0.388263E-04,  0.306515E-04, -0.352214E-04, -0.253940E-04, &
        -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
        -0.933645E-04, -0.664045E-04, -0.570712E-05, -0.566312E-04/
      DATA (BTP(i),i=65,128)  /                                     &
        -0.364967E-04,  0.393501E-06, -0.234050E-04, -0.141317E-04, &
        -0.525480E-04, -0.172241E-04, -0.410843E-04, -0.358348E-04, &
        -0.256168E-04, -0.509482E-04, -0.180570E-04, -0.555356E-04, &
        -0.271464E-04, -0.274040E-04, -0.480889E-04, -0.275751E-04, &
        -0.415681E-04, -0.383770E-04, -0.280139E-04, -0.287919E-04, &
        -0.125865E-04, -0.265467E-04, -0.172765E-04, -0.164611E-04, &
         0.189183E-04, -0.171219E-04, -0.132766E-04, -0.344611E-05, &
        -0.442832E-05, -0.185779E-04, -0.139755E-04,  0.168083E-05, &
        -0.395287E-05, -0.297871E-05,  0.434383E-05,  0.131741E-04, &
        -0.192637E-04, -0.549551E-05,  0.122553E-05,  0.204627E-04, &
         0.154027E-04,  0.953462E-05,  0.131125E-05,  0.732839E-05, &
         0.755405E-05, -0.305552E-05, -0.434858E-05,  0.308409E-05, &
        -0.164787E-05, -0.818533E-05, -0.355041E-04, -0.504696E-05, &
        -0.229022E-04, -0.356891E-04, -0.230346E-04,  0.518835E-05, &
        -0.160187E-04, -0.104617E-04, -0.464754E-04, -0.115807E-04, &
        -0.130230E-04, -0.603491E-05, -0.125324E-04, -0.165516E-04/
      DATA (BTP(i),i=129,163)  /                                    &
        -0.991679E-05, -0.529432E-04, -0.200199E-04, -0.181977E-04, &
        -0.220940E-04, -0.204483E-04, -0.432584E-04, -0.449109E-04, &
        -0.247305E-04, -0.174253E-04, -0.484446E-04,  0.354150E-04, &
        -0.425581E-04, -0.406562E-04, -0.505495E-04, -0.651856E-04, &
        -0.153953E-04, -0.894294E-04, -0.616551E-04, -0.846504E-04, &
        -0.699414E-04, -0.376203E-04, -0.940985E-04, -0.753050E-04, &
        -0.183710E-04, -0.123907E-03, -0.279347E-04, -0.736381E-04, &
        -0.103588E-03, -0.754117E-04, -0.140991E-03, -0.366687E-04, &
        -0.927785E-04, -0.125321E-03, -0.115290E-03/

      DATA (BETAD(i),i=1,64)  /                                     &
         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 (BETAD(i),i=65,128)  /                                   &
         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 (BETAD(i),i=129,163)  /                                  &
         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/

!-----------------------------------------------------------------------
!
!    Random band parameters for the longwave calculations using
!    comboned wide frequency bands between 160 and 1200 cm-1, 
!    as well as the 2270-2380 band for source calculations.
!
!        BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1
!        BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS)
!                    FOR 560-1200 CM-1
!        BAND  15:  FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE 
!                   CALCULATION ONLY
!
!        Thus NBLY presently equals   15
! 
!        Bands are arranged in order of increasing wavenumber.
!
!      ACOMB       =   RANDOM "A" PARAMETER FOR (NBLY) BANDS
!      BCOMB       =   RANDOM "B" PARAMETER FOR (NBLY) BANDS
!      BETACM      =   CONTINUUM COEFFICIENTS FOR (NBLY) BANDS
!      APCM,BPCM   =   CAPPHI COEFFICIENTS FOR (NBLY) BANDS 
!      ATPCM,BTPCM =   CAPPSI COEFFICIENTS FOR (NBLY) BANDS 
!      BDLOCM      =   LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS 
!      BDHICM      =   HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS
!      AO3CM       =   RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE
!                      BANDS.
!      BO3CM       =   RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE
!                      BANDS
!      AB15CM      =   THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS
!                      REPRESENTING THE 15 UM BAND COMPLEX OF CO2 
!      BETINC      =   CONT.COEFFICIENT FOR A SPECIFIED WIDE
!                      FREQ.BAND (800-990 AND 1070-1200 CM-1).
!      IBAND       =   INDEX NO OF THE 40 WIDE BANDS USED IN
!                      COMBINED WIDE BAND CALCULATIONS. IN OTHER
!                      WORDS,INDEX TELLING WHICH OF THE 40 WIDE 
!                      BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN 
!                      EACH OF THE FIRST 8 COMBINED WIDE BANDS
!
!     Data for ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM are
!     obtained by using the AFGL 1982 catalog. Continuum coefficients 
!     are from Roberts (1976). IBAND index values are obtained by 
!     experimentation. This data was formerly in COMMON /BDCOMB/.

      INTEGER  IBAND(40)
      REAL  ACOMB(NBLY),BCOMB(NBLY),                        &
            BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), &
            BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC,   &
            AO3CM(3),BO3CM(3),AB15CM(2) 

      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/
      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/

!-----------------------------------------------------------------------
!
!    Random band parameters for specific wide bands. At present,
!    the information consists of:  1) random model parameters for
!    the 15 um band, 560-800 cm-1; 2) the continuum coefficient for
!    the 800-990, 1070-1200 cm-1 band.
!
!    specifically:  
!      AWIDE       =   RANDOM "A" PARAMETER FOR  BAND 
!      BWIDE       =   RANDOM "B" PARAMETER FOR  BAND 
!      BETAWD      =   CONTINUUM COEFFICIENTS FOR BAND
!      APWD,BPWD   =   CAPPHI COEFFICIENTS FOR  BAND
!      ATPWD,BTPWD =   CAPPSI COEFFICIENTS FOR BAND 
!      BDLOWD      =   LOWEST FREQUENCY IN EACH  FREQ  BAND 
!      BDHIWD      =   HIGHEST FREQUENCY IN EACH FREQ  BAND 
!      AB15WD      =   THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND 
!                      REPRESENTING THE 15 UM BAND COMPLEX OF CO2 
!      BETINW      =   CONT.COEFFICIENT FOR A SPECIFIED WIDE
!                      FREQ.BAND (800-990 AND 1070-1200 CM-1).
!      SKO2D       =   1./BETINW, USED IN SPA88 FOR CONT. COEFFS
!      SKC1R       =   BETAWD/BETINW, USED FOR CONT. COEFF. FOR 
!                      15 UM BAND IN FST88
!      SKO3R       =   RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO 
!                        BETINW, USED FOR 9.6 UM CONT COEFF IN FST88
!
!     Data for AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD are
!     obtained by using the AFGL 1982 catalog. Continuum coefficients 
!     are from Roberts (1976). This data was formerly in
!     COMMON /BDWIDE/.

      REAL  AWIDE,BWIDE,BETAWD,    &
            APWD,BPWD,ATPWD,BTPWD, &
            BDLOWD,BDHIWD,BETINW,  &
            AB15WD,SKO2D,SKC1R,SKO3R

      DATA AWIDE  / 0.309801E+01/
      DATA BWIDE  / 0.495357E-01/
      DATA APWD   / 0.177115E-01/
      DATA BPWD   /-0.545226E-04/
      DATA ATPWD  / 0.187967E-01/
      DATA BTPWD  /-0.567449E-04/
      DATA BETAWD / 0.347839E+02/
      DATA BETINW / 0.766811E+01/
      DATA BDLOWD / 0.560000E+03/
      DATA BDHIWD / 0.800000E+03/

!-----------------------------------------------------------------------
!
!       CLDFAC     =  CLOUD TRANSMISSION FUNCTION,ASSUMING RANDOM
!                       OVERLAP

      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: CLDFAC

!-----------------------------------------------------------------------
!
!     Basic quantities computed in SUBROUTINE LWRAD and used in
!     the remaining longwave routines (formally COMMON /KDACOM/):
!
!       QH2O     =  H2O MASS MIXING RATIO,MULTIPLIED BY THE 
!                     DIFFUSIVITY FACTOR (DIFFCTR)
!       P        =  PRESSURE AT FLUX LEVELS OF MODEL
!       DELP2    =  PRESSURE DIFFERENCE BETWEEN FLUX LEVELS 
!       DELP     =  INVERSE OF DELP2
!       TTTT     =  TEMPERATURE ASSIGNED TO MODEL FLUX LEVELS 
!       VAR1     =  H2O OPTICAL PATH IN MODEL LAYERS (BETWEEN 
!                     FLUX LEVELS)
!       VAR2     =  PRESSURE-WEIGHTED H2O OPTICAL PATH IN MODEL LAYERS
!       VAR3     =  O3 OPTICAL PATH IN MODEL LAYERS 
!       VAR4     =  PRESSURE-WEIGHTED O3 OPTICAL PATH IN MODEL LAYERS 
!       CNTVAL   =  H2O CONTINUUM PATH IN MODEL LAYERS FOR THE
!                     800-990 AND 1070-1200 CM-1 COMBINED BAND

      REAL, ALLOCATABLE, DIMENSION(:,:) :: QH2O,P,DELP2,DELP,TTTT
      REAL, ALLOCATABLE, DIMENSION(:,:) :: VAR1,VAR2,VAR3,VAR4,CNTVAL

!-----------------------------------------------------------------------
!
!     Flux quantities computed by the radiation code, used for
!     diagnostic purposes (formally COMMON /RDFLUX/): 
!
!       FLX1E1     =  FLUX AT TOP FOR 0-160,1200-2200 CM-1 RANGE
!       GXCTS      =  FLUX AT TOP FOR 160-1200 CM-1 RANGE 
!       FCTSG      =  CTS FLUX AT GROUND. USED TO OBTAIN GXCTS
!                              BY BANDS.

      REAL, ALLOCATABLE, DIMENSION(:)   :: FLX1E1,GXCTS
      REAL, ALLOCATABLE, DIMENSION(:,:) :: FCTSG

!-----------------------------------------------------------------------
!
!     Planck function values used for the radiative calculations
!     (formally COMMON /SRCCOM/):
!
!       SORC     =  PLANCK FCTN, AT MODEL TEMPERATURES, FOR ALL BANDS 
!                     USED IN CTS CALCULATIONS
!       CSOUR1   =  PLANCK FCTN FOR 560-670 CM-1 BAND 
!       CSOUR2   =  PLANCK FCTN FOR 670-800 CM-1 BAND 
!       CSOUR    =  PLANCK FCTN FOR 560-800 CM-1 BANDS
!       OSOUR    =  PLANCK FCTN FOR 990-1070 CM-1 BAND
!       SS1      =  PLANCK FCTN FOR 800-990,1070-1200 CM-1 BANDS

      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SORC
      REAL, ALLOCATABLE, DIMENSION(:,:) :: CSOUR1,CSOUR2,OSOUR,CSOUR,SS1

!-----------------------------------------------------------------------
!
!     Quantities precomputed in subroutine TABLE for use in
!     the longwave radiation module (formally COMMON /TABCOM/):
!
!        EM1     =  E1 FUNCTION, EVALUATED OVER THE 0-560 AND 
!                   1200-2200 CM-1 INTERVALS
!        EM1WDE  =  E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1
!                   INTERVAL
!        TABLE1  =  E2 FUNCTION, EVALUATED OVER THE 0-560 AND 
!                   1200-2200 CM-1 INTERVALS
!        TABLE2  =  TEMPERATURE DERIVATIVE OF TABLE1
!        TABLE3  =  MASS DERIVATIVE OF TABLE1 
!        EM3     =  E3 FUNCTION, EVALUATED OVER THE 0-560 AND 
!                   1200-2200 CM-1 INTERVALS
!        SOURCE  =  PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR
!                   BANDS USED IN CTS CALCULATIONS
!        DSRCE   =  TEMPERATURE DERIVATIVE OF SOURCE
!        INDX2   =  INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" 
!                   ELEMENTS OF AVEPHI,ETC.,IN FST88
!        KMAXV   =  INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" 
!                   ELEMENTS OF AVEPHI,ETC.,IN FST88
!        KMAXVM  =  KMAXV(LMAX),USED FOR DO LOOP INDICES 

      INTEGER, ALLOCATABLE, DIMENSION(:) :: INDX1,INDX2,KMAXV

      INTEGER :: KMAXVM
      INTEGER, PRIVATE :: IMAXold=0,LMAXold=0
      INTEGER, PRIVATE :: IMAX

      REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE

!     REAL  EM1   (28,180),EM1WDE(28,180),TABLE1(28,180),
!     COMMON /TABCOM/  EM1   (28,180),EM1WDE(28,180),TABLE1(28,180),
!    &                 TABLE2(28,180),TABLE3(28,180),EM3   (28,180)
      
!-----------------------------------------------------------------------
!
!     Transmission functions used for radiative computations, and
!     output heating rates and fluxes, except those needed out of
!     the radiative module (formally COMMON /TFCOM/): 
!
!       TO3      =  TRANSMISSION FCTN FOR THE 990-1070 CM-1 BAND
!                     O3(9.6 UM) + H2O CONTINUUM (NO LINES) 
!       CO21     =  TRANSMISSION FCTN FOR THE 560-800 CM-1 BAND 
!                     (AS 1 BAND). INCLUDES CO2 (IN LWRAD) AND
!                      H2O(L+C) AFTER MULTIPLICATION WITH "OVER"
!                      IN FST88 
!       EMISS    =  E2 EMISSIVITYY FCTN FOR H2O LINES (0-560,1200-2200
!                      CM-1). OBTAINED IN E1E288. 
!       EMISS2   =  TRANSMISSION FCTN FOR H2O CONTINUUM IN THE 800-990
!                      AND 1070-1200 CM-1 REGION, TAKEN AS 1 BAND 
!       AVEPHI   =  H2O OPTICAL PATHS BET. FLUX PRESSURES: INPUT TO 
!                      EMISSIVITY CALCULATIONS. 
!       TTEMP    =  TEMPERATURES USED AS INPUT FOR EMISSIVITY CALCS.
!       CTS      =  APPROX CTS HEATING RATES FOR 160-560 AND 800-990, 
!                      1070-1200 CM-1 RANGES
!       CTSO3    =  APPROX CTS HEATING RATES FOR 560-800,990-1070 CM-1
!                      RANGES 
!       EXCTS    =  EXACT CTS HEATING RATES FOR 160-1200 CM-1 RANGE 
!       EXCTSN   =  EXACT CTS HEATING RATES, BY BANDS 
!       E1FLX    =  E1 EMISSIVITY FCTN FOR H2O LINES (0-560,1200-CM-1)
!       CO2NBL   =  CO2 TRANS. FCTNS. (NOT PRESSURE-INTEGRATED) FOR 
!                      ADJACENT LEVELS,OVER THE 560-800 CM-1 RANGE. 
!       CO2SP1   =  CO2 TRANS. FCTNS. (NOT PRESSURE-INTEGRATED) BET.
!                      A FLUX LEVEL AND SPACE, FOR THE 560-670 CM-1 
!                      RANGE. USED FOR EXACT CTS CALCS. 
!       CO2SP2   =  SAME AS CO2SP1, BUT FOR THE 670-800 CM-1 RANGE. 
!       CO2SP    =  SAME AS CO2SP1, BUT FOR THE 560-800 CM-1 BAND.
!                      USED FOR APPROX CTS CALCS. 
!       TO3SPC   =  O3 OPTICAL DEPTHS BET. A LEVEL AND SPACE. USED FOR
!                      EXACT CTS CALCS. 
!       TOTVO2   =  H2O CONTINUUM OPTICAL PATHS BET. SPACE AND A
!                      LEVEL, USING THE CNT. COEFFICIENT FOR THE
!                      1-BAND 800-990,1070-1200 CM-1 BAND. USED FOR 
!                      CTS CALCS. 

      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: TO3,CO21,EMISS,EMISS2,AVEPHI
      REAL,ALLOCATABLE,DIMENSION(:,:)   :: CTS,CTSO3,EXCTS
      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: EXCTSN
      REAL,ALLOCATABLE,DIMENSION(:,:)   :: E1FLX,CO2NBL,CO2SP1,CO2SP2
      REAL,ALLOCATABLE,DIMENSION(:,:)   :: CO2SP,TO3SPC,TOTVO2

!------------ VERSION NUMBER ----------------

 character(len=128) :: version = '$Id: longwave.F90,v 13.0 2006/03/28 21:09:33 fms Exp $'
 character(len=128) :: tagname = '$Name: tikal $'
 logical            :: module_is_initialized = .false.

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

public LWRad, Rad_DeAlloc, longwave_init, longwave_end
public OSOUR, CSOUR, SS1, FLX1E1, GXCTS, FCTSG, CLDFAC, DELP2, DELP, &
       TO3, CO21, EMISS, EMISS2, CTS, EXCTS, EXCTSN, E1FLX, CO2SP,   &
       IBAND, BANDLO, BANDHI


      CONTAINS

!#######################################################################
!#######################################################################
      Subroutine longwave_init
!------- write version number  ---------

      if ( mpp_pe() == mpp_root_pe() ) then
           call write_version_number(version, tagname)
      endif

      module_is_initialized = .true.

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

      End Subroutine longwave_init

!#######################################################################
!#######################################################################

      Subroutine longwave_end

      module_is_initialized = .false.
!---------------------------------------------------------------------

      End Subroutine longwave_end

!#######################################################################
!#######################################################################

      SUBROUTINE LWRAD (KTOP,KBTM,NCLDS,EMCLD,PRES,TEMP,RH2O,QO3,CAMT, &
                        RRVCO2,  HEATRA,GRNFLX,TOPFLX, LSFC,PSFC)

      INTEGER, INTENT(IN), DIMENSION(:,:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:,:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: EMCLD
      REAL,    INTENT(IN), DIMENSION(:,:,:) :: PRES,TEMP,RH2O,QO3,CAMT
      REAL,    INTENT(IN)                   :: RRVCO2

      REAL,   INTENT(OUT), DIMENSION(:,:,:) :: HEATRA
      REAL,   INTENT(OUT), DIMENSION(:,:)   :: GRNFLX,TOPFLX

      INTEGER, INTENT(IN),OPTIONAL, DIMENSION(:,:)   :: LSFC
      REAL   , INTENT(IN),OPTIONAL, DIMENSION(:,:)   :: PSFC

      INTEGER  J

      IMAX=SIZE(PRES,1)
      CALL RAD_ALLOC (IMAX)

      DO j=1,SIZE(PRES,2)

        CALL CLO88 (KTOP(:,j,:),KBTM(:,j,:),NCLDS(:,j), &
                    CAMT(:,j,:),EMCLD(:,j,:))

      IF (PRESENT(LSFC) .and. PRESENT(PSFC)) THEN
        CALL LWRAD2 (KTOP(:,j,:),KBTM(:,j,:),NCLDS(:,j),EMCLD(:,j,:), &
                     PRES(:,j,:),TEMP(:,j,:),RH2O(:,j,:),QO3(:,j,:),  &
                     CAMT(:,j,:), RRVCO2,                             &
                     HEATRA(:,j,:),GRNFLX(:,j),TOPFLX(:,j),           &
                     LSFC(:,j),PSFC(:,j))
      ELSE
        CALL LWRAD2 (KTOP(:,j,:),KBTM(:,j,:),NCLDS(:,j),EMCLD(:,j,:), &
                     PRES(:,j,:),TEMP(:,j,:),RH2O(:,j,:),QO3(:,j,:),  &
                     CAMT(:,j,:), RRVCO2,                             &
                     HEATRA(:,j,:),GRNFLX(:,j),TOPFLX(:,j))
      ENDIF

      ENDDO

!del  CALL RAD_DEALLOC

      END SUBROUTINE LWRAD

!#######################################################################
!#######################################################################

      SUBROUTINE LWRAD2  (KTOP,KBTM,NCLDS,EMCLD,PRES,TEMP,RH2O,QO3,CAMT, &
                          RRVCO2,  HEATRA,GRNFLX,TOPFLX, LSFC,PSFC)

!-----------------------------------------------------------------------
!                    LONG WAVE RADIATION CODE
!                    ------------------------
!   SUBROUTINE LWRAD (formally LWR88) COMPUTES TEMPERATURE-CORRECTED
!   CO2 TRANSMISSION FUNCTIONS AND ALSO COMPUTES THE PRESSURE GRID
!   AND LAYER OPTICAL PATHS.
!-----------------------------------------------------------------------
!                        INPUT PARAMETERS
!                        ----------------
!
!      KTOP    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD TOP,USED
!                    IN THE LONGWAVE PROGRAM
!      KBTM    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD BOTTOM, 
!                    USED IN THE LONGWAVE PROGRAM 
!      NCLDS   =  NO. CLOUDS AT EACH GRID PT.
!      EMCLD   =  CLOUD EMISSIVITY. SET TO ONE BY DEFAULT, BUT MAY
!                    BE MODIFIED FOR USE IN LONGWAVE PROGRAM. 
!      PRES    =  PRESSURE (CGS UNITS) AT DATA LEVELS OF MODEL
!      TEMP    =  TEMPERATURE (K) AT DATA LEVELS OF MODEL
!      RH2O    =  MASS MIXING RATIO (G/G) OF H2O AT MODEL DATA LVLS.
!      QO3     =  MASS MIXING RATIO (G/G) OF O3 AT MODEL DATA LVLS. 
!      CAMT    =  CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE
!                 SPECIFIED IN THE KTOP/KBTM INDICES)
!      RRVCO2  =  THE VOLUME MIXING RATIO OF CO2 (SCALAR)
!                 (used in NLTE, passed by argument list)
!
!      PSFC    =  Surface pressure, dimensioned by IMAX.
!      TSFC    =  Surface temperature, dimensioned by IMAX.
!      LSFC    =  Vertical index of the lowest model level,
!                    dimensioned by IMAX.
!
!-----------------------------------------------------------------------
!                        OUTPUT PARAMETERS
!                        -----------------
!
!      HEATRA     =  HEATING RATE AT DATA LEVELS (K/DAY) 
!      GRNFLX     =  NET LONGWAVE FLUX AT THE GROUND (CGS UNITS) 
!      TOPFLX     =  NET LONGWAVE FLUX AT THE TOP    (CGS UNITS)
!
!
!-----------------------------------------------------------------------
!         OTHER INPUTS (FROM COMMON BLOCKS):
!         ----------------------------------
!      CO251,CO258,CDT51,CDT58         CO2BD3 
!      C2D51,C2D58,CO2M51,CO2M58       CO2BD3 
!      CDTM51,CDTM58,C2DM51,C2DM58     CO2BD3 
!      STEMP,GTEMP                     CO2BD3 
!      CO231,CO238,CDT31,CDT38         CO2BD2 
!      C2D31,C2D38                     CO2BD2 
!      CO271,CO278,CDT71,CDT78         CO2BD4 
!      C2D71,C2D78                     CO2BD4 
!      BETINW                          BDWIDE 
!
!          OUTPUTS: 
!      CO21,CO2NBL,CO2SP1,CO2SP2       TFCOM
!      VAR1,VAR2,VAR3,VAR4,CNTVAL      KDACOM 
!      QH2O,P,DELP,DELP2,T             KDACOM 
!
!          CALLS: 
!      FST88
!-----------------------------------------------------------------------
!----------------INPUT ARGUMENTS----------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:) :: EMCLD
      REAL,    INTENT(IN), DIMENSION(:,:) :: PRES,TEMP,RH2O,QO3,CAMT
      REAL,    INTENT(IN)                 :: RRVCO2
      INTEGER, INTENT(IN),OPTIONAL, DIMENSION(:)   :: LSFC
      REAL   , INTENT(IN),OPTIONAL, DIMENSION(:)   :: PSFC

!                         D I M E N S I O N
!    &  KTOP(IMAX,LP1),KBTM(IMAX,LP1),NCLDS(IMAX),EMCLD(IMAX,LP1),
!    &  TEMP(IMAX,LP1),PRES(IMAX,LP1),RH2O(IMAX,LMAX),QO3(IMAX,LMAX),
!    &  CAMT(IMAX,LP1),LSFC(IMAX),PSFC(IMAX)
!----------------OUTPUT ARGUMENTS---------------------------------------

      REAL,   INTENT(OUT), DIMENSION(:,:) :: HEATRA
      REAL,   INTENT(OUT), DIMENSION(:)   :: GRNFLX,TOPFLX

!-----------------------------------------------------------------------
!----------------LOCAL ARRAY STORAGE------------------------------------

      integer :: k, kp
      real    :: diftt
      real, dimension(IMAX,LP1)  :: &
                    PRESS, CO2R1, DCO2D1, D2CD21, D2CD22, &
                    CO2R2 , DCO2D2, TDAV, TSTDAV, VSUM3, TEXPSL, TLSQU
      
      real, dimension(IMAX,LMAX)  :: &
                    VV, CO2MR, CO2MD, CO2M2D, VSUM4

      real, dimension(IMAX)  :: &
                    VSUM1, VSUM2, A1, A2
!      DIMENSION  :: PRESS(IMAX,LP1)

!     DIMENSION  CO2R(IMAX,LP1,LP1),DIFT(IMAX,LP1,LP1)
!     DIMENSION                     DIFT(IMAX,LP1,LP1)
!      DIMENSION  CO2R1 (IMAX,LP1), DCO2D1(IMAX,LP1) 
!      DIMENSION  D2CD21(IMAX,LP1), D2CD22(IMAX,LP1)
!      DIMENSION  CO2R2 (IMAX,LP1), DCO2D2(IMAX,LP1) 
!      DIMENSION  TDAV(IMAX,LP1),TSTDAV(IMAX,LP1), &
!                 VV(IMAX,LMAX),VSUM3(IMAX,LP1),VSUM1(IMAX),VSUM2(IMAX) 
!      DIMENSION  CO2MR (IMAX,LMAX),CO2MD (IMAX,LMAX),CO2M2D(IMAX,LMAX) 
!      DIMENSION  A1(IMAX),A2(IMAX)
!-----------------------------------------------------------------------
!     DIMENSION  DIFTD(IMAX,LP1,LP1) 
!     DIMENSION  DCO2DT(IMAX,LP1,LP1),D2CDT2(IMAX,LP1,LP1) 
!      DIMENSION  TEXPSL(IMAX,LP1),TLSQU(IMAX,LP1)
!      DIMENSION  VSUM4(IMAX,LMAX) 
!      DIMENSION  DIFT1D(IMAX,LP1M) 
!-----------------------------------------------------------------------
!     EQUIVALENCE (DIFTD,CO2R)
!     EQUIVALENCE (DCO2DT,D2CDT2,CO2R)
!     EQUIVALENCE (VSUM3,TLSQU,TEXPSL)
!     EQUIVALENCE (VV,VSUM4)
!     EQUIVALENCE (DIFT1D,DIFT) 
!-----------------------------------------------------------------------
!----------- check presence of optional arguments ----------------------

      IF ((     PRESENT(LSFC) .and. .not.PRESENT(PSFC)) .or. &
          (.not.PRESENT(LSFC) .and.      PRESENT(PSFC))) THEN
         Call Error_Mesg ('LWRAD in LONGWAVE_MOD', &
                          'LSFC and PSFC must be used together.', FATAL)
      ENDIF
!-----------------------------------------------------------------------
!--- NOTE: convert input pressure (PRES) from MKS to CGS units

      DO K=1,LP1
      DO I=1,IMAX 
         PRESS(I,K)=10.*PRES(I,K)
      ENDDO
      ENDDO

!****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP)

      DO K=2,LMAX
      DO I=1,IMAX 
         P(I,K)=0.50*(PRESS(I,K-1)+PRESS(I,K))
      ENDDO
      ENDDO

      IF (.not.PRESENT(LSFC)) THEN
         DO I=1,IMAX 
            P(I,1)=0.0 
            P(I,LP1)=PRESS(I,LP1) 
         ENDDO
      ELSE
         DO I=1,IMAX 
            P(I,1)=0.0 
            P(I,LP1)=PRESS(I,LP1) 
!--- note: convert from MKS to CGS units
            P(I,LSFC(I)+1)=10.*PSFC(I) 
         ENDDO
      ENDIF

      DO K=1,LMAX
      DO I=1,IMAX 
         DELP2(I,K)=P(I,K+1)-P(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         DELP(I,K)=1.0/DELP2(I,K)
      ENDDO
      ENDDO


!****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE
!    CORRECTIONS (TEXPSL) 

      DO K=2,LMAX
      DO I=1,IMAX 
         TTTT(I,K)=0.50*(TEMP(I,K-1)+TEMP(I,K))
      ENDDO
      ENDDO

      IF (.not.PRESENT(LSFC)) THEN
         DO I=1,IMAX 
            TTTT(I,1)=TEMP(I,1)
            TTTT(I,LP1)=TEMP(I,LP1)
         ENDDO
      ELSE
         DO I=1,IMAX 
            TTTT(I,1)=TEMP(I,1)
            TTTT(I,LP1)=TEMP(I,LP1)
            TTTT(I,LSFC(I)+1)=TEMP(I,LP1)
         ENDDO
      ENDIF


!****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF.
!    (THIS IS 1800.(1./TEMP-1./296.)) 

      DO K=1,LP1
      DO I=1,IMAX 
         TEXPSL(I,K)=1800./TEMP(I,K)-6.081081081
      ENDDO
      ENDDO

!...THEN TAKE EXPONENTIAL 

      DO K=1,LP1
      DO I=1,IMAX
         TEXPSL(I,K)=EXP(TEXPSL(I,K))
      ENDDO
      ENDDO
!***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS 
!-----------------------------------------------------------------------
!***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 K=1,LMAX
      DO I=1,IMAX 
         QH2O(I,K)=RH2O(I,K)*DIFFCTR 
      ENDDO
      ENDDO

!---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS 
!   THE LEVEL PRESSURE (PRESS)

      DO K=1,LMAX
      DO I=1,IMAX 
         VV(I,K)=0.50*(P(I,K+1)+P(I,K))*P0INV 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         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)+0.0003)
         VAR4(I,K)=VAR3(I,K)*(VV(I,K)+0.003)
      ENDDO
      ENDDO


!  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.

      DO K=1,LMAX
      DO I=1,IMAX 
         CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ &
                  (RH2O(I,K)+RATH2OMW)
      ENDDO
      ENDDO
      

!***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS 
!   FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD.
!   TEMP. SOUNDING (DIFT) 

      DO I=1,IMAX 
         TSTDAV(I,1)=0.0
         TDAV(I,1)=0.0
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         VSUM3(I,K)=TEMP(I,K)-STEMP(K) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         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)
      ENDDO
      ENDDO

!***COMPUTE DIFT
!2    DO K=1,LP1
!2    DO KP=1,LP1 
!2    DO I=1,IMAX 
!        DIFTD(I,KP,K)=TSTDAV(I,KP)-TSTDAV(I,K)
!2       DIFT (I,KP,K)=TSTDAV(I,KP)-TSTDAV(I,K)
!2    ENDDO
!2    ENDDO
!     ENDDO

!2    DO K=1,LP1
!2    DO KP=1,LP1 
!2    DO I=1,IMAX 
!        DIFTD(I,KP,K)=1.0/(DIFTD(I,KP,K)+1.E-20) 
!2       DIFT (I,KP,K)=1.0/(DIFT (I,KP,K)+1.E-20) 
!2    ENDDO
!2    ENDDO
!2    ENDDO

!9    DO K=1,LP1
!9    DO KP=1,LP1 
!9    DO I=1,IMAX 
!        DIFT(I,KP,K)=TDAV(I,KP)-TDAV(I,K) 
!d       DIFT(I,KP,K)=(TDAV(I,KP)-TDAV(I,K))*DIFT(i,kp,k) 
!9       DIFT(I,KP,K)=(TDAV(I,KP)-TDAV(I,K))*(1.0/(tstdav(i,kp)-
!9   &                 tstdav(i,k) + 1.E-20))
!9    ENDDO
!9    ENDDO
!9    ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        DIFT(I,KP,K)=DIFT(I,KP,K)*DIFTD(I,KP,K) 
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         VSUM4(I,K)=0.50*(VSUM3(I,K+1)+VSUM3(I,K))
      ENDDO
      ENDDO

!9    DO K=2,LP1
!9    DO I=1,IMAX 
!9       DIFT(I,K,K)=VSUM4(I,K-1)
!9    ENDDO
!9    ENDDO

!****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2) 
! ---- NOTE: PRESS converted from MKS to CGS

      DO I=1,IMAX 
         A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2
         A2(I)=(P0-PRESS(I,LP1))/P0XZP2
      ENDDO

!***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 K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 
!        CO2R(I,KP,K)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
         CO21(I,KP,K)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K)
         D2CD21(I,K)=A1(I)*C2D31(K)+A2(I)*C2D38(K) 
         DCO2D1(I,K)=A1(I)*CDT31(K)+A2(I)*CDT38(K) 
         CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K)
         D2CD22(I,K)=A1(I)*C2D71(K)+A2(I)*C2D78(K) 
         DCO2D2(I,K)=A1(I)*CDT71(K)+A2(I)*CDT78(K) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         D2CD21(I,K)=1.E-3*D2CD21(I,K)
         DCO2D1(I,K)=1.E-2*DCO2D1(I,K)
         D2CD22(I,K)=1.E-3*D2CD22(I,K)
         DCO2D2(I,K)=1.E-2*DCO2D2(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K)
         CO2MD(I,K)=A1(I)*CDTM51(K)+A2(I)*CDTM58(K)
         CO2M2D(I,K)=A1(I)*C2DM51(K)+A2(I)*C2DM58(K) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CO2MD(I,K)=1.E-2*CO2MD(I,K)
         CO2M2D(I,K)=1.E-3*CO2M2D(I,K)
      ENDDO
      ENDDO

!***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT 

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        CO21(I,KP,K)=CO2R(I,KP,K) 
!     ENDDO
!     ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        DCO2DT(I,KP,K)=A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K)
!     ENDDO
!     ENDDO
!     ENDDO
!
!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        DCO2DT(I,KP,K)=1.E-2*DCO2DT(I,KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 

!        CO21(I,KP,K)=CO21(I,KP,K)+DIFT(I,KP,K)*DCO2DT(I,KP,K) 
!5       CO21(I,KP,K)=CO21(I,KP,K)+DIFT(I,KP,K)*(1.0E-2*(a1(I)*
!5   &                CDT51(KP,K)+A2(i)*CDT58(KP,K))) 
        if ( (kp .ne. k) .or. k .eq. 1) then
         CO21(I,KP,K)=CO21(I,KP,K)+                              &
                (Tdav(i,kp) - tdav(i,k))*(1.0/ (tstdav(i,kp) -   &
                                         tstdav(i,k) + 1.E-20))* &
                       (1.0E-2*(a1(I)* &
                      CDT51(KP,K)+A2(i)*CDT58(KP,K))) 
        else if ( (kp .eq. k)  .and. (k .ge. 2) ) then
         CO21(I,KP,K)=CO21(I,KP,K)+ &
              vsum4(i,k-1)*         &
                 (1.0E-2*(a1(I)*    &
                      CDT51(KP,K)+A2(i)*CDT58(KP,K))) 
         endif
      ENDDO
      ENDDO
      ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        D2CDT2(I,KP,K)=A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        D2CDT2(I,KP,K)=1.E-3*D2CDT2(I,KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 

!        CO21(I,KP,K)=CO21(I,KP,K)+0.50*
!                     DIFT(I,KP,K)* 
!    &                DIFT(I,KP,K)*D2CDT2(I,KP,K) 
!7       CO21(I,KP,K)=CO21(I,KP,K)+0.50*
!7   &                DIFT(I,KP,K)* 
!7   &                DIFT(I,KP,K)*(1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*
!7   &                c2D58(KP,K))) 

        if ( (kp .ne. k) .or. k .eq. 1) then
         DIFTT      =(TDAV(I,KP)-TDAV(I,K))*(1.0/(tstdav(i,kp)- &
                       tstdav(i,k) + 1.E-20))
!        CO21(I,KP,K)=CO21(I,KP,K)+0.50*
         CO21(I,KP,K)=CO21(I,KP,K)+0.50*                        &
            diftt*diftt*                                        &
!8   &                DIFT(I,KP,K)* 
!8   &                DIFT(I,KP,K)* 
!    &          (0.5*((Tdav(i,kp) - tdav(i,k))*(1.0/ (tstdav(i,kp) - 
!    &                         tstdav(i,k) + 1.E-20)) *
!    &          (Tdav(i,kp) - tdav(i,k))* (1.0/ (tstdav(i,kp) - 
!    &                        tstdav(i,k) + 1.E-20)) ) )*
               ((1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*c2D58(KP,K)))) 
!    &              (1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*c2D58(KP,K))) 
        else if ( (kp .eq. k)  .and. (k .ge. 2) ) then
         CO21(I,KP,K)=CO21(I,KP,K)+0.50*                        &
              vsum4(i,k-1)*                                     &
              vsum4(i,k-1)*                                     &
                    (1.E-3*(A1(I)*C2D51(KP,K) + A2(I)*c2D58(KP,K))) 
        endif
      ENDDO
      ENDDO
      ENDDO

!***COMPUTE TRANSMISSION FCTNS USED IN SPA88
!---(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 K=1,LP1
      DO I=1,IMAX 
!6       CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K,1)*
!6   &               (DCO2D1(I,K)+0.50*DIFT(I,K,1)*D2CD21(I,K)) 
!6       CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K,1)*
!6   &               (DCO2D2(I,K)+0.50*DIFT(I,K,1)*D2CD22(I,K)) 
         CO2SP1(I,K)=CO2R1(I,K)+                                &
                ((Tdav(i,k) - tdav(i,1))*(1.0/ (tstdav(i,k) -   &
                     tstdav(i,1)   + 1.E-20))) *                &
                     (DCO2D1(I,K)+0.50*                         &
                ((Tdav(i,k ) - tdav(i,1))*(1.0/ (tstdav(i,k ) - &
                        tstdav(i,1)  + 1.E-20)))*               &
                        D2CD21(I,K)) 
         CO2SP2(I,K)=CO2R2(I,K)+                                &
                ((Tdav(i,k) - tdav(i,1)) *(1.0/ (tstdav(i,k ) - &
                           tstdav(i,1)  + 1.E-20)))*            &
                     (DCO2D2(I,K)+0.50*                         &
                ((Tdav(i,k) - tdav(i,1))*(1.0/ (tstdav(i,k ) -  &
                         tstdav(i,1) + 1.E-20)))*               &
              D2CD22(I,K)) 
      ENDDO
      ENDDO

!--- WE AREN''T DOING NBL TFS ON THE 100 CM-1 BANDS .
      DO K=1,LMAX
      DO I=1,IMAX 
!7       CO2NBL(I,K)=CO2MR(I,K)+DIFT(I,K,K+1)*(CO2MD(I,K)+0.50* 
!7   &                      DIFT(I,K,K+1)*CO2M2D(I,K)) 
         CO2NBL(I,K)=CO2MR(I,K)+                               &
             ((Tdav(i,k ) - tdav(i,k+1))*(1.0/ (tstdav(i,k ) - &
                        tstdav(i,k+1) + 1.E-20)))*             &
       (CO2MD(I,K)+0.50*                                       &
            ((Tdav(i,k ) - tdav(i,k+1))*(1.0/ (tstdav(i,k ) -  &
                      tstdav(i,k+1) + 1.E-20)))*               &
                CO2M2D(I,K)) 
      ENDDO
      ENDDO

!***COMPUTE TEMP. COEFFICIENT BASED ON TTTT(K) (SEE REF.2) 
      DO K=1,LP1
      DO I=1,IMAX
         IF (TTTT(I,K) <= 250.) THEN
              TLSQU(I,K)=B0+(TTTT(I,K)-250.)*      &
                            (B1+(TTTT(I,K)-250.)*  &
                         (B2+B3*(TTTT(I,K)-250.))) 
         ELSE 
            TLSQU(I,K)=B0 
         ENDIF
      ENDDO
      ENDDO

!***APPLY TO ALL CO2 TFS
      DO K=1,LP1
      DO KP=1,LP1 
      DO I=1,IMAX 
         CO21(I,KP,K)=CO21(I,KP,K)*(1.0-TLSQU(I,KP))+TLSQU(I,KP) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CO2SP1(I,K)=CO2SP1(I,K)*(1.0-TLSQU(I,1))+TLSQU(I,1) 
         CO2SP2(I,K)=CO2SP2(I,K)*(1.0-TLSQU(I,1))+TLSQU(I,1) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CO2NBL(I,K)=CO2NBL(I,K)*(1.0-TLSQU(I,K))+TLSQU(I,K) 
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
      IF (Present(LSFC)) THEN
         CALL FST88 (KTOP,KBTM,NCLDS,EMCLD,PRESS,TEMP,CAMT,RRVCO2, &
                     HEATRA,GRNFLX,TOPFLX, LSFC)
      ELSE
         CALL FST88 (KTOP,KBTM,NCLDS,EMCLD,PRESS,TEMP,CAMT,RRVCO2, &
                     HEATRA,GRNFLX,TOPFLX)
      ENDIF
!-----------------------------------------------------------------------
      END SUBROUTINE LWRAD2

!#######################################################################
!#######################################################################

      SUBROUTINE FST88 (KTOP,KBTM,NCLDS,EMCLD,PRESS,TEMP,CAMT,RRVCO2, &
                         HEATRA,GRNFLX,TOPFLX, LSFC)

!-----------------------------------------------------------------------
!                        INPUT PARAMETERS
!                        ----------------
!
!      KTOP    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD TOP,USED
!                    IN THE LONGWAVE PROGRAM
!      KBTM    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD BOTTOM,
!                    USED IN THE LONGWAVE PROGRAM
!      NCLDS   =  NO. CLOUDS AT EACH GRID PT.
!      EMCLD   =  CLOUD EMISSIVITY. SET TO ONE BY DEFAULT, BUT MAY
!                    BE MODIFIED FOR USE IN LONGWAVE PROGRAM.
!      PRESS   =  PRESSURE (CGS UNITS) AT DATA LEVELS OF MODEL
!      TEMP    =  TEMPERATURE (K) AT DATA LEVELS OF MODEL
!      CAMT    =  CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE
!                 SPECIFIED IN THE KTOP/KBTM INDICES)
!      RRVCO2  =  THE VOLUME MIXING RATIO OF CO2 (SCALAR)
!                 (used in NLTE, passed by argument list)
!
!      LSFC    =  Vertical index of the lowest model level,
!                    dimensioned by IMAX. (For eta coordinate)
!
!-----------------------------------------------------------------------
!                        OUTPUT PARAMETERS
!                        -----------------
!
!      HEATRA     =  HEATING RATE AT DATA LEVELS (K/DAY)
!      GRNFLX     =  NET LONGWAVE FLUX AT THE GROUND (CGS UNITS)
!      TOPFLX     =  NET LONGWAVE FLUX AT THE TOP    (CGS UNITS)
!
!
!-----------------------------------------------------------------------
!     ***************************************************************** 
!          SUBROUTINE FST88 IS THE MAIN COMPUTATION MODULE OF THE 
!     LONG-WAVE RADIATION CODE. IN IT ALL "EMISSIVITY" CALCULATIONS,
!     INCLUDING CALLS TO TABLE LOOKUP SUBROUTINES. ALSO,AFTER CALLING 
!     SUBROUTINE "SPA88", FINAL COMBINED HEATING RATES AND GROUND 
!     FLUX ARE OBTAINED.
!     ***************************************************************** 
!-----------------------------------------------------------------------
!              OTHER INPUTS:  
!              -------------
!        BETINW,BETAWD,AB15WD              BDWIDE 
!        BETAD,BO3RND,AO3RND               BANDTA 
!        QH2O,P,DELP2,DELP,T,VAR1,VAR2,    KDACOM 
!        VAR3,VAR4,CNTVAL                  KDACOM 
!        BCLDS                             RDBITS 
!        INDX2,KMAXV,SOURCE,DSRCE          TABCOM 
!        SKC1R,SKC3R,KMAXVM,NREP1,NREP2    TABCOM 
!        CO2NBL,CO2SP,CO21                 TFCOM
!
!              OUTPUTS: 
!        FLX1E1                            RDFLUX 
! 
!          CALLED BY  :    LWR88
!
!          CALLS      :    CLO88,E1E288,E3V88,SPA88,NLTE
!
!
!              PASSED VARIABLES:  
!              
!              IN E3V88:  
!        EMD     =  E3 FUNCTION FOR H2O LINES (0-560,1200-2200 CM-1)
!                     COMPUTED IN E3V88 
!        TPL     =  TEMPERATURE INPUT FOR E3 CALCULATION IN E3V88 
!        EMPL    =  H2O AMOUNT,INPUT FOR E3 CALCULATION IN E3V88
!
!              IN E1E288: 
!        E1CTS1  =  E1 FUNCTION FOR THE (I+1)TH LEVEL USING THE 
!                   TEMPERATURE OF THE ITH DATA LEVEL,COMPUTED OVER 
!                   THE FREQUENCY RANGE 0-560,1200-2200 CM-1. (E1CTS1-
!                   E1CTW1) IS USED IN OBTAINING THE FLUX AT THE TOP
!                   IN THE 0-160,1200-2200 CM-1 RANGE (FLX1E1). 
!        E1CTS2  =  E1 FUNCTION FOR THE ITH LEVEL, USING THE TEMP. OF 
!                   THE ITH DATA LEVEL,COMPUTED OVER THE FREQUENCY RANGE
!                   0-560,1200-2200 CM-1. (E1CTS2-E1CTW2) IS ALSO USED
!                   IN OBTAINING THE FLUX AT THE TOP IN THE 0-160,. 
!                   1200-2200 CM-1 RANGE. 
!        E1FLX   =  E1 FCTN. FOR THE ITH LEVEL,USING THE TEMPERATURE AT 
!                   THE TOP OF THE ATMOSPHERE. COMPUTED OVER THE FREQ.
!                   RANGE 0-560,1200-2200 CM-1. USED FOR Q(APPROX) TERM.
!                   (IN COMMON BLOCK TFCOM) 
!        E1CTW1  =  LIKE E1CTS1,BUT COMPUTED OVER THE 160-560 CM-1 RANGE
!                   AND USED FOR Q(APPROX,CTS) CALCULATION
!        E1CTW2  =  LIKE E1CTS2,BUT COMPUTED OVER THE 160-560 CM-1 RANGE
!                   AND USED FOR Q(APPROX,CTS) CALCULATION
!        FXO     =  TEMPERATURE INDEX USED FOR E1 FUNCTION AND ALSO 
!                   USED FOR SOURCE FUNCTION CALC. IN FST88.
!        DT      =  TEMP. DIFF.BETWEEN MODEL TEMPS. AND TEMPS. AT 
!                   TABULAR VALUES OF E1 AND SOURCE FCTNS. USED IN
!                   FST88 AND IN E1 FUNCTION CALC.
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
!#include "bdwide.h"
!-----------------------------------------------------------------------
!#include "bdcomb.h"
!-----------------------------------------------------------------------
!----------------INPUT ARGUMENTS----------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:) :: EMCLD,PRESS,TEMP,CAMT
      REAL,    INTENT(IN)                 :: RRVCO2
      INTEGER, INTENT(IN), DIMENSION(:), OPTIONAL :: LSFC

!                         D I M E N S I O N
!    &  KTOP(IMAX,LP1),KBTM(IMAX,LP1),NCLDS(IMAX),EMCLD(IMAX,LP1),
!    &  TEMP(IMAX,LP1),PRESS(IMAX,LP1),CAMT(IMAX,LP1),LSFC(IMAX)
!----------------OUTPUT ARGUMENTS---------------------------------------

      REAL,   INTENT(OUT), DIMENSION(:,:) :: HEATRA
      REAL,   INTENT(OUT), DIMENSION(:)   :: GRNFLX,TOPFLX

!----------------OUTPUT ARGUMENTS---------------------------------------
!     DIMENSION   HEATRA(IMAX,LMAX),GRNFLX(IMAX),TOPFLX(IMAX)
!-----------------------------------------------------------------------
!----------------LOCAL ARRAY STORAGE------------------------------------
      integer :: i, k, n, klen, kmaxs, kk, kp, icnt, nc
      real    :: hm5
      integer :: IXO(IMAX,LP1),ITOP(IMAX),IBOT(IMAX)
      real    :: VTMP1(IMAX,LP1M),VTMP2(IMAX,LP1V),VTMP3(IMAX,LP1),   &
                 C(IMAX,LLP1),ALP(IMAX,LLP1),DSORC(IMAX,LP1),         &
                 TOTPHI(IMAX,LP1),TOTO3(IMAX,LP1),TPHIO3(IMAX,LP1),   &
                 RLOG(IMAX,LMAX),DELPTC(IMAX),PTOP(IMAX),PBOT(IMAX),  &
                 FTOP(IMAX),FBOT(IMAX) 
!-----------------------------------------------------------------------
!  ------DIMENSION OF VARIABLES EQUIVALENCED TO THOSE ABOVE------
      real    :: TVAL(IMAX,LP1),VSUM1(IMAX,LP1),HEATEM(IMAX,LP1) 
      real    :: EMXX(IMAX,LMAX)
      real    :: CSUB(IMAX,LLP1) 
      real    :: FLX(IMAX,LP1)
      real    :: OSS(IMAX,LP1),CSS(IMAX,LP1),SS2(IMAX,LP1),TC(IMAX,LP1), &
                DTC(IMAX,LP1)
      real    :: ALPSQ1(IMAX,LP1),ALPSQ2(IMAX,LP1) 
      real    :: DELPR1(IMAX,LP1),DELPR2(IMAX,LP1) 
      real    :: FLXNET(IMAX,LP1),FLXTHK(IMAX,LP1) 
      real    :: Z1(IMAX,LP1),CEVAL(IMAX,LP1)
      real    :: TOTEVV(IMAX,LP1)
      real    :: AVMO3(IMAX,LP1M),AVPHO3(IMAX,LP1V),FAC1(IMAX,LP1V)
      real    :: FAC2(IMAX,LP1M),AVVO2(IMAX,LP1M),AVEPHJ(IMAX,LP1V)
!1    DIMENSION OVER(IMAX,LP1,LP1)
!     DIMENSION OVER1D(IMAX,LP1M)
!1    DIMENSION EMISST(IMAX,LP1,LP1)
!---DIMENSION OF VARIABLES EQUIVALENCED TO THOSE IN OTHER COMMON BLKS-- 
!     DIMENSION TO31D(IMAX,LP1M),EMI21D(IMAX,LP1M)
!     DIMENSION CO21D(IMAX,LP1M),EMIS1D(IMAX,LP1M)
!     DIMENSION AVEP1D(IMAX,LP1M),AVEP1(IMAX*LP1M)
!---DIMENSION OF VARIABLES PASSED TO OTHER SUBROUTINES--- 
      real    :: E1CTS1(IMAX,LP1),E1CTS2(IMAX,LMAX) 
      real    :: E1CTW1(IMAX,LP1),E1CTW2(IMAX,LMAX) 
      real    :: FXO(IMAX,LP1),DT(IMAX,LP1)
      real    :: EMD(IMAX,LLP1),TPL(IMAX,LLP1),EMPL(IMAX,LLP1) 
!---EMX1 IS A LOCAL VARIABLE USED AS INPUT AND OUTPUT TO E1E288--
      real    :: EMX1(IMAX)

!     EQUIVALENCE (VTMP3,TVAL,VSUM1,EMXX,TC,HEATEM) 
!     EQUIVALENCE (VTMP2,VTMP21,AVPHO3,FAC1,AVEPHJ) 
!     EQUIVALENCE (VTMP1,AVMO3,FAC2,AVVO2,OVER,EMISST)
!     EQUIVALENCE (DSORC,TOTEVV,DELPR1,OSS,SUM,FLXNET)
!     EQUIVALENCE (TOTPHI,DELPR2,CSS,FLX,Z1)
!     EQUIVALENCE (TOTO3,ALPSQ1,DTC,FLXTHK) 
!     EQUIVALENCE (TPHIO3,ALPSQ2,SS2,CEVAL) 
!     EQUIVALENCE (AVEPHI,AVEP1D,AVEP1),(EMI21D,EMISS2) 
!     EQUIVALENCE (OVER1D,OVER),(TO31D,TO3),(EMIS1D,EMISS)
!     EQUIVALENCE (CO21D,CO21)
!     EQUIVALENCE (ALP,CSUB)
!-----------------------------------------------------------------------

!          FIRST SECTION IS TABLE LOOKUP FOR SOURCE FUNCTION AND
!     DERIVATIVE (B AND DB/DT).ALSO,THE NLTE CO2 SOURCE FUNCTION
!     IS OBTAINED 

      DO K=1,LP1
      DO I=1,IMAX 
         FXO(I,K)=AINT((TEMP(I,K)-100.)*0.10+1.0)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         TVAL(I,K)=90.+10.*FXO(I,K)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         DT(I,K)=TEMP(I,K)-TVAL(I,K) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         IXO(I,K)=FXO(I,K) 
         SS1(I,K)=0.0 
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
      DO 110 N=1,NBLY 

      DO K=1,LP1
      DO I=1,IMAX 
         SORC(I,K,N)=SOURCE(IXO(I,K),N) 
         DSORC(I,K)=DSRCE(IXO(I,K),N) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         SORC(I,K,N)=SORC(I,K,N)+DT(I,K)*DSORC(I,K)
      ENDDO
      ENDDO

      IF (N == 11 .or. N == 12 .or. N == 14) THEN 
         DO K=1,LP1
         DO I=1,IMAX 
            SS1(I,K)=SS1(I,K)+SORC(I,K,N) 
         ENDDO
         ENDDO
      ENDIF 

 110  CONTINUE
!-----------------------------------------------------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         CSOUR1(I,K)=SORC(I,K,9) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CSOUR2(I,K)=SORC(I,K,10)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         OSOUR(I,K)=SORC(I,K,13) 
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
!
!     THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2
! 
!     CALL NLTE (PRESS,RRVCO2)
!     DO 141 K=1,INLTE
!     DO 141 I=1,IMAX 
!     CSOUR1(I,K)=SORC(I,K,9) 
!     CSOUR2(I,K)=SORC(I,K,10)
!141  CONTINUE
! 
!-----------------------------------------------------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         CSOUR(I,K)=CSOUR1(I,K)+CSOUR2(I,K)
      ENDDO
      ENDDO
 
!-----------------------------------------------------------------------
!     SECOND SECTION PRODUCES 4 MATRICES FOR LATER USE IN PROGRAM:  
!     1) AVEPHI(I,J) IS THE SCALED WATER MASS FOR USE IN TABLES (THIS 
!     IS U(P,P'') IN REF.(4);
!     2) OVER (I,J) IS THE WATER TRANSMISSION FUNCTION (USING 
!     "EMISSIVITY" APPROXIMATION) IN THE 560-800 CM-1  BAND;
!     3) TO3(I,J) IS THE EXACT OZONE TRANSMISSION FUNCTION (USING 
!     PARAMETERS FOR THE 990-1070 CM-1 BAND FROM THE 1982 AFGL CATALOG) 
!     4)EMISS2(I,J) IS THE EMISSIVITY H20 TRANSMISSION FUNCTION DUE 
!     TO THE 10 UM CONTINUUM,TREATED AS ONE BAND. 

      DO I=1,IMAX 
         TOTPHI(I,1)=0.0
         TOTO3(I,1)=0.0 
         TPHIO3(I,1)=0.0
         TOTVO2(I,1)=0.0
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1) 
      ENDDO
      ENDDO


!     THE CALCULATIONAL PROCEDURE USED HERE IS: 
!       1) FROM THE 1-D VECTORS (TOTPHI,TOTO3,ETC) CONSTRUCT A 1-D
!  ARRAYS INCLUDING ALL INFORMATION FOR THE UPPER (I>J) TRIANGLE
!  OF THE SYMMETRIC MATRICES(LP1,LP1);
!       2)PERFORM COMPUTATIONS ON THESE ARRAYS TO OBTAIN TO3,OVER,
!  AVEPHJ: UPPER TRIANGLE OF THE SYMMETRIC MATRICES IN 1-D FORM 
!       3) LOAD NUMBERS INTO THE UPPER TRIANGLE OF THE 2-D
!  MATRICES TO3,OVER,AVEPHI,USING THE CDC Q8MERG FUNCTION 
!       4) FILL UP THE LOWER TRIANGLE,USING THE CDC "SCATTER" FUNCTION
!     THE DIAGRAM BELOW ILLUSTRATES THE RELATIONSHIP BETWEEN THE 1-D
!  ARRAY AND THE 2-D SYMMETRIC MATRIX FOR A 4X4 MATRIX. 
! 
!                    I
!             1      2       3       4
!           --------------------------
!        1           1       2       3     THE NOS. ARE THE 
!    J   2                   4       5     POSITIONS IN THE 
!        3                           6     1-D ARRAY
!        4
! 
!***IN ORDER TO USE A MINIMUM OF STORAGE SPACE, THE CALCULATIONS HAVE 
!   BEEN ORDERED AS FOLLOWS:  
! 
!     ---------------------------------------
!     STAGE 1...COMPUTE O3 TRANSMISSION FCTNS
!     ---------------------------------------

      DO K=1,LMAX
         KLEN=LP1-K
         KMAXS=KMAXV(K)
         DO KK=1,KLEN
            DO I=1,IMAX 
               AVMO3(I,KMAXS+KK-1)=TOTO3(I,KK+K)-TOTO3(I,K)
               AVPHO3(I,KMAXS+KK-1)=TPHIO3(I,KK+K)-TPHIO3(I,K) 
            ENDDO
         ENDDO
      ENDDO

!---SOME OF THE CALCS. BELOW ARE "STRIP-MINED" SO THAT VECTOR CALCS.
!   ARE RESTRICTED TO A LENGTH OF 65535.  THIS IS A CYBER 205 LIMIT.
!   (THE COMPILER HANDLES STRIP-MINING  OF FORTRAN 77 CODE).

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         FAC1(I,KK)=BO3RND(2)*AVPHO3(I,KK)/AVMO3(I,KK)
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         FAC2(I,KK)=4.0*AO3RND(2)*AVMO3(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP1(I,KK)=1.0+FAC2(I,KK)/FAC1(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP1(I,KK)=SQRT(VTMP1(I,KK)) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=0.50*(FAC1(I,KK)*(VTMP1(I,KK)-1.0))
      ENDDO
      ENDDO

      DO K=1,LMAX
         KLEN=LP1-K
         KMAXS=KMAXV(K)
         DO KK=1,KLEN
            DO I=1,IMAX 
               AVVO2(I,KMAXS+KK-1)=TOTVO2(I,KK+K)-TOTVO2(I,K)
            ENDDO
         ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         TO3SPC(I,K)=VTMP2(I,K)
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=VTMP2(I,KK)+SKO3R*AVVO2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=-1.0*VTMP2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=EXP(VTMP2(I,KK))
      ENDDO
      ENDDO

      DO K=1,LMAX
         KMAXS=KMAXV(K)
         DO KP=K+1,LP1 
            DO I=1,IMAX 
               TO3(I,KP,K)=VTMP2(I,KMAXS-(K+1)+KP) 
            ENDDO
         ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         TO3(I,K,K)=1.0
      ENDDO
      ENDDO

      DO K=1,KMAXVM 
      DO I=1,IMAX
         TO3(I,INDX1(K),INDX2(K))=VTMP2(I,K)
      ENDDO
      ENDDO

! 
!     -------------------------
!     STAGE 2... COMPUTE AVEPHI 
!     -------------------------
! 
      DO 401 K=1,LMAX
         KLEN=LP1-K
         KMAXS=KMAXV(K)

         DO KK=1,KLEN
         DO I=1,IMAX 
            AVEPHJ(I,KMAXS+KK-1)=TOTPHI(I,KK+K)-TOTPHI(I,K) 
         ENDDO
         ENDDO
 
         DO KP=K+1,LP1 
         DO I=1,IMAX 
            AVEPHI(I,KP,K)=AVEPHJ(I,KMAXS-(K+1)+KP) 
         ENDDO
         ENDDO

 401  CONTINUE


      DO K=1,LP1
      DO I=1,IMAX 
         AVEPHI(I,K,K)=1.01E-16 
      ENDDO
      ENDDO

      DO K=1,KMAXVM 
      DO I=1,IMAX
         AVEPHI(I,INDX1(K),INDX2(K))=AVEPHJ(I,K)
      ENDDO
      ENDDO


!     ----------------------
!     STAGE 3...COMPUTE OVER 
!     ----------------------

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=AB15WD*AVEPHJ(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=SQRT(VTMP2(I,KK)) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=VTMP2(I,KK)+SKC1R*AVVO2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=-1.0*VTMP2(I,KK) 
      ENDDO
      ENDDO

      DO KK=1,KMAXVM
      DO I=1,IMAX 
         VTMP2(I,KK)=EXP(VTMP2(I,KK))
      ENDDO
      ENDDO

!     DO K=1,LMAX
!        KMAXS=KMAXV(K)
!        DO KP=K+1,LP1 
!        DO I=1,IMAX 
!           OVER(I,KP,K)=VTMP2(I,KMAXS-(K+1)+KP)
!        ENDDO
!        ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO I=1,IMAX 
!        OVER(I,K,K)=1.0 
!     ENDDO
!     ENDDO

!     DO K=1,KMAXVM 
!     DO I=1,IMAX
!        OVER(I,INDX1(K),INDX2(K))=VTMP2(I,K)
!     ENDDO
!     ENDDO


!     ------------------------
!     STAGE 4...COMPUTE EMISS2
!     ------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         VTMP3(I,K)=TOTVO2(I,K)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         VTMP3(I,K)=-1.0*VTMP3(I,K) 
      ENDDO
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX
         VTMP3(I,K)=EXP(VTMP3(I,K))
      ENDDO
      ENDDO

!   COMPUTE 1-BAND CONTINUUM TRANSMISSIVITIES (EMISS2)

      DO K=1,LP1
      DO I=1,IMAX 
         TOTEVV(I,K)=1.0/VTMP3(I,K)
      ENDDO
      ENDDO

      DO K=1,LP1
      DO KP=1,K 
      DO I=1,IMAX 
         EMISS2(I,KP,K)=VTMP3(I,K)*TOTEVV(I,KP)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO KP=K+1,LP1 
      DO I=1,IMAX 
         EMISS2(I,KP,K)=VTMP3(I,KP)*TOTEVV(I,K)
      ENDDO
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
!         THE THIRD SECTION CALCULATES BOUNDARY LAYER AND NEARBY LAYER
!     CORRECTIONS TO THE TRANSMISSION FUNCTIONS OBTAINED ABOVE. METHODS 
!     ARE GIVEN IN REF. (4).
!-----------------------------------------------------------------------
!     THE FOLLOWING RATIOS ARE USED IN VARIOUS NBL CALCULATIONS: 

      DO K=2,LMAX
      DO I=1,IMAX 
         DELPR1(I,K)=DELP(I,K)*(PRESS(I,K)-P(I,K)) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         DELPR2(I,K)=DELP(I,K-1)*(P(I,K)-PRESS(I,K-1)) 
      ENDDO
      ENDDO


!        THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE H2O 
!     TRANS. FCTN (OVER) COMBINED WITH THE CO2 FCTN (CO21). 
! 
!       COMBINE CO21,OVER INTO CO21; BEFORE MAKING NBL CORRECTIONS, 
!     LOAD (1,K) VALUES FOR USE IN EXACT CTS CALCULATIONS IN SPA88. 

      DO K=1,LMAX
         KMAXS=KMAXV(K)
         DO KP=K+1,LP1 
         DO I=1,IMAX 
         CO21(I,KP,K)=CO21(I,KP,K)*VTMP2(I,KMAXS-(K+1)+KP)
         ENDDO
         ENDDO
      ENDDO

!     DO K=1,LP1
!     DO I=1,IMAX 
!        OVER(I,K,K)=1.0 
!     ENDDO
!     ENDDO

      DO K=1,KMAXVM 
      DO I=1,IMAX
!        CO21(I,KP,K)=CO21(I,KP,K)*
         CO21(I,indx1(k), indx2(k))=CO21(I,indx1(k), indx2(k))* &
                                       VTMP2(I,K)
      ENDDO
      ENDDO

!     DO K=1,LP1
!     DO KP=1,LP1 
!     DO I=1,IMAX 
!        CO21(I,KP,K)=CO21(I,KP,K)*OVER(I,KP,K)
!     ENDDO
!     ENDDO
!     ENDDO

      DO K=1,LP1
      DO I=1,IMAX 
         CO2SP(I,K)=CO21(I,1,K)
      ENDDO
      ENDDO


!       PERFORM NBL COMPUTATIONS FOR THE CO2 15 UM BAND 

      DO K=2,LMAX
      DO I=1,IMAX 
         ALPSQ1(I,K)=SQRT(DELPR1(I,K)) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         ALPSQ2(I,K)=SQRT(DELPR2(I,K)) 
      ENDDO
      ENDDO


!     DO K=1,LMAX
!        KMAXS=KMAXV(K)
!        DO KP=K+1,LP1 
!        DO I=1,IMAX 
!           OVER(I,KP,K)=VTMP2(I,KMAXS-(K+1)+KP)
!        ENDDO
!        ENDDO
!     ENDDO

!     DO K=1,LP1
!     DO I=1,IMAX 
!        OVER(I,K,K)=1.0 
!     ENDDO
!     ENDDO

!     DO K=1,KMAXVM 
!     DO I=1,IMAX
!        OVER(I,INDX1(K),INDX2(K))=VTMP2(I,K)
!     ENDDO
!     ENDDO

!     DO K=1,LMAX
!     DO I=1,IMAX 
!        RLOG(I,K)=OVER(I,K,K+1) 
!     ENDDO
!     ENDDO

      do k=1,LMAX
      do i=1,IMAX
      do kk=1,KMAXVM
        if (indx1(kk) .eq. k .and. indx2(kk) .eq. (k+1) ) then
          rlog(i,k) = vtmp2(i,kk)
          cycle
        endif
      end do
      end do
      end do


      DO K=1,LMAX
      DO I=1,IMAX 
         RLOG(I,K)=RLOG(I,K)*CO2NBL(I,K) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX
         RLOG(I,K)=LOG(RLOG(I,K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         ALP(I,LM1+K)=-ALPSQ1(I,K)*RLOG(I,K) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         ALP(I,K-1)=-ALPSQ2(I,K)*RLOG(I,K-1) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         ALP(I,LL)=-RLOG(I,LMAX)
         ALP(I,LLP1)=-RLOG(I,LMAX)* &
                         SQRT(DELP(I,LMAX)*(P(I,LP1)-PRESS(I,LM1)))
      ENDDO


!***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY 
!   EVALUATED.

      DO K=1,LLP1 
      DO I=1,IMAX 
         C(I,K)=ALP(I,K)*(-0.66667+ALP(I,K)*(0.25+ALP(I,K)*(-0.066667)))
      ENDDO
      ENDDO

      DO I=1,IMAX 
         CO21(I,LP1,LP1)=1.0+C(I,LMAX)
         CO21(I,LP1,LMAX)=1.0+(DELP2(I,LMAX)*C(I,LL)-(PRESS(I,LMAX)- &
                      P(I,LMAX))*C(I,LLM1))/(P(I,LP1)-PRESS(I,LMAX)) 
         CO21(I,LMAX,LP1)=1.0+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)-    &
                           (P(I,LP1)-PRESS(I,LMAX))*C(I,LMAX))/      &
                           (PRESS(I,LMAX)-PRESS(I,LM1))
      ENDDO


!***  THE K INDICES IN THE FOLLOWING LOOP RUN FROM 21 TO 40 IN THE
!     L40 SKYHI CODE VERSION

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=1.0+0.50*(C(I,LM1+K)+C(I,K-1))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CO21(I,K,K)=CEVAL(I,K-1)
      ENDDO
      ENDDO


!    COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE
!    ONE-BAND CONTINUUM BAND (EMISS2 AND TO3). THE SF2 FUNCTION IS
!    USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4).

      DO K=2,LMAX
      DO I=1,IMAX 
         CSUB(I,K)=CNTVAL(I,K)*DELPR1(I,K) 
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CSUB(I,K+LM1)=CNTVAL(I,K-1)*DELPR2(I,K) 
      ENDDO
      ENDDO


!---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED

      HM5=-0.50
      DO K=2,LLM1 
      DO I=1,IMAX 
!        C(I,K)=CSUB(I,K)*(HM5+CSUB(I,K)*
!    &                               (0.166666-CSUB(I,K)*0.0416666))
         C(I,K)= 0.166666-CSUB(I,K)*0.0416666
         C(I,K)= CSUB(I,K)*(CSUB(I,K)*C(I,K)-0.50)
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMISS2(I,LP1,LP1)=1.0+C(I,LLM1) 
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=1.0+0.50*(C(I,K)+C(I,LM1+K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         EMISS2(I,K,K)=CEVAL(I,K-1)
      ENDDO
      ENDDO

      DO K=2,LLM1 
      DO I=1,IMAX 
         CSUB(I,K)=CSUB(I,K)*SKO3R 
      ENDDO
      ENDDO

!
!---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED

      DO K=2,LLM1 
      DO I=1,IMAX 
         C(I,K)=CSUB(I,K)*(-0.50+CSUB(I,K)* &
                                     (0.166666-CSUB(I,K)*0.0416666))
      ENDDO
      ENDDO

      DO I=1,IMAX 
         TO3(I,LP1,LP1)=1.0+C(I,LLM1)
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=1.0+0.50*(C(I,K)+C(I,LM1+K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         TO3(I,K,K)=CEVAL(I,K-1) 
      ENDDO
      ENDDO


!-----------------------------------------------------------------------
!          FOURTH SECTION OBTAINS WATER TRANSMISSION FUNCTIONS
!     USED IN Q(APPROX) CALCULATIONS AND ALSO MAKES NBL CORRECTIONS:  
!     1) EMISS (I,J) IS THE TRANSMISSION FUNCTION MATRIX OBTAINED 
!     BY CALLING SUBROUTINE E1E288; 
!     2) "NEARBY LAYER" CORRECTIONS (EMISS(I,I)) ARE OBTAINED 
!     USING SUBROUTINE E3V88; 
!     3) SPECIAL VALUES AT THE SURFACE (EMISS(LMAX,LP1),EMISS(LP1,L),
!     EMISS(LP1,LP1)) ARE CALCULATED. 
! 
!     EMXX,AV1,AND EMPL ARE COMPUTED BEFORE AVEPHI IS MODIFIED
! 
!      OBTAIN ARGUMENTS FOR E1E288 AND E3V88: 
!-----------------------------------------------------------------------
! 
      DO I=1,IMAX 
         EMX1(I)=QH2O(I,LMAX)*PRESS(I,LMAX)*(PRESS(I,LMAX)-P(I,LMAX))* &
                                                             GP0INV
      ENDDO

      DO K=1,LM1
      DO I=1,IMAX 
         EMXX(I,K)=AVEPHI(I,K,LMAX)+EMX1(I) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMPL(I,1)=AVEPHI(I,LMAX,LP1) 
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         EMPL(I,K)=QH2O(I,K-1)*P(I,K)*(P(I,K)-PRESS(I,K-1))*GP0INV
      ENDDO
      ENDDO

      DO K=LP2,LL 
      DO I=1,IMAX 
         EMPL(I,K)=QH2O(I,K-LMAX)*P(I,K-LMAX)* &
                   (PRESS(I,K-LMAX)-P(I,K-LMAX))*GP0INV
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMPL(I,LLP1)=EMPL(I,LL) 
      ENDDO

      DO I=1,IMAX 
         TPL(I,1)=TEMP(I,LMAX)
         TPL(I,LP1)=0.50*(TTTT(I,LP1)+TEMP(I,LMAX)) 
         TPL(I,LLP1)=0.50*(TTTT(I,LMAX)+TEMP(I,LMAX))
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         TPL(I,K)=TTTT(I,K) 
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         TPL(I,K+LMAX)=TTTT(I,K) 
      ENDDO
      ENDDO


!---THE CALCULATION OF TTEMP HAS BEEN MOVED TO E1E288 TO SAVE STORAGE 

      DO K=2,LMAX
      DO I=1,IMAX 
         AVEPHI(I,K,K)=EMXX(I,K-1) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         AVEPHI(I,LP1,LMAX)=AVEPHI(I,LP1,LMAX)+EMPL(I,LMAX) 
      ENDDO


!     COMPUTE LOGS OF WATER MASS ARGUMENTS FOR  E1E288; 
!     THE CORRESPONDING QUANTITY FOR E3V88 (EMPL) MUST BE OBTAINED
!     WITHIN THAT SUBROUTINE, AS EMPL IS USED AFTER E3V88 IS CALLED.

      DO KK=1,LP1 
      DO K=1,LP1 
      DO I=1,IMAX
         AVEPHI(I,K,KK)=LOG10(AVEPHI(I,K,KK))
      ENDDO
      ENDDO
      ENDDO
!
!-----------------------------------------------------------------------
!
!     CALL E1E288 FOR EMISSIVITY TRANSMISSION FCTNS FOR H2O 
!     -----------------------------------------------------
           CALL E1E288 (E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,FXO,DT,TEMP)
! 
!-----------------------------------------------------------------------
!
!     CALL E3V88 FOR NBL H2O TRANSMISSIVITIES 
!     ---------------------------------------
           CALL E3V88 (EMD,TPL,EMPL) 
!
!-----------------------------------------------------------------------
! 
!   COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS
!    USING METHODS FOR H2O GIVEN IN REF. (4)

      DO K=2,LMAX
      DO I=1,IMAX 
         CEVAL(I,K-1)=EMD(I,K+LMAX)+EMD(I,K)
      ENDDO
      ENDDO

      DO K=1,LM1
      DO I=1,IMAX 
         EMISS(I,LP1,K)=0.50*(EMISS(I,K+1,K+1)+EMISS(I,LP1,K))
      ENDDO
      ENDDO

      DO K=2,LMAX
      DO I=1,IMAX 
         EMISS(I,K,K)=CEVAL(I,K-1) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         EMISS(I,LMAX,LP1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ &
          EMX1(I) + 0.25*(EMISS(I,LMAX,LP1)+EMISS(I,LP1,LMAX)) 
         EMISS(I,LP1,LP1)=2.0*EMD(I,LP1) 
         EMISS(I,LP1,LMAX)=2.0*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*    &
                        EMPL(I,LLP1))/(QH2O(I,LMAX)*PRESS(I,LMAX)* &
                        (P(I,LP1)-PRESS(I,LMAX))*GP0INV) 
      ENDDO


!-----------------------------------------------------------------------
!     SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER,
!     CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS.
! 
                         CALL SPA88 (PRESS,TEMP)
!
!-----------------------------------------------------------------------
! 
!          THIS SECTION PERFORMS THE CALCULATION OF "EMISSIVITY"
!     FLUXES FOR THE 4 COMPONENTS COMPRISING THE LW FREQUENCY REGION. 
!     (EMISS = THE 0-160,1200-2200 CM-1 BAND; EMISS2 THE 800-990, 
!     1070-1200 CM-1 BAND; TO3 THE 990-1070 CM-1 BAND; CO21 THE 560-800 
!     CM-1 BAND).  EMISST IS THE COMBINED EXCHANGE TERM AND FLX THE 
!     COMBINED NET FLUX.
!
!-----------------------------------------------------------------------

      DO K=1,LP1
      DO I=1,IMAX 
         TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K) 
      ENDDO
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         OSS(I,K)=OSOUR(I,K)-OSOUR(I,K-1)
         CSS(I,K)=CSOUR(I,K)-CSOUR(I,K-1)
         DTC(I,K)=TC(I,K)-TC(I,K-1)
         SS2(I,K)=SS1(I,K)-SS1(I,K-1)
      ENDDO
      ENDDO

!1    DO K=1,LP1
!1    DO I=1,IMAX 
!1       EMISST(I,1,K)=TC(I,1)*E1FLX(I,K)+SS1(I,1)*EMISS2(I,K,1)+
!1   &                 OSOUR(I,1)*TO3(I,K,1)+CSOUR(I,1)*CO2SP(I,K)
!1    ENDDO
!1    ENDDO

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

!1    DO K=1,LP1
!1    DO KP=2,LP1 
!1    DO I=1,IMAX 
!1       EMISST(I,KP,K)=DTC(I,KP)*EMISS(I,KP,K)+
!1   &                  SS2(I,KP)*EMISS2(I,KP,K)+OSS(I,KP)*TO3(I,KP,K)+
!1   &                  CSS(I,KP)*CO21(I,KP,K) 
!1    ENDDO
!1    ENDDO
!1    ENDDO

!1    DO K=1,LP1
!1    DO KP=1,LP1 
!1    DO I=1,IMAX 
!1       EMISST(I,KP,K)=EMISST(I,KP,K)*CLDFAC(I,KP,K)
!1    ENDDO
!1    ENDDO
!1    ENDDO


!---THE ORDER OF THE 911 LOOPS IS TO MINIMIZE "MEMORY CONFLICTS"
!   ON THE CYBER 205

      DO K=1,LP1
      DO I=1,IMAX 
!f       FLX(I,K)=0.0 
         FLX(I,K)=                                                     &
         (TC(I,1)*E1FLX(I,K)+SS1(I,1)*EMISS2(I,K,1)+                   &
                       OSOUR(I,1)*TO3(I,K,1)+CSOUR(I,1)*CO2SP(I,K)) *  &
           cldfac(i,1,k) 
      ENDDO
      ENDDO

!f    DO KP=1,LP1 
      DO KP=2,LP1 
      DO K=1,LP1
      DO I=1,IMAX 
!f       FLX(I,K)=FLX(I,K)+EMISST(I,KP,K)
         FLX(I,K)=FLX(I,K)+                                             &
                       ( DTC(I,KP)*EMISS(I,KP,K)+                       &
                        SS2(I,KP)*EMISS2(I,KP,K)+OSS(I,KP)*TO3(I,KP,K)+ &
                        CSS(I,KP)*CO21(I,KP,K) ) *cldfac(i,kp,k)
      ENDDO
      ENDDO
      ENDDO


!-----------------------------------------------------------------------
!    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 K=1,LMAX 
      DO I=1,IMAX
      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)*(EMISS2(I,K+1,1)*CLDFAC(I,K+1,1)-               &
                        EMISS2(I,K,1)*CLDFAC(I,K,1))) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX
         CEVAL(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)))
      ENDDO
      ENDDO

      DO I=1,IMAX
         FLX1E1(I)=0.0
      ENDDO

      DO K=1,LMAX 
      DO I=1,IMAX
         FLX1E1(I)=FLX1E1(I)+CEVAL(I,K)
      ENDDO
      ENDDO

      DO I=1,IMAX
         FLX1E1(I)=FLX1E1(I)+TC(I,LP1)*CLDFAC(I,LP1,1)* &
                   (E1CTS1(I,LP1)-E1CTW1(I,LP1))
      ENDDO


!-----------------------------------------------------------------------
!     FINAL SECTION OBTAINS EMISSIVITY HEATING RATES, 
!     TOTAL HEATING RATES AND THE FLUX AT THE GROUND
!-----------------------------------------------------------------------

!     .....CALCULATE THE EMISSIVITY HEATING RATES 

      DO K=1,LMAX 
      DO I=1,IMAX
         HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K)
      ENDDO
      ENDDO

!     .....CALCULATE THE TOTAL HEATING RATES

      DO K=1,LMAX 
      DO I=1,IMAX
         HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K)
      ENDDO
      ENDDO

!     .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE
!    TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1) 

      DO K=1,LMAX 
      DO I=1,IMAX
         VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1 
      ENDDO
      ENDDO

      DO I=1,IMAX
         TOPFLX(I)=FLX1E1(I)+GXCTS(I)
      ENDDO


!---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS
!    THE THICK CLOUD SECTION IS INVOKED.

      DO I=1,IMAX
         FLXNET(I,1)=TOPFLX(I) 
      ENDDO

      DO K=2,LP1 
      DO I=1,IMAX
         FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1)
      ENDDO
      ENDDO

      IF (Present(LSFC)) THEN
         DO I=1,IMAX
            GRNFLX(I)=FLXNET(I,LSFC(I)+1) 
         ENDDO
      ELSE
         DO I=1,IMAX
            GRNFLX(I)=FLXNET(I,LP1) 
         ENDDO
      ENDIF


!-----------------------------------------------------------------------
!     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 I=1,IMAX
         ICNT=ICNT+NCLDS(I)
      ENDDO

      IF (ICNT == 0) GO TO 6999


!***THE OUTER LOOP IS ON THE NO. OF CLOUDS( BEGINNING AT NC=2,AS NC=1 IS
!   A DUMMY LAYER)

!    **************************************
              DO 6001 NC=2,LP1
!    **************************************

!***OBTAIN THE LARGEST NO. OF CLOUDS IN THE LAT. ROW. IF THE CLOUD
!   INDEX (NC) IS GREATER THAT THIS NO.,TERMINATE THE CLOUD LOOP

      ICNT=0
      DO I=1,IMAX
         IF (NCLDS(I) >= NC-1) THEN
            ICNT=ICNT+1
         ENDIF
      ENDDO
      IF (ICNT == 0) GO TO 6999 

!***FOR THE NC''TH CLOUD LEVEL,OBTAIN THE TOP AND BOTTOM INDEX,AND 
!   COUNT THE NO. OF THICK CLOUDS (DEFINED AS A NONZERO DIFFERENCE
!   BET. THE TOP AND BOTTOM INDICES). SKIP TO THE NEXT CLOUD INDEX
!   (INCREMENT NC) IF THIS NO. IS ZERO. 

      DO I=1,IMAX
         ITOP(I)=KTOP(I,NC)
         IBOT(I)=KBTM(I,NC)
      ENDDO

      ICNT=0
      DO I=1,IMAX
         IF (ITOP(I) < IBOT(I)) THEN
            ICNT=ICNT+1
         ENDIF
      ENDDO
      IF (ICNT == 0) GO TO 6001 

!***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 I=1,IMAX
         PTOP(I)=P(I,ITOP(I))
         FTOP(I)=FLXNET(I,ITOP(I))
         PBOT(I)=P(I,IBOT(I)+1)
         FBOT(I)=FLXNET(I,IBOT(I)+1)
      ENDDO

!***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC) 

      DO I=1,IMAX
         DELPTC(I)=(FBOT(I)-FTOP(I))/(PBOT(I)-PTOP(I)) 
      ENDDO

!***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR 
!   ALL LEVELS. THIS QUANTITY WILL BE USED ONLY IN THE THICK CLOUD
!   LEVELS, BUT, FOR EFFICIENCY, IS COMPUTED FOR ALL LEVELS.

      DO K=1,LP1 
      DO I=1,IMAX
         Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I)
      ENDDO
      ENDDO

!***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 K=1,LP1 
      DO I=1,IMAX
         FLXTHK(I,K)=FLXNET(I,K)*(1.0-CAMT(I,NC)*EMCLD(I,NC)) + &
                     Z1(I,K)*CAMT(I,NC)*EMCLD(I,NC)
      ENDDO
      ENDDO

!***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS. 

      DO K=1,LP1
      DO I=1,IMAX
         IF (K > ITOP(I) .and. K <= IBOT(I)  &
                          .and.  (NC-1) <= NCLDS(I))  THEN
              FLXNET(I,K)=FLXTHK(I,K)
         ENDIF
      ENDDO
      ENDDO

!                   ******END OF CLOUD LOOP***** 
 6001                        CONTINUE
!                   ***************************

!-----------------------------------------------------------------------
!                THE THICK CLOUD SECTION ENDS HERE.
!-----------------------------------------------------------------------

 6999                        CONTINUE

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

!***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE 
!   REVISED FLUXES: 

      DO K=1,LMAX 
      DO I=1,IMAX
         HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K)
      ENDDO
      ENDDO

!---------------------------------------------------------------------**
      END SUBROUTINE FST88

!#######################################################################
!#######################################################################

      SUBROUTINE E1E288 (G1,G2,G3,G4,G5,FXOE1,DTE1,TEMP)

!-----------------------------------------------------------------------
!     SUBROUTINE E1E288 COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION
!  FOR LONGWAVE RADIATION FOR ALL TERMS EXCEPT THE EXCHANGE WITH THE
!  TOP OF THE ATMOSPHERE. THE METHOD IS A TABLE LOOKUP ON A PRE-
!  COMPUTED E2 FUNCTION (DEFINED IN REF. (4)).
!      THE E1 FUNCTION  CALCULATIONS (FORMERLY DONE IN SUBROUTINE 
!  E1V88 COMPUTE THE FLUX RESULTING FROM THE EXCHANGE OF PHOTONS
!  BETWEEN A LAYER AND THE TOP OF THE ATMOSPHERE.  THE METHOD IS A
!  TABLE LOOKUP ON A PRE-COMPUTED E1 FUNCTION.
!     CALCULATIONS ARE DONE IN TWO FREQUENCY RANGES:  
!       1) 0-560,1200-2200 CM-1   FOR Q(APPROX) 
!       2) 160-560 CM-1           FOR Q(APPROX,CTS).
!  MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4).
!-----------------------------------------------------------------------
!       INPUTS:                    (COMMON BLOCKS)
!     TABLE1,TABLE2,TABLE,EM1,EM1WDE   TABCOM 
!     AVEPHI                           TFCOM
!     TEMP                      ARGUMENT LIST 
!     T                                KDACOM 
!     FXOE1,DTE1                ARGUMENT LIST 
!
!       OUTPUTS:  
!     EMISS                            TFCOM
!     G1,G2,G3                  ARGUMENT LIST,FOR 1ST FREQ. RANGE 
!     G4,G5                     ARGUMENT LIST,FOR 2ND FREQ. RANGE 
! 
!        CALLED BY :     FST88
!        CALLS     :  
! 
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "tabcom.h"
real :: EM1   (28,180),EM1WDE(28,180),EM3   (28,180),  &
     &                 TABLE1(28,180),TABLE2(28,180),TABLE3(28,180)
      COMMON /TABCOM/  EM1   , EM1WDE, EM3   ,  &
     &                 TABLE1, TABLE2, TABLE3
!-----------------------------------------------------------------------
      REAL,  INTENT(OUT), DIMENSION(:,:) :: G1,G2,G3,G4,G5
      REAL,  INTENT(IN) , DIMENSION(:,:) :: FXOE1,DTE1,TEMP

!**** I/O ARGUMENTS
!CC   DIMENSION FXOE1(IMAX,LP1),DTE1(IMAX,LP1),G1(IMAX,LP1),
!CC  &          G2(IMAX,LMAX),G3(IMAX,LP1),G4(IMAX,LP1),G5(IMAX,LMAX) 
!CC   DIMENSION  TEMP(IMAX,LP1)
!-----------------------------------------------------------------------
      integer :: kk, k, i, kp
      integer :: IT1(IMAX,LL3P) 
      real    :: TTEMP(IMAX,LP1,LP1)
      real    :: FIT1(IMAX,LL3P),DTOT1(IMAX,LL3P),                    &
                 DTOT2(IMAX,LL3P),DTOT3(IMAX,LL3P),DTOT4(IMAX,LL3P),  &
                 WW1(IMAX,LP1),WW2(IMAX,LP1)
      real    :: FYO(IMAX,LP1),DU(IMAX,LP1),F1(IMAX,LP1)
!-----------------------------------------------------------------------
      real    :: FXO(IMAX,LP1),FIVAL(IMAX,LP1),  &
                    DT(IMAX,LP1),F2(IMAX,LP1),F3(IMAX,LP1)
      integer :: IVAL(IMAX,LP1)
      real    :: T1(5040),T2(5040),T4(5040)
      real    :: EM1V(5040),EM1VW(5040)
!     DIMENSION TTMP1D(IMAX,LP1M) 

      CHARACTER(LEN=40) :: err_string
!-----------------------------------------------------------------------
      EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) 
!     EQUIVALENCE (TTMP1D,TTEMP)
!     EQUIVALENCE (IVAL,IT1),(FIVAL,FIT1),(DT,WW1)
!     EQUIVALENCE (FXO,WW2),(F2,DTOT2),(F3,DTOT3) 
      EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)),  &
                  (T4(1),TABLE3(1,1))
!-----------------------------------------------------------------------

      DO KK=1,LP1
      DO K=1,LP1
      DO I=1,IMAX 
         TTEMP(I,K,KK)=TTTT(I,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,LM1
      DO I=1,IMAX 
         TTEMP(I,K+1,K+1)=TEMP(I,LMAX)
      ENDDO
      ENDDO

      DO I=1,IMAX 
         TTEMP(I,LP1,LMAX)=TEMP(I,LM1)
      ENDDO


!-----------------------------------------------------------------------
!---THE REST OF THE SUBROUTINE IS CARRIED OUT WITHIN A K-LOOP (121) 
!    PRIMARILY TO CONSERVE STORAGE. SOME LOSS OF SPEED OCCURS.
!-----------------------------------------------------------------------
                         DO 121 K=1,LP1
!-----------------------------------------------------------------------
! 
      DO KP=1,LP1 
      DO I=1,IMAX 
         FXO(I,KP)=AINT((TTEMP(I,KP,K)-100.)*0.10+1.0) 
         FYO(I,KP)=AINT((AVEPHI(I,KP,K)+16.)*10.)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         DU(I,KP)=AVEPHI(I,KP,K)-0.10*(FYO(I,KP)+1.0)+16.1
         DT(I,KP)=TTEMP(I,KP,K)-10.*FXO(I,KP)-90.
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         FYO(I,KP)=28.*FYO(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         FIVAL(I,KP)=FYO(I,KP)+FXO(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         IVAL(I,KP)=FIVAL(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1
      DO I=1,IMAX
         IF (IVAL(I,KP) > 5040) THEN
            Write (err_string(1:32),800) i,kp,ival(i,kp)
 800        Format ('i,kp,ival=',2i6,i10)
            CALL Error_Mesg ('E1E288 in LONGWAVE_MOD', &
                             err_string(1:32), NOTE)
         ENDIF
         F1(I,KP)=T1(IVAL(I,KP)) 
         F2(I,KP)=T2(IVAL(I,KP)) 
         F3(I,KP)=T4(IVAL(I,KP)) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         EMISS(I,KP,K)=F1(I,KP)+DU(I,KP)*F2(I,KP)+DT(I,KP)*F3(I,KP)
      ENDDO
      ENDDO


!***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).
! 
!                      ----------------
                       IF (K == 1) THEN
!                      ----------------

      DO KP=1,LP1 
      DO I=1,IMAX 
         FIT1(I,KP)=FYO(I,KP)+FXOE1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LMAX 
      DO I=1,IMAX 
         FIT1(I,LP1+KP)=FYO(I,KP+1)+FXOE1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         FIT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1)
      ENDDO
      ENDDO

      DO KP=1,LL3P
      DO I=1,IMAX 
         IT1(I,KP)=FIT1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         WW1(I,KP)=10.-DTE1(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         WW2(I,KP)=0.10-DU(I,KP)
      ENDDO
      ENDDO

      DO KP=1,LL3P 
      DO I=1,IMAX
         DTOT1(I,KP)=EM1V(IT1(I,KP)) 
         DTOT2(I,KP)=EM1V(IT1(I,KP)+1) 
         DTOT3(I,KP)=EM1V(IT1(I,KP)+28)
         DTOT4(I,KP)=EM1V(IT1(I,KP)+29)
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
      G1(I,KP)=WW1(I,KP)*WW2(I,KP)*DTOT1(I,KP)+  &
               WW2(I,KP)*DTE1(I,KP)*DTOT2(I,KP)+ &
               WW1(I,KP)*DU(I,KP)*DTOT3(I,KP)+   &
               DTE1(I,KP)*DU(I,KP)*DTOT4(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LMAX 
      DO I=1,IMAX 
      G2(I,KP)=WW1(I,KP)*WW2(I,KP+1)*DTOT1(I,KP+LP1)+  &
               WW2(I,KP+1)*DTE1(I,KP)*DTOT2(I,KP+LP1)+ &
               WW1(I,KP)*DU(I,KP+1)*DTOT3(I,KP+LP1)+   &
               DTE1(I,KP)*DU(I,KP+1)*DTOT4(I,KP+LP1) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
      G3(I,KP)=WW1(I,1)*WW2(I,KP)*DTOT1(I,KP+LLP1)+   &
               WW2(I,KP)*DTE1(I,1)*DTOT2(I,KP+LLP1)+  &
               WW1(I,1)*DU(I,KP)*DTOT3(I,KP+LLP1)+    &
               DTE1(I,1)*DU(I,KP)*DTOT4(I,KP+LLP1) 
      ENDDO
      ENDDO


!...REPEAT FOR WIDE-BAND COMPUTATIONS OF G4,G5

      DO KP=1,LLP1 
      DO I=1,IMAX
         DTOT1(I,KP)=EM1VW(IT1(I,KP))
         DTOT2(I,KP)=EM1VW(IT1(I,KP)+1)
         DTOT3(I,KP)=EM1VW(IT1(I,KP)+28) 
         DTOT4(I,KP)=EM1VW(IT1(I,KP)+29) 
      ENDDO
      ENDDO

      DO KP=1,LP1 
      DO I=1,IMAX 
         G4(I,KP)=WW1(I,KP)*WW2(I,KP)*DTOT1(I,KP)+   &
                  WW2(I,KP)*DTE1(I,KP)*DTOT2(I,KP)+  &
                  WW1(I,KP)*DU(I,KP)*DTOT3(I,KP)+    &
                  DTE1(I,KP)*DU(I,KP)*DTOT4(I,KP) 
      ENDDO
      ENDDO

      DO KP=1,LMAX 
      DO I=1,IMAX 
         G5(I,KP)=WW1(I,KP)*WW2(I,KP+1)*DTOT1(I,KP+LP1)+   &
                  WW2(I,KP+1)*DTE1(I,KP)*DTOT2(I,KP+LP1)+  &
                  WW1(I,KP)*DU(I,KP+1)*DTOT3(I,KP+LP1)+    &
                  DTE1(I,KP)*DU(I,KP+1)*DTOT4(I,KP+LP1) 
      ENDDO
      ENDDO

!                       -------------
                            ENDIF 
!-----------------------------------------------------------------------
 121                       CONTINUE
!-----------------------------------------------------------------------
      END SUBROUTINE E1E288

!#######################################################################
!#######################################################################

      SUBROUTINE E3V88 (EMV,TV,AV) 

!C    IMPLICIT NONE
!-----------------------------------------------------------------------
!     SUBROUTINE E3V88 COMPUTES NEARBY LAYER TRANSMISSIVITIES FOR 
!  H2O USING A TABLE LOOKUP OF THE PRE-COMPUTED E3 FUNCTION 
! ( DESCRIBED IN REF. (4)). 
!-----------------------------------------------------------------------
!         INPUTS:                 (COMMON BLOCKS,ARGS.) 
!       TV,AV                      ARGUMENT LIST
!       EM3                        TABCOM 
!
!          OUTPUTS: 
!       EMV                        ARGUMENT LIST
! 
!       CALLED BY  :    FST88 
! 
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "tabcom.h"
      real ::          EM1   (28,180),EM1WDE(28,180),EM3   (28,180), &
                       TABLE1(28,180),TABLE2(28,180),TABLE3(28,180)
      COMMON /TABCOM/  EM1    ,EM1WDE ,EM3   , &
                       TABLE1 ,TABLE2 ,TABLE3
!-----------------------------------------------------------------------
      REAL, INTENT(OUT), DIMENSION(:,:) :: EMV
      REAL, INTENT(IN),  DIMENSION(:,:) :: TV,AV

      INTEGER, DIMENSION(SIZE(TV,1),SIZE(TV,2)) ::  IT
      REAL, DIMENSION(SIZE(TV,1),SIZE(TV,2)) ::  FXO,FYO,FIT,WW1, &
                            AV1LOG,D1,D2,D3,D4,TVAL,DT,WW2,UVAL,DU
!-----------------------------------------------------------------------
      REAL :: EM3V(5040)
      INTEGER I,K
!-----------------------------------------------------------------------
      EQUIVALENCE (EM3V(1),EM3(1,1))
!-----------------------------------------------------------------------

         AV1LOG(:,:)=LOG10(AV(:,:))

         FXO(:,:)=AINT((TV(:,:)-100.)*0.10+1.0)

         TVAL(:,:)=90.+10.*FXO(:,:)

         DT(:,:)=TV(:,:)-TVAL(:,:) 

         FYO(:,:)=AINT((AV1LOG(:,:)+16.)*10.)

         UVAL(:,:)=-16.1+0.10*(FYO(:,:)+1.0)

         DU(:,:)=AV1LOG(:,:)-UVAL(:,:) 

         FIT(:,:)=FXO(:,:)+FYO(:,:)*28.

         IT(:,:)=FIT(:,:)

      DO K=1,SIZE(TV,2)
      DO I=1,SIZE(TV,1)
         D1(I,K)=EM3V(IT(I,K)) 
         D2(I,K)=EM3V(IT(I,K)+1) 
         D3(I,K)=EM3V(IT(I,K)+28)
         D4(I,K)=EM3V(IT(I,K)+29)
      ENDDO
      ENDDO

         WW1(:,:)=10.-DT(:,:)
         WW2(:,:)=0.10-DU(:,:)

         EMV(:,:)=WW1(:,:)*WW2(:,:)*D1(:,:)+WW2(:,:)*DT(:,:)*D2(:,:)+ &
                  WW1(:,:)*DU(:,:)*D3(:,:)+DT(:,:)*DU(:,:)*D4(:,:) 

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

!#######################################################################
!#######################################################################

      SUBROUTINE SPA88 (PRESS,TEMP)

!-----------------------------------------------------------------------
!     SUBROUTINE SPA88 COMPUTES EXACT CTS HEATING RATES AND FLUXES AND
!  CORRESPONDING CTS EMISSIVITY QUANTITIES FOR H2O,CO2 AND O3.
!
!          INPUTS:                (COMMON BLOCKS) 
!       ACOMB,BCOMB,APCM,BPCM                  BDCOMB 
!       ATPCM,BTPCM,BETACM                     BDCOMB 
!       BETINW                                 BDWIDE 
!       VAR1,VAR2,P,DELP,DELP2                 KDACOM 
!       TOTVO2,TO3SPC,CO2SP1,CO2SP2,CO2SP      TFCOM
!       CLDFAC                                 CLDCOM 
!       SKO2D                                  TABCOM 
!       SORC,CSOUR,OSOUR                       SRCCOM 
!           OUTPUTS:  
!       EXCTS,EXCTSN,CTSO3                     TFCOM
!        GXCTS,FCTSG                           RDFLUX 
!           CALLED BY:  
!       FST88 
! 
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
!#include "bdwide.h"
!-----------------------------------------------------------------------
!#include "bdcomb.h"
!-----------------------------------------------------------------------
      REAL,  INTENT(IN), DIMENSION(:,:) :: PRESS,TEMP

!     DIMENSION  PRESS(IMAX,LP1),TEMP(IMAX,LP1)
!-----------------------------------------------------------------------
      integer :: k, n
      real ::    CAPPHI(IMAX,LP1),CAPPSI(IMAX,LP1),TT(IMAX,LMAX), &
                 FAC1(IMAX,LMAX),FAC2(IMAX,LMAX),                 &
                 CTMP(IMAX,LP1),CDIF(IMAX,LMAX),                  &
                 TOPM(IMAX,LMAX),TOPPHI(IMAX,LMAX),               &
                 BOT(IMAX),                                       &
                 X(IMAX,LMAX),Y(IMAX,LMAX),VFLUX(IMAX,LMAX)
!-----------------------------------------------------------------------
      real :: F(IMAX,LMAX),FF(IMAX,LMAX),AG(IMAX,LMAX),AGG(IMAX,LMAX), &
       AH(IMAX,LMAX),AHH(IMAX,LMAX),AI(IMAX,LMAX),AII(IMAX,LMAX),        &
       AJ(IMAX,LMAX),AJJ(IMAX,LMAX),FELSX(IMAX,LMAX),                    &
       PHITMP(IMAX,LMAX),PSITMP(IMAX,LMAX)
!-----------------------------------------------------------------------
!     EQUIVALENCE (CAPPHI,AJ,AI,AH,AG,F,PHITMP) 
!     EQUIVALENCE (CAPPSI,AJJ,AII,AHH,AGG,FF,PSITMP)
!-----------------------------------------------------------------------

!     COMPUTE TEMP. TEMPEDENCE OF LINE INTENSITIES (CAPPHI,CAPPSI)

      DO K=1,LMAX
      DO I=1,IMAX 
         X(I,K)=TEMP(I,K)-250.
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         Y(I,K)=X(I,K)*X(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         EXCTS(I,K)=0.0 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         GXCTS(I)=0.0 
      ENDDO

!*************BEGIN LOOP ON FREQUENCY BANDS (N)*************************

                       DO 200 N=1,NBLM 

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

      DO K=1,LMAX
      DO I=1,IMAX 
         F(I,K)=0.044194*(APCM(N)*X(I,K)+BPCM(N)*Y(I,K)) 
         FF(I,K)=0.044194*(ATPCM(N)*X(I,K)+BTPCM(N)*Y(I,K))
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AG(I,K)=(1.418191+F(I,K))*F(I,K)+1.0
         AGG(I,K)=(1.418191+FF(I,K))*FF(I,K)+1.0 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AH(I,K)=AG(I,K)*AG(I,K) 
         AHH(I,K)=AGG(I,K)*AGG(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AI(I,K)=AH(I,K)*AH(I,K) 
         AII(I,K)=AHH(I,K)*AHH(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         AJ(I,K)=AI(I,K)*AI(I,K) 
         AJJ(I,K)=AII(I,K)*AII(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CAPPHI(I,K)=AJ(I,K)*AJ(I,K) 
         CAPPSI(I,K)=AJJ(I,K)*AJJ(I,K) 
      ENDDO
      ENDDO


!   OBTAIN WEIGHED OPTICAL PATH AND MEAN PRESSURE (TOPM,TOPPHI) 

      DO K=1,LMAX
      DO I=1,IMAX 
         PHITMP(I,K)=VAR1(I,K)*CAPPHI(I,K) 
         PSITMP(I,K)=VAR2(I,K)*CAPPSI(I,K) 
      ENDDO
      ENDDO

      DO I=1,IMAX 
         TOPM(I,1)=PHITMP(I,1) 
         TOPPHI(I,1)=PSITMP(I,1) 
      ENDDO

      DO K=2,LMAX
!     DO I=1,IMAX 
         TOPM(:,K)=TOPM(:,K-1)+PHITMP(:,K) 
         TOPPHI(:,K)=TOPPHI(:,K-1)+PSITMP(:,K) 
!     ENDDO
      ENDDO

!***COMPUTE CTS TRANSMISSION FCTNS FOR ALL BANDS (TT) 

      DO K=1,LMAX
      DO I=1,IMAX 
         FAC1(I,K)=ACOMB(N)*TOPM(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(N)*TOPPHI(I,K))
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         FELSX(I,K)=FAC1(I,K)/SQRT(1.0+FAC2(I,K))
      ENDDO
      ENDDO


!***ADD H2O CONTINUUM PATHS FOR FREQ. BANDS 5-14

      IF (N >= 5 .and. N <= 14) THEN
         DO K=1,LMAX
         DO I=1,IMAX 
            FELSX(I,K)=FELSX(I,K)+BETACM(N)*TOTVO2(I,K+1)*SKO2D 
         ENDDO
         ENDDO
      ENDIF 

!***ADD O3 PATHS FOR BAND 13:990-1070 BAND

      IF (N == 13) THEN 
         DO K=1,LMAX
         DO I=1,IMAX 
            FELSX(I,K)=FELSX(I,K)+TO3SPC(I,K) 
         ENDDO
         ENDDO
      ENDIF 

      DO K=1,LMAX
      DO I=1,IMAX 
         FELSX(I,K)=-1.0*FELSX(I,K) 
      ENDDO
      ENDDO


!***COMPUTE EXPONENTIAL (TT)

      DO K=1,LMAX
      DO I=1,IMAX
         TT(I,K)=EXP(FELSX(I,K))
      ENDDO
      ENDDO

!***ADD THE CO2 TRANSMISSIVITIES FOR BANDS 9 AND 10 (15 UM BAND)

      IF (N == 9) THEN
         DO K=1,LMAX
         DO I=1,IMAX 
            TT(I,K)=TT(I,K)*CO2SP1(I,K+1) 
         ENDDO
         ENDDO
      ENDIF 

      IF (N == 10) THEN 
         DO K=1,LMAX
         DO I=1,IMAX 
            TT(I,K)=TT(I,K)*CO2SP2(I,K+1) 
         ENDDO
         ENDDO
      ENDIF 

!*** COMPUTE EXACT CTS HEATING RATES (EXCTS,EXCTSN) 

      DO I=1,IMAX 
         CTMP(I,1)=1.0 
      ENDDO

      DO K=2,LP1
      DO I=1,IMAX 
         CTMP(I,K)=TT(I,K-1)*CLDFAC(I,K,1) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         CDIF(I,K)=SORC(I,K,N)*(CTMP(I,K+1)-CTMP(I,K)) 
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         EXCTSN(I,K,N)=RADCON*DELP(I,K)*CDIF(I,K)
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         EXCTS(I,K)=EXCTS(I,K)+EXCTSN(I,K,N) 
      ENDDO
      ENDDO


!    OBTAIN EXACT CTS FLUXES (GXCTS,FCTSG) AND APPROX CTS HEATING 
!     RATES (CTSO3) 

      DO I=1,IMAX 
         BOT(I)=0.50*DELP(I,LMAX)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,LMAX)) + &
                   TT(I,LMAX)*(P(I,LP1)+PRESS(I,LMAX)-2.0*P(I,LMAX)))
      ENDDO

      DO I=1,IMAX 
         FCTSG(I,N)=CLDFAC(I,LP1,1)*(TT(I,LMAX)*SORC(I,LMAX,N)+  &
                    BOT(I)*(SORC(I,LP1,N)-SORC(I,LMAX,N)))
      ENDDO

      DO I=1,IMAX 
         GXCTS(I)=GXCTS(I)+FCTSG(I,N)
      ENDDO


!**************END LOOP ON FREQUENCY BANDS******************************

 200                   CONTINUE

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

      DO K=1,LMAX
      DO I=1,IMAX 
         VFLUX(I,K)=EXCTS(I,K)*DELP2(I,K)*RADCON1
      ENDDO
      ENDDO

      DO K=1,LMAX
      DO I=1,IMAX 
         GXCTS(I)=GXCTS(I)-VFLUX(I,K)
      ENDDO
      ENDDO

!*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
!     (CTSO3) 

      DO K=1,LMAX
      DO I=1,IMAX 
         CTSO3(I,K)=RADCON*DELP(I,K)*                          &
                    (CSOUR(I,K)*(CO2SP(I,K+1)*CLDFAC(I,K+1,1)- &
                                 CO2SP(I,K)*CLDFAC(I,K,1))  +  &
                     OSOUR(I,K)*(TO3(I,K+1,1)*CLDFAC(I,K+1,1)- &
                                 TO3(I,K,1)*CLDFAC(I,K,1)))
      ENDDO
      ENDDO

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

!#######################################################################
!#######################################################################

!         CO21                            TFCOM 
      SUBROUTINE NLTE (PRESS,RRVCO2)

!-----------------------------------------------------------------------
!     SUBROUTINE NLTE IS THE PRESENT FORMULATION OF AN NLTE 
!     CALCULATION OF THE SOURCE FCTN IN THE 15 UM REGION (2 BANDS)
!-----------------------------------------------------------------------
!
!     RRVCO2 IS THE VOLUME MIXING RATIO OF CO2 (SCALAR)
!
!-----------------------------------------------------------------------
!
!           INPUTS                       (COMMON BLOCKS)
!         BANDLO,BANDHI                   BANDTA
!         DELP                            KDACOM
!         CO21                            TFCOM 
!         CSOUR1,CSOUR2                   SRCCOM
!           OUTPUTS:  
!         SORC                            SRCCOM
!-----------------------------------------------------------------------
      REAL, INTENT(IN), DIMENSION(:,:) :: PRESS
      REAL, INTENT(IN)                 :: RRVCO2
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
      integer :: n, k, i, KP, IITER
      real ::      CMTRX(IMAX,LMAX,INLTE),VNL(IMAX,LMAX,INLTE),     &
            VSUM(IMAX,INLTE),BDENOM(IMAX,INLTE),CDIAG(IMAX,INLTE),    &
            TCOLL(IMAX,INLTE),FNLTE(IMAX,INLTE),                      &
            AZ(IMAX,INLTE),AG(IMAX,INLTE),                            &
            C1B7(2),C2B7(2),CENT(2),DEL(2) 
!-----------------------------------------------------------------------
!*****DEGENERACY FACTOR=0.5*****
      real DEGEN
      DATA DEGEN /0.5/ 
!-----------------------------------------------------------------------

      DO N=1,2
         CENT(N)=0.50*(BANDLO(N+NNLTE)+BANDHI(N+NNLTE)) 
         DEL(N)=BANDHI(N+NNLTE)-BANDLO(N+NNLTE)
         C1B7(N)=3.7412E-5*CENT(N)*CENT(N)*CENT(N)*DEL(N) 
         C2B7(N)=1.4387*CENT(N) 
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         TCOLL(I,K)=DEGEN*1.5E-5*PRESS(I,LP1)/(SECPDA*PRESS(I,K)) 
         FNLTE(I,K)=3.5*TCOLL(I,K)*C1B7(1)/(RRVCO2*C2B7(1)) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LM1 
      DO I=1,IMAX 
         CMTRX(I,KP,K)=RADCON*DELP(I,K)*(CO21(I,KP,K+1)-CO21(I,KP+1,K+1)  &
                       -CO21(I,KP,K)+CO21(I,KP+1,K)) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CMTRX(I,LMAX,K)=DELP(I,K)*(CO21(I,LMAX,K+1)-CO21(I,LMAX,K))* &
                         RADCON
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CDIAG(I,K)=CMTRX(I,K,K) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         BDENOM(I,K)=1.0/(1.0-FNLTE(I,K)*CDIAG(I,K)) 
         SORC(I,K,9)=CSOUR1(I,K) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LMAX 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*CSOUR1(I,KP)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=INLTEP,LMAX
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AZ(I,K)=CSOUR1(I,K)+FNLTE(I,K)*VSUM(I,K)
      ENDDO
      ENDDO

!              **** ITERATION BEGINS HERE ****

                       DO IITER=1,2
!                      ------------

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*SORC(I,KP,9)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AG(I,K)=FNLTE(I,K)*(VSUM(I,K)-CDIAG(I,K)*SORC(I,K,9)) 
         SORC(I,K,9)=BDENOM(I,K)*(AZ(I,K)+AG(I,K)) 
      ENDDO
      ENDDO

!                      -----------
                          ENDDO
!                      -----------

      DO K=1,INLTE
      DO I=1,IMAX 
         TCOLL(I,K)=DEGEN*1.5E-5*PRESS(I,LP1)/(SECPDA*PRESS(I,K)) 
         FNLTE(I,K)=3.5*TCOLL(I,K)*C1B7(2)/(RRVCO2*C2B7(2)) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LM1 
      DO I=1,IMAX 
         CMTRX(I,KP,K)=RADCON*DELP(I,K)*(CO21(I,KP,K+1)-CO21(I,KP+1,K+1) &
                       -CO21(I,KP,K)+CO21(I,KP+1,K)) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CMTRX(I,LMAX,K)=DELP(I,K)*(CO21(I,LMAX,K+1)-CO21(I,LMAX,K))* &
                         RADCON
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         CDIAG(I,K)=CMTRX(I,K,K) 
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         BDENOM(I,K)=1.0/(1.0-FNLTE(I,K)*CDIAG(I,K)) 
         SORC(I,K,10)=CSOUR2(I,K)
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,LMAX 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*CSOUR2(I,KP)
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=INLTEP,LMAX
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AZ(I,K)=CSOUR2(I,K)+FNLTE(I,K)*VSUM(I,K)
      ENDDO
      ENDDO

!             **** ITERATION BEGINS HERE ****

                       DO IITER=1,2
!                      ------------

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VNL(I,KP,K)=CMTRX(I,KP,K)*SORC(I,KP,10) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX
         VSUM(I,K)=0.0
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO KP=1,INLTE 
      DO I=1,IMAX 
         VSUM(I,K)=VSUM(I,K)+VNL(I,KP,K) 
      ENDDO
      ENDDO
      ENDDO

      DO K=1,INLTE
      DO I=1,IMAX 
         AG(I,K)=FNLTE(I,K)*(VSUM(I,K)-CDIAG(I,K)*SORC(I,K,10))
         SORC(I,K,10)=BDENOM(I,K)*(AZ(I,K)+AG(I,K))
      ENDDO
      ENDDO

!                      -----------
                          ENDDO
!                      -----------

      END SUBROUTINE NLTE

!#######################################################################
!#######################################################################

      SUBROUTINE CLO88 (KTOP,KBTM,NCLDS,CAMT,EMCLD)

!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!     SUBROUTINE CLO88 COMPUTES CLOUD TRANSMISSION FUNCTIONS FOR THE
!  LONGWAVE CODE,USING CODE WRITTEN BY BERT KATZ (301-763-8161).
!  AND MODIFIED BY DAN SCHWARZKOPF IN DECEMBER,1988.
!-----------------------------------------------------------------------
!                        INPUT PARAMETERS
!                        ----------------
!
!      KTOP    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD TOP,USED
!                    IN THE LONGWAVE PROGRAM
!      KBTM    =  INDEX OF (DATA LEVEL) PRESSURE OF CLOUD BOTTOM,
!                    USED IN THE LONGWAVE PROGRAM
!      NCLDS   =  NO. CLOUDS AT EACH GRID PT.
!      EMCLD   =  CLOUD EMISSIVITY. SET TO ONE BY DEFAULT, BUT MAY
!                    BE MODIFIED FOR USE IN LONGWAVE PROGRAM.
!      CAMT    =  CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE
!                 SPECIFIED IN THE KTOP/KBTM INDICES)
!
!-----------------------------------------------------------------------
!
!                OUTPUT:  
!      CLDFAC                       CLDCOM
! 
!----------------INPUT ARGUMENTS----------------------------------------

      INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOP,KBTM
      INTEGER, INTENT(IN), DIMENSION(:)   :: NCLDS
      REAL,    INTENT(IN), DIMENSION(:,:) :: EMCLD,CAMT

!                         D I M E N S I O N
!    &  KTOP(IMAX,LP1),KBTM(IMAX,LP1),NCLDS(IMAX),EMCLD(IMAX,LP1),
!    &  CAMT(IMAX,LP1)
!-----------------------------------------------------------------------
!     DIMENSION        V1(IMAX,LP1,LP1),
      integer :: k, kp, nc, icnt
      real ::        CAMTV(IMAX),V11D(IMAX,LP1) 
!-----------------------------------------------------------------------
      LOGICAL BCLDUD,BCLDSA,BCLDSB,BCLDSC
      DIMENSION BCLDUD(2*IMAX,LP1),BCLDSA(IMAX,LP1), &
                BCLDSB(IMAX,LP1),BCLDSC(IMAX,LP1)
!-----------------------------------------------------------------------
!                      ***LOGICAL ARRAY DEFINITIONS***
!
!   BCLDUD  =  T  IF (AT GRID POINT I) :1) VERTICAL LEVEL K IS BELOW
!                 THE TOP OF CLOUD (NC);2) VERTICAL LEVEL K IS NOT
!                 BELOW THE BOTTOM OF CLOUD (NC). FOR EACH VERTICAL
!                 LEVEL K,THE FIRST (IMAX) PTS. IS FOR TEST (1);
!                 THE SECOND (IMAX) PTS. IS FOR TEST (2).
!   BCLDSA  =  T  IF (AT GRID POINT I)  EITHER VERTICAL LEVEL K OR
!                 VERTICAL LEVEL KP IS BELOW THE TOP OF CLOUD (NC).
!   BCLDSB  =  T  IF (AT GRID POINT I) EITHER VERTICAL LEVEL K OR
!                 VERTICAL LEVEL KP IS NOT BELOW THE BOTTOM OF
!                 CLOUD (NC).
!   BCLDSC  = T  IF (AT GRID POINT I) :1)VERTICAL LEVEL K IS ABOVE CLOUD
!                (NC) AND VERTICAL LEVEL KP IS BELOW CLOUD (NC), OR VICE
!                VERSA; 2) VERTICAL LEVELS K,KP ARE BOTH BELOW THE TOP
!                OF CLOUD (NC) AND ABOVE THE BOTTOM OF CLOUD (NC)
!                BELOW THE TOP OF CLOUD (NC).
!-----------------------------------------------------------------------

! *** Initialize CLDFAC ***
! *** Note: If the user wants to initialize this quantity
! ***       then it must be passed as an argument (in & out)

      DO K =1,LP1
      DO KP=1,LP1
      DO I =1,IMAX
         CLDFAC(I,KP,K)=1.0
      ENDDO
      ENDDO
      ENDDO

!               ******* LOOP ON CLOUDS *******

                       DO 1 NC=1,LMAX

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

!         *** IF NO GRID PT HAS AN (NCTH) CLOUD, ***
!         *** THE CLOUD CALCULATION IS COMPLETE  ***

                      ICNT=0
                      DO I=1,IMAX
                         IF (NC <= NCLDS(I)) THEN
                            ICNT=ICNT+1
                         ENDIF
                      ENDDO

                   IF (ICNT == 0) then
                      RETURN
                   endif

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

!***COMPUTE BCLDUD***
      DO K=1,LP1
      DO I=1,IMAX
         BCLDUD(I,K)=K.GT.KTOP(I,NC+1)
         BCLDUD(IMAX+I,K)=K.LE.KBTM(I,NC+1)
      ENDDO
      ENDDO

!***INITIALIZE THE CLOUD TF FOR THE (NCTH) CLOUD TO UNITY.
!     DO K=1,LP1
!     DO KP=1,LP1
!     DO I=1,IMAX
!        V1(I,KP,K)=1.0
!     ENDDO
!     ENDDO
!     ENDDO

!***DEFINE THE CLOUD TRANSMISSIVITY.  THE TRANSMISSIVITY IS TAKEN AS
!  (1-CLOUD EMISSIVITY) FOR THE FRACTION OF THE GRID BOX WITH THE NCTH
!  LAYER OF CLOUD, AND ONE OTHERWISE. ( NOTE THAT IF AT POINT I, THE
!  NCTH CLOUD DOES NOT EXIST, ITS AMOUNT IS TAKEN AS ZERO). AS A RESULT,
!  THE CLOUD TRANSMISSIVITY MAY BE DEFINED AS THOUGH THE EMISSIVITY
!  WERE UNITY AND THE CLOUD AMOUNT WERE MULTIPLIED BY THE EMISSIVITY.

      DO I=1,IMAX
         IF (NC <= NCLDS(I)) THEN
            CAMTV(I)=1.0-CAMT(I,NC+1)*EMCLD(I,NC+1)
         ELSE
            CAMTV(I)=1.0
         ENDIF
      ENDDO

      DO K=1,LP1
      DO I=1,IMAX
         V11D(I,K)=CAMTV(I)
      ENDDO
      ENDDO

!***THE 221 LOOP IS THE K-LOOP. WE USED SUCH A LOOP PRIMARILY TO REDUCE
!    SPACE***

                              DO 221 K=1,LP1

      DO KP=1,LP1
      DO I=1,IMAX
         BCLDSA(I,KP)=BCLDUD(I,KP).or.BCLDUD(I,K)
         BCLDSB(I,KP)=BCLDUD(IMAX+I,KP).or.BCLDUD(IMAX+I,K)
      ENDDO
      ENDDO

!---COMBINE BCLDSA AND BCLDSB INTO BCLDSC
      DO KP=1,LP1
      DO I=1,IMAX
         BCLDSC(I,KP)=BCLDSA(I,KP).and.BCLDSB(I,KP)
      ENDDO
      ENDDO

!***DEFINE TRANSMISSION FUNCTION FOR LEVELS WHERE LOGICAL ARRAY BCLDSC
!   INDICATES THAT A CLOUD IS PRESENT

!     DO KP=1,LP1
!     DO I=1,IMAX
!        IF (BCLDSC(I,KP)) THEN
!           V1(I,KP,K)=V11D(I,KP)
!        ENDIF
!     ENDDO
!     ENDDO

!221                            CONTINUE


!***RANDOM OVERLAP OF CLOUD IS ASSUMED IS OBTAINING THE TOTAL CLOUD TF**
!     DO K=1,LP1
      DO KP=1,LP1
      DO I=1,IMAX
!        CLDFAC(I,KP,K)=CLDFAC(I,KP,K)*V1(I,KP,K)
      if (bcldsc(i,kp) ) then
         CLDFAC(I,KP,K)=CLDFAC(I,KP,K)*V11d(I,KP)
      else
      endif
      ENDDO
      ENDDO
!      ENDDO
221                            CONTINUE


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

   1                      CONTINUE

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

!-----------------------------------------------------------------------
      END SUBROUTINE CLO88

!#######################################################################
!#######################################################################

      SUBROUTINE TABLE
!-----------------------------------------------------------------------
!     SUBROUTINE TABLE COMPUTES TABLE ENTRIES USED IN THE LONGWAVE RADIA
!     PROGRAM. ALSO CALCULATED ARE INDICES USED IN STRIP-MINING AND FOR 
!     SOME PRE-COMPUTABLE FUNCTIONS.
!-----------------------------------------------------------------------
!#include "hcon.h"
!-----------------------------------------------------------------------
!#include "bandta.h"
!-----------------------------------------------------------------------
!#include "bdwide.h"
!-----------------------------------------------------------------------
!#include "bdcomb.h"
!-----------------------------------------------------------------------
!#include "tabcom.h"
      integer :: i1, i2e, i2, indx, jp, n, icnt, j, ia, nsubds, nsb
      real    :: cent, del, bdlo, bdhi, c1, anu
      real ::          EM1   (28,180),EM1WDE(28,180),EM3   (28,180), &
                       TABLE1(28,180),TABLE2(28,180),TABLE3(28,180)
      COMMON /TABCOM/  EM1    ,EM1WDE ,EM3    , &
                       TABLE1 ,TABLE2 ,TABLE3
!-----------------------------------------------------------------------
      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),         &
                 R1(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)
!
!*** NOTE: THE DATA,EQUIVALENCE AND DIMENSION STATEMENTS FOR QUANTITIES 
!    EQUIVALENCED TO COMMON BLOCK BANDTA DEPEND ON THE VALUE OF THE 
!    PARAMETER NBLW.
! 
!-----------------------------------------------------------------------
!***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
!....FOR NARROW-BANDS...
      DO N=1,NBLW
         ANB(N)=ARNDM(N)
         BNB(N)=BRNDM(N)
         CENTNB(N)=0.50*(BANDLO(N)+BANDHI(N))
         DELNB(N)=BANDHI(N)-BANDLO(N)
         BETANB(N)=BETAD(N)
      ENDDO
         AB15(1)=ANB(57)*BNB(57)
         AB15(2)=ANB(58)*BNB(58)
!....FOR WIDE BANDS...
         AB15WD=AWIDE*BWIDE

!***COMPUTE INDICES: INDX2,KMAXV

      ICNT=0
      DO I1=1,LMAX
         I2E=LP1-I1
         DO I2=1,I2E
            ICNT=ICNT+1
            INDX=LP1*(I2-1)+LP2*I1
            INDX1(ICNT)=MOD(INDX,LP1)
            IF (INDX1(ICNT) == 0) INDX1(ICNT)=LP1
            INDX2(ICNT)=(INDX+LMAX)/LP1
         ENDDO
      ENDDO

         KMAXV(1)=1
      DO I=2,LMAX
         KMAXV(I)=KMAXV(I-1)+(LP2-I)
      ENDDO
         KMAXVM=KMAXV(LMAX)

!***COMPUTE RATIOS OF CONT. COEFFS
      SKC1R=BETAWD/BETINW
      SKO3R=BETAD(61)/BETINW
      SKO2D=1.0/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)=1.0E-16
      DO J=1,180
         JP=J+1
         ZROOT(J)=SQRT(ZMASS(J))
         ZMASS(JP)=ZMASS(J)*1.258925411
      ENDDO

      DO I=1,28
         XTEMV(I)=90.+10.*I
         TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
         FORTCU(I)=4.0*XTEMV(I)*XTEMV(I)*XTEMV(I)
      ENDDO

!******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 N=1,NBLY
      DO I=1,28
         SOURCE(I,N)=0.0
      ENDDO
      ENDDO

      DO N=1,NBLX
      DO I=1,28
         SRCWD(I,N)=0.0
      ENDDO
      ENDDO

!---BEGIN FREQ. LOOP (ON N)
      DO 211 N=1,NBLX

!***THE 160-1200 BAND CASES
        IF (N <= 46) THEN
          CENT=CENTNB(N+16)
          DEL=DELNB(N+16)
          BDLO=BANDLO(N+16)
          BDHI=BANDHI(N+16)
        ENDIF

!***THE 2270-2380 BAND CASE
        IF (N == NBLX) THEN
          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-1.0E-1)/10+1
      DO 213 NSB=1,NSUBDS
        IF (NSB .ne. NSUBDS) THEN
          CNUSB(NSB)=10.*(NSB-1)+BDLO+5.0
          DNUSB(NSB)=10.
        ELSE
          CNUSB(NSB)=0.50*(10.*(NSB-1)+BDLO+BDHI)
          DNUSB(NSB)=BDHI-(10.*(NSB-1)+BDLO)
        ENDIF
        C1=(3.7412E-5)*CNUSB(NSB)**3

!---BEGIN TEMP. LOOP (ON I)

        DO I=1,28
          X(I)=1.4387*CNUSB(NSB)/XTEMV(I)
          X1(I)=EXP(X(I))
          SRCS(I)=C1/(X1(I)-1.0)
          SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
        ENDDO

213   CONTINUE
211   CONTINUE

!***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
!   AND DSRCE

      DO N=1,40
      DO I=1,28
         SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
      ENDDO
      ENDDO

      DO N=9,NBLY
      DO I=1,28
         SOURCE(I,N)=SRCWD(I,N+32)
      ENDDO
      ENDDO

      DO N=1,NBLY
      DO I=1,27
         DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*0.10
      ENDDO
      ENDDO

      DO N=1,NBLW
         ALFANB(N)=BNB(N)*ANB(N)
         AROTNB(N)=SQRT(ALFANB(N))
      ENDDO

!***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.

      DO IA=1,3
         ANU=CENT+0.50*(IA-2)*DEL
         C1=(3.7412E-5)*ANU*ANU*ANU+1.E-20

!---TEMPERATURE LOOP---
         DO I=1,28
            X(I)=1.4387*ANU/XTEMV(I)
            X1(I)=EXP(X(I))
            SC(I)=C1/((X1(I)-1.0)+1.E-20)
            DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
         ENDDO
         IF (IA == 2) THEN
            DO I=1,28
               SRC1NB(I,N)=DEL*SC(I)
               DBDTNB(I,N)=DEL*DSC(I)
            ENDDO
         ENDIF
      ENDDO

301   CONTINUE

!***NEXT COMPUTE R1,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 R1 SUMMED OVER THE 160-560 CM-1 RANGE

      DO I=1,28
         SUM4(I)=0.0
         SUM6(I)=0.0
         SUM7(I)=0.0
         SUM8(I)=0.0
         SUM4WD(I)=0.0
      ENDDO

      DO 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 < 560. .or. CENT > 1200. .and. CENT <= 2200.) THEN
            DO 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)
            ENDDO
         ENDIF
!***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
         IF (CENT > 160. .and. CENT < 560.) THEN
            DO I=1,28
               SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
            ENDDO
         ENDIF

      ENDDO

      DO I=1,28
         R1(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)
      ENDDO

      DO J=1,180
      DO I=1,28
         SUM(I,J)=0.0
         PERTSM(I,J)=0.0
         SUM3(I,J)=0.0
         SUMWDE(I,J)=0.0
      ENDDO
      ENDDO

!------- 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 < 560. .or. CENT > 1200. .and. CENT <= 2200.) THEN
            DO J=1,180
               X2(J)=AROTNB(N)*ZROOT(J)
               EXPO(J)=EXP(-X2(J))
            ENDDO

            DO J=1,180
               IF (X2(J) >= 100.) THEN
                  EXPO(J)=0.0
               ENDIF
            ENDDO

            DO J=121,180
               FAC(J)=ZMASS(J)*(1.0-(1.0+X2(J))*EXPO(J))/(X2(J)*X2(J))
            ENDDO

            DO J=1,180
            DO 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)
            ENDDO
            ENDDO

            DO J=121,180
            DO I=1,28
               SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
            ENDDO
            ENDDO
         ENDIF

!---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
         IF (CENT > 160. .and. CENT < 560.) THEN
            DO J=1,180
            DO I=1,28
               SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
            ENDDO
            ENDDO
         ENDIF

 411  CONTINUE
!-----------------------------------------------------------------------

      DO J=1,180
      DO I=1,28
         EM1(I,J)=SUM(I,J)/TFOUR(I)
         TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
      ENDDO
      ENDDO

      DO J=121,180
      DO I=1,28
         EM3(I,J)=SUM3(I,J)/FORTCU(I)
      ENDDO
      ENDDO

      DO J=1,179
      DO I=1,28
         TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*10.
      ENDDO
      ENDDO

      DO J=1,180
      DO I=1,27
         TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*0.10
      ENDDO
      ENDDO

      DO I=1,28
         TABLE2(I,180)=0.0
      ENDDO

      DO J=1,180
         TABLE3(28,J)=0.0
      ENDDO

      DO J=1,2
      DO I=1,28
         EM1(I,J)=R1(I)
      ENDDO
      ENDDO

      DO J=1,120
      DO I=1,28
         EM3(I,J)=R2(I)/2.0-S2(I)*SQRT(ZMASS(J))/3.0+T3(I)*ZMASS(J)/8.0
      ENDDO
      ENDDO

      DO J=121,180
      DO I=1,28
         EM3(I,J)=EM3(I,J)/ZMASS(J)
      ENDDO
      ENDDO


!***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
!   WE USE R1WD AND SUMWDE OBTAINED ABOVE.
      DO J=1,180
      DO I=1,28
         EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
      ENDDO
      ENDDO

      DO J=1,2
      DO I=1,28
         EM1WDE(I,J)=R1WD(I)
      ENDDO
      ENDDO

!-----------------------------------------------------------------------
      END SUBROUTINE TABLE

!#######################################################################

      SUBROUTINE RAD_ALLOC (IMAX)

      INTEGER,INTENT(IN) :: IMAX

!-----------------------------------------------------------------------
!   Allocates temporary space for longwave code
!-----------------------------------------------------------------------

!-------------- SRCCOM -----------------
      ALLOCATE (SORC(IMAX,LP1,NBLY))
      ALLOCATE (CSOUR1(IMAX,LP1))
      ALLOCATE (CSOUR2(IMAX,LP1))
      ALLOCATE (OSOUR(IMAX,LP1))
      ALLOCATE (CSOUR(IMAX,LP1))
      ALLOCATE (SS1(IMAX,LP1))

!-------------- KDACOM -----------------
      ALLOCATE (QH2O(IMAX,LP1))
      ALLOCATE (P(IMAX,LP1))
      ALLOCATE (DELP2(IMAX,LMAX))
      ALLOCATE (DELP(IMAX,LMAX))
      ALLOCATE (TTTT(IMAX,LP1))
      ALLOCATE (VAR1(IMAX,LMAX))
      ALLOCATE (VAR2(IMAX,LMAX))
      ALLOCATE (VAR3(IMAX,LMAX))
      ALLOCATE (VAR4(IMAX,LMAX))
      ALLOCATE (CNTVAL(IMAX,LP1))

!-------------- RDFLUX -----------------
      ALLOCATE (FLX1E1(IMAX))
      ALLOCATE (GXCTS(IMAX))
      ALLOCATE (FCTSG(IMAX,NBLY))

!-------------- CLDCOM -----------------
      ALLOCATE (CLDFAC(IMAX,LP1,LP1))

!-------------- TFCOM -----------------
      ALLOCATE (TO3   (IMAX,LP1,LP1))
      ALLOCATE (CO21  (IMAX,LP1,LP1))
      ALLOCATE (EMISS (IMAX,LP1,LP1))
      ALLOCATE (EMISS2(IMAX,LP1,LP1))
      ALLOCATE (AVEPHI(IMAX,LP1,LP1))

      ALLOCATE (CTS  (IMAX,LMAX))
      ALLOCATE (CTSO3(IMAX,LMAX))
      ALLOCATE (EXCTS(IMAX,LMAX))

      ALLOCATE (EXCTSN(IMAX,LMAX,NBLY))

      ALLOCATE (E1FLX (IMAX,LP1))
      ALLOCATE (CO2NBL(IMAX,LMAX))
      ALLOCATE (CO2SP1(IMAX,LP1))
      ALLOCATE (CO2SP2(IMAX,LP1))
      ALLOCATE (CO2SP (IMAX,LP1))
      ALLOCATE (TO3SPC(IMAX,LMAX))
      ALLOCATE (TOTVO2(IMAX,LP1))

!-----------------------------------------------------------------------
!-------------- TABCOM + Initialize tables for longwave ----------------

      IF (IMAX .ne. IMAXold .or. LMAX .ne. LMAXold) THEN
           IF (Allocated(INDX1)) DeAllocate (INDX1)
           IF (Allocated(INDX2)) DeAllocate (INDX2)
           IF (Allocated(KMAXV)) DeAllocate (KMAXV)
                                   Allocate (INDX1(LP1V))
                                   Allocate (INDX2(LP1V))
                                   Allocate (KMAXV(LP1))
           CALL TABLE
           IMAXold=IMAX
           LMAXold=LMAX
      ENDIF

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

      END SUBROUTINE RAD_ALLOC

!#######################################################################

      SUBROUTINE RAD_DEALLOC

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

!     ----- SRCCOM -----
      DEALLOCATE (SORC)
      DEALLOCATE (CSOUR1)
      DEALLOCATE (CSOUR2)
      DEALLOCATE (OSOUR)
      DEALLOCATE (CSOUR)
      DEALLOCATE (SS1)

!     ----- KDACOM -----
      DEALLOCATE (QH2O)
      DEALLOCATE (P)
      DEALLOCATE (DELP2)
      DEALLOCATE (DELP)
      DEALLOCATE (TTTT)
      DEALLOCATE (VAR1)
      DEALLOCATE (VAR2)
      DEALLOCATE (VAR3)
      DEALLOCATE (VAR4)
      DEALLOCATE (CNTVAL)

!     ----- RDFLUX -----
      DEALLOCATE (FLX1E1)
      DEALLOCATE (GXCTS)
      DEALLOCATE (FCTSG)

!     ----- CLDCOM -----
      DEALLOCATE (CLDFAC)

!-------------- TABCOM -----------------
!     DEALLOCATE (INDX1)
!     DEALLOCATE (INDX2)
!     DEALLOCATE (KMAXV)

!-------------- TFCOM -----------------
      DEALLOCATE (TO3   )
      DEALLOCATE (CO21  )
      DEALLOCATE (EMISS )
      DEALLOCATE (EMISS2)
      DEALLOCATE (AVEPHI)

      DEALLOCATE (CTS  )
      DEALLOCATE (CTSO3)
      DEALLOCATE (EXCTS)

      DEALLOCATE (EXCTSN)

      DEALLOCATE (E1FLX )
      DEALLOCATE (CO2NBL)
      DEALLOCATE (CO2SP1)
      DEALLOCATE (CO2SP2)
      DEALLOCATE (CO2SP )
      DEALLOCATE (TO3SPC)
      DEALLOCATE (TOTVO2)

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

      END SUBROUTINE RAD_DEALLOC

!#######################################################################

                     END MODULE LONGWAVE_MOD

