#include "dims.h" SUBROUTINE QINITE use cons_module,only: len1,len2,len3,kmax,kmaxp1,kmaxm1,expz, | expzmid,expzmid_inv,p0,boltz,rmassinv_o2,rmassinv_o, | rmassinv_n2 use input_module,only: f107 use init_module,only: sfeps implicit none C **** C **** CALCULATE BACKGROUND IONIZATION RATES C **** #include "params.h" #include "fcom.h" #include "vscr.h" #include "index.h" #include "buff.h" #include "crates_tdep.h" #include "phys.h" #include "cmpbnd.h" #include "mwt.h" real :: rlatm,rlonm,dipmag,decmag,sndec,csdec,sn2dec,sncsdc, | rlatmp,rlonmp,dlons COMMON/TRGM/RLATM(ZIMXP,ZJMX),RLONM(ZIMXP,ZJMX), 1DIPMAG(ZIMXP,ZJMX),DECMAG(ZIMXP,ZJMX),SNDEC(ZIMXP,ZJMX), 2CSDEC(ZIMXP,ZJMX),SN2DEC(ZIMXP,ZJMX),SNCSDC(ZIMXP,ZJMX), 3RLATMP(ZJMX),RLONMP(ZJMX),DLONS(ZJMX) 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 :: sjnmlya(zimxp,zkmxp) real :: SA(3,3),SI(3,3),AL(3) integer :: i,n,k,m,npsk,nps1k,nps2k,ntk,nmsk,nnvk,nqo2pk,nqopk, | nqn2pk,nqnpk,nqnopk,nnvo2k,npnok ! SA(:,1)=(/1.6E-18,0.,0./) SA(:,2)=(/22.E-18,10.24E-18,23.11E-18/) SA(:,3)=(/16.E-18,8.4E-18,11.61E-18/) SI(:,1)=(/1.0E-18,0.,0./) SI(:,2)=(/22.E-18,10.24E-18,23.11E-18/) SI(:,3)=(/16.E-18,8.4E-18,11.61E-18/) C **** C **** MOD FOR QINITE (COMPUTES BACKGROUND IONIZATION RATES) C **** ! 11/30/98: AL changed as per modsrc.kibo: ! AL=(/5.E4,5.E3,5.E3/) AL=(/1.5E7,1.5E6,1.5E6/) C **** C **** S1 = PSI1, S2 = PSI2, S3 = PSI3 (K) C **** DO 1 N=1,2 NPSK= NJ+NPS+(N-1)*KMAXP1 C **** LEVELS 2 THRU KMAXP1 K=(2-N)*KMAXP1+2 DO 1 I=1,LEN2 S2(I,K)=.5*(F(I,NPSK)+F(I,NPSK+1)) 1 CONTINUE C **** LEVEL 1 NPS1K=NJ+NPS NPS2K=NPS1K+KMAXP1 DO 2 I=1,LEN1 S1(I,1)=.5*((B(I,1,1)+1.)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+FB(I,1)) S2(I,1)=.5*(B(I,2,1)*F(I,NPS1K)+(B(I,2,2)+1.)*F(I,NPS2K)+FB(I,2)) 2 CONTINUE C **** S3 = PSI3 (K) DO 3 I=1,LEN3 S3(I,1)=1.-S1(I,1)-S2(I,1) 3 CONTINUE C **** C **** S4 =T (K) C **** NTK=NJ+NT C **** LEVELS 2 THRU KMAX DO 4 I=LEN1+1,LEN2 S4(I,1)=.5*(F(I,NTK)+F(I,NTK-1)) 4 CONTINUE C **** LEVELS 1 AND KMAXP1 DO 5 I=1,LEN1 S4(I,1)=F(I,NTK+KMAX) S4(I,KMAXP1)=F(I,NTK+KMAXM1) 5 CONTINUE C **** C **** S5 =N*MBAR (K) C **** C **** S5 = EXPS (K) DO 6 K=1,KMAX DO 6 I=1,LEN1 S5(I,K)=expzmid_inv*expz(K) 6 CONTINUE DO 7 I=1,LEN1 S5(I,KMAXP1)=expzmid*expz(KMAX) 7 CONTINUE C **** S3 = N*MBAR NMSK=NJ+NMS DO 8 I=1,LEN3 S5(I,1)=p0*S5(I,1)*F(I,NMSK)/(boltz*S4(I,1)) 8 CONTINUE C **** C **** CALCULATE IONIZATION OF O2, O, N2 IN S6, S7, S8 C **** C **** INITIALIZATION S6 = S7 = S8 = 0. DO 9 I=1,3*LEN3 S8(I,1)=0. 9 CONTINUE C **** SUMMATION OVER WAVE LENGTH DO 10 N=1,3 C **** S9 = TAU DO 11 I=1,LEN3 S9(I,1)=0. 11 CONTINUE C **** SUMMATION OVER SPECIES DO 12 M=1,3 NNVK=NNVO2+(M-1)*KMAXP1 DO 12 I=1,LEN3 S9(I,1)=S9(I,1)+SA(M,N)*F(I,NNVK) 12 CONTINUE C **** S9 = EXP(-TAU) = EXP(-S9) DO 13 I=1,LEN3 S9(I,1)=EXP(-S9(I,1)) 13 CONTINUE C **** ADD O2, O, N2 IONIZATION TO S6, S7, S8 ! DO 14 M=1,3 ! K=(3-M)*KMAXP1+1 ! DO 14 I=1,LEN3 ! S8(I,K)=S8(I,K)+AL(N)*SI(M,N)*S3(I,K)*S9(I,1)/RMASS(M) ! 14 CONTINUE k = 2*kmaxp1+1 do i=1,len3 S8(I,K)=S8(I,K)+AL(N)*SI(1,N)*S3(I,K)*S9(I,1)*rmassinv_o2 enddo k = kmaxp1+1 do i=1,len3 S8(I,K)=S8(I,K)+AL(N)*SI(2,N)*S3(I,K)*S9(I,1)*rmassinv_o enddo k = 1 do i=1,len3 S8(I,K)=S8(I,K)+AL(N)*SI(3,N)*S3(I,K)*S9(I,1)*rmassinv_n2 enddo 10 CONTINUE C **** C **** CALCULATE CONTRIBUTIONS TO NQO2P, NQOP, NQN2P, NQNP C **** NQO2PK=NQO2P NQOPK=NQOP NQN2PK=NQN2P NQNPK=NQNP DO 15 I=1,LEN3 F(I,NQO2PK)=F(I,NQO2PK)+0.67*S6(I,1)*S5(I,1) F(I,NQOPK)=F(I,NQOPK)+(0.33*S6(I,1)+S7(I,1))*S5(I,1) F(I,NQN2PK)=F(I,NQN2PK)+0.86*S8(I,1)*S5(I,1) F(I,NQNPK)=F(I,NQNPK)+0.14*S8(I,1)*S5(I,1) 15 CONTINUE ! ! 2/23/01: XJNOPN (crates_tdep.h) nighttime production moved here ! from qrj (sjnmlya is local). f(i,nnvo2) from chapmn.f, ! sfeps from init_mod.f, and sflux from /qrj_coeff/. ! nnvo2k=nnvo2 do i=1,len3 sjnmlya(i,1) = | (0.68431 *exp(-8.22114E-21*f(i,nnvo2k))+ | 0.229841 *exp(-1.77556E-20*f(i,nnvo2k))+ | 0.0865412*exp(-8.22112E-21*f(i,nnvo2k)))*sfeps xjnopn(i,1) = 2.02E-18*sflux(12)/100.*sjnmlya(i,1) enddo C **** C **** CALCULATE NO IONIZATION AND ADD TO NQNOP C **** NQNOPK=NQNOP NNVO2K=NNVO2 NPNOK=NJ+NPNO C **** LEVEL 1 DO 16 I=1,LEN1 F(I,NQNOPK)=F(I,NQNOPK)+XJNOPN(I,1)*F(I,NPNOK) 1*S5(I,1)/RMNO 16 CONTINUE C **** LEVELS 2 THRU KMAXP1 DO 17 I=LEN1+1,LEN3 F(I,NQNOPK)=F(I,NQNOPK)+XJNOPN(I,1)*.5*(F(I,NPNOK)+ 1F(I,NPNOK-1))*S5(I,1)/RMNO 17 CONTINUE C **** C **** CALCULATE IONIZATION RAY FROM GALACTIC COSMIC RAYS C **** AND ADD TO TOTAL IONIZATION RATE ! time-gcm only (not in tiegcm): NQO2PK=NQO2P-1 NQOPK=NQOP-1 NQN2PK=NQN2P-1 NQNPK=NQNP-1 DO 18 K=1,KMAXP1 NQO2PK=NQO2PK+1 NQOPK=NQOPK+1 NQN2PK=NQN2PK+1 NQNPK=NQNPK+1 DO 18 I=1,LEN1 S15(I,K) = (S1(I,K)*rmassinv_o2+S2(I,K)*rmassinv_o+ + S3(I,K)*rmassinv_n2)*S5(I,K) S14(I,K) = 1.44E-17*S15(I,K) S13(I,K) = 1.932E-17*S15(I,K) S12(I,K) = S13(I,K)+(S14(I,K)-S13(I,K))/135.*(f107-65.) S14(I,K) = 2.84E-17-6.7407E-20*(f107-65.) S13(I,K) = 0.6+0.8*ABS(COS(RLATM(I,J))) S11(I,K) = (1.74E-18+S14(I,K)*(ABS(SIN(RLATM(I,J))))**4)* + (3.E+17)**(1.-S13(I,K))*S15(I,K)**S13(I,K) S10(I,K) = (1.74E-18+S14(I,K)*(ABS(SIN(RLATM(I,J))))**4)* + S15(I,K) s9(i,k) = s11(i,k) if (s15(i,k) < 3.e+17) s9(i,k) = s10(i,k) if (abs(rlatm(i,j)) >= 0.925) s9(i,k) = s12(i,k) F(I,NQO2PK) = F(I,NQO2PK)+0.154*S9(I,K) F(I,NQOPK) = F(I,NQOPK)+0.076*S9(I,K) F(I,NQN2PK) = F(I,NQN2PK)+0.585*S9(I,K) ! ! 11/30/98: added DISN2P as per modsrc.kibo: ! DISN2P(I,K) = DISN2P(I,1)+0.585*S9(I,K) ! 12/20/00: fixed 2nd dimension of disn2p on rhs: DISN2P(I,K) = DISN2P(I,K)+0.585*S9(I,K) F(I,NQNPK) = F(I,NQNPK)+0.185*S9(I,K) 18 CONTINUE RETURN END C