
      SUBROUTINE SOLHEAT(UT)                                            
      SAVE
      PARAMETER(KMX=96)
      include "blank.h"
      include "solars.h"
      COMMON/INDEXX/ITIME,IAUR,ISOLPRO                                  
      COMMON/PROTON/ZPRS(KMX),ALS(KMX),TU(KMX),TDENA(KMX),AB(KMX)       
      COMMON/COLMTR/XXN(KMX),COL(KMX),CNO2(KMX),CNO(KMX),CNN2(KMX)      
     1,CLNO3(KMX)                                                       
      COMMON/COSMICR/QCR(KMX)                                           
      COMMON/CROSTRF/SIGABS(5,59),SIGION(13,59)                         
      COMMON/RGLWTR/QUENCH,A1D,A6300                                    
      COMMON/RJH2O2O/RJH2O2C(KMX)                                       
      DIMENSION WAVE1(59),WAVE2(59),SFLUX(59),BRN2(59),BRO2(59)         
      DIMENSION SGH2O(13),SGCO2(13),SA(3,3),SI(3,3),AL(3),SIGXO2(3),    
     1SIGXN2(3),SIGXO(3),EXFLXR(3),EFFX(3),XLAM(3),XRFLX(3)             
      DATA SGH2O/5.,5.,5.,3.,1.5,.8,.8,1.1,0.,0.,0.,0.,0./              
      DATA SGCO2/.5,1.0,1.5,3.,4.,5.5,5.,5.,0.,0.,0.,0.,0./             
      DATA FNUXLYA/2.E+9/                                               
      DATA AL/1.E+7,5.E+8,5.E+7/                                        
      DATA SI/0.,1.E-18,0.,23.11E-18,22.E-18,10.24E-18,11.61E-18,16.E-18
     1,8.4E-18/                                                         
      DATA SA/0.,1.6E-18,0.,23.11E-18,22.E-18,10.24E-18,11.61E-18,      
     116.E-18,8.4E-18/                                                  
      DATA SIGXO2/9.28,4.4,1.64/                                        
      DATA SIGXN2/5.45,2.35,0.967/                                      
      DATA SIGXO/4.64,2.0,0.87/                                         
      DATA EXFLXR/0.5,0.4,0.1/                                          
      DATA EFFX/3.,5.,7./                                               
      DATA XLAM/70.,50.,35./                                            
      DATA BRN2/                                                        
     +              36 * 0.00,                                          
     +             0.01, 0.04, 0.04, 0.03, 0.05, 0.05,                  
     +             0.15, 0.20, 0.20, 0.25, 0.32, 0.34,                  
     +             11 * 0.36/                                           
      DATA BRO2/                                                        
     +              30 * 0.00,                                          
     +             .025, .036, .045, .120, .155, .189,                  
     +             .230, 0.20, 0.20, 0.20, 0.23, 0.25,                  
     +             0.29, 16 * 0.33/                                     
      ISCALE=0                                                          
      ITIMET=ITIME                                                      
      CALL SSFLUX(ISCALE,F107,F107A,WAVE1,WAVE2,SFLUX,ITIMET)           
 900  FORMAT(1X,*I AM HERE*)                                            
      EFF=0.33                                                          
      ERG=1.602E-12                                                     
      QUENCH=2.3E-11                                                    
      A1D=6.81E-3                                                       
      A6300=5.15E-3                                                     
      FDUXLYA=SFLUX(12)                                                 
      XMLW=48.                                                          
      DO 14 K=1,KMX                                                     
      QOP(K)=0.                                                         
      QO2P(K)=0.                                                        
      QN2P(K)=0.                                                        
      QINP(K)=0.                                                        
      QTIN(K)=1.E-20                                                    
      QSR(K)=1.E-20                                                     
      QSRB(K)=1.E-20                                                    
      QHERZ(K)=1.E-20                                                   
      QHAR(K)=1.E-20                                                    
      QHUG(K)=1.E-20                                                    
      QCHAP(K)=1.E-20                                                   
      DSO2(K)=1.E-20                                                    
      DSO2SR(K)=1.E-20                                                  
      DSO2SRB(K)=1.E-20                                                 
      DSO2EUV(K)=1.E-20                                                 
      DO3HAR(K)=1.E-20                                                  
      DO3HUG(K)=1.E-20                                                  
      DO3CHAP(K)=1.E-20                                                 
      DH2OEUV(K)=1.E-20                                                 
      DH2OLYA(K)=1.E-20                                                 
      DH2OSRC(K)=1.E-20                                                 
      DH2OSRB(K)=1.E-20                                                 
      DCO2LYA(K)=1.E-20                                                 
      DCO2EUV(K)=1.E-20                                                 
      DCO2SRC(K)=1.E-20                                                 
      DCO2SRB(K)=1.E-20                                                 
      DCOEUV(K)=1.E-20                                                  
      DCH4EUV(K)=1.E-20                                                 
      DCH4LYA(K)=1.E-20                                                 
      XJNO(K)=1.E-20                                                    
      SR63(K)=1.E-20                                                    
      QNSP(K)=1.E-20                                                    
      QIAN(K)=1.E-20                                                    
      QIAUR(K)=1.E-20                                                   
      QPRO(K)=1.E-20                                                    
      QAURH(K)=1.E-20                                                   
      QPROH(K)=1.E-20                                                   
      QIXRAY(K)=1.E-20                                                  
      QNSPE(K)=1.E-20                                                   
      XJNO2(K)=1.E-20                                                   
      DO 15 L=1,3                                                       
      TAU=SA(1,L)*CNN2(K)+SA(2,L)*CNO2(K)+SA(3,L)*CNO(K)                
      TAUP=EXP(-TAU)                                                    
      THNG3=AL(L)*SI(1,L)*XNN2(K)*TAUP                                  
      QN2P(K)=QN2P(K)+THNG3*0.86                                        
      QINP(K)=QINP(K)+THNG3*0.14                                        
      THNG4=AL(L)*SI(2,L)*XNO2(K)*TAUP                                  
      QO2P(K)=QO2P(K)+THNG4*0.78                                        
      THNG5=AL(L)*SI(3,L)*XNO(K)*TAUP                                   
      QOP(K)=QOP(K)+THNG5+THNG4*0.22                                    
      QNSPE(K)=QNSPE(K)+THNG3+THNG4+THNG5                               
  15  CONTINUE                                                          
      QNOP(K)=FNUXLYA*2.E-18*XNNO(K)*EXP(-8.E-21*CNO2(K))               
      QTIN(K)=QNOP(K)+QN2P(K)+QINP(K)+QO2P(K)+QOP(K)                    
      QNIGHT(K)=QTIN(K)*35.*EFF*1.602E-12/RHO(K)                        
      QN(K)=QNIGHT(K)                                                   
      XXN(K)=XNO3(K)                                                    
  14  CONTINUE                                                          
      CALL COLUM(XMLW)                                                  
      DTOR=ATAN(1.)/45.                                                 
      RTOD=1./DTOR                                                      
      PI=180./RTOD                                                      
      C1=23.5*DTOR                                                      
      DLE=ATAN(TAN(C1)*SIN(2.*PI*(DAY-80.)/365.))                       
      DLES=SIN(DLE)                                                     
      DLEC=COS(DLE)                                                     
      GLATR=GLAT*DTOR                                                   
      GLONR=GLONG*DTOR                                                  
      SECZI=1./(DLES*SIN(GLATR)+COS(GLATR)*COS(PI*(STL-12.)/12.)*DLEC)  
      ZI=ACOS(1./SECZI)*RTOD                                            
      DO 2 K=1,KMX                                                      
      CLNO3(K)=COL(K)                                                   
      RJH2O2(K)=2.4E-4                                                  
      RJH2O2C(K)=RJH2O2(K)                                              
      CGM(K)=1.0                                                        
      ALT=ZPHT(K)                                                       
      XP=(RE+ALT*1.E+5)/SHT(K)                                          
      Y=0.5*XP*(COS(ZI*DTOR))**2                                        
      TT=SQRT(Y)                                                        
      IF(TT.GT.8.) GO TO 10                                             
      YERF=(1.0606963+0.55643831*TT)/(1.0619896+1.7245609*TT+TT*TT)     
      GO TO 11                                                          
  10  YERF=0.56498823/(0.06651874+TT)                                   
  11  CONTINUE                                                          
      IF(ZI.GT.90.) GO TO 12                                            
      CHAPS=SQRT(0.5*PI*XP)*YERF                                        
      SCHAP(K)=CHAPS                                                    
      TXNO(K)=CNO(K)*CHAPS                                              
      TXNO2(K)=CNO2(K)*CHAPS                                            
      TXNN2(K)=CNN2(K)*CHAPS                                            
      TXNO3(K)=CLNO3(K)*CHAPS                                           
      GO TO 13                                                          
  12  CONTINUE                                                          
      RG=(RE+ALT*1.E+5)*SIN(ZI*DTOR)                                    
      ZG=RG-RE                                                          
      IF(ZG.GT.10.E+5) GO TO 4447                                       
      ZG=10.E+5                                                         
      CGM(K)=1.E-10                                                     
      RJH2O2(K)=2.4E-4*CGM(K)                                           
      RJH2O2C(K)=RJH2O2(K)                                              
 4447 CONTINUE                                                          
      CALL TANCOMP(ZG,XMO2,XMN2,XMO,XMO3,TMM,CNGO2,CNGN2,CNGO,CNGO3,    
     1CLNO3)                                                            
      SHG=BOLTZ*TMM/(1.66E-24*GZ(K))                                    
      BFD=0.5*PI*RG/SHG                                                 
      CHAPO=SQRT(BFD*16.)                                               
      CHAO2=SQRT(BFD*32.)                                               
      CHAN2=SQRT(BFD*28.)                                               
      CHAO3=SQRT(BFD*48.)                                               
      SCHAP(K)=CHAO3                                                    
      TXNO2(K)=CHAO2*(2.*CNGO2-XNO2(K)*SHG*YERF/32.)                    
      TXNN2(K)=CHAN2*(2.*CNGN2-XNN2(K)*SHG*YERF/28.)                    
      TXNO(K)=CHAPO*(2.*CNGO-XNO(K)*SHG*YERF/16.)                       
      TXNO3(K)=CHAO3*(2.*CNGO3-XNO3(K)*SHG*YERF/48.)                    
  13  CONTINUE                                                          
      QSR(K)=0.                                                         
      DSO2SR(K)=0.                                                      
      DH2OSRC(K)=0.                                                     
      DCO2SRC(K)=0.                                                     
      SR63(K)=0.                                                        
      SFAC=1.+0.11*(F107-65.)/165.                                      
      DH2OSRB(K)=1.2E-6*EXP(-1.E-7*TXNO2(K)**0.35)*SFAC                 
      DCO2SRB(K)=1.90E-9*EXP(-1.E-7*TXNO2(K)**0.35)*SFAC                
C COMPLETELY QUIET SUN 0.1 ERGS/CM/S                                    
C QUIET SUN LOW        0.2                                              
C QUIET SUN HIGH       0.4                                              
C ACTIVE               0.6                                              
C DISTURBED FLARES     1.0                                              
C EXCEPTIONAL FLARE    > 1.0                                            
      EXRAY=0.1+1.0*(F107-67.)/178.                                     
      DO 20 L=1,3                                                       
      XRFLX(L)=EXRAY*EXFLXR(L)*XLAM(L)/(12400.*ERG)                     
      TAU=(SIGXO2(L)*TXNO2(K)+SIGXN2(L)*TXNN2(K)+SIGXO(L)*TXNO(K))*     
     1 1.E-19                                                           
      CTAU=EXP(-TAU)                                                    
      THNG1=XNO2(K)*SIGXO2(L)*1.E-19*CTAU*XRFLX(L)*EFFX(L)              
      THNG2=XNN2(K)*SIGXN2(L)*1.E-19*CTAU*XRFLX(L)*EFFX(L)              
      THNG3=XNO(K)*SIGXO(L)*1.E-19*CTAU*XRFLX(L)*EFFX(L)                
      QO2P(K)=QO2P(K)+THNG1*0.67                                        
      QN2P(K)=QN2P(K)+THNG2*0.64                                        
      QINP(K)=QINP(K)+THNG2*0.36                                        
      QOP(K)=QOP(K)+(THNG3+0.33*THNG1)                                  
      QIXRAY(K)=QIXRAY(K)+THNG1+THNG2+THNG3                             
      QNSPE(K)=QNSPE(K)+1.57*THNG2                                      
  20  CONTINUE                                                          
      TAUR=SIGABS(1,49)*TXNO(K)+SIGABS(3,49)+TXNN2(K)                   
     1+SIGABS(2,49)*TXNO2(K)                                            
      TAUP=SIGABS(1,20)*TXNO(K)+SIGABS(3,20)*TXNN2(K)                   
     1+SIGABS(2,20)*TXNO2(K)                                            
      TAUR1=1.3*TAUR                                                    
      TAUR2=2.0*TAUR                                                    
      TAUR3=2.5*TAUR                                                    
      IF(TAUR.GT.9.) TAUR=9.                                            
      IF(TAUP.GT.9.) TAUP=9.                                            
      IF(TAUR1.GT.9.) TAUR1=9.                                          
      IF(TAUR2.GT.9.) TAUR2=9.                                          
      IF(TAUR3.GT.9.) TAUR3=9.                                          
      CTAUR=EXP(-TAUR)                                                  
      CTAUR1=EXP(-TAUR1)                                                
      CTAUR2=EXP(-TAUR2)                                                
      CTAUR3=EXP(-TAUR3)                                                
      CTAUP=EXP(-TAUP)                                                  
      RSP=2.4*CTAUR/(CTAUR+2.*(CTAUR1+CTAUR2+CTAUR3))                   
      RSQ=1.5*CTAUR/(CTAUR+2.*(CTAUR1+CTAUR2+CTAUR3)+TAUP/TAUR*CTAUP)   
      CSPI=1.0+RSP                                                      
      CSPJ=1.0+RSQ                                                      
      DO 7633 L=1,59                                                    
      TAU=SIGABS(1,L)*TXNO(K)+SIGABS(2,L)*TXNO2(K)+SIGABS(3,L)          
     1*TXNN2(K)                                                         
      CTAU=EXP(-TAU)                                                    
      THNG1=XNO2(K)*SIGION(2,L)*CTAU*SFLUX(L)                           
      THNG2=XNN2(K)*SIGION(3,L)*CTAU*SFLUX(L)                           
      THNG3=XNO(K)*SIGION(1,L)*CTAU*SFLUX(L)                            
      THNG4=XN4S(K)*SIGION(12,L)*CTAU*SFLUX(L)                          
      QO2P(K)=QO2P(K)+THNG1*(1.-BRO2(L)+RSQ)                            
      QN2P(K)=QN2P(K)+THNG2*(1.-BRN2(L)+RSP)                            
      QINP(K)=QINP(K)+THNG2*BRN2(L)+THNG4*CSPI                          
      QOP(K)=QOP(K)+THNG3*(1.+RSP)+THNG1*BRO2(L)                        
      QNSP(K)=QNSP(K)+XNN2(K)*(SIGABS(3,L)-SIGION(3,L))*CTAU*SFLUX(L)   
      QNSPE(K)=QNSPE(K)+1.57*THNG2*RSP                                  
      IF(L.LT.16) GO TO 7634                                            
      ALAMAV=(WAVE1(L)+WAVE2(L))/2.                                     
      DH2OEUV(K)=DH2OEUV(K)+1.5E-17*CTAU*SFLUX(L)                       
      DCO2EUV(K)=DCO2EUV(K)+2.5E-17*CTAU*SFLUX(L)                       
      DCOEUV(K)=DCOEUV(K)+1.7E-17*CTAU*SFLUX(L)                         
      WL1=WAVE1(L)                                                      
      IF(WL1.LT.300.) SGCH4=1.E-17                                      
      IF(WL1.GE.300..AND.WL1.LT.900.) SGCH4=1.E-17+(4.E-17/600.)*(WL1-  
     1300.)                                                             
      IF(WL1.GE.900..AND.WL1.LT.1050.) SGCH4=5.E-17-(2.E-17/130.)*(WL1- 
     1900.)                                                             
      IF(WL1.GE.1050.) SGCH4=0.                                         
      DCH4EUV(K)=DCH4EUV(K)+SGCH4*CTAU*SFLUX(L)                         
 7634 CONTINUE                                                          
      IF(L.GT.13) GO TO 7633                                            
      TAU=SIGABS(2,L)*TXNO2(K)                                          
      THNG=SFLUX(L)*SIGABS(2,L)*EXP(-TAU)                               
      THNH=THNG/SIGABS(2,L)                                             
      DSO2SR(K)=DSO2SR(K)+THNG                                          
      ALAMAV=(WAVE1(L)+WAVE2(L))/2.                                     
      QSR(K)=QSR(K)+THNG*XNO2(K)                                        
     1*1.602E-12*((12400./ALAMAV-7.12)                                  
     2+1.96*(2.3E-11*XNN2(K))/(9.E-3+2.3E-11*XNN2(K)))/RHO(K)           
      SR63(K)=SR63(K)+XNO2(K)*THNG*A6300/(A1D*(1.+QUENCH*XNN2(K)/A1D))  
      DH2OSRC(K)=DH2OSRC(K)+THNH*SGH2O(L)*1.E-18                        
      DCO2SRC(K)=DCO2SRC(K)+THNH*SGCO2(L)*1.E-19                        
      XJNO2(K)=XJNO2(K)+THNH*1.5E-17                                    
 7633 CONTINUE                                                          
      TO2LYA=EXP(-2.115E-18*TXNO2(K)**0.8855)                           
      QNOP(K)=QNOP(K)+FDUXLYA*2.02E-18*XNNO(K)*TO2LYA                   
      RB9(K)=FDUXLYA*2.02E-18*TO2LYA                                    
      DH2OLYA(K)=FDUXLYA*1.57E-17*TO2LYA                                
      DO3LYA(K)=FDUXLYA*2.27E-17*TO2LYA                                 
      DSO2LYA(K)=FDUXLYA*8.E-21*EXP(-8.E-21*TXNO2(K))                   
      DCH4LYA(K)=FDUXLYA*1.85E-17*TO2LYA                                
      DCO2LYA(K)=FDUXLYA*8.14E-20*TO2LYA                                
      QNLYA(K)=(DSO2LYA(K)*XNO2(K)+DH2OLYA(K)*XNH2O(K)+DCH4LYA(K)*      
     1XNCH4(K)+DO3LYA(K)*XNO3(K))*1.602E-12*(12400./1216.)/RHO(K)       
      RJCO2(K)=DCO2LYA(K)+DCO2SRB(K)+DCO2SRC(K)                         
      DH2OT(K)=DH2OLYA(K)+DH2OSRC(K)+DH2OSRB(K)+DH2OEUV(K)              
      QTIN(K)=QO2P(K)+QN2P(K)+QINP(K)+QOP(K)+QNOP(K)                    
  2   CONTINUE                                                          
      DO 222 K=1,KMX                                                    
      XJNO(K)=4.E-6*EXP(-1.E-8*(TXNO2(K))**0.38)*EXP(-5.E-19*           
     1TXNO3(K))*SFAC*CGM(K)                                             
      IF(TXNO2(K).LE.1.E+18) GO TO 8                                    
      DENON=0.67*TXNO2(K)+3.44E+9*SQRT(TXNO2(K))                        
      QSRB(K)=XNO2(K)/DENON/RHO(K)*SFAC                                 
      GO TO 9                                                           
  8   CONTINUE                                                          
      QSRB(K)=XNO2(K)*2.43E-19/RHO(K)*SFAC                              
  9   CONTINUE                                                          
      DSO2SRB(K)=1.1E-7*EXP(-1.97E-10*TXNO2(K)**0.522)*SFAC             
      IF(TXNO2(K).GT.1.E+19) DSO2SRB(K)=1.45E+8/(TXNO2(K)**0.83)*       
     1SFAC                                                              
      DSO2(K)=DSO2SR(K)+DSO2SRB(K)+DSO2LYA(K)                           
      DO3HAR(K)=9.5E-3*CGM(K)                                           
      DO3HUG(K)=1.2E-4*CGM(K)                                           
      DO3CHAP(K)=4.4E-4*CGM(K)                                          
      DNOSRB(K)=4.5E-6*EXP(-1.E-8*(TXNO2(K))**0.38)*EXP(-5.E-19*        
     1TXNO3(K))*SFAC                                                    
      QCHAP(K)=1.05E-15*XNO3(K)*EXP(-2.85E-21*TXNO3(K))                 
      QHUG(K)=XNO3(K)*(59.2+(40.-59.2)*EXP(-0.0125*TXNO3(K)             
     1*EXP(-0.0127*                                                     
     13055.))-40.*EXP(-0.0125*TXNO3(K)*EXP(-0.0127*2805.)))/(0.0127*    
     2TXNO3(K))/RHO(K)                                                  
      IF(XNO3(K).LT.1.E+4) QHUG(K)=1.E-20                               
      QHAR(K)=4.05E-14*XNO3(K)*EXP(-8.8E-18*TXNO3(K))                   
      QHERZ(K)=1.2E+3*(6.6E-24*XNO2(K)+4.9E-18*XNO3(K))*EXP(-6.6E-24*   
     1TXNO2(K)-4.9E-18*TXNO3(K))                                        
      QNO3(K)=QCHAP(K)+QHUG(K)+QHAR(K)                                  
      QN(K)=QSR(K)+QSRB(K)+QN(K)+QNLYA(K)                               
  222 CONTINUE                                                          
  1   CONTINUE                                                          
      CALL COSRAY(45.)                                                  
      DO 16 K=1,KMX                                                     
      XO21DL(K)=1.E-20                                                  
      XNO2S(K)=XO21DL(K)                                                
      QO2S1=0.549E-09*EXP(-2.406E-20*TXNO2(K))                          
      QO2S2=2.614E-09*EXP(-8.508E-20*TXNO2(K))                          
      QO2S(K)=XNO2S(K)*(QO2S1+QO2S2)                                    
      QN2P(K)=QN2P(K)+0.585*QCR(K)                                      
      QINP(K)=QINP(K)+0.185*QCR(K)                                      
      QO2P(K)=QO2P(K)+0.154*QCR(K)+QO2S(K)                              
      QOP(K)=QOP(K)+0.076*QCR(K)                                        
      QNSPE(K)=QNSPE(K)+QCR(K)                                          
  16  CONTINUE                                                          
      IAUR=1                                                            
      IF(IAUR.EQ.0) GO TO 5                                             
      AUREFF=0.1                                                        
      ALP=0.75                                                          
      EAUR=0.025                                                        
      FLUXAR=EAUR/(2.*ALP*1.602E-09)                                    
      CALL QAURORA(FLUXAR,ALP,ETOTAL)                                   
      DO 4 K=1,KMX                                                      
      QOP(K)=QOP(K)+QIA(3,K)                                            
      QN2P(K)=QN2P(K)+QIA(1,K)                                          
      QO2P(K)=QO2P(K)+QIA(2,K)                                          
      QINP(K)=QINP(K)+QIA(5,K)                                          
      QTIN(K)=QOP(K)+QO2P(K)+QN2P(K)+QINP(K)+QNOP(K)                    
      QIAUR(K)=QIA(1,K)+QIA(2,K)+QIA(3,K)+QIA(5,K)                      
      QIAN(K)=35.*QTI(K)*1.602E-12*AUREFF/RHO(K)                        
      QAURH(K)=QIAN(K)                                                  
      QN(K)=QN(K)+QIAN(K)                                               
      QNSPE(K)=QNSPE(K)+1.57*QIA(1,K)/0.76                              
  4   CONTINUE                                                          
  5   CONTINUE                                                          
      IF(ISOLPRO.EQ.0) GO TO 30                                         
      DO 31 K=1,KMX                                                     
      ZPRS(K)=ZP(K)                                                     
      ALS(K)=ZPHT(K)                                                    
      TU(K)=TN(K)                                                       
      TDENA(K)=(XNO(K)*16.+XNO2(K)*32.+XNN2(K)*28.)*1.66E-24            
      AB(K)=XNO(K)+XNO2(K)+XNN2(K)                                      
  31  CONTINUE                                                          
C     CALL PROTON(UT)                                                   
      ISOLPR=0                                                          
      DO 32 K=1,KMX                                                     
      QO2P(K)=QO2P(K)+QPRO(K)                                           
      QTIN(K)=QTIN(K)+QPRO(K)                                           
      QPROH(K)=35.*QPRO(K)*1.602E-12/RHO(K)                             
      QIAN(K)=QIAN(K)+QPROH(K)                                          
      QN(K)=QN(K)+QPROH(K)                                              
      QNSPE(K)=QNSPE(K)+QPRO(K)                                         
  32  CONTINUE                                                          
  30  CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE TANCOMP(ZG,XMO2,XMN2,XMO,XMO3,TMM,CNGO2,CNGN2,CNGO,    
     1CNGO3)                                                            
      SAVE
      PARAMETER(KMX=96)
      include "blank.h"
      COMMON/COLMTR/XXN(KMX),COL(KMX),CNO2(KMX),CNO(KMX),CNN2(KMX)      
     1,CLNO3(KMX)                                                       
      ZU=ZG*1.E-5                                                       
      IF(ZU.LT.ZPHT(1)) GO TO 3                                         
      KMX1=KMX-1                                                        
      DO 1 K=1,KMX1                                                     
      IF(ZU.GE.ZPHT(K).AND.ZU.LE.ZPHT(K+1)) GO TO 2                     
  1   CONTINUE                                                          
  2   ABD=(ZU-ZPHT(K))/(ZPHT(K+1)-ZPHT(K))                              
      XMO2=XNO2(K)*EXP(ALOG(XNO2(K+1)/XNO2(K))*ABD)                     
      XMN2=XNN2(K)*EXP(ALOG(XNN2(K+1)/XNN2(K))*ABD)                     
      XMO=XNO(K)*EXP(ALOG(XNO(K+1)/XNO(K))*ABD)                         
      XMO3=XNO3(K)*EXP(ALOG(XNO3(K+1)/XNO3(K))*ABD)                     
      TMM=TN(K)+(TN(K+1)-TN(K))*(ZU-ZPHT(K))/(ZPHT(K+1)-ZPHT(K))        
      CNGO2=CNO2(K)*EXP(ALOG(CNO2(K+1)/CNO2(K))*ABD)                    
      CNGN2=CNN2(K)*EXP(ALOG(CNN2(K+1)/CNN2(K))*ABD)                    
      CNGO=CNO(K)*EXP(ALOG(CNO(K+1)/CNO(K))*ABD)                        
      CNGO3=CLNO3(K)*EXP(ALOG(CLNO3(K+1)/CLNO3(K))*ABD)                 
      GO TO 4                                                           
  3   XMO2=XNO2(1)*EXP((-ZG+ZPHT(1)*1.E+5)/SHT(1))                      
      XMN2=XNN2(1)*EXP((-ZG+ZPHT(1)*1.E+5)/SHT(1))                      
      XMO=XNO(1)                                                        
      XMO3=XNO3(1)*EXP((-ZG+ZPHT(1)*1.E+5)/SHT(1))                      
      TMM=TN(1)                                                         
      CNGO2=XMO2*SHT(1)                                                 
      CNGN2=XMN2*SHT(1)                                                 
      CNGO=CNO(1)                                                       
      CNGO3=XMO3*SHT(1)                                                 
  4   CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE SSFLUX(ISCALE, F107, F107A, WAVE1, WAVE2, SFLUX,ITIMET)
      SAVE
C                                                                       
      PARAMETER (LM=59,LMAX=59)                                         
C    Subroutine SSFLUX scales the solar flux according to the 10.7 cm fl
C F107 and the 81-day centered average 10.7 cm flux F107A.  The longwave
C boundary WAVE1 and shortwave boundary WAVE2 of the wavelenth bins are 
C returned (Angstroms), and the solar flux in photons cm-2 s-1 returned 
C in SFLUX.                                                             
C   If ISCALE=0 the flux is scaled using parameterization methods based 
C F107 and F107A.  For ionizing EUV, Hinteregger's contrast ratio method
C is used, based on the Torr and Torr (JGR 90, 6675, 1985) bin structure
C for reference spectrum SC21REFW.  The 1026A (H LyB) and 335A (FeXVI)
C enhancement ratios are calculated from Hinteregger's formula, using th
C coefficients which reduce to the reference values at F107=71.5,       
C F107A=75.4.  The 'best fit' coefficients are not used as they produce 
C negative values at low solar activity, but remain in a 'commented out'
C data statement for reference.  The rest of the spectrum is then calcul
C from these key emissions using Hinteregger's method.  Scaling factors 
C were calculated by the author from contrast ratios in the original    
C spectrum data file.  For FUV in the 1050A-1350A region, 50A interval  
C averaging was done by the author from SC21REFW, and scaling factors
C also calculated.  This is a mere place holder since 50A bins are not  
C adequate for actual band calculations in this region.  For Lyman alpha
C which is treated seperately as an individual line, Rottman's          
C paraterization cited by Bossy (PSS 31, 977, 1983) is used.  For the   
C SR continuum, the Torr et al. (JGR 80, 6063, 1980) parameterization   
C is used with the coefficients adjusted to reflect the measurements of 
C (JGR 86, 6697, 1981), Mount et al. (JGR 85, 4271, 1980), and Mount and
C Rottman (JGR 86, 9193, 1981; JGR 88, 5403, 1983; JGR 90, 13031, 1985).
C (N.b. - the evidence from SME indicates that the change with solar act
C of the SR continuum flux is much smaller than what is used here - pers
C communication from Gary Rottman.)                                     
C   If ISCALE=1 linear interpolation between high and low activity spect
C is used, based on F107 alone, and assuming that the low activity spect
C corresponds to F107=68 and the high activitiy spectrum to F107=243.   
C The Hinteregger SC21REFW and F79050 spectra as binned by Torr and Torr
C are used for ionizing EUV.  For the 1050A-1350A region, the SC21REFW
C spectrum  averaged into 50A intervals is used for low solar activity; 
C the high activity spectrum was obtained by scaling this spectrum      
C using the contrast ratios.  For Lyman alpha and the SR continuum,     
C linear interpolation amounts to the same thing as the aformentioned   
C parameterization.                                                     
C    In either case, the EUV fluxes between 250A and 50A are normalized 
C upwards (Richards and Torr, 1984).  The normalization coefficient is 2
C at F107=68 and reduces linearly to 1 at F107=243.                     
C    X-ray fluxes shortwards of 50A are included, 10/88.  The Hinteregge
C fluxes were used to 18A; shortwards of there approximations taken from
C notes are employed on a temporary basis.                              
C                                                                       
C S.C. Solomon, 12/88                                                   
C                                                                       
C                                                                       
C Definitions:                                                          
C ISCALE   =0 for contrast ratio method, =1 for linear interpolation    
C F107     daily 10.7 cm flux                                           
C F107A    81-day centered average 10.7 cm flux                         
C WAVE1    longwave bound of spectral intervals                         
C WAVE2    shortwave bound of spectral intervals (= WAVE1 for indiv. lin
C SFLUX    scaled solar flux returned by subroutine                     
C LMAX     dimension of WAVE1, WAVE2, and SFLUX arrays, must be <= LM   
C WAVEL    = WAVE1                                                      
C WAVES    = WAVE2                                                      
C RFLUX    low solar activity reference flux                            
C XFLUX    high solar activity flux                                     
C SCALE1   scaling factors for H LyB-keyed chromospheric emissions      
C SCALE2   scaling factors for FeXVI-keyed coronal emissions            
C LM       dimension of above arrays, currently = 59                    
C SRA      'A' value for S-R continuum scaling formula                  
C SRB      'B' value for S-R continuum scaling formula                  
C B1       fit coefficients for H LyB                                   
C B2       fit coefficients for FeXVI                                   
C R1       enhancement ratio for H LyB                                  
C R2       enhancement ratio for FeXVI                                  
C SFNORM   normalization factor for scaling flux shortwards of 250A     
C                                                                       
C                                                                       
C                                                                       
      DIMENSION WAVE1(LMAX), WAVE2(LMAX), SFLUX(LMAX),                  
     >          WAVEL(LM), WAVES(LM), RFLUX(LM), XFLUX(LM),             
     >          SCALE1(LM), SCALE2(LM), SRA(8), SRB(8), B1(3), B2(3)    
C                                                                       
      DIMENSION SIGAO(59),SIGAO2(59),SIGAN2(59),SIGIO(59),SIGIN2(59),   
     1SIGIO2(59),SIGACO(59),SIGICO(59),SIGACO2(59),SIGICO2(59),         
     2SIGIO4S(59),SIGIO2D(59),SIGIO2P(59),SIGIO4P(59),SIGIO2Q(59),      
     3SIGIHE(59),SIGIN(59),SIGIH(59)                                    
      COMMON/CROSTRF/SIGABS(5,59),SIGION(13,59)                         
C new B's:                                                              
      DATA B1/1.0, 0.0138, 0.005/, B2/1.0, 0.59425, 0.3811/             
C                                                                       
C old B's, commented out:                                               
C     DATA B1/1.31, 0.01106, 0.00492/, B2/-6.618, 0.66159, 0.38319/     
C                                                                       
      DATA WAVEL/ 1750.00, 1700.00, 1650.00, 1600.00, 1550.00, 1500.00, 
     >            1450.00, 1400.00, 1350.00, 1300.00, 1250.00, 1215.67, 
     >            1200.00, 1150.00, 1100.00, 1050.00, 1031.91, 1025.72, 
     >            1000.00,  977.02,  950.00,  900.00,  850.00,  800.00, 
     >             789.36,  770.41,  765.15,  750.00,  703.31,  700.00, 
     >             650.00,  629.73,  609.76,  600.00,  584.33,  554.37, 
     >             550.00,  500.00,  465.22,  450.00,  400.00,  368.07, 
     >             350.00,  303.78,  303.31,  300.00,  284.15,  256.30, 
     >             250.00,  200.00,  150.00,  100.00,   50.00,   32.00, 
     >              23.00,   16.00,    8.00,    4.00,    2.00/          
      DATA WAVES/ 1700.00, 1650.00, 1600.00, 1550.00, 1500.00, 1450.00, 
     >            1400.00, 1350.00, 1300.00, 1250.00, 1200.00, 1215.67, 
     >            1150.00, 1100.00, 1050.00, 1000.00, 1031.91, 1025.72, 
     >             950.00,  977.02,  900.00,  850.00,  800.00,  750.00, 
     >             789.36,  770.41,  765.15,  700.00,  703.31,  650.00, 
     >             600.00,  629.73,  609.76,  550.00,  584.33,  554.37, 
     >             500.00,  450.00,  465.22,  400.00,  350.00,  368.07, 
     >             300.00,  303.78,  303.31,  250.00,  284.15,  256.30, 
     >             200.00,  150.00,  100.00,   50.00,   32.00,   23.00, 
     >              16.00,    8.00,    4.00,    2.00,    1.00/          
      DATA RFLUX/  370.45,  203.69,   96.00,   69.71,   50.70,   26.67, 
     >              17.21,    8.26,   12.86,    4.10,    5.20,  333.80, 
     >               2.78,    0.70,    3.07,    3.64,    3.18,    4.38, 
     >               1.78,    5.96,    4.22,    4.43,    1.93,    0.87, 
     >               0.79,    0.24,    0.20,    0.17,    0.39,    0.22, 
     >               0.17,    1.50,    0.45,    0.48,    1.58,    0.80, 
     >               0.51,    0.31,    0.18,    0.39,    0.21,    0.74, 
     >               0.87,    6.00,    0.24,    0.84,    0.10,    0.27, 
     >               0.92,    1.84,    0.13,    0.38,  0.0215,  0.0067, 
     >             0.0009,  0.0003,   1.E-6,   3.E-9,   1.E-11/         
      DATA XFLUX/  464.20,  241.50,  131.50,  101.90,   81.32,   48.71, 
     >              37.16,   21.14,   30.70,   11.20,   12.00,  438.80, 
     >               6.50,    1.60,    6.40,    8.66,    9.04,   13.12, 
     >               4.42,   13.18,   12.03,   13.29,    5.01,    2.18, 
     >               1.59,    0.67,    0.43,    0.43,    0.72,    0.46, 
     >               0.48,    3.02,    1.46,    1.02,    4.86,    1.59, 
     >               1.57,    1.67,    0.36,    0.99,    2.20,    1.39, 
     >               5.63,   11.28,    2.50,    4.14,    3.16,    0.59, 
     >               3.70,    4.85,    0.34,    1.15,    0.18,    0.08, 
     >              0.025,    0.03,   1.E-3,   3.E-5,   1.E-6/          
      DATA SCALE1/35347.5, 33095.6, 18040.6, 13733.0, 12564.2, 7121.38, 
     >            6608.74, 5779.89, 8009.80, 3186.34, 3033.78,  47555., 
     >            1692.09,  405.95, 1516.20, 2731.70, 3314.57, 4375.00, 
     >            1316.91, 3621.91, 3908.56, 4432.54, 1541.21,  531.73, 
     >             364.83,    0.00,  116.00,  129.41,  162.48,   94.07, 
     >              41.29,  709.50,    0.00,  268.47, 1561.05,  367.64, 
     >             290.06,  184.36,    0.00,   86.15,    7.50,    0.00, 
     >               0.00, 2220.00,    0.00,   61.00,    0.00,   86.95, 
     >             206.00,  135.89,   60.35,  157.12,    7.06,    0.75, 
     >               0.00,    0.00,    0.00,    0.00,    0.00/          
      DATA SCALE2/   0.00,    0.00,    0.00,    0.00,    0.00,    0.00, 
     >               0.00,    0.00,    0.00,    0.00,    0.00,    0.00, 
     >               0.00,    0.00,    0.00,    0.00,    0.00,    0.00, 
     >               0.00,    0.00,    0.00,    0.00,    0.00,    0.00, 
     >               0.00,    5.34,    0.00,    0.00,    0.00,    0.54, 
     >               3.30,    0.00,   12.60,    0.00,    0.00,    0.00, 
     >               5.34,   11.63,    2.28,    5.56,   24.93,    8.16, 
     >              60.69,    0.00,   28.20,   45.90,   40.80,    1.27, 
     >              35.47,   42.80,    1.12,    6.19,    1.26,    0.69, 
     >               0.23,    0.30,    0.01,   3.E-4,   1.E-5/          
      DATA SRA/     0.536,   0.216,   0.203,   0.184,   0.175,   0.126, 
     >              0.114,   0.073/                                     
      DATA SRB/     334.0,   189.0,    82.2,    57.2,    38.8,    18.1, 
     >               9.46,    3.30/                                     
C                                                                       
      DATA SIGAO /  18 * 0.00,                                          
     >             0.00, 0.00, 2.12, 4.18, 4.38, 4.23,                  
     >             4.28, 4.18, 4.18, 8.00,11.35,10.04,                  
     >            12.21,12.22,12.23,11.90,12.17,12.13,                  
     >            11.91,11.64,11.25,11.21, 9.64, 9.95,                  
     >             8.67, 7.70, 7.68, 6.61, 7.13, 6.05,                  
     >             5.30, 2.90, 1.60, 0.59, 0.16, 0.05,                  
     >             0.51, 0.07, .012, .002, .0002/                       
C                                                                       
      DATA SIGAO2/ 0.50, 1.50, 3.40, 6.00,10.00,13.00,                  
     >            15.00,12.00, 2.20, 0.30, 3.00, 0.01,                  
     >             0.30, 0.10, 1.00, 1.10, 1.00, 1.60,                  
     >            16.53, 4.00,15.54, 9.85,20.87,27.09,                  
     >            26.66,25.18,21.96,29.05,25.00,26.27,                  
     >            26.02,25.80,26.10,25.04,22.00,25.59,                  
     >            24.06,21.59,20.40,19.39,18.17,18.40,                  
     >            17.19,16.80,16.80,15.10,15.70,13.20,                  
     >            10.60, 7.10, 4.00, 1.18, 0.32, 0.10,                  
     >             1.02, 0.14, .024, .004, .0004/                       
C                                                                       
      DATA SIGAN2/  18 * 0.00,                                          
     >            36.16, 0.70,16.99,46.63,15.05,30.71,                  
     >            19.26,26.88,35.46,30.94,26.30,29.75,                  
     >            23.22,23.20,23.10,22.38,23.20,24.69,                  
     >            24.53,21.85,21.80,21.07,17.51,18.00,                  
     >            13.00,11.60,11.60,10.30,10.60, 9.70,                  
     >             8.00, 4.40, 1.90, 0.60, 0.24, 1.16,                  
     >             0.48, 0.09, .015, .003, .0003/                       
C                                                                       
      DATA SIGIO /  18 * 0.00,                                          
     >             0.00, 0.00, 2.12, 4.18, 4.38, 4.23,                  
     >             4.28, 4.18, 4.18, 8.00,11.35,10.04,                  
     >            12.21,12.22,12.23,11.90,12.17,12.13,                  
     >            11.91,11.64,11.25,11.21, 9.64, 9.95,                  
     >             8.67, 7.70, 7.68, 6.61, 7.13, 6.05,                  
     >             5.30, 2.90, 1.60, 0.59, 0.16, 0.05,                  
     >             0.51, 0.07, .012, .002, .0002/                       
C                                                                       
      DATA SIGIO2/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,                  
     >             0.00, 0.00, 0.00, 0.00, 0.00, 0.00,                  
     >             0.00, 0.00, 0.00, 0.27, 0.00, 1.00,                  
     >            12.22, 2.50, 9.34, 4.69, 6.12, 9.39,                  
     >            11.05, 9.69, 8.59,23.81,23.00,22.05,                  
     >            25.94,25.80,26.10,25.04,22.00,25.59,                  
     >            24.06,21.59,20.40,19.39,18.17,18.40,                  
     >            17.19,16.80,16.80,15.10,15.70,13.20,                  
     >            10.60, 7.10, 4.00, 1.18, 0.32, 0.10,                  
     >             1.02, 0.14, .024, .004, .0004/                       
C                                                                       
      DATA SIGIN2/  18 * 0.00,                                          
     >             0.00, 0.00, 0.00, 0.00, 0.00,16.75,                  
     >            10.18,18.39,23.77,23.20,23.00,25.06,                  
     >            23.22,23.20,23.10,22.38,23.20,24.69,                  
     >            24.53,21.85,21.80,21.07,17.51,18.00,                  
     >            13.00,11.60,11.60,10.30,10.60, 9.70,                  
     >             8.00, 4.40, 1.90, 0.60, 0.24, 1.16,                  
     >             0.48, 0.09, .015, .003, .0003/                       
C                                                                       
C  CO                                                                   
      DATA SIGACO/6*0.,1.92,3.53,5.48,8.02,10.02,11.70,11.01,           
     1 12.52,12.47,13.61,15.43,15.69,18.01,19.92,20.09,21.61,22.28,     
     2 22.52,22.41,18.42,18.60,19.78,25.59,24.45,25.98,26.28,15.26,     
     3  33.22,21.35,22.59,37.64,49.44,28.50,52.9,3*0.0,16*0./           
      DATA SIGICO/6*0.,1.92,3.53,5.48,8.02,10.02,11.70,11.01,           
     1 12.52,12.47,13.61,15.43,15.69,18.01,19.92,20.09,21.44,22.31,     
     2 21.38,21.62,16.93,16.75,17.01,17.04,16.70,17.02,12.17,9.20,      
     3 15.44,11.38,17.13,11.70,6*0.0,16*0./                             
C  CO2                                                                  
      DATA SIGACO2/6*0.,4.42,7.51,11.03,14.98,17.88,21.21,20.00,        
     1 23.44,23.44,23.88,25.70,25.81,27.52,28.48,29.27,31.61,33.20,     
     2 34.21,34.00,25.31,25.86,25.88,25.96,21.76,22.48,53.96,26.48,     
     3 21.79,31.83,12.84,49.06,70.89,29.91,34.41,3*0.0,16*0./           
      DATA SIGICO2/6*0.,4.42,7.51,11.03,14.98,17.88,21.21,20.00,        
     1 23.44,23.44,23.88,25.70,25.81,27.52,28.48,29.27,31.61,33.20,     
     2 34.21,34.00,20.16,21.27,21.14,21.72,17.71,17.02,50.39,20.00,     
     3 17.07,21.53,10.67,19.66,6*0.0,16*0./                             
C  O+(4S)                                                               
      DATA SIGIO4S/6*0.,.32,1.03,1.62,1.95,2.15,2.33,2.23,2.23,         
     1 2.45,2.61,2.81,2.77,2.99,3.15,3.28,3.39,3.50,3.58,3.46,3.67,     
     2 3.74,3.73,4.04,4.91,4.20,4.18,4.18,4.28,4.23,4.38,4.18,2.12,     
     3 5*.00,16*0./                                                     
C  O+(2D)                                                               
      DATA SIGIO2D/6*0.,.34,1.14,2.00,2.62,3.02,3.39,3.18,3.62,         
     1 3.63,3.98,4.37,4.31,4.75,5.04,5.23,5.36,5.47,5.49,5.30,5.51,     
     2 5.50,5.50,5.52,6.44,3.80,12*.00,16*0./                           
C  O+(2P)                                                               
      DATA SIGIO2P/6*0.,.22,.75,1.30,1.70,1.95,2.17,2.04,2.32,          
     1 2.32,2.52,2.74,2.70,2.93,3.06,3.13,3.15,3.16,3.10,3.02,3.05,     
     2 2.98,2.97,.47,14*.00,16*0./                                      
C  O+(4P)                                                               
      DATA SIGIO4P/6*0.,.10,.34,.58,.73,.82,.89,.85,.91,.91,.93,        
     1 .92,.92,.55,24*.00,16*0./                                        
C  O+(2P*)                                                              
      DATA SIGIO2Q/6*0.,.03,.27,.46,.54,.56,.49,.52,.41,.41,            
     1 28*.00,16*0./                                                    
C  HE+                                                                  
      DATA SIGIHE/6*0.,.21,.53,1.02,1.71,2.16,2.67,2.38,                
     1 3.05,3.05,3.65,4.35,4.25,5.51,6.53,7.09,.72,21*.00,16*0./        
C  N+  BANKS AND KOCKARTS X1.E-17                                       
      DATA SIGIN/6*0.,0.1,0.2,0.25,0.35,0.4,0.5,0.5,0.6,0.6,0.65,       
     10.8,0.7,1.,1.,1.,1.1,1.15,1.2,1.1,1.2,1.2,1.2,1.2,1.2,1.1,1.1,1.1,
     21.0,1.0,1.0,1.0,1.0,5*0.,16*0./                                   
C  H+  BANKS AND KOCKARTS X1.E-18                                       
      DATA SIGIH/6*0.,0.05,0.02,0.05,0.12,0.16,0.20,0.23,0.27,          
     10.27,0.36,0.44,0.53,0.8,0.9,1.0,1.4,1.6,1.8,1.8,2.,2.2,2.3,2.8,   
     23.1,3.5,3.8,4.,4.,4.1,4.8,5.8,6.12,5*0.,16*0./                    
C                                                                       
      IF (ISCALE .EQ. 0) THEN                                           
        R1 =  B1(1) + B1(2)*(F107A-71.5) + B1(3)*(F107-F107A+3.9)       
        R2 =  B2(1) + B2(2)*(F107A-71.5) + B2(3)*(F107-F107A+3.9)       
        DO 100 L=1,LMAX                                                 
        IF (L .LT. 9) THEN                                              
          SFLUX(L) = SRA(L) * F107 + SRB(L)                             
        ELSE                                                            
          IF (L .EQ. 12) THEN                                           
            SFLUX(L) = 332. + 0.6 * (F107-65.)                          
          ELSE                                                          
            SFLUX(L) = (RFLUX(L) + ((R1-1.)*SCALE1(L)                   
     >                            + (R2-1.)*SCALE2(L)) / 1000.)         
            IF (SFLUX(L) .LT. 0.0) SFLUX(L) = 0.0                       
          ENDIF                                                         
        ENDIF                                                           
  100   CONTINUE                                                        
      ELSE                                                              
        FRAT = (F107-68.) / (243.-68.)                                  
        DO 200 L=1,LMAX                                                 
        SFLUX(L) = RFLUX(L) + (XFLUX(L)-RFLUX(L)) * FRAT                
  200   CONTINUE                                                        
      ENDIF                                                             
C                                                                       
      SFNORM = 2. - (F107-68.) / (243.-68.)                             
      IF (SFNORM .LT. 1.0) SFNORM = 1.0                                 
C                                                                       
      DO 300 L=1,LMAX                                                   
      WAVE1(L) = WAVEL(L)                                               
      WAVE2(L) = WAVES(L)                                               
      IF (WAVE1(L) .LT. 251. .AND. WAVE2(L) .GT. 49.)                   
     >   SFLUX(L) = SFLUX(L) * SFNORM                                   
      SFLUX(L) = SFLUX(L) * 1.E9                                        
  300 CONTINUE                                                          
      IF(ITIMET.GT.1) RETURN                                            
        DO 10 L=1,LMAX                                                  
        M=LMAX-L+1                                                      
        SIGABS(1,L) = SIGAO(L)  * 1.E-18                                
        SIGABS(2,L) = SIGAO2(L) * 1.E-18                                
        SIGABS(3,L) = SIGAN2(L) * 1.E-18                                
        SIGION(1,L) = SIGIO(L)  * 1.E-18                                
        SIGION(2,L) = SIGIO2(L) * 1.E-18                                
        SIGION(3,L) = SIGIN2(L) * 1.E-18                                
        SIGABS(4,L) = SIGACO(M) * 1.E-18                                
        SIGION(4,L) = SIGICO(M) * 1.E-18                                
        SIGABS(5,L) = SIGACO2(M)* 1.E-18                                
        SIGION(5,L) = SIGICO2(M)* 1.E-18                                
        SIGION(6,L) = SIGIO4S(M)* 1.E-18                                
        SIGION(7,L) = SIGIO2D(M)* 1.E-18                                
        SIGION(8,L) = SIGIO2P(M)* 1.E-18                                
        SIGION(9,L) = SIGIO4P(M) * 1.E-18                               
        SIGION(10,L)= SIGIO2Q(M)* 1.E-18                                
        SIGION(11,L)= SIGIHE(M) * 1.E-18                                
        SIGION(12,L)= SIGIN(M)  * 1.E-17                                
        SIGION(13,L)= SIGIH(M)  * 1.E-18                                
   10   CONTINUE                                                        
        ITIMET=ITIMET+1                                                 
      RETURN                                                            
      END                                                               
c
      SUBROUTINE COSRAY(PHI)                                            
      SAVE
      PARAMETER(KMX=96)
      include "blank.h"
      COMMON/COSMICR/QCR(KMX)                                           
      RAD=57.295                                                        
      IF(PHI.GT.53.) GO TO 1                                            
      X1=1.74E-18                                                       
      X2=2.84E-17+(1.93E-17-2.84E-17)/135.*(F107-65.)                   
      X3=0.6+0.8*ABS(COS(PHI/RAD))                                      
      DO 2 K=1,KMX                                                      
      XM=XNO(K)+XNO2(K)+XNN2(K)                                         
      IF(XM.LT.3.E+17) GO TO 3                                          
      QCR(K)=(X1+X2*(ABS(SIN(PHI/RAD)))**4.)*(3.E+17)**(1.-X3)*(XM)**X3 
      GO TO 4                                                           
  3   CONTINUE                                                          
      QCR(K)=(X1+X2*(ABS(SIN(PHI/RAD)))**4.)*XM                         
  4   CONTINUE                                                          
  2   CONTINUE                                                          
      GO TO 5                                                           
  1   CONTINUE                                                          
      X1=1.44E-17                                                       
      X2=4.92E-18                                                       
      DO 6 K=1,KMX                                                      
      XM=XNO(K)+XNO2(K)+XNN2(K)                                         
      A=X1*XM                                                           
      B=(X1+X2)*XM                                                      
      QCR(K)=B+(A-B)/135.*(F107-65.)                                    
  6   CONTINUE                                                          
  5   CONTINUE                                                          
      RETURN                                                            
      END                                                               
