#include "dims.h" SUBROUTINE QRJ use cons_module,only: len1,len2,len3,kmax,kmaxp1,expz, | rmassinv,t0,avo,expzmid,expzmid_inv,p0,boltz,gask,rmassinv_o2, | rmassinv_o,rmassinv_n2 ! use o2src ! module in o2src.f for O2 heating/dissoc in Shumann-Runge ! 12/11/00: Use o2srbc as per kibo12 use o2srbc ! module in o2srbc.f for O2 heating/dissoc in Shumann-Runge use input_module,only: f107 use init_module,only: sfeps implicit none C **** CALCULATE HEATING AND DISSOCIATION RATES C **** CHAPMAN INTEGRAL FOR EACH SPECIES AT EACH GRID C **** POINT IN NNO2, NNO, NNN2 (CALCULATED BY SUB CHAPMN) #include "params.h" #include "fcom.h" #include "vscr.h" #include "index.h" #include "buff.h" #include "phys.h" #include "crates_tdep.h" #include "cmpbnd.h" #include "mwt.h" ! ! Absorption and ionization coefficients are in shared common ! /qrj_coeff/. Sigmas, sigeuv are data initialized in block ! data subprogram set_qrj_coeff below. (see also init_sflux and ! init_sigmas below) ! integer,parameter :: lmax=59 real :: euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc,sigmas, | quench,sflux,brn2,bro2,temp common/qrj_coeff/ + EUVEFF(ZKMXP),SIGEUV(8,lmax),FEUV(lmax),RLMEUV(lmax),FSRC(15), + SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4),SFLUX(lmax), + BRN2(lmax),BRO2(lmax) ! ! 11/30/98: Added SJNMLYA, etc as per modsrc.kibo: real :: SJNMLYA(ZIMXP,ZKMXP), SJMLYA(ZIMXP,ZKMXP), 1 SJO2LYA(ZIMXP,ZKMXP) ! ! Declarations for O2 photolysis and heating in Shumann-Runge Continuum ! (SRC) and Shumann-Runge Bands (SRB) (see o2srbc.f). ! 12/11/00: declarations for o2srbc as per kibo12: real :: | xno2(zkmxp), ! o2 column density (cm-2) | rho(zkmxp), ! total density | fcp(zkmxp), ! specific heat | fnno2(zkmxp,zimxp), ! o2 slant column density from chapman | do2src(zimxp,zkmxp), ! o2 dissoc in SRC (mkdo2src output) | ho2src(zimxp,zkmxp), ! o2 heating in SRC (mkho2src output) | do2srb(zimxp,zkmxp), ! o2 dissoc in SRB (mkdo2srb output) | ho2srb(zimxp,zkmxp) ! o2 heating in SRB (mkdo2srb output) real :: do2,do22,factor,sfac,zkmin integer :: i,k,n,m,kmin,imin integer :: nno2k,nnok,nnn2k,nps1k,nps2k,npo1k,npn4sk,nqk,nrjk, | nqtefk,njco2tk,njh2otk,njh2olk,njo3dk,njo3pk,njo2dk,njch4tk, | nqo2jk,nqop2pk,nqnopk,nqop2dk,nnk,ntk,nqo2pk,nqopk,nqn2pk, | nqnpk,nno3k,nnvo2k,npnok,npo3k,npo21dk,ndnk,nmsk ! ! If mks > 0, ho2src or ho2srb are returned in deg K/sec (mks) ! If mks <= 0, ho2src or ho2srb are returned in ergs/gm-1/s-1 (cgs) integer,save :: mks=0 ! units flag for ho2src ! DO2=8.203E-12 DO22=1.1407E-11 C **** C **** C **** COMPUTE S14 = RSQ, S15 = RSP C **** C **** C **** S1 = TAU(R), S2 = TAU(Q) C **** NNO2K = NNO2 NNOK = NNO NNN2K = NNN2 DO 6 I = 1,LEN3 S1(I,1) = SIGEUV(1,49)*F(I,NNO2K)+SIGEUV(2,49)*F(I,NNOK)+ 1 SIGEUV(3,49)*F(I,NNN2K) S2(I,1) = SIGEUV(1,20)*F(I,NNO2K)+SIGEUV(2,20)*F(I,NNOK)+ 1 SIGEUV(3,20)*F(I,NNN2K) C **** C **** S3 = TAU(1), S4 = TAU(2), S5 = TAU(3) C **** S3(I,1) = 1.3*S1(I,1) S4(I,1) = 2.0*S1(I,1) S5(I,1) = 2.5*S1(I,1) C **** C **** IF(TAU.GT.9.0) TAU = 9.0 C **** if (s1(i,1) > 9.) s1(i,1) = 9. if (s2(i,1) > 9.) s2(i,1) = 9. if (s3(i,1) > 9.) s3(i,1) = 9. if (s4(i,1) > 9.) s4(i,1) = 9. if (s5(i,1) > 9.) s5(i,1) = 9. C **** C **** TAU(N) = EXP(-TAU(N)) FOR N = 1,3,1 C **** s3(i,1) = exp(-s3(i,1)) s4(i,1) = exp(-s4(i,1)) s5(i,1) = exp(-s5(i,1)) C **** C **** S6 = EXP(-TAU(R)), S7 = EXP(-TAU(Q)) C **** s6(i,1) = exp(-s1(i,1)) s7(i,1) = exp(-s2(i,1)) C **** C **** S14 = RSP, S15 = RSQ C **** S14(I,1) = S6(I,1)+2.*(S3(I,1)+S4(I,1)+S5(I,1)) S15(I,1) = 1.5*S6(I,1)/(S14(I,1)+S2(I,1)/S1(I,1)*S7(I,1)) S14(I,1) = 2.4*S6(I,1)/S14(I,1) 6 CONTINUE C **** C **** C **** S1 = PSI(O2), S2 = PSI(O), S3 = PSI(N2), S4 = PSI(N4S) C **** C **** NPS1K=NJ+NPS NPS2K=NJ+NPS2 NPO1K=NJ+NPO1 NPN4SK=NJ+NPN4S C **** C **** LEVELS 2 THRU KMAXP1 C **** DO 7 I=1,LEN2 S1(I,2)=.5*(F(I,NPS1K)+F(I,NPS1K+1)) S2(I,2)=.5*(F(I,NPS2K)+F(I,NPS2K+1)) C S4(I,2)=.5*(F(I,NPN4SK)+F(I,NPN4SK+1)) S4(I,2)=0. 7 CONTINUE C **** C **** LEVEL 1 C **** DO 8 I=1,LEN1 S1(I,1)=.5*((B(I,1,1)+1.)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+ 1 FB(I,1)) S2(I,1)=.5*(B(I,2,1)*F(I,NPS1K)+(B(I,2,2)+1.)*F(I,NPS2K)+ 1 FB(I,2)) S4(I,1) = 0. 8 CONTINUE C **** C **** NOW CALCULATE S3 = PSI(N2) C **** DO 9 I=1,LEN3 S3(I,1)=1.-S1(I,1)-S2(I,1) 9 CONTINUE C **** C **** C **** CALCULATE IONIZATION CONTRIBUTIONS IN S8 - S13 C **** C **** C **** S8 = O2 IONIZATION C **** S9 = O IONIZATION C **** S10 = N2 IONIZATION C **** S11 = N4S IONIZATION C **** S12 = O2 IONIZATION * BRO2 C **** S13 = N2 IONIZATION * BRN2 C **** C **** C **** CONTRIBUTIONS TO Q, J AND QTEF FROM EUV C **** C **** INITIALIZE Q, RJ AND QTEF C **** NQK = NQ NRJK = NRJ NQTEFK = NQTEF NJCO2TK = NJCO2T NJH2OTK = NJH2OT NJH2OLK = NJH2OL NJO3DK = NJO3D NJO3PK = NJO3P NJO2DK = NJO2D NJCH4TK = NJCH4T NQO2JK = NQO2J NQOP2PK = NQOP2P NQNOPK = NQNOP NQOP2DK = NQOP2D DO 10 I = 1,LEN3 DNOEUV(I,1) = 0. F(I,NQK) = 0. F(I,NRJK) = 0. F(I,NQTEFK) = 0. F(I,NJCO2TK) = 0. F(I,NJH2OTK) = 0. F(I,NJH2OLK) = 0. F(I,NJO3DK) = 0. F(I,NJO3PK) = 0. F(I,NJO2DK) = 0. F(I,NJCH4TK) = 0. F(I,NQO2JK) = 0. F(I,NQOP2PK) = 0. F(I,NQOP2DK) = 0. F(I,NQNOPK) = 0. 10 CONTINUE C **** C **** INITIALIZE S8 - S13 C **** DO 11 I=1,6*LEN3 S13(I,1)=0. 11 CONTINUE C **** C **** SUMMATION OVER WAVE LENGTH C **** ! write(6,"('qrj: j=',i2,' sfeps=',e12.4,' feuv=',/,(6e12.4))") ! | j,sfeps,feuv ! Given zkmin, calculate kmin for any vertical resolution: zkmin = -7.0 kmin = int((zkmin-zsb)/dz)+1 ! write(6,"('qrj: j=',i2,' zkmin=',f6.2,' kmin=',i2)") j,zkmin,kmin IMIN = (KMIN-1)*LEN1 + 1 DO 12 N = 16,lmax C **** C **** S5=SUM(O2,O,N2)(SIGMA*CHAPMAN) C **** S6=SUM(O2,O,N2)(SIGMA*PSI/RMASS) C **** S7=SUM(O2,O,N2,N4S)(SIGMAS) C **** C **** INITIALIZE S5, S6, S7 C **** DO 13 I = IMIN,LEN3 S5(I,1) = 0. S6(I,1) = 0. S7(I,1) = 0. 13 CONTINUE C **** C **** SUMMATION OVER O2, O, N2 C **** DO 14 M = 1,3 K = (3-M)*KMAXP1+1 NNK = NNO2+(M-1)*KMAXP1 DO 14 I = IMIN,LEN3 S5(I,1) = S5(I,1)+SIGEUV(M,N)*F(I,NNK) S6(I,1) = S6(I,1)+SIGEUV(M,N)*S3(I,K)*rmassinv(M) S7(I,1) = S7(I,1)+SIGMAS(M,N) 14 CONTINUE DO 15 I = IMIN,LEN3 C **** C **** ADD CONTRIBUTIONS FROM N4S TO S7 C **** S7(I,1) = S7(I,1)+SIGMAS(4,N) C **** C **** S5 = F(LAMDA)*EXP(-TAU) C **** S5(I,1) = FEUV(N)*exp(-S5(I,1)) C **** C **** ADD CONTRIBUTIONS TO Q AND RJE C **** ! C(60) 1.9845E-16 F(I,NQK) = F(I,NQK)+1.9845E-16/RLMEUV(N)*S5(I,1)*S6(I,1) F(I,NRJK) = F(I,NRJK)+S5(I,1)*S7(I,1) F(I,NJCO2TK) = F(I,NJCO2TK)+S5(I,1)*SIGEUV(5,N) C F(I,NJH2OLK) = F(I,NJH2OLK)+S5(I,1)*SIGEUV(6,N) DNOEUV(I,1) = DNOEUV(I,1)+S5(I,1)*SIGEUV(7,N) F(I,NJO3DK) = F(I,NJO3DK)+S5(I,1)*SIGEUV(4,N) F(I,NJCH4TK) = F(I,NJCH4TK)+S5(I,1)*SIGEUV(8,N) F(I,NQOP2PK) = F(I,NQOP2PK)+S5(I,1)*SIGMAS(6,N)* 1 S2(I,1)*rmassinv_o F(I,NQOP2DK) = F(I,NQOP2DK)+S5(I,1)*SIGMAS(5,N)* 1 S2(I,1)*rmassinv_o 15 CONTINUE C **** C **** ADD IONIZATION FOR O2, O, N2 TO S8, S9, S10 C **** DO 16 M=1,3 K=(3-M)*KMAXP1+1 DO 16 I = IMIN,LEN3 S10(I,K)=S10(I,K)+SIGMAS(M,N)*S5(I,1)*S3(I,K)*rmassinv(M) 16 CONTINUE DO 17 I = IMIN,LEN3 C **** C **** ADD EFFECTIVE N2 IONIZATION TO QTEF ! 11/30/98: added *2. to next statement as per modsrc.kibo: C **** F(I,NQTEFK) = F(I,NQTEFK)+(SIGEUV(3,N)-SIGMAS(3,N))*S5(I,1)* 1 S3(I,1)*rmassinv_n2*2. C **** C **** ADD N4S IONIZATION TO S11 C **** S11(I,1) = S11(I,1)+SIGMAS(4,N)*S5(I,1)*S4(I,1)/RMN4S C **** C **** ADD IONIZATION CONTRIBUTIONS TO S12 AND S13 C **** S12(I,1) = S12(I,1)+SIGMAS(1,N)*S5(I,1)*S1(I,1)*rmassinv_o2* 1 BRO2(N) S13(I,1) = S13(I,1)+SIGMAS(3,N)*S5(I,1)*S3(I,1)*rmassinv_n2* 1 BRN2(N) 17 CONTINUE 12 CONTINUE C **** C **** MULTIPLY Q BY EFICIENCY FACTOR C **** C **** NQK=NQK-1 DO 18 K=1,KMAXP1 NQK=NQK+1 DO 18 I=1,LEN1 F(I,NQK)=F(I,NQK)*EUVEFF(K)*avo 18 CONTINUE C **** C **** C **** CALCULATE N*MBAR IN S5 C **** C **** C **** S6 = T(TOTAL,K) C **** C **** LEVEL 1 C **** NTK=NJ+NT+KMAX DO 19 I=1,LEN1 S6(I,1)=F(I,NTK)+T0(1) 19 CONTINUE C **** C **** LEVELS 2 THRU KMAX C **** NTK=NJ+NT-1 DO 20 K=2,KMAX NTK=NTK+1 DO 20 I=1,LEN1 S6(I,K)=.5*(F(I,NTK)+F(I,NTK+1))+T0(K) 20 CONTINUE C **** C **** LEVEL KMAXP1 C **** NTK=NJ+NT+KMAX-1 DO 21 I=1,LEN1 S6(I,KMAXP1)=F(I,NTK)+T0(KMAXP1) 21 CONTINUE C **** C **** S7 = EXPS (K) C **** DO 22 K=1,KMAX DO 22 I=1,LEN1 S7(I,K)=expzmid_inv*expz(K) 22 CONTINUE DO 23 I=1,LEN1 S7(I,KMAXP1)=expzmid*expz(KMAX) 23 CONTINUE C **** C **** S5 = N*MBAR (K) C **** NMSK=NJ+NMS DO 24 I=1,LEN3 S5(I,1)=p0*S7(I,1)*F(I,NMSK)/(boltz*S6(I,1)) 24 CONTINUE C **** C **** C **** CALCULATE CONTRIBUTIONS TO NQO2P, NQOP, NQN2P, NQNP C **** AND NQTEF C **** C **** NQO2PK = NQO2P NQOPK = NQOP NQOP2PK = NQOP2P NQOP2DK = NQOP2D NQN2PK = NQN2P NQNPK = NQNP NQTEFK = NQTEF NNO2K = NNO2 NNO3K = NNO3 NNVO2K = NNVO2 DO 25 I=1,LEN3 F(I,NQO2PK) = F(I,NQO2PK)+(S8(I,1)*(1.+S15(I,1))-S12(I,1))* 1 S5(I,1) F(I,NQN2PK) = F(I,NQN2PK)+(S10(I,1)*(1.+S14(I,1))-S13(I,1))* 1 S5(I,1) DISN2P(I,1) = S10(I,1)*S14(I,1)*S5(I,1) F(I,NQNPK) = F(I,NQNPK)+(S11(I,1)+S13(I,1))*S5(I,1) F(I,NQTEFK) = F(I,NQTEFK)*S5(I,1) S4(I,1) = F(I,NQOP2PK)+F(I,NQOP2DK)+S9(I,1)+S12(I,1) F(I,NQOP2PK) = (F(I,NQOP2PK)+S4(I,1)*S14(I,1)*0.22)*S5(I,1) F(I,NQOP2DK) = (F(I,NQOP2DK)+S4(I,1)*S14(I,1)*0.24)*S5(I,1) F(I,NQOPK) = F(I,NQOPK)+(S9(I,1)+S12(I,1)+S4(I,1)*S14(I,1) 1 *0.56)*S5(I,1) C XJNO(I,1) = 4.5E-6*(1.+0.11*(f107-65.)/165.)*exp(-1.E-8* C 1 F(I,NNO2K)**0.38)*exp(-5.E-19*F(I,NNO3K)) C 2 *SFEPS XJNO(I,1) = 7.0E-6*(1.+0.11*(f107-65.)/165.)*exp(-1.E-8* 1 F(I,NNO2K)**0.38)*exp(-5.E-19*F(I,NNO3K)) 2 *SFEPS ! 12/11/00: add parens to sjmlya as per kibo12: SJMLYA(I,1) = (0.68431*exp(-8.22114E-21*F(I,NNO2K))+ 1 0.229841*exp(-1.77556E-20*F(I,NNO2K))+ 2 0.0865412*exp(-8.22112E-21*F(I,NNO2K))) 3 *SFLUX(12) SJO2LYA(I,1) = (6.0073E-21*exp(-8.2166E-21*F(I,NNO2K))+ 1 4.28569E-21*exp(-1.63296E-20*F(I,NNO2K))+ 2 1.28059E-20*exp(-4.85121E-17*F(I,NNO2K))) 3 *SFLUX(12) XJNOP(I,1) = 2.02E-18*SJMLYA(I,1) SJNMLYA(I,1) = (0.68431*exp(-8.22114E-21*F(I,NNVO2K))+ 1 0.229841*exp(-1.77556E-20*F(I,NNVO2K))+ 2 0.0865412*exp(-8.22112E-21*F(I,NNVO2K))) 3 *SFEPS XJNOPN(I,1) = 2.02E-18*SFLUX(12)/100.*SJNMLYA(I,1) 25 CONTINUE C **** C **** CALCULATE NO IONIZATION AND ADD TO NQNOP C **** NQNOPK=NQNOP NNO2K=NNO2 NPNOK=NJ+NPNO C **** LEVEL 1 DO 26 I=1,LEN1 F(I,NQNOPK)=F(I,NQNOPK)+(XJNOP(I,1)+DNOEUV(I,1))*F(I,NPNOK) 1 *S5(I,1)/RMNO 26 CONTINUE C **** LEVELS 2 THRU KMAXP1 DO 27 I=LEN1+1,LEN3 F(I,NQNOPK)=F(I,NQNOPK)+(XJNOP(I,1)+DNOEUV(I,1))*.5* 1 (F(I,NPNOK)+F(I,NPNOK-1))*S5(I,1)/RMNO 27 CONTINUE NQO2PK = NQO2P NQOPK = NQOP NQOP2PK = NQOP2P NQOP2DK = NQOP2D NQN2PK = NQN2P NQNPK = NQNP NQTEFK = NQTEF NQNOPK=NQNOP DO 270 I=1,LEN3 if (f(i,nqo2pk) < 1.e-20) f(i,nqo2pk) = 1.e-20 if (f(i,nqn2pk) < 1.e-20) f(i,nqn2pk) = 1.e-20 if (f(i,nqnpk) < 1.e-20) f(i,nqnpk) = 1.e-20 if (f(i,nqtefk) < 1.e-20) f(i,nqtefk) = 1.e-20 if (f(i,nqop2pk) < 1.e-20) f(i,nqop2pk) = 1.e-20 if (f(i,nqop2dk) < 1.e-20) f(i,nqop2dk) = 1.e-20 if (f(i,nqopk) < 1.e-20) f(i,nqopk) = 1.e-20 if (f(i,nqnopk) < 1.e-20) f(i,nqnopk) = 1.e-20 270 CONTINUE DO 28 K=1,KMAXP1 FACTOR=avo*p0/gask*expz(1)*expzmid**(2*K-3) DO 28 I=1,LEN1 S8(I,K)=FACTOR/((S1(I,K)*rmassinv_o2+S2(I,K)*rmassinv_o+ 1 S3(I,K)*rmassinv_n2)*S6(I,K)) 28 CONTINUE DO 29 I=1,LEN3 S8(I,1)=S8(I,1)*(QUENCH(1)*S3(I,1)*rmassinv_n2+ 1 QUENCH(2)*S1(I,1)*rmassinv_o2) S8(I,1)=QUENCH(3)*S8(I,1)/(QUENCH(4)+S8(I,1)) 29 CONTINUE NQK=NQ NRJK=NRJ NJCO2TK = NJCO2T NJH2OTK = NJH2OT NJO3DK = NJO3D NJO2DK = NJO2D C **** C **** S7=SUM OVER WAVE LENGTH(SIGMA*F*EXP(-SIGMA*CHAPMAN)* C **** (HC/LAMDA-DO2)) C **** INITIALIZE S7 C **** DO 30 I=1,LEN3 S7(I,1)=0. ! 12/11/00: as per kibo12: ! DO2SRC(I,1) = 0 30 CONTINUE C **** C **** SUMMATION OVER WAVE LENGTH C **** NNO2K=NNO2 DO 31 N=1,15 DO 31 I=1,LEN3 S10(I,1)=FSRC(N)*exp(-SIGSRC(N)*F(I,NNO2K)) S9(I,1)=SIGSRC(N)*S10(I,1) ! 12/11/00: s7 commented out as per kibo12: ! S7(I,1)=S7(I,1)+S9(I,1)* ! 1 (1.9845E-16/RLMSRC(N)-DO22+S8(I,1)) ! S7(I,1)=S7(I,1)+S9(I,1)* ! 1 (1.9845E-16/RLMSRC(N)-DO22) C **** C **** UPDATE RJ C **** ! 12/11/00: as per kibo12: ! Update NRJ and NJO2D using SSFLUX, if NOT calling o2src: ! F(I,NRJK)=F(I,NRJK)+S9(I,1) ! F(I,NJO2DK) = F(I,NJO2DK)+S9(I,1) ! DO2SRC(I,1) = DO2SRC(I,1)+S9(I,1) ! F(I,NJCO2TK) = F(I,NJCO2TK)+SIGEUV(5,N)*S10(I,1) F(I,NJH2OTK) = F(I,NJH2OTK)+SIGEUV(6,N)*S10(I,1) F(I,NQNOPK) = F(I,NQNOPK)+SIGEUV(7,N)*S10(I,1) F(I,NJO3DK) = F(I,NJO3DK)+SIGEUV(4,N)*S10(I,1) 31 CONTINUE C **** C **** UPDATE Q C **** ! O2 SRC added from o2src calls below. ! Update Q here if NOT calling o2src: ! DO 32 I=1,LEN3 ! F(I,NQK)=F(I,NQK)+S7(I,1)*avo*S1(I,1)*rmassinv_o2 ! HO2SRC(I,1)= S7(I,1)*avo*S1(I,1)*rmassinv_o2 ! 32 CONTINUE ! ! O2 photolysis and heating in Shumann-Runge Continuum (SRC) ! These routines are in module o2src, file o2src.F. ! First get rho (gm/cm3) and xno2 (cm3), using N*MBAR S5 from above, ! and S1,S2,S3 (psio2,psio,psin2 interpolated to interfaces). ! ! 9/26/00: retain k-loop on inside for now -- Sx(i,k) scratch arrays ! will be transformed to Sxk(k,i) when this qrj is rewritten (see ! tgcm14/qrj.F) ! ! 12/11/00: f107 is use associated from input module, and rmassinv ! is in cons_mod. ! do i=1,len1 ho2src(i,:) = 0. do2src(i,:) = 0. do k=1,kmaxp1 rho(k) = (s1(i,k)*s5(i,k) + ! o2 | s2(i,k)*s5(i,k) + ! o | s3(i,k)*s5(i,k))*1.66e-24 ! n2 (gm/cm3) xno2(k) = s1(i,k)*rmassinv(1)*s5(i,k) ! cm3 fcp(k) = f(i,ncp+k-1) ! specific heat for ho2src units fnno2(k,i) = f(i,nno2+k-1) ! from chapman enddo ! k=1,kmaxp1 ! ! Pass columns at each grid point to the o2src routines. ! mkdo2src returns do2src (dissociation), mkho2src returns ho2src (heating) ! subroutine mkdo2src(sco2,f107d,do2src,nlev) ! subroutine mkho2src(sco2,xno2,rho,cp,f107d,ho2src,nlev,mks) ! call mkdo2src(fnno2(:,i),f107,do2src(i,:),zkmxp) call mkho2src(fnno2(:,i),xno2,rho,fcp,f107,ho2src(i,:), | zkmxp,mks) ! ! 12/11/00: call mkdo2srb as per kibo12: call mkdo2srb(fnno2(:,i),xno2,rho,fcp,f107,sfeps, | do2srb(i,:),ho2srb(i,:),zkmxp,mks) enddo ! i=1,len1 ! ! Add o2 heating to f(nq), and o2 dissociation to f(nrj): do k=1,kmaxp1 nqk = nq+k-1 nrjk = nrj+k-1 njo2dk = njo2d+k-1 f(:,nqk) = f(:,nqk)+ho2src(:,k) f(:,nrjk) = f(:,nrjk)+do2src(:,k) f(:,njo2dk) = f(:,njo2dk)+do2src(:,k) ! 12/11/00: add do2srb and ho2srb as per kibo12: f(:,nrjk) = f(:,nrjk)+do2srb(:,k) f(:,nqk) = f(:,nqk)+ho2srb(:,k) enddo C **** C **** CONTRIBUTIONS FROM OZONE DISSOCIATION FROM THE C **** HERZBERG, HARTLEY, HUGGINS AND CHAPIUS BANDS C **** C **** CONTRIBUTIONS FROM SOLAR LYMAN-A, SRB AND C **** HERZBERG TO O2 DISSOCIATION AND HEATING C **** SFAC = 1.+0.11*(f107-65.)/165. NPO3K = NJ+NPO3 NPS1K = NJ+NPS NPO21DK = NJ+NPO21D DO 36 I=1,LEN2 S1(I,2) = 0.5*(F(I,NPO3K)+F(I,NPO3K+1)) S2(I,2) = 0.5*(F(I,NPS1K)+F(I,NPS1K+1)) S3(I,2) = 0.5*(F(I,NPO21DK)+F(I,NPO21DK+1)) 36 CONTINUE C **** C **** LEVEL 1 C **** DO 37 I=1,LEN1 S1(I,1) = F(I,NPO3K)**1.5/SQRT(F(I,NPO3K+1)) S2(I,1) = F(I,NPS1K)**1.5/SQRT(F(I,NPS1K+1)) S3(I,1) = F(I,NPO21DK)**1.5/SQRT(F(I,NPO21DK+1)) 37 CONTINUE NRJK = NRJ NNO3K = NNO3 NJO3PK = NJO3P NJO3DK = NJO3D NNO2K = NNO2 NQK = NQ NDNK = NDN NNO2K=NNO2 NJH2OLK=NJH2OL NJCO2TK = NJCO2T NJH2OTK = NJH2OT NJO2DK = NJO2D NQO2PK = NQO2P NJCH4TK = NJCH4T DO 39 I=1,LEN3 S4(I,1) = F(I,NNO2K) s9(i,1) = f(i,nno3k) if (f(i,nno3k) < 1.e+5) s9(i,1) = 1.e+5 C C **** C **** DISSOCIATION AND HEATING OF O3 COMPONENTS C **** C C **** DISSOCIATION AND HEATING FROM LY-A C F(I,NJO3DK) = F(I,NJO3DK)+2.27E-17*SJMLYA(I,1) F(I,NQK) = F(I,NQK)+2.27E-17*SJMLYA(I,1)*S1(I,1)/RMO3* 1 avo*9.944E-12 C C **** HARTLEY BANDS OF O3 C temp = 1.0E-3*exp(-1.5577E-13*s9(i,1)**0.6932) if (s9(i,1) < 1.6E+20) | temp = 1.04E-2*exp(-1.0217E-6*s9(i,1)**0.3587) f(i,njo3dk) = f(i,njo3dk)+(temp* | 0.68 +exp(-1.4912E-14*s4(i,1)**0.5298)* | (4.053E-4*exp(-8.1381E-16*s9(i,1)**0.8856)+ | 4.7E-6 *exp(-1.5871E-14*s9(i,1)**0.7665))* | 1.085 *exp(-1.4655E-25*s4(i,1)**1.0743)*0.68)*sfeps ! C **** CHAPPIUS AND HUGGINS BANDS F(I,NJO3PK) = F(I,NJO3PK)+(4.5E-4*exp(-3.4786E-11*S4(I,1) 1 **0.3366)*exp(-1.0061E-20*S9(I,1)**0.9719) 2 +(7.5E-4*exp(-2.7663E-19*S9(I,1)**1.0801) 3 +2.5E-4/(1.+1.5772E-18*S9(I,1)**0.9516)) 4 *exp(-1.0719E-10*S4(I,1)**0.3172)) 5 *SFEPS C C C **** OZONE HEATING TO NQK ADDED HERE C S12(I,1) = exp(-5.50E-24*F(I,NNO2K) 1 -6.22E-18*F(I,NNO3K)) S11(I,1) = exp(-1.34E-26*F(I,NNO2K) 1 -1.66E-18*F(I,NNO3K)) F(I,NQK) = F(I,NQK)+((5.512E-16*exp(-3.16E-21*F(I,NNO3K)) 1 +(41.21E-16*exp(-8.94E-19*F(I,NNO3K)) 2 + 10.90E-16*exp(-1.09E-19*F(I,NNO3K)) 3 + 52.80E-16*exp(-3.07E-18*F(I,NNO3K))) 4 +(69.60E-16*exp(-9.65E-18*F(I,NNO3K)) 5 + 9.39E-16*exp(-4.79E-18*F(I,NNO3K))) 6 +(14.94E-16*S12(I,1)+2.76E-16*S11(I,1))) 7 *S1(I,1)/RMO3*avo)*SFEPS C C **** C **** DISSOCIATION AND HEATING OF O2 COMPONENTS C **** C C **** DISSOCIATION AND HEATING FROM LY-A C F(I,NRJK) = F(I,NRJK)+SJO2LYA(I,1) F(I,NJO2DK) = F(I,NJO2DK)+SJO2LYA(I,1)*0.53 C F(I,NJO2DK) = F(I,NJO2DK)+SJO2LYA(I,1) F(I,NQK) = F(I,NQK)+SJO2LYA(I,1)*S2(I,1)*rmassinv_o2*avo* 1 8.13816E-12 C C **** DISSOCIATION AND HEATING FROM SRB C C DO 101 IL=1,15 C TRANO3 = exp(-SIGO3(IL)*F(I,NNO3K)) C SUM = 0. C DO 102 JL=1,6 C SUM = SUM+SG(JL,IL)*exp(-SG(JL,IL)*F(I,NNO2K))*W(JL) C102 CONTINUE C SUN = SUN+SI(IL)*DL(IL)*TRANO3*SUM C SUQ = SUQ+SI(IL)*DL(IL)*TRANO3*SUM*(12400./WL(IL)-5.12) C 1 *S2(I,1)*rmassinv_o2*avo C101 CONTINUE C F(I,NRJK) = F(I,NRJK)+SUN C F(I,NQK) = F(I,NQK)+SUQ C C **** DISSOCIATION FROM SRB ! 12/11/00: SRB commented out as per kibo12: ! S8(I,1) = (merge(0.70E+8/(F(I,NNO2K)**0.83), ! 1 5.56E-8*exp(-1.97E-10 ! 2 *F(I,NNO2K)**0.522),F(I,NNO2K)-1.E+19>=0.)*SFAC) ! 3 *SFEPS ! F(I,NRJK) = F(I,NRJK)+S8(I,1) C C **** HEATING FROM SRB - ZHU ! F(I,NQK) = F(I,NQK)+(26.4960E-20/SQRT(1.+1.734E-18*F(I,NNO2K)) ! 1 *exp(-0.02388*(SQRT(1.+1.734E-18*F(I,NNO2K))-1.)) ! 2 *S2(I,1)*rmassinv_o2*avo) ! 3 *SFEPS C C **** DISSOCIATION AND HEATING FROM HERZBERG C S12(I,1) = 7.4E-10*exp(-2.5352E-15*S4(I,1)**0.6288) 1 *exp(-4.6661E-18*S9(I,1)**0.9538)* 2 0.9*exp(-1.4110E-25*S4(I,1)**1.0667) F(I,NRJK) = F(I,NRJK)+S12(I,1)*SFEPS ! 12/11/00: *sfeps as per kibo12: F(I,NQK) = F(I,NQK)+S12(I,1)*S2(I,1)*rmassinv_o2*avo* 1 0.46458E-12*sfeps C C **** C **** O(1D) PHOTODISSOCIATION PRODUCTION FROM CO2 C **** C **** FROM LY-A C F(I,NJCO2T) = F(I,NJCO2T)+8.14E-20*SJMLYA(I,1) XJCO2D(I,1)= F(I,NJCO2T) C C **** C **** TOTAL CO2 PHOTODISSOCIATION C **** C if (s4(i,1) >= 6.3e+22) then f(i,njco2tk) = f(i,njco2tk)+(2.0e-11* | exp(-1.9087E-20*S4(I,1)**0.8675)* | exp(-2.9570E-14*S9(I,1)**0.7582)* | exp(-5.9648E-15*S4(I,1)**0.6172))*sfeps else f(i,njco2tk) = f(i,njco2tk)+(8.5E-9* | exp(-3.4368E-3*S4(I,1)**0.1456)* | exp(-2.9570E-14*S9(I,1)**0.7582)* | exp(-5.9648E-15*S4(I,1)**0.6172))*sfeps endif C C **** C **** TOTAL H2O PHOTODISSOCIATION C **** C C C F(I,NJH2OTK) = F(I,NJH2OTK)+ C 1 (4.7E-6*exp(-1.7092E-20*S4(I,1)**0.9864) C 2 +1.5E-8*exp(-1.116E-26*S4(I,1)**1.1999)+ C 3 2.5E-9*exp(-7.7798E-18*S4(I,1)**0.7610))* C 4 exp(-3.1368E-13*S9(I,1)**0.7091)* C 5 exp(-3.7960E-17*S4(I,1)**0.7149) S7(I,1)=exp(-1.E-7*F(I,NNO2K)**0.35)*SFEPS F(I,NJH2OLK) = 1.53E-17*SJMLYA(I,1) F(I,NJH2OTK) = F(I,NJH2OTK)+F(I,NJH2OLK) 1 +SFAC*1.2E-6*S7(I,1) C **** C **** TOTAL O2(1DG) IONIZATION C **** F(I,NQO2PK) = F(I,NQO2PK)+(0.549E-9*exp(-2.406E-20 1 *F(I,NNO2K))+2.6E-9*exp(-8.508E-20 2 *F(I,NNO2K)))*S3(I,1)*rmassinv_o2*S5(I,1) 3 *SFEPS C C **** C **** TOTAL CH4 PHOTODISSOCIATION C **** XJCH4A(I,1) = 1.3E-6*exp(-8.4899E-21*S4(I,1)**1.0034)* 1 exp(-3.1398E-17*S9(I,1)**1.0031)* 2 exp(-0.2776/S9(I,1)**0.8240) XJCH4B(I,1) = 3.888E-6*exp(-4.7152E-21*S4(I,1)**1.0153)* 1 exp(-4.0876E-16*S9(I,1)**0.9347)* 2 exp(-0.4976/S9(I,1)**0.0916) C F(I,NJCH4TK) = F(I,NJCH4TK)+(XJCH4A(I,1)+XJCH4B(I,1)) 1 *SFEPS C F(I,NJCH4TK) = F(I,NJCH4TK)+1.85E-17*SJMLYA(I,1) C C **** NEW RATES FOR H2O2,CH2O,N2O AND HO2 C XJH2O2(I,1) = ((1.0E-4/(1.+1.6951E-17*S9(I,1)**0.8573))+ 1 1.0E-4*exp(-2.0818E-23*S4(I,1)**0.9415)* 2 exp(-8.5266E-14*S9(I,1)**0.7466)*0.8721* 3 exp(-1.4871E-20*S4(I,1)**0.8573)) 4 *SFEPS XJCH2OA(I,1) = (1.2E-4*exp(-2.3481E-40*S4(I,1)**1.4962)* 1 exp(-2.1444E-10*S9(I,1)**0.5043)* 2 0.95*exp(-7.1534E-54*S4(I,1)**2.0170)) 3 *SFEPS XJCH2OB(I,1) = (1.1E-4*exp(-6.0858E-70*S4(I,1)**2.6383)* 1 exp(-1.8189E-10*S9(I,1)**0.4812)* 2 exp(-2.4759E-7*S4(I,1)**0.1970)) 3 *SFEPS XJN2O(I,1) = ((3.5E-6*exp(-1.1232E-5*S4(I,1)**0.2638)+ 1 3.5E-7*exp(-3.4971E-18*S4(I,1)**0.7601)) 2 *exp(-7.5897E-14*S9(I,1)**0.7283) 3 *exp(-1.8121E-33*S9(I,1)**1.7512)) 4 *SFEPS XJHO2(I,1) = (8.2E-4*exp(-6.4971E-16*S4(I,1)**0.6354) 1 *exp(-3.2108E-12*S9(I,1)**0.6469) 2 *exp(-7.2877E-21*S9(I,1)**1.1077)) 3 *SFEPS C 39 CONTINUE NDNK = NDN DO 40 K = 1,KMAXP1 DO 40 I = 1,LEN1 XJNO2(I,K) = 1.3E-2*F(I,NDNK)*SFEPS XJCH3OO(I,K) = 2.71E-5*F(I,NDNK)*SFEPS C XJ762(I,K) = 5.35E-9*F(I,NDNK)*SFEPS XJ762(I,K) = 0. 40 CONTINUE RETURN END !----------------------------------------------------------------------- subroutine init_sflux use cons_module,only: use input_module,only: f107,f107a use init_module,only: sfeps implicit none ! ! Flux initialization once per time step, called from advnce. ! (this call moved from qrj in multi-task version) ! #include "params.h" ! ! Shared common: integer,parameter :: lmax=59 real :: euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc,sigmas, | quench,sflux,brn2,bro2 common/qrj_coeff/ + EUVEFF(ZKMXP),SIGEUV(8,lmax),FEUV(lmax),RLMEUV(lmax),FSRC(15), + SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4),SFLUX(lmax), + BRN2(lmax),BRO2(lmax) ! ! Local: real wave1(lmax),wave2(lmax) ! 11/30/98: Added EUVFLX as per modsrc.kibo: real :: EUVFLX(37),hlybr,fexvir,hlya,heiew,xuvfac integer :: iscale,n,nn ! ISCALE = 0 HLYBR = 0. FEXVIR = 0. ! 12/11/00: hlya as per kibo12: C HLYA = 3.E+11+0.4E+10*(f107-70.) HLYA = 1.E+11*(0.5839+0.3554*SQRT(f107a)+0.1730*(SQRT(f107) 1 -SQRT(f107a))) HEIEW = 0. C XUVFAC =0. XUVFAC = 2.0 - (f107-68.0) / (243.0-68.0) IF (XUVFAC .LT. 1.0) XUVFAC = 1.0 C **** C **** THE FLAG ISCALE CHOOSES THE FLUX MODELING METHOD C **** FROM THE SUBROUTINE SSFLUX. ISCALE=0 DOES SOLOMON'S, C **** ISCALE=1 DOES A LIN. INTERP.,AND ISCALE=2 DOES TOBISKA' C **** C ISCALE =0 for Hinteregger contrast ratio method C =1 for Hinteregger linear interpolation C =2 for Tobiska EUV91 model C =3 for Woods & Rottman 10 Nov. 1988 measurement C =4 for Woods & Rottman 20 Jun. 1989 measurement C F107 daily 10.7 cm flux (1.E-22 W m-2 Hz-1) C F107A 81-day centered average 10.7 cm flux C HLYBR ratio of H Ly-b 1026A flux to solar minimum value (optional) C FEXVIR ratio of Fe XVI 335A flux to solar minimum value (optional) C HLYA H Lyman-alpha flux (photons cm-2 s-1) (optional) C HEIEW He I 10830A equivalent width, (milliAngstroms) (optional) C XUVFAC factor for scaling flux 16-250A (optional) C WAVE1 longwave bound of spectral intervals (Angstroms) C WAVE2 shortwave bound of intervals (= WAVE1 for indiv. lines) C SFLUX scaled solar flux returned by subroutine (photons cm-2 s-1) C ! write(6,"('init_sflux call ssflux: f107=',f9.3,' f107a=',f9.3, ! | ' hlya=',e12.4,' xuvfac=',e12.4)") f107,f107a,hlya,xuvfac CALL SSFLUX(ISCALE,F107,F107A,HLYBR,FEXVIR,HLYA, 1 HEIEW, XUVFAC, WAVE1, WAVE2, SFLUX) ! ! 11/30/98: Added euvac call as per modsrc.kibo: CALL EUVAC(F107,F107A,EUVFLX) C **** C **** TRANSFER VALUES OF SFLUX TO APPROPRIATE SLOTS C **** ! FEUV, FSRC, SFLUX are in shared common /qrj_coeff/ ! and are referenced by qrj. ! ! SFEPS (init_mod.F) is initialized to 1 by sub init, and recalculated ! in advnce.F only if calendar day is being advanced and at ! new day boundaries. ! DO 4 N = 16,lmax FEUV(N) = SFLUX(N)*SFEPS 4 CONTINUE DO 5 N = 1,15 FSRC(N) = SFLUX(N)*SFEPS 5 CONTINUE DO 55 N=1,37 NN = N+15 FEUV(NN) = EUVFLX(N)*SFEPS 55 CONTINUE return end !----------------------------------------------------------------------- subroutine init_sigmas implicit none C **** C **** INITIALIZATION UPON FIRST ENTRY C **** ! Called once per run from start. ! (this call was moved from qrj in multi-task version) ! SIGxxx were init by block data set_qrj_coeff (qrj.f) ! #include "params.h" integer,parameter :: lmax=59 real :: euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc,sigmas, | quench,sflux,brn2,bro2 common/qrj_coeff/ + EUVEFF(ZKMXP),SIGEUV(8,lmax),FEUV(lmax),RLMEUV(lmax),FSRC(15), + SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4),SFLUX(lmax), + BRN2(lmax),BRO2(lmax) real :: wleuv1,wleuv2,sigao,sigao2,sigan2,sigio,sigio2,sigin2, | brop4s,brop2d,brop2p,afac,sigop2p,sigop2d,sigop4s,sigin,brn2np, | bro2op,f74113 COMMON/EUV/ WLEUV1(37),WLEUV2(37),SIGAO(37),SIGAO2(37), 1 SIGAN2(37),SIGIO(37),SIGIO2(37),SIGIN2(37), 2 BROP4S(37),BROP2D(37),BROP2P(37),AFAC(37), 3 SIGOP2P(37),SIGOP2D(37),SIGOP4S(37), 4 SIGIN(37),BRN2NP(37),BRO2OP(37),F74113(37) integer :: m,n,nn,i ! DO 1 M=1,3 DO 1 N=1,lmax SIGEUV(M,N)=SIGEUV(M,N)*1.E-18 SIGMAS(M,N)=SIGMAS(M,N)*1.E-18 SIGEUV(M+4,N)=SIGEUV(M+4,N)*1.E-18 1 CONTINUE DO 2 N = 1,lmax SIGMAS(4,N) = SIGMAS(4,N)*1.E-17 SIGEUV(4,N) = SIGEUV(4,N)*1.E-17 SIGMAS(5,N) = SIGMAS(5,N)*1.E-18 SIGMAS(6,N) = SIGMAS(6,N)*1.E-18 SIGEUV(8,N) = SIGEUV(8,N)*1.E-17 2 CONTINUE DO 3 N = 1,15 RLMSRC(N) = RLMEUV(N) SIGSRC(N) = SIGEUV(1,N) 3 CONTINUE ! ! This loop moved from sub euvac: DO 51 I=1,37 BROP2P(I) = 0. IF(I.GT.14) BROP2P(I) = 1.-BROP2D(I)-BROP4S(I) SIGOP2P(I)=SIGIO(I)*BROP2P(I) SIGOP2D(I)=SIGIO(I)*BROP2D(I) SIGOP4S(I)=SIGIO(I)*BROP4S(I) 51 CONTINUE ! ! 11/30/98: Added DO 56 as per modsrc.kibo: DO 56 N = 1,37 NN = N+15 SIGEUV(1,NN) = SIGAO2(N) SIGEUV(2,NN) = SIGAO(N) SIGEUV(3,NN) = SIGAN2(N) SIGMAS(1,NN) = SIGIO2(N) SIGMAS(2,NN) = SIGOP4S(N) SIGMAS(3,NN) = SIGIN2(N) SIGMAS(4,NN) = SIGIN(N) SIGMAS(5,NN) = SIGOP2D(N) SIGMAS(6,NN) = SIGOP2P(N) BRN2(NN) = BRN2NP(N) BRO2(NN) = BRO2OP(N) 56 CONTINUE return end !----------------------------------------------------------------------- block data set_qrj_coeff implicit none #include "params.h" integer,parameter :: lmax=59 real :: euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc,sigmas, | quench,sflux,brn2,bro2 common/qrj_coeff/ + EUVEFF(ZKMXP),SIGEUV(8,lmax),FEUV(lmax),RLMEUV(lmax),FSRC(15), + SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4),SFLUX(lmax), + BRN2(lmax),BRO2(lmax) integer :: n C **** C **** TOTAL ABSORPTION COEFFICIENTS C **** C **** SIGEUV(1,N) = SIGA(O2) C **** SIGEUV(2,N) = SIGA(O) C **** SIGEUV(3,N) = SIGA(N2) C **** SIGEUV(4,N) = SIGA(O3) C **** SIGEUV(5,N) = SIGA(CO2) C **** SIGEUV(6,N) = SIGA(H2O) C **** SIGEUV(7,N) = SIGA(NO) C **** SIGEUV(8,N) = SIGA(CH4) C **** C **** TOTAL IONIZATION COEFFICIENTS C **** C **** SIGMAS(1,N) = SIGI(O2) C **** SIGMAS(2,N) = SIGI(O+(4S)) C **** SIGMAS(3,N) = SIGI(N2) C **** SIGMAS(4,N) = SIGI(N) C **** SIGMAS(5,N) = SIGI(O+(2D)) C **** SIGMAS(6,N) = SIGI(O+(2P)) C **** DATA RLMEUV/0.17250E-04, 0.16750E-04, 0.16250E-04, 0.15750E-04, + 0.15250E-04, 0.14750E-04, 0.14250E-04, 0.13750E-04, + 0.13250E-04, 0.12750E-04, 0.12250E-04, 0.12157E-04, + 0.11750E-04, 0.11250E-04, 0.10750E-04, 0.10250E-04, + 0.10319E-04, 0.10257E-04, 0.97500E-05, 0.97702E-05, + 0.92500E-05, 0.87500E-05, 0.82500E-05, 0.77500E-05, + 0.78936E-05, 0.77041E-05, 0.76515E-05, 0.72500E-05, + 0.70331E-05, 0.67500E-05, 0.62500E-05, 0.62973E-05, + 0.60976E-05, 0.57500E-05, 0.58433E-05, 0.55437E-05, + 0.52500E-05, 0.47500E-05, 0.46522E-05, 0.42500E-05, + 0.37500E-05, 0.36807E-05, 0.32500E-05, 0.30378E-05, + 0.30331E-05, 0.27500E-05, 0.28415E-05, 0.25630E-05, + 0.22500E-05, 0.17500E-05, 0.12500E-05, 0.75000E-06, + 0.41000E-06, 0.27500E-06, 0.19500E-06, 0.12000E-06, + 0.60000E-07, 0.30000E-07, 0.15000E-07/ DATA(SIGEUV(1,N),N=1,lmax)/ + 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/ DATA(SIGEUV(2,N),N=1,lmax)/ + 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/ DATA(SIGEUV(3,N),N=1,lmax)/ + 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/ DATA(SIGMAS(1,N),N=1,lmax)/ + 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/ DATA(SIGMAS(2,N),N=1,lmax)/ + 20 * 0.00, 2.12, 4.18, 4.38, 4.23, + 4.28, 4.18, 4.18, 4.20, 4.91, 4.01, + 3.78, 3.79, 3.67, 3.45, 3.53, 3.52, + 3.45, 3.26, 3.15, 3.03, 2.51, 2.59, + 2.25, 1.93, 1.92, 1.65, 1.78, 1.51, + 1.38, 0.78, 0.46, 0.18, 0.05, 0.015, + 0.015, 0.02, 0.004, 0.0006, 0.00006/ DATA(SIGMAS(3,N),N=1,lmax)/ + 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/ DATA(SIGMAS(4,N),N=1,lmax)/ + 22 * 0.00, + 1.00, 1.00, 1.00, 1.00, 1.10, 1.10, + 1.10, 1.20, 1.20, 1.20, 1.20, 1.20, + 1.10, 1.20, 1.15, 1.10, 1.00, 1.00, + 1.00, 0.70, 0.80, 0.65, 0.60, 0.60, + 0.50, 0.50, 0.40, 0.35, 0.25, 0.20, + 0.10, 0.10, 0.10, 0.05, 0.01, + 2*0.0/ DATA(SIGMAS(5,N),N=1,lmax)/ + 27 * 0.00, 3.80, 6.44, 5.52, 5.49, + 5.50, 5.50, 5.36, 5.48, 5.46, 5.36, + 5.24, 5.06, 4.71, 3.86, 3.98, 3.47, + 2.85, 2.84, 2.38, 2.64, 2.12, 1.86, + 0.99, 0.51, 0.19, 0.05, 0.015, 0.015, + 0.02, 0.004, 0.0006, 0.00006/ DATA(SIGMAS(6,N),N=1,lmax)/ + 29 * 0.00, 0.50, 2.93, 2.93, 3.06, + 3.09, 3.16, 3.15, 3.10, 3.14, 3.04, + 3.48, 3.28, 3.38, 2.95, 2.93, 2.92, + 2.58, 2.71, 2.42, 2.07, 1.13, 0.62, + 0.22, 0.06, 0.02, 0.02, 0.03, 0.004, + 0.0007, 0.00007/ DATA(BRN2(N),N=1,lmax)/ + 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(N),N=1,lmax)/ + 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/ DATA(SIGEUV(4,N),N=1,lmax)/ + 13 * 0.00, + 1.25, 0.92, 0.92, 0.92, 0.92, 0.80, + 0.95, 0.95, 1.30, 1.86, 2.96, 2.96, + 3.48, 3.48, 3.64, 0.44, 0.41, 3.62, + 3.46, 3.51, 3.51, 3.20, 3.06, 3.06, + 3.20, 21*0./ C DATA(SIGEUV(5,N),N=1,lmax)/ + 0.05, 0.10, 0.15, 0.30, 0.40, 0.55, + 0.50, 0.50, 0.80, 0.50, 0.20, 0.00, + 0.00,18.52,14.80,18.50,14.20,15.10, + 29.60,42.90,74.10,18.50,14.80,22.20, + 31.90,37.00,93.90,22.20,35.20,18.50, + 29.60,34.30,35.30,31.50,34.20,30.40, + 33.30,25.20,27.60,20.40,27.80,27.80, + 18.50,23.40,23.40,22.90,25.90,28.20, + 22.20,11.10,9*0./ C DATA(SIGEUV(6,N),N=1,lmax)/ + 5.00, 5.00, 5.00, 3.00, 1.50, 0.80, + 0.80, 1.10, 5.00, 8.00, 8.00, 0.00, + 4.44, 4.44, 4.44,18.52,14.10,29.60, + 15.56, 9.63,18.52,18.52,35.19,37.04, + 48.90,35.19,33.33,25.93,14.81,25.93, + 24.07,24.44,31.10,22.20,17.04,26.67, + 24.07,29.60,26.67,26.67,24.07,23.70, + 22.20,22.20,22.20,22.20,32.60,18.52, + 14.81,11.11,9*0./ C DATA(SIGEUV(7,N),N=1,lmax)/ + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 1.85, 2.04, 2.04, 0.00, + 2.41, 3.70, 6.48, 7.41, 3.70, 8.15, + 16.67,20.74,24.07,16.67,12.96,12.96, + 14.44,12.96, 7.41,14.44,14.44,18.52, + 20.00,20.00,20.00,20.00,20.00,20.00, + 18.52,16.67,24.81,22.22,22.22,21.85, + 18.52,22.96,22.96,25.93,19.26,25.93, + 22.22,22.22,9*0./ DATA (SIGEUV(8,N),N=1,lmax)/ + 16*0., 2.97, 3.07, 3.46, 3.82, 4.23, 5.00, 4.67, + 4.33, 4.26, 4.14, 4.10, 4.00, 3.69, 3.67, 3.33, + 3.20, 3.07, 3.00, 2.90, 2.70, 2.67, 2.33, 2.10, + 2.00, 1.67, 1.45, 1.33, 1.03, 1.02, 14*1.00/ C C DATA EUVEFF/ZKMXP*0.10/ DATA EUVEFF/ZKMXP*0.05/ DATA QUENCH/7.E-11,5.E-11,3.1401E-12,9.1E-3/ end ! block data set_qrj_coeff