	PROGRAM ISO
C******************************************************************************
C This program runs a two-dimensional hydrostatic model containing
C parameterizations of convection and radiative transfer. The model
C may be oriented in the east-west direction with periodic boundaries,
C or in the north-south direction with rigid boundaries. Radiation and
C ocean mixed layer temperature may be calculated or specified in the input
C sounding file. The model is nonlinear, except that the advection of the
C overturning circulation by itself is neglected. Standard Laplacian forms
C diffusion modify the wind variables, but not temperature or specific
C humidity. The parameter NLO specifies the number of grid columns; it
C must be at least 4. The number of vertical levels is specified in the
C input sounding file. 
C
C There are two input files that must be supplied: sounding.in, which
C contains one vertical sounding of all the model variables for each
C grid column, and params.in, which contains most of the parameters
C used to control the model. There must be at least as many sounding
C columns in sounding.in as NLO-2. 
C
C Output consists of the file sounding,out, whose format is identical to
C that of sounding.in, and a series of matrix files containing time-
C distance series and distance-pressure cross-section averaged over
C the last n time steps of the integration, where n is specified in
C params.in. One may specify these files to be in matlab-readable ASCII
C format or comma-separated ASCII format. The matlab script files
C script.m, scriptr.m, stek.m, and stekr.m provide alternative ways
C of displaying the output. 
C
C The main program and subroutine CONVECT were created by Kerry Emanuel,
C while the radiation code was developed by Chou et al. (J. Climate, 4,
C 1991, p. 424) and modified by Ridgway and N. Renno. The radiation subroutine
C may be deleted if radiative cooling is specified; this will result in faster
C compilation and running. 
C
C*****************************************************************************
C
C Note: The parameter NA must be greater than or equal to the total number 
C       of model levels at which the state variables are defined.  This will
C       equal the number of tropospheric levels plus 9. NOTE THAT NA MUST BE
C       SET TO THE SAME VALUE IN SUBROUTINE CONVECT. NTIME is at least the
C       number of time steps that certain quanitities like precipitation are
C	output to the graphics arrays. NCL is the number of cloud types
C       used by the radiation code. 
C
	PARAMETER (NA=60, NAP=NA+1, NTIME=5000, NCL=1)
	PARAMETER (NLO=20)
C 
C  Dimension various arrays
C
C  Temperatures:
C
	REAL T1(NLO,NA), T2(NLO,NA), T3(NLO,NA), TTEMP(NA)
	REAL TCONV(NA),RCONV(NA), T0(NLO,NA)	
	REAL TRAD(NA), TVP(NA)
C
C  Sea surface temperatures:
C
	REAL TS1(NLO),TS2(NLO),TS3(NLO)
C
C  Specific humidities:
C
	REAL R1(NLO,NA), R2(NLO,NA), R3(NLO,NA), RS(NA), RRAD(NA)
	REAL RTEMP(NA), R0(NLO,NA)
C
C  Pressures:
C
	REAL P(NA), PH(NAP), PHRAD(NAP), PBLF(NA)
	REAL SPONGE(NA)
C
C  Latitudes:
C
	REAL RLAT(NLO), COSZA(NLO), COSLAT(NLO)
C
C  Trace gases used in radiative calculation:
C
	REAL O3(NA)
	REAL N2O
C
C  Streamfunction and zonal wind
C
	REAL PSI(NLO,NA), U(NA), FC(NLO)
	REAL ETA1(NLO,NA),ETA2(NLO,NA),ETA3(NLO,NA)
        REAL U1(NLO,NA), U2(NLO,NA), U3(NLO,NA)
C
C  ***   Applied Omega   ***
C
	REAL AOMEGA(NA)
C
C  Forcings:
C
	REAL FT(NA), FR(NA), FTNET(NLO,NA), FRNET(NLO,NA)
	REAL FTS(NLO),ETAF(NLO,NA),UF(NLO,NA),RADFLUX(NLO)
C
C  Radiative arrays:
C
	REAL RCOOL(NLO,NA), CS(NCL), PCTOP(NCL), PCBOT(NCL), TAUS(NCL)
	REAL FNETIR(NAP), FNETSO(NAP), COOLR(NA), HEATR(NA), HOUR
	REAL HOUR0
	CHARACTER*1 RADINT, TSINT, TDEP, DDEP, DARAD, ANRAD
C
C  Surface arrays
C
	REAL EFRAC(NLO), DEPTH(NLO)
C
C  Character constants
C
	CHARACTER*1 WDEP,BCS
	CHARACTER*3 FFMT
C
C  Convective quantities used for diagnostics:
C
	REAL MP(NA), RP(NA), SIJ(NA,NA), WATER(NA)
        REAL CBMFA(NLO),FRSUB(NA)
	REAL MUP(NA), MDOWN(NA), ENT(NA), DET(NA)
	REAL FRDET(NA)
C
C  Time-dependent quantities for graphics output:
C
	REAL QGRAPH(NLO,NTIME),OGRAPH(NLO,NTIME),PGRAPH(NLO,NTIME)
	REAL VGRAPH(NLO,NTIME),UTGRAPH(NLO,NTIME),GTIME(NTIME)
	REAL SSTGRAPH(NLO,NTIME), MPIGRAPH(NLO,NTIME)
	REAL T100GRAPH(NLO,NTIME), T100BAR(NLO)
C
C  Space-dependent quantities for output:
C
	REAL OLGRAPH(NLO,NA),MUPGRAPH(NLO,NA),MDGRAPH(NLO,NA)
	REAL PREBAR(NLO),RHGRAPH(NLO,NA),ULGRAPH(NLO,NA)
	REAL OBAR(NLO),VBAR(NLO),UBAR(NLO),SSTBAR(NLO)
	REAL PSIGRAPH(NLO,NA),MUPG(NLO,NA),MDG(NLO,NA),RHG(NLO,NA)
	REAL OLG(NLO,NA),TEMPGRAPH(NLO,NA), AMGRAPH(NLO,NA)
C
C  Special graphics arrays:
C
	REAL DISX(NLO)
C
C  Latent heat at T=0 C
C
	REAL LV0
C
C  Common block with subroutine CONVECT:
C
	COMMON / CVT / TVP,MP,RP,SIJ,MUP,MDOWN,ENT,DET,FRDET,FRSUB,
     1     WATER,INB 
C
C  Open input and output files:
C
	OPEN(UNIT=8, FILE='params.in', STATUS='OLD')
	OPEN(UNIT=9, FILE='sounding.in', STATUS='OLD')
	OPEN(UNIT=10, FILE='sounding.out', STATUS='unknown')
	OPEN(UNIT=11, FILE='error.out', STATUS='unknown')
C
C
C  Read in the parameters of the model from the file params.in
C
	  READ(8,10)RADINT,TSINT,SCON,AWN,MONTH,IDAY,
     1    HOUR,TDEP,DDEP,DARAD,ANRAD,WDEP,BCS,COSZ,
     2    ALB,CO2,RLATB,RLATE,DEPTHR,
     *    EFRACR,DPBL,TDEEP,CCOUP,AOMEGMAX,
     3    VS0,US0,WS0,DAMP,SCOEF,PFIX,DT,ENDTIME,RADFREQ,
     4    PRINFREQ,VTRANS,PAVE,FFMT
C
   10	FORMAT(//,2(T37,A1,/),(T32,F12.6,/),
     1    T32,F12.6,/,2(T32,I6,/),T32,F12.6,
     2    /,6(T37,A1,/),23(T32,F12.6,/),T37,A3)
C
C  Renormalize certain parameters
C
	DT=DT*60.0
	DAMP=1.0/(24.*3600.*DAMP)
	SCOEF=1.0/(60.*SCOEF)
        TDEEP=TDEEP+273.15
	AOMEGMAX=AOMEGMAX/36.0
	ALENGTH=2.*3.14159*6.38E6/AWN
	DX=ALENGTH/FLOAT(NLO-2)
	DXI=1.0/DX
	DTI=1.0/DT
	DPBLI=1.0/DPBL
	ENDTIME=ENDTIME*3600.0*24.0
	RADFREQ=RADFREQ*3600.0
	PRINFREQ=PRINFREQ*3600.0
	PAVE=PAVE*24.*3600.
	PAFRAC=DT/(PAVE+1.0)
	WS0=WS0*WS0
	CO2=1.0E-6*CO2
	ICOSZ=1
        IF(ANRAD.EQ.'y'.OR.ANRAD.EQ.'Y')THEN
         TDEP='n'
         DDEP='n'
        END IF
        IF(DARAD.EQ.'y'.OR.DARAD.EQ.'Y')THEN
         TDEP='n'
        END IF
	IF(TDEP.EQ.'y'.OR.TDEP.EQ.'Y')ICOSZ=2
	MONTH0=MONTH
	IDAY0=IDAY
	HOUR0=HOUR
	WFAC=0.0
C
C  Latitude and Corilois parameter
C
        DO K=1,NLO
         RLAT(K)=RLATB+(RLATE-RLATB)*FLOAT(K-2)/FLOAT(NLO-3)
         FC(K)=1.454E-4*SIN(3.14159*RLAT(K)/180.)
        END DO
        RLATTEMP=RLATB-2.*(RLATE-RLATB)/FLOAT(NLO-3)
        COSLAT(1)=COS(3.14159*RLAT(1)/180.)/
     1    (COS(3.14159*RLATTEMP/180.)+0.01)
        DO K=2,NLO
         COSLAT(K)=COS(3.14159*RLAT(K)/180.)/
     1    (COS(3.14159*RLAT(K-1)/180.)+0.01)
        END DO
C
C  Ocean mixed layer depth and surface moisture availability
C
        DO K=1,NLO
         DEPTH(K)=DEPTHR
         EFRAC(K)=EFRACR
c        IF(K.GT.14)THEN
c          EFRAC(K)=0.5
c         DEPTH(K)=5.0
c        END IF
        END DO
C
C  ***  If desired, calculate annual average solar zenith angle  ***
C
        IF(ANRAD.EQ.'y'.OR.ANRAD.EQ.'Y')THEN
           DARAD='n'
	 DO 12 K=2,NLO-1
           fac=.01745
           BCOSZ=0.0
         DO 18 IDD=1,365
           x=float((MONTH-1)*30+IDD+MONTH/2)
           xlat=RLAT(K)*fac
           phi=2.*3.14159*x/365.
           tphi=phi*2.
           ttphi=phi*3.
           cosphi=cos(phi)
           sinphi=sin(phi)
           costph=cos(tphi)
           sintph=sin(tphi)
           costtp=cos(ttphi)
           sinttp=sin(ttphi)
           delta=.006918-0.399912*cosphi+0.070257*sinphi-0.006758*
     *          costph+0.000907*sintph-0.002697*costtp+.00148*sinttp
         COSZ=0.0
          DO 17 JT=1,101
         hrl=0.24*FLOAT(JT-1)
           anx=(hrl-12.)*15.*fac
           eq=.000075+.001868*cosphi-.032077*sinphi-.014615*costph
     *       -.040849*sintph
           ang=anx+eq
           AC=sin(xlat)*sin(delta)+cos(xlat)*cos(delta)*cos(ang)
         AC=MAX(AC,0.0)
           COSZ=COSZ+AC
   17   CONTINUE
          COSZ=0.01*COSZ
          BCOSZ=BCOSZ+COSZ
   18   CONTINUE
          COSZ=BCOSZ/365.
	  COSZA(K)=COSZ
   12	CONTINUE
        END IF
C
C  Read in the initial soundings from the file sounding.in
C
	DO 42 J=2,NLO-1
	READ(9,20)NP,TS1(J)
   20 	FORMAT(T15,I3,T55,F5.2,////)
	TS1(J)=TS1(J)+273.15
	TS2(J)=TS1(J)
	DO 40 I=1,NP
	 READ(9,30)P(I),T1(J,I),R1(J,I),O3(NP+1-I),PSI(J,I),RCOOL(J,I),
     1    U1(J,I)
   30 	 FORMAT(3X,F6.1,T12,F8.3,T25,F10.6,T39,F6.3,T47,F6.2,
     1    T58,F7.3,T64,F5.1)
C
C  Renormalize certain quantities and produce reverse order arrays for
C       radiative subroutine
C
	 T1(J,I)=T1(J,I)+273.15
	 R1(J,I)=0.001*R1(J,I)
	 T2(J,I)=T1(J,I)
	 T0(J,I)=T1(J,I)
	 R2(J,I)=R1(J,I)
	 R0(J,I)=R1(J,I)
	 RCOOL(J,I)=RCOOL(J,I)/(24.*3600.)
	 PSI(J,I)=1.0E4*PSI(J,I)
	 IF(P(I).LE.(PFIX+5.0))THEN
	  PSI(J,I+1)=0.0
	  U1(J,I)=0.0
	 END IF
	 U2(J,I)=U1(J,I)
C
	 IF(J.EQ.(NLO-1))THEN
	  T1(J,I)=T1(J,I)+1.0
	  T2(J,I)=T1(J,I)
	 END IF
C
   40	CONTINUE 
   42	CONTINUE
C
	CLOSE(UNIT=8,DISPOSE='SAVE')
	CLOSE(UNIT=9,DISPOSE='SAVE')
C
c	TS1(2)=TS1(2)+0./(1.+0.15*9.0)
c	TS2(2)=TS1(2)
C
C  Surface pressure and surface exchange coefficient
C
	PG=1012.0
	CD=0.5E-3
C
C  Trace gas concentrations   
C
	CH4=1.75E-6
	N2O=0.28E-6
C
C  Asselin Filter Value
C
	AFILT=0.2
C
C  Renormalize ozone, define levels
C
	PT=200.0
	NPTOP=1
	N=1
	DO 43 I=1,NP
	 O3(NP+1-I)=1.0E-6*O3(NP+1-I)
	 IF(P(I).GE.(PFIX-1.0))NPTOP=MAX(NPTOP,I)
	 IF(P(I).GE.78.0)N=MAX(N,I)
	 IF(I.GT.1)THEN
	  PH(I)=0.5*(P(I)+P(I-1))  
	  PHRAD(NP+2-I)=PH(I)
	 END IF
C
C    Applied Omega
C
	 AOMEGA(I)=4.*AOMEGMAX*(P(1)-P(I))*(P(I)-PT)/
     1    ((P(1)-PT)**2)
	 IF(P(I).LT.PT)AOMEGA(I)=0.0
C
C    Boundary layer stress decay function
C
	PBLF(I)=EXP((P(I)-P(1))*DPBLI)
c	PBLF(I)=(DPBL-P(1)+P(I))*DPBLI
c	PBLF(I)=MAX(PBLF(I),0.0)
C
C    Sponge layer coefficients
C
	SPONGE(I)=SCOEF*(1.-P(I)/95.0)
	SPONGE(I)=MAX(SPONGE(I),0.0)
C
   43	CONTINUE
C
	NPTOP=MIN(NPTOP,NP-1)
	N=MIN(N,(NP-1))
C
	PH(1)=2.*P(1)-PH(2)
	PHRAD(NP+1)=PH(1)
	PH(NP+1)=2.*PH(NP)-PH(NP-1)
	PH(NP+1)=MAX(0.1,PH(NP+1))
	PHRAD(1)=PH(NP+1)
C
	DPH1I=1.0/(PH(1)-PH(2))
	DPHNPI=1.0/(PH(NP)-PH(NP+1))
	DP1I=1.0/(P(1)-P(2))
	DPNPI=1.0/(P(NP-1)-P(NP))
C
C  Set cloud fractions in radiative scheme
C
	DO 50 I=1,NCL
	 CS(I)=0.0
	 PCTOP(I)=200.0
	 PCBOT(I)=900.0
	 TAUS(I)=1.0
   50	CONTINUE
         NCL0=1
c
c        CS(1)=0.14
c	CS(1)=0.03
c        PCTOP(1)=220.
c        PCBOT(1)=280.
c        TAUS(1)=2.0
c
c        CS(2)=0.09
c        PCTOP(2)=460.0
c        PCBOT(2)=640.0
c        TAUS(2)=6.0
c
c        CS(3)=0.3
c	CS(3)=0.0
c        PCTOP(3)=640.0
c        PCBOT(3)=940.0
c        TAUS(3)=12.0
C
C  Assign thermodynamic constants
C
	CPD=1005.7
	CPV=1870.0
	CL=4190.0
	RD=287.04
	RV=461.5
	LV0=2.501E6
	G=9.8
	ROWL=1000.0
	EXPAN=3.2E-4
	EPS=RD/RV
	EPSI=1./EPS
	CPVMCL=CL-CPV
C
C  Initialize certain quantities and arrays
C
	QSPEED=0.0
	DO 45 J=2,NLO-1
	FTS(J)=0.0
	PSI(J,1)=0.0
	ETA1(J,1)=0.0
	ETA2(J,1)=0.0
	PSI(J,NP)=0.0
	ETA1(J,NP)=0.0
	ETA2(J,NP)=0.0
	RADFLUX(J)=0.0
	CBMFA(J)=0.0
   45	CONTINUE
C
	DO 60 I=1,NP
	 COOLR(I)=0.0
	 HEATR(I)=0.0
	 DO 51 K=2,NLO-1
	  UF(K,I)=0.0
	 IF(I.NE.1.AND.I.NE.NP)THEN
	  ETA1(K,I)=-1.0E-4*((PSI(K,I+1)-PSI(K,I))/(PH(I+1)-PH(I))-
     1     (PSI(K,I)-PSI(K,I-1))/(PH(I)-PH(I-1)))/(P(I)-P(I-1))
	  ETA2(K,I)=ETA1(K,I)
	 END IF
	 ETAF(K,I)=0.0
	 FTNET(K,I)=0.0
	 FRNET(K,I)=0.0
	 MUPGRAPH(K,I)=0.0
	 MDGRAPH(K,I)=0.0
	 OLGRAPH(K,I)=0.0
	 RHGRAPH(K,I)=0.0
	 ULGRAPH(K,I)=0.0
	 PSIGRAPH(K,I)=0.0
	 TEMPGRAPH(K,I)=0.0
	 AMGRAPH(K,I)=0.0
   51	 CONTINUE	
   60	CONTINUE
	DO 65 K=2,NLO-1
	 PREBAR(K)=0.0
	 VBAR(K)=0.0
	 UBAR(K)=0.0
	 SSTBAR(K)=0.0
	 T100BAR(K)=0.0
   65	CONTINUE
C
C  Initialize counters
C
	TIME=0.0
	RADTIME=0.0
	PRINTIME=0.0
	NT=0
	NPR=1
	NPRINT=0
C
C  Begin time loop at next statement
C
  100	CONTINUE
C
	TIME=TIME+DT
	RADTIME=RADTIME+DT
	PRINTIME=PRINTIME+DT
	NT=NT+1
	IF(TIME.GT.ENDTIME)GOTO 200
	NPRINT=NPRINT+1
c	IF(TIME.GT.(50.*24.*3600.))CD=0.0
C
C  ***   Boundary values   ***
C
	IF(BCS.EQ.'p')THEN
c
	TS1(1)=TS1(NLO-1)
	TS2(1)=TS2(NLO-1)
	TS1(NLO)=TS1(2)
	TS2(NLO)=TS2(2)
	DO 105 I=1,NP
	 U1(1,I)=U1(NLO-1,I)
	 U2(1,I)=U2(NLO-1,I)
	 U1(NLO,I)=U1(2,I)
	 U2(NLO,I)=U2(2,I)
	 T1(1,I)=T1(NLO-1,I)
	 T2(1,I)=T2(NLO-1,I)
	 T1(NLO,I)=T1(2,I)
	 T2(NLO,I)=T2(2,I)
	 R1(1,I)=R1(NLO-1,I)
	 R2(1,I)=R2(NLO-1,I)
	 R1(NLO,I)=R1(2,I)
	 R2(NLO,I)=R2(2,I)
	 PSI(1,I)=PSI(NLO-1,I)
	 PSI(NLO,I)=PSI(2,I)
	 ETA1(1,I)=ETA1(NLO-1,I)
	 ETA1(NLO,I)=ETA1(2,I)
  105	CONTINUE
C
	ELSE
C
	TS1(1)=TS1(2)
	TS2(1)=TS2(2)
	TS1(NLO)=TS1(NLO-1)
	TS2(NLO)=TS2(NLO-1)
	DO 106 I=1,NP
	 U1(1,I)=0.0
	 U2(1,I)=0.0
	 U1(NLO,I)=0.0
	 U2(NLO,I)=0.0
	 T1(1,I)=T1(2,I)
	 T2(1,I)=T2(2,I)
	 T1(NLO,I)=T1(NLO-1,I)
	 T2(NLO,I)=T2(NLO-1,I)
	 R1(1,I)=R1(2,I)
	 R2(1,I)=R2(2,I)
	 R1(NLO,I)=R1(NLO-1,I)
	 R2(NLO,I)=R2(NLO-1,I)
	 PSI(1,I)=0.0
	 PSI(NLO,I)=0.0
	 ETA1(1,I)=0.0
	 ETA1(NLO,I)=0.0
	 PSI(NLO-1,I)=0.0
	 ETA1(NLO-1,I)=0.0
  106	CONTINUE
C
	END IF
C
	DO 155 K=2,NLO-1
C
	IF(TDEP.EQ.'y'.OR.TDEP.EQ.'Y')THEN
	 XT=TIME/(3600.*24.)+HOUR0/24.
	 HOUR=24.*(XT-AINT(XT))
	END IF
	IF(DDEP.EQ.'y'.OR.DDEP.EQ.'Y')THEN
         XT=TIME/(3600.*24.)+FLOAT(IDAY0)+30.*FLOAT(MONTH0-1)+
     1    HOUR0/24.
         DAY=XT-365.*AINT(XT/365.)
         AMON=1.1+AINT((DAY-1.)/30.)
         AMON=MIN(12.1,AMON)
         MONTH=AMON
         MONTH=MAX(MONTH,1)
         IDAY=DAY-30.*FLOAT(MONTH-1)
        END IF
C
C  Calculate saturation specific humidity and some temporary arrays
C   Do crude adjustment for supersaturation
C
	TC=TS1(K)-273.15
	ES=6.112*EXP(17.67*TC/(243.5+TC))
	RSS=0.98*EPS*ES/(PG-(1.-EPS)*ES)
	PRADJ=0.0
	TG=TS1(K)
	RG=RSS
C
	DO 110 I=1,NP
	 FTNET(K,I)=0.0
	 FRNET(K,I)=0.0
	 TC=T2(K,I)-273.15
         IF(TC.GE.0.0)THEN
          ES=6.112*EXP(17.67*TC/(243.5+TC))
         ELSE
          ES=EXP(23.33086-6111.72784/T2(K,I)+0.15215*LOG(T2(K,I)))
         END IF
         ES=MIN(ES,P(I))
	 RS(I)=EPS*ES/(P(I)-(1.-EPS)*ES)
	 TRAD(NP+1-I)=T2(K,I)
	 RRAD(NP+1-I)=R2(K,I)
	 RRAD(NP+1-I)=MAX(RRAD(NP+1-I),0.0)
c	 IF(P(I).GT.90.0)THEN
c   	  RRAD(NP+1-I)=MAX(RRAD(NP+1-I),(0.1*RS(I)))
c  	 ELSE
c 	  RRAD(NP+1-I)=MAX(RRAD(NP+1-I),2.0E-6)
c  	 END IF
	 TTEMP(I)=T2(K,I)
	 RTEMP(I)=R2(K,I)
	 TCONV(I)=T2(K,I)
	 RCONV(I)=R2(K,I)
C
	 IF(R2(K,I).GT.RS(I))THEN
          ALV=LV0-CPVMCL*TC
          CPN=CPD*(1.-R2(K,I))+CPV*R2(K,I)
          TNEW=(ALV*(R2(K,I)+RS(I)*(ALV/(RV*T2(K,I))-1.))+
     1     CPN*T2(K,I))/
     2     (CPN+ALV*ALV*RS(I)/(RV*T2(K,I)*T2(K,I)))
          RNEW=RS(I)*(1.+(TNEW-T2(K,I))*ALV/(RV*T2(K,I)*T2(K,I)))
          FRADJ=0.5*(RNEW-R2(K,I))/DT
	  FRNET(K,I)=FRNET(K,I)+FRADJ
	  FTADJ=-ALV*FRADJ/CPN
	  FTNET(K,I)=FTNET(K,I)+FTADJ
	  PRADJ=PRADJ-100.0*(PH(I)-PH(I+1))*FRADJ*1000.0*
     1     3600.0*24.0/(ROWL*G)
	 END IF	
  110	CONTINUE
	CBMF=CBMFA(K)
C
C  Call convection subroutine
C
	CALL CONVECT(TCONV,RCONV,RS,P,PH,TG,RG,PG,NA,N,DT,IFLAG,FT,FR,PRECIP,
     1    WD,TPRIME,QPRIME,CBMF)

C
C  If necessary, write to error file
C
	IF(IFLAG.EQ.4)THEN
	 WRITE(11,120)NT
  120	 FORMAT(5X,'CFL condition violated at time step ',I8)
	END IF
C
C  Add convective precip to precip from supersaturation adjustment
C
	PRECIP=PRECIP+PRADJ
C
	PREBAR(K)=PREBAR(K)+PRECIP
        OBAR(K)=OBAR(K)+36.*(COSLAT(K)*PSI(K,9)-
     1    PSI(K-1,9))*DXI
        VBAR(K)=VBAR(K)+0.01*PSI(K,2)*DPH1I
        UBAR(K)=UBAR(K)+U2(K,1)
        SSTBAR(K)=SSTBAR(K)+TS2(K)-273.15
	T100BAR(K)=T100BAR(K)+T2(K,37)-273.15
C
C  Add convective tendencies to net tendencies
C
	IF(K.EQ.2)INBA=INB
	RINB=MIN(R1(1,INBA),8.0E-5)
	TSRAD=TS2(K)
	RLATA=RLAT(K)
	ALR=ALB
c	IF(K.GT.14)ALR=0.0
	DO 125 I=1,N
	 FTNET(K,I)=FTNET(K,I)+FT(I)
	 FRNET(K,I)=FRNET(K,I)+FR(I)
C	 IF(I.GT.INBA)THEN
C	  FRNET(K,I)=FRNET(K,I)+1.0E-6*(RINB-R1(K,I))
C	 END IF
	 R2(K,I)=RCONV(I)
	 T2(K,I)=TCONV(I)
  125	CONTINUE
	CBMFA(K)=CBMF
C
C  *** Relax water vapor above tropopause to tropopause value  ***
C
C        DO 126 I=INB+1,NP
C         FRNET(K,I)=FRNET(K,I)+2.0E-6*(2.0E-6*P(I)/P(INB+1)-R1(K,I))
C  126   CONTINUE
C
C  If desired, call radiation scheme
C
	IF(RADINT.EQ.'y'.OR.RADINT.EQ.'Y')THEN
	 IF(TIME.LT.(1.5*DT).OR.RADTIME.GT.(RADFREQ-10.0))THEN
	  IF(K.EQ.(NLO-1))RADTIME=0.0
	  COSZ=COSZA(K)
C
	  HRL=HOUR
C
C  If diurnal average radiation used, average cosine of zenith angle
C    over 1 day
C
          IF(DARAD.EQ.'y'.OR.DARAD.EQ.'Y')THEN
           fac=.01745
           x=float((MONTH-1)*30+IDAY+MONTH/2)
           xlat=RLAT(K)*fac
           phi=2.*3.14159*x/365.
           tphi=phi*2.
           ttphi=phi*3.
           cosphi=cos(phi)
           sinphi=sin(phi)
           costph=cos(tphi)
           sintph=sin(tphi)
           costtp=cos(ttphi)
           sinttp=sin(ttphi)
           delta=.006918-0.399912*cosphi+0.070257*sinphi-0.006758*
     *          costph+0.000907*sintph-0.002697*costtp+.00148*sinttp
           COSZ=0.0
           DO 127 JT=1,101
            hrl=0.24*FLOAT(JT-1)
            anx=(hrl-12.)*15.*fac
            eq=.000075+.001868*cosphi-.032077*sinphi-.014615*costph
     *        -.040849*sintph
            ang=anx+eq
            AC=sin(xlat)*sin(delta)+cos(xlat)*cos(delta)*cos(ang)
            AC=MAX(AC,0.0)
            COSZ=COSZ+AC
  127      CONTINUE
           COSZ=0.01*COSZ
          END IF
C
	  CALL radia(NP,1,PHRAD,TRAD,RRAD,O3,CO2,CH4,N2O,TSRAD,ALR,
     1     NCL0,CS,PCTOP,PCBOT,TAUS,
     2     SCON,RLATA,MONTH,IDAY,HRL,COSZ,ICOSZ,
     3     FNETIR,FNETSO,COOLR,HEATR,FDWNIRS,FLUPIRS)
C
C  Calculate net radiative cooling rate
C
	  RADFLUX(K)=FNETIR(NP+1)+FNETSO(NP+1)
	  DO 130 I=1,NP
	   RCOOL(K,I)=(COOLR(NP-I+1)-HEATR(NP-I+1))/(24.*3600.)
           RCOOL(K,I)=RCOOL(K,I)*1003./(CPD*(1.-R2(K,I))+CPV*R2(K,I))
           RCOOL(K,I)=RCOOL(K,I)*G/9.8
  130	  CONTINUE
	 END IF
	ELSE
	 RADFLUX(K)=0.0
	 DO 131 I=1,NP
         RADFLUX(K)=RADFLUX(K)+(CPD*(1.-R2(K,I))+CPV*R2(K,I))*
     1    RCOOL(K,I)*100.*(PH(I)-PH(I+1))/G
  131	 CONTINUE
	END IF
C
C  Add radiative cooling to net heating rate
C
	DO 135 I=1,NP
	 FTNET(K,I)=FTNET(K,I)-RCOOL(K,I)
  135	CONTINUE
C
C  Calculate surface flux forcing
C
	TSA=T1(K,1)*(PG/P(1))**(RD/CPD)
	ROWS=PG/(RD*TSA*(1.+R2(K,1)*(EPSI-1.)))
	IF(WDEP.EQ.'y'.OR.WDEP.EQ.'Y')THEN
	 VS=VS0+0.005*(PSI(K,2)+PSI(K-1,2))*DPH1I
	 VSB=VS0+0.01*PSI(K,2)*DPH1I
	 US=US0+U1(K,1)
	 USB=0.5*(U1(K,1)+U1(K+1,1))
	 VSURF=SQRT(WS0+WD*WD+VS*VS+US*US)
	 VSURFB=SQRT(WS0+WD*WD+VSB*VSB+USB*USB)
	 VSPRIME=VSURF-SQRT(WS0+VS*VS+US*US)
	ELSE
	 VSURF=SQRT(WS0+WD*WD+VS0*VS0+US0*US0)
	 VSPRIME=VSURF-SQRT(WS0+VS0*VS0+US0*US0)
	END IF
C
	FTSURF=G*ROWS*CD*(VSURF*(TS1(K)-TSA)-VSPRIME*TPRIME)
     1    *DPH1I
	FTNET(K,1)=FTNET(K,1)+FTSURF
	FRSURF=G*ROWS*CD*(VSURF*(RSS-R1(K,1))-VSPRIME*QPRIME)
     1    *EFRAC(K)*DPH1I
	FRNET(K,1)=FRNET(K,1)+FRSURF
C
C  Put values into time arrays
C
	IF(PRINTIME.GT.(PRINFREQ-10.0))THEN
	 ANPRI=1./FLOAT(NPRINT)
	 PGRAPH(K,NPR)=PREBAR(K)*ANPRI
	 OGRAPH(K,NPR)=OBAR(K)*ANPRI
	 VGRAPH(K,NPR)=VBAR(K)*ANPRI
	 UTGRAPH(K,NPR)=UBAR(K)*ANPRI
	 SSTGRAPH(K,NPR)=SSTBAR(K)*ANPRI
	 T100GRAPH(K,NPR)=T100BAR(K)*ANPRI
C
	 PREBAR(K)=0.0
	 OBAR(K)=0.0
	 VBAR(K)=0.0
	 UBAR(K)=0.0
	 SSTBAR(K)=0.0
	 T100BAR(K)=0.0
C
	 SST=TS2(K)-273.15
         CALL PCMIN(SST,PG,P,TCONV,RCONV,NA,N,PMIN,VMAX,IFL)
	 MPIGRAPH(K,NPR)=VMAX
C
	 IF(K.EQ.(NLO-1))THEN
	  GTIME(NPR)=TIME/(3600.*24.)
	  NPR=NPR+1
	  PRINTIME=0.0
	  NPRINT=0
	 END IF
	END IF
C
C  Calculate forcing of ocean temperature
C
        IF(TSINT.EQ.'y'.OR.TSINT.EQ.'Y')THEN
	 TC=TS1(K)-273.15
	 ALV=(LV0-CPVMCL*TC)*EFRAC(K)
	 SFLUX=(CPD*(1.-R1(K,1))+CPV*R1(K,1))*100.0*ROWS*CD*(VSURF*
     1      (TS1(K)-TSA)-VSPRIME*TPRIME)+
     2      ALV*100.0*ROWS*CD*(VSURF*(RSS-R1(K,1))-VSPRIME*QPRIME)
	 FTS(K)=(RADFLUX(K)-SFLUX)/(DEPTH(K)*ROWL*CL)
C
C  Calculate ocean current speed and add in ocean temperature advection
C	
	 VA=0.01*PSI(K,2)*DPH1I
	 QSQ=1.0E-6*DX*VSURF*(-VA)/DEPTH(K)-2.0*G*
     1    EXPAN*DEPTH(K)*(TS2(1)- TS2(2))
	 QSPEED=CCOUP*SQRT(MAX(0.0,QSQ))
         IF(PRINTIME.GT.(PRINFREQ-10.0))THEN
	  QGRAPH(K,NPR)=QSPEED
	 END IF
	 IF(QSPEED.GT.0.0)THEN
          FTS(K)=FTS(K)+2.*QSPEED*(TS2(K-1)-TS2(K))*DXI
         ELSE
	  FTS(K)=FTS(K)-2.*QSPEED*(TS2(K+1)-TS2(K))*DXI
	 END IF
	END IF
C
C         FTS(2)=0.
C         IF(TIME.GT.(120.*3600.*24.).AND.TIME.LT.(180.*3600.*24.))THEN
C          TS3(2)=TSORIG+2.0
C         ELSE
C          TS3(2)=TSORIG
C         END IF
C         TS2(2)=TS3(2)
C         TS1(2)=TS2(2)
C
C  Calculate atmospheric forcings and add to net tendencies
C
C  Level 1 forcings
C
C  Advections:
C
	VOMEG=(COSLAT(K)*PSI(K,2)-PSI(K-1,2))*DXI+AOMEGA(2)
	VVP=0.01*MAX(VOMEG,0.0)
	VAM=0.01*PSI(K-1,2)*DPH1I         
	VAP=0.01*PSI(K,2)*DPH1I
	VAM=MAX(VAM,0.0)
	VAP=MIN(VAP,0.0)
	VA=VAP+VAM
	ALPHA=RD*T2(K,1)*(1.+R2(K,1)*(EPSI-1.))/P(1)
C
	FTADV=VVP*ALPHA/CPD-VVP*(T2(K,1)-T2(K,2))*DP1I
	FRADV=-VVP*(R2(K,1)-R2(K,2))*DP1I
	FUADV=-VVP*(U2(K,1)-U2(K,2))*DP1I
	FTHADV=-(VAM*(T2(K,1)-T2(K-1,1))+VAP*(T2(K+1,1)-T2(K,1)))*DXI
        FRHADV=-(VAM*(R2(K,1)-R2(K-1,1))+VAP*(R2(K+1,1)-R2(K,1)))*DXI
        FUHADV=-(VAM*(U2(K,1)-U2(K-1,1))+VAP*(U2(K+1,1)-U2(K,1)))*DXI
C
        UF(K,1)=VA*FC(K)-ROWS*G*CD*VSURF*U1(K,1)*DPBLI+
     1   FUADV+FUHADV
	ETAF(K,1)=0.0
	FTNET(K,1)=FTNET(K,1)+FTADV+FTHADV
	FRNET(K,1)=FRNET(K,1)+FRADV+FRHADV
C
C  Level 1 Horizontal diffusion terms
C
C	DIFHU=2.*DAMP*(U1(K+1,1)+U1(K-1,1)-2.*U1(K,1))
	DIFHU=2.*DAMP*(U1(K+1,1)*COSLAT(K+1)+U1(K-1,1)*COSLAT(K-1)-
     1   2.*U1(K,1)*COSLAT(K))/COSLAT(K)
	DIFHT=2.*DAMP*(T1(K+1,1)+T1(K-1,1)-2.*T1(K,1))
	DIFHR=2.*DAMP*(R1(K+1,1)+R1(K-1,1)-2.*R1(K,1))
C
	UF(K,1)=UF(K,1)+DIFHU
	FTNET(K,1)=FTNET(K,1)+DIFHT
	FRNET(K,1)=FRNET(K,1)+DIFHR
C
C  Interior forcings
C
	DO 140 I=2, NP-1
C
C  Advections:
C
        VOMEG1=(COSLAT(K)*PSI(K,I+1)-PSI(K-1,I+1))*DXI+AOMEGA(I+1)
        VOMEG=(COSLAT(K)*PSI(K,I)-PSI(K-1,I))*DXI+AOMEGA(I)
	VVP=0.01*MAX(VOMEG1,0.0)
	VVM=0.01*MIN(VOMEG,0.0)
	ALPHA=RD*T2(K,I)*(1.+R2(K,I)*(EPSI-1.))/P(I)
        VAM=0.01*(PSI(K-1,I+1)-PSI(K-1,I))/(PH(I)-PH(I+1))
        VAP=0.01*(PSI(K,I+1)-PSI(K,I))/(PH(I)-PH(I+1))
        VAM=MAX(VAM,0.0)
        VAP=MIN(VAP,0.0)
	VA=VAP+VAM
	FTADV=(VVP+VVM)*ALPHA/CPD-
     1   VVP*(T2(K,I)-T2(K,I+1))/(P(I)-P(I+1))-
     2	 VVM*(T2(K,I-1)-T2(K,I))/(P(I-1)-P(I))
        FRADV=-VVP*(R2(K,I)-R2(K,I+1))/(P(I)-P(I+1))-    
     1	 VVM*(R2(K,I-1)-R2(K,I))/(P(I-1)-P(I))
	FUADV=-VVP*(U2(K,I)-U2(K,I+1))/(P(I)-P(I+1))-    
     1	 VVM*(U2(K,I-1)-U2(K,I))/(P(I-1)-P(I))
        FTHADV=-(VAM*(T2(K,I)-T2(K-1,I))+VAP*(T2(K+1,I)-T2(K,I)))*DXI
        FRHADV=-(VAM*(R2(K,I)-R2(K-1,I))+VAP*(R2(K+1,I)-R2(K,I)))*DXI
        FUHADV=-(VAM*(U2(K,I)-U2(K-1,I))+VAP*(U2(K+1,I)-U2(K,I)))*DXI
C
        UF(K,I)=VA*FC(K)-ROWS*G*CD*VSURF*U1(K,1)*PBLF(I)*DPBLI+
     1   FUADV+FUHADV
	FTNET(K,I)=FTNET(K,I)+FTADV+FTHADV
	FRNET(K,I)=FRNET(K,I)+FRADV+FRHADV
C
C  Calculate forcing of horizontal vorticity
C
	  TVDIF1=T2(K+1,I)*(1.+R2(K+1,I)*(EPSI-1.))-
     1     T2(K,I)*(1.+R2(K,I)*(EPSI-1.))
	  TVDIF2=T2(K+1,I-1)*(1.+R2(K+1,I-1)*(EPSI-1.))-
     1     T2(K,I-1)*(1.+R2(K,I-1)*(EPSI-1.))
	  ETAF(K,I)=0.005*RD*DXI*(TVDIF1/PH(I)+TVDIF2/PH(I-1))
	  FCBAR=0.5*(FC(K)+FC(K+1))
          ETAF(K,I)=ETAF(K,I)-FCBAR*0.005*(U2(K,I-1)+U2(K+1,I-1)-
     1     U2(K,I)-U2(K+1,I))/(P(I-1)-P(I))
c	  ETAF(K,I)=ETAF(K,I)-0.005*(FC(K)*(U2(K,I-1)-U2(K,I))+
c     1     FC(K+1)*(U2(K+1,I-1)-U2(K+1,I)))/(P(I-1)-P(I))
	  ETAF(K,I)=ETAF(K,I)-ROWS*1.0E-4*G*CD*VSURFB*PSI(K,2)*
     1     PBLF(I-1)*DPBLI*DPBLI*DPH1I         
C
C  Vertical diffusion terms
C
c	  DIFETA=DAMP*(PH(I-1)-PH(I+1))*0.5*((ETA1(K,I+1)-ETA1(K,I))/
c     1     (PH(I)-PH(I+1))-(ETA1(K,I)-ETA1(K,I-1))/(PH(I-1)-PH(I)))
c	  DIFU=DAMP*(P(I-1)-P(I+1))*0.5*((U1(K,I+1)-U1(K,I))/
c     1     (P(I)-P(I+1))-(U1(K,I)-U1(K,I-1))/(P(I-1)-P(I)))
C
c	  ETAF(K,I)=ETAF(K,I)+DIFETA
c	  UF(K,I)=UF(K,I)+DIFU
C
C  Horizontal diffusion terms
C
	  DIFHETA=2.*DAMP*(ETA1(K+1,I)+ETA1(K-1,I)-2.*ETA1(K,I))
C	  DIFHU=2.*DAMP*(U1(K+1,I)+U1(K-1,I)-2.*U1(K,I))
	  DIFHU=2.*DAMP*(U1(K+1,I)*COSLAT(K+1)+U1(K-1,I)*COSLAT(K-1)-
     1     2.*U1(K,I)*COSLAT(K))/COSLAT(K)
	  DIFHT=2.*DAMP*(T1(K+1,I)+T1(K-1,I)-2.*T1(K,I))
	  DIFHR=2.*DAMP*(R1(K+1,I)+R1(K-1,I)-2.*R1(K,I))
C
	  ETAF(K,I)=ETAF(K,I)+DIFHETA
	  UF(K,I)=UF(K,I)+DIFHU
	  FTNET(K,I)=FTNET(K,I)+DIFHT
	  FRNET(K,I)=FRNET(K,I)+DIFHR
C
C  Sponge layer damping
C
	  FTNET(K,I)=FTNET(K,I)+SPONGE(I)*(T0(K,I)-T1(K,I))
	  FRNET(K,I)=FRNET(K,I)+SPONGE(I)*(R0(K,I)-R1(K,I))
	  UF(K,I)=UF(K,I)-SPONGE(I)*U1(K,I)
	  ETAF(K,I)=ETAF(K,I)-SPONGE(I)*ETA1(K,I)  
C
	 IF(I.GE.NPTOP)THEN
	  ETAF(K,I)=0.0
	  UF(K,I)=0.0
	 END IF
C
  140	CONTINUE
C
C  Level NP forcings
C
	UF(K,NP)=0.0
C
C  Calculate certain graphics quantities 
C
	 DO 150 I=1,NP
	  MUPG(K,I)=1000.*MUP(I)
	  MDG(K,I)=-1000.*MP(I)
	  RHG(K,I)=100.*R2(K,I)/(RS(I)+2.0E-6)
	  RHG(K,I)=MIN(RHG(K,I),100.0)
	  RHG(K,I)=MAX(RHG(K,I),0.0)
          OLG(K,I)=36.*(COSLAT(K)*PSI(K,I)-PSI(K-1,I))*DXI
  150	 CONTINUE
C
  155    CONTINUE
C
C      Calculate moving average plots
C
	IF(TIME.GT.(ENDTIME-PAVE))THEN
	 DO 203 I=1,NP
          DO 203 K=2,NLO-1
           J=K+(VTRANS*TIME*DXI)
           IF(VTRANS.GE.0.0)THEN
            J=J-(NLO-2)*(J/NLO)
           ELSE
            J=J+(NLO-1)*((NLO-J)/NLO)
           END IF
	   OLGRAPH(K,I)=OLGRAPH(K,I)+OLG(J,I)*PAFRAC
	   MUPGRAPH(K,I)=MUPGRAPH(K,I)+MUPG(J,I)*PAFRAC
	   MDGRAPH(K,I)=MDGRAPH(K,I)+MDG(J,I)*PAFRAC
	   RHGRAPH(K,I)=RHGRAPH(K,I)+RHG(J,I)*PAFRAC
	   ULGRAPH(K,I)=ULGRAPH(K,I)+U2(J,I)*PAFRAC
	   PSIGRAPH(K,I)=PSIGRAPH(K,I)+1.0E-5*PSI(J,I)*
     1      COS(3.14159*RLAT(J)/180.)*PAFRAC
	   TEMPGRAPH(K,I)=TEMPGRAPH(K,I)+T2(J,I)*PAFRAC
	   AMGRAPH(K,I)=AMGRAPH(K,I)+(U2(J,I)+
     1      1.454E-4*6.38E6*COS(3.14159*RLAT(J)/180.))*
     2      PAFRAC
  203	 CONTINUE
	END IF
C
C  Advance quantities one time step, applying Asselin filter
C
	DO 180 K=2,NLO-1
C
	IF(TSINT.EQ.'y'.OR.TSINT.EQ.'Y')THEN
	 TS3(K)=TS1(K)+2.*DT*FTS(K)
	 TS3(K)=MAX(TS3(K),270.0)
         TS1(K)=TS2(K)+AFILT*(TS1(K)+TS3(K)-2.*TS2(K))
	 TS2(K)=TS3(K)
c	 IF(K.GT.7)THEN
c          X=2.*FLOAT(K-13)/5.0
c          DELTATS=4.0
c          TS2(K)=TS2(7)-0.5*DELTATS*(1.+TANH(X))
c	 END IF
	END IF
C
	DO 160 I=1,NP
	  T3(K,I)=T1(K,I)+2.*DT*FTNET(K,I)
	  R3(K,I)=R1(K,I)+2.*DT*FRNET(K,I)
	  T1(K,I)=T2(K,I)+AFILT*(T1(K,I)+T3(K,I)-2.*T2(K,I))
	  R1(K,I)=R2(K,I)+AFILT*(R1(K,I)+R3(K,I)-2.*R2(K,I))
	  T2(K,I)=T3(K,I)
	  R2(K,I)=R3(K,I)
	  IF(I.LT.NPTOP)THEN
	  ETA3(K,I)=ETA1(K,I)+2.*DT*ETAF(K,I)
	  ETA1(K,I)=ETA2(K,I)+AFILT*(ETA1(K,I)+ETA3(K,I)-2.*ETA2(K,I))
	  ETA2(K,I)=ETA3(K,I)
          U3(K,I)=U1(K,I)+2.*DT*UF(K,I)
          U1(K,I)=U2(K,I)+AFILT*(U1(K,I)+U3(K,I)-2.*U2(K,I))
          U2(K,I)=U3(K,I)
	  END IF
  160	CONTINUE
	ETA1(K,1)=ETA1(K,2)
C
C  Find streamfunction
C
	 PSI(K,NPTOP)=0.0
	 ETA2(K,NPTOP)=0.0
	 FV=0.0
	 DO 165 I=NPTOP-1,1,-1
	  FV=FV+ETA2(K,I+1)*100.0*(P(I)-P(I+1))
	  PSI(K,I)=PSI(K,I+1)+FV*100.0*(PH(I)-PH(I+1))
  165	 CONTINUE
	 DO 170 I=NPTOP-1,2,-1
	  PSI(K,I)=PSI(K,1)*(PH(I)-PH(NPTOP))/(PH(1)-PH(NPTOP))-PSI(K,I)
  170	 CONTINUE
	 PSI(K,1)=0.0
C
  180	CONTINUE
C
C  Return to beginning of time loop
C
	GOTO 100
C
C  Output processing starts here
C
  200	CONTINUE
	NPR=NPR-1
C
C  Subtract horizontal mean temperature from composite temperature
C
	DO 1010 I=1,NP
	 II=MIN(I,NP-1)
	 TEMBAR=0.0
	 DO 1005 K=2,NLO-1
	  TEMBAR=TEMBAR+TEMPGRAPH(K,II)
 1005    CONTINUE
	 TEMBAR=TEMBAR/FLOAT(NLO-2)
	 DO 1006 K=2,NLO-1
	  TEMPGRAPH(K,I)=TEMPGRAPH(K,II)-TEMBAR
 1006	 CONTINUE
 1010	CONTINUE
C
C  ***   Add boundary conditions to contour plots   ***
C
	IF(BCS.EQ.'p')THEN
C
	DO 205 I=1,NPR
	 PGRAPH(1,I)=PGRAPH(NLO-1,I)
	 PGRAPH(NLO,I)=PGRAPH(2,I)
	 OGRAPH(1,I)=OGRAPH(NLO-1,I)
	 OGRAPH(NLO,I)=OGRAPH(2,I)
         VGRAPH(1,I)=VGRAPH(NLO-1,I)
         VGRAPH(NLO,I)=VGRAPH(2,I)
         UTGRAPH(1,I)=UTGRAPH(NLO-1,I)
         UTGRAPH(NLO,I)=UTGRAPH(2,I)
         SSTGRAPH(1,I)=SSTGRAPH(NLO-1,I)
         SSTGRAPH(NLO,I)=SSTGRAPH(2,I)
	 T100GRAPH(1,I)=T100GRAPH(NLO-1,I)
	 T100GRAPH(NLO,I)=T100GRAPH(2,I)
	 MPIGRAPH(1,I)=MPIGRAPH(NLO-1,I)
	 MPIGRAPH(NLO,I)=MPIGRAPH(2,I)
  205	CONTINUE
	DO 207 J=1,NP
	 MUPGRAPH(1,J)=MUPGRAPH(NLO-1,J)
	 MUPGRAPH(NLO,J)=MUPGRAPH(2,J)
         MDGRAPH(1,J)=MDGRAPH(NLO-1,J)
         MDGRAPH(NLO,J)=MDGRAPH(2,J)
         OLGRAPH(1,J)=OLGRAPH(NLO-1,J)
         OLGRAPH(NLO,J)=OLGRAPH(2,J)
         RHGRAPH(1,J)=RHGRAPH(NLO-1,J)
         RHGRAPH(NLO,J)=RHGRAPH(2,J)
         ULGRAPH(1,J)=ULGRAPH(NLO-1,J)
         ULGRAPH(NLO,J)=ULGRAPH(2,J)
         PSIGRAPH(1,J)=PSIGRAPH(NLO-1,J)
         PSIGRAPH(NLO,J)=PSIGRAPH(2,J)
         TEMPGRAPH(1,J)=TEMPGRAPH(NLO-1,J)
         TEMPGRAPH(NLO,J)=TEMPGRAPH(2,J)
	 AMGRAPH(1,J)=AMGRAPH(NLO-1,J)
	 AMGRAPH(NLO,J)=AMGRAPH(2,J)
  207	CONTINUE
C
	ELSE
C
	DO 206 I=1,NPR
	 PGRAPH(1,I)=PGRAPH(2,I)
	 PGRAPH(NLO,I)=PGRAPH(NLO-1,I)
	 OGRAPH(1,I)=OGRAPH(2,I)
	 OGRAPH(NLO,I)=OGRAPH(NLO-1,I)
         VGRAPH(1,I)=0.0
         VGRAPH(NLO,I)=0.0
         UTGRAPH(1,I)=0.0
         UTGRAPH(NLO,I)=0.0
         SSTGRAPH(1,I)=SSTGRAPH(2,I)
         SSTGRAPH(NLO,I)=SSTGRAPH(NLO-1,I)
         T100GRAPH(1,I)=T100GRAPH(2,I)
         T100GRAPH(NLO,I)=T100GRAPH(NLO-1,I)
	 MPIGRAPH(1,I)=MPIGRAPH(2,I)
	 MPIGRAPH(NLO,I)=MPIGRAPH(NLO-1,I)
  206	CONTINUE
	DO 208 J=1,NP
	 MUPGRAPH(1,J)=MUPGRAPH(2,J)
	 MUPGRAPH(NLO,J)=MUPGRAPH(NLO-1,J)
         MDGRAPH(1,J)=MDGRAPH(2,J)
         MDGRAPH(NLO,J)=MDGRAPH(NLO-1,J)
         OLGRAPH(1,J)=OLGRAPH(2,J)
         OLGRAPH(NLO,J)=OLGRAPH(NLO-1,J)
         RHGRAPH(1,J)=RHGRAPH(2,J)
         RHGRAPH(NLO,J)=RHGRAPH(NLO-1,J)
         ULGRAPH(1,J)=0.0
         ULGRAPH(NLO,J)=0.0
         PSIGRAPH(1,J)=0.0
         PSIGRAPH(NLO,J)=0.0
         TEMPGRAPH(1,J)=TEMPGRAPH(2,J)
         TEMPGRAPH(NLO,J)=TEMPGRAPH(NLO-1,J)
	 AMGRAPH(NLO,J)=AMGRAPH(NLO-1,J)
	 AMGRAPH(1,J)=AMGRAPH(2,J)
  208	CONTINUE
C
	END IF
C
C ***   Write contour plot ASCII files  ***
C
	DO 400 I=1,NLO
	 DISX(I)=0.001*DX*FLOAT(I-1)
  400	CONTINUE
C
	IF(FFMT.EQ.'csv')THEN
C
	OPEN(UNIT=12, FILE='precip.csv',STATUS='UNKNOWN')
        OPEN(UNIT=13, FILE='omegat.csv',STATUS='UNKNOWN')
        OPEN(UNIT=14, FILE='vt.csv',STATUS='UNKNOWN')
        OPEN(UNIT=15, FILE='omegal.csv',STATUS='UNKNOWN')
        OPEN(UNIT=16, FILE='mul.csv',STATUS='UNKNOWN')
        OPEN(UNIT=17, FILE='mdl.csv',STATUS='UNKNOWN')
	OPEN(UNIT=18, FILE='ut.csv',STATUS='UNKNOWN')
        OPEN(UNIT=19, FILE='psi.csv',STATUS='UNKNOWN')
        OPEN(UNIT=20, FILE='rh.csv',STATUS='UNKNOWN')
        OPEN(UNIT=21, FILE='ul.csv',STATUS='UNKNOWN')
        OPEN(UNIT=22, FILE='sst.csv',STATUS='UNKNOWN')
	OPEN(UNIT=26, FILE='temp.csv',STATUS='UNKNOWN')
	OPEN(UNIT=27, FILE='t100.csv',STATUS='UNKNOWN')
	OPEN(UNIT=28, FILE='mpi.csv',STATUS='UNKNOWN')
	OPEN(UNIT=29, FILE='am.csv',STATUS='UNKNOWN')
C
	WRITE(12,405)(DISX(I),I=1,NLO)
        WRITE(13,405)(DISX(I),I=1,NLO)
        WRITE(14,405)(DISX(I),I=1,NLO)
        WRITE(15,405)(DISX(I),I=1,NLO)
        WRITE(16,405)(DISX(I),I=1,NLO)
        WRITE(17,405)(DISX(I),I=1,NLO)
        WRITE(18,405)(DISX(I),I=1,NLO)
        WRITE(19,405)(DISX(I),I=1,NLO)
        WRITE(20,405)(DISX(I),I=1,NLO)
        WRITE(21,405)(DISX(I),I=1,NLO)
        WRITE(22,405)(DISX(I),I=1,NLO)
        WRITE(26,405)(DISX(I),I=1,NLO)
        WRITE(27,405)(DISX(I),I=1,NLO)
	WRITE(28,405)(DISX(I),I=1,NLO)
        WRITE(29,405)(DISX(I),I=1,NLO)
  405	FORMAT(2X,200(F9.1,','))
	DO 410 I=1,NPR
	 WRITE(12,415)GTIME(I),(PGRAPH(J,I),J=1,NLO)
         WRITE(13,415)GTIME(I),(OGRAPH(J,I),J=1,NLO)
         WRITE(14,415)GTIME(I),(VGRAPH(J,I),J=1,NLO)
         WRITE(18,415)GTIME(I),(UTGRAPH(J,I),J=1,NLO)
	 WRITE(22,415)GTIME(I),(SSTGRAPH(J,I),J=1,NLO)
	 WRITE(27,415)GTIME(I),(T100GRAPH(J,I),J=1,NLO)
	 WRITE(28,415)GTIME(I),(MPIGRAPH(J,I),J=1,NLO)
  410	CONTINUE
  415	FORMAT(2X,200(F10.4,','))
	DO 420 I=NP,1,-1
	 WRITE(15,415)P(I),(OLGRAPH(J,I),J=1,NLO)
         WRITE(16,415)P(I),(MUPGRAPH(J,I),J=1,NLO)
         WRITE(17,415)P(I),(MDGRAPH(J,I),J=1,NLO)
         WRITE(19,415)P(I),(PSIGRAPH(J,I),J=1,NLO)
         WRITE(20,415)P(I),(RHGRAPH(J,I),J=1,NLO)
         WRITE(21,415)P(I),(ULGRAPH(J,I),J=1,NLO)
         WRITE(26,415)P(I),(TEMPGRAPH(J,I),J=1,NLO)
         WRITE(29,415)P(I),(AMGRAPH(J,I),J=1,NLO)
  420	CONTINUE
C
	ELSE
C
	OPEN(UNIT=12, FILE='precip.out',STATUS='UNKNOWN')
        OPEN(UNIT=13, FILE='omegat.out',STATUS='UNKNOWN')
        OPEN(UNIT=14, FILE='vt.out',STATUS='UNKNOWN')
        OPEN(UNIT=15, FILE='omegal.out',STATUS='UNKNOWN')
        OPEN(UNIT=16, FILE='mul.out',STATUS='UNKNOWN')
        OPEN(UNIT=17, FILE='mdl.out',STATUS='UNKNOWN')
	OPEN(UNIT=18, FILE='ut.out',STATUS='UNKNOWN')
        OPEN(UNIT=19, FILE='psi.out',STATUS='UNKNOWN')
        OPEN(UNIT=20, FILE='rh.out',STATUS='UNKNOWN')
        OPEN(UNIT=21, FILE='ul.out',STATUS='UNKNOWN')
	OPEN(UNIT=22, FILE='x.out',STATUS='UNKNOWN')
	OPEN(UNIT=23, FILE='t.out',STATUS='UNKNOWN')
	OPEN(UNIT=24, FILE='p.out',STATUS='UNKNOWN')
        OPEN(UNIT=25, FILE='sst.out',STATUS='UNKNOWN')
	OPEN(UNIT=26, FILE='temp.out',STATUS='UNKNOWN')
	OPEN(UNIT=27, FILE='t100.out',STATUS='UNKNOWN')
	OPEN(UNIT=28, FILE='mpi.out',STATUS='UNKNOWN')
        OPEN(UNIT=29, FILE='am.out',STATUS='UNKNOWN')
C
        WRITE(22,425)(DISX(I),I=1,NLO)
  425	FORMAT(2X,200(F9.1,' '))
	WRITE(23,435)(GTIME(I),I=1,NPR)
  435	FORMAT(2X,500(F9.1,' '))
	WRITE(24,437)(P(I),I=1,NP)
  437	FORMAT(2X,100(F9.1,' '))
C
	DO 440 I=1,NPR
	 WRITE(12,445)(PGRAPH(J,I),J=1,NLO)
         WRITE(13,445)(OGRAPH(J,I),J=1,NLO)
         WRITE(14,445)(VGRAPH(J,I),J=1,NLO)
         WRITE(18,445)(UTGRAPH(J,I),J=1,NLO)
         WRITE(25,445)(SSTGRAPH(J,I),J=1,NLO)
	 WRITE(27,445)(T100GRAPH(J,I),J=1,NLO)
	 WRITE(28,445)(MPIGRAPH(J,I),J=1,NLO)
  440	CONTINUE
  445	FORMAT(2X,200(F10.4,' '))
	DO 450 I=1,NP
	 WRITE(15,445)(OLGRAPH(J,I),J=1,NLO)
         WRITE(16,445)(MUPGRAPH(J,I),J=1,NLO)
         WRITE(17,445)(MDGRAPH(J,I),J=1,NLO)
         WRITE(19,445)(PSIGRAPH(J,I),J=1,NLO)
         WRITE(20,445)(RHGRAPH(J,I),J=1,NLO)
         WRITE(21,445)(ULGRAPH(J,I),J=1,NLO)
         WRITE(26,445)(TEMPGRAPH(J,I),J=1,NLO)
         WRITE(29,445)(AMGRAPH(J,I),J=1,NLO)
  450	CONTINUE
C
	END IF
C
C  Output to file sounding.out
C
	DO 350 K=2,NLO-1
	TS2C=TS2(K)-273.15
	CO2A=CO2*1.0E6
	WRITE(10,210) NP,QGRAPH(K,NPR),TS2C
  210	FORMAT(2X, 'N levels = ',T15,I3,T26,'Q=',F5.2,' m/s',
     1    T48,'SST=',T55,F5.2,' C',/)
C
        WRITE(10,220)
  220   FORMAT(2X,'Pressure',T14,'Temp.',T25,'Spec. humid.',T40,
     1    'O3 mr',T49, 'Psi',T57,'Rcool',T67,'U')
        WRITE(10,230)
  230   FORMAT(4X,'(mb)',T15,'(C)',T28,'(g/kg)',T40,'10**-6',T47,
     1    'E4 kg/m/s',T57,'(K/dy)',T66,'m/s')
        WRITE(10,240)
  240   FORMAT(2X,'-------',T14,'-----',T25,'------------',T40,
     1   '-----',T48, '-----',T57,'------',T67,'-')
c
	DO 260 I=1,NP
	 OZ=1.0E6*O3(NP+1-I)
	 TC=T2(K,I)-273.15
	 RM=1000.0*R2(K,I)
	 AOMEG=PSI(K,I)*1.0E-4
	 ARADC=RCOOL(K,I)*3600.*24.
         WRITE(10,250)P(I),TC,RM,OZ,AOMEG,ARADC,U2(K,I)
  250    FORMAT(3X,F6.1,T12,F8.3,T25,F10.6,T39,F6.3,T47,F6.2,
     1   T56,F7.3,T64,F5.1)
  260	CONTINUE	
  350	CONTINUE
C
C  Open and use NCAR graphics
C
C	CALL OPNGKS
C	CALL CONREC(PGRAPH,NLO,NLO,NPR,0.0,0.0,0.0,0,0,0)
C	CALL FRAME
C       CALL CONREC(OGRAPH,NLO,NLO,NPR,0.0,0.0,0.0,0,0,0)
C	CALL FRAME
C       CALL CONREC(VGRAPH,NLO,NLO,NPR,0.0,0.0,0.0,0,0,0)
C	CALL FRAME
C       CALL CONREC(MUPGRAPH,NLO,NLO,NP,0.0,0.0,0.0,0,0,0)
C       CALL FRAME
C       CALL CONREC(MDGRAPH,NLO,NLO,NP,0.0,0.0,0.0,0,0,0)
C       CALL FRAME
C       CALL CONREC(OLGRAPH,NLO,NLO,NP,0.0,0.0,0.0,0,0,0)
C       CALL FRAME
C	CALL CLSGKS
	STOP 
	END
C
***************************************************************************
*****                       SUBROUTINE CONVECT                        *****
*****                           VERSION 4.2                           *****
*****                          15 July, 1998                          *****
***************************************************************************
C
	SUBROUTINE CONVECT
     *    (T,       Q,   QS,     P,       PH,      TG,   QG,
     *     PG,      ND,  NL,     DELT,    IFLAG,   FT,   FQ,
     *     PRECIP,  WD,  TPRIME, QPRIME,  CBMF)
C
C-----------------------------------------------------------------------------
C    *** On input:      ***
C
C     T:   Array of absolute temperature (K) of dimension ND, with first
C           index corresponding to lowest model level. Note that this array
C           will be altered by the subroutine if dry convective adjustment
C           occurs
C
C     Q:   Array of specific humidity (gm/gm) of dimension ND, with first
C            index corresponding to lowest model level. Must be defined
C            at same grid levels as T. Note that this array will be altered
C            if dry convective adjustment occurs
C
C     QS:  Array of saturation specific humidity of dimension ND, with first
C            index corresponding to lowest model level. Must be defined
C            at same grid levels as T. Note that this array will be altered
C            if dry convective adjustment occurs
C
C     P:   Array of pressure (mb) of dimension ND, with first
C            index corresponding to lowest model level. Must be defined
C            at same grid levels as T
C
C     PH:  Array of pressure (mb) of dimension ND+1, with first index
C            corresponding to lowest level. These pressures are defined at
C            levels intermediate between those of P, T, Q and QS. The first
C             value of PH should be greater than (i.e. at a lower level than)
C             the first value of the array P
C
C     TG:  Scalar ground or sea surface temperature (K)
C
C     QG:  Scalar ground or sea surface value of saturation specific
C            humidity(gm/gm)
C
C     PG:  Scalar ground or sea surface value of pressure (mb). Can be the same
C           value as PH(1)
C
C     ND: The dimension of the arrays T,Q,QS,P,PH,FT and FQ
C
C     NL:  The maximum number of levels to which convection can
C              penetrate, plus 1
C              NL MUST be less than or equal to ND-1
C
C     DELT: The model time step (sec) between calls to CONVECT
C
C----------------------------------------------------------------------------
C    ***   On Output:         ***
C
C     IFLAG: An output integer whose value denotes the following:
C
C                VALUE                        INTERPRETATION
C                -----                        --------------
C                  0               No moist convection; atmosphere is not
C                                  unstable, or surface temperature is less
C                                  than 250 K or surface specific humidity
C                                  is non-positive.
C
C                  1               Moist convection occurs.
C
C                  2               No moist convection: lifted condensation
C                                  level is above the 200 mb level.
C
C                  3               No moist convection: cloud base is higher
C                                  then the level NL-1.
C
C                  4               Moist convection occurs, but a CFL condition
C                                  on the subsidence warming is violated. This
C                                  does not cause the scheme to terminate.
C
C     FT:   Array of temperature tendency (K/s) of dimension ND, defined at same
C             grid levels as T, Q, QS and P
C
C     FQ:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
C             defined at same grid levels as T, Q, QS and P
C
C     PRECIP: Scalar convective precipitation rate (mm/day)
C
C     WD:    A convective downdraft velocity scale. For use in surface
C       flux parameterizations. See convect.ps file for details
C
C     TPRIME: A convective downdraft temperature perturbation scale (K).
C             For use in surface flux parameterizations. See convect.ps
C             file for details
C
C     QPRIME: A convective downdraft specific humidity
C              perturbation scale (gm/gm).
C              For use in surface flux parameterizations. See convect.ps
C              file for details
C
C     CBMF:   The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
C              BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
C              ITS NEXT CALL. That is, the value of CBMF must be "remembered"
C              by the calling program between calls to CONVECT
C
C------------------------------------------------------------------------------
C
C    ***  THE PARAMETER NA SHOULD IN GENERAL BE GREATER THAN   ***
C    ***                OR EQUAL TO  ND + 1                    ***
C
      PARAMETER (NA=60)           
C
      INTEGER NENT(NA)
      REAL T(ND),Q(ND),QS(ND),P(ND),PH(ND+1)
      REAL FT(ND),FQ(ND)
      REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
      REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
      REAL QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
      REAL SIGP(NA),TP(NA),TOLD(NA),CPN(NA)
      REAL LV(NA),LVCP(NA),LV0,H(NA),HP(NA),GZ(NA),HM(NA)
C
      REAL MUP(NA),MDOWN(NA),ENT(NA),DET(NA),FQDET(NA),FQSUB(NA)
      COMMON / CVT / TVP,MP,QP,SIJ,MUP,MDOWN,ENT,DET,FQDET,FQSUB,
     1     WATER, INB
C
C------------------------------------------------------------------------------
C
C   ***                    SPECIFY PARAMETERS                        ***
C
C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
C   ***               BETWEEN 0 C AND TLCRIT)                        ***
C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
C   ***                       FORMULATION                            ***
C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
C   ***                        OF CLOUD                              ***
C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
C   ***                          OF RAIN                             ***
C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
c   ***                          OF SNOW                             ***
C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
C
        ELCRIT=.0011
        TLCRIT=-55.0
        ENTP=1.5
        SIGD=0.05
        SIGS=0.12
        OMTRAIN=50.0
        OMTSNOW=5.5 
        COEFFR=1.0
        COEFFS=0.8
	BETA=10.0
        DTMAX=0.9 
        ALPHA=0.02  
        DAMP=0.01
C
C   ***        ASSIGN VALUES OF THERMODYNAMIC CONSTANTS,        ***
C   ***            GRAVITY, AND LIQUID WATER DENSITY.           ***
C   ***             THESE SHOULD BE CONSISTENT WITH             ***
C   ***              THOSE USED IN CALLING PROGRAM              ***
C   ***     NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT  ***
C
      CPD=1005.7
      CPV=1870.0
      CL=4190.0 
      RV=461.5
      RD=287.04
      LV0=2.501E6
      G=9.8  
      ROWL=1000.0
C
      CPVMCL=CL-CPV 
      EPS=RD/RV
      EPSI=1./EPS
      GINV=1.0/G
      DELTI=1.0/DELT
C
C           ***  INITIALIZE OUTPUT ARRAYS AND PARAMETERS  ***
C
	DO 5 I=1,ND
	 FT(I)=0.0
	 FQ(I)=0.0
	 MDOWN(I)=0.0
	 MUP(I)=0.0
	 ENT(I)=0.0
	 DET(I)=0.0
	 FQDET(I)=0.0
	 FQSUB(I)=0.0
	 WATER(I)=0.0
	 QP(I)=Q(I)
	 MP(I)=0.0
	 TVP(I)=T(I)*(1.+Q(I)*EPSI-Q(I))
    5   CONTINUE
	DO 7 I=1,NL+1
	 RDCP=(RD*(1.-Q(I))+Q(I)*RV)/
     1    (CPD*(1.-Q(I))+Q(I)*CPV)
	 TH(I)=T(I)*(1000.0/P(I))**RDCP
    7   CONTINUE
	PRECIP=0.0
        WD=0.0
        TPRIME=0.0
        QPRIME=0.0
	IFLAG=0
	INB=ND
C
C     ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
C
C     ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
C     ***                BOUNDARY LAYER SCHEME !                 ***
C                        
      JC=0
	DO 30 I=NL-1,1,-1
	 JN=0
	   SUM=TH(I)*(1.+Q(I)*EPSI-Q(I))
	 DO 10 J=I+1,NL
	    SUM=SUM+TH(J)*(1.+Q(J)*EPSI-Q(J))
	    THBAR=SUM/FLOAT(J+1-I)
	  IF((TH(J)*(1.+Q(J)*EPSI-Q(J))).LT.THBAR)JN=J
	  IF(I.EQ.1.AND.P(J).GT.948.)JN=MAX(JN,J)
   10    CONTINUE
c         IF(I.EQ.1)JN=MAX(JN,3)
	 IF(JN.EQ.0)GOTO 30
   12    CONTINUE
	 AHM=0.0
	 RM=0.0
	 DO 15 J=I,JN
	  AHM=AHM+(CPD*(1.-Q(J))+Q(J)*CPV)*T(J)*(PH(J)-PH(J+1))
	  RM=RM+Q(J)*(PH(J)-PH(J+1))
   15    CONTINUE
	 RM=RM/(PH(I)-PH(JN+1))
	 A2=0.0
	 DO 20 J=I,JN
	  Q(J)=RM
	  RDCP=(RD*(1.-Q(J))+Q(J)*RV)/
     1     (CPD*(1.-Q(J))+Q(J)*CPV)  
	  X=(0.001*P(J))**RDCP
	  TOLD(J)=T(J)
	  T(J)=X
	  A2=A2+(CPD*(1.-Q(J))+Q(J)*CPV)*X*(PH(J)-PH(J+1))
   20    CONTINUE
	 DO 25 J=I,JN
	  TH(J)=AHM/A2
	  T(J)=T(J)*TH(J)
	  TC=TOLD(J)-273.15
	  ALV=LV0-CPVMCL*TC
	  QS(J)=QS(J)+QS(J)*(1.+QS(J)*0.608)*ALV*(T(J)-
     1     TOLD(J))/(RV*TOLD(J)*TOLD(J))
   25    CONTINUE
	 IF((TH(JN+1)*(1.+Q(JN+1)*EPSI-Q(JN+1))).LT.
     1    (TH(JN)*(1.+Q(JN)*EPSI-Q(JN))))THEN
	  JN=JN+1
	  GOTO 12
	 END IF
	 IF(I.EQ.1)JC=JN 
   30   CONTINUE
C
C   ***   Remove any supersaturation that results from adjustment ***
C
      IF(JC.GT.1)THEN
       DO 38 J=1,JC
	  IF(QS(J).LT.Q(J))THEN 
	   ALV=LV0-CPVMCL*(T(J)-273.15)  
	   TNEW=T(J)+ALV*(Q(J)-QS(J))/(CPD*(1.-Q(J))+
     1      CL*Q(J)+QS(J)*(CPV-CL+ALV*ALV/(RV*T(J)*T(J))))
	   QNEW=Q(J)-(CPD*(1.-Q(J))+CPV*Q(J))*(TNEW-T(J))/ALV
	   PRECIP=PRECIP+24.*3600.*1.0E5*(PH(J)-PH(J+1))*
     1      (Q(J)-QNEW)/(G*DELT*ROWL)
	   T(J)=TNEW
	   Q(J)=QNEW
	  END IF     
   38  CONTINUE  
      END IF
C
C  *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
C  
	GZ(1)=0.0
	CPN(1)=CPD*(1.-Q(1))+Q(1)*CPV
	H(1)=T(1)*CPN(1)
        LV(1)=LV0-CPVMCL*(T(1)-273.15)
        HM(1)=LV(1)*Q(1)
        AHMIN=1.0E12
        IHMIN=NL
	DO 40 I=2,NL
	  TVX=T(I)*(1.+Q(I)*EPSI-Q(I))
	  TVY=T(I-1)*(1.+Q(I-1)*EPSI-Q(I-1))
	  GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I)
	  CPN(I)=CPD*(1.-Q(I))+CPV*Q(I)
	  H(I)=T(I)*CPN(I)+GZ(I)
          LV(I)=LV0-CPVMCL*(T(I)-273.15)
          HM(I)=(CPD*(1.-Q(I))+CL*Q(I))*(T(I)-T(1))+
     1     LV(I)*Q(I)+GZ(I)
C
C  ***  Find level of minimum moist static energy    ***
C
          IF(HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN
           AHMIN=HM(I)
           IHMIN=I
          END IF
   40   CONTINUE
C
C  ***  CHECK WHETHER LOWEST LEVEL TEMPERATURE AND SPECIFIC HUMIDITY   ***
C  ***                          ARE REASONABLE                         ***
C  ***      Skip convection if HM increases monotonically upward       ***
C
        IF(T(1).LT.250.0.OR.Q(1).LE.0.0.OR.P(IHMIN).LT.400.)THEN
	 IFLAG=0
	 RETURN
	END IF
C
C  ***     Find that model level below the level of minimum moist       ***
C  ***  static energy that has the maximum value of moist static energy ***
C
        AHMAX=0.0
        DO 42 I=1,IHMIN
         IF(HM(I).GT.AHMAX)THEN
          NK=I
          AHMAX=HM(I)
         END IF
   42   CONTINUE
C
C   ***  CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT PARCEL ORIGIN LEVEL ***
C   ***       (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)      ***
C
	IF(T(NK).LT.250.0.OR.Q(NK).LE.0.0)GOTO 800
	RH=Q(NK)/QS(NK)
	CHI=T(NK)/(1669.0-122.0*RH-T(NK))
	PLCL=P(NK)*(RH**CHI)
	IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
	 IFLAG=2
	 GOTO 800
	END IF
C
C   ***  CALCULATE FIRST LEVEL ABOVE LCL (=ICB)  ***
C
	ICB=NL-1
	DO 50 I=NK+1,NL
	 IF(P(I).LT.PLCL)THEN
	  ICB=MIN(ICB,I)
	 END IF
   50   CONTINUE
	IF(ICB.GE.(NL-1))THEN
	 IFLAG=3
	 GOTO 800
	END IF
C
C   *** FIND TEMPERATURE UP THROUGH ICB AND TEST FOR INSTABILITY           ***
C
C   *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL      ***
C   ***  TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC             ***
C   ***                   LIQUID WATER CONTENT                             ***
C
	CALL TLIFT(P,T,Q,QS,GZ,ICB,NK,TVP,TP,CLW,ND,NL,1)
	DO 54 I=NK,ICB
	 TV(I)=T(I)*(1.+Q(I)*EPSI-Q(I))
	 TVP(I)=TVP(I)-TP(I)*Q(NK)
   54   CONTINUE
C
C   ***  If there was no convection at last time step and parcel    ***
C   ***       is stable at ICB then skip rest of calculation        ***
C
        IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN
	 IFLAG=0
	 GOTO 800
	END IF
C
C   ***  IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
C
	IF(IFLAG.NE.4)IFLAG=1
C
C   ***  FIND THE REST OF THE LIFTED PARCEL TEMPERATURES          ***
C
	CALL TLIFT(P,T,Q,QS,GZ,ICB,NK,TVP,TP,CLW,ND,NL,2)
C
C   ***  SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF   ***
C   ***          PRECIPITATION FALLING OUTSIDE OF CLOUD           ***
C   ***      THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)     ***
C                 
        DO 57 I=1,NK
         EP(I)=0.0
         SIGP(I)=SIGS
         CLW(I)=0.0
   57   CONTINUE
        DO 60 I=NK+1,NL
	 TCA=TP(I)-273.15
	 IF(TCA.GE.0.0)THEN
	  ELACRIT=ELCRIT
	 ELSE
	  ELACRIT=ELCRIT*(1.0-TCA/TLCRIT)
	 END IF
         ELACRIT=MAX(ELACRIT,0.0)
	 EP(I)=1.0-ELACRIT/MAX(CLW(I),1.0E-8)
	 EP(I)=MAX(EP(I),0.0)
	 EP(I)=MIN(EP(I),1.0)
	 SIGP(I)=SIGS
   60   CONTINUE
C
C   ***       CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL     ***
C   ***                    VIRTUAL TEMPERATURE                    ***
C
	DO 64 I=ICB+1,NL
	 TV(I)=T(I)*(1.+Q(I)*EPSI-Q(I))
         TVP(I)=TVP(I)*(1.-Q(NK)+EP(I)*CLW(I))
   64   CONTINUE
C
C   ***        NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS       ***
C
	DO 70 I=1,NL
	 HP(I)=H(I)
	 QP(I)=Q(I)
	 NENT(I)=0
	 WATER(I)=0.0
	 EVAP(I)=0.0
	 MP(I)=0.0
	 M(I)=0.0
	 LVCP(I)=LV(I)/CPN(I)
	 DO 70 J=1,NL
	  QENT(I,J)=Q(J)
	  ELIJ(I,J)=0.0
	  MENT(I,J)=0.0
	  SIJ(I,J)=0.0
   70   CONTINUE
C
C  ***  FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S      ***
C  ***          HIGHEST LEVEL OF NEUTRAL BUOYANCY                 ***
C  ***     AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)           ***
C
        CAPE=0.0
	CAPEM=0.0
	INB=ICB+1
        INB1=INB
        DO 82 I=ICB+1,NL-1
         BY=(TVP(I)-TV(I))*(PH(I)-PH(I+1))/P(I)
         BYP=(TVP(I+1)-TV(I+1))*(PH(I+1)-PH(I+2))/P(I+1)
         CAPE=CAPE+BY
         IF(BY.GE.0.0)INB1=I+1
         IF(CAPE.GT.0.0)THEN
          INB=I+1
          CAPEM=CAPE
         END IF
   82 	CONTINUE
   81 	CONTINUE
        CAPE=CAPEM+BYP
        DEFRAC=CAPEM-CAPE
        DEFRAC=MAX(DEFRAC,0.001)
        FRAC=-CAPE/DEFRAC
        FRAC=MIN(FRAC,1.0)
        FRAC=MAX(FRAC,0.0)
C
C   ***   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL   ***
C
	DO 95 I=ICB,INB
	 HP(I)=H(NK)+(LV(I)+(CPD-CPV)*T(I))*EP(I)*CLW(I)
   95   CONTINUE                  
C
C   ***  CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I),  ***
c   ***                   AT EACH MODEL LEVEL                       ***
C
	CBMFSUM=0.0
	DBOSUM=0.0
C   
C   ***     INTERPOLATE DIFFERENCE BETWEEN LIFTED PARCEL AND      ***
C   ***  ENVIRONMENTAL TEMPERATURES TO LIFTED CONDENSATION LEVEL  ***
C	
        TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(P(ICB-1)-PLCL)/
     1    (CPN(ICB-1)*P(ICB-1))
        TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-P(ICB))/
     1    (P(ICB)-P(ICB+1))
        DTPBL=0.0
        DO 96 I=NK,ICB-1
         DTPBL=DTPBL+(TVP(I)-TV(I))*(PH(I)-PH(I+1))
   96   CONTINUE
        DTPBL=DTPBL/(PH(NK)-PH(ICB))
        DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL
        DTMA=DTMIN
C
C   ***  ADJUST CLOUD BASE MASS FLUX   ***
C
      CBMFOLD=CBMF
      CBMF=(1.-DAMP)*CBMF+0.1*ALPHA*DTMA
      CBMF=MAX(CBMF,0.0)
C
C   *** If cloud base mass flux is zero, skip rest of calculation  ***
C
      IF(CBMF.EQ.0.0.AND.CBMFOLD.EQ.0.0)THEN
       GOTO 800
      END IF
      CBMFSUM=0.5*(CBMF+CBMFOLD)
C
C   ***   CALCULATE RATES OF MIXING,  M(I)   ***
C
      M(ICB)=0.0
      DO 103 I=ICB+1,INB
       K=MIN(I,INB1)
       DBO=ABS(TV(K+1)-TVP(K+1)-TV(K-1)+TVP(K-1))+
     1  ENTP*0.04*(PH(K)-PH(K+1))
       DBOSUM=DBOSUM+DBO
       M(I)=CBMF*DBO
  103 CONTINUE
      DO 110 I=ICB+1,INB
       M(I)=M(I)/DBOSUM  
  110 CONTINUE     
C
C   ***  CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING  ***
C   ***     RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING     ***
C   ***                        FRACTION (SIJ)                          ***
C
	DO 170 I=ICB+1,INB
	 QTI=Q(NK)-EP(I)*CLW(I)
	 DO 160 J=ICB,INB
	  BF2=1.+LV(J)*LV(J)*QS(J)/(RV*T(J)*T(J)*CPD)
	  ANUM=H(J)-HP(I)+(CPV-CPD)*T(J)*(QTI-Q(J))
	  DENOM=H(I)-HP(I)+(CPD-CPV)*(Q(I)-QTI)*T(J)
	  DEI=DENOM
	  IF(ABS(DEI).LT.0.01)DEI=0.01
	  SIJ(I,J)=ANUM/DEI
	  SIJ(I,I)=1.0
	  ALTEM=SIJ(I,J)*Q(I)+(1.-SIJ(I,J))*QTI-QS(J)
	  ALTEM=ALTEM/BF2
	  CWAT=CLW(J)*(1.-EP(J))
	  STEMP=SIJ(I,J)
	  IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR.
     1      ALTEM.GT.CWAT).AND.J.GT.I)THEN
	   ANUM=ANUM-LV(J)*(QTI-QS(J)-CWAT*BF2)
	   DENOM=DENOM+LV(J)*(Q(I)-QTI)
	   IF(ABS(DENOM).LT.0.01)DENOM=0.01
	   SIJ(I,J)=ANUM/DENOM
	   ALTEM=SIJ(I,J)*Q(I)+(1.-SIJ(I,J))*QTI-QS(J)
	   ALTEM=ALTEM-(BF2-1.)*CWAT
	  END IF
	  IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
	   QENT(I,J)=SIJ(I,J)*Q(I)+(1.-SIJ(I,J))*QTI
	   ELIJ(I,J)=ALTEM
	   ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
	   MENT(I,J)=M(I)/(1.-SIJ(I,J))
	   NENT(I)=NENT(I)+1
	  END IF
	  SIJ(I,J)=MAX(0.0,SIJ(I,J))
	  SIJ(I,J)=MIN(1.0,SIJ(I,J))
  160    CONTINUE
C
C   ***   IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS  ***
C   ***   AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES  ***
C
	 IF(NENT(I).EQ.0)THEN
	  MENT(I,I)=M(I)
	  QENT(I,I)=Q(NK)-EP(I)*CLW(I)
	  ELIJ(I,I)=CLW(I)
	  SIJ(I,I)=1.0
	 END IF 
  170   CONTINUE
	SIJ(INB,INB)=1.0
C
C   ***  NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL  ***
C   ***              PROBABILITIES OF MIXING                     ***
C
	DO 200 I=ICB+1,INB
	IF(NENT(I).NE.0)THEN
	 QP1=Q(NK)-EP(I)*CLW(I)
	 ANUM=H(I)-HP(I)-LV(I)*(QP1-QS(I))
	 DENOM=H(I)-HP(I)+LV(I)*(Q(I)-QP1)
	 IF(ABS(DENOM).LT.0.01)DENOM=0.01
	 SCRIT=ANUM/DENOM
	 ALT=QP1-QS(I)+SCRIT*(Q(I)-QP1)
	 IF(SCRIT.LT.0.0.OR.ALT.LT.0.0)SCRIT=1.0
	 ASIJ=0.0
	 SMIN=1.0
	 DO 175 J=ICB,INB
	  IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
	   IF(J.GT.I)THEN
	    SMID=MIN(SIJ(I,J),SCRIT)
	    SJMAX=SMID
	    SJMIN=SMID
	    IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN
	     SMIN=SMID
	     SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT)
	     SJMIN=MAX(SIJ(I,J-1),SIJ(I,J))
	     SJMIN=MIN(SJMIN,SCRIT)
	    END IF
	   ELSE
	    SJMAX=MAX(SIJ(I,J+1),SCRIT)
	    SMID=MAX(SIJ(I,J),SCRIT)
	    SJMIN=0.0
	    IF(J.GT.1)SJMIN=SIJ(I,J-1)
	    SJMIN=MAX(SJMIN,SCRIT)
	   END IF
	   DELP=ABS(SJMAX-SMID)
	   DELM=ABS(SJMIN-SMID)
	   ASIJ=ASIJ+(DELP+DELM)*(PH(J)-PH(J+1))
	   MENT(I,J)=MENT(I,J)*(DELP+DELM)*(PH(J)-PH(J+1))
	  END IF
  175    CONTINUE
	 ASIJ=MAX(1.0E-21,ASIJ)
	 ASIJ=1.0/ASIJ
	 DO 180 J=ICB,INB
	  MENT(I,J)=MENT(I,J)*ASIJ
  180    CONTINUE
	 BSUM=0.0
	 DO 190 J=ICB,INB
	  BSUM=BSUM+MENT(I,J)
  190    CONTINUE
	 IF(BSUM.LT.1.0E-18)THEN
	  NENT(I)=0
	  MENT(I,I)=M(I)
	  QENT(I,I)=Q(NK)-EP(I)*CLW(I)
	  ELIJ(I,I)=CLW(I)
	  SIJ(I,I)=1.0
	 END IF
	END IF
  200   CONTINUE
C
C   ***  CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING    ***
C   ***             DOWNDRAFT CALCULATION                      ***
C
	IF(EP(INB).LT.0.0001)GOTO 405
C
C   ***  INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER   ***
C   ***                AND CONDENSED WATER FLUX                    ***
C
	QP(INB)=Q(INB-1)
	QP(INB+1)=Q(INB)
	WT(INB+1)=0.0
	JTT=2
C
C    ***                    BEGIN DOWNDRAFT LOOP                    ***
C
	DO 400 I=INB,1,-1
C
C    ***              CALCULATE DETRAINED PRECIPITATION             ***
C
	WDTRAIN=G*EP(I)*M(I)*CLW(I)
	IF(I.GT.1)THEN
	 DO 320 J=1,I-1
	 AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
	 AWAT=MAX(0.0,AWAT)
  320    WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I)
	END IF
C
C    ***    FIND RAIN WATER AND EVAPORATION USING PROVISIONAL   ***
C    ***              ESTIMATES OF QP(I)AND QP(I-1)             ***
C     
c
c   ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
c 
        COEFF=COEFFS
        WT(I)=OMTSNOW
c      
c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
c
        IF(T(I).GT.273.0)THEN
         COEFF=COEFFR
         WT(I)=OMTRAIN
        END IF
        QSM=0.5*(Q(I)+QP(I+1))
        AFAC=COEFF*PH(I)*(QS(I)-QSM)/(1.0E4+2.0E3*PH(I)*QS(I))
        AFAC=MAX(AFAC,0.0)
        SIGT=SIGP(I)
        SIGT=MAX(0.0,SIGT)
        SIGT=MIN(1.0,SIGT)
        B6=100.*(PH(I)-PH(I+1))*SIGT*AFAC/WT(I)
        C6=(WATER(I+1)*WT(I+1)+WDTRAIN/SIGD)/WT(I)
        REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
        EVAP(I)=SIGT*AFAC*REVAP
        WATER(I)=REVAP*REVAP
C
C    ***  CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER     ***
C    ***              HYDROSTATIC APPROXIMATION                 ***
C   
	IF(I.EQ.1)GOTO 360
	DHDP=(H(I)-H(I-1))/(P(I-1)-P(I))
	DHDP=MAX(DHDP,10.0)
	MP(I)=100.*GINV*LV(I)*SIGD*EVAP(I)/DHDP
	MP(I)=MAX(MP(I),0.0)
C
C   ***   ADD SMALL AMOUNT OF INERTIA TO DOWNDRAFT              ***
C
	FAC=20.0/(PH(I-1)-PH(I))
	MP(I)=(FAC*MP(I+1)+MP(I))/(1.+FAC)
C   
C    ***      FORCE MP TO DECREASE LINEARLY TO ZERO                 ***
C    ***      BETWEEN ABOUT 950 MB AND THE SURFACE                  ***
C
	  IF(P(I).GT.(0.949*P(1)))THEN
	   JTT=MAX(JTT,I)
	   MP(I)=MP(JTT)*(P(1)-P(I))/(P(1)-P(JTT))
	  END IF              
  360   CONTINUE
C
C    ***       FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT     ***
C
	IF(I.EQ.INB)GOTO 400
	IF(I.EQ.1)THEN
	 QTM=Q(1) 
	 QSTM=QS(1)
	ELSE
	 QTM=Q(I-1)
	 QSTM=QS(I-1)
	END IF
	QP(I)=QTM    
	IF(MP(I).GT.MP(I+1))THEN
	  RAT=MP(I+1)/MP(I)
	  QP(I)=QP(I+1)*RAT+Q(I)*(1.0-RAT)+100.*GINV*
     1       SIGD*(PH(I)-PH(I+1))*(EVAP(I)/MP(I))
	 ELSE
	  IF(MP(I+1).GT.0.0)THEN
	    QP(I)=(GZ(I+1)-GZ(I)+QP(I+1)*(LV(I+1)+T(I+1)*(
     1        CL-CPD))+CPD*(T(I+1)-T(I)))/(LV(I)+T(I)*(CL-CPD))
	  END IF
	END IF
	QP(I)=MIN(QP(I),QSTM)
	QP(I)=MAX(QP(I),0.0)
  400   CONTINUE
C
C   ***  CALCULATE SURFACE PRECIPITATION IN MM/DAY     ***
C
	PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G)
C
  405   CONTINUE
C
C   ***  CALCULATE DOWNDRAFT VELOCITY SCALE AND SURFACE TEMPERATURE AND  ***
c   ***                    WATER VAPOR FLUCTUATIONS                      ***
C
      WD=BETA*ABS(MP(ICB))*0.01*RD*T(ICB)/(SIGD*P(ICB))
      QPRIME=0.5*(QP(1)-Q(1))
      TPRIME=LV0*QPRIME/CPD
C
C   ***  CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE  ***
C   ***                      AND MIXING RATIO                        ***
C
	DPINV=0.01/(PH(1)-PH(2))
	AM=0.0
	IF(NK.EQ.1)THEN
	 DO 410 K=2,INB
  410    AM=AM+M(K)
	END IF
	IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4
	FT(1)=FT(1)+G*DPINV*AM*(T(2)-T(1)+(GZ(2)-GZ(1))/CPN(1))
	FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1)
	FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(T(2)-
     1   T(1))*DPINV/CPN(1)
	FQ(1)=FQ(1)+G*MP(2)*(QP(2)-Q(1))*
     1    DPINV+SIGD*EVAP(1)
	FQDET(1)=FQ(1)
	FQ(1)=FQ(1)+G*AM*(Q(2)-Q(1))*DPINV
	FQSUB(1)=G*AM*(Q(2)-Q(1))*DPINV
	AMDE=0.0
	DO 415 J=2,INB
	 FQ(1)=FQ(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-Q(1))
	 FQSUB(1)=FQSUB(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-Q(1))
  415   CONTINUE
C
C   ***  CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO  ***
C   ***               AT LEVELS ABOVE THE LOWEST LEVEL                   ***
C
C   ***  FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES  ***
C   ***                      THROUGH EACH LEVEL                          ***
C
	DO 500 I=2,INB
	DPINV=0.01/(PH(I)-PH(I+1))
	CPINV=1.0/CPN(I)
	AMP1=0.0
	AD=0.0
	IF(I.GE.NK)THEN
	 DO 440 K=I+1,INB+1
  440    AMP1=AMP1+M(K)
	END IF
	DO 450 K=1,I
	DO 450 J=I+1,INB+1
	 AMP1=AMP1+MENT(K,J)
	 MUP(I)=AMP1
  450   CONTINUE
	IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4
	DO 470 K=1,I-1
	DO 470 J=I,INB
	AD=AD+MENT(J,K)
	MDOWN(I)=AD
  470   CONTINUE
	FT(I)=FT(I)+G*DPINV*(AMP1*(T(I+1)-T(I)+(GZ(I+1)-GZ(I))*
     1   CPINV)-AD*(T(I)-T(I-1)+(GZ(I)-GZ(I-1))*CPINV))
     2   -SIGD*LVCP(I)*EVAP(I)
	FT(I)=FT(I)+G*DPINV*MENT(I,I)*(HP(I)-H(I)+
     1    T(I)*(CPV-CPD)*(Q(I)-QENT(I,I)))*CPINV
	FT(I)=FT(I)+SIGD*WT(I+1)*(CL-CPD)*WATER(I+1)*
     1    (T(I+1)-T(I))*DPINV*CPINV
	FQ(I)=FQ(I)+G*DPINV*(AMP1*(Q(I+1)-Q(I))-
     1    AD*(Q(I)-Q(I-1)))
	FQSUB(I)=FQ(I)
	DO 480 K=1,I-1
	 AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
	 AWAT=MAX(AWAT,0.0)
	 FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-Q(I))
	 FQDET(I)=G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-Q(I))
  480   CONTINUE
	DO 490 K=I,INB
	 FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-Q(I))
	 FQDET(I)=FQDET(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-Q(I))
  490   CONTINUE
	FQ(I)=FQ(I)+SIGD*EVAP(I)+G*(MP(I+1)*
     1    (QP(I+1)-Q(I))-MP(I)*(QP(I)-Q(I-1)))*DPINV
	FQDET(I)=FQDET(I)+SIGD*EVAP(I)+G*(MP(I+1)*
     1    (QP(I+1)-Q(I))-MP(I)*(QP(I)-Q(I-1)))*DPINV
  500   CONTINUE
C
C   *** Adjust tendencies at top of convection layer to reflect  ***
C   ***       actual position of the level zero CAPE             ***
C
        FQOLD=FQ(INB)
        FQ(INB)=FQ(INB)*(1.-FRAC)
        FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PH(INB)-PH(INB+1))/
     1   (PH(INB-1)-PH(INB)))*LV(INB)/LV(INB-1)
        FTOLD=FT(INB)
        FT(INB)=FT(INB)*(1.-FRAC)
        FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PH(INB)-PH(INB+1))/
     1   (PH(INB-1)-PH(INB)))*CPN(INB)/CPN(INB-1)
C
C   ***   Very slightly adjust temperature tendencies to force exact   ***
C   ***                     enthalpy conservation                      ***
C
	ENTS=0.0
	DO 680 I=1,INB
	 ENTS=ENTS+(CPN(I)*FT(I)+LV(I)*FQ(I))*(PH(I)-PH(I+1))	
  680	CONTINUE
	ENTS=ENTS/(PH(1)-PH(INB+1))
	DO 640 I=1,INB
	 FT(I)=FT(I)-ENTS/CPN(I)
  640	CONTINUE
	DO 750 I=1,INB
	 DO 710 K=1,INB
	  DET(I)=DET(I)+MENT(K,I)
  710    CONTINUE
	 DO 720 K=1,INB
	  ENT(I)=ENT(I)+MENT(I,K)
  720    CONTINUE
	 ENT(I)=ENT(I)-MENT(I,I)
  750   CONTINUE
C
C   ***           RETURN           ***
C
	RETURN
  800   CONTINUE
	RETURN
	END
C
C ---------------------------------------------------------------------------
C
	SUBROUTINE TLIFT(P,T,Q,QS,GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
	REAL GZ(ND),TPK(ND),CLW(ND),P(ND)
	REAL T(ND),Q(ND),QS(ND),TVP(ND),LV0
C
C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
C
	CPD=1005.7
	CPV=1870.0
	CL=4190.0
        RV=461.5
	RD=287.04
	LV0=2.501E6
C
	CPVMCL=CL-CPV
	EPS=RD/RV
	EPSI=1./EPS
C
C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
C
	AH0=(CPD*(1.-Q(NK))+CL*Q(NK))*T(NK)+Q(NK)*(LV0-CPVMCL*(
     1   T(NK)-273.15))+GZ(NK)
	CPP=CPD*(1.-Q(NK))+Q(NK)*CPV
	CPINV=1./CPP
C
	IF(KK.EQ.1)THEN
C
C   ***   CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE   ***
C
	DO 50 I=1,ICB-1
	 CLW(I)=0.0
   50   CONTINUE
	DO 100 I=NK,ICB-1
	 TPK(I)=T(NK)-(GZ(I)-GZ(NK))*CPINV
	 TVP(I)=TPK(I)*(1.+Q(NK)*EPSI)
  100   CONTINUE
	END IF
C
C    ***  FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE    ***
C
	NST=ICB
	NSB=ICB
	IF(KK.EQ.2)THEN  
	 NST=NL
	 NSB=ICB+1
	END IF
	DO 300 I=NSB,NST
	 TG=T(I)
	 QG=QS(I)
	 ALV=LV0-CPVMCL*(T(I)-273.15)
	 DO 200 J=1,2
	  S=CPD+ALV*ALV*QG/(RV*T(I)*T(I))
	  S=1./S
	  AHG=CPD*TG+(CL-CPD)*Q(NK)*T(I)+ALV*QG+GZ(I)
	  TG=TG+S*(AH0-AHG)
	  TC=TG-273.15
	  DENOM=243.5+TC
	  DENOM=MAX(DENOM,1.0)
          IF(TC.GE.0.0)THEN  
	   ES=6.112*EXP(17.67*TC/DENOM)
          ELSE  
           ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
          END IF  
	  QG=EPS*ES/(P(I)-ES*(1.-EPS))
  200    CONTINUE
	 ALV=LV0-CPVMCL*(T(I)-273.15)
         TPK(I)=(AH0-(CL-CPD)*Q(NK)*T(I)-GZ(I)-ALV*QG)/CPD
	 CLW(I)=Q(NK)-QG
	 CLW(I)=MAX(0.0,CLW(I))
	 RG=QG/(1.-Q(NK))
	 TVP(I)=TPK(I)*(1.+RG*EPSI)
  300   CONTINUE
	RETURN
	END
      subroutine radia (np,nsb,pl,ta,wa,oa,cmc,cmh,cmn,ts,rsfc,
     $                  nc,cs,pctop,pcbot,taus,
     $                  sc,rlat,month,iday,hrl,cosz,icosz,
     $                  fnetir,fnetso,coolr,heatr,fdwnirs,flupirs)
c
c************************************************************************
c  this program computes ir & solar fluxes and cooling & heating
c  rates in the atmosphere.
c
c  input parameters:                              units    dimension
c     number of atmospheric layers (np)           n/d          1
c     number of sublayers in ecah layer (nsb)     n/d          1
c     level pressure (pl)                         mb          np+1
c     layer temperature (ta)                      k           np
c     layer specific humidity (wa)                gr/gr       np
c     layer ozone concentration (oa)              gr/gr       np
c     co2 mixing ratio by volumn (cmc)            parts/part   1
c     ch4 mixing ratio by volumn (cmh)            parts/part   1
c     n2o mixing ratio by volumn (cmn)            parts/part   1
c     surface temperature (ts)                    k            1
c     surface albedo (rsfc)                       fraction     1
c     number of cloud types (nc)                  n/d          1
c     cloud cover (cs)                            fraction    nc
c     cloud top   (pctop)                         mb          nc
c     cloud base  (pcbot)                         mb          nc
c     cloud optical thickness (taus)              n/d         nc
c     solar constant(sc)                          w/m**2       1
c     latitude (rlat)                             degree       1
c     month (month): 1 for january                month        1
c     day of month (iday, 1-31)                   day          1
c     local hour (hrl,0-24)                       hr           1
c     cosine of solar zenith angle (cosz)         n/d          1
c  the following two parameters must be specified:
c     icosz: cosz is given if icosz=1                          1
c            otherwise, cosz is computed from rlat,
c            month, iday and hrl
c     terman:the value of cosz below which                     1
c            solar fluxes are not computed
c
c  output parameters:
c     net downward ir flux (fnetir)                w/m**2     np+1
c     net downward solar flux (fnetso)             w/m**2     np+1
c     downward ir flux at the surface (fdwnirs)    w/m**2     1
c     upward ir flux at the surface   (flupirs)    w/m**2     1
c     ir cooling rate (coolr)                      c/day      np
c     solar heating rate (heatr)                   c/day      np
c
c  subroutines called:
c     irrad, sorad
c
c  note: 1) specified parameters are input from subroutine block data.
c        2) latitude, month, day, and hour are used for computing
c           the sun-earth distance and the solar zenith angle.
c        3) when layers are thick, it might be desirable to subdivide
c           each layer into a number of layers (i.e. nsb>1) for
c           accurate ir flux calculations.
c********************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
c  input parameters
      dimension pl(lay),ta(lay),wa(lay),oa(lay),taual(lay)
      dimension cs(nnc),pctop(nnc),pcbot(nnc),taus(nnc)
c  output variables
      dimension fnetir(lay),fnetso(lay)
      dimension coolr(lay),heatr(lay)
      data  terman/0.005/
c121191      data icosz/2/, terman/0.005/
c
c     print 30
   30 format (/,' ******   output of the program radia   *****')
c
c  check the range of temperature
c
	cmn=0.28E-6
      do 10 ip=1,np
      if(ta(ip).gt.160. .and. ta(ip).lt.340.) go to 10
         PRINT*,'ERROR AT RAD91: TEMP OUT OF RANGE '
         PRINT*,'P = ', PL(IP), ' T = ', TA(IP)
         PRINT*
c        print 5
   5     format(1x,' temperature is outside the range where fitting ',
     $              'for planck flux is valid.')
       stop 'rad t'
  10  continue
c
c  npp1 = surface level
      npp1 = np + 1
c
c  call irrad for thermal radiation if ifir=1
c  call sorad for solar radiation if ifso=1
      ifir = 1
      ifso = 1
*     print 22,ifir,ifso
  22  format(1x,'flag of calling ir=',i2,3x,'flag of calling solar=',i2)
c
c  initialization
c
      fdwnirs=0.0
      flupirs=0.0
C
      do 23 i=1,npp1
      fnetir(i)=0.
      fnetso(i)=0.
      coolr(i) =0.
      heatr(i) =0.
  23  continue
c
      if(ifir.eq.1) then
c        Cirrus cloud are treated as half-black...
cc         cs(1) = 0.5 * cs(1)
         call irrad(np,nsb,nc,cs,pctop,pcbot,
     $   pl,ta,wa,oa,ts,cmc,cmh,cmn,fnetir,coolr,fdwnirs,flupirs)
cc         cs(1) = 2.0 * cs(1)
      endif
c
      if(ifso.ne.1)  go to 999
c
c------------------------------------------------------------------------
c  compute solar zenith angle
c  if "icosz" is not equal to 1, the cosine of solar zenith angle,
c  cosz, is calculated from latitude, month, day, and local hour.
c  computation of the solar zenith angle follows roger davies
c  (nasa tm 83961, 1982)
c
*     print 2341, icosz,cosz,terman
 2341 format (' icosz,cosz,terman=', i4,2f10.3)
      if(icosz.ne.1) then
         fac=.01745
         x=float((month-1)*30+iday+month/2)
         xlat=rlat*fac
         phi=2.*3.14159*x/365.
         tphi=phi*2.
         ttphi=phi*3.
         cosphi=cos(phi)
         sinphi=sin(phi)
         costph=cos(tphi)
         sintph=sin(tphi)
         costtp=cos(ttphi)
         sinttp=sin(ttphi)
         delta=.006918-0.399912*cosphi+0.070257*sinphi-0.006758*
     *          costph+0.000907*sintph-0.002697*costtp+.00148*sinttp
         anx=(hrl-12.)*15.*fac
         eq=.000075+.001868*cosphi-.032077*sinphi-.014615*costph
     *       -.040849*sintph
         ang=anx+eq
         cosz=sin(xlat)*sin(delta)+cos(xlat)*cos(delta)*cos(ang)
      endif
c
c------------------------------------------------------------------------
c
c  if the sun's altitude is low (cosz less than terman), solar
c  fluxes are not computed.
      if(cosz.lt.terman) go to 999
c
c------------------------------------------------------------------------
c
c  compute incoming solar flux at the top of the atmosphere, s0, by
c  taking into account the effect of the sun-earth distance
c
      rad=3.1415926/180.
      alop=78.
      eccen=0.0178
      if(month.le.3) month=month+12
      date=float((month-4)*30+iday+10)/360.
      ang=6.28318*date+rad*alop
      dst=1.+eccen*cos(ang)
      dmean=1.-eccen**2
c     s0=sc*(dst/dmean)**2
           s0=sc
c     print 99,month,iday,date,ang,dst,dmean,sc,s0
   99 format(' m,day,date,ang,dst,dm,sc,s0=',2i3,2f6.2,2f7.4,2f7.1)
c
c
      rsfcir = rsfc 
      rsfcuv = rsfc 
      DO 541 I = 1, NP
         TAUAL(I) = 0.0
541   CONTINUE
c
      call sorad(np,nc,cs,pctop,pcbot,taus,taual,pl,ta,wa,oa,
     $                 cmc,rsfcir,rsfcuv,sc,cosz,icosz,
     $                 rlat,month,iday,hrl,fnetso,heatr)
c                                           
c====================== print out input data ==========================
c
  999 continue
c  print out input information
*     print 32,np
   32 format(/,' number of pressure layers:',i4)
*     print 34,nsb
   34 format(1x,'number of sublayers in each pressure layer:',i3)
*     if(ifso.eq.1) print 36,s0
   36 format(1x,'incoming solar flux:',f7.1)
*     if(ifso.eq.1) print 38,cosz
   38 format(1x,'the cosine of solar zenith angle:',f6.3)
*     print 40,rsfc,ts
   40 format(1x,'surface albedo:',f5.2,/,1x,'surface temperature:',f8.2)
*     print 42,cmc,cmh,cmn
   42 format(1x,'co2, ch4, and n2o mixing ratios:',3e10.2)
*     print 44,nc
   44 format(1x,'cloud information:',/,4x,'number of cloud types:',i3)
*     if(nc.ne.0)print 46,(i,cs(i),pctop(i),pcbot(i),taus(i),i=1,nc)
   46 format(/,4x,'type',2x,'amount',2x,'top(mb)',2x,'base(mb)',2x,
     $    'optical thickness',/,4x,i3,3x,f5.2,3x,f6.0,3x,f7.0,6x,f6.1)
c     print 50
   50 format(/,10x,'pressure levels(mb) of sample profile')
c     print 52,(pl(i),i=1,npp1)
   52 format(5(6x,f9.3))
c     print 54
   54 format(/,10x,'layer temperatures (k)')
c     print 56,(ta(i),i=1,np)
   56 format(5(5x,f8.2))
c     print 58
   58 format(/,10x,'layer humidity concentration (gm/gm)')
c     print 60,(wa(i),i=1,np)
   60 format(5(5x,e9.3))
c     print 62
   62 format(/,10x,'layer ozone concentration (gm/gm)')
c     print 60,(oa(i),i=1,np)
c
c========================= print out results ========================
c
c  print out ir & solar fluxes and cooling or heating rate
*     print 70
   70 format(//,2x,'pressure',4x,'ir flux',4x,'solar flux',7x,
     $'cooling',4x,'heating')
*     print 72
   72 format(4x,'(mb)',7x,'(watts/cm**2)',12x,'(degree celcius/day)')
c
      do 76 ip=1,np
*     print 75,pl(ip),fnetir(ip),fnetso(ip),coolr(ip),heatr(ip)
   76 continue
*     print 75,pl(npp1),fnetir(npp1),fnetso(npp1)
   75 format(1x,f8.3,5x,f7.2,6x,f7.2,8x,f7.2,4x,f7.2)
c-----------------------------------------------------------------------
 1000 continue
      return
      end
c***********************************************************************
      subroutine irrad
     $  (np,nsb,nc,cs,pctop,pcbot,pl,ta,wa,oa,ts,cmc,cmh,cmn,
     $   fnetir,coolr,fdwnirs,flupirs)
c***********************************************************************
c  this subroutine computes ir fluxes and cooling rate
c
c  input parameters:
c     np,nsb,nc,cs,pctop,pcbot,pl,ta,wa,oa,ts,cmc,cmh,cmn
c
c  required data:
c     auc,c1,c2,auo,o1,o2: precomputed tables for co2 and o3
c                          transmission calculations
c
c  output parameters:
c     fnetir: net downward ir flux (w/m**2)
c     coolr : ir cooling rate (degree celcius/day)
c
c  subroutines called: irh2oc
c                      irh2ow
c                      irh2om
c                      irco2
c                      iro3
c                      irtrc1
c                      irtrc2
c                      irtrc3
c***********************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension pl(lay),ta(lay),wa(lay),oa(lay),pa(lay)
      dimension pai(lay),tai(lay),rawi(lay),oai(lay)
      dimension pui(lay),dpi(lay)
      dimension fluxuh(lay),fluxdh(lay),fluxuc(lay),fluxdc(lay)
      dimension fluxuw(lay),fluxdw(lay),fluxwm(lay)
      dimension rfluxu(lay),rfluxd(lay),rfluxu3(lay),rfluxd3(lay)
      dimension rfluxu1(lay),rfluxd1(lay),rfluxu2(lay),rfluxd2(lay)
      dimension fnetir(lay),coolr(lay)
      dimension ubar(lay),wbarc(lay),wbarw(lay),heit(lay)
      dimension pctop(nnc),pcbot(nnc),cs(nnc)
      dimension icb(nnc),ict(nnc)
c
c-----------------------------------------------------------------------
c
c  npp1 = surface level
c
      npp1 = np + 1
c
      do 10 ip=1,np
      pa(ip)=.5*(pl(ip)+pl(ip+1))
   10 continue
      pa(npp1) = pl(npp1)
      ta(npp1) = ts
c
c====================== subdivision of layers ==========================
c
c in computing fluxes at each of the (np+1) levels, each of the
c np layers is divided into nsb sublayers.
c therefore, the total number of sublevels is npt.
c sublayers and sublevels are arranged in such a way that the indices for
c the surface layer and the surface level are both npt
c
      npt = np*nsb +1
c
c identify the layer closest to the 20-mb level for the purpose of
c merging the middle and lower atmospheric water vapor cooling rates
c the index "ipst" is to be used in the subroutine "irh2om"
c
      ipst=0
  31  ipst=ipst+1
      if(pa(ipst).le.20.) go to 31
      ipst=ipst-1
*     print 32,ipst
  32  format(1x,' ipst=',i4)
c
c===== pressure, temperature, humidity, and ozone interpolations =======
c
c      pui is sublevel pressure.
c      pai is the mean pressure of a sublayer.
c      tai is the sublayer temperature.
c      rawi is the sublayer specific humidity.
c      oai is the sublayer ozone mixing ratio.
c
      ix=1
      pui(1)=pl(1)
      do 20 i=1,np
      ddd=(pl(i+1)-pl(i))/float(nsb)
      do 20 k=1,nsb
      ix=ix+1
      dpi(ix)=ddd
      pui(ix)=pui(ix-1)+ddd
      pai(ix)=.5*(pui(ix)+pui(ix-1))
   20 continue
c
      nck=2
      do 30 ix=2,npt
   24 if( pai(ix) .lt. pa(nck)) go to 25
      if(nck .eq. np) go to 25
      nck=nck+1
      go to 24
   25 continue
      xx=alog(wa(nck-1))
      x1=alog(pai(ix)/pa(nck-1))
      x2=alog(wa(nck)/wa(nck-1))
      x3=alog(pa(nck)/pa(nck-1))
      rawi(ix)=exp(xx+x1*x2/x3)
      oai(ix)=oa(nck-1)+x1/x3*(oa(nck)-oa(nck-1))
      tai(ix)=ta(nck-1)+x1/x3*(ta(nck)-ta(nck-1))
   30 continue
      oai(1)=oai(2)
      tai(1)=tai(2)
*     print 33,(i,pai(i),dpi(i),tai(i),rawi(i),oai(i),i=1,npt)
   33 format(1x,i4,2x,2f8.3,2x,f6.2,2x,e12.4,2x,e12.4)
c
c===================== compute scaled water vapor amounts ===============
c   wbarc: for molecular absorption in the band-center region;
c   wbarw: for molecular absorption in the band-wing region;
c   ubar: for continuum absorption
c
      ubar(1)=0.
      wbarc(1)=0.0
      wbarw(1)=0.0
      do 44 ix=2,npt
      wbarc(ix)=wbarc(ix-1)+1.02*rawi(ix)*dpi(ix)
     * *(pai(ix)/275.0)*exp(0.005*(tai(ix)-225.0))
      wbarw(ix)=wbarw(ix-1)+1.02*rawi(ix)*dpi(ix)
     * *(pai(ix)/550.0)*exp(0.016*(tai(ix)-256.0))
      xx=(pai(ix)/630.)*rawi(ix)*rawi(ix)*dpi(ix)*1.02
      xx=xx*exp(1800./tai(ix)-6.0811)
      ubar(ix)=ubar(ix-1)+xx
c     print 45,wbarc(ix),wbarw(ix),ubar(ix)
   45 format(1x,'wbarc,wbarw,ubar=',3f10.5)
   44 continue
c
c=============== identify indices for cloud top and base ===============
c  pctop and pcbot are, respectively, the cloud top and base pressures
c  ict and icb are, respectively, indices for cloud top and base levels
c
      if(nc.eq.0)goto 77
      do 73 ic=1,nc
      if(pcbot(ic).gt.pl(npp1)) pcbot(ic)=pl(npp1)
      ix=1
   52 ix=ix+1
      if(pui(ix).lt.pctop(ic))goto 52
   54 ut=pctop(ic)-pui(ix-1)
      ub=pui(ix)-pctop(ic)
      ict(ic)=ix
      if(ut.lt.ub) ict(ic)=ix-1
      ix=ict(ic)-1
   64 ix=ix+1
      if(pui(ix).lt.pcbot(ic))goto 64
   66 ut=pcbot(ic)-pui(ix-1)
      ub=pui(ix)-pcbot(ic)
      icb(ic)=ix
      if(ut.lt.ub) icb(ic)=ix-1
      if(ict(ic).eq.icb(ic)) ict(ic)=ict(ic)-1
C      write(*, 72)ic,ict(ic),icb(ic)
   72 format (' ic,ict,icb=',3i4)
   73 continue
   77 continue
c
c ========================  flux calculations =========================
c
c     fluxuh: upward flux in h20 band
c     fluxdh: downward flux in h2o band
c     fluxuc: upward flux in 15 micron band
c     fluxdc: downward flux in 15 micron band
c     fluxuw: upward flux in 9.6 micron band
c     fluxdw: downward flux in 9.6 micron band
c     fluxwm: net downward flux in the middle atmosphere in h2o band
c             (0-540 and 1380-1900 /cm)
c     rfluxu: reduction of upward flux due to n2o and ch4
c     rfluxd: reduction of downward flux due to n2o and ch4
c             (note: the units for all output fluxes are w/m**2)
c
c flux initialization
c
      do 100 ip=1,npp1
      fluxuh(ip)=0.
      fluxdh(ip)=0.
      fluxuc(ip)=0.
      fluxdc(ip)=0.
      fluxuw(ip)=0.
      fluxdw(ip)=0.
      fluxwm(ip)=0.
      rfluxu1(ip)=0.
      rfluxd1(ip)=0.
      rfluxu2(ip)=0.
      rfluxd2(ip)=0.
      rfluxu3(ip)=0.
      rfluxd3(ip)=0.
  100 continue
c
      call irh2oc(np,nsb,nc,cs,icb,ict,tai,wbarc,ts,
     $                         fluxuh,fluxdh)
      call irh2ow(np,nsb,nc,cs,icb,ict,tai,ubar,wbarw,ts,
     $                         fluxuh,fluxdh)
      call irh2om(np,nsb,ipst,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $                             fluxwm)
      call irco2(np,nsb,nc,cs,icb,ict,pai,tai,
     $                        dpi,ts,cmc,ubar,wbarw,
     $                        fluxuc,fluxdc)
      call iro3(np,nsb,nc,cs,icb,ict,pai,tai,
     $                      oai,dpi,ts,ubar,wbarw,
     $                      fluxuw,fluxdw)
c  compute reductions of ir flux in the spectral region 1215-1380 cm-1
c  due to ch4 and n2o
      call irtrc1(np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $              cmh,cmn,
     $              rfluxu1,rfluxd1)
c  compute reductions of ir flux in the spectral region 1135-1215 cm-1
c  due to n2o
      call irtrc2(np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $              cmn,ubar,
     $              rfluxu2,rfluxd2)
c  compute reductions of ir flux in the spectral region 560-615 cm-1
c  due to n2o
      call irtrc3(np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $              cmc,cmn,ubar,
     $              rfluxu3,rfluxd3)
c
c ===================== print out ir fluxes =========================
c
*      write(*,70)
*   70 format(//,2x,'pressure',5x,'h2o bands',7x,
*     $ 'co2 band',6x,'ozone band',5x,'reduction')
*      write(*,71)
*   71 format(5x,'(mb)',40x,'(watts/cm**2)')
*      write(*,74)
*   74 format(15x,'down',3x,'up',7x,'down',3x,'up',5x,'down',3x,'up',
*     $ 6x,'down',3x,'up',/)
c
      do 76 ip=1,npp1
      rfluxd(ip)=rfluxd1(ip)+rfluxd2(ip)+rfluxd3(ip)
      rfluxu(ip)=rfluxu1(ip)+rfluxu2(ip)+rfluxu3(ip)
*      write(*,75)pl(ip),fluxdh(ip),fluxuh(ip),fluxdc(ip),fluxuc(ip),
*     $        fluxdw(ip),fluxuw(ip),rfluxd(ip),rfluxu(ip)
*   75 format(1x,f7.2,3x,4(1x,2f7.2))
   76 continue
c
c  compute cooling rate profile
c  water vapor cooling rates are computed differently in the middle
c  atmosphere (pressure < 20mb) and the lower atmosphere (pressure > 20mb)
c
      fac=3.6*24./10.03*.98
      do 80 ip=1,np
      ipp1=ip+1
      if(ip.gt.ipst) then
         x1=fluxdh(ip)-fluxuh(ip)+fluxdc(ip)-fluxuc(ip)
     $     +fluxdw(ip)-fluxuw(ip)-(rfluxd(ip)-rfluxu(ip))
         x2=fluxdh(ipp1)-fluxuh(ipp1)+fluxdc(ipp1)-fluxuc(ipp1)
     $     +fluxdw(ipp1)-fluxuw(ipp1)-(rfluxd(ipp1)-rfluxu(ipp1))
      else
         x1=fluxwm(ip)+fluxdc(ip)-fluxuc(ip)
     $     +fluxdw(ip)-fluxuw(ip)-(rfluxd(ip)-rfluxu(ip))
         x2=fluxwm(ipp1)+fluxdc(ipp1)-fluxuc(ipp1)
     $     +fluxdw(ipp1)-fluxuw(ipp1)-(rfluxd(ipp1)-rfluxu(ipp1))
      endif
      coolr(ip)=(x2-x1)*fac/(pl(ipp1)-pl(ip))
   80 continue
c
c  re-compute net downward fluxes from the cooling profile
c

      fnetir(npp1) = x2
      do 101 ip=npp1-1,1,-1
      fnetir(ip)=fnetir(ip+1)-coolr(ip)*(pl(ip+1)-pl(ip))/fac
  101 continue
c
c  compute the downward and upward fluxes at the surface (Nilton Renno)
c
      fdwnirs= fluxdh(npp1)+fluxdc(npp1)+fluxdw(npp1)-rfluxd(npp1)
      flupirs=-fluxuh(npp1)-fluxuc(npp1)-fluxuw(npp1)+rfluxu(npp1)

c      print*, '  P = ', pl(npp1),'   AFNETIR = ', fnetir(npp1)
   
      return
      end
c************************************************************************
      subroutine irh2oc(np,nsb,nc,cs,icb,ict,tai,wbarc,ts,
     $                  fluxuh,fluxdh)
c************************************************************************
c  this subroutine is for computing ir fluxes in the water vapor
c  spectral regions 0-340 and 1380-1900 cm-1.
c  accuracy in cooling rate is better than 0.1 c/day below the
c  10-mb level.
c
c  input parameters:
c     np,nsb,nc,cs,icb,ict,tai,wbarc,ts
c
c  output parameters:
c     fluxuh: upward flux
c     fluxdh: downward flux
c
c  external function used: tauc
c******************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension fluxuh(lay),fluxdh(lay),flux(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
      dimension wbarc(lay),tai(lay)
      dimension tcnt(2),bk(lay),ccnt(lay)
c
c  plk is the function fitting to the spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
c
      npp1 = np + 1
      npt = np*nsb + 1
c
c =============  compute planck functions, bk and bs =============
c
      do 12 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(0.86724,-5.88664,24.99984,-19.46123,1.570,tt)
   12 continue
      tt=ts/100.
      bs=plk(0.86724,-5.88664,24.99984,-19.46123,1.570,tt)
c     print 15,(bk(i),i=1,npt),bs
   15 format(10f7.2)
c
c =================  compute downward fluxes ===================
c
      do 70 ip=2,npp1
      is=(ip-1)*nsb+1
      ism1=is-1
      flux(is)=0.
c  this do-loop is for computing the intermediate fluxes, flux
      do 55 lp=1,ism1
      ix=is-lp
c
      kt=ix-1
c  kt is the index for the boundaries of a sublayer
      do 51 it=1,2
      kt=kt+1
      if(kt.eq.is) go to 46
c  compute the transmittance, tcnt
      dw=wbarc(is)-wbarc(kt)
      tcnt(it)=tauc(dw,tai(ix+1))
      go to 47
   46 tcnt(it)=1.0
   47 continue
      if(it.eq.2) ccnt(kt)=tcnt(it)
   51 continue
      flux(ix)=flux(ix+1)+bk(ix+1)*(tcnt(2)-tcnt(1))
   55 continue
      if(nc.ne.0)goto 59
      fluxdh(ip)=fluxdh(ip)+flux(1)
      goto 70
   59 continue
c  for cloud atmosphere
      sumc=0.
      do 65 ic=1,nc
      ncbx=icb(ic)
      if(is.le.ict(ic))goto 65
      if(is.le.ncbx)goto 62
      fluxdh(ip)=fluxdh(ip)+(flux(ncbx)+bk(ncbx)*ccnt(ncbx))*cs(ic)
      goto 63
   62 continue
      fluxdh(ip)=fluxdh(ip)+bk(is)*cs(ic)
   63 sumc=sumc+cs(ic)
c     if (is.gt.84) print 91, is,ncbx,flux(ncbx),bk(ncbx),ccnt(ncbx)
   91 format (' xxxx',2i5,3f12.3)
   65 continue
      fluxdh(ip)=fluxdh(ip)+flux(1)*(1.-sumc)
   70 continue
c     print 28,(fluxdh(ip),ip=1,npp1)
   28 format(' fluxdh=',12f6.0)
c
c ===================  compute upward fluxes ===================
c
      do 80 ip=1,np
      is=(ip-1)*nsb+1
      isp1=is+1
      flux(is)=0.
c  this do-loop is for computing the intermediate fluxes, flux
      do 75 ix=isp1,npt
      kt=ix+1
c  kt is the index of the boundaries of a sublayer
      do 52 it=1,2
      kt=kt-1
      if(kt.eq.is) go to 57
      dw=wbarc(kt)-wbarc(is)
      tcnt(it)=tauc(dw,tai(ix))
      go to 58
   57 tcnt(it)=1.0
   58 continue
      if(it.eq.2) ccnt(kt)=tcnt(it)
   52 continue
      flux(ix)=flux(ix-1)+bk(ix)*(tcnt(2)-tcnt(1))
   75 continue
      flux(npt)=flux(npt)+bs*tcnt(1)
      if(nc.ne.0)goto 76
      fluxuh(ip)=fluxuh(ip)+flux(npt)
      goto 80
   76 continue
c  for cloud atmosphere
      sumc=0.
      do 64 ic=1,nc
      nctx=ict(ic)
      if(is.ge.icb(ic))goto 64
      if(is.ge.nctx)goto 66
      fluxuh(ip)=fluxuh(ip)+(flux(nctx)+bk(nctx+1)*ccnt(nctx))*cs(ic)
      goto 67
   66 continue
      fluxuh(ip)=fluxuh(ip)+bk(is+1)*cs(ic)
   67 sumc=sumc+cs(ic)
   64 continue
      fluxuh(ip)=fluxuh(ip)+flux(npt)*(1.-sumc)
   80 continue
c
      fluxuh(npp1)=fluxuh(npp1)+bs
c     print 29,(fluxuh(ip),ip=1,npp1)
  29  format(' fluxuh=',12f6.0)
      return
      end
c************************************************************************
      subroutine irh2ow(np,nsb,nc,cs,icb,ict,tai,ubar,wbarw,ts,
     $                  fluxuh,fluxdh)
c************************************************************************
c  this subroutine is for computing ir fluxes in the water vapor
c  spectral regions 340-540, 800-980, 1100-1380 and 1900-3000 cm-1.
c  accuracy in cooling rate is better than 0.1 c/day.
c
c  input parameters:
c     np,nsb,nc,cs,icb,ict,tai,ubar,wbarw,ts
c
c  output parameters:
c     fluxuh: upward flux
c     fluxdh: downward flux
c
c  external function used: tauw
c******************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension fluxuh(lay),fluxdh(lay),flux(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
      dimension ubar(lay),wbarw(lay),tai(lay)
      dimension twng(2),bk(lay),cwng(lay)
c
c  plk is the function fitting to the spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
c
      npp1 = np + 1
      npt = np*nsb + 1
c
c ==============  compute planck functions, bk and bs ==============
c
      do 12 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(0.00058,2.69866,-1.51742,0.13576,2.020,tt)
   12 continue
      tt=ts/100.
      bs=plk(0.00058,2.69866,-1.51742,0.13576,2.020,tt)
c
c =================  compute downward fluxes ==================
c
      do 70 ip=2,npp1
      is=(ip-1)*nsb+1
      ism1=is-1
      flux(is)=0.
c  this do-loop is for computing the intermediate fluxes, flux
      do 55 lp=1,ism1
      ix=is-lp
      kt=ix-1
c  kt is the index of the boundaries of a sublayer
      do 51 it=1,2
      kt=kt+1
      if(kt.eq.is) go to 48
c  compute the transmittance, twng
      dw=wbarw(is)-wbarw(kt)
      du=ubar(is)-ubar(kt)
c          du=0.0001
      twng(it)=tauw(dw,du,tai(ix+1))
      go to 49
   48 twng(it)=1.0
   49 continue
      if(it.eq.2) cwng(kt)=twng(it)
   51 continue
      flux(ix)=flux(ix+1)+bk(ix+1)*(twng(2)-twng(1))
   55 continue
      if(nc.ne.0)goto 59
      fluxdh(ip)=fluxdh(ip)+flux(1)
      goto 70
   59 continue
c  for cloud atmosphere
      sumc=0.
      do 65 ic=1,nc
      ncbx=icb(ic)
      if(is.le.ict(ic))goto 65
      if(is.le.ncbx)goto 62
      fluxdh(ip)=fluxdh(ip)+(flux(ncbx)+bk(ncbx)*cwng(ncbx))*cs(ic)
      goto 63
   62 continue
      fluxdh(ip)=fluxdh(ip)+bk(is)*cs(ic)
   63 sumc=sumc+cs(ic)
   65 continue
      fluxdh(ip)=fluxdh(ip)+flux(1)*(1.-sumc)
   70 continue
c     print 28,(fluxdh(ip),ip=1,npp1)
   28 format(1x,'fluxdh=',12f6.0)
c
c ===================  compute upward fluxes =====================
c
      do 80 ip=1,np
      is=(ip-1)*nsb+1
      isp1=is+1
      flux(is)=0.
c  this do-loop is for computing the intermediate fluxes, flux
      do 75 ix=isp1,npt
      kt=ix+1
c  kt is the index of the boundaries of a sublayer
      do 52 it=1,2
      kt=kt-1
      if(kt.eq.is) go to 83
c  compute the transmittance, twng
      dw=wbarw(kt)-wbarw(is)
      du=ubar(kt)-ubar(is)
c        du=0.0001
      twng(it)=tauw(dw,du,tai(ix))
      go to 84
   83 twng(it)=1.0
   84 continue
      if(it.eq.2) cwng(kt)=twng(it)
   52 continue
      flux(ix)=flux(ix-1)+bk(ix)*(twng(2)-twng(1))
   75 continue
      flux(npt)=flux(npt)+bs*twng(1)
      if(nc.ne.0)goto 76
      fluxuh(ip)=fluxuh(ip)+flux(npt)
      goto 80
   76 continue
c  for cloud atmosphere
      sumc=0.
      do 64 ic=1,nc
      nctx=ict(ic)
      if(is.ge.icb(ic))goto 64
      if(is.ge.nctx)goto 66
      fluxuh(ip)=fluxuh(ip)+(flux(nctx)+bk(nctx+1)*cwng(nctx))*cs(ic)
      goto 67
   66 continue
      fluxuh(ip)=fluxuh(ip)+bk(is+1)*cs(ic)
   67 sumc=sumc+cs(ic)
   64 continue
      fluxuh(ip)=fluxuh(ip)+flux(npt)*(1.-sumc)
   80 continue
c
      fluxuh(npp1)=fluxuh(npp1)+bs
c     print 29,(fluxuh(ip),ip=1,npp1)
  29  format(1x,'fluxuh=',12f6.0)
      return
      end
c
c************************************************************************
      subroutine irh2om(np,nsb,ipst,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $                             fluxwm)
c************************************************************************
c compute middle atmosppheric ir cooling rate due to h2o.
c accuracy in cooling rate is better than 0.10 c/day above
c the 60-mb level.
c results below the 60-mb level are not accurate.
c reference: chou, kratz, and ridgeway (j. climate, 1990)
c
c input parameters:
c    np,nsb,ipst,nc,cs,icb,ict,pai,tai,rawi,dpi,ts
c
c output parameters:
c   fluxwm: net downward (downward minus upward) fluxes
c
c subroutine called: flxcom
c************************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension sw(lay),sp(lay),st(lay),bk(lay)
      dimension tauf(lay,lay),fluxwm(lay)
      dimension fluxd(lay),fluxu(lay)
      dimension pai(lay),tai(lay),rawi(lay),dpi(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
c
c  plk is the function fitting to the spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
c
      npp1 = np + 1
      npt = np*nsb + 1
      ipstp1=ipst+1
c
c ==============  compute planck functions, bk and bs ==============
c
      do  2 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(0.10528,-0.11541,17.44984,-16.46303,1.910,tt)
    2 continue
      tt=ts/100.
      bs=plk(0.10528,-0.11541,17.44984,-16.46303,1.910,tt)
c     print 21,(bk(ix),ix=1,npt),bs
   21 format(10f7.2)
c
c  compute vertically integrated quantities, sw, sp, and st.
      sw(1)=0.
      sp(1)=0.
      st(1)=0.
      do 45 ix=2,npt
      ww=1.02*rawi(ix)*dpi(ix)
      sw(ix)=ww+sw(ix-1)
      sp(ix)=pai(ix)*ww+sp(ix-1)
      st(ix)=ww*tai(ix)+st(ix-1)
   45 continue
c
c=============== compute transmission functions ======================
c
      do 26 i=1,ipstp1
      is=(i-1)*nsb+1
      do 26 j=1,npt
      if (is.eq.j) then
      tauf(j,i)=1.
      else
      w=abs(sw(is)-sw(j))
      x=alog(w)
      tr=-2.5  +0.264*x-0.01*x*x
      tr=1.-exp(tr)
      peff=(sp(is)-sp(j))/(sw(is)-sw(j))
      teff=(st(is)-st(j))/(sw(is)-sw(j))
      dt=teff-250.
      aw=.9999147+.07489*w**.40+1.8286*w**0.8
      bw=-.0000826+.07124*w**.40+1.807*w**0.8
      tauf(j,i)=tr*(aw-bw*(peff/.251)**.4)
      tauf(j,i)=1.-(1.-tauf(j,i))*exp(0.00406*dt)
      if(tauf(j,i).lt.0.) tauf(j,i)=0.
      if(tauf(j,i).gt.1.) tauf(j,i)=1.
      endif
   26 continue
c
c  compute fluxes
      call flxcom(np,nsb,bk,bs,tauf,nc,cs,icb,ict,1,fluxu,fluxd)
c
      do 62 i=1,ipstp1
      fluxwm(i)=fluxd(i)-fluxu(i)
  62  continue
      return
      end
c**********************************************************************
      function tauc(dw,tai)
c**********************************************************************
c  compute water vapor transmission function in the band-center regions
c  0-340 and 1380-1900 /cm
c  dw : scaled water vapor amount
c  tai: temperature
c---------------------------------------------------------------------
c
      tu(a,b,c,w)=a+b*w+c*w**2
c
      t250=exp(-7790.*dw/(1.+1340.*dw**0.59+550.*dw))
      rlogw=alog(dw)
      al=tu(5.18,0.51,0.0,rlogw)
      alpha=exp(al)*1.0e-4
      bt=tu(4.61,0.71,0.014,rlogw)
      beta=exp(bt)*1.0e-6
      tauc=t250*(1.+alpha*(tai-250.)+beta*(tai-250.)**2)
      if(tauc.gt.1.) tauc=1.
      if(tauc.lt.0.) tauc=0.
      return
      end
c********************************************************************
      function tauw(dw,du,tai)
c********************************************************************
c  compute water vapor transmission function in the band-wing regions
c  340-500, 800-980, 1100-1380, and 1900-3000 /cm
c  dw : scaled water vapor amount for line absorption
c  du : scaled water vapor amount for continuum absorption
c  tai: temperature
c---------------------------------------------------------------------
c
      tu(d,e,f,w)=d+e*w+f*w**2
c
      ta=-230.*dw/(1.+200.*dw**0.60+130.*dw)
      rlogw=alog(dw)
c     tb=tu(17.63,-1.87,-0.069,rlogw)
      tb=tu(17.51,-2.51,-0.046,rlogw)
      t250=exp(ta-tb*du)
      aa=tu(3.77,0.174,-0.032,rlogw)
      aa=exp(aa)
      ab=tu(587.,-102.,-35.,rlogw)
      alpha=(aa+ab*du)*1.0e-4
      ba=tu(2.65,0.249,-0.025,rlogw)
      ba=exp(ba)
      beta=(-ba+140.*du)*1.0e-6
      tauw=t250*(1.+alpha*(tai-250.)+beta*(tai-250.)**2)
      if(tauw.gt.1.) tauw=1.
      if(tauw.lt.0.) tauw=0.
      return
      end
c**********************************************************************
      subroutine irco2(np,nsb,nc,cs,icb,ict,pai,tai,dpi,ts,cmc,
     $                 ubar,wbarw,
     $                 fluxuc,fluxdc)
c**********************************************************************
c compute ir fluxes in the spectral region 540-800 cm-1.
c absorption is due to co2 and h2o.
c accuracy in cooling rate is better than 0.3 c/day
c
c input parameters:
c    np,nsb,nc,cs,icb,ict,pai,tai,dpi,ts,cmc,
c    ubar,wbarw
c
c specified parameters:
c    auc: precomputed transmission functions
c    c1 and c2: coefficients for correcting the effect of temperature
c               on the transmission functions
c
c output parameter:
c        fluxuc: upward flux
c        fluxdc: downward flux
c
c subroutines called: transm and flxcom
c****************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension bk(lay),tauf(lay,lay),wc(lay)
      dimension fluxuc(lay),fluxdc(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
      dimension ubar(lay),wbarw(lay)
      dimension pai(lay),tai(lay),dpi(lay)
      dimension aux(26,21),t1(26,21),t2(26,21)
      common/co2/auc(26,21),c1(26,21),c2(26,21)
c
c  plk is the function fitting to the spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
      tran(a,b,xm,w)=exp(-a*w/(1.+b*w**xm))
c
      npp1 = np + 1
      npt = np*nsb + 1
c
c =============== compute planck functions, bk and bs  ===============
c
      do  2 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(-0.71668,14.77184,-35.20000,24.96629,1.440,tt)
    2 continue
      tt=ts/100.
      bs=plk(-0.71668,14.77184,-35.20000,24.96629,1.440,tt)
c     print 21,(bk(ix),ix=1,npt),bs
   21 format(10f7.2)
c
c ================== compute co2 amount (wc)  ====================
c                    units are (cm-atm)stp
      do 5 lp=2,npt
      wc(lp)=cmc*789.*dpi(lp)
    5 continue
c     print 3,(dpi(lp),wc(lp),lp=2,npt)
   3  format(1x,'dpi,wc=',10f7.2)
c
c  tauf is the transmittance in the 15 micron band
c
      do 8 i=1,npp1
      do 8 j=1,npt
      tauf(j,i)=1.0
  8   continue
c
      do 9 j=1,21
      do 9 i=1,26
      aux(i,j)=auc(i,j)
      t1(i,j)=c1(i,j)
      t2(i,j)=c2(i,j)
  9   continue
      rlog1=-3.
      dlogw=0.3
c  compute co2 transmission functions
      call transm(np,nsb,pai,tai,rlog1,dlogw,wc,aux,t1,t2,tauf)
c
c ============= compute water vapor transmisison functions ===========
c   x: mean transmission due to h2o line absorption
c   y: mean transmission due to h2o continuum absorption
c
      do 28 ip=1,npp1
      is=(ip-1)*nsb+1
      do 32 ix=1,npt
      if(is .eq. ix) go to 32
      dx=abs(wbarw(is)-wbarw(ix))
      x=tran(6.7,16.,0.6,dx)
      dx=abs(ubar(is)-ubar(ix))
      dx=27.*dx**.83
      if (dx.lt.0.005) go to 38
      y=1./exp(dx)
      go to 40
   38 continue
      y=1.-dx
   40 continue
      tauf(ix,ip)=tauf(ix,ip)*x*y
c     tauf(ix,ip)=x
   32 continue
   28 continue
c
c  compute fluxes
      call flxcom(np,nsb,bk,bs,tauf,nc,cs,icb,ict,1,fluxuc,fluxdc)
c
      return
      end
c**********************************************************************
      subroutine iro3(np,nsb,nc,cs,icb,ict,pai,tai,oai,dpi,ts,
     $                 ubar,wbarw,
     $                 fluxuw,fluxdw)
c**********************************************************************
c compute ir fluxes in the spectral region 980-1100 cm-1.
c absorption is due to o3 and h2o.
c accuracy in cooling rate is better than 0.1 c/day
c
c input parameters:
c    np,nsb,nc,cs,icb,ict,pai,tai,oai,dpi,ts,
c    ubar,wbarw
c
c specified parameters:
c    auo: precomputed transmission functions
c    o1 and o2: coefficients for correcting the effect of temperature
c               on the transmission functions
c
c output parameter:
c        fluxuw: upward flux
c        fluxdw: downward flux
c
c subroutines called: transm and flxcom
c****************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension bk(lay),tauf(lay,lay),wo(lay)
      dimension fluxuw(lay),fluxdw(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
      dimension ubar(lay),wbarw(lay)
      dimension pai(lay),tai(lay),dpi(lay),oai(lay)
      dimension aux(26,21),t1(26,21),t2(26,21)
      common/o3/auo(26,21),o1(26,21),o2(26,21)
c
c  plk is the function fitting to the spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
      tran(a,b,xm,w)=exp(-a*w/(1.+b*w**xm))
c
      npp1 = np + 1
      npt = np*nsb + 1
c
c =========== compute planck functions, bk and bs ============
c
      do  2 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(118.80259,-463.19279,608.73870,-269.36267,0.6,tt)
    2 continue
      tt=ts/100.
      bs=plk(118.80259,-463.19279,608.73870,-269.36267,0.6,tt)
c     print 21,(bwi(ix),ix=1,npt),bss
   21 format(10f7.2)
c
c ================= compute o3 amount (wo) ==================
c                   units are (cm-atm)stp
      fac=466.7
      do 5 lp=2,npt
      wo(lp)=1.02*oai(lp)*dpi(lp)*fac
    5 continue
c
c  tauf is the transmittance in the 9.6 micron band
c
      do 8 i=1,npp1
      do 8 j=1,npt
      tauf(j,i)=1.0
  8   continue
c
      do 9 j=1,21
      do 9 i=1,26
      aux(i,j)=auo(i,j)
      t1(i,j)=o1(i,j)
      t2(i,j)=o2(i,j)
  9   continue
      rlog1=-4.
      dlogw=0.2
c  compute ozone transmission functions
      call transm(np,nsb,pai,tai,rlog1,dlogw,wo,aux,t1,t2,tauf)
c
c =========== compute water vapor transmisison functions ============
c   x:mean transmission due to h2o line absorption
c   y:mean transmission due to h2o continuum absorption
c
      do 28 ip=1,npp1
      is=(ip-1)*nsb+1
      do 32 ix=1,npt
      if(is .eq. ix) go to 32
      dx=abs(wbarw(is)-wbarw(ix))
      x=tran(0.05,1.47,0.5,dx)
      dx=abs(ubar(is)-ubar(ix))
      dx=8.10*dx**0.94
      if (dx.lt.0.005) go to 38
      y=1./exp(dx)
      go to 40
   38 continue
      y=1.-dx
   40 continue
      tauf(ix,ip)=tauf(ix,ip)*x*y
c     tauf(ix,ip)=x
   32 continue
   28 continue
c
c  compute fluxes
      call flxcom(np,nsb,bk,bs,tauf,nc,cs,icb,ict,1,fluxuw,fluxdw)
c
      return
      end
c
c**********************************************************************
      subroutine irtrc1(np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $                  cmh,cmn,
     $                  rfluxu1,rfluxd1)
c**********************************************************************
c compute reductions of ir flux in the spectral region 1215-1380 cm-1
c due to n2o and ch4
c reference: chou, kratz, and ridgeway (j. climate, 1990)
c
c input parameters:
c    np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,cmh,cmn
c
c output parameter:
c       rfluxu1: reduction of upward flux   (units: w/m**2)
c       rfluxd1: reduction of downward flux (units: w/m**2)
c
c subroutine called: flxcom
c****************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension bk(lay),rtau(lay,lay)
      dimension rflux(lay),ww(lay),wn(lay),wh(lay)
      dimension wws(lay),wns(lay),whs(lay)
      dimension rfluxu1(lay),rfluxd1(lay)
      dimension pai(lay),tai(lay),rawi(lay),dpi(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
c
c  plk is the function fitting to spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
      tran(a,b,xm,w)=exp(-a*w/(1.+b*w**xm))
c
      npp1 = np + 1
      npt = np*nsb + 1
c
c =============== compute planck functions, bk and bs  ===============
c
      do 23 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(8.75621,-43.18132,72.62078,-41.4669,1.016,tt)
   23 continue
      tt=ts/100.
      bs=plk(8.75621,-43.18132,72.62078,-41.4669,1.016,tt)
c     print 21,(bk(ix),ix=1,npt),bs
   21 format(10f7.2)
c
c======= compute h2o amount(ww), n2o amount(wn) and ch4 amount(wh) ==========
c        units are g/cm**2 for h2o and (cm-atm)stp for n2o and ch4
c
      ww(1)=0.
      wn(1)=0.
      wh(1)=0.
      do 15 i=2,npt
      ww(i)=1.02*rawi(i)*dpi(i)
      wn(i)=1.*cmn*789.*dpi(i)
      wh(i)=1.*cmh*789.*dpi(i)
c     print 10, i, ww(i),wn(i),wh(i),dpi(i)
   10 format (' i,ww,wn,wh,dpi=',i3,4e12.3)
   15 continue
c     print 17, cmn,cmh
   17 format (' cmn,cmh=',2e12.3)
c
c============ compute scaled column absorber amount ==================
c
      wws(1)=0.
      wns(1)=0.
      whs(1)=0.
      do 20 i=2,npt
      dt=tai(i)-250.
      pmm=(pai(i)/500.)
      wws(i)=wws(i-1)+ww(i)*pmm*exp(0.016*dt)
      pmm=(pai(i)/500.)**0.50
      wns(i)=wns(i-1)+wn(i)*pmm*exp(0.00021*dt*dt)
      whs(i)=whs(i-1)+wh(i)*pmm
   20 continue
      do 50 i=1,npp1
      is=(i-1)*nsb+1
      do 40 iq=1,npt
      if (is.ne.iq) go to 22
      rtau(iq,i)=0.
      go to 40
   22 continue
      xw=abs(wws(is)-wws(iq))
      xn=abs(wns(is)-wns(iq))
      xh=abs(whs(is)-whs(iq))
c
c================= compute transmission function ========================
c             for h2o(tauw), n2o(taun), and ch4(tauh)
c
      tauw=tran(32.46,45.47,0.58,xw)
      taun=tran(4.83,5.45,0.57,xn)
      tauh=tran(2.01,5.17,0.58,xh)
      taun=1.-(1.-taun)*0.8072
      rtau(iq,i)=tauw*(1.-taun*tauh)
   40 continue
   50 continue
c     do 55 j=1,npt
c     print 56,(rtau(i,1),i=1,npt)
c  55 print 56,(rtau(i,npt),i=1,npt)
   56 format(1x,8f7.4)
c
      call flxcom(np,nsb,bk,bs,rtau,nc,cs,icb,ict,0,rfluxu1,rfluxd1)
c
c     print 73,(i,rfluxd1(i),rfluxu1(i),i=1,npp1)
   73 format(i5,2f10.3)
      return
      end
c
c**********************************************************************
      subroutine irtrc2(np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $                  cmn,ubar,
     $                  rfluxu2,rfluxd2)
c**********************************************************************
c compute reductions of ir flux in the spectral region 1135-1215 cm-1
c due to n2o
c reference: chou, kratz, and ridgeway (j. climate, 1990)
c
c input parameters:
c    np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,cmn,ubar
c
c output parameter:
c       rfluxu2: reduction of upward flux   (units: w/m**2)
c       rfluxd2: reduction of downward flux (units: w/m**2)
c
c subroutine called: flxcom
c****************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension bk(lay),rtau(lay,lay)
      dimension rflux(lay),ww(lay),wn(lay)
      dimension wws(lay),wns(lay),ubar(lay)
      dimension rfluxu2(lay),rfluxd2(lay)
      dimension pai(lay),tai(lay),rawi(lay),dpi(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
c
c  plk is the function fitting to spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
      tran(a,b,xm,w)=exp(-a*w/(1.+b*w**xm))
c
      npp1 = np + 1
      npt = np*nsb + 1
c
c =============== compute planck functions, bk and bs  ===============
c
      do 23 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(-0.00061,0.06337,-0.3675,0.66745,2.831,tt)
   23 continue
      tt=ts/100.
      bs=plk(-0.00061,0.06337,-0.3675,0.66745,2.831,tt)
c     print 21,(bk(ix),ix=1,npt),bs
   21 format(10f7.2)
c
c======= compute h2o amount(ww) and n2o amount(wn) ==========
c        units are g/cm**2 for h2o and (cm-atm)stp for n2o
c
      ww(1)=0.
      wn(1)=0.
      do 15 i=2,npt
      ww(i)=1.02*rawi(i)*dpi(i)
      wn(i)=1.*cmn*789.*dpi(i)
c     print 10, i, ww(i),wn(i),dpi(i)
   10 format (' i,ww,wn,dpi=',i3,3e12.3)
   15 continue
c
c============ compute scaled column absorber amount ==================
c
      wws(1)=0.
      wns(1)=0.
      do 20 i=2,npt
      dt=tai(i)-250.
      pmm=(pai(i)/500.)**0.50
      wws(i)=wws(i-1)+ww(i)*pmm*exp(0.0187*dt-5.99e-5*dt*dt)
      wns(i)=wns(i-1)+wn(i)*pmm
   20 continue
      do 50 i=1,npp1
      is=(i-1)*nsb+1
      do 40 iq=1,npt
      if (is.ne.iq) go to 22
      rtau(iq,i)=0.
      go to 40
   22 continue
      xw=abs(wws(is)-wws(iq))
      xn=abs(wns(is)-wns(iq))
      dx=abs(ubar(is)-ubar(iq))
c
c================= compute transmission function ========================
c                   for h2o(tauw) and n2o(taun)
c
      tauw=tran(0.70,4.65,0.55,xw)*exp(-6.75*dx**0.94)
      taun=tran(0.31,0.48,0.57,xn)
      rtau(iq,i)=tauw*(1.-taun)
   40 continue
   50 continue
c     do 55 j=1,npt
c     print 56,(rtau(i,1),i=1,npt)
c  55 print 56,(rtau(i,npt),i=1,npt)
   56 format(1x,8f7.4)
c
      call flxcom(np,nsb,bk,bs,rtau,nc,cs,icb,ict,0,rfluxu2,rfluxd2)
c
c     print 73,(i,rfluxd2(i),rfluxu2(i),i=1,npp1)
   73 format(i5,2f10.3)
      return
      end
c**********************************************************************
      subroutine irtrc3(np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,
     $                   cmc,cmn,ubar,
     $                   rfluxu3,rfluxd3)
c**********************************************************************
c compute reductions of ir flux in the spectral region 560-615 cm-1
c due to h2o, n2o and co2
c reference: chou, kratz, and ridgeway (j. climate, 1990)
c
c input parameters:
c    np,nsb,nc,cs,icb,ict,pai,tai,rawi,dpi,ts,cmc,cmn,ubar
c
c output parameter:
c       rfluxu3: reduction of upward flux   (units: w/m**2)
c       rfluxd3: reduction of downward flux (units: w/m**2)
c
c subroutine called: flxcom
c****************************************************************
c
      parameter (lay=88)
      parameter (nnc=6)
      dimension bk(lay),rtau(lay,lay),ubar(lay)
      dimension rflux(lay),ww(lay),wn(lay),wc(lay)
      dimension wws(lay),wns(lay),wcs(lay)
      dimension rfluxu3(lay),rfluxd3(lay)
      dimension pai(lay),tai(lay),rawi(lay),dpi(lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
c
c  plk is the function fitting to spectrally-integrated planck flux
c
      plk(a,b,c,d,xm,t)=a*(t**(xm*3))+b*(t**(xm*2))+c*t**xm+d
      tran(a,b,xm,w)=exp(-a*w/(1.+b*w**xm))
c
      npp1 = np + 1
      npt = np*nsb + 1
c
c =============== compute planck functions, bk and bs  ===============
c
      do 23 ix=1,npt
      tt=tai(ix)/100.
      bk(ix)=plk(-0.42128,6.6214,-14.12493,8.79743,1.2,tt)
   23 continue
      tt=ts/100.
      bs=plk(-0.42128,6.6214,-14.12493,8.79743,1.2,tt)
c     print 21,(bk(ix),ix=1,npt),bs
   21 format(10f7.2)
c
c======= compute h2o amount(ww), n2o amount(wn) and co2 amount(wh) ==========
c        units are g/cm**2 for h2o and (cm-atm)stp for n2o and co2
c
      ww(1)=0.
      wn(1)=0.
      wc(1)=0.
      do 15 i=2,npt
      ww(i)=1.02*rawi(i)*dpi(i)
      wn(i)=1.*cmn*789.*dpi(i)
      wc(i)=1.*cmc*789.*dpi(i)
c     print 10, i, ww(i),wn(i),wc(i),ubar(i),dpi(i)
   10 format (' i,ww,wn,wc,ubar,dpi=',i3,5e12.3)
   15 continue
c     print 17, cmn,ccm
   17 format (' cmn,cmc=',2e12.3)
c
c============ compute scaled column absorber amount ==================
c
      wws(1)=0.
      wns(1)=0.
      wcs(1)=0.
      do 20 i=2,npt
      dt=tai(i)-250.
      pmm=(pai(i)/500.)
      wws(i)=wws(i-1)+ww(i)*pmm*exp(0.0162*dt-5.45e-5*dt*dt)
      pmm=(pai(i)/300.)**0.50
      wns(i)=wns(i-1)+wn(i)*pmm
      wcs(i)=wcs(i-1)+wc(i)*pmm*exp(0.0164*dt-7.04e-5*dt*dt)
   20 continue
      do 50 i=1,npp1
      is=(i-1)*nsb+1
      do 40 iq=1,npt
      if (is.ne.iq) go to 22
      rtau(iq,i)=0.
      go to 40
   22 continue
      xw=abs(wws(is)-wws(iq))
      xn=abs(wns(is)-wns(iq))
      xc=abs(wcs(is)-wcs(iq))
      dx=abs(ubar(is)-ubar(iq))
c
c================= compute transmission function ========================
c             for h2o(tauw), n2o(taun), and co2(tauc)
c
      tauw=tran(20.72,31.93,0.55,xw)*exp(-63.56*dx**0.9)
      taun=tran(1.19,2.74,0.55,xn)
      tauc=tran(0.023,0.46,0.54,xc)
      rtau(iq,i)=tauw*tauc*(1.-taun)
   40 continue
   50 continue
c     do 55 j=1,npt
c     print 56,(rtau(i,1),i=1,npt)
c  55 print 56,(rtau(i,npt),i=1,npt)
   56 format(1x,8f7.4)
c
      call flxcom(np,nsb,bk,bs,rtau,nc,cs,icb,ict,0,rfluxu3,rfluxd3)
c
c     print 73,(i,rfluxd3(i),rfluxu3(i),i=1,npp1)
   73 format(i5,2f10.2)
      return
      end
c********************************************************************
      subroutine flxcom(np,nsb,bk,bs,tau,nc,cs,icb,ict,id,
     $                  fluxu,fluxd)
c********************************************************************
c compute ir fluxes given transmission and planck functions
c
c input parameters:
c    np,nsb,bk,bs,nc,cs,icb,ict,
c    id = 1  if fluxes are to be computed
c       = 0  if reduction in fluxes are to be computed
c    tau : transmittance if id=1
c        : change in transmittance if id=0
c
c output parameter:
c       fluxu: upward flux   (units: w/m**2)
c       fluxd: downward flux (units: w/m**2)
c
c subroutine called: none
c********************************************************************
      parameter (lay=88)
      parameter (nnc=6)
      dimension fluxd(lay),fluxu(lay),flux(lay)
      dimension bk(lay),tau(lay,lay)
      dimension cs(nnc),icb(nnc),ict(nnc)
c
c  npp1 : surface level
      npp1 = np + 1
      npt = np*nsb + 1
c
c=================== compute downward fluxes =========================
c
      fluxd(1)=0.
      do 70 ip=2,npp1
      fluxd(ip)=0.
      tay=1.
      if(id.eq.0) tay=0.
      is=(ip-1)*nsb+1
      ism1=is-1
      xx=0.
      do 65 lp=1,ism1
      ix=is-lp
      xx=xx+bk(ix+1)*(tay-tau(ix,ip))
      flux(ix)=xx
      tay=tau(ix,ip)
   65 continue
      if(nc.ne.0)goto 66
      fluxd(ip)=flux(1)
      goto 70
   66 continue
      sumc=0.
      do 68 ic=1,nc
      ncbx=icb(ic)
      if(is.le.ict(ic))goto 68
      if(is.le.ncbx)goto 69
      fluxd(ip)=fluxd(ip)+(flux(ncbx)+bk(ncbx)*tau(ncbx,ip))*cs(ic)
      go to 67
   69 continue
      if(id.eq.0) goto 67
      fluxd(ip)=fluxd(ip)+bk(is)*cs(ic)
   67 sumc=sumc+cs(ic)
   68 continue
      fluxd(ip)=fluxd(ip)+flux(1)*(1.-sumc)
   70 continue
c
c================== compute upward fluxes ==================
c
      do 80 ip=1,np
      fluxu(ip)=0.
      tay=1.
      if(id.eq.0) tay=0.
      is=(ip-1)*nsb+1
      isp1=is+1
      xx=0.
      do 72 ix=isp1,npt
      xx=xx+bk(ix)*(tay-tau(ix,ip))
      flux(ix)=xx
      tay=tau(ix,ip)
   72 continue
      flux(npt)=flux(npt)+bs*tay
      if(nc.ne.0)goto 73
      fluxu(ip)=flux(npt)
      goto 80
   73 continue
      sumc=0.
      do 78 ic=1,nc
      nctx=ict(ic)
      if(is.ge.icb(ic))goto 78
      if(is.ge.nctx)goto 75
      fluxu(ip)=fluxu(ip)+(flux(nctx)+bk(nctx+1)*tau(nctx,ip))*cs(ic)
      go to 77
   75 continue
      if(id.eq.0) go to 77
      fluxu(ip)=fluxu(ip)+bk(is+1)*cs(ic)
   77 sumc=sumc+cs(ic)
   78 continue
      fluxu(ip)=fluxu(ip)+flux(npt)*(1.-sumc)
   80 continue
      fluxu(npp1)=bs
      if(id.eq.0) fluxu(npp1)=0.
c
c     print 87
   87 format (2x,'i',2x,'fluxd',4x,'fluxu')
c     print 88, (i,fluxd(i),fluxu(i),i=1,npp1)
   88 format (i5,2f10.2)
      return
      end
c***********************************************************************
      subroutine transm(np,nsb,pai,tai,flogw1,dlogw,ww,aux,t1,t2,
     $                  tauf)
c***********************************************************************
c computation of ozone (9.6 micron) or co2 (15 micron)
c transmission functions using table look-up
c reference: chou and kouvaris (jgr, 1990), and
c            chou, kratz, and ridgeway (j. climate, 1990)
c
c input parameters:
c   flogw1: first value of logw
c   dlogw: interval of the logarithm of water vapor amount at which
c          transmittances are precomputed
c   ww:    absorber amount
c   aux:   precomputed transmittances
c   c1,c2: coefficients for taking into account the temperature effect
c          on transmittance
c
c output parameter:
c   tauf:  transmission function
c
c subroutine called: none
c***********************************************************************
c
      parameter (lay=88)
      dimension pai(lay),tai(lay)
      dimension aux(26,21),t1(26,21),t2(26,21)
      dimension ww(lay),sw(lay),w(21)
      dimension tauf(lay,lay),sp(lay),st(lay)
      dimension pr(26)
      data pr/0.01,0.0158,0.025,0.0398,0.063,0.1,0.158,
     $        0.25,0.398,0.63,1.00,1.585,2.51,3.981,6.31,
     $        10.0,15.85,25.12,39.81,63.10,100.0,158.49,
     $        251.19,398.11,630.96,1000.0/
c
      npp1 = np + 1
      npt = np*nsb + 1
c
      dlogp=.2
      do 6 iw=1,21
      w(iw)=10.**(flogw1+float(iw-1)*dlogw)
    6 continue
c
c======================================================================
c   ww: absorber amount;  pai: pressure; tai: temperature
c
      sp(1)=0.
      st(1)=0.
      sw(1)=0.
      do 10 ip=2,npt
      sp(ip)=sp(ip-1)+pai(ip)*ww(ip)
      st(ip)=st(ip-1)+tai(ip)*ww(ip)
      sw(ip)=sw(ip-1)+ww(ip)
   10 continue
c     print 5,(ww(ip),sw(ip),ip=1,npt)
   5  format(1x,'ww,sw=',10f7.2)
c
      do 124 ip=1,npp1
      is=(ip-1)*nsb+1
      do 124 j=1,npt
      if(is.eq.j)goto 124
      xw=sw(j)-sw(is)
      dp=sp(j)-sp(is)
      dt=st(j)-st(is)
c  pax: effective pressure;  tax: effective temperature
      pax=dp/xw
      tax=dt/xw
c
      iq=2
  114 if(pr(iq).gt.pax) goto 113
      if(iq.eq.26)goto 113
      iq=iq+1
      goto 114
  113 continue
      iw=2
      xw=abs(sw(j)-sw(is))
  134 if(w(iw).gt.xw) goto 123
      if(iw.eq.21)goto 123
      iw=iw+1
      goto 134
  123 continue
      dt=tax-250.
      iqm1=iq-1
      iwm1=iw-1
      dpp=alog10(pax/pr(iqm1))
      dww=alog10(xw/w(iwm1))
      dpr=dpp/dlogp
      dwr=dww/dlogw
      dpwr=dpr*dwr
c----------------------------------------------------------------------
      dau=(aux(iq,iwm1)-aux(iqm1,iwm1))*dpr
      dau=dau+(aux(iqm1,iw)-aux(iqm1,iwm1))*dwr
      ax=aux(iqm1,iwm1)+dau
c----------------------------------------------------------------------
      dau=(t1(iq,iwm1)-t1(iqm1,iwm1))*dpr
      dau=dau+(t1(iqm1,iw)-t1(iqm1,iwm1))*dwr
      ac1=t1(iqm1,iwm1)+dau
c----------------------------------------------------------------------
      dau=(t2(iq,iwm1)-t2(iqm1,iwm1))*dpr
      dau=dau+(t2(iqm1,iw)-t2(iqm1,iwm1))*dwr
      ac2=t2(iqm1,iwm1)+dau
c----------------------------------------------------------------------
      absx=10.**ax
      bbsx=absx*(1.+ac1*dt*dt+ac2*dt)
      tauf(j,ip)=1.-bbsx
  124 continue
c
      do 44 ip=1,npp1
      j=(ip-1)*nsb+1
      tauf(j,ip)=1.
   44 continue
      return
      end
      block data
      common/co2/auc(26,21),c1(26,21),c2(26,21)
      common/o3/auo(26,21),o1(26,21),o2(26,21)
      common/band/xk(9),hk(8,9),cah(22,19)
      COMMON/RTDATA/LR(10,10,31),LT(10,10,31),LR2(10,10)
c
      data ((auc(ip,iw),iw=1,21),ip=1,3)/
     &-0.3241e+01,-0.3099e+01,-0.2956e+01,-0.2810e+01,-0.2667e+01,
     &-0.2532e+01,-0.2407e+01,-0.2290e+01,-0.2177e+01,-0.2067e+01,
     &-0.1959e+01,-0.1852e+01,-0.1747e+01,-0.1643e+01,-0.1540e+01,
     &-0.1439e+01,-0.1341e+01,-0.1247e+01,-0.1154e+01,-0.1063e+01,
     &-0.9730e+00,-0.3241e+01,-0.3099e+01,-0.2955e+01,-0.2809e+01,
     &-0.2666e+01,-0.2531e+01,-0.2405e+01,-0.2287e+01,-0.2173e+01,
     &-0.2061e+01,-0.1951e+01,-0.1842e+01,-0.1735e+01,-0.1628e+01,
     &-0.1523e+01,-0.1420e+01,-0.1320e+01,-0.1222e+01,-0.1127e+01,
     &-0.1033e+01,-0.9400e+00,-0.3240e+01,-0.3098e+01,-0.2954e+01,
     &-0.2808e+01,-0.2664e+01,-0.2528e+01,-0.2401e+01,-0.2282e+01,
     &-0.2166e+01,-0.2052e+01,-0.1940e+01,-0.1828e+01,-0.1718e+01,
     &-0.1609e+01,-0.1501e+01,-0.1396e+01,-0.1293e+01,-0.1193e+01,
     &-0.1095e+01,-0.9980e+00,-0.9020e+00/
      data ((auc(ip,iw),iw=1,21),ip=4,6)/
     &-0.3239e+01,-0.3096e+01,-0.2952e+01,-0.2805e+01,-0.2661e+01,
     &-0.2524e+01,-0.2396e+01,-0.2274e+01,-0.2156e+01,-0.2040e+01,
     &-0.1924e+01,-0.1810e+01,-0.1698e+01,-0.1586e+01,-0.1475e+01,
     &-0.1367e+01,-0.1262e+01,-0.1159e+01,-0.1057e+01,-0.9580e+00,
     &-0.8600e+00,-0.3238e+01,-0.3094e+01,-0.2949e+01,-0.2802e+01,
     &-0.2656e+01,-0.2518e+01,-0.2387e+01,-0.2263e+01,-0.2143e+01,
     &-0.2023e+01,-0.1904e+01,-0.1787e+01,-0.1672e+01,-0.1557e+01,
     &-0.1444e+01,-0.1334e+01,-0.1225e+01,-0.1119e+01,-0.1015e+01,
     &-0.9130e+00,-0.8150e+00,-0.3235e+01,-0.3091e+01,-0.2945e+01,
     &-0.2796e+01,-0.2649e+01,-0.2508e+01,-0.2375e+01,-0.2248e+01,
     &-0.2124e+01,-0.2001e+01,-0.1879e+01,-0.1759e+01,-0.1640e+01,
     &-0.1523e+01,-0.1407e+01,-0.1294e+01,-0.1183e+01,-0.1074e+01,
     &-0.9680e+00,-0.8650e+00,-0.7670e+00/
      data ((auc(ip,iw),iw=1,21),ip=7,9)/
     &-0.3231e+01,-0.3085e+01,-0.2938e+01,-0.2788e+01,-0.2638e+01,
     &-0.2495e+01,-0.2358e+01,-0.2227e+01,-0.2099e+01,-0.1972e+01,
     &-0.1847e+01,-0.1724e+01,-0.1603e+01,-0.1483e+01,-0.1365e+01,
     &-0.1249e+01,-0.1135e+01,-0.1024e+01,-0.9170e+00,-0.8150e+00,
     &-0.7180e+00,-0.3225e+01,-0.3078e+01,-0.2928e+01,-0.2775e+01,
     &-0.2623e+01,-0.2476e+01,-0.2335e+01,-0.2200e+01,-0.2068e+01,
     &-0.1938e+01,-0.1809e+01,-0.1683e+01,-0.1559e+01,-0.1438e+01,
     &-0.1317e+01,-0.1199e+01,-0.1084e+01,-0.9720e+00,-0.8660e+00,
     &-0.7650e+00,-0.6730e+00,-0.3216e+01,-0.3066e+01,-0.2913e+01,
     &-0.2757e+01,-0.2601e+01,-0.2450e+01,-0.2305e+01,-0.2165e+01,
     &-0.2030e+01,-0.1896e+01,-0.1765e+01,-0.1636e+01,-0.1510e+01,
     &-0.1386e+01,-0.1263e+01,-0.1144e+01,-0.1027e+01,-0.9160e+00,
     &-0.8110e+00,-0.7130e+00,-0.6250e+00/
      data ((auc(ip,iw),iw=1,21),ip=10,12)/
     &-0.3202e+01,-0.3048e+01,-0.2892e+01,-0.2731e+01,-0.2571e+01,
     &-0.2415e+01,-0.2266e+01,-0.2123e+01,-0.1984e+01,-0.1847e+01,
     &-0.1713e+01,-0.1582e+01,-0.1454e+01,-0.1328e+01,-0.1205e+01,
     &-0.1084e+01,-0.9680e+00,-0.8580e+00,-0.7550e+00,-0.6620e+00,
     &-0.5790e+00,-0.3183e+01,-0.3023e+01,-0.2862e+01,-0.2697e+01,
     &-0.2533e+01,-0.2372e+01,-0.2219e+01,-0.2073e+01,-0.1930e+01,
     &-0.1791e+01,-0.1656e+01,-0.1523e+01,-0.1394e+01,-0.1266e+01,
     &-0.1142e+01,-0.1021e+01,-0.9060e+00,-0.7990e+00,-0.7010e+00,
     &-0.6130e+00,-0.5350e+00,-0.3156e+01,-0.2990e+01,-0.2823e+01,
     &-0.2655e+01,-0.2486e+01,-0.2321e+01,-0.2165e+01,-0.2015e+01,
     &-0.1871e+01,-0.1730e+01,-0.1593e+01,-0.1459e+01,-0.1329e+01,
     &-0.1200e+01,-0.1076e+01,-0.9560e+00,-0.8440e+00,-0.7410e+00,
     &-0.6480e+00,-0.5660e+00,-0.4940e+00/
      data ((auc(ip,iw),iw=1,21),ip=13,15)/
     &-0.3120e+01,-0.2948e+01,-0.2776e+01,-0.2603e+01,-0.2431e+01,
     &-0.2263e+01,-0.2104e+01,-0.1952e+01,-0.1806e+01,-0.1664e+01,
     &-0.1526e+01,-0.1392e+01,-0.1260e+01,-0.1132e+01,-0.1008e+01,
     &-0.8920e+00,-0.7830e+00,-0.6850e+00,-0.5980e+00,-0.5220e+00,
     &-0.4560e+00,-0.3078e+01,-0.2897e+01,-0.2720e+01,-0.2544e+01,
     &-0.2369e+01,-0.2200e+01,-0.2038e+01,-0.1884e+01,-0.1737e+01,
     &-0.1595e+01,-0.1456e+01,-0.1321e+01,-0.1189e+01,-0.1062e+01,
     &-0.9410e+00,-0.8280e+00,-0.7250e+00,-0.6320e+00,-0.5520e+00,
     &-0.4820e+00,-0.4210e+00,-0.3029e+01,-0.2840e+01,-0.2658e+01,
     &-0.2480e+01,-0.2303e+01,-0.2132e+01,-0.1969e+01,-0.1814e+01,
     &-0.1666e+01,-0.1524e+01,-0.1385e+01,-0.1249e+01,-0.1118e+01,
     &-0.9930e+00,-0.8750e+00,-0.7660e+00,-0.6690e+00,-0.5830e+00,
     &-0.5090e+00,-0.4450e+00,-0.3890e+00/
      data ((auc(ip,iw),iw=1,21),ip=16,18)/
     &-0.2978e+01,-0.2779e+01,-0.2593e+01,-0.2412e+01,-0.2235e+01,
     &-0.2063e+01,-0.1899e+01,-0.1743e+01,-0.1595e+01,-0.1451e+01,
     &-0.1311e+01,-0.1176e+01,-0.1046e+01,-0.9230e+00,-0.8090e+00,
     &-0.7060e+00,-0.6140e+00,-0.5330e+00,-0.4630e+00,-0.4010e+00,
     &-0.3480e+00,-0.2927e+01,-0.2717e+01,-0.2525e+01,-0.2343e+01,
     &-0.2166e+01,-0.1995e+01,-0.1831e+01,-0.1674e+01,-0.1524e+01,
     &-0.1379e+01,-0.1239e+01,-0.1104e+01,-0.9760e+00,-0.8560e+00,
     &-0.7470e+00,-0.6490e+00,-0.5620e+00,-0.4850e+00,-0.4180e+00,
     &-0.3580e+00,-0.3070e+00,-0.2883e+01,-0.2662e+01,-0.2461e+01,
     &-0.2275e+01,-0.2098e+01,-0.1927e+01,-0.1762e+01,-0.1603e+01,
     &-0.1450e+01,-0.1303e+01,-0.1161e+01,-0.1026e+01,-0.8980e+00,
     &-0.7800e+00,-0.6720e+00,-0.5760e+00,-0.4930e+00,-0.4220e+00,
     &-0.3620e+00,-0.3110e+00,-0.2660e+00/
      data ((auc(ip,iw),iw=1,21),ip=19,21)/
     &-0.2846e+01,-0.2612e+01,-0.2401e+01,-0.2210e+01,-0.2031e+01,
     &-0.1861e+01,-0.1696e+01,-0.1535e+01,-0.1379e+01,-0.1228e+01,
     &-0.1085e+01,-0.9500e+00,-0.8240e+00,-0.7090e+00,-0.6050e+00,
     &-0.5160e+00,-0.4400e+00,-0.3770e+00,-0.3230e+00,-0.2760e+00,
     &-0.2330e+00,-0.2817e+01,-0.2572e+01,-0.2350e+01,-0.2150e+01,
     &-0.1968e+01,-0.1797e+01,-0.1632e+01,-0.1469e+01,-0.1310e+01,
     &-0.1157e+01,-0.1013e+01,-0.8800e+00,-0.7580e+00,-0.6480e+00,
     &-0.5520e+00,-0.4700e+00,-0.4020e+00,-0.3440e+00,-0.2930e+00,
     &-0.2470e+00,-0.2060e+00,-0.2796e+01,-0.2541e+01,-0.2308e+01,
     &-0.2098e+01,-0.1910e+01,-0.1736e+01,-0.1569e+01,-0.1405e+01,
     &-0.1243e+01,-0.1089e+01,-0.9440e+00,-0.8120e+00,-0.6940e+00,
     &-0.5910e+00,-0.5030e+00,-0.4300e+00,-0.3680e+00,-0.3140e+00,
     &-0.2660e+00,-0.2220e+00,-0.1830e+00/
      data ((auc(ip,iw),iw=1,21),ip=22,24)/
     &-0.2781e+01,-0.2519e+01,-0.2275e+01,-0.2055e+01,-0.1857e+01,
     &-0.1677e+01,-0.1507e+01,-0.1341e+01,-0.1179e+01,-0.1024e+01,
     &-0.8800e+00,-0.7500e+00,-0.6370e+00,-0.5420e+00,-0.4620e+00,
     &-0.3970e+00,-0.3400e+00,-0.2880e+00,-0.2410e+00,-0.2000e+00,
     &-0.1650e+00,-0.2772e+01,-0.2504e+01,-0.2252e+01,-0.2022e+01,
     &-0.1813e+01,-0.1624e+01,-0.1448e+01,-0.1280e+01,-0.1118e+01,
     &-0.9630e+00,-0.8210e+00,-0.6950e+00,-0.5880e+00,-0.5000e+00,
     &-0.4280e+00,-0.3680e+00,-0.3140e+00,-0.2640e+00,-0.2200e+00,
     &-0.1810e+00,-0.1500e+00,-0.2766e+01,-0.2494e+01,-0.2236e+01,
     &-0.1997e+01,-0.1778e+01,-0.1577e+01,-0.1393e+01,-0.1221e+01,
     &-0.1058e+01,-0.9060e+00,-0.7670e+00,-0.6470e+00,-0.5460e+00,
     &-0.4650e+00,-0.3990e+00,-0.3420e+00,-0.2900e+00,-0.2430e+00,
     &-0.2010e+00,-0.1660e+00,-0.1380e+00/
      data ((auc(ip,iw),iw=1,21),ip=25,26)/
     &-0.2762e+01,-0.2486e+01,-0.2224e+01,-0.1977e+01,-0.1749e+01,
     &-0.1538e+01,-0.1343e+01,-0.1164e+01,-0.1001e+01,-0.8520e+00,
     &-0.7190e+00,-0.6050e+00,-0.5110e+00,-0.4360e+00,-0.3730e+00,
     &-0.3180e+00,-0.2690e+00,-0.2250e+00,-0.1860e+00,-0.1550e+00,
     &-0.1280e+00,-0.2759e+01,-0.2480e+01,-0.2213e+01,-0.1961e+01,
     &-0.1725e+01,-0.1505e+01,-0.1299e+01,-0.1113e+01,-0.9470e+00,
     &-0.8010e+00,-0.6750e+00,-0.5700e+00,-0.4850e+00,-0.4140e+00,
     &-0.3520e+00,-0.2980e+00,-0.2500e+00,-0.2090e+00,-0.1750e+00,
     &-0.1470e+00,-0.1210e+00/
c
      data ((c1(ip,iw),iw=1,21),ip=1,3)/
     & 0.6000e-05, 0.9000e-05, 0.1100e-04, 0.1200e-04, 0.1200e-04,
     & 0.1300e-04, 0.1600e-04, 0.1900e-04, 0.2200e-04, 0.2300e-04,
     & 0.2400e-04, 0.2500e-04, 0.2600e-04, 0.2700e-04, 0.2700e-04,
     & 0.2500e-04, 0.2400e-04, 0.2200e-04, 0.2100e-04, 0.1900e-04,
     & 0.1700e-04, 0.6000e-05, 0.9000e-05, 0.1100e-04, 0.1200e-04,
     & 0.1200e-04, 0.1300e-04, 0.1600e-04, 0.1900e-04, 0.2200e-04,
     & 0.2300e-04, 0.2300e-04, 0.2400e-04, 0.2500e-04, 0.2600e-04,
     & 0.2600e-04, 0.2400e-04, 0.2200e-04, 0.2100e-04, 0.1900e-04,
     & 0.1800e-04, 0.1600e-04, 0.6000e-05, 0.9000e-05, 0.1100e-04,
     & 0.1200e-04, 0.1200e-04, 0.1300e-04, 0.1600e-04, 0.1900e-04,
     & 0.2100e-04, 0.2200e-04, 0.2300e-04, 0.2300e-04, 0.2400e-04,
     & 0.2500e-04, 0.2400e-04, 0.2300e-04, 0.2100e-04, 0.2000e-04,
     & 0.1800e-04, 0.1600e-04, 0.1400e-04/
      data ((c1(ip,iw),iw=1,21),ip=4,6)/
     & 0.6000e-05, 0.9000e-05, 0.1100e-04, 0.1200e-04, 0.1200e-04,
     & 0.1300e-04, 0.1600e-04, 0.1900e-04, 0.2100e-04, 0.2200e-04,
     & 0.2200e-04, 0.2200e-04, 0.2300e-04, 0.2300e-04, 0.2300e-04,
     & 0.2100e-04, 0.2000e-04, 0.1800e-04, 0.1700e-04, 0.1500e-04,
     & 0.1300e-04, 0.6000e-05, 0.9000e-05, 0.1100e-04, 0.1200e-04,
     & 0.1200e-04, 0.1300e-04, 0.1600e-04, 0.1800e-04, 0.2000e-04,
     & 0.2100e-04, 0.2100e-04, 0.2100e-04, 0.2100e-04, 0.2200e-04,
     & 0.2100e-04, 0.2000e-04, 0.1800e-04, 0.1700e-04, 0.1500e-04,
     & 0.1400e-04, 0.1200e-04, 0.6000e-05, 0.9000e-05, 0.1100e-04,
     & 0.1200e-04, 0.1200e-04, 0.1300e-04, 0.1500e-04, 0.1800e-04,
     & 0.1900e-04, 0.2000e-04, 0.1900e-04, 0.1900e-04, 0.2000e-04,
     & 0.2000e-04, 0.2000e-04, 0.1800e-04, 0.1700e-04, 0.1500e-04,
     & 0.1400e-04, 0.1300e-04, 0.1100e-04/
      data ((c1(ip,iw),iw=1,21),ip=7,9)/
     & 0.6000e-05, 0.9000e-05, 0.1100e-04, 0.1200e-04, 0.1200e-04,
     & 0.1300e-04, 0.1500e-04, 0.1700e-04, 0.1800e-04, 0.1800e-04,
     & 0.1800e-04, 0.1800e-04, 0.1800e-04, 0.1800e-04, 0.1800e-04,
     & 0.1700e-04, 0.1500e-04, 0.1400e-04, 0.1300e-04, 0.1100e-04,
     & 0.1000e-04, 0.6000e-05, 0.9000e-05, 0.1100e-04, 0.1200e-04,
     & 0.1200e-04, 0.1200e-04, 0.1400e-04, 0.1600e-04, 0.1700e-04,
     & 0.1700e-04, 0.1600e-04, 0.1600e-04, 0.1700e-04, 0.1700e-04,
     & 0.1700e-04, 0.1600e-04, 0.1500e-04, 0.1400e-04, 0.1200e-04,
     & 0.1100e-04, 0.1000e-04, 0.6000e-05, 0.9000e-05, 0.1100e-04,
     & 0.1100e-04, 0.1100e-04, 0.1200e-04, 0.1300e-04, 0.1400e-04,
     & 0.1500e-04, 0.1500e-04, 0.1500e-04, 0.1500e-04, 0.1500e-04,
     & 0.1500e-04, 0.1500e-04, 0.1400e-04, 0.1300e-04, 0.1200e-04,
     & 0.1100e-04, 0.1000e-04, 0.9000e-05/
      data ((c1(ip,iw),iw=1,21),ip=10,12)/
     & 0.6000e-05, 0.9000e-05, 0.1100e-04, 0.1100e-04, 0.1100e-04,
     & 0.1100e-04, 0.1200e-04, 0.1300e-04, 0.1400e-04, 0.1400e-04,
     & 0.1300e-04, 0.1300e-04, 0.1400e-04, 0.1400e-04, 0.1400e-04,
     & 0.1300e-04, 0.1200e-04, 0.1200e-04, 0.1100e-04, 0.1000e-04,
     & 0.8000e-05, 0.6000e-05, 0.8000e-05, 0.1000e-04, 0.1000e-04,
     & 0.1000e-04, 0.1000e-04, 0.1000e-04, 0.1200e-04, 0.1200e-04,
     & 0.1200e-04, 0.1200e-04, 0.1200e-04, 0.1300e-04, 0.1300e-04,
     & 0.1300e-04, 0.1200e-04, 0.1200e-04, 0.1100e-04, 0.1000e-04,
     & 0.9000e-05, 0.7000e-05, 0.6000e-05, 0.8000e-05, 0.9000e-05,
     & 0.1000e-04, 0.9000e-05, 0.9000e-05, 0.9000e-05, 0.1000e-04,
     & 0.1100e-04, 0.1100e-04, 0.1100e-04, 0.1100e-04, 0.1200e-04,
     & 0.1200e-04, 0.1200e-04, 0.1100e-04, 0.1100e-04, 0.1000e-04,
     & 0.9000e-05, 0.8000e-05, 0.6000e-05/
      data ((c1(ip,iw),iw=1,21),ip=13,15)/
     & 0.6000e-05, 0.8000e-05, 0.9000e-05, 0.9000e-05, 0.8000e-05,
     & 0.7000e-05, 0.8000e-05, 0.9000e-05, 0.1000e-04, 0.1000e-04,
     & 0.1000e-04, 0.1000e-04, 0.1100e-04, 0.1100e-04, 0.1100e-04,
     & 0.1100e-04, 0.1000e-04, 0.9000e-05, 0.8000e-05, 0.6000e-05,
     & 0.4000e-05, 0.5000e-05, 0.7000e-05, 0.8000e-05, 0.8000e-05,
     & 0.7000e-05, 0.7000e-05, 0.7000e-05, 0.8000e-05, 0.9000e-05,
     & 0.9000e-05, 0.1000e-04, 0.1000e-04, 0.1000e-04, 0.1000e-04,
     & 0.1000e-04, 0.1000e-04, 0.1000e-04, 0.8000e-05, 0.7000e-05,
     & 0.5000e-05, 0.3000e-05, 0.5000e-05, 0.6000e-05, 0.7000e-05,
     & 0.7000e-05, 0.7000e-05, 0.6000e-05, 0.6000e-05, 0.7000e-05,
     & 0.8000e-05, 0.9000e-05, 0.9000e-05, 0.1000e-04, 0.1000e-04,
     & 0.1000e-04, 0.1000e-04, 0.1000e-04, 0.9000e-05, 0.7000e-05,
     & 0.6000e-05, 0.4000e-05, 0.2000e-05/
      data ((c1(ip,iw),iw=1,21),ip=16,18)/
     & 0.4000e-05, 0.5000e-05, 0.6000e-05, 0.6000e-05, 0.6000e-05,
     & 0.6000e-05, 0.5000e-05, 0.6000e-05, 0.7000e-05, 0.8000e-05,
     & 0.8000e-05, 0.9000e-05, 0.9000e-05, 0.9000e-05, 0.9000e-05,
     & 0.9000e-05, 0.8000e-05, 0.6000e-05, 0.4000e-05, 0.2000e-05,
     & 0.1000e-05, 0.3000e-05, 0.4000e-05, 0.5000e-05, 0.6000e-05,
     & 0.6000e-05, 0.6000e-05, 0.5000e-05, 0.5000e-05, 0.6000e-05,
     & 0.7000e-05, 0.8000e-05, 0.8000e-05, 0.8000e-05, 0.9000e-05,
     & 0.8000e-05, 0.8000e-05, 0.6000e-05, 0.4000e-05, 0.2000e-05,
     & 0.1000e-05, 0.0000e+00, 0.2000e-05, 0.3000e-05, 0.4000e-05,
     & 0.5000e-05, 0.5000e-05, 0.5000e-05, 0.5000e-05, 0.5000e-05,
     & 0.5000e-05, 0.6000e-05, 0.6000e-05, 0.6000e-05, 0.6000e-05,
     & 0.6000e-05, 0.6000e-05, 0.5000e-05, 0.4000e-05, 0.2000e-05,
     & 0.1000e-05, 0.0000e+00, 0.0000e+00/
      data ((c1(ip,iw),iw=1,21),ip=19,21)/
     & 0.2000e-05, 0.2000e-05, 0.3000e-05, 0.4000e-05, 0.5000e-05,
     & 0.5000e-05, 0.5000e-05, 0.5000e-05, 0.4000e-05, 0.4000e-05,
     & 0.5000e-05, 0.5000e-05, 0.5000e-05, 0.5000e-05, 0.4000e-05,
     & 0.3000e-05, 0.1000e-05, 0.0000e+00, 0.0000e+00,-0.1000e-05,
     &-0.2000e-05, 0.1000e-05, 0.2000e-05, 0.2000e-05, 0.3000e-05,
     & 0.4000e-05, 0.5000e-05, 0.5000e-05, 0.5000e-05, 0.4000e-05,
     & 0.4000e-05, 0.4000e-05, 0.4000e-05, 0.5000e-05, 0.4000e-05,
     & 0.3000e-05, 0.2000e-05, 0.0000e+00, 0.0000e+00,-0.1000e-05,
     &-0.2000e-05,-0.3000e-05, 0.1000e-05, 0.1000e-05, 0.1000e-05,
     & 0.2000e-05, 0.3000e-05, 0.4000e-05, 0.5000e-05, 0.5000e-05,
     & 0.5000e-05, 0.4000e-05, 0.3000e-05, 0.3000e-05, 0.3000e-05,
     & 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.0000e+00,-0.1000e-05,
     &-0.2000e-05,-0.3000e-05,-0.3000e-05/
      data ((c1(ip,iw),iw=1,21),ip=22,24)/
     & 0.0000e+00, 0.0000e+00, 0.1000e-05, 0.1000e-05, 0.3000e-05,
     & 0.4000e-05, 0.5000e-05, 0.5000e-05, 0.5000e-05, 0.4000e-05,
     & 0.3000e-05, 0.3000e-05, 0.2000e-05, 0.2000e-05, 0.1000e-05,
     & 0.0000e+00, 0.0000e+00,-0.1000e-05,-0.2000e-05,-0.3000e-05,
     &-0.3000e-05, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.1000e-05,
     & 0.2000e-05, 0.3000e-05, 0.4000e-05, 0.5000e-05, 0.5000e-05,
     & 0.4000e-05, 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.1000e-05,
     & 0.0000e+00, 0.0000e+00,-0.1000e-05,-0.2000e-05,-0.3000e-05,
     &-0.3000e-05,-0.2000e-05, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.1000e-05, 0.2000e-05, 0.2000e-05, 0.3000e-05, 0.4000e-05,
     & 0.5000e-05, 0.4000e-05, 0.3000e-05, 0.2000e-05, 0.1000e-05,
     & 0.0000e+00,-0.1000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,
     &-0.3000e-05,-0.2000e-05,-0.1000e-05/
      data ((c1(ip,iw),iw=1,21),ip=25,26)/
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.1000e-05, 0.1000e-05,
     & 0.2000e-05, 0.3000e-05, 0.4000e-05, 0.4000e-05, 0.4000e-05,
     & 0.3000e-05, 0.2000e-05, 0.0000e+00,-0.1000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.1000e-05,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.1000e-05,
     & 0.1000e-05, 0.2000e-05, 0.2000e-05, 0.3000e-05, 0.3000e-05,
     & 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.0000e+00,-0.1000e-05,
     &-0.3000e-05,-0.4000e-05,-0.3000e-05,-0.3000e-05,-0.1000e-05,
     & 0.0000e+00, 0.0000e+00/
c
      data ((c2(ip,iw),iw=1,21),ip=1,3)/
     & 0.4300e-02, 0.5300e-02, 0.6000e-02, 0.6500e-02, 0.6700e-02,
     & 0.6700e-02, 0.6800e-02, 0.7000e-02, 0.7400e-02, 0.7700e-02,
     & 0.7900e-02, 0.8100e-02, 0.8200e-02, 0.8200e-02, 0.8200e-02,
     & 0.8100e-02, 0.7900e-02, 0.7700e-02, 0.7400e-02, 0.7200e-02,
     & 0.6800e-02, 0.4300e-02, 0.5300e-02, 0.6000e-02, 0.6500e-02,
     & 0.6600e-02, 0.6700e-02, 0.6800e-02, 0.7000e-02, 0.7200e-02,
     & 0.7500e-02, 0.7700e-02, 0.7900e-02, 0.7900e-02, 0.8000e-02,
     & 0.7900e-02, 0.7700e-02, 0.7600e-02, 0.7300e-02, 0.7100e-02,
     & 0.6800e-02, 0.6400e-02, 0.4300e-02, 0.5300e-02, 0.6000e-02,
     & 0.6400e-02, 0.6600e-02, 0.6600e-02, 0.6700e-02, 0.6900e-02,
     & 0.7100e-02, 0.7300e-02, 0.7500e-02, 0.7600e-02, 0.7600e-02,
     & 0.7600e-02, 0.7600e-02, 0.7400e-02, 0.7200e-02, 0.7000e-02,
     & 0.6700e-02, 0.6400e-02, 0.6000e-02/
      data ((c2(ip,iw),iw=1,21),ip=4,6)/
     & 0.4300e-02, 0.5200e-02, 0.6000e-02, 0.6400e-02, 0.6500e-02,
     & 0.6500e-02, 0.6600e-02, 0.6700e-02, 0.6900e-02, 0.7100e-02,
     & 0.7200e-02, 0.7300e-02, 0.7300e-02, 0.7300e-02, 0.7200e-02,
     & 0.7000e-02, 0.6800e-02, 0.6600e-02, 0.6300e-02, 0.6000e-02,
     & 0.5700e-02, 0.4200e-02, 0.5200e-02, 0.5900e-02, 0.6300e-02,
     & 0.6400e-02, 0.6400e-02, 0.6400e-02, 0.6500e-02, 0.6600e-02,
     & 0.6800e-02, 0.6900e-02, 0.6900e-02, 0.6900e-02, 0.6900e-02,
     & 0.6800e-02, 0.6600e-02, 0.6400e-02, 0.6100e-02, 0.5900e-02,
     & 0.5600e-02, 0.5300e-02, 0.4200e-02, 0.5100e-02, 0.5800e-02,
     & 0.6200e-02, 0.6300e-02, 0.6200e-02, 0.6200e-02, 0.6200e-02,
     & 0.6300e-02, 0.6400e-02, 0.6500e-02, 0.6500e-02, 0.6500e-02,
     & 0.6500e-02, 0.6400e-02, 0.6200e-02, 0.6000e-02, 0.5700e-02,
     & 0.5500e-02, 0.5200e-02, 0.5000e-02/
      data ((c2(ip,iw),iw=1,21),ip=7,9)/
     & 0.4100e-02, 0.5000e-02, 0.5700e-02, 0.6000e-02, 0.6000e-02,
     & 0.5900e-02, 0.5900e-02, 0.5900e-02, 0.5900e-02, 0.6000e-02,
     & 0.6100e-02, 0.6100e-02, 0.6100e-02, 0.6100e-02, 0.6000e-02,
     & 0.5800e-02, 0.5600e-02, 0.5400e-02, 0.5100e-02, 0.4900e-02,
     & 0.4700e-02, 0.4000e-02, 0.4800e-02, 0.5400e-02, 0.5700e-02,
     & 0.5700e-02, 0.5600e-02, 0.5500e-02, 0.5500e-02, 0.5500e-02,
     & 0.5600e-02, 0.5700e-02, 0.5700e-02, 0.5700e-02, 0.5600e-02,
     & 0.5500e-02, 0.5400e-02, 0.5200e-02, 0.5000e-02, 0.4800e-02,
     & 0.4600e-02, 0.4400e-02, 0.3800e-02, 0.4600e-02, 0.5100e-02,
     & 0.5400e-02, 0.5400e-02, 0.5200e-02, 0.5100e-02, 0.5100e-02,
     & 0.5100e-02, 0.5200e-02, 0.5300e-02, 0.5300e-02, 0.5300e-02,
     & 0.5200e-02, 0.5200e-02, 0.5000e-02, 0.4800e-02, 0.4700e-02,
     & 0.4500e-02, 0.4300e-02, 0.4200e-02/
      data ((c2(ip,iw),iw=1,21),ip=10,12)/
     & 0.3600e-02, 0.4300e-02, 0.4800e-02, 0.5000e-02, 0.4900e-02,
     & 0.4800e-02, 0.4700e-02, 0.4600e-02, 0.4700e-02, 0.4800e-02,
     & 0.4900e-02, 0.4900e-02, 0.4900e-02, 0.4900e-02, 0.4800e-02,
     & 0.4700e-02, 0.4500e-02, 0.4400e-02, 0.4200e-02, 0.4100e-02,
     & 0.4000e-02, 0.3300e-02, 0.3900e-02, 0.4300e-02, 0.4500e-02,
     & 0.4500e-02, 0.4300e-02, 0.4200e-02, 0.4300e-02, 0.4300e-02,
     & 0.4400e-02, 0.4500e-02, 0.4600e-02, 0.4600e-02, 0.4600e-02,
     & 0.4500e-02, 0.4400e-02, 0.4300e-02, 0.4200e-02, 0.4000e-02,
     & 0.4000e-02, 0.3900e-02, 0.2900e-02, 0.3400e-02, 0.3800e-02,
     & 0.4000e-02, 0.4000e-02, 0.3900e-02, 0.3900e-02, 0.3900e-02,
     & 0.4000e-02, 0.4100e-02, 0.4200e-02, 0.4300e-02, 0.4300e-02,
     & 0.4300e-02, 0.4200e-02, 0.4200e-02, 0.4100e-02, 0.4000e-02,
     & 0.3900e-02, 0.3800e-02, 0.3800e-02/
      data ((c2(ip,iw),iw=1,21),ip=13,15)/
     & 0.2400e-02, 0.2900e-02, 0.3200e-02, 0.3500e-02, 0.3600e-02,
     & 0.3600e-02, 0.3600e-02, 0.3600e-02, 0.3700e-02, 0.3900e-02,
     & 0.4000e-02, 0.4000e-02, 0.4000e-02, 0.4000e-02, 0.4000e-02,
     & 0.4000e-02, 0.3900e-02, 0.3800e-02, 0.3800e-02, 0.3700e-02,
     & 0.3700e-02, 0.1900e-02, 0.2400e-02, 0.2700e-02, 0.3000e-02,
     & 0.3200e-02, 0.3300e-02, 0.3300e-02, 0.3400e-02, 0.3500e-02,
     & 0.3600e-02, 0.3700e-02, 0.3800e-02, 0.3800e-02, 0.3900e-02,
     & 0.3800e-02, 0.3800e-02, 0.3800e-02, 0.3700e-02, 0.3700e-02,
     & 0.3700e-02, 0.3600e-02, 0.1500e-02, 0.1900e-02, 0.2300e-02,
     & 0.2600e-02, 0.2900e-02, 0.3000e-02, 0.3100e-02, 0.3200e-02,
     & 0.3300e-02, 0.3500e-02, 0.3600e-02, 0.3600e-02, 0.3700e-02,
     & 0.3700e-02, 0.3700e-02, 0.3700e-02, 0.3700e-02, 0.3600e-02,
     & 0.3600e-02, 0.3600e-02, 0.3600e-02/
      data ((c2(ip,iw),iw=1,21),ip=16,18)/
     & 0.1100e-02, 0.1500e-02, 0.1900e-02, 0.2300e-02, 0.2600e-02,
     & 0.2900e-02, 0.3000e-02, 0.3100e-02, 0.3200e-02, 0.3300e-02,
     & 0.3400e-02, 0.3500e-02, 0.3600e-02, 0.3600e-02, 0.3600e-02,
     & 0.3700e-02, 0.3700e-02, 0.3700e-02, 0.3700e-02, 0.3600e-02,
     & 0.3500e-02, 0.8000e-03, 0.1100e-02, 0.1500e-02, 0.2000e-02,
     & 0.2400e-02, 0.2700e-02, 0.2900e-02, 0.3000e-02, 0.3100e-02,
     & 0.3200e-02, 0.3300e-02, 0.3400e-02, 0.3500e-02, 0.3600e-02,
     & 0.3600e-02, 0.3600e-02, 0.3700e-02, 0.3700e-02, 0.3700e-02,
     & 0.3600e-02, 0.3400e-02, 0.6000e-03, 0.9000e-03, 0.1300e-02,
     & 0.1700e-02, 0.2100e-02, 0.2500e-02, 0.2800e-02, 0.2900e-02,
     & 0.3000e-02, 0.3100e-02, 0.3200e-02, 0.3200e-02, 0.3300e-02,
     & 0.3300e-02, 0.3300e-02, 0.3300e-02, 0.3300e-02, 0.3300e-02,
     & 0.3300e-02, 0.3200e-02, 0.3100e-02/
      data ((c2(ip,iw),iw=1,21),ip=19,21)/
     & 0.4000e-03, 0.7000e-03, 0.1000e-02, 0.1400e-02, 0.1900e-02,
     & 0.2300e-02, 0.2600e-02, 0.2800e-02, 0.2900e-02, 0.3000e-02,
     & 0.3000e-02, 0.3100e-02, 0.3100e-02, 0.3200e-02, 0.3200e-02,
     & 0.3200e-02, 0.3300e-02, 0.3300e-02, 0.3300e-02, 0.3200e-02,
     & 0.3000e-02, 0.3000e-03, 0.5000e-03, 0.8000e-03, 0.1200e-02,
     & 0.1700e-02, 0.2100e-02, 0.2400e-02, 0.2700e-02, 0.2800e-02,
     & 0.2900e-02, 0.2900e-02, 0.3000e-02, 0.3000e-02, 0.3100e-02,
     & 0.3200e-02, 0.3200e-02, 0.3300e-02, 0.3300e-02, 0.3200e-02,
     & 0.3100e-02, 0.3000e-02, 0.2000e-03, 0.4000e-03, 0.7000e-03,
     & 0.1100e-02, 0.1400e-02, 0.1800e-02, 0.2200e-02, 0.2500e-02,
     & 0.2700e-02, 0.2800e-02, 0.2800e-02, 0.2800e-02, 0.2900e-02,
     & 0.3000e-02, 0.3100e-02, 0.3200e-02, 0.3200e-02, 0.3200e-02,
     & 0.3200e-02, 0.3000e-02, 0.2900e-02/
      data ((c2(ip,iw),iw=1,21),ip=22,24)/
     & 0.2000e-03, 0.4000e-03, 0.6000e-03, 0.9000e-03, 0.1200e-02,
     & 0.1600e-02, 0.1900e-02, 0.2200e-02, 0.2500e-02, 0.2600e-02,
     & 0.2700e-02, 0.2700e-02, 0.2800e-02, 0.2900e-02, 0.3000e-02,
     & 0.3200e-02, 0.3200e-02, 0.3200e-02, 0.3000e-02, 0.2900e-02,
     & 0.2700e-02, 0.2000e-03, 0.3000e-03, 0.6000e-03, 0.8000e-03,
     & 0.1100e-02, 0.1300e-02, 0.1600e-02, 0.2000e-02, 0.2300e-02,
     & 0.2500e-02, 0.2600e-02, 0.2700e-02, 0.2800e-02, 0.2900e-02,
     & 0.3000e-02, 0.3100e-02, 0.3100e-02, 0.3100e-02, 0.2900e-02,
     & 0.2700e-02, 0.2600e-02, 0.2000e-03, 0.3000e-03, 0.5000e-03,
     & 0.7000e-03, 0.9000e-03, 0.1100e-02, 0.1400e-02, 0.1700e-02,
     & 0.2000e-02, 0.2300e-02, 0.2500e-02, 0.2700e-02, 0.2800e-02,
     & 0.2900e-02, 0.3000e-02, 0.3000e-02, 0.3000e-02, 0.2900e-02,
     & 0.2800e-02, 0.2600e-02, 0.2500e-02/
      data ((c2(ip,iw),iw=1,21),ip=25,26)/
     & 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03, 0.8000e-03,
     & 0.9000e-03, 0.1100e-02, 0.1400e-02, 0.1700e-02, 0.2000e-02,
     & 0.2300e-02, 0.2600e-02, 0.2800e-02, 0.3000e-02, 0.3000e-02,
     & 0.3000e-02, 0.2900e-02, 0.2800e-02, 0.2600e-02, 0.2500e-02,
     & 0.2500e-02, 0.1000e-03, 0.2000e-03, 0.3000e-03, 0.5000e-03,
     & 0.6000e-03, 0.7000e-03, 0.9000e-03, 0.1100e-02, 0.1500e-02,
     & 0.1800e-02, 0.2200e-02, 0.2600e-02, 0.2900e-02, 0.3100e-02,
     & 0.3000e-02, 0.2900e-02, 0.2800e-02, 0.2600e-02, 0.2500e-02,
     & 0.2500e-02, 0.2500e-02/
c
      data ((auo(ip,iw),iw=1,21),ip=1,3)/
     &-0.3186e+01,-0.2996e+01,-0.2811e+01,-0.2632e+01,-0.2460e+01,
     &-0.2297e+01,-0.2145e+01,-0.2007e+01,-0.1881e+01,-0.1768e+01,
     &-0.1665e+01,-0.1569e+01,-0.1478e+01,-0.1389e+01,-0.1302e+01,
     &-0.1216e+01,-0.1132e+01,-0.1051e+01,-0.9740e+00,-0.9010e+00,
     &-0.8340e+00,-0.3186e+01,-0.2996e+01,-0.2811e+01,-0.2632e+01,
     &-0.2460e+01,-0.2297e+01,-0.2145e+01,-0.2007e+01,-0.1881e+01,
     &-0.1768e+01,-0.1665e+01,-0.1569e+01,-0.1478e+01,-0.1389e+01,
     &-0.1301e+01,-0.1215e+01,-0.1131e+01,-0.1050e+01,-0.9720e+00,
     &-0.8990e+00,-0.8320e+00,-0.3186e+01,-0.2996e+01,-0.2811e+01,
     &-0.2632e+01,-0.2460e+01,-0.2297e+01,-0.2145e+01,-0.2006e+01,
     &-0.1881e+01,-0.1768e+01,-0.1665e+01,-0.1568e+01,-0.1477e+01,
     &-0.1388e+01,-0.1300e+01,-0.1214e+01,-0.1130e+01,-0.1048e+01,
     &-0.9700e+00,-0.8970e+00,-0.8290e+00/
      data ((auo(ip,iw),iw=1,21),ip=4,6)/
     &-0.3186e+01,-0.2996e+01,-0.2811e+01,-0.2632e+01,-0.2459e+01,
     &-0.2297e+01,-0.2145e+01,-0.2006e+01,-0.1880e+01,-0.1767e+01,
     &-0.1664e+01,-0.1568e+01,-0.1476e+01,-0.1387e+01,-0.1299e+01,
     &-0.1212e+01,-0.1127e+01,-0.1045e+01,-0.9670e+00,-0.8930e+00,
     &-0.8240e+00,-0.3186e+01,-0.2996e+01,-0.2811e+01,-0.2631e+01,
     &-0.2459e+01,-0.2296e+01,-0.2145e+01,-0.2005e+01,-0.1880e+01,
     &-0.1766e+01,-0.1663e+01,-0.1566e+01,-0.1474e+01,-0.1385e+01,
     &-0.1296e+01,-0.1209e+01,-0.1124e+01,-0.1041e+01,-0.9620e+00,
     &-0.8870e+00,-0.8160e+00,-0.3186e+01,-0.2996e+01,-0.2811e+01,
     &-0.2631e+01,-0.2459e+01,-0.2296e+01,-0.2144e+01,-0.2005e+01,
     &-0.1879e+01,-0.1765e+01,-0.1661e+01,-0.1564e+01,-0.1471e+01,
     &-0.1381e+01,-0.1292e+01,-0.1205e+01,-0.1118e+01,-0.1035e+01,
     &-0.9540e+00,-0.8780e+00,-0.8060e+00/
      data ((auo(ip,iw),iw=1,21),ip=7,9)/
     &-0.3186e+01,-0.2996e+01,-0.2811e+01,-0.2631e+01,-0.2458e+01,
     &-0.2295e+01,-0.2143e+01,-0.2003e+01,-0.1877e+01,-0.1763e+01,
     &-0.1658e+01,-0.1561e+01,-0.1467e+01,-0.1376e+01,-0.1287e+01,
     &-0.1198e+01,-0.1110e+01,-0.1025e+01,-0.9430e+00,-0.8640e+00,
     &-0.7900e+00,-0.3185e+01,-0.2996e+01,-0.2810e+01,-0.2630e+01,
     &-0.2458e+01,-0.2294e+01,-0.2141e+01,-0.2001e+01,-0.1874e+01,
     &-0.1759e+01,-0.1654e+01,-0.1555e+01,-0.1461e+01,-0.1369e+01,
     &-0.1278e+01,-0.1187e+01,-0.1098e+01,-0.1011e+01,-0.9270e+00,
     &-0.8460e+00,-0.7700e+00,-0.3185e+01,-0.2996e+01,-0.2810e+01,
     &-0.2629e+01,-0.2456e+01,-0.2292e+01,-0.2139e+01,-0.1998e+01,
     &-0.1870e+01,-0.1754e+01,-0.1647e+01,-0.1547e+01,-0.1451e+01,
     &-0.1357e+01,-0.1264e+01,-0.1172e+01,-0.1080e+01,-0.9910e+00,
     &-0.9040e+00,-0.8210e+00,-0.7430e+00/
      data ((auo(ip,iw),iw=1,21),ip=10,12)/
     &-0.3185e+01,-0.2995e+01,-0.2809e+01,-0.2628e+01,-0.2454e+01,
     &-0.2289e+01,-0.2135e+01,-0.1993e+01,-0.1863e+01,-0.1746e+01,
     &-0.1637e+01,-0.1535e+01,-0.1437e+01,-0.1341e+01,-0.1245e+01,
     &-0.1150e+01,-0.1056e+01,-0.9640e+00,-0.8750e+00,-0.7900e+00,
     &-0.7090e+00,-0.3185e+01,-0.2994e+01,-0.2807e+01,-0.2626e+01,
     &-0.2451e+01,-0.2285e+01,-0.2129e+01,-0.1985e+01,-0.1854e+01,
     &-0.1733e+01,-0.1622e+01,-0.1518e+01,-0.1417e+01,-0.1317e+01,
     &-0.1219e+01,-0.1121e+01,-0.1024e+01,-0.9300e+00,-0.8380e+00,
     &-0.7510e+00,-0.6690e+00,-0.3183e+01,-0.2993e+01,-0.2805e+01,
     &-0.2623e+01,-0.2447e+01,-0.2279e+01,-0.2121e+01,-0.1974e+01,
     &-0.1840e+01,-0.1716e+01,-0.1602e+01,-0.1493e+01,-0.1389e+01,
     &-0.1286e+01,-0.1184e+01,-0.1083e+01,-0.9840e+00,-0.8880e+00,
     &-0.7950e+00,-0.7060e+00,-0.6230e+00/
      data ((auo(ip,iw),iw=1,21),ip=13,15)/
     &-0.3183e+01,-0.2991e+01,-0.2802e+01,-0.2619e+01,-0.2441e+01,
     &-0.2270e+01,-0.2110e+01,-0.1959e+01,-0.1821e+01,-0.1693e+01,
     &-0.1574e+01,-0.1461e+01,-0.1352e+01,-0.1246e+01,-0.1141e+01,
     &-0.1038e+01,-0.9370e+00,-0.8390e+00,-0.7450e+00,-0.6560e+00,
     &-0.5720e+00,-0.3181e+01,-0.2988e+01,-0.2799e+01,-0.2613e+01,
     &-0.2433e+01,-0.2260e+01,-0.2095e+01,-0.1940e+01,-0.1796e+01,
     &-0.1662e+01,-0.1538e+01,-0.1420e+01,-0.1307e+01,-0.1198e+01,
     &-0.1090e+01,-0.9850e+00,-0.8830e+00,-0.7840e+00,-0.6900e+00,
     &-0.6020e+00,-0.5200e+00,-0.3179e+01,-0.2985e+01,-0.2794e+01,
     &-0.2606e+01,-0.2424e+01,-0.2247e+01,-0.2077e+01,-0.1917e+01,
     &-0.1767e+01,-0.1627e+01,-0.1496e+01,-0.1373e+01,-0.1256e+01,
     &-0.1143e+01,-0.1033e+01,-0.9270e+00,-0.8240e+00,-0.7260e+00,
     &-0.6330e+00,-0.5460e+00,-0.4670e+00/
      data ((auo(ip,iw),iw=1,21),ip=16,18)/
     &-0.3177e+01,-0.2982e+01,-0.2789e+01,-0.2599e+01,-0.2413e+01,
     &-0.2232e+01,-0.2058e+01,-0.1892e+01,-0.1734e+01,-0.1587e+01,
     &-0.1450e+01,-0.1322e+01,-0.1200e+01,-0.1084e+01,-0.9730e+00,
     &-0.8670e+00,-0.7640e+00,-0.6670e+00,-0.5760e+00,-0.4920e+00,
     &-0.4160e+00,-0.3167e+01,-0.2971e+01,-0.2777e+01,-0.2585e+01,
     &-0.2396e+01,-0.2211e+01,-0.2033e+01,-0.1861e+01,-0.1698e+01,
     &-0.1544e+01,-0.1400e+01,-0.1267e+01,-0.1141e+01,-0.1023e+01,
     &-0.9110e+00,-0.8040e+00,-0.7020e+00,-0.6070e+00,-0.5180e+00,
     &-0.4370e+00,-0.3640e+00,-0.3169e+01,-0.2972e+01,-0.2776e+01,
     &-0.2582e+01,-0.2390e+01,-0.2203e+01,-0.2019e+01,-0.1841e+01,
     &-0.1671e+01,-0.1510e+01,-0.1358e+01,-0.1217e+01,-0.1086e+01,
     &-0.9640e+00,-0.8500e+00,-0.7430e+00,-0.6430e+00,-0.5510e+00,
     &-0.4650e+00,-0.3890e+00,-0.3210e+00/
      data ((auo(ip,iw),iw=1,21),ip=19,21)/
     &-0.3170e+01,-0.2972e+01,-0.2775e+01,-0.2580e+01,-0.2386e+01,
     &-0.2195e+01,-0.2008e+01,-0.1826e+01,-0.1650e+01,-0.1481e+01,
     &-0.1322e+01,-0.1174e+01,-0.1036e+01,-0.9100e+00,-0.7940e+00,
     &-0.6870e+00,-0.5890e+00,-0.4990e+00,-0.4180e+00,-0.3460e+00,
     &-0.2840e+00,-0.3171e+01,-0.2972e+01,-0.2774e+01,-0.2578e+01,
     &-0.2382e+01,-0.2189e+01,-0.1999e+01,-0.1813e+01,-0.1633e+01,
     &-0.1459e+01,-0.1293e+01,-0.1138e+01,-0.9940e+00,-0.8620e+00,
     &-0.7430e+00,-0.6360e+00,-0.5400e+00,-0.4540e+00,-0.3770e+00,
     &-0.3110e+00,-0.2530e+00,-0.3170e+01,-0.2971e+01,-0.2773e+01,
     &-0.2576e+01,-0.2379e+01,-0.2185e+01,-0.1993e+01,-0.1804e+01,
     &-0.1620e+01,-0.1441e+01,-0.1271e+01,-0.1110e+01,-0.9600e+00,
     &-0.8230e+00,-0.7010e+00,-0.5920e+00,-0.4970e+00,-0.4140e+00,
     &-0.3430e+00,-0.2810e+00,-0.2290e+00/
      data ((auo(ip,iw),iw=1,21),ip=22,24)/
     &-0.3170e+01,-0.2971e+01,-0.2772e+01,-0.2574e+01,-0.2377e+01,
     &-0.2182e+01,-0.1988e+01,-0.1798e+01,-0.1611e+01,-0.1430e+01,
     &-0.1255e+01,-0.1089e+01,-0.9340e+00,-0.7930e+00,-0.6670e+00,
     &-0.5560e+00,-0.4620e+00,-0.3820e+00,-0.3150e+00,-0.2580e+00,
     &-0.2110e+00,-0.3170e+01,-0.2971e+01,-0.2772e+01,-0.2573e+01,
     &-0.2376e+01,-0.2180e+01,-0.1985e+01,-0.1793e+01,-0.1605e+01,
     &-0.1421e+01,-0.1244e+01,-0.1075e+01,-0.9160e+00,-0.7710e+00,
     &-0.6410e+00,-0.5290e+00,-0.4340e+00,-0.3560e+00,-0.2930e+00,
     &-0.2410e+00,-0.1970e+00,-0.3170e+01,-0.2971e+01,-0.2771e+01,
     &-0.2573e+01,-0.2375e+01,-0.2178e+01,-0.1983e+01,-0.1791e+01,
     &-0.1601e+01,-0.1416e+01,-0.1237e+01,-0.1065e+01,-0.9040e+00,
     &-0.7560e+00,-0.6230e+00,-0.5090e+00,-0.4140e+00,-0.3380e+00,
     &-0.2780e+00,-0.2290e+00,-0.1880e+00/
      data ((auo(ip,iw),iw=1,21),ip=25,26)/
     &-0.3171e+01,-0.2971e+01,-0.2772e+01,-0.2573e+01,-0.2375e+01,
     &-0.2178e+01,-0.1983e+01,-0.1790e+01,-0.1600e+01,-0.1414e+01,
     &-0.1233e+01,-0.1060e+01,-0.8970e+00,-0.7470e+00,-0.6120e+00,
     &-0.4960e+00,-0.4010e+00,-0.3260e+00,-0.2680e+00,-0.2220e+00,
     &-0.1830e+00,-0.3172e+01,-0.2973e+01,-0.2773e+01,-0.2575e+01,
     &-0.2376e+01,-0.2179e+01,-0.1984e+01,-0.1790e+01,-0.1600e+01,
     &-0.1413e+01,-0.1232e+01,-0.1058e+01,-0.8930e+00,-0.7420e+00,
     &-0.6060e+00,-0.4890e+00,-0.3940e+00,-0.3190e+00,-0.2620e+00,
     &-0.2170e+00,-0.1790e+00/
c
      data ((o1(ip,iw),iw=1,21),ip=1,3)/
     &-0.3000e-05,-0.3000e-05,-0.4000e-05,-0.4000e-05,-0.5000e-05,
     &-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.4000e-05,-0.3000e-05,
     &-0.1000e-05, 0.0000e+00, 0.1000e-05, 0.2000e-05, 0.3000e-05,
     & 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.0000e+00,-0.1000e-05,
     &-0.3000e-05,-0.3000e-05,-0.3000e-05,-0.3000e-05,-0.4000e-05,
     &-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.4000e-05,
     &-0.3000e-05,-0.1000e-05, 0.0000e+00, 0.1000e-05, 0.2000e-05,
     & 0.3000e-05, 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.0000e+00,
     &-0.1000e-05,-0.3000e-05,-0.3000e-05,-0.3000e-05,-0.4000e-05,
     &-0.4000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,
     &-0.4000e-05,-0.3000e-05,-0.1000e-05, 0.0000e+00, 0.1000e-05,
     & 0.2000e-05, 0.3000e-05, 0.3000e-05, 0.2000e-05, 0.1000e-05,
     & 0.0000e+00,-0.1000e-05,-0.3000e-05/
      data ((o1(ip,iw),iw=1,21),ip=4,6)/
     &-0.3000e-05,-0.3000e-05,-0.4000e-05,-0.4000e-05,-0.5000e-05,
     &-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.4000e-05,-0.3000e-05,
     &-0.1000e-05, 0.0000e+00, 0.1000e-05, 0.2000e-05, 0.3000e-05,
     & 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.0000e+00,-0.1000e-05,
     &-0.3000e-05,-0.3000e-05,-0.3000e-05,-0.4000e-05,-0.4000e-05,
     &-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.4000e-05,
     &-0.3000e-05,-0.1000e-05, 0.0000e+00, 0.1000e-05, 0.2000e-05,
     & 0.3000e-05, 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.0000e+00,
     &-0.1000e-05,-0.3000e-05,-0.2000e-05,-0.3000e-05,-0.4000e-05,
     &-0.4000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,
     &-0.4000e-05,-0.3000e-05,-0.1000e-05, 0.0000e+00, 0.1000e-05,
     & 0.2000e-05, 0.3000e-05, 0.3000e-05, 0.3000e-05, 0.1000e-05,
     & 0.0000e+00,-0.1000e-05,-0.2000e-05/
      data ((o1(ip,iw),iw=1,21),ip=7,9)/
     &-0.2000e-05,-0.3000e-05,-0.4000e-05,-0.4000e-05,-0.5000e-05,
     &-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.4000e-05,-0.3000e-05,
     &-0.1000e-05, 0.0000e+00, 0.1000e-05, 0.2000e-05, 0.3000e-05,
     & 0.3000e-05, 0.3000e-05, 0.2000e-05, 0.0000e+00,-0.1000e-05,
     &-0.2000e-05,-0.3000e-05,-0.3000e-05,-0.4000e-05,-0.4000e-05,
     &-0.4000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,-0.4000e-05,
     &-0.3000e-05,-0.1000e-05, 0.0000e+00, 0.1000e-05, 0.2000e-05,
     & 0.3000e-05, 0.3000e-05, 0.3000e-05, 0.2000e-05, 0.0000e+00,
     &-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.3000e-05,-0.3000e-05,
     &-0.4000e-05,-0.4000e-05,-0.5000e-05,-0.5000e-05,-0.5000e-05,
     &-0.4000e-05,-0.2000e-05,-0.1000e-05, 0.0000e+00, 0.1000e-05,
     & 0.2000e-05, 0.3000e-05, 0.3000e-05, 0.3000e-05, 0.2000e-05,
     & 0.0000e+00,-0.1000e-05,-0.2000e-05/
      data ((o1(ip,iw),iw=1,21),ip=10,12)/
     &-0.3000e-05,-0.3000e-05,-0.4000e-05,-0.4000e-05,-0.4000e-05,
     &-0.4000e-05,-0.5000e-05,-0.4000e-05,-0.3000e-05,-0.2000e-05,
     &-0.1000e-05, 0.0000e+00, 0.1000e-05, 0.2000e-05, 0.3000e-05,
     & 0.3000e-05, 0.3000e-05, 0.1000e-05, 0.0000e+00,-0.1000e-05,
     &-0.2000e-05,-0.2000e-05,-0.3000e-05,-0.3000e-05,-0.3000e-05,
     &-0.4000e-05,-0.4000e-05,-0.4000e-05,-0.4000e-05,-0.3000e-05,
     &-0.2000e-05, 0.0000e+00, 0.0000e+00, 0.1000e-05, 0.2000e-05,
     & 0.3000e-05, 0.3000e-05, 0.2000e-05, 0.1000e-05, 0.0000e+00,
     &-0.1000e-05,-0.2000e-05,-0.3000e-05,-0.3000e-05,-0.3000e-05,
     &-0.3000e-05,-0.3000e-05,-0.4000e-05,-0.4000e-05,-0.3000e-05,
     &-0.3000e-05,-0.2000e-05, 0.0000e+00, 0.0000e+00, 0.1000e-05,
     & 0.2000e-05, 0.2000e-05, 0.2000e-05, 0.2000e-05, 0.1000e-05,
     & 0.0000e+00,-0.1000e-05,-0.3000e-05/
      data ((o1(ip,iw),iw=1,21),ip=13,15)/
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.3000e-05,-0.3000e-05,
     &-0.3000e-05,-0.3000e-05,-0.3000e-05,-0.2000e-05,-0.1000e-05,
     & 0.0000e+00, 0.0000e+00, 0.1000e-05, 0.2000e-05, 0.2000e-05,
     & 0.2000e-05, 0.1000e-05, 0.0000e+00, 0.0000e+00,-0.1000e-05,
     &-0.3000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.3000e-05,-0.3000e-05,-0.2000e-05,-0.2000e-05,
     &-0.1000e-05, 0.0000e+00, 0.0000e+00, 0.1000e-05, 0.1000e-05,
     & 0.1000e-05, 0.1000e-05, 0.1000e-05, 0.0000e+00, 0.0000e+00,
     &-0.2000e-05,-0.3000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.1000e-05, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.1000e-05, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     &-0.1000e-05,-0.2000e-05,-0.3000e-05/
      data ((o1(ip,iw),iw=1,21),ip=16,18)/
     &-0.1000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.1000e-05,
     &-0.1000e-05, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00,-0.1000e-05,-0.2000e-05,
     &-0.3000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.1000e-05,-0.1000e-05, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,-0.1000e-05,
     &-0.2000e-05,-0.3000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     &-0.1000e-05,-0.2000e-05,-0.2000e-05/
      data ((o1(ip,iw),iw=1,21),ip=19,21)/
     &-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.1000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.1000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,
     & 0.0000e+00, 0.0000e+00,-0.1000e-05,-0.1000e-05,-0.1000e-05,
     &-0.2000e-05,-0.1000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.1000e-05,
     &-0.1000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,
     &-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.1000e-05,
     &-0.2000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,
     &-0.1000e-05,-0.2000e-05,-0.2000e-05/
      data ((o1(ip,iw),iw=1,21),ip=22,24)/
     &-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.2000e-05,
     &-0.1000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.1000e-05,-0.1000e-05,-0.1000e-05,-0.2000e-05,
     &-0.2000e-05,-0.1000e-05,-0.2000e-05,-0.1000e-05,-0.1000e-05,
     &-0.2000e-05,-0.1000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.3000e-05/
      data ((o1(ip,iw),iw=1,21),ip=25,26)/
     &-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.2000e-05,
     &-0.1000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.3000e-05,-0.2000e-05,-0.1000e-05,-0.2000e-05,-0.1000e-05,
     &-0.2000e-05,-0.2000e-05,-0.1000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,-0.2000e-05,
     &-0.2000e-05,-0.3000e-05/
c
      data ((o2(ip,iw),iw=1,21),ip=1,3)/
     & 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03, 0.9000e-03,
     & 0.1300e-02, 0.1700e-02, 0.2200e-02, 0.2800e-02, 0.3300e-02,
     & 0.3700e-02, 0.4200e-02, 0.4500e-02, 0.4900e-02, 0.5100e-02,
     & 0.5400e-02, 0.5500e-02, 0.5500e-02, 0.5500e-02, 0.5300e-02,
     & 0.5200e-02, 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03,
     & 0.9000e-03, 0.1300e-02, 0.1700e-02, 0.2200e-02, 0.2800e-02,
     & 0.3300e-02, 0.3700e-02, 0.4200e-02, 0.4500e-02, 0.4900e-02,
     & 0.5100e-02, 0.5300e-02, 0.5500e-02, 0.5500e-02, 0.5400e-02,
     & 0.5300e-02, 0.5100e-02, 0.1000e-03, 0.2000e-03, 0.4000e-03,
     & 0.6000e-03, 0.9000e-03, 0.1300e-02, 0.1700e-02, 0.2200e-02,
     & 0.2700e-02, 0.3300e-02, 0.3700e-02, 0.4100e-02, 0.4500e-02,
     & 0.4800e-02, 0.5100e-02, 0.5300e-02, 0.5400e-02, 0.5400e-02,
     & 0.5400e-02, 0.5200e-02, 0.5100e-02/
      data ((o2(ip,iw),iw=1,21),ip=4,6)/
     & 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03, 0.9000e-03,
     & 0.1300e-02, 0.1700e-02, 0.2200e-02, 0.2700e-02, 0.3200e-02,
     & 0.3700e-02, 0.4100e-02, 0.4500e-02, 0.4800e-02, 0.5100e-02,
     & 0.5300e-02, 0.5400e-02, 0.5400e-02, 0.5300e-02, 0.5200e-02,
     & 0.5000e-02, 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03,
     & 0.9000e-03, 0.1300e-02, 0.1700e-02, 0.2200e-02, 0.2700e-02,
     & 0.3200e-02, 0.3700e-02, 0.4100e-02, 0.4500e-02, 0.4800e-02,
     & 0.5000e-02, 0.5200e-02, 0.5300e-02, 0.5300e-02, 0.5200e-02,
     & 0.5000e-02, 0.4800e-02, 0.1000e-03, 0.2000e-03, 0.4000e-03,
     & 0.6000e-03, 0.9000e-03, 0.1300e-02, 0.1700e-02, 0.2200e-02,
     & 0.2700e-02, 0.3200e-02, 0.3700e-02, 0.4100e-02, 0.4400e-02,
     & 0.4700e-02, 0.5000e-02, 0.5100e-02, 0.5200e-02, 0.5200e-02,
     & 0.5100e-02, 0.4900e-02, 0.4600e-02/
      data ((o2(ip,iw),iw=1,21),ip=7,9)/
     & 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03, 0.9000e-03,
     & 0.1300e-02, 0.1700e-02, 0.2200e-02, 0.2700e-02, 0.3200e-02,
     & 0.3600e-02, 0.4000e-02, 0.4300e-02, 0.4600e-02, 0.4800e-02,
     & 0.5000e-02, 0.5000e-02, 0.5000e-02, 0.4800e-02, 0.4600e-02,
     & 0.4400e-02, 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03,
     & 0.9000e-03, 0.1200e-02, 0.1600e-02, 0.2100e-02, 0.2600e-02,
     & 0.3100e-02, 0.3500e-02, 0.3900e-02, 0.4200e-02, 0.4500e-02,
     & 0.4700e-02, 0.4800e-02, 0.4800e-02, 0.4700e-02, 0.4600e-02,
     & 0.4400e-02, 0.4100e-02, 0.1000e-03, 0.2000e-03, 0.4000e-03,
     & 0.6000e-03, 0.9000e-03, 0.1200e-02, 0.1600e-02, 0.2100e-02,
     & 0.2500e-02, 0.3000e-02, 0.3400e-02, 0.3800e-02, 0.4100e-02,
     & 0.4300e-02, 0.4500e-02, 0.4500e-02, 0.4500e-02, 0.4400e-02,
     & 0.4200e-02, 0.4000e-02, 0.3800e-02/
      data ((o2(ip,iw),iw=1,21),ip=10,12)/
     & 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03, 0.8000e-03,
     & 0.1100e-02, 0.1500e-02, 0.2000e-02, 0.2400e-02, 0.2900e-02,
     & 0.3200e-02, 0.3600e-02, 0.3800e-02, 0.4000e-02, 0.4100e-02,
     & 0.4200e-02, 0.4200e-02, 0.4000e-02, 0.3900e-02, 0.3700e-02,
     & 0.3400e-02, 0.1000e-03, 0.2000e-03, 0.3000e-03, 0.5000e-03,
     & 0.7000e-03, 0.1100e-02, 0.1400e-02, 0.1800e-02, 0.2300e-02,
     & 0.2700e-02, 0.3000e-02, 0.3300e-02, 0.3500e-02, 0.3700e-02,
     & 0.3800e-02, 0.3800e-02, 0.3800e-02, 0.3600e-02, 0.3500e-02,
     & 0.3300e-02, 0.3100e-02, 0.0000e+00, 0.1000e-03, 0.3000e-03,
     & 0.4000e-03, 0.7000e-03, 0.9000e-03, 0.1300e-02, 0.1700e-02,
     & 0.2000e-02, 0.2400e-02, 0.2700e-02, 0.3000e-02, 0.3200e-02,
     & 0.3300e-02, 0.3400e-02, 0.3400e-02, 0.3300e-02, 0.3300e-02,
     & 0.3100e-02, 0.3000e-02, 0.2800e-02/
      data ((o2(ip,iw),iw=1,21),ip=13,15)/
     & 0.0000e+00, 0.1000e-03, 0.2000e-03, 0.4000e-03, 0.6000e-03,
     & 0.8000e-03, 0.1100e-02, 0.1400e-02, 0.1800e-02, 0.2100e-02,
     & 0.2400e-02, 0.2600e-02, 0.2700e-02, 0.2800e-02, 0.2900e-02,
     & 0.3000e-02, 0.2900e-02, 0.2900e-02, 0.2800e-02, 0.2700e-02,
     & 0.2500e-02, 0.0000e+00, 0.1000e-03, 0.1000e-03, 0.3000e-03,
     & 0.4000e-03, 0.6000e-03, 0.9000e-03, 0.1100e-02, 0.1400e-02,
     & 0.1700e-02, 0.2000e-02, 0.2200e-02, 0.2300e-02, 0.2400e-02,
     & 0.2500e-02, 0.2600e-02, 0.2600e-02, 0.2600e-02, 0.2500e-02,
     & 0.2400e-02, 0.2300e-02, 0.0000e+00, 0.0000e+00, 0.1000e-03,
     & 0.2000e-03, 0.3000e-03, 0.4000e-03, 0.6000e-03, 0.9000e-03,
     & 0.1100e-02, 0.1400e-02, 0.1600e-02, 0.1800e-02, 0.1900e-02,
     & 0.2100e-02, 0.2200e-02, 0.2200e-02, 0.2300e-02, 0.2300e-02,
     & 0.2300e-02, 0.2200e-02, 0.2200e-02/
      data ((o2(ip,iw),iw=1,21),ip=16,18)/
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.1000e-03, 0.2000e-03,
     & 0.3000e-03, 0.4000e-03, 0.6000e-03, 0.8000e-03, 0.1000e-02,
     & 0.1200e-02, 0.1400e-02, 0.1600e-02, 0.1700e-02, 0.1900e-02,
     & 0.2000e-02, 0.2100e-02, 0.2100e-02, 0.2100e-02, 0.2100e-02,
     & 0.2000e-02, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.1000e-03, 0.2000e-03, 0.3000e-03, 0.4000e-03, 0.6000e-03,
     & 0.7000e-03, 0.9000e-03, 0.1100e-02, 0.1300e-02, 0.1500e-02,
     & 0.1600e-02, 0.1800e-02, 0.1900e-02, 0.2000e-02, 0.2000e-02,
     & 0.2000e-02, 0.1900e-02, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.1000e-03, 0.1000e-03, 0.2000e-03,
     & 0.4000e-03, 0.5000e-03, 0.7000e-03, 0.9000e-03, 0.1100e-02,
     & 0.1200e-02, 0.1400e-02, 0.1600e-02, 0.1700e-02, 0.1800e-02,
     & 0.1900e-02, 0.1900e-02, 0.1900e-02/
      data ((o2(ip,iw),iw=1,21),ip=19,21)/
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.1000e-03, 0.1000e-03, 0.2000e-03, 0.4000e-03,
     & 0.5000e-03, 0.7000e-03, 0.9000e-03, 0.1100e-02, 0.1200e-02,
     & 0.1400e-02, 0.1600e-02, 0.1700e-02, 0.1800e-02, 0.1800e-02,
     & 0.1800e-02, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.1000e-03, 0.1000e-03,
     & 0.2000e-03, 0.4000e-03, 0.5000e-03, 0.7000e-03, 0.9000e-03,
     & 0.1100e-02, 0.1300e-02, 0.1400e-02, 0.1600e-02, 0.1700e-02,
     & 0.1700e-02, 0.1700e-02, 0.0000e+00,-0.1000e-03, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.1000e-03, 0.2000e-03, 0.3000e-03, 0.4000e-03, 0.6000e-03,
     & 0.8000e-03, 0.1000e-02, 0.1200e-02, 0.1300e-02, 0.1500e-02,
     & 0.1600e-02, 0.1700e-02, 0.1700e-02/
      data ((o2(ip,iw),iw=1,21),ip=22,24)/
     &-0.1000e-03,-0.1000e-03, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.1000e-03,
     & 0.2000e-03, 0.3000e-03, 0.5000e-03, 0.7000e-03, 0.9000e-03,
     & 0.1100e-02, 0.1300e-02, 0.1400e-02, 0.1500e-02, 0.1600e-02,
     & 0.1600e-02,-0.1000e-03,-0.1000e-03,-0.1000e-03, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.1000e-03, 0.1000e-03, 0.3000e-03, 0.4000e-03, 0.6000e-03,
     & 0.8000e-03, 0.1000e-02, 0.1200e-02, 0.1400e-02, 0.1500e-02,
     & 0.1600e-02, 0.1600e-02,-0.1000e-03,-0.1000e-03, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.1000e-03, 0.2000e-03, 0.4000e-03,
     & 0.5000e-03, 0.7000e-03, 0.9000e-03, 0.1100e-02, 0.1300e-02,
     & 0.1500e-02, 0.1600e-02, 0.1600e-02/
      data ((o2(ip,iw),iw=1,21),ip=25,26)/
     &-0.1000e-03,-0.1000e-03, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.1000e-03, 0.2000e-03, 0.3000e-03, 0.5000e-03, 0.7000e-03,
     & 0.9000e-03, 0.1100e-02, 0.1300e-02, 0.1500e-02, 0.1600e-02,
     & 0.1600e-02, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00,
     & 0.0000e+00, 0.1000e-03, 0.2000e-03, 0.3000e-03, 0.5000e-03,
     & 0.7000e-03, 0.9000e-03, 0.1100e-02, 0.1300e-02, 0.1500e-02,
     & 0.1600e-02, 0.1600e-02/
c
      data (xk(i),i=1,9)/
     & 0.2400e-03, 0.2400e-02, 0.2400e-01, 0.2400e+00, 0.2400e+01,
     & 0.2400e+02, 0.2400e+03, 0.2400e+04, 0.2400e+05/
c
      data ((hk(i,j),i=1,8),j=1,9)/
     &  3.292, 39.327, 39.240, 25.225, 61.675, 66.720, 43.777,279.255,
     &  5.900, 17.905, 15.330, 22.245, 24.090, 27.110, 29.707,142.290,
     &  9.015, 12.750, 16.982, 24.850, 32.805, 12.442, 19.220,128.070,
     &  9.635, 10.632, 23.675, 19.112, 19.722,  3.577,  5.475, 91.828,
     &  7.575, 11.047, 20.187,  6.780,  6.295,  0.682,  1.010, 53.577,
     &  7.082,  5.352,  9.040,  1.652,  1.382,  0.022,  0.025, 24.562,
     &  3.202,  1.592,  2.387,  0.397,  0.145,  0.000,  0.000,  7.725,
     &  0.880,  0.405,  0.455,  0.002,  0.000,  0.000,  0.000,  1.742,
     &  0.205,  0.012,  0.007,  0.000,  0.000,  0.000,  0.000,  0.225/
c
      data ((cah(i,j),i=1,22),j= 1, 5)/
     & 0.9923, 0.9922, 0.9921, 0.9920, 0.9916, 0.9910, 0.9899, 0.9882,
     & 0.9856, 0.9818, 0.9761, 0.9678, 0.9558, 0.9395, 0.9188, 0.8945,
     & 0.8675, 0.8376, 0.8029, 0.7621, 0.7154, 0.6647, 0.9876, 0.9876,
     & 0.9875, 0.9873, 0.9870, 0.9864, 0.9854, 0.9837, 0.9811, 0.9773,
     & 0.9718, 0.9636, 0.9518, 0.9358, 0.9153, 0.8913, 0.8647, 0.8350,
     & 0.8005, 0.7599, 0.7133, 0.6627, 0.9808, 0.9807, 0.9806, 0.9805,
     & 0.9802, 0.9796, 0.9786, 0.9769, 0.9744, 0.9707, 0.9653, 0.9573,
     & 0.9459, 0.9302, 0.9102, 0.8866, 0.8604, 0.8311, 0.7969, 0.7565,
     & 0.7101, 0.6596, 0.9708, 0.9708, 0.9707, 0.9705, 0.9702, 0.9697,
     & 0.9687, 0.9671, 0.9647, 0.9612, 0.9560, 0.9483, 0.9372, 0.9221,
     & 0.9027, 0.8798, 0.8542, 0.8253, 0.7916, 0.7515, 0.7054, 0.6551,
     & 0.9568, 0.9568, 0.9567, 0.9565, 0.9562, 0.9557, 0.9548, 0.9533,
     & 0.9510, 0.9477, 0.9428, 0.9355, 0.9250, 0.9106, 0.8921, 0.8700,
     & 0.8452, 0.8171, 0.7839, 0.7443, 0.6986, 0.6486/
      data ((cah(i,j),i=1,22),j= 6,10)/
     & 0.9377, 0.9377, 0.9376, 0.9375, 0.9372, 0.9367, 0.9359, 0.9345,
     & 0.9324, 0.9294, 0.9248, 0.9181, 0.9083, 0.8948, 0.8774, 0.8565,
     & 0.8328, 0.8055, 0.7731, 0.7342, 0.6890, 0.6395, 0.9126, 0.9126,
     & 0.9125, 0.9124, 0.9121, 0.9117, 0.9110, 0.9098, 0.9079, 0.9052,
     & 0.9012, 0.8951, 0.8862, 0.8739, 0.8579, 0.8385, 0.8161, 0.7900,
     & 0.7585, 0.7205, 0.6760, 0.6270, 0.8809, 0.8809, 0.8808, 0.8807,
     & 0.8805, 0.8802, 0.8796, 0.8786, 0.8770, 0.8747, 0.8712, 0.8659,
     & 0.8582, 0.8473, 0.8329, 0.8153, 0.7945, 0.7697, 0.7394, 0.7024,
     & 0.6588, 0.6105, 0.8427, 0.8427, 0.8427, 0.8426, 0.8424, 0.8422,
     & 0.8417, 0.8409, 0.8397, 0.8378, 0.8350, 0.8306, 0.8241, 0.8148,
     & 0.8023, 0.7866, 0.7676, 0.7444, 0.7154, 0.6796, 0.6370, 0.5897,
     & 0.7990, 0.7990, 0.7990, 0.7989, 0.7988, 0.7987, 0.7983, 0.7978,
     & 0.7969, 0.7955, 0.7933, 0.7899, 0.7846, 0.7769, 0.7664, 0.7528,
     & 0.7357, 0.7141, 0.6866, 0.6520, 0.6108, 0.5646/
      data ((cah(i,j),i=1,22),j=11,15)/
     & 0.7515, 0.7515, 0.7515, 0.7515, 0.7514, 0.7513, 0.7511, 0.7507,
     & 0.7501, 0.7491, 0.7476, 0.7450, 0.7409, 0.7347, 0.7261, 0.7144,
     & 0.6992, 0.6793, 0.6533, 0.6203, 0.5805, 0.5357, 0.7020, 0.7020,
     & 0.7020, 0.7019, 0.7019, 0.7018, 0.7017, 0.7015, 0.7011, 0.7005,
     & 0.6993, 0.6974, 0.6943, 0.6894, 0.6823, 0.6723, 0.6588, 0.6406,
     & 0.6161, 0.5847, 0.5466, 0.5034, 0.6518, 0.6518, 0.6518, 0.6518,
     & 0.6518, 0.6517, 0.6517, 0.6515, 0.6513, 0.6508, 0.6500, 0.6485,
     & 0.6459, 0.6419, 0.6359, 0.6273, 0.6151, 0.5983, 0.5755, 0.5458,
     & 0.5095, 0.4681, 0.6017, 0.6017, 0.6017, 0.6017, 0.6016, 0.6016,
     & 0.6016, 0.6015, 0.6013, 0.6009, 0.6002, 0.5989, 0.5967, 0.5932,
     & 0.5879, 0.5801, 0.5691, 0.5535, 0.5322, 0.5043, 0.4700, 0.4308,
     & 0.5518, 0.5518, 0.5518, 0.5518, 0.5518, 0.5518, 0.5517, 0.5516,
     & 0.5514, 0.5511, 0.5505, 0.5493, 0.5473, 0.5441, 0.5393, 0.5322,
     & 0.5220, 0.5076, 0.4878, 0.4617, 0.4297, 0.3929/
      data ((cah(i,j),i=1,22),j=16,19)/
     & 0.5031, 0.5031, 0.5031, 0.5031, 0.5031, 0.5030, 0.5030, 0.5029,
     & 0.5028, 0.5025, 0.5019, 0.5008, 0.4990, 0.4960, 0.4916, 0.4850,
     & 0.4757, 0.4624, 0.4441, 0.4201, 0.3904, 0.3564, 0.4565, 0.4565,
     & 0.4565, 0.4564, 0.4564, 0.4564, 0.4564, 0.4563, 0.4562, 0.4559,
     & 0.4553, 0.4544, 0.4527, 0.4500, 0.4460, 0.4400, 0.4315, 0.4194,
     & 0.4028, 0.3809, 0.3538, 0.3227, 0.4122, 0.4122, 0.4122, 0.4122,
     & 0.4122, 0.4122, 0.4122, 0.4121, 0.4120, 0.4117, 0.4112, 0.4104,
     & 0.4089, 0.4065, 0.4029, 0.3976, 0.3900, 0.3792, 0.3643, 0.3447,
     & 0.3203, 0.2923, 0.3696, 0.3696, 0.3696, 0.3696, 0.3696, 0.3696,
     & 0.3695, 0.3695, 0.3694, 0.3691, 0.3687, 0.3680, 0.3667, 0.3647,
     & 0.3615, 0.3570, 0.3504, 0.3409, 0.3279, 0.3106, 0.2892, 0.2642/
c
      data (((lr(i,j,k),i=1,10),j=1,7),k= 1, 1)/
     &    579,    461,    349,    262,    196,    147,    110,     82,
     &     61,     46,    634,    544,    458,    379,    308,    249,
     &    199,    158,    124,     97,    683,    608,    540,    478,
     &    419,    364,    314,    269,    229,    193,    731,    668,
     &    613,    562,    516,    472,    432,    394,    359,    326,
     &    768,    715,    668,    627,    588,    553,    521,    491,
     &    463,    438,    783,    734,    691,    652,    617,    585,
     &    556,    529,    505,    483,    784,    736,    693,    655,
     &    621,    589,    560,    534,    510,    488/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 2, 2)/
     &    574,    456,    346,    260,    195,    146,    109,     81,
     &     60,     45,    628,    538,    452,    373,    304,    245,
     &    196,    155,    122,     96,    674,    598,    531,    468,
     &    410,    356,    307,    262,    223,    189,    718,    654,
     &    598,    547,    500,    457,    416,    379,    345,    313,
     &    750,    695,    646,    602,    563,    527,    494,    463,
     &    436,    411,    762,    709,    663,    622,    585,    551,
     &    520,    493,    467,    445,    763,    710,    664,    623,
     &    587,    553,    523,    495,    470,    448/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 3, 3)/
     &    568,    451,    342,    257,    192,    144,    108,     80,
     &     60,     45,    620,    530,    445,    367,    298,    240,
     &    192,    152,    120,     94,    663,    587,    519,    457,
     &    399,    346,    297,    254,    216,    183,    704,    638,
     &    580,    528,    481,    438,    398,    361,    328,    297,
     &    730,    671,    620,    575,    534,    497,    463,    433,
     &    405,    381,    738,    681,    632,    589,    550,    514,
     &    482,    454,    428,    405,    739,    682,    633,    589,
     &    550,    515,    484,    455,    429,    407/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 4, 4)/
     &    561,    445,    337,    253,    189,    142,    106,     79,
     &     59,     44,    610,    520,    436,    359,    292,    234,
     &    187,    148,    117,     92,    651,    573,    505,    443,
     &    386,    334,    287,    245,    208,    176,    686,    618,
     &    559,    507,    459,    416,    377,    341,    309,    279,
     &    708,    645,    592,    544,    502,    464,    430,    400,
     &    372,    348,    713,    652,    599,    553,    512,    476,
     &    443,    413,    387,    364,    713,    652,    600,    554,
     &    513,    476,    443,    414,    388,    365/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 5, 5)/
     &    552,    437,    331,    248,    186,    139,    104,     77,
     &     58,     43,    598,    508,    425,    349,    283,    228,
     &    181,    144,    113,     89,    635,    556,    488,    427,
     &    371,    320,    274,    233,    198,    167,    666,    595,
     &    535,    482,    434,    392,    353,    318,    287,    259,
     &    682,    616,    560,    511,    468,    429,    394,    364,
     &    337,    313,    685,    620,    565,    516,    474,    436,
     &    402,    373,    346,    323,    686,    620,    565,    517,
     &    474,    436,    403,    373,    347,    324/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 6, 6)/
     &    541,    428,    324,    242,    181,    136,    101,     75,
     &     56,     42,    584,    493,    412,    338,    273,    219,
     &    175,    138,    109,     86,    617,    537,    468,    407,
     &    352,    303,    259,    220,    186,    158,    642,    569,
     &    507,    454,    406,    364,    326,    292,    263,    237,
     &    654,    584,    526,    475,    431,    391,    357,    326,
     &    300,    277,    656,    587,    528,    478,    434,    395,
     &    361,    331,    305,    283,    656,    587,    528,    478,
     &    434,    395,    361,    332,    306,    283/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 7, 7)/
     &    528,    416,    315,    235,    176,    131,     98,     73,
     &     55,     41,    566,    476,    396,    324,    261,    209,
     &    167,    132,    104,     82,    595,    514,    445,    385,
     &    331,    284,    241,    205,    173,    147,    615,    540,
     &    477,    422,    375,    333,    297,    264,    236,    212,
     &    623,    550,    489,    437,    392,    352,    318,    288,
     &    263,    241,    624,    551,    490,    439,    394,    355,
     &    320,    291,    266,    244,    624,    551,    490,    439,
     &    394,    355,    321,    291,    266,    244/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 8, 8)/
     &    511,    402,    304,    227,    169,    127,     94,     70,
     &     52,     40,    546,    456,    377,    307,    248,    198,
     &    157,    124,     98,     78,    569,    487,    419,    360,
     &    308,    262,    222,    188,    159,    134,    585,    507,
     &    443,    388,    341,    301,    265,    235,    209,    186,
     &    590,    513,    451,    398,    352,    313,    279,    250,
     &    226,    206,    590,    514,    451,    398,    353,    314,
     &    280,    252,    227,    207,    590,    514,    451,    398,
     &    353,    314,    280,    252,    227,    207/
      data (((lr(i,j,k),i=1,10),j=1,7),k= 9, 9)/
     &    492,    385,    290,    217,    162,    121,     90,     67,
     &     50,     38,    521,    432,    355,    288,    231,    184,
     &    146,    115,     91,     72,    540,    457,    389,    331,
     &    281,    238,    201,    169,    142,    121,    551,    471,
     &    406,    352,    306,    267,    233,    204,    180,    160,
     &    554,    475,    411,    358,    312,    274,    241,    214,
     &    191,    172,    555,    475,    411,    358,    313,    274,
     &    242,    214,    191,    173,    555,    475,    411,    358,
     &    313,    274,    242,    214,    191,    173/
      data (((lr(i,j,k),i=1,10),j=1,7),k=10,10)/
     &    468,    365,    275,    205,    153,    114,     85,     63,
     &     47,     36,    493,    404,    330,    266,    213,    169,
     &    134,    105,     83,     67,    507,    424,    356,    300,
     &    253,    212,    178,    149,    125,    106,    515,    433,
     &    368,    315,    270,    232,    200,    174,    152,    135,
     &    516,    435,    371,    317,    273,    236,    205,    179,
     &    158,    141,    516,    435,    371,    318,    273,    236,
     &    205,    179,    158,    142,    516,    435,    371,    318,
     &    273,    236,    205,    179,    158,    142/
      data (((lr(i,j,k),i=1,10),j=1,7),k=11,11)/
     &    441,    341,    256,    191,    142,    105,     78,     58,
     &     44,     34,    460,    373,    302,    242,    193,    152,
     &    120,     94,     75,     60,    471,    387,    321,    268,
     &    223,    185,    154,    128,    107,     91,    475,    393,
     &    329,    276,    233,    198,    168,    144,    125,    110,
     &    476,    394,    330,    278,    235,    200,    171,    147,
     &    128,    114,    476,    394,    330,    278,    235,    200,
     &    171,    147,    128,    114,    476,    394,    330,    278,
     &    235,    200,    171,    147,    128,    114/
      data (((lr(i,j,k),i=1,10),j=1,7),k=12,12)/
     &    409,    314,    235,    175,    130,     96,     71,     53,
     &     40,     31,    424,    339,    271,    216,    170,    134,
     &    105,     83,     65,     53,    431,    348,    284,    234,
     &    192,    158,    130,    107,     90,     76,    433,    351,
     &    289,    239,    198,    165,    138,    117,    101,     88,
     &    433,    352,    289,    239,    199,    166,    139,    118,
     &    102,     90,    433,    352,    289,    239,    199,    166,
     &    139,    118,    102,     90,    433,    352,    289,    239,
     &    199,    166,    139,    118,    102,     90/
      data (((lr(i,j,k),i=1,10),j=1,7),k=13,13)/
     &    373,    284,    212,    157,    116,     86,     63,     47,
     &     36,     28,    383,    301,    238,    188,    147,    115,
     &     90,     70,     56,     46,    387,    307,    247,    199,
     &    161,    131,    106,     87,     72,     62,    389,    309,
     &    249,    202,    164,    135,    111,     93,     79,     69,
     &    389,    309,    249,    202,    165,    135,    111,     93,
     &     79,     69,    389,    309,    249,    202,    165,    135,
     &    111,     93,     79,     69,    389,    309,    249,    202,
     &    165,    135,    111,     93,     79,     69/
      data (((lr(i,j,k),i=1,10),j=1,7),k=14,14)/
     &    333,    250,    186,    137,    101,     74,     55,     41,
     &     31,     24,    339,    262,    204,    159,    123,     95,
     &     74,     58,     46,     38,    341,    265,    209,    166,
     &    132,    105,     84,     68,     57,     49,    342,    266,
     &    210,    167,    133,    107,     87,     71,     60,     52,
     &    342,    266,    210,    167,    133,    107,     87,     71,
     &     60,     52,    342,    266,    210,    167,    133,    107,
     &     87,     71,     60,     52,    342,    266,    210,    167,
     &    133,    107,     87,     71,     60,     52/
      data (((lr(i,j,k),i=1,10),j=1,7),k=15,15)/
     &    289,    214,    158,    116,     85,     62,     46,     34,
     &     26,     21,    292,    221,    169,    130,    100,     76,
     &     59,     46,     36,     31,    294,    223,    172,    134,
     &    104,     82,     64,     52,     43,     37,    294,    223,
     &    172,    134,    105,     82,     65,     53,     44,     39,
     &    294,    223,    172,    134,    105,     82,     65,     53,
     &     44,     39,    294,    223,    172,    134,    105,     82,
     &     65,     53,     44,     39,    294,    223,    172,    134,
     &    105,     82,     65,     53,     44,     39/
      data (((lr(i,j,k),i=1,10),j=1,7),k=16,16)/
     &    242,    176,    129,     94,     68,     50,     36,     27,
     &     21,     17,    244,    180,    135,    102,     77,     58,
     &     44,     34,     28,     24,    244,    181,    137,    104,
     &     79,     61,     47,     37,     31,     27,    244,    181,
     &    137,    104,     80,     61,     48,     38,     31,     28,
     &    244,    181,    137,    104,     80,     61,     48,     38,
     &     31,     28,    244,    181,    137,    104,     80,     61,
     &     48,     38,     31,     28,    244,    181,    137,    104,
     &     80,     61,     48,     38,     31,     28/
      data (((lr(i,j,k),i=1,10),j=1,7),k=17,17)/
     &    193,    138,    100,     72,     52,     37,     27,     20,
     &     16,     13,    194,    140,    103,     76,     57,     42,
     &     32,     24,     20,     17,    194,    140,    103,     77,
     &     58,     43,     33,     26,     21,     19,    194,    140,
     &    103,     77,     58,     43,     33,     26,     21,     19,
     &    194,    140,    103,     77,     58,     43,     33,     26,
     &     21,     19,    194,    140,    103,     77,     58,     43,
     &     33,     26,     21,     19,    194,    140,    103,     77,
     &     58,     43,     33,     26,     21,     19/
      data (((lr(i,j,k),i=1,10),j=1,7),k=18,18)/
     &    143,    100,     71,     51,     36,     26,     19,     14,
     &     11,      9,    143,    101,     73,     53,     39,     28,
     &     21,     16,     13,     12,    143,    101,     73,     53,
     &     39,     29,     21,     16,     13,     12,    143,    101,
     &     73,     53,     39,     29,     21,     16,     14,     12,
     &    143,    101,     73,     53,     39,     29,     21,     16,
     &     14,     12,    143,    101,     73,     53,     39,     29,
     &     21,     16,     14,     12,    143,    101,     73,     53,
     &     39,     29,     21,     16,     14,     12/
      data (((lr(i,j,k),i=1,10),j=1,7),k=19,19)/
     &     94,     64,     45,     32,     22,     16,     11,      8,
     &      6,      6,     94,     64,     45,     32,     23,     16,
     &     12,      9,      7,      7,     94,     64,     45,     32,
     &     23,     17,     12,      9,      8,      7,     94,     64,
     &     45,     32,     23,     17,     12,      9,      8,      7,
     &     94,     64,     45,     32,     23,     17,     12,      9,
     &      8,      7,     94,     64,     45,     32,     23,     17,
     &     12,      9,      8,      7,     94,     64,     45,     32,
     &     23,     17,     12,      9,      8,      7/
      data (((lr(i,j,k),i=1,10),j=1,7),k=20,20)/
     &     45,     30,     21,     14,     10,      7,      5,      3,
     &      3,      2,     45,     30,     21,     14,     10,      7,
     &      5,      4,      3,      3,     45,     30,     21,     14,
     &     10,      7,      5,      4,      3,      3,     45,     30,
     &     21,     14,     10,      7,      5,      4,      3,      3,
     &     45,     30,     21,     14,     10,      7,      5,      4,
     &      3,      3,     45,     30,     21,     14,     10,      7,
     &      5,      4,      3,      3,     45,     30,     21,     14,
     &     10,      7,      5,      4,      3,      3/
      data (((lr(i,j,k),i=1,10),j=1,7),k=21,21)/
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
c
      data (((lt(i,j,k),i=1,10),j=1,7),k= 1, 1)/
     &    383,    501,    616,    708,    777,    830,    870,    901,
     &    924,    941,    316,    401,    486,    567,    642,    706,
     &    760,    805,    843,    874,    251,    316,    377,    436,
     &    494,    551,    604,    654,    700,    741,    175,    220,
     &    262,    303,    342,    381,    419,    457,    493,    529,
     &     94,    118,    141,    163,    184,    205,    225,    245,
     &    265,    285,     30,     38,     45,     52,     59,     65,
     &     72,     79,     85,     91,      3,      4,      4,      5,
     &      6,      7,      7,      8,      9,     10/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 2, 2)/
     &    378,    495,    611,    703,    773,    826,    866,    897,
     &    921,    938,    310,    394,    478,    560,    634,    698,
     &    753,    799,    837,    868,    244,    307,    367,    425,
     &    483,    539,    593,    642,    688,    730,    166,    210,
     &    250,    289,    327,    364,    401,    438,    475,    510,
     &     85,    106,    127,    147,    166,    185,    204,    223,
     &    242,    261,     24,     30,     36,     41,     47,     52,
     &     57,     63,     68,     73,      1,      2,      2,      3,
     &      3,      4,      4,      5,      5,      6/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 3, 3)/
     &    372,    489,    604,    697,    767,    821,    862,    893,
     &    917,    935,    303,    386,    469,    550,    624,    689,
     &    744,    791,    829,    861,    235,    297,    355,    412,
     &    469,    525,    578,    628,    674,    716,    156,    197,
     &    235,    272,    308,    344,    381,    417,    453,    488,
     &     74,     94,    112,    129,    147,    164,    181,    198,
     &    216,    233,     18,     22,     27,     31,     35,     39,
     &     44,     48,     52,     56,      1,      1,      1,      1,
     &      2,      2,      2,      2,      3,      3/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 4, 4)/
     &    365,    481,    596,    689,    760,    815,    856,    888,
     &    912,    931,    295,    375,    457,    538,    613,    678,
     &    734,    781,    820,    853,    225,    284,    340,    396,
     &    452,    507,    561,    611,    657,    700,    145,    182,
     &    218,    253,    287,    322,    357,    392,    427,    461,
     &     63,     80,     96,    111,    126,    141,    157,    172,
     &    188,    204,     13,     16,     19,     22,     25,     28,
     &     32,     35,     38,     41,      0,      0,      0,      0,
     &      1,      1,      1,      1,      1,      1/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 5, 5)/
     &    356,    470,    586,    680,    752,    807,    849,    881,
     &    906,    925,    285,    363,    443,    524,    598,    664,
     &    720,    768,    809,    842,    213,    269,    323,    377,
     &    432,    487,    540,    590,    637,    680,    131,    166,
     &    198,    231,    263,    296,    329,    363,    397,    431,
     &     52,     66,     79,     92,    105,    118,    131,    145,
     &    159,    173,      8,     11,     13,     15,     17,     19,
     &     21,     24,     26,     28,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 6, 6)/
     &    346,    458,    573,    668,    741,    797,    840,    873,
     &    899,    919,    272,    348,    427,    506,    581,    647,
     &    704,    753,    794,    829,    199,    252,    303,    355,
     &    408,    462,    515,    565,    612,    656,    117,    147,
     &    177,    206,    236,    267,    298,    330,    363,    397,
     &     42,     53,     63,     74,     84,     95,    107,    118,
     &    130,    143,      5,      6,      8,      9,     11,     12,
     &     14,     15,     17,     18,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 7, 7)/
     &    333,    443,    558,    653,    728,    785,    829,    863,
     &    890,    910,    258,    330,    407,    486,    560,    627,
     &    685,    735,    777,    813,    183,    232,    280,    329,
     &    381,    433,    485,    536,    584,    628,    101,    128,
     &    154,    180,    207,    235,    264,    295,    326,    358,
     &     31,     40,     48,     56,     65,     74,     83,     92,
     &    103,    113,      3,      4,      4,      5,      6,      7,
     &      8,      9,     10,     11,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 8, 8)/
     &    317,    424,    539,    636,    711,    770,    815,    851,
     &    878,    900,    241,    309,    383,    461,    535,    602,
     &    661,    712,    756,    793,    165,    210,    254,    300,
     &    349,    400,    452,    502,    550,    595,     84,    107,
     &    130,    153,    176,    201,    228,    256,    286,    317,
     &     22,     29,     35,     41,     47,     54,     61,     69,
     &     77,     86,      1,      2,      2,      3,      3,      4,
     &      4,      5,      5,      6,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k= 9, 9)/
     &    298,    402,    517,    615,    691,    751,    798,    835,
     &    864,    887,    221,    285,    355,    431,    505,    573,
     &    633,    685,    731,    770,    145,    185,    225,    268,
     &    314,    363,    413,    463,    511,    557,     68,     87,
     &    105,    125,    145,    167,    191,    217,    244,    273,
     &     15,     19,     23,     28,     32,     37,     43,     48,
     &     55,     62,      0,      1,      1,      1,      1,      1,
     &      2,      2,      2,      3,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=10,10)/
     &    277,    376,    490,    589,    667,    729,    778,    817,
     &    847,    872,    199,    257,    324,    398,    471,    539,
     &    600,    654,    700,    741,    124,    159,    194,    233,
     &    276,    322,    371,    419,    467,    513,     52,     67,
     &     82,     98,    115,    133,    154,    177,    202,    228,
     &      9,     12,     15,     17,     21,     24,     28,     32,
     &     37,     42,      0,      0,      0,      0,      0,      0,
     &      0,      1,      1,      1,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=11,11)/
     &    252,    346,    458,    558,    639,    703,    753,    794,
     &    826,    852,    174,    227,    289,    360,    432,    500,
     &    561,    616,    665,    707,    102,    131,    162,    196,
     &    235,    279,    325,    372,    418,    464,     38,     49,
     &     60,     73,     86,    101,    119,    138,    160,    184,
     &      5,      7,      8,     10,     12,     14,     16,     19,
     &     22,     26,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=12,12)/
     &    224,    311,    422,    522,    604,    671,    724,    766,
     &    801,    829,    148,    194,    250,    317,    388,    455,
     &    517,    573,    623,    667,     81,    104,    130,    159,
     &    194,    233,    276,    321,    366,    410,     26,     33,
     &     42,     51,     61,     73,     87,    103,    121,    141,
     &      2,      3,      4,      5,      6,      7,      9,     10,
     &     12,     15,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=13,13)/
     &    193,    273,    380,    480,    565,    633,    688,    733,
     &    770,    801,    121,    160,    210,    272,    339,    406,
     &    468,    524,    575,    621,     61,     79,     99,    123,
     &    153,    188,    227,    268,    311,    353,     16,     21,
     &     27,     33,     40,     49,     59,     72,     86,    103,
     &      1,      1,      2,      2,      3,      3,      4,      5,
     &      6,      7,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=14,14)/
     &    160,    231,    333,    433,    519,    589,    647,    695,
     &    734,    767,     95,    126,    169,    225,    288,    352,
     &    413,    470,    521,    568,     43,     56,     71,     90,
     &    115,    144,    178,    215,    255,    295,      9,     12,
     &     15,     19,     24,     30,     37,     46,     58,     71,
     &      0,      0,      0,      0,      1,      1,      1,      2,
     &      2,      3,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=15,15)/
     &    127,    188,    283,    381,    467,    539,    599,    649,
     &    691,    726,     70,     94,    129,    178,    236,    296,
     &    355,    411,    462,    509,     28,     37,     48,     62,
     &     80,    104,    133,    165,    200,    236,      4,      6,
     &      8,     10,     13,     16,     21,     27,     35,     45,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      1,      1,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=16,16)/
     &     95,    144,    230,    324,    410,    483,    545,    597,
     &    642,    679,     48,     66,     92,    133,    184,    239,
     &    295,    348,    398,    445,     16,     22,     29,     38,
     &     52,     70,     92,    119,    149,    180,      2,      2,
     &      3,      4,      6,      8,     10,     14,     19,     26,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=17,17)/
     &     66,    103,    177,    265,    348,    422,    485,    539,
     &    585,    625,     30,     42,     61,     92,    135,    184,
     &    234,    284,    332,    377,      8,     11,     16,     21,
     &     30,     42,     59,     80,    103,    129,      0,      1,
     &      1,      1,      2,      3,      4,      6,      9,     13,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=18,18)/
     &     41,     66,    127,    206,    285,    357,    420,    475,
     &    522,    564,     17,     24,     35,     58,     91,    132,
     &    176,    221,    265,    308,      3,      5,      7,     10,
     &     15,     23,     34,     49,     66,     87,      0,      0,
     &      0,      0,      0,      1,      1,      2,      3,      6,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=19,19)/
     &     21,     36,     82,    149,    222,    290,    351,    406,
     &    454,    496,      7,     11,     17,     32,     56,     88,
     &    124,    163,    202,    240,      1,      1,      2,      3,
     &      6,     10,     17,     26,     39,     53,      0,      0,
     &      0,      0,      0,      0,      0,      0,      1,      2,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=20,20)/
     &      8,     15,     45,     99,    162,    224,    282,    334,
     &    381,    424,      2,      3,      6,     13,     29,     52,
     &     80,    111,    144,    176,      0,      0,      0,      0,
     &      1,      3,      7,     12,     20,     29,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
      data (((lt(i,j,k),i=1,10),j=1,7),k=21,21)/
     &      0,      1,     18,     57,    108,    162,    214,    263,
     &    308,    349,      0,      0,      0,      3,     11,     26,
     &     46,     69,     95,    121,      0,      0,      0,      0,
     &      0,      0,      2,      4,      9,     14,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0,      0,      0/
c
      data ((lr2(i,j),i=1,10),j=1,7)/
     &    598,    477,    362,    272,    204,    153,    114,     85,
     &     64,     47,    660,    570,    483,    400,    327,    264,
     &    211,    168,    132,    103,    719,    647,    581,    518,
     &    457,    399,    346,    297,    253,    214,    784,    729,
     &    679,    632,    587,    543,    501,    461,    423,    387,
     &    852,    815,    781,    748,    717,    688,    659,    632,
     &    605,    580,    909,    887,    866,    846,    827,    809,
     &    791,    774,    758,    743,    949,    936,    924,    913,
     &    902,    892,    882,    873,    864,    855/
      end

C************************************************************************
c*************** u1/frmdc/joseph/solar.f ****************************
      subroutine sorad(np,nc,cs,pctop,pcbot,taucl,taual,pl,ta,wa,oa,
     $                 cmc,rsfcir,rsfcuv,sc,cosz,icosz,
     $                 rlat,month,iday,hrl,fnet,heatr)
c************************************************************************
c  computation of solar radiation
c  references: chou (1986, j. climate appl. meteor.)
c     chou (1990, j. climate), and chou (1991, j. atms. sci.)
c
c  input parameters:                              units       size
c     number of atmospheric layers (np)           n/d          1
c     number of cloud types (nc)                  n/d          1
c     cloud cover (cs)                            fraction    nc
c     cloud top   (pctop)                         mb          nc
c     cloud base  (pcbot)                         mb          nc
c     total cloud-scattering optical              n/d         nc
c       thickness (taucl)
c     aerosol optical thickness (taual)           n/d         np 
c     level pressure (pl)                         mb          np+1
c     layer temperature (ta)                      k           np
c     layer specific humidity (wa)                gm/gm       np
c     layer ozone concentration (oa)              gm/gm       np
c     co2 mixing ratio by volumn (cmc)            parts/part   1
c     near ir surface albedo (rsfcir)             fraction     1
c     uv+visible surface albedo (rsfcuv)          fraction     1
c     solar constant(sc)                          w/m**2       1
c     cosine of solar zenith angle (cosz)         n/d          1
c     latitude (rlat)                             degree       1
c     month (month): 1 for january                month        1
c     day of month (iday, 1-31)                   day          1
c     local hour (hrl,0-24)                       hr           1
c
c  the following parameters must be specified:
c     icosz: cosz is given if icosz=1 
c            otherwise, cosz is computed from rlat,
c            month, iday and hrl
c     iso:   the incoming solar flux is set equal to the
c            solar constant if iso=1. Otherwise, it is computed by
c            taking into account the effect of the sun-earth distance
c            according to latitude, month, day and hour.
c     terman:the value of cosz below which 
c            solar flux is small and not computed
c     io2:   absorption due to oxygen is included if io2=1
c     ico2:  absorption due to co2 is included if ico2=1
c
c  fixed input datae:
c     cah:   transmission in co2 bands given in block data
c
c  output parameters:
c     solar heating rate (heatr)                   c/day      np
c     net downward solar flux (fnet)               w/m**2     np+1
c
c  notes:
c     1) rlat is negative in the southern hemisphere
c     2) for a clear atmosphere, set nc=0.
c     3) if aerosol is not included, set taual(i)=0.
c
c  subroutines called: solir, soluv, and fswa (or rtable)
c**********************************************************************
c    
      parameter (lay=88)
      parameter (nnc=6)
      dimension pl(lay),pa(lay),dp(lay),ta(lay),wa(lay),oa(lay)
      dimension  wh(lay), wc(lay), o2(lay), oz(lay)
      dimension swh(lay),swc(lay),so2(lay),soz(lay)
      dimension cs(nnc),pctop(nnc),pcbot(nnc),taucl(nnc)
      dimension ict(nnc),icb(nnc)
      dimension tausct(lay),uh(lay),taual(lay),scal(lay)
      dimension firnet(lay),fuvnet(lay),fnet(lay),heatr(lay)
      dimension fco2(lay)
      common /sco2/cah(22,19)
      data iso/1/,terman/0.005/
      data io2/1/,ico2/1/
c
c-----twater and to2 are broadband transmission functions for
c     water vapor and oxygen, respectively.
c
      twater(x)=exp(-11.5*x/(1.+10.5*x+64.*x**.59))                             
      to2(x)=exp(-0.00027*sqrt(x))
c
      do 8 i=1,np
      fnet(i)=0.
      heatr(i)=0.
    8 continue
      npp1=np+1
      fnet(npp1)=0.
c
      if(icosz.ne.1) then
c
c-----compute the cosine of the solar zenith angle
c     this section follows roger davies (nasa tm 83961, 1982)
       fac=.01745
       x=float((month-1)*30+iday+month/2)
       xlat=rlat*fac
       phi=2.*3.14159*x/365.
       tphi=phi*2.
       ttphi=phi*3.
       cosphi=cos(phi)
       sinphi=sin(phi)
       costph=cos(tphi)
       sintph=sin(tphi)
       costtp=cos(ttphi)
       sinttp=sin(ttphi)
       delta=.006918-0.399912*cosphi+0.070257*sinphi-0.006758*
     *        costph+0.000907*sintph-0.002697*costtp+.00148*sinttp
       anx=(hrl-12.)*15.*fac
       eq=.000075+.001868*cosphi-.032077*sinphi-.014615*costph
     *     -.040849*sintph
       ang=anx+eq
       cosz=sin(xlat)*sin(delta)+cos(xlat)*cos(delta)*cos(ang)
      endif
c
c-----if the sun's altitude is low (cosz less than terman), solar
c     fluxes are not computed.
c
      if(cosz.lt.terman) return
      s0=sc
      if (iso.eq.1) go to 5
c
c-----compute incoming solar flux at the top of the atmosphere, s0, by
c     taking into account the effect of the sun-earth distance
c
      rad=3.1415926/180.
      alop=78.
      eccen=0.0178
      if(month.le.3) month=month+12
      date=float((month-4)*30+iday+10)/360.
      ang=6.28318*date+rad*alop
      dst=1.+eccen*cos(ang)
      dmean=1.-eccen**2
      s0=sc*(dst/dmean)**2
    5 continue
c
c-----compute mean layer pressure and layer thickness
c     layers and levels are arranged in such a way that
c     index for the surface level and surface layer
c     are np+1 and np, respectively
c
      do 10 i=1,np
      pa(i)=0.5*(pl(i)+pl(i+1))
      dp(i)=pl(i+1)-pl(i)
   10 continue
c
c-----compute scaling function
      do 20 i=1,np
      scal(i)=(pa(i)/300.)**0.8
   20 continue
c
c-----compute scaled absorber amounts for h2o(wh,swh),
c     o3(oz,soz), co2(wc,swc), and o2(o2,so2).
c     the units are g/cm**2 for wh and (cm-atm)stp for wc,o2,o3.
c
      swh(1)=0.
      soz(1)=0.
      swc(1)=0.
      so2(1)=0.
c
      do  30 i=1,np
      ip1=i+1
      xx=wa(i)*dp(i)*1.02
      wh(i)=xx*scal(i)*exp(0.00135*(ta(i)-240.0))
      swh(ip1)=swh(i)+wh(i)
      wc(i)=cmc*789.*dp(i)*scal(i)
      swc(ip1)=swc(i)+wc(i)
      o2(i)=165.22*dp(i)*scal(i)
      so2(ip1)=so2(i)+o2(i)
      oz(i)=1.02*oa(i)*dp(i)*466.7
      soz(ip1)=soz(i)+oz(i)
   30 continue
c     write(3, 40)
   40 format (' lp ',7x,'swh',12x,'soz',8x,'so2',8x,'swc')
c     write(3, 50)(lp,swh(lp),soz(lp),so2(lp),swc(lp),lp=1,np)
   50 format(1x,i2,3x,3f14.6,f10.1)
c
c-----compute the total cloud amount " sumc "
c     " ncp1 " is the index for the clear atmosphere
c     ncp1=1 if there is no cloud 
c
      sumc=0.
      ncp1=nc+1
      cs(ncp1)=1.
      if (nc.ne.0) then
      do 60 ic=1,nc
   60 sumc=sumc+cs(ic)
      cs(ncp1)=1.0-sumc
c
c-----identify indices for cloud top (ict) and cloud base (icb)
c
      do 70 ic=1,nc
      if(pcbot(ic).gt.pl(npp1)) pcbot(ic)=pl(npp1)
      ix=1
   72 ix=ix+1
      if(pl(ix).lt.pctop(ic))goto 72
      ut=pctop(ic)-pl(ix-1)
      ub=pl(ix)-pctop(ic)
      ict(ic)=ix
      if(ut.lt.ub)ict(ic)=ix-1
      ix=ict(ic)-1
   74 ix=ix+1
      if(pl(ix).lt.pcbot(ic))goto 74
      ut=pcbot(ic)-pl(ix-1)
      ub=pl(ix)-pcbot(ic)
      icb(ic)=ix
      if(ut.lt.ub)icb(ic)=ix-1
      if (ict(ic).eq.icb(ic)) ict(ic)=ict(ic)-1
c     write(3, 76) ic,ict(ic),icb(ic)
   76 format (1x,'ic,ict,icb=', 3i5)
   70 continue
      endif
c
c-----iterate over all cloudy and clear situations
c     if there are no clouds, nx=1
c     if overcast, nx=nc
c     if partly cloudy, nx=nc+1
      nx=ncp1
      if (cs(ncp1).lt.0.001) nx=nc
c
      do 200 ic=1,nx
      if (ic.eq.ncp1) itop=npp1
c
c  compute h2o content(uh) and
c  cloud-scattering optical thickness (tausct)
c
      do 80 ip=1,npp1
      tausct(ip)=0.
      uh(ip)=wh(ip)
      firnet(ip) = 0.
      fuvnet(ip) = 0.
   80 continue
c
c  for cloudy layers
      if (ic.lt.ncp1) then
      itop=ict(ic)
      ibas=icb(ic)
      dpp=pl(ibas)-pl(itop)
      ib=ibas-1
      do 84 i=itop,ib
      if (ta(i).gt.273.) xx=9.4051-2354./ta(i)
      if (ta(i).le.273.) xx=10.553-2667./ta(i)
      xx=.622*10.**xx/pa(i)
      uh(i)=1.02*xx*dp(i)*scal(i)
      tausct(i)=taucl(ic)*(dp(i)/dpp)
   84 continue
      endif
c
      if (ic.lt.ncp1) go to 90
      do 92 i=1,np
      if (taual(i).gt.0.002) go to 90
   92 continue
c
c-----compute nir fluxes in a non-scattering atmosphere 
c     the fractin of solar energy contained in nir is 0.5343
c
      ww=swh(npp1)*(1./cosz+1.9)                                              
      do 96 i=1,npp1                                                           
      w1=swh(i)/cosz                                                            
      w2=ww-swh(i)*1.9
      f1=twater(w1)                                                             
      f2=twater(w2)*rsfcir
      firnet(i)=(f1-f2)*s0*cosz*0.5343
   96 continue                                                                  
      go to 94
   90 continue
c
c-----compute nir fluxes in a scattering atmosphere
c
      call solir (np,uh,itop,tausct,taual,s0,cosz,
     *            rsfcir,firnet)
   94 continue
c
c-----compute uv+visible fluxes
c
      call soluv (np,oz,dp,itop,tausct,taual,s0,cosz,
     *            rsfcuv,fuvnet)

      do 100 i=1,npp1
      fnet(i)=fnet(i)+(firnet(i)+fuvnet(i))*cs(ic)
  100 continue
c
  200 continue
c
      if(io2.ne.1) go to 993
c
c-----compute the absorption due to oxygen
c
      s=39.2*cosz
      ww=so2(npp1)*(1./cosz+1.9)
      if(sumc .gt. 0.9995) goto 120
c
c  for clear atmosphere
      do 150 i=1,npp1
      w1=so2(i)/cosz
      w2=ww-so2(i)*1.9
      f1=1.0-to2(w1)
      f2=(1.0-to2(w2))*rsfcuv
      fnet(i)=fnet(i)-s*(f1-f2)*(1.-sumc)
  150 continue
  120 continue
c
c  for cloudy atmosphere
c  absorption by oxygen of the reflected solar flux is neglected.
c
      if(nc.eq.0.or.sumc.lt..005)goto 160
      do 170 ic=1,nc
      asyto=0.843
      tauto=taucl(ic)
      call fswa(1.0,asyto,cosz,1.0,tauto,ru0,tu0)
c     call rtable (1.0,cosx,tauto,ru0,tu0)
      do 180 ip=1,npp1
      if (ip .le. ict(ic)) then
      w1=so2(ip)/cosz
      f1=1.0-to2(w1)
      fnet(ip)=fnet(ip)-s*f1*cs(ic)
      else
      w1=w1+o2(ip-1)*1.66
      f1=(1.-to2(w1))*ru0
      fnet(ip)=fnet(ip)-s*f1*cs(ic)
      endif
  180 continue
  170 continue
  160 continue
c
  993 if(ico2.ne.1) go to 994
c
c-----table look-up for the absorption due to co2
c
      s=46.78*cosz
      do 230 i=2,npp1
      xc=swc(i)/cosz
      xw=swh(i)/cosz
      clog=alog10(xc)
      wlog=alog10(xw)
      xic=(clog+3.15)/.3+1.
      xiw=(wlog+4.15)/.3+1.
      ic=xic
      iw=xiw
      if(ic.lt.2)ic=2
      if(iw.lt.2)iw=2
      if(ic.gt.22)ic=22
      if(iw.gt.19)iw=19
      dc=clog-float(ic-2)*.3+3.
      dw=wlog-float(iw-2)*.3+4.
      x1=cah(1,iw-1)+(cah(1,iw)-cah(1,iw-1))/.3*dw
      x2=cah(ic-1,iw-1)+(cah(ic-1,iw)-cah(ic-1,iw-1))/.3*dw
      y2=x2+(cah(ic,iw-1)-cah(ic-1,iw-1))/.3*dc
      if (x1.lt.y2) x1=y2
      fco2(i)=s*(x1-y2)
  230 continue
c
      if (sumc .gt. 0.995) go to 235
c
c for clear atmosphere
      do 240 i=2,npp1
      fnet(i) = fnet(i) - fco2(i)*(1.-sumc)
  240 continue
c
c-----for cloudy atmosphere
c
  235 continue
      if(nc.eq.0 .or. sumc.lt.0.005) go to 250
c  
c-----absorption due to co2 in and below clouds is neglected
c
      do 260 ic=1,nc
      ix=ict(ic)
      do 270 i=2,ix
      fnet(i) = fnet(i) - fco2(i)*cs(ic)
  270 continue
  260 continue
  250 continue
c
  994 continue
c
c-----compute heating rate
c
      fac=3.6*24./10.03*.98
      do 320 i=1,np
      ip1=i+1
      heatr(i)=(fnet(i)-fnet(ip1))*fac/dp(i)
  320 continue
      return
      end  
c
c**************************************************************
c
      subroutine solir (np,uh,itop,tausct,tauaer,s0,cosz,
     *                  rsfcir,firnet)
c
c**************************************************************
c  compute solar flux in the near infrared region
c  the nir region is divided into 7 water vapor bands:
c  3.2, 1.87, 1.38, 1.14, 0.9, 0.8, and 0.7 microns
c
c  input parameters:                              units       size   
c     number of atmospheric layers (np)            n/d          1
c     scaled water vapor amount (uh)               gm/cm**2    np 
c     index for the cloud-top level (itop)         n/d          1
c     cloud-scattering optical thickness (tausct)  n/d         np
c     aerosol optical thickness (tauaer)           n/d         np 
c     incoming solar flux (s0)                     w/m**2       1
c     cosine of solar zenith angle (cosz)          n/d          1
c     surface albedo (rsfcir)                      fraction     1
c
c  fixed input data:
c     h2o absorption coefficient (xk)              cm**2/gm     8
c     k-distribution function    (hk)              w/m**2      8x8
c    
c  the following parameters must by specified by users:
c     cloud-droplet single scattering albedo(sacl) n/d          8
c     aerosol single scattering albedo (ssaal)     n/d          1
c     cloud asymmetry factor (asycl)               n/d          1
c     aerosol asymmetry factor (asyal)             n/d          1
c
c  output parameters:
c     net downward flux (firnet)                   w/m**2      np+1
c
c  subroutines called:  fswa (or rtable) and adding
c**************************************************************
      parameter (lay=88)
      parameter (nnc=6)
      dimension uh(lay),tausct(lay),tauaer(lay)
      dimension rr(lay),tt(lay),rstar(lay),tstar(lay),td(lay)
      dimension tb(lay,8),tbs(lay,8)
      dimension upflux(lay),dnflux(lay),firnet(lay)
      dimension xk(8),hk(8,8),sacl(8)
      data (xk(i),i=1,8)/            
     & 0.2400e-03, 0.2400e-02, 0.2400e-01, 0.2400e+00, 0.2400e+01,              
     & 0.2400e+02, 0.2400e+03, 0.2400e+04/                          
      data ((hk(i,j),i=1,8),j=1,8)/
     &  3.292, 39.327, 39.240, 25.225, 61.675, 66.720, 43.777,279.255,
     &  5.900, 17.905, 15.330, 22.245, 24.090, 27.110, 29.707,142.290,
     &  9.015, 12.750, 16.982, 24.850, 32.805, 12.442, 19.220,128.070,
     &  9.635, 10.632, 23.675, 19.112, 19.722,  3.577,  5.475, 91.828,
     &  7.575, 11.047, 20.187,  6.780,  6.295,  0.682,  1.010, 53.577,
     &  7.082,  5.352,  9.040,  1.652,  1.382,  0.022,  0.025, 24.562,
     &  3.202,  1.592,  2.387,  0.399,  0.145,  0.000,  0.000,  7.727,
     &  1.290,  0.429,  0.469,  0.000,  0.000,  0.000,  0.000,  2.190/
c
c-----the first 7 values of sacl are for the 7 absorption bands
c     the last value of sacl is the mean for the entire nir region
c
      data sacl/.96,.97,.98,.99,.995,2*.999,.99/
      data asycl/0.843/
      data ssaal/.787/,asyal/0.843/
c
      npp1=np+1
      do 50  i=1,npp1
      firnet(i)=0.0
   50 continue
c
c-----pre-compute beam and diffuse transmittances
c
      do 60 ik=1,8
      do 60 ip=1,np
      xz=xk(ik)*uh(ip)
      xz1=xz/cosz
      tb(ip,ik)=exp(-xz1)
      tbs(ip,ik)=exp(-1.66*xz)
   60 continue
c
c-----the do-loop over absorption bands ib can go either from 1 to
c     7 for individual absorption bands or from 8 to 8 if the entire
c     nir is treated as one single band
c
      rr(npp1)=rsfcir
c     do 100 ib=8,8
      do 100 ib=1,7
      ssacl=sacl(ib)
c
c-----ik is the index for the k-distribution function (or the
c     absorption coefficient)
c
      do 200 ik=1,8
      if (hk(ib,ik).lt.0.001) go to 200
c
      do 300 ip=1,np
c
c-----skip to 70 if there is no scattering
      if (tauaer(ip).lt.0.002.and.tausct(ip).lt.0.002) go to 70
c
c-----for scattering layers
c     tausct is the cloud scattering optical thickness
c     tauabs is the cloud absorption optical thickness
c
      taual=tauaer(ip)
      tauabs=tausct(ip)/ssacl-tausct(ip)
      taucl=tausct(ip)+tauabs
      tauwv=xk(ik)*uh(ip)
c
c-----compute total optical thickness, single scattering albedo,
c     and asymmetry factor
      tauto=tauwv+taucl+taual
      ssato=(ssacl*taucl+ssaal*taual)/tauto 
      asyto=(asycl*ssacl*taucl+asyal*ssaal*taual)/
     &      (ssato*tauto)
      td(ip)=exp(-tauto/cosz)
c
c-----compute reflection and transmission for each layer
c     rr and tt are reflection and transmission illuminated from
c     above, rstar and tstar are reflection and transmission
c     illuminated from below
c
c-----rtable is for computing cloud abledo with an asymmtry
c     of 0.843.  it should not be used if the optical thickness
c     is less than 0.05.
c
      cosx=0.602
      call fswa   (ssato,asyto,cosx,1.0,tauto,ru0,tu0)
c     call rtable (ssato,cosx,tauto,ru0,tu0)
      rstar(ip)=ru0
      tstar(ip)=tu0
c
      if (ip.le.itop) then
      cosx=cosz
      call fswa   (ssato,asyto,cosx,1.0,tauto,ru0,tu0)
c     call rtable (ssato,cosx,tauto,ru0,tu0)
      endif
      rr(ip)=ru0
      tt(ip)=tu0
      go to 300
   70 continue
c
c-----for clear layers
c     td and tt are, respectively, direct and total transmitttaces
c     illuminated from above
c
      rr(ip)=0.
      rstar(ip)=0.
      tstar(ip)=tbs(ip,ik)
      if (ip.gt.itop) then
      tt(ip)=tbs(ip,ik)
      td(ip)=0.
      else
      tt(ip)=tb(ip,ik)
      td(ip)=tb(ip,ik)
      endif
  300 continue
c
c-----compute upward and downward fluxes at each level
c     using a two-stream adding method
c
      call adding (npp1,td,rr,tt,rstar,tstar,upflux,dnflux)
      wt=hk(ib,ik)*(s0/1365.0)*cosz
      do 90 ip=1,npp1
      firnet(ip) = firnet(ip) + (dnflux(ip)-upflux(ip))*wt
   90  continue
c
  200 continue
  100 continue
      return
      end
c
c*****************************************************************
c
      subroutine soluv (np,oz,dp,itop,tausct,tauaer,s0,cosz,
     *                  rsfcuv,fuvnet)
c
c**************************************************************
c  compute solar flux in the uv+visible region
c  the uv+visible region is grouped into 4 bands:
c  (.225-.285);(.175-.225,.285-.3);(.3-0.325);(.325-.69)
c
c  input parameters:                              units        size   
c     number of atmospheric layers (np)            n/d           1
c     scaled ozone amount (oz)                  (cm-atm)stp      1
c     thickness of atmospehric layers (dp)         mb           np
c     index for the cloud-top level (itop)         n/d           1
c     cloud-scattering optical thickness(tausct)   n/d          np
c     aerosol optical thickness (tauaer)           n/d          np 
c     incoming solar flux (s0)                     w/m**2        1
c     cosine of solar zenith angle (cosz)          n/d           1
c     surface albedo (rsfcuv)                      fraction      1
c    
c  fixed input data:
c     spectral-integrated solar flux (sflux)       w/m**2        4
c     rayleigh optical thickness (ray)             /mb           4
c     ozone absorption coefficient (ozo)        /(cm-atm)stp     4
c    
c  the following parameters must by specified by users:
c     cloud asymmetry factor (asycl)               n/a           1
c     aerosol single scattering albedo (ssaal)     n/a           1
c     aerosol asymmetry factor (asyal)             n/a            1
c
c  output parameters:
c     net downward flux (fuvnet)                   w/m**2       np+1
c
c  subroutines called:  fswa (or rtable) and adding
c**************************************************************
      parameter (lay=88)
      parameter (nnc=6)
      dimension oz(lay),dp(lay),tausct(lay),tauaer(lay)
      dimension rr(lay),tt(lay),rstar(lay),tstar(lay),td(lay)
      dimension tb(lay),tbs(lay)
      dimension upflux(lay),dnflux(lay),fuvnet(lay)
      dimension sflux(4),ray(4),ozo(4)
c
c-----solar flux and depletion coefficients of the four bands
c
      data sflux/7.245,6.901,15.16,608.35/
      data ray /0.188e-2,0.158e-2,0.954e-3,0.174e-3/
      data ozo /0.1805e+3,0.267e+2,0.199e+1,0.050/
c
      data asycl,asyal/0.843,0.843/
      data ssaal/0.787/
c
      npp1=np+1
      do 50 i=1,npp1
      fuvnet(i)=0.
   50 continue
c
c-----integration over spectral bands
c
      rr(npp1)=rsfcuv
      do 100 iv=1,4
c
c-----iteration over layers
c 
      do 200 ip=1,np
      taual=tauaer(ip)
      taucl=tausct(ip)
      taurs=ray(iv)*dp(ip)
      tauoz=ozo(iv)*oz(ip)
c
c-----compute total optical thickness, single scattering albedo,
c     and asymmetry factor
c
      tauto=taucl+taual+taurs+tauoz
      ssato=(taucl+ssaal*taual+taurs)/tauto
      td(ip)=exp(-tauto/cosz)
c
c-----skip to 60 if absorption is much larger than scattering
      if (ssato.lt.0.002)go to 60
c
c-----for scattering layers
c
      asyto=(asycl*taucl+asyal*ssaal*taual)/(ssato*tauto)
      cosx=0.602
c
c-----rtable is for computing cloud abledo with an asymmtry
c     of 0.843.  it should not be used if the optical thickness
c     is less than 0.05.
c
      call fswa(ssato,asyto,cosx,1.0,tauto,ru0,tu0)
c     call rtable (ssato,cosx,tauto,ru0,tu0)
      rstar(ip)=ru0
      tstar(ip)=tu0
      if (ip.le.itop) then
      cosx=cosz
      call fswa(ssato,asyto,cosx,1.0,tauto,ru0,tu0)
c     call rtable (ssato,cosx,tauto,ru0,tu0)
      endif
      rr(ip)=ru0
      tt(ip)=tu0
      go to 200
   60 continue    
c
c-----for absorption layers
c
      rr(ip)=0.0
      rstar(ip)=0.0
      tstar(ip)=exp(-1.66*tauto)
      if (ip.gt.itop) then
      tt(ip)=tstar(ip)
      td(ip)=0.
      else
      tt(ip)=td(ip)
      endif
  200 continue
c
c-----compute upward and downward fluxes at each level
c     using a two-stream adding method
c
      call adding (npp1,td,rr,tt,rstar,tstar,upflux,dnflux)
c
      wt=sflux(iv)*(s0/1365.0)*cosz
      do 80 ip=1,npp1
      fuvnet(ip)=fuvnet(ip)+(dnflux(ip)-upflux(ip))*wt
   80 continue
  100 continue
      return
      end
c******** u1/frmdc/joseph/fswa.f*****************************
c
        subroutine fswa(wxx,gxx,u0xx,f0xx,ttxx,ru0,tu0)     
c
c*************************************************************
c--compute transmittance and reflectance of a layer using
c  the 4-stream discrete ordinate method of Liou, Fu and Ackerman
c  ackerman (1988, JAS).  This code is provided by dr. qiang fu
c
c  input parameters:
c     wxx: single scattering albedo
c     gxx: asymmetry factor
c     u0xx:  cosine of the solar zenith angle
c     ttxx: optical thickness
c
c  output parameters:
c     ru0:   reflectance
c     tu0:   transmittance
c
c  note:   
c    (1) the flux reflected by the layer is (u0xx*f0xx)*ru0
c    (2) for wxx=0.8, gxx=0.75, u0xx=0.1, f0xx=1., and ttxx=4.
c        results whould be ru0=0.36061 and tu0=0.04775.
c
c  subroutines called:
c     coeff1, coeff2, coeff4, coeffl, gs4, giaf
c*************************************************************
        dimension b(4,3),a(2,2,2),d(4),z(4),a1(4,4),z1(4),
     1  gg(4),f(2),fit(4),fib(4)
        dimension ac(4),u(4)
        common /dis/ac
        common /point/u
        data ac/0.5,0.5,0.5,0.5/
        data u/-0.7886752,-0.2113247,0.2113247,0.7886752/
c       data ac/.3478548,.6521452,.6521452,.3478547/
c       data u/-.8611363,-.3399810,.3399810,.8611363/
        w=wxx
        g=gxx
        f0=f0xx
        u0=u0xx
        tt=ttxx
        if(w.lt.0.99999) goto 10
        w=0.99999
  10    continue
        ff=g*g*g*g
        ww=w
        w=(1.0-ff)*ww/(1.0-ff*ww)
        t1=tt*(1.0-ff*ww)
        call coeff1(w,g,b,u0)
        call coeff2(b,a,d,u0)
        call coeff4(a,d,b1,c1,z,u0)
        call coeffl(b1,c1,z,t1,u0,a,b,gg,a1,z1,fk1,fk2,f0)
        t=0.0
        call qiaf(fk1,fk2,t1,t,u0,gg,a1,z1,f0,fit,f)
        x=3.14159*u0*f0
        ru0=f(1)/x
        t=t1
        call qiaf(fk1,fk2,t1,t,u0,gg,a1,z1,f0,fib,f)
        tu0=-1.0*f(2)/x
        return
        end
c
        function p0(x)
        p0=1.0
        return
        end
c
        function p1(x)
        p1=x
        return
        end
c
        function p2(x)
        p2=1.5*x*x-0.5
        return
        end
c
        function p3(x)
        p3=2.5*x*x*x-1.5*x
        return
        end
c
        function p(x,g)
        yy=g*g
        p=(1.0-yy)/(1.0+yy-2.0*g*x)**1.5
        return
        end  
c
c *****************************************************************************
c coefficient calculations for four first-order differential equations.
c *****************************************************************************
        subroutine coeff1(w,g,b,u0)
        dimension c(4,5),u(5),a(5),b(4,3)
        common /dis/a1(4)
        common /point/u1(4)
        do 200 i=1,4
        u(i)=u1(i)
        a(i)=a1(i)
 200    continue
        u(5)=-u0
        a(5)=1.0
c **************************************************************************
        y1=g
        y2=y1*g
        y3=y2*g
        y4=y3*g
        w0=1.0
        w1=3.0*y1
        w2=5.0*y2
        w3=7.0*y3
        w4=9.0*y4
        f=w4/9.0
c w0, w1, w2, w3 and w4 are the first five expansion coefficients when the 
c scattering phase function is expanded as the Legendre polynomial series.
c When Henyey-Greenstein phase function is used, Wl=(2*l+1)*g**l.
c **************************************************************************
        x=0.5*w/(1.0-f)
        w01=(w0-f)*x
        w11=(w1-3.0*f)*x
        w21=(w2-5.0*f)*x
        w31=(w3-7.0*f)*x
c w01, w11, w21 and w31 are the first four expansion coefficients after
c incorporating the delta-forward adjustment to account for the forward
c diffraction peak.
c ************************************************************************
        do 10 i=1,4
        o0=w01*p0(u(i))
        o1=w11*p1(u(i))
        o2=w21*p2(u(i))
        o3=w31*p3(u(i))
        do 20 j=1,5
        c(i,j)=a(j)*(o0*p0(u(j))+o1*p1(u(j))+o2*p2(u(j))+o3*p3(u(j)))
        if (i.eq.j) goto 100
        c(i,j)=c(i,j)/u(i)
        goto 20
 100    c(i,j)=(c(i,j)-1)/u(i)
 20     continue
 10     continue
        b(1,1)=c(4,4)-c(4,1)
        b(1,2)=c(4,4)+c(4,1)
        b(2,1)=c(4,3)-c(4,2)
        b(2,2)=c(4,3)+c(4,2)
        b(3,1)=c(3,4)-c(3,1)
        b(3,2)=c(3,4)+c(3,1)
        b(4,1)=c(3,3)-c(3,2)
        b(4,2)=c(3,3)+c(3,2)
        b(1,3)=c(4,5)-c(1,5)
        b(2,3)=c(3,5)-c(2,5)
        b(3,3)=c(3,5)+c(2,5)
        b(4,3)=c(4,5)+c(1,5)
        return
        end
c
c ****************************************************************************
c coefficient calculations for second-order differential equations.
c ****************************************************************************
        subroutine coeff2(b,a,d,u0)
        dimension b(4,3),a(2,2,2),d(4)
        a(2,2,1)=b(1,1)*b(1,2)+b(2,1)*b(3,2)
        a(2,1,1)=b(1,1)*b(2,2)+b(2,1)*b(4,2)
        a(1,2,1)=b(3,1)*b(1,2)+b(4,1)*b(3,2)
        a(1,1,1)=b(3,1)*b(2,2)+b(4,1)*b(4,2)
        a(2,2,2)=b(1,2)*b(1,1)+b(2,2)*b(3,1)
        a(2,1,2)=b(1,2)*b(2,1)+b(2,2)*b(4,1)
        a(1,2,2)=b(3,2)*b(1,1)+b(4,2)*b(3,1)
        a(1,1,2)=b(3,2)*b(2,1)+b(4,2)*b(4,1)
        d(1)=b(3,2)*b(4,3)+b(4,2)*b(3,3)+b(2,3)/u0
        d(2)=b(1,2)*b(4,3)+b(2,2)*b(3,3)+b(1,3)/u0
        d(3)=b(3,1)*b(1,3)+b(4,1)*b(2,3)+b(3,3)/u0
        d(4)=b(1,1)*b(1,3)+b(2,1)*b(2,3)+b(4,3)/u0
        return
        end
c
c **************************************************************************
c coefficient calculations for fourth-order differential equations.
c **************************************************************************
        subroutine coeff4(a,d,b1,c1,z,u0)
        dimension z(4),a(2,2,2),d(4)
        x=u0*u0
        b1=a(2,2,1)+a(1,1,1)
        c1=a(2,1,1)*a(1,2,1)-a(1,1,1)*a(2,2,1)
        z(1)=a(2,1,1)*d(3)+d(4)/x-a(1,1,1)*d(4)
        z(2)=a(1,2,1)*d(4)-a(2,2,1)*d(3)+d(3)/x
        z(3)=a(2,1,2)*d(1)+d(2)/x-a(1,1,2)*d(2)
        z(4)=a(1,2,2)*d(2)-a(2,2,2)*d(1)+d(1)/x
        return
        end
c
        subroutine coeffl(b1,c1,z,t1,u0,a,b,gg,a1,z1,fk1,fk2,f0)
        dimension z(4),a(2,2,2),b(4,3),aa(4,4),zz(4)
        dimension z1(4),a1(4,4),gg(4)
        x=sqrt(b1*b1+4.0*c1)
        fk1=sqrt((b1+x)*0.5)
        fk2=sqrt((b1-x)*0.5)
        x=1/(u0*u0*u0*u0)-b1/(u0*u0)-c1
        do 10 i=1,4
        z(i)=0.5*f0*z(i)/x
 10     continue
        z1(1)=0.5*(z(1)+z(3))
        z1(2)=0.5*(z(2)+z(4))
        z1(3)=0.5*(z(2)-z(4))
        z1(4)=0.5*(z(1)-z(3))
        fq=exp(-t1/u0)
        zz(1)=(-z1(1))*fq
        zz(2)=(-z1(2))*fq
        zz(3)=-z1(3)
        zz(4)=-z1(4)
c ****************************************************************************
c With diffuse radiation from the top and bottom of this layer, just modify
c the terms zz(1), zz(2), zz(3) and zz(4) to include the diffuse boundary
c effects.
c ****************************************************************************
        a2=(fk1*fk1-a(2,2,1))/a(2,1,1)
        b2=(fk2*fk2-a(2,2,1))/a(2,1,1)
        x=b(1,1)*b(4,1)-b(3,1)*b(2,1)
        y=fk2*(b2*b(2,1)-b(4,1))/x
        zx=fk1*(a2*b(2,1)-b(4,1))/x
        a1(1,1)=0.5*(1-y)
        a1(1,2)=0.5*(1-zx)
        a1(1,3)=0.5*(1+zx)
        a1(1,4)=0.5*(1+y)
        y=fk2*(b(3,1)-b2*b(1,1))/x
        zx=fk1*(b(3,1)-a2*b(1,1))/x
        a1(2,1)=0.5*(b2-y)
        a1(2,2)=0.5*(a2-zx)
        a1(2,3)=0.5*(a2+zx)
        a1(2,4)=0.5*(b2+y)
        do 20 i=3,4
        do 30 j=1,4
        k=5-i
        l=5-j
        a1(i,j)=a1(k,l)
 30     continue
 20     continue
        do 40 i=1,2
        do 40 j=3,4
        aa(i,j)=a1(i,j)
        aa(j,i)=a1(j,i)
 40     continue
        x=exp(-fk2*t1)
        aa(1,1)=a1(1,1)*x
        aa(2,1)=a1(2,1)*x
        aa(3,4)=a1(3,4)*x
        aa(4,4)=a1(4,4)*x
        x=exp(-fk1*t1)
        aa(1,2)=a1(1,2)*x
        aa(2,2)=a1(2,2)*x
        aa(3,3)=a1(3,3)*x
        aa(4,3)=a1(4,3)*x
        call gs4(4,aa,zz,0.1e-10,kwji,gg)
        return
        end
c
c ***************************************************************************
c subroutine for solving linear algebraic equations.
c ***************************************************************************
        subroutine gs4(n,a,b,ep,kwji,x)
        dimension a(n,n),b(n),m(100),x(n)
        do 10 i=1,n
 10     m(i)=i
        do 20 k=1,n
        p=0.0
        do 30 i=k,n
        do 30 j=k,n
        if(abs(a(i,j)).le.abs(p)) goto 30
        p=a(i,j)
        io=i
        jo=j
 30     continue
        if(abs(p)-ep) 200,200,300
 200    kwji=1
        return
 300    if(jo.eq.k) goto400
        do 40 i=1,n
        t=a(i,jo)
        a(i,jo)=a(i,k)
 40     a(i,k)=t
        j=m(k)
        m(k)=m(jo)
        m(jo)=j
 400    if(io.eq.k) goto 500
        do 50 j=k,n
        t=a(io,j)
        a(io,j)=a(k,j)
 50     a(k,j)=t
        t=b(io)
        b(io)=b(k)
        b(k)=t
 500    p=1/p
        in=n-1
        if(k.eq.n) goto 600
        do 60 j=k,in
 60     a(k,j+1)=a(k,j+1)*p
 600    b(k)=b(k)*p
        if(k.eq.n) goto20
        do 70 i=k,in
        do 80 j=k,in
 80     a(i+1,j+1)=a(i+1,j+1)-a(i+1,k)*a(k,j+1)
 70     b(i+1)=b(i+1)-a(i+1,k)*b(k)
 20     continue
        do 90 i1=2,n
        i=n+1-i1
        do 90 j=i,in
 90     b(i)=b(i)-a(i,j+1)*b(j+1)
        do 1 k=1,n
        i=m(k)
 1      a(1,i)=b(k)
        do 2 k=1,n
 2      b(k)=a(1,k)
        kwji=1
        do 33 i=1,n
 33     x(i)=b(i)
        return
        end
c
        subroutine qiaf(fk1,fk2,t1,t,u0,gg,a1,z1,f0,fi,f)
        common/dis/a(4)/point/u(4)
        dimension gg(4),a1(4,4),a2(4,4),z1(4),fi(4),f(2)
        dt=t1-t
        x=exp(-fk2*t)
        y=exp(-fk2*dt)
        do 10 i=1,4
        a2(i,1)=a1(i,1)*x*gg(1)
 10     a2(i,4)=a1(i,4)*y*gg(4)
        x=exp(-fk1*t)
        y=exp(-fk1*dt)
        do 20 i=1,4
        a2(i,2)=a1(i,2)*x*gg(2)
        a2(i,3)=a1(i,3)*y*gg(3)
 20     continue
        wm=t/u0
        x=exp(-wm)
        do 30 i=1,4
        fi(i)=z1(i)*x
 30     continue
        do 40 i=1,4
        do 50 j=1,4
        fi(i)=fi(i)+a2(i,j)
 50     continue
 40     continue
        f(1)=2.0*3.14159*(a(3)*u(3)*fi(2)+a(4)*u(4)*fi(1))
        f(2)=-2.0*3.14159*(a(3)*u(3)*fi(3)+a(4)*u(4)*fi(4))
     1  -u0*3.14159*f0*x
        return
        end

c************* u1/frmdc/joseph/sosub.f *******************************
      subroutine adding (np1,tb,r,t,rs,ts,upflux,dwflux)
c*********************************************************************
c  compute upward and downward fluxes using a two-stream adding method
c  the direct radiation is separated from the diffuse radiation
c  
c  input parameters:
c     np1:total number of layers (including the surface)
c     tb: direct beam tranmssion
c     t:  transmission of a layer illuminated by direct radiation
c     r:  reflection of a layer illuminated by direct radiation
c     ts: transmission of a layer illuminated by diffuse radiation
c     rs: reflection of a layer illuminated by diffuse radiation
c
c  output parameters:
c     upflux:  upward fluxes
c     dwflux:  downward fluxes
c*********************************************************************
      parameter (lay=88)
      dimension tb(lay),r(lay),t(lay),rs(lay),ts(lay)
      dimension rab(lay,lay),tab(lay,lay),tbab(lay),
     *          rsab(lay,lay),tsab(lay,lay),rssab(lay,lay)
      dimension upflux(lay),dwflux(lay)
c
      nlay= np1  - 1
      nm1 = nlay - 1
c
c-----boundary conditions
c
      tbab(1) = tb(1)
      rab(1,1) = r(1)
      tab(1,1) = t(1)
      rsab(1,1) = rs(1)
      rssab(1,1) = rs(1)
      tsab(1,1) = ts(1)
      rab(np1,np1) = r(np1)
      rsab(np1,np1) = r(np1)
c
c-----layers are added one at a time, going down, to obtain rab(1,i)
c     tab(1,i) and tbab(i-1) for i=2,nlay+1 and rsab(1,i), rssab(1,i)
c     and tsab(1,i) for i=2,nlay
c     rsab  is the diffuse reflectance illuminated from above
c     rssab is the diffuse reflectance illuminated from below
c
      do 50 l=2,np1
      denm = 1. - rssab(1,l-1)*rs(l)
      rab(1,l) = rab(1,l-1)+tsab(1,l-1)*(tbab(l-1)*r(l)
     *           +(tab(1,l-1)-tbab(l-1))*rs(l))/denm
      if(l .eq. np1) goto 50
      tbab(l)=tbab(l-1)*tb(l)
      tab(1,l) = tbab(l-1)*t(l)+ts(l)*(tbab(l-1)*rssab(1,l-1)*r(l)
     *           +(tab(1,l-1)-tbab(l-1)))/denm
      rssab(1,l) = rs(l) + ts(l)*rssab(1,l-1)*ts(l)/denm
      tsab(1,l) = ts(l)*tsab(1,l-1)/denm
  50  continue
c
c
c-----layers are added one at a time, going up, to obtain
c     rab(nlay+1-l,nlay+1) for l=1,nlay-1 starting with the ground layer
c
      do 100 l=1,nlay
c     do 100 l=1,nm1
      denm = 1. - rs(np1-l)*rsab(np1-l+1,np1)
      rab(np1-l,np1)=r(np1-l)+ts(np1-l)*(tb(np1-l)*rab(np1-l+1,np1)
     *       +(t(np1-l)-tb(np1-l))*rsab(np1-l+1,np1))/denm
      rsab(np1-l,np1)=rs(np1-l)+ts(np1-l)*rsab(np1-l+1,np1)
     *       *ts(np1-l)/denm
 100  continue
c     write (3,1033) (i,rab(1,i),rab(i,np1),i=1,np1)
 1033 format (i4,2f8.3)
c
c-----as two composite layers, say (1,l) and (l+1,nlay+1), are added,
c     the upward and downward fluxes (normalized by the incoming flux)
c     at the boundary between the two layers are determined as belows
c
      do 150 l=2,np1
      denm = 1.- rssab(1,l-1)*rsab(l,np1)
      upflux(l)=(tbab(l-1)*rab(l,np1)+(tab(1,l-1)-tbab(l-1))
     *            *rsab(l,np1))/denm
      dwflux(l) = tbab(l-1)+(tbab(l-1)*rab(l,np1)*rssab(1,l-1)
     *            +(tab(1,l-1)-tbab(l-1)))/denm
 150  continue
      upflux(1) = rab(1,np1)
      dwflux(1) = 1.0
      return
      end
c
      subroutine rtable(w0,cosx,delt,rout,tout)                                
c************************************************************************      
c  interpolate transmissivity and reflectivity from the table lt and           
c  lr or lr2                                                                   
c                                                                              
c  input parameters:                                                           
c     w0:    sigle scattering albedo                                           
c     cosx:  solar zenith angle                                                
c     delt:  cloud optical thickness                                           
c  required data:                                                              
c     lr:    table of reflectivities                                           
c     lt:    table of transmissivities                                         
c     lr2:   table of reflectivities (for w0=1.)                               
c                                                                              
c  output parameters:                                                          
c     rout:  reflectivity                                                      
c     tout:  transmissivity                                                    
c  note:  tables lr, lt and lr2 are computed for a cloud asymmetry             
c         factor equal to 0.843                                                
c                                                                              
c*************************************************************************     
c
      common/rtdata/lr(10,10,31),lt(10,10,31),lr2(10,10)
      iu=cosx/0.1 + 1                                                          
      if(iu.lt.1) iu=1                                                         
      if(iu.gt.9) iu=9                                                         
      cosz=float(iu)*0.1 - 0.05                                                
      slu=(cosx-cosz)/0.1                                                      
c                                                            
c-----the first value of optical thickness for the tables is .125
c     the value 1.0536 is -log10(.125*.0625)/2.
      taux=alog10(delt)                                                        
      itau=(taux+1.053605)/0.30103 + 1                                         
      if(itau.lt.1) itau=1                                                     
      if(itau.gt.9) itau=9                                                     
      taus=float(itau-1)*0.30103-0.9031                                        
      sltau=(taux-taus)/0.30103                                                
      if(w0.gt.0.999) go to 50                                                 
c  for the case with absorption                                                
      wx=alog10(1.-w0)                                                         
      iw=(wx+3.05)/0.1 + 1                                                     
      if(iw.lt.1) iw=1                                                         
      if(iw.gt.30) iw=30                                                       
      sigma=-3.+float(iw-1)*0.1                                                
      slw=(wx-sigma)/0.1                                                       
c                                                                              
      rout=(float(lr(iu,itau,iw)) +                                            
     $     (float(lr(iu+1,itau,iw))-float(lr(iu,itau,iw)))*slu +               
     $     (float(lr(iu,itau+1,iw))-float(lr(iu,itau,iw)))*sltau +             
     $     (float(lr(iu,itau,iw+1))-float(lr(iu,itau,iw)))*slw)*.001           
      iu1=iu+1                                                                 
      it1=itau+1                                                               
      iw1=iw+1                                                                 
      tout=(float(lt(iu,itau,iw)) +                                            
     $     (float(lt(iu+1,itau,iw))-float(lt(iu,itau,iw)))*slu +               
     $     (float(lt(iu,itau+1,iw))-float(lt(iu,itau,iw)))*sltau +             
     $     (float(lt(iu,itau,iw+1))-float(lt(iu,itau,iw)))*slw)*.001           
      if(rout.gt.1.0) rout=1.0                                                 
      if(tout.gt.1.0) tout=1.0                                                 
      if(rout.lt.0.0) rout=0.0                                                 
      if(tout.lt.0.0) tout=0.0                                                 
      go to 99                                                                 
c  for the case without absorption                                             
  50  continue                                                                 
      rout=(float(lr2(iu,itau)) +                                              
     $     (float(lr2(iu+1,itau))-float(lr2(iu,itau)))*slu +                   
     $     (float(lr2(iu,itau+1))-float(lr2(iu,itau)))*sltau)*.001          
      if(rout.gt.1.0) rout=1.0                                                
      if(rout.lt.0.0) rout=0.0                                                
      tout=1.-rout                                                             
  99  continue                                                                 
      return                                                                   
      end                                                                      
*---------------------------------------------------------------------------*
*:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::*
*---------------------------------------------------------------------------*
*---------------------------------------------------------------------------*
*---------------------------------------------------------------------------*
      SUBROUTINE CLDPRM(NL,PLEVEL,PLAYER,TLAYER,WLAYER,QLAYER,
     &                  QLWC,QLWP,RHO,REFF,TAUSWC,EMSSLW)
*
*  COMPUTE CLOUD MICROPHYSICAL AND RADIATIVE PARAMETERS
*
*  REVISED :  SETEMBER  1990  (NILTON RENNO)
*
*  ARGUMENT LIST :
*
*           NL      = (NLAYER) NUMBER OF LAYERS (ONE WILL BE ADDED AT TOP)
*           PLEVEL  = PRESSURE AT EACH LEVEL (mb)
*
*           PLAYER  = LAYER PRESSURES (mb)
*           TLAYER  = LAYER TEMPERATURES (DEG k)
*           WLAYER  = LAYER WATER VAPOR MIXING RATIOS (G/G)
*           QLAYER  = LAYER LIQUID WATER MIXING RATIOS (G/G)
*
*  COMPUTED :
*
*           QLWP    = LIQUID WATER PATH IN G/M**2 IN EACH LAYER
*           QLWC    = LIQUID WATER CONCENTRATION IN G/M**3 IN EACH LAYER
*           REFF    = THE LIQUID WATER EFFECTIVE RADIUS EACH LAYER (MICRONS)
*           TAUSWC  = THE SHORTWAVE SINGLE-LAYER OPTICAL THICKNESS
*           EMSSLW  = THE LONGWAVE CLOUD LAYER EMISSIVITY
*           RHO     = THE DENSITY (G/M**3)
*
*
      REAL PLEVEL(*),PLAYER(*),TLAYER(*),WLAYER(*),QLAYER(*)
      REAL QLWC(*),QLWP(*)
      REAL RHO(*), REFF(*)
      REAL TAUSWC(*),EMSSLW(*)
*
      IF(NL.LE. 0) STOP 'NL.LE. 0 IN CLDPRM'
*
      SUMLWP=0.
      SUMTAU=0.
c      WRITE(13,901)
c901   FORMAT(//,'     BLCLD :      PLEVEL      PLAYER      QLAYER',//)
c902   FORMAT(I12,2F12.2,F12.6)
      DO 100 L=1,NL
      RHO(L) =ATMDEN(PLAYER(L),TLAYER(L),WLAYER(L))
      QLWC(L)=QLAYER(L)*RHO(L)
*     Modified by Nilton Renno --An ERROR was found-- before was 9.81E-05 ** ?
*                                ------------------
      QLWP(L)=QLAYER(L)*(PLEVEL(L+1)-PLEVEL(L))/9.81E-02
      REFF(L)=11.*QLWC(L)+4.
      TAUSWC(L)=1.5*QLWP(L)/REFF(L)
*     TAULOG=0.
*     TAUSWC(L)=0.
*     IF(QLWP(L).GT.1.) TAULOG=0.3000+1.6800*ALOG(ALOG10(QLWP(L)))
*     IF(QLWP(L).GT.1.) TAUSWC(L)=10.**TAULOG
      EMSSLW(L)=1.
      IF(QLWP(L).LT.500.) EMSSLW(L)=1.-EXP(-0.15*QLWP(L))
      SUMLWP=SUMLWP+QLWP(L)
      SUMTAU=SUMTAU+TAUSWC(L)
c      IF(QLAYER(L).GT.0.) WRITE(13,902) L,PLEVEL(L),PLAYER(L),QLAYER(L)
100   CONTINUE
*
      TAUSGL=0.
      IF(SUMLWP.GT.1.) TAULOG=0.3000+1.6800*ALOG(ALOG10(SUMLWP))
      IF(SUMLWP.GT.1.) TAUSGL=10.**TAULOG
c*     WRITE(6,990) SUMLWP,TAUSGL,SUMTAU
c990   FORMAT(///,10X,'TOTAL LIQUID WATER PATH IS  ( G/M**2 ) ',F10.3,
c     &        //,10X,'OPTICAL THICKNESS BASED ON LOG FORMULA ',F10.3,
c     &        //,10X,'OPTICAL THICKNESS BASED ON  QLWP/REFF  ',F10.3,//)
*
      RETURN
      END
      FUNCTION ATMDEN(P,T,R)
*
*     ATMDEN   :   ATMOSPHERIC DENSITY (G/M**3)
*     P        :   TOTAL PRESSURE (MBAR)
*     T        :   TEMPERATURE (K)
*     R        :   DIMENSIONLESS WATER VAPOR MASS MIXING RATIO (GM/GM)
*
      DATA RD /287.05 /, EPS /0.622/
      VIRTEM = T * (1.+R/EPS)/(1.+R)
      ATMDEN = 1.E+5*P/(RD*VIRTEM)
      RETURN
      END
C
       SUBROUTINE PCMIN(SST,PSL,P,T,R,NA,N,PMIN,VMAX,IFL)
C
C   ***   This subroutine calculates the mimimum central pressure  ***
C   ***            and maximum 10 m 1 minute wind speed            ***
C   ***    achievable in tropical cyclones, given a sounding       ***
C   ***             and a sea surface temperature.                 ***
C
C  INPUT:   SST: Sea surface temperature in C
C
C           PSL: Sea level pressure (mb)
C
C           P,T,R: One-dimensional arrays of dimension NA
C             containing pressure (mb), temperature (K),
C             and mixing ratio (kg/kg). The arrays MUST be
C             arranged so that the lowest index corresponds
C             to the lowest model level, with increasing index
C             corresponding to decreasing pressure. The temperature
C             sounding should extend to at least the tropopause and 
C             preferably to the lower stratosphere, however the
C             mixing ratios are not important above the boundary
C             layer. Missing mixing ratios can be replaced by zeros.
C
C           NA: The dimension of P,T and R
C
C           N:  The actual number of points in the sounding
C                (N is less than or equal to NA)
C
C  OUTPUT:  PMIN is the minimum central pressure, in mb
C
C           VMAX is the maximum surface wind speed, in m/s
C                  (reduced to reflect surface drag)
C
C           IFL is a flag: A value of 1 means OK; a value of 0
C              indicates no convergence (hypercane); a value of 2
C              means that the CAPE routine failed.
C
C-----------------------------------------------------------------------------
	REAL T(NA), P(NA), R(NA)
C
C   ***   Adjustable constant: Ratio of C_k to C_D    ***
C
	CKCD=0.7
C
C   ***   Adjustable constant for buoyancy of displaced parcels:  ***
C   ***    0=Reversible ascent;  1=Pseudo-adiabatic ascent        ***
C
        SIG=0.0
C
C   ***  Adjustable switch: if IDISS = 0, no dissipative heating is   ***
C   ***     allowed; otherwise, it is                                 ***
C
	IDISS=1
C
C   ***   Normalize certain quantities   ***
C
	SSTK=SST+273.15
	ES0=6.112*EXP(17.67*SST/(243.5+SST))
C
C   ***   Default values   ***
C
        VMAX=0.0
	PMIN=PSL
	IFL=1
C
	NP=0
	PM=950.0
C
C   ***   Find environmental CAPE *** 
C
      TP=T(1)
      RP=R(1)
      PP=P(1)
      CALL CAPE(TP,RP,PP,T,R,P,NA,N,SIG,CAPEA,TOA,IFLAG)
      IF(IFLAG.NE.1)IFL=2
C
C   ***   Begin iteration to find mimimum pressure   ***
C
  100 CONTINUE
C
C   ***  Find CAPE at radius of maximum winds   ***
C
      TP=T(1)
      PP=PM
      RP=0.622*R(1)*PSL/(PM*(0.622+R(1))-R(1)*PSL)
      CALL CAPE(TP,RP,PP,T,R,P,NA,N,SIG,CAPEM,TOM,IFLAG) 
      IF(IFLAG.NE.1)IFL=2
      RAT=SSTK/MAX(TOM,1.0)
      IF(IDISS.EQ.0)RAT=1.0
C
C  ***  Find saturation CAPE at radius of maximum winds   ***
C
      TP=SSTK
      PP=PM
      RP=0.622*ES0/(PM-ES0)
      CALL CAPE(TP,RP,PP,T,R,P,NA,N,SIG,CAPEMS,TOMS,IFLAG)
      IF(IFLAG.NE.1)IFL=2
C
C  ***  Initial estimate of minimum pressure   ***
C
      RS0=RP
      TV1=T(1)*(1.+R(1)/0.622)/(1.+R(1))
	TVAV=0.5*(TV1+SSTK*(1.+RS0/0.622)/(1.+RS0))
	CAT=CAPEM-CAPEA+0.5*CKCD*RAT*(CAPEMS-CAPEM)
	PNEW=PSL*EXP(-CAT/(287.04*TVAV))
C
C   ***  Test for convergence   ***
C
	IF(ABS(PNEW-PM).GT.0.2)THEN
	 PM=PNEW
	 NP=NP+1
	 IF(NP.GT.1000.OR.PM.LT.400.0)THEN
	  PMIN=400.0
	  IFL=0
	  GOTO 900
	 END IF
	 GOTO 100
	ELSE
	 CAT=CAPEM-CAPEA+CKCD*RAT*(CAPEMS-CAPEM)
	 PMIN=PSL*EXP(-CAT/(287.04*TVAV))
	END IF
  900	CONTINUE
	FAC=MAX(0.0,(CAPEMS-CAPEM))
	VMAX=0.8*SQRT(CKCD*RAT*FAC)
C
C   ***  Renormalize sounding arrays   ***
C	
	DO 910 I=1,N
	 R(I)=R(I)*1000.0
	 T(I)=T(I)-273.15
  910	CONTINUE
C
	RETURN
	END
C        
      SUBROUTINE CAPE(TP,RP,PP,T,R,P,ND,N,SIG,CAPED,TO,IFLAG)
C
C     This subroutine calculates the CAPE of a parcel with pressure PP (mb), 
C       temperature TP (K) and mixing ratio RP (gm/gm) given a sounding
C       of temperature (T in K) and mixing ratio (R in gm/gm) as a function
C       of pressure (P in mb). ND is the dimension of the arrays T,R and P,
C       while N is the actual number of points in the sounding. CAPED is
C       the calculated value of CAPE and TO is the temperature at the
C       level of neutral buoyancy.  IFLAG is a flag
C       integer. If IFLAG = 1, routine is successful; if it is 0, routine did
C       not run owing to improper sounding (e.g.no water vapor at parcel level).
C       IFLAG=2 indicates that routine did not converge.                 
C
      REAL T(ND),R(ND),P(ND),TVRDIF(100)   
      REAL NA
C
C   ***   Default values   ***
C      
      CAPED=0.0
      TO=T(1)
      IFLAG=1
C
C   ***   Check that sounding is suitable    ***
C
      IF(RP.LT.1.0E-6.OR.TP.LT.200.0)THEN
       IFLAG=0
       RETURN
      END IF            
C
C   ***   Assign values of thermodynamic constants     ***
C
      CPD=1005.7
      CPV=1870.0
      CL=4190.0
      CPVMCL=2320.0
      RV=461.5
      RD=287.04
      EPS=RD/RV
      ALV0=2.501E6
C
C   ***  Define various parcel quantities, including reversible   ***
C   ***                       entropy, S.                         ***
C                           
      TPC=TP-273.15
      ESP=6.112*EXP(17.67*TPC/(243.5+TPC))
      EVP=RP*PP/(EPS+RP)
      RH=EVP/ESP
      ALV=ALV0-CPVMCL*TPC
      S=(CPD+RP*CL)*LOG(TP)-RD*LOG(PP-EVP)+
     1   ALV*RP/TP-RP*RV*LOG(RH)            
C
C   ***  Find lifted condensation pressure, PLCL   ***
C     
	CHI=TP/(1669.0-122.0*RH-TP)
	PLCL=PP*(RH**CHI)
C
C   ***  Begin updraft loop   ***
C
	NCMAX=0
	DO 200 J=2,N
C
C    ***   Don't bother lifting parcel above 60 mb    ***
C
	 IF(P(J).LT.59.0)GOTO 200
C
C    ***  Parcel quantities below lifted condensation level   ***
C	 
	 IF(P(J).GE.PLCL)THEN
	  TG=TP*(P(J)/PP)**(RD/CPD)
	  RG=RP
C
C   ***   Calculate buoyancy   ***
C  
	  TLVR=TG*(1.+RG/EPS)/(1.+RG)
	  TVRDIF(J)=TLVR-T(J)*(1.+R(J)/EPS)/(1.+R(J))
	 ELSE
C
C   ***  Parcel quantities above lifted condensation level  ***
C	 
	  TG=T(J)          
	  TJC=T(J)-273.15 
	  ES=6.112*EXP(17.67*TJC/(243.5+TJC)) 
	  RG=EPS*ES/(P(J)-ES)
C
C   ***  Iteratively calculate lifted parcel temperature and mixing   ***
C   ***                ratio for reversible ascent                    ***
C
	  NC=0
  120	  CONTINUE
	  NC=NC+1
C
C   ***  Calculate estimates of the rates of change of the entropy    ***
C   ***           with temperature at constant pressure               ***
C  
	  ALV=ALV0-CPVMCL*(TG-273.15)
	  SL=(CPD+RP*CL+ALV*ALV*RG/(RV*TG*TG))/TG
	  EM=RG*P(J)/(EPS+RG)
	  SG=(CPD+RP*CL)*LOG(TG)-RD*LOG(P(J)-EM)+
     1      ALV*RG/TG
	  IF(NC.LT.3)THEN
	   AP=0.3
	  ELSE
	   AP=1.0
	  END IF
	  TGNEW=TG+AP*(S-SG)/SL  
C
C   ***   Test for convergence   ***
C
	  IF(ABS(TGNEW-TG).GT.0.01)THEN
	   TG=TGNEW
	   TC=TG-273.15
	   ENEW=6.112*EXP(17.67*TC/(243.5+TC))
C
C   ***   Bail out if things get out of hand   ***
C
	   IF(NC.GT.500.OR.ENEW.GT.(P(J)-1.0))THEN
            IFLAG=2
            RETURN
	   END IF
	   RG=EPS*ENEW/(P(J)-ENEW)           
	   GOTO 120
	  END IF
	  NCMAX=MAX(NC,NCMAX)
C
C   *** Calculate buoyancy   ***
C
          RMEAN=SIG*RG+(1.-SIG)*RP
	  TLVR=TG*(1.+RG/EPS)/(1.+RMEAN)
	  TVRDIF(J)=TLVR-T(J)*(1.+R(J)/EPS)/(1.+R(J))
	 END IF
  200	CONTINUE
C
C  ***  Begin loop to find NA, PA, and CAPE from reversible ascent ***
C
	NA=0.0
	PA=0.0
C
C   ***  Find maximum level of positive buoyancy, INB    ***
C
	INB=1
	DO 550 J=N,1,-1
	 IF(TVRDIF(J).GT.0.0)INB=MAX(INB,J)
  550	CONTINUE
C
C   ***  Find positive and negative areas and CAPE  ***
C
	IF(INB.GT.1)THEN
	 DO 600 J=2,INB
	  TVM=0.5*(TVRDIF(J)+TVRDIF(J-1))
	  PMA=0.5*(P(J)+P(J-1))
	  IF(TVM.LE.0.0)THEN
	   NA=NA-RD*TVM*(P(J-1)-P(J))/PMA
	  ELSE
	   PA=PA+RD*TVM*(P(J-1)-P(J))/PMA
	  END IF
  600	 CONTINUE
C
C   ***   Find residual positive area above INB and TO  ***
C
       PAT=0.0
       TO=T(INB)
       IF(INB.LT.N)THEN
        PINB=(P(INB+1)*TVRDIF(INB)-P(INB)*TVRDIF(INB+1))/
     1   (TVRDIF(INB)-TVRDIF(INB+1))
        PAT=RD*TVRDIF(INB)*(P(INB)-PINB)/(P(INB)+PINB)
	TO=(T(INB)*(PINB-P(INB+1))+T(INB+1)*(P(INB)-PINB))/
     1    (P(INB)-P(INB+1))
       END IF
C
C   ***   Find CAPE  ***
C            
	 CAPED=PA+PAT-NA
	 CAPED=MAX(CAPED,0.0)
	END IF
C
	RETURN
	END

