phys/module_ra_gfdleta.F

   1 !WRF:MODEL_RA:RADIATION
   2 !
   3 #define FERRIER_GFDL
   4 MODULE MODULE_RA_GFDLETA
   5       USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE
   6       USE MODULE_MODEL_CONSTANTS
   7 #ifdef FERRIER_GFDL
   8       USE MODULE_MP_ETANEW, ONLY : FPVS,GPVS
   9 #endif
  10       INTEGER,PARAMETER :: NL=81
  11       INTEGER,PARAMETER :: NBLY=15
  12       REAL,PARAMETER :: RTHRESH=1.E-15,RTD=1./DEGRAD
  13
  14       INTEGER, SAVE, DIMENSION(3)     :: LTOP
  15       REAL   , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
  16       REAL   , SAVE, DIMENSION(NL)    :: PRGFDL
  17       REAL   , SAVE                   :: AB15WD,SKO2D,SKC1R,SKO3R
  18
  19       REAL   , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180),     &
  20                            TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
  21                            SOURCE(28,NBLY), DSRCE(28,NBLY)
  22
  23       REAL   ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
  24       REAL   ,SAVE                 :: R1,RSIN1,RCOS1,RCOS2
  25 ! Created by CO2 initialization
  26       REAL,   SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,&
  27                                            C2D58,CO258
  28       REAL,   SAVE, ALLOCATABLE, DIMENSION(:)   :: STEMP,GTEMP,CO231,CO238, &
  29                                            C2D31,C2D38,CDT31,CDT38, &
  30                                            CO271,CO278,C2D71,C2D78, &
  31                                            CDT71,CDT78
  32       REAL,   SAVE, ALLOCATABLE, DIMENSION(:)   :: CO2M51,CO2M58,CDTM51,CDTM58, &
  33                                            C2DM51,C2DM58
  34       CHARACTER(256) :: ERRMESS
  35
  36 ! Used by CO2 initialization
  37 !     COMMON/PRESS/PA(109)
  38 !     COMMON/TRAN/ TRANSA(109,109)
  39 !     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
  40       REAL   ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV
  41       REAL   ,SAVE, DIMENSION(109,109) :: TRANSA
  42       REAL   ,SAVE  :: CORE,UEXP,SEXP
  43
  44       EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
  45       EQUIVALENCE (EM3V(1),EM3(1,1))
  46       EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
  47                   (T4(1),TABLE3(1,1))
  48       REAL,SAVE,DIMENSION(4) :: PTOPC
  49 !
  50 !--- Used for Gaussian look up tables
  51 !
  52       REAL, PRIVATE,PARAMETER :: XSDmax=3.1, DXSD=.01
  53       INTEGER, PRIVATE,PARAMETER :: NXSD=XSDmax/DXSD
  54       REAL, DIMENSION(NXSD),PRIVATE,SAVE :: AXSD
  55       REAL, PRIVATE :: RSQR
  56       LOGICAL, PRIVATE,SAVE :: SDprint=.FALSE.
  57
  58
  59       REAL, PRIVATE, PARAMETER :: RHgrd=1.0
  60       REAL, PRIVATE, PARAMETER :: T_ice=-40.0
  61
  62 !
  63 !--- Important parameters for cloud properties - see extensive comments in
  64 !    DO 580 loop within subroutine RADTN
  65 !
  66       REAL, PARAMETER ::  &
  67      &   TRAD_ice=0.5*T_ice      & !--- Very tunable parameter
  68      &,  ABSCOEF_W=800.          & !--- Very tunable parameter
  69      &,  ABSCOEF_I=500.          & !--- Very tunable parameter
  70      &,  SECANG=-1.66            & !--- Very tunable parameter
  71 !!     &,  SECANG=-0.75            & !--- Very tunable parameter
  72      &,  CLDCOEF_LW=1.5          & !--- Enhance LW cloud depths
  73      &,  ABSCOEF_LW=SECANG*CLDCOEF_LW  & !--- Final factor for cloud emissivities
  74      &,  Qconv=0.1e-3            & !--- Very tunable parameter
  75      &,  CTauCW=ABSCOEF_W*Qconv  &
  76      &,  CTauCI=ABSCOEF_I*Qconv
  77 !
  78
  79 CONTAINS
  80
  81 !-----------------------------------------------------------------------
  82       SUBROUTINE GFDLETAINIT(EMISS,SFULL,SHALF,PPTOP,                   &
  83      &                       JULYR,MONTH,IDAY,GMT,                      &
  84      &                       CONFIG_FLAGS,ALLOWED_TO_READ,              &
  85      &                       IDS, IDE, JDS, JDE, KDS, KDE,              &
  86      &                       IMS, IME, JMS, JME, KMS, KME,              &
  87      &                       ITS, ITE, JTS, JTE, KTS, KTE              )
  88 !-----------------------------------------------------------------------
  89       IMPLICIT NONE
  90 !-----------------------------------------------------------------------
  91       TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS
  92       INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
  93      &                     ,IMS,IME,JMS,JME,KMS,KME                     &
  94      &                     ,ITS,ITE,JTS,JTE,KTS,KTE
  95       INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY
  96       REAL,INTENT(IN) :: GMT,PPTOP
  97       REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF
  98       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EMISS
  99       LOGICAL,INTENT(IN) :: ALLOWED_TO_READ
 100 !
 101       INTEGER :: I,IHRST,J,N
 102       REAL :: PCLD,XSD,PI,SQR2PI
 103       REAL :: SSLP=1013.25
 104       REAL, PARAMETER :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642.,       &
 105      &                   PLBTM=105000.
 106 !-----------------------------------------------------------------------
 107 !***********************************************************************
 108 !-----------------------------------------------------------------------
 109 !
 110 !--- In case ETAMPNEW microphysics is not called, initialize lookup tables for
 111 !    saturation vapor pressures (only FPVS is used in radiation, which calculates
 112 !    vapor pressure w/r/t water for T>=0C and w/r/t ice for T<0C).
 113 !
 114       CALL GPVS
 115
 116 !***  INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS.
 117 !
 118       LTOP(1)=0
 119       LTOP(2)=0
 120       LTOP(3)=0
 121 !
 122       DO N=1,KTE
 123         PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10.
 124         IF(PCLD>=PTOP_LO)LTOP(1)=N
 125         IF(PCLD>=PTOP_MID)LTOP(2)=N
 126         IF(PCLD>=PTOP_HI)LTOP(3)=N
 127 !       PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
 128       ENDDO
 129 !***
 130 !***  ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES
 131 !***
 132       PTOPC(1)=PLBTM
 133       PTOPC(2)=PTOP_LO*100.
 134       PTOPC(3)=PTOP_MID*100.
 135       PTOPC(4)=PTOP_HI*100.
 136 !
 137 !***  USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS
 138 !***  OTHERWISE CALL CO2O3.
 139 !
 140       IF(ALLOWED_TO_READ)THEN
 141         IF(CONFIG_FLAGS%CO2TF==1)THEN
 142           CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
 143         ELSE
 144           CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
 145         ENDIF
 146 !
 147         CALL O3CLIM
 148         CALL TABLE
 149         IHRST=NINT(GMT)
 150 !       WRITE(0,*)'into solard ',gmt,ihrst
 151         CALL SOLARD(IHRST,IDAY,MONTH,JULYR)
 152       ENDIF
 153 !
 154 !***  FOR NOW, GFDL RADIATION ASSUMES EMISSIVITY = 1.0
 155 !
 156       DO J=JTS,JTE
 157       DO I=ITS,ITE
 158         EMISS(I,J) = 1.0
 159       ENDDO
 160       ENDDO
 161 !
 162 !---  Calculate the area under the Gaussian curve at the start of the
 163 !---  model run and build the look up table AXSD
 164 !
 165       PI=ACOS(-1.)
 166       SQR2PI=SQRT(2.*PI)
 167       RSQR=1./SQR2PI
 168       DO I=1,NXSD
 169         XSD=REAL(I)*DXSD
 170         AXSD(I)=GAUSIN(XSD)
 171         if (SDprint) print *,'I, XSD, AXSD =',I,XSD,AXSD(I)
 172       ENDDO
 173 !
 174 !-----------------------------------------------------------------------
 175       END SUBROUTINE GFDLETAINIT
 176 !-----------------------------------------------------------------------
 177 !
 178 !
 179 !-----------------------------------------------------------------------
 180       SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D       &
 181      &                ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T                   &
 182      &                ,QV,QW,QI,QS                                      &
 183      &                ,TSK2D,GLW,RSWIN,GSW,RSWINC                       &
 184      &                ,RSWTOA,RLWTOA,CZMEAN                             &
 185      &                ,GLAT,GLON,HTOP,HBOT,HTOPR,HBOTR,ALBEDO,CUPPT     &
 186      &                ,VEGFRA,SNOW,G,GMT                                &
 187 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
 188      &                ,NSTEPRA,NPHS,ITIMESTEP                           &
 189      &                ,XTIME,JULIAN                                     &
 190      &                ,JULYR,JULDAY,GFDL_LW,GFDL_SW                     &
 191      &                ,CFRACL,CFRACM,CFRACH                             &
 192      &                ,ACFRST,NCFRST,ACFRCV,NCFRCV                      &
 193      &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
 194      &                ,IMS,IME,JMS,JME,KMS,KME                          &
 195      &                ,ITS,ITE,JTS,JTE,KTS,KTE)
 196 !-----------------------------------------------------------------------
 197       IMPLICIT NONE
 198 !-----------------------------------------------------------------------
 199       INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
 200      &                     ,IMS,IME,JMS,JME,KMS,KME                     &
 201      &                     ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP           &
 202      &                     ,NPHS,NSTEPRA
 203
 204       INTEGER,INTENT(IN) :: julyr,julday
 205       INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST        & !Added
 206                                                          ,NCFRCV          !Added
 207       REAL,INTENT(IN) :: DT,GMT,G,XTIME,JULIAN
 208
 209       REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme)::         &
 210                                     THRATEN,THRATENLW,THRATENSW,CLDFRA  !Added CLDFRA
 211       REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w,   &
 212      &                                                      rho_phy,    &
 213      &                                                      p_phy,      &
 214      &                                                      PI3D
 215       REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW,      &
 216      &                                                TSK2D,VEGFRA,     &
 217      &                                                XLAND
 218       REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON
 219       REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,HTOPR,HBOTR,CUPPT
 220       REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA,        & !Added
 221      &                                                   RLWTOA,        & !Added
 222      &                                                   ACFRST,        & !Added
 223      &                                                   ACFRCV
 224       REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW
 225       REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN             &
 226      &                                           ,RSWIN,RSWINC        &
 227      &                                           ,CFRACL,CFRACM,CFRACH
 228       REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QS,QV,   &
 229      &                                                         QW,T
 230       LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
 231       REAL, OPTIONAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI
 232
 233       REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP,  &
 234      &                                             QWFLIP,TFLIP
 235       REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP
 236       REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
 237       REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT
 238       INTEGER :: IDAT(3),IHOUR,Jmonth,Jday
 239       INTEGER :: I,J,K,KFLIP,IHRST
 240
 241 ! begin debugging radiation
 242       integer :: imd,jmd
 243       real :: FSWrat
 244 ! end debugging radiation
 245 !-----------------------------------------------------------------------
 246 !***********************************************************************
 247 !-----------------------------------------------------------------------
 248       IF(GFDL_LW.AND.GFDL_SW )GO TO 100
 249 !
 250       DO J=JMS,JME
 251         DO K=KMS,KME
 252           DO I=IMS,IME
 253             CLDFRA(I,K,J)=0.
 254           ENDDO
 255         ENDDO
 256       ENDDO
 257 !
 258       DO K=KMS,KME
 259          KFLIP=KME+1-K
 260          DO J=JTS,JTE
 261          DO I=ITS,ITE
 262            P8WFLIP(I,K,J)=P8W(I,KFLIP,J)
 263          ENDDO
 264          ENDDO
 265       ENDDO
 266 !
 267 !- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25)
 268 !
 269       DO K=KTS,KTE
 270         KFLIP=KTE+1-K
 271         DO J=JTS,JTE
 272         DO I=ITS,ITE
 273           TFLIP (I,K,J)=T(I,KFLIP,J)
 274           QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J)))
 275           QWFLIP(I,K,J)=MAX(QW(I,KFLIP,J),0.)      !Modified
 276 ! Note that QIFLIP will contain QS+QI if both are passed in, otherwise just QS
 277 !     Eta MP now outputs QS instead of QI (JD 2006-05-12)
 278           QIFLIP(I,K,J)=MAX(QS(I,KFLIP,J),0.)      !Added QS
 279           IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J)      !Added QI
 280           PFLIP (I,K,J)=P_PHY(I,KFLIP,J)
 281 !
 282 !***  USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL
 283 !
 284         ENDDO
 285         ENDDO
 286       ENDDO
 287 !
 288       DO J=JTS,JTE
 289       DO I=ITS,ITE
 290         CUBOT(I,J)=KTE+1-HBOT(I,J)
 291         CUTOP(I,J)=KTE+1-HTOP(I,J)
 292       ENDDO
 293       ENDDO
 294 !
 295       CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
 296 !
 297       IDAT(1)=JMONTH
 298       IDAT(2)=JDAY
 299       IDAT(3)=JULYR
 300       IHRST  =NINT(GMT)
 301
 302       IHOUR  =MOD((IHRST+NINT(XTIME/60.0)),24)
 303 !     write(0,*)' before SOLARD in ETARA ', IHOUR,JDAY,JMONTH,JULYR
 304       CALL SOLARD(IHOUR,JDAY,JMONTH,JULYR)
 305 !-----------------------------------------------------------------------
 306       CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP,                         &
 307      &            PFLIP,P8WFLIP,XLAND,TSK2D,                            &
 308      &            GLAT,GLON,CUTOP,CUBOT,ALBEDO,CUPPT,                   &
 309      &            ACFRCV,NCFRCV,ACFRST,NCFRST,                          &
 310      &            VEGFRA,SNOW,GLW,GSW,RSWIN,RSWINC,                     &
 311 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
 312      &            IDAT,IHRST,XTIME,JULIAN,                              &
 313      &            NSTEPRA,NSTEPRA,NPHS,ITIMESTEP,                       &
 314      &            TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN,              &
 315      &            CFRACL,CFRACM,CFRACH,                                 &
 316      &            IDS,IDE,JDS,JDE,KDS,KDE,                              &
 317      &            IMS,IME,JMS,JME,KMS,KME,                              &
 318      &            ITS,ITE,JTS,JTE,KTS,KTE                              )
 319 !-----------------------------------------------------------------------
 320 ! begin debugging radiation
 321 !     imd=(ims+ime)/2
 322 !     jmd=(jms+jme)/2
 323 !     FSWrat=0.
 324 !     if (RSWIN(imd,jmd) .gt. 0.)   &
 325 !        FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
 326 !     write(6,"(2a,2i5,5f9.2,f8.4,i3,2f8.4)") &
 327 !       '{rad4 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
 328 !      ,'ACFRCV,NCFRCV,ALBEDO,RSWOUT/RSWIN = '   &
 329 !      ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd)  &
 330 !      ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
 331 !      ,ACFRCV(imd,jmd),NCFRCV(imd,jmd),ALBEDO(imd,jmd),FSWrat
 332 ! end debugging radiation
 333 !
 334 !--- Need to save LW & SW tendencies since radiation calculates both and this block
 335 !    is skipped when GFDL SW is called, both only if GFDL LW is also called
 336 !
 337       IF(GFDL_LW)THEN
 338         DO J=JTS,JTE
 339         DO K = KTS,KTE
 340           KFLIP=KTE+1-K
 341           DO I=ITS,ITE
 342             THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J)
 343             THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
 344             THRATEN(I,K,J)  =THRATEN(I,K,J) + THRATENLW(I,K,J)
 345           ENDDO
 346         ENDDO
 347         ENDDO
 348       ENDIF
 349 !
 350 !*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER.
 351 !    Only gets executed if a different LW scheme (not GFDL) is called
 352 !
 353       IF(GFDL_SW)THEN
 354         DO J=JTS,JTE
 355         DO K=KTS,KTE
 356           KFLIP=KTE+1-K
 357           DO I=ITS,ITE
 358             THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
 359           ENDDO
 360         ENDDO
 361         ENDDO
 362       ENDIF
 363 !
 364 !***  RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP
 365 !***  FOR NEXT INTERVAL BETWEEN RADIATION CALLS
 366 !
 367       DO J=JTS,JTE
 368       DO I=ITS,ITE
 369 ! SAVE VALUE USED BY RADIATION BEFORE RESETTING HTOP AND HBOT
 370         HBOTR(I,J)=HBOT(I,J)
 371         HTOPR(I,J)=HTOP(I,J)
 372         HBOT(I,J)=REAL(KTE+1)
 373         HTOP(I,J)=0.
 374         CUPPT(I,J)=0.
 375       ENDDO
 376       ENDDO
 377 !
 378   100 IF(GFDL_SW)THEN
 379         DO J=JTS,JTE
 380         DO K=KTS,KTE
 381           KFLIP=KTE+1-K
 382           DO I=ITS,ITE
 383             THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J)
 384           ENDDO
 385         ENDDO
 386         ENDDO
 387       ENDIF
 388 !
 389   END SUBROUTINE ETARA
 390 !
 391 !-----------------------------------------------------------------------
 392       SUBROUTINE RADTN(DT,T,Q,QCW,QICE,                                 &
 393      &                 PFLIP,P8WFLIP,XLAND,TSK2D,                       &
 394      &                 GLAT,GLON,CUTOP,CUBOT,ALB,CUPPT,                 &
 395      &                 ACFRCV,NCFRCV,ACFRST,NCFRST,                     &
 396      &                 VEGFRC,SNO,GLW,GSW,RSWIN,RSWINC,                 &
 397 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
 398      &                 IDAT,IHRST,XTIME,JULIAN,                         &
 399      &                 NRADS,NRADL,NPHS,NTSD,                           &
 400      &                 TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN,         &
 401      &                 CFRACL,CFRACM,CFRACH,                            &
 402      &                 ids,ide, jds,jde, kds,kde,                       &
 403      &                 ims,ime, jms,jme, kms,kme,                       &
 404      &                 its,ite, jts,jte, kts,kte                       )
 405 !-----------------------------------------------------------------------
 406       IMPLICIT NONE
 407 !-----------------------------------------------------------------------
 408
 409 ! GLAT : geodetic latitude in radians of the mass points on the computational grid.
 410
 411 ! CZEN : instantaneous cosine of the solar zenith angle.
 412
 413 ! CUTOP : (REAL) model layer number that is highest in the atmosphere
 414 !        in which convective cloud occurred since the previous call to the
 415 !        radiation driver.
 416
 417 ! CUBOT : (REAL) model layer number that is lowest in the atmosphere
 418 !        in which convective cloud occurred since the previous call to the
 419 !        radiation driver.
 420
 421 ! ALB  : is no longer used in the operational radiation.  Prior to 24 July 2001
 422 !        ALB was the climatological albedo that was modified within RADTN to
 423 !        account for vegetation fraction and snow.
 424 !
 425 ! ALB  : reintroduced as the dynamic albedo from LSM
 426
 427 ! CUPPT: accumulated convective precipitation (meters) since the
 428 !        last call to the radiation.
 429
 430 ! TSK2D : skin temperature
 431
 432 ! IHE and IHW are relative location indices needed to locate neighboring
 433 !       points on the Eta's Arakawa E grid since arrays are indexed locally on
 434 !       each MPI task rather than globally.  IHE refers to the adjacent grid
 435 !       point (a V point) to the east of the mass point being considered.  IHW
 436 !       is the adjacent grid point to the west of the given mass point.
 437
 438 ! IRAD is a relic from older code that is no longer needed.
 439
 440 ! ACFRCV : sum of the convective cloud fractions that were computed
 441 !          during each call to the radiation between calls to the subroutines that
 442 !          do the forecast output.
 443
 444 ! NCFRCV : the total number of times in which the convective cloud
 445 !          fraction was computed to be greater than zero in the radiation between
 446 !          calls to the output routines.  In the post-processor, ACFRCV is divided
 447 !          by NCFRCV to yield an average convective cloud fraction.
 448
 449 !          ACFRST and NCFRST are the analogs for stratiform cloud cover.
 450
 451 !          VEGFRC is the fraction of the gridbox with vegetation.
 452
 453 !          LVL holds the number of model layers that lie below the ground surface
 454 !          at each point.  Clearly for sigma coordinates LVL is zero everywhere.
 455
 456 ! CTHK  :  an assumed maximum thickness of stratiform clouds currently set
 457 !          to 20000 Pascals.  I think this is relevant for computing "low",
 458 !          "middle", and "high" cloud fractions which are post-processed but which
 459 !          do not feed back into the integration.
 460
 461 ! IDAT  : a 3-element integer array holding the month, day, and year,
 462 !        respectively, of the date for the start time of the free forecast.
 463
 464 ! ABCFF : holds coefficients for various absorption bands.  You can see
 465 !         where they are set in GFDLRD.F.
 466
 467 ! LTOP  : a 3-element integer array holding the model layer that is at or
 468 !         immediately below the specified pressure levels for the tops
 469 !         of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa)
 470 !         stratiform clouds.  These are for the diagnostic cloud layers
 471 !         needed in the output but not in the integration.
 472
 473 ! NRADS : integer number of fundamental timesteps (our smallest
 474 !         timestep, i.e., the one for inertial gravity wave adjustment)
 475 !         between updates of the shortwave tendencies.
 476
 477 ! NRADL : integer number of fundamental timesteps between updates of
 478 !         the longwave tendencies.
 479
 480 ! NTSD   : integer counter of the fundamental timesteps that have
 481 !         elapsed since the start of the forecast.
 482
 483 ! GLW : incoming longwave radiation at the surface
 484 ! GSW : NET (down minus up, or incoming minus outgoing) all-sky shortwave radiation at the surface
 485 ! RSWIN  : total (clear + cloudy sky) incoming (downward) solar radiation at the surface
 486 ! RSWINC : clear sky incoming (downward) solar radiation at the surface
 487
 488 ! TENDS,TENDL : shortwave,longwave (respectively) temperature tendency
 489
 490 ! CLDFRA : 3D cloud fraction
 491
 492 ! RSWTOA, RLWTOA : outgoing shortwave, longwave (respectively) fluxes at top of atmosphere
 493
 494 ! CZMEAN : time-average cosine of the zenith angle
 495
 496 ! CFRACL,CFRACM,CFRACH : low, middle, & high (diagnosed) cloud fractions
 497
 498 ! XTIME : time since simulation start (minutes)
 499
 500 ! JULIAN: Day of year (0.0 at 00Z Jan 1st)
 501
 502 !**********************************************************************
 503 !****************************** NOTE **********************************
 504 !**********************************************************************
 505 !*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD
 506 !*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY
 507 !*** THAN LONGWAVE.
 508 !**********************************************************************
 509 !****************************** NOTE **********************************
 510 !**********************************************************************
 511 !-----------------------------------------------------------------------
 512 !     INTEGER, PARAMETER         :: NL=81
 513       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,         &
 514      &                              ims,ime, jms,jme, kms,kme ,         &
 515      &                              its,ite, jts,jte, kts,kte
 516       INTEGER, INTENT(IN)        :: NRADS,NRADL,NTSD,NPHS
 517 !     LOGICAL, INTENT(IN)        :: RESTRT
 518       REAL   , INTENT(IN)        :: DT,XTIME,JULIAN
 519 !     REAL   , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
 520       INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
 521 !-----------------------------------------------------------------------
 522       INTEGER            :: LM1,LP1,LM
 523       INTEGER, INTENT(IN)               :: IHRST
 524 !     REAL,    INTENT(IN), DIMENSION(NL)    :: PRGFDL
 525 !
 526       REAL, PARAMETER :: EPSQ1=1.E-5,EPSQ=1.E-12,EPSO3=1.E-10,H0=0.     &
 527      &, H1=1.,HALF=.5,T0C=273.15,CUPRATE=24.*1000.,HPINC=HALF*1.E1      &
 528 !------------------------ For Clouds ----------------------------------
 529      &, CLFRmin=0.01, TAUCmax=4.161                                     &
 530 !--- Parameters used for new cloud cover scheme
 531      &, XSDmin=-XSDmax, DXSD1=-DXSD, STSDM=0.01, CVSDM=.04              &
 532      &, DXSD2=HALF*DXSD, DXSD2N=-DXSD2, PCLDY=0.25
 533 !
 534       INTEGER, PARAMETER :: NB=12,KSMUD=0
 535       INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15)
 536       REAL (KIND=K15) :: DDX,EEX,PROD
 537 !     REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
 538 !-----------------------------------------------------------------------
 539       LOGICAL :: SHORT,LONG
 540       LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITCP1,BITSP1
 541       LOGICAL, SAVE :: CNCLD=.TRUE.
 542       LOGICAL :: NEW_CLOUD
 543 !-----------------------------------------------------------------------
 544       REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D
 545       REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW,   &
 546      &                                                         QICE,T,  &
 547      &                                                         PFLIP,   &
 548      &                                                         P8WFLIP
 549
 550 !     REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE
 551       REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN   &
 552      &                                                ,RSWIN,RSWINC     & !Added
 553      &                                                ,CFRACL,CFRACM    &
 554      &                                                ,CFRACH
 555       REAL, INTENT(OUT),DIMENSION(ims:ime,kms:kme,jms:jme) :: CLDFRA   !added
 556
 557 !     REAL,   INTENT(IN), DIMENSION(kms:kme)   :: ETAD
 558 !     REAL,   INTENT(IN), DIMENSION(kms:kme)   :: AETA
 559 !-----------------------------------------------------------------------
 560       REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: CUTOP,CUBOT,CUPPT
 561       REAL,   INTENT(IN   ), DIMENSION(ims:ime,jms:jme)  :: ALB,SNO
 562 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
 563       REAL,   INTENT(IN   ), DIMENSION(ims:ime,jms:jme)  :: GLAT,GLON
 564 !-----------------------------------------------------------------------
 565       REAL,   DIMENSION(ims:ime,jms:jme)  :: CZEN
 566       INTEGER, DIMENSION(its:ite, jts:jte):: LMH
 567 !-----------------------------------------------------------------------
 568 !     INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW
 569 !-----------------------------------------------------------------------
 570       REAL,   INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST &
 571                                                           ,RSWTOA,RLWTOA
 572       INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST
 573 !-----------------------------------------------------------------------
 574       REAL,   INTENT(IN),   DIMENSION(ims:ime,jms:jme) :: VEGFRC
 575       REAL,   INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
 576      &                                                            TENDS
 577 !-----------------------------------------------------------------------
 578       REAL :: CTHK(3)
 579       DATA CTHK/20000.0,20000.0,20000.0/
 580
 581       REAL,DIMENSION(10),SAVE :: CC,PPT
 582 !-----------------------------------------------------------------------
 583       REAL,SAVE :: ABCFF(NB)
 584       INTEGER,DIMENSION(its:ite,jts:jte) :: LVL
 585       REAL,   DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL
 586       REAL,   DIMENSION(  0:kte)  :: CLDAMT
 587       REAL,   DIMENSION(its:ite,3):: CLDCFR
 588       INTEGER,   DIMENSION(its:ite,3):: MBOT,MTOP
 589       REAL,   DIMENSION(its:ite)  :: PSFC,TSKN,ALBEDO,XLAT,COSZ,        &
 590      &                               SLMSK,FLWUP,                       &
 591      &                               FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS,  &
 592      &                               FLWUPS,FSWDNSC
 593
 594       REAL,   DIMENSION(its:ite,kts:kte) :: PMID,TMID
 595       REAL,   DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN
 596       REAL,   DIMENSION(its:ite,jts:jte) :: TOT
 597
 598       REAL,   DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT
 599       INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
 600       INTEGER,DIMENSION(its:ite)   :: NCLDS,KCLD
 601       REAL,   DIMENSION(its:ite)   :: TAUDAR
 602       REAL,   DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL
 603
 604       REAL,   DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID
 605 !!      &                                     ,QOVRCST                  ! Added
 606       REAL,SAVE :: P400=40000.
 607       INTEGER,SAVE :: NFILE=14
 608
 609 !-----------------------------------------------------------------------
 610       REAL    :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG
 611       REAL    :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2
 612       REAL    :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX
 613       REAL    :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF
 614       REAL    :: BB,GG,FCTR,PDSLIJ,CFRAVG,SNOMM
 615       REAL    :: THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD
 616       REAL    :: RHtot,SDM
 617       REAL    :: TauC,CTauL,CTauS,  CFSmax,CFCmax
 618       INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW,    &
 619      &           JD,II
 620       INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL
 621       INTEGER :: LCNVB,LCNVT
 622       INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP
 623       INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1
 624
 625       INTEGER :: INDEXS,IXSD
 626       DATA    CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/
 627       DATA    PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./
 628       DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989.,      &
 629      &           2706.,39011./
 630 ! begin debugging radiation
 631       integer :: imd,jmd, Jndx
 632       real :: FSWrat
 633       imd=(ims+ime)/2
 634       jmd=(jms+jme)/2
 635 ! end debugging radiation
 636 !
 637 !=======================================================================
 638 !
 639       MYJS=jts
 640       MYJE=jte
 641       MYIS=its
 642       MYIE=ite
 643       MYJS1=jts !????
 644       MYJE1=jte
 645       MYJS2=jts
 646       MYJE2=jte
 647       LM=kte
 648       LM1=LM-1
 649       LP1=LM+1
 650 !
 651       DO J=JTS,JTE
 652       DO I=ITS,ITE
 653         LMH(I,J)=KME-1
 654         LVL(I,J)=0
 655       ENDDO
 656       ENDDO
 657 !**********************************************************************
 658 !***  THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED.
 659 !**********************************************************************
 660 !----------------------CONVECTION--------------------------------------
 661 !  NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP
 662 !     FOR RADIATION
 663 !   NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS
 664 !         THEY ARE INTEGER MULTIPLES OF EACH OTHER
 665 !  CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD
 666 !
 667       NTSPH=NINT(3600./DT)
 668       NRADPP=MIN(NRADS,NRADL)
 669       CLSTP=1.0*NRADPP/NTSPH
 670       CONVPRATE=CUPRATE/CLSTP
 671 !----------------------CONVECTION--------------------------------------
 672 !***
 673 !***  STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE.
 674 !***
 675       SHORT=.TRUE.
 676       LONG=.TRUE.
 677       ITIMSW=0
 678       ITIMLW=0
 679       IF(SHORT)ITIMSW=1
 680       IF(LONG) ITIMLW=1
 681 !***
 682 !***  FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE
 683 !***  BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS
 684 !***  CALLED.  ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON.
 685 !***
 686 !     TIME=NTSD*DT
 687       TIME=XTIME*60.
 688 !-----------------------------------------------------------------------
 689       CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN,             &
 690      &            MYIS,MYIE,MYJS,MYJE,                                  &
 691      &            ids,ide, jds,jde, kds,kde,                            &
 692      &            ims,ime, jms,jme, kms,kme,                            &
 693      &            its,ite, jts,jte, kts,kte                             )
 694 !-----------------------------------------------------------------------
 695 !     write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS)
 696       ADDL=0.
 697       IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
 698       RANG=PI2*(DAYI-RLAG)/(365.+ADDL)
 699       RSIN1=SIN(RANG)
 700       RCOS1=COS(RANG)
 701       RCOS2=COS(2.*RANG)
 702 !
 703 !-----------------------------------------------------------------------
 704       IF(SHORT)THEN
 705         DO J=MYJS,MYJE
 706         DO I=MYIS,MYIE
 707           CZMEAN(I,J)=0.
 708           TOT(I,J)=0.
 709         ENDDO
 710         ENDDO
 711 !
 712         DO II=0,NRADS,NPHS
 713           TIMES=XTIME*60.+II*DT
 714           CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN,        &
 715      &                MYIS,MYIE,MYJS,MYJE,                              &
 716      &                ids,ide, jds,jde, kds,kde,                        &
 717      &                ims,ime, jms,jme, kms,kme,                        &
 718      &                its,ite, jts,jte, kts,kte                         )
 719 !         write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),&
 720 !    &                II,NRADS,NPHS,NTSD,DT
 721           DO J=MYJS,MYJE
 722           DO I=MYIS,MYIE
 723             IF(CZEN(I,J).GT.0.)THEN
 724               CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
 725               TOT(I,J)=TOT(I,J)+1.
 726             ENDIF
 727           ENDDO
 728           ENDDO
 729         ENDDO
 730         DO J=MYJS,MYJE
 731         DO I=MYIS,MYIE
 732           IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
 733         ENDDO
 734         ENDDO
 735       ENDIF
 736
 737 !
 738 !
 739 !***  Do not modify pressure for ozone concentrations below the top layer
 740 !***
 741       DO L=2,LM
 742       DO I=MYIS,MYIE
 743         POZN(I,L)=H1
 744       ENDDO
 745       ENDDO
 746 !-----------------------------------------------------------------------
 747 !
 748 !***********************************************************************
 749 !***  THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN
 750 !***********************************************************************
 751 !                        *********************
 752                          DO 700 J = MYJS, MYJE
 753 !                        *********************
 754 !
 755       DO 125 L=1,LM
 756       DO I=MYIS,MYIE
 757         TMID(I,L)=T(I,1,J)
 758         QMID(I,L)=EPSQ
 759         QWMID(I,L)=0.
 760         QIMID(I,L)=0.
 761         CSMID(I,L)=0.
 762         CCMID(I,L)=0.
 763         OZN(I,L)=EPSO3
 764         TENDS(I,L,J)=0.
 765         TENDL(I,L,J)=0.
 766       ENDDO
 767   125 CONTINUE
 768 !
 769       DO 140 N=1,3
 770       DO I=MYIS,MYIE
 771         CLDCFR(I,N)=0.
 772         MTOP(I,N)=0
 773         MBOT(I,N)=0
 774       ENDDO
 775   140 CONTINUE
 776 !***
 777 !***  FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT
 778 !***  ARE ACTUALLY AT ETA LEVEL L=LMH.
 779 !***
 780       DO 200 I=MYIS,MYIE
 781 !     IR=IRAD(I)
 782       LML=LMH(I,J)
 783       LVLIJ=LVL(I,J)
 784 !
 785       DO L=1,LML
 786         PMID(I,L+LVLIJ)=PFLIP(I,L,J)
 787         PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J)
 788         EXNER=(1.E5/PMID(I,L+LVLIJ))**RCP
 789         TMID(I,L+LVLIJ)=T(I,L,J)
 790         THMID(I,L+LVLIJ)=T(I,L,J)*EXNER
 791         QMID(I,L+LVLIJ)=MAX(EPSQ, Q(I,L,J))
 792 !--- Note that rain is ignored, only effects from cloud water and
 793 !    ice (cloud ice + snow) are considered
 794         QWMID(I,L+LVLIJ)=QCW(I,L,J)
 795         QIMID(I,L+LVLIJ)=QICE(I,L,J)
 796       ENDDO
 797 !***
 798 !***  FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN.
 799 !***  PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA.
 800 !***  TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1.
 801 !***
 802       IF(LVLIJ.GT.0)THEN
 803         KNTLYR=0
 804 !
 805         DO L=LVLIJ,1,-1
 806           KNTLYR=KNTLYR+1
 807           PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*HPINC
 808           PINT(I,L+1)=PMID(I,L)+HPINC
 809           EXNER=(1.E5/PMID(I,L))**RCP
 810           THMID(I,L)=TMID(I,L)*EXNER
 811         ENDDO
 812       ENDIF
 813 !
 814       IF(LVLIJ.EQ.0) THEN
 815          PINT(I,1)=P8WFLIP(I,1,J)
 816       ELSE
 817          PINT(I,1)=PMID(I,1)-HPINC
 818       ENDIF
 819   200 CONTINUE
 820 !***
 821 !***  FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE,
 822 !***  ZENITH ANGLE, SEA MASK, AND ALBEDO.  THE SKIN TEMPERATURE IS
 823 !***  NEGATIVE OVER WATER.
 824 !***
 825       DO 250 I=MYIS,MYIE
 826       PSFC(I)=P8WFLIP(I,KME,J)
 827       APES=(PSFC(I)*1.E-5)**RCP
 828 !     TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J))
 829       IF((XLAND(I,J)-1.5).GT.0.)THEN
 830         TSKN(I)=-TSK2D(I,J)
 831       ELSE
 832         TSKN(I)=TSK2D(I,J)
 833       ENDIF
 834
 835 !     TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.))
 836 !     SLMSK(I)=SM(I,J)
 837       SLMSK(I)=XLAND(I,J)-1.
 838 !
 839 !     SNO(I,J)=AMAX1(SNO(I,J),0.)
 840 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
 841       SNOMM=AMAX1(SNO(I,J),0.)
 842       SNOFAC=AMIN1(SNOMM/0.02, 1.0)
 843 !!!!  ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J))
 844       ALBEDO(I)=ALB(I,J)
 845 !
 846       XLAT(I)=GLAT(I,J)*RTD
 847       COSZ(I)=CZMEAN(I,J)
 848   250 CONTINUE
 849 !-----------------------------------------------------------------------
 850 !---  COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION  (Ferrier, Nov '04)
 851 !
 852 !--- Assumes Gaussian-distributed probability density functions (PDFs) for
 853 !    total relative humidity (RHtot) within the grid for convective and
 854 !    grid-scale cloud processes.  The standard deviation of RHtot is assumed
 855 !    to be larger for convective clouds than grid-scale (stratiform) clouds.
 856 !-----------------------------------------------------------------------
 857 !
 858       DO I=MYIS,MYIE
 859         LML=LMH(I,J)
 860         LVLIJ=LVL(I,J)
 861         DO 255 L=1,LML
 862             LL=L+LVLIJ
 863             WV=QMID(I,LL)/(1.-QMID(I,LL))       !--- Water vapor mixing ratio
 864             QCLD=QWMID(I,LL)+QIMID(I,LL)        !--- Total cloud water + ice mixing ratio
 865             IF (QCLD .LE. EPSQ) GO TO 255       !--- Skip if no condensate is present
 866             CLFR=H0
 867             WV=QMID(I,LL)/(1.-QMID(I,LL))       !--- Water vapor mixing ratio
 868
 869     !
 870     !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C )
 871     !
 872 #ifdef FERRIER_GFDL
 873             ESAT=1000.*FPVS(TMID(I,LL))         !--- Saturation vapor pressure (Pa)
 874 #else
 875             ESAT=FPVS_new(TMID(I,LL))           !--- Saturation vapor pressure (Pa)
 876 #endif
 877             QSAT=EP_2*ESAT/(PMID(I,LL)-ESAT)    !--- Saturation mixing ratio
 878             RHUM=WV/QSAT                        !--- Relative humidity
 879     !
 880     !--- Revised cloud cover parameterization (temporarily ignore rain)
 881     !
 882             RHtot=(WV+QCLD)/QSAT                !--- Total relative humidity
 883             LCNVT=NINT(CUTOP(I,J))+LVLIJ
 884             LCNVT=MIN(LM,LCNVT)
 885             LCNVB=NINT(CUBOT(I,J))+LVLIJ
 886             LCNVB=MIN(LM,LCNVB)
 887             IF (LL.GE.LCNVT .AND. LL.LE.LCNVB) THEN
 888                SDM=CVSDM
 889             ELSE
 890                SDM=STSDM
 891             ENDIF
 892             ARG=(RHtot-RHgrd)/SDM
 893             IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) THEN
 894                CLFR=HALF
 895             ELSE IF (ARG .GT. DXSD2) THEN
 896                IF (ARG .GE. XSDmax) THEN
 897                   CLFR=H1
 898                ELSE
 899                   IXSD=INT(ARG/DXSD+HALF)
 900                   IXSD=MIN(NXSD, MAX(IXSD,1))
 901                   CLFR=HALF+AXSD(IXSD)
 902                   if (SDprint)                                          &
 903      & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)")                 &
 904      & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot     &
 905      & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
 906                ENDIF              !--- End IF (ARG .GE. XSDmax)
 907             ELSE
 908                IF (ARG .LE. XSDmin) THEN
 909                   CLFR=H0
 910                ELSE
 911                   IXSD=INT(ARG/DXSD1+HALF)
 912                   IXSD=MIN(NXSD, MAX(IXSD,1))
 913                   CLFR=HALF-AXSD(IXSD)
 914                   if (SDprint)                                          &
 915      & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)")                 &
 916      & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot     &
 917      & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
 918                   IF (CLFR .LT. CLFRmin) CLFR=H0
 919                ENDIF        !--- End IF (ARG .LE. XSDmin)
 920             ENDIF           !--- IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N)
 921             CSMID(I,LL)=CLFR
 922 255       CONTINUE         !--- End DO L=1,LML
 923       ENDDO                !--- End DO I=MYIS,MYIE
 924 !
 925 !***********************************************************************
 926 !******************  END OF GRID-SCALE CLOUD FRACTIONS  ****************
 927 !
 928 !---  COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION
 929 !
 930 !--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is
 931 !    used for convective cloud fraction as a function of precipitation
 932 !    rate.  Cloud fractions have been increased by 20% for each rainrate
 933 !    interval so that shallow, nonprecipitating convection is ascribed a
 934 !    constant cloud fraction of 0.1  (Ferrier, Feb '02).
 935 !***********************************************************************
 936 !
 937       IF (CNCLD) THEN
 938         DO I=MYIS,MYIE
 939 !
 940 !***  CLOUD TOPS AND BOTTOMS COME FROM CUCNVC
 941 !     Convective clouds need to be at least 2 model layers thick
 942 !
 943           IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) THEN
 944  !--- Compute convective cloud fractions if appropriate  (Ferrier, Feb '02)
 945             CLFR=CC(1)
 946             PMOD=CUPPT(I,J)*CONVPRATE
 947             IF (PMOD .GT. PPT(1)) THEN
 948               DO NC=1,10
 949                 IF(PMOD.GT.PPT(NC)) NMOD=NC
 950               ENDDO
 951               IF (NMOD .GE. 10) THEN
 952                 CLFR=CC(10)
 953               ELSE
 954                 CC1=CC(NMOD)
 955                 CC2=CC(NMOD+1)
 956                 P1=PPT(NMOD)
 957                 P2=PPT(NMOD+1)
 958                 CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1)
 959               ENDIF      !--- End IF (NMOD .GE. 10) ...
 960               CLFR=MIN(H1, CLFR)
 961             ENDIF        !--- End IF (PMOD .GT. PPT(1)) ...
 962   !
 963   !***  ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS
 964   !
 965             LVLIJ=LVL(I,J)
 966             LCNVT=NINT(CUTOP(I,J))+LVLIJ
 967             LCNVT=MIN(LM,LCNVT)
 968             LCNVB=NINT(CUBOT(I,J))+LVLIJ
 969             LCNVB=MIN(LM,LCNVB)
 970 !! !
 971 !! !---- For debugging
 972 !! !
 973 !!      WRITE(6,"(2(A,I3),2(A,I2),2(A,F5.2),2(A,I2),A,F6.4)")
 974 !!     & ' J=',J,' I=',I,' LCNVB=',LCNVB,' LCNVT=',LCNVT
 975 !!     &, ' CUBOT=',CUBOT(I,J),' CUTOP=',CUTOP(I,J)
 976 !!     &,' LVL=',LVLIJ,' LMH=',LMH(I,J),' CCMID=',CLFR
 977 !! !
 978    !
 979    !--- Build in small amounts of subgrid-scale convective condensate
 980    !    (simple assumptions), but only if the convective cloud fraction
 981    !    exceeds that of the grid-scale cloud fraction
 982    !
 983             DO LL=LCNVT,LCNVB
 984               ARG=MAX(H0, H1-CSMID(I,LL))
 985               CCMID(I,LL)=MIN(ARG,CLFR)
 986             ENDDO           !--- End DO LL=LCNVT,LCNVB
 987           ENDIF             !--- IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) ...
 988         ENDDO               !--- End DO I loop
 989       ENDIF                 !--- End IF (CNCLD) ...
 990 !
 991 !*********************************************************************
 992 !***************  END OF CONVECTIVE CLOUD FRACTIONS  *****************
 993 !*********************************************************************
 994 !***
 995 !***  DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID
 996 !***  AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL
 997 !***
 998 !***  NOTE: THIS IS FOR DIAGNOSTICS ONLY!!!
 999 !***
1000 !***
1001        DO 500 I=MYIS,MYIE
1002 !!
1003        DO L=0,LM
1004          CLDAMT(L)=0.
1005        ENDDO
1006 !!
1007 !!***  NOW GOES LOW, MIDDLE, HIGH
1008 !!
1009        DO 480 NLVL=1,3
1010        CLDMAX=0.
1011        MALVL=LM
1012        LLTOP=LM+1-LTOP(NLVL)+LVL(I,J)
1013 !!***
1014 !!***  GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN
1015 !!***  QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND.
1016 !!***
1017        IF(LLTOP.GE.LM)GO TO 480
1018 !!
1019        IF(NLVL.GT.1)THEN
1020          LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J)
1021          LLBOT=MIN(LLBOT,LM1)
1022        ELSE
1023          LLBOT=LM1
1024        ENDIF
1025 !!
1026        DO 435 L=LLTOP,LLBOT
1027        CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L))
1028        IF(CLDAMT(L).GT.CLDMAX)THEN
1029          MALVL=L
1030          CLDMAX=CLDAMT(L)
1031        ENDIF
1032    435 CONTINUE
1033 !!*********************************************************************
1034 !! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN
1035 !! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992).
1036 !! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE
1037 !! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED.
1038 !! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST
1039 !! CONTINUING CLOUD LAYERS IN THE DOMAIN.
1040 !!*********************************************************************
1041        CL1=0.0
1042        CL2=0.0
1043        KBT1=LLBOT
1044        KBT2=LLBOT
1045        KTH1=0
1046        KTH2=0
1047 !!
1048        DO 450 LL=LLTOP,LLBOT
1049        L=LLBOT-LL+LLTOP
1050        BIT1=.FALSE.
1051        CR1=CLDAMT(L)
1052        BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND.                           &
1053       &     (PINT(I,L).LT.PTOPC(NLVL)).AND.                             &
1054       &     (CLDAMT(L).GT.0.0)
1055        BIT1=BIT1.OR.BITX
1056        IF(.NOT.BIT1)GO TO 450
1057 !!***
1058 !!***  BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER
1059 !!***  NOTE:  WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE
1060 !!***         DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR
1061 !!***         HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY
1062 !!***         WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE
1063 !!***         NEEDED IN THE FUTURE.
1064 !!***
1065        BITY=BITX.AND.(KTH2.LE.0)
1066        BITZ=BITX.AND.(KTH2.GT.0)
1067 !!
1068        IF(BITY)THEN
1069          KBT2=L
1070          KTH2=1
1071        ENDIF
1072 !!
1073        IF(BITZ)THEN
1074          KTOP1=KBT2-KTH2+1
1075          DPCL=PMID(I,KBT2)-PMID(I,KTOP1)
1076          IF(DPCL.LT.CTHK(NLVL))THEN
1077            KTH2=KTH2+1
1078          ELSE
1079            KBT2=KBT2-1
1080          ENDIF
1081        ENDIF
1082        IF(BITX)CL2=AMAX1(CL2,CR1)
1083 !!***
1084 !!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP.
1085 !!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD
1086 !!*** LAYER IN THAT DOMAIN.
1087 !!***
1088        BIT2=.FALSE.
1089        BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. &
1090             PINT(I,L-1).LT.PTOPC(NLVL+1))
1091        BITZ=BITY.AND.CL1.GT.0.0
1092        BITW=BITY.AND.CL1.LE.0.0
1093        BIT2=BIT2.OR.BITY
1094        IF(.NOT.BIT2)GO TO 450
1095 !!
1096        IF(BITZ)THEN
1097          KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2))
1098          KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1
1099          CL1=CL1+CL2-CL1*CL2
1100        ENDIF
1101 !!
1102        IF(BITW)THEN
1103          KBT1=KBT2
1104          KTH1=KTH2
1105          CL1=CL2
1106        ENDIF
1107 !!
1108        IF(BITY)THEN
1109          KBT2=LLBOT
1110          KTH2=0
1111          CL2=0.0
1112        ENDIF
1113    450 CONTINUE
1114 !
1115        CLDCFR(I,NLVL)=AMIN1(1.0,CL1)
1116        MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1)
1117        MBOT(I,NLVL)=KBT1
1118    480 CONTINUE
1119    500 CONTINUE
1120
1121 !***
1122 !***  SET THE UN-NEEDED TAUDAR TO ONE
1123 !***
1124       DO I=MYIS,MYIE
1125         TAUDAR(I)=1.0
1126       ENDDO
1127 !----------------------------------------------------------------------
1128 ! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982),
1129 ! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993).
1130 !
1131 ! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO
1132 !         CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL
1133 !         LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED
1134 !         IN THIS CALCULATIONS.
1135 !
1136 !                                     QINGYUN ZHAO   95-3-22
1137 !
1138 !----------------------------------------------------------------------
1139 !
1140 !***
1141 !*** INITIALIZE ARRAYS FOR USES LATER
1142 !***
1143
1144       DO 600 I=MYIS,MYIE
1145       LML=LMH(I,J)
1146       LVLIJ=LVL(I,J)
1147 !
1148 !***
1149 !*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD
1150 !***       LAYER ABOVE THE SURFACE AND SO ON.
1151 !***
1152       EMIS(I,1)=1.0
1153       KTOP(I,1)=LP1
1154       KBTM(I,1)=LP1
1155       CAMT(I,1)=1.0
1156       KCLD(I)=2
1157 !
1158       DO NBAND=1,NB
1159         RRCL(I,NBAND,1)=0.0
1160         TTCL(I,NBAND,1)=1.0
1161       ENDDO
1162 !
1163       DO 510 L=2,LP1
1164       CAMT(I,L)=0.0
1165       KTOP(I,L)=1
1166       KBTM(I,L)=1
1167       EMIS(I,L)=0.0
1168 !
1169       DO NBAND=1,NB
1170         RRCL(I,NBAND,L)=0.0
1171         TTCL(I,NBAND,L)=1.0
1172       ENDDO
1173   510 CONTINUE
1174
1175 !### End changes so far
1176 !***
1177 !*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER
1178 !*** CLOUD TYPE=1: STRATIFORM CLOUD
1179 !***       TYPE=2: CONVECTIVE CLOUD
1180 !*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT,
1181 !*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION.
1182 !*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS.
1183 !*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN.
1184 !*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS
1185 !*** OF MODEL LEVEL.
1186 !***
1187       NEW_CLOUD=.TRUE.
1188 !
1189       DO L=2,LML
1190         LL=LML-L+1+LVLIJ                        !-- Model layer
1191         CLFR=MAX(CCMID(I,LL),CSMID(I,LL))       !-- Cloud fraction in layer
1192         CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1))  !-- Cloud fraction in lower layer
1193 !-------------------
1194         IF (CLFR .GE. CLFRMIN) THEN
1195 !--- Cloud present at level
1196           IF (NEW_CLOUD) THEN
1197 !--- New cloud layer
1198             IF(L==2.AND.CLFR1>=CLFRmin)THEN
1199               KBTM(I,KCLD(I))=LL+1
1200               CAMT(I,KCLD(I))=CLFR1
1201             ELSE
1202               KBTM(I,KCLD(I))=LL
1203               CAMT(I,KCLD(I))=CLFR
1204             ENDIF
1205             NEW_CLOUD=.FALSE.
1206           ELSE
1207 !--- Existing cloud layer
1208             CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR)
1209           ENDIF        ! End IF (NEW_CLOUD .EQ. 0) ...
1210         ELSE IF (CLFR1 .GE. CLFRMIN) THEN
1211 !--- Cloud is not present at level but did exist at lower level, then ...
1212           IF (L .EQ. 2) THEN
1213 !--- For the case of ground fog
1214             KBTM(I,KCLD(I))=LL+1
1215             CAMT(I,KCLD(I))=CLFR1
1216           ENDIF
1217           KTOP(I,KCLD(I))=LL+1
1218           NEW_CLOUD=.TRUE.
1219           KCLD(I)=KCLD(I)+1
1220           CAMT(I,KCLD(I))=0.0
1221         ENDIF
1222 !-------------------
1223       ENDDO      !--- End DO L loop
1224 !***
1225 !*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND;
1226 !*** THE LAST IS THE SKY):
1227 !***
1228       NCLDS(I)=KCLD(I)-2
1229       NCLD=NCLDS(I)
1230 !***
1231 !***  NOW CALCULATE CLOUD RADIATIVE PROPERTIES
1232 !***
1233       IF(NCLD.GE.1)THEN
1234 !***
1235 !*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!!
1236 !***
1237         DO 580 NC=2,NCLD+1
1238 !
1239         TauC=0.    !--- Total optical depth for each cloud layer (solar & longwave)
1240         QSUM=0.0
1241         NKTP=LP1
1242         NBTM=0
1243         BITX=CAMT(I,NC).GE.CLFRMIN
1244         NKTP=MIN(NKTP,KTOP(I,NC))
1245         NBTM=MAX(NBTM,KBTM(I,NC))
1246 !
1247         DO LL=NKTP,NBTM
1248           IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN
1249             PRS1=PINT(I,LL)*0.01
1250             PRS2=PINT(I,LL+1)*0.01
1251             DELP=PRS2-PRS1
1252             TCLD=TMID(I,LL)-T0C
1253             QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2)                       &
1254      &           /(120.1612*SQRT(TMID(I,LL)))
1255 !
1256 !***********************************************************************
1257 !****  IMPORTANT NOTES concerning input cloud optical properties  ******
1258 !***********************************************************************
1259 !
1260 !--- The simple optical depth parameterization from eq. (1) of Harshvardhan
1261 !    et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship)
1262 !    is used for convective cloud properties with some simple changes.
1263 !
1264 !--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are
1265 !    described below.
1266 !      1) CTau=0.08*(Qc/Q0) for cloud water mixing ratio (Qc), where
1267 !         Q0 is assumed to be the threshold mixing ratio for "thick anvils",
1268 !         as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al.
1269 !         (1989).  A value of Q0=0.1 g/kg is assumed based on experience w/
1270 !         cloud observations, and it is intended only to be a crude scaling
1271 !         factor for "order of magnitude" effects.  The functional dependence
1272 !         on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7).
1273 !         Result: CTau=800.*Qc => note that the "800." factor is referred to
1274 !         as an absorption coefficient
1275 !      2) For an assumed value of Q0=1 g/kg for "thick anvils", then
1276 !         CTau=80.*Qc, or an absorption coefficient that is an order of
1277 !         magnitude less.
1278 !      => ABSCOEF_W can vary from 100. to 1000. !!
1279 !      3) From p. 3105 of Dudhia (1989), values of
1280 !         0.14 (m**2/g) * 1000 (g/kg) / 9.81 (m/s**2) = 14.27 /Pa
1281 !         => 14.27 (/Pa) * 100 (Pa/mb) = 1427 /mb
1282 !      4) From Dudhia's SW radiation, ABSCOEF_W ~ 1000.  after units conversion
1283 !      5) Again from p. 3105 of Dudhia (1989), he notes that ice absorption
1284 !         coefficients are roughly half those of cloud water, it was decided
1285 !         to keep this simple and assume half that of water.
1286 !      => ABSCOEF_I=0.5*ABSCOEF_W
1287 !
1288 !--- For convection, the following is assumed:
1289 !      1) A characteristic water/ice mixing ratio (Qconv)
1290 !      2) A temperature threshold for water or ice (TRAD_ice)
1291 !
1292 !-----------------------------------------------------------------------
1293 !
1294             CTau=0.
1295 !-- For crude estimation of convective cloud optical depths
1296             IF (CCMID(I,LL) .GE. CLFRmin) THEN
1297               IF (TCLD .GE. TRAD_ice) THEN
1298                 CTau=CTauCW            !--- Convective cloud water
1299               ELSE
1300                 CTau=CTauCI            !--- Convective ice
1301               ENDIF
1302 !              CTau=CTau*CCMID(I,LL)    !--- Reduce by convective cloud fraction
1303             ENDIF
1304 !
1305 !-- For crude estimation of grid-scale cloud optical depths
1306 !
1307 !--   => The following 2 lines were intended to reduce cloud optical depths further
1308 !        than what's parameterized in the NAM and what's theoretically justified
1309 !            CTau=CTau+CSMID(I,LL)*   &
1310 !     &           ( ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) )
1311             CTau=CTau+ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL)
1312             TauC=TauC+DELP*CTau
1313           ENDIF      !--- End IF(LL.GE.KTOP(I,NC) ....
1314         ENDDO        !--- End DO LL
1315 !
1316         IF(BITX)EMIS(I,NC)=1.0-EXP(ABSCOEF_LW*TauC)
1317         IF(QSUM.GE.EPSQ1)THEN
1318 !
1319           DO 570 NBAND=1,NB
1320           IF(BITX)THEN
1321             PROD=ABCFF(NBAND)*QSUM
1322             DDX=TauC/(TauC+PROD)
1323             EEX=1.0-DDX
1324             IF(ABS(EEX).GE.1.E-8)THEN
1325               DD=DDX
1326               EE=EEX
1327               FF=1.0-DD*0.85
1328               AA=MIN(50.0,SQRT(3.0*EE*FF)*TauC)
1329               AA=EXP(-AA)
1330               BB=FF/EE
1331               GG=SQRT(BB)
1332               DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA
1333               RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD)
1334               TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD)
1335             ENDIF
1336           ENDIF
1337   570     CONTINUE
1338         ENDIF
1339   580   CONTINUE
1340 !
1341       ENDIF
1342 !
1343   600 CONTINUE
1344 !*********************************************************************
1345 !******************  COMPUTE OZONE AT MIDLAYERS  *********************
1346 !*********************************************************************
1347 !
1348 !***  MODIFY PRESSURE AT THE TOP MODEL LAYER TO ACCOUNT FOR THE TOTAL
1349 !***  OZONE FROM MODEL TOP (PINT_1) TO THE TOP OF THE ATMOSPHERE (0 MB)
1350 !
1351       DO I=MYIS,MYIE
1352         FCTR=PINT(I,2)/(PINT(I,2)-PINT(I,1))
1353         POZN(I,1)=FCTR*(PMID(I,1)-PINT(I,1))
1354       ENDDO
1355 !
1356       CALL OZON2D(LM,POZN,XLAT,OZN,                                &
1357                   MYIS,MYIE,                                       &
1358                   ids,ide, jds,jde, kds,kde,                       &
1359                   ims,ime, jms,jme, kms,kme,                       &
1360                   its,ite, jts,jte, kts,kte                        )
1361 !
1362 !***
1363 !***  NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED.
1364 !***
1365 !----------------------------------------------------------------------
1366 !***
1367 !***  CALL THE GFDL RADIATION DRIVER
1368 !***
1369 !***
1370       Jndx=J
1371       CALL RADFS &
1372      &     (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT         &
1373 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
1374      &,     CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL                         &
1375      &,     COSZ,TAUDAR,1                                               &
1376      &,     1,0                                                         &
1377      &,     ITIMSW,ITIMLW                                               &
1378      &,     TENDS(ITS,KTS,J),TENDL(ITS,KTS,J)                           &
1379      &,     FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC       &
1380      &,     ids,ide, jds,jde, kds,kde                                   &
1381      &,     ims,ime, jms,jme, kms,kme                                   &
1382 ! begin debugging radiation
1383      &,     its,ite, jts,jte, kts,kte                                   &
1384      &,     imd,jmd, Jndx                                       )
1385 ! end debugging radiation
1386 !----------------------------------------------------------------------
1387       IF(LONG)THEN
1388 !
1389 !--  All fluxes in W/m**2
1390 !--- GLW    => downward longwave at the surface (formerly RLWIN)
1391 !--- RLWTOA => outgoing longwave at the top of the atmosphere
1392 !-- Note:  RLWOUT & SIGT4 have been removed because they are no longer being used!
1393 !
1394         DO I=MYIS,MYIE
1395           GLW(I,J)=FLWDNS(I)
1396           RLWTOA(I,J)=FLWUP(I)
1397         ENDDO
1398       ENDIF
1399 !
1400       IF(SHORT)THEN
1401 !
1402 !--  All fluxes in W/m**2
1403 !--- GSW    => NET shortwave at the surface
1404 !--- RSWIN  => incoming shortwave at the surface (all sky)
1405 !--- RSWINC => clear-sky incoming shortwave at the surface
1406 !--- RSWTOA => outgoing (reflected) shortwave at the top of the atmosphere
1407 !
1408         DO I=MYIS,MYIE
1409           GSW(I,J)=FSWDNS(I)-FSWUPS(I)
1410           RSWIN(I,J) =FSWDNS(I)
1411           RSWINC(I,J)=FSWDNSC(I)
1412           RSWTOA(I,J)=FSWUP(I)
1413         ENDDO
1414       ENDIF
1415 !
1416 !***  ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND
1417 !***  CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY.
1418 !***  ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL.
1419 !
1420 !***  ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS.
1421 !
1422 !***  UPDATE NEW 3D CLOUD FRACTION (CLDFRA)
1423 !
1424       DO I=MYIS,MYIE
1425         CFRACL(I,J)=CLDCFR(I,1)
1426         CFRACM(I,J)=CLDCFR(I,2)
1427         CFRACH(I,J)=CLDCFR(I,3)
1428         IF(CNCLD)THEN
1429           CFSmax=0.   !-- Maximum cloud fraction (stratiform component)
1430           CFCmax=0.   !-- Maximum cloud fraction (convective component)
1431           DO L=1,LMH(I,J)
1432             LL=L+LVL(I,J)
1433             CFSmax=MAX(CFSmax, CSMID(I,LL) )
1434             CFCmax=MAX(CFCmax, CCMID(I,LL) )
1435           ENDDO
1436           ACFRST(I,J)=ACFRST(I,J)+CFSmax
1437           NCFRST(I,J)=NCFRST(I,J)+1
1438           ACFRCV(I,J)=ACFRCV(I,J)+CFCmax
1439           NCFRCV(I,J)=NCFRCV(I,J)+1
1440         ELSE
1441   !--- Count only locations with grid-scale cloudiness, ignore convective clouds
1442   !    (option not used, but if so set to the total cloud fraction)
1443           CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J))
1444           ACFRST(I,J)=ACFRST(I,J)+CFRAVG
1445           NCFRST(I,J)=NCFRST(I,J)+1
1446         ENDIF
1447 !--- Flip 3D cloud fractions in the vertical and save time
1448         LML=LMH(I,J)
1449         DO L=1,LML
1450           LL=LML-L+1+LVL(I,J)
1451           CLDFRA(I,L,J)=MAX(CCMID(I,LL),CSMID(I,LL))
1452         ENDDO
1453       ENDDO      !-- I index
1454 !***
1455 !***  THIS ROW IS FINISHED. GO TO NEXT
1456 !***
1457 !                        *********************
1458   700                          CONTINUE
1459 !                        *********************
1460 !----------------------------------------------------------------------
1461 !***
1462 !***  CALLS TO RADIATION THIS TIME STEP ARE COMPLETE.
1463 !***
1464 !----------------------------------------------------------------------
1465 ! begin debugging radiation
1466 !     FSWrat=0.
1467 !     if (RSWIN(imd,jmd) .gt. 0.)  &
1468 !        FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
1469 !     write(6,"(2a,2i5,7f9.2)") &
1470 !       '{rad3 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
1471 !      ,'ALBEDO,RSWOUT/RSWIN = '&
1472 !      ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd)  &
1473 !      ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
1474 !      ,ALB(imd,jmd),FSWrat
1475 ! end debugging radiation
1476 !----------------------------------------------------------------------
1477 !
1478 !--- Need to save LW & SW tendencies since radiation calculates both and this block
1479
1480       END SUBROUTINE RADTN
1481
1482 !----------------------------------------------------------------------
1483
1484       REAL FUNCTION GAUSIN(xsd)
1485       REAL, PARAMETER :: crit=1.e-3
1486       REAL A1,A2,RN,B1,B2,B3,SUM
1487 !
1488 !  This function calculate area under the Gaussian curve between mean
1489 !  and xsd # of standard deviation (03/22/2004  Hsin-mu Lin)
1490 !
1491       a1=xsd*RSQR
1492       a2=exp(-0.5*xsd**2)
1493       rn=1.
1494       b1=1.
1495       b2=1.
1496       b3=1.
1497       sum=1.
1498       do while (b2 .gt. crit)
1499          rn=rn+1.
1500          b2=xsd**2/(2.*rn-1.)
1501          b3=b1*b2
1502          sum=sum+b3
1503          b1=b3
1504       enddo
1505       GAUSIN=a1*a2*sum
1506       RETURN
1507       END FUNCTION GAUSIN
1508
1509 !----------------------------------------------------------------------
1510
1511       SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN,     &
1512                         MYIS,MYIE,MYJS,MYJE,                           &
1513                         IDS,IDE, JDS,JDE, KDS,KDE,                     &
1514                         IMS,IME, JMS,JME, KMS,KME,                     &
1515                         ITS,ITE, JTS,JTE, KTS,KTE                      )
1516 !----------------------------------------------------------------------
1517       IMPLICIT NONE
1518 !----------------------------------------------------------------------
1519       INTEGER, INTENT(IN)        :: IDS,IDE, JDS,JDE, KDS,KDE ,        &
1520                                     IMS,IME, JMS,JME, KMS,KME ,        &
1521                                     ITS,ITE, JTS,JTE, KTS,KTE
1522       INTEGER, INTENT(IN)        :: MYJS,MYJE,MYIS,MYIE
1523
1524       REAL,    INTENT(IN)        :: TIMES
1525       REAL,    INTENT(OUT)       :: HOUR,DAYI
1526       INTEGER, INTENT(IN)        :: IHRST
1527
1528       INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
1529       REAL,    INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON
1530       REAL,    INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN
1531
1532       REAL,    PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866,    &
1533                             GSTC3=9.3104E-2,GSTC4=-6.2E-6,             &
1534                             PI=3.1415926,PI2=2.*PI,PIH=0.5*PI,         &
1535 !#$                         DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD,    &
1536                             DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, &
1537                             ZEROJD=2451545.0
1538
1539       REAL    :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM,   &
1540                  ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG
1541       REAL    :: HRLCL,SINALT
1542       INTEGER :: KMNTH,KNT,IDIFYR,J,I
1543       LOGICAL :: LEAP
1544 !-----------------------------------------------------------------------
1545 !-----------------------------------------------------------------------
1546       INTEGER :: MONTH (12)
1547 !-----------------------------------------------------------------------
1548       DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
1549 !***********************************************************************
1550 !     SAVE MONTH
1551       DAY=0.
1552       LEAP=.FALSE.
1553       IF(MOD(IDAT(3),4).EQ.0)THEN
1554         MONTH(2)=29
1555         LEAP=.TRUE.
1556       ENDIF
1557       IF(IDAT(1).GT.1)THEN
1558         KMNTH=IDAT(1)-1
1559         DO 10 KNT=1,KMNTH
1560         DAY=DAY+REAL(MONTH(KNT))
1561    10   CONTINUE
1562       ENDIF
1563 !***
1564 !***  CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO
1565 !***  FORECAST TIME OF INTEREST
1566 !***
1567       DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24.
1568       DAYI=REAL(INT(DAY)+1)
1569       HOUR=(DAY-DAYI+1.)*24.
1570       YFCTR=2000.-IDAT(3)
1571 !-----------------------------------------------------------------------
1572 !***
1573 !***  FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND
1574 !***  RIGHT ASCENSION.
1575 !***
1576 !-----------------------------------------------------------------------
1577       IDIFYR=IDAT(3)-2000
1578 !***
1579 !***  FIND JULIAN DATE OF START OF THE RELEVANT YEAR
1580 !***  ADDING IN LEAP DAYS AS NEEDED
1581 !***
1582       IF(IDIFYR.LT.0)THEN
1583         ADDDAY=REAL(IDIFYR/4)
1584       ELSE
1585         ADDDAY=REAL((IDIFYR+3)/4)
1586       ENDIF
1587       STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5
1588 !***
1589 !***  THE JULIAN DATE OF THE TIME IN QUESTION
1590 !***
1591       DATJUL=STARTYR+DAY
1592 !
1593 !***  DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE
1594 !***  AT 00H 1 January 2000
1595 !
1596       DIFJD=DATJUL-ZEROJD
1597 !
1598 !***  MEAN GEOMETRIC LONGITUDE OF THE SUN
1599 !
1600       SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2
1601 !
1602 !***  THE MEAN ANOMOLY
1603 !
1604       ANOM=(357.528+0.9856003*DIFJD)*DEG2RD
1605 !
1606 !***  APPARENT GEOMETRIC LONGITUDE OF THE SUN
1607 !
1608       SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD
1609       IF(SLON.GT.PI2)SLON=SLON-PI2
1610 !
1611 !***  DECLINATION AND RIGHT ASCENSION
1612 !
1613       DEC=ASIN(SIN(SLON)*SIN(OBLIQ))
1614       RA=ACOS(COS(SLON)/COS(DEC))
1615       IF(SLON.GT.PI)RA=PI2-RA
1616 !***
1617 !***  FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR
1618 !***  HOUR ANGLE.
1619 !***
1620       DATJ0=STARTYR+DAYI-1.
1621       TU=(DATJ0-2451545.)/36525.
1622       STIM0=GSTC1+TU*(GSTC2+GSTC3*TU+GSTC4*TU*TU)
1623       SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR
1624       SIDTIM=SIDTIM*15.*DEG2RD
1625       IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2
1626       IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2
1627       HRANG=SIDTIM-RA
1628 !
1629       DO 100 J=MYJS,MYJE
1630       DO 100 I=MYIS,MYIE
1631 !     HRLCL=HRANG-GLON(I,J)
1632       HRLCL=HRANG+GLON(I,J)+PI2
1633 !***
1634 !***  THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE
1635 !***  COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE.
1636 !***
1637       SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* &
1638        COS(GLAT(I,J))
1639       IF(SINALT.LT.0.)SINALT=0.
1640       CZEN(I,J)=SINALT
1641   100 CONTINUE
1642 !***
1643 !***  IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME,
1644 !***  RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE
1645 !***  RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED).
1646 !***
1647       IF(DAYI.GT.365.)THEN
1648         IF(.NOT.LEAP)THEN
1649           DAYI=DAYI-365.
1650         ELSEIF(LEAP.AND.DAYI.GT.366.)THEN
1651           DAYI=DAYI-366.
1652         ENDIF
1653       ENDIF
1654 !
1655       END SUBROUTINE ZENITH
1656 !-----------------------------------------------------------------------
1657
1658   SUBROUTINE OZON2D (LK,POZN,XLAT,QO3,                                &
1659                      MYIS,MYIE,                                       &
1660                      ids,ide, jds,jde, kds,kde,                       &
1661                      ims,ime, jms,jme, kms,kme,                       &
1662                      its,ite, jts,jte, kts,kte                        )
1663 !----------------------------------------------------------------------
1664  IMPLICIT NONE
1665 !----------------------------------------------------------------------
1666       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
1667                                     ims,ime, jms,jme, kms,kme ,      &
1668                                     its,ite, jts,jte, kts,kte
1669       INTEGER, INTENT(IN)        :: LK,MYIS,MYIE
1670       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN
1671       REAL,    INTENT(IN), DIMENSION(its:ite)  :: XLAT
1672       REAL,    INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3
1673 !----------------------------------------------------------------------
1674       INTEGER, PARAMETER ::  NL=81,NLP1=NL+1,LNGTH=37*NL
1675
1676 !     REAL,    INTENT(IN),  DIMENSION(37,NL) :: XDUO3N,XDO3N4,XDO3N2,XDO3N3
1677 !     REAL,    INTENT(IN), DIMENSION(NL)    :: PRGFDL
1678 !----------------------------------------------------------------------
1679 !----------------------------------------------------------------------
1680       INTEGER,DIMENSION(its:ite)    :: JJROW
1681       REAL,   DIMENSION(its:ite)    :: TTHAN
1682       REAL,   DIMENSION(its:ite,NL) :: QO3O3
1683
1684       INTEGER :: I,K,NUMITR,ILOG,IT,NHALF
1685       REAL    :: TH2,DO3V,DO3VP,APHI,APLO
1686 !----------------------------------------------------------------------
1687       DO I=MYIS,MYIE
1688         TH2=0.2*XLAT(I)
1689         JJROW(I)=19.001-TH2
1690         TTHAN(I)=(19-JJROW(I))-TH2
1691       ENDDO
1692 !
1693 !***  SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
1694 !
1695       DO K=1,NL
1696       DO I=MYIS,MYIE
1697         DO3V=XDUO3N(JJROW(I),K)+RSIN1*XDO3N2(JJROW(I),K)  &
1698                    +RCOS1*XDO3N3(JJROW(I),K)  &
1699                    +RCOS2*XDO3N4(JJROW(I),K)
1700         DO3VP=XDUO3N(JJROW(I)+1,K)+RSIN1*XDO3N2(JJROW(I)+1,K) &
1701                     +RCOS1*XDO3N3(JJROW(I)+1,K) &
1702                     +RCOS2*XDO3N4(JJROW(I)+1,K)
1703 !
1704 !***  NOW LATITUDINAL INTERPOLATION
1705 !***  AND CONVERT O3 INTO MASS MIXING RATIO (ORIG DATA MPY BY 1.E4)
1706 !
1707         QO3O3(I,K)=1.E-4*(DO3V+TTHAN(I)*(DO3VP-DO3V))
1708       ENDDO
1709       ENDDO
1710 !***
1711 !***  VERTICAL INTERPOLATION FOR EACH GRIDPOINT (LINEAR IN LN P)
1712 !***
1713       NUMITR=0
1714       ILOG=NL
1715    20 CONTINUE
1716       ILOG=(ILOG+1)/2
1717         IF(ILOG.EQ.1)GO TO 25
1718         NUMITR=NUMITR+1
1719         GO TO 20
1720    25 CONTINUE
1721 !
1722       DO 60 K=1,LK
1723 !
1724       NHALF=(NL+1)/2
1725       DO I=MYIS,MYIE
1726         JJROW(I)=NHALF
1727       ENDDO
1728 !
1729       DO 40 IT=1,NUMITR
1730       NHALF=(NHALF+1)/2
1731       DO I=MYIS,MYIE
1732         IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN
1733           JJROW(I)=JJROW(I)-NHALF
1734         ELSEIF(POZN(I,K).GE.PRGFDL(JJROW(I)))THEN
1735           JJROW(I)=JJROW(I)+NHALF
1736         ENDIF
1737         JJROW(I)=MIN(JJROW(I),NL)
1738         JJROW(I)=MAX(JJROW(I),2)
1739       ENDDO
1740    40 CONTINUE
1741 !
1742       DO 50 I=MYIS,MYIE
1743       IF(POZN(I,K).LT.PRGFDL(1))THEN
1744         QO3(I,K)=QO3O3(I,1)
1745       ELSE IF(POZN(I,K).GT.PRGFDL(NL))THEN
1746         QO3(I,K)=QO3O3(I,NL)
1747       ELSE
1748         APLO=ALOG(PRGFDL(JJROW(I)-1))
1749         APHI=ALOG(PRGFDL(JJROW(I)))
1750         QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ &
1751                    (APLO-APHI)* &
1752                    (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I)))
1753       ENDIF
1754    50 CONTINUE
1755 !
1756    60 CONTINUE
1757
1758   END SUBROUTINE OZON2D
1759 !-----------------------------------------------------------------------
1760
1761 ! SUBROUTINE ZERO2(ARRAY, &
1762 !                  ids,ide, jds,jde, kds,kde,                         &
1763 !                  ims,ime, jms,jme, kms,kme,                         &
1764 !                  its,ite, jts,jte, kts,kte                          )
1765 !----------------------------------------------------------------------
1766 !IMPLICIT NONE
1767 !----------------------------------------------------------------------
1768 !     INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
1769 !                                   ims,ime, jms,jme, kms,kme ,      &
1770 !                                   its,ite, jts,jte, kts,kte
1771 !     REAL, INTENT(INOUT), DIMENSION(its:ite,jts:jte) :: ARRAY
1772 !     INTEGER :: I,J
1773 !----------------------------------------------------------------------
1774 !     DO J=jts,jte
1775 !     DO I=its,ite
1776 !       ARRAY(I,J)=0.
1777 !     ENDDO
1778 !     ENDDO
1779
1780 ! END SUBROUTINE ZERO2
1781
1782 !----------------------------------------------------------------
1783
1784       SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
1785                  ids,ide, jds,jde, kds,kde,            &
1786                  ims,ime, jms,jme, kms,kme,            &
1787                  its,ite, jts,jte, kts,kte             )
1788 !----------------------------------------------------------------------
1789  IMPLICIT NONE
1790 !----------------------------------------------------------------------
1791       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
1792                                     ims,ime, jms,jme, kms,kme ,      &
1793                                     its,ite, jts,jte, kts,kte
1794
1795 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
1796 !                .      .    .                                       .
1797 ! SUBPROGRAM:    O3INT       COMPUTE ZONAL MEAN OZONE FOR ETA LYRS
1798 !   PRGMMR: KENNETH CAMPANA  ORG: W/NMC23    DATE: 89-07-07
1799 !           MICHAEL BALDWIN  ORG: W/NMC22    DATE: 92-06-08
1800 !
1801 ! ABSTRACT: THIS CODE WRITTEN AT GFDL...
1802 !   CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE,
1803 !   FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4
1804 !   CODE IS CALLED ONLY ONCE.
1805 !
1806 ! PROGRAM HISTORY LOG:
1807 !   84-01-01  FELS AND SCHWARZKOPF,GFDL.
1808 !   89-07-07  K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE.
1809 !   92-06-08  M. BALDWIN - UPDATE TO RUN IN ETA MODEL
1810 !
1811 ! USAGE:    CALL O3INT(O3,SIGL) OLD
1812 !   INPUT ARGUMENT LIST:
1813 !     PHALF    - MID LAYER PRESSURE (K=LM+1 IS MODEL SURFACE)
1814 !   OUTPUT ARGUMENT LIST:
1815 !     DDUO3N   - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4)
1816 !     DDO3N2     DIMENSIONED(L,N),WHERE L(=37) IS LATITUDE BETWEEN
1817 !     DDO3N3     N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR)
1818 !     DDO3N4     AND SEASON-WIN,SPR,SUM,FALL.
1819 !        IN COMMON
1820 !
1821 !   OUTPUT FILES:
1822 !     OUTPUT   - PRINT FILE.
1823 !
1824 ! ATTRIBUTES:
1825 !   LANGUAGE: FORTRAN 200.
1826 !
1827 !$$$
1828 !....     PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3
1829 !..    OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE)
1830 !-----------------------------------------------------------------------
1831 !      INCLUDE "parmeta"
1832 !-----------------------------------------------------------------------
1833 !     *********************************************************
1834
1835       INTEGER :: N,NP,NP2,NM1
1836
1837 !     PARAMETER (N=LM,NP=N+1,NP2=N+2,NM1=N-1)
1838 !     *********************************************************
1839 !-----------------------------------------------------------------------
1840 !***
1841 !***  SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
1842 !***  CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
1843 !***  DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
1844 !***
1845       REAL, INTENT(OUT), DIMENSION(37,kte):: DDUO3N,DDO3N2,DDO3N3,DDO3N4
1846
1847 !                        C O M M O N /SAVMEM/
1848 !       ...WINTER....  ...SPRING....  ...SUMMER....  ....FALL.....
1849 !    1  DDUO3N(37,LM), DDO3N2(37,LM), DDO3N3(37,LM), DDO3N4(37,LM)
1850 !          ..... K.CAMPANA   OCTOBER 1988
1851 !CCC  DIMENSION T41(NP2,2),O3O3(37,N,4)
1852 !     DIMENSION SIGL(N)
1853 !     *********************************************************
1854       REAL ::   QI(82)
1855       REAL ::   DDUO3(19,kts:kte),RO31(10,41),RO32(10,41),DUO3N(19,41)
1856       REAL ::   TEMPN(19)
1857       REAL ::   O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), &
1858                 O3LO4(10,16)
1859       REAL ::   O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33)
1860       REAL ::   O35DEG(37,kts:kte)
1861       REAL ::   RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), &
1862                 PHALF(kts:kte+1),P(81),PH(82)
1863
1864       INTEGER :: NKK,NK,NKP,K,L,NCASE,ITAPE,IPLACE,NKMM,NKM,KI,KK,KQ,JJ,KEN
1865       REAL :: O3RD,O3TOT,O3DU
1866
1867       EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17))
1868       EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46))
1869       EQUIVALENCE (P1(1),P(1)),(P2(1),P(49))
1870       DATA PH1/      0., &
1871            0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
1872            0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
1873            0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
1874            0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
1875            0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
1876            0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
1877            0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
1878            0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
1879            0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
1880            0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
1881            0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
1882       DATA PH2/ &
1883            0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
1884            0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
1885            0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
1886            0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
1887            0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
1888            0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
1889            0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
1890            0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
1891            0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
1892            0.1000000E+01/
1893       DATA P1/ &
1894            0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
1895            0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
1896            0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
1897            0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
1898            0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
1899            0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
1900            0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
1901            0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
1902            0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
1903            0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
1904            0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
1905            0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
1906       DATA P2/ &
1907            0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
1908            0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
1909            0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
1910            0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
1911            0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
1912            0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
1913            0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
1914            0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
1915            0.1000000E+01/
1916       DATA O3HI1/ &
1917        .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
1918        .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
1919        .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
1920        .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
1921        .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
1922        .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
1923        .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
1924        .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
1925        1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
1926        1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
1927        1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
1928        2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
1929        2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
1930        2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
1931        2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
1932        3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
1933       DATA O3HI2/ &
1934        3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
1935        3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
1936        4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
1937        5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
1938        6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
1939        9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
1940        12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
1941        14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
1942        14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
1943       DATA O3LO1/ &
1944        14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
1945        14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
1946        11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
1947        7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
1948        4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
1949        1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
1950        0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
1951        .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
1952        .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
1953        .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
1954        .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
1955        .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
1956        .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
1957        .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
1958        .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
1959        .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
1960       DATA O3LO2/ &
1961        14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
1962        13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
1963        10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
1964        7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
1965        3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
1966        1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
1967        .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
1968        .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
1969        .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
1970        .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
1971        .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
1972        .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
1973        .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
1974        .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
1975        .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
1976        .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
1977       DATA O3LO3/ &
1978        14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
1979        13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
1980        10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
1981        7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
1982        4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
1983        1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
1984        .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
1985        .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
1986        .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
1987        .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
1988        .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
1989        .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
1990        .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
1991        .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
1992        .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
1993        .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
1994       DATA O3LO4/ &
1995        14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
1996        12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
1997        10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
1998        7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
1999        4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
2000        2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
2001        0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
2002        .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
2003        .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
2004        .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
2005        .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
2006        .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
2007        .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
2008        .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
2009        .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
2010        .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
2011
2012 !!!!!
2013 !     PSS=101325.
2014 !     PDIF=PSS-PT
2015 !
2016 !     DO L=1,LM1
2017 !       PHALF(L+1)=AETA(L)*PDIF+PT
2018 !     ENDDO
2019 !
2020 !     PHALF(1)=0.
2021 !     PHALF(LP1)=PSS
2022 !!!!
2023       N=kte;NP=N+1;NP2=N+2;NM1=N-1
2024
2025       NKK=41
2026       NK=81
2027       NKP=NK+1
2028       DO 24 K=1,NP
2029 !  24 PHALF(K)=PHALF(K)*1.0E 03
2030    24 PHALF(K)=PHALF(K)*0.01*1.0E+03
2031 !  24 PSTD(K)=PSTD(K+1)*1.0E 03
2032       DO 25 K=1,NK
2033       PH(K)=PH(K)*1013250.
2034    25 P(K)=P(K)*1013250.
2035       PH(NKP)=PH(NKP)*1013250.
2036 !KAC  WRITE (6,3) PH
2037 !KAC  WRITE (6,3) P
2038 !     WRITE (6,3) (PHALF(K),K=1,NP)
2039 !     WRITE (6,3) (PSTD(K),K=1,NP)
2040 !***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM.
2041       DO 1010 K=1,25
2042       DO 1010 L=1,10
2043         RO31(L,K)=O3HI(L,K)
2044         RO32(L,K)=O3HI(L,K)
2045 1010  CONTINUE
2046 !
2047       DO 3000 NCASE=1,4
2048       ITAPE=NCASE+50
2049       IPLACE=2
2050       IF (NCASE.EQ.2) IPLACE=4
2051       IF (NCASE.EQ.3) IPLACE=1
2052       IF (NCASE.EQ.4) IPLACE=3
2053 !***NCASE=1: SPRING (IN N.H.)
2054 !***NCASE=2: FALL   (IN N.H.)
2055 !***NCASE=3: WINTER (IN N.H.)
2056 !***NCASE=4: SUMMER (IN N.H.)
2057       IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN
2058          DO 1011 K=26,41
2059          DO 1011 L=1,10
2060            RO31(L,K)=O3LO1(L,K-25)
2061            RO32(L,K)=O3LO2(L,K-25)
2062 1011     CONTINUE
2063       ENDIF
2064       IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN
2065          DO 1031 K=26,41
2066          DO 1031 L=1,10
2067            RO31(L,K)=O3LO3(L,K-25)
2068            RO32(L,K)=O3LO4(L,K-25)
2069 1031     CONTINUE
2070       ENDIF
2071       DO 30 KK=1,NKK
2072       DO 31 L=1,10
2073       DUO3N(L,KK)=RO31(11-L,KK)
2074    31 DUO3N(L+9,KK)=RO32(L,KK)
2075       DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK))
2076    30 CONTINUE
2077 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
2078       IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN
2079          DO 1024 KK=1,NKK
2080          DO 1025 L=1,19
2081            TEMPN(L)=DUO3N(20-L,KK)
2082 1025     CONTINUE
2083          DO 1026 L=1,19
2084            DUO3N(L,KK)=TEMPN(L)
2085 1026     CONTINUE
2086 1024     CONTINUE
2087       ENDIF
2088 !***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE
2089 !      LEVELS
2090 !KAC  WRITE (6,800) DUO3N
2091 !***BEGIN LATITUDE (10 DEG) LOOP
2092       DO 33 L=1,19
2093       DO 22 KK=1,NKK
2094    22 RSTD(KK)=DUO3N(L,KK)
2095       NKM=NK-1
2096       NKMM=NK-3
2097 !     BESSELS HALF-POINT INTERPOLATION FORMULA
2098       DO 60 K=4,NKMM,2
2099       KI=K/2
2100    60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ &
2101       RSTD(KI-1))/16.
2102       RDATA(2)=.5*(RSTD(2)+RSTD(1))
2103       RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1))
2104 !     PUT UNCHANGED DATA INTO NEW ARRAY
2105       DO 61 K=1,NK,2
2106       KQ=(K+1)/2
2107    61 RDATA(K)=RSTD(KQ)
2108 !---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT
2109 !     WRITE (6,798) RDATA
2110 !     CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL
2111       DO 99 KK=1,N
2112       RBAR(KK)=0.
2113 !     LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN
2114       DO 98 K=1,NK
2115       IF(PH(K+1).LT.PHALF(KK)) GO TO 98
2116       IF(PH(K).GT.PHALF(KK+1)) GO TO 98
2117       IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2118       )+RDATA(K)*(PH(K+1)-PHALF(KK))
2119       IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(KK &
2120       )+RDATA(K)*(PH(K+1)-PH(K))
2121       IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2122       )+RDATA(K)*(PHALF(KK+1)-PH(K))
2123    98 CONTINUE
2124       RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK))
2125       IF(RBAR(KK).GT..0000) GO TO 99
2126 !     CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE
2127 !     OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND
2128 !     PHALF(KK).   PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM
2129 !     RDATA
2130       DO 29 K=1,NK
2131       IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K)
2132    29 CONTINUE
2133    99 CONTINUE
2134 !     CALCULATE TOTAL OZONE
2135       O3RD=0.
2136       DO 89 KK=1,80
2137    89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK))
2138       O3RD=O3RD+RDATA(81)*(P(81)-PH(81))
2139       O3RD=O3RD/980.
2140       O3TOT=0.
2141       DO 88 KK=1,N
2142    88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK))
2143       O3TOT=O3TOT/980.
2144 !     UNITS ARE MICROGRAMS/CM**2
2145       O3DU=O3TOT/2.144
2146 !     O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM)
2147 !--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT
2148 !     WRITE (6,796) O3RD,O3TOT,O3DU
2149       DO 23 KK=1,N
2150    23 DDUO3(L,KK)=RBAR(KK)*.01
2151    33 CONTINUE
2152 !***END OF LATITUDE LOOP
2153 !
2154 !***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
2155 !      10 DEG VALUES
2156       DO 1060 KK=1,N
2157         DO 1061 L=1,19
2158           O35DEG(2*L-1,KK)=DDUO3(L,KK)
2159 1061    CONTINUE
2160         DO 1062 L=1,18
2161           O35DEG(2*L,KK)=0.5*(DDUO3(L,KK)+DDUO3(L+1,KK))
2162 1062    CONTINUE
2163 1060  CONTINUE
2164 !***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE
2165 !O222  ***************************************************
2166 !C          WRITE (66) O35DEG
2167       IF (IPLACE.EQ.1) THEN
2168       DO 302 JJ=1,37
2169        DO 302 KEN=1,N
2170         DDUO3N(JJ,KEN) = O35DEG(JJ,KEN)
2171   302 CONTINUE
2172       ELSE IF (IPLACE.EQ.2) THEN
2173       DO 312 JJ=1,37
2174        DO 312 KEN=1,N
2175         DDO3N2(JJ,KEN) = O35DEG(JJ,KEN)
2176   312 CONTINUE
2177       ELSE IF (IPLACE.EQ.3) THEN
2178       DO 322 JJ=1,37
2179        DO 322 KEN=1,N
2180         DDO3N3(JJ,KEN) = O35DEG(JJ,KEN)
2181   322 CONTINUE
2182       ELSE IF (IPLACE.EQ.4) THEN
2183       DO 332 JJ=1,37
2184        DO 332 KEN=1,N
2185         DDO3N4(JJ,KEN) = O35DEG(JJ,KEN)
2186   332 CONTINUE
2187       END IF
2188 !O222  ***************************************************
2189 3000  CONTINUE
2190 !***END OF LOOP OVER CASES
2191       RETURN
2192    1  FORMAT(10F4.2)
2193     2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X)
2194    3  FORMAT(10E12.5)
2195   797 FORMAT(10F7.2)
2196   799 FORMAT(19F6.4)
2197   800 FORMAT(19F6.2)
2198   102 FORMAT(' O3 IPLACE=',I4)
2199  1033 FORMAT(19F6.5)
2200   101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, &
2201       1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,)
2202
2203       END SUBROUTINE O3INT
2204 !----------------------------------------------------------------
2205
2206   SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP                  &
2207       ,          ids,ide, jds,jde, kds,kde                      &
2208       ,          ims,ime, jms,jme, kms,kme                      &
2209       ,          its,ite, jts,jte, kts,kte                      )
2210 !----------------------------------------------------------------------
2211  IMPLICIT NONE
2212 !----------------------------------------------------------------------
2213       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
2214                                     ims,ime, jms,jme, kms,kme ,      &
2215                                     its,ite, jts,jte, kts,kte
2216 !----------------------------------------------------------------------
2217
2218 !     ************************************************************
2219 !     *                                                          *
2220 !     * THIS SUBROUTINE WAS MODIFIED TO BE USED IN THE ETA MODEL *
2221 !     *                                                          *
2222 !     *                            Q. ZHAO    95-3-22            *
2223 !     *                                                          *
2224 !     ************************************************************
2225
2226       REAL,    INTENT(OUT),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2227       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2228       INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2229       INTEGER, INTENT(IN), DIMENSION(its:ite)           :: NCLDS
2230
2231       REAL,    DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2232       REAL,    DIMENSION(kts:kte+1) :: CLDROW
2233       INTEGER:: IQ,ITOP,I,J,JTOP,IR,IP,K1,K2,KB,K,KP,KT,NC
2234       REAL   :: XCLD
2235
2236       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE
2237
2238     !  DIMENSION CLDIPT(LP1,LP1, 64 )
2239     !  DIMENSION NCLDS(IDIM1:IDIM2),KTOP(IDIM1:IDIM2,LP1), &
2240     !            KBTM(IDIM1:IDIM2,LP1)
2241     !  DIMENSION CLDROW(LP1)
2242     !  DIMENSION CAMT(IDIM1:IDIM2,LP1),CLDFAC(IDIM1:IDIM2,LP1,LP1)
2243
2244       L=kte
2245       LP1=L+1;  LP2=L+2;  LP3=L+3
2246       LM1=L-1;  LM2=L-2;  LM3=L-3
2247       MYIS=its; MYIE=ite
2248
2249 !
2250       DO 1 IQ=MYIS,MYIE,64
2251       ITOP=IQ+63
2252       IF(ITOP.GT.MYIE) ITOP=MYIE
2253       JTOP=ITOP-IQ+1
2254       DO 11 IP=1,JTOP
2255       IR=IQ+IP-1
2256       IF (NCLDS(IR).EQ.0) THEN
2257         DO 25 J=1,LP1
2258         DO 25 I=1,LP1
2259         CLDIPT(I,J,IP)=1.
2260 25      CONTINUE
2261       ENDIF
2262       IF (NCLDS(IR).GE.1) THEN
2263           XCLD=1.-CAMT(IR,2)
2264            K1=KTOP(IR,2)+1
2265            K2=KBTM(IR,2)
2266           DO 27 J=1,LP1
2267               CLDROW(J)=1.
2268 27        CONTINUE
2269           DO 29 J=1,K2
2270               CLDROW(J)=XCLD
2271 29        CONTINUE
2272           KB=MAX(K1,K2+1)
2273           DO 33 K=KB,LP1
2274           DO 33 KP=1,LP1
2275                CLDIPT(KP,K,IP)=CLDROW(KP)
2276 33        CONTINUE
2277           DO 37 J=1,LP1
2278               CLDROW(J)=1.
2279 37        CONTINUE
2280           DO 39 J=K1,LP1
2281               CLDROW(J)=XCLD
2282 39        CONTINUE
2283           KT=MIN(K1-1,K2)
2284           DO 43 K=1,KT
2285           DO 43 KP=1,LP1
2286               CLDIPT(KP,K,IP)=CLDROW(KP)
2287 43        CONTINUE
2288           IF(K2+1.LE.K1-1) THEN
2289             DO 31 J=K2+1,K1-1
2290             DO 31 I=1,LP1
2291                 CLDIPT(I,J,IP)=1.
2292 31          CONTINUE
2293           ELSE IF(K1.LE.K2) THEN
2294             DO 32 J=K1,K2
2295             DO 32 I=1,LP1
2296                 CLDIPT(I,J,IP)=XCLD
2297 32          CONTINUE
2298           ENDIF
2299       ENDIF
2300
2301       IF (NCLDS(IR).GE.2) THEN
2302         DO 21 NC=2,NCLDS(IR)
2303           XCLD=1.-CAMT(IR,NC+1)
2304            K1=KTOP(IR,NC+1)+1
2305            K2=KBTM(IR,NC+1)
2306           DO 47 J=1,LP1
2307               CLDROW(J)=1.
2308 47        CONTINUE
2309           DO 49 J=1,K2
2310               CLDROW(J)=XCLD
2311 49        CONTINUE
2312           KB=MAX(K1,K2+1)
2313           DO 53 K=KB,LP1
2314           DO 53 KP=1,LP1
2315                CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2316 53        CONTINUE
2317           DO 57 J=1,LP1
2318               CLDROW(J)=1.
2319 57        CONTINUE
2320           DO 59 J=K1,LP1
2321               CLDROW(J)=XCLD
2322 59        CONTINUE
2323           KT=MIN(K1-1,K2)
2324           DO 63 K=1,KT
2325           DO 63 KP=1,LP1
2326               CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2327 63        CONTINUE
2328           IF(K1.LE.K2) THEN
2329             DO 52 J=K1,K2
2330             DO 52 I=1,LP1
2331                 CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD
2332 52          CONTINUE
2333           ENDIF
2334 21        CONTINUE
2335       ENDIF
2336 11    CONTINUE
2337       DO 71 J=1,LP1
2338       DO 71 I=1,LP1
2339       DO 71 IP=1,JTOP
2340       IR=IQ+IP-1
2341       CLDFAC(IR,I,J)=CLDIPT(I,J,IP)
2342 71    CONTINUE
2343 1     CONTINUE
2344
2345   END SUBROUTINE CLO89
2346 !----------------------------------------------------------------
2347 !     SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX,                         &
2348 !                      PRESS,TEMP,RH2O,QO3,CLDFAC,                   &
2349 !                      CAMT,NCLDS,KTOP,KBTM,                         &
2350 !!                     BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V,       &
2351 !                      BO3RND,AO3RND, &
2352 !                      APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
2353 !                      ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
2354 !                      GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
2355 !                      P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
2356 !                      TEN,HP1,FOUR,HM1EZ,SKO3R,                     &
2357 !                      AB15WD,SKC1R,RADCON,QUARTR,TWO,               &
2358 !                      HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
2359 !                      RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
2360 !                      ids,ide, jds,jde, kds,kde,                    &
2361 !                      ims,ime, jms,jme, kms,kme,                    &
2362 !                      its,ite, jts,jte, kts,kte                     )
2363
2364       SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX,                         &
2365                        PRESS,TEMP,RH2O,QO3,CLDFAC,                   &
2366                        CAMT,NCLDS,KTOP,KBTM,                         &
2367 !                      BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V,       &
2368                        BO3RND,AO3RND, &
2369                        APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
2370                        ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
2371                        GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
2372                        P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
2373                        TEN,HP1,FOUR,HM1EZ,                           &
2374                        RADCON,QUARTR,TWO,                            &
2375                        HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
2376                        RADCON1,H16E1, H28E1,H44194M2,H1P41819,       &
2377                        ids,ide, jds,jde, kds,kde,                    &
2378                        ims,ime, jms,jme, kms,kme,                    &
2379                        its,ite, jts,jte, kts,kte                     )
2380 !---------------------------------------------------------------------
2381  IMPLICIT NONE
2382 !----------------------------------------------------------------------
2383 !     INTEGER, PARAMETER :: NBLY=15
2384
2385       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
2386                                     ims,ime, jms,jme, kms,kme ,      &
2387                                     its,ite, jts,jte, kts,kte
2388       REAL,    INTENT(IN)        :: ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR
2389       REAL,    INTENT(IN)        :: GINV,H3M4,BETINW,RATH2OMW,GP0INV
2390       REAL,    INTENT(IN)        :: P0XZP8,P0XZP2,H3M3,P0,H1M3
2391       REAL,    INTENT(IN)        :: H1M2,H25E2,B0,B1,B2,B3,HAF
2392 !     REAL,    INTENT(IN)        :: TEN,HP1,FOUR,HM1EZ,SKO3R
2393       REAL,    INTENT(IN)        :: TEN,HP1,FOUR,HM1EZ
2394 !     REAL,    INTENT(IN)        :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2395       REAL,    INTENT(IN)        :: RADCON,QUARTR,TWO
2396       REAL,    INTENT(IN)        :: HM6666M2,HMP66667,HMP5, HP166666,H41666M2
2397 !     REAL,    INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D
2398       REAL,    INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819
2399 !----------------------------------------------------------------------
2400       REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2401 !     REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
2402 !     REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2403       REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2404                                          BCOMB,BETACM
2405
2406       REAL,    INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2407       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2408       INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2409       INTEGER, INTENT(IN), DIMENSION(its:ite)           :: NCLDS
2410
2411       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2412       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte)   :: RH2O,QO3
2413       REAL,    INTENT(OUT), DIMENSION(its:ite,kts:kte)   :: HEATRA
2414       REAL,    INTENT(OUT), DIMENSION(its:ite)           :: GRNFLX,TOPFLX
2415
2416 !     REAL,    DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2417
2418 !     Include co2 data from a file, which needs to have exactly vertical
2419 !     dimension of the model.
2420
2421
2422 !!! ??? co2 table
2423 !     REAL,    DIMENSION(kts:kte+1,kts:kte+1) :: CO251,CDT51,CDT58,C2D51,&
2424 !                                                C2D58,CO258
2425 !     REAL,    DIMENSION(kts:kte+1)           :: STEMP,GTEMP,CO231,CO238, &
2426 !                                                C2D31,C2D38,CDT31,CDT38, &
2427 !                                                CO271,CO278,C2D71,C2D78, &
2428 !                                                CDT71,CDT78
2429 !     REAL,    DIMENSION(kts:kte)             :: CO2M51,CO2M58,CDTM51,CDTM58, &
2430 !                                                C2DM51,C2DM58
2431 !!! end co2 table
2432
2433 !     REAL,    DIMENSION(kts:kte+1) :: CLDROW
2434
2435       REAL,    DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,&
2436                                                TPHIO3,TOTVO2,TSTDAV,TDAV, &
2437                                                VSUM3,CO2R1,D2CD21,DCO2D1, &
2438                                                CO2R2,D2CD22,DCO2D2,CO2SP1,&
2439                                                CO2SP2,CO2R,DCO2DT,D2CDT2, &
2440                                                TLSQU,DIFT
2441       REAL,    DIMENSION(its:ite,kts:kte)   :: DELP2,DELP,CO2NBL,&
2442                                                QH2O,VV,VAR1,VAR2,VAR3,VAR4
2443       REAL,    DIMENSION(its:ite,kts:kte+1) :: P,T
2444       REAL,    DIMENSION(its:ite,kts:kte)   :: CO2MR,CO2MD,CO2M2D
2445       REAL,    DIMENSION(its:ite,kts:kte*2+1):: EMPL
2446
2447       REAL,    DIMENSION(its:ite)           :: EMX1,EMX2,VSUM1,VSUM2,A1,A2
2448       REAL,    DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2449
2450    !  COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1),
2451    !  DIMENSION CO21(IDIM1:IDIM2,LP1,LP1),CO2NBL(IDIM1:IDIM2,L)
2452    !  DIMENSION CO2R(IDIM1:IDIM2,LP1),DIFT(IDIM1:IDIM2,LP1)
2453    ! 1   CO2M2D(IDIM1:IDIM2,L)
2454    !  DIMENSION CO2MR(IDIM1:IDIM2,L),CO2MD(IDIM1:IDIM2,L),
2455    ! 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L),
2456    ! 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L),
2457    !  COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1),
2458    ! 1 CDT38(LP1),C2D31(LP1),C2D38(LP1)
2459    !  DIMENSION CO2R1(IDIM1:IDIM2,LP1),DCO2D1(IDIM1:IDIM2,LP1)
2460    !  DIMENSION D2CD21(IDIM1:IDIM2,LP1),D2CD22(IDIM1:IDIM2,LP1)
2461    ! 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3
2462    ! 1 VV(IDIM1:IDIM2,L),VSUM3(IDIM1:IDIM2,LP1),VSUM1(IDIM1:IDIM2),
2463    ! 2 VSUM2(IDIM1:IDIM2)
2464    !  DIMENSION TDAV(IDIM1:IDIM2,LP1),TSTDAV(IDIM1:IDIM2,LP1),
2465    !  LLP1=LL+1, LL = 2L
2466    !  EMX2(IDIM1:IDIM2),EMPL(IDIM1:IDIM2,LLP1)
2467    !  DIMENSION TPHIO3(IDIM1:IDIM2,LP1),
2468    !  DIMENSION TEXPSL(IDIM1:IDIM2,LP1)
2469    !  DIMENSION QH2O(IDIM1:IDIM2,L)
2470    !  DIMENSION DELP2(IDIM1:IDIM2,L)
2471    !  DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L),
2472    ! 1   VAR3(IDIM1:IDIM2,L),VAR4(IDIM1:IDIM2,L)
2473    ! 1 VV(IDIM1:IDIM2,L)
2474    !  DIMENSION CNTVAL(IDIM1:IDIM2,LP1)
2475    !  DIMENSION TOTO3(IDIM1:IDIM2,LP1)
2476    !  DIMENSION EMX1(IDIM1:IDIM2),
2477
2478    !  DIMENSION PRESS(IDIM1:IDIM2,LP1),TEMP(IDIM1:IDIM2,LP1), &
2479    !     RH2O(IDIM1:IDIM2,L),QO3(IDIM1:IDIM2,L)
2480    !  DIMENSION HEATRA(IDIM1:IDIM2,L),GRNFLX(IDIM1:IDIM2),    &
2481    !     TOPFLX(IDIM1:IDIM2)
2482
2483 !
2484 !
2485 !****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP)
2486 !****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE
2487 !    CORRECTIONS (TEXPSL)
2488
2489       INTEGER :: K, I,KP
2490       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
2491
2492       L=kte
2493       LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
2494       LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
2495       MYIS=its; MYIE=ite
2496
2497
2498       DO 103 K=2,L
2499       DO 103 I=MYIS,MYIE
2500       P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K))
2501       T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K))
2502 103   CONTINUE
2503       DO 105 I=MYIS,MYIE
2504       P(I,1)=ZERO
2505       P(I,LP1)=PRESS(I,LP1)
2506       T(I,1)=TEMP(I,1)
2507       T(I,LP1)=TEMP(I,LP1)
2508 105   CONTINUE
2509       DO 107 K=1,L
2510       DO 107 I=MYIS,MYIE
2511       DELP2(I,K)=P(I,K+1)-P(I,K)
2512       DELP(I,K)=ONE/DELP2(I,K)
2513 107   CONTINUE
2514 !****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF.
2515 !    (THIS IS 1800.(1./TEMP-1./296.))
2516       DO 125 K=1,LP1
2517       DO 125 I=MYIS,MYIE
2518       TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108
2519 !...THEN TAKE EXPONENTIAL
2520       TEXPSL(I,K)=EXP(TEXPSL(I,K))
2521 125   CONTINUE
2522 !***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY
2523 !   APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE
2524 !   UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4).
2525 !   THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND
2526 !   VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND
2527 !   O3,RESPECTIVELY.
2528 !
2529       DO 131 K=1,L
2530       DO 131 I=MYIS,MYIE
2531       QH2O(I,K)=RH2O(I,K)*DIFFCTR
2532 !---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS
2533 !   THE LEVEL PRESSURE (PRESS)
2534       VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV
2535       VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV
2536       VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV
2537       VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4)
2538       VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3)
2539 !  COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS.
2540 !  (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR
2541 !  (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE
2542 !  USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT
2543 !  SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF
2544 !  AN ANGULAR INTEGRATION IS SEVERE.
2545 !
2546       CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ &
2547                    (RH2O(I,K)+RATH2OMW)
2548 131   CONTINUE
2549 !   COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM
2550       DO 201 I=MYIS,MYIE
2551       TOTPHI(I,1)=ZERO
2552       TOTO3(I,1)=ZERO
2553       TPHIO3(I,1)=ZERO
2554       TOTVO2(I,1)=ZERO
2555 201   CONTINUE
2556       DO 203 K=2,LP1
2557       DO 203 I=MYIS,MYIE
2558       TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1)
2559       TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1)
2560       TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1)
2561       TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1)
2562 203   CONTINUE
2563 !---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2564 !   P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS.
2565 !---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2566 !   P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1.
2567 !
2568       DO 801 I=MYIS,MYIE
2569       EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV
2570       EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV
2571 801   CONTINUE
2572 !---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1)
2573 !   OR TO PRESS(K+1) (INDEX LP2-LL)
2574       DO 811 K=1,L
2575       DO 811 I=MYIS,MYIE
2576       EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV
2577 811   CONTINUE
2578       DO 812 K=1,LM1
2579       DO 812 I=MYIS,MYIE
2580       EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) &
2581                      *GP0INV
2582 812   CONTINUE
2583       DO 821 I=MYIS,MYIE
2584       EMPL(I,1)=VAR2(I,L)
2585       EMPL(I,LLP1)=EMPL(I,LL)
2586 821   CONTINUE
2587 !***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS
2588 !   FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD.
2589 !   TEMP. SOUNDING (DIFT)
2590       DO 161 I=MYIS,MYIE
2591       TSTDAV(I,1)=ZERO
2592       TDAV(I,1)=ZERO
2593 161   CONTINUE
2594       DO 162 K=1,LP1
2595       DO 162 I=MYIS,MYIE
2596       VSUM3(I,K)=TEMP(I,K)-STEMP(K)
2597 162   CONTINUE
2598       DO 163 K=1,L
2599       DO 165 I=MYIS,MYIE
2600       VSUM2(I)=GTEMP(K)*DELP2(I,K)
2601       VSUM1(I)=VSUM2(I)*VSUM3(I,K)
2602       TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I)
2603       TDAV(I,K+1)=TDAV(I,K)+VSUM1(I)
2604 165   CONTINUE
2605 163   CONTINUE
2606 !
2607 !****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2)
2608       DO 171 I=MYIS,MYIE
2609       A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2
2610       A2(I)=(P0-PRESS(I,LP1))/P0XZP2
2611 171   CONTINUE
2612 !***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION
2613 !   FUNCTIONS AND TEMP. DERIVATIVES
2614 !---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE
2615 !   STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME)
2616       DO 184 K=1,LP1
2617       DO 184 I=MYIS,MYIE
2618         CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K)
2619         D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K))
2620         DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K))
2621         CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K)
2622         D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K))
2623         DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K))
2624 184   CONTINUE
2625       DO 190 K=1,L
2626       DO 190 I=MYIS,MYIE
2627         CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K)
2628         CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K))
2629         CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K))
2630 190   CONTINUE
2631 !***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT
2632 !
2633 !   THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING
2634 !   3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS
2635 !   CALCULATION IS FOR (I,KP,1)
2636       DO 211 KP=2,LP1
2637       DO 211 I=MYIS,MYIE
2638       DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP)
2639 211   CONTINUE
2640       DO 212 I=MYIS,MYIE
2641       CO21(I,1,1)=1.0
2642       CO2SP1(I,1)=1.0
2643       CO2SP2(I,1)=1.0
2644 212   CONTINUE
2645       DO 215 KP=2,LP1
2646       DO 215 I=MYIS,MYIE
2647 !---CALCULATIONS FOR KP>1 FOR K=1
2648       CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1)
2649       DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1))
2650       D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1))
2651       CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2652                    HAF*DIFT(I,KP)*D2CDT2(I,KP))
2653 !---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE
2654 !   SAME VALUE OF DIFT DUE TO SYMMETRY
2655       CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP)
2656       DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP))
2657       D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP))
2658       CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2659                    HAF*DIFT(I,KP)*D2CDT2(I,KP))
2660 215   CONTINUE
2661 !   THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW.
2662 !---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS
2663 !    INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1))
2664       DO 250 K=2,LP1
2665       DO 250 I=MYIS,MYIE
2666       CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* &
2667        D2CD21(I,K))
2668       CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* &
2669        D2CD22(I,K))
2670 250   CONTINUE
2671 !
2672 !   NEXT THE CASE WHEN K=2...L
2673       DO 220 K=2,L
2674       DO 222 KP=K+1,LP1
2675       DO 222 I=MYIS,MYIE
2676       DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ &
2677                     (TSTDAV(I,KP)-TSTDAV(I,K))
2678       CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
2679       DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K))
2680       D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K))
2681       CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2682                    HAF*DIFT(I,KP)*D2CDT2(I,KP))
2683       CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP)
2684       DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP))
2685       D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP))
2686       CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2687                    HAF*DIFT(I,KP)*D2CDT2(I,KP))
2688 222   CONTINUE
2689 220   CONTINUE
2690 !   FINALLY THE CASE WHEN K=KP,K=2..LP1
2691       DO 206 K=2,LP1
2692       DO 206 I=MYIS,MYIE
2693       DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1))
2694       CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K)
2695       DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K))
2696       D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K))
2697       CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ &
2698                    HAF*DIFT(I,K)*D2CDT2(I,K))
2699 206   CONTINUE
2700 !--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS .
2701       DO 260 K=1,L
2702       DO 260 I=MYIS,MYIE
2703       CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* &
2704        VSUM3(I,K)*CO2M2D(I,K))
2705 260   CONTINUE
2706 !***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2)
2707       DO 264 K=1,LP1
2708       DO 264 I=MYIS,MYIE
2709       IF (T(I,K).LE.H25E2) THEN
2710          TLSQU(I,K)=B0+(T(I,K)-H25E2)* &
2711                             (B1+(T(I,K)-H25E2)* &
2712                          (B2+B3*(T(I,K)-H25E2)))
2713       ELSE
2714          TLSQU(I,K)=B0
2715       ENDIF
2716 264   CONTINUE
2717 !***APPLY TO ALL CO2 TFS
2718       DO 280 K=1,LP1
2719       DO 282 KP=1,LP1
2720       DO 282 I=MYIS,MYIE
2721       CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP)
2722 282   CONTINUE
2723 280   CONTINUE
2724       DO 284 K=1,LP1
2725       DO 286 I=MYIS,MYIE
2726       CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2727       CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2728 286   CONTINUE
2729 284   CONTINUE
2730       DO 288 K=1,L
2731       DO 290 I=MYIS,MYIE
2732       CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K)
2733 290   CONTINUE
2734 288   CONTINUE
2735 !     CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2736 !                QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2737 !                CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2738 !                CO21,CO2NBL,CO2SP1,CO2SP2, &
2739 !                VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2740 !                TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2741 !                EMX1,EMX2,EMPL, &
2742 !
2743 !                BO3RND,AO3RND, &
2744 !!               T1,T2,T4 , EM1V,EM1VW, EM3V, &
2745 !                APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
2746 !                TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2747 !                AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2748 !                HM6666M2,HMP66667,HMP5, &
2749 !                HP166666,H41666M2,RADCON1, &
2750 !                H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2751 !                SKO2D,                                        &
2752 !                ids,ide, jds,jde, kds,kde,                    &
2753 !                ims,ime, jms,jme, kms,kme,                    &
2754 !                its,ite, jts,jte, kts,kte                     )
2755
2756       CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2757                  QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2758                  CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2759                  CO21,CO2NBL,CO2SP1,CO2SP2, &
2760                  VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2761                  TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2762                  EMX1,EMX2,EMPL, &
2763 !
2764                  BO3RND,AO3RND, &
2765 !                T1,T2,T4 , EM1V,EM1VW, EM3V, &
2766                  APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
2767                  TEN,HP1,HAF,ONE,FOUR,HM1EZ,       &
2768                  RADCON,QUARTR,TWO,  &
2769                  HM6666M2,HMP66667,HMP5, &
2770                  HP166666,H41666M2,RADCON1, &
2771                  H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2772                  ids,ide, jds,jde, kds,kde,                    &
2773                  ims,ime, jms,jme, kms,kme,                    &
2774                  its,ite, jts,jte, kts,kte                     )
2775
2776   END SUBROUTINE LWR88
2777 !---------------------------------------------------------------------
2778 ! SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2779 !                      QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2780 !                      CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2781 !                      CO21,CO2NBL,CO2SP1,CO2SP2, &
2782 !                      VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2783 !                      TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2784 !                      EMX1,EMX2,EMPL, &
2785 !                      BO3RND,AO3RND, &
2786 !!                     T1,T2,T4 , EM1V,EM1VW, EM3V, &
2787 !                      APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
2788 !                      TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2789 !                      AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2790 !                      HM6666M2,HMP66667,HMP5, &
2791 !                      HP166666,H41666M2,RADCON1, &
2792 !                      H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2793 !                      SKO2D,                                        &
2794 !                      ids,ide, jds,jde, kds,kde,                    &
2795 !                      ims,ime, jms,jme, kms,kme,                    &
2796 !                      its,ite, jts,jte, kts,kte                     )
2797
2798   SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2799                        QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2800                        CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2801                        CO21,CO2NBL,CO2SP1,CO2SP2, &
2802                        VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2803                        TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2804                        EMX1,EMX2,EMPL, &
2805                        BO3RND,AO3RND, &
2806 !                      T1,T2,T4 , EM1V,EM1VW, EM3V, &
2807                        APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
2808                        TEN,HP1,HAF,ONE,FOUR,HM1EZ,       &
2809                        RADCON,QUARTR,TWO, &
2810                        HM6666M2,HMP66667,HMP5, &
2811                        HP166666,H41666M2,RADCON1, &
2812                        H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2813                        ids,ide, jds,jde, kds,kde,                    &
2814                        ims,ime, jms,jme, kms,kme,                    &
2815                        its,ite, jts,jte, kts,kte                     )
2816 !---------------------------------------------------------------------
2817  IMPLICIT NONE
2818 !----------------------------------------------------------------------
2819 !     INTEGER, PARAMETER :: NBLY=15
2820
2821       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
2822                                     ims,ime, jms,jme, kms,kme ,      &
2823                                     its,ite, jts,jte, kts,kte
2824
2825 !     REAL,    INTENT(IN)        :: TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R
2826       REAL,    INTENT(IN)        :: TEN,HP1,HAF,ONE,FOUR,HM1EZ
2827 !     REAL,    INTENT(IN)        :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2828       REAL,    INTENT(IN)        :: RADCON,QUARTR,TWO
2829       REAL,    INTENT(IN)        :: HM6666M2,HMP66667,HMP5
2830       REAL,    INTENT(IN)        :: HP166666,H41666M2,RADCON1,H16E1, H28E1
2831 !     REAL,    INTENT(IN)        :: H25E2,H44194M2,H1P41819,SKO2D
2832       REAL,    INTENT(IN)        :: H25E2,H44194M2,H1P41819
2833
2834       REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2835                                          BCOMB,BETACM
2836
2837 !     REAL, INTENT(IN), DIMENSION(5040) :: T1,T2,T4,EM1V,EM1VW
2838 !     REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2839       REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: EMPL
2840       REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TOTO3,TPHIO3,TOTPHI,CNTVAL,&
2841                                                         CO2SP1,CO2SP2
2842
2843       REAL,    INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2844       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT,TOTVO2
2845       INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2846       INTEGER, INTENT(IN), DIMENSION(its:ite)           :: NCLDS
2847       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte)   :: QH2O
2848       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2849       REAL,    INTENT(OUT), DIMENSION(its:ite,kts:kte)  :: HEATRA
2850       REAL,    INTENT(OUT), DIMENSION(its:ite)          :: GRNFLX,TOPFLX
2851       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: P,T
2852       REAL,    INTENT(INOUT), DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2853       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte)   :: CO2NBL,DELP2, &
2854                                                            DELP,&
2855                                                VAR1,VAR2,VAR3,VAR4
2856       REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2857       REAL, INTENT(IN), DIMENSION(its:ite)   :: EMX1,EMX2
2858
2859       REAL, DIMENSION(its:ite,kts:kte*2+1) :: TPL,EMD,ALP,C,CSUB,CSUB2
2860       REAL, DIMENSION(its:ite,kts:kte*2+1) :: C2
2861       INTEGER, DIMENSION(its:ite,kts:kte+1) :: IXO
2862       REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, &
2863                                             SS1,CSOUR,TC,OSS,CSS,DTC,SS2,&
2864                                             AVEPHI,E1CTS1,E1FLX,  &
2865                                             E1CTW1,DSORC,EMISS,FAC1,&
2866                                             TO3SP,OVER1D,CNTTAU,TOTEVV,&
2867                                             CO2SP,FLX,AVMO3, &
2868                                             AVPHO3,AVVO2,CONT1D,TO31D,EMISDG,&
2869                                             DELPR1
2870       REAL, DIMENSION(its:ite,kts:kte+1) :: EMISSB,DELPR2,CONTDG,TO3DG,HEATEM,&
2871                                             VSUM1,FLXNET,Z1
2872
2873       REAL, DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
2874       REAL, DIMENSION(its:ite,kts:kte)   :: E1CTS2,E1CTW2,TO3SPC,RLOG,EXCTS,&
2875                                             CTSO3,CTS
2876       REAL, DIMENSION(its:ite)   :: GXCTS,FLX1E1
2877       REAL, DIMENSION(its:ite)   :: PTOP,PBOT,FTOP,FBOT,DELPTC
2878       REAL, DIMENSION(its:ite,2) :: FXOSP,DTSP,EMSPEC
2879 !     REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE
2880       INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
2881       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
2882
2883       L=kte
2884       LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
2885       LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
2886       LLM2 = LL-2; LLM1=LL-1
2887       MYIS=its; MYIE=ite
2888
2889 !
2890       DO 101 K=1,LP1
2891       DO 101 I=MYIS,MYIE
2892 !---TEMP. INDICES FOR E1,SOURCE
2893       VTMP3(I,K)=AINT(TEMP(I,K)*HP1)
2894       FXO(I,K)=VTMP3(I,K)-9.
2895       DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K)
2896 !---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY)
2897       IXO(I,K)=FXO(I,K)
2898 101   CONTINUE
2899       DO 103 k=1,L
2900       DO 103 I=MYIS,MYIE
2901 !---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS)
2902       VTMP3(I,K)=AINT(T(I,K+1)*HP1)
2903       FXOE2(I,K)=VTMP3(I,K)-9.
2904       DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K)
2905 103   CONTINUE
2906 !---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS.
2907       DO 105 I=MYIS,MYIE
2908       FXOE2(I,LP1)=FXO(I,L)
2909       DTE2(I,LP1)=DT(I,L)
2910       FXOSP(I,1)=FXOE2(I,LM1)
2911       FXOSP(I,2)=FXO(I,LM1)
2912       DTSP(I,1)=DTE2(I,LM1)
2913       DTSP(I,2)=DT(I,LM1)
2914 105   CONTINUE
2915 !
2916 !---SOURCE FUNCTION FOR COMBINED BAND 1
2917       DO 4114 I=MYIS,MYIE
2918       DO 4114 K=1,LP1
2919         VTMP3(I,K)=SOURCE(IXO(I,K),1)
2920         DSORC(I,K)=DSRCE(IXO(I,K),1)
2921 4114   CONTINUE
2922       DO 4112 K=1,LP1
2923       DO 4112 I=MYIS,MYIE
2924       SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2925 4112   CONTINUE
2926 !---SOURCE FUNCTION FOR COMBINED BAND 2
2927       DO 4214 I=MYIS,MYIE
2928       DO 4214 K=1,LP1
2929         VTMP3(I,K)=SOURCE(IXO(I,K),2)
2930         DSORC(I,K)=DSRCE(IXO(I,K),2)
2931 4214   CONTINUE
2932       DO 4212 K=1,LP1
2933       DO 4212 I=MYIS,MYIE
2934       SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2935 4212   CONTINUE
2936 !---SOURCE FUNCTION FOR COMBINED BAND 3
2937       DO 4314 I=MYIS,MYIE
2938       DO 4314 K=1,LP1
2939         VTMP3(I,K)=SOURCE(IXO(I,K),3)
2940         DSORC(I,K)=DSRCE(IXO(I,K),3)
2941 4314   CONTINUE
2942       DO 4312 K=1,LP1
2943       DO 4312 I=MYIS,MYIE
2944       SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2945 4312   CONTINUE
2946 !---SOURCE FUNCTION FOR COMBINED BAND 4
2947       DO 4414 I=MYIS,MYIE
2948       DO 4414 K=1,LP1
2949         VTMP3(I,K)=SOURCE(IXO(I,K),4)
2950         DSORC(I,K)=DSRCE(IXO(I,K),4)
2951 4414   CONTINUE
2952       DO 4412 K=1,LP1
2953       DO 4412 I=MYIS,MYIE
2954       SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2955 4412   CONTINUE
2956 !---SOURCE FUNCTION FOR COMBINED BAND 5
2957       DO 4514 I=MYIS,MYIE
2958       DO 4514 K=1,LP1
2959         VTMP3(I,K)=SOURCE(IXO(I,K),5)
2960         DSORC(I,K)=DSRCE(IXO(I,K),5)
2961 4514   CONTINUE
2962       DO 4512 K=1,LP1
2963       DO 4512 I=MYIS,MYIE
2964       SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2965 4512   CONTINUE
2966 !---SOURCE FUNCTION FOR COMBINED BAND 6
2967       DO 4614 I=MYIS,MYIE
2968       DO 4614 K=1,LP1
2969         VTMP3(I,K)=SOURCE(IXO(I,K),6)
2970         DSORC(I,K)=DSRCE(IXO(I,K),6)
2971 4614   CONTINUE
2972       DO 4612 K=1,LP1
2973       DO 4612 I=MYIS,MYIE
2974       SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2975 4612   CONTINUE
2976 !---SOURCE FUNCTION FOR COMBINED BAND 7
2977       DO 4714 I=MYIS,MYIE
2978       DO 4714 K=1,LP1
2979         VTMP3(I,K)=SOURCE(IXO(I,K),7)
2980         DSORC(I,K)=DSRCE(IXO(I,K),7)
2981 4714   CONTINUE
2982       DO 4712 K=1,LP1
2983       DO 4712 I=MYIS,MYIE
2984       SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2985 4712   CONTINUE
2986 !---SOURCE FUNCTION FOR COMBINED BAND 8
2987       DO 4814 I=MYIS,MYIE
2988       DO 4814 K=1,LP1
2989         VTMP3(I,K)=SOURCE(IXO(I,K),8)
2990         DSORC(I,K)=DSRCE(IXO(I,K),8)
2991 4814   CONTINUE
2992       DO 4812 K=1,LP1
2993       DO 4812 I=MYIS,MYIE
2994       SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2995 4812   CONTINUE
2996 !---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1)
2997       DO 4914 I=MYIS,MYIE
2998       DO 4914 K=1,LP1
2999         VTMP3(I,K)=SOURCE(IXO(I,K),9)
3000         DSORC(I,K)=DSRCE(IXO(I,K),9)
3001 4914   CONTINUE
3002       DO 4912 K=1,LP1
3003       DO 4912 I=MYIS,MYIE
3004       SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3005 4912   CONTINUE
3006 !---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1)
3007       DO 5014 I=MYIS,MYIE
3008       DO 5014 K=1,LP1
3009         VTMP3(I,K)=SOURCE(IXO(I,K),10)
3010         DSORC(I,K)=DSRCE(IXO(I,K),10)
3011 5014  CONTINUE
3012       DO 5012 K=1,LP1
3013       DO 5012 I=MYIS,MYIE
3014       SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3015 5012   CONTINUE
3016 !---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1)
3017       DO 5114 I=MYIS,MYIE
3018       DO 5114 K=1,LP1
3019         VTMP3(I,K)=SOURCE(IXO(I,K),11)
3020         DSORC(I,K)=DSRCE(IXO(I,K),11)
3021 5114   CONTINUE
3022       DO 5112 K=1,LP1
3023       DO 5112 I=MYIS,MYIE
3024       SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3025 5112   CONTINUE
3026 !---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1)
3027       DO 5214 I=MYIS,MYIE
3028       DO 5214 K=1,LP1
3029         VTMP3(I,K)=SOURCE(IXO(I,K),12)
3030         DSORC(I,K)=DSRCE(IXO(I,K),12)
3031 5214   CONTINUE
3032       DO 5212 K=1,LP1
3033       DO 5212 I=MYIS,MYIE
3034       SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3035 5212   CONTINUE
3036 !---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1)
3037       DO 5314 I=MYIS,MYIE
3038       DO 5314 K=1,LP1
3039         VTMP3(I,K)=SOURCE(IXO(I,K),13)
3040         DSORC(I,K)=DSRCE(IXO(I,K),13)
3041 5314   CONTINUE
3042       DO 5312 K=1,LP1
3043       DO 5312 I=MYIS,MYIE
3044       SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3045 5312   CONTINUE
3046 !---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1)
3047       DO 5414 I=MYIS,MYIE
3048       DO 5414 K=1,LP1
3049         VTMP3(I,K)=SOURCE(IXO(I,K),14)
3050         DSORC(I,K)=DSRCE(IXO(I,K),14)
3051 5414   CONTINUE
3052       DO 5412 K=1,LP1
3053       DO 5412 I=MYIS,MYIE
3054       SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3055 5412   CONTINUE
3056 !
3057 !        THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2
3058 !
3059 !
3060 !     CALL NLTE
3061 !
3062 !
3063 !---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR)
3064 !   AND THE WINDOW REGION (SS1)
3065       DO 131 K=1,LP1
3066       DO 131 I=MYIS,MYIE
3067       SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14)
3068 131   CONTINUE
3069       DO 143 K=1,LP1
3070       DO 143 I=MYIS,MYIE
3071       CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10)
3072 143   CONTINUE
3073 !
3074 !---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES
3075 !   (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA-
3076 !   TIONS.
3077 !
3078       DO 901 K=1,LP1
3079       DO 901 I=MYIS,MYIE
3080       TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K)
3081 901   CONTINUE
3082       DO 903 K=1,L
3083       DO 903 I=MYIS,MYIE
3084       OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13)
3085       CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K)
3086       DTC(I,K+1)=TC(I,K+1)-TC(I,K)
3087       SS2(I,K+1)=SS1(I,K+1)-SS1(I,K)
3088 903   CONTINUE
3089 !
3090 !
3091 !---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO
3092 !    (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS
3093 !    ON THE FOLLOWING PRINCIPLES:
3094 !
3095 !          LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL
3096 !          THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K))
3097 !               OVER ALL KP'S, FROM 1 TO LP1.
3098 !
3099 !          WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS:
3100 !
3101 !          FOR ALL K'S K=1 TO LP1:
3102 !              FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K))  (1)
3103 !                      OVER ALL KP'S, FROM K+1 TO LP1
3104 !          AND
3105 !              FOR KP FROM K+1 TO LP1:
3106 !                 FLUX(KP) = DELTAB(K)*TAU(K,KP)              (2)
3107 !
3108 !          NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS)
3109 !          WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM
3110 !          K+1 TO LP1, EACH TIME K IS INCREMENTED.
3111 !          EQUATIONS (1) AND (2) THEN BECOME:
3112 !
3113 !             TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K)
3114 !             FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP))   (3)
3115 !             FLUX(KP) = DELTAB(K)*TAU1D(KP)                   (4)
3116 !
3117 !         THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR
3118 !         NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND
3119 !         WITH CARE.
3120 !
3121 !      COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR
3122 !      THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO,
3123 !      THE
3124 !      STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI
3125 !---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY
3126 !   AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY
3127 !   MAY BE EXTRACTED HERE.
3128       DO 3021 K=1,L
3129       DO 3021 I=MYIS,MYIE
3130       AVEPHI(I,K)=TOTPHI(I,K+1)
3131 3021  CONTINUE
3132 !---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1)
3133 !   LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES
3134 !   A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE
3135 !   (OTHERWISE VACANT) LP1'TH POSITION
3136 !
3137       DO 803 I=MYIS,MYIE
3138       AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3139 803   CONTINUE
3140 !   COMPUTE FLUXES FOR K=1
3141       CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, &
3142                   FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T,         &
3143 !                 T1,T2,T4 ,EM1V,EM1VW,                    &
3144                   H16E1,TEN,HP1,H28E1,HAF,                 &
3145                   ids,ide, jds,jde, kds,kde,               &
3146                   ims,ime, jms,jme, kms,kme,               &
3147                   its,ite, jts,jte, kts,kte                )
3148
3149       DO 302 K=1,L
3150       DO 302 I=MYIS,MYIE
3151       FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1)
3152       TO3SPC(I,K)=HAF*(FAC1(I,K)* &
3153           (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE))
3154 !   FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS
3155 !   CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY.
3156       TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1)))
3157       OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ &
3158                   SKC1R*TOTVO2(I,K+1)))
3159 !---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE
3160 !  2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH
3161 !  OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU
3162       CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1))
3163       TOTEVV(I,K)=1./CNTTAU(I,K)
3164 302   CONTINUE
3165       DO 3022 K=1,L
3166       DO 3022 I=MYIS,MYIE
3167       CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1)
3168 3022  CONTINUE
3169       DO 3023 K=1,L
3170       DO 3023 I=MYIS,MYIE
3171       CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K)
3172 3023  CONTINUE
3173 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3174       DO 1808 I=MYIS,MYIE
3175       RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1)
3176 1808  CONTINUE
3177 !---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH
3178 !   THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN
3179 !   THE OTHER CALCULATIONS
3180       DO 305 K=2,LP1
3181       DO 305 I=MYIS,MYIE
3182       FLX(I,K)= (TC(I,1)*E1FLX(I,K) &
3183                 +SS1(I,1)*CNTTAU(I,K-1) &
3184                 +SORC(I,1,13)*TO3SP(I,K-1) &
3185                 +CSOUR(I,1)*CO2SP(I,K)) &
3186                 *CLDFAC(I,1,K)
3187 305   CONTINUE
3188       DO 307 I=MYIS,MYIE
3189       FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) &
3190                 +CSOUR(I,1)
3191 307   CONTINUE
3192 !---THE KP TERMS FOR K=1...
3193       DO 303 KP=2,LP1
3194       DO 303 I=MYIS,MYIE
3195       FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) &
3196                         +SS2(I,KP)*CNTTAU(I,KP-1) &
3197                         +CSS(I,KP)*CO21(I,KP,1) &
3198                         +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1)
3199 303   CONTINUE
3200 !          SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER
3201 !     CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS.
3202 !
3203       CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
3204                  CLDFAC,TEMP,PRESS,VAR1,VAR2, &
3205                  P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
3206                  CO2SP1,CO2SP2,CO2SP,              &
3207                  APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
3208                  H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO,    &
3209 !                SKO2D,RADCON,                                 &
3210                  RADCON,                                 &
3211                  ids,ide, jds,jde, kds,kde,                    &
3212                  ims,ime, jms,jme, kms,kme,                    &
3213                  its,ite, jts,jte, kts,kte                     )
3214
3215 !
3216 !    THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2
3217 !    EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800-
3218 !    990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE
3219 !    CONTAINED IN CTSO3, COMPUTED IN SPA88.
3220 !
3221       DO 998 I=MYIS,MYIE
3222       VTMP3(I,1)=1.
3223 998   CONTINUE
3224       DO 999 K=1,L
3225       DO 999 I=MYIS,MYIE
3226       VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1)
3227 999   CONTINUE
3228       DO 1001 K=1,L
3229       DO 1001 I=MYIS,MYIE
3230       CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* &
3231            (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + &
3232             SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K)))
3233 1001  CONTINUE
3234 !
3235       DO 1011 K=1,L
3236       DO 1011 I=MYIS,MYIE
3237       VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - &
3238                         CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K)))
3239 1011  CONTINUE
3240       DO 1012 I=MYIS,MYIE
3241       FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* &
3242                 (E1CTS1(I,LP1)-E1CTW1(I,LP1))
3243 1012  CONTINUE
3244       DO 1014 K=1,L
3245       DO 1013 I=MYIS,MYIE
3246       FLX1E1(I)=FLX1E1(I)+VTMP3(I,K)
3247 1013  CONTINUE
3248 1014  CONTINUE
3249 !
3250 !---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1  CASES.
3251 !   CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL
3252 !   EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS.
3253 !
3254       DO 321 K=2,LM1
3255       KLEN=K
3256 !
3257       DO 3218 KK=1,LP1-K
3258       DO 3218 I=MYIS,MYIE
3259       AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K)
3260 3218  CONTINUE
3261       DO 1803 I=MYIS,MYIE
3262       AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3263 1803   CONTINUE
3264 !---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT
3265 !   WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL
3266 !   AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS
3267 !   BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE
3268 !    THEIR FLUXES SEPARASTELY.
3269 !
3270       CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2,  &
3271 !                      T1,T2,T4,                      &
3272                        H16E1,HP1,H28E1,HAF,TEN,       &
3273                        ids,ide, jds,jde, kds,kde,     &
3274                        ims,ime, jms,jme, kms,kme,     &
3275                        its,ite, jts,jte, kts,kte      )
3276
3277       DO 322 KK=1,LP1-K
3278       DO 322 I=MYIS,MYIE
3279       AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K)
3280       AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K)
3281       AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K)
3282       CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1)
3283 322   CONTINUE
3284 !
3285       DO 3221 KK=1,LP1-K
3286       DO 3221 I=MYIS,MYIE
3287       FAC1(I,K+KK-1)=BO3RND(2)*AVPHO3(I,K+KK-1)/AVMO3(I,K+KK-1)
3288       VTMP3(I,K+KK-1)=HAF*(FAC1(I,K+KK-1)* &
3289         (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,K+KK-1))/ &
3290          FAC1(I,K+KK-1))-ONE))
3291       TO31D(I,K+KK-1)=EXP(HM1EZ*(VTMP3(I,K+KK-1) &
3292                          +SKO3R*AVVO2(I,K+KK-1)))
3293       OVER1D(I,K+KK-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,K+KK-1))+ &
3294                   SKC1R*AVVO2(I,K+KK-1)))
3295       CO21(I,K+KK,K)=OVER1D(I,K+KK-1)*CO21(I,K+KK,K)
3296 3221  CONTINUE
3297       DO 3223 KP=K+1,LP1
3298       DO 3223 I=MYIS,MYIE
3299       CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP)
3300 3223  CONTINUE
3301 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3302       DO 1804 I=MYIS,MYIE
3303       RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K)
3304 1804  CONTINUE
3305 !---THE KP TERMS FOR ARBIRRARY K..
3306       DO 3423 KP=K+1,LP1
3307       DO 3423 I=MYIS,MYIE
3308       FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) &
3309                         +SS2(I,KP)*CONT1D(I,KP-1) &
3310                         +CSS(I,KP)*CO21(I,KP,K) &
3311                         +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K)
3312 3423  CONTINUE
3313       DO 3425 KP=K+1,LP1
3314       DO 3425 I=MYIS,MYIE
3315       FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) &
3316                          +SS2(I,K)*CONT1D(I,KP-1) &
3317                          +CSS(I,K)*CO21(I,K,KP) &
3318                          +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP)
3319 3425  CONTINUE
3320 321   CONTINUE
3321 !
3322       DO 821 I=MYIS,MYIE
3323       TPL(I,1)=TEMP(I,L)
3324       TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L))
3325       TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L))
3326 821   CONTINUE
3327       DO 823 K=2,L
3328       DO 823 I=MYIS,MYIE
3329       TPL(I,K)=T(I,K)
3330       TPL(I,K+L)=T(I,K)
3331 823   CONTINUE
3332 !
3333 !---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES,
3334 !   DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1)
3335       DO 833 I=MYIS,MYIE
3336       AVEPHI(I,1)=VAR2(I,L)
3337       AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L)
3338 833   CONTINUE
3339       CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP,                          &
3340 !                     T1,T2,T4, &
3341                       H16E1,TEN,H28E1,HP1,                          &
3342                       ids,ide, jds,jde, kds,kde,                    &
3343                       ims,ime, jms,jme, kms,kme,                    &
3344                       its,ite, jts,jte, kts,kte                     )
3345
3346 !
3347 !     CALL E3V88 FOR NBL H2O TRANSMISSIVITIES
3348 !          CALL E3V88(EMD,TPL,EMPL,EM3V, &
3349            CALL E3V88(EMD,TPL,EMPL, &
3350                       TEN,HP1,H28E1,H16E1,  &
3351                       ids,ide, jds,jde, kds,kde,                    &
3352                       ims,ime, jms,jme, kms,kme,                    &
3353                       its,ite, jts,jte, kts,kte                     )
3354 !
3355 !   COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS
3356 !    USING METHODS FOR H2O GIVEN IN REF. (4)
3357       DO 851 K=2,L
3358       DO 851 I=MYIS,MYIE
3359       EMISDG(I,K)=EMD(I,K+L)+EMD(I,K)
3360 851   CONTINUE
3361 !
3362 !   NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN
3363 !   LWR88
3364       DO 861 I=MYIS,MYIE
3365       EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ &
3366        EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2))
3367       EMISDG(I,LP1)=TWO*EMD(I,LP1)
3368       EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ &
3369        EMX2(I)
3370 861   CONTINUE
3371       DO 331 I=MYIS,MYIE
3372       FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L)
3373       VTMP3(I,L)=HAF*(FAC1(I,L)* &
3374           (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE))
3375       TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L)))
3376       OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ &
3377                   SKC1R*CNTVAL(I,L)))
3378       CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1)
3379       RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L)
3380 331   CONTINUE
3381       DO 618 K=1,L
3382       DO 618 I=MYIS,MYIE
3383       RLOG(I,K)=LOG(RLOG(I,K))
3384 618   CONTINUE
3385       DO 601 K=1,LM1
3386       DO 601 I=MYIS,MYIE
3387       DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1))
3388       ALP(I,LP1+K-1)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1)
3389 601   CONTINUE
3390       DO 603 K=1,L
3391       DO 603 I=MYIS,MYIE
3392       DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K))
3393       ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K)
3394 603   CONTINUE
3395       DO 625 I=MYIS,MYIE
3396       ALP(I,LL)=-RLOG(I,L)
3397       ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1)))
3398 625   CONTINUE
3399 !        THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE
3400 !     FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION.
3401 !
3402 !       PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND
3403 !***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY
3404 !   EVALUATED.
3405       DO 631 K=1,LLP1
3406       DO 631 I=MYIS,MYIE
3407       C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2))
3408 631   CONTINUE
3409       DO 641 I=MYIS,MYIE
3410       CO21(I,LP1,LP1)=ONE+C(I,L)
3411       CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* &
3412        C(I,LLM1))/(P(I,LP1)-PRESS(I,L))
3413       CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- &
3414        (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1))
3415 641   CONTINUE
3416       DO 643 K=2,L
3417       DO 643 I=MYIS,MYIE
3418       CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1))
3419 643   CONTINUE
3420 !
3421 !    COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE
3422 !    ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS
3423 !    USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4).
3424       DO 651 K=1,LM1
3425       DO 651 I=MYIS,MYIE
3426       CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1)
3427       CSUB(I,LP1+K-1)=CNTVAL(I,K)*DELPR2(I,K+1)
3428 651   CONTINUE
3429 !---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED
3430       DO 655 K=1,LLM2
3431       DO 655 I=MYIS,MYIE
3432       CSUB2(I,K+1)=SKO3R*CSUB(I,K+1)
3433       C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* &
3434                 (HP166666-CSUB(I,K+1)*H41666M2))
3435       C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* &
3436                  (HP166666-CSUB2(I,K+1)*H41666M2))
3437 655   CONTINUE
3438       DO 661 I=MYIS,MYIE
3439       CONTDG(I,LP1)=1.+C(I,LLM1)
3440       TO3DG(I,LP1)=1.+C2(I,LLM1)
3441 661   CONTINUE
3442       DO 663 K=2,L
3443       DO 663 I=MYIS,MYIE
3444       CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K))
3445       TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K))
3446 663   CONTINUE
3447 !---NOW OBTAIN FLUXES
3448 !
3449 !    FOR THE DIAGONAL TERMS...
3450       DO 871 K=2,LP1
3451       DO 871 I=MYIS,MYIE
3452       FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) &
3453                        +SS2(I,K)*CONTDG(I,K) &
3454                        +OSS(I,K)*TO3DG(I,K) &
3455                        +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K)
3456 871   CONTINUE
3457 !     FOR THE TWO OFF-DIAGONAL TERMS...
3458       DO 873 I=MYIS,MYIE
3459       FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) &
3460                         +DTC(I,LP1)*EMSPEC(I,2) &
3461                         +OSS(I,LP1)*TO31D(I,L) &
3462                         +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L)
3463       FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) &
3464                             +OSS(I,L)*TO31D(I,L) &
3465                             +SS2(I,L)*CONT1D(I,L) &
3466                             +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1)
3467 873   CONTINUE
3468 !
3469 !     FINAL SECTION OBTAINS EMISSIVITY HEATING RATES,
3470 !     TOTAL HEATING RATES AND THE FLUX AT THE GROUND
3471 !
3472 !     .....CALCULATE THE EMISSIVITY HEATING RATES
3473       DO 1101 K=1,L
3474       DO 1101 I=MYIS,MYIE
3475       HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K)
3476 1101  CONTINUE
3477 !     .....CALCULATE THE TOTAL HEATING RATES
3478       DO 1103 K=1,L
3479       DO 1103 I=MYIS,MYIE
3480       HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K)
3481 1103  CONTINUE
3482 !     .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE
3483 !    TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1)
3484       DO 1111 K=1,L
3485       DO 1111 I=MYIS,MYIE
3486       VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1
3487 1111  CONTINUE
3488       DO 1115 I=MYIS,MYIE
3489       TOPFLX(I)=FLX1E1(I)+GXCTS(I)
3490       FLXNET(I,1)=TOPFLX(I)
3491 1115  CONTINUE
3492 !---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS
3493 !    THE THICK CLOUD SECTION IS INVOKED.
3494       DO 1123 K=2,LP1
3495       DO 1123 I=MYIS,MYIE
3496       FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1)
3497 1123  CONTINUE
3498       DO 1125 I=MYIS,MYIE
3499       GRNFLX(I)=FLXNET(I,LP1)
3500 1125  CONTINUE
3501 !
3502 !     THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD
3503 !     FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT,
3504 !     FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED.
3505 !***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE
3506 !   ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS.
3507       ICNT=0
3508       DO 1301 I=MYIS,MYIE
3509       ICNT=ICNT+NCLDS(I)
3510 1301  CONTINUE
3511       IF (ICNT.EQ.0) GO TO 6999
3512 !---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW
3513       KCLDS=NCLDS(MYIS)
3514       DO 2106 I=MYIS,MYIE
3515       KCLDS=MAX(NCLDS(I),KCLDS)
3516 2106  CONTINUE
3517 !
3518 !
3519 !***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF
3520 !   THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE
3521 !   BEEN DEFINED!).
3522       DO 1361 KK=1,KCLDS
3523       KMIN=LP1
3524       KMAX=0
3525       DO 1362 I=MYIS,MYIE
3526         J1=KTOP(I,KK+1)
3527 !       IF (J1.EQ.1) GO TO 1362
3528         J3=KBTM(I,KK+1)
3529         IF (J3.GT.J1) THEN
3530           PTOP(I)=P(I,J1)
3531           PBOT(I)=P(I,J3+1)
3532           FTOP(I)=FLXNET(I,J1)
3533           FBOT(I)=FLXNET(I,J3+1)
3534 !***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC)
3535           DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I))
3536           KMIN=MIN(KMIN,J1)
3537           KMAX=MAX(KMAX,J3)
3538         ENDIF
3539 1362  CONTINUE
3540       KMIN=KMIN+1
3541 !***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR
3542 !   ALL LEVELS.
3543       DO 1365 K=KMIN,KMAX
3544       DO 1363 I=MYIS,MYIE
3545 !       IF (KTOP(I,KK+1).EQ.1) GO TO 1363
3546         IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN
3547           Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I)
3548 !ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) +
3549 !ORIGINAL1            Z1(I,K)*CAMT(I,KK+1)
3550           FLXNET(I,K)=Z1(I,K)
3551         ENDIF
3552 1363  CONTINUE
3553 1365  CONTINUE
3554 1361  CONTINUE
3555 !***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN
3556 !   THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY
3557 !    THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED.
3558 !     DO 6051 K=1,LP1
3559 !     DO 6051 I=MYIS,MYIE
3560 !     FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) +
3561 !    1            Z1(I,K)*CAMT(I,NC)
3562 !051  CONTINUE
3563 !***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS.
3564 !     DO 1401 K=1,LP1
3565 !     DO 1401 I=MYIS,MYIE
3566 !     IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I)
3567 !    1  .AND.  (NC-1).LE.NCLDS(I))  THEN
3568 !          FLXNET(I,K)=FLXTHK(I,K)
3569 !     ENDIF
3570 !401  CONTINUE
3571 !
3572 !******END OF CLOUD LOOP*****
3573 6001  CONTINUE
3574 6999  CONTINUE
3575 !***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE
3576 !   REVISED FLUXES:
3577       DO 6101 K=1,L
3578       DO 6101 I=MYIS,MYIE
3579       HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K)
3580 6101  CONTINUE
3581 !     THE THICK CLOUD SECTION ENDS HERE.
3582
3583   END SUBROUTINE FST88
3584
3585 !----------------------------------------------------------------------
3586
3587   SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2,      &
3588                        AVEPHI,TEMP,T,                                &
3589 !                      T1,T2,T4,EM1V,EM1VW,                          &
3590                        H16E1,TEN,HP1,H28E1,HAF,                      &
3591                        ids,ide, jds,jde, kds,kde,                    &
3592                        ims,ime, jms,jme, kms,kme,                    &
3593                        its,ite, jts,jte, kts,kte                     )
3594 !---------------------------------------------------------------------
3595  IMPLICIT NONE
3596 !----------------------------------------------------------------------
3597       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
3598                                     ims,ime, jms,jme, kms,kme ,      &
3599                                     its,ite, jts,jte, kts,kte
3600       REAL,INTENT(IN) :: H16E1,TEN,HP1,H28E1,HAF
3601
3602       REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS
3603       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: FXOE1,DTE1,FXOE2,DTE2
3604       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,TEMP,T
3605       REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte)   :: G2,G5
3606 !     REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4 ,EM1V,EM1VW
3607
3608       REAL,DIMENSION(its:ite,kts:kte+1) :: TMP3,DU,FYO,WW1,WW2
3609       INTEGER,DIMENSION(its:ite,kts:kte*3+2)   :: IT1
3610       INTEGER,DIMENSION(its:ite,kts:kte+1) :: IVAL
3611
3612 !     REAL,DIMENSION(28,180):: EM1,EM1WDE,TABLE1,TABLE2, &
3613 !                              TABLE3
3614 !     EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
3615 !     EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
3616 !      (T4(1),TABLE3(1,1))
3617
3618       INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3619       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3620
3621       L=kte
3622       LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
3623       LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
3624       LLM2 = LL-2; LLM1=LL-1
3625       MYIS=its; MYIE=ite
3626
3627 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
3628 !   (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
3629 !   THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN
3630 !   OBTAINED IN FST88, FOR CONVENIENCE.
3631 !
3632 !---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY--
3633 !
3634 !---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS
3635 !   THE SPECIAL CASE FOR THE LP1TH LAYER.
3636
3637       DO 1322 K=1,LP1
3638       DO 1322 I=MYIS,MYIE
3639       TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
3640       FYO(I,K)=AINT(TMP3(I,K)*TEN)
3641       DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
3642       FYO(I,K)=H28E1*FYO(I,K)
3643       IVAL(I,K)=FYO(I,K)+FXOE2(I,K)
3644       EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
3645                               +DTE2(I,K)*T4(IVAL(I,K))
3646 1322  CONTINUE
3647 !
3648 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
3649 !   BY AVERAGING THE VALUES FOR L AND LP1:
3650       DO 1344 I=MYIS,MYIE
3651       EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
3652 1344  CONTINUE
3653 !
3654 !   CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS
3655 !   THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE
3656 !   TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING
3657 !   TO THE FLUXES AT OTHER LEVELS.
3658 !
3659 !***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY
3660 !    DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE
3661 !    SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE
3662 !    BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED
3663 !    IN THE E2 CALCS.,WITH K=1).
3664 !
3665 !
3666 !   FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE
3667 !   USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT
3668 !    THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE
3669 !   INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED.
3670       DO 208 I=MYIS,MYIE
3671       IT1(I,1)=FXOE1(I,1)
3672       WW1(I,1)=TEN-DTE1(I,1)
3673       WW2(I,1)=HP1
3674 208   CONTINUE
3675       DO 209 K=1,L
3676       DO 209 I=MYIS,MYIE
3677       IT1(I,K+1)=FYO(I,K)+FXOE1(I,K+1)
3678       IT1(I,LP2+K-1)=FYO(I,K)+FXOE1(I,K)
3679       WW1(I,K+1)=TEN-DTE1(I,K+1)
3680       WW2(I,K+1)=HP1-DU(I,K)
3681 209   CONTINUE
3682       DO 211 KP=1,L
3683       DO 211 I=MYIS,MYIE
3684       IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1)
3685 211   CONTINUE
3686 !
3687 !
3688 !  G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG)
3689       DO 230 I=MYIS,MYIE
3690       G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ &
3691               WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1)
3692       G3(I,1)=G1(I,1)
3693 230   CONTINUE
3694       DO 240 K=1,L
3695       DO 240 I=MYIS,MYIE
3696       G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ &
3697               WW2(I,K+1)*DTE1(I,K+1)*EM1V(IT1(I,K+1)+1)+ &
3698               WW1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+28)+ &
3699               DTE1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+29)
3700       G2(I,K)=WW1(I,K)*WW2(I,K+1)*EM1V(IT1(I,K+LP2-1))+ &
3701               WW2(I,K+1)*DTE1(I,K)*EM1V(IT1(I,K+LP2-1)+1)+ &
3702               WW1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+28)+ &
3703               DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29)
3704 240   CONTINUE
3705       DO 241 KP=2,LP1
3706       DO 241 I=MYIS,MYIE
3707       G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ &
3708               WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ &
3709               WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ &
3710               DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29)
3711 241   CONTINUE
3712 !
3713       DO 244 I=MYIS,MYIE
3714       G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ &
3715               WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1)
3716 244   CONTINUE
3717       DO 242 K=1,L
3718       DO 242 I=MYIS,MYIE
3719       G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ &
3720               WW2(I,K+1)*DTE1(I,K+1)*EM1VW(IT1(I,K+1)+1)+ &
3721               WW1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+28)+ &
3722               DTE1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+29)
3723       G5(I,K)=WW1(I,K)*WW2(I,K+1)*EM1VW(IT1(I,K+LP2-1))+ &
3724               WW2(I,K+1)*DTE1(I,K)*EM1VW(IT1(I,K+LP2-1)+1)+ &
3725               WW1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+28)+ &
3726               DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29)
3727 242   CONTINUE
3728 !
3729   END SUBROUTINE E1E290
3730
3731 !----------------------------------------------------------------------
3732
3733  SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR,                      &
3734                        CLDFAC,TEMP,PRESS,VAR1,VAR2,                  &
3735                        P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC,             &
3736                        CO2SP1,CO2SP2,CO2SP,                          &
3737                        APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
3738                        H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO,    &
3739 !                      SKO2D,RADCON,                                 &
3740                        RADCON,                                 &
3741                        ids,ide, jds,jde, kds,kde,                    &
3742                        ims,ime, jms,jme, kms,kme,                    &
3743                        its,ite, jts,jte, kts,kte                     )
3744 !---------------------------------------------------------------------
3745  IMPLICIT NONE
3746 !----------------------------------------------------------------------
3747 !     INTEGER, PARAMETER :: NBLY=15
3748       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
3749                                     ims,ime, jms,jme, kms,kme ,      &
3750                                     its,ite, jts,jte, kts,kte
3751
3752       REAL,INTENT(IN) :: H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3753                          RADCON
3754 !                        SKO2D,RADCON
3755
3756       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: CSOUR
3757       REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte)  :: CTSO3
3758       REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte)  :: EXCTS
3759       REAL,INTENT(OUT),DIMENSION(its:ite)          :: GXCTS
3760       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
3761       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
3762       REAL,INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
3763
3764       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: VAR1,VAR2
3765       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: P
3766       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte)   :: DELP,DELP2,TO3SPC
3767       REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) ::TOTVO2,TO3SP,CO2SP1,&
3768                                                      CO2SP2,CO2SP
3769       REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
3770                                          BCOMB,BETACM
3771
3772       REAL,DIMENSION(its:ite,kts:kte+1) ::CTMP,CTMP2,CTMP3
3773       REAL,DIMENSION(its:ite,kts:kte)   ::X,Y,FAC1,FAC2,F,FF,AG,AGG, &
3774                                           PHITMP,PSITMP,TOPM,TOPPHI,TT
3775
3776       INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3777       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3778
3779       L=kte
3780       LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
3781       LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
3782       LLM2 = LL-2; LLM1=LL-1
3783       MYIS=its; MYIE=ite
3784
3785 !--!COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM
3786
3787       DO 101 K=1,L
3788       DO 101 I=MYIS,MYIE
3789       X(I,K)=TEMP(I,K)-H25E2
3790       Y(I,K)=X(I,K)*X(I,K)
3791 101   CONTINUE
3792 !---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE
3793 !   TRANSMISSION FCTNS AT THE TOP.
3794       DO 345 I=MYIS,MYIE
3795       CTMP(I,1)=ONE
3796       CTMP2(I,1)=1.
3797       CTMP3(I,1)=1.
3798 345   CONTINUE
3799 !***BEGIN LOOP ON FREQUENCY BANDS (1)***
3800 !
3801 !---CALCULATION FOR BAND 1 (COMBINED BAND 1)
3802 !
3803 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3804 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3805 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3806       DO 301 K=1,L
3807       DO 301 I=MYIS,MYIE
3808       F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K))
3809       FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K))
3810       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3811       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3812       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3813       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3814 301   CONTINUE
3815 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3816 !   P(K) (TOPM,TOPPHI)
3817       DO 315 I=MYIS,MYIE
3818       TOPM(I,1)=PHITMP(I,1)
3819       TOPPHI(I,1)=PSITMP(I,1)
3820 315   CONTINUE
3821       DO 319 K=2,L
3822       DO 317 I=MYIS,MYIE
3823       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3824       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3825 317   CONTINUE
3826 319   CONTINUE
3827 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3828       DO 321 K=1,L
3829       DO 321 I=MYIS,MYIE
3830       FAC1(I,K)=ACOMB(1)*TOPM(I,K)
3831       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K))
3832       TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3833       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3834 321   CONTINUE
3835 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3836       DO 353 K=1,L
3837       DO 353 I=MYIS,MYIE
3838       EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K))
3839 353   CONTINUE
3840 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3841       DO 361 I=MYIS,MYIE
3842       GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+ &
3843          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3844          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3845          (SORC(I,LP1,1)-SORC(I,L,1)))
3846 361   CONTINUE
3847 !
3848 !
3849 !-----CALCULATION FOR BAND 2 (COMBINED BAND 2)
3850 !
3851 !
3852 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3853 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3854 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3855       DO 401 K=1,L
3856       DO 401 I=MYIS,MYIE
3857       F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K))
3858       FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K))
3859       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3860       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3861       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3862       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3863 401   CONTINUE
3864 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3865 !   P(K) (TOPM,TOPPHI)
3866       DO 415 I=MYIS,MYIE
3867       TOPM(I,1)=PHITMP(I,1)
3868       TOPPHI(I,1)=PSITMP(I,1)
3869 415   CONTINUE
3870       DO 419 K=2,L
3871       DO 417 I=MYIS,MYIE
3872       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3873       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3874 417   CONTINUE
3875 419   CONTINUE
3876 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3877       DO 421 K=1,L
3878       DO 421 I=MYIS,MYIE
3879       FAC1(I,K)=ACOMB(2)*TOPM(I,K)
3880       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K))
3881       TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3882       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3883 421   CONTINUE
3884 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3885       DO 453 K=1,L
3886       DO 453 I=MYIS,MYIE
3887       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* &
3888                    (CTMP(I,K+1)-CTMP(I,K))
3889 453   CONTINUE
3890 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3891       DO 461 I=MYIS,MYIE
3892       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ &
3893          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3894          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3895          (SORC(I,LP1,2)-SORC(I,L,2)))
3896 461   CONTINUE
3897 !
3898 !-----CALCULATION FOR BAND 3 (COMBINED BAND 3)
3899 !
3900 !
3901 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3902 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3903 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3904       DO 501 K=1,L
3905       DO 501 I=MYIS,MYIE
3906       F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K))
3907       FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K))
3908       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3909       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3910       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3911       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3912 501   CONTINUE
3913 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3914 !   P(K) (TOPM,TOPPHI)
3915       DO 515 I=MYIS,MYIE
3916       TOPM(I,1)=PHITMP(I,1)
3917       TOPPHI(I,1)=PSITMP(I,1)
3918 515   CONTINUE
3919       DO 519 K=2,L
3920       DO 517 I=MYIS,MYIE
3921       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3922       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3923 517   CONTINUE
3924 519   CONTINUE
3925 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3926       DO 521 K=1,L
3927       DO 521 I=MYIS,MYIE
3928       FAC1(I,K)=ACOMB(3)*TOPM(I,K)
3929       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K))
3930       TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3931       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3932 521   CONTINUE
3933 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3934       DO 553 K=1,L
3935       DO 553 I=MYIS,MYIE
3936       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* &
3937                    (CTMP(I,K+1)-CTMP(I,K))
3938 553   CONTINUE
3939 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3940       DO 561 I=MYIS,MYIE
3941       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ &
3942          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3943          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3944          (SORC(I,LP1,3)-SORC(I,L,3)))
3945 561   CONTINUE
3946 !
3947 !-----CALCULATION FOR BAND 4 (COMBINED BAND 4)
3948 !
3949 !
3950 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3951 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3952 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3953       DO 601 K=1,L
3954       DO 601 I=MYIS,MYIE
3955       F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K))
3956       FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K))
3957       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3958       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3959       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3960       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3961 601   CONTINUE
3962 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3963 !   P(K) (TOPM,TOPPHI)
3964       DO 615 I=MYIS,MYIE
3965       TOPM(I,1)=PHITMP(I,1)
3966       TOPPHI(I,1)=PSITMP(I,1)
3967 615   CONTINUE
3968       DO 619 K=2,L
3969       DO 617 I=MYIS,MYIE
3970       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3971       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3972 617   CONTINUE
3973 619   CONTINUE
3974 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3975       DO 621 K=1,L
3976       DO 621 I=MYIS,MYIE
3977       FAC1(I,K)=ACOMB(4)*TOPM(I,K)
3978       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K))
3979       TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3980       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3981 621   CONTINUE
3982 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3983       DO 653 K=1,L
3984       DO 653 I=MYIS,MYIE
3985       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* &
3986                    (CTMP(I,K+1)-CTMP(I,K))
3987 653   CONTINUE
3988 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3989       DO 661 I=MYIS,MYIE
3990       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ &
3991          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3992          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3993          (SORC(I,LP1,4)-SORC(I,L,4)))
3994 661   CONTINUE
3995 !
3996 !-----CALCULATION FOR BAND 5 (COMBINED BAND 5)
3997 !
3998 !
3999 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4000 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4001 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4002       DO 701 K=1,L
4003       DO 701 I=MYIS,MYIE
4004       F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K))
4005       FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K))
4006       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4007       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4008       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4009       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4010 701   CONTINUE
4011 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4012 !   P(K) (TOPM,TOPPHI)
4013       DO 715 I=MYIS,MYIE
4014       TOPM(I,1)=PHITMP(I,1)
4015       TOPPHI(I,1)=PSITMP(I,1)
4016 715   CONTINUE
4017       DO 719 K=2,L
4018       DO 717 I=MYIS,MYIE
4019       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4020       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4021 717   CONTINUE
4022 719   CONTINUE
4023 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4024       DO 721 K=1,L
4025       DO 721 I=MYIS,MYIE
4026       FAC1(I,K)=ACOMB(5)*TOPM(I,K)
4027       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K))
4028       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4029                  BETACM(5)*TOTVO2(I,K+1)*SKO2D))
4030       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4031 721   CONTINUE
4032 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4033       DO 753 K=1,L
4034       DO 753 I=MYIS,MYIE
4035       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* &
4036                    (CTMP(I,K+1)-CTMP(I,K))
4037 753   CONTINUE
4038 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4039       DO 761 I=MYIS,MYIE
4040       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ &
4041          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4042          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4043          (SORC(I,LP1,5)-SORC(I,L,5)))
4044 761   CONTINUE
4045 !
4046 !-----CALCULATION FOR BAND 6 (COMBINED BAND 6)
4047 !
4048 !
4049 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4050 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4051 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4052       DO 801 K=1,L
4053       DO 801 I=MYIS,MYIE
4054       F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K))
4055       FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K))
4056       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4057       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4058       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4059       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4060 801   CONTINUE
4061 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4062 !   P(K) (TOPM,TOPPHI)
4063       DO 815 I=MYIS,MYIE
4064       TOPM(I,1)=PHITMP(I,1)
4065       TOPPHI(I,1)=PSITMP(I,1)
4066 815   CONTINUE
4067       DO 819 K=2,L
4068       DO 817 I=MYIS,MYIE
4069       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4070       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4071 817   CONTINUE
4072 819   CONTINUE
4073 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4074       DO 821 K=1,L
4075       DO 821 I=MYIS,MYIE
4076       FAC1(I,K)=ACOMB(6)*TOPM(I,K)
4077       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K))
4078       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4079                  BETACM(6)*TOTVO2(I,K+1)*SKO2D))
4080       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4081 821   CONTINUE
4082 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4083       DO 853 K=1,L
4084       DO 853 I=MYIS,MYIE
4085       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* &
4086                    (CTMP(I,K+1)-CTMP(I,K))
4087 853   CONTINUE
4088 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4089       DO 861 I=MYIS,MYIE
4090       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ &
4091          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4092          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4093          (SORC(I,LP1,6)-SORC(I,L,6)))
4094 861   CONTINUE
4095 !
4096 !-----CALCULATION FOR BAND 7 (COMBINED BAND 7)
4097 !
4098 !
4099 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4100 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4101 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4102       DO 901 K=1,L
4103       DO 901 I=MYIS,MYIE
4104       F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K))
4105       FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K))
4106       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4107       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4108       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4109       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4110 901   CONTINUE
4111 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4112 !   P(K) (TOPM,TOPPHI)
4113       DO 915 I=MYIS,MYIE
4114       TOPM(I,1)=PHITMP(I,1)
4115       TOPPHI(I,1)=PSITMP(I,1)
4116 915   CONTINUE
4117       DO 919 K=2,L
4118       DO 917 I=MYIS,MYIE
4119       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4120       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4121 917   CONTINUE
4122 919   CONTINUE
4123 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4124       DO 921 K=1,L
4125       DO 921 I=MYIS,MYIE
4126       FAC1(I,K)=ACOMB(7)*TOPM(I,K)
4127       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K))
4128       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4129                  BETACM(7)*TOTVO2(I,K+1)*SKO2D))
4130       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4131 921   CONTINUE
4132 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4133       DO 953 K=1,L
4134       DO 953 I=MYIS,MYIE
4135       EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)* &
4136                    (CTMP(I,K+1)-CTMP(I,K))
4137 953   CONTINUE
4138 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4139       DO 961 I=MYIS,MYIE
4140       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ &
4141          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4142          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4143          (SORC(I,LP1,7)-SORC(I,L,7)))
4144 961   CONTINUE
4145 !
4146 !-----CALCULATION FOR BAND 8 (COMBINED BAND 8)
4147 !
4148 !
4149 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4150 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4151 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4152       DO 1001 K=1,L
4153       DO 1001 I=MYIS,MYIE
4154       F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K))
4155       FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K))
4156       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4157       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4158       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4159       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4160 1001  CONTINUE
4161 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4162 !   P(K) (TOPM,TOPPHI)
4163       DO 1015 I=MYIS,MYIE
4164       TOPM(I,1)=PHITMP(I,1)
4165       TOPPHI(I,1)=PSITMP(I,1)
4166 1015  CONTINUE
4167       DO 1019 K=2,L
4168       DO 1017 I=MYIS,MYIE
4169       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4170       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4171 1017  CONTINUE
4172 1019  CONTINUE
4173 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4174       DO 1021 K=1,L
4175       DO 1021 I=MYIS,MYIE
4176       FAC1(I,K)=ACOMB(8)*TOPM(I,K)
4177       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K))
4178       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4179                  BETACM(8)*TOTVO2(I,K+1)*SKO2D))
4180       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4181 1021  CONTINUE
4182 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4183       DO 1053 K=1,L
4184       DO 1053 I=MYIS,MYIE
4185       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* &
4186                    (CTMP(I,K+1)-CTMP(I,K))
4187 1053  CONTINUE
4188 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4189       DO 1061 I=MYIS,MYIE
4190       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ &
4191          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4192          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4193          (SORC(I,LP1,8)-SORC(I,L,8)))
4194 1061  CONTINUE
4195 !
4196 !-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2)
4197 !
4198 !
4199 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4200 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4201 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4202       DO 1101 K=1,L
4203       DO 1101 I=MYIS,MYIE
4204       F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K))
4205       FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K))
4206       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4207       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4208       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4209       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4210 1101  CONTINUE
4211 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4212 !   P(K) (TOPM,TOPPHI)
4213       DO 1115 I=MYIS,MYIE
4214       TOPM(I,1)=PHITMP(I,1)
4215       TOPPHI(I,1)=PSITMP(I,1)
4216 1115  CONTINUE
4217       DO 1119 K=2,L
4218       DO 1117 I=MYIS,MYIE
4219       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4220       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4221 1117  CONTINUE
4222 1119  CONTINUE
4223 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4224       DO 1121 K=1,L
4225       DO 1121 I=MYIS,MYIE
4226       FAC1(I,K)=ACOMB(9)*TOPM(I,K)
4227       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K))
4228       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4229                  BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1)
4230       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4231 1121  CONTINUE
4232 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4233       DO 1153 K=1,L
4234       DO 1153 I=MYIS,MYIE
4235       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* &
4236                    (CTMP(I,K+1)-CTMP(I,K))
4237 1153  CONTINUE
4238 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4239       DO 1161 I=MYIS,MYIE
4240       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ &
4241          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4242          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4243          (SORC(I,LP1,9)-SORC(I,L,9)))
4244 1161  CONTINUE
4245 !
4246 !-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2)
4247 !
4248 !
4249 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4250 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4251 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4252       DO 1201 K=1,L
4253       DO 1201 I=MYIS,MYIE
4254       F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K))
4255       FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K))
4256       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4257       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4258       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4259       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4260 1201  CONTINUE
4261 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4262 !   P(K) (TOPM,TOPPHI)
4263       DO 1215 I=MYIS,MYIE
4264       TOPM(I,1)=PHITMP(I,1)
4265       TOPPHI(I,1)=PSITMP(I,1)
4266 1215  CONTINUE
4267       DO 1219 K=2,L
4268       DO 1217 I=MYIS,MYIE
4269       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4270       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4271 1217  CONTINUE
4272 1219  CONTINUE
4273 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4274       DO 1221 K=1,L
4275       DO 1221 I=MYIS,MYIE
4276       FAC1(I,K)=ACOMB(10)*TOPM(I,K)
4277       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K))
4278       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4279                  BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1)
4280       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4281 1221  CONTINUE
4282 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4283       DO 1253 K=1,L
4284       DO 1253 I=MYIS,MYIE
4285       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* &
4286                    (CTMP(I,K+1)-CTMP(I,K))
4287 1253  CONTINUE
4288 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4289       DO 1261 I=MYIS,MYIE
4290       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ &
4291          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4292          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4293          (SORC(I,LP1,10)-SORC(I,L,10)))
4294 1261  CONTINUE
4295 !
4296 !-----CALCULATION FOR BAND 11 (800-900 CM-1)
4297 !
4298 !
4299 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4300 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4301 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4302       DO 1301 K=1,L
4303       DO 1301 I=MYIS,MYIE
4304       F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K))
4305       FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K))
4306       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4307       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4308       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4309       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4310 1301  CONTINUE
4311 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4312 !   P(K) (TOPM,TOPPHI)
4313       DO 1315 I=MYIS,MYIE
4314       TOPM(I,1)=PHITMP(I,1)
4315       TOPPHI(I,1)=PSITMP(I,1)
4316 1315  CONTINUE
4317       DO 1319 K=2,L
4318       DO 1317 I=MYIS,MYIE
4319       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4320       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4321 1317  CONTINUE
4322 1319  CONTINUE
4323 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4324       DO 1321 K=1,L
4325       DO 1321 I=MYIS,MYIE
4326       FAC1(I,K)=ACOMB(11)*TOPM(I,K)
4327       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K))
4328       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4329                  BETACM(11)*TOTVO2(I,K+1)*SKO2D))
4330       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4331 1321  CONTINUE
4332 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4333       DO 1353 K=1,L
4334       DO 1353 I=MYIS,MYIE
4335       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* &
4336                    (CTMP(I,K+1)-CTMP(I,K))
4337 1353  CONTINUE
4338 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4339       DO 1361 I=MYIS,MYIE
4340       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ &
4341          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4342          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4343          (SORC(I,LP1,11)-SORC(I,L,11)))
4344 1361  CONTINUE
4345 !
4346 !-----CALCULATION FOR BAND 12 (900-990 CM-1)
4347 !
4348 !
4349 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4350 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4351 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4352       DO 1401 K=1,L
4353       DO 1401 I=MYIS,MYIE
4354       F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K))
4355       FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K))
4356       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4357       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4358       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4359       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4360 1401  CONTINUE
4361 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4362 !   P(K) (TOPM,TOPPHI)
4363       DO 1415 I=MYIS,MYIE
4364       TOPM(I,1)=PHITMP(I,1)
4365       TOPPHI(I,1)=PSITMP(I,1)
4366 1415  CONTINUE
4367       DO 1419 K=2,L
4368       DO 1417 I=MYIS,MYIE
4369       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4370       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4371 1417  CONTINUE
4372 1419  CONTINUE
4373 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4374       DO 1421 K=1,L
4375       DO 1421 I=MYIS,MYIE
4376       FAC1(I,K)=ACOMB(12)*TOPM(I,K)
4377       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K))
4378       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4379                  BETACM(12)*TOTVO2(I,K+1)*SKO2D))
4380       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4381 1421  CONTINUE
4382 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4383       DO 1453 K=1,L
4384       DO 1453 I=MYIS,MYIE
4385       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* &
4386                    (CTMP(I,K+1)-CTMP(I,K))
4387 1453  CONTINUE
4388 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4389       DO 1461 I=MYIS,MYIE
4390       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ &
4391          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4392          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4393          (SORC(I,LP1,12)-SORC(I,L,12)))
4394 1461  CONTINUE
4395 !
4396 !-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3))
4397 !
4398 !
4399 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4400 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4401 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4402       DO 1501 K=1,L
4403       DO 1501 I=MYIS,MYIE
4404       F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K))
4405       FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K))
4406       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4407       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4408       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4409       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4410 1501  CONTINUE
4411 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4412 !   P(K) (TOPM,TOPPHI)
4413       DO 1515 I=MYIS,MYIE
4414       TOPM(I,1)=PHITMP(I,1)
4415       TOPPHI(I,1)=PSITMP(I,1)
4416 1515  CONTINUE
4417       DO 1519 K=2,L
4418       DO 1517 I=MYIS,MYIE
4419       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4420       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4421 1517  CONTINUE
4422 1519  CONTINUE
4423 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4424       DO 1521 K=1,L
4425       DO 1521 I=MYIS,MYIE
4426       FAC1(I,K)=ACOMB(13)*TOPM(I,K)
4427       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K))
4428       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4429                  BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K)))
4430       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4431 1521  CONTINUE
4432 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4433       DO 1553 K=1,L
4434       DO 1553 I=MYIS,MYIE
4435       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* &
4436                    (CTMP(I,K+1)-CTMP(I,K))
4437 1553  CONTINUE
4438 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4439       DO 1561 I=MYIS,MYIE
4440       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ &
4441          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4442          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4443          (SORC(I,LP1,13)-SORC(I,L,13)))
4444 1561  CONTINUE
4445 !
4446 !-----CALCULATION FOR BAND 14 (1070-1200 CM-1)
4447 !
4448 !
4449 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4450 !   BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4451 !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4452       DO 1601 K=1,L
4453       DO 1601 I=MYIS,MYIE
4454       F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K))
4455       FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K))
4456       AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4457       AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4458       PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4459       PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4460 1601  CONTINUE
4461 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4462 !   P(K) (TOPM,TOPPHI)
4463       DO 1615 I=MYIS,MYIE
4464       TOPM(I,1)=PHITMP(I,1)
4465       TOPPHI(I,1)=PSITMP(I,1)
4466 1615  CONTINUE
4467       DO 1619 K=2,L
4468       DO 1617 I=MYIS,MYIE
4469       TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4470       TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4471 1617  CONTINUE
4472 1619  CONTINUE
4473 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4474       DO 1621 K=1,L
4475       DO 1621 I=MYIS,MYIE
4476       FAC1(I,K)=ACOMB(14)*TOPM(I,K)
4477       FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K))
4478       TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4479                  BETACM(14)*TOTVO2(I,K+1)*SKO2D))
4480       CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4481 1621  CONTINUE
4482 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4483       DO 1653 K=1,L
4484       DO 1653 I=MYIS,MYIE
4485       EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* &
4486                    (CTMP(I,K+1)-CTMP(I,K))
4487 1653  CONTINUE
4488 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4489       DO 1661 I=MYIS,MYIE
4490       GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ &
4491          (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4492          TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4493          (SORC(I,LP1,14)-SORC(I,L,14)))
4494 1661  CONTINUE
4495 !
4496 !
4497 !   OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND
4498 !   USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE
4499 !   THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT
4500 !   BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS
4501 !   REDUCING COMPUTATIONS!
4502       DO 1731 K=1,L
4503       DO 1731 I=MYIS,MYIE
4504       GXCTS(I)=GXCTS(I)-EXCTS(I,K)
4505 1731  CONTINUE
4506 !
4507 !   NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE
4508 !   FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON)
4509       DO 1741 K=1,L
4510       DO 1741 I=MYIS,MYIE
4511       EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K)
4512 1741  CONTINUE
4513 !---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT
4514 !   EXCTS HAS ITS APPROPRIATE VALUE.
4515 !
4516 !*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
4517 !     (CTSO3)
4518       DO 1711 K=1,L
4519       DO 1711 I=MYIS,MYIE
4520       CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1)
4521       CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1)
4522 1711  CONTINUE
4523       DO 1701 K=1,L
4524       DO 1701 I=MYIS,MYIE
4525       CTSO3(I,K)=RADCON*DELP(I,K)* &
4526            (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + &
4527             SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)))
4528 1701  CONTINUE
4529
4530  END SUBROUTINE SPA88
4531 !----------------------------------------------------------------------
4532
4533  SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
4534 !                      T1,T2,T4,                                     &
4535                        H16E1,HP1,H28E1,HAF,TEN,                      &
4536                        ids,ide, jds,jde, kds,kde,                    &
4537                        ims,ime, jms,jme, kms,kme,                    &
4538                        its,ite, jts,jte, kts,kte                     )
4539 !---------------------------------------------------------------------
4540  IMPLICIT NONE
4541 !----------------------------------------------------------------------
4542       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
4543                                     ims,ime, jms,jme, kms,kme ,      &
4544                                     its,ite, jts,jte, kts,kte
4545       INTEGER, INTENT(IN)        :: KLEN
4546       REAL, INTENT(IN) :: H16E1,HP1,H28E1,HAF ,TEN
4547       REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: EMISSB
4548       REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,FXOE2,DTE2
4549
4550 !     REAL, INTENT(IN ), DIMENSION(5040) :: T1,T2,T4
4551
4552       REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1) :: EMISS
4553
4554       REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,DT,FYO,DU
4555       INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4556
4557 !     REAL,    DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4558 !     EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4559 !                 (T4(1),TABLE3(1,1))
4560 !     EQUIVALENCE (TMP3,DT)
4561
4562       INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
4563       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK
4564
4565       L=kte
4566       LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
4567       LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
4568       LLM2 = LL-2; LLM1=LL-1
4569       MYIS=its; MYIE=ite
4570
4571
4572 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
4573 !   (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
4574 !   THUS GENERATES THE E2 FUNCTION.
4575 !
4576 !---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL
4577 !   CASE: RESULTS ARE IN EMISS
4578
4579
4580
4581       DO 132 K=1,LP2-KLEN
4582       DO 132 I=MYIS,MYIE
4583       TMP3(I,K)=LOG10(AVEPHI(I,KLEN+K-1))+H16E1
4584       FYO(I,K)=AINT(TMP3(I,K)*TEN)
4585       DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4586       FYO(I,K)=H28E1*FYO(I,K)
4587       IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN+K-1)
4588       EMISS(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4589                                  +DTE2(I,KLEN+K-1)*T4(IVAL(I,K))
4590 132   CONTINUE
4591 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
4592 !   BY AVERAGING THE VALUES FOR L AND LP1:
4593       DO 1344 I=MYIS,MYIE
4594       EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
4595 1344  CONTINUE
4596 !---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT.
4597 !
4598 !---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB.
4599 !  IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING
4600 !  FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH
4601 !  THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT
4602 !  INVOLVED HERE.
4603 !     (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN
4604 !   EMISSB(I,(KLEN) TO L)
4605       DO 142 K=1,LP1-KLEN
4606       DO 142 I=MYIS,MYIE
4607       DT(I,K)=DTE2(I,KLEN-1)
4608       IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1)
4609 142   CONTINUE
4610 !
4611       DO 234 K=1,LP1-KLEN
4612       DO 234 I=MYIS,MYIE
4613       EMISSB(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4614                                       +DT(I,K)*T4(IVAL(I,K))
4615 234   CONTINUE
4616
4617  END SUBROUTINE E290
4618
4619 !---------------------------------------------------------------------
4620
4621   SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP,                         &
4622 !                      T1,T2,T4,                                     &
4623                        H16E1,TEN,H28E1,HP1,                          &
4624                        ids,ide, jds,jde, kds,kde,                    &
4625                        ims,ime, jms,jme, kms,kme,                    &
4626                        its,ite, jts,jte, kts,kte                     )
4627 !---------------------------------------------------------------------
4628  IMPLICIT NONE
4629 !----------------------------------------------------------------------
4630       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
4631                                     ims,ime, jms,jme, kms,kme ,      &
4632                                     its,ite, jts,jte, kts,kte
4633       REAL,INTENT(IN ) :: H16E1,TEN,H28E1,HP1
4634       REAL,INTENT(INOUT),DIMENSION(its:ite,kts:kte+1) :: EMISS
4635       REAL,INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI
4636       REAL,INTENT(IN ),DIMENSION(its:ite,2) :: FXOSP,DTSP
4637
4638 !     REAL, INTENT(IN ),DIMENSION(5040) :: T1,T2,T4
4639
4640 !     REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4641 !     EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4642 !                 (T4(1),TABLE3(1,1))
4643
4644       INTEGER :: K,I,MYIS,MYIE
4645
4646       REAL,    DIMENSION(its:ite,kts:kte+1) :: TMP3,FYO,DU
4647       INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4648
4649       MYIS=its
4650       MYIE=ite
4651
4652       DO 132 K=1,2
4653       DO 132 I=MYIS,MYIE
4654       TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
4655       FYO(I,K)=AINT(TMP3(I,K)*TEN)
4656       DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4657       IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K)
4658       EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ &
4659                                DTSP(I,K)*T4(IVAL(I,K))
4660 132   CONTINUE
4661
4662   END SUBROUTINE E2SPEC
4663
4664 !---------------------------------------------------------------------
4665
4666 ! SUBROUTINE E3V88(EMV,TV,AV,EM3V,            &
4667   SUBROUTINE E3V88(EMV,TV,AV, &
4668                        TEN,HP1,H28E1,H16E1,  &
4669                        ids,ide, jds,jde, kds,kde,                    &
4670                        ims,ime, jms,jme, kms,kme,                    &
4671                        its,ite, jts,jte, kts,kte                     )
4672 !---------------------------------------------------------------------
4673  IMPLICIT NONE
4674 !----------------------------------------------------------------------
4675       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
4676                                     ims,ime, jms,jme, kms,kme ,      &
4677                                     its,ite, jts,jte, kts,kte
4678       REAL,    INTENT(IN)  :: TEN,HP1,H28E1,H16E1
4679 !-----------------------------------------------------------------------
4680       REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV
4681       REAL, INTENT(IN),  DIMENSION(its:ite,kts:kte*2+1) :: TV,AV
4682 !     REAL, INTENT(IN),  DIMENSION(5040) :: EM3V
4683
4684       REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,&
4685                                             FYO
4686 !     REAL, DIMENSION(5040) :: EM3V
4687
4688 !     EQUIVALENCE (EM3V(1),EM3(1,1))
4689
4690       INTEGER,DIMENSION(its:ite,kts:kte*2+1) ::IT
4691
4692       INTEGER :: LLP1,I,K,MYIS,MYIE ,L
4693       L = kte
4694       LLP1 = 2*L + 1
4695       MYIS=its; MYIE=ite
4696
4697 !---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND
4698 !   K (1-LLP1)
4699
4700       DO 203 K=1,LLP1
4701       DO 203 I=MYIS,MYIE
4702         FXO(I,K)=AINT(TV(I,K)*HP1)
4703         TMP3(I,K)=LOG10(AV(I,K))+H16E1
4704         DT(I,K)=TV(I,K)-TEN*FXO(I,K)
4705         FYO(I,K)=AINT(TMP3(I,K)*TEN)
4706         DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4707 !---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE
4708 !   DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K.
4709         IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1
4710         WW1(I,K)=TEN-DT(I,K)
4711         WW2(I,K)=HP1-DU(I,K)
4712         EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ &
4713                  WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ &
4714                  WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ &
4715                  DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20)
4716 203   CONTINUE
4717
4718   END SUBROUTINE E3V88
4719 !-----------------------------------------------------------------------
4720
4721   SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,             &
4722                        DFSWL,                                         &
4723                        PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3,     &
4724                        NCLDS,KTOPSW,KBTMSW,CAMT,CRR,CTT,              &
4725                        ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND,   &
4726 !                      UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2,                &
4727                        ABCFF,PWTS,                                    &
4728                        H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,     &
4729                        HP816,RRAYAV,GINV,CFCO2,CFO3,                  &
4730                        TWO,H235M3,HP26,H129M2,H75826M4,H1036E2,       &
4731                        H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,    &
4732                        H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON,    &
4733                        ids,ide, jds,jde, kds,kde,                     &
4734                        ims,ime, jms,jme, kms,kme,                     &
4735                        its,ite, jts,jte, kts,kte                      )
4736 !----------------------------------------------------------------------
4737  IMPLICIT NONE
4738 !----------------------------------------------------------------------
4739       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
4740                                     ims,ime, jms,jme, kms,kme ,      &
4741                                     its,ite, jts,jte, kts,kte
4742       REAL,INTENT(IN) :: RRCO2,SSOLAR
4743       REAL,INTENT(IN) :: H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,HP816,RRAYAV,&
4744                          GINV,CFCO2,CFO3
4745       REAL,INTENT(IN) :: TWO,H235M3,HP26,H129M2,H75826M4,H1036E2
4746       REAL,INTENT(IN) :: H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,H323M4,HM1EZ
4747       REAL,INTENT(IN) :: DIFFCTR,O3DIFCTR,FIFTY,RADCON
4748 !----------------------------------------------------------------------
4749       INTEGER, PARAMETER :: NB=12
4750       REAL,    INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: PRESS,CAMT
4751       REAL,    INTENT(IN ),DIMENSION(its:ite,kts:kte) :: RH2O,QO3
4752       REAL,    INTENT(IN ),DIMENSION(its:ite) :: COSZRO,TAUDAR,ALVB,ALVD,ALNB,ALND
4753       INTEGER, INTENT(IN ),DIMENSION(its:ite) :: NCLDS
4754       INTEGER, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) ::KTOPSW,KBTMSW
4755       REAL, INTENT(IN ),DIMENSION(its:ite,NB,kts:kte+1) ::CRR,CTT
4756
4757       REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) ::     &
4758                                        FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL
4759       REAL, INTENT(OUT),DIMENSION(its:ite) :: GDFVB,GDFVD,GDFNB,GDFND
4760       REAL, INTENT(IN), DIMENSION(NB) :: ABCFF,PWTS
4761
4762 !     REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4763 !     REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1)   :: TUCO2,TUO3,TDO3,TDCO2
4764
4765       REAL, DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4766       REAL, DIMENSION(its:ite,kts:kte+1)   :: TUCO2,TUO3,TDO3,TDCO2
4767
4768       REAL, DIMENSION(its:ite,kts:kte*2+2) :: TCO2,TO3
4769       REAL, DIMENSION(its:ite,kts:kte+1) :: PP,DP,PR2,DU,DUCO2,DUO3,UD,TTD
4770       REAL, DIMENSION(its:ite,kts:kte+1) :: UDCO2,UDO3,UR,URCO2,URO3,TTU
4771       REAL, DIMENSION(its:ite,kts:kte+1) :: DFN,UFN
4772       REAL, DIMENSION(its:ite,kts:kte+1) :: XAMT,FF,FFCO2,FFO3,CR,CT
4773       REAL, DIMENSION(its:ite,kts:kte+1) :: PPTOP,DPCLD,TTDB1,TTUB1
4774       REAL, DIMENSION(its:ite,kts:kte+1) :: TDCL1,TUCL1,TDCL2,DFNTRN,  &
4775                                             UFNTRN,TCLU,TCLD,ALFA,ALFAU, &
4776                                             UFNCLU,DFNCLU
4777
4778       REAL, DIMENSION(its:ite,NB) :: DFNTOP
4779       REAL, DIMENSION(its:ite) :: SECZ,TMP1,RRAY,REFL,REFL2,CCMAX
4780
4781 !                    EQUIVALENCE &
4782 !       (UDO3,UO3(its,1),DFNCLU), (URO3,UO3(its,kte+2), UFNCLU) &
4783 !     , (UDCO2,UCO2(its,1),TCLD), (URCO2,UCO2(its,kte+2), TCLU) &
4784 !     , (TDO3 ,TO3(its,1),DFNTRN),(TUO3,TO3(its,kte+2), UFNTRN) &
4785 !     , (TDCO2,TCO2(its,1)      ),(TUCO2,TCO2(its,kte+2)        ) &
4786 !     , (FF   , ALFA ),   (FFCO2 , ALFAU ),   (FFO3  , TTDB1 ) &
4787 !     , (DU   , TTUB1),   (DUCO2 , TUCL1 ),   (DUO3  , TDCL1 ) &
4788 !     , (PR2  , TDCL2)
4789
4790 !                    EQUIVALENCE &
4791 !       (UDO3,DFNCLU), (URO3,UFNCLU) &
4792 !     , (UDCO2,TCLD ), (URCO2,TCLU) &
4793 !     , (TDO3 ,DFNTRN),(TUO3,UFNTRN) &
4794 !!    , (TDCO2,TCO2(its,1)      ),(TUCO2,TCO2(its,kte+2)        ) &
4795 !     , (FF   , ALFA ),   (FFCO2 , ALFAU ),   (FFO3  , TTDB1 ) &
4796 !     , (DU   , TTUB1),   (DUCO2 , TUCL1 ),   (DUO3  , TDCL1 ) &
4797 !     , (PR2  , TDCL2)
4798
4799       INTEGER :: K,I,KP,N,IP,MYIS1,KCLDS,NNCLDS,JTOP,KK,J2,J3,J1
4800       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
4801       REAL    :: DENOM,HTEMP,TEMPF,TEMPG
4802
4803       L=kte
4804       LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
4805       LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
4806       MYIS=its; MYIE=ite
4807       MYIS1=MYIS+1    ! ??
4808
4809       DO 100 I=MYIS,MYIE
4810         SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE)
4811         PP(I,1)   = ZERO
4812         PP(I,LP1) = PRESS(I,LP1)
4813         TMP1(I)  = ONE/PRESS(I,LP1)
4814 100   CONTINUE
4815       DO 110 K=1,LM1
4816       DO 110 I=MYIS,MYIE
4817         PP(I,K+1) = HAF*(PRESS(I,K+1)+PRESS(I,K))
4818 110   CONTINUE
4819       DO 120 K=1,L
4820       DO 120 I=MYIS,MYIE
4821         DP (I,K) = PP(I,K+1)-PP(I,K)
4822         PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1))
4823 120   CONTINUE
4824       DO 130 K=1,L
4825       DO 130 I=MYIS,MYIE
4826         PR2(I,K) = PR2(I,K)*TMP1(I)
4827 130   CONTINUE
4828 !     CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS)
4829       DO 140 N=1,NB
4830       DO 140 IP=MYIS,MYIE
4831         DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N)
4832 140   CONTINUE
4833 !     EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION
4834 !     FOR THE VISIBLE BAND
4835       DO 150 I=MYIS,MYIE
4836         RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
4837         REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ &
4838                   (ONE-ALVD(I)*RRAYAV)
4839 150   CONTINUE
4840       DO 155 I=MYIS,MYIE
4841         RRAY(I) = 0.104/(ONE+4.8*COSZRO(I))
4842         REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ &
4843                   (ONE-ALVD(I)*0.093)
4844 155   CONTINUE
4845 !     CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER
4846 !     IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2.
4847 !     DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3.
4848       DO 160 K=1,L
4849       DO 160 I=MYIS,MYIE
4850         DU   (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K)
4851         DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K)
4852         DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K)
4853 160   CONTINUE
4854 !
4855 !                 CALCULATE CLEAR SKY SW FLUX
4856 !
4857 !     OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE
4858 !     FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD
4859 !     PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING
4860 !     QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3.
4861       DO 200 IP=MYIS,MYIE
4862         UD   (IP,1) = ZERO
4863         UDCO2(IP,1) = ZERO
4864         UDO3 (IP,1) = ZERO
4865 ! SH
4866         UO3  (IP,1) = UDO3 (IP,1)
4867         UCO2 (IP,1) = UDCO2(IP,1)
4868
4869 200   CONTINUE
4870       DO 210 K=2,LP1
4871       DO 210 I=MYIS,MYIE
4872         UD   (I,K) = UD   (I,K-1)+DU   (I,K-1)*SECZ(I)
4873         UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I)
4874         UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I)
4875 ! SH
4876         UO3  (I,K) = UDO3 (I,K)
4877         UCO2 (I,K) = UDCO2(I,K)
4878
4879 210   CONTINUE
4880       DO 220 IP=MYIS,MYIE
4881         UR   (IP,LP1) = UD   (IP,LP1)
4882         URCO2(IP,LP1) = UDCO2(IP,LP1)
4883         URO3 (IP,LP1) = UDO3 (IP,LP1)
4884 ! SH
4885         UO3  (IP,LP1+LP1) = URO3 (IP,LP1)
4886         UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
4887
4888 220   CONTINUE
4889       DO 230 K=L,1,-1
4890       DO 230 IP=MYIS,MYIE
4891         UR   (IP,K) = UR   (IP,K+1)+DU   (IP,K)*DIFFCTR
4892         URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
4893         URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
4894 ! SH
4895         UO3 (IP,LP1+K) = URO3 (IP,K)
4896         UCO2(IP,LP1+K) = URCO2(IP,K)
4897
4898 230   CONTINUE
4899 !     CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED
4900 !     BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED
4901 !     BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX,
4902 !     AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT
4903 !     OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2.
4904 !       SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE
4905 !     VALUES ACTUALLY STORED IN TCO2.
4906       DO 240 K=1,LL
4907       DO 240 I=MYIS,MYIE
4908        TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
4909                              -H75826M4)
4910 240   CONTINUE
4911
4912 ! SH
4913       DO 241 K=1,L
4914       DO 241 I=MYIS,MYIE
4915         TDCO2(I,K+1)=TCO2(I,K+1)
4916 241   CONTINUE
4917       DO 242 K=1,L
4918       DO 242 I=MYIS,MYIE
4919         TUCO2(I,K)=TCO2(I,LP1+K)
4920 242   CONTINUE
4921
4922 !     NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN
4923 !     THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS
4924 !     50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED
4925 !     BY 2. THE TRANSMISSIONS ARE STORED IN TO3.
4926       HTEMP = H1036E2*H1036E2*H1036E2
4927       DO 250 K=1,LL
4928       DO 250 I=MYIS,MYIE
4929         TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
4930                   (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
4931                   H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
4932                   H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
4933 250   CONTINUE
4934
4935 ! SH
4936       DO 251 K=1,L
4937       DO 251 I=MYIS,MYIE
4938         TDO3(I,K+1)=TO3(I,K+1)
4939 251   CONTINUE
4940       DO 252 K=1,L
4941       DO 252 I=MYIS,MYIE
4942         TUO3(I,K)=TO3(I,LP1+K)
4943 252   CONTINUE
4944
4945
4946 !   START FREQUENCY LOOP (ON N) HERE
4947 !
4948 !--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION
4949       DO 260 K=1,L
4950       DO 260 I=MYIS,MYIE
4951         TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
4952         TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
4953         DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1)
4954         UFN(I,K) = TTU(I,K)*TUO3(I,K)
4955 260   CONTINUE
4956       DO 270 I=MYIS,MYIE
4957         DFN(I,1)   = ONE
4958         UFN(I,LP1) = DFN(I,LP1)
4959 270   CONTINUE
4960 !     SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE
4961 !     ATMOSPHERE (DFNTOP(I,1))
4962 !     DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS
4963       DO 280  K=1,LP1
4964       DO 280  I=MYIS,MYIE
4965         DFSWL(I,K) =         DFN(I,K)*DFNTOP(I,1)
4966         UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1)
4967 280   CONTINUE
4968       DO 285 I=MYIS,MYIE
4969         GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I))
4970         GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - &
4971                     (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I))
4972         GDFNB(I) = ZERO
4973         GDFND(I) = ZERO
4974 285   CONTINUE
4975 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
4976 !   AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
4977 !   TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS
4978 !   RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
4979       DO 350 N=2,NB
4980         IF (N.EQ.2) THEN
4981 !   THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
4982 !   THAT OF BAND 1 (SAVED AS TTD,TTU)
4983 !--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION
4984           DO 290 K=1,L
4985           DO 290 I=MYIS,MYIE
4986             DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1)
4987             UFN(I,K) = TTU(I,K)*TUCO2(I,K)
4988 290       CONTINUE
4989         ELSE
4990 !   CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED
4991 !   BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH
4992 !   IS THE SAME FOR ALL INFRARED BANDS.
4993           DO 300 K=1,L
4994           DO 300 I=MYIS,MYIE
4995             DFN(I,K+1)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) &
4996                        *TDCO2(I,K+1)
4997             UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) &
4998                      *TUCO2(I,K)
4999 300       CONTINUE
5000         ENDIF
5001 !---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR
5002 !   ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS.
5003         DO 310 I=MYIS,MYIE
5004           DFN(I,1)   = ONE
5005           UFN(I,LP1) = DFN(I,LP1)
5006 310     CONTINUE
5007 !     SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP
5008 !     AND SUM OVER BANDS
5009         DO 320 K=1,LP1
5010         DO 320 I=MYIS,MYIE
5011           DFSWL(I,K) = DFSWL(I,K) +         DFN(I,K)*DFNTOP(I,N)
5012           UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N)
5013 320     CONTINUE
5014         DO 330 I=MYIS,MYIE
5015           GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N)
5016 330     CONTINUE
5017 350   CONTINUE
5018       DO 360 K=1,LP1
5019       DO 360 I=MYIS,MYIE
5020         FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K)
5021 360   CONTINUE
5022       DO 370 K=1,L
5023       DO 370 I=MYIS,MYIE
5024         HSWL(I,K)=RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K)
5025 370   CONTINUE
5026 !
5027 !---END OF FREQUENCY LOOP (OVER N)
5028 !
5029 !                 CALCULATE CLOUDY SKY SW FLUX
5030 !
5031       KCLDS=NCLDS(MYIS)
5032       DO 400 I=MYIS1,MYIE
5033         KCLDS=MAX(NCLDS(I),KCLDS)
5034 400   CONTINUE
5035         DO 410 K=1,LP1
5036         DO 410 I=MYIS,MYIE
5037           DFSWC(I,K) = DFSWL(I,K)
5038           UFSWC(I,K) = UFSWL(I,K)
5039           FSWC (I,K) = FSWL (I,K)
5040 410     CONTINUE
5041         DO 420 K=1,L
5042         DO 420 I=MYIS,MYIE
5043           HSWC(I,K) = HSWL(I,K)
5044 420     CONTINUE
5045 !*******************************************************************
5046       IF (KCLDS .EQ. 0)  RETURN
5047 !*******************************************************************
5048       DO 430 K=1,LP1
5049       DO 430 I=MYIS,MYIE
5050         XAMT(I,K) = CAMT(I,K)
5051 430   CONTINUE
5052       DO 470 I=MYIS,MYIE
5053         NNCLDS   = NCLDS(I)
5054         CCMAX(I) = ZERO
5055         IF (NNCLDS .LE. 0) GO TO 470
5056         CCMAX(I) = ONE
5057         DO 450 K=1,NNCLDS
5058           CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1))
5059 450     CONTINUE
5060         CCMAX(I) = ONE - CCMAX(I)
5061         IF (CCMAX(I) .GT. ZERO) THEN
5062           DO 460 K=1,NNCLDS
5063             XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I)
5064 460       CONTINUE
5065         END IF
5066 470   CONTINUE
5067       DO 480 K=1,LP1
5068       DO 480 I=MYIS,MYIE
5069         FF   (I,K) = DIFFCTR
5070         FFCO2(I,K) = DIFFCTR
5071         FFO3 (I,K) = O3DIFCTR
5072 480   CONTINUE
5073       DO 490 IP=MYIS,MYIE
5074         JTOP = KTOPSW(IP,NCLDS(IP)+1)
5075       DO 490 K=1,JTOP
5076         FF   (IP,K) = SECZ(IP)
5077         FFCO2(IP,K) = SECZ(IP)
5078         FFO3 (IP,K) = SECZ(IP)
5079 490   CONTINUE
5080       DO 500 I=MYIS,MYIE
5081         RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
5082         REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ &
5083                   (ONE-ALVD(I)*RRAYAV)
5084 500   CONTINUE
5085       DO 510 IP=MYIS,MYIE
5086         UD   (IP,1) = ZERO
5087         UDCO2(IP,1) = ZERO
5088         UDO3 (IP,1) = ZERO
5089 ! SH
5090         UO3  (IP,1) = UDO3 (IP,1)
5091         UCO2 (IP,1) = UDCO2(IP,1)
5092
5093 510   CONTINUE
5094       DO 520 K=2,LP1
5095       DO 520 I=MYIS,MYIE
5096         UD   (I,K) = UD   (I,K-1)+DU   (I,K-1)*FF   (I,K)
5097         UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K)
5098         UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K)
5099 ! SH
5100         UO3 (I,K)  = UDO3 (I,K)
5101         UCO2(I,K)  = UDCO2(I,K)
5102
5103 520   CONTINUE
5104       DO 530 IP=MYIS,MYIE
5105         UR   (IP,LP1) = UD   (IP,LP1)
5106         URCO2(IP,LP1) = UDCO2(IP,LP1)
5107         URO3 (IP,LP1) = UDO3 (IP,LP1)
5108 ! SH
5109         UO3  (IP,LP1+LP1) = URO3 (IP,LP1)
5110         UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
5111
5112 530   CONTINUE
5113       DO 540 K=L,1,-1
5114       DO 540 IP=MYIS,MYIE
5115         UR   (IP,K) = UR   (IP,K+1)+DU   (IP,K)*DIFFCTR
5116         URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
5117         URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
5118 ! SH
5119         UO3 (IP,LP1+K) = URO3 (IP,K)
5120         UCO2(IP,LP1+K) = URCO2(IP,K)
5121
5122 540   CONTINUE
5123       DO 550 K=1,LL
5124       DO 550 I=MYIS,MYIE
5125         TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
5126                               -H75826M4)
5127 550   CONTINUE
5128 ! SH
5129       DO 551 K=1,L
5130       DO 551 I=MYIS,MYIE
5131         TDCO2(I,K+1)=TCO2(I,K+1)
5132 551   CONTINUE
5133       DO 552 K=1,L
5134       DO 552 I=MYIS,MYIE
5135         TUCO2(I,K)=TCO2(I,LP1+K)
5136 552   CONTINUE
5137
5138       DO 560 K=1,LL
5139       DO 560 I=MYIS,MYIE
5140         TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
5141                  (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
5142                 H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
5143                 H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
5144 560   CONTINUE
5145 ! SH
5146       DO 561 K=1,L
5147       DO 561 I=MYIS,MYIE
5148         TDO3(I,K+1)=TO3(I,K+1)
5149 561   CONTINUE
5150       DO 562 K=1,L
5151       DO 562 I=MYIS,MYIE
5152         TUO3(I,K)=TO3(I,LP1+K)
5153 562   CONTINUE
5154
5155 !********************************************************************
5156 !---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN
5157 !   BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!).
5158 !********************************************************************
5159       DO 570 I=MYIS,MYIE
5160         CR(I,1) = REFL(I)
5161 570   CONTINUE
5162 !***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR
5163 !   REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND
5164 !---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES
5165 !   EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE).
5166       DO 581 I=MYIS,MYIE
5167       KCLDS=NCLDS(I)
5168       IF(KCLDS.EQ.0) GO TO 581
5169       DO 580 KK=2,KCLDS+1
5170         CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK)
5171         CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK)
5172 580   CONTINUE
5173 581   CONTINUE
5174 !---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF
5175 !   "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED
5176 !   LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL
5177 !   FREQUENCY BANDS.
5178       DO 591 I=MYIS,MYIE
5179       KCLDS=NCLDS(I)
5180       IF(KCLDS.EQ.0) GO TO 591
5181       DO 590 KK=1,KCLDS
5182         IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN
5183            PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1))
5184            DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1)))
5185         ENDIF
5186 590   CONTINUE
5187 591   CONTINUE
5188       DO 600 K=1,L
5189       DO 600 I=MYIS,MYIE
5190         TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
5191         TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
5192         TTD  (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1)
5193         TTU  (I,K) = TTUB1(I,K)*TUO3(I,K)
5194 600   CONTINUE
5195       DO 610 I=MYIS,MYIE
5196         TTD(I,1)   = ONE
5197         TTU(I,LP1) = TTD(I,LP1)
5198 610   CONTINUE
5199 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5200 !   TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5201 !   EACH BAND N. THE REQUIRED QUANTITIES ARE:
5202 !      TTD(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
5203 !      TTU(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
5204 !      TTD(I,KBTMSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
5205 !      AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE
5206 !      STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY,
5207 !      AS THEY HAVE MULTIPLE USE IN THE PGM.
5208 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5209       DO 620 I=MYIS,MYIE
5210         TDCL1 (I,1) = TTD(I,LP1)
5211         TUCL1 (I,1) = TTU(I,LP1)
5212         TDCL2 (I,1) = TDCL1(I,1)
5213         DFNTRN(I,1) = ONE/TDCL1(I,1)
5214         UFNTRN(I,1) = DFNTRN(I,1)
5215 620   CONTINUE
5216       DO 631 I=MYIS,MYIE
5217       KCLDS=NCLDS(I)
5218       IF(KCLDS.EQ.0) GO TO 631
5219       DO 630 KK=2,KCLDS+1
5220         TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5221         TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5222         TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5223 630   CONTINUE
5224 631   CONTINUE
5225 !---COMPUTE INVERSES
5226       DO 641 I=MYIS,MYIE
5227       KCLDS=NCLDS(I)
5228       IF(KCLDS.EQ.0) GO TO 641
5229 ! SH
5230       DO 640 KK=2,KCLDS+1
5231         DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5232         UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5233 640   CONTINUE
5234 641   CONTINUE
5235 !---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE
5236 !   TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS
5237 !   QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY
5238 !   FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH
5239 !   ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K).
5240       DO 651 I=MYIS,MYIE
5241       KCLDS=NCLDS(I)
5242       IF(KCLDS.EQ.0) GO TO 651
5243       DO 650 KK=1,KCLDS
5244         TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5245         TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5246 650   CONTINUE
5247 651   CONTINUE
5248 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5249 !   COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5250 !   FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5251 !   THE CLOUD IN QUESTION.
5252 !---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION
5253       DO 660 I=MYIS,MYIE
5254       KCLDS=NCLDS(I)
5255       IF(KCLDS.EQ.0) GO TO 660
5256         ALFA (I,1)=CR(I,1)
5257         ALFAU(I,1)=ZERO
5258 660   CONTINUE
5259 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5260       DO 671 I=MYIS,MYIE
5261       KCLDS=NCLDS(I)
5262       IF(KCLDS.EQ.0) GO TO 671
5263       DO 670 KK=2,KCLDS+1
5264         ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ &
5265               (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5266         ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK)
5267 670   CONTINUE
5268 671   CONTINUE
5269 !     CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5270 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5271 !   OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5272 !   AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST
5273 !   CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5274 !   HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5275 !   EQUALS ALFA. THIS IS ALSO CORRECT.
5276       DO 680 I=MYIS,MYIE
5277       KCLDS=NCLDS(I)
5278       IF(KCLDS.EQ.0) GO TO 680
5279         UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5280         DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5281 680   CONTINUE
5282 !---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED
5283 !  ABOVE
5284       DO 691 I=MYIS,MYIE
5285       KCLDS=NCLDS(I)
5286       IF(KCLDS.EQ.0) GO TO 691
5287       DO 690 KK=KCLDS,1,-1
5288         UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* &
5289                        TCLU(I,KK))
5290         DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK)
5291 690   CONTINUE
5292 691   CONTINUE
5293       DO 701 I=MYIS,MYIE
5294       KCLDS=NCLDS(I)
5295       IF(KCLDS.EQ.0) GO TO 701
5296       DO 700 KK=1,KCLDS+1
5297         UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5298         DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5299 700   CONTINUE
5300 701   CONTINUE
5301 !---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD)
5302       DO 720 I=MYIS,MYIE
5303       KCLDS=NCLDS(I)
5304       IF(KCLDS.EQ.0) GO TO 720
5305         J2=KBTMSW(I,2)
5306         DO 710 K=J2,LP1
5307           UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5308           DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5309 710     CONTINUE
5310 720   CONTINUE
5311 !---REMAINING LEVELS (IF ANY!)
5312       DO 760 I=MYIS,MYIE
5313       KCLDS=NCLDS(I)
5314       IF(KCLDS.EQ.0) GO TO 760
5315       DO 755 KK=2,KCLDS+1
5316         J1=KTOPSW(I,KK)
5317         J2=KBTMSW(I,KK+1)
5318         IF (J1.EQ.1) GO TO 755
5319         DO 730 K=J2,J1
5320           UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5321           DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5322 730     CONTINUE
5323 !---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD
5324 !   LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY
5325 !   TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX).
5326         J3=KBTMSW(I,KK)
5327         IF ((J3-J1).GT.1) THEN
5328           TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5329           TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5330           DO 740 K=J1+1,J3-1
5331             UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5332             DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5333 740       CONTINUE
5334         ENDIF
5335 755   CONTINUE
5336 760   CONTINUE
5337       DO 770 I=MYIS,MYIE
5338       KCLDS=NCLDS(I)
5339       IF(KCLDS.EQ.0) GO TO 770
5340       DO 771 K=1,LP1
5341         DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1)
5342         UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1)
5343 771   CONTINUE
5344 770   CONTINUE
5345       DO 780 I=MYIS,MYIE
5346       KCLDS=NCLDS(I)
5347       IF(KCLDS.EQ.0) GO TO 780
5348         TMP1(I) = ONE - CCMAX(I)
5349         GDFVB(I) = TMP1(I)*GDFVB(I)
5350         GDFNB(I) = TMP1(I)*GDFNB(I)
5351         GDFVD(I) = TMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1)
5352 780   CONTINUE
5353 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
5354 !   AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
5355 !   TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS
5356 !   RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
5357 !
5358       DO 1000 N=2,NB
5359 !YH93
5360         DO 791 I=MYIS,MYIE
5361         KCLDS=NCLDS(I)
5362         IF(KCLDS.EQ.0) GO TO 791
5363         DO 790 K=1,KCLDS+1
5364           CR(I,K) = CRR(I,N,K)*XAMT(I,K)
5365           CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K)
5366 790     CONTINUE
5367 791     CONTINUE
5368 !YH93
5369         IF (N.EQ.2) THEN
5370 !   THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
5371 !   THAT OF BAND 1 (SAVED AS TTDB1,TTUB1)
5372           DO 800 I=MYIS,MYIE
5373         KCLDS=NCLDS(I)
5374         IF(KCLDS.EQ.0) GO TO 800
5375         DO 801 KK=2,LP1
5376             TTD(I,KK) = TTDB1(I,KK)*TDCO2(I,KK)
5377 801     CONTINUE
5378         DO 802 KK=1,L
5379             TTU(I,KK) = TTUB1(I,KK)*TUCO2(I,KK)
5380 802     CONTINUE
5381 800       CONTINUE
5382         ELSE
5383           DO 810 I=MYIS,MYIE
5384         KCLDS=NCLDS(I)
5385         IF(KCLDS.EQ.0) GO TO 810
5386         DO 811 KK=2,LP1
5387             TTD(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,KK))) &
5388                      * TDCO2(I,KK)
5389 811     CONTINUE
5390         DO 812 KK=1,L
5391             TTU(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,KK))) &
5392                      * TUCO2(I,KK)
5393 812     CONTINUE
5394 810       CONTINUE
5395         ENDIF
5396 !---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR
5397 !   ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS.
5398         DO 820 I=MYIS,MYIE
5399         KCLDS=NCLDS(I)
5400         IF(KCLDS.EQ.0) GO TO 820
5401           TTU(I,LP1) = TTD(I,LP1)
5402           TTD(I,1)   = ONE
5403 820     CONTINUE
5404 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5405 !   TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5406 !   EACH BAND N. THE REQUIRED QUANTITIES ARE:
5407 !      TTD(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
5408 !      TTD(I,KBTMSW(I,K),N)  K RUNS FROM 2 TO NCLDS(I)+1:
5409 !      TTU(I,KTOPSW(I,K),N)  K RUNS FROM 1 TO NCLDS(I)+1:
5410 !      AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED
5411 !      IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS
5412 !      THEY HAVE MULTIPLE USE IN THE PGM.
5413 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5414         DO 830 I=MYIS,MYIE
5415         KCLDS=NCLDS(I)
5416         IF(KCLDS.EQ.0) GO TO 830
5417           TDCL1 (I,1) = TTD(I,LP1)
5418           TUCL1 (I,1) = TTU(I,LP1)
5419           TDCL2 (I,1) = TDCL1(I,1)
5420           DFNTRN(I,1) = ONE/TDCL1(I,1)
5421           UFNTRN(I,1) = DFNTRN(I,1)
5422 830     CONTINUE
5423         DO 841 I=MYIS,MYIE
5424         KCLDS=NCLDS(I)
5425         IF(KCLDS.EQ.0) GO TO 841
5426         DO 840 KK=2,KCLDS+1
5427           TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5428           TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5429           TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5430 840     CONTINUE
5431 841     CONTINUE
5432         DO 851 I=MYIS,MYIE
5433         KCLDS=NCLDS(I)
5434         IF(KCLDS.EQ.0) GO TO 851
5435         DO 850 KK=2,KCLDS+1
5436           DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5437           UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5438 850     CONTINUE
5439 851     CONTINUE
5440         DO 861 I=MYIS,MYIE
5441         KCLDS=NCLDS(I)
5442         IF(KCLDS.EQ.0) GO TO 861
5443         DO 860 KK=1,KCLDS
5444           TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5445           TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5446 860     CONTINUE
5447 861     CONTINUE
5448 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5449 !   COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5450 !   FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5451 !   THE CLOUD IN QUESTION.
5452         DO 870 I=MYIS,MYIE
5453         KCLDS=NCLDS(I)
5454         IF(KCLDS.EQ.0) GO TO 870
5455           ALFA (I,1) = CR(I,1)
5456           ALFAU(I,1) = ZERO
5457 870     CONTINUE
5458 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5459         DO 881 I=MYIS,MYIE
5460         KCLDS=NCLDS(I)
5461         IF(KCLDS.EQ.0) GO TO 881
5462         DO 880 KK=2,KCLDS+1
5463           ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - &
5464                    TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5465           ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK)
5466 880     CONTINUE
5467 881     CONTINUE
5468 !     CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5469 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5470 !   OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5471 !   AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST
5472 !   CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5473 !   HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5474 !   EQUALS ALFA. THIS IS ALSO CORRECT.
5475         DO 890 I=MYIS,MYIE
5476         KCLDS=NCLDS(I)
5477         IF(KCLDS.EQ.0) GO TO 890
5478           UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5479           DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5480 890     CONTINUE
5481         DO 901 I=MYIS,MYIE
5482         KCLDS=NCLDS(I)
5483         IF(KCLDS.EQ.0) GO TO 901
5484         DO 900 KK=KCLDS,1,-1
5485 !
5486 !***  ACCOUNT FOR UNREALISTICALLY SMALL CLOUD AMOUNT
5487 !
5488         DENOM=ALFA(I,KK+1)*TCLU(I,KK)
5489         IF(DENOM.GT.RTHRESH)THEN
5490           UFNCLU(I,KK)=UFNCLU(I,KK+1)*ALFAU(I,KK+1)/DENOM
5491         ELSE
5492           UFNCLU(I,KK)=0.
5493         ENDIF
5494         IF(ALFA(I,KK).GT.RTHRESH)THEN
5495           DFNCLU(I,KK)=UFNCLU(I,KK)/ALFA(I,KK)
5496         ELSE
5497           DFNCLU(I,KK)=0.
5498         ENDIF
5499 900     CONTINUE
5500 901     CONTINUE
5501 !     NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS
5502         DO 911 I=MYIS,MYIE
5503         KCLDS=NCLDS(I)
5504         IF(KCLDS.EQ.0) GO TO 911
5505         DO 910 KK=1,KCLDS+1
5506           UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5507           DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5508 910     CONTINUE
5509 911     CONTINUE
5510         DO 930 I=MYIS,MYIE
5511         KCLDS=NCLDS(I)
5512         IF(KCLDS.EQ.0) GO TO 930
5513           J2=KBTMSW(I,2)
5514           DO 920 K=J2,LP1
5515             UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5516             DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5517 920       CONTINUE
5518 930     CONTINUE
5519         DO 970  I=MYIS,MYIE
5520         KCLDS=NCLDS(I)
5521         IF(KCLDS.EQ.0) GO TO 970
5522         DO 965  KK=2,KCLDS+1
5523           J1 = KTOPSW(I,KK)
5524           J2 = KBTMSW(I,KK+1)
5525           IF (J1.EQ.1) GO TO 965
5526           DO 940 K=J2,J1
5527             UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5528             DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5529 940       CONTINUE
5530           J3 = KBTMSW(I,KK)
5531           IF ((J3-J1).GT.1) THEN
5532             TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5533             TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5534             DO 950 K=J1+1,J3-1
5535               UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5536               DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5537 950         CONTINUE
5538           ENDIF
5539 965     CONTINUE
5540 970     CONTINUE
5541         DO 980 I=MYIS,MYIE
5542         KCLDS=NCLDS(I)
5543         IF(KCLDS.EQ.0) GO TO 980
5544         DO 981 K=1,LP1
5545           DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N)
5546           UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N)
5547 981     CONTINUE
5548 980     CONTINUE
5549         DO 990 I=MYIS,MYIE
5550         KCLDS=NCLDS(I)
5551         IF(KCLDS.EQ.0) GO TO 990
5552           GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N)
5553 990     CONTINUE
5554 1000  CONTINUE
5555       DO 1100 I=MYIS,MYIE
5556         KCLDS=NCLDS(I)
5557         IF(KCLDS.EQ.0) GO TO 1100
5558       DO 1101 K=1,LP1
5559         DFSWC(I,K) = TMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K)
5560         UFSWC(I,K) = TMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K)
5561 1101  CONTINUE
5562 1100  CONTINUE
5563       DO 1200 I=MYIS,MYIE
5564         KCLDS=NCLDS(I)
5565         IF(KCLDS.EQ.0) GO TO 1200
5566         DO 1201 KK=1,LP1
5567         FSWC(I,KK) = UFSWC(I,KK)-DFSWC(I,KK)
5568 1201    CONTINUE
5569 1200  CONTINUE
5570       DO 1250 I=MYIS,MYIE
5571         KCLDS=NCLDS(I)
5572         IF(KCLDS.EQ.0) GO TO 1250
5573         DO 1251 KK=1, L
5574         HSWC(I,KK) = RADCON*(FSWC(I,KK+1)-FSWC(I,KK))/DP(I,KK)
5575 1251    CONTINUE
5576 1250  CONTINUE
5577
5578   END SUBROUTINE SWR93
5579 !-----------------------------------------------------------------------
5580
5581   SUBROUTINE RADFS &
5582
5583 !     *****************************************************************
5584 !     *                                                               *
5585 !     *   THE INTERNAL DRIVE FOR GFDL RADIATION                       *
5586 !     *   THIS SUBROUTINE WAS FROM Y.H AND K.A.C (1993)               *
5587 !     *   AND MODIFIED BY Q. ZHAO FOR USE IN THE ETA MODEL            *
5588 !     *                   NOV. 18,  1993                              *
5589 !     *                                                               *
5590 !     * UPDATE: THIS SUBROUTINE WAS MODIFIED TO USE CLOUD FRACTION    *
5591 !     *         ON EACH MODEL LAYER.                                  *
5592 !     *                                QINGYUN  ZHAO   95-3-22        *
5593 !     *****************************************************************
5594 !***
5595 !***  REQUIRED INPUT:
5596 !***
5597                 (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
5598 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
5599       ,          CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL &
5600       ,          COSZRO,TAUDAR,IBEG &
5601       ,          KO3,KALB &
5602       ,          ITIMSW,ITIMLW &
5603 !***************************************************************************
5604 !*              IX IS THE LENGTH OF A ROW IN THE DOMAIN
5605 !
5606 !*   QS(IX):            THE SURFACE PRESSURE (PA)
5607 !*   PP(IX,L):          THE MIDLAYER PRESSURES (PA)  (L IS THE VERT. DIMEN.)
5608 !*   PPI(IX,LP1)        THE INTERFACE PRESSURES (PA)
5609 !*   QQH2O(IX,L):       THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG)
5610 !*   TT(IX,L):          THE MIDLAYER TEMPERATURE (K)
5611 !*   O3QO3(IX,L):       THE MIDLAYER OZONE MIXING RATIO
5612 !*   TSFC(IX):          THE SKIN TEMP. (K); NEGATIVE OVER WATER
5613 !*   SLMSK(IX):         THE SEA MASK (LAND=0,SEA=1)
5614 !*   ALBEDO(IX):        THE SURFACE ALBEDO (EXPRESSED AS A FRACTION)
5615 !*   XLAT(IX):          THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES
5616 !*                              (N.H.> 0)
5617 !* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5618 !*                      LAYER=1:SURFACE
5619 !*                      LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON
5620 !*   CAMT(IX,LP1):      CLOUD FRACTION OF EACH CLOUD LAYER
5621 !*   ITYP(IX,LP1):      CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE)
5622 !*   KTOP(IX,LP1):      HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL)
5623 !*   KBTM(IX,LP1):      BOTTOM OF EACH CLOUD LAYER
5624 !*   NCLDS(IX):         NUMBER OF CLOUD LAYERS
5625 !*   EMCLD(IX,LP1):     CLOUD EMISSIVITY
5626 !*   RRCL(IX,NB,LP1)    CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS
5627 !*   TTCL(IX,NB,LP1)    CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS
5628 !* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5629 !*
5630 !*   COSZRO(IX):        THE COSINE OF THE SOLAR ZENITH ANGLE
5631 !*   TAUDAR:            =1.0
5632 !*   IBEG:              =1
5633 !*   KO3:               =1 ( READ IN THE QZONE DATA)
5634 !*   KALB:              =0
5635 !*   ITIMSW:            =1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED)
5636 !*   ITIMLW:            =1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED)
5637 !************************************************************************
5638 !***
5639 !*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL
5640 !***
5641       ,          SWH,HLW &
5642       ,          FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC  &
5643       ,          ids,ide, jds,jde, kds,kde                      &
5644       ,          ims,ime, jms,jme, kms,kme                      &
5645 ! begin debugging radiation
5646       ,          its,ite, jts,jte, kts,kte                      &
5647       ,          imd,jmd, Jndx                                  )
5648 ! end debugging radiation
5649 !************************************************************************
5650 !*    SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S.
5651 !*         SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5652 !*    HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S.
5653 !*         HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5654 !*  FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5655 !*         FLWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5656 !*  FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5657 !*         FSWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5658 !*  FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5659 !*         FSWDN IS A REAL ARRAY DIMENSIONED (NCOL).
5660 !* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5661 !*         FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5662 !* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5663 !*         FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5664 !* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5665 !*         FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5666 !* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5667 !*         FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5668 !* FSWDNSC: CLEAR-SKY DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5669 !*         FSWDNSC IS A REAL ARRAY DIMENSIONED (NCOL).
5670 !************************************************************************
5671 !***
5672 !*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL
5673 !***
5674 !----------------------------------------------------------------------
5675  IMPLICIT NONE
5676 !----------------------------------------------------------------------
5677 !INTEGER, PARAMETER :: NBLY=15
5678  INTEGER, PARAMETER :: NB=12
5679  INTEGER, PARAMETER :: NBLX=47
5680  INTEGER , PARAMETER:: NBLW = 163
5681
5682  REAL,PARAMETER ::      AMOLWT=28.9644
5683  REAL,PARAMETER ::      CSUBP=1.00484E7
5684  REAL,PARAMETER ::      DIFFCTR=1.66
5685  REAL,PARAMETER ::      G=980.665
5686  REAL,PARAMETER ::      GINV=1./G
5687  REAL,PARAMETER ::      GRAVDR=980.0
5688  REAL,PARAMETER ::      O3DIFCTR=1.90
5689  REAL,PARAMETER ::      P0=1013250.
5690  REAL,PARAMETER ::      P0INV=1./P0
5691  REAL,PARAMETER ::      GP0INV=GINV*P0INV
5692  REAL,PARAMETER ::      P0XZP2=202649.902
5693  REAL,PARAMETER ::      P0XZP8=810600.098
5694  REAL,PARAMETER ::      P0X2=2.*1013250.
5695  REAL,PARAMETER ::      RADCON=8.427
5696  REAL,PARAMETER ::      RADCON1=1./8.427
5697  REAL,PARAMETER ::      RATCO2MW=1.519449738
5698  REAL,PARAMETER ::      RATH2OMW=.622
5699  REAL,PARAMETER ::      RGAS=8.3142E7
5700  REAL,PARAMETER ::      RGASSP=8.31432E7
5701  REAL,PARAMETER ::      SECPDA=8.64E4
5702 !
5703 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
5704 !        ARRANGED IN DECREASING ORDER
5705  REAL,PARAMETER ::      HUNDRED=100.
5706  REAL,PARAMETER ::      HNINETY=90.
5707  REAL,PARAMETER ::      HNINE=9.0
5708  REAL,PARAMETER ::      SIXTY=60.
5709  REAL,PARAMETER ::      FIFTY=50.
5710  REAL,PARAMETER ::      TEN=10.
5711  REAL,PARAMETER ::      EIGHT=8.
5712  REAL,PARAMETER ::      FIVE=5.
5713  REAL,PARAMETER ::      FOUR=4.
5714  REAL,PARAMETER ::      THREE=3.
5715  REAL,PARAMETER ::      TWO=2.
5716  REAL,PARAMETER ::      ONE=1.
5717  REAL,PARAMETER ::      HAF=0.5
5718  REAL,PARAMETER ::      QUARTR=0.25
5719  REAL,PARAMETER ::      ZERO=0.
5720 !
5721 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
5722 !       ARRANGED IN DECREASING ORDER
5723  REAL,PARAMETER ::      H83E26=8.3E26
5724  REAL,PARAMETER ::      H71E26=7.1E26
5725  REAL,PARAMETER ::      H1E15=1.E15
5726  REAL,PARAMETER ::      H1E13=1.E13
5727  REAL,PARAMETER ::      H1E11=1.E11
5728  REAL,PARAMETER ::      H1E8=1.E8
5729  REAL,PARAMETER ::      H2E6=2.0E6
5730  REAL,PARAMETER ::      H1E6=1.0E6
5731  REAL,PARAMETER ::      H69766E5=6.97667E5
5732  REAL,PARAMETER ::      H4E5=4.E5
5733  REAL,PARAMETER ::      H165E5=1.65E5
5734  REAL,PARAMETER ::      H5725E4=57250.
5735  REAL,PARAMETER ::      H488E4=48800.
5736  REAL,PARAMETER ::      H1E4=1.E4
5737  REAL,PARAMETER ::      H24E3=2400.
5738  REAL,PARAMETER ::      H20788E3=2078.8
5739  REAL,PARAMETER ::      H2075E3=2075.
5740  REAL,PARAMETER ::      H18E3=1800.
5741  REAL,PARAMETER ::      H1224E3=1224.
5742  REAL,PARAMETER ::      H67390E2=673.9057
5743  REAL,PARAMETER ::      H5E2=500.
5744  REAL,PARAMETER ::      H3082E2=308.2
5745  REAL,PARAMETER ::      H3E2=300.
5746  REAL,PARAMETER ::      H2945E2=294.5
5747  REAL,PARAMETER ::      H29316E2=293.16
5748  REAL,PARAMETER ::      H26E2=260.0
5749  REAL,PARAMETER ::      H25E2=250.
5750  REAL,PARAMETER ::      H23E2=230.
5751  REAL,PARAMETER ::      H2E2=200.0
5752  REAL,PARAMETER ::      H15E2=150.
5753  REAL,PARAMETER ::      H1386E2=138.6
5754  REAL,PARAMETER ::      H1036E2=103.6
5755  REAL,PARAMETER ::      H8121E1=81.21
5756  REAL,PARAMETER ::      H35E1=35.
5757  REAL,PARAMETER ::      H3116E1=31.16
5758  REAL,PARAMETER ::      H28E1=28.
5759  REAL,PARAMETER ::      H181E1=18.1
5760  REAL,PARAMETER ::      H18E1=18.
5761  REAL,PARAMETER ::      H161E1=16.1
5762  REAL,PARAMETER ::      H16E1=16.
5763  REAL,PARAMETER ::      H1226E1=12.26
5764  REAL,PARAMETER ::      H9P94=9.94
5765  REAL,PARAMETER ::      H6P08108=6.081081081
5766  REAL,PARAMETER ::      H3P6=3.6
5767  REAL,PARAMETER ::      H3P5=3.5
5768  REAL,PARAMETER ::      H2P9=2.9
5769  REAL,PARAMETER ::      H2P8=2.8
5770  REAL,PARAMETER ::      H2P5=2.5
5771  REAL,PARAMETER ::      H1P8=1.8
5772  REAL,PARAMETER ::      H1P4387=1.4387
5773  REAL,PARAMETER ::      H1P41819=1.418191
5774  REAL,PARAMETER ::      H1P4=1.4
5775  REAL,PARAMETER ::      H1P25892=1.258925411
5776  REAL,PARAMETER ::      H1P082=1.082
5777  REAL,PARAMETER ::      HP816=0.816
5778  REAL,PARAMETER ::      HP805=0.805
5779  REAL,PARAMETER ::      HP8=0.8
5780  REAL,PARAMETER ::      HP60241=0.60241
5781  REAL,PARAMETER ::      HP602409=0.60240964
5782  REAL,PARAMETER ::      HP6=0.6
5783  REAL,PARAMETER ::      HP526315=0.52631579
5784  REAL,PARAMETER ::      HP518=0.518
5785  REAL,PARAMETER ::      HP5048=0.5048
5786  REAL,PARAMETER ::      HP3795=0.3795
5787  REAL,PARAMETER ::      HP369=0.369
5788  REAL,PARAMETER ::      HP26=0.26
5789  REAL,PARAMETER ::      HP228=0.228
5790  REAL,PARAMETER ::      HP219=0.219
5791  REAL,PARAMETER ::      HP166666=.166666
5792  REAL,PARAMETER ::      HP144=0.144
5793  REAL,PARAMETER ::      HP118666=0.118666192
5794  REAL,PARAMETER ::      HP1=0.1
5795 !        (NEGATIVE EXPONENTIALS BEGIN HERE)
5796  REAL,PARAMETER ::      H658M2=0.0658
5797  REAL,PARAMETER ::      H625M2=0.0625
5798  REAL,PARAMETER ::      H44871M2=4.4871E-2
5799  REAL,PARAMETER ::      H44194M2=.044194
5800  REAL,PARAMETER ::      H42M2=0.042
5801  REAL,PARAMETER ::      H41666M2=0.0416666
5802  REAL,PARAMETER ::      H28571M2=.02857142857
5803  REAL,PARAMETER ::      H2118M2=0.02118
5804  REAL,PARAMETER ::      H129M2=0.0129
5805  REAL,PARAMETER ::      H1M2=.01
5806  REAL,PARAMETER ::      H559M3=5.59E-3
5807  REAL,PARAMETER ::      H3M3=0.003
5808  REAL,PARAMETER ::      H235M3=2.35E-3
5809  REAL,PARAMETER ::      H1M3=1.0E-3
5810  REAL,PARAMETER ::      H987M4=9.87E-4
5811  REAL,PARAMETER ::      H323M4=0.000323
5812  REAL,PARAMETER ::      H3M4=0.0003
5813  REAL,PARAMETER ::      H285M4=2.85E-4
5814  REAL,PARAMETER ::      H1M4=0.0001
5815  REAL,PARAMETER ::      H75826M4=7.58265E-4
5816  REAL,PARAMETER ::      H6938M5=6.938E-5
5817  REAL,PARAMETER ::      H394M5=3.94E-5
5818  REAL,PARAMETER ::      H37412M5=3.7412E-5
5819  REAL,PARAMETER ::      H15M5=1.5E-5
5820  REAL,PARAMETER ::      H1439M5=1.439E-5
5821  REAL,PARAMETER ::      H128M5=1.28E-5
5822  REAL,PARAMETER ::      H102M5=1.02E-5
5823  REAL,PARAMETER ::      H1M5=1.0E-5
5824  REAL,PARAMETER ::      H7M6=7.E-6
5825  REAL,PARAMETER ::      H4999M6=4.999E-6
5826  REAL,PARAMETER ::      H451M6=4.51E-6
5827  REAL,PARAMETER ::      H25452M6=2.5452E-6
5828  REAL,PARAMETER ::      H1M6=1.E-6
5829  REAL,PARAMETER ::      H391M7=3.91E-7
5830  REAL,PARAMETER ::      H1174M7=1.174E-7
5831  REAL,PARAMETER ::      H8725M8=8.725E-8
5832  REAL,PARAMETER ::      H327M8=3.27E-8
5833  REAL,PARAMETER ::      H257M8=2.57E-8
5834  REAL,PARAMETER ::      H1M8=1.0E-8
5835  REAL,PARAMETER ::      H23M10=2.3E-10
5836  REAL,PARAMETER ::      H14M10=1.4E-10
5837  REAL,PARAMETER ::      H11M10=1.1E-10
5838  REAL,PARAMETER ::      H1M10=1.E-10
5839  REAL,PARAMETER ::      H83M11=8.3E-11
5840  REAL,PARAMETER ::      H82M11=8.2E-11
5841  REAL,PARAMETER ::      H8M11=8.E-11
5842  REAL,PARAMETER ::      H77M11=7.7E-11
5843  REAL,PARAMETER ::      H72M11=7.2E-11
5844  REAL,PARAMETER ::      H53M11=5.3E-11
5845  REAL,PARAMETER ::      H48M11=4.8E-11
5846  REAL,PARAMETER ::      H44M11=4.4E-11
5847  REAL,PARAMETER ::      H42M11=4.2E-11
5848  REAL,PARAMETER ::      H37M11=3.7E-11
5849  REAL,PARAMETER ::      H35M11=3.5E-11
5850  REAL,PARAMETER ::      H32M11=3.2E-11
5851  REAL,PARAMETER ::      H3M11=3.0E-11
5852  REAL,PARAMETER ::      H28M11=2.8E-11
5853  REAL,PARAMETER ::      H24M11=2.4E-11
5854  REAL,PARAMETER ::      H23M11=2.3E-11
5855  REAL,PARAMETER ::      H2M11=2.E-11
5856  REAL,PARAMETER ::      H18M11=1.8E-11
5857  REAL,PARAMETER ::      H15M11=1.5E-11
5858  REAL,PARAMETER ::      H14M11=1.4E-11
5859  REAL,PARAMETER ::      H114M11=1.14E-11
5860  REAL,PARAMETER ::      H11M11=1.1E-11
5861  REAL,PARAMETER ::      H1M11=1.E-11
5862  REAL,PARAMETER ::      H96M12=9.6E-12
5863  REAL,PARAMETER ::      H93M12=9.3E-12
5864  REAL,PARAMETER ::      H77M12=7.7E-12
5865  REAL,PARAMETER ::      H74M12=7.4E-12
5866  REAL,PARAMETER ::      H65M12=6.5E-12
5867  REAL,PARAMETER ::      H62M12=6.2E-12
5868  REAL,PARAMETER ::      H6M12=6.E-12
5869  REAL,PARAMETER ::      H45M12=4.5E-12
5870  REAL,PARAMETER ::      H44M12=4.4E-12
5871  REAL,PARAMETER ::      H4M12=4.E-12
5872  REAL,PARAMETER ::      H38M12=3.8E-12
5873  REAL,PARAMETER ::      H37M12=3.7E-12
5874  REAL,PARAMETER ::      H3M12=3.E-12
5875  REAL,PARAMETER ::      H29M12=2.9E-12
5876  REAL,PARAMETER ::      H28M12=2.8E-12
5877  REAL,PARAMETER ::      H24M12=2.4E-12
5878  REAL,PARAMETER ::      H21M12=2.1E-12
5879  REAL,PARAMETER ::      H16M12=1.6E-12
5880  REAL,PARAMETER ::      H14M12=1.4E-12
5881  REAL,PARAMETER ::      H12M12=1.2E-12
5882  REAL,PARAMETER ::      H8M13=8.E-13
5883  REAL,PARAMETER ::      H46M13=4.6E-13
5884  REAL,PARAMETER ::      H36M13=3.6E-13
5885  REAL,PARAMETER ::      H135M13=1.35E-13
5886  REAL,PARAMETER ::      H12M13=1.2E-13
5887  REAL,PARAMETER ::      H1M13=1.E-13
5888  REAL,PARAMETER ::      H3M14=3.E-14
5889  REAL,PARAMETER ::      H15M14=1.5E-14
5890  REAL,PARAMETER ::      H14M14=1.4E-14
5891 !
5892 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
5893 !          ARRANGED IN DESCENDING ORDER
5894  REAL,PARAMETER ::      HM2M2=-.02
5895  REAL,PARAMETER ::      HM6666M2=-.066667
5896  REAL,PARAMETER ::      HMP5=-0.5
5897  REAL,PARAMETER ::      HMP575=-0.575
5898  REAL,PARAMETER ::      HMP66667=-.66667
5899  REAL,PARAMETER ::      HMP805=-0.805
5900  REAL,PARAMETER ::      HM1EZ=-1.
5901  REAL,PARAMETER ::      HM13EZ=-1.3
5902  REAL,PARAMETER ::      HM19EZ=-1.9
5903  REAL,PARAMETER ::      HM1E1=-10.
5904  REAL,PARAMETER ::      HM1597E1=-15.97469413
5905  REAL,PARAMETER ::      HM161E1=-16.1
5906  REAL,PARAMETER ::      HM1797E1=-17.97469413
5907  REAL,PARAMETER ::      HM181E1=-18.1
5908  REAL,PARAMETER ::      HM8E1=-80.
5909  REAL,PARAMETER ::      HM1E2=-100.
5910 !
5911  REAL,PARAMETER ::      H1M16=1.0E-16
5912  REAL,PARAMETER ::      H1M20=1.E-20
5913  REAL,PARAMETER ::      Q19001=19.001
5914  REAL,PARAMETER ::      DAYSEC=1.1574E-5
5915  REAL,PARAMETER ::      HSIGMA=5.673E-8
5916  REAL,PARAMETER ::      TWENTY=20.0
5917  REAL,PARAMETER ::      HP537=0.537
5918  REAL,PARAMETER ::      HP2=0.2
5919  REAL,PARAMETER ::      RCO2=3.3E-4
5920  REAL,PARAMETER ::      H3M6=3.0E-6
5921  REAL,PARAMETER ::      PI=3.1415927
5922  REAL,PARAMETER ::      DEGRAD1=180.0/PI
5923  REAL,PARAMETER ::      H74E1=74.0
5924  REAL,PARAMETER ::      H15E1=15.0
5925
5926  REAL, PARAMETER:: B0 = -.51926410E-4
5927  REAL, PARAMETER:: B1 = -.18113332E-3
5928  REAL, PARAMETER:: B2 = -.10680132E-5
5929  REAL, PARAMETER:: B3 = -.67303519E-7
5930  REAL, PARAMETER:: AWIDE = 0.309801E+01
5931  REAL, PARAMETER:: BWIDE = 0.495357E-01
5932  REAL, PARAMETER:: BETAWD = 0.347839E+02
5933  REAL, PARAMETER:: BETINW = 0.766811E+01
5934
5935
5936       INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
5937                                     ims,ime, jms,jme, kms,kme ,      &
5938                                     its,ite, jts,jte, kts,kte
5939       INTEGER, INTENT(IN)        :: IBEG,KO3,KALB,ITIMSW,ITIMLW
5940 !----------------------------------------------------------------------
5941 !      ****************************************************************
5942 !      *  GENERALIZED FOR PLUG-COMPATIBILITY -                        *
5943 !      *    ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..*
5944 !......*  EXAMPLE FOR MRF:                                            *
5945 !      *    KO3  =0  AND O3QO3=DUMMY ARRAY.   (GFDL CLIMO O3 USED)    *
5946 !      *    KEMIS=0  AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)*
5947 !      *    KALB =0  AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... *
5948 !      *    KCCO2=0,CO2 OBTAINED FROM BLOCK DATA                      *
5949 !      *         =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET...     *
5950 !      *  UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92      *
5951 !      *    OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE           *
5952 !      *       COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE)   *
5953 !      *       SLMSK = 0.                                             *
5954 !      *    SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH   *
5955 !      *       ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR     *
5956 !      *       COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92      *
5957 !      *       ALBEDO GE .5                                           *
5958 !      *   UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR        *
5959 !      *       CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92       *
5960 !      *       SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 .......      *
5961 !      *  UPDATED FOR USE NEW CLD SCHEME      ......YH  DEC 92        *
5962 !      *    INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT)  *
5963 !      *       OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY)       *
5964 !      *    IEMIS=0  USE THE ORG. CLD EMIS SCHEME                     *
5965 !      *         =1  USE TEMP DEP. CLD EMIS SCHEME                    *
5966 !      *  UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE *
5967 !      *    INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0'  *
5968 !      *                                      ......YH FEB 93         *
5969 !      ****************************************************************
5970 !--------------------------------
5971 !     INTEGER, PARAMETER:: LNGTH=37*kte
5972 !--------------------------------
5973
5974 !     REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
5975
5976       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT
5977       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O
5978       REAL,    INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD
5979       REAL,    INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT
5980       REAL,    INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR
5981       REAL,    INTENT(OUT), DIMENSION(its:ite):: FLWUPS
5982       INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS
5983       INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM
5984       REAL,    INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL
5985       REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3
5986 !     REAL,  INTENT(IN),  DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
5987 !     REAL,  INTENT(IN),  DIMENSION(5040) :: EM3V
5988
5989 !     REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR
5990
5991 ! TABLE ???
5992
5993       REAL,  DIMENSION(3) :: BO3RND,AO3RND
5994       REAL,  DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
5995                                 BCOMB,BETACM
5996
5997       DATA AO3RND / 0.543368E+02,  0.234676E+04,  0.384881E+02/
5998       DATA BO3RND / 0.526064E+01,  0.922424E+01,  0.496515E+01/
5999
6000       DATA ACOMB  / &
6001          0.152070E+05,  0.332194E+04,  0.527177E+03,  0.163124E+03, &
6002          0.268808E+03,  0.534591E+02,  0.268071E+02,  0.123133E+02, &
6003          0.600199E+01,  0.640803E+00,  0.501549E-01,  0.167961E-01, &
6004          0.178110E-01,  0.170166E+00,  0.537083E-02/
6005       DATA BCOMB  / &
6006          0.152538E+00,  0.118677E+00,  0.103660E+00,  0.100119E+00, &
6007          0.127518E+00,  0.118409E+00,  0.904061E-01,  0.642011E-01, &
6008          0.629660E-01,  0.643346E-01,  0.717082E-01,  0.629730E-01, &
6009          0.875182E-01,  0.857907E-01,  0.214005E+00/
6010       DATA APCM   / &
6011         -0.671879E-03,  0.654345E-02,  0.143657E-01,  0.923593E-02, &
6012          0.117022E-01,  0.159596E-01,  0.181600E-01,  0.145013E-01, &
6013          0.170062E-01,  0.233303E-01,  0.256735E-01,  0.274745E-01, &
6014          0.279259E-01,  0.197002E-01,  0.349782E-01/
6015       DATA BPCM   / &
6016         -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, &
6017         -0.361981E-04, -0.145117E-04,  0.198349E-04, -0.486529E-04, &
6018         -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
6019         -0.982953E-04, -0.772497E-04, -0.748263E-04/
6020       DATA ATPCM  / &
6021         -0.106346E-02,  0.641531E-02,  0.137362E-01,  0.922513E-02, &
6022          0.136162E-01,  0.169791E-01,  0.206959E-01,  0.166223E-01, &
6023          0.171776E-01,  0.229724E-01,  0.275530E-01,  0.302731E-01, &
6024          0.281662E-01,  0.199525E-01,  0.370962E-01/
6025       DATA BTPCM  / &
6026         -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, &
6027         -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, &
6028         -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
6029         -0.933645E-04, -0.664045E-04, -0.115290E-03/
6030       DATA BETACM / &
6031          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
6032          0.188625E+03,  0.144293E+03,  0.174098E+03,  0.909366E+02, &
6033          0.497489E+02,  0.221212E+02,  0.113124E+02,  0.754174E+01, &
6034          0.589554E+01,  0.495227E+01,  0.000000E+00/
6035
6036
6037 !        *********************************************
6038 !====>   *   OUTPUT TO CALLING PROGRAM               *
6039 !        *********************************************
6040
6041        REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW
6042        REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, &
6043                            FSWDNS,FLWUP,FLWDNS,FSWDNSC
6044
6045 !        *********************************************
6046 !====>   *   POSSIBLE OUTPUT TO CALLING PROGRAM      *
6047 !        *********************************************
6048
6049       REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR
6050
6051 !        ************************************************************
6052 !====>   *   ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) *
6053 !        ************************************************************
6054
6055       REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL
6056
6057 !        ******************************************************
6058 !====>   *   ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB *
6059 !        ******************************************************
6060
6061        REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC
6062        REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF
6063        REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA
6064        REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX
6065        REAL, DIMENSION(kts:kte+1)::PHALF
6066 !..... ADD PRESSURE INTERFACE
6067
6068        REAL,    DIMENSION(NB) :: ABCFF,PWTS
6069
6070        DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., &
6071                   989.,2706.,39011./
6072        DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, &
6073                  .001467,.002342,.001075/
6074
6075        REAL     :: CFCO2,CFO3,REFLO3,RRAYAV
6076
6077        DATA CFCO2,CFO3/508.96,466.64/
6078        DATA REFLO3/1.9/
6079        DATA RRAYAV/0.144/
6080
6081 !        *********************************************
6082 !====>   *   VECTOR TEMPORARIES FOR CLOUD CALC.      *
6083 !        *********************************************
6084
6085        REAL,    DIMENSION(its:ite):: TTHAN
6086        REAL,    DIMENSION(its:ite,kts:kte):: DO3V,DO3VP
6087        INTEGER, DIMENSION(its:ite):: JJROW
6088
6089 !====>    **************************************************************
6090 !--     SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
6091 !             CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
6092 !         DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
6093 !         COMMON /SAVMEM/ &
6094 !-       ...WINTER....  ...SPRING....  ...SUMMER....  ....FALL.....
6095 !        DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L)
6096
6097        REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4
6098
6099 !====>    **************************************************************
6100 !
6101       REAL,   DIMENSION(21,20) :: ALBD
6102       REAL,   DIMENSION(20)    :: ZA
6103       REAL,   DIMENSION(21)    :: TRN
6104       REAL,   DIMENSION(19)    :: DZA
6105
6106       REAL    :: YEAR,TPI,SSOLAR,DATE,TH2,ZEN,DZEN,ALB1,ALB2
6107       INTEGER :: IR,IQ,JX
6108       DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, &
6109                .70,.75,.80,.85,.90,.95,1.00/
6110
6111       REAL ::  ALB11(21,7),ALB22(21,7),ALB33(21,6)
6112
6113       EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), &
6114                   (ALB33(1,1),ALBD(1,15))
6115       DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
6116        .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
6117        .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
6118        .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
6119        .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
6120        .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
6121        .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
6122        .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
6123        .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
6124        .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
6125        .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
6126        .246,.235,.222,.211,.205,.200/
6127       DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
6128        .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
6129        .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
6130        .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
6131        .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
6132        .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
6133        .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
6134        .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
6135        .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
6136        .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
6137        .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
6138        .058,.055,.054,.053,.052,.052/
6139       DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
6140        .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
6141        .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
6142        .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
6143        .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
6144        .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
6145        .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
6146        .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
6147        .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
6148        .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/
6149       DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., &
6150               50.,40.,30.,20.,10.,0.0/
6151       DATA DZA/8*2.0,6*4.0,5*10.0/
6152
6153 !    ***********************************************************
6154 !
6155
6156        REAL,    DIMENSION(its:ite)        :: ALVB,ALNB,ALVD,ALND, &
6157                                              GDFVB,   &
6158                                              GDFNB,GDFVD,GDFND,   &
6159                                              SFCALB
6160
6161        REAL    :: RRVCO2,RRCO2,TDUM
6162        REAL    :: ALBD0,ALVD1,ALND1
6163        INTEGER :: N
6164 !
6165 !***  The following two lines are for debugging.
6166        integer :: imd,jmd, Jndx
6167        real :: FSWrat,FSWrat1,FSWDNS1
6168 !***
6169
6170 !====>    BEGIN HERE             .......................
6171 !
6172 !--- SSOLAR IS THE SOLAR CONSTANT SCALED TO A MORE CURRENT VALUE;
6173 !          I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN.
6174       REAL,PARAMETER :: H196=1.96
6175
6176       INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
6177       INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
6178
6179       L=kte
6180       LP1=L+1;  LP2=L+2;  LP3=L+3; LLP1 = 2*L + 1
6181       LM1=L-1;  LM2=L-2;  LM3=L-3; LL = 2*L
6182       LLM2 = LL-2; LLM1=LL-1
6183       MYIS=its; MYIE=ite
6184
6185 !******ZHAO
6186 !  NOTE: XLAT IS IN DEGREE HERE
6187 !*****ZHAO
6188 !-- Formerly =>  SOLC=2./(R1*R1), SSOLAR=0.98*SOLC
6189       SSOLAR=H196/(R1*R1)
6190 !*********************************************************
6191 ! Special note: The solar constant is reduced extra 3 percent to account
6192 !               for the lack of aerosols in the shortwave radiation
6193 !               parameterization.       Q. Zhao    96-7-23
6194 ! ### May also be due not accounting for reduction in solar constant due to
6195 !     absorption by ozone above the top of the model domain (Ferrier, Apr-2005)
6196 !*********************************************************
6197       SSOLAR=SSOLAR*0.97
6198 !
6199       DO 40 I=MYIS,MYIE
6200         IR = I + IBEG - 1
6201         TH2=HP2*XLAT(IR)
6202         JJROW(I)=Q19001-TH2
6203         TTHAN(I)=(19-JJROW(I))-TH2
6204 !.....  NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN
6205 !          CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS
6206         SFCALB(I) = ALBEDO(IR)
6207 !.....  NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK...
6208 !***ZHAO
6209 !  NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA
6210 !        THE UNIT FOR PRESS IS MICRO BAR
6211 !        SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL
6212 !***ZHAO
6213         PRESS(I,LP1)=QS(IR)*10.0
6214         TEMP(I,LP1)=ABS(TSFC(IR))
6215         COSZEN(I) = COSZRO(IR)
6216         TAUDA(I) = TAUDAR(IR)
6217    40 CONTINUE
6218 !***ZHAO
6219 !.....  ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC
6220 !       ETA MODEL HAS THE SAME STRUCTURE
6221 !***ZHAO
6222       DO 50 K=1,L
6223        DO 50 I=MYIS,MYIE
6224         IR = I + IBEG - 1
6225 !.....  NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK..........
6226         TEMP(I,K) = TT(IR,K)
6227         PRESS(I,K) = 10.0 * PP(IR,K)
6228 !.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK
6229         RH2O(I,K)=QQH2O(IR,K)
6230         IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6
6231    50 CONTINUE
6232 !...    *************************
6233       IF (KO3.EQ.0) GO TO 65
6234 !...    *************************
6235       DO 60 K=1,L
6236        DO 60 I=MYIS,MYIE
6237         QO3(I,K) = O3QO3(I+IBEG-1,K)
6238    60 CONTINUE
6239    65 CONTINUE
6240 !...   ************************************
6241       IF (KALB.GT.0) GO TO 110
6242 !...   ************************************
6243 !..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF
6244 !         1) OPEN SEA POINT (SLMSK=1);2) KALB=0
6245       IQ=INT(TWENTY*HP537+ONE)
6246       DO 105 I=MYIS,MYIE
6247          IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN
6248            ZEN=DEGRAD1*ACOS(MAX(COSZEN(I),0.0))
6249            IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE)
6250            IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) &
6251               JX=INT(QUARTR*(H74E1-ZEN)+HNINE)
6252            IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1)
6253            DZEN=-(ZEN-ZA(JX))/DZA(JX)
6254            ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX))
6255            ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX))
6256            SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ))
6257          ENDIF
6258   105 CONTINUE
6259   110 CONTINUE
6260 !        **********************************
6261       IF (KO3.GT.0) GO TO 135
6262 !        **********************************
6263 !.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE,
6264 !....   SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
6265       DO 125 I=MYIS,MYIE
6266
6267          PHALF(1)=0.
6268          PHALF(LP1)=PPI(I,kme)
6269          DO K=1,LM1
6270             PHALF(K+1)=PP(I,K) !  AETA(K)*PDIF+PT ! BSF index was erroneously L
6271          ENDDO
6272
6273          CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
6274                  ids,ide, jds,jde, kds,kde,            &
6275                  ims,ime, jms,jme, kms,kme,            &
6276                  its,ite, jts,jte, kts,kte             )
6277
6278          DO 130 K=1,L
6279           DO3V(I,K)  = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) &
6280                       +RCOS1*DDO3N3(JJROW(I),K) &
6281                       +RCOS2*DDO3N4(JJROW(I),K)
6282           DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) &
6283                      +RCOS1*DDO3N3(JJROW(I)+1,K) &
6284                      +RCOS2*DDO3N4(JJROW(I)+1,K)
6285 !...   NOW LATITUDINAL INTERPOLATION, AND
6286 !          CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4)
6287           QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K)))
6288   130   CONTINUE
6289   125 CONTINUE
6290   135 CONTINUE
6291 !.............
6292       DO 195 I=MYIS,MYIE
6293 !.....     VISIBLE AND NEAR IR DIFFUSE ALBEDO
6294         ALVD(I) = SFCALB(I)
6295         ALND(I) = SFCALB(I)
6296 !.....     VISIBLE AND NEAR IR DIRECT BEAM ALBEDO
6297         ALVB(I) = SFCALB(I)
6298         ALNB(I) = SFCALB(I)
6299 !
6300 !--- Remove diurnal variation of land surface albedos (Ferrier, 6/28/05)
6301 !--- Turn back on to mimic NAM 8/17/05
6302 !
6303 !.....     VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW
6304 !        ..FUNCTION OF COSINE SOLAR ZENITH ANGLE..
6305         IF (SLMSK(I+IBEG-1).LT.0.5) THEN
6306          IF (SFCALB(I).LE.0.5) THEN
6307           ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI)
6308           ALBD0 = EXP (ALBD0)
6309           ALVD1 = (ALVD(I) - 0.054313) / 0.945687
6310           ALND1 = (ALND(I) - 0.054313) / 0.945687
6311           ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0
6312           ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0
6313  !-- Put in an upper limit on beam albedos
6314           ALVB(I) = MIN(0.5,ALVB(I))
6315           ALNB(I) = MIN(0.5,ALNB(I))
6316          END IF
6317         END IF
6318   195 CONTINUE
6319 !.....SURFACE VALUES OF RRCL AND TTCL
6320       DO 200 N=1,2
6321         DO 200 I=MYIS,MYIE
6322       RRCL(I,N,1)=ALVD(I)
6323       TTCL(I,N,1)=ZERO
6324   200 CONTINUE
6325       DO 220 N=3,NB
6326       DO 220 I=MYIS,MYIE
6327          RRCL(I,N,1)=ALND(I)
6328          TTCL(I,N,1)=ZERO
6329   220 CONTINUE
6330 !...     **************************
6331 !...     *  END OF CLOUD SECTION  *
6332 !...     **************************
6333 !... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2
6334 !   INTO RRCO2,THE MASS MIXING RATIO.
6335       RRVCO2=RCO2
6336       RRCO2=RRVCO2*RATCO2MW
6337   250 IF(ITIMLW .EQ. 0) GO TO 300
6338 !
6339 !             ***********************
6340 !====>        * LONG WAVE RADIATION *
6341 !             ***********************
6342 !
6343 !....     ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS
6344       DO 240 K=1,LP1
6345       DO 240 I=MYIS,MYIE
6346         EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K)
6347   240 CONTINUE
6348 !....    GET CLD FACTOR FOR LW CALCULATIONS
6349 !....
6350
6351 ! shuhua
6352
6353       CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, &
6354                  ids,ide, jds,jde, kds,kde,    &
6355                  ims,ime, jms,jme, kms,kme,    &
6356                  its,ite, jts,jte, kts,kte     )
6357
6358 ! shuhua
6359 !===>        LONG WAVE RADIATION
6360 !     CALL LWR88(HEATRA,GRNFLX,TOPFLX,         &
6361 !                PRESS,TEMP,RH2O,QO3,CLDFAC,   &
6362 !                EQCMT,NCLDS,KTOP,KBTM,        &
6363 !
6364 !!               BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6365 !                BO3RND,AO3RND, &
6366 !                APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
6367 !                ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
6368 !                GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
6369 !                P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
6370 !                TEN,HP1,FOUR,HM1EZ,SKO3R,                     &
6371 !                AB15WD,SKC1R,RADCON,QUARTR,TWO,               &
6372 !                HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
6373 !                RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
6374 !                ids,ide, jds,jde, kds,kde,                    &
6375 !                ims,ime, jms,jme, kms,kme,                    &
6376 !                its,ite, jts,jte, kts,kte                    )
6377
6378       CALL LWR88(HEATRA,GRNFLX,TOPFLX,         &
6379                  PRESS,TEMP,RH2O,QO3,CLDFAC,   &
6380                  EQCMT,NCLDS,KTOP,KBTM,        &
6381 !
6382 !                BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6383                  BO3RND,AO3RND, &
6384                  APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM,     &
6385                  ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR,        &
6386                  GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8,   &
6387                  P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF,  &
6388                  TEN,HP1,FOUR,HM1EZ,                           &
6389                  RADCON,QUARTR,TWO,                            &
6390                  HM6666M2,HMP66667,HMP5, HP166666,H41666M2,    &
6391                  RADCON1,H16E1, H28E1,H44194M2,H1P41819,       &
6392                  ids,ide, jds,jde, kds,kde,                    &
6393                  ims,ime, jms,jme, kms,kme,                    &
6394                   its,ite, jts,jte, kts,kte                    )
6395
6396 !....
6397 !================================================================================
6398 !--- IMPORTANT!!  Y.-T Hou advised Ferrier, Mitchell, & Ek on 7/28/05 to use
6399 !    the following algorithm, because the GFDL code calculates NET longwave flux
6400 !    (GRNFLX, Up - Down) as its fundamental quantity.
6401 !
6402 !    1.  Calculate upward LW at surface (FLWUPS)
6403 !    2.  Calculate downward LW at surface (FLWDNS) = FLWUPS - .001*GRNFLX
6404 !
6405 !--- Note:  The following fluxes must be multipled by .001 to convert to mks
6406 !       => GRNFLX, or GRound Net FLuX
6407 !       => TOPFLX, or top of the atmosphere fluxes (FLWUP)
6408 !
6409 !--- IMPORTANT!!  If the surface emissivity (SFCEMS) differs from 1.0, then
6410 !    uncomment the line below starting with "!BSF"
6411 !================================================================================
6412       DO 280 I=MYIS,MYIE
6413         IR = I + IBEG - 1
6414         FLWUP(IR) = .001*TOPFLX(I)
6415 !        TDUM=TEMP(I,LP1)
6416 !--- Use an average of the skin & lowest model level temperature
6417         TDUM=.5*(TEMP(I,LP1)+TEMP(I,L))
6418         FLWUPS(IR)=HSIGMA*TDUM*TDUM*TDUM*TDUM
6419 !BSF        FLWUPS(IR)=SFCEMS*HSIGMA*TDUM*TDUM*TDUM*TDUM
6420         FLWDNS(IR)=FLWUPS(IR)-.001*GRNFLX(I)
6421   280 CONTINUE
6422 !....  Average LW heating/cooling rates over the lowest 2 atmospheric layers,
6423 !      which may be necessary for when dealing with thin layers near the surface
6424       DO I=MYIS,MYIE
6425          TDUM=.5*(HEATRA(I,L)+HEATRA(I,LM1))
6426          HEATRA(I,L)=TDUM
6427          HEATRA(I,LM1)=TDUM
6428       ENDDO
6429 !....      CONVERT HEATING RATES TO DEG/SEC
6430       DO 290 K=1,L
6431         DO 290 I=MYIS,MYIE
6432           HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC
6433   290 CONTINUE
6434   300 CONTINUE
6435       IF(ITIMSW .EQ. 0) GO TO 350
6436 !SW
6437       CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, &
6438                  PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, &
6439                  NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, &
6440                  ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
6441 !
6442 !                UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2,                &
6443                  ABCFF,PWTS,                                    &
6444                  H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,     &
6445                  HP816,RRAYAV,GINV,CFCO2,CFO3,                  &
6446                  TWO,H235M3,HP26,H129M2,H75826M4,H1036E2,       &
6447                  H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,    &
6448                  H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON,    &
6449                  ids,ide, jds,jde, kds,kde,                     &
6450                  ims,ime, jms,jme, kms,kme,                     &
6451                  its,ite, jts,jte, kts,kte                      )
6452
6453 !SW
6454 !
6455 !.....    GET SW FLUXES IN WATTS/M**2
6456       DO 320 I=MYIS,MYIE
6457        IR = I + IBEG - 1
6458        FSWUP(IR) = UF(I,1) * 1.E-3
6459        FSWDN(IR) = DF(I,1) * 1.E-3
6460        FSWUPS(IR) = UF(I,LP1) * 1.E-3
6461 !-- FSWDNS is more accurate using array DF than summing the GDFxx arrays
6462 !C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3
6463 !!       FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3
6464        FSWDNS(IR) = DF(I,LP1) * 1.E-3
6465        FSWDNSC(IR) = DFL(I,LP1) * 1.E-3
6466 !...    DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION
6467 !.....     VISIBLE AND NEAR IR DIFFUSE
6468        GDFVDR(IR) = GDFVD(I) * 1.E-3
6469        GDFNDR(IR) = GDFND(I) * 1.E-3
6470 !.....     VISIBLE AND NEAR IR DIRECT BEAM
6471        GDFVBR(IR) = GDFVB(I) * 1.E-3
6472        GDFNBR(IR) = GDFNB(I) * 1.E-3
6473   320 CONTINUE
6474 !....      CONVERT HEATING RATES TO DEG/SEC
6475       DO 330 K=1,L
6476         DO 330 I=MYIS,MYIE
6477           SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC
6478   330 CONTINUE
6479   350 CONTINUE
6480 ! begin debugging radiation
6481
6482 !     if (Jndx .eq. jmd) then
6483 !       FSWDNS1=(GDFVB(imd)+GDFNB(imd)+GDFVD(imd)+GDFND(imd))*.001
6484 !       write(6,"(3a,2i5,7f9.2)") '{rad2 imd,Jndx,'  &
6485 !      ,'GSW=FSWDNS-FSWUPS,RSWIN=FSWDNS,RSWIN_1=FSWDNS1,' &
6486 !      ,'FSWDNS-FSWDNS1,RSWOUT=FSWUPS,RSWINC=FSWDNSC,GLW=FLWDNS = ' &
6487 !      ,imd,Jndx, FSWDNS(imd)-FSWUPS(imd),FSWDNS(imd),FSWDNS1  &
6488 !      ,FSWDNS(imd)-FSWDNS1,FSWUPS(imd),FSWDNSC(imd),FLWDNS(imd)
6489 !       FSWrat=0.
6490 !       if (FSWDNS(imd) .ne. 0.) FSWrat=FSWUPS(imd)/FSWDNS(imd)
6491 !       FSWrat1=0.
6492 !       if (FSWDNS1 .ne. 0.) FSWrat1=FSWUPS(imd)/FSWDNS1
6493 !       write(6,"(2a,10f8.4)") '{rad2a ALBEDO,SFCALB,ALVD,ALND,ALVB,' &
6494 !      ,'ALNB,CZEN,SLMSK,FSWUPS/FSWDNS,FSWUPS/FSWDNS1 = ' &
6495 !      ,ALBEDO(imd),SFCALB(imd),ALVD(imd),ALND(imd),ALVB(imd)  &
6496 !      ,ALNB(imd),COSZEN(imd),SLMSK(imd),FSWrat,FSWrat1
6497 !     endif
6498 ! end debugging radiation
6499       RETURN
6500  1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', &
6501                  'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2)
6502
6503   END SUBROUTINE RADFS
6504
6505 !-----------------------------------------------------------------------
6506     SUBROUTINE O3CLIM
6507 !                (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL,         &
6508 !                ids,ide, jds,jde, kds,kde,                   &
6509 !                ims,ime, jms,jme, kms,kme,                   &
6510 !                its,ite, jts,jte, kts,kte                    )
6511 !----------------------------------------------------------------------
6512  IMPLICIT NONE
6513 !----------------------------------------------------------------------
6514 !     INTEGER, INTENT(IN)        :: ids,ide, jds,jde, kds,kde ,      &
6515 !                                   ims,ime, jms,jme, kms,kme ,      &
6516 !                                   its,ite, jts,jte, kts,kte
6517
6518 !     ******************************************************************
6519 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
6520 !                .      .    .
6521 ! SUBPROGRAM:    O3CLIM      GENERATE SEASONAL OZONE DISTRIBUTION
6522 !   PRGRMMR: GFDL/CAMPANA    ORG: W/NP22     DATE: ??-??-??
6523 !
6524 ! ABSTRACT:
6525 !     O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING
6526 !     81-LAYER DATA FROM GFDL.
6527 !
6528 ! PROGRAM HISTORY LOG:
6529 !   ??-??-??  GFDL/KC    - ORIGINATOR
6530 !   96-07-26  BLACK      - MODIFIED FOR ETA MODEL
6531 !
6532 ! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN
6533 !   INPUT ARGUMENT LIST:
6534 !     NONE
6535 !
6536 !   OUTPUT ARGUMENT LIST:
6537 !     NONE
6538 !
6539 !   OUTPUT FILES:
6540 !     NONE
6541 !
6542 !   SUBPROGRAMS CALLED:
6543 !
6544 !     UNIQUE:
6545 !        NONE
6546 !
6547 !     LIBRARY:
6548 !        NONE
6549 !
6550 !   COMMON BLOCKS: SEASO3
6551 !                  O3DATA
6552 !
6553 ! ATTRIBUTES:
6554 !   LANGUAGE: FORTRAN 90
6555 !   MACHINE : IBM SP
6556 !$$$
6557 !----------------------------------------------------------------------
6558 !      INTEGER   :: NL,NLP1,NLGTH,NKK,NK,NKP
6559        INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1
6560 !----------------------------------------------------------------------
6561 !     INCLUDE "SEASO3.comm"
6562 !---------------------------------------------------------------------
6563 !     REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
6564 !     REAL, INTENT(OUT), DIMENSION(NL)    :: PRGFDL
6565
6566 !      COMMON /SEASO3/
6567 !      ...WINTER....  ...SPRING....  ...SUMMER....  ....FALL.....
6568 !    & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL)
6569 !
6570 !    &,PRGFDL(NL)
6571 !---------------------------------------------------------------------
6572        REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) &
6573               ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16)
6574 !----------------------------------------------------------------------
6575        REAL    :: AVG,A1,B1,B2
6576        INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex
6577 !----------------------------------------------------------------------
6578        REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) &
6579       ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) &
6580       ,DDUO3N(19,NL),DUO3N(19,41) &
6581       ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) &
6582       ,O3HI(10,25) &
6583       ,RSTD(81),RBAR(NL),RDATA(81) &
6584       ,PHALF(NL),P(81),PH(82)
6585        REAL   :: PXX(81),PYY(82)                       !  fix for nesting
6586 !----------------------------------------------------------------------
6587 !nesting                         EQUIVALENCE &
6588 !nesting     (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6589 !nesting    ,(PH1(1),PH(1)),(PH2(1),PH(46)) &
6590 !nesting    ,(P1(1),P(1)),(P2(1),P(49))
6591                            EQUIVALENCE &
6592        (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6593       ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) &               ! fix for nesting
6594       ,(P1(1),PXX(1)),(P2(1),PXX(49))                   ! fix for nesting
6595 !----------------------------------------------------------------------
6596 !                          EQUIVALENCE &
6597 !      (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) &
6598 !     ,(XRAD2(1),XDO3N2(1,1)) &
6599 !     ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),)
6600                            EQUIVALENCE &
6601        (XRAD1(1),O3O3(1,1,1)) &
6602       ,(XRAD2(1),O3O3(1,1,2)) &
6603       ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4))
6604 !----------------------------------------------------------------------
6605 !---------------------------------------------------------------------
6606       DATA PH1/      0.,     &
6607            0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04,     &
6608            0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04,     &
6609            0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04,     &
6610            0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03,     &
6611            0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03,     &
6612            0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03,     &
6613            0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03,     &
6614            0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03,     &
6615            0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02,     &
6616            0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02,     &
6617            0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
6618       DATA PH2/     &
6619            0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02,     &
6620            0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01,     &
6621            0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01,     &
6622            0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01,     &
6623            0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01,     &
6624            0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00,     &
6625            0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00,     &
6626            0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00,     &
6627            0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00,     &
6628            0.1000000E+01/
6629       DATA P1/     &
6630            0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04,     &
6631            0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04,     &
6632            0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04,     &
6633            0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03,     &
6634            0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03,     &
6635            0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03,     &
6636            0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03,     &
6637            0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03,     &
6638            0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02,     &
6639            0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02,     &
6640            0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02,     &
6641            0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
6642       DATA P2/     &
6643            0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01,     &
6644            0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01,     &
6645            0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01,     &
6646            0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01,     &
6647            0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00,     &
6648            0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00,     &
6649            0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00,     &
6650            0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00,     &
6651            0.1000000E+01/
6652       DATA O3HI1/     &
6653        .55,.50,.45,.45,.40,.35,.35,.30,.30,.30,     &
6654        .55,.51,.46,.47,.42,.38,.37,.36,.35,.35,     &
6655        .55,.53,.48,.49,.44,.42,.41,.40,.38,.38,     &
6656        .60,.55,.52,.52,.50,.47,.46,.44,.42,.41,     &
6657        .65,.60,.55,.56,.53,.52,.50,.48,.45,.45,     &
6658        .75,.65,.60,.60,.55,.55,.55,.50,.48,.47,     &
6659        .80,.75,.75,.75,.70,.70,.65,.63,.60,.60,     &
6660        .90,.85,.85,.80,.80,.75,.75,.74,.72,.71,     &
6661        1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80,        &
6662        1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
6663        1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5,     &
6664        2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7,     &
6665        2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0,     &
6666        2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3,     &
6667        2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6,     &
6668        3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
6669       DATA O3HI2/     &
6670        3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8,     &
6671        3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2,     &
6672        4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2,     &
6673        5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7,     &
6674        6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2,     &
6675        9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3,     &
6676        12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
6677        14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5,  &
6678        14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
6679       DATA O3LO1/     &
6680        14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4,  &
6681        14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4,   &
6682        11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2,    &
6683        7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1,     &
6684        4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9,     &
6685        1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1,     &
6686        0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2,     &
6687        .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9,     &
6688        .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5,     &
6689        .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6,     &
6690        .05,.05,.06,.09,.20,.40,.70,.80,.90,.90,     &
6691        .05,.05,.06,.08,.10,.13,.20,.25,.30,.40,     &
6692        .05,.05,.05,.06,.07,.07,.08,.09,.10,.13,     &
6693        .05,.05,.05,.05,.06,.06,.06,.06,.07,.07,     &
6694        .05,.05,.05,.05,.05,.05,.05,.06,.06,.06,     &
6695        .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
6696       DATA O3LO2/     &
6697        14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9,   &
6698        13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6,   &
6699        10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1,    &
6700        7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8,     &
6701        3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5,     &
6702        1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0,     &
6703        .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1,     &
6704        .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0,     &
6705        .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0,     &
6706        .05,.05,.06,.12,.15,.30,.60,.70,.80,.80,     &
6707        .04,.05,.06,.08,.09,.15,.30,.40,.40,.40,     &
6708        .04,.04,.05,.055,.06,.09,.12,.13,.15,.15,    &
6709        .03,.03,.045,.052,.055,.06,.07,.07,.06,.07,  &
6710        .03,.03,.04,.051,.052,.052,.06,.06,.05,.05,  &
6711        .02,.02,.03,.05,.05,.05,.04,.04,.04,.04,     &
6712        .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
6713       DATA O3LO3/     &
6714        14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3,    &
6715        13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8,     &
6716        10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7,     &
6717        7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5,     &
6718        4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4,     &
6719        1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2,     &
6720        .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6,     &
6721        .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3,     &
6722        .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0,     &
6723        .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8,     &
6724        .04,.04,.04,.08,.20,.30,.55,.60,.75,.90,     &
6725        .04,.04,.04,.05,.06,.10,.12,.15,.20,.25,     &
6726        .04,.04,.03,.04,.05,.06,.07,.07,.07,.08,     &
6727        .03,.03,.04,.05,.05,.05,.05,.05,.05,.05,     &
6728        .03,.03,.03,.04,.04,.04,.05,.05,.04,.04,     &
6729        .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
6730       DATA O3LO4/     &
6731        14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6,  &
6732        12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1,   &
6733        10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9,    &
6734        7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6,     &
6735        4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3,     &
6736        2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1,     &
6737        0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0,     &
6738        .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5,     &
6739        .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6,     &
6740        .07,.08,.10,.14,.20,.50,.70,.90,.90,.80,     &
6741        .05,.06,.08,.12,.14,.20,.35,.40,.60,.50,     &
6742        .05,.05,.08,.09,.09,.09,.11,.12,.15,.18,     &
6743        .04,.05,.06,.07,.07,.08,.08,.08,.08,.08,     &
6744        .04,.04,.05,.07,.07,.07,.07,.07,.06,.05,     &
6745        .02,.02,.04,.05,.05,.05,.05,.05,.04,.04,     &
6746        .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
6747 !----------------------------------------------------------------------
6748 !***
6749 !***  COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES
6750 !***  WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3
6751 !***  AND PSFC=1013.25 MB    ......K.A.C. DEC94
6752 !***
6753       DO K=1,NK
6754 !        PH(K)=PH(K)*1013250.
6755 !        P(K)=P(K)*1013250.
6756         PH(K)=PYY(K)*1013250.         ! fix for nesting
6757         P(K)=PXX(K)*1013250.          ! fix for nesting
6758       ENDDO
6759 !
6760 !      PH(NKP)=PH(NKP)*1013250.
6761       PH(NKP)=PYY(NKP)*1013250.       ! fix for nesting
6762 !
6763       DO K=1,NL
6764         PSTD(K)=P(K)
6765       ENDDO
6766 !
6767       DO K=1,25
6768       DO N=1,10
6769         RO31(N,K)=O3HI(N,K)
6770         RO32(N,K)=O3HI(N,K)
6771       ENDDO
6772       ENDDO
6773 !----------------------------------------------------------------------
6774       DO 100 NCASE=1,4
6775 !
6776 !***  NCASE=1: SPRING (IN N.H.)
6777 !***  NCASE=2: FALL   (IN N.H.)
6778 !***  NCASE=3: WINTER (IN N.H.)
6779 !***  NCASE=4: SUMMER (IN N.H.)
6780 !
6781       IPLACE=2
6782       IF(NCASE.EQ.2)IPLACE=4
6783       IF(NCASE.EQ.3)IPLACE=1
6784       IF(NCASE.EQ.4)IPLACE=3
6785 !
6786       IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN
6787         DO K=26,41
6788         DO N=1,10
6789           RO31(N,K)=O3LO1(N,K-25)
6790           RO32(N,K)=O3LO2(N,K-25)
6791         ENDDO
6792         ENDDO
6793       ENDIF
6794 !
6795       IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN
6796         DO K=26,41
6797         DO N=1,10
6798           RO31(N,K)=O3LO3(N,K-25)
6799           RO32(N,K)=O3LO4(N,K-25)
6800         ENDDO
6801         ENDDO
6802       ENDIF
6803 !
6804       DO 25 KK=1,NKK
6805       DO N=1,10
6806         DUO3N(N,KK)=RO31(11-N,KK)
6807         DUO3N(N+9,KK)=RO32(N,KK)
6808       ENDDO
6809       DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK))
6810    25 CONTINUE
6811 !
6812 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
6813 !
6814       IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN
6815         DO 50 KK=1,NKK
6816         DO N=1,19
6817           TEMPN(N)=DUO3N(20-N,KK)
6818         ENDDO
6819          DO N=1,19
6820            DUO3N(N,KK)=TEMPN(N)
6821          ENDDO
6822    50   CONTINUE
6823       ENDIF
6824 !
6825 !***  DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE
6826 !***  LEVELS
6827 !
6828 !***  BEGIN LATITUDE (10 DEG) LOOP
6829 !
6830       DO 75 N=1,19
6831 !
6832       DO KK=1,NKK
6833         RSTD(KK)=DUO3N(N,KK)
6834       ENDDO
6835 !
6836       NKM=NK-1
6837       NKMM=NK-3
6838 !***
6839 !***  BESSELS HALF-POINT INTERPOLATION FORMULA
6840 !***
6841       DO K=4,NKMM,2
6842         KI=K/2
6843         RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) &
6844                                            -RSTD(KI)+RSTD(KI-1))/16.
6845       ENDDO
6846 !
6847       RDATA(2)=0.5*(RSTD(2)+RSTD(1))
6848       RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1))
6849 !
6850 !***  PUT UNCHANGED DATA INTO NEW ARRAY
6851 !
6852       DO K=1,NK,2
6853         KQ=(K+1)/2
6854         RDATA(K)=RSTD(KQ)
6855       ENDDO
6856 !
6857       DO KK=1,NL
6858         DDUO3N(N,KK)=RDATA(KK)*.01
6859       ENDDO
6860 !
6861    75 CONTINUE
6862 !
6863 !***  END OF LATITUDE LOOP
6864 !
6865 !----------------------------------------------------------------------
6866 !***
6867 !***  CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
6868 !***  10 DEG VALUES
6869 !***
6870       DO 90 KK=1,NL
6871 !
6872       DO N=1,19
6873         O35DEG(2*N-1,KK)=DDUO3N(N,KK)
6874       ENDDO
6875 !
6876       DO N=1,18
6877         O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK))
6878       ENDDO
6879 !
6880    90 CONTINUE
6881 !
6882       DO JJ=1,37
6883       DO KEN=1,NL
6884         O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN)
6885       ENDDO
6886       ENDDO
6887 !
6888   100 CONTINUE
6889 !----------------------------------------------------------------------
6890 !***  END OF LOOP OVER CASES
6891 !----------------------------------------------------------------------
6892 !***
6893 !***  AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT
6894 !***  TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D)
6895 !***
6896       DO I=1,NLGTH
6897         AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I))
6898         A1=0.5*(XRAD2(I)-XRAD4(I))
6899         B1=0.5*(XRAD1(I)-XRAD3(I))
6900         B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I)))
6901
6902 !       XRAD1(I)=AVG
6903 !       XRAD2(I)=A1
6904 !       XRAD3(I)=B1
6905 !       XRAD4(I)=B2
6906
6907         iindex = 1+mod((I-1),37)
6908         jindex = 1+(I-1)/37
6909         XDUO3N(iindex,jindex)=AVG
6910         XDO3N2(iindex,jindex)=A1
6911         XDO3N3(iindex,jindex)=B1
6912         XDO3N4(iindex,jindex)=B2
6913       ENDDO
6914 !***
6915 !***  CONVERT GFDL PRESSURE (MICROBARS) TO PA
6916 !***
6917       DO N=1,NL
6918         PRGFDL(N)=PSTD(N)*1.E-1
6919       ENDDO
6920 !
6921     END SUBROUTINE O3CLIM
6922
6923 !---------------------------------------------------------------------
6924       SUBROUTINE TABLE
6925 !                     (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3,          &
6926 !                      SOURCE,DSRCE                                  )
6927 !---------------------------------------------------------------------
6928  IMPLICIT NONE
6929 !----------------------------------------------------------------------
6930
6931 !INTEGER, PARAMETER :: NBLY=15
6932  INTEGER, PARAMETER :: NB=12
6933  INTEGER, PARAMETER :: NBLX=47
6934  INTEGER , PARAMETER:: NBLW = 163
6935
6936  REAL,PARAMETER ::      AMOLWT=28.9644
6937  REAL,PARAMETER ::      CSUBP=1.00484E7
6938  REAL,PARAMETER ::      DIFFCTR=1.66
6939  REAL,PARAMETER ::      G=980.665
6940  REAL,PARAMETER ::      GINV=1./G
6941  REAL,PARAMETER ::      GRAVDR=980.0
6942  REAL,PARAMETER ::      O3DIFCTR=1.90
6943  REAL,PARAMETER ::      P0=1013250.
6944  REAL,PARAMETER ::      P0INV=1./P0
6945  REAL,PARAMETER ::      GP0INV=GINV*P0INV
6946  REAL,PARAMETER ::      P0XZP2=202649.902
6947  REAL,PARAMETER ::      P0XZP8=810600.098
6948  REAL,PARAMETER ::      P0X2=2.*1013250.
6949  REAL,PARAMETER ::      RADCON=8.427
6950  REAL,PARAMETER ::      RADCON1=1./8.427
6951  REAL,PARAMETER ::      RATCO2MW=1.519449738
6952  REAL,PARAMETER ::      RATH2OMW=.622
6953  REAL,PARAMETER ::      RGAS=8.3142E7
6954  REAL,PARAMETER ::      RGASSP=8.31432E7
6955  REAL,PARAMETER ::      SECPDA=8.64E4
6956 !
6957 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
6958 !        ARRANGED IN DECREASING ORDER
6959  REAL,PARAMETER ::      HUNDRED=100.
6960  REAL,PARAMETER ::      HNINETY=90.
6961  REAL,PARAMETER ::      HNINE=9.0
6962  REAL,PARAMETER ::      SIXTY=60.
6963  REAL,PARAMETER ::      FIFTY=50.
6964  REAL,PARAMETER ::      TEN=10.
6965  REAL,PARAMETER ::      EIGHT=8.
6966  REAL,PARAMETER ::      FIVE=5.
6967  REAL,PARAMETER ::      FOUR=4.
6968  REAL,PARAMETER ::      THREE=3.
6969  REAL,PARAMETER ::      TWO=2.
6970  REAL,PARAMETER ::      ONE=1.
6971  REAL,PARAMETER ::      HAF=0.5
6972  REAL,PARAMETER ::      QUARTR=0.25
6973  REAL,PARAMETER ::      ZERO=0.
6974 !
6975 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
6976 !       ARRANGED IN DECREASING ORDER
6977  REAL,PARAMETER ::      H83E26=8.3E26
6978  REAL,PARAMETER ::      H71E26=7.1E26
6979  REAL,PARAMETER ::      H1E15=1.E15
6980  REAL,PARAMETER ::      H1E13=1.E13
6981  REAL,PARAMETER ::      H1E11=1.E11
6982  REAL,PARAMETER ::      H1E8=1.E8
6983  REAL,PARAMETER ::      H2E6=2.0E6
6984  REAL,PARAMETER ::      H1E6=1.0E6
6985  REAL,PARAMETER ::      H69766E5=6.97667E5
6986  REAL,PARAMETER ::      H4E5=4.E5
6987  REAL,PARAMETER ::      H165E5=1.65E5
6988  REAL,PARAMETER ::      H5725E4=57250.
6989  REAL,PARAMETER ::      H488E4=48800.
6990  REAL,PARAMETER ::      H1E4=1.E4
6991  REAL,PARAMETER ::      H24E3=2400.
6992  REAL,PARAMETER ::      H20788E3=2078.8
6993  REAL,PARAMETER ::      H2075E3=2075.
6994  REAL,PARAMETER ::      H18E3=1800.
6995  REAL,PARAMETER ::      H1224E3=1224.
6996  REAL,PARAMETER ::      H67390E2=673.9057
6997  REAL,PARAMETER ::      H5E2=500.
6998  REAL,PARAMETER ::      H3082E2=308.2
6999  REAL,PARAMETER ::      H3E2=300.
7000  REAL,PARAMETER ::      H2945E2=294.5
7001  REAL,PARAMETER ::      H29316E2=293.16
7002  REAL,PARAMETER ::      H26E2=260.0
7003  REAL,PARAMETER ::      H25E2=250.
7004  REAL,PARAMETER ::      H23E2=230.
7005  REAL,PARAMETER ::      H2E2=200.0
7006  REAL,PARAMETER ::      H15E2=150.
7007  REAL,PARAMETER ::      H1386E2=138.6
7008  REAL,PARAMETER ::      H1036E2=103.6
7009  REAL,PARAMETER ::      H8121E1=81.21
7010  REAL,PARAMETER ::      H35E1=35.
7011  REAL,PARAMETER ::      H3116E1=31.16
7012  REAL,PARAMETER ::      H28E1=28.
7013  REAL,PARAMETER ::      H181E1=18.1
7014  REAL,PARAMETER ::      H18E1=18.
7015  REAL,PARAMETER ::      H161E1=16.1
7016  REAL,PARAMETER ::      H16E1=16.
7017  REAL,PARAMETER ::      H1226E1=12.26
7018  REAL,PARAMETER ::      H9P94=9.94
7019  REAL,PARAMETER ::      H6P08108=6.081081081
7020  REAL,PARAMETER ::      H3P6=3.6
7021  REAL,PARAMETER ::      H3P5=3.5
7022  REAL,PARAMETER ::      H2P9=2.9
7023  REAL,PARAMETER ::      H2P8=2.8
7024  REAL,PARAMETER ::      H2P5=2.5
7025  REAL,PARAMETER ::      H1P8=1.8
7026  REAL,PARAMETER ::      H1P4387=1.4387
7027  REAL,PARAMETER ::      H1P41819=1.418191
7028  REAL,PARAMETER ::      H1P4=1.4
7029  REAL,PARAMETER ::      H1P25892=1.258925411
7030  REAL,PARAMETER ::      H1P082=1.082
7031  REAL,PARAMETER ::      HP816=0.816
7032  REAL,PARAMETER ::      HP805=0.805
7033  REAL,PARAMETER ::      HP8=0.8
7034  REAL,PARAMETER ::      HP60241=0.60241
7035  REAL,PARAMETER ::      HP602409=0.60240964
7036  REAL,PARAMETER ::      HP6=0.6
7037  REAL,PARAMETER ::      HP526315=0.52631579
7038  REAL,PARAMETER ::      HP518=0.518
7039  REAL,PARAMETER ::      HP5048=0.5048
7040  REAL,PARAMETER ::      HP3795=0.3795
7041  REAL,PARAMETER ::      HP369=0.369
7042  REAL,PARAMETER ::      HP26=0.26
7043  REAL,PARAMETER ::      HP228=0.228
7044  REAL,PARAMETER ::      HP219=0.219
7045  REAL,PARAMETER ::      HP166666=.166666
7046  REAL,PARAMETER ::      HP144=0.144
7047  REAL,PARAMETER ::      HP118666=0.118666192
7048  REAL,PARAMETER ::      HP1=0.1
7049 !        (NEGATIVE EXPONENTIALS BEGIN HERE)
7050  REAL,PARAMETER ::      H658M2=0.0658
7051  REAL,PARAMETER ::      H625M2=0.0625
7052  REAL,PARAMETER ::      H44871M2=4.4871E-2
7053  REAL,PARAMETER ::      H44194M2=.044194
7054  REAL,PARAMETER ::      H42M2=0.042
7055  REAL,PARAMETER ::      H41666M2=0.0416666
7056  REAL,PARAMETER ::      H28571M2=.02857142857
7057  REAL,PARAMETER ::      H2118M2=0.02118
7058  REAL,PARAMETER ::      H129M2=0.0129
7059  REAL,PARAMETER ::      H1M2=.01
7060  REAL,PARAMETER ::      H559M3=5.59E-3
7061  REAL,PARAMETER ::      H3M3=0.003
7062  REAL,PARAMETER ::      H235M3=2.35E-3
7063  REAL,PARAMETER ::      H1M3=1.0E-3
7064  REAL,PARAMETER ::      H987M4=9.87E-4
7065  REAL,PARAMETER ::      H323M4=0.000323
7066  REAL,PARAMETER ::      H3M4=0.0003
7067  REAL,PARAMETER ::      H285M4=2.85E-4
7068  REAL,PARAMETER ::      H1M4=0.0001
7069  REAL,PARAMETER ::      H75826M4=7.58265E-4
7070  REAL,PARAMETER ::      H6938M5=6.938E-5
7071  REAL,PARAMETER ::      H394M5=3.94E-5
7072  REAL,PARAMETER ::      H37412M5=3.7412E-5
7073  REAL,PARAMETER ::      H15M5=1.5E-5
7074  REAL,PARAMETER ::      H1439M5=1.439E-5
7075  REAL,PARAMETER ::      H128M5=1.28E-5
7076  REAL,PARAMETER ::      H102M5=1.02E-5
7077  REAL,PARAMETER ::      H1M5=1.0E-5
7078  REAL,PARAMETER ::      H7M6=7.E-6
7079  REAL,PARAMETER ::      H4999M6=4.999E-6
7080  REAL,PARAMETER ::      H451M6=4.51E-6
7081  REAL,PARAMETER ::      H25452M6=2.5452E-6
7082  REAL,PARAMETER ::      H1M6=1.E-6
7083  REAL,PARAMETER ::      H391M7=3.91E-7
7084  REAL,PARAMETER ::      H1174M7=1.174E-7
7085  REAL,PARAMETER ::      H8725M8=8.725E-8
7086  REAL,PARAMETER ::      H327M8=3.27E-8
7087  REAL,PARAMETER ::      H257M8=2.57E-8
7088  REAL,PARAMETER ::      H1M8=1.0E-8
7089  REAL,PARAMETER ::      H23M10=2.3E-10
7090  REAL,PARAMETER ::      H14M10=1.4E-10
7091  REAL,PARAMETER ::      H11M10=1.1E-10
7092  REAL,PARAMETER ::      H1M10=1.E-10
7093  REAL,PARAMETER ::      H83M11=8.3E-11
7094  REAL,PARAMETER ::      H82M11=8.2E-11
7095  REAL,PARAMETER ::      H8M11=8.E-11
7096  REAL,PARAMETER ::      H77M11=7.7E-11
7097  REAL,PARAMETER ::      H72M11=7.2E-11
7098  REAL,PARAMETER ::      H53M11=5.3E-11
7099  REAL,PARAMETER ::      H48M11=4.8E-11
7100  REAL,PARAMETER ::      H44M11=4.4E-11
7101  REAL,PARAMETER ::      H42M11=4.2E-11
7102  REAL,PARAMETER ::      H37M11=3.7E-11
7103  REAL,PARAMETER ::      H35M11=3.5E-11
7104  REAL,PARAMETER ::      H32M11=3.2E-11
7105  REAL,PARAMETER ::      H3M11=3.0E-11
7106  REAL,PARAMETER ::      H28M11=2.8E-11
7107  REAL,PARAMETER ::      H24M11=2.4E-11
7108  REAL,PARAMETER ::      H23M11=2.3E-11
7109  REAL,PARAMETER ::      H2M11=2.E-11
7110  REAL,PARAMETER ::      H18M11=1.8E-11
7111  REAL,PARAMETER ::      H15M11=1.5E-11
7112  REAL,PARAMETER ::      H14M11=1.4E-11
7113  REAL,PARAMETER ::      H114M11=1.14E-11
7114  REAL,PARAMETER ::      H11M11=1.1E-11
7115  REAL,PARAMETER ::      H1M11=1.E-11
7116  REAL,PARAMETER ::      H96M12=9.6E-12
7117  REAL,PARAMETER ::      H93M12=9.3E-12
7118  REAL,PARAMETER ::      H77M12=7.7E-12
7119  REAL,PARAMETER ::      H74M12=7.4E-12
7120  REAL,PARAMETER ::      H65M12=6.5E-12
7121  REAL,PARAMETER ::      H62M12=6.2E-12
7122  REAL,PARAMETER ::      H6M12=6.E-12
7123  REAL,PARAMETER ::      H45M12=4.5E-12
7124  REAL,PARAMETER ::      H44M12=4.4E-12
7125  REAL,PARAMETER ::      H4M12=4.E-12
7126  REAL,PARAMETER ::      H38M12=3.8E-12
7127  REAL,PARAMETER ::      H37M12=3.7E-12
7128  REAL,PARAMETER ::      H3M12=3.E-12
7129  REAL,PARAMETER ::      H29M12=2.9E-12
7130  REAL,PARAMETER ::      H28M12=2.8E-12
7131  REAL,PARAMETER ::      H24M12=2.4E-12
7132  REAL,PARAMETER ::      H21M12=2.1E-12
7133  REAL,PARAMETER ::      H16M12=1.6E-12
7134  REAL,PARAMETER ::      H14M12=1.4E-12
7135  REAL,PARAMETER ::      H12M12=1.2E-12
7136  REAL,PARAMETER ::      H8M13=8.E-13
7137  REAL,PARAMETER ::      H46M13=4.6E-13
7138  REAL,PARAMETER ::      H36M13=3.6E-13
7139  REAL,PARAMETER ::      H135M13=1.35E-13
7140  REAL,PARAMETER ::      H12M13=1.2E-13
7141  REAL,PARAMETER ::      H1M13=1.E-13
7142  REAL,PARAMETER ::      H3M14=3.E-14
7143  REAL,PARAMETER ::      H15M14=1.5E-14
7144  REAL,PARAMETER ::      H14M14=1.4E-14
7145 !
7146 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
7147 !          ARRANGED IN DESCENDING ORDER
7148  REAL,PARAMETER ::      HM2M2=-.02
7149  REAL,PARAMETER ::      HM6666M2=-.066667
7150  REAL,PARAMETER ::      HMP5=-0.5
7151  REAL,PARAMETER ::      HMP575=-0.575
7152  REAL,PARAMETER ::      HMP66667=-.66667
7153  REAL,PARAMETER ::      HMP805=-0.805
7154  REAL,PARAMETER ::      HM1EZ=-1.
7155  REAL,PARAMETER ::      HM13EZ=-1.3
7156  REAL,PARAMETER ::      HM19EZ=-1.9
7157  REAL,PARAMETER ::      HM1E1=-10.
7158  REAL,PARAMETER ::      HM1597E1=-15.97469413
7159  REAL,PARAMETER ::      HM161E1=-16.1
7160  REAL,PARAMETER ::      HM1797E1=-17.97469413
7161  REAL,PARAMETER ::      HM181E1=-18.1
7162  REAL,PARAMETER ::      HM8E1=-80.
7163  REAL,PARAMETER ::      HM1E2=-100.
7164 !
7165  REAL,PARAMETER ::      H1M16=1.0E-16
7166  REAL,PARAMETER ::      H1M20=1.E-20
7167  REAL,PARAMETER ::      HP98=0.98
7168  REAL,PARAMETER ::      Q19001=19.001
7169  REAL,PARAMETER ::      DAYSEC=1.1574E-5
7170  REAL,PARAMETER ::      HSIGMA=5.673E-5
7171  REAL,PARAMETER ::      TWENTY=20.0
7172  REAL,PARAMETER ::      HP537=0.537
7173  REAL,PARAMETER ::      HP2=0.2
7174  REAL,PARAMETER ::      RCO2=3.3E-4
7175  REAL,PARAMETER ::      H3M6=3.0E-6
7176  REAL,PARAMETER ::      PI=3.1415927
7177  REAL,PARAMETER ::      DEGRAD1=180.0/PI
7178  REAL,PARAMETER ::      H74E1=74.0
7179  REAL,PARAMETER ::      H15E1=15.0
7180
7181  REAL, PARAMETER:: B0 = -.51926410E-4
7182  REAL, PARAMETER:: B1 = -.18113332E-3
7183  REAL, PARAMETER:: B2 = -.10680132E-5
7184  REAL, PARAMETER:: B3 = -.67303519E-7
7185  REAL, PARAMETER:: AWIDE = 0.309801E+01
7186  REAL, PARAMETER:: BWIDE = 0.495357E-01
7187  REAL, PARAMETER:: BETAWD = 0.347839E+02
7188  REAL, PARAMETER:: BETINW = 0.766811E+01
7189
7190
7191 !     REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
7192 !                          TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
7193 !                          SOURCE(28,NBLY), DSRCE(28,NBLY)
7194
7195 !
7196       REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW)
7197       REAL :: BANDLO(NBLW),BANDHI(NBLW)
7198
7199       INTEGER :: IBAND(40)
7200
7201       REAL :: BANDL1(64),BANDL2(64),BANDL3(35)
7202       REAL :: BANDH1(64),BANDH2(64),BANDH3(35)
7203 !     REAL :: AB15WD,SKO2D,SKC1R,SKO3R
7204
7205 !     REAL :: AWIDE,BWIDE,BETAWD,BETINW
7206
7207 !     DATA AWIDE  / 0.309801E+01/
7208 !     DATA BWIDE  / 0.495357E-01/
7209 !     DATA BETAWD / 0.347839E+02/
7210 !     DATA BETINW / 0.766811E+01/
7211
7212 !
7213 !% #NPADL = #PAGE*#NPAGE -  4*28*180  -  2*181 - 7*28 - 180 ;
7214 !% #NPADL = #NPADL       -  11*28  - 2*180 - 2*30 ;
7215
7216 !     PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW)
7217
7218       REAL ::  &
7219                SUM(28,180),PERTSM(28,180),SUM3(28,180),       &
7220                SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), &
7221                DBDTNB(28,NBLW)
7222       REAL ::  &
7223                ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), &
7224                TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), &
7225                SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28),     &
7226                R1T(28),R2(28),S2(28),T3(28),R1WD(28)
7227       REAL ::  EXPO(180),FAC(180)
7228       REAL ::  CNUSB(30),DNUSB(30)
7229       REAL ::  ALFANB(NBLW),AROTNB(NBLW)
7230       REAL ::  ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), &
7231                BETANB(NBLW)
7232
7233       REAL ::  AB15(2)
7234
7235       REAL ::   ARNDM1(64),ARNDM2(64),ARNDM3(35)
7236       REAL ::   BRNDM1(64),BRNDM2(64),BRNDM3(35)
7237       REAL ::   BETAD1(64),BETAD2(64),BETAD3(35)
7238
7239       EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), &
7240                   (ARNDM3(1),ARNDM(129))
7241       EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), &
7242                   (BRNDM3(1),BRNDM(129))
7243       EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), &
7244                   (BETAD3(1),BETAD(129))
7245
7246 !---------------------------------------------------------------
7247       REAL    :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp
7248       INTEGER :: N,I,ICNT,I1,I2E,I2
7249       INTEGER :: J,JP,NSUBDS,NSB,IA
7250
7251 !---------------------------------------------------------------
7252
7253       DATA IBAND  / &
7254           2,   1,   2,   2,   1,   2,   1,   3,   2,   2, &
7255           3,   2,   2,   4,   2,   4,   2,   3,   3,   2, &
7256           4,   3,   4,   3,   7,   5,   6,   7,   6,   5, &
7257           7,   6,   7,   8,   6,   6,   8,   8,   8,   8/
7258
7259       DATA BANDL1 / &
7260          0.000000E+00,  0.100000E+02,  0.200000E+02,  0.300000E+02, &
7261          0.400000E+02,  0.500000E+02,  0.600000E+02,  0.700000E+02, &
7262          0.800000E+02,  0.900000E+02,  0.100000E+03,  0.110000E+03, &
7263          0.120000E+03,  0.130000E+03,  0.140000E+03,  0.150000E+03, &
7264          0.160000E+03,  0.170000E+03,  0.180000E+03,  0.190000E+03, &
7265          0.200000E+03,  0.210000E+03,  0.220000E+03,  0.230000E+03, &
7266          0.240000E+03,  0.250000E+03,  0.260000E+03,  0.270000E+03, &
7267          0.280000E+03,  0.290000E+03,  0.300000E+03,  0.310000E+03, &
7268          0.320000E+03,  0.330000E+03,  0.340000E+03,  0.350000E+03, &
7269          0.360000E+03,  0.370000E+03,  0.380000E+03,  0.390000E+03, &
7270          0.400000E+03,  0.410000E+03,  0.420000E+03,  0.430000E+03, &
7271          0.440000E+03,  0.450000E+03,  0.460000E+03,  0.470000E+03, &
7272          0.480000E+03,  0.490000E+03,  0.500000E+03,  0.510000E+03, &
7273          0.520000E+03,  0.530000E+03,  0.540000E+03,  0.550000E+03, &
7274          0.560000E+03,  0.670000E+03,  0.800000E+03,  0.900000E+03, &
7275          0.990000E+03,  0.107000E+04,  0.120000E+04,  0.121000E+04/
7276       DATA BANDL2 / &
7277          0.122000E+04,  0.123000E+04,  0.124000E+04,  0.125000E+04, &
7278          0.126000E+04,  0.127000E+04,  0.128000E+04,  0.129000E+04, &
7279          0.130000E+04,  0.131000E+04,  0.132000E+04,  0.133000E+04, &
7280          0.134000E+04,  0.135000E+04,  0.136000E+04,  0.137000E+04, &
7281          0.138000E+04,  0.139000E+04,  0.140000E+04,  0.141000E+04, &
7282          0.142000E+04,  0.143000E+04,  0.144000E+04,  0.145000E+04, &
7283          0.146000E+04,  0.147000E+04,  0.148000E+04,  0.149000E+04, &
7284          0.150000E+04,  0.151000E+04,  0.152000E+04,  0.153000E+04, &
7285          0.154000E+04,  0.155000E+04,  0.156000E+04,  0.157000E+04, &
7286          0.158000E+04,  0.159000E+04,  0.160000E+04,  0.161000E+04, &
7287          0.162000E+04,  0.163000E+04,  0.164000E+04,  0.165000E+04, &
7288          0.166000E+04,  0.167000E+04,  0.168000E+04,  0.169000E+04, &
7289          0.170000E+04,  0.171000E+04,  0.172000E+04,  0.173000E+04, &
7290          0.174000E+04,  0.175000E+04,  0.176000E+04,  0.177000E+04, &
7291          0.178000E+04,  0.179000E+04,  0.180000E+04,  0.181000E+04, &
7292          0.182000E+04,  0.183000E+04,  0.184000E+04,  0.185000E+04/
7293       DATA BANDL3 / &
7294          0.186000E+04,  0.187000E+04,  0.188000E+04,  0.189000E+04, &
7295          0.190000E+04,  0.191000E+04,  0.192000E+04,  0.193000E+04, &
7296          0.194000E+04,  0.195000E+04,  0.196000E+04,  0.197000E+04, &
7297          0.198000E+04,  0.199000E+04,  0.200000E+04,  0.201000E+04, &
7298          0.202000E+04,  0.203000E+04,  0.204000E+04,  0.205000E+04, &
7299          0.206000E+04,  0.207000E+04,  0.208000E+04,  0.209000E+04, &
7300          0.210000E+04,  0.211000E+04,  0.212000E+04,  0.213000E+04, &
7301          0.214000E+04,  0.215000E+04,  0.216000E+04,  0.217000E+04, &
7302          0.218000E+04,  0.219000E+04,  0.227000E+04/
7303
7304       DATA BANDH1 / &
7305          0.100000E+02,  0.200000E+02,  0.300000E+02,  0.400000E+02, &
7306          0.500000E+02,  0.600000E+02,  0.700000E+02,  0.800000E+02, &
7307          0.900000E+02,  0.100000E+03,  0.110000E+03,  0.120000E+03, &
7308          0.130000E+03,  0.140000E+03,  0.150000E+03,  0.160000E+03, &
7309          0.170000E+03,  0.180000E+03,  0.190000E+03,  0.200000E+03, &
7310          0.210000E+03,  0.220000E+03,  0.230000E+03,  0.240000E+03, &
7311          0.250000E+03,  0.260000E+03,  0.270000E+03,  0.280000E+03, &
7312          0.290000E+03,  0.300000E+03,  0.310000E+03,  0.320000E+03, &
7313          0.330000E+03,  0.340000E+03,  0.350000E+03,  0.360000E+03, &
7314          0.370000E+03,  0.380000E+03,  0.390000E+03,  0.400000E+03, &
7315          0.410000E+03,  0.420000E+03,  0.430000E+03,  0.440000E+03, &
7316          0.450000E+03,  0.460000E+03,  0.470000E+03,  0.480000E+03, &
7317          0.490000E+03,  0.500000E+03,  0.510000E+03,  0.520000E+03, &
7318          0.530000E+03,  0.540000E+03,  0.550000E+03,  0.560000E+03, &
7319          0.670000E+03,  0.800000E+03,  0.900000E+03,  0.990000E+03, &
7320          0.107000E+04,  0.120000E+04,  0.121000E+04,  0.122000E+04/
7321       DATA BANDH2 / &
7322          0.123000E+04,  0.124000E+04,  0.125000E+04,  0.126000E+04, &
7323          0.127000E+04,  0.128000E+04,  0.129000E+04,  0.130000E+04, &
7324          0.131000E+04,  0.132000E+04,  0.133000E+04,  0.134000E+04, &
7325          0.135000E+04,  0.136000E+04,  0.137000E+04,  0.138000E+04, &
7326          0.139000E+04,  0.140000E+04,  0.141000E+04,  0.142000E+04, &
7327          0.143000E+04,  0.144000E+04,  0.145000E+04,  0.146000E+04, &
7328          0.147000E+04,  0.148000E+04,  0.149000E+04,  0.150000E+04, &
7329          0.151000E+04,  0.152000E+04,  0.153000E+04,  0.154000E+04, &
7330          0.155000E+04,  0.156000E+04,  0.157000E+04,  0.158000E+04, &
7331          0.159000E+04,  0.160000E+04,  0.161000E+04,  0.162000E+04, &
7332          0.163000E+04,  0.164000E+04,  0.165000E+04,  0.166000E+04, &
7333          0.167000E+04,  0.168000E+04,  0.169000E+04,  0.170000E+04, &
7334          0.171000E+04,  0.172000E+04,  0.173000E+04,  0.174000E+04, &
7335          0.175000E+04,  0.176000E+04,  0.177000E+04,  0.178000E+04, &
7336          0.179000E+04,  0.180000E+04,  0.181000E+04,  0.182000E+04, &
7337          0.183000E+04,  0.184000E+04,  0.185000E+04,  0.186000E+04/
7338       DATA BANDH3 / &
7339          0.187000E+04,  0.188000E+04,  0.189000E+04,  0.190000E+04, &
7340          0.191000E+04,  0.192000E+04,  0.193000E+04,  0.194000E+04, &
7341          0.195000E+04,  0.196000E+04,  0.197000E+04,  0.198000E+04, &
7342          0.199000E+04,  0.200000E+04,  0.201000E+04,  0.202000E+04, &
7343          0.203000E+04,  0.204000E+04,  0.205000E+04,  0.206000E+04, &
7344          0.207000E+04,  0.208000E+04,  0.209000E+04,  0.210000E+04, &
7345          0.211000E+04,  0.212000E+04,  0.213000E+04,  0.214000E+04, &
7346          0.215000E+04,  0.216000E+04,  0.217000E+04,  0.218000E+04, &
7347          0.219000E+04,  0.220000E+04,  0.238000E+04/
7348
7349 !
7350 !***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING
7351 !   THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS
7352       DATA ARNDM1  / &
7353          0.354693E+00,  0.269857E+03,  0.167062E+03,  0.201314E+04, &
7354          0.964533E+03,  0.547971E+04,  0.152933E+04,  0.599429E+04, &
7355          0.699329E+04,  0.856721E+04,  0.962489E+04,  0.233348E+04, &
7356          0.127091E+05,  0.104383E+05,  0.504249E+04,  0.181227E+05, &
7357          0.856480E+03,  0.136354E+05,  0.288635E+04,  0.170200E+04, &
7358          0.209761E+05,  0.126797E+04,  0.110096E+05,  0.336436E+03, &
7359          0.491663E+04,  0.863701E+04,  0.540389E+03,  0.439786E+04, &
7360          0.347836E+04,  0.130557E+03,  0.465332E+04,  0.253086E+03, &
7361          0.257387E+04,  0.488041E+03,  0.892991E+03,  0.117148E+04, &
7362          0.125880E+03,  0.458852E+03,  0.142975E+03,  0.446355E+03, &
7363          0.302887E+02,  0.394451E+03,  0.438112E+02,  0.348811E+02, &
7364          0.615503E+02,  0.143165E+03,  0.103958E+02,  0.725108E+02, &
7365          0.316628E+02,  0.946456E+01,  0.542675E+02,  0.351557E+02, &
7366          0.301797E+02,  0.381010E+01,  0.126319E+02,  0.548010E+01, &
7367          0.600199E+01,  0.640803E+00,  0.501549E-01,  0.167961E-01, &
7368          0.178110E-01,  0.170166E+00,  0.273514E-01,  0.983767E+00/
7369       DATA ARNDM2  / &
7370          0.753946E+00,  0.941763E-01,  0.970547E+00,  0.268862E+00, &
7371          0.564373E+01,  0.389794E+01,  0.310955E+01,  0.128235E+01, &
7372          0.196414E+01,  0.247113E+02,  0.593435E+01,  0.377552E+02, &
7373          0.305173E+02,  0.852479E+01,  0.116780E+03,  0.101490E+03, &
7374          0.138939E+03,  0.324228E+03,  0.683729E+02,  0.471304E+03, &
7375          0.159684E+03,  0.427101E+03,  0.114716E+03,  0.106190E+04, &
7376          0.294607E+03,  0.762948E+03,  0.333199E+03,  0.830645E+03, &
7377          0.162512E+04,  0.525676E+03,  0.137739E+04,  0.136252E+04, &
7378          0.147164E+04,  0.187196E+04,  0.131118E+04,  0.103975E+04, &
7379          0.621637E+01,  0.399459E+02,  0.950648E+02,  0.943161E+03, &
7380          0.526821E+03,  0.104150E+04,  0.905610E+03,  0.228142E+04, &
7381          0.806270E+03,  0.691845E+03,  0.155237E+04,  0.192241E+04, &
7382          0.991871E+03,  0.123907E+04,  0.457289E+02,  0.146146E+04, &
7383          0.319382E+03,  0.436074E+03,  0.374214E+03,  0.778217E+03, &
7384          0.140227E+03,  0.562540E+03,  0.682685E+02,  0.820292E+02, &
7385          0.178779E+03,  0.186150E+03,  0.383864E+03,  0.567416E+01/
7386       DATA ARNDM3  / &
7387          0.225129E+03,  0.473099E+01,  0.753149E+02,  0.233689E+02, &
7388          0.339802E+02,  0.108855E+03,  0.380016E+02,  0.151039E+01, &
7389          0.660346E+02,  0.370165E+01,  0.234169E+02,  0.440206E+00, &
7390          0.615283E+01,  0.304077E+02,  0.117769E+01,  0.125248E+02, &
7391          0.142652E+01,  0.241831E+00,  0.483721E+01,  0.226357E-01, &
7392          0.549835E+01,  0.597067E+00,  0.404553E+00,  0.143584E+01, &
7393          0.294291E+00,  0.466273E+00,  0.156048E+00,  0.656185E+00, &
7394          0.172727E+00,  0.118349E+00,  0.141598E+00,  0.588581E-01, &
7395          0.919409E-01,  0.155521E-01,  0.537083E-02/
7396       DATA BRNDM1  / &
7397          0.789571E-01,  0.920256E-01,  0.696960E-01,  0.245544E+00, &
7398          0.188503E+00,  0.266127E+00,  0.271371E+00,  0.330917E+00, &
7399          0.190424E+00,  0.224498E+00,  0.282517E+00,  0.130675E+00, &
7400          0.212579E+00,  0.227298E+00,  0.138585E+00,  0.187106E+00, &
7401          0.194527E+00,  0.177034E+00,  0.115902E+00,  0.118499E+00, &
7402          0.142848E+00,  0.216869E+00,  0.149848E+00,  0.971585E-01, &
7403          0.151532E+00,  0.865628E-01,  0.764246E-01,  0.100035E+00, &
7404          0.171133E+00,  0.134737E+00,  0.105173E+00,  0.860832E-01, &
7405          0.148921E+00,  0.869234E-01,  0.106018E+00,  0.184865E+00, &
7406          0.767454E-01,  0.108981E+00,  0.123094E+00,  0.177287E+00, &
7407          0.848146E-01,  0.119356E+00,  0.133829E+00,  0.954505E-01, &
7408          0.155405E+00,  0.164167E+00,  0.161390E+00,  0.113287E+00, &
7409          0.714720E-01,  0.741598E-01,  0.719590E-01,  0.140616E+00, &
7410          0.355356E-01,  0.832779E-01,  0.128680E+00,  0.983013E-01, &
7411          0.629660E-01,  0.643346E-01,  0.717082E-01,  0.629730E-01, &
7412          0.875182E-01,  0.857907E-01,  0.358808E+00,  0.178840E+00/
7413       DATA BRNDM2  / &
7414          0.254265E+00,  0.297901E+00,  0.153916E+00,  0.537774E+00, &
7415          0.267906E+00,  0.104254E+00,  0.400723E+00,  0.389670E+00, &
7416          0.263701E+00,  0.338116E+00,  0.351528E+00,  0.267764E+00, &
7417          0.186419E+00,  0.238237E+00,  0.210408E+00,  0.176869E+00, &
7418          0.114715E+00,  0.173299E+00,  0.967770E-01,  0.172565E+00, &
7419          0.162085E+00,  0.157782E+00,  0.886832E-01,  0.242999E+00, &
7420          0.760298E-01,  0.164248E+00,  0.221428E+00,  0.166799E+00, &
7421          0.312514E+00,  0.380600E+00,  0.353828E+00,  0.269500E+00, &
7422          0.254759E+00,  0.285408E+00,  0.159764E+00,  0.721058E-01, &
7423          0.170528E+00,  0.231595E+00,  0.307184E+00,  0.564136E-01, &
7424          0.159884E+00,  0.147907E+00,  0.185666E+00,  0.183567E+00, &
7425          0.182482E+00,  0.230650E+00,  0.175348E+00,  0.195978E+00, &
7426          0.255323E+00,  0.198517E+00,  0.195500E+00,  0.208356E+00, &
7427          0.309603E+00,  0.112011E+00,  0.102570E+00,  0.128276E+00, &
7428          0.168100E+00,  0.177836E+00,  0.105533E+00,  0.903330E-01, &
7429          0.126036E+00,  0.101430E+00,  0.124546E+00,  0.221406E+00/
7430       DATA BRNDM3  / &
7431          0.137509E+00,  0.911365E-01,  0.724508E-01,  0.795788E-01, &
7432          0.137411E+00,  0.549175E-01,  0.787714E-01,  0.165544E+00, &
7433          0.136484E+00,  0.146729E+00,  0.820496E-01,  0.846211E-01, &
7434          0.785821E-01,  0.122527E+00,  0.125359E+00,  0.101589E+00, &
7435          0.155756E+00,  0.189239E+00,  0.999086E-01,  0.480993E+00, &
7436          0.100233E+00,  0.153754E+00,  0.130780E+00,  0.136136E+00, &
7437          0.159353E+00,  0.156634E+00,  0.272265E+00,  0.186874E+00, &
7438          0.192090E+00,  0.135397E+00,  0.131497E+00,  0.127463E+00, &
7439          0.227233E+00,  0.190562E+00,  0.214005E+00/
7440       DATA BETAD1  / &
7441          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7442          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7443          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7444          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7445          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7446          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7447          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7448          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7449          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7450          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7451          0.234879E+03,  0.217419E+03,  0.201281E+03,  0.186364E+03, &
7452          0.172576E+03,  0.159831E+03,  0.148051E+03,  0.137163E+03, &
7453          0.127099E+03,  0.117796E+03,  0.109197E+03,  0.101249E+03, &
7454          0.939031E+02,  0.871127E+02,  0.808363E+02,  0.750349E+02, &
7455          0.497489E+02,  0.221212E+02,  0.113124E+02,  0.754174E+01, &
7456          0.589554E+01,  0.495227E+01,  0.000000E+00,  0.000000E+00/
7457       DATA BETAD2  / &
7458          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7459          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7460          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7461          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7462          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7463          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7464          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7465          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7466          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7467          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7468          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7469          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7470          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7471          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7472          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7473          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00/
7474       DATA BETAD3  / &
7475          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7476          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7477          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7478          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7479          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7480          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7481          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7482          0.000000E+00,  0.000000E+00,  0.000000E+00,  0.000000E+00, &
7483          0.000000E+00,  0.000000E+00,  0.000000E+00/
7484 !---------------------------------------------------------------
7485 !     EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), &
7486 !                 (BANDL3(1),BANDLO(129))
7487
7488 !     L     = kme-1
7489 !     LP1   = L+1
7490 !     LP1V  = LP1*(1+2*L/2)
7491 !     IMAX  = ite
7492 !     LP2   = L + 2
7493
7494       DO I = 1,64
7495          BANDLO(I)=BANDL1(I)
7496       ENDDO
7497
7498       DO I = 65,128
7499          BANDLO(I)=BANDL2(I-64)
7500       ENDDO
7501
7502       DO I = 129,163
7503          BANDLO(I)=BANDL3(I-128)
7504       ENDDO
7505
7506       DO I = 1,64
7507          BANDHI(I)=BANDH1(I)
7508       ENDDO
7509
7510       DO I = 65,128
7511          BANDHI(I)=BANDH2(I-64)
7512       ENDDO
7513
7514       DO I = 129,163
7515          BANDHI(I)=BANDH3(I-128)
7516       ENDDO
7517
7518 !****************************************
7519 !***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
7520 !....FOR NARROW-BANDS...
7521       DO 101 N=1,NBLW
7522       ANB(N)=ARNDM(N)
7523       BNB(N)=BRNDM(N)
7524       CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N))
7525       DELNB(N)=BANDHI(N)-BANDLO(N)
7526       BETANB(N)=BETAD(N)
7527 101   CONTINUE
7528       AB15(1)=ANB(57)*BNB(57)
7529       AB15(2)=ANB(58)*BNB(58)
7530 !....FOR WIDE BANDS...
7531       AB15WD=AWIDE*BWIDE
7532 !
7533 !***COMPUTE INDICES: IND,INDX2,KMAXV
7534 !SH   ICNT=0
7535 !SH   DO 113 I1=1,L
7536 !SH     I2E=LP1-I1
7537 !SH     DO 115 I2=1,I2E
7538 !SH       ICNT=ICNT+1
7539 !SH       INDX2(ICNT)=LP1*(I2-1)+LP2*I1
7540 !SH115     CONTINUE
7541 !SH113   CONTINUE
7542 !SH   KMAXV(1)=1
7543 !SH   DO 117 I=2,L
7544 !SH   KMAXV(I)=KMAXV(I-1)+(LP2-I)
7545 117   CONTINUE
7546 !SH   KMAXVM=KMAXV(L)
7547 !***COMPUTE RATIOS OF CONT. COEFFS
7548       SKC1R=BETAWD/BETINW
7549       SKO3R=BETAD(61)/BETINW
7550       SKO2D=ONE/BETINW
7551 !
7552 !****BEGIN TABLE COMPUTATIONS HERE***
7553 !***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES
7554 !---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS
7555 !   WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM
7556 !   100K TO 370K.
7557 !---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF
7558 !   180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS
7559 !   ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS.
7560       ZMASS(1)=H1M16
7561       DO 201 J=1,180
7562       JP=J+1
7563       ZROOT(J)=SQRT(ZMASS(J))
7564       ZMASS(JP)=ZMASS(J)*H1P25892
7565 201   CONTINUE
7566       DO 203 I=1,28
7567       XTEMV(I)=HNINETY+TEN*I
7568       TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
7569       FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I)
7570 203   CONTINUE
7571 !******THE COMPUTATION OF SOURCE,DSRCE IS  NEEDED ONLY
7572 !   FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE
7573 !   MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD)
7574 !   THEN COMBINED (USING IBAND) INTO SOURCE.
7575       DO 205 N=1,NBLY
7576       DO 205 I=1,28
7577       SOURCE(I,N)=ZERO
7578 205   CONTINUE
7579       DO 207 N=1,NBLX
7580       DO 207 I=1,28
7581       SRCWD(I,N)=ZERO
7582 207   CONTINUE
7583 !---BEGIN FREQ. LOOP (ON N)
7584       DO 211 N=1,NBLX
7585         IF (N.LE.46) THEN
7586 !***THE 160-1200 BAND CASES
7587           CENT=CENTNB(N+16)
7588           DEL=DELNB(N+16)
7589           BDLO=BANDLO(N+16)
7590           BDHI=BANDHI(N+16)
7591         ENDIF
7592         IF (N.EQ.NBLX) THEN
7593 !***THE 2270-2380 BAND CASE
7594           CENT=CENTNB(NBLW)
7595           DEL=DELNB(NBLW)
7596           BDLO=BANDLO(NBLW)
7597           BDHI=BANDHI(NBLW)
7598         ENDIF
7599 !***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE
7600 !  ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS.
7601       NSUBDS=(DEL-H1M3)/10+1
7602       DO 213 NSB=1,NSUBDS
7603       IF (NSB.NE.NSUBDS) THEN
7604         CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE
7605         DNUSB(NSB)=TEN
7606       ELSE
7607         CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI)
7608         DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO)
7609       ENDIF
7610       C1=(H37412M5)*CNUSB(NSB)**3
7611 !---BEGIN TEMP. LOOP (ON I)
7612       DO 215 I=1,28
7613       X(I)=H1P4387*CNUSB(NSB)/XTEMV(I)
7614       X1(I)=EXP(X(I))
7615       SRCS(I)=C1/(X1(I)-ONE)
7616       SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
7617 215   CONTINUE
7618 213   CONTINUE
7619 211   CONTINUE
7620 !***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
7621 !   AND DSRCE
7622       DO 221 N=1,40
7623       DO 221 I=1,28
7624       SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
7625 221   CONTINUE
7626       DO 223 N=9,NBLY
7627       DO 223 I=1,28
7628       SOURCE(I,N)=SRCWD(I,N+32)
7629 223   CONTINUE
7630       DO 225 N=1,NBLY
7631       DO 225 I=1,27
7632       DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1
7633 225   CONTINUE
7634       DO 231 N=1,NBLW
7635       ALFANB(N)=BNB(N)*ANB(N)
7636       AROTNB(N)=SQRT(ALFANB(N))
7637 231   CONTINUE
7638 !***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR
7639 !   USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE
7640 !   BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ.
7641 !   RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT.
7642 !
7643       DO 301 N=1,NBLW
7644       CENT=CENTNB(N)
7645       DEL=DELNB(N)
7646 !---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT
7647 !   IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR
7648 !   THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY.
7649 #if 0
7650       DO 303 IA=1,3
7651 #else
7652 !jm -- getting floating point exceptions for IA=1, since 2 is only
7653 !      used anyway, I disabled the looping.
7654       DO 303 IA=2,2
7655 #endif
7656       ANU=CENT+HAF*(IA-2)*DEL
7657       C1=(H37412M5)*ANU*ANU*ANU+H1M20
7658 !---TEMPERATURE LOOP---
7659       DO 305 I=1,28
7660          X(I)=H1P4387*ANU/XTEMV(I)
7661          X1(I)=EXP(X(I))
7662 !#$      tmp=max((X1(I)-ONE),H1M20)
7663 !#$      SC(I)=C1/tmp
7664          SC(I)=C1/((X1(I)-ONE)+H1M20)
7665 !#$      DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1)
7666          DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
7667 305      CONTINUE
7668       IF (IA.EQ.2) THEN
7669          DO 307 I=1,28
7670          SRC1NB(I,N)=DEL*SC(I)
7671          DBDTNB(I,N)=DEL*DSC(I)
7672 307      CONTINUE
7673       ENDIF
7674 303   CONTINUE
7675 301   CONTINUE
7676 !***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION
7677 !   WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A
7678 !   DIFFERENT DEPENDENCE ON (ZMASS).
7679 !---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE
7680       DO 311 I=1,28
7681       SUM4(I)=ZERO
7682       SUM6(I)=ZERO
7683       SUM7(I)=ZERO
7684       SUM8(I)=ZERO
7685       SUM4WD(I)=ZERO
7686 311   CONTINUE
7687       DO 313 N=1,NBLW
7688       CENT=CENTNB(N)
7689 !***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4
7690 !   SUM6,SUM7,SUM8
7691       IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7692          DO 315 I=1,28
7693          SUM4(I)=SUM4(I)+SRC1NB(I,N)
7694          SUM6(I)=SUM6(I)+DBDTNB(I,N)
7695          SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N)
7696          SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N)
7697 315      CONTINUE
7698       ENDIF
7699 !***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
7700       IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7701          DO 316 I=1,28
7702          SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
7703 316      CONTINUE
7704       ENDIF
7705 313   CONTINUE
7706       DO 317 I=1,28
7707       R1T(I)=SUM4(I)/TFOUR(I)
7708       R2(I)=SUM6(I)/FORTCU(I)
7709       S2(I)=SUM7(I)/FORTCU(I)
7710       T3(I)=SUM8(I)/FORTCU(I)
7711       R1WD(I)=SUM4WD(I)/TFOUR(I)
7712 317   CONTINUE
7713       DO 401 J=1,180
7714       DO 401 I=1,28
7715       SUM(I,J)=ZERO
7716       PERTSM(I,J)=ZERO
7717       SUM3(I,J)=ZERO
7718       SUMWDE(I,J)=ZERO
7719 401   CONTINUE
7720 !---FREQUENCY LOOP BEGINS---
7721       DO 411 N=1,NBLW
7722       CENT=CENTNB(N)
7723 !***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1
7724       IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7725          DO 413 J=1,180
7726          X2(J)=AROTNB(N)*ZROOT(J)
7727          EXPO(J)=EXP(-X2(J))
7728 413      CONTINUE
7729          DO 415 J=1,180
7730          IF (X2(J).GE.HUNDRED) THEN
7731               EXPO(J)=ZERO
7732          ENDIF
7733 415      CONTINUE
7734          DO 417 J=121,180
7735          FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J))
7736 417      CONTINUE
7737          DO 419 J=1,180
7738          DO 419 I=1,28
7739          SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J)
7740          PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J)
7741 419      CONTINUE
7742          DO 421 J=121,180
7743          DO 421 I=1,28
7744          SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
7745 421      CONTINUE
7746       ENDIF
7747 !---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
7748       IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7749          DO 420 J=1,180
7750          DO 420 I=1,28
7751          SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
7752 420      CONTINUE
7753       ENDIF
7754 411   CONTINUE
7755       DO 431 J=1,180
7756       DO 431 I=1,28
7757       EM1(I,J)=SUM(I,J)/TFOUR(I)
7758       TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
7759 431   CONTINUE
7760       DO 433 J=121,180
7761       DO 433 I=1,28
7762       EM3(I,J)=SUM3(I,J)/FORTCU(I)
7763 433   CONTINUE
7764       DO 441 J=1,179
7765       DO 441 I=1,28
7766       TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN
7767 441   CONTINUE
7768       DO 443 J=1,180
7769       DO 443 I=1,27
7770       TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1
7771 443   CONTINUE
7772       DO 445 I=1,28
7773       TABLE2(I,180)=ZERO
7774 445   CONTINUE
7775       DO 447 J=1,180
7776       TABLE3(28,J)=ZERO
7777 447   CONTINUE
7778       DO 449 J=1,2
7779       DO 449 I=1,28
7780       EM1(I,J)=R1T(I)
7781 449   CONTINUE
7782       DO 451 J=1,120
7783       DO 451 I=1,28
7784       EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT
7785 451   CONTINUE
7786       DO 453 J=121,180
7787       DO 453 I=1,28
7788       EM3(I,J)=EM3(I,J)/ZMASS(J)
7789 453   CONTINUE
7790 !***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
7791 !   WE USE R1WD AND SUMWDE OBTAINED ABOVE.
7792       DO 501 J=1,180
7793       DO 501 I=1,28
7794       EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
7795 501   CONTINUE
7796       DO 503 J=1,2
7797       DO 503 I=1,28
7798       EM1WDE(I,J)=R1WD(I)
7799 503   CONTINUE
7800
7801       END SUBROUTINE TABLE
7802
7803 !---------------------------------------------------------------------
7804     SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR)
7805 !---------------------------------------------------------------------
7806     IMPLICIT NONE
7807 !---------------------------------------------------------------------
7808 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
7809 !                .      .    .                               .
7810 ! SUBPROGRAM:    SOLARD      COMPUTE THE SOLAR-EARTH DISTANCE
7811 !   PRGRMMR: Q.ZHAO           ORG: W/NMC2     DATE: 96-7-23
7812 !
7813 ! ABSTRACT:
7814 !     SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY
7815 !     FOR USE IN SHORT-WAVE RADIATION.
7816 !
7817 ! PROGRAM HISTORY LOG:
7818 !   96-07-23  Q.ZHAO      - ORIGINATOR
7819 !   98-10-09  Q.ZHAO      - CHANGED TO USE IW3JDN IN W3LIB TO
7820 !                           CALCULATE JD.
7821 !   04-11-18  Y.-T. HOU   - FIXED ERROR IN JULIAN DAY CALCULATION
7822 !
7823 ! USAGE: CALL SOLARD FROM SUBROUTINE INIT
7824 !
7825 !   INPUT ARGUMENT LIST:
7826 !       NONE
7827 !
7828 !   OUTPUT ARGUMENT LIST:
7829 !       R1   - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH
7830 !              (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER).
7831 !
7832 !   INPUT FILES:
7833 !     NONE
7834 !
7835 !   OUTPUT FILES:
7836 !     NONE
7837 !
7838 !   SUBPROGRAMS CALLED:
7839 !
7840 !     UNIQUE: NONE
7841 !
7842 !     LIBRARY: IW3JDN
7843 !
7844 !   COMMON BLOCKS: CTLBLK
7845 !
7846 ! ATTRIBUTES:
7847 !   LANGUAGE: FORTRAN 90
7848 !   MACHINE : IBM SP
7849 !***********************************************************************
7850      REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI
7851 !-----------------------------------------------------------------------
7852 !     INTEGER, INTENT(IN ) :: IHRST,IDAT(3)
7853       INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR
7854 !     REAL   , INTENT(OUT) :: R1
7855 !-----------------------------------------------------------------------
7856       INTEGER :: NDM(12),JYR19,JMN
7857       REAL    :: CCR
7858
7859       DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/
7860       DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/
7861
7862 !.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900
7863 !.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT
7864 !.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT
7865 !
7866       REAL    :: TPP
7867       DATA TPP/1.55/
7868
7869       INTEGER :: JDOR2,JDOR1
7870       DATA JDOR2/2415020/, JDOR1/2415019/
7871
7872       REAL    :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1
7873       INTEGER :: JHR,JD,ITER
7874 !
7875 !     LIBRARY: IW3JDN
7876 !
7877 !    --------------------------------------------------------------------
7878 !     COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT
7879 !     ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100
7880 !     BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN
7881 !     CALENDAR DURING THIS PERIOD
7882 !    --------------------------------------------------------------------
7883
7884       JHR=IHRST
7885 !
7886       JD=IDAY-32075                                                     &
7887              +1461*(JULYR+4800+(MONTH-14)/12)/4                         &
7888              +367*(MONTH-2-(MONTH-14)/12*12)/12                         &
7889              -3*((JULYR+4900+(MONTH-14)/12)/100)/4
7890       IF(JHR.LT.12)THEN
7891         JD=JD-1
7892         FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN)
7893       ELSE
7894   7     FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN)
7895       END IF
7896       DAYINC=JHR/24.0
7897       FJD1=JD+FJD+DAYINC
7898       JD=FJD1
7899       FJD=FJD1-JD
7900 !***
7901 !*** CALCULATE THE SOLAR-EARTH DISTANCE
7902 !***
7903       DAT=REAL(JD-JDOR2)-TPP+FJD
7904 !***
7905 !    COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH
7906 !***
7907       T=FLOAT(JD-JDOR2)/36525.E0
7908 !***
7909 !    COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS)
7910 !***
7911       YEAR=.25964134E0+.304E-5*T
7912 !***
7913 !    COMPUTES ORBIT ECCENTRICITY FROM T
7914 !***
7915       EC=.01675104E0-(.418E-4+.126E-6*T)*T
7916       YEAR=YEAR+365.E0
7917 !***
7918 !    DATE=DAYS SINCE LAST PERIHELION PASSAGE
7919 !***
7920       DATE = MOD(DAT,YEAR)
7921 !***
7922 !    SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD
7923 !***
7924       EM=PI2*DATE/YEAR
7925       E=1.E0
7926       ITER = 0
7927  31   EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E))
7928       CR=ABS(E-EP)
7929       E=EP
7930       ITER = ITER + 1
7931       IF(ITER.GT.10) GOTO 1031
7932       IF(CR.GT.CCR) GO TO 31
7933  1031 CONTINUE
7934       R1=1.E0-EC*COS(E)
7935 !
7936       WRITE(0,1000)JULYR,MONTH,IDAY,IHRST,R1
7937  1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ &
7938              'YEAR=',I5,'  MONTH=',I3,'  DAY=',I3,' HOUR=' &
7939       ,      I3,' R1=',F9.4)
7940 !***
7941 !    RETURN TO RADTN
7942 !***
7943     END SUBROUTINE SOLARD
7944 !---------------------------------------------------------------------
7945     SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday)
7946 !---------------------------------------------------------------------
7947     IMPLICIT NONE
7948 !-----------------------------------------------------------------------
7949     INTEGER, INTENT(IN) :: JULDAY,julyr
7950     INTEGER, INTENT(OUT) :: Jmonth,Jday
7951     LOGICAL :: LEAP,NOT_FIND_DATE
7952     INTEGER :: MONTH (12),itmpday,itmpmon,i
7953 !-----------------------------------------------------------------------
7954     DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
7955 !***********************************************************************
7956     NOT_FIND_DATE = .true.
7957
7958     itmpday = JULDAY
7959     itmpmon = 1
7960     LEAP=.FALSE.
7961     IF(MOD(julyr,4).EQ.0)THEN
7962       MONTH(2)=29
7963       LEAP=.TRUE.
7964     ENDIF
7965
7966     i = 1
7967     DO WHILE (NOT_FIND_DATE)
7968        IF(itmpday.GT.MONTH(i))THEN
7969          itmpday=itmpday-MONTH(i)
7970        ELSE
7971          Jday=itmpday
7972          Jmonth=i
7973          NOT_FIND_DATE = .false.
7974        ENDIF
7975        i = i+1
7976     END DO
7977
7978     END SUBROUTINE CAL_MON_DAY
7979 !!================================================================================
7980 ! CO2 initialization code
7981
7982       FUNCTION ANTEMP(L,Z)
7983       REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
7984 ! ************** TROPICAL SOUNDING **************************
7985       DATA (ZB(N,1),N=1,10)/  2.0,   3.0,   16.5,  21.5,  45.0, &
7986                               51.0,  70.0,  100.,  200.,  300./
7987       DATA (C(N,1),N=1,11)/ -6.0,  -4.0,  -6.7,   4.0,   2.2,   &
7988                          1.0,  -2.8,  -.27,   0.0,   0.0,  0.0/
7989       DATA (DELTA(N,1),N=1,10)/.5,    .5,    .3,    .5,    1.0, &
7990                               1.0,   1.0,   1.0,   1.0,    1.0/
7991 ! ************** SUB-TROPICAL SUMMER ************************
7992       DATA (ZB(N,2),N=1,10)/ 1.5,   6.5,  13.0,  18.0,  26.0, &
7993                               36.0,  48.0,  50.0, 70.0,  100./
7994       DATA (C(N,2),N=1,11)/ -4.0,  -6.0,  -6.5,   0.0,   1.2, &
7995                         2.2,   2.5,   0.0,  -3.0,  -0.25,  0.0/
7996       DATA (DELTA(N,2),N=1,10)/ .5,  1.0,    .5,    .5,   1.0, &
7997                               1.0,  2.5,    .5,   1.0,   1.0/
7998 ! ************** SUB-TROPICAL WINTER ************************
7999       DATA (ZB(N,3),N=1,10)/ 3.0,  10.0,  19.0,  25.0,  32.0, &
8000                               44.5, 50.0,  71.0,  98.0,  200.0/
8001       DATA (C(N,3),N=1,11)/ -3.5,  -6.0,  -0.5,  0.0,   0.4, &
8002                               3.2,   1.6,  -1.8, -0.7,   0.0,   0.0/
8003       DATA (DELTA(N,3),N=1,10)/ .5,   .5,  1.0,   1.0,   1.0, &
8004                               1.0,  1.0,  1.0,   1.0,   1.0/
8005 ! *************  SUB-ARCTIC SUMMER *************************
8006       DATA (ZB(N,4),N=1,10)/ 4.7, 10.0,  23.0,  31.8,  44.0, &
8007                               50.2, 69.2, 100.0, 102.0, 103.0/
8008       DATA (C(N,4),N=1,11)/ -5.3, -7.0,   0.0,  1.4,   3.0, &
8009                                0.7, -3.3,  -0.2,  0.0,   0.0,  0.0/
8010       DATA (DELTA(N,4),N=1,10)/ .5,   .3,  1.0,   1.0,   2.0, &
8011                               1.0,  1.5,  1.0,   1.0,   1.0/
8012 ! ************ SUB-ARCTIC WINTER *****************************
8013       DATA (ZB(N,5),N=1,10)/ 1.0,   3.2,   8.5,   15.5,   25.0, &
8014                               30.0,  35.0,  50.0,  70.0,  100.0/
8015       DATA (C(N,5),N=1,11)/ 3.0,  -3.2,  -6.8,  0.0,  -0.6, &
8016                               1.0,   1.2,   2.5, -0.7,  -1.2,  0.0/
8017       DATA (DELTA(N,5),N=1,10)/ .4,   1.5,    .3 ,   .5,   1.0, &
8018                               1.0,   1.0,   1.0,   1.0,   1.0/
8019 ! ************ US STANDARD 1976 ******************************
8020       DATA (ZB(N,6),N=1,10)/ 11.0,  20.0,  32.0,  47.0,  51.0, &
8021                              71.0,  84.8520,  90.0,  91.0,  92.0/
8022       DATA (C(N,6),N=1,11)/ -6.5,   0.0,   1.0,   2.80,  0.0, &
8023                              -2.80, -2.00,  0.0,   0.0,   0.0,  0.0/
8024       DATA (DELTA(N,6),N=1,10)/ 0.3,   1.0,   1.0,   1.0,   1.0, &
8025                               1.0,   1.0,   1.0,   1.0,   1.0/
8026 !
8027 ! ************ ENLARGED US STANDARD 1976 **********************
8028       DATA (ZB(N,7),N=1,10)/ 11.0,  20.0,  32.0,  47.0,  51.0, &
8029                              71.0,  84.8520,  90.0,  91.0,  92.0/
8030       DATA (C(N,7),N=1,11)/ -6.5,   0.0,   1.0,   2.80,  0.0, &
8031                              -2.80, -2.00,  0.0,   0.0,   0.0,  0.0/
8032       DATA (DELTA(N,7),N=1,10)/ 0.3,   1.0,   1.0,   1.0,   1.0, &
8033                               1.0,   1.0,   1.0,   1.0,   1.0/
8034 !
8035       DATA TSTAR/ 300.0,  294.0,  272.2,  287.0,  257.1, 2*288.15/
8036 !
8037       NLAST=10
8038       TEMP=TSTAR(L)+C(1,L)*Z
8039       DO 20 N=1,NLAST
8040       EXPO=(Z-ZB(N,L))/DELTA(N,L)
8041       EXPP=ZB(N,L)/DELTA(N,L)
8042 !JD single-precision change
8043 !      FAC=EXP(EXPP)+EXP(-EXPP)
8044 !mp     write(6,*) '.........................................'
8045 !mp what in the hell does the next line do?
8046 !mp
8047 !mp     apparently if statement <0 or =0 then 23, else 24
8048 !mp     IF(ABS(EXPO)-100.0) 23,23,24
8049 !
8050 ! changed to a more reasonable value for the workstation
8051 !
8052       IF(ABS(EXPO)-50.0) 23,23,24
8053    23 X=EXP(EXPO)
8054       Y=X+1.0/X
8055       ZLOG=ALOG(Y)
8056       GO TO 25
8057    24 ZLOG=ABS(EXPO)
8058 !mp   25 IF(EXPP-100.0) 27,27,28
8059    25 IF(EXPP-50.0) 27,27,28
8060 !JD single-precision change
8061    27 FAC=EXP(EXPP)+EXP(-EXPP)
8062       FACLOG=ALOG(FAC)
8063       GO TO 29
8064    28 FACLOG=EXPP
8065 !     TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)*
8066 !    1     ALOG((EXP(EXPO)+EXP(-EXPO))/FAC))
8067    29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* &
8068            (ZLOG-FACLOG))
8069 !mp     write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L),
8070 !mp     +       ZLOG,FACLOG
8071    20 CONTINUE
8072       ANTEMP=TEMP
8073
8074       END FUNCTION ANTEMP
8075
8076 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
8077
8078       SUBROUTINE COEINT(RAT,IR)
8079 ! **********************************************************************
8080 !
8081 !
8082 !            THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO
8083 !       THE  FUNCTIONAL FORM
8084 !                     TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)),
8085 !               WHERE
8086 !                     PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/
8087 !                                 (ETA*(P1+P2+CORE)+(P1-P2))
8088 !
8089 !
8090 !        THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER
8091 !        WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH
8092 !        PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL
8093 !        VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER.
8094 !            SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT
8095 !        VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU
8096 !        ITERATION VALUE OF ETA.
8097 !             DEFINE:
8098 !                PATHA=PATH(P(I),P(I-2),CORE,ETA)
8099 !                PATHB=PATH(P(I),P(I-1),CORE,ETA);
8100 !        THEN
8101 !                R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1)))
8102 !                 = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)),
8103 !        SO THAT
8104 !                R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB).
8105 !        THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T
8106 !        RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE
8107 !        THAN 2 TO GIVE THE ARRAYS X(I) AND C(I).
8108 !             NEWTON S METHOD FOR SOLVING THE EQUATION
8109 !                 F(X)=0
8110 !        MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD).
8111 !        THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE.
8112 !        THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS
8113 !        BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T
8114 !        (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T
8115 !        USED FOR INTERPOLATION.
8116 !           THERE ARE SEVERAL POSSIBLE PITFALLS:
8117 !              1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH
8118 !                 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP
8119 !                 AND AN ERROR MESSAGE IS PRINTED OUT.
8120 !              2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT
8121 !                 BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C
8122 !                 NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF
8123 !                 A WARNING IS PRINTED OUT.
8124 !
8125 !  *********************************************************************
8126 !....
8127 !     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8128 !     COMMON/PRESS/PA(109)
8129       REAL RAT,SINV
8130 !     REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
8131       REAL PA2
8132 !     COMMON/TRAN/ TRANSA(109,109)
8133 !     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
8134       DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109)
8135       DIMENSION SINV(4)
8136       INTEGER :: IERR
8137       DATA SINV/2.74992,2.12731,4.38111,0.0832926/
8138 !NOV89   DIMENSION SINV(3)
8139 !NOV89   DATA SINV/2.74992,2.12731,4.38111/
8140 !O222  OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988
8141 !O222   WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS
8142       CORE=5.000
8143       UEXP=0.90
8144 !      P0=0.7
8145       DO 902 I=1,109
8146       PA2=PA(I)*PA(I)
8147       SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25)
8148 902   CONTINUE
8149       DO 900 I=1,109
8150       ETA(I)=3.2E-4*EXP(-PA(I)/500.)
8151       ETAP(I)=ETA(I)
8152 900   CONTINUE
8153       DO 1200 NP=1,10
8154       DO 1000 I=3,109
8155       SEXP=SEXPV(I)
8156       R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1))
8157       REXP=R**(UEXP/SEXP)
8158       arg1=path(pa(i),pa(i-2),core,eta(i))
8159       arg2=path(pa(i),pa(i-1),core,eta(i))
8160       PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP
8161       PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP
8162       XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA)
8163       DO 1010 LL=1,20
8164       F1=DLOG(1.0D0+XX*PATHA)
8165       F2=DLOG(1.0D0+XX*PATHB)
8166       F=F1/F2-REXP
8167       FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ &
8168           (F2*F2)
8169       XX=XX-F/FPRIME
8170       CHECK=1.0D0+XX*PATHA
8171 !!!!  IF (CHECK) 1020,1020,1025
8172       IF(CHECK.LE.0.)THEN
8173         WRITE(errmess,360)I,LL,CHECK
8174         WRITE(errmess,*)' xx=',xx,' patha=',patha
8175   360   FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10)
8176         CALL wrf_error_fatal ( errmess )
8177       ENDIF
8178  1010 CONTINUE
8179       CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ &
8180        (DLOG(1.0D0+XX*PATHA)+1.0D-20)
8181       XA(I)=XX
8182 1000  CONTINUE
8183       XA(2)=XA(3)
8184       XA(1)=XA(3)
8185       CA(2)=CA(3)
8186       CA(1)=CA(3)
8187       DO 1100 I=3,109
8188       PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP
8189       PATH0(I)=1.0D0+XA(I)*PATH0(I)
8190 !+++  IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I)
8191 1100  CONTINUE
8192       DO 1035 I=1,109
8193       SEXP=SEXPV(I)
8194       ETAP(I)=ETA(I)
8195       ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* &
8196         (CA(I)*XA(I))**(1./UEXP)
8197 1035  CONTINUE
8198 !
8199 !     THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985).
8200 !        THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S)
8201 !      IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND
8202 !      S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND
8203 !       ALSO,THE DENOMINATOR IS MULTIPLIED BY
8204 !      1000 TO PERMIT USE OF MB UNITS FOR PRESSURE.
8205 !        S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN
8206 !      ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL
8207 !      1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS.
8208 !      FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992.
8209 !      (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS)
8210 !      FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731
8211 !      FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111
8212 !      FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926
8213 !      SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2
8214 !        RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV,
8215 !      LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION.
8216 !
8217 !     WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109)
8218 !366   FORMAT (2I4,4E20.12)
8219 1200  CONTINUE
8220  361  FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ &
8221        20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6)
8222       RETURN
8223       END SUBROUTINE COEINT
8224
8225 !--------------
8226
8227
8228 !CCC  PROGRAM CO2INS
8229       SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag)
8230 !     *********************************************************
8231 !       SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ******
8232 !          ..... K.CAMPANA   MARCH 1988,OCTOBER 1988...
8233 !          ..... K.CAMPANA   DECEMBER 1988-CLEANED UP FOR LAUNCHER
8234 !          ..... K.CAMPANA   NOVEMBER 1989-ALTERED FOR NEW RADIATION
8235 !     *********************************************************
8236       DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6)
8237       DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8238        CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8239        CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8240 !CC   ITIN=22
8241 !CC   ITIN1=23
8242 !O222  LATEST CODE HAD  IQ=1
8243 !CC      IQ=4
8244 1011  FORMAT (4F20.14)
8245 !CC      READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8246 !CC      READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8247 !CC      READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8248 !CC      READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8249 !CC      READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8250 !CC      READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8251       DO 300 J=1,LP1
8252         DO 300 I=1,LP1
8253           CO2PO(I,J) = T22(I,J,1)
8254 !NOV89
8255           IF (IQ.EQ.5) GO TO 300
8256 !NOV89
8257           CO2PO1(I,J) = T22(I,J,2)
8258           CO2PO2(I,J) = T22(I,J,3)
8259   300 CONTINUE
8260       DO 301 J=1,LP1
8261         DO 301 I=1,LP1
8262           CO2800(I,J) = T23(I,J,1)
8263 !NOV89
8264           IF (IQ.EQ.5) GO TO 301
8265 !NOV89
8266           CO2801(I,J) = T23(I,J,2)
8267           CO2802(I,J) = T23(I,J,3)
8268   301 CONTINUE
8269 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8270 !   ARE:
8271 !        IQ=1    560-800     (CONSOL.=490-850)
8272 !        IQ=2    560-670     (CONSOL.=490-670)
8273 !        IQ=3    670-800     (CONSOL.=670-850)
8274 !        IQ=4    560-760 (ORIGINAL CODE)   (CONSOL.=490-850)
8275 !NOV89
8276 !        IQ=5   2270-2380    (CONSOL.=2270-2380)
8277 !NOV89
8278 !  THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8279 !  USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8280 !  WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8281 !NOV89
8282 !      NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE
8283 !  COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY
8284 !  ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES
8285 !  (IQ=1,4).  IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE
8286 !  WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS
8287 !  CALCULATIONS.  ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP.
8288 !  DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED.
8289 !NOV89
8290       IF (IQ.EQ.1) THEN
8291          C1=1.5
8292          C2x=0.5
8293       ENDIF
8294       IF (IQ.EQ.2) THEN
8295         C1=18./11.
8296         C2x=7./11.
8297       ENDIF
8298       IF (IQ.EQ.3) THEN
8299         C1=18./13.
8300         C2x=5./13.
8301       ENDIF
8302       IF (IQ.EQ.4) THEN
8303         C1=1.8
8304         C2x=0.8
8305       ENDIF
8306 !NOV89
8307       IF (IQ.EQ.5) THEN
8308         C1=1.0
8309         C2x=0.0
8310       ENDIF
8311 !NOV89
8312       DO 1021 I=1,LP1
8313       DO 1021 J=1,LP1
8314       CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8315       CO2800(J,I)=C1*CO2800(J,I)-C2x
8316 !NOV89
8317       IF (IQ.EQ.5) GO TO 1021
8318 !NOV89
8319       CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8320       CO2801(J,I)=C1*CO2801(J,I)-C2x
8321       CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8322       CO2802(J,I)=C1*CO2802(J,I)-C2x
8323 1021  CONTINUE
8324 !NOV89
8325       IF (IQ.GE.1.AND.IQ.LE.4) THEN
8326 !NOV89
8327       DO 1 J=1,LP1
8328       DO 1 I=1,LP1
8329       DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8330       DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8331       D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8332       D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8333 1     CONTINUE
8334 !NOV89
8335       ENDIF
8336 !NOV89
8337 !O222 *********************************************************
8338 !CC       REWIND 66
8339 !        SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE
8340 !CC       WRITE (66) DCDT10
8341 !CC       WRITE (66) CO2PO
8342 !CC       WRITE (66) D2CT10
8343 !CC       WRITE (66) DCDT8
8344 !CC       WRITE (66) CO2800
8345 !CC       WRITE (66) D2CT8
8346 !CC       REWIND 66
8347 !NOV89
8348       IF (IQ.EQ.1.OR.IQ.EQ.4) THEN
8349 !NOV89
8350       DO 400 J=1,LP1
8351        DO 400 I=1,LP1
8352         T66(I,J,1) = DCDT10(I,J)
8353         T66(I,J,2) = CO2PO(I,J)
8354         T66(I,J,3) = D2CT10(I,J)
8355         T66(I,J,4) = DCDT8(I,J)
8356         T66(I,J,5) = CO2800(I,J)
8357         T66(I,J,6) = D2CT8(I,J)
8358   400 CONTINUE
8359 !NOV89
8360       ELSE
8361       DO 409 I=1,LP1
8362         T66(I,1,2) = CO2PO(1,I)
8363         T66(I,1,5) = CO2800(1,I)
8364         IF (IQ.EQ.5) GO TO 409
8365         T66(I,1,1) = DCDT10(1,I)
8366         T66(I,1,3) = D2CT10(1,I)
8367         T66(I,1,4) = DCDT8(1,I)
8368         T66(I,1,6) = D2CT8(1,I)
8369   409 CONTINUE
8370       ENDIF
8371 !NOV89
8372 !O222 *********************************************************
8373       RETURN
8374       END SUBROUTINE CO2INS
8375 !O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT)
8376 !NOV89
8377       SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2)
8378 !NOV89
8379 !     *********************************************************
8380 !       CHANGES TO DATA READ  AND FORMAT SEE CO222     ***
8381 !          ..... K.CAMPANA   MARCH 1988,OCTOBER 1988
8382 !       CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89
8383 !     *********************************************************
8384 !       CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS
8385 !  FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS
8386 !  HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE
8387 !  USER.
8388 !
8389 !        METHOD:
8390 !
8391 !      CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS-
8392 !  SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND
8393 !  2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY
8394 !  OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE
8395 !  THE DIAGRAM AND DISCUSSION BELOW.
8396 !      CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME.
8397 !
8398 !     LET P BE AN ARRAY OF USER-DEFINED PRESSURES
8399 !     AND PD BE USER-DEFINED PRESSURE LAYERS.
8400 !
8401 !       - - - - - - - - -   PD(I-1) ---
8402 !                                     ^
8403 !       -----------------   P(I)      ^  PRESSURE LAYER I  (PLM(I))
8404 !                                     ^
8405 !       - - - - - - - - -   PD(I)  ---
8406 !                                     ^
8407 !       -----------------   P(I+1)    ^  PRESSURE LAYER I+1 (PLM(I+1))
8408 !                                     ^
8409 !       - - - - - - - - -   PD(I+1)---
8410 !            ...                          (THE NOTATION USED IS
8411 !            ...                          CONSISTENT WITH THE CODE)
8412 !            ...
8413 !      - - - - - - - - -    PD(J-1)
8414 !
8415 !      -----------------    P(J)
8416 !
8417 !      - - - - - - - - -    PD(J)
8418 !
8419 !      PURPOSE 1:   THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES
8420 !      P(I) AND P(J) ,TAU(P(I),P(J))  IS COMPUTED BY THIS PROGRAM.
8421 !      IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD
8422 !      (PD,PLM ARE NOT INPUTTED).
8423 !
8424 !      PURPOSE 2:   THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER-
8425 !      MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY
8426 !         TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL
8427 !
8428 !                           PD(I)
8429 !                           ----
8430 !             1             ^
8431 !        -------------  *   ^   TAU ( P',PLM(J) )  DP'
8432 !        PD(I)-PD(I-1)      ^
8433 !                        ----
8434 !                        PD(I-1)
8435 !
8436 !           THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER.
8437 !        FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE
8438 !        PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)).
8439 !           FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS
8440 !        A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN
8441 !        ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION
8442 !        DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT
8443 !        INPUTTED).
8444 !
8445 !            THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS
8446 !       CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC
8447 !       PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED
8448 !       FOR LAYER-MEAN TRANSMISSIVITIES.
8449 !
8450 !          FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE
8451 !      PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID
8452 !     OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED.
8453 !      THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US
8454 !     STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE
8455 !     SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A
8456 !     TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS)
8457 !     BY 25 DEGREES.
8458 !         THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS
8459 !     AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS-
8460 !     MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S.
8461 !     A LOGARITHMIC INTERPOLATION SCHEME IS USED.
8462 !         THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES
8463 !     GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES
8464 !     OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID.
8465 !     THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO-
8466 !     LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD
8467 !     DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE
8468 !     USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES.
8469 !
8470 !     MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES:
8471 !          THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD,
8472 !     AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES
8473 !     (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE
8474 !     DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO
8475 !     PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J)
8476 !     (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR
8477 !     GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)).
8478 !        NOTE:
8479 !     TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT
8480 !     TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING)
8481 !     DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER
8482 !     (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J).
8483 !     THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN
8484 !     THE FIXED PRESSURE PLM(3)  AND THE PRESSURE LAYER HAVING AN AVERAG
8485 !     PRESSURE OF PLM(2).
8486 !         ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER
8487 !     BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE;
8488 !     TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1.
8489 !
8490 !
8491 !             REFERENCE:
8492 !         S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE
8493 !     ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL
8494 !     OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981.
8495 !        MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS;
8496 !     CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R.
8497 !     IS PLANNED TO DOCUMENT THESE CHANGES.
8498 !
8499 !            AUTHOR:    M.DANIEL SCHWARZKOPF
8500 !
8501 !            DATE:      14 JULY 1983
8502 !
8503 !            ADDRESS:
8504 !
8505 !                      G.F.D.L.
8506 !                      P.O.BOX 308
8507 !                      PRINCETON,N.J.08540
8508 !                      U.S.A.
8509 !            TELEPHONE:  (609) 452-6521
8510 !
8511 !            INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE
8512 !        ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS-
8513 !        MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2
8514 !        CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND
8515 !        1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS:
8516 !          FILE 2   1X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8517 !          FILE 3   1X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8518 !          FILE 4   2X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8519 !          FILE 5   2X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8520 !          FILE 6   4X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8521 !          FILE 7   4X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8522 !            FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING
8523 !        TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE
8524 !        COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES
8525 !        DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED
8526 !        TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER
8527 !        CALCULATIONS.
8528 !
8529 !            PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER
8530 !        AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A
8531 !        CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR
8532 !        ADAPTATIONS TO OTHER MACHINES.
8533 !
8534 !          INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8535 !
8536 !   UNIT NO    VARIABLES       FORMAT      STATEMENT NO.    TYPE
8537 !      5        P (PURPOSE 1)  (5E16.9)        201         CARDS
8538 !      5        PD (PURPOSE 2) (5E16.9)        201         CARDS
8539 !      5        PLM(PURPOSE 2) (5E16.9)        201         CARDS
8540 !      5        NMETHD         (I3)            202         CARDS
8541 !      20       TRANSA         (4F20.14)       102          TAPE
8542 !NOV89
8543 !      ITAPE    TRANSA         (4F20.14)       102          TAPE
8544 !NOV89
8545 !
8546 !         OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8547 !
8548 !   UNIT NO    VARIABLES       FORMAT     STATEMENT NO.
8549 !      6         TRNFCT        (1X,8F15.8)     301         PRINT
8550 !      22        TRNFCT        (4F20.14)       102          TAPE
8551 !
8552 !            PARAMETER INPUTS:
8553 !     A) NLEVLS    : NLEVLS IS AN (INTEGER) PARAMETER DENOTING
8554 !        THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1
8555 !        OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO
8556 !        SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT
8557 !        GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2.
8558 !        IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO
8559 !        PRESSURE LAYERS=2,SO NLEVLS=2
8560 !           IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD
8561 !        CHANGE THIS VALUE TO A USER-SPECIFIED VALUE.
8562 !     B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1;
8563 !        NLP2=NLEVLS+2.
8564 !           SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER
8565 !        STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE.
8566 !
8567 !            INPUTS:
8568 !
8569 !     A) TRANSA    : THE 109X109 GRID OF TRANSMISSION FUNCTIONS
8570 !            TRANSA IS A  DOUBLE PRECISION REAL ARRAY.
8571 !
8572 !           TRANSA  IS READ FROM FILE 20. THIS FILE CONTAINS 3
8573 !     RECORDS,AS FOLLOWS:
8574 !        1)   TRANSA, STANDARD TEMPERATURE PROFILE
8575 !        3)   TRANSA, STANDARD TEMPERATURES + 25 DEG
8576 !        5)   TRANSA, STANDARD TEMPERATURES - 25 DEG
8577 !
8578 !     B)   NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS
8579 !       TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR
8580 !       PURPOSE 2).
8581 !
8582 !     C)     P,PD,PLM :
8583 !          P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE
8584 !       GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR
8585 !       PURPOSE 1.THE DIMENSION  OF P IS  IN MILLIBARS.THE
8586 !       FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE
8587 !       IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE
8588 !       LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS.
8589 !         PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE
8590 !       LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE
8591 !       TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS
8592 !       FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8593 !       LIMITATIONS.
8594 !         PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN
8595 !       PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS
8596 !       FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8597 !       LIMITATIONS.PD IS READ IN BEFORE PLM.
8598 !
8599 !          NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR
8600 !       PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH.
8601 !
8602 !
8603 !
8604 !
8605 !           LIMITATIONS:
8606 !     1)       P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL
8607 !       MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO.
8608 !       THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO
8609 !       QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS
8610 !       NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J),
8611 !       ONE MUST INCLUDE SUCH A LEVEL.
8612 !     2)      PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB.
8613 !       EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE.
8614 !     3)      IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER,
8615 !       SIMPLY DELETE THE LINE.
8616 !     4)      IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING:
8617 !            1) DELETE ALL PARAMETER STATEMENTS IN CO2INT
8618 !            2) AT THE POINT WHERE NMETHOD IS READ IN,ADD:
8619 !                READ (5,202) NLEVLS
8620 !                NLP1=NLEVLS+1
8621 !                NLP2=NLEVLS+2
8622 !            3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING
8623 !              ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT.
8624 !              THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED
8625 !              IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA,
8626 !              P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2)
8627 !              IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS.
8628 !      5)    PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER
8629 !       STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE
8630 !       SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS
8631 !       PARAMETER   NLEVLS=40
8632 !      6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO
8633 !       REQUIREMENTS OF CDC FORTAN.
8634 !      7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF
8635 !       TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO
8636 !       PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT.
8637 !
8638 !     OUTPUT:
8639 !         A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION
8640 !     FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22.
8641 !     THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE
8642 !     OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14).
8643 !
8644 !         B)  PRINTED  OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN
8645 !     THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY
8646 !     MODIFY OR ELIMINATE THIS AT WILL.
8647 !
8648 !      ************   FUNCTION INTERPOLATER ROUTINE  *****************
8649 !
8650 !
8651 !     ******   THE FOLLOWING PARAMETER GIVES THE NUMBER OF     *******
8652 !     ******           DATA LEVELS IN THE MODEL                *******
8653 !     ****************************************************************
8654 !     ****************************************************************
8655       COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
8656 !     COMMON/PRESS/PA(109)
8657 !     COMMON/TRAN/ TRANSA(109,109)
8658 !     COMMON / OUTPUT / TRNS(NLP1,NLP1)
8659 !     COMMON/INPUTP/P(NLP1),PD(NLP2)
8660       DIMENSION TRNS(NLP1,NLP1)
8661       DIMENSION P(NLP1),PD(NLP2)
8662       DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1)
8663       DIMENSION NRTAB(3)
8664       DIMENSION T15A(NLP2,2),T15B(NLP1)
8665       DIMENSION T22(NLP1,NLP1,3)
8666       LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
8667       DATA NRTAB/1,2,4/
8668 !***********************************
8669 !   THE FOLLOWING ARE THE INPUT FORMATS
8670 100   FORMAT (4F20.14)
8671 743   FORMAT (F20.14)
8672 201   FORMAT (5E16.9)
8673 202   FORMAT (I3)
8674 !O222   203   FORMAT (F12.6,I2)
8675 203   FORMAT (F12.6)
8676 !    THE FOLLOWING ARE THE OUTPUT FORMATS
8677 102   FORMAT (4F20.14)
8678 301   FORMAT (1X,8F15.8)
8679 !
8680 !CC   REWIND 15
8681 !CC   REWIND 20
8682 !NOV89
8683       REWIND ITAPE
8684 !NOV89
8685 !CC   REWIND 22
8686 !
8687 !     CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES
8688 !     NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^
8689       PA(1)=0.
8690       FACT15=10.**(1./15.)
8691       FACT30=10.**(1./30.)
8692       PA(2)=1.0E-3
8693       DO 231 I=2,76
8694       PA(I+1)=PA(I)*FACT15
8695 231   CONTINUE
8696       DO 232 I=77,108
8697       PA(I+1)=PA(I)*FACT30
8698 232   CONTINUE
8699 !
8700       N=25
8701       NLV=NLEVLS
8702       NLP1V=NLP1
8703       NLP2V=NLP2
8704 !     READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX
8705 !     GIVING THE FREQUENCY RANGE OF THE LBL DATA
8706 !O222    READ (5,203) RATIO,IR
8707 !CC         IR = 1
8708 !CC         READ (5,203) RATIO
8709 !O222   ***********************************
8710 !***VALUES FOR IR*****
8711 !          IR=1     CONSOL. LBL TRANS. =490-850
8712 !          IR=2     CONSOL. LBL TRANS. =490-670
8713 !          IR=3     CONSOL. LBL TRANS. =670-850
8714 !          IR=4     CONSOL. LBL TRANS. =2270-2380
8715 !*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK
8716 !     ALSO READ IN THE METHOD NO.(1 OR 2)
8717 !CC         READ (5,202) NMETHD
8718       IF (RATIO.EQ.1.0) GO TO 621
8719       CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' )
8720 !NOV89  621   ITAP1=20
8721 621   ITAP1=ITAPE
8722 !NOV89
8723       NTAP=1
8724       IF (NMETHD.EQ.2) GO TO 502
8725 !   *****CARDS FOR PURPOSE 1(NMETHD=1)
8726 !CC         READ (15,201) (P(I),I=1,NLP1)
8727       DO 300 I=1,NLP1
8728         P(I)=T15B(I)
8729   300 CONTINUE
8730       DO 801 I=1,NLP1
8731       PS(I)=P(I)
8732 801   CONTINUE
8733       GO TO 503
8734 502   CONTINUE
8735 !  *****CARDS FOR PURPOSE 2(NMETHD=2)
8736 !CC         READ (15,201) (PD(I),I=1,NLP2)
8737 !CC         READ (15,201) (PLM(I),I=1,NLP1)
8738       DO 303 I=1,NLP2
8739         PD(I)=T15A(I,1)
8740   303 CONTINUE
8741       DO 302 I=1,NLP1
8742         PLM(I)=T15A(I,2)
8743   302 CONTINUE
8744       DO 802 I=1,NLP1
8745       PDS(I)=PD(I+1)
8746       PS(I)=PLM(I)
8747 802   CONTINUE
8748 !
8749 503   CONTINUE
8750 !  *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES
8751 !NOV89
8752 !NOV89    DO 400 KKK=1,3
8753       ICLOOP = 3
8754       IF (IR.EQ.4) ICLOOP = 1
8755       DO 400 KKK=1,ICLOOP
8756 !NOV89
8757 !  **********************
8758       IF (NMETHD.EQ.2) GO TO 505
8759 !   *****CARDS FOR PURPOSE 1(NMETHD=1)
8760       DO 803 I=1,NLP1
8761       P(I)=PS(I)
8762 803   CONTINUE
8763       GO TO 506
8764 505   CONTINUE
8765 !  *****CARDS FOR PURPOSE 2(NMETHD=2)
8766       DO 804 I=1,NLP1
8767       PD(I)=PDS(I)
8768       P(I)=PS(I)
8769 804   CONTINUE
8770 !
8771 506   CONTINUE
8772       IA=108
8773       IAP=IA+1
8774 !NOV89   IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109)
8775 !mp       IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109)
8776         IF (NTAP.EQ.1) THEN
8777            IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109)
8778            CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE )
8779         ENDIF
8780 !mp     IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881
8781 !mp
8782         do J=109,1,-6
8783 !mp     write(6,697)(TRANSA(I,J),I=5,105,10)
8784         enddo
8785 ! 697   format(11(f5.3,1x))
8786 !mp
8787 !NOV89
8788       DO 4 I=1,IAP
8789       TRANSA(I,I)=1.0
8790     4 CONTINUE
8791       CALL COEINT(RATIO,IR)
8792       DO 805 I=1,NLP1
8793       DO 805 J=1,NLP1
8794       TRNS(J,I)=1.00
8795 805   CONTINUE
8796       DO 10 I=1,NLP1
8797       DO 20 J=1,I
8798       IF (I.EQ.J) GO TO 20
8799       P1=P(J)
8800       P2=P(I)
8801       CALL SINTR2
8802       TRNS(J,I)=TRNSLO
8803 20    CONTINUE
8804 10    CONTINUE
8805       DO 47 I=1,NLP1
8806       DO 47 J=I,NLP1
8807       TRNS(J,I)=TRNS(I,J)
8808 47    CONTINUE
8809 !  *****THIS IS THE END OF PURPOSE 1 CALCULATIONS
8810       IF (NMETHD.EQ.1) GO TO 2872
8811 !
8812       DO 51 J=1,NLP1
8813       DO 52 I=2,NLP1
8814       IA=I
8815       JA=J
8816       N=25
8817       IF (I.NE.J) N=3
8818       CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
8819 52    CONTINUE
8820 51    CONTINUE
8821 !  *****THIS IS THE END OF PURPOSE 2 CALCULATIONS
8822 2872  CONTINUE
8823 !
8824 !+++  WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8825 !CC         WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8826       DO 304 J=1,NLP1
8827        DO 304 I=1,NLP1
8828         T22(I,J,KKK) = TRNS(I,J)
8829   304 CONTINUE
8830 400   CONTINUE
8831       RETURN
8832       END SUBROUTINE CO2INT
8833 !CCC  PROGRAM CO2IN1
8834       SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1)
8835 !    CO2IN1=CO2INS FOR METHOD 1
8836 !     *********************************************************
8837 !       SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ***
8838 !          ..... K.CAMPANA   MARCH 1988,OCTOBER 1988
8839 !          ..... K.CAMPANA   DECEMBER 88 CLEANED UP FOR LAUNCHER
8840 !     *********************************************************
8841       DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6)
8842       DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8843        CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8844        CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8845       ITIN=20
8846       ITIN1=21
8847 !O222 LATEST CODE HAS IQ=1
8848 !CC         IQ=4
8849 1011  FORMAT (4F20.14)
8850 !CC        READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8851 !CC        READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8852 !CC        READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8853 !CC        READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8854 !CC        READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8855 !CC        READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8856       DO 300 J=1,LP1
8857         DO 300 I=1,LP1
8858           CO2PO(I,J) = T20(I,J,1)
8859 !NOV89
8860           IF (IQ.EQ.5) GO TO 300
8861 !NOV89
8862           CO2PO1(I,J) = T20(I,J,2)
8863           CO2PO2(I,J) = T20(I,J,3)
8864   300 CONTINUE
8865       DO 301 J=1,LP1
8866         DO 301 I=1,LP1
8867           CO2800(I,J) = T21(I,J,1)
8868 !NOV89
8869           IF (IQ.EQ.5) GO TO 301
8870 !NOV89
8871           CO2801(I,J) = T21(I,J,2)
8872           CO2802(I,J) = T21(I,J,3)
8873   301 CONTINUE
8874 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8875 !   ARE:
8876 !        IQ=1    560-800     (CONSOL.=490-850)
8877 !        IQ=2    560-670     (CONSOL.=490-670)
8878 !        IQ=3    670-800     (CONSOL.=670-850)
8879 !        IQ=4    560-760 (ORIGINAL CODE)   (CONSOL.=490-850)
8880 !NOV89
8881 !        IQ=5   2270-2380    (CONSOL.=2270-2380)
8882 !NOV89
8883 !  THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8884 !  USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8885 !  WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8886       IF (IQ.EQ.1) THEN
8887          C1=1.5
8888          C2x=0.5
8889       ENDIF
8890       IF (IQ.EQ.2) THEN
8891         C1=18./11.
8892         C2x=7./11.
8893       ENDIF
8894       IF (IQ.EQ.3) THEN
8895         C1=18./13.
8896         C2x=5./13.
8897       ENDIF
8898       IF (IQ.EQ.4) THEN
8899         C1=1.8
8900         C2x=0.8
8901       ENDIF
8902 !NOV89
8903       IF (IQ.EQ.5) THEN
8904         C1=1.0
8905         C2x=0.0
8906       ENDIF
8907 !NOV89
8908       DO 1021 I=1,LP1
8909       DO 1021 J=1,LP1
8910       CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8911       CO2800(J,I)=C1*CO2800(J,I)-C2x
8912 !NOV89
8913       IF (IQ.EQ.5) GO TO 1021
8914 !NOV89
8915       CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8916       CO2801(J,I)=C1*CO2801(J,I)-C2x
8917       CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8918       CO2802(J,I)=C1*CO2802(J,I)-C2x
8919 1021  CONTINUE
8920 !NOV89
8921       IF (IQ.GE.1.AND.IQ.LE.4) THEN
8922 !NOV89
8923       DO 1 J=1,LP1
8924       DO 1 I=1,LP1
8925       DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8926       DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8927       D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8928       D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8929 1     CONTINUE
8930 !NOV89
8931       ENDIF
8932 !NOV89
8933 !O222 *********************************************************
8934 !CC          REWIND 66
8935 !        SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE
8936 !CC          WRITE (66) (DCDT10(I,I+1),I=1,L)
8937 !CC          WRITE (66) (CO2PO(I,I+1),I=1,L)
8938 !CC          WRITE (66) (D2CT10(I,I+1),I=1,L)
8939 !CC          WRITE (66) (DCDT8(I,I+1),I=1,L)
8940 !CC          WRITE (66) (CO2800(I,I+1),I=1,L)
8941 !CC          WRITE (66) (D2CT8(I,I+1),I=1,L)
8942 !CC          REWIND 66
8943 !O222 *********************************************************
8944       DO 400 I=1,L
8945         T66(I,2) = CO2PO(I,I+1)
8946         T66(I,5) = CO2800(I,I+1)
8947 !NOV89
8948         IF (IQ.EQ.5) GO TO 400
8949 !NOV89
8950         T66(I,1) = DCDT10(I,I+1)
8951         T66(I,3) = D2CT10(I,I+1)
8952         T66(I,4) = DCDT8(I,I+1)
8953         T66(I,6) = D2CT8(I,I+1)
8954   400 CONTINUE
8955       RETURN
8956       END SUBROUTINE CO2IN1
8957 !CCC  PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987....
8958       SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
8959                         SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2)
8960 !
8961 ! **         THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS
8962 ! **         AND O3 MIXING RATIOS BY USING AN ANALYTICAL
8963 ! **         FUNCTION WHICH APPROXIMATES
8964 ! **         THE US STANDARD (1976).  THIS IS
8965 ! **         CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE
8966 ! **         MAIN PROGRAM.  THE FORM OF THE ANALYTICAL FUNCTION WAS
8967 ! **         SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN.
8968 ! ******************************************************************
8969 !         CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222  **
8970 !             ....K. CAMPANA MARCH 88,OCTOBER 88
8971       DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), &
8972                 T43(NLP2,2),T44(NLP)
8973       DIMENSION SGLVNU(NLP),SIGLNU(NL)
8974       DIMENSION SFULL(NLP),SHALF(NL)
8975 ! ******************************************************************
8976 !
8977 !*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS
8978 !     QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA-
8979 !     TIONAL RADIATION CODES
8980 !
8981       CHARACTER*20 PROFIL
8982       DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP)
8983       DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2)
8984       DIMENSION PD(NLP2),GTEMP(NLP)
8985       DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4)
8986       DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2)
8987 !
8988 !
8989       DATA PROFIL/ &
8990          'US STANDARD 1976'/
8991       DATA PSMAX/1013.250/
8992 !
8993 ! **         NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING
8994 ! **        VALUES:    0 =SIGMA LEVELS ARE USED;   1= SKYHI L40 LEVELS
8995 ! **        ARE USED;   2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0
8996 !
8997       NTYPE=0
8998 !O222 READ (*,*) NTYPE
8999     5 NLEV=NL
9000       DELZAP=0.5
9001       R=8.31432
9002       G0=9.80665
9003       ZMASS=28.9644
9004       AA=6356.766
9005          ALT(1)=0.0
9006          TEMP(1)=ANTEMP(6,0.0)
9007 !*******DETERMINE THE PRESSURES (PRESS)
9008       PSTAR=PSMAX
9009 !
9010 !***  LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION
9011 !
9012       LTOP(1)=0
9013       LTOP(2)=0
9014       LTOP(3)=0
9015       DO 30 N=1,NL
9016         PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10.
9017         IF(PCLD.GE.642.)LTOP(1)=N
9018         IF(PCLD.GE.350.)LTOP(2)=N
9019         IF(PCLD.GE.150.)LTOP(3)=N
9020 !       PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
9021    30 CONTINUE
9022 !
9023 !O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP)
9024 !O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP)
9025 !O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP)
9026 !CC----      CALL SIGP(PSTAR,PD,GTEMP)
9027       NLM=NL-1
9028       CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9029                 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2)
9030       PD(NLP2)=PSTAR
9031       DO 40 N=1,NLP
9032       PRSINT(N)=PD(NLP2+1-N)
9033  40   CONTINUE
9034 !    *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE
9035       DO 504 NQ=1,4
9036       DO 505 N=2,NLP
9037  505  PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N))
9038       PRESS(1)=PRSINT(1)
9039 !*********************
9040       DO 100 N=1,NLEV
9041 !
9042 ! **         ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT
9043 ! **         INTERVALS OF APPROXIMATELY 'DELZAP' KM.
9044 !
9045       DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1))
9046       NINT=DLOGP/DELZAP
9047       NINT=NINT+1
9048       ZNINT=NINT
9049 !     G=G0
9050       DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT)
9051       HT=ALT(N)
9052 !
9053 ! **         CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF
9054 ! **                   RUNGE-KUTTA INTEGRATION.
9055 !
9056       DO 200 M=1,NINT
9057       RK1=ANTEMP(6,HT)*DZ
9058       RK2=ANTEMP(6,HT+0.5*RK1)*DZ
9059       RK3=ANTEMP(6,HT+0.5*RK2)*DZ
9060       RK4=ANTEMP(6,HT+RK3)*DZ
9061 !mp     write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ
9062       HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4)
9063   200 CONTINUE
9064       ALT(N+1)=HT
9065       TEMP(N+1)=ANTEMP(6,HT)
9066   100 CONTINUE
9067       DO 506 N=1,NLP
9068       TMPINT(N,NQ)=TEMP(N)
9069       A(N,NQ)=ALT(N)
9070 506   CONTINUE
9071 504   CONTINUE
9072 !O222   *****************************************************
9073 !***OUTPUT TEMPERATURES
9074 !O222   *****************************************************
9075       DO 901 N=1,NLP
9076         SGTEMP(N,1) = TMPINT(NLP2-N,1)
9077   901 CONTINUE
9078 !O222   *****************************************************
9079 !***OUTPUT GTEMP
9080 !O222   *****************************************************
9081       DO 902 N=1,NLP
9082         SGTEMP(N,2) = GTEMP(N)
9083   902 CONTINUE
9084 !O222   *****************************************************
9085       RETURN
9086       END SUBROUTINE CO2PTZ
9087       FUNCTION PATH(A,B,C,E)
9088 !....
9089 !     DOUBLE PRECISION XA,CA
9090 !     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9091       PEXP=1./SEXP
9092       PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.))
9093       RETURN
9094       END FUNCTION PATH
9095 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9096       SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F)
9097 !....
9098 !     DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL
9099       D1=(FP-F0)/(XP-X0)
9100       D2=(FM-F0)/(XM-X0)
9101       B=(D1-D2)/(XP-XM)
9102       A=D1-B*(XP-X0)
9103       DEL=(X-X0)
9104       F=F0+DEL*(A+DEL*B)
9105       RETURN
9106       END SUBROUTINE QINTRP
9107       SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
9108       COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9109       DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V)
9110       DIMENSION WT(101)
9111       N2=2*N
9112       N2P=2*N+1
9113 !  *****WEIGHTS ARE CALCULATED
9114       WT(1)=1.
9115       DO 21 I=1,N
9116       WT(2*I)=4.
9117       WT(2*I+1)=1.
9118 21    CONTINUE
9119       IF (N.EQ.1) GO TO 25
9120       DO 22 I=2,N
9121       WT(2*I-1)=2.
9122 22    CONTINUE
9123 25    CONTINUE
9124       TRNSNB=0.
9125       DP=(PD(IA)-PD(IA-1))/N2
9126       PFIX=P(JA)
9127       DO 1 KK=1,N2P
9128       PVARY=PD(IA-1)+(KK-1)*DP
9129       IF (PVARY.GE.PFIX) P2=PVARY
9130       IF (PVARY.GE.PFIX) P1=PFIX
9131       IF (PVARY.LT.PFIX) P1=PVARY
9132       IF (PVARY.LT.PFIX) P2=PFIX
9133       CALL SINTR2
9134       TRNSNB=TRNSNB+TRNSLO*WT(KK)
9135 1     CONTINUE
9136       TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1)))
9137       RETURN
9138       END SUBROUTINE QUADSR
9139 !---------------------------------------------------------------------
9140       SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9141                       SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2)
9142       DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2)
9143       DIMENSION SIGLY(KD),SIGLV(KP)
9144       DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM)
9145       DIMENSION IDATE(4)
9146       DIMENSION T41(KP2,2),T42(KP), &
9147                 T43(KP2,2),T44(KP)
9148 !     integer :: retval
9149 !     character(50) :: prsmid='prsmid'
9150 !CC   18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL
9151 !CC   DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, &
9152 !CC          .594,.688,.777,.856,.920,.960,.981,.995/
9153 !     FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1),
9154 !     PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.)
9155 !
9156 !.....   GET NMC SIGMA STRUCTURE
9157 !CC   IF (LREAD.GT.0) GO TO 914
9158 !---   PPTOP IS MODEL TOP PRESSURE IN CB....
9159 !        SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A.....
9160 !cccc PPTOP=5.0
9161 !     READ(11,PPTOP,END=12321)
9162 12321 CONTINUE
9163 !     WRITE(6,88221)PPTOP,KD,KP
9164 !88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2)
9165 !     open(unit=23,file='fort.23',form='unformatted' &
9166 !     ,    access='sequential')
9167 !     REWIND 23
9168 !     READ(23)SIGLY
9169 !     DO KKK=1,KD
9170 !      SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD
9171 !     END DO
9172 !     WRITE(6,88222)
9173 !88222 FORMAT(' READ AETA')
9174 !     DO 37821 LLL=1,KD
9175 !     WRITE(6,37820)LLL,SIGLY(LLL)
9176 !37820 FORMAT(' L=',I2,' AETA=',E12.5)
9177 !37821 CONTINUE
9178 !     READ(23)SIGLV
9179 !     DO KKK=1,KP
9180 !      SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD
9181 !     END DO
9182 !     WRITE(6,88223)
9183 !88223 FORMAT(' READ ETA')
9184 !     PRINT 704,(SIGLY(K),K=1,KD)
9185 !     PRINT 704,(SIGLV(K),K=1,KP)
9186 !      DO 37823 LLL=1,KP
9187 !      WRITE(6,37822)LLL,SIGLV(LLL)
9188 !37822 FORMAT(' L=',I2,' ETA=',E12.5)
9189 !37823 CONTINUE
9190   701 FORMAT(F6.2)
9191   702 FORMAT(7F10.6)
9192       IF (PPTOP.LE.0.) GO TO 708
9193       PSFC=100.
9194 !--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM
9195 !      VERTICAL LOCATION
9196       DO 706 K=1,KD
9197        SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9198   706 CONTINUE
9199       DO 707 K=1,KP
9200        SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9201   707 CONTINUE
9202   708 CONTINUE
9203 !     PRINT 703,PPTOP
9204 !     PRINT 704,(SIGLY(K),K=1,KD)
9205 !     PRINT 704,(SIGLV(K),K=1,KP)
9206   703 FORMAT(1H ,'PTOP =',F6.2)
9207   704 FORMAT(1H ,7F10.6)
9208       DO 913 K=1,KP
9209        SGLVNU(K) = SIGLV(K)
9210        IF (K.LE.KD) SIGLNU(K) = SIGLY(K)
9211   913 CONTINUE
9212       DO 77 K=1,KD
9213          Q(K) = SIGLNU(KD+1-K)
9214    77 CONTINUE
9215       PSS=    1013250.
9216       QMH(1)=0.
9217       QMH(KP)=1.
9218       DO 1 K=2,KD
9219       QMH(K)=0.5*(Q(K-1)+Q(K))
9220 1     CONTINUE
9221       PD(1)=0.
9222       PD(KP2)=PSS
9223       DO 2 K=2,KP
9224       PD(K)=Q(K-1)*PSS
9225 2     CONTINUE
9226 !       call int_get_fresh_handle(retval)
9227 !       close(retval)
9228 !       write(0,*)' before open in CO2O3'
9229 !       open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier)
9230 !       write(0,*)' after open1'
9231 !       do k=1,62
9232 !         write(retval)pd(k)
9233 !       enddo
9234 !       close(retval)
9235       PLM(1)=0.
9236       DO 3 K=1,KM
9237       PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9238 3     CONTINUE
9239       PLM(KP)=PSS
9240       DO 4 K=1,KD
9241       GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250.
9242 4     CONTINUE
9243       GTEMP(KP)=0.
9244 !+++  WRITE (6,100) (GTEMP(K),K=1,KD)
9245 !+++  WRITE (6,100) (PD(K),K=1,KP2)
9246 !+++  WRITE (6,100) (PLM(K),K=1,KP)
9247 !***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB)
9248 !  THE FOLLOWING PUTS P-DATA INTO MB
9249       DO 11 I=1,KP
9250       PD(I)=PD(I)*1.0E-3
9251       PLM(I)=PLM(I)*1.0E-3
9252 11    CONTINUE
9253       PD(KP2)=PD(KP2)*1.0E-3
9254 !CC         WRITE (41,101) (PD(K),K=1,KP2)
9255 !CC         WRITE (41,101) (PLM(K),K=1,KP)
9256 !CC         WRITE (42,101) (PLM(K),K=1,KP)
9257       DO 300 K=1,KP2
9258        T41(K,1) = PD(K)
9259   300 CONTINUE
9260       DO 301 K=1,KP
9261        T41(K,2) = PLM(K)
9262        T42(K) = PLM(K)
9263   301 CONTINUE
9264 !***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ
9265       DO 12 I=1,KP2
9266       PDT(I)=PD(I)
9267 12    CONTINUE
9268 !***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED
9269       PSS=0.8*1013250.
9270       QMH(1)=0.
9271       QMH(KP)=1.
9272       DO 201 K=2,KD
9273       QMH(K)=0.5*(Q(K-1)+Q(K))
9274 201   CONTINUE
9275       PD(1)=0.
9276       PD(KP2)=PSS
9277       DO 202 K=2,KP
9278       PD(K)=Q(K-1)*PSS
9279 202   CONTINUE
9280       PLM(1)=0.
9281       DO 203 K=1,KM
9282       PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9283 203   CONTINUE
9284       PLM(KP)=PSS
9285 !+++  WRITE (6,100) (PD(K),K=1,KP2)
9286 !+++  WRITE (6,100) (PLM(K),K=1,KP)
9287 !***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB)
9288 !  THE FOLLOWING PUTS P-DATA INTO MB
9289       DO 211 I=1,KP
9290       PD(I)=PD(I)*1.0E-3
9291       PLM(I)=PLM(I)*1.0E-3
9292 211   CONTINUE
9293       PD(KP2)=PD(KP2)*1.0E-3
9294 !CC       WRITE (43,101) (PD(K),K=1,KP2)
9295 !CC       WRITE (43,101) (PLM(K),K=1,KP)
9296 !CC       WRITE (44,101) (PLM(K),K=1,KP)
9297       DO 302 K=1,KP2
9298        T43(K,1) = PD(K)
9299   302 CONTINUE
9300       DO 303 K=1,KP
9301        T43(K,2) = PLM(K)
9302        T44(K) = PLM(K)
9303   303 CONTINUE
9304 !***RESTORE PD
9305       DO 212 I=1,KP2
9306       PD(I)=PDT(I)
9307 212   CONTINUE
9308 100   FORMAT (1X,5E20.13)
9309 101   FORMAT (5E16.9)
9310       RETURN
9311       END SUBROUTINE SIGP
9312 !---------------------------------------------------------------------
9313       SUBROUTINE SINTR2
9314 !....
9315 !     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9316 !     REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
9317       COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9318 !     COMMON/PRESS/ PA(109)
9319 !     COMMON/TRAN/ TRANSA(109,109)
9320 !     COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9321       DO 70 L=1,109
9322       IP1=L
9323       IF (P2-PA(L)) 65,65,70
9324    70 CONTINUE
9325    65 I=IP1-1
9326       IF (IP1.EQ.1) IP1=2
9327       IF (I.EQ.0) I=1
9328       DO 80 L=1,109
9329       JP1=L
9330       IF (P1-PA(L)) 75,75,80
9331    80 CONTINUE
9332    75 J=JP1-1
9333       IF (JP1.EQ.1) JP1=2
9334       IF (J.EQ.0) J=1
9335       JJJ=J
9336       III=I
9337       J=JJJ
9338       JP1=J+1
9339       I=III
9340       IP1=I+1
9341 !  DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION
9342 !    FOR PETA(=0.5*(P1+P2))
9343       PETA=P2
9344       DO 90 L=1,109
9345       IETAP1=L
9346       IF (PETA-PA(L)) 85,85,90
9347 90    CONTINUE
9348 85    IETA=IETAP1-1
9349       IF (IETAP1.EQ.1) IETAP1=2
9350       IF (IETA.EQ.0) IETA=1
9351       ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ &
9352        (PA(IETAP1)-PA(IETA))
9353       SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- &
9354        SEXPV(IETA))/ (PA(IETAP1)-PA(IETA))
9355       PIPMPI=PA(IP1)-PA(I)
9356       UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP
9357       IF (I-J) 126,126,127
9358   126 CONTINUE
9359       TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP)
9360       TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP)
9361       TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI
9362       GO TO 128
9363   127 TIJ=TRANSA(I,J)
9364       TIPJ=TRANSA(I+1,J)
9365       TIJP=TRANSA(I,J+1)
9366       TIPJP=TRANSA(I+1,J+1)
9367       UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP
9368       UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP
9369       UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP
9370       UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP
9371       PRODI=CA(I)*XA(I)
9372       PRODIP=CA(I+1)*XA(I+1)
9373       PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI
9374       XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI
9375       CINT=PROD/XINT
9376       AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP)
9377       AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP)
9378       AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP)
9379       AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP)
9380       EIJ=TIJ+AIJ
9381       EIPJ=TIPJ+AIPJ
9382       EIJP=TIJP+AIJP
9383       EIPJP=TIPJP+AIPJP
9384       DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J))
9385       DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J))
9386       EPIP1=EIJ+DTDJ*(P1-PA(J))
9387       EPIPP1=EIPJ+DTDPJ*(P1-PA(J))
9388       EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI
9389       TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9390       IF (I.GE.108.OR.J.GE.108) GO TO 350
9391       IF (I-J-2) 350,350,355
9392 355   CONTINUE
9393       TIP2J=TRANSA(I+2,J)
9394       TIP2JP=TRANSA(I+2,J+1)
9395       TI2J2=TRANSA(I+2,J+2)
9396       TIJP2=TRANSA(I,J+2)
9397       TIPJP2=TRANSA(I+1,J+2)
9398       UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP
9399       UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP
9400       UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP
9401       UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP
9402       UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP
9403       AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP)
9404       AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP)
9405       AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP)
9406       AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP)
9407       AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP)
9408       EIP2J=TIP2J+AIP2J
9409       EIP2JP=TIP2JP+AIP2JP
9410       EIJP2=TIJP2+AIJP2
9411       EIPJP2=TIPJP2+AIPJP2
9412       EI2J2=TI2J2+AI2J2
9413       CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI)
9414       CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP)
9415       CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2)
9416       CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL)
9417       TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9418   350 CONTINUE
9419   128 CONTINUE
9420   205 CONTINUE
9421       RETURN
9422       END SUBROUTINE SINTR2
9423       SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2)
9424 !CCC  PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL
9425 !                     CODES TO PRODUCE A FILE OF CO2 HGT DATA
9426 !                     FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE
9427 !                     CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89.
9428 !NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C.
9429       LOGICAL                 :: opened
9430       LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
9431       CHARACTER*80 errmess
9432 !     integer :: retval,kk,ka,kb
9433 !     character(50) :: co2='co2'
9434       INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR
9435       DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6)
9436 !NOV89
9437       DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6)
9438 !NOV89
9439       DIMENSION T41(LP2,2),T42(LP1), &
9440                 T43(LP2,2),T44(LP1)
9441       DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3)
9442       DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3)
9443       DIMENSION SGLVNU(LP1),SIGLNU(L)
9444       DIMENSION SFULL(LP1),SHALF(L)
9445 !     DIMENSION STEMP(LP1),GTEMP(LP1)
9446 !     DIMENSION CDTM51(L),CO2M51(L),C2DM51(L)
9447 !     DIMENSION CDTM58(L),CO2M58(L),C2DM58(L)
9448 !     DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1)
9449 !     DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1)
9450 !NOV89
9451 !     DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1)
9452 !     DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1)
9453 !     DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1)
9454 !     DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1)
9455 !     DIMENSION CO211(LP1),CO218(LP1)
9456 !     EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2))
9457 !     EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4))
9458 !     EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6))
9459 !     EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2))
9460 !     EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4))
9461 !     EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6))
9462 !     EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5))
9463 !NOV89
9464 !     EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2))
9465 !     EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2))
9466 !     EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4))
9467 !     EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6))
9468 !     EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2))
9469 !     EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4))
9470 !     EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6))
9471
9472 !
9473 !    Deallocate before reading. This is required for nested domain init.
9474 !
9475       IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9476       IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9477       IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9478       IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9479       IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9480       IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9481       IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9482       IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9483       IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9484       IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9485       IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9486       IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9487       IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9488       IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9489       IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9490       IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9491       IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9492       IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9493       IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9494       IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9495       IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9496       IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9497       IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9498       IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9499       IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9500       IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9501 !
9502       ALLOCATE(CO251(LP1,LP1))
9503       ALLOCATE(CDT51(LP1,LP1))
9504       ALLOCATE(C2D51(LP1,LP1))
9505       ALLOCATE(CO258(LP1,LP1))
9506       ALLOCATE(CDT58(LP1,LP1))
9507       ALLOCATE(C2D58(LP1,LP1))
9508       ALLOCATE(STEMP(LP1))
9509       ALLOCATE(GTEMP(LP1))
9510       ALLOCATE(CO231(LP1))
9511       ALLOCATE(CDT31(LP1))
9512       ALLOCATE(C2D31(LP1))
9513       ALLOCATE(CO238(LP1))
9514       ALLOCATE(CDT38(LP1))
9515       ALLOCATE(C2D38(LP1))
9516       ALLOCATE(CO271(LP1))
9517       ALLOCATE(CDT71(LP1))
9518       ALLOCATE(C2D71(LP1))
9519       ALLOCATE(CO278(LP1))
9520       ALLOCATE(CDT78(LP1))
9521       ALLOCATE(C2D78(LP1))
9522       ALLOCATE(CO2M51(L))
9523       ALLOCATE(CDTM51(L))
9524       ALLOCATE(C2DM51(L))
9525       ALLOCATE(CO2M58(L))
9526       ALLOCATE(CDTM58(L))
9527       ALLOCATE(C2DM58(L))
9528       IF ( wrf_dm_on_monitor() ) THEN
9529         DO i = 61,99
9530           INQUIRE ( i , OPENED = opened )
9531           IF ( .NOT. opened ) THEN
9532             etarad_unit61 = i
9533             GOTO 2061
9534           ENDIF
9535         ENDDO
9536         etarad_unit61 = -1
9537  2061   CONTINUE
9538         DO i = 62,99
9539           INQUIRE ( i , OPENED = opened )
9540           IF ( .NOT. opened ) THEN
9541             etarad_unit62 = i
9542             GOTO 2062
9543           ENDIF
9544         ENDDO
9545         etarad_unit62 = -1
9546  2062   CONTINUE
9547         DO i = 63,99
9548           INQUIRE ( i , OPENED = opened )
9549           IF ( .NOT. opened ) THEN
9550             etarad_unit63 = i
9551             GOTO 2063
9552           ENDIF
9553         ENDDO
9554         etarad_unit63 = -1
9555  2063   CONTINUE
9556       ENDIF
9557       CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE )
9558       IF ( etarad_unit61 < 0 ) THEN
9559         CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9560       ENDIF
9561       CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE )
9562       IF ( etarad_unit62 < 0 ) THEN
9563         CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9564       ENDIF
9565       CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE )
9566       IF ( etarad_unit63 < 0 ) THEN
9567         CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9568       ENDIF
9569         IF ( wrf_dm_on_monitor() ) THEN
9570           OPEN(etarad_unit61,FILE='tr49t85',                  &
9571                FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR)
9572         ENDIF
9573         IF ( wrf_dm_on_monitor() ) THEN
9574           OPEN(etarad_unit62,FILE='tr49t67',                  &
9575                FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR)
9576         ENDIF
9577         IF ( wrf_dm_on_monitor() ) THEN
9578           OPEN(etarad_unit63,FILE='tr67t85',                  &
9579                FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR)
9580         ENDIF
9581
9582 !===>  GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44....
9583       LREAD = 0
9584 !     DO KKK=1,L
9585 !JD      READ(23)SIGLNU(KKK)
9586 !      SIGLNU(KKK)=1.-FLOAT(KKK)/LP1
9587 !     END DO
9588       CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9589                   SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2)
9590 !       call int_get_fresh_handle(retval)
9591 !       close(retval)
9592 !       open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier)
9593 !       do kk=1,2
9594 !         write(retval)(sgtemp(k,kk),k=1,61)
9595 !       enddo
9596       DO K=1,LP1
9597         STEMP(K)=SGTEMP(K,1)
9598         GTEMP(K)=SGTEMP(K,2)
9599       ENDDO
9600 !===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9601 !         IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE...
9602 !           FOR THE CONSOLIDATED 490-850 CM-1 BAND...
9603 !NOV89
9604 !     ICO2TP=61
9605       ICO2TP=etarad_unit61
9606 !NOV89
9607       IR = 1
9608       RATIO = 1.0
9609       NMETHD = 2
9610       CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9611       IR = 1
9612       RATIO = 1.0
9613       NMETHD = 1
9614       CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2)
9615       IR = 1
9616       RATIO = 1.0
9617       NMETHD = 2
9618       CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9619       IR = 1
9620       RATIO = 1.0
9621       NMETHD = 1
9622       CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2)
9623 !===>    FILL UP THE CO2D1D ARRAY
9624 !       THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND
9625 !         THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS,
9626 !         WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE
9627 !         ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE
9628 !         ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O..
9629 !
9630       IQ = 1
9631       CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1)
9632 !       do kk=1,6
9633 !         write(retval)(co2d1d(k,kk),k=1,60)
9634 !       enddo
9635       DO K=1,L
9636         CDTM51(K)=CO2D1D(K,1)
9637         CO2M51(K)=CO2D1D(K,2)
9638         C2DM51(K)=CO2D1D(K,3)
9639         CDTM58(K)=CO2D1D(K,4)
9640         CO2M58(K)=CO2D1D(K,5)
9641         C2DM58(K)=CO2D1D(K,6)
9642       ENDDO
9643 !
9644 !===>    FILL UP THE CO2D2D ARRAY
9645 !    THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9646 !        FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9647 !        MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9648 !        TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A
9649 !        200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9650 !        SCHWARZKOPF AND FELS (J.G.R.,1985).
9651 !
9652       CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1)
9653 !       do kk=1,6
9654 !         write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61)
9655 !       enddo
9656       DO K1=1,LP1
9657       DO K2=1,LP1
9658         CDT51(K1,K2)=CO2D2D(K1,K2,1)
9659         CO251(K1,K2)=CO2D2D(K1,K2,2)
9660         C2D51(K1,K2)=CO2D2D(K1,K2,3)
9661         CDT58(K1,K2)=CO2D2D(K1,K2,4)
9662         CO258(K1,K2)=CO2D2D(K1,K2,5)
9663         C2D58(K1,K2)=CO2D2D(K1,K2,6)
9664       ENDDO
9665       ENDDO
9666 !
9667 !NOV89
9668 !===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9669 !         IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE...
9670 !           FOR THE CONSOLIDATED 490-670 CM-1 BAND...
9671 !     ICO2TP=62
9672       ICO2TP=etarad_unit62
9673       IR = 2
9674       RATIO = 1.0
9675       NMETHD = 2
9676       CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9677       CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9678       IQ = 2
9679       CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2)
9680 !       do kk=1,6
9681 !         write(retval)(co2iq2(k,1,kk),k=1,61)
9682 !       enddo
9683       DO K=1,LP1
9684         CDT31(K)=CO2IQ2(K,1,1)
9685         CO231(K)=CO2IQ2(K,1,2)
9686         C2D31(K)=CO2IQ2(K,1,3)
9687         CDT38(K)=CO2IQ2(K,1,4)
9688         CO238(K)=CO2IQ2(K,1,5)
9689         C2D38(K)=CO2IQ2(K,1,6)
9690       ENDDO
9691 !===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9692 !         IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE...
9693 !           FOR THE CONSOLIDATED 670-850 CM-1 BAND...
9694 !     ICO2TP=63
9695       ICO2TP=etarad_unit63
9696       IR = 3
9697       RATIO = 1.0
9698       NMETHD = 2
9699       CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9700       CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9701       IQ = 3
9702       CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3)
9703 !       do kk=1,6
9704 !         write(retval)(co2iq3(k,1,kk),k=1,61)
9705 !       enddo
9706 !       close(retval)
9707       DO K=1,LP1
9708         CDT71(K)=CO2IQ3(K,1,1)
9709         CO271(K)=CO2IQ3(K,1,2)
9710         C2D71(K)=CO2IQ3(K,1,3)
9711         CDT78(K)=CO2IQ3(K,1,4)
9712         CO278(K)=CO2IQ3(K,1,5)
9713         C2D78(K)=CO2IQ3(K,1,6)
9714       ENDDO
9715 !---      FOLLOWING CODE NOT WORKING AND NOT NEEDED YET
9716 !===>  INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9717 !         IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE...
9718 !           FOR THE 4.3 MICRON BAND...
9719 ! NOT USED YET      ICO2TP=65
9720 ! NOT USED YET      IR = 4
9721 ! NOT USED YET      RATIO = 1.0
9722 ! DAN SCHWARZ --- USE 300PPMV  RATIO = 0.9091   (NOT TESTED YET).....
9723 ! NOT USED YET      NMETHD = 2
9724 ! NOT USED YET      CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD)
9725 ! NOT USED YET      CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD)
9726 ! NOT USED YET      IQ = 5
9727 ! NOT USED YET      CALL CO2INS(T22,T23,CO2IQ5,IQ)
9728 !NOV89
9729 !...     WRITE DATA TO DISK..
9730 !            ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA
9731 !               IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP..
9732
9733 ! NOT USED YET      WRITE(66) CO211
9734 ! NOT USED YET      WRITE(66) CO218
9735 !NOV89
9736          IF ( wrf_dm_on_monitor() ) THEN
9737            CLOSE (etarad_unit61)
9738            CLOSE (etarad_unit62)
9739            CLOSE (etarad_unit63)
9740          ENDIF
9741
9742       RETURN
9743 9061 CONTINUE
9744      WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t85 on unit ',etarad_unit61
9745      write(0,*)' IERROR=',IERROR
9746      CALL wrf_error_fatal(errmess)
9747 9062 CONTINUE
9748      WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t67 on unit ',etarad_unit62
9749      write(0,*)' IERROR=',IERROR
9750      CALL wrf_error_fatal(errmess)
9751 9063 CONTINUE
9752      WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr67t85 on unit ',etarad_unit63
9753      write(0,*)' IERROR=',IERROR
9754      CALL wrf_error_fatal(errmess)
9755       END SUBROUTINE CO2O3
9756
9757
9758 !!================================================================================
9759 !----------------------------------------------------------------------
9760 !----------------------------------------------------------------------
9761       SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
9762 !----------------------------------------------------------------------
9763 !    *******************************************************************
9764 !    *                           C O N R A D                           *
9765 !    *    READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL  *
9766 !    *      COORDINATE TESTS      ...                                  *
9767 !    *    THESE ARRAYS USED TO BE IN BLOCK DATA    ...K.CAMPANA-MAR 90 *
9768 !    *******************************************************************
9769 !
9770 !----------------------------------------------------------------------
9771       IMPLICIT NONE
9772 !----------------------------------------------------------------------
9773       INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
9774 !----------------------------------------------------------------------
9775 !
9776       INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE
9777       INTEGER,DIMENSION(3) :: RSZE
9778 !
9779       REAL,DIMENSION(KMS:KME-1,6) :: CO21D
9780       REAL,DIMENSION(KMS:KME,2) :: SGTMP
9781       REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7
9782       REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D
9783       REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2
9784       LOGICAL :: OPENED
9785       LOGICAL,EXTERNAL :: wrf_dm_on_monitor
9786       CHARACTER*80 errmess
9787       character*255 message
9788 !
9789 !----------------------------------------------------------------------
9790 !
9791 !                 CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE
9792 !
9793 !   THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION
9794 !       FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND
9795 !       SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985),
9796 !-----  THE 2-DIMENSIONAL ARRAYS ARE
9797 !                    CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9798 !        FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9799 !        MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9800 !        TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A
9801 !        200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9802 !        SCHWARZKOPF AND FELS (J.G.R.,1985).
9803 !-----  THE 1-DIM ARRAYS ARE
9804 !                  CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9805 !          FOR TAU(I,I+1),I=1,L,
9806 !            WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE
9807 !            ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES.
9808 !          THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O.
9809 !-----  THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
9810 !         1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW)  L18 DATA LEVELS FOR
9811 !         PSTAR=1013250.
9812 !-----  STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS
9813 !        USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM)
9814 !
9815 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9816 !   AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED
9817 !   ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE
9818 !   DATA ARE IN BLOCK DATA BD3:
9819 !         CO251    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9820 !                       WITH P(SFC)=1013.25 MB
9821 !         CO258    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9822 !                       WITH P(SFC)= 810 MB
9823 !         CDT51    =  FIRST TEMPERATURE DERIVATIVE OF CO251
9824 !         CDT58    =  FIRST TEMPERATURE DERIVATIVE OF CO258
9825 !         C2D51    =  SECOND TEMPERATURE DERIVATIVE OF CO251
9826 !         C2D58    =  SECOND TEMPERATURE DERIVATIVE OF CO251
9827 !         CO2M51   =  TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE
9828 !                        LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR
9829 !                        NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB
9830 !         CO2M58   =  SAME AS CO2M51,WITH P(SFC)= 810 MB
9831 !         CDTM51   =  FIRST TEMPERATURE DERIVATIVE OF CO2M51
9832 !         CDTM58   =  FIRST TEMPERATURE DERIVATIVE OF CO2M58
9833 !         C2DM51   =  SECOND TEMPERATURE DERIVATIVE OF CO2M51
9834 !         C2DM58   =  SECOND TEMPERATURE DERIVATIVE OF CO2M58
9835 !         STEMP    =  STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL
9836 !                        STRUCTURE WITH P(SFC)=1013.25 MB
9837 !         GTEMP    =  WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL
9838 !                        STRUCTURE WITH P(SFC)=1013.25 MB.
9839 !-----       THE FOLLOWING ARE STILL IN BLOCK DATA
9840 !         B0       =  TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN.
9841 !                        CORRECTION FOR T(K). (SEE REF. 4 AND BD3)
9842 !         B1       =  TEMP. COEFFICIENT, USED ALONG WITH B0
9843 !         B2       =  TEMP. COEFFICIENT, USED ALONG WITH B0
9844 !         B3       =  TEMP. COEFFICIENT, USED ALONG WITH B0
9845 !
9846 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9847 !   AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM
9848 !   CO2 BAND.  THESE DATA ARE IN BLOCK DATA BD2.
9849 !     FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE
9850 !     THESE ARE USED FOR CTS COMPUTATIONS.
9851 !         CO231    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9852 !                       WITH P(SFC)=1013.25 MB
9853 !         CO238    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9854 !                       WITH P(SFC)= 810 MB
9855 !         CDT31    =  FIRST TEMPERATURE DERIVATIVE OF CO231
9856 !         CDT38    =  FIRST TEMPERATURE DERIVATIVE OF CO238
9857 !         C2D31    =  SECOND TEMPERATURE DERIVATIVE OF CO231
9858 !         C2D38    =  SECOND TEMPERATURE DERIVATIVE OF CO231
9859 !
9860 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9861 !   AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM
9862 !   CO2 BAND.  THESE DATA ARE IN BLOCK DATA BD4.
9863 !         CO271    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9864 !                       WITH P(SFC)=1013.25 MB
9865 !         CO278    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9866 !                       WITH P(SFC)= 810 MB
9867 !         CDT71    =  FIRST TEMPERATURE DERIVATIVE OF CO271
9868 !         CDT78    =  FIRST TEMPERATURE DERIVATIVE OF CO278
9869 !         C2D71    =  SECOND TEMPERATURE DERIVATIVE OF CO271
9870 !         C2D78    =  SECOND TEMPERATURE DERIVATIVE OF CO271
9871 !
9872 ! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION *******
9873 !
9874 ! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270-
9875 !       2380 PART OF THE 4.3 UM CO2 BAND.
9876 !              THESE DATA ARE IN BLOCK DATA BD5.
9877 !         CO211    =  TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9878 !                        WITH P(SFC)=1013.25 MB
9879 !         CO218    =  TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9880 !                       WITH P(SFC)= 810 MB
9881 !
9882 ! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION ***********
9883 !----------------------------------------------------------------------
9884 !
9885       L=KME-KMS
9886       LP1=KME-KMS+1
9887 !
9888 !----------------------------------------------------------------------
9889       IF ( wrf_dm_on_monitor() ) THEN
9890         DO i = 14,99
9891       write(message,*)' in CONRAD i=',i,' opened=',opened
9892       call wrf_debug(1,message)
9893           INQUIRE ( i , OPENED = opened )
9894           IF ( .NOT. opened ) THEN
9895             nunit_co2 = i
9896             GOTO 2014
9897           ENDIF
9898         ENDDO
9899         nunit_co2 = -1
9900  2014   CONTINUE
9901       ENDIF
9902         IF ( wrf_dm_on_monitor() ) THEN
9903           OPEN(nunit_co2,FILE='co2_trans',                  &
9904                FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR)
9905           REWIND NUNIT_CO2
9906         ENDIF
9907
9908 !----------------------------------------------------------------------
9909 !
9910 !***  READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.
9911 !
9912       RSZE(1) = LP1
9913       RSZE(2) = L
9914       RSZE(3) = LP1*LP1
9915 !----------------------------------------------------------------------
9916 !
9917       RSIZE = RSZE(1)
9918 !
9919       DO KK=1,2
9920         IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE)
9921         CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE )
9922       ENDDO
9923 !
9924 !----------------------------------------------------------------------
9925 !
9926       RSIZE = RSZE(2)
9927 !
9928       DO KK=1,6
9929         IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE)
9930         CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE )
9931       ENDDO
9932 !
9933 !----------------------------------------------------------------------
9934 !
9935       RSIZE = RSZE(3)
9936 !
9937       DO KK=1,6
9938         IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE)
9939         CALL wrf_dm_bcast_real( DATA2(1), RSIZE )
9940         N=0
9941 !
9942         DO I1=1,LP1
9943         DO I2=1,LP1
9944           N=N+1
9945           CO22D(I1,I2,KK)=DATA2(N)
9946         ENDDO
9947         ENDDO
9948 !
9949       ENDDO
9950
9951 !
9952 !    Deallocate before reading. This is required for nested domain init.
9953 !
9954       IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9955       IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9956       IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9957       IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9958       IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9959       IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9960       IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9961       IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9962       IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9963       IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9964       IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9965       IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9966       IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9967       IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9968       IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9969       IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9970       IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9971       IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9972       IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9973       IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9974       IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9975       IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9976       IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9977       IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9978       IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9979       IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9980 !
9981 !----------------------------------------------------------------------
9982 !
9983       RSIZE = RSZE(1)
9984 !
9985       DO KK=1,6
9986         IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE)
9987         CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE )
9988       ENDDO
9989 !
9990 !----------------------------------------------------------------------
9991 !
9992       DO KK=1,6
9993         IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE)
9994         CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE )
9995       ENDDO
9996 !
9997 !----------------------------------------------------------------------
9998       ALLOCATE(CO251(LP1,LP1))
9999       ALLOCATE(CDT51(LP1,LP1))
10000       ALLOCATE(C2D51(LP1,LP1))
10001       ALLOCATE(CO258(LP1,LP1))
10002       ALLOCATE(CDT58(LP1,LP1))
10003       ALLOCATE(C2D58(LP1,LP1))
10004       ALLOCATE(STEMP(LP1))
10005       ALLOCATE(GTEMP(LP1))
10006       ALLOCATE(CO231(LP1))
10007       ALLOCATE(CDT31(LP1))
10008       ALLOCATE(C2D31(LP1))
10009       ALLOCATE(CO238(LP1))
10010       ALLOCATE(CDT38(LP1))
10011       ALLOCATE(C2D38(LP1))
10012       ALLOCATE(CO271(LP1))
10013       ALLOCATE(CDT71(LP1))
10014       ALLOCATE(C2D71(LP1))
10015       ALLOCATE(CO278(LP1))
10016       ALLOCATE(CDT78(LP1))
10017       ALLOCATE(C2D78(LP1))
10018       ALLOCATE(CO2M51(L))
10019       ALLOCATE(CDTM51(L))
10020       ALLOCATE(C2DM51(L))
10021       ALLOCATE(CO2M58(L))
10022       ALLOCATE(CDTM58(L))
10023       ALLOCATE(C2DM58(L))
10024 !----------------------------------------------------------------------
10025 !
10026       DO K=1,LP1
10027         STEMP(K) = SGTMP(K,1)
10028         GTEMP(K) = SGTMP(K,2)
10029       ENDDO
10030 !
10031       DO K=1,L
10032         CDTM51(K) = CO21D(K,1)
10033         CO2M51(K) = CO21D(K,2)
10034         C2DM51(K) = CO21D(K,3)
10035         CDTM58(K) = CO21D(K,4)
10036         CO2M58(K) = CO21D(K,5)
10037         C2DM58(K) = CO21D(K,6)
10038       ENDDO
10039 !
10040       DO J=1,LP1
10041       DO I=1,LP1
10042         CDT51(I,J) = CO22D(I,J,1)
10043         CO251(I,J) = CO22D(I,J,2)
10044         C2D51(I,J) = CO22D(I,J,3)
10045         CDT58(I,J) = CO22D(I,J,4)
10046         CO258(I,J) = CO22D(I,J,5)
10047         C2D58(I,J) = CO22D(I,J,6)
10048       ENDDO
10049       ENDDO
10050 !
10051       DO K=1,LP1
10052         CDT31(K) = CO21D3(K,1)
10053         CO231(K) = CO21D3(K,2)
10054         C2D31(K) = CO21D3(K,3)
10055         CDT38(K) = CO21D3(K,4)
10056         CO238(K) = CO21D3(K,5)
10057         C2D38(K) = CO21D3(K,6)
10058       ENDDO
10059 !
10060       DO K=1,LP1
10061         CDT71(K) = CO21D7(K,1)
10062         CO271(K) = CO21D7(K,2)
10063         C2D71(K) = CO21D7(K,3)
10064         CDT78(K) = CO21D7(K,4)
10065         CO278(K) = CO21D7(K,5)
10066         C2D78(K) = CO21D7(K,6)
10067       ENDDO
10068 !
10069 !----------------------------------------------------------------------
10070       IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2
10071    66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2)
10072 !----------------------------------------------------------------------
10073       IF( wrf_dm_on_monitor() )THEN
10074         CLOSE(nunit_co2)
10075       ENDIF
10076       RETURN
10077 !
10078 9014 CONTINUE
10079      WRITE(errmess,'(A51,I4)')'module_ra_gfdleta: error reading co2_trans on unit ',nunit_co2
10080      CALL wrf_error_fatal(errmess)
10081 !----------------------------------------------------------------------
10082       END SUBROUTINE CONRAD
10083 !+---+-----------------------------------------------------------------+
10084 ! Replacement routine to compute saturation vapor pressure over
10085 ! water/ice.  This is needed here in case we run microphysics other
10086 ! than ETAMPNEW (Ferrier) because it initializes a lookup table to
10087 ! facilitate calculations of FVPS.  For speed, we use the polynomial
10088 ! expansion of Flatau & Walko, 1989.
10089 !+---+-----------------------------------------------------------------+
10090       REAL FUNCTION FPVS_new(T)
10091
10092       IMPLICIT NONE
10093       REAL, INTENT(IN):: T
10094
10095       if (T .ge. 273.16) then
10096          FPVS_new = e_sub_l(T)
10097       else
10098          FPVS_new = e_sub_i(T)
10099       endif
10100
10101       END FUNCTION FPVS_new
10102 !
10103 !+---+-----------------------------------------------------------------+
10104 ! THIS FUNCTION CALCULATES THE LIQUID SATURATION PRESSURE AS
10105 ! A FUNCTION OF TEMPERATURE.
10106 !
10107       REAL FUNCTION e_sub_l(T)
10108
10109       IMPLICIT NONE
10110       REAL, INTENT(IN):: T
10111       REAL:: ESL,X
10112       REAL, PARAMETER:: C0= .611583699E03
10113       REAL, PARAMETER:: C1= .444606896E02
10114       REAL, PARAMETER:: C2= .143177157E01
10115       REAL, PARAMETER:: C3= .264224321E-1
10116       REAL, PARAMETER:: C4= .299291081E-3
10117       REAL, PARAMETER:: C5= .203154182E-5
10118       REAL, PARAMETER:: C6= .702620698E-8
10119       REAL, PARAMETER:: C7= .379534310E-11
10120       REAL, PARAMETER:: C8=-.321582393E-13
10121
10122       X=AMAX1(-80.,T-273.16)
10123
10124       ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10125
10126       e_sub_l = ESL
10127
10128       END FUNCTION e_sub_l
10129 !
10130 !+---+-----------------------------------------------------------------+
10131 ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR PRESSURE AS A
10132 ! FUNCTION OF TEMPERATURE.
10133 !
10134       REAL FUNCTION e_sub_i(T)
10135
10136       IMPLICIT NONE
10137       REAL, INTENT(IN):: T
10138       REAL:: ESI,X
10139       REAL, PARAMETER:: C0= .609868993E03
10140       REAL, PARAMETER:: C1= .499320233E02
10141       REAL, PARAMETER:: C2= .184672631E01
10142       REAL, PARAMETER:: C3= .402737184E-1
10143       REAL, PARAMETER:: C4= .565392987E-3
10144       REAL, PARAMETER:: C5= .521693933E-5
10145       REAL, PARAMETER:: C6= .307839583E-7
10146       REAL, PARAMETER:: C7= .105785160E-9
10147       REAL, PARAMETER:: C8= .161444444E-12
10148
10149       X=AMAX1(-80.,T-273.16)
10150       ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10151
10152       e_sub_i = ESI
10153
10154       END FUNCTION e_sub_i
10155
10156 !
10157
10158 !----------------------------------------------------------------------
10159 !
10160       END MODULE module_RA_GFDLETA
10161 !
10162 !----------------------------------------------------------------------
10163