      subroutine pnbtcb (s,d)
!c     implicit double precision (a-h,o-z)                                    dp
       use mod_parameters
      common/range/mft,mlt,lft,llt,nftm1
!!	  common /stressflag/ ElemFractCode(nume),ElemDecayCount(nume)
!c	  common /overlapping/ intersec(4, nume), area_coeff(nume), update_flag
!c	  real area_coeff
!!	  integer ElemFractCode
!c      integer update_flag
      common/vect4/
     1 py1(nelemg),py2(nelemg),py3(nelemg),py4(nelemg),
     2 pz1(nelemg),pz2(nelemg),pz3(nelemg),pz4(nelemg),
     3 ph1(nelemg),ph2(nelemg),ph3(nelemg),ph4(nelemg)
      common/vect5/
     1 cb11(nelemg),cb21(nelemg),cb31(nelemg),cb41(nelemg),
     2 cb12(nelemg),cb22(nelemg),cb32(nelemg),cb42(nelemg),
     3 cb13(nelemg),cb23(nelemg),cb33(nelemg),cb43(nelemg),
     4 cb14(nelemg),cb24(nelemg),cb34(nelemg),cb44(nelemg),
     5 cb15(nelemg),cb25(nelemg),cb35(nelemg),cb45(nelemg),
     6 cb16(nelemg),cb26(nelemg),cb36(nelemg),cb46(nelemg),
     7 cb17(nelemg),cb27(nelemg),cb37(nelemg),cb47(nelemg),
     8 cb18(nelemg),cb28(nelemg),cb38(nelemg),cb48(nelemg)
      dimension s(44,1),d(4,4,1)
!$OMP PARALLEL DO
      do 10 i=lft,llt
      cb11(i)=d(1,1,i)*py1(i)+d(1,4,i)*pz1(i)
      cb21(i)=d(2,1,i)*py1(i)+d(2,4,i)*pz1(i)
      cb41(i)=d(4,1,i)*py1(i)+d(4,4,i)*pz1(i)
      cb12(i)=d(1,2,i)*pz1(i)+d(1,4,i)*py1(i)
      cb22(i)=d(2,2,i)*pz1(i)+d(2,4,i)*py1(i)
      cb42(i)=d(4,2,i)*pz1(i)+d(4,4,i)*py1(i)
!   10 continue
!      do 20 i=lft,llt
      cb13(i)=d(1,1,i)*py2(i)+d(1,4,i)*pz2(i)
      cb23(i)=d(2,1,i)*py2(i)+d(2,4,i)*pz2(i)
      cb43(i)=d(4,1,i)*py2(i)+d(4,4,i)*pz2(i)
      cb14(i)=d(1,2,i)*pz2(i)+d(1,4,i)*py2(i)
      cb24(i)=d(2,2,i)*pz2(i)+d(2,4,i)*py2(i)
      cb44(i)=d(4,2,i)*pz2(i)+d(4,4,i)*py2(i)
!   20 continue
!      do 30 i=lft,llt
      cb15(i)=d(1,1,i)*py3(i)+d(1,4,i)*pz3(i)
      cb25(i)=d(2,1,i)*py3(i)+d(2,4,i)*pz3(i)
      cb45(i)=d(4,1,i)*py3(i)+d(4,4,i)*pz3(i)
      cb16(i)=d(1,2,i)*pz3(i)+d(1,4,i)*py3(i)
      cb26(i)=d(2,2,i)*pz3(i)+d(2,4,i)*py3(i)
      cb46(i)=d(4,2,i)*pz3(i)+d(4,4,i)*py3(i)
!   30 continue
!      do 40 i=lft,llt
      cb17(i)=d(1,1,i)*py4(i)+d(1,4,i)*pz4(i)
      cb27(i)=d(2,1,i)*py4(i)+d(2,4,i)*pz4(i)
      cb47(i)=d(4,1,i)*py4(i)+d(4,4,i)*pz4(i)
      cb18(i)=d(1,2,i)*pz4(i)+d(1,4,i)*py4(i)
      cb28(i)=d(2,2,i)*pz4(i)+d(2,4,i)*py4(i)
      cb48(i)=d(4,2,i)*pz4(i)+d(4,4,i)*py4(i)
!   40 continue
!      do 50 i=lft,llt
      s(1,i)=s(1,i)+py1(i)*cb11(i)+pz1(i)*cb41(i)
      s(2,i)=s(2,i)+pz1(i)*cb21(i)+py1(i)*cb41(i)
      s(3,i)=s(3,i)+pz1(i)*cb22(i)+py1(i)*cb42(i)
      s(4,i)=s(4,i)+py2(i)*cb11(i)+pz2(i)*cb41(i)
      s(5,i)=s(5,i)+py2(i)*cb12(i)+pz2(i)*cb42(i)
      s(6,i)=s(6,i)+py2(i)*cb13(i)+pz2(i)*cb43(i)
      s(7,i)=s(7,i)+pz2(i)*cb21(i)+py2(i)*cb41(i)
      s(8,i)=s(8,i)+pz2(i)*cb22(i)+py2(i)*cb42(i)
      s(9,i)=s(9,i)+pz2(i)*cb23(i)+py2(i)*cb43(i)
      s(10,i)=s(10,i)+pz2(i)*cb24(i)+py2(i)*cb44(i)
!   50 continue
!      do 60 i=lft,llt
      s(11,i)=s(11,i)+py3(i)*cb11(i)+pz3(i)*cb41(i)
      s(12,i)=s(12,i)+py3(i)*cb12(i)+pz3(i)*cb42(i)
      s(13,i)=s(13,i)+py3(i)*cb13(i)+pz3(i)*cb43(i)
      s(14,i)=s(14,i)+py3(i)*cb14(i)+pz3(i)*cb44(i)
      s(15,i)=s(15,i)+py3(i)*cb15(i)+pz3(i)*cb45(i)
      s(16,i)=s(16,i)+pz3(i)*cb21(i)+py3(i)*cb41(i)
      s(17,i)=s(17,i)+pz3(i)*cb22(i)+py3(i)*cb42(i)
      s(18,i)=s(18,i)+pz3(i)*cb23(i)+py3(i)*cb43(i)
      s(19,i)=s(19,i)+pz3(i)*cb24(i)+py3(i)*cb44(i)
      s(20,i)=s(20,i)+pz3(i)*cb25(i)+py3(i)*cb45(i)
!   60 continue
!      do 70 i=lft,llt
      s(21,i)=s(21,i)+pz3(i)*cb26(i)+py3(i)*cb46(i)
      s(22,i)=s(22,i)+py4(i)*cb11(i)+pz4(i)*cb41(i)
      s(23,i)=s(23,i)+py4(i)*cb12(i)+pz4(i)*cb42(i)
      s(24,i)=s(24,i)+py4(i)*cb13(i)+pz4(i)*cb43(i)
      s(25,i)=s(25,i)+py4(i)*cb14(i)+pz4(i)*cb44(i)
      s(26,i)=s(26,i)+py4(i)*cb15(i)+pz4(i)*cb45(i)
      s(27,i)=s(27,i)+py4(i)*cb16(i)+pz4(i)*cb46(i)
      s(28,i)=s(28,i)+py4(i)*cb17(i)+pz4(i)*cb47(i)
      s(29,i)=s(29,i)+pz4(i)*cb21(i)+py4(i)*cb41(i)
      s(30,i)=s(30,i)+pz4(i)*cb22(i)+py4(i)*cb42(i)
!   70 continue
!      do 80 i=lft,llt
      s(31,i)=s(31,i)+pz4(i)*cb23(i)+py4(i)*cb43(i)
      s(32,i)=s(32,i)+pz4(i)*cb24(i)+py4(i)*cb44(i)
      s(33,i)=s(33,i)+pz4(i)*cb25(i)+py4(i)*cb45(i)
      s(34,i)=s(34,i)+pz4(i)*cb26(i)+py4(i)*cb46(i)
      s(35,i)=s(35,i)+pz4(i)*cb27(i)+py4(i)*cb47(i)
      s(36,i)=s(36,i)+pz4(i)*cb28(i)+py4(i)*cb48(i)
!   80 continue
   10 continue
!c     update stiffness for cracked element
!c      do i=lft,llt
!c        ink=i+nftm1
!c		if(ElemFractCode(ink)==1) then
!c		  do j=1,36
!c		    s(j,i)=area_coeff(ink)*s(j,i)
!c	      end do
!c		end if
!c	  end do
!c      if (update_flag==1) then
!
!c      do i=lft,llt
!c
!c	    ink=i+nftm1
!c	    if(ElemFractCode(ink)==2) then
!c	    open (unit = 11, file='stiff.dat', status = 'old')
!c	    do j=1,36
!c         read (11,*) s(j,i)
!c		end do
!c		close (unit=11)
!c		end if
!c
!c      end do
!
!c	  end if

      return
      end


CCHECK
C      SUBROUTINE TO CHECK SENSE LIGHTS
c     SUBROUTINE CHECK(J)
C
c     REAL MFSTOP
c     LOGICAL PREVER
c     COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
c    1KN,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
c    2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
c    3DELPR,PASS,IPC,LOPC,ISS
C
C     DO 1 I=1,4
C     CALL SLITET(I,J)
C     GO TO (2,1),J
C1     CONTINUE
c     J=2
c     RETURN
C2     J=1
C     PREVER=.TRUE.
C     RETURN
c     END
C     ESTABLISH VALUES FOR STATOR EXIT FLOW
      SUBROUTINE FLOW1(I)
C
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1 K,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      REAL M0
      COMMON /SSTA01/CP0(8),w0(6),               PS0(6,8),V0(6,8),TS0(6,
     18),VU0(6,8),VZ0(6,8),RHOS0(6,8),PS1(6,8),WGT1(8),TA1(8),WG1(6,8),
     2            DPDR1(6,8),SI(6,8),  CP1(8),PHI1(6,8),TS1(6,8),V1(6,8)
     3,RHOS1(6,8),ALF1E(6,8),VU1(6,8),VZ1(6,8),M0(6,8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      COMMON/TPT1/PT1(6),TT1(6,8)
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
C
C
C
C     print *,' Entering  In flow1  PT1(I)= ',PT1(I)
      ETAO1=1.
      cat1=cos(atan(tangm1(i,k)))
      EX=(GAM(2,K)-1.)/GAM(2,K)
C        COMPUTE ISENTROPIC STATOR TEMPERATURE RATIO
      PHI1(I,K)=PT0PS1(I,K)**EX
C        TEST FOR LOSS COEFFICIENT INPUT
C     IF (OMEGAS(1,1))2,2,1
C     replaced by ....................
      IF(OMEGAS(1,1).LE.0.) THEN
         GO TO 2
      ELSE
         GO TO 1
      ENDIF
1     CALL LOSS1(I,K,EX)
2     IF(EPR.GT.0.) CALL ETAPR(PT0PS1(I,K),ETAO1)
      ETA=ETAS(I,K)*ETAO1
      TS1(I,K)=TT1(I,K)*(1.-ETA      *(1.-1./PHI1(I,K)))
C     IF(I-IP)6,3,6
C     replaced by ....................
      IF((I-IP).NE.0) THEN
         GO TO 6
      ELSE
         GO TO 3
      ENDIF
C3     IF(GAMF)4,4,5
C     replaced by ....................
3     IF(GAMF.LE.0.) THEN
         GO TO 4
      ELSE
         GO TO 5
      ENDIF
4     TA1(K)=.5*(TT1(I,K)+TS1(I,K))
      CALL GAMA(PT0(IP,K),TA1(K),FAIRx(2,k),WAIRx(2,k),GAM(2,K))
5     EX=(GAM(2,K)-1.0)/GAM(2,K)
      EXI=1./EX
C     CRITICAL PRESSURE RATIO
      CALL PHIM(EXI,ETA      ,PHI1C   ,PTPS1C   )
      CP1(K)=RG1(k)*EXI/AJ
C        EXIT VELOCITY
6     V1(I,K)=SQRT(2.*G*AJ*CP1(K)*(TT1(I,K)-TS1(I,K)))
c      Pressure ratio correction to flow coefficient
      if (i.eq.ip) call etacf(pt0ps1(i,k),ptps1c,xcf)
C        EXIT PRESSURE
C     print *,'  In flow1  PT1(I)= ',PT1(I),'  PT0PS1(k)=',PT0PS1(I,K)
      PS1(I,K)=PT1(I  )/PT0PS1(I,K)
C        EXIT DENSITY
C     print *,'  In flow1  PS1(I,K)= ',PS1(I,K),'  rg1(k)=',rg1(k)
C     print *,'  TS1(I,K)= ',TS1(I,K)
      RHOS1(I,K)=144.*PS1(I,K)/(rg1(k)*TS1(I,K))
C        TEST CRITICAL PRESSURE RATIO
C     IF(RVU1(I,K))120,130,120
C     replaced by ....................
      IF(RVU1(I,K).NE.0.) THEN
         GO TO 120
      ELSE
         GO TO 130
      ENDIF
120   SNALF1=RVU1(I,K)*2./DP1(I,K)/V1(I,K)
      ASNALF=ABS(SNALF1)
      IF(ASNALF.GT.1.)SNALF1=SNALF1/(ASNALF+.01)
      CSAL1E=SQRT (1.-SNALF1**2)
      ALF1E(I,K)=ATAN(SNALF1/CSAL1E)
C130   IF(PT0PS1(I,K)-PTPS1C)140,   8,8
C     replaced by ....................
130   IF((PT0PS1(I,K)-PTPS1C).LT.0.) THEN
         GO TO 140
      ELSE
         GO TO 8
      ENDIF
C        GREATER THAN CRITICAL
8     IF(RVU1(I,K).NE.0.) GOTO 11
C     IF (IP-I) 21,9,21
C     replaced by ....................
      IF((IP-I).NE.0) THEN
         GO TO 21
      ELSE
         GO TO 9
      ENDIF
C9     IF (PRPC)10,10,22
C     replaced by ....................
9     IF(PRPC.LE.0.) THEN
         GO TO 10
      ELSE
         GO TO 22
      ENDIF
C        PREVIOUS PITCH NONCRITICAL
10    PRPC=1.
      GO TO 22
21    IF (PT0PS1(I,K).LE.PT0PS1(IP,K))  GO TO 22
      GO TO 11
22    IF ((I.EQ.1).OR.(I.EQ.ISECT))  SCRIT=1.
      GO TO 11
C        PITCH OR OUTBOARD SECTOR
11    CONTINUE
C   PRESSURE RATIO ABOVE CRITICAL
      IF(EPR.GT.0.) CALL ETAPR(PTPS1C,ETAO1)
      ETAC=ETAS(I,K)*ETAO1
      V1C     =SQRT(2.*G*AJ*CP1(K)*TT1(I,K)*ETAC     *(PHI1C
     1-1.)/PHI1C   )
      TS1C     =TT1(I,K)*(1.-ETAC     *(1.-1./PHI1C   ))
      RHOS1C     =144.*PT1(I  )/(  PTPS1C   *TS1C     *rg1(k))
C     IF(RVU1(I,K))15,150,15
C     replaced by ....................
C     print *,'  RVU1(I,K)=',RVU1(I,K),' I=',I,' K=',K
      IF(RVU1(I,K).NE.0.) THEN
         GO TO 15
      ELSE
         GO TO 150
      ENDIF
150   continue
C     print *,'   in flow1...  after 150...'
      cscyl=sqrt(1./(1.+(1./csalf1(i,k)**2-1.)/cat1**2))
      WG1(I,K)=RHOS1C     *V1C     *ANN1(I,K)*CScyl
     & *cat1*cfs(i,k)*xcf
      if (ando(1,k).gt.0.0) wg1(i,k)=wg1(i,k)/cfs(i,k)/xcf
      CScyle     =WG1(I,K)/(RHOS1(I,K)*V1(I,K)*ANN1(I,K))
     & /cat1/cfs(i,k)/xcf
      if (ando(1,k).gt.0.0) cscyle=cscyle*cfs(i,k)*xcf
      csal1e=sqrt(1./(1.+(1./cscyle**2-1.)*cat1**2))
C     EFFECTIVE STATOR EXIT ANGLE
      ALF1E(I,K)=ATAN2(SQRT(1.-CSAL1E     *CSAL1E     ),
     1CSAL1E)
      GO TO 16
C   PRESSURE RATIO LESS THAN CRITICAL
140   IF(RVU1(I,K).NE.0.)GO TO 15
      CSAL1E     =CSALF1(I,K)
      ALF1E(I,K)=ALF1(I,K)
15    continue
C     print *,'   in flow1...  after 15...'
      cscyle=sqrt(1./(1.+(1./csal1e**2-1.)/cat1**2))
C     print *,' cscyle =',cscyle,'  in flow1....'
c     print *,'  ANN1(I,K)=',ANN1(I,K),' I=',I,' K=',K
C     print *,'  RHOS1(I,K)=',RHOS1(I,K),' cat1 =',cat1
C     print *,'  cfs(I,K)=',cfs(I,K),' xcf  =',xcf
      WG1(I,K)=RHOS1(I,K)*V1(I,K)*ANN1(I,K)*CScyle
     & *cat1*cfs(i,k)*xcf
C       print *,'  WG1(I,K) = ',WG1(I,K),'  in flow1..1.'
      if (ando(1,k).gt.0.0) wg1(i,k)=wg1(i,k)/cfs(i,k)/xcf
C       print *,'  WG1(I,K) = ',WG1(I,K),'  in flow1..2.'
      IF(RVU1(I,K).EQ.0.) GO TO 16
C     IF(PT0PS1(I,K)-PTPS1C)170,180,180
C     replaced by ....................
      IF((PT0PS1(I,K)-PTPS1C).LT.0.) THEN
         GO TO 170
      ELSE
         GO TO 180
      ENDIF
170   CSALF1(I,K)=CSAL1E
      ALF1(I,K)=ALF1E(I,K)
      GO TO 16
180   CScyl=WG1(I,K)/RHOS1C/V1C/ANN1(I,K)/cfs(i,k)/xcf
     & /cat1
      if (ando(1,k).gt.0.0) cscyl=cscyl*cfs(i,k)*xcf
      csalf1(i,k)=sqrt(1./(1.+(1./cscyl**2-1.)*cat1**2))
      ALF1(I,K)=ATAN(SQRT(1.-CSALF1(I,K)**2)/CSALF1(I,K))*SNALF1/ASNALF
16    VU1(I,K)=V1(I,K)*SIN(ALF1E(I,K))
      VZ1(I,K)=V1(I,K)*CSAL1E
      IF(I.LT.ISECT) GO TO 17
      IF(PRPC.EQ.1.) PRPC=2.
17    j=2
      GO TO (19,20),J
19    CALL DIAGT(2)
20    RETURN
      END


      SUBROUTINE ICARUS(
     &     debug,
     &     debugcol,
     &     npoints,
     &     sunlit,
     &     nlev,
     &     ncol,
     &     pfull,
     &     phalf,
     &     qv,
     &     cc,
     &     conv,
     &     dtau_s,
     &     dtau_c,
     &     dtau_s_snow,
     &     top_height,
     &     top_height_direction,
     &     overlap,
     &     frac_out,
     &     prec_frac,
     &     skt,
     &     emsfc_lw,
     &     at,
     &     dem_s,
     &     dem_c,
     &     dem_s_snow,
     &     fq_isccp,
     &     totalcldarea,
     &     meanptop,
     &     meantaucld,
     &     meanalbedocld,
     &     meantb,
     &     meantbclr,
     &     boxtau,
     &     boxptop
     &)

!$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $

! *****************************COPYRIGHT****************************
! (c) 2009, Lawrence Livermore National Security Limited Liability
! Corporation.
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the
! following conditions are met:
!
!     * Redistributions of source code must retain the above
!       copyright  notice, this list of conditions and the following
!       disclaimer.
!     * Redistributions in binary form must reproduce the above
!       copyright notice, this list of conditions and the following
!       disclaimer in the documentation and/or other materials
!       provided with the distribution.
!     * Neither the name of the Lawrence Livermore National Security
!       Limited Liability Corporation nor the names of its
!       contributors may be used to endorse or promote products
!       derived from this software without specific prior written
!       permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! *****************************COPYRIGHT*******************************
! *****************************COPYRIGHT*******************************
! *****************************COPYRIGHT*******************************
! *****************************COPYRIGHT*******************************

      implicit none

!     NOTE:   the maximum number of levels and columns is set by
!             the following parameter statement

      INTEGER ncolprint

!     -----
!     Input
!     -----

      INTEGER npoints       !  number of model points in the horizontal
      INTEGER nlev          !  number of model levels in column
      INTEGER ncol          !  number of subcolumns

      INTEGER sunlit(npoints) !  1 for day points, 0 for night time

      REAL pfull(npoints,nlev)
                       !  pressure of full model levels (Pascals)
                  !  pfull(npoints,1) is top level of model
                  !  pfull(npoints,nlev) is bot of model

      REAL phalf(npoints,nlev+1)
                  !  pressure of half model levels (Pascals)
                  !  phalf(npoints,1) is top of model
                  !  phalf(npoints,nlev+1) is the surface pressure

      REAL qv(npoints,nlev)
                  !  water vapor specific humidity (kg vapor/ kg air)
                  !         on full model levels

      REAL cc(npoints,nlev)
                  !  input cloud cover in each model level (fraction)
                  !  NOTE:  This is the HORIZONTAL area of each
                  !         grid box covered by clouds

      REAL conv(npoints,nlev)
                  !  input convective cloud cover in each model
                  !   level (fraction)
                  !  NOTE:  This is the HORIZONTAL area of each
                  !         grid box covered by convective clouds

      REAL dtau_s(npoints,nlev)
                  !  mean 0.67 micron optical depth of stratiform
                !  clouds in each model level
                  !  NOTE:  this the cloud optical depth of only the
                  !  cloudy part of the grid box, it is not weighted
                  !  with the 0 cloud optical depth of the clear
                  !         part of the grid box

      REAL dtau_c(npoints,nlev)
                  !  mean 0.67 micron optical depth of convective
                !  clouds in each
                  !  model level.  Same note applies as in dtau_s.

      REAL dtau_s_snow(npoints,nlev)
                  !  mean 0.67 micron optical depth of stratiform
                !  snow in each model level

      INTEGER overlap                   !  overlap type
                              !  1=max
                              !  2=rand
                              !  3=max/rand

      INTEGER top_height                !  1 = adjust top height using both a computed
                                        !  infrared brightness temperature and the visible
                              !  optical depth to adjust cloud top pressure. Note
                              !  that this calculation is most appropriate to compare
                              !  to ISCCP data during sunlit hours.
                                        !  2 = do not adjust top height, that is cloud top
                                        !  pressure is the actual cloud top pressure
                                        !  in the model
                              !  3 = adjust top height using only the computed
                              !  infrared brightness temperature. Note that this
                              !  calculation is most appropriate to compare to ISCCP
                              !  IR only algortihm (i.e. you can compare to nighttime
                              !  ISCCP data with this option)

      INTEGER top_height_direction ! direction for finding atmosphere pressure level
                                 ! with interpolated temperature equal to the radiance
				 ! determined cloud-top temperature
				 !
				 ! 1 = find the *lowest* altitude (highest pressure) level
				 ! with interpolated temperature equal to the radiance
				 ! determined cloud-top temperature
				 !
				 ! 2 = find the *highest* altitude (lowest pressure) level
				 ! with interpolated temperature equal to the radiance
				 ! determined cloud-top temperature
				 !
				 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
				 !				 !
				 ! 1 = old setting: matches all versions of
				 ! ISCCP simulator with versions numbers 3.5.1 and lower
				 !
				 ! 2 = default setting: for version numbers 4.0 and higher
!
!     The following input variables are used only if top_height = 1 or top_height = 3
!
      REAL skt(npoints)                 !  skin Temperature (K)
      REAL emsfc_lw                     !  10.5 micron emissivity of surface (fraction)
      REAL at(npoints,nlev)                   !  temperature in each model level (K)
      REAL dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
                              !  clouds in each
                                        !  model level.  Same note applies as in dtau_s.
      REAL dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
                              !  clouds in each
                                        !  model level.  Same note applies as in dtau_s.

      REAL dem_s_snow(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
                              !  snow in each
                                        !  model level.  Same note applies as in dtau_s.

      REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
                              ! Equivalent of BOX in original version, but
                              ! indexed by column then row, rather than
                              ! by row then column

      REAL prec_frac(npoints,ncol,nlev) ! box indicator for precipitation
					! 0 -> clear sky
                                        ! 1 -> LS precipitation
                                        ! 2 -> CONV precipitation
                    			! 3 -> both

!     ------
!     Output
!     ------

      REAL fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
                                        !  each of the 49 ISCCP D level cloud types

      REAL totalcldarea(npoints)        !  the fraction of model grid box columns
                                        !  with cloud somewhere in them.  NOTE: This diagnostic
					! does not count model clouds with tau < isccp_taumin
                              ! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
			      ! However, this diagnostic does equal the sum over entries of fq_isccp with
			      ! itau = 2:7 (omitting itau = 1)

      ! The following three means are averages only over the cloudy areas with tau > isccp_taumin.
      ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.

      REAL meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
                                        !  in cloud top pressure.

      REAL meantaucld(npoints)          !  mean optical thickness
                                        !  linear averaging in albedo performed.

      real meanalbedocld(npoints)        ! mean cloud albedo
                                        ! linear averaging in albedo performed

      real meantb(npoints)              ! mean all-sky 10.5 micron brightness temperature

      real meantbclr(npoints)           ! mean clear-sky 10.5 micron brightness temperature

      REAL boxtau(npoints,ncol)         !  optical thickness in each column

      REAL boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column

!
!     ------
!     Working variables added when program updated to mimic Mark Webb's PV-Wave code
!     ------

      REAL dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave
                              !  emissivity in part of
                              !  gridbox under consideration

      REAL ptrop(npoints)
      REAL attrop(npoints)
      REAL attropmin (npoints)
      REAL atmax(npoints)
      REAL btcmin(npoints)
      REAL transmax(npoints)

      INTEGER i,j,ilev,ibox,itrop(npoints)
      INTEGER ipres(npoints)
      INTEGER itau(npoints),ilev2
      INTEGER acc(nlev,ncol)
      INTEGER match(npoints,nlev-1)
      INTEGER nmatch(npoints)
      INTEGER levmatch(npoints,ncol)

      !variables needed for water vapor continuum absorption
      real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
      real taumin(npoints)
      real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
      real press(npoints), dpress(npoints), atmden(npoints)
      real rvh20(npoints), wk(npoints), rhoave(npoints)
      real rh20s(npoints), rfrgn(npoints)
      real tmpexp(npoints),tauwv(npoints)

      character*1 cchar(6),cchar_realtops(6)
      integer icycle
      REAL tau(npoints,ncol)
      LOGICAL box_cloudy(npoints,ncol)
      REAL tb(npoints,ncol)
      REAL ptop(npoints,ncol)
      REAL emcld(npoints,ncol)
      REAL fluxtop(npoints,ncol)
      REAL trans_layers_above(npoints,ncol)
      real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
      REAL albedocld(npoints,ncol)
      real boxarea
      integer debug       ! set to non-zero value to print out inputs
                    ! with step debug
      integer debugcol    ! set to non-zero value to print out column
                    ! decomposition with step debugcol
      integer rangevec(npoints),rangeerror

      integer index1(npoints),num1,jj,k1,k2
      real rec2p13,tauchk,logp,logp1,logp2,atd
      real output_missing_value

      character*10 ftn09

      DATA isccp_taumin / 0.3 /
      DATA output_missing_value / 1.E+20 /
      DATA cchar / ' ','-','1','+','I','+'/
      DATA cchar_realtops / ' ',' ','1','1','I','I'/

!     ------ End duplicate definitions common to wrapper routine

      tauchk = -1.*log(0.9999999)
      rec2p13=1./2.13

      ncolprint=0

      if ( debug.ne.0 ) then
          j=1
          write(6,'(a10)') 'j='
          write(6,'(8I10)') j
          write(6,'(a10)') 'debug='
          write(6,'(8I10)') debug
          write(6,'(a10)') 'debugcol='
          write(6,'(8I10)') debugcol
          write(6,'(a10)') 'npoints='
          write(6,'(8I10)') npoints
          write(6,'(a10)') 'nlev='
          write(6,'(8I10)') nlev
          write(6,'(a10)') 'ncol='
          write(6,'(8I10)') ncol
          write(6,'(a11)') 'top_height='
          write(6,'(8I10)') top_height
	  write(6,'(a21)') 'top_height_direction='
          write(6,'(8I10)') top_height_direction
          write(6,'(a10)') 'overlap='
          write(6,'(8I10)') overlap
          write(6,'(a10)') 'emsfc_lw='
          write(6,'(8f10.2)') emsfc_lw
        do j=1,npoints,debug
          write(6,'(a10)') 'j='
          write(6,'(8I10)') j
          write(6,'(a10)') 'sunlit='
          write(6,'(8I10)') sunlit(j)
          write(6,'(a10)') 'pfull='
          write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
          write(6,'(a10)') 'phalf='
          write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
          write(6,'(a10)') 'qv='
          write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
          write(6,'(a10)') 'cc='
          write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
          write(6,'(a10)') 'conv='
          write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
          write(6,'(a10)') 'dtau_s='
          write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
          write(6,'(a10)') 'dtau_c='
          write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
          write(6,'(a10)') 'dtau_s_snow='
          write(6,'(8g12.5)') (dtau_s_snow(j,i),i=1,nlev)
          write(6,'(a10)') 'skt='
          write(6,'(8f10.2)') skt(j)
          write(6,'(a10)') 'at='
          write(6,'(8f10.2)') (at(j,i),i=1,nlev)
          write(6,'(a10)') 'dem_s='
          write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
          write(6,'(a10)') 'dem_c='
          write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev)
	  write(6,'(a10)') 'dem_s_snow='
          write(6,'(8f10.3)') (dem_s_snow(j,i),i=1,nlev)
        enddo
      endif

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

      if (ncolprint.ne.0) then
      do j=1,npoints,1000
        write(6,'(a10)') 'j='
        write(6,'(8I10)') j
      enddo
      endif

      if (top_height .eq. 1 .or. top_height .eq. 3) then

      do j=1,npoints
          ptrop(j)=5000.
          attropmin(j) = 400.
          atmax(j) = 0.
          attrop(j) = 120.
          itrop(j) = 1
      enddo

      do 12 ilev=1,nlev
        do j=1,npoints
         if (pfull(j,ilev) .lt. 40000. .and.
     &          pfull(j,ilev) .gt.  5000. .and.
     &          at(j,ilev) .lt. attropmin(j)) then
                ptrop(j) = pfull(j,ilev)
                attropmin(j) = at(j,ilev)
                attrop(j) = attropmin(j)
                itrop(j)=ilev
           end if
        enddo
12    continue

      do 13 ilev=1,nlev
        do j=1,npoints
           if (at(j,ilev) .gt. atmax(j) .and.
     &              ilev  .ge. itrop(j)) atmax(j)=at(j,ilev)
        enddo
13    continue

      end if

      if (top_height .eq. 1 .or. top_height .eq. 3) then
          do j=1,npoints
              meantb(j) = 0.
	      meantbclr(j) = 0.
          end do
      else
          do j=1,npoints
              meantb(j) = output_missing_value
       	      meantbclr(j) = output_missing_value
          end do
      end if

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

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

      do ilev=1,nlev
        do j=1,npoints

          rangevec(j)=0

          if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
!           error = cloud fraction less than zero
!           error = cloud fraction greater than 1
            rangevec(j)=rangevec(j)+1
          endif

          if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
!           ' error = convective cloud fraction less than zero'
!           ' error = convective cloud fraction greater than 1'
            rangevec(j)=rangevec(j)+2
          endif

          if (dtau_s(j,ilev) .lt. 0.) then
!           ' error = stratiform cloud opt. depth less than zero'
            rangevec(j)=rangevec(j)+4
          endif

          if (dtau_c(j,ilev) .lt. 0.) then
!           ' error = convective cloud opt. depth less than zero'
            rangevec(j)=rangevec(j)+8
          endif

          if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
!             ' error = stratiform cloud emissivity less than zero'
!             ' error = stratiform cloud emissivity greater than 1'
            rangevec(j)=rangevec(j)+16
          endif

          if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
!             ' error = convective cloud emissivity less than zero'
!             ' error = convective cloud emissivity greater than 1'
              rangevec(j)=rangevec(j)+32
          endif

          if (dtau_s_snow(j,ilev) .lt. 0.) then
!           ' error = stratiform snow opt. depth less than zero'
            rangevec(j)=rangevec(j)+64
          endif

          if (dem_s_snow(j,ilev) .lt. 0. .or.
     &        dem_s_snow(j,ilev) .gt. 1.) then
!             ' error = stratiform snow emissivity less than zero'
!             ' error = stratiform snow emissivity greater than 1'
            rangevec(j)=rangevec(j)+128
          endif

        enddo

        rangeerror=0
        do j=1,npoints
            rangeerror=rangeerror+rangevec(j)
        enddo

        if (rangeerror.ne.0) then
              write (6,*) 'Input variable out of range'
              write (6,*) 'rangevec:'
              write (6,*) rangevec
!! local mod for CAM/CCSM - comment out per Brian Eaton, jek
!!              call flush(6)
              STOP
        endif
      enddo

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

!
!     ---------------------------------------------------!
!     COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
!     put into vector tau

      !initialize tau and albedocld to zero
      do 15 ibox=1,ncol
        do j=1,npoints
            tau(j,ibox)=0.
          albedocld(j,ibox)=0.
          boxtau(j,ibox)=output_missing_value
          boxptop(j,ibox)=output_missing_value
          box_cloudy(j,ibox)=.false.
        enddo
15    continue

      !compute total cloud optical depth for each column
      do ilev=1,nlev
            !increment tau for each of the boxes
            do ibox=1,ncol
              do j=1,npoints
                 if (frac_out(j,ibox,ilev).eq.1) then
                        tau(j,ibox)=tau(j,ibox)
     &                     + dtau_s(j,ilev)
                 endif
                 if (frac_out(j,ibox,ilev).eq.2) then
                        tau(j,ibox)=tau(j,ibox)
     &                     + dtau_c(j,ilev)
                 end if
                 if ((prec_frac(j,ibox,ilev).eq.1) .or.
     &               (prec_frac(j,ibox,ilev).eq.3)) then
                        tau(j,ibox)=tau(j,ibox)
     &                     + dtau_s_snow(j,ilev)
                 end if
              enddo
            enddo ! ibox
      enddo ! ilev
          if (ncolprint.ne.0) then

              do j=1,npoints ,1000
                write(6,'(a10)') 'j='
                write(6,'(8I10)') j
                write(6,'(i2,1X,8(f7.2,1X))')
     &          ilev,
     &          (tau(j,ibox),ibox=1,ncolprint)
              enddo
          endif
!
!     ---------------------------------------------------!

!
!     ---------------------------------------------------!
!     COMPUTE INFRARED BRIGHTNESS TEMPERUATRES
!     AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE
!
!     again this is only done if top_height = 1 or 3
!
!     fluxtop is the 10.5 micron radiance at the top of the
!              atmosphere
!     trans_layers_above is the total transmissivity in the layers
!             above the current layer
!     fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear
!             sky versions of these quantities.

      if (top_height .eq. 1 .or. top_height .eq. 3) then

        !----------------------------------------------------------------------
        !
        !             DO CLEAR SKY RADIANCE CALCULATION FIRST
        !
        !compute water vapor continuum emissivity
        !this treatment follows Schwarkzopf and Ramasamy
        !JGR 1999,vol 104, pages 9467-9499.
        !the emissivity is calculated at a wavenumber of 955 cm-1,
        !or 10.47 microns
        wtmair = 28.9644
        wtmh20 = 18.01534
        Navo = 6.023E+23
        grav = 9.806650E+02
        pstd = 1.013250E+06
        t0 = 296.
        if (ncolprint .ne. 0)
     &         write(6,*)  'ilev   pw (kg/m2)   tauwv(j)      dem_wv'
        do 125 ilev=1,nlev
          do j=1,npoints
               !press and dpress are dyne/cm2 = Pascals *10
               press(j) = pfull(j,ilev)*10.
               dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10
               !atmden = g/cm2 = kg/m2 / 10
               atmden(j) = dpress(j)/grav
               rvh20(j) = qv(j,ilev)*wtmair/wtmh20
               wk(j) = rvh20(j)*Navo*atmden(j)/wtmair
               rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev))
               rh20s(j) = rvh20(j)*rhoave(j)
               rfrgn(j) = rhoave(j)-rh20s(j)
               tmpexp(j) = exp(-0.02*(at(j,ilev)-t0))
               tauwv(j) = wk(j)*1.e-20*(
     &           (0.0224697*rh20s(j)*tmpexp(j)) +
     &                (3.41817e-7*rfrgn(j)) )*0.98
               dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j))
          enddo
               if (ncolprint .ne. 0) then
               do j=1,npoints ,1000
               write(6,'(a10)') 'j='
               write(6,'(8I10)') j
               write(6,'(i2,1X,3(f8.3,3X))') ilev,
     &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
     &           tauwv(j),dem_wv(j,ilev)
               enddo
             endif
125     continue

        !initialize variables
        do j=1,npoints
          fluxtop_clrsky(j) = 0.
          trans_layers_above_clrsky(j)=1.
        enddo

        do ilev=1,nlev
          do j=1,npoints

            ! Black body emission at temperature of the layer

              bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
              !bb(j)= 5.67e-8*at(j,ilev)**4

              ! increase TOA flux by flux emitted from layer
              ! times total transmittance in layers above

                fluxtop_clrsky(j) = fluxtop_clrsky(j)
     &            + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j)

                ! update trans_layers_above with transmissivity
              ! from this layer for next time around loop

                trans_layers_above_clrsky(j)=
     &            trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev))

          enddo
            if (ncolprint.ne.0) then
             do j=1,npoints ,1000
              write(6,'(a10)') 'j='
              write(6,'(8I10)') j
              write (6,'(a)') 'ilev:'
              write (6,'(I2)') ilev

              write (6,'(a)')
     &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
              write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
     &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
             enddo
            endif

        enddo   !loop over level

        do j=1,npoints
          !add in surface emission
          bb(j)=1/( exp(1307.27/skt(j)) - 1. )
          !bb(j)=5.67e-8*skt(j)**4

          fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j)
     &     * trans_layers_above_clrsky(j)

          !clear sky brightness temperature
          meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))

        enddo

        if (ncolprint.ne.0) then
        do j=1,npoints ,1000
          write(6,'(a10)') 'j='
          write(6,'(8I10)') j
          write (6,'(a)') 'id:'
          write (6,'(a)') 'surface'

          write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
          write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j),
     &      100.*fluxtop_clrsky(j),
     &       trans_layers_above_clrsky(j), meantbclr(j)
        enddo
      endif

        !
        !           END OF CLEAR SKY CALCULATION
        !
        !----------------------------------------------------------------

        if (ncolprint.ne.0) then

        do j=1,npoints ,1000
            write(6,'(a10)') 'j='
            write(6,'(8I10)') j
            write (6,'(a)') 'ts:'
            write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)

            write (6,'(a)') 'ta_rev:'
            write (6,'(8f7.2)')
     &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)

        enddo
        endif
        !loop over columns
        do ibox=1,ncol
          do j=1,npoints
            fluxtop(j,ibox)=0.
            trans_layers_above(j,ibox)=1.
          enddo
        enddo

        do ilev=1,nlev
              do j=1,npoints
                ! Black body emission at temperature of the layer

              bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
              !bb(j)= 5.67e-8*at(j,ilev)**4
              enddo

            do ibox=1,ncol
              do j=1,npoints

              ! emissivity for point in this layer
                if (frac_out(j,ibox,ilev).eq.1) then
                dem(j,ibox)= 1. -
     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
                else if (frac_out(j,ibox,ilev).eq.2) then
                dem(j,ibox)= 1. -
     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_c(j,ilev)) )
                else
                dem(j,ibox)=  dem_wv(j,ilev)
                end if

                if ((prec_frac(j,ibox,ilev).eq.1) .or.
     &              (prec_frac(j,ibox,ilev).eq.3) ) then
                dem(j,ibox) = 1. -
     &             ( (1. - dem(j,ibox)) * (1. - dem_s_snow(j,ilev)) )
                else
                dem(j,ibox) = dem(j,ibox)
                end if

                ! increase TOA flux by flux emitted from layer
              ! times total transmittance in layers above

                fluxtop(j,ibox) = fluxtop(j,ibox)
     &            + dem(j,ibox) * bb(j)
     &            * trans_layers_above(j,ibox)

                ! update trans_layers_above with transmissivity
              ! from this layer for next time around loop

                trans_layers_above(j,ibox)=
     &            trans_layers_above(j,ibox)*(1.-dem(j,ibox))

              enddo ! j
            enddo ! ibox

            if (ncolprint.ne.0) then
              do j=1,npoints,1000
              write (6,'(a)') 'ilev:'
              write (6,'(I2)') ilev

              write(6,'(a10)') 'j='
              write(6,'(8I10)') j
              write (6,'(a)') 'emiss_layer:'
              write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)

              write (6,'(a)') '100.*bb(j):'
              write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)

              write (6,'(a)') '100.*f:'
              write (6,'(8f7.2)')
     &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)

              write (6,'(a)') 'total_trans:'
              write (6,'(8f7.2)')
     &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
            enddo
          endif

        enddo ! ilev

          do j=1,npoints
            !add in surface emission
            bb(j)=1/( exp(1307.27/skt(j)) - 1. )
            !bb(j)=5.67e-8*skt(j)**4
          end do

        do ibox=1,ncol
          do j=1,npoints

            !add in surface emission

            fluxtop(j,ibox) = fluxtop(j,ibox)
     &         + emsfc_lw * bb(j)
     &         * trans_layers_above(j,ibox)

          end do
        end do

        !calculate mean infrared brightness temperature
        do ibox=1,ncol
          do j=1,npoints
            meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox))))
	  end do
        end do
	  do j=1, npoints
	    meantb(j) = meantb(j) / real(ncol)
	  end do

        if (ncolprint.ne.0) then

          do j=1,npoints ,1000
          write(6,'(a10)') 'j='
          write(6,'(8I10)') j
          write (6,'(a)') 'id:'
          write (6,'(a)') 'surface'

          write (6,'(a)') 'emiss_layer:'
          write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)

          write (6,'(a)') '100.*bb(j):'
          write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)

          write (6,'(a)') '100.*f:'
          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)

	  write (6,'(a)') 'meantb(j):'
          write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint)

          end do
      endif

        !now that you have the top of atmosphere radiance account
        !for ISCCP procedures to determine cloud top temperature

        !account for partially transmitting cloud recompute flux
        !ISCCP would see assuming a single layer cloud
        !note choice here of 2.13, as it is primarily ice
        !clouds which have partial emissivity and need the
        !adjustment performed in this section
        !
      !If it turns out that the cloud brightness temperature
      !is greater than 260K, then the liquid cloud conversion
        !factor of 2.56 is used.
      !
        !Note that this is discussed on pages 85-87 of
        !the ISCCP D level documentation (Rossow et al. 1996)

          do j=1,npoints
            !compute minimum brightness temperature and optical depth
            btcmin(j) = 1. /  ( exp(1307.27/(attrop(j)-5.)) - 1. )
          enddo
        do ibox=1,ncol
          do j=1,npoints
            transmax(j) = (fluxtop(j,ibox)-btcmin(j))
     &                /(fluxtop_clrsky(j)-btcmin(j))
          !note that the initial setting of tauir(j) is needed so that
          !tauir(j) has a realistic value should the next if block be
          !bypassed
            tauir(j) = tau(j,ibox) * rec2p13
            taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001))

          enddo

          if (top_height .eq. 1) then
            do j=1,npoints
              if (transmax(j) .gt. 0.001 .and.
     &          transmax(j) .le. 0.9999999) then
                fluxtopinit(j) = fluxtop(j,ibox)
              tauir(j) = tau(j,ibox) *rec2p13
              endif
            enddo
            do icycle=1,2
              do j=1,npoints
                if (tau(j,ibox) .gt. (tauchk            )) then
                if (transmax(j) .gt. 0.001 .and.
     &            transmax(j) .le. 0.9999999) then
                  emcld(j,ibox) = 1. - exp(-1. * tauir(j)  )
                  fluxtop(j,ibox) = fluxtopinit(j) -
     &              ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
                  fluxtop(j,ibox)=max(1.E-06,
     &              (fluxtop(j,ibox)/emcld(j,ibox)))
                  tb(j,ibox)= 1307.27
     &              / (log(1. + (1./fluxtop(j,ibox))))
                  if (tb(j,ibox) .gt. 260.) then
                  tauir(j) = tau(j,ibox) / 2.56
                  end if
                end if
                end if
              enddo
            enddo

          endif

          do j=1,npoints
            if (tau(j,ibox) .gt. (tauchk            )) then
                !cloudy box
		!NOTE: tb is the cloud-top temperature not infrared brightness temperature
		!at this point in the code
                tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox))))
                if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then
                         tb(j,ibox) = attrop(j) - 5.
                   tau(j,ibox) = 2.13*taumin(j)
                end if
            else
                !clear sky brightness temperature
                tb(j,ibox) = meantbclr(j)
            end if
          enddo ! j
        enddo ! ibox

        if (ncolprint.ne.0) then

          do j=1,npoints,1000
          write(6,'(a10)') 'j='
          write(6,'(8I10)') j

          write (6,'(a)') 'attrop:'
          write (6,'(8f7.2)') (attrop(j))

          write (6,'(a)') 'btcmin:'
          write (6,'(8f7.2)') (btcmin(j))

          write (6,'(a)') 'fluxtop_clrsky*100:'
          write (6,'(8f7.2)')
     &      (100.*fluxtop_clrsky(j))

          write (6,'(a)') '100.*f_adj:'
          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)

          write (6,'(a)') 'transmax:'
          write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)

          write (6,'(a)') 'tau:'
          write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)

          write (6,'(a)') 'emcld:'
          write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)

          write (6,'(a)') 'total_trans:'
          write (6,'(8f7.2)')
     &        (trans_layers_above(j,ibox),ibox=1,ncolprint)

          write (6,'(a)') 'total_emiss:'
          write (6,'(8f7.2)')
     &        (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)

          write (6,'(a)') 'total_trans:'
          write (6,'(8f7.2)')
     &        (trans_layers_above(j,ibox),ibox=1,ncolprint)

          write (6,'(a)') 'ppout:'
          write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
          enddo ! j
      endif

      end if

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

!
!     ---------------------------------------------------!
!     DETERMINE CLOUD TOP PRESSURE
!
!     again the 2 methods differ according to whether
!     or not you use the physical cloud top pressure (top_height = 2)
!     or the radiatively determined cloud top pressure (top_height = 1 or 3)
!

      !compute cloud top pressure
      do 30 ibox=1,ncol
        !segregate according to optical thickness
        if (top_height .eq. 1 .or. top_height .eq. 3) then
          !find level whose temperature
          !most closely matches brightness temperature
          do j=1,npoints
            nmatch(j)=0
          enddo
          do 29 k1=1,nlev-1
	    if (top_height_direction .eq. 2) then
	      ilev = nlev - k1
	    else
	      ilev = k1
	    end if
            !cdir nodep
            do j=1,npoints
	     if (ilev .ge. itrop(j)) then
              if ((at(j,ilev)   .ge. tb(j,ibox) .and.
     &          at(j,ilev+1) .le. tb(j,ibox)) .or.
     &          (at(j,ilev) .le. tb(j,ibox) .and.
     &          at(j,ilev+1) .ge. tb(j,ibox))) then
                nmatch(j)=nmatch(j)+1
		match(j,nmatch(j))=ilev
              end if
	     end if
            enddo
29        continue

          do j=1,npoints
            if (nmatch(j) .ge. 1) then
              k1 = match(j,nmatch(j))
	      k2 = k1 + 1
              logp1 = log(pfull(j,k1))
              logp2 = log(pfull(j,k2))
	      atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
              logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
              ptop(j,ibox) = exp(logp)
	      if(abs(pfull(j,k1)-ptop(j,ibox)) .lt.
     &            abs(pfull(j,k2)-ptop(j,ibox))) then
                 levmatch(j,ibox)=k1
              else
                 levmatch(j,ibox)=k2
              end if
            else
              if (tb(j,ibox) .le. attrop(j)) then
                ptop(j,ibox)=ptrop(j)
                levmatch(j,ibox)=itrop(j)
              end if
              if (tb(j,ibox) .ge. atmax(j)) then
                ptop(j,ibox)=pfull(j,nlev)
                levmatch(j,ibox)=nlev
              end if
            end if
          enddo ! j

        else ! if (top_height .eq. 1 .or. top_height .eq. 3)

          do j=1,npoints
            ptop(j,ibox)=0.
          enddo
          do ilev=1,nlev
            do j=1,npoints
              if ((ptop(j,ibox) .eq. 0. )
     &           .and.(frac_out(j,ibox,ilev) .ne. 0)) then
                ptop(j,ibox)=phalf(j,ilev)
              levmatch(j,ibox)=ilev
              end if
            end do
          end do
        end if

        do j=1,npoints
          if (tau(j,ibox) .le. (tauchk            )) then
            ptop(j,ibox)=0.
            levmatch(j,ibox)=0
          endif
        enddo

30    continue

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

!
!     ---------------------------------------------------!
!     DETERMINE ISCCP CLOUD TYPE FREQUENCIES
!
!     Now that ptop and tau have been determined,
!     determine amount of each of the 49 ISCCP cloud
!     types
!
!     Also compute grid box mean cloud top pressure and
!     optical thickness.  The mean cloud top pressure and
!     optical thickness are averages over the cloudy
!     area only. The mean cloud top pressure is a linear
!     average of the cloud top pressures.  The mean cloud
!     optical thickness is computed by converting optical
!     thickness to an albedo, averaging in albedo units,
!     then converting the average albedo back to a mean
!     optical thickness.
!

      !compute isccp frequencies

      !reset frequencies
      do 38 ilev=1,7
      do 38 ilev2=1,7
        do j=1,npoints !
             if (sunlit(j).eq.1 .or. top_height .eq. 3) then
                fq_isccp(j,ilev,ilev2)= 0.
	     else
	        fq_isccp(j,ilev,ilev2)= output_missing_value
	     end if
        enddo
38    continue

      !reset variables need for averaging cloud properties
      do j=1,npoints
        if (sunlit(j).eq.1 .or. top_height .eq. 3) then
             totalcldarea(j) = 0.
             meanalbedocld(j) = 0.
             meanptop(j) = 0.
             meantaucld(j) = 0.
	else
             totalcldarea(j) = output_missing_value
             meanalbedocld(j) = output_missing_value
             meanptop(j) = output_missing_value
             meantaucld(j) = output_missing_value
	end if
      enddo ! j

      boxarea = 1./real(ncol)

      do 39 ibox=1,ncol
        do j=1,npoints

          if (tau(j,ibox) .gt. (tauchk            )
     &      .and. ptop(j,ibox) .gt. 0.) then
              box_cloudy(j,ibox)=.true.
          endif

          if (box_cloudy(j,ibox)) then

              if (sunlit(j).eq.1 .or. top_height .eq. 3) then

                boxtau(j,ibox) = tau(j,ibox)

		if (tau(j,ibox) .ge. isccp_taumin) then
		   totalcldarea(j) = totalcldarea(j) + boxarea

                   !convert optical thickness to albedo
                   albedocld(j,ibox)
     &		   = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82)

                   !contribute to averaging
                   meanalbedocld(j) = meanalbedocld(j)
     &                                +albedocld(j,ibox)*boxarea

                end if

            endif

          endif

          if (sunlit(j).eq.1 .or. top_height .eq. 3) then

           if (box_cloudy(j,ibox)) then

              !convert ptop to millibars
              ptop(j,ibox)=ptop(j,ibox) / 100.

              !save for output cloud top pressure and optical thickness
              boxptop(j,ibox) = ptop(j,ibox)

              if (tau(j,ibox) .ge. isccp_taumin) then
	      	meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
              end if

              !reset itau(j), ipres(j)
              itau(j) = 0
              ipres(j) = 0

              !determine optical depth category
              if (tau(j,ibox) .lt. isccp_taumin) then
                  itau(j)=1
              else if (tau(j,ibox) .ge. isccp_taumin
     &
     &          .and. tau(j,ibox) .lt. 1.3) then
                itau(j)=2
              else if (tau(j,ibox) .ge. 1.3
     &          .and. tau(j,ibox) .lt. 3.6) then
                itau(j)=3
              else if (tau(j,ibox) .ge. 3.6
     &          .and. tau(j,ibox) .lt. 9.4) then
                  itau(j)=4
              else if (tau(j,ibox) .ge. 9.4
     &          .and. tau(j,ibox) .lt. 23.) then
                  itau(j)=5
              else if (tau(j,ibox) .ge. 23.
     &          .and. tau(j,ibox) .lt. 60.) then
                  itau(j)=6
              else if (tau(j,ibox) .ge. 60.) then
                  itau(j)=7
              end if

              !determine cloud top pressure category
              if (    ptop(j,ibox) .gt. 0.
     &          .and.ptop(j,ibox) .lt. 180.) then
                  ipres(j)=1
              else if(ptop(j,ibox) .ge. 180.
     &          .and.ptop(j,ibox) .lt. 310.) then
                  ipres(j)=2
              else if(ptop(j,ibox) .ge. 310.
     &          .and.ptop(j,ibox) .lt. 440.) then
                  ipres(j)=3
              else if(ptop(j,ibox) .ge. 440.
     &          .and.ptop(j,ibox) .lt. 560.) then
                  ipres(j)=4
              else if(ptop(j,ibox) .ge. 560.
     &          .and.ptop(j,ibox) .lt. 680.) then
                  ipres(j)=5
              else if(ptop(j,ibox) .ge. 680.
     &          .and.ptop(j,ibox) .lt. 800.) then
                  ipres(j)=6
              else if(ptop(j,ibox) .ge. 800.) then
                  ipres(j)=7
              end if

              !update frequencies
              if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then
              fq_isccp(j,itau(j),ipres(j))=
     &          fq_isccp(j,itau(j),ipres(j))+ boxarea
              end if

            end if

          end if

        enddo ! j
39    continue

      !compute mean cloud properties
      do j=1,npoints
        if (totalcldarea(j) .gt. 0.) then
	  ! code above guarantees that totalcldarea > 0
	  ! only if sunlit .eq. 1 .or. top_height = 3
	  ! and applies only to clouds with tau > isccp_taumin
          meanptop(j) = meanptop(j) / totalcldarea(j)
          meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
          meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895)
	else
	  ! this code is necessary so that in the case that totalcldarea = 0.,
	  ! that these variables, which are in-cloud averages, are set to missing
	  ! note that totalcldarea will be 0. if all the clouds in the grid box have
	  ! tau < isccp_taumin
	  meanptop(j) = output_missing_value
          meanalbedocld(j) = output_missing_value
          meantaucld(j) = output_missing_value
        end if
      enddo ! j
!
!     ---------------------------------------------------!

!     ---------------------------------------------------!
!     OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
!
      if (debugcol.ne.0) then
!
         do j=1,npoints,debugcol

            !produce character output
            do ilev=1,nlev
              do ibox=1,ncol
                   acc(ilev,ibox)=0
              enddo
            enddo

            do ilev=1,nlev
              do ibox=1,ncol
                   acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
                   if (levmatch(j,ibox) .eq. ilev)
     &                 acc(ilev,ibox)=acc(ilev,ibox)+1
              enddo
            enddo

             !print test

          write(ftn09,11) j
11        format('ftn09.',i4.4)
          open(9, FILE=ftn09, FORM='FORMATTED')

             write(9,'(a1)') ' '
             write(9,'(10i5)')
     &                  (ilev,ilev=5,nlev,5)
             write(9,'(a1)') ' '

             do ibox=1,ncol
               write(9,'(40(a1),1x,40(a1))')
     &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev)
     &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev)
             end do
             close(9)

             if (ncolprint.ne.0) then
               write(6,'(a1)') ' '
                    write(6,'(a2,1X,5(a7,1X),a50)')
     &                  'ilev',
     &                  'pfull','at',
     &                  'cc*100','dem_s','dtau_s',
     &                  'cchar'

!               do 4012 ilev=1,nlev
!                    write(6,'(60i2)') (box(i,ilev),i=1,ncolprint)
!                   write(6,'(i2,1X,5(f7.2,1X),50(a1))')
!     &                  ilev,
!     &                  pfull(j,ilev)/100.,at(j,ilev),
!     &                  cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev)
!     &                  ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint)
!4012           continue
               write (6,'(a)') 'skt(j):'
               write (6,'(8f7.2)') skt(j)

               write (6,'(8I7)') (ibox,ibox=1,ncolprint)

               write (6,'(a)') 'tau:'
               write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)

               write (6,'(a)') 'tb:'
               write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)

               write (6,'(a)') 'ptop:'
               write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
             endif

        enddo

      end if

      return
      end


      SUBROUTINE JACCWF (TIME  ,TEMP ,MAG)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER*2        KP1
      DIMENSION        KP1(21,4)
      EQUIVALENCE     (KP1(1,1)   ,KP(1,1))
C
C.......................................................................
C
C     VERSION OF JUNE 16,1976
C
C     PURPOSE
C        SUBROUTINE JACCWF PROVIDES THE CALLING ROUTINE WITH MAGNETIC
C        ACTIVITY INDEX AND EXOSPHERIC TEMPERATURE AT TIME TMOD
C
C     INTERFACES
C
C        VARIABLE    COM/ARGLIST    I/O    DESCRIPTION
C        --------    -----------    ---    -----------------------------
C        IERR        ARG. LIST       O     ERROR FLAG
C                                          = 0, NO ERROR
C                                          =23, INPUT TIME OUT OF RANGE
C        IT          /ORJACC/       I/O    MODIFIED JULIAN DATE OF FIRST
C                                          TC CURRENTLY IN COMMON
C        KP(21,8)    /ORJACC/        O     MAGNETIC ACTIVITY 3-HOUR
C                                          INDICES
C        MAG         ARG. LIST       O     VALUE OF KP CORRESPONDING TO
C                                          TIME TMOD
C        TC(20)      /ORJACC/        O     EXOSPHERIC TEMPERATURES
C        TEMP        ARG. LIST       O     VALUE OF TC CORRESPONDING TO
C                                          TIME TMOD
C        TIME        ARG. LIST       I     FULL UTC JULIAN DATE OF
C                                          REQUESTED OUTPUT
C
C     COMMON BLOCKS NEEDED
C        ORJACC
C
C     SUBROUTINES AND FUNCTIONS REQUIRED
C        NONE
C
C     REQUIRED EXTERNAL DATA SETS
C        JACCHIA-ROBERTS DATA FILE
C
C      SUBROUTINE JACCWF IS CALLED FROM SUBROUTINE JACROB
C
C.......................................................................
C
      INTEGER*2 KP
      REAL*4 TC
C
      COMMON/ORJACC/ IT,KP(21,8),TC(20)
C
C
C
      TMOD = TIME - 2430000.5D0
C
      ITA  = TMOD
C
C
C              DETERMINE CURRENT VALUE OF TEMP AND MAG
C
      TEMP   = TC (ITA - IT + 1)
      DAY    = TMOD - .28D0
      IDAY   = DAY
      HOUR   = (DAY - IDAY) * 24.D0
      I3HOUR = 1.D0 + HOUR/3.D0
      MAG    = KP (IDAY-IT+2, I3HOUR)
C
      RETURN
      END