! SUBROUTINE QRJ ! use input_module,only: f107 use init_module,only: sfeps ! CDIR$ VFUNCTION EXPHF 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 "cons.h" include "index.h" include "buff.h" include "phys.h" include "crates.h" include "cmpbnd.h" include "mwt.h" integer,parameter :: lmax=59 real :: EUVEFF(ZKMXP),SIGEUV(3,lmax),FEUV(lmax),RLMEUV(lmax), | FSRC(15),SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4), | SFLUX(lmax),BRN2(lmax),BRO2(lmax) common/qrj_coeff/ euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc, | sigmas,quench,sflux,brn2,bro2 ! ! Local: integer :: n,m,nno2k,nnok,nnn2k,i,nps1k,nps2k, | npn4sk,nqk,nrjk,nqtefk,nqop2pk,nqop2dk,k,nnk,ntk,nmsk,nqo2pk, | nqopk,nqn2pk,nqnpk,nqnopk,npnok,kk real :: do2,ad,bd,aband,do22,e3,factor,bband,cband, | rlmeuvinv(lmax),rlmsrcinv(15),rmn4sinv real :: | s1k(zkmxp,zimxp), s2k(zkmxp,zimxp), s3k(zkmxp,zimxp), | s4k(zkmxp,zimxp), s5k(zkmxp,zimxp), s6k(zkmxp,zimxp), | s7k(zkmxp,zimxp), s8k(zkmxp,zimxp), s9k(zkmxp,zimxp), | s10k(zkmxp,zimxp), s11k(zkmxp,zimxp), s12k(zkmxp,zimxp), | s13k(zkmxp,zimxp), s14k(zkmxp,zimxp), s15k(zkmxp,zimxp) integer,parameter :: l1=16, nlam=lmax-l1+1 real :: s5lk(nlam,zkmxp,zimxp),s6lk(nlam,zkmxp,zimxp), | s7lk(nlam,zkmxp,zimxp) ! DO2=8.203E-12 AD=5.435E-9 BD=1.232E-6 ABAND=0.143 BBAND=9.64E8 CBAND=9.03E-19 DO22=1.1407E-11 E3=0.33 ! ! More efficient to multiply by inverse than to divide: ! (see also rmassinv) do i=1,lmax rlmeuvinv(i) = 1./rlmeuv(i) enddo do i=1,15 rlmsrcinv(i) = 1./rlmsrc(i) enddo rmn4sinv = 1./rmn4s C **** C **** C **** COMPUTE S14 = RSQ, S15 = RSP C **** C **** C **** S1 = TAU(R), S2 = TAU(Q) C **** do i=1,len1 NNO2K = NNO2 NNOK = NNO NNN2K = NNN2 if (idn(i)==1) then do k=1,kmaxp1 S1k(k,i) = SIGEUV(1,49)*F(I,NNO2K)+SIGEUV(2,49)*F(I,NNOK)+ | SIGEUV(3,49)*F(I,NNN2K) S2k(k,i) = SIGEUV(1,20)*F(I,NNO2K)+SIGEUV(2,20)*F(I,NNOK)+ | SIGEUV(3,20)*F(I,NNN2K) C **** C **** S3 = TAU(1), S4 = TAU(2), S5 = TAU(3) C **** S3k(k,i) = 1.3*S1k(k,i) S4k(k,i) = 2.0*S1k(k,i) S5k(k,i) = 2.5*S1k(k,i) C **** C **** IF(TAU.GT.9.0) TAU = 9.0 C **** if (s1k(k,i) > 9.) s1k(k,i) = 9. if (s2k(k,i) > 9.) s2k(k,i) = 9. if (s3k(k,i) > 9.) s3k(k,i) = 9. if (s4k(k,i) > 9.) s4k(k,i) = 9. if (s5k(k,i) > 9.) s5k(k,i) = 9. C **** C **** TAU(N) = EXP(-TAU(N)) FOR N = 1,3,1 C **** S3k(k,i) = exp(-S3k(k,i)) S4k(k,i) = exp(-S4k(k,i)) S5k(k,i) = exp(-S5k(k,i)) C **** C **** S6 = EXP(-TAU(R)), S7 = EXP(-TAU(Q)) C **** S6k(k,i) = exp(-S1k(k,i)) S7k(k,i) = exp(-S2k(k,i)) C **** C **** S14 = RSP, S15 = RSQ C **** S14k(k,i) = S6k(k,i)+2.*(S3k(k,i)+S4k(k,i)+S5k(k,i)) S15k(k,i) = 1.5*S6k(k,i)/(S14k(k,i)+S2k(k,i)/S1k(k,i)* | S7k(k,i)) S14k(k,i) = 2.4*S6k(k,i)/S14k(k,i) nno2k = nno2k+1 nnok = nnok+1 nnn2k = nnn2k+1 enddo ! k=1,kmaxp1 endif ! idn==1 enddo ! i=1,len1 C **** C **** S1 = PSI(O2), S2 = PSI(O), S3 = PSI(N2), S4 = PSI(N4S) C **** LEVELS 2 THRU KMAXP1 C **** do i=1,len1 if (idn(i)==1) then NPS1K=NJ+NPS NPS2K=NJ+NPS2 NPN4SK=NJ+NPN4S do k=1,kmax S1k(k+1,i)=.5*(F(I,NPS1K)+F(I,NPS1K+1)) S2k(k+1,i)=.5*(F(I,NPS2K)+F(I,NPS2K+1)) S4k(k+1,i)=0. nps1k = nps1k+1 nps2k = nps2k+1 npn4sk = npn4sk+1 enddo endif enddo C **** C **** LEVEL 1 C **** NPS1K=NJ+NPS NPS2K=NJ+NPS2 NPN4SK=NJ+NPN4S DO 8 I=1,LEN1 S1k(1,i) = .5*((B(I,1,1)+1.)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+ 1 FB(I,1)) S2k(1,i) = .5*(B(I,2,1)*F(I,NPS1K)+(B(I,2,2)+1.)*F(I,NPS2K)+ 1 FB(I,2)) S4k(1,i) = 0. 8 CONTINUE C **** C **** NOW CALCULATE S3 = PSI(N2) C **** do i=1,len1 if (idn(i)==1) then do k=1,kmaxp1 S3k(k,i)=1.-S1k(k,i)-S2k(k,i) enddo endif enddo 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 NQOP2PK = NQOP2P NQOP2DK = NQOP2D DO 10 I = 1,LEN3 F(I,NQK) = 0. F(I,NRJK) = 0. F(I,NQTEFK) = 0. F(I,NQOP2PK) = 0. F(I,NQOP2DK) = 0. 10 CONTINUE C **** C **** INITIALIZE S8 - S13 C **** do i=1,len1 do k=1,kmaxp1 s8k(k,i) = 0. s9k(k,i) = 0. s10k(k,i) = 0. s11k(k,i) = 0. s12k(k,i) = 0. s13k(k,i) = 0. enddo enddo C **** C **** SUMMATION OVER WAVE LENGTH C **** 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 i=1,len1 do k=1,kmaxp1 do n=l1,lmax s5lk(n,k,i) = 0. s6lk(n,k,i) = 0. s7lk(n,k,i) = 0. enddo enddo enddo C **** C **** SUMMATION OVER O2, O, N2 C **** do i=1,len1 if (idn(i) == 1) then ! daytime nno2k = nno2 nnok = nno nnn2k = nnn2 nqk = nq nrjk = nrj nqop2pk = nqop2p nqop2dk = nqop2d nqtefk = nqtef do k=1,kmaxp1 do n=l1,lmax s5lk(n,k,i)=s5lk(n,k,i)+SIGEUV(1,N)*F(I,nno2k)+ | SIGEUV(2,N)*F(I,nnok) + | SIGEUV(3,N)*F(I,nnn2k) s6lk(n,k,i)=s6lk(n,k,i)+SIGEUV(1,N)*S1k(k,i)*rmassinv(1)+ | SIGEUV(2,N)*S2k(k,i)*rmassinv(2)+ | SIGEUV(3,N)*S3k(k,i)*rmassinv(3) s7lk(n,k,i)=s7lk(n,k,i)+SIGMAS(1,N)+SIGMAS(2,N)+ | SIGMAS(3,N) ! s5lk(n,k,i) = FEUV(N)*exp(-s5lk(n,k,i)) s7lk(n,k,i) = s7lk(n,k,i)+SIGMAS(4,N) F(I,NQK) = F(I,NQK)+C(60)*rlmeuvinv(N)*s5lk(n,k,i)* | s6lk(n,k,i) F(I,NRJK) = F(I,NRJK)+s5lk(n,k,i)*s7lk(n,k,i) F(I,NQOP2PK) = F(I,NQOP2PK)+s5lk(n,k,i)*SIGMAS(6,N)* 1 S2k(k,i)*rmassinv(2) F(I,NQOP2DK) = F(I,NQOP2DK)+s5lk(n,k,i)*SIGMAS(5,N)* 1 S2k(k,i)*rmassinv(2) C **** C **** ADD IONIZATION FOR O2, O, N2 TO S8, S9, S10 C **** s8k(k,i) = s8k(k,i)+sigmas(1,n)*s5lk(n,k,i)*s1k(k,i)* | rmassinv(1) s9k(k,i) = s9k(k,i)+sigmas(2,n)*s5lk(n,k,i)*s2k(k,i)* | rmassinv(2) s10k(k,i)=s10k(k,i)+sigmas(3,n)*s5lk(n,k,i)*s3k(k,i)* | rmassinv(3) ! F(I,NQTEFK) = F(I,NQTEFK)+(SIGEUV(3,N)-SIGMAS(3,N))* | s5lk(n,k,i)*S3k(k,i)*rmassinv(3)*2. ! *2. is a snoe mod S11k(k,i) = S11k(k,i)+SIGMAS(4,N)*s5lk(n,k,i)*S4k(k,i)* | rmn4sinv S12k(k,i) = S12k(k,i)+SIGMAS(1,N)*s5lk(n,k,i)*S1k(k,i)* | rmassinv(1)*BRO2(N) S13k(k,i) = S13k(k,i)+SIGMAS(3,N)*s5lk(n,k,i)*S3k(k,i)* | rmassinv(3)*BRN2(N) enddo ! n=l1,lmax nno2k = nno2k+1 nnok = nnok+1 nnn2k = nnn2k+1 nqk = nqk+1 nrjk = nrjk+1 nqop2pk = nqop2pk+1 nqop2dk = nqop2dk+1 nqtefk = nqtefk+1 enddo ! k=1,kmaxp1 endif ! idn(i)==1 enddo ! i=1,len1 C **** C **** MULTIPLY Q BY EFICIENCY FACTOR C **** C **** NQK=NQ-1 DO 18 K=1,KMAXP1 NQK=NQK+1 DO 18 I=1,LEN1 if (idn(i)==1) F(I,NQK)=F(I,NQK)*EUVEFF(K)*C(85) 18 CONTINUE C **** C **** C **** CALCULATE N*MBAR IN S5 C **** S6 = T(TOTAL,K) NTK=NJ+NT+KMAX do i=1,len1 if (idn(i)==1) then S6k(1,i)=F(I,NTK)+T0(1) NTK=NJ+NT-1 do k=2,kmax NTK=NTK+1 S6k(k,i)=.5*(F(I,NTK)+F(I,NTK+1))+T0(K) enddo NTK=NJ+NT+KMAX-1 S6k(kmaxp1,i)=F(I,NTK)+T0(KMAXP1) endif enddo C **** C **** S7 = EXPS (K) C **** do i=1,len1 do k=1,kmax S7k(k,i)=C(87)*EXPS(K) enddo enddo do i=1,len1 S7k(kmaxp1,i)=C(86)*EXPS(KMAX) enddo C **** C **** C **** CALCULATE CONTRIBUTIONS TO NQO2P, NQOP, NQN2P, NQNP C **** AND NQTEF C **** C **** disn2p = 0. ! whole array init do i=1,len1 if (idn(i) == 1) then ! daytime NQO2PK = NQO2P NQOPK = NQOP NQN2PK = NQN2P NQNPK = NQNP NQTEFK = NQTEF NQOP2PK = NQOP2P NQOP2DK = NQOP2D NMSK=NJ+NMS do k=1,kmaxp1 S5k(k,i)=C(81)*S7k(k,i)*F(I,NMSK)/(C(84)*S6k(k,i)) ! N*MBAR DISN2P(I,k) = S10k(k,i)*S14k(k,i)*S5k(k,i) F(I,NQO2PK) = F(I,NQO2PK)+(S8k(k,i)* | (1.+S15k(k,i))-S12k(k,i))*S5k(k,i) F(I,NQN2PK) = F(I,NQN2PK)+(S10k(k,i)* | (1.+S14k(k,i))-S13k(k,i))*S5k(k,i) F(I,NQNPK) = F(I,NQNPK)+(S11k(k,i)+S13k(k,i))*S5k(k,i) F(I,NQTEFK) = F(I,NQTEFK)*S5k(k,i) S4k(k,i) = F(I,NQOP2PK)+F(I,NQOP2DK)+S9k(k,i)+S12k(k,i) F(I,NQOP2PK) = (F(I,NQOP2PK)+S4k(k,i)*S14k(k,i)*0.22)* | S5k(k,i) F(I,NQOP2DK) = (F(I,NQOP2DK)+S4k(k,i)*S14k(k,i)*0.24)* | S5k(k,i) F(I,NQOPK) = F(I,NQOPK)+(S9k(k,i)+S12k(k,i)+S4k(k,i)* | S14k(k,i)*0.56)*S5k(k,i) NQO2PK = NQO2PK+1 NQOPK = NQOPK+1 NQN2PK = NQN2PK+1 NQNPK = NQNPK+1 NQTEFK = NQTEFK+1 NQOP2PK = NQOP2PK+1 NQOP2DK = NQOP2DK+1 NMSK = NMSK+1 enddo ! k=1,kmaxp1 endif enddo ! i=1,len1 C **** C **** CALCULATE NO IONIZATION AND ADD TO NQNOP C **** do i=1,len1 if (idn(i)==1) then nqnopk = nqnop npnok = nj+npno F(I,NQNOPK)=F(I,NQNOPK)+BETA9(I,1)*F(I,NPNOK)*S5k(1,i)/RMNO ! nqnopk = nqnop+1 npnok = nj+npno+1 do k=2,kmaxp1 F(I,NQNOPK)=F(I,NQNOPK)+BETA9(I,k)*.5*(F(I,NPNOK)+ | F(I,NPNOK-1))*S5k(k,i)/RMNO nqnopk = nqnopk+1 npnok = npnok+1 enddo ! do k=1,kmaxp1 FACTOR=C(85)*C(81)/C(57)*EXPS(1)*C(86)**(2*K-3) S8k(k,i)=FACTOR/((S1k(k,i)*rmassinv(1)+S2k(k,i)*rmassinv(2)+ | S3k(k,i)*rmassinv(3))*S6k(k,i)) S8k(k,i)=S8k(k,i)*(QUENCH(1)*S3k(k,i)*rmassinv(3)+ | QUENCH(2)*S1k(k,i)*rmassinv(1)) S8k(k,i)=QUENCH(3)*S8k(k,i)/(QUENCH(4)+S8k(k,i)) enddo endif enddo C **** C **** S7=SUM OVER WAVE LENGTH(SIGMA*F*EXP(-SIGMA*CHAPMAN)* C **** (HC/LAMDA-DO2)) C **** INITIALIZE S7 C **** do i=1,len1 do k=1,kmaxp1 s7k(k,i) = 0. enddo enddo C **** C **** SUMMATION OVER WAVE LENGTH C **** do i=1,len1 if (idn(i) == 1) then NNO2K=NNO2 NRJK = NRJ do k=1,kmaxp1 do n=1,l1-1 S9k(k,i)=SIGSRC(N)*FSRC(N)*exp(-SIGSRC(N)*F(I,NNO2K)) S7k(k,i)=S7k(k,i)+S9k(k,i)* | (C(60)*rlmsrcinv(N)-DO22+S8k(k,i)) F(I,NRJK)=F(I,NRJK)+S9k(k,i) enddo nno2k = nno2k+1 nrjk = nrjk+1 enddo endif enddo nno2k = nno2 nrjk = nrj C **** C **** UPDATE Q C **** CONTRIBUTIONS FROM SCHUMANN RUNGE BANDS C **** S7=P3*F C **** do i=1,len1 if (idn(i)==1) then nno2k = nno2 nqk = nq nrjk = nrj do k=1,kmaxp1 F(I,NQK)=F(I,NQK)+S7k(k,i)*C(85)*S1k(k,i)*rmassinv(1) S8k(k,i)=SQRT(F(I,NNO2K)) if (F(I,NNO2K) >= 1.e18) then s7k(k,i) = (1./(ABAND*F(I,NNO2K)+BBAND*S8k(k,i)))* | (1.+0.11*(f107-65.)/165.)*sfeps else s7k(k,i) = cband*(1.+0.11*(f107-65.)/165.)*sfeps endif F(I,NQK)=F(I,NQK)+S7k(k,i)*C(85)*S1k(k,i)*rmassinv(1)*E3 F(I,NRJK)=F(I,NRJK)+S7k(k,i)/DO2 nno2k = nno2k+1 nqk = nqk+1 nrjk = nrjk+1 enddo endif enddo RETURN end subroutine qrj !--------------------------------------------------------------- subroutine init_sflux use input_module,only: f107,f107a use init_module,only: sfeps ! ! Flux initialization once per time step, called from advnce. ! (this call moved from qrj in multi-task version) ! include "params.h" include "cons.h" integer,parameter :: lmax=59 real :: EUVEFF(ZKMXP),SIGEUV(3,lmax),FEUV(lmax),RLMEUV(lmax), | FSRC(15),SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4), | SFLUX(lmax),BRN2(lmax),BRO2(lmax) common/qrj_coeff/ euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc, | sigmas,quench,sflux,brn2,bro2 real :: EUVFLX(37),wave1(lmax),wave2(lmax) ! output from euvac real :: flya,hlybr,fexvir,hlya,heiew,xuvfac integer :: iscale,n,nn ! ! 2/00: ! Use f107,f107a from input_mod (these are either provided by ! the user, or obtained from GPI database, see input_mod.f and ! gpi_mod.f). ! F107 = C(61) ! F107A = C(62) ! HLYBR = 0. FEXVIR = 0. HLYA = 3.E+11+0.4E+10*(C(61)-70.) HEIEW = 0. C XUVFAC =0. C XUVFAC = 2.0 - (C(61)-68.0) / (243.0-68.0) XUVFAC = 4.0 - (C(61)-68.0) / (243.0-68.0) IF (XUVFAC .LT. 1.0) XUVFAC = 1.0 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 CALL SSFLUX(ISCALE,F107,F107A,HLYBR,FEXVIR,HLYA, | HEIEW, XUVFAC, WAVE1, WAVE2, SFLUX) CALL EUVAC(F107,F107A,EUVFLX) C **** C **** TRANSFER VALUES OF SFLUX TO APPROPRIATE SLOTS C **** 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 !--------------------------------------------------------------- block data set_qrj_coeff include "params.h" integer,parameter :: lmax=59 real :: EUVEFF(ZKMXP),SIGEUV(3,lmax),FEUV(lmax),RLMEUV(lmax), | FSRC(15),SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4), | SFLUX(lmax),BRN2(lmax),BRO2(lmax) common/qrj_coeff/ euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc, | sigmas,quench,sflux,brn2,bro2 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 **** 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 **** C **** 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 EUVEFF/29*0.05/ C DATA EUVEFF/29*0.10/ DATA QUENCH/7.E-11,5.E-11,3.1401E-12,9.1E-3/ end ! block data set_qrj_coeff !--------------------------------------------------------------- subroutine init_sigmas 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" parameter (lmax=59) real :: EUVEFF(ZKMXP),SIGEUV(3,lmax),FEUV(lmax),RLMEUV(lmax), | FSRC(15),SIGSRC(15),RLMSRC(15),SIGMAS(6,lmax),QUENCH(4), | SFLUX(lmax),BRN2(lmax),BRO2(lmax) common/qrj_coeff/ euveff,sigeuv,feuv,rlmeuv,fsrc,sigsrc,rlmsrc, | sigmas,quench,sflux,brn2,bro2 real :: wleuv1,wleuv2,sigao,sigao2,sigan2,sigio,sigio2, | sigin2,brop4s,brop2d,brop2p,sigop2p,sigop2d,sigop4s, | sigin,brn2np,bro2op 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), 3 SIGOP2P(37),SIGOP2D(37),SIGOP4S(37), 4 SIGIN(37),BRN2NP(37),BRO2OP(37) ! 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 1 CONTINUE DO 2 N = 1,lmax SIGMAS(4,N) = SIGMAS(4,N)*1.E-17 SIGMAS(5,N) = SIGMAS(5,N)*1.E-18 SIGMAS(6,N) = SIGMAS(6,N)*1.E-18 2 CONTINUE DO 3 N = 1,15 RLMSRC(N) = RLMEUV(N) SIGSRC(N) = SIGEUV(1,N) 3 CONTINUE ! ! DO 51 loop moved here from original euvac. DO 51 N=1,37 BROP2P(N) = 0. IF(N.GT.14) BROP2P(N) = 1.-BROP2D(N)-BROP4S(N) SIGOP2P(N)=SIGIO(N)*BROP2P(N) SIGOP2D(N)=SIGIO(N)*BROP2D(N) SIGOP4S(N)=SIGIO(N)*BROP4S(N) 51 CONTINUE DO 56 N = 1,37 NN = N+15 ! 16:52 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