c c Blank common: c COMMON ZP(KMX),ZPHT(KMX),TNMS(KMX),XOM(KMX),XN2M(KMX),XO2M(KMX), 1ZPMHT(KMX),SHTMS(KMX),AMASS(KMX),RHOMS(KMX),TE(KMX),TI(KMX), 2TN(KMX),XNE(KMX),XNO(KMX),XNO2(KMX),XNN2(KMX),XN4S(KMX),XNNO(KMX), 3XN2D(KMX),RHO(KMX),SHT(KMX),XIN2P(KMX),XIOP(KMX),XINOP(KMX), 4XINP(KMX),AMAS(KMX),XCHUE(KMX),XIO2P(KMX),XCO2(KMX),SHCO2(KMX), 5XNH2O(KMX),XNHOX(KMX),XNHO2(KMX),XNOH(KMX),XNHM(KMX),XNO1D(KMX), 6XNO3(KMX),XNH2(KMX),XIHP(KMX),XIOHP(KMX),XIH2OP(KMX),XNNO2(KMX), 7XNCH4(KMX),XNH2O2(KMX),XNHTOT(KMX),XNCO2(KMX),XNCO(KMX),XNH(KMX), 8O1DEX(KMX),XNHE(KMX),XNHEM(KMX),XNARG(KMX),XNARGM(KMX),XN4SM(KMX), 9ZPMS(KMX),GZ(KMX),QHOXI(KMX),ZQHT(KMX),F107,F107A,CO2MIX,DAY, 1GLAT,GLONG,STL,ZI,SCHAP(KMX),RE,BOLTZ COMMON/SODIUM/PNAM(KMX),PNAS(KMX),XLNAS(KMX),XNAS(KMX), 1XLBNAS,XNAPCO2(KMX),XNAPH2O(KMX),XNAOP(KMX),XNAO(KMX) 2,PNASP(KMX),XLNASP(KMX),XNASP(KMX),XNAPN2(KMX),XNAOH(KMX), 3XNAO2(KMX),PNAOH(KMX),XLNAOH(KMX),PNAO2(KMX),XLNAO2(KMX), 4PNAO(KMX),XLNAO(KMX),XNAX(KMX) COMMON/SOLARS/QOP(KMX),QO2P(KMX),QN2P(KMX),QINP(KMX),QTIN(KMX), 1QSR(KMX),QSRB(KMX),QHERZ(KMX),QHAR(KMX),QHUG(KMX),QCHAP(KMX), 2DSO2(KMX),DSO2SR(KMX),DSO2SRB(KMX),DSO2EUV(KMX),DO3HAR(KMX), 3DO3HUG(KMX),DO3CHAP(KMX),DH2OEUV(KMX),DH2OLYA(KMX),DH2OSRC(KMX), 4DH2OSRB(KMX),DCO2EUV(KMX),DCO2LYA(KMX),DCO2SRC(KMX),DCO2SRB(KMX), 5DCOEUV(KMX),DCH4EUV(KMX),DCH4LYA(KMX),XJNO(KMX),SR63(KMX), 6QNSP(KMX),QIAN(KMX),QIAUR(KMX),QPRO(KMX),QAURH(KMX),QPROH(KMX), 7QIXRAY(KMX),QNSPE(KMX),XJNO2(KMX),QNOP(KMX),QNIGHT(KMX),QN(KMX), 8RJH2O2(KMX),CGM(KMX),TXNO(KMX),TXNO2(KMX),TXNN2(KMX),TXNO3(KMX), 9RB9(KMX),QNLYA(KMX),RJCO2(KMX),DH2OT(KMX),XNO2S(KMX),XO21DL(KMX), 1QO2S(KMX),QIA(5,KMX),QTI(KMX),DO3LYA(KMX),DSO2LYA(KMX), 2DNOSRB(KMX),QNO3(KMX) */ */ */ *CDK ASAS COMMON/ASAS/ F(1,KMXP55) *CDK ASASF COMMON/ASAS/ F(1,KMXP55) *CDK ASAS2 COMMON/ASAS2/ F(IMXP,KMXP55) *CDK ASAS2F COMMON/ASAS2/ FF(IMXP,KMXP55) */ */ */ *CDK CH4H2COF COMMON/CH4H2COF/RJCH4(KMXP),FK9OP(KMXP),SCO2I(KMXP),RSKIONS(KMXP), 1RJCO2T(KMXP),RKCO2P(KMXP),SCOI(KMXP) *CDK CH4H2CFF COMMON/CH4H2COF/RJCH4(KMXP,7) *CDK CH4H2CO2 COMMON/CH4H2CO2/RJCH4(KMXP,IMXP),FK9OP(KMXP,IMXP),SCO2I(KMXP,IMXP) 1 ,RSKIONS(KMXP,IMXP),RJCO2T(KMXP,IMXP),RKCO2P(KMXP,IMXP), 2 SCOI(KMXP,IMXP) *CDK CH4H2C2F COMMON/CH4H2CO2/RJCH4F(KMXP,IMXP,7) */ */ */ *CDK CONS COMMON/CONS/C(120),RMASS(3),T0(KMXP),LEN1,LEN2,LEN3,KMAX,KMAXP1, 1EXPS(KMXP),DIFK(KMXP) *CDK CONS2 COMMON/CONS/C(120),RMASS(3),T0(KMXP),LEN1,LEN2,LEN3,KMAX,KMAXP1, 1EXPS(KMXP),DIFK(IMXP,KMXP),IMAX,IMAXP2,IMAXP4,FB(IMXP,2) *CDK CONS3 COMMON/CONS/CC(120),RMASS(3),T0(KMXP),LEN1,LEN2,LEN3,KMAX,KMAXP1, 1EXPS(KMXP),DIFK(IMXP,KMXP),IMAX,IMAXP2,IMAXP4,FB(IMXP,2) */ */ */ *CDK CRATES COMMON/CRATES/RK12(KMXP),RK13(KMXP),RK14(KMXP),RK15(KMXP) *CDK CRATESF COMMON/CRATES/RK12(KMXP,4) *CDK CRATES2 COMMON/CRATES2/RK12(KMXP,IMXP),RK13(KMXP,IMXP),RK14(KMXP,IMXP), 1 RK15(KMXP,IMXP) *CDK CRATES2F COMMON/CRATES2/RK12F(KMXP,IMXP,4) */ */ */ *CDK DISSHOX COMMON/DISSHOX/SH2OT(KMXP),YIOP(KMXP),YIHP(KMXP),YIOHP(KMXP), 1SH2OSRB(KMXP),SH2OLYA(KMXP),SH2OSRC(KMXP),SH2OEUV(KMXP), 2SHOXI(KMXP) *CDK DISSHOXF COMMON/DISSHOX/SH2OT(KMXP,9) *CDK DISSHOX2 COMMON/DISSHOX2/SH2OT(KMXP,IMXP),YIOP(KMXP,IMXP),YIHP(KMXP,IMXP), 1 YIOHP(KMXP,IMXP),SH2OSRB(KMXP,IMXP),SH2OLYA(KMXP,IMXP), 2 SH2OSRC(KMXP,IMXP),SH2OEUV(KMXP,IMXP),SHOXI(KMXP,IMXP) *CDK DISSHX2F COMMON/DISSHOX2/SH2OTF(KMXP,IMXP,9) */ */ */ *CDK FIELDS COMMON/FIELDS/FT(KMXP),FNO2(KMXP),FNO(KMXP),FNN2(KMXP),FNAR(KMXP), 1FNHE(KMXP),FNNO(KMXP),FNN2D(KMXP),FNN4S(KMXP),FRJ(KMXP),FW(KMXP), 2FNHOX(KMXP),PPN2D(KMXP),FNE(KMXP),PPN4S(KMXP),FK4O2P(KMXP), 3FK5O2P(KMXP),F107,FTE(KMXP),FDIFK(KMXP),FU(KMXP) *CDK FIELDSF COMMON/FIELDS/FT(KMXP,17),F107,FTE(KMXP,3) *CDK FIELDS2 COMMON/FIELDS2/FT(KMXP,IMXP),FNO2(KMXP,IMXP),FNO(KMXP,IMXP), 1FNN2(KMXP,IMXP),FNAR(KMXP,IMXP),FNHE(KMXP,IMXP),FNNO(KMXP,IMXP), 2FNN2D(KMXP,IMXP),FNN4S(KMXP,IMXP),FRJ(KMXP,IMXP),FW(KMXP,IMXP), 3FNHOX(KMXP,IMXP),PPN2D(KMXP,IMXP),FNE(KMXP,IMXP),PPN4S(KMXP,IMXP), 4FK4O2P(KMXP,IMXP),FK5O2P(KMXP,IMXP),F107,FTE(KMXP,IMXP), 5FDIFK(KMXP,IMXP),FU(KMXP,IMXP),FWI(KMXP,IMXP),FUI(KMXP,IMXP) 6,FNAS(KMXP,IMXP),FNAO(KMXP,IMXP),FNAO2(KMXP,IMXP),FNAOH(KMXP,IMXP) *CDK FIELDS2F COMMON/FIELDS2/FTF(KMXP,IMXP,17),F107F,FTEF(KMXP,IMXP,9) */ */ */ *CDK FIELDT COMMON/FIELDT/FNH2O(KMXP),FNH2O2(KMXP),FNO1D(KMXP),FNH2(KMXP), 1FNOH(KMXP),FNHO2(KMXP),FNO3(KMXP),FNH(KMXP),FNCH4(KMXP),FNCO(KMXP) 2,FNCO2(KMXP),FNNO2(KMXP) *CDK FIELDTF COMMON/FIELDT/FNH2O(KMXP,12) *CDK FIELDT2 COMMON/FIELDT2/FNH2O(KMXP,IMXP),FNH2O2(KMXP,IMXP),FNO1D(KMXP,IMXP) 1,FNH2(KMXP,IMXP),FNOH(KMXP,IMXP),FNHO2(KMXP,IMXP),FNO3(KMXP,IMXP), 2FNH(KMXP,IMXP),FNCH4(KMXP,IMXP),FNCO(KMXP,IMXP),FNCO2(KMXP,IMXP), 3FNNO2(KMXP,IMXP) *CDK FIELDT2F COMMON/FIELDT2/FNH2OF(KMXP,IMXP,12) */ */ */ *CDK FLUX COMMON/FLUX/FLUXNO,IBNDNO,FLUXCO,IBNDCO *CDK FLUX2 COMMON/FLUX2/FLUXNO(IMXP),IBNDNO,FLUXCO(IMXP),IBNDCO *CDK FLUX2F COMMON/FLUX2/FLUXNOF(IMXP),IBNDNOF,FLUXCOF(IMXP),IBNDCOF */ */ */ *CDK H2FORG COMMON/H2FORG/RJH2OLY(KMXP) *CDK H2FORG2 COMMON/H2FORG2/RJH2OLY(KMXP,IMXP) *CDK H2FORG2F COMMON/H2FORG2/RJH2OLYF(KMXP,IMXP) */ */ */ *CDK HEFLUX COMMON/HEFLUX/FLUX *CDK HEFLUX2 COMMON/HEFLUX2/FLUX(IMXP) *CDK HEFLUX2F COMMON/HEFLUX2/FLUXF(IMXP) */ */ */ *CDK HOXSTUF COMMON/HOXSTUF/HO2HR(KMXP),OHHR(KMXP),HHOXR(KMXP),ANT(KMXP), 1BNT(KMXP),CNT(KMXP),DNT(KMXP),ASNT(KMXP),CONPR(KMXP),DSNT(KMXP) *CDK HOXSTUFF COMMON/HOXSTUF/HO2HR(KMXP,10) *CDK HOXSTUF2 COMMON/HOXSTUF2/HO2HR(KMXP,IMXP),OHHR(KMXP,IMXP),HHOXR(KMXP,IMXP), 1 ANT(KMXP,IMXP),BNT(KMXP,IMXP),CNT(KMXP,IMXP),DNT(KMXP,IMXP), 2 ASNT(KMXP,IMXP),CONPR(KMXP,IMXP),DSNT(KMXP,IMXP) *CDK HOXSTF2F COMMON/HOXSTUF2/HO2HRF(KMXP,IMXP,10) */ */ */ *CDK HOXUPP COMMON/HOXUPP/FHOX *CDK HOXUPP2 COMMON/HOXUPP2/FHOX(IMXP) *CDK HOXUPP2F COMMON/HOXUPP2/FHOXF(IMXP) */ */ */ *CDK INDEX COMMON/INDEX/NJ,NT,NU,NPS,NPS2,NPSA,NPSH,NPNO,NPN4S,NPCH4,NPH2, 1NPCO2,NPCO,NPHOX,NPH2O,NW,NPSNM,NPS2NM,NPSANM,NPSHNM,NPNONM, 2NN4SNM,NCH4NM,NPH2NM,NCO2NM,NPCONM,NHOXNM,NH2ONM,NJNP,NDJ,NRJ */ */ */ *CDK INDEXDAT DATA NJ,NT,NU,NPS,NPS2,NPSA,NPSH,NPNO,NPN4S,NPCH4,NPH2,NPCO2, 1 NPCO,NPHOX,NPH2O,NW,NPSNM,NPS2NM,NPSANM,NPSHNM,NPNONM,NN4SNM, 2 NCH4NM,NPH2NM,NCO2NM,NPCONM,NHOXNM,NH2ONM,NJNP,NDJ,NRJ/1,0,KMXP, 3 KMXP2,KMXP3,KMXP4,KMXP5,KMXP6,KMXP7,KMXP8,KMXP9,KMXP10,KMXP11, 4 KMXP12,KMXP13,KMXP14,KMXP15,KMXP16,KMXP17,KMXP18,KMXP19,KMXP20, 5 KMXP21,KMXP22,KMXP23,KMXP24,KMXP25,KMXP26,KMP27P,KMP54P,0/ */ */ */ *CDK IONHOX COMMON/IONHOX/PHOXIC(KMXP) *CDK IONHOX2 COMMON/IONHOX2/PHOXIC(KMXP,IMXP) *CDK IONHOX2F COMMON/IONHOX2/PHOXICF(KMXP,IMXP) */ */ */ *CDK NEWRAT COMMON/NEWRAT/HO2OH(KMXP),HOH(KMXP),OHHOX(KMXP) *CDK NEWRATF COMMON/NEWRATF/HO2OH(KMXP,3) *CDK NEWRAT2 COMMON/NEWRAT2/HO2OH(KMXP,IMXP),HOH(KMXP,IMXP),OHHOX(KMXP,IMXP) *CDK NEWRAT2F COMMON/NEWRAT2/HO2OHF(KMXP,IMXP,3) */ */ */ *CDK NOZNOZ COMMON/NOZNOZ/SNO2NO(KMXP),RNONOZ(KMXP),FNNOZ(KMXP) *CDK NOZNOZF COMMON/NOZNOZF/SNO2NO(KMXP,3) *CDK NOZNOZ2 COMMON/NOZNOZ2/SNO2NO(KMXP,IMXP),RNONOZ(KMXP,IMXP), 1 FNNOZ(KMXP,IMXP) *CDK NOZNOZ2F COMMON/NOZNOZ2/SNO2NOF(KMXP,IMXP,3) */ */ */ *CDK OPION COMMON/OPION/FIOP(KMXP) *CDK OPION2 COMMON/OPION2/FIOP(KMXP,IMXP) *CDK OPION2F COMMON/OPION2/FIOPF(KMXP,IMXP) */ */ */ *CDK OXOXOX COMMON/OXOXOX/O3OR(KMXP),XNOX(KMXP),OOXR(KMXP),FNOX(KMXP),XNOX1 1,PS2B *CDK OXOXOXF COMMON/OXOXOX/O3OR(KMXP,4),XNOX1(2) *CDK OXOXOX2 COMMON/OXOXOX2/O3OR(KMXP,IMXP),XNOX(KMXP),OOXR(KMXP,IMXP), 1 FNOX(KMXP,IMXP),XNOX1,PS2B(IMXP) *CDK OXOXOX2F COMMON/OXOXOX2/O3ORF(KMXP,IMXP),XNOXF(KMXP),OOXRF(KMXP,IMXP,2), 1 XNOX1,PS2B(IMXP) */ */ */ *CDK PARAMS PARAMETER (KMX=95,IMX=20) PARAMETER (KMXP=KMX+1,IMXP=IMX+4) PARAMETER (KMXP2=2*KMXP,KMXP3=3*KMXP,KMXP4=4*KMXP, 1 KMXP5=5*KMXP,KMXP6=6*KMXP,KMXP7=7*KMXP,KMXP8=8*KMXP,KMXP9=9*KMXP 2 ,KMXP10=10*KMXP,KMXP11=11*KMXP,KMXP12=12*KMXP,KMXP13=13*KMXP, 3 KMXP14=14*KMXP,KMXP15=15*KMXP,KMXP16=16*KMXP,KMXP17=17*KMXP, 4 KMXP18=18*KMXP,KMXP19=19*KMXP,KMXP20=20*KMXP,KMXP21=21*KMXP, 5 KMXP22=22*KMXP,KMXP23=23*KMXP,KMXP24=24*KMXP,KMXP25=25*KMXP, 6 KMXP26=26*KMXP,KMP27P=27*KMXP+1,KMP54P=54*KMXP+1,KMXP55=55*KMXP) */ */ */ *CDK PSIB COMMON/PSIB/PARB,PHB,PNOB,PN4SB,PCH4B,PH2B,PCO2B,PCOB,PHOXB,PH2OB *CDK PSIBF COMMON/PSIB/PARB(10) *CDK PSIB2 COMMON/PSIB2/PARB(IMXP),PHB(IMXP),PNOB(IMXP),PN4SB(IMXP), 1 PCH4B(IMXP),PH2B(IMXP),PCO2B(IMXP),PCOB(IMXP),PHOXB(IMXP), 2 PH2OB(IMXP) *CDK PSIB2F COMMON/PSIB2/PARBF(IMXP,10) */ */ */ *CDK PHOTO COMMON/PHOTO/XNO,XN4S,XCH4,XH2,XCO2,XCO,XH2O *CDK PHOTOF COMMON/PHOTO/XNO(7) *CDK PHOTO2 COMMON/PHOTO2/XNO(IMXP),XN4S(IMXP),XCH4(IMXP),XH2(IMXP),XCO2(IMXP) 1 ,XCO(IMXP),XH2O(IMXP) *CDK PHOTO2F COMMON/PHOTO2/XNOF(IMXP,7) */ */ */ *CDK PHOTOO COMMON/PHOTOO/XHE,XARG *CDK PHOTOOF COMMON/PHOTOO/XHE(2) *CDK PHOTOO2 COMMON/PHOTOO2/XHE(IMXP),XARG(IMXP) *CDK PHOTOO2F COMMON/PHOTOO2/XHEF(IMXP,2) */ */ */ *CDK RATEBLK COMMON/RATEBLK/RKK(25,KMXP),ALPP(10,KMXP),RBB(20,KMXP), 1RKMM(50,KMXP) *CDK RATEBLK2 COMMON/RATEBLK2/RKK(25,KMXP,IMXP),ALPP(10,KMXP,IMXP), 1RBB(20,KMXP,IMXP),RKMM(50,KMXP,IMXP) *CDK RATBLK2F COMMON/RATEBLK2/RKKF(25,KMXP,IMXP),ALPPF(10,KMXP,IMXP), 1RBBF(20,KMXP,IMXP),RKMMF(50,KMXP,IMXP) */ */ */ *CDK RJH2O2O COMMON/RJH2O2O/RJH2O2(KMXP) *CDK RJH2O2O2 COMMON/RJH2O2O2/RJH2O2(KMXP,IMXP) *CDK RJH2O22F COMMON/RJH2O2O2/RJH2O2F(KMXP,IMXP) */ */ */ *CDK SOURCE COMMON/SOURCE/FS11(KMXP),FS12(KMXP),FS21(KMXP),FS22(KMXP), 1FS1(KMXP),FS2(KMXP) *CDK SOURCEF COMMON/SOURCE/FS11(KMXP,6) *CDK SOURCE2 COMMON/SOURCE2/FS11(KMXP,IMXP),FS12(KMXP,IMXP),FS21(KMXP,IMXP), 1FS22(KMXP,IMXP),FS1(KMXP,IMXP),FS2(KMXP,IMXP) *CDK SOURCE2F COMMON/SOURCE2/FS11F(KMXP,IMXP,6) */ */ */ *CDK VSCR COMMON/VSCR/S15(IMXP,KMXP),S14(IMXP,KMXP),S13(IMXP,KMXP), 1S12(IMXP,KMXP),S11(IMXP,KMXP),S10(IMXP,KMXP),S9(IMXP,KMXP), 2S8(IMXP,KMXP),S7(IMXP,KMXP),S6(IMXP,KMXP),S5(IMXP,KMXP), 3S4(IMXP,KMXP),S3(IMXP,KMXP),S2(IMXP,KMXP),S1(IMXP,KMXP),T1(IMXP) 4,T2(IMXP),T3(IMXP),T4(IMXP),T5(IMXP),T6(IMXP),T7(IMXP) */ */ */ *CDK VSCR2 COMMON/VSCR/GAMA(IMXP,KMXP,2,2),Z(IMXP,KMXP,2),EMBAR(IMXP, 1KMXP),AK(IMXP,2,2,2),EP(IMXP,2,2),FK(IMXP,2),PK(IMXP, 22,2),QK(IMXP,2,2), RK(IMXP,2,2),WKM1(IMXP,2,2),WKM2(IMXP, 32,2),WKV1(IMXP,2),WKV2(IMXP,2),WKS1(IMXP),WKS2(IMXP),WKS3(IMXP), 4EMBAR0(IMXP),PS0(IMXP,2) */ */ */ *CDK VSCR3 COMMON/VSCR/WK1(KMXP,IMXP),WK2(KMXP,IMXP),WK3(KMXP,IMXP), 1 WK4(KMXP,IMXP),WK5(KMXP,IMXP),WK6(KMXP,IMXP),WK7(KMXP,IMXP), 2 WK8(KMXP,IMXP),WK9(KMXP,IMXP),WK10(KMXP,IMXP),WK11(KMXP,IMXP), 3 WK12(KMXP,IMXP),WK13(KMXP,IMXP) */ */ */ */ *DK BLKDATA */ */ */ CDIR$ NOLIST BLOCK DATA BLOCKS *CA PARAMS COMMON/BLK1/ZERO1 *CA ASAS2 COMMON/BLK2/ZERO2 *CA CH4H2CO2 COMMON/BLK3/ZERO3 *CA CONS2 COMMON/BLK4/ZERO4 *CA CRATES2 COMMON/BLK5/ZERO5 *CA DISSHOX2 COMMON/BLK6/ZERO6 *CA FIELDS2 COMMON/BLK7/ZERO7 *CA FIELDT2 COMMON/BLK8/ZERO8 *CA FLUX2 COMMON/BLK9/ZERO9 *CA H2FORG2 COMMON/BLK10/ZERO10 *CA HEFLUX2 COMMON/BLK11/ZERO11 *CA HOXSTUF2 COMMON/BLK12/ZERO12 *CA HOXUPP2 COMMON/BLK13/ZERO13 *CA INDEX COMMON/BLK14/ZERO14 *CA IONHOX2 COMMON/BLK15/ZERO15 *CA NEWRAT2 COMMON/BLK16/ZERO16 *CA NOZNOZ2 COMMON/BLK17/ZERO17 *CA OPION2 COMMON/BLK18/ZERO18 *CA OXOXOX2 COMMON/BLK19/ZERO19 *CA PSIB2 COMMON/BLK20/ZERO20 *CA PHOTO2 COMMON/BLK21/ZERO21 *CA PHOTOO2 COMMON/BLK22/ZERO22 *CA RATEBLK2 COMMON/BLK23/ZERO23 *CA RJH2O2O2 COMMON/BLK24/ZERO24 *CA SOURCE2 COMMON/BLK25/ZERO25 *CA VSCR COMMON/BLK26/ZERO26 DATA ZERO1,ZERO2,ZERO3,ZERO4,ZERO5,ZERO6,ZERO7,ZERO8,ZERO9 1 /1.,2.,3.,4.,5.,6.,7.,8.,9./ DATA ZERO10,ZERO11,ZERO12,ZERO13,ZERO14,ZERO15,ZERO16,ZERO17, 1 ZERO18,ZERO19/10.,11.,12.,13.,14.,15.,16.,17.,18.,19./ DATA ZERO20,ZERO21,ZERO22,ZERO23,ZERO24,ZERO25,ZERO26 2 /20.,21.,22.,23.,24.,25.,26./ END C C SUBROUTINE CHKBLKS SAVE COMMON/BLK1/ZERO1 COMMON/BLK2/ZERO2 COMMON/BLK3/ZERO3 COMMON/BLK4/ZERO4 COMMON/BLK5/ZERO5 COMMON/BLK6/ZERO6 COMMON/BLK7/ZERO7 COMMON/BLK8/ZERO8 COMMON/BLK9/ZERO9 COMMON/BLK10/ZERO10 COMMON/BLK11/ZERO11 COMMON/BLK12/ZERO12 COMMON/BLK13/ZERO13 COMMON/BLK14/ZERO14 COMMON/BLK15/ZERO15 COMMON/BLK16/ZERO16 COMMON/BLK17/ZERO17 COMMON/BLK18/ZERO18 COMMON/BLK19/ZERO19 COMMON/BLK20/ZERO20 COMMON/BLK21/ZERO21 COMMON/BLK22/ZERO22 COMMON/BLK23/ZERO23 COMMON/BLK24/ZERO24 COMMON/BLK25/ZERO25 COMMON/BLK26/ZERO26 C WRITE(6,100)ZERO1,ZERO2,ZERO3,ZERO4,ZERO5,ZERO6,ZERO7,ZERO8,ZERO9, C 1 ZERO10,ZERO11,ZERO12,ZERO13,ZERO14,ZERO15,ZERO16,ZERO17, C 2 ZERO18,ZERO19,ZERO20,ZERO21,ZERO22,ZERO23,ZERO24,ZERO25,ZERO26 C 100 FORMAT(10E12.4) RETURN END */ *DK CMPN4S */ SUBROUTINE CMPN4S CDIR$ BOUNDS SAVE C **** C **** ADVANCE N4S COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CONS, FIELDS, FIELDT, FLUX, INDEX, PHOTO, C **** PSIB, RATEBLK, VSCR C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA INDEX *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA VSCR DIMENSION PHIN4S(3) DATA RMN4S,PHIN4S/14.,0.651,0.731,0.741/ C **** C **** UPPER BOUNDARY: DIFFUSIVE EQUILIBRIUM C **** LOWER BOUNDARY: PHOTO-CHEMICAL EQUILIBRIUM C **** DO 1 I=3,LEN1-2 T4(I)=0. T1(I)=0. T2(I)=1. T3(I)=-XN4S(I)*RMN4S/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 1 CONTINUE C **** C **** SOURCES C **** DO 2 K=1,KMAXP1 DO 2 I=3,LEN1-2 S1(I,K)=-(FK4O2P(K,I)+RBB(1,K,I)*FNO2(K,I)+RBB(3,K,I)* 1 FNNO(K,I)+RBB(10,K,I)*FNOH(K,I)) S2(I,K)=PPN4S(K,I)+RBB(4,K,I)*FNN2D(K,I)*FNO(K,I)+RBB(5,K,I)* 1 FNN2D(K,I)*FNE(K,I)+RBB(7,K,I)*FNN2D(K,I)+RBB(8,K,I)* 2 FNNO(K,I) 2 CONTINUE C **** C **** PERIODIC POINTS C **** DO 3 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 3 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 3 CONTINUE IBND=0 IBNDB=0 ALFA=0. CALL MINOR(NPN4S,NN4SNM,RMN4S,PHIN4S,ALFA,IBND,IBNDB,PN4SB) RETURN END */ *DK PPHOTO */ CDIR$ NOLIST SUBROUTINE PHOTO SAVE C **** C **** COMMON DECKS NEEDED: C **** PARAMETER, CONS, FIELDS, FIELDT, FLUX, PHOTO, PHOTOO, C **** RATEBLK C **** *CA PARAMS *CA CONS3 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA PHOTO2 *CA PHOTOO2 *CA RATEBLK2 DIMENSION A(IMXP),B(IMXP),C(IMXP),D(IMXP),E(IMXP),R(IMXP),S(IMXP), 1 T(IMXP),FM(IMXP) DO 1 I = 3,LEN1-2 A(I) = PPN4S(1,I)+RBB(4,1,I)*FNN2D(1,I)*FNO(1,I)+RBB(5,1,I)* 1 FNN2D(1,I)*FNE(1,I)+RBB(7,1,I)*FNN2D(1,I) B(I)=RBB(2,1,I)*FNO2(1,I)*FNN2D(1,I)+RBB(13,1,I)*FNO(1,I)* 1 FNNO2(1,I)+RBB(14,1,I)**FNNO2(1,I) C(I)=FK4O2P(1,I)+RBB(1,1,I)*FNO2(1,I)+RBB(10,1,I)*FNOH(1,I) D(I)=FK5O2P(1,I)+RBB(6,1,I)*FNN2D(1,I)+RBB(8,1,I)+RBB(9,1,I)+ 1 RBB(11,1,I)*FNO3(1,I)+RBB(12,1,I)*FNHO2(1,I) E(I)=RBB(1,1,I)*FNO2(1,I)+RBB(10,1,I)*FNOH(1,I) R(I)=RBB(3,1,I)*E(I)+RBB(3,1,I)*C(I) S(I)=-(RBB(8,1,I)*E(I)-RBB(3,1,I)*B(I)-D(I)*C(I)+RBB(3,1,I)* 1 A(I)) T(I)=-(RBB(8,1,I)*B(I)+D(I)*A(I)) XN4S(I)=(-S(I)+SQRT(S(I)*S(I)-4.*R(I)*T(I)))/(2.*R(I)) XNO(I)=(C(I)*XN4S(I)-A(I))/(RBB(8,1,I)-RBB(3,1,I)*XN4S(I)) FM(I)=FNO(1,I)+FNO2(1,I)+FNN2(1,I) XNO(I)=1.1E-8*FM(I) XCH4(I)=0.16E-6*FM(I) XH2(I)=0.5E-6*FM(I) XCO2(I)=350.E-6*FM(I) XCO(I)=3.6E-8*FM(I) XH2O(I)=6.0E-6*FM(I) XHE(I)=5.24E-6*FM(I) XARG(I)=9.34E-3*FM(I) 1 CONTINUE C WRITE(6,1234)(XN4S(I),XNO(I),XCH4(I),XH2(I),XCO2(I), C 1 XCO(I),XH2O(I),XHE(I),XARG(I),I=1,LEN1) C ***** C ***** PERIODIC POINTS C ***** DO 2 I = 1,2 XN4S(I) = XN4S(I+IMAX) XN4S(I+IMAXP2) = XN4S(I+2) XNO(I) = XNO(I+IMAX) XNO(I+IMAXP2) = XNO(I+2) XCH4(I) = XCH4(I+IMAX) XCH4(I+IMAXP2) = XCH4(I+2) XH2(I) = XH2(I+IMAX) XH2(I+IMAXP2) = XH2(I+2) XCO2(I) = XCO2(I+IMAX) XCO2(I+IMAXP2) = XCO2(I+2) 2 CONTINUE DO 3 I =1,2 XCO(I) = XCO(I+IMAX) XCO(I+IMAXP2) = XCO(I+2) XH2O(I) = XH2O(I+IMAX) XH2O(I+IMAXP2) = XH2O(I+2) XHE(I) = XHE(I+IMAX) XHE(I+IMAXP2) = XHE(I+2) XARG(I) = XARG(I+IMAX) XARG(I+IMAXP2) = XARG(I+2) 3 CONTINUE C WRITE(6,1234)(XN4S(I),XNO(I),XCH4(I),XH2(I),XCO2(I), C 1 XCO(I),XH2O(I),XHE(I),XARG(I),I=1,LEN1) C1234 FORMAT(9E12.4) RETURN END CDIR$ NOLIST */ *DK COMP */ CDIR$ NOLIST SUBROUTINE COMP SAVE C **** ADVANCE PSI IN TIME C **** C **** COMMON DECKS: C **** C **** PARAMS, ASAS, CONS, CRATES, INDEX, SOURCE, VSCR2 C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA CRATES2 *CA INDEX *CA SOURCE2 *CA VSCR2 DIMENSION AK0(2,2),S(2,2),PHI(2,3),DELTA(2,2),B(2,2) DIMENSION SS(2,2) DIMENSION ENMBAR(IMXP),FS11ST(IMXP),FS12ST(IMXP),FS21ST(IMXP), 1 FS22ST(IMXP),ST(IMXP) EQUIVALENCE (C(40),B) DATA PHI/0.,0.673,1.35,0.,1.11,0.769/,TAU/1.86E+3/, AS/-1.,1.,0.,0./,DELTA/1.,0.,0.,1./, BT00/273./ DATA SS/0.,0.,1.,-1./ DATA SMALL/1.E-6/ DFACT=1. C **** CALCULATE EMBAR NPS1K=NJ+NPS-1 NPS2K=NPS1K+KMAXP1 DO 1 K = 1,KMAXP1 DO 1 I=1,LEN1 EMBAR(I,K)=1./(F(I,NPS1K+K)/RMASS(1)+F(I,NPS2K+K)/RMASS(2)+(1.- A F(I,NPS1K+K)-F(I,NPS2K+K))/RMASS(3)) 1 CONTINUE C CALCULATE PS0, EMBAR0 AND .5*((DMBAR/DZ)/MBAR) AT LEVEL 1/2 NPS1K=NJ+NPS NPS2K=NPS1K+KMAXP1 DO 30 I=1,LEN1 PS0(I,1)=B(1,1)*F(I,NPS1K)+B(1,2)*F(I,NPS2K)+FB(I,1) PS0(I,2)=B(2,1)*F(I,NPS1K)+B(2,2)*F(I,NPS2K)+FB(I,2) EMBAR0(I)=1./(PS0(I,1)/RMASS(1)+PS0(I,2)/RMASS(2)+(1.-PS0(I,1) A -PS0(I,2))/RMASS(3)) WKS3(I)=(EMBAR(I,1)-EMBAR0(I))/(C(3)*(EMBAR0(I)+EMBAR(I,1))) 30 CONTINUE C **** CALCULTE EP AND AK AT LEVEL 1/2, SET Z(0) TO ZERO KM=1 KP=2 C **** EP(1/2) DO 2 L=1,2 DO 2 I=1,LEN1 EP(I,L,KP)=1.-(2./(EMBAR0(I)+EMBAR(I,1)))*(RMASS(L)+ A (EMBAR(I,1)-EMBAR0(I))/C(3)) Z(I,1,L)=0. 2 CONTINUE DO 3 L=1,2 LL=3-L NPSL=NJ+NPS+(L-1)*KMAXP1 DO 3 M=1,2 DO 3 I=1,LEN1 AK(I,L,M,KP)=-DELTA(L,M)*(PHI(LL,3)+(PHI(LL,L)-PHI(LL,3))* A .5*(PS0(I,L)+F(I,NPSL)))-(1.-DELTA(L,M))*(PHI(L,M)- B PHI(L,3))*.5*(PS0(I,L)+F(I,NPSL)) 3 CONTINUE C **** WKS1=MBAR/M3*(T00/(T0+T))*0.25/(TAU*DET) AT LEVEL 1/2 NTK=NJ+NT+KMAX DO 4 I=1,LEN1 WKS1(I)=0.5*(EMBAR0(I)+EMBAR(I,1))/RMASS(3)*(T00/(T0(1)+ A F(I,NTK)))**0.25/(TAU*(AK(I,1,1,KP)*AK(I,2,2,KP)-AK(I,1,2,KP)* B AK(I,2,1,KP))) 4 CONTINUE C **** COMPLETE CALCULATION OF AK(1/2) DO 5 L=1,2 DO 5 M=1,2 DO 5 I=1,LEN1 AK(I,L,M,KP)=AK(I,L,M,KP)*WKS1(I) C **** SET GAMA(0) TO 0. GAMA(I,1,L,M)=0. 5 CONTINUE C **** MAIN HEIGHT DO LOOP DO 6 K=1,KMAX C **** CYCLE K LEVELS KB=KM KM=KP KP=KB C **** EP(K+1/2) DO 7 L=1,2 DO 7 I=1,LEN1 EP(I,L,KP)=1.-(2./(EMBAR(I,K)+EMBAR(I,K+1)))*(RMASS(L)+ A (EMBAR(I,K+1)-EMBAR(I,K))/C(3)) 7 CONTINUE C **** AK(K+1/2) DO 8 L=1,2 LL=3-L NPSL=NJ+NPS+(L-1)*KMAXP1+K DO 8 M=1,2 DO 8 I=1,LEN1 AK(I,L,M,KP)=-DELTA(L,M)*(PHI(LL,3)+(PHI(LL,L)-PHI(LL,3))* A .5*(F(I,NPSL-1)+F(I,NPSL)))-(1.-DELTA(L,M))*(PHI(L,M)- B PHI(L,3))*.5*(F(I,NPSL-1)+F(I,NPSL)) 8 CONTINUE C **** WKS1=MBAR/M3*(T00/(T0+T))**0.25/(TAU*DET(ALFA)) NTK=NJ+NT+K DO 9 I=1,LEN1 WKS1(I)=0.5*(EMBAR(I,K)+EMBAR(I,K+1))/RMASS(3)*(T00/(T0(K+1)+.5* A (F(I,NTK-1)+F(I,NTK))))**0.25/(TAU*(AK(I,1,1,KP)*AK(I,2,2,KP)- B AK(I,1,2,KP)*AK(I,2,1,KP))) C **** EDDY DIFFUSION TERMS IN WKS1 AND WKS2 WKS2(I)=WKS3(I) WKS3(I)=(EMBAR(I,K+1)-EMBAR(I,K))/(C(3)*(EMBAR(I,K)+ C EMBAR(I,K+1))) 9 CONTINUE C **** C **** CALCULATE AUGMENTED SOURCE TERMS C **** NTK=NJ+NT+K-1 NPS1K=NJ+NPS+K-1 NPS2K=NPS1K+KMAXP1 C **** ENMBAR=P0*EXPS*MBAR/(K*T) DO 91 I = 1,LEN1 ENMBAR(I)=C(81)*EXPS(K)*EMBAR(I,K)/(C(84)*F(I,NTK)) FS11ST(I)=ENMBAR(I)**2*(-.5/.3*(RK13(K,I)+RK13(K+1,I))* 1 (F(I,NPS2K)/RMASS(2))**2-1./3.*(RK14(K,I)+RK14(K+1,I))* 2 F(I,NPS1K)/RMASS(1)*F(I,NPS2K)/RMASS(2)+.5*(RK15(K,I)+ 3 RK15(K+1,I))*(-.5*F(I,NPS2K)/(RMASS(2)*EMBAR(I,K))+1./3.* 4 (F(I,NPS2K)/RMASS(2))**2+2./3.*F(I,NPS1K)/RMASS(1)* 5 F(I,NPS2K)/RMASS(2))) FS21ST(I)=.5*(FS21(K,I)+FS21(K+1,I))+FS11ST(I) FS11ST(I)=.5*(FS11(K,I)+FS11(K+1,I))+FS11ST(I) FS12ST(I)=-1./3.*(RK13(K,I)+RK13(K+1,I))*F(I,NPS1K)/RMASS(1)* 1 F(I,NPS2K)/RMASS(2)-1./6.*(RK14(K,I)+RK14(K+1,I))*(F(I,NPS1K)/ 2 RMASS(1))**2+.5*(RK15(K,I)+RK15(K+1,I))*F(I,NPS1K)/RMASS(1)* 3 (-.5/EMBAR(I,K)+1./3.*F(I,NPS1K)/RMASS(1)+2./3.*F(I,NPS2K)/ 4 RMASS(2)) FS22ST(I)=.5*(FS22(K,I)+FS22(K+1,I))+ENMBAR(I)**2*(-(RK12(K,I)+ 1 RK12(K+1,I))*F(I,NPS2K)/(RMASS(2)*EMBAR(I,K))+FS12ST(I)) FS12ST(I)=.5*(FS12(K,I)+FS12(K+1,I))+ENMBAR(I)**2*(.5*(RK12(K,I) 1 +RK12(K+1,I))*F(I,NPS2K)/(RMASS(2)*EMBAR(I,K))+FS12ST(I)) C **** C **** TOTAL SOURCE C **** C ST(I)=.5*(ENMBAR(I)*((2.*(FS11(K,I)+FS11(K+1,I))+FS21(K,I)+ C 1 FS21(K+1,I))*F(I,NPS1K)/RMASS(1)+(2.*(FS12(K,I)+FS12(K+1,I))+ C 2 FS22(K,I)+FS22(K+1,I))*F(I,NPS2K)/RMASS(2))+2.*(FS1(K,I)+ C 3 FS1(K+1,I))+FS2(K,I)+FS2(K+1,I)-3.*ENMBAR(I)**3*((RK13(K,I)+ C 4 RK13(K+1,I))*F(I,NPS1K)/RMASS(1)*(F(I,NPS2K)/RMASS(2))**2+ C 5 (RK14(K,I)+RK14(K+1,I))*(F(I,NPS1K)/RMASS(1))**2*F(I,NPS2K)/ C 6 RMASS(2)+(RK15(K,I)+RK15(K+1,I))*F(I,NPS1K)/RMASS(1)* C 7 F(I,NPS2K)/RMASS(2)*(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)))* C 8 RMASS(2)/ENMBAR ST(I)=0. C **** C **** SET UP SOURCE MATRIX IN WKM2 C **** WKM2(I,1,1)=FS11ST(I)-ST(I) WKM2(I,1,2)=2.*FS12ST(I) WKM2(I,2,1)=.5*FS21ST(I) WKM2(I,2,2)=FS22ST(I)-ST(I) 91 CONTINUE C **** FINISH CALCULATING AK(K+1/2) AND GENERATE PK, QK, RK NWK=NJ+NW+K DO 10 L=1,2 DO 10 M=1,2 DO 10 I=1,LEN1 AK(I,L,M,KP)=AK(I,L,M,KP)*WKS1(I) PK(I,L,M)=(AK(I,L,M,KM)*(1./C(3)+EP(I,M,KM)/2.)-EXPS(K) A *(C(87)*DIFK(I,K)*DFACT*(1./C(3)-WKS2(I))+0.25* B (F(I,NWK-1)+F(I,NWK)))*DELTA(L,M))/C(3) RK(I,L,M)=(AK(I,L,M,KP)*(1./C(3)-EP(I,M,KP)/2.)-EXPS(K) A *(C(86)*DIFK(I,K+1)*DFACT*(1./C(3)+WKS3(I))-0.25* B (F(I,NWK-1)+F(I,NWK)))*DELTA(L,M))/C(3) QK(I,L,M)=-(AK(I,L,M,KM)*(1./C(3)-EP(I,M,KM)/2.)+ A AK(I,L,M,KP)*(1./C(3)+EP(I,M,KP)/2.))/C(3)+EXPS(K)* B (((C(86)*DIFK(I,K+1)*(1./C(3)-WKS3(I))+C(87)*DIFK(I,K)* C (1./C(3)+WKS2(I)))*DFACT/C(3)+C(7))*DELTA(L,M)- D WKM2(I,L,M)) 10 CONTINUE C **** CALCULATE HORIZONTAL ADVECTION IN FK ARRAY DO 11 L=1,2 NPSL=NPS+(L-1)*KMAXP1 CALL ADVECL(NPSL,FK(1,L),K) 11 CONTINUE C **** C **** ADD EXPLICIT SOURCE TERMS FK C **** DO 111 I = 1,LEN1 FK(I,1)=FK(I,1)-(FS1(K,I)+FS1(K+1,I))*RMASS(2)/ENMBAR(I) FK(I,2)=FK(I,2)-.5*(FS2(K,I)+FS2(K+1,I))*RMASS(2)/ENMBAR(I) 111 CONTINUE C **** SHAPIRO SMOOTHER (ELIMINATED) DO 112 L=1,2 NPSK=NPSNM+(L-1)*KMAXP1+K-1 NPSNMK=NJ+NPSK DO 112 I=3,IMAXP2 WKV2(I,L)=F(I,NPSNMK)-C(26)*(F(I+2,NPSNMK)+F(I-2,NPSNMK)-4.* 1 (F(I+1,NPSNMK)+F(I-1,NPSNMK))+6.*F(I,NPSNMK)) 112 CONTINUE C **** COMPLETE CALCULATION OF RHS IN FK DO 12 L=1,2 DO 12 I=3,IMAXP2 FK(I,L)=EXPS(K)*(WKV2(I,L)*C(7)-FK(I,L)) 12 CONTINUE C **** INSERT PERIODIC POINTS DO 121 L = 1,2 DO 121 I = 1,2 FK(I,L) = FK(I+IMAX,L) FK(I+IMAXP2,L) = FK(I+2,L) 121 CONTINUE IF(K.EQ.1) GO TO 13 IF(K.EQ.KMAX) GO TO 14 GO TO 15 13 CONTINUE C **** LOWER BNDRY DO 16 L=1,2 DO 16 M=1,2 DO 16 KK=1,2 DO 16 I=1,LEN1 QK(I,L,M)=QK(I,L,M)+PK(I,L,KK)*B(KK,M) 16 CONTINUE DO 33 L=1,2 DO 33 M=1,2 DO 33 I=1,LEN1 FK(I,L)=FK(I,L)-PK(I,L,M)*FB(I,M) PK(I,L,M)=0. 33 CONTINUE GO TO 15 14 CONTINUE C **** UPPER BNDRY DO 17 L=1,2 DO 17 M=1,2 DO 17 I=1,LEN1 QK(I,L,M)=QK(I,L,M)+(1.+.5*EP(I,M,KP)*C(3))/(1.-.5* A EP(I,M,KP)*C(3))*RK(I,L,M) RK(I,L,M)=0. 17 CONTINUE 15 CONTINUE C **** QK=ALFAK=QK-PK*GAMA(K-1) DO 18 L=1,2 DO 18 M=1,2 DO 18 KK=1,2 DO 18 I=1,LEN1 QK(I,L,M)=QK(I,L,M)-PK(I,L,KK)*GAMA(I,K,KK,M) 18 CONTINUE C **** WKS1=DET(ALFA) DO 19 I=1,LEN1 WKS1(I)=QK(I,1,1)*QK(I,2,2)-QK(I,1,2)*QK(I,2,1) 19 CONTINUE C **** WKM1=ALFAI DO 20 L=1,2 LL=3-L DO 20 M=1,2 DO 20 I=1,LEN1 WKM1(I,L,M)=(DELTA(L,M)*QK(I,LL,LL)-(1.-DELTA(L,M))* A QK(I,L,M))/WKS1(I) 20 CONTINUE C **** GAMA(K+1)=ALFAI*RK C **** WKV1=FK-PK*Z(K) DO 21 L=1,2 DO 22 I=1,LEN1 WKV1(I,L)=FK(I,L) 22 CONTINUE DO 21 M=1,2 DO 23 I=1,LEN1 GAMA(I,K+1,L,M)=0. WKV1(I,L)=WKV1(I,L)-PK(I,L,M)*Z(I,K,M) 23 CONTINUE DO 21 KK=1,2 DO 21 I=1,LEN1 GAMA(I,K+1,L,M)=GAMA(I,K+1,L,M)+WKM1(I,L,KK)*RK(I,KK,M) 21 CONTINUE C **** Z(K+1)=WKM1*WKV1 DO 231 L=1,2 DO 232 I=1,LEN1 Z(I,K+1,L)=0. 232 CONTINUE DO 231 M=1,2 DO 231 I=1,LEN1 Z(I,K+1,L)=Z(I,K+1,L)+WKM1(I,L,M)*WKV1(I,M) 231 CONTINUE 6 CONTINUE C **** SET PSNP(KMAXP1) TO ZERO DO 24 L=1,2 NPSL=NJNP+NPS+(L-1)*KMAXP1+KMAX DO 24 I=1,LEN1 F(I,NPSL)=0. 24 CONTINUE C **** DOWNWARD SWEEP DO 25 KK=1,KMAX K=KMAX+1-KK DO 25 L=1,2 NPSL=NJNP+NPS+(L-1)*KMAXP1+(K-1) DO 26 I=1,LEN1 F(I,NPSL)=Z(I,K+1,L) 26 CONTINUE DO 25 M=1,2 NPSM=NJNP+NPS+(M-1)*KMAXP1+K DO 25 I=1,LEN1 F(I,NPSL)=F(I,NPSL)-GAMA(I,K+1,L,M)*F(I,NPSM) 25 CONTINUE C **** INSERT VALUE OF PS(KMAXP1) USING BNDRY CONDITION DO 27 L=1,2 NPSL=NJNP+NPS+(L-1)*KMAXP1+KMAX DO 27 I=1,LEN1 F(I,NPSL)=(1.+.5*EP(I,L,KP)*C(3))/(1.-.5*EP(I,L,KP)*C(3))* A F(I,NPSL-1) 27 CONTINUE C **** TIME SMOOTHING OF PSI NPSNMK=NJ+NPSNM-1 NPSK=NJ+NPS-1 NPSNPK=NJNP+NPS-1 NPSMNK=NJNP+NPSNM-1 DO 29 K = 1,2*KMAXP1 DO 29 I=1,LEN1 F(I,NPSMNK+K)=C(30)*F(I,NPSK+K)+C(31)*(F(I,NPSNMK+K)+ 1 F(I,NPSNPK+K)) 29 CONTINUE C **** INSERT PERIODIC POINTS K1=NJNP+NPS K2=K1+2*KMAXP1-1 DO 31 N=1,2 DO 32 I=1,2 DO 32 K=K1,K2 F(I,K)=F(I+IMAX,K) F(I+IMAXP2,K)=F(I+2,K) 32 CONTINUE K1=NJNP+NPSNM K2=K1+2*KMAXP1-1 31 CONTINUE C **** INSURE NON-NEGATIVE PSI NPS1K=NJNP+NPS-1 NPS2K=NJNP+NPS2-1 NPS1MK=NJNP+NPSNM-1 NPS2MK=NJNP+NPS2NM-1 DO 41 K=1,KMAXP1 DO 41 I=1,LEN1 F(I,NPS1K+K)=CVMGP(F(I,NPS1K+K),SMALL,F(I,NPS1K+K)-SMALL) F(I,NPS2K+K)=CVMGP(F(I,NPS2K+K),SMALL,F(I,NPS2K+K)-SMALL) F(I,NPS1MK+K)=CVMGP(F(I,NPS1MK+K),SMALL,F(I,NPS1MK+K)-SMALL) F(I,NPS2MK+K)=CVMGP(F(I,NPS2MK+K),SMALL,F(I,NPS2MK+K)-SMALL) F(I,NPS1K+K)=F(I,NPS1K+K)*CVMGP(1.,(1.-SMALL)/(F(I,NPS1K+K)+ 1 F(I,NPS2K+K)),1.-SMALL-F(I,NPS1K+K)-F(I,NPS2K+K)) F(I,NPS2K+K)=F(I,NPS2K+K)*CVMGP(1.,(1.-SMALL)/(F(I,NPS1K+K)+ 1 F(I,NPS2K+K)),1.-SMALL-F(I,NPS1K+K)-F(I,NPS2K+K)) F(I,NPS1MK+K)=F(I,NPS1MK+K)*CVMGP(1.,(1.-SMALL)/(F(I,NPS1MK+K)+ 1 F(I,NPS2MK+K)),1.-SMALL-F(I,NPS1MK+K)-F(I,NPS2MK+K)) F(I,NPS2MK+K)=F(I,NPS2MK+K)*CVMGP(1.,(1.-SMALL)/(F(I,NPS1MK+K)+ 1 F(I,NPS2MK+K)),1.-SMALL-F(I,NPS1MK+K)-F(I,NPS2MK+K)) 41 CONTINUE RETURN END CDIR$ NOLIST */ *DK FACE */ CDIR$ NOLIST SUBROUTINE FACE2(STEP,DS,SB,DX) SAVE C **** C **** INTERFACE C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CONS, CRATES, FIELDS, FIELDT, FLUX, C **** HOXSTUF, INDEX, INDEXDAT, NEWRAT, PSIB, SOURCE, VSCR3 C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA CRATES2 *CA DISSHOX2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA HOXSTUF2 *CA INDEX *CA INDEXDAT *CA NEWRAT2 *CA NOZNOZ2 *CA OXOXOX2 *CA PHOTO2 *CA PHOTOO2 *CA PSIB2 *CA RATEBLK2 *CA RJH2O2O2 *CA SOURCE2 *CA VSCR3 COMMON/SODIUMP/PNA(KMXP,IMXP),XLNA(KMXP,IMXP),XLBNA(IMXP) 1,PNAI(KMXP,IMXP),XLNAI(KMXP,IMXP),XLBNAI(IMXP) 2,RNAO(KMXP,IMXP),RNAO2(KMXP,IMXP),RNAOH(KMXP,IMXP) DIMENSION IFP(12) DIMENSION FM(IMXP),DH2OT(KMXP,IMXP) EQUIVALENCE (C(46),PS1B),(C(47),PS3B) DATA PS1B,PS3B/.22,.78/ DATA ISTAR/0/,PI/3.141592654/ IF(ISTAR.EQ.0)THEN C **** C **** SET INITIAL CONSTANTS C **** CONVERT NUMBER DENSITIES TO PSI'S C **** ISTAR=1 KMAX=KMX KMAXP1=KMAX+1 IMAX=IMX IMAXP2=IMAX+2 IMAXP4=IMAX+4 LEN1=IMXP LEN2=LEN1*KMAX LEN3=LEN1*KMAXP1 C **** SET DLAMDA DLAMDA=8.*ATAN(1.)/IMAX C(1)=DLAMDA C **** FINITE DIFFERENCE OPERATOR CONSTANTS C(10)=2./(3.*DLAMDA) C(11)=1./(12.*DLAMDA) C **** SHAPIRO SMOOTHER CONSTANT C C(26)=3.0E-2 C(26)=0. C **** TIME SMOOTHING CONSTANT ALPHA=.95 C(30)=ALPHA C(31)=.5*(1.-ALPHA) C **** B MATRIX C(40)=-1. C(41)=0. C(42)=0. C(43)=-1. C **** ATOMIC OXYGEN RECOMBINATION RATE C(44)=3.8E-30 C **** FB VECTOR DO 12 I = 1,LEN1 FB(I,1)=2*C(46) 12 CONTINUE C **** EARTHS RADIUS C C(51)=6.3 122E8 C(51)=IMX*DX/(2.*PI) C(52)=1./C(51) C(53)=C(51)*C(51) C **** ACCELERATION DU TO GRAVITY C(54)=870. C **** GAS CONSTANT C(57)=8.314E7 C **** P0 C(81)=5.E-4 C **** BOLTZMANN CONSTANT C(84)=1.38E-16 C **** AVOGRADO'S NUMBER C(85)=6.023E23 RMASS(1)=32. RMASS(2)=16. RMASS(3)=28. RMA=23. RMH=23. RMNO=30. RMN4S=14. RMCH4=16. RMH2=2. RMCO2=44. RMCO=28. RMH2O=18. RMHOX=1. C **** T0 DO 2 K=1,KMAXP1 T0(K)=0. 2 CONTINUE C **** C **** SET INITIAL PSI'S C **** C **** WK1=PSI1, WK2=PSI2, WK3=PSAR, WK4=PSHE, C **** WK5=PNO, WK6=PN4S, WK7=PCH4, WK8=PH2, C **** WK9=PCO2, WK10=PCO, WK11=PHOX, WK12=PH2O C **** DO 3 K=1,KMAXP1 DO 3 I=3,LEN1-1 FNNOZ(K,I)=FNNO(K,I)+FNNO2(K,I) WK1(K,I)=FNO2(K,I)*RMASS(1)+FNO(K,I)*RMASS(2)+FNN2(K,I)* 1 RMASS(3) WK2(K,I)=FNOX(K,I)*RMASS(2)/WK1(K,I) WK3(K,I)=FNAR(K,I)*RMA/WK1(K,I) WK4(K,I)=FNHE(K,I)*RMH/WK1(K,I) WK5(K,I)=FNNOZ(K,I)*RMNO/WK1(K,I) WK6(K,I)=FNN4S(K,I)*RMN4S/WK1(K,I) WK7(K,I)=FNCH4(K,I)*RMCH4/WK1(K,I) WK8(K,I)=FNH2(K,I)*RMH2/WK1(K,I) WK9(K,I)=FNCO2(K,I)*RMCO2/WK1(K,I) WK10(K,I)=FNCO(K,I)*RMCO/WK1(K,I) WK11(K,I)=FNHOX(K,I)*RMHOX/WK1(K,I) WK12(K,I)=FNH2O(K,I)*RMH2O/WK1(K,I) WK1(K,I)=FNO2(K,I)*RMASS(1)/WK1(K,I) 3 CONTINUE C **** C **** TRANSFER PSI'S TO F-ARRAY C **** NPS1K=NJ+NPS-1 NPS2K=NPS1K+KMAXP1 NPSAK=NJ+NPSA-1 NPSHK=NJ+NPSH-1 NPNOK=NJ+NPNO-1 NPN4SK=NJ+NPN4S-1 NPCH4K=NJ+NPCH4-1 NPH2K=NJ+NPH2-1 NPCO2K=NJ+NPCO2-1 NPCOK=NJ+NPCO-1 NPHOXK=NJ+NPHOX-1 NPH2OK=NJ+NPH2O-1 DO 4 K=1,KMAX DO 4 I=3,LEN1-1 F(I,NPS1K+K)=.5*(WK1(K,I)+WK1(K+1,I)) F(I,NPS2K+K)=.5*(WK2(K,I)+WK2(K+1,I)) F(I,NPSAK+K)=.5*(WK3(K,I)+WK3(K+1,I)) F(I,NPSHK+K)=.5*(WK4(K,I)+WK4(K+1,I)) F(I,NPNOK+K)=.5*(WK5(K,I)+WK5(K+1,I)) F(I,NPN4SK+K)=.5*(WK6(K,I)+WK6(K+1,I)) F(I,NPCH4K+K)=.5*(WK7(K,I)+WK7(K+1,I)) F(I,NPH2K+K)=.5*(WK8(K,I)+WK8(K+1,I)) F(I,NPCO2K+K)=.5*(WK9(K,I)+WK9(K+1,I)) F(I,NPCOK+K)=.5*(WK10(K,I)+WK10(K+1,I)) F(I,NPHOXK+K)=.5*(WK11(K,I)+WK11(K+1,I)) F(I,NPH2OK+K)=.5*(WK12(K,I)+WK12(K+1,I)) 4 CONTINUE C **** BOUNDARY DO 9 I = 3,LEN1-1 F(I,NPS1K+KMAXP1)=1.5*WK1(KMAXP1,I)-.5*WK1(KMAX,I) F(I,NPS2K+KMAXP1)=1.5*WK2(KMAXP1,I)-.5*WK2(KMAX,I) F(I,NPSAK+KMAXP1)=1.5*WK3(KMAXP1,I)-.5*WK3(KMAX,I) F(I,NPSHK+KMAXP1)=1.5*WK4(KMAXP1,I)-.5*WK4(KMAX,I) F(I,NPNOK+KMAXP1)=1.5*WK5(KMAXP1,I)-.5*WK5(KMAX,I) F(I,NPN4SK+KMAXP1)=1.5*WK6(KMAXP1,I)-.5*WK6(KMAX,I) F(I,NPCH4K+KMAXP1)=1.5*WK7(KMAXP1,I)-.5*WK7(KMAX,I) F(I,NPH2K+KMAXP1)=1.5*WK8(KMAXP1,I)-.5*WK8(KMAX,I) F(I,NPCO2K+KMAXP1)=1.5*WK9(KMAXP1,I)-.5*WK9(KMAX,I) F(I,NPCOK+KMAXP1)=1.5*WK10(KMAXP1,I)-.5*WK10(KMAX,I) F(I,NPHOXK+KMAXP1)=1.5*WK11(KMAXP1,I)-.5*WK11(KMAX,I) F(I,NPH2OK+KMAXP1)=1.5*WK12(KMAXP1,I)-.5*WK12(KMAX,I) F(I,NPS1K+KMAXP1)=1.5*WK1(KMAXP1,I)-.5*WK1(KMAX,I) F(I,NPS2K+KMAXP1)=1.5*WK2(KMAXP1,I)-.5*WK2(KMAX,I) F(I,NPSAK+KMAXP1)=1.5*WK3(KMAXP1,I)-.5*WK3(KMAX,I) F(I,NPSHK+KMAXP1)=1.5*WK4(KMAXP1,I)-.5*WK4(KMAX,I) F(I,NPNOK+KMAXP1)=1.5*WK5(KMAXP1,I)-.5*WK5(KMAX,I) F(I,NPN4SK+KMAXP1)=1.5*WK6(KMAXP1,I)-.5*WK6(KMAX,I) F(I,NPCH4K+KMAXP1)=1.5*WK7(KMAXP1,I)-.5*WK7(KMAX,I) F(I,NPH2K+KMAXP1)=1.5*WK8(KMAXP1,I)-.5*WK8(KMAX,I) F(I,NPCO2K+KMAXP1)=1.5*WK9(KMAXP1,I)-.5*WK9(KMAX,I) F(I,NPCOK+KMAXP1)=1.5*WK10(KMAXP1,I)-.5*WK10(KMAX,I) F(I,NPHOXK+KMAXP1)=1.5*WK11(KMAXP1,I)-.5*WK11(KMAX,I) F(I,NPH2OK+KMAXP1)=1.5*WK12(KMAXP1,I)-.5*WK12(KMAX,I) 9 CONTINUE C **** C **** PERIODIC POINTS C **** NPSK = NJ+NPS-1 DO 16 I=1,2 DO 16 K=1,12*KMAXP1 F(I,NPSK+K) = F(I+IMAX,NPSK+K) F(I+IMAXP2,NPSK+K) = F(I+2,NPSK+K) 16 CONTINUE IFP(1) = NPS IFP(2) = NPS2 IFP(3) = NPSA IFP(4) = NPSH IFP(5) = NPNO IFP(6) = NPN4S IFP(7) = NPCH4 IFP(8) = NPH2 IFP(9) = NPCO2 IFP(10) = NPCO IFP(11) = NPHOX IFP(12) = NPH2O C CALL PLOT(IFP,12,NJ) C **** C **** COPY CURRENT FIELDS TO NM ARRAYS C **** NPSK = NJ+NPS-1 NPSNMK = NJ+NPSNM-1 DO 14 K = 1,12*KMAXP1 DO 14 I = 1,LEN1 F(I,NPSNMK+K) = F(I,NPSK+K) 14 CONTINUE IFP(1) = NPSNM IFP(2) = NPS2NM IFP(3) = NPSANM IFP(4) = NPSHNM IFP(5) = NPNONM IFP(6) = NN4SNM IFP(7) = NCH4NM IFP(8) = NPH2NM IFP(9) = NCO2NM IFP(10) = NPCONM IFP(11) = NHOXNM IFP(12) = NH2ONM C CALL PLOT(IFP,12,NJ) ENDIF C(3)=DS C(7)=1./STEP C **** EXP(-.5*DS) C(86)=EXP(-.5*DS) C **** EXP(.5*DS) C(87)=1./C(86) C **** EXPS, DIFK S=SB+.5*DS EXPS(1)=EXP(-S) EXPDS=EXP(-DS) DO 1 K=2,KMAXP1 EXPS(K)=EXPS(K-1)*EXPDS 1 CONTINUE DO 15 K = 1,KMAXP1 DO 15 I = 3,LEN1-2 DIFK(I,K) = FDIFK(K,I) 15 CONTINUE C **** C **** PERIODIC POINTS FOR T, U, W, RJ, PS2B, DIFK C **** DO 17 I = 1,2 PS2B(I) = PS2B(I+IMAX) PS2B(I+IMAXP2) = PS2B(I+2) DO 17 K = 1,KMAXP1 DIFK(I,K) = DIFK(I+IMAX,K) DIFK(I+IMAXP2,K) = DIFK(I+2,K) FT(K,I) = FT(K,I+IMAX) FT(K,I+IMAXP2) = FT(K,I+2) FUI(K,I) = FUI(K,I+IMAX) FU(K,I) = FU(K,I+IMAX) FUI(K,I+IMAXP2) = FUI(K,I+2) FU(K,I+IMAXP2) = FU(K,I+2) FW(K,I) = FW(K,I+IMAX) FWI(K,I) = FWI(K,I+IMAX) FW(K,I+IMAXP2) = FW(K,I+2) FWI(K,I+IMAXP2) = FWI(K,I+2) FRJ(K,I) = FRJ(K,I+IMAX) FRJ(K,I+IMAXP2) = FRJ(K,I+2) 17 CONTINUE C **** C **** PERIODIC POINTS FOR SOURCE TERMS C **** C CALL CHKBLKS DO 18 I = 1,2 DO 18 K =1,KMAXP1 FS11(K,I) = FS11(K,I+IMAX) FS11(K,I+IMAXP2) = FS11(K,I+2) FS12(K,I) = FS12(K,I+IMAX) FS12(K,I+IMAXP2) = FS12(K,I+2) FS21(K,I) = FS21(K,I+IMAX) FS21(K,I+IMAXP2) = FS21(K,I+2) FS22(K,I) = FS22(K,I+IMAX) FS22(K,I+IMAXP2) = FS22(K,I+2) FS1(K,I) = FS1(K,I+IMAX) FS1(K,I+IMAXP2) = FS1(K,I+2) FS2(K,I) = FS2(K,I+IMAX) FS2(K,I+IMAXP2) = FS2(K,I+2) 18 CONTINUE C CALL CHKBLKS C **** C **** PERIODIC POINTS RATE COEFFICIENTS C **** DO 19 I = 1,2 DO 20 N = 1,25 DO 20 K = 1,KMAXP1 RKK(N,K,I) = RKK(N,K,I+IMAX) RKK(N,K,I+IMAXP2) = RKK(N,K,I+2) 20 CONTINUE DO 21 N = 1,10 DO 21 K = 1,KMAXP1 ALPP(N,K,I) = ALPP(N,K,I+IMAX) ALPP(N,K,I+IMAXP2) = ALPP(N,K,I+2) 21 CONTINUE DO 22 N = 1,20 DO 22 K = 1,KMAXP1 RBB(N,K,I) = RBB(N,K,I+IMAX) RBB(N,K,I+IMAXP2) = RBB(N,K,I+2) 22 CONTINUE DO 23 N = 1,50 DO 23 K = 1,KMAXP1 RKMM(N,K,I) = RKMM(N,K,I+IMAX) RKMM(N,K,I+IMAXP2) = RKMM(N,K,I+2) 23 CONTINUE DO 24 K = 1,KMAXP1 RK12(K,I) = RK12(K,I+IMAX) RK12(K,I+IMAXP2) = RK12(K,I+2) RK13(K,I) = RK13(K,I+IMAX) RK13(K,I+IMAXP2) = RK13(K,I+2) RK14(K,I) = RK14(K,I+IMAX) RK14(K,I+IMAXP2) = RK14(K,I+2) RK15(K,I) = RK15(K,I+IMAX) RK15(K,I+IMAXP2) = RK15(K,I+2) 24 CONTINUE 19 CONTINUE C **** C **** NTRANSFER T AND U C **** N NTK=NJ+NT-1 NUK=NJ+NU-1 DO 5 K=1,KMAX DO 5 I=1,LEN1 F(I,NTK+K)=.5*(FT(K,I)+FT(K+1,I)) F(I,NUK+K)=.5*(FU(K,I)+FU(K+1,I)) 5 CONTINUE C **** BOUNDARY DO 10 I = 1,LEN1 F(I,NTK+KMAXP1)=FT(1,I) F(I,NUK+KMAXP1)=FU(1,I) 10 CONTINUE C **** C **** TRANSFER W AND RJ C **** NWK=NJ+NW-1 NRJK=NDJ+NRJ-1 DO 6 K=1,KMAXP1 DO 6 I=1,LEN1 F(I,NWK+K)=FW(K,I) F(I,NRJK+K)=FRJ(K,I) 6 CONTINUE C **** C **** UPDATE PSI'S C **** C CALL CHKBLKS CALL RATES(FT) C CALL CHKBLKS C **** C **** LOWER BOUNDARY CONDITION C **** DO 11 I = 1,LEN1 C ENMBAR(I)=C(81)*EXPS(1)*C(87)/((PS1B/RMASS(1)+PS3B/RMASS(3))* C 1 C(84)*FT(1,I)) C AA(I)=ENMBAR(I)**3*(2.*RK12(1,I)*(PS1B/RMASS(1)+PS3B/RMASS(3))+ C 1 RK13(1,I)*PS1B/RMASS(1)-RK15(1,I)*RMASS(2)*PS1B/(RMASS(3)* C 2 RMASS(1))) C BB(I)=ENMBAR(I)*(ENMBAR(I)**2*(RK14(1,I)*(PS1B/RMASS(1))**2+ C 1 RK15(1,I)*(PS1B/RMASS(1))*(1.-PS1B)/RMASS(3))-FS22(1,I)) C CC(I)=-FS21(1,I)*ENMBAR(I)*PS1B/RMASS(1)-FS2(1,I) C PS2B(I)=RMASS(2)*(-BB(I)+SQRT(BB(I)**2-4.*AA(I)*CC(I)))/(2.* C 1 AA(I)) FB(I,2)=PS2B(I) 11 CONTINUE C II=1 C WRITE(6,101)II C 101 FORMAT(* HI*I1) C CALL CHKBLKS CALL COMP C CALL CHKBLKS CALL PHOTO C CALL CHKBLKS CALL CMPN2D C CALL CHKBLKS CALL CMPN4S C CALL CHKBLKS CALL COMPNO C CALL CHKBLKS CALL COMPARG C CALL CHKBLKS C CALL COMPHE C CALL CHKBLKS CALL COMPCH4 C CALL CHKBLKS CALL COMPH2 C CALL CHKBLKS CALL COMPCO2 C CALL CHKBLKS CALL COMPCO C CALL CHKBLKS CALL COMPHOX C CALL CHKBLKS CALL COMPH2O C CALL CHKBLKS C **** C **** NTRANSFER UI C **** N NUK=NJ+NU-1 DO 55 K=1,KMAX DO 55 I=1,LEN1 F(I,NUK+K)=.5*(FUI(K,I)+FUI(K+1,I)) 55 CONTINUE C **** BOUNDARY DO 67 I = 1,LEN1 F(I,NUK+KMAXP1)=FUI(1,I) 67 CONTINUE C **** C **** TRANSFER WI C **** NWK=NJ+NW-1 DO 66 K=1,KMAXP1 DO 66 I=1,LEN1 F(I,NWK+K)=FWI(K,I) 66 CONTINUE CALL COMPHE IFP(1) = NPS IFP(2) = NPS2 IFP(3) = NPSA IFP(4) = NPSH IFP(5) = NPNO IFP(6) = NPN4S IFP(7) = NPCH4 IFP(8) = NPH2 IFP(9) = NPCO2 IFP(10) = NPCO IFP(11) = NPHOX IFP(12) = NPH2O C CALL PLOT(IFP,12,NJNP) C WRITE(6,1000)PNOB,PN4SB C1000 FORMAT(* PNOB, PN4SB *,2E13.4) C **** C **** CONVERT PSI'S TO NUMBER DENSITIES C **** C **** WK1=INTERPOLATED PSI1, WK2=INTERPOLATED PSI2 C **** WK3=INTERPOLATED PSAR, WK4=INTERPOLATED PSHE C **** WK5=INTERPOLATED PSNO, WK6=INTERPOLATED PSN4S C **** WK7=INTERPOLATED PSCH4, WK8=INTERPOLATED PSH2 C **** WK9=INTERPOLATED PSCO2, WK10=INTERPOLATED PSCO C **** WK11=INTERPOLATED PSHOX, WK12=INTERPOLATED PSH2O C **** NPS1K=NJNP+NPS-1 NPS2K=NPS1K+KMAXP1 NPSAK=NJNP+NPSA-1 NPSHK=NJNP+NPSH-1 NPNOK=NJNP+NPNO-1 NPN4SK=NJNP+NPN4S-1 NPCH4K=NJNP+NPCH4-1 NPH2K=NJNP+NPH2-1 NPCO2K=NJNP+NPCO2-1 NPCOK=NJNP+NPCO-1 NPHOXK=NJNP+NPHOX-1 NPH2OK=NJNP+NPH2O-1 DO 7 K=1,KMAX DO 7 I=1,LEN1 WK1(K+1,I)=.5*(F(I,NPS1K+K)+F(I,NPS1K+K+1)) WK2(K+1,I)=.5*(F(I,NPS2K+K)+F(I,NPS2K+K+1)) WK3(K+1,I)=.5*(F(I,NPSAK+K)+F(I,NPSAK+K+1)) WK4(K+1,I)=.5*(F(I,NPSHK+K)+F(I,NPSHK+K+1)) WK5(K+1,I)=.5*(F(I,NPNOK+K)+F(I,NPNOK+K+1)) WK6(K+1,I)=.5*(F(I,NPN4SK+K)+F(I,NPN4SK+K+1)) WK7(K+1,I)=.5*(F(I,NPCH4K+K)+F(I,NPCH4K+K+1)) WK8(K+1,I)=.5*(F(I,NPH2K+K)+F(I,NPH2K+K+1)) WK9(K+1,I)=.5*(F(I,NPCO2K+K)+F(I,NPCO2K+K+1)) WK10(K+1,I)=.5*(F(I,NPCOK+K)+F(I,NPCOK+K+1)) WK11(K+1,I)=.5*(F(I,NPHOXK+K)+F(I,NPHOXK+K+1)) WK12(K+1,I)=.5*(F(I,NPH2OK+K)+F(I,NPH2OK+K+1)) 7 CONTINUE C **** LOWER BOUNDARY DO 13 I = 1,LEN1 WK1(1,I)=PS1B WK2(1,I)=PS2B(I) WK3(1,I)=.5*(F(1,NPSAK+1)+PARB(I)) WK4(1,I)=.5*(F(1,NPSHK+1)+PHB(I)) WK5(1,I)=.5*(F(1,NPNOK+1)+PNOB(I)) WK6(1,I)=.5*(F(1,NPN4SK+1)+PN4SB(I)) WK7(1,I)=.5*(F(1,NPCH4K+1)+PCH4B(I)) WK8(1,I)=.5*(F(1,NPH2K+1)+PH2B(I)) WK9(1,I)=.5*(F(1,NPCO2K+1)+PCO2B(I)) WK10(1,I)=.5*(F(1,NPCOK+1)+PCOB(I)) WK11(1,I)=.5*(F(1,NPHOXK+1)+PHOXB(I)) WK12(1,I)=.5*(F(1,NPH2OK+1)+PH2OB(I)) 13 CONTINUE C **** C **** CONVERT TO NUMBER DENSITIES C **** C **** WK5=MBAR*P0*EXPS/(R*T) DO 8 K=1,KMAXP1 DO 8 I=3,LEN1-1 WK13(K,I)=C(81)*EXPS(K)*C(87)/(C(84)*FT(K,I)*(WK1(K,I)/ 1 RMASS(1)+WK2(K,I)/RMASS(2)+(1.-WK1(K,I)-WK2(K,I))/RMASS(3))) FNO2(K,I)=WK1(K,I)*WK13(K,I)/RMASS(1) FNOX(K,I)=WK2(K,I)*WK13(K,I)/RMASS(2) FNO(K,I)=OOXR(K,I)*FNOX(K,I) FNO3(K,I)=O3OR(K,I)*FNO(K,I) FNN2(K,I)=(1.-WK1(K,I)-WK2(K,I))*WK13(K,I)/RMASS(3) FM(I)=FNO(K,I)+FNO2(K,I)+FNN2(K,I) FNAR(K,I)=WK3(K,I)*WK13(K,I)/RMA C FNAS(K,I)=FNAR(K,I)/(1.+RNAO(K,I)+RNAO2(K,I)+RNAOH(K,I)) C FNAO(K,I)=FNAS(K,I)*RNAO(K,I) C FNAO2(K,I)=FNAS(K,I)*RNAO2(K,I) C FNAOH(K,I)=FNAS(K,I)*RNAOH(K,I) FNHE(K,I)=WK4(K,I)*WK13(K,I)/RMH FNNOZ(K,I)=WK5(K,I)*WK13(K,I)/RMNO FNNO(K,I)=RNONOZ(K,I)*FNNOZ(K,I) FNNO2(K,I)=SNO2NO(K,I)*FNNO(K,I) FNN4S(K,I)=WK6(K,I)*WK13(K,I)/RMN4S FNCH4(K,I)=WK7(K,I)*WK13(K,I)/RMCH4 FNH2(K,I)=WK8(K,I)*WK13(K,I)/RMH2 FNCO2(K,I)=WK9(K,I)*WK13(K,I)/RMCO2 FNCO(K,I)=WK10(K,I)*WK13(K,I)/RMCO FNHOX(K,I)=WK11(K,I)*WK13(K,I)/RMHOX FNH2O(K,I)=WK12(K,I)*WK13(K,I)/RMH2O HO2HR(K,I)=RKMM(28,K,I)*FM(I)*FNO2(K,I)/(RKMM(18,K,I)* 1 FNO(K,I)+RBB(12,K,I)*FNNO(K,I)+RKMM(26,K,I)*FNO3(K,I)) OHHR(K,I)=((RKMM(18,K,I)*FNO(K,I)*RKMM(28,K,I)*FNO2(K,I)* 1 FM(I))/(RKMM(18,K,I)*FNO(K,I)+RKMM(26,K,I)*FNO3(K,I)+ 2 RBB(12,K,I)*FNNO(K,I))+RKMM(29,K,I)*FNO3(K,I))/ 3 (RKMM(17,K,I)*FNO(K,I)+RKMM(21,K,I)*FNO3(K,I)) HHOXR(K,I)=1./(1.+HO2HR(K,I)+OHHR(K,I)) FNH(K,I)=HHOXR(K,I)*FNHOX(K,I) FNHO2(K,I)=HO2HR(K,I)*FNH(K,I) FNOH(K,I)=OHHR(K,I)*FNH(K,I) DH2OT(K,I)=SH2OSRC(K,I)+SH2OSRB(K,I)+.88*SH2OLYA(K,I)+ 1 SH2OEUV(K,I) C FNH2O2(K,I)=RKMM(27,K,I)*FNHO2(K,I)*FNHO2(K,I)/(RJH2O2(K,I) C 1 +RKMM(19,K,I)*FNO(K,I)+RKMM(24,K,I)*FNOH(K,I)) FNH2O2(K,I)=1.E-20 8 CONTINUE C***************************** C CALL CONREC(FNO2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNOX(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNO(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNO3(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNN2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNAR(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNHE(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNNOZ(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNNO(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNNO2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNN4S(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNCH4(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNH2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNCO2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNCO(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNHOX(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNH2O(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(HO2HR(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(OHHR(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(HHOXR(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNH(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNHO2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNOH(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(DH2OT(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNH2O2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C***************************** C **** C **** FLIP BUFFER INDICES C **** ITEMP = NJ NJ = NJNP NJNP = ITEMP RETURN END CDIR$ NOLIST */ *DK ADVECL */ CDIR$ NOLIST SUBROUTINE ADVECL(NX,S,K) SAVE *CA PARAMS *CA ASAS2 *CA CONS2 *CA INDEX DIMENSION S(IMXP) NUK=NJ+NU+(K-1) NXK=NJ+NX+(K-1) DO 1 I=3,IMAXP2 S(I)=.5*C(52)*(C(10)*(F(I+1,NXK)-F(I-1,NXK))*(F(I+1,NUK)+F(I-1, ANUK))-C(11)*(F(I+2,NXK)-F(I-2,NXK))*(F(I+2,NUK)+F(I-2,NUK))) 1 CONTINUE RETURN END */ *DK CMPN2D */ SUBROUTINE CMPN2D SAVE C **** C **** CALCULATE N(N2D) ASSUMING PHOTOCHEMICAL EQUILIBRIUM C **** C **** COMMON BLOCKS NEEDED: C **** PARAMS, CONS, FIELDS, FIELDT, FLUX, OPION, RATEBLK C **** *CA PARAMS *CA CONS2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA NOZNOZ2 *CA OPION2 *CA RATEBLK2 DO 1 K=1,KMAXP1 DO 1 I=3,LEN1-2 FNN2D(K,I)=PPN2D(K,I)/(RBB(2,K,I)*FNO2(K,I)+RBB(4,K,I)* 1 FNO(K,I)+RBB(5,K,I)*FNE(K,I)+RBB(6,K,I)*FNNO(K,I)+RBB(7,K,I) 2 +FIOP(K,I)) FNNOZ(K,I)=FNNO(K,I)+FNNO2(K,I) SNO2NO(K,I)=(RBB(12,K,I)*FNHO2(K,I)+RBB(11,K,I)*FNO3(K,I)) 1 /(RBB(14,K,I)+RBB(13,K,I)*FNO(K,I)+RBB(15,K,I)*FNO3(K,I)) RNONOZ(K,I)=1./(1.+SNO2NO(K,I)) 1 CONTINUE C **** C **** PERIODIC POINTS C **** DO 2 I = 1,2 DO 2 K = 1,KMAXP1 FNN2D(K,I) = FNN2D(K,I+IMAX) FNN2D(K,I+IMAXP2) = FNN2D(K,I+2) FNNOZ(K,I) = FNNOZ(K,I+IMAX) FNNOZ(K,I+IMAXP2) = FNNOZ(K,I+2) SNO2NO(K,I) = SNO2NO(K,I+IMAX) SNO2NO(K,I+IMAXP2) = SNO2NO(K,I+2) RNONOZ(K,I) = RNONOZ(K,I+IMAX) RNONOZ(K,I+IMAXP2) = RNONOZ(K,I+2) 2 CONTINUE RETURN END */ *DK COMPCH4 */ SUBROUTINE COMPCH4 SAVE C **** C **** ADVANCE CH4 COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CH4H2COF, CONS, FIELDS, FIELDT, FLUX, C **** INDEX, PHOTO, PSIB, RATEBLKL, VSCR C **** *CA PARAMS *CA ASAS2 *CA CH4H2CO2 *CA CONS2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA INDEX *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA VSCR DIMENSION PHICH4(3) DATA RMCH4,PHICH4/16.,0.921,0.846,1.077/ C **** C **** UPPER BOUNDARY: DIFFUSIVE EQUILIBRIUM C **** DO 1 I=1,LEN1 T4(I)=0. 1 CONTINUE C **** C **** SOURCES C **** DO 2 K=1,KMAXP1 DO 2 I=3,LEN1-2 S1(I,K)=-(RJCH4(K,I)+RKMM(35,K,I)*FNOH(K,I)+RKMM(36,K,I)* 1 FNO(K,I)+RKMM(37,K,I)*FNO1D(K,I)) S2(I,K)=0. 2 CONTINUE C **** DENSITY SPECIFIED AT LOWER BOUNDARY DO 4 I=3,LEN1-2 T1(I)=0. T2(I)=1. T3(I)=-XCH4(I)*RMCH4/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 4 CONTINUE C **** C **** PERIODIC POINTS C **** DO 3 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 3 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 3 CONTINUE IBNDB=0 IBND=0 ALFA=0. CALL MINOR(NPCH4,NCH4NM,RMCH4,PHICH4,ALFA,IBND,IBNDB,PCH4B) RETURN END */ *DK COMPCO */ SUBROUTINE COMPCO SAVE C **** C **** ADVANCE CO COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CH4H2COF, CONS, FIELDS, FIELDT, FLUX, C **** INDEX, PHOTO, PSIB, RATEBLK, VSCR C **** *CA PARAMS *CA ASAS2 *CA CH4H2CO2 *CA CONS2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA INDEX *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA VSCR DIMENSION PHICO(3) DATA RMCO,PHICO/28.,0.833,1.427,0.852/ C **** C **** UPPER BOUNDARY: DIFFUSIVE EQUILIBRIUM C **** DO 1 I=1,LEN1 T4(I)=0. 1 CONTINUE C **** C **** SOURCES C **** DO 2 K=1,KMAXP1 DO 2 I=3,LEN1-2 S1(I,K)=-(RKMM(40,K,I)*FNO(K,I)*(FNO(K,I)+FNO2(K,I)+FNN2(K,I)) 1 +RKMM(41,K,I)*FNOH(K,I)) S2(I,K)=RKCO2P(K,I)*FNCO2(K,I)+(RKMM(35,K,I)*FNOH(K,I) 1 +RKMM(36,K,I)*FNO(K,I)+RKMM(37,K,I)*FNO1D(K,I))*FNCH4(K,I)+ 2 SCOI(K,I) 2 CONTINUE C **** IF IBNDCO = 0, FLUX GIVEN AT LOWER BOUNDARY IF(IBNDCO.EQ.0)THEN DO 3 I=3,LEN1-2 T1(I)=0. T2(I)=0. T3(I)=FLUXCO(I) 3 CONTINUE IBNDB=1 C **** IF IBNDCO = 1, PHOTOCHEMICAL EQUILIBRIUM AT LOWER C **** BOUNDARY ELSE IF(IBNDCO.EQ.1)THEN DO 4 I=3,LEN1-2 T1(I)=0. T2(I)=1. T3(I)=-XCO(I)*RMCO/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 4 CONTINUE C **** C **** PERIODIC POINTS C **** DO 5 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 5 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 5 CONTINUE IBNDB=0 ENDIF IBND=0 ALFA=0. CALL MINOR(NPCO,NPCONM,RMCO,PHICO,ALFA,IBND,IBNDB,PCOB) RETURN END */ *DK COMPCO2 */ SUBROUTINE COMPCO2 SAVE C **** C **** ADVANCE CO2 COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CH4H2COF, CONS, FIELDS, FIELDT, FLUX, C **** INDEX, PHOTO, PSIB, RATEBLK, VSCR C **** *CA PARAMS *CA ASAS2 *CA CH4H2CO2 *CA CONS2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA INDEX *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA VSCR DIMENSION PHICO2(3) DATA RMCO2,PHICO2/44.,1.199,3.91,1.201/ C **** C **** UPPER BOUNDARY: DIFFUSIVE EQUILIBRIUM C **** DO 1 I=1,LEN1 T4(I)=0. 1 CONTINUE C **** C **** SOURCES C **** DO 2 K=1,KMAXP1 DO 2 I=3,IMAXP4-2 S1(I,K)=-(RJCO2T(K,I)+RSKIONS(K,I)) S2(I,K)=RKMM(40,K,I)*FNCO(K,I)*FNO(K,I)*(FNO(K,I)+FNO2(K,I)+ 1 FNN2(K,I))+RKMM(41,K,I)*FNCO(K,I)*FNOH(K,I)+SCO2I(K,I) 2 CONTINUE C **** DENSITY SPECIFIED AT LOWER BOUNDARY DO 4 I=3,LEN1-2 T1(I)=0. T2(I)=1. T3(I)=-XCO2(I)*RMCO2/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 4 CONTINUE C **** C **** PERIODIC POINTS C **** DO 3 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 3 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 3 CONTINUE IBNDB=0 IBND=0 ALFA=0. CALL MINOR(NPCO2,NCO2NM,RMCO2,PHICO2,ALFA,IBND,IBNDB,PCO2B) RETURN END */ *DK COMPH2 */ SUBROUTINE COMPH2 SAVE C **** C **** ADVANCE H2 COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CH4H2COF, CONS, FIELDS, FIELDT, FLUX, C **** H2FORG, INDEX, PHOTO, PSIB, RATEBLK, VSCR C **** *CA PARAMS *CA ASAS2 *CA CH4H2CO2 *CA CONS2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA H2FORG2 *CA INDEX *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA VSCR DIMENSION PHIH2(3) DATA RMH2,PHIH2/2.,0.226,0.321,0.282/ C **** C **** UPPER BOUNDARY: DIFFUSIVE EQUILIBRIUM C **** DO 1 I=1,LEN1 T4(I)=0. 1 CONTINUE C **** C **** SOURCES C **** DO 2 K=1,KMAXP1 DO 2 I=3,IMAXP4-2 S1(I,K)=-(RKMM(11,K,I)*FNO1D(K,I)+RKMM(20,K,I)*FNO(K,I)+ 1 RKMM(25,K,I)*FNOH(K,I)+FK9OP(K,I)) S2(I,K)=0.12*RJH2OLY(K,I)*FNH2O(K,I)+RKMM(30,K,I)*FNH(K,I)* 1 FNHO2(K,I)+RKMM(33,K,I)* 2 FNH(K,I)*FNH(K,I)*(FNO(K,I)+FNO2(K,I)+FNN2(K,I))+RJCH4(K,I)* 3 FNCH4(K,I) 2 CONTINUE C **** DENSITY SPECIFIED AT LOWER BOUNDARY DO 4 I=3,LEN1-2 T1(I)=0. T2(I)=1. T3(I)=-XH2(I)*RMH2/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 4 CONTINUE C **** C **** PERIODIC POINTS C **** DO 3 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 3 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 3 CONTINUE IBNDB=0 IBND=0 ALFA=0. CALL MINOR(NPH2,NPH2NM,RMH2,PHIH2,ALFA,IBND,IBNDB,PH2B) RETURN END */ *DK COMPH2O */ SUBROUTINE COMPH2O SAVE C **** C **** ADVANCE H2O COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CONS, DISSHOX, FIELDS, FIELDT, FLUX, C **** INDEX, IONHOX, PHOTO, PSIB, RATEBLK, VSCR C **** C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA DISSHOX2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA INDEX *CA IONHOX2 *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA VSCR DIMENSION PHIH2O(3) DATA RMH2O,PHIH2O/18.,0.817,0.922,0.920/ C **** C **** UPPER BOUNDARY: DIFFUSIVE EQUILIBRIUM C **** DO 1 I=1,LEN1 T4(I)=0. 1 CONTINUE C **** C **** SOURCES C **** DO 2 K=1,KMAXP1 DO 2 I=3,LEN1-1 S1(I,K)=-(SH2OSRB(K,I)+SH2OSRC(K,I)+SH2OLYA(K,I)+SH2OEUV(K,I) 1 +RKMM(10,K,I)*FNO1D(K,I)+RKK(10,K,I)*YIOP(K,I)+RKMM(42,K,I)* 2 FNO(K,I)) S2(I,K)=RKMM(22,K,I)*FNOH(K,I)*FNOH(K,I)+RKMM(23,K,I)* 1 FNOH(K,I)*FNHO2(K,I)+RKMM(24,K,I)*FNOH(K,I)*FNH2O2(K,I)+ 2 RKMM(25,K,I)*FNOH(K,I)*FNH2(K,I)+RKMM(32,K,I)*FNH(K,I)* 3 FNHO2(K,I)+(2.*RKMM(35,K,I)*FNOH(K,I)+RKMM(36,K,I)*FNO(K,I)+ 4 RKMM(37,K,I)*FNO1D(K,I))*FNCH4(K,I)-PHOXIC(K,I)*0.5 2 CONTINUE C **** DENSITY SPECIFIED AT LOWER BOUNDAR DO 4 I=3,LEN1-2 T1(I)=0. T2(I)=1. T3(I)=-XH2O(I)*RMH2O/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 4 CONTINUE C **** C **** PERIODIC POINTS C **** DO 3 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 3 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 3 CONTINUE C CALL CONREC(SH2OSRB(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(SH2OSRC(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(SH2OLYA(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(SH2OEUV(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNO1D(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(YIOP(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNO(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNOH(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNHO2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNH2O2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNH2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNH(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNCH4(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(PHOXIC(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNO2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNN2(1,3),KMAXP1,KMAXP1,IMAX+1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S1,LEN1,LEN1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S2,LEN1,LEN1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME DO 5 I = 3,IMAX+3 DO 5 K = 1,KMAXP1 S3(I,K) = RKK(10,K,I) S4(I,K) = RKMM(10,K,I) S5(I,K) = RKMM(22,K,I) S6(I,K) = RKMM(23,K,I) S7(I,K) = RKMM(24,K,I) S8(I,K) = RKMM(25,K,I) S9(I,K) = RKMM(32,K,I) S10(I,K) = RKMM(35,K,I) S11(I,K) = RKMM(36,K,I) S12(I,K) = RKMM(37,K,I) S13(I,K) = RKMM(42,K,I) 5 CONTINUE C CALL CONREC(S3(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S4(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S5(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S6(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S7(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S8(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S9(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S10(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S11(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S12(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(S13(3,1),LEN1,IMAX+1,KMAXP1,0.,0.,0.,0,0,-1430B) C CALL FRAME C WRITE(6,2345)(T3(I),XH2O(I),I=1,LEN1) C2345 FORMAT(2E15.4) IBNDB=0 IBND=0 ALFA=0. CALL MINOR(NPH2O,NH2ONM,RMH2O,PHIH2O,ALFA,IBND,IBNDB,PH2OB) RETURN END */ *DK COMPHE */ SUBROUTINE COMPHE SAVE C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CONS, FIELDS, HEFLUX, INDEX, PHOTOO, C **** PSIB, VSCR C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA FIELDS2 *CA HEFLUX2 *CA INDEX *CA PHOTOO2 *CA PSIB2 *CA VSCR COMMON/SODIUMP/PNA(KMXP,IMXP),XLNA(KMXP,IMXP),XLBNA(IMXP) 1,PNAI(KMXP,IMXP),XLNAI(KMXP,IMXP),XLBNAI(IMXP) 2,RNAO(KMXP,IMXP),RNAO2(KMXP,IMXP),RNAOH(KMXP,IMXP) DIMENSION PHIH(3) DIMENSION FMM(IMXP) C DATA RMH,PHIH,ALFAH,PSHB/23.,.270,.404,.322,-0.38,0.73E-6/ DATA RMH,PHIH,ALFAH,PSHB/23.,1.042,1.509,1.176,0.17,0.131E-1/ C **** UPPER BOUNDARY CONDITION C **** T4=TOTAL FLUX AT UPPER BOUNDARY DO 10 I=3,LEN1-2 FMM(I)=FNO(1,I)*16.+FNO2(1,I)*32.+FNN2(1,I)*28. T4(I) =0. T1(I)=0. T2(I)=1. T3(I)=-XLBNAI(I)*RMH/FMM(I) 10 CONTINUE C DO 10 I=3,LEN1-2 C FMM(I)=FNO(1,I)*16.+FNO2(1,I)*32.+FNN2(1,I)*28. C T4(I) = FLUX(I) C 10 CONTINUE C **** LOWER BOUNDARY CONDITION - CONSTANT VALUE C DO 4 I=3,LEN1-2 C T1(I)=0. C T2(I)=1. C T3(I)=-XHE(I)*RMH/FMM(I) C 4 CONTINUE C **** SOURCES ARE ZERO DO 5 K=1,KMAXP1 DO 5 I=3,IMAXP4-2 S1(I,K)=-XLNAI(K,I) S2(I,K)=PNAI(K,I) 5 CONTINUE C **** C **** PERIODIC POINTS C **** DO 3 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) 3 CONTINUE IBND=0 IBNDB=0 CALL MINOR(NPSH,NPSHNM,RMH,PHIH,ALFAH,IBND,IBNDB,PHB) RETURN END */ *DK COMPARG */ SUBROUTINE COMPARG SAVE C **** ADVANCE AR COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS,ASAS,CONS,FIELDS,INDEX,PHOTOO,PSIB,VSCR C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA FIELDS2 *CA INDEX *CA PHOTOO2 *CA PSIB2 *CA VSCR COMMON/SODIUMP/PNA(KMXP,IMXP),XLNA(KMXP,IMXP),XLBNA(IMXP) 1,PNAI(KMXP,IMXP),XLNAI(KMXP,IMXP),XLBNAI(IMXP) 2,RNAO(KMXP,IMXP),RNAO2(KMXP,IMXP),RNAOH(KMXP,IMXP) DIMENSION PHIA(3) DIMENSION FMM(IMXP) DATA RMA,PHIA,ALFAA,PSAB/23.,1.042,1.509,1.176,0.17,0.131E-1/ C **** UPPER BOUNDARY - ZERO DIFFUSIVE FLUX C **** LOWER BOUNDARY - CONSTANT VALUE DO 1 I=3,LEN1-2 FMM(I)=FNO(1,I)*16.+FNO2(1,I)*32.+FNN2(1,I)*28. T4(I)=0. T1(I)=0 T2(I)=1. T3(I)=-XLBNA(I)*RMA/FMM(I) 1 CONTINUE IBNDB=0 C LOWER BOUNDARY FLUX CONDITION C FLUXNA=0. C DO 1 I=3,LEN1-2 C T4(I)=0. C T1(I)=0 C T2(I)=0. C T3(I)=FLUXNA C 1 CONTINUE C IBNDB=1 C **** SOURCES DO 2 K=1,KMAXP1 DO 2 I=3,IMAXP4-2 S1(I,K)=-XLNA(K,I) S2(I,K)=PNA(K,I) 2 CONTINUE DO 3 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 3 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 3 CONTINUE IBND=0 CALL MINOR (NPSA,NPSANM,RMA,PHIA,ALFAA,IBND,IBNDB,PARB) RETURN END */ *DK COMPHOX */ SUBROUTINE COMPHOX SAVE C **** C **** ADVANCE HOX COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CONS, DISSHOX, FIELDS, FIELDT, FLUX, C **** HOXSTUF, HOXUPP, INDEX, IONHOX, NEWRAT, PHOTO, PSIB, C **** RATEBLK, RJH2O2O, VSCR C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA DISSHOX2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA HOXSTUF2 *CA HOXUPP2 *CA INDEX *CA IONHOX2 *CA NEWRAT2 *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA RJH2O2O2 *CA VSCR DIMENSION FM(IMXP),SS1(IMXP),SS2(IMXP),RR(IMXP),XHOX(IMXP) DIMENSION PHIHOX(3) DATA RMHOX,PHIHOX/1.,0.146,0.243,0.162/ C **** C **** UPPER BOUNDARY: TOTAL FLUX=FHOX C **** DO 1 I=3,LEN1-2 T4(I)=FHOX(I) 1 CONTINUE IBND=1 C **** C **** SOURCES C **** C U=9. C V=17. C W=25. U=1. V=1. W=1. DO 2 K=1,KMAXP1 DO 2 I=3,LEN1-2 FM(I)=FNO(K,I)+FNO2(K,I)+FNN2(K,I) HO2HR(K,I)=RKMM(28,K,I)*FM(I)*FNO2(K,I)/(RKMM(18,K,I)* 1 FNO(K,I)+RBB(12,K,I)*FNNO(K,I)+RKMM(26,K,I)*FNO3(K,I)) OHHR(K,I)=((RKMM(18,K,I)*FNO(K,I)*RKMM(28,K,I)*FNO2(K,I)* 1 FM(I))/(RKMM(18,K,I)*FNO(K,I)+RKMM(26,K,I)*FNO3(K,I)+ 2 RBB(12,K,I)*FNNO(K,I))+RKMM(29,K,I)*FNO3(K,I))/ 3 (RKMM(17,K,I)*FNO(K,I)+RKMM(21,K,I)*FNO3(K,I)) HHOXR(K,I)=1./(1.+HO2HR(K,I)+OHHR(K,I)) SS1(I)=HO2HR(K,I) SS2(I)=OHHR(K,I) RR(I)=HHOXR(K,I) S2(I,K)=(2.*(SH2OSRB(K,I)+SH2OSRC(K,I)+SH2OEUV(K,I)+0.88* 1 SH2OLYA(K,I))*FNH2O(K,I)*U+2.*RJH2O2(K,I)*FNH2O2(K,I)*V+ 2 PHOXIC(K,I)+(2.*RKMM(11,K,I)*FNH2(K,I)*U+2.*RKMM(10,K,I)* 3 FNH2O(K,I)*V+2.*RKMM(37,K,I)*FNCH4(K,I))*FNO1D(K,I)*V+ 4 RKK(11,K,I)*YIHP(K,I)*FNO(K,I)+2.*RKMM(20,K,I)* FNH2(K,I)* 5 FNO(K,I)*U+2.*RKMM(19,K,I)*FNH2O2(K,I)*FNO(K,I)*W+2.* 6 RKMM(42,K,I)*FNH2O(K,I)*FNO(K,I)*V+2.*RKMM(36,K,I)* 7 FNCH4(K,I)*FNO(K,I)*V+RKK(9,K,I)*FNH2(K,I)*YIOP(K,I)+ 8 ALPP(4,K,I)*YIOHP(K,I)*FNE(K,I)) S1(I,K)=-(2.*RKMM(23,K,I)*SS1(I)*RR(I)*SS2(I)*RR(I)+ 1 2.*RKMM(27,K,I)*SS1(I)*SS1(I)*RR(I)*RR(I)+2.*(RKMM(30,K,I)+ 2 RKMM(32,K,I))*SS1(I)*RR(I)*RR(I)+2.*RKMM(22,K,I)*SS2(I)* 3 RR(I)*SS2(I)*RR(I)+2.*RKMM(33,K,I)*FM(I)*RR(I)*RR(I))* 4 FNHOX(K,I)-RKK(12,K,I)*YIOP(K,I)*RR(I) 2 CONTINUE C **** PHOTOCHEMICAL EQUILIBRIUM AT LOWER BOUNDARY DO 3 I = 3,LEN1-2 FM(I)=FNO(1,I)+FNO2(1,I)+FNN2(1,I) SS1(I)=HO2HR(1,I) SS2(I)=OHHR(1,I) RR(I)=HHOXR(1,I) XHOX(I)=SQRT((2.*(SH2OSRB(1,I)+SH2OSRC(1,I)+SH2OEUV(1,I)+0.88* 1 SH2OLYA(1,I))*FNH2O(1,I)*U+2.*RJH2O2(1,I)*FNH2O2(1,I)*V+ 1 PHOXIC(1,I) 2 +(2.*RKMM(11,1,I)*FNH2(1,I)*U+2.*RKMM(10,1,I)*FNH2O(1,I)*V+2.* 3 RKMM(37,1,I)*FNCH4(1,I))*FNO1D(1,I)*V+RKK(11,1,I)*YIHP(1,I)* 4 FNO(1,I)+2.*RKMM(20,1,I)*FNH2(1,I)*FNO(1,I)*U+2.*RKMM(19,1,I)* 5 FNH2O2(1,I)*FNO(1,I)*W+2.*RKMM(42,1,I)*FNH2O(1,I)*FNO(1,I)*V+ 6 2.*RKMM(36,1,I)*FNCH4(1,I)*FNO(1,I)*V+RKK(9,1,I)*FNH2(1,I)* 7 YIOP(1,I)+ALPP(4,1,I)*YIOHP(1,I)*FNE(1,I))/(2.*RKMM(23,1,I)* 8 SS1(I)*RR(I)*SS2(I)*RR(I)+2.*RKMM(27,1,I)*SS1(I)*SS1(I)*RR(I)* 9 RR(I)+2.*(RKMM(30,1,I)+RKMM(32,1,I))*SS1(I)*RR(I)*RR(I)+2.* 1 RKMM(22,1,I)*RR(I)*RR(I)*SS2(I)*SS2(I)+2.*RKMM(33,1,I)*FM(I)* 2 RR(I)*RR(I))) 3 CONTINUE DO 4 I=3,LEN1-2 T1(I)=0. T2(I)=1. T3(I)=-XHOX(I)/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 4 CONTINUE C **** C **** PERIODIC POINTS C **** DO 5 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 5 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 5 CONTINUE IBNDB=0 ALFA=-0.38 CALL MINOR(NPHOX,NHOXNM,RMHOX,PHIHOX,ALFA,IBND,IBNDB,PHOXB) RETURN END */ *DK COMPNO */ SUBROUTINE COMPNO SAVE C **** C **** ADVANCE NO COMPOSITION BY ONE TIME STEP C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CONS, FIELDS, FIELDT, FLUX, INDEX, PHOTO, C **** PSIB, RATEBLK, VSCR C **** *CA PARAMS *CA ASAS2 *CA CONS2 *CA FIELDS2 *CA FIELDT2 *CA FLUX2 *CA INDEX *CA NOZNOZ2 *CA PHOTO2 *CA PSIB2 *CA RATEBLK2 *CA VSCR DIMENSION PHINO(3) DATA RMNO,PHINO/30.,0.814,0.866,0.926/ C **** C **** UPPER BOUNDARY: DIFFUSIVE EQUILIBRIUM C **** DO 1 I=1,LEN1 T4(I)=0. 1 CONTINUE C **** C **** SOURCES C **** DO 2 K=1,KMAXP1 DO 2 I=3,LEN1-2 S1(I,K)=-(FK5O2P(K,I)+RBB(3,K,I)*FNN4S(K,I)+RBB(6,K,I)* 1 FNN2D(K,I)+RBB(8,K,I)+RBB(9,K,I))*RNONOZ(K,I) S2(I,K)=RBB(1,K,I)*FNO2(K,I)*FNN4S(K,I)+RBB(2,K,I)*FNO2(K,I)* 1 FNN2D(K,I)+RBB(10,K,I)*FNOH(K,I)*FNN4S(K,I) 2 CONTINUE C **** IF IBNDNO = 0, FLUX GIVEN AT LOWER BOUNDARY IF(IBNDNO.EQ.0)THEN DO 3 I=3,LEN1-2 T1(I)=0. T2(I)=0. T3(I)=FLUXNO(I) 3 CONTINUE IBNDB=1 C **** IF IBNDNO = 1, PHOTOCHEMICAL EQUILIBRIUM AT LOWER C **** BOUNDARY ELSE IF(IBNDNO.EQ.1)THEN DO 4 I=3,LEN1-2 T4(I)=0. T1(I)=0. T2(I)=1. T3(I)=-XNO(I)*RMNO/(FNO2(1,I)*RMASS(1)+FNO(1,I)*RMASS(2)+ 1 FNN2(1,I)*RMASS(3)) 4 CONTINUE IBNDB=0 ENDIF DO 5 I = 1,2 T1(I) = T1(I+IMAX) T1(I+IMAXP2) = T1(I+2) T2(I) = T2(I+IMAX) T2(I+IMAXP2) = T2(I+2) T3(I) = T3(I+IMAX) T3(I+IMAXP2) = T3(I+2) T4(I) = T4(I+IMAX) T4(I+IMAXP2) = T4(I+2) DO 5 K = 1,KMAXP1 S1(I,K) = S1(I+IMAX,K) S1(I+IMAXP2,K) = S1(I+2,K) S2(I,K) = S2(I+IMAX,K) S2(I+IMAXP2,K) = S2(I+2,K) 5 CONTINUE IBND=0 ALFA=0. CALL MINOR(NPNO,NPNONM,RMNO,PHINO,ALFA,IBND,IBNDB,PNOB) RETURN END */ *DK FFACE */ SUBROUTINE FFACE(II) SAVE C **** C **** INTERFACES ONE- AND TWO-DIMENSIONAL COMMON BLOCKS C **** *CA PARAMS *CA CONS2 *CA ASASF *CA ASAS2F *CA CH4H2CFF *CA CH4H2C2F *CA CRATESF *CA CRATES2F *CA DISSHOXF *CA DISSHX2F *CA FIELDSF *CA FIELDS2F *CA FIELDTF *CA FIELDT2F *CA FLUX *CA FLUX2F *CA H2FORG *CA H2FORG2F *CA HEFLUX *CA HEFLUX2F *CA HOXSTUFF *CA HOXSTF2F *CA HOXUPP *CA HOXUPP2F *CA IONHOX *CA IONHOX2F *CA NEWRATF *CA NEWRAT2F *CA OPION *CA OPION2F *CA PSIBF *CA PSIB2F *CA PHOTOF *CA PHOTO2F *CA PHOTOOF *CA PHOTOO2F *CA RATEBLK *CA RATBLK2F *CA RJH2O2O *CA RJH2O22F *CA SOURCEF *CA SOURCE2F C **** C **** ALLOW FOR PERIODIC WRAP AROUND POINTS (TWO AT EACH END) C **** I = II+2 C **** C **** /ASAS/ AND /ASAS2/ ***** NEED TO WORK OUT LEAPFROG C **** POINTERS C **** C **** /CH4H2COF/ AND /CH4H2CO2/ C **** DO 2 J = 1,7 DO 2 K = 1,KMAXP1 RJCH4F(K,I,J) = RJCH4(K,J) 2 CONTINUE C **** C **** /CRATES/ AND /CRATES2/ C **** DO 3 J = 1,4 DO 3 K = 1,KMAXP1 RK12F(K,I,J) = RK12(K,J) 3 CONTINUE C **** C **** /DISSHOX/ AND /DISSHOX2/ C **** DO 4 J = 1,9 DO 4 K = 1,KMAXP1 SH2OTF(K,I,J) = SH2OT(K,J) 4 CONTINUE C **** C **** /FIELDS/ AND /FIELDS2/ C **** DO 5 J = 1,17 DO 5 K = 1,KMAXP1 FTF(K,I,J) = FT(K,J) 5 CONTINUE F107F = F107 DO 6 J = 1,3 DO 6 K = 1,KMAXP1 FTEF(K,I,J) = FTE(K,J) 6 CONTINUE C **** C **** /FIELDT/ AND /FIELDT2/ C **** DO 7 J = 1,12 DO 7 K = 1,KMAXP1 FNH2OF(K,I,J) = FNH2O(K,J) 7 CONTINUE C **** C **** /FLUX/ AND /FLUX2/ C **** FLUXNOF(I) = FLUXNO IBNDNOF = IBNDNO FLUXCOF(I) = FLUXCO IBNDCOF = IBNDCO C **** C **** /H2FORG/ AND /H2FORG2/ C **** DO 8 K =1,KMAXP1 RJH2OLYF(K,I) = RJH2OLY(K) 8 CONTINUE C **** C **** /HEFLUX/ AND /HEFLUX2/ C **** FLUXF(I) = FLUX C **** C **** /HOXSTUF/ AND /HOXSTUF2/ C **** DO 9 J = 1,10 DO 9 K = 1,KMAXP1 HO2HRF(K,I,J) = HO2HR(K,J) 9 CONTINUE C **** C **** /HOXUPP/ AND /HOXUPP2/ C **** FHOXF(I) = FHOX C **** C **** /IONHOX/ AND /IONHOX2/ C **** DO 10 K = 1,KMAXP1 PHOXICF(K,I) = PHOXIC(K) 10 CONTINUE C **** C **** /NEWRATF/ AND /NEWRAT2F/ C **** DO 11 J = 1,3 DO 11 K = 1,KMAXP1 HO2OHF(K,I,J) = HO2OH(K,J) 11 CONTINUE C **** C **** /OPION/ AND /OPION2/ C **** DO 12 K = 1,KMAXP1 FIOPF(K,I) = FIOP(K) 12 CONTINUE C **** C **** /PSIB/ AND /PSIB2/ C **** DO 13 J = 1,10 PARBF(I,J) = PARB(J) 13 CONTINUE C **** C **** /PHOTO/ AND /PHOTO2/ C **** DO 14 J =1,7 XNOF(I,J) = XNO(J) 14 CONTINUE C **** C **** /PHOTOO/ AND /PHOTOO2/ C **** DO 15 J = 1,2 XHEF(I,J) = XHE(J) 15 CONTINUE C **** C **** /RATEBLK/ AND /RATEBLK2/ C **** DO 16 J = 1,25 DO 16 K = 1,KMAXP1 RKKF(J,K,I) = RKK(J,K) 16 CONTINUE DO 17 J = 1,10 DO 17 K = 1,KMAXP1 ALPPF(J,K,I) = ALPP(J,K) 17 CONTINUE DO 18 J = 1,20 DO 18 K = 1,KMAXP1 RBBF(J,K,I) = RBB(J,K) 18 CONTINUE DO 19 J = 1,50 DO 19 K = 1,KMAXP1 RKMMF(J,K,I) = RKMM(J,K) 19 CONTINUE C **** C **** /RJH2O2O/ AND /RJH2O2O2/ C **** DO 21 K = 1,KMAXP1 RJH2O2F(K,I) = RJH2O2(K) 21 CONTINUE C **** C **** /SOURCE/ AND /SOURCE2/ C **** DO 20 J = 1,6 DO 20 K = 1,KMAXP1 FS11F(K,I,J) = FS11(K,J) 20 CONTINUE RETURN END */ *DK MINOR */ SUBROUTINE MINOR(NX,NXNM,RMX,PHIX,ALFAX,IBND,IBNDB,PXB) SAVE C **** C **** COMMON DECKS: C **** PARAMS, ASAS, CONS, INDEX, VSCR, C **** C **** C **** ADVANCES MINOR SPECIES BY ONE TIME STEP C **** NX = INDEX OF MINOR SPECIES FOR TIME T(N) C **** NXNM = INDEX OF MINOR SPECIES FOR TIME T(N-1) C **** NPSDH = INDEX FOR HORIZONTAL DIFFUSION FIELD C **** RMX = MOLECULAR WEIGHT OF MINOR SPECIES C **** PHIX = DIFFUSION VECTOR, PHI(X,N),N=1,3 C **** ALFAX = THERMAL DIFFUSION COEFFICIENT C **** IBND=0 IF DIFFUSIVE FLUX GIVEN AT UPPER BOUNDARY (IN T4) C **** =1 IF TOTAL FLUX GIVEN AT UPPER BOUNDARY (IN T4) C **** NOTE: FLUXES ARE IN 1/(CM**2*SEC) C **** C **** ON ENTRY: C **** LOWER BOUNDARY: C **** IF IBNDB = 0, THEN C **** T1 = A, T2 = B, T3 = C DEFINE LOWER BOUNDARY CONDITION C **** WHERE A*DPSX/DZ + B*PSX + C = 0. C **** IF IBNDB = 1, THEN C **** T3 = UPWARD FLUX (1/(SEC*CM**2)) AT LOWER BOUNDARY C **** UPPER BOUNDARY: C **** T4 = PHI, GIVES UPWARD FLUX OF SPECIES X AT UPPER C **** BOUNDARY (1/(SEC*CM**2)) C **** SOURCES: C **** S1 = SX/N(X), WHERE SX IS PORTION OF NUMBER DENSITY C **** SOURCE PROPORTIONAL TO N(X), THE MINOR SPECIES NUMBER C **** DENSITY C **** S2 = S0, PORTION OF NUMBER DENSITY SOURCE INDEPENDENT C **** OF N(X). *CA PARAMS *CA ASAS2 *CA CONS2 *CA INDEX *CA VSCR DIMENSION PHIX(3),B(2,2),PHI(2,3) DIMENSION PXB(IMXP) DATA PHI/0.,0.673,1.35,0.,1.11,0.769/,TAU/1.86E+3/,T00/273./, 1SMALL/1.E-15/ EQUIVALENCE (C(40),B) C **** S13 = HORIZONAL ADVECTION DO 24 K=1,KMAX CALL ADVECL(NX,S13(1,K),K) 24 CONTINUE C **** PERIODIC POINTS DO 42 I=1,2 T1(I)=T1(I+IMAX) T1(I+IMAXP2)=T1(I+2) T2(I)=T2(I+IMAX) T2(I+IMAXP2)=T2(I+2) T3(I)=T3(I+IMAX) T3(I+IMAXP2)=T3(I+2) T4(I)=T4(I+IMAX) T4(I+IMAXP2)=T4(I+2) DO 42 K=1,KMAXP1 S1(I,K)=S1(I+IMAX,K) S1(I+IMAXP2,K)=S1(I+2,K) S2(I,K)=S2(I+IMAX,K) S2(I+IMAXP2,K)=S2(I+2,K) S13(I,K)=S13(I+IMAX,K) S13(I+IMAXP2,K)=S13(I+2,K) 42 CONTINUE C **** S14=SX/N(X)(K+1/2), S15=S0(K+1/2) DO 1 K=1,KMAX DO 1 I=1,LEN1 S15(I,K)=.5*(S2(I,K)+S2(I,K+1)) S14(I,K)=.5*(S1(I,K)+S1(I,K+1)) 1 CONTINUE C **** T4 = PS1(-1/2), T5 = PS2(-1/2), T6 = MBAR(-1/2) NPS1K=NJ+NPS NPS2K=NPS1K+KMAXP1 DO 2 I=1,LEN1 T7(I)=T4(I) T4(I)=B(1,1)*F(I,NPS1K)+B(1,2)*F(I,NPS2K)+FB(I,1) T5(I)=B(2,1)*F(I,NPS1K)+B(2,2)*F(I,NPS2K)+FB(I,2) T6(I)=1./(T4(I)/RMASS(1)+T5(I)/RMASS(2)+(1.-T4(I)-T5(I))/RMASS(3)) 2 CONTINUE C **** S12 = MBAR(K+1/2) NPS1K=NJ+NPS-1 NPS2K=NPS1K+KMAXP1 DO 3 K = 1,KMAXP1 DO 3 I=1,LEN1 S12(I,K)=1./(F(I,NPS1K+K)/RMASS(1)+F(I,NPS2K+K)/RMASS(2)+(1.- 1 F(I,NPS1K+K)-F(I,NPS2K+K))/RMASS(3)) 3 CONTINUE C **** S11 = MBAR(K), S10 = DM/DZ(K), S9 = PS2(K), C **** S8 = PS1(K), S7 = DPS2/DZ(K), S6 = DPS1/DZ(K) C **** LOWER BOUNDARY DO 4 I=1,LEN1 S11(I,1)=.5*(T6(I)+S12(I,1)) S10(I,1)=(S12(I,1)-T6(I))/C(3) S9(I,1)=.5*(T5(I)+F(I,NPS2K+1)) S8(I,1)=.5*(T4(I)+F(I,NPS1K+1)) S7(I,1)=(F(I,NPS2K+1)-T5(I))/C(3) S6(I,1)=(F(I,NPS1K+1)-T4(I))/C(3) T4(I)=T7(I) 4 CONTINUE C **** LEVELS K=2,KMAXP1 DO 5 K = 2,KMAXP1 DO 5 I=1,LEN1 S11(I,K)=.5*(S12(I,K)+S12(I,K-1)) S10(I,K)=(S12(I,K)-S12(I,K-1))/C(3) S9(I,K)=.5*(F(I,NPS2K+K)+F(I,NPS2K+K-1)) S8(I,K)=.5*(F(I,NPS1K+K)+F(I,NPS1K+K-1)) S7(I,K)=(F(I,NPS2K+K)-F(I,NPS2K+K-1))/C(3) S6(I,K)=(F(I,NPS1K+K)-F(I,NPS1K+K-1))/C(3) 5 CONTINUE C **** S5=T(TOT,K) C **** LOWER AND UPPER BOUNDARIES NTK=NJ+NT+KMAX DO 6 I=1,LEN1 S5(I,1)=T0(1)+F(I,NTK) S5(I,KMAXP1)=T0(KMAXP1)+F(I,NTK-1) 6 CONTINUE C **** LEVELS K=2,KMAX NTK=NJ+NT DO 7 K=2,KMAX NTK=NTK+1 DO 7 I=1,LEN1 S5(I,K)=T0(K)+.5*(F(I,NTK)+F(I,NTK-1)) 7 CONTINUE C **** EVALUATE ALFA12, ALFA21, ALFAM1, ALFAM2 ALFA12=PHI(1,2)-PHI(1,3) ALFA21=PHI(2,1)-PHI(2,3) ALFAX1=PHIX(1)-PHIX(3) ALFAX2=PHIX(2)-PHIX(3) C **** S15=(S0*MX/NMBAR)(K+1/2) NTK=NJ+NT-1 DO 8 K=1,KMAX NTK=NTK+1 DO 8 I=1,LEN1 S15(I,K)=S15(I,K)*RMX*C(84)*(.5*(T0(K)+T0(K+1))+F(I,NTK))/(C(81)* 1EXPS(K)*S12(I,K)) 8 CONTINUE C **** IF IBNDB = 1, SET UP FLUX BOUNDARY CONDITION AT BOTTOM IF(IBNDB.EQ.1)THEN DO 26 I=1,LEN1 T1(I)=1. T2(I)=S10(I,1)/S11(I,1) T3(I)=T3(I)*C(54)*RMX/(DIFK(I,1)*C(81)*EXPS(1)*C(87)*C(85)) 26 CONTINUE ENDIF C **** S1 = ALFA(1,1,K), S2 = ALFA(1,2,K), C **** S2 = ALFA(2,1,K), S4 = ALFA(2,2,K) DO 9 K=1,KMAXP1 DO 9 I=1,LEN1 S1(I,K)=-(PHI(1,3)+ALFA12*S9(I,K)) S2(I,K)=ALFA12*S8(I,K) S3(I,K)=ALFA21*S9(I,K) S4(I,K)=-(PHI(2,3)+ALFA21*S8(I,K)) C **** S12=EX(K) S12(I,K)=((ALFAX1*S4(I,K)-ALFAX2*S3(I,K))*(S6(I,K)-(1.-(RMASS(1)+ 1 S10(I,K))/S11(I,K))*S8(I,K))+(ALFAX2*S1(I,K)-ALFAX1*S2(I,K))* 2 (S7(I,K)-(1.-(RMASS(2)+S10(I,K))/S11(I,K))*S9(I,K)))/(S1(I,K)* 3 S4(I,K)-S2(I,K)*S3(I,K))+1.-(RMX+S10(I,K))/S11(I,K) C **** S10 = (DM/DZ)/MBAR S10(I,K)=S10(I,K)/S11(I,K) C **** S11 = AX(K) S11(I,K)=-S11(I,K)/(TAU*RMASS(3))*(T00/S5(I,K))**0.25/(PHIX(3)+ 1 ALFAX1*S8(I,K)+ALFAX2*S9(I,K)) 9 CONTINUE C **** S12=EX-ALFAX*D/DS(LN(T(TOT)) (THERMAL DIFFUSION TERM) DO 21 K=2,KMAX DO 21 I=1,LEN1 S12(I,K)=S12(I,K)-ALFAX*(S5(I,K+1)-S5(I,K-1))/(2.*C(3)* 1 S5(I,K)) 21 CONTINUE C **** LOWER BOUNDARY AND UPPER BOUNDARY DO 22 I=1,LEN1 S12(I,1)=S12(I,1)-ALFAX*(S5(I,2)-S5(I,1))/(C(3)*S5(I,1)) 22 CONTINUE K=KMAXP1 DO 23 I=1,LEN1 S12(I,K)=S12(I,K)-ALFAX*(S5(I,K)-S5(I,K-1) 1 )/(C(3)*S5(I,K)) 23 CONTINUE C **** T7=DFACT DO 10 I=1,LEN1 T7(I)=1. 10 CONTINUE C **** SHAPIRO SMOOTHER, S10=NXNM (ELIMINATED) NXNMK=NJ+NXNM-1 DO 12 K=1,KMAXP1 DO 12 I=3,LEN1-2 S9(I,K)=S10(I,K) S10(I,K)=F(I,NXNMK+K)-C(26)*(F(I+2,NXNMK+K)+F(I-2,NXNMK+K)-4.* 1 (F(I+2,NXNMK+K)+F(I-2,NXNMK+K))+6.*F(I,NXNMK+K)) 12 CONTINUE C **** S1 = P, S2 = Q, S3 = R, S4= F NWK=NJ+NW-1 DO 13 K=1,KMAX NWK=NWK+1 DO 13 I=1,LEN1 S1(I,K)=S11(I,K)/C(3)*(1./C(3)+.5*S12(I,K))-EXPS(K)*(C(87)* 1 DIFK(I,K)*T7(I)*(1./C(3)-.5*S9(I,K))+0.25*(F(I,NWK)+ 2 F(I,NWK+1)))/C(3) S3(I,K)=S11(I,K+1)/C(3)*(1./C(3)-.5*S12(I,K+1))-EXPS(K)*(C(86)* 1 DIFK(I,K+1)*T7(I)*(1./C(3)+.5*S9(I,K+1))-0.25*(F(I,NWK)+ 2 F(I,NWK+1)))/C(3) S2(I,K)=-(S11(I,K)/C(3)*(1./C(3)-.5*S12(I,K))+S11(I,K+1)/C(3)*(1./ 1 C(3)+.5*S12(I,K+1)))+EXPS(K)*((C(87)*DIFK(I,K)*(1./C(3)+.5* 2 S9(I,K))+C(86)*DIFK(I,K+1)*(1./C(3)-.5*S9(I,K+1)))*T7(I)/C(3)- 3 S14(I,K)+C(7)) S4(I,K)=EXPS(K)*(S10(I,K)*C(7)-S13(I,K)+S15(I,K)) 13 CONTINUE C **** BOUNDARIES C **** MODIFY EX(KMAXP1) IF IBND=1 IF(IBND.EQ.1)THEN NWK=NJ+NW+KMAX DO 25 I=1,LEN1 T7(I)=EXPS(KMAX)*C(86)*F(I,NWK)/S11(I,KMAXP1) S12(I,KMAXP1)=S12(I,KMAXP1)-T7(I) 25 CONTINUE ENDIF DO 14 I=1,LEN1 C **** LOWER BOUNDARY S2(I,1)=S2(I,1)+S1(I,1)*(T1(I)+.5*T2(I)*C(3))/(T1(I)-.5*T2(I)*C(3) 1) S4(I,1)=S4(I,1)-S1(I,1)*T3(I)*C(3)/(T1(I)-.5*T2(I)*C(3)) S1(I,1)=0. C **** UPPER BOUNDARY (UPWARD FLUX GIVEN) S2(I,KMAX)=S2(I,KMAX)+S3(I,KMAX)*(1.+.5*S12(I,KMAXP1)*C(3))/(1.- 1.5*S12(I,KMAXP1)*C(3)) S4(I,KMAX)=S4(I,KMAX)-S3(I,KMAX)*C(54)*RMX/(C(81)*S11(I,KMAXP1)* 1C(85))*T4(I)*C(3)/(1.-.5*S12(I,KMAXP1)*C(3)) S3(I,KMAX)=0. 14 CONTINUE C **** SOLVE TRIDIAGONAL SYSTEM NXNPK=NJNP+NX CALL TRSOLV(S1,S2,S3,S4,S7,F(1,NXNPK),LEN1,3,LEN1-2,KMAXP1,1,KMAX 1,1) C **** INSERT VALUE OF NXNPK(KMAXP1) USING UPPER BOUNDARY C **** CONDITION NXNPK=NJNP+NX+KMAX DO 15 I=3,LEN1-2 F(I,NXNPK)=(C(54)*RMX/(C(81)*S11(I,KMAXP1)*C(85))*T4(I)*C(3)+ 1(1.+.5*S12(I,KMAXP1)*C(3))*F(I,NXNPK-1))/(1.-.5*S12(I,KMAXP1)* 2C(3)) 15 CONTINUE C **** INSERT PERIODIC POINTS K1=NJNP+NX K2=K1+KMAX DO 18 N=1,2 DO 19 I=1,2 DO 19 K=K1,K2 F(I,K)=F(I+IMAX,K) F(I+IMAXP2,K)=F(I+2,K) 19 CONTINUE K1=NJNP+NXNM K2=K1+KMAX 18 CONTINUE C **** TIME SMOOTHING NXNMK=NJ+NXNM-1 NXK=NJ+NX-1 NXNPK=NJNP+NX-1 NXMNK=NJNP+NXNM-1 DO 17 K=1,KMAXP1 DO 17 I=1,LEN1 F(I,NXMNK+K)=C(30)*F(I,NXK+K)+C(31)*(F(I,NXNMK+K)+F(I,NXNPK+K)) 17 CONTINUE C **** PXB = PSX(-1/2) NXNPK=NJNP+NX DO 16 I = 1,LEN1 PXB(I)=(F(I,NXNPK)*(T1(I)+.5*T2(I)*C(3))+T3(I)*C(3))/ 1(T1(I)-.5*T2(I)*C(3)) 16 CONTINUE C **** INSURE NON-NEGATIVE NX NXK=NJNP+NX-1 NXNMK=NJNP+NXNM-1 DO 20 K=1,KMAXP1 DO 20 I=1,LEN1 F(I,NXK+K)=CVMGP(F(I,NXK+K),SMALL,F(I,NXK+K)-SMALL) F(I,NXNMK+K)=CVMGP(F(I,NXNMK+K),SMALL,F(I,NXNMK+K)-SMALL) 20 CONTINUE RETURN END */ *DK PLOT */ SUBROUTINE PLOT(IFP,N,NJ) SAVE C **** C **** PROCEDURE TO PLOT OUT MASS MIXING RATIOS C **** C **** ARRAY IFP CONTAINS INDICES OF FIELDS TO BE PLOTTED C **** C **** FOR EXAMPLE: C **** NPS FOR O2 C **** NPS2 FOR O C **** NPSA FOR AR C **** NPSH FOR HE C **** NPNO FOR NO C **** NPN4S FOR N4S C **** NPCH4 FOR CH4 C **** NPH2 FOR H2 C **** NPCO2 FOR CO2 C **** NPCO FOR CO C **** NPHOX FOR HOX C **** NPH2O FOR H2O C **** C **** N IS NUMBER OF INDICES PASSED (MAX IS 28) C **** C **** NJ IS BUFFER POINTER C **** *CA PARAMS *CA ASAS2 *CA CONS2 DIMENSION IFP(1),LABEL(28),LAB2(28) DATA LABEL/3H O2,3H O,3H AR,3H HE,3H NO,3HN4S,3HCH4,3H H2,3HCO2, 13H CO,3HHOX,3HH2O/ C **** C **** SHIFT REQUIRED LABELS TO ARRAY LAB2 C **** DO 1 I=1,N LAB2(I)=LABEL(MOD(IFP(I)/KMAXP1-1,13)) 1 CONTINUE C **** C **** PLOT FIELDS C **** CALL GSCLIP(0) DO 2 I = 1,N CALL CONREC(F(3,NJ+IFP(I)),IMAXP4,IMAX+1,KMAXP1,0.,0.,0.,0,0, 1 -1430B) C **** C **** WRITE TITLE C **** CALL GETSET(FXA,FXB,FYA,FYB,XC,XD,YC,YD,LTYPE) MXA = KFPX(FXA) MXB = KFPX(FXB) MYA = KFPY(FYA) MYB = KFPY(FYB) MX = (MXA+MXB)/2 MY = MYB+48 CALL PWRIT(CPUX(MX),CPUY(MY),LAB2(I),3,2,0,0) CALL FRAME 2 CONTINUE CALL GSCLIP(1) RETURN END */ *DK RATES */ SUBROUTINE RATES(FT) SAVE C **** C **** CALCULATES K12, K13, K14, K15 AT ALL LEVELS C **** C **** COMMON DECKS: C **** PARAMS, CONS, CRATES C **** *CA PARAMS *CA CONS2 *CA CRATES2 *CA OXOXOX2 DIMENSION FT(KMXP,1) C **** C **** PERIODIC POINTS FOR OOXR C **** DO 2 I = 1,2 DO 2 K = 1,KMAXP1 OOXR(K,I) = OOXR(K,I+IMX) OOXR(K,I+IMX+2) = OOXR(K,I+2) 2 CONTINUE DO 1 K=1,KMAXP1 DO 1 I=1,LEN1 C RK13(K,I)=2.15E-34*EXP(345./FT(K,I)) C RK14(K,I)=2.15E-34*EXP(345./FT(K,I)) C RK15(K,I)=8.82E-35*EXP(575./FT(K,I)) C NEW JPL-85 RATES RK12(K,I)=OOXR(K,I)*OOXR(K,I)*9.59E-34*EXP(480./FT(K,I)) C RK12(K,I)=0. C RK13(K,I)=OOXR(K,I)*6.0E-34*(300./FT(K,I))**2.8 C RK14(K,I)=OOXR(K,I)*6.0E-34*(300./FT(K,I))**2.8 C RK15(K,I)=OOXR(K,I)*6.0E-34*(300./FT(K,I))**2.8 RK13(K,I)=0. RK14(K,I)=0. RK15(K,I)=0. 1 CONTINUE RETURN END */ *DK UTILITY */ CDIR$ NOLIST SUBROUTINE TRSOLV(A,B,C,F,W,X,IF,I1,I2,KF,K1,K2,NF) SAVE C **** SOLVES TRIDIAGONAL SYSTEM C **** A(I,K)*X(I,K-1)+B(I,K)*X(I,K)+C(I,K)*X(I,K+1)=F(I,K) C **** WHERE I=I1,I2,1 AND K=K1,K2,1 AND A(I,K1)=C(I,K2)=0. C **** ARRAYS A,B,C,F,X ARE DIMENSIONED (IF,KF) C **** WHERE 1.LE.I1.LT.I2.LE.IF AND 1.LE.K1.LT.K2.LE.KF C **** W IS WORK SPACE DIMENSIONED (IF,3*KF) C **** THE ROUTINE USES VECTOR OPERATIONS ON ARRAYS OF LENGTH C **** IMAX=I2-I1+1 DIMENSION A(IF,KF),B(IF,KF),C(IF,KF),F(IF,KF),W(IF,3*KF),X(IF,KF) IMAX=I2-I1+1 K1P=K1+1 GO TO(1,2),NF 1 CONTINUE C **** LOWER BOUNDARY C **** W(K1)=B(K1) DO 3 I=I1,I2 W(I,K1)=B(I,K1) 3 CONTINUE C **** SWEEP THROUGH K DO 4 K=K1P,K2 C **** W(KF+K-1)=C(K-1)/W(K-1) CALL QVDIV0(W(I1,KF+K-1),C(I1,K-1),W(I1,K-1),IMAX) C **** W(K)=A(K)*W(KF+K-1) CALL QVMPY0(W(I1,K),A(I1,K),W(I1,KF+K-1),IMAX) C **** W(K)=B(K)-W(K) CALL QVSUB0(W(I1,K),B(I1,K),W(I1,K),IMAX) 4 CONTINUE 2 CONTINUE C **** LOWER BOUNDARY C **** W(2*KF+K1)=F(K1)/W(K1) CALL QVDIV0(W(I1,2*KF+K1),F(I1,K1),W(I1,K1),IMAX) DO 5 K=K1P,K2 C **** W(2*KF+K)=A(K)*W(2*KF+K-1) CALL QVMPY0(W(I1,2*KF+K),A(I1,K),W(I1,2*KF+K-1),IMAX) C **** W(2*KF+K)=F(K)-W(2*KF+K) CALL QVSUB0(W(I1,2*KF+K),F(I1,K),W(I1,2*KF+K),IMAX) C **** W(2*KF+K)=W(2*KF+K)/W(K) CALL QVDIV0(W(I1,2*KF+K),W(I1,2*KF+K),W(I1,K),IMAX) 5 CONTINUE C **** BACK SUBSTITUTION C **** X(K2)=W(2*KF+K2) DO 6 I=I1,I2 X(I,K2)=W(I,2*KF+K2) 6 CONTINUE DO 7 KK=K1P,K2 K=K1+K2-KK C **** X(K)=W(KF+K)*X(K+1) CALL QVMPY0(X(I1,K),W(I1,KF+K),X(I1,K+1),IMAX) C **** X(K)=W(2*KF+K)-X(K) CALL QVSUB0(X(I1,K),W(I1,2*KF+K),X(I1,K),IMAX) 7 CONTINUE RETURN END SUBROUTINE QAA0(W,X,Y,Z,N) SAVE DIMENSION W(1),X(1),Y(1),Z(1) DO 100 I=1,N W(I) = X(I) + Y(I) + Z(I) 100 CONTINUE RETURN END SUBROUTINE QAM0(W,X,Y,Z,N) SAVE DIMENSION W(1),X(1),Y(1),Z(1) DO 100 I=1,N W(I) = ( X(I) + Y(I) ) * Z(I) 100 CONTINUE RETURN END SUBROUTINE QAM1(W,X,Y,C,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = ( X(I) + Y(I) ) * C 100 CONTINUE RETURN END SUBROUTINE QAM2(W,X,C,Y,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = ( X(I) + C ) * Y(I) 100 CONTINUE RETURN END SUBROUTINE QMA0(W,X,Y,Z,N) SAVE DIMENSION W(1),X(1),Y(1),Z(1) DO 100 I=1,N W(I) = X(I) * Y(I) + Z(I) 100 CONTINUE RETURN END SUBROUTINE QMA1(W,X,Y,C,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = X(I) * Y(I) + C 100 CONTINUE RETURN END SUBROUTINE QMA2(W,X,C,Y,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = X(I) * C + Y(I) 100 CONTINUE RETURN END SUBROUTINE QMA5(W,C,X,S,N) SAVE DIMENSION W(1),X(1) DO 100 I=1,N W(I) = C * X(I) + S 100 CONTINUE RETURN END SUBROUTINE QMM0(W,X,Y,Z,N) SAVE DIMENSION W(1),X(1),Y(1),Z(1) DO 100 I=1,N W(I) = X(I) * Y(I) * Z(I) 100 CONTINUE RETURN END SUBROUTINE QMM1(W,X,Y,C,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = X(I) * Y(I) * C 100 CONTINUE RETURN END SUBROUTINE QMS0(W,X,Y,Z,N) SAVE DIMENSION W(1),X(1),Y(1),Z(1) DO 100 I=1,N W(I) = X(I) * Y(I) - Z(I) 100 CONTINUE RETURN END SUBROUTINE QSA0(W,X,Y,Z,N) SAVE DIMENSION W(1),X(1),Y(1),Z(1) DO 100 I=1,N W(I) = X(I) - Y(I) + Z(I) 100 CONTINUE RETURN END SUBROUTINE QSM0(W,X,Y,Z,N) SAVE DIMENSION W(1),X(1),Y(1),Z(1) DO 100 I=1,N W(I) = ( X(I) - Y(I) ) * Z(I) 100 CONTINUE RETURN END SUBROUTINE QSM1(W,X,Y,C,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = ( X(I) - Y(I) ) * C 100 CONTINUE RETURN END SUBROUTINE QVADD0(W,X,Y,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = X(I) + Y(I) 100 CONTINUE RETURN END SUBROUTINE QVADD1(W,X,C,N) SAVE DIMENSION W(1),X(1) DO 100 I=1,N W(I) = X(I) + C 100 CONTINUE RETURN END SUBROUTINE QVDIV0(W,X,Y,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = X(I) / Y(I) 100 CONTINUE RETURN END SUBROUTINE QVDIV2(W,C,X,N) SAVE DIMENSION W(1),X(1) DO 100 I=1,N W(I) = C / X(I) 100 CONTINUE RETURN END SUBROUTINE QVMPY0(W,X,Y,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = X(I) * Y(I) 100 CONTINUE RETURN END SUBROUTINE QVMPY2(W,C,X,N) SAVE DIMENSION W(1),X(1) DO 100 I=1,N W(I) = C * X(I) 100 CONTINUE RETURN END SUBROUTINE QVSUB0(W,X,Y,N) SAVE DIMENSION W(1),X(1),Y(1) DO 100 I=1,N W(I) = X(I) - Y(I) 100 CONTINUE RETURN END SUBROUTINE QVSUB1(W,X,C,N) SAVE DIMENSION W(1),X(1) DO 100 I=1,N W(I) = X(I) - C 100 CONTINUE RETURN END SUBROUTINE BNBDY(NPDE,TM,ZL,ZR,AL,AR,BL,BR) SAVE PARAMETER(KMX=96,MMX=46) include "blank.h" COMMON/SOLVTR/TP(MMX),DA(MMX),SHI(MMX),ATP(MMX),DAZ(MMX), 1SHIZ(MMX),ATPZ(MMX),ATPZZ(MMX),BNTR(MMX),CNTR(MMX),BRTR,QQOP(MMX) 2,XLOP(MMX),SHA(KMX),SHAZ(KMX),SHII(KMX),DAA(KMX) DIMENSION AL(NPDE),AR(NPDE),BL(NPDE),BR(NPDE) FLUXE=0. M=KMX-MMX+1 BL(1)=XIOP(M) BR(1)=(BRTR*AR(1)-FLUXE/DA(MMX))*SHA(MMX) RETURN END SUBROUTINE CLEVEL(CL,NCL,IF) SAVE DIMENSION CL(40),CCL(40) IIF=IF IF(IIF.EQ.0)RETURN NNCL=NCL DO 1 N=1,NNCL CCL(N)=CL(N) 1 CONTINUE RETURN ENTRY DLEVEL(CL,NCL,IF) IF=IIF IF(IF.EQ.0)RETURN NCL=NNCL DO 2 N=1,NCL CL(N)=CCL(N) 2 CONTINUE RETURN END SUBROUTINE COLUM(XMLW) SAVE PARAMETER(KMX=96) include "blank.h" COMMON/COLMTR/XXN(KMX),COL(KMX),CNO2(KMX),CNO(KMX),CNN2(KMX) 1,CLNO3(KMX) SHTX=1.38E-16*TN(KMX)/(1.66E-24*GZ(KMX)) COL(KMX)=XXN(KMX)*SHTX/XMLW KMX1=KMX-1 DO 1 K=KMX1,1,-1 K1=K+1 ALP=ALOG(XXN(K1)/XXN(K))/(ZQHT(K1)-ZQHT(K)) IF(ALP.EQ.0) GO TO 2 COL(K)=COL(K1)+XXN(K)*(EXP(ALP*(ZQHT(K1)-ZQHT(K)))-1.)/ALP GO TO 1 2 COL(K)=COL(K1)+XXN(K)*(ZQHT(K1)-ZQHT(K)) 1 CONTINUE RETURN END SUBROUTINE COLUMN(UT) SAVE PARAMETER(KMX=96) include "blank.h" COMMON/COLMTR/XXN(KMX),COL(KMX),CNO2(KMX),CNO(KMX),CNN2(KMX) 1,CLNO3(KMX) SHTCP=1.38E-16*TN(KMX)/(1.66E-24*GZ(KMX)) CNO2(KMX)=XNO2(KMX)*SHTCP/32. CNO(KMX)=XNO(KMX)*SHTCP/16. CNN2(KMX)=XNN2(KMX)*SHTCP/28. KMX1=KMX-1 DO 13 K=KMX1,1,-1 K1=K+1 ZQHT(K)=ZPHT(K)*1.E+5 ZQHT(K1)=ZPHT(K1)*1.E+5 ALP1=ALOG(XNO2(K1)/XNO2(K))/(ZQHT(K1)-ZQHT(K)) ALP2=ALOG(XNO(K1)/XNO(K))/(ZQHT(K1)-ZQHT(K)) ALP3=ALOG(XNN2(K1)/XNN2(K))/(ZQHT(K1)-ZQHT(K)) CNO2(K)=CNO2(K1)+XNO2(K)*(EXP(ALP1*(ZQHT(K1)-ZQHT(K)))-1.)/ALP1 CNN2(K)=CNN2(K1)+XNN2(K)*(EXP(ALP3*(ZQHT(K1)-ZQHT(K)))-1.)/ALP3 IF(ALP2.EQ.0) GO TO 2 CNO(K)=CNO(K1)+XNO(K)*(EXP(ALP2*(ZQHT(K1)-ZQHT(K)))-1.)/ALP2 GO TO 1 2 CNO(K)=CNO(K1)+XNO(K)*(ZQHT(K1)-ZQHT(K)) 1 CONTINUE 13 CONTINUE RETURN END SUBROUTINE COMPSEU(DTIME,II,ITU) SAVE PARAMETER(KMX=96,KMXP=96,IMXP=21,IMXP2=IMXP+1) include "blank.h" include "solars.h" include "sodium.h" COMMON/TRAVLH/RK(50),ALP(20),RB(20),RKM(60) COMMON/WIND/UU(KMX),WW(KMX) COMMON/OXOXOX2/O3OR(KMX,-1:IMXP2),XNOX(KMX), 1 OOXR(KMX,-1:IMXP2),FNOX(KMX,-1:IMXP2),XNOX1, 1 PS2B(-1:IMXP2) COMMON/NOZNOZ2/SNO2NO(KMXP,-1:IMXP2),RNONOZ(KMXP,-1:IMXP2), 1 FNNOZ(KMXP,-1:IMXP2) COMMON/NOZTRF/XNNOZ(KMX) COMMON/DENTRF/QNN(KMX),QNMN(KMX),QNC(KMX),QN1D(KMX),DSNCHM(KMX), 1DSICHM(KMX),QO3PR(KMX),E630Z(KMX),E63DR(KMX),E63N2D(KMX), 2E6300(KMX),QHOXO2(KMX),QHOXNO(KMX),QHOXT(KMX),PARCD(KMX), 3SPED(KMX),SHAL(KMX),ALAMXX(KMX),ALAMXY(KMX),XNOF(KMX),QJOUL(KMX) COMMON/PERTRF/TNO(KMX),TNP(KMX),FDIFP(KMX) COMMON/EDDYTRE/FDIFO(KMX) COMMON/WINDTRF/UN(KMX),VN(KMX),WN(KMX),UI(KMX),VI(KMX),WI(KMX) 1,WGAM(KMX),DWGAM(KMX),UIT,VUT COMMON/CH4H2CO2/RJCH4(KMXP,-1:IMXP2),FK9OP(KMXP,-1:IMXP2), 1 SCO2I(KMXP,-1:IMXP2),RSKIONS(KMXP,-1:IMXP2), 2 RJCO2T(KMXP,-1:IMXP2),RKCO2P(KMXP,-1:IMXP2),SCOI(KMXP,-1:IMXP2) COMMON/CRATES2/RK12(KMXP,-1:IMXP2),RK13(KMXP,-1:IMXP2), 1 RK14(KMXP,-1:IMXP2),RK15(KMXP,-1:IMXP2) COMMON/DISSHOX2/SH2OT(KMXP,-1:IMXP2),YIOP(KMXP,-1:IMXP2), 1 YIHP(KMXP,-1:IMXP2),YIOHP(KMXP,-1:IMXP2),SH2OSRB(KMXP,-1:IMXP2), 2 SH2OLYA(KMXP,-1:IMXP2),SH2OSRC(KMXP,-1:IMXP2), 3 SH2OEUV(KMXP,-1:IMXP2),SHOXI(KMXP,-1:IMXP2) COMMON/FIELDS2/FT(KMXP,-1:IMXP2),FNO2(KMXP,-1:IMXP2), 1 FNO(KMXP,-1:IMXP2),FNN2(KMXP,-1:IMXP2),FNAR(KMXP,-1:IMXP2), 2 FNHE(KMXP,-1:IMXP2),FNNO(KMXP,-1:IMXP2),FNN2D(KMXP,-1:IMXP2), 3 FNN4S(KMXP,-1:IMXP2),FRJ(KMXP,-1:IMXP2),FW(KMXP,-1:IMXP2), 4 FNHOX(KMXP,-1:IMXP2),PPN2D(KMXP,-1:IMXP2),FNE(KMXP,-1:IMXP2), 5 PPN4S(KMXP,-1:IMXP2),FK4O2P(KMXP,-1:IMXP2), 6 FK5O2P(KMXP,-1:IMXP2),FF107,FTE(KMXP,-1:IMXP2), 7 FDIFK(KMXP,-1:IMXP2),FU(KMXP,-1:IMXP2),FWI(KMXP,-1:IMXP2), 8 FUI(KMXP,-1:IMXP2),FNAS(KMXP,-1:IMXP2),FNAO(KMXP,-1:IMXP2), 9 FNAO2(KMXP,-1:IMXP2),FNAOH(KMXP,-1:IMXP2) COMMON/FIELDT2/FNH2O(KMXP,-1:IMXP2),FNH2O2(KMXP,-1:IMXP2), 1 FNO1D(KMXP,-1:IMXP2),FNH2(KMXP,-1:IMXP2),FNOH(KMXP,-1:IMXP2), 2 FNHO2(KMXP,-1:IMXP2),FNO3(KMXP,-1:IMXP2),FNH(KMXP,-1:IMXP2), 3 FNCH4(KMXP,-1:IMXP2),FNCO(KMXP,-1:IMXP2),FNCO2(KMXP,-1:IMXP2), 4 FNNO2(KMXP,-1:IMXP2) COMMON/FLUX2/FLUXNO(-1:IMXP2),IBNDNO,FLUXCO(-1:IMXP2),IBNDCO COMMON/H2FORG2/RJH2OLY(KMXP,-1:IMXP2) COMMON/HEFLUX2/FLUXHE(-1:IMXP2) COMMON/HOXSTUF2/HO2HR(KMXP,-1:IMXP2),OHHR(KMXP,-1:IMXP2), 1 HHOXR(KMXP,-1:IMXP2),ANT(KMXP,-1:IMXP2),BNT(KMXP,-1:IMXP2), 2 CNT(KMXP,-1:IMXP2),DNT(KMXP,-1:IMXP2),ASNT(KMXP,-1:IMXP2), 3 CONPR(KMXP,-1:IMXP2),DSNT(KMXP,-1:IMXP2) COMMON/HOXUPP2/FHOX(-1:IMXP2) COMMON/IONHOX2/PHOXIC(KMX,-1:IMXP2) COMMON/NEWRAT2/HO2OH(KMXP,-1:IMXP2),HOH(KMXP,-1:IMXP2), 1 OHHOX(KMXP,-1:IMXP2) COMMON/OPION2/FIOP(KMXP,-1:IMXP2) COMMON/PSIB2/PARB(-1:IMXP2),PHB(-1:IMXP2),PNOB(-1:IMXP2), 1 PN4SB(-1:IMXP2),PCH4B(-1:IMXP2),PH2B(-1:IMXP2),PCO2B(-1:IMXP2), 2 PCOB(-1:IMXP2),PHOXB(-1:IMXP2),PH2OB(-1:IMXP2) COMMON/PHOTOO2/XHE(-1:IMXP2),XARG(-1:IMXP2) COMMON/RATEBLK2/RKK(25,KMXP,-1:IMXP2),ALPP(10,KMXP,-1:IMXP2), 1RBB(20,KMXP,-1:IMXP2),RKMM(50,KMXP,-1:IMXP2) COMMON/RJH2O2O2/RRJH2O2(KMXP,-1:IMXP2) COMMON/SOURCE2/FS11(KMXP,-1:IMXP2),FS12(KMXP,-1:IMXP2), 1 FS21(KMXP,-1:IMXP2),FS22(KMXP,-1:IMXP2),FS1(KMXP,-1:IMXP2), 2 FS2(KMXP,-1:IMXP2) DIMENSION DJOP(KMX),DJO2P(KMX) COMMON/SODIUMP/PNA(KMXP,-1:IMXP2),XLNA(KMXP,-1:IMXP2), 1XLBNA(-1:IMXP2),PNAI(KMXP,-1:IMXP2),XLNAI(KMXP,-1:IMXP2), 2XLBNAI(-1:IMXP2),RNAO(KMXP,-1:IMXP2),RNAO2(KMXP,-1:IMXP2), 3RNAOH(KMXP,-1:IMXP2) FF107=F107 IIRX=1 STEP=DTIME/FLOAT(IIRX) DO 777 IIR=1,IIRX DO 99 K=1,KMX RRJH2O2(K,II)=1.E-20 TN(K)=TNO(K)+TNP(K) CALL RATECOE(TI(K),TE(K),TN(K)) CALL RATECOF(TI(K),TE(K),TN(K)) DO 4819 I=1,20 4819 RKK(I,K,II)=RK(I) DO 4820 I=1,7 4820 ALPP(I,K,II)=ALP(I) DO 4821 I=1,13 4821 RBB(I,K,II)=RB(I) RBB(14,K,II)=XJNO2(K) RBB(15,K,II)=RB(15) DO 4822 I=8,43 4822 RKMM(I,K,II)=RKM(I) FALP14S=0.2 FALP12D=0.8 FALP23P=0.15 FALP21D=0.85 FALP34S=0.1 FALP32D=0.9 BRN2D=0.6 BRN4S=1.-BRN2D RBB(8,K,II)=XJNO(K) RBB(9,K,II)=RB9(K) QN2D=QNSPE(K)*BRN2D+QNSP(K)+QINP(K)*BRN2D QN4S=QNSPE(K)*BRN4S+QNSP(K)+QINP(K)*BRN4S PN2D=QN2D+RK(3)*XIN2P(K)*XNO(K)+ALP(1)*XINOP(K)*XNE(K)* 1FALP12D+ALP(3)*XIN2P(K)*XNE(K)*FALP32D PN4S=QN4S+RK(2)*XIOP(K)*XNN2(K)+RK(6)*XINP(K)*XNO2(K)+ALP(1) 1*XINOP(K)*XNE(K)*FALP14S+2.*ALP(3)*XIN2P(K)*XNE(K)* 2FALP34S+ALP(3)*XIN2P(K)*XNE(K)*FALP32D+RK(8)*XINP(K)*XNO(K) EDDYC=2.0E-6 EDDYMB=8.5E-7 ZPMB=-9.0 EDDYLB=8.0E-8 EZB=-14. TURZP=-6.5 FDIFK(K,II)=EDDYC*EXP(0.5*(TURZP-ZP(K))) IF(ZP(K).LE.TURZP) FDIFK(K,II)=EDDYMB*EXP(ALOG(EDDYC/EDDYMB) 1*(ZP(K)-ZPMB)/(TURZP-ZPMB)) IF(ZP(K).LE.ZPMB) FDIFK(K,II)=EDDYLB*EXP(ALOG(EDDYMB/EDDYLB) 1*(ZP(K)-ZP(1))/(ZPMB-EZB)) FDIFK(K,II)=FDIFO(K)+FDIFP(K) FT(K,II)=TN(K) FTE(K,II)=TE(K) FNO1D(K,II)=XNO1D(K) FRJ(K,II)=DSO2(K) FW(K,II)=WW(K) FU(K,II)=UU(K) PPN2D(K,II)=PN2D FNE(K,II)=XNE(K) PPN4S(K,II)=PN4S FK4O2P(K,II)=RK(4)*XIO2P(K) FK5O2P(K,II)=RK(5)*XIO2P(K) FK9OP(K,II)=RK(9)*XIOP(K) RSKIONS(K,II)=RK(13)*XIOP(K)+RK(14)*XIN2P(K) SCOI(K,II)=RK(13)*XIOP(K)*XNCO2(K) SCO2I(K,II)=1.E-20 RJCH4(K,II)=DCH4LYA(K)+DCH4EUV(K) RKCO2P(K,II)=DCO2LYA(K)+DCO2SRC(K)+DCO2SRB(K) RJCO2T(K,II)=DCO2LYA(K)+DCO2SRC(K)+DCO2SRB(K)+DCO2EUV(K) SH2OT(K,II)=DH2OT(K) YIOP(K,II)=XIOP(K) YIHP(K,II)=XIHP(K) YIOHP(K,II)=1.E-20 SH2OSRB(K,II)=DH2OSRB(K) SH2OSRC(K,II)=DH2OSRC(K) SH2OEUV(K,II)=DH2OEUV(K) SH2OLYA(K,II)=DH2OLYA(K) SHOXI(K,II)=QHOXI(K) RJH2OLY(K,II)=DH2OLYA(K) PHOXIC(K,II)=(QHOXO2(K)+QHOXNO(K))*QTIN(K) FIOP(K,II)=XIOP(K)*RK(22) XM=XNO(K)+XNO2(K)+XNN2(K) XNOX(K)=XNO(K)+XNO3(K) XNNOZ(K)=XNNO(K)+XNNO2(K) FNOX(K,II)=XNOX(K) FNNOZ(K,II)=XNNOZ(K) FM=XNO(K)+XNO2(K)+XNN2(K) DJOP(K)=QOP(K)/XNO(K) DJO2P(K)=QO2P(K)/XNO2(K) O3OR(K,II)=RKM(13)*XNO2(K)*FM/(DO3HAR(K)+DO3HUG(K)+DO3CHAP(K)+ 1 RKM(21)*XNOH(K)+RKM(26)*XNHO2(K)+RKM(29)*XNH(K)+RB(11)*XNNO(K)+ 2 RKM(16)*XNO(K)) SS=O3OR(K,II) OOXR(K,II)=1./(1.+O3OR(K,II)) RR=OOXR(K,II) A4=0.12*DH2OLYA(K)*XNH2O(K)+RKM(22)*XNOH(K)*XNOH(K)+RKM(32)* 1XNH(K)*XNHO2(K)+RB(3)*XN4S(K)*XNNO(K)+RB(6)*XN2D(K)*XNNO(K)+( 2XJNO(K)+RBB(9,K,II))*XNNO(K)+XJNO2(K)*XNNO2(K)+RK(4)*XIO2P(K) 2*XN4S(K) 3+RK(7)*XINP(K)*XNO2(K)+RK(10)*XIOP(K)*XN2D(K)+RK(12)*XIOP(K)* 4XNH(K)+ALP(1)*XINOP(K)*XNE(K)+2.*ALP(2)*XIO2P(K)*XNE(K) A5=2.*(DSO2SR(K)+DSO2SRB(K)+DSO2LYA(K))+RB(1)*XN4S(K) 1+RB(2)*XN2D(K)+RK(1)*XIOP(K) B1=RKM(10)*XNH2O(K)*XNO1D(K)+RKM(11)*XNH2(K)*XNO1D(K) B2=2.*RKM(16)*SS*RR*RR B3=RKM(21)*XNOH(K)*SS*RR+RKM(26)*XNHO2(K)*SS*RR+RKM(29)*XNH(K)*SS 1*RR+RKM(17)*XNOH(K)*RR+RKM(18)*XNHO2(K)*RR+RB(11)*XNNO(K)*SS*RR+ 2RB(13)*XNNO2(K)*RR+RB(15)*XNNO2(K)*SS*RR+DJOP(K)*RR+ 3RKM(40)*FM*XNCO(K)*RR C1=2.*RKM(16)*SS*RR*RR C2=RKM(17)*XNOH(K)*RR+(DO3HAR(K)+DO3HUG(K)+DO3CHAP(K))*SS*RR+ 1RKM(18)*XNHO2(K)*RR+RKM(21)*XNOH(K)*SS*RR+2.*RKM(26)*XNHO2(K)*SS 2*RR+RKM(29)*XNH(K)*SS*RR+RB(11)*XNNO(K)*SS*RR 3+RB(13)*XNNO2(K)*RR C3=RKM(23)*XNOH(K)*XNHO2(K)+RKM(27)*XNHO2(K)*XNHO2(K)+RKM(30)* 1XNH(K)*XNHO2(K)+RK(5)*XNNO(K)*XIO2P(K) D1=RKM(28)*FM*XNH(K)+RB(1)*XN4S(K)+RB(2)*XN2D(K)+RK(1)*XIOP(K) 1+RK(6)*XINP(K)+RK(7)*XINP(K)+RK(21)*XIN2P(K)+(DSO2SR(K)+DSO2SRB(K) 2+DSO2LYA(K))+DJO2P(K) 900 FORMAT(1X,*I AM HERE*) IF(K.GT.1) GO TO 993 B2=B2+2.*RKM(12)*FM*RR*RR B4=B1-A4-A5*XNO2(1) XNOX1=(-B3+SQRT(B3*B3-4.*B2*B4))/(2.*B2) XNOXS=XNOX1 XNO(1)=XNOXS*OOXR(1,II) XNO3(1)=O3OR(1,II)*XNO(1) PS2B(II)=(XNO(1)*16.+XNO3(1)*48.)/(XNO2(1)*32.+XNN2(1)*28.) 993 CONTINUE FS11(K,II)=-D1 FS12(K,II)=C2+C1*XNOX(K) FS21(K,II)=A5 FS22(K,II)=-B3-B2*XNOX(K) FS1(K,II)=C3 FS2(K,II)=A4-B1 C****************************************************************** C NEUTRAL SODIUM IN THE ARGON SLOT XJNAP=2.0E-5 RKSI1=1.4E-9 RKSI2=1.0E-9 RKSI3=6.2E-10 RKC1=2.5E-31*(200./TN(K))**1.6 RKCM1=1.4E-15 RKC2=3.2E-29 RKCM2=1.2E-17 RKC3=1.0E-9 RKC4=1.0E-9 RKC5=1.2E-6 RKC6=1.2E-6 RKSI4=0. RKSI5=0. RKS1=1.5E-9*EXP(-220./TN(K)) RKS2=0.3E-9*EXP(-383./TN(K)) RKS2S=1.2E-9*EXP(-383./TN(K)) RKS2T=RKS2+RKS2S RKS3=4.7E-30*(200./TN(K))**1.22 XJNAO2=4.0E-3 XJNAOH=1.0E-3 RKS6=1.0E-9*EXP(-1300./TN(K)) RKS7=8.0E-10*EXP(-374./TN(K)) RKS8=1.5E-9*EXP(636./TN(K)) RKS8S=3.2E-10*EXP(-550./TN(K)) RKS8T=RKS8+RKS8S RKS9=3.0E-10*EXP(-668./TN(K)) RKS10=1.0E-10 RKS11=3.E-10*EXP(-2000./TN(K)) RKS12=5.E-10*EXP(-1000./TN(K)) XM=XNO(K)+XNO2(K)+XNN2(K) C XNAOP(K)=RKSI4*XNO3(K)*XNASP(K)/(RKSI5*XNE(K)) XNAPN2(K)=RKC1*XNN2(K)*XM*XNASP(K)/(RKC3*XNCO2(K)+RKCM1*XM) XNAPCO2(K)=(RKC2*XNCO2(K)*XM*XNASP(K)+RKC3*XNCO2(K)*XNAPN2(K)) 1/(RKCM2*XM+RKC4*XNH2O(K)+RKC5*XNE(K)) XNAPH2O(K)=RKC4*XNH2O(K)*XNAPCO2(K)/(RKC6*XNE(K)) C AS=2.E-3 C AS=2.E-2 C ZPS=100. C H1S=24. C H2S=40. C PNAM(K)=AS*EXP(-((ZPHT(K)-ZPS)/H1S)**2)*EXP((ZPHT(K)-ZPS)/H2S) AS=1.E-4 ZPSS=89. H1SS=3. PNAM(K)=AS*EXP(-((ZPHT(K)-ZPSS)/H1SS)**2) A1=XJNAO2+RKS6*XNO(K)+RKS10*XNOH(K)+RKS11*XNH(K) B1=RKS1*XNO3(K) B2=RKS6*XNO(K)*RKS3*XNO2(K)*XNN2(K)/A1 B3=RKS2T*XNO(K)+RKS7*XNH2O(K)+RKS8T*XNO3(K)+RKS9*XNH(K) 1-RKS6*XNO(K)*RKS8*XNO3(K)/A1 A3=(B1+B2)/B3 B4=RKS3*XNO2(K)*XNN2(K) A2=(B4+RKS8*XNO3(K)*(B1+B2)/B3)/A1 A4=(RKS7*XNH2O(K)*A3+(RKS10*XNOH(K)+RKS11*XNH(K))*A2)/(RKS12* 1XNH(K)+XJNAOH) PNAS(K)=PNAM(K)+RKC5*XNE(K)*XNAPCO2(K)+RKC6*XNE(K)*XNAPH2O(K) 1+RKSI5*XNE(K)*XNAOP(K) XLNAS(K)=XJNAP+RKSI1*XIO2P(K)+RKSI2*XINOP(K)+RKSI3*XIN2P(K) 1+RKS1*XNO3(K)+RKS3*XNO2(K)*XNN2(K)-((RKS2T*XNO(K)+RKS8S*XNO3(K) 2+RKS9*XNH(K))*A3+XJNAO2*A2+(XJNAOH+RKS12*XNH(K))*A4) C XLNAS(K)=XJNAP+RKSI1*XIO2P(K)+RKSI2*XINOP(K)+RKSI3*XIN2P(K) IF(K.EQ.1) XLBNA(II)=PNAS(K)/XLNAS(K) PNA(K,II)=PNAS(K) XLNA(K,II)=XLNAS(K) RNAO(K,II)=A3 RNAO2(K,II)=A2 RNAOH(K,II)=A4 C IF(ITU.NE.1) GO TO 748 C FNAS(K,II)=FNAR(K,II)/(1.+A3+A2+A4) C FNAO(K,II)=FNAS(K,II)*A3 C FNAO2(K,II)=FNAS(K,II)*A2 C FNAOH(K,II)=FNAS(K,II)*A4 C748 CONTINUE DIP=50. SI=SIN(DIP/57.295) SII=SI*SI CI=COS(DIP/57.295) CII=CI*CI VINP=3.E-10*(XNO(K)+XNO2(K)+XNN2(K)) XMASO=23. BGAUS=0.4 WOI=9.57946E+3*BGAUS/XMASO RHOI=VINP/WOI COI=1./(1+RHOI*RHOI) UI(K)=COI*(RHOI*RHOI*UN(K)+RHOI*(-VN(K)*SI-WN(K)*CI)) 1+COI*(UIT+RHOI*VUT) VI(K)=COI*(RHOI*RHOI*VN(K)+RHOI*UN(K)*SI+VN(K)*CII-WN(K)*SI*CI) 1+COI*(VUT*SI-RHOI*UIT*SI) WI(K)=COI*(RHOI*RHOI*WN(K)+RHOI*UN(K)*CI-VN(K)*SI*CI+ 1WN(K)*SII)+COI*(VUT*CI-RHOI*UIT*CI) WGAM(K)=WI(K) FWI(K,II)=WI(K)/SHT(K) FUI(K,II)=VI(K) PNAP=0. PNASP(K)=(XJNAP+RKSI1*XIO2P(K)+RKSI2*XINOP(K)+RKSI3*XIN2P(K)) 1*XNAS(K)+PNAP XM=XNO(K)+XNO2(K)+XNN2(K) ASP=RKC1*XNN2(K)*XM/(RKC3*XNCO2(K)+RKCM1*XM) BSP=RKC2*XNCO2(K)*XM CSP=RKCM2*XM+RKC4*XNH2O(K)+RKC5*XNE(K) XLNASP(K)=RKC1*XNN2(K)*XM+RKC2*XNCO2(K)*XM+RKSI4*XNO3(K) 1-RKCM1*XM*ASP-RKCM2*XM*(BSP+RKC3*XNCO2(K)*ASP)/CSP IF(K.EQ.1) XLBNAI(II)=PNASP(K)/XLNASP(K) PNAI(K,II)=PNASP(K) XLNAI(K,II)=XLNASP(K) 99 CONTINUE C********************* C IF(II.EQ.IMXP)THEN C CALL CONREC(FNNO(1,1),KMXP,KMXP,IMXP,0.,0.,0.,0,0,-1430B) C CALL FRAME C CALL CONREC(FNNO2(1,1),KMXP,KMXP,IMXP,0.,0.,0.,0,0,-1430B) C CALL FRAME C ENDIF C********************* C IBNDNO=0, FLUX AT LOWER BOUNDARY, IBNDNO=1,PHOTOCHEMICAL EQUILIBRIUM IBNDNO=1 FLUXNO(II)=0. FLUXHE(II)=0. IBNDCO=1 FLUXCO(II)=0. HC1=BOLTZ*1000./(1.66E-24*GZ(KMX)) XNC1=2.75E+4 PI=3.1415926 B=0.72 HC=BOLTZ*TN(KMX)/(1.66E-24*GZ(KMX)) ALAMC=(6371.E+5+ZPHT(KMX)*1.E+5)/HC U=SQRT(2.*BOLTZ*TN(KMX)/1.66E-24) FAC=B*U*(1.+ALAMC)*EXP(-ALAMC)/(2.*SQRT(PI)) PHIJ=XNH(KMX)*FAC PHIP=0.36*PHIJ PHIE=2.8E+8*XNH(KMX)*HC*PHIJ/(5.E+7*XNC1*HC1) FHOX(II)=PHIJ+PHIP+PHIE 777 CONTINUE RETURN END SUBROUTINE DENMOD(UT,DT) SAVE PARAMETER(KMX=96,KIY=40,MMX=46) include "blank.h" include "solars.h" COMMON/DENTRF/QNN(KMX),QNMN(KMX),QNC(KMX),QN1D(KMX),DSNCHM(KMX), 1DSICHM(KMX),QO3PR(KMX),E630Z(KMX),E63DR(KMX),E63N2D(KMX), 2E6300(KMX),QHOXO2(KMX),QHOXNO(KMX),QHOXT(KMX),PARCD(KMX), 3SPED(KMX),SHAL(KMX),ALAMXX(KMX),ALAMXY(KMX),XNOF(KMX),QJOUL(KMX) COMMON/TRAVLH/RK(50),ALP(20),RB(20),RKM(60) COMMON/TRAVSL/AA,BB,CC,DD,EE,FF,GG,CI,HH,CJ,CK,RR COMMON/RGLWTR/QUENCH,A1D,A6300 COMMON/QIONDC/AR(54),ISWTC,ELEC COMMON/PIONTR/PHOXO2,PHOXNO,PHOXI,PHOXT COMMON/IONTRFF/XNPI(KMX),XNNI(KMX),XNEEE(KMX) DIMENSION BCB(3),ROOT(6),B(3),R(6) DIMENSION ACOF(5),XMASS(40) COMPLEX TOOT(4),RLAM DIMENSION Y(4), ATOL(4), RWORK(74), IWORK(24) DATA XME/5.486E-4/,QCHR/1.602E-19/ DATA XMASS/0.,0.,0.,0.,0.,30.,48.,66.,84.,58.,76.,94.,74.,92., 1 110.,32.,64.,80.,50.,36.,19.,37.,55.,73.,91.,109.,127.,145., 2 16.,32.,48.,64.,46.,62.,60.,76.,62.,60.,44.,34./ ERG=1.602E-12 FALP14S=0.2 FALP12D=0.8 FALP23P=0.15 FALP21D=0.85 FALP34S=0.5 FALP32D=0.5 A5577=1.28 A1S=1.36 Y1S=0.05 FOE=0.85 FN2D=1. QCHR2=QCHR*QCHR BGAUS=0.4 BG=BGAUS*1.E-4 CTTS=9.57946E+3*BGAUS WE=CTTS/XME C ****************************** DO 55 K=1,KMX CALL RATECOE(TI(K),TE(K),TN(K)) XINP(K)=(QINP(K)+RK(22)*XIOP(K)*XN2D(K)) 1/((RK(6)+RK(7))*XNO2(K)+RK(8)*XNO(K)) XIHP(K)=RK(12)*XNH(K)*XIOP(K)/(RK(11)*XNO(K)) 55 CONTINUE 900 FORMAT(1X,*I AM HERE*) M2=KMX-MMX+1 DO 5 M=1,M2 CALL RATECOE(TI(M),TE(M),TN(M)) XIOP(M)=(QOP(M)+RK(8)*XNO(M)*XINP(M)+RK(11)*XIHP(M)*XNO(M))/ 1(RK(1)*XNO2(M)+RK(2)*XNN2(M)+RK(9)*XNH2(M)+RK(10)*XNH2O(M)+ 2RK(12)*XNH(M)+RK(22)*XN2D(M)) 5 CONTINUE CALL OPDIFSV(UT,DT) DO 44 K=1,KMX CALL RATECOE(TI(K),TE(K),TN(K)) AA=QNOP(K)+RK(2)*XIOP(K)*XNN2(K)+RK(7)*XINP(K)*XNO2(K) BB=QO2P(K)+RK(1)*XIOP(K)*XNO2(K)+RK(6)*XINP(K)*XNO2(K) C 1+RK(21)*XIN2P(K)*XNO2(K) CC=RK(4)*XN4S(K)+RK(5)*XNNO(K) DD=QN2P(K) EE=RK(3)*XNO(K)+RK(21)*XNO2(K) FF=XIOP(K) GG=XINP(K) A4=ALP(1)*ALP(2)*ALP(3) A3=ALP(1)*(ALP(2)*EE+ALP(3)*CC)-ALP(1)*ALP(2)*ALP(3)*(FF+GG) A2=ALP(1)*EE*CC-ALP(1)*(ALP(2)*EE+ALP(3)*CC)*(FF+GG)-ALP(1)*ALP(2) 1*DD-ALP(1)*ALP(3)*BB-ALP(2)*ALP(3)*AA A1=-ALP(1)*(EE*CC*(FF+GG)+DD*CC+BB*EE)-ALP(2)*EE*(AA+DD)-ALP(3)* 1CC*(AA+BB) A0=-EE*CC*(AA+BB+DD) ACOF(1)=A0 ACOF(2)=A1 ACOF(3)=A2 ACOF(4)=A3 ACOF(5)=A4 CALL QUART(ACOF,SOOT,DELTA,G,H,RL,CDELTA,RLAM) XNE(K)=SOOT XIOP(K)=FF XIN2P(K)=DD/(EE+ALP(3)*XNE(K)) XINP(K)=GG XIO2P(K)=BB/(CC+ALP(2)*XNE(K)) XINOP(K)=(AA+EE*DD/(EE+ALP(3)*XNE(K))+CC*BB/(CC+ALP(2)*XNE(K 1)))/(ALP(1)*XNE(K)) XNPI(K)=XNE(K) XNEEE(K)=XNE(K) XNNI(K)=1.E-20 44 CONTINUE C****************************************************************** C ********************************************* C CALL OZONE(UT) DO 4 K=1,KMX CALL RATECOE(TI(K),TE(K),TN(K)) CALL RATECOF(TI(K),TE(K),TN(K)) QNN(K)=(RB(1)*XN4S(K)*XNO2(K)*1.4+RB(2)*XN2D(K)*XNO2(K)*1.84+ 1RB(3)*XN4S(K)*XNNO(K)*2.68+RB(4)*XN2D(K)*XNO(K)*2.38+RB(5)*XN2D(K) 2*XNE(K)*2.38+RB(6)*XN2D(K)*XNNO(K)*5.63+RB(10)*XN4S(K)*XNOH(K)*2.1 3+RB(11)*XNNO(K)*XNO3(K)*2.08+RB(12)*XNHO2(K)*XNNO(K)*0.35+RB(13)* 4XNNO2(K)*XNO(K)*1.98)*ERG/RHO(K) XM=XNO(K)+XNO2(K)+XNN2(K) QNMN(K)=(RKM(29)*XNH(K)*XNO3(K)*3.34+RKM(17)*XNO(K)*XNOH(K)*0.72 1+RKM(18)*XNO(K)*XNHO2(K)*2.39+RKM(28)*XNH(K)*XNO2(K)*XM*2.0 2+RKM(10)*XNO1D(K)*XNH2O(K)*1.23+RKM(11)*XNO1D(K)*XNH2(K)*1.88+ 3RKM(19)*XNO(K)*XNH2O2(K)*3.44+RKM(20)*XNO(K)*XNH2(K)*0.08+ 4RKM(21)*XNOH(K)*XNO3(K)*1.73+RKM(22)*XNOH(K)*XNOH(K)*.73+RKM(23)* 43.06* 5XNOH(K)*XNHO2(K)+RKM(24)*XNOH(K)+XNH2O2(K)*1.35+RKM(25)*XNOH(K)* 6XNH2(K)*0.65+RKM(26)*XNHO2(K)*XNO3(K)*1.23+RKM(27)*XNHO2(K)* 7XNHO2(K)*1.71+RKM(30)*XNH(K)*XNHO2(K)*2.41+RKM(30)*XNH(K)*XNHO2(K) 8*2.41+RKM(31)*XNH(K)*XNHO2(K)*1.61+RKM(32)*XNH(K)*XNHO2(K)*2.34+ 9RKM(33)*XNH(K)*XNH(K)*XM*4.52+RKM(35)*XNCH4(K)*XNOH(K)*5.38+ 1RKM(36)*XNO(K)*XNCH4(K)*4.65+RKM(37)*XNCH4(K)*XNO1D(K) 2+RKM(40)*XNO(K)*XM*XNCO(K)*5.51+RKM(41)*XNCO(K)*XNOH(K)*1.07 3)*ERG/RHO(K) QNN(K)=QNN(K)+QNMN(K) QNC(K)=(RK(1)*XIOP(K)*XNO2(K)*1.555+RK(2)*XIOP(K)*XNN2(K)*1.088+ 1RK(3)*XIN2P(K)*XNO(K)*0.70+RK(4)*XIO2P(K)*XN4S(K)*4.213+RK(5)* 2XIO2P(K)*XNNO(K)*2.813+RK(6)*XINP(K)*XNO2(K)*2.486+RK(7)*XINP(K) 3*XNO2(K)*6.699+ALP(1)*XINOP(K)*XNE(K)*(FALP12D*0.38+FALP14S* 42.75)+ALP(2)*XIO2P(K)*XNE(K)*(FALP23P*6.95+FALP21D*4.98)+ 5ALP(3)*XIN2P(K)*XNE(K)*(FALP34S*5.82+FALP32D*3.44)+RK(8)* 6XINP(K)*XNO(K)*0.93+RK(21)*XIN2P(K)*XNO2(K)*3.52+ 7RK(22)*XIOP(K)*XN2D(K)*1.45)*ERG/RHO(K) QN1D(K)=(FALP21D*ALP(2)*XIO2P(K)*XNE(K)+RB(2)*XN2D(K)*XNO2(K))* 1 1.96*ERG*(2.3E-11*XNN2(K)/(9.E-3+2.3E-11*XNN2(K)))/RHO(K) O1DEX(K)=FALP21D*ALP(2)*XIO2P(K)*XNE(K)+RB(2)*XN2D(K)*XNO2(K) DSNCHM(K)=RB(1)*XN4S(K)+RB(2)*XN2D(K) DSICHM(K)=(RK(4)*XIO2P(K)*XN4S(K)+RK(7)*XINP(K)*XNO2(K)+ALP(2)* 1XIO2P(K)*XNE(K))/XNO2(K) DSO2(K)=DSO2(K)+DSICHM(K)+DSNCHM(K) QO3PR(K)=(RKM(12)*XNO(K)*XM*XNO(K)*5.12+RKM(13)*XNO(K)*XNO(K) 1*XNO2(K)*1.05+RKM(14)*XNO(K)*XNO2(K)*XNO2(K)*1.05+RKM(15)* 2XNO(K)*XNO2(K)*XNN2(K)*1.05+RKM(16)*XNO(K)*XNO3(K)*4.06)*ERG/ 3RHO(K) QN(K)=QNN(K)+QNC(K)+QN(K)+QN1D(K)+QO3PR(K)+QNO3(K) DEN1=RKM(8)*XNO2(K)+RKM(9)*XNN2(K)+RKM(10)*XNH2O(K)+RKM(11)* 1XNH2(K)+RKM(37)*XNCH4(K)+A1D SR63(K)=SR63(K)*A6300/DEN1 E630Z(K)=DO3HAR(K)*XNO3(K)*A6300/DEN1 E63DR(K)=FOE*A6300*ALP(2)*XIO2P(K)*XNE(K)/DEN1 E63N2D(K)=FN2D*A6300*RB(2)*XN2D(K)*XNO2(K)/DEN1 E6300(K)=E63DR(K)+E63N2D(K)+SR63(K)+E630Z(K) XNT=XNO(K)+XNO2(K)+XNN2(K) XMOLP=(XIN2P(K)*28.+XIO2P(K)*32.+XIOP(K)*16.+XINOP(K)*30. 1+XINP(K)*14.)/XNE(K) BGAUS2=BGAUS*BGAUS WPOSI=CTTS/XMOLP WNEGI=0. ALAM=0. VINN=2.6E-09*XNT/SQRT(XMOLP) QHOXI(K)=0. QHOXO2(K)=0. QHOXNO(K)=0. QHOXT(K)=0. IF(K.GT.KIY) GO TO 10 HH=ZPHT(K) TTN=TN(K) AM=XNO(K)+XNO2(K)+XNN2(K) AN2=XNN2(K) CO2=XNCO2(K) H2O=XNH2O(K) O2=XNO2(K) O1=XNO(K) O3=XNO3(K) ANO1=XNNO(K) ANO2=XNNO2(K) C O2S=XNO2S(K) O2S=1.E-20 HNO3=1.E-20 QIO2P=QO2P(K)+QN2P(K)+QOP(K)+QINP(K) QINOP=QNOP(K) O2COL=TXNO2(K) ALPH1=ALP(1) ALPH3=ALP(2) ISWTC=0 CALL IONCOMP(HH,TTN,AM,AN2,CO2,H2O,O2,O3,O1,ANO1,ANO2,O2S,HNO3, 1QIO2P,QINOP,O2COL,ALPH1,ALPH3) QHOXI(K)=PHOXT*QPRO(K) QHOXO2(K)=PHOXO2 QHOXNO(K)=PHOXNO QHOXT(K)=PHOXT XNPI(K)=AR(4) XNNI(K)=AR(5) XNEEE(K)=AR(2) XIO2P(K)=AR(16) XINOP(K)=AR(6) XNE(K)=AR(2) ALAM=AR(3) XPOSI=AR(4) XNEGI=AR(5) SUM=0. DO 46 J=6,28 46 SUM=SUM+XMASS(J)*AR(J) SUN=0. DO 47 J=29,40 47 SUN=SUN+XMASS(J)*AR(J) XMOLP=SUM/AR(4) XMOLN=SUN/AR(5) WNEGI=CTTS/XMOLN WPOSI=CTTS/XMOLP VINN=2.6E-09*XNT/SQRT(XMOLN) 10 CONTINUE TW=TE(K) TE12=SQRT(TW) VEN=2.33E-11*XNN2(K)*TW*(1.-1.21E-4*TW)+1.82E-10*XNO2(K)*TE12*(1.+ 13.6E-2*TE12)+8.2E-10*XNO(K)*TE12 C VINP=2.6E-09*XNT/SQRT(XMOLP) COLFAC=1.5 VINP=0.73E-9*SQRT(TN(K)/1000.)*XNO(K)*COLFAC+0.69E-9*XNN2(K)+ 10.67E-9*XNO2(K) VEI=34.+4.18*ALOG10(TW**3/XNE(K))/TW**1.5 CN=1./(BG*QCHR) CKOE=CN*WE/(VEI+VEN) CKOP=CN*WPOSI/(VINP+VEI) CKON=CN*WNEGI/(VINN+VEI) PARCD(K)=XNE(K)*1.E+6*QCHR2*(CKOE+(1.+ALAM)*CKOP+ALAM*CKON) VP=VINP VN=VINN VE=VEN+VEI CKPE=CN*WE*VE/(VE*VE+WE*WE) CKPP=CN*WPOSI*VP/(VP*VP+WPOSI*WPOSI) CKPN=CN*WNEGI*VN/(VN*VN+WNEGI*WNEGI) SPED(K)=XNE(K)*1.E+6*QCHR2*(CKPE+(1.+ALAM)*CKPP+ALAM*CKPN) CKHE=CN*WE*WE/(VE*VE+WE*WE) CKHP=CN*WPOSI*WPOSI/(VP*VP+WPOSI*WPOSI) CKHN=CN*WNEGI*WNEGI/(VN*VN+WNEGI*WNEGI) SHAL(K)=XNE(K)*1.E+6*QCHR2*(CKHE-(1.+ALAM)*CKHP-ALAM*CKHN) ALAM1=SPED(K)*BGAUS2/RHO(K)*1.E-11 ALAM2=SHAL(K)*BGAUS2/RHO(K)*1.E-11 ALAMXX(K)=ALAM1 ALAMXY(K)=ALAM2 202 FORMAT(1X,I5,2X,8E12.4) XM=XNO(K)+XNO2(K)+XNN2(K) XNOF(K)=XN2D(K)+XN4S(K)+XNNO(K)+XNNO2(K) 4 CONTINUE TLAMXX=0. DO 988 K=2,KMX RZ=RHO(K) RZM=RHO(K-1) RW=0.5*(ZPHT(K)-ZPHT(K-1))*1.E+5 TLAMXX=TLAMXX+(ALAMXX(K)*RZ+ALAMXX(K-1)*RZM)*RW 988 CONTINUE AX=5.163E+11 TLAM=TLAMXX*AX AJOUL=7.5E+10 EMVV=SQRT(AJOUL*(BGAUS*1.E-3)**2/TLAM) EMV=EMVV EFIEL=EMV/(BGAUS*1.E-3) DO 82 K=1,KMX QJOUL(K)=ALAMXX(K)*EFIEL*EFIEL QN(K)=QN(K)+QJOUL(K) 82 CONTINUE RETURN END CDIR$ NOLIST SUBROUTINE QUART(A,ROOT,DELTA,G,H,RL,CDELTA,RLAM) SAVE COMPLEX CP DIMENSION A(5) DATA E/1.E-1200/ A0=A(5) A1=A(4)/4. A2=A(3)/6. A3=A(2)/4. A4=A(1) G=A0**2*A3-3.*A0*A1*A2+2.*A1**3 H=A0*A2-A1**2 RI=A0*A4-4.*A1*A3+3.*A2**2 RJ=A0*(A2*A4-A3**2)-A1*(A1*A4-A3*A2)+A2*(A1*A3-A2**2) RK=A0**2*RI-3.*H**2 RL=12.*H**2-A0**2*RI CH=-RI/12. CG=RJ/4. DELTA=RI**3-27.*RJ**2 CDELTA=CG**2+4.*CH**3 CP=CDELTA+E CP=(.5*(CG+CP**.5)+E)**(1./3.) RLAM=-2.*REAL(CP) P=A0*RLAM+A1**2-A0*A2+E P=SQRT(P) Q=(2.*RLAM+A2)**2-A0*A4+E Q=SQRT(Q) PQ=2.*A1*RLAM+A1*A2-A0*A3+E P=SIGN(P,Q*PQ) ROOT=P-A1 ROOT=(ROOT+SQRT(ROOT**2-A0*(A2+2.*RLAM-Q)))/A0 RETURN END SUBROUTINE EFIELD(XMLAT,XMLON,DAYNO,UT,ISEASAV,IUTAV,POT,VU,VE) SAVE C GIVES QUIET-DAY IONOSPHERIC ELECTROSTATIC PSEUDO-POTENTIAL AND E X B C DRIFTS AT 300 KM FOR SOLAR MINIMUM CONDITIONS. SEE RICHMOND ET AL. ( C 1980, P. ) FOR DEFINITIONS OF MAGNETIC COORDINATES, PSEUDO-POTENT C AND DRIFT COMPONENTS. C C INPUT PARAMETERS - C XMLAT, XMLON ARE MAGNETIC LATITUDE AND EAST LONGITUDE IN DEGREES. C DAYNO IS DAY NUMBER OF THE YEAR FROM 1. TO 365.24, WITH 1. BEING JA C UT IS UNIVERSAL TIME IN HOURS. C ISEASAV IS 0 IF NO SEASONAL AVERAGING IS DESIRED. C IS 1 FOR AVERAGE OVER NOV. - FEB. C IS 2 FOR AVERAGE OVER MAY -AUG. C IS 3 FOR AVERAGE OVER MAR., APR., SEPT., OCT. C IS 4 FOR AVERAGE OVER ENTIRE YEAR. C IF ISEASAV.NE.0, DAYNO IS IGNORED. C IUTAV IS 0 IF NO UT AVERAGING IS DESIRED. C IS 1 FOR AVERAGE OVER ALL UT AT THE FIXED LOCAL TIME GIVEN BY C UT + (XMLON - 69.)/15. C C OUTPUT PARAMETERS - C POT IS THE ELECTROSTATIC PSEUDO-POTENTIAL IN VOLTS. C VU IS THE DRIFT VELOCITY COMPONENT PERPENDICULAR TO THE GEOMAGNETIC C IN THE UPWARD/POLEWARD DIRECTION IN THE MAGNETIC MERIDIAN PLANE, C VE IS THE DRIFT VELOCITY COMPONENT IN THE MAGNETIC EASTWARD DIRECTI C M/S. C THE OUTPUT VALUES ARE GEOPHYSICALLY MEANINGFUL ONLY FOR LATITUDES BET C ABOUT -65 AND +65 DEGREES. IF ISEASAV OR IUTAV IS OUT OF RANGE POT C AND VE ARE SET TO -1/0. DIMENSION KF(128),LF(128),MF(128),NF(128),JF(128),Q(5),RS(16), 1 FUT(5),RR(16),RSRS(16),P(16),VP(16),PA(5,9),VA(5,9),FS(3), 2 FT(3,3),SML(4),CML(4), A(128),PB(9),VB(9) DATA IFIRST/1/,ISVP/5/,A/ * -70.,-183., 31.,-112., 19., -39., -2., 2., -33., 2., 2., *-111., 46., -4., -5., 7., 9., -17., 2., 9., -10., 2., * -9., 22., 145., -57., -42., -6., 6., -5., -2., 20., 16., * 16., -77., -18., 13., -8., 16., -52., -10., 7., 2., 11., * -28., 2., -85., -82., 3.,-281., -71., -25., -57., -50., 21., * -10., 10., -81., 24., 7., 5., 30., 32., 5., -5., 11., * -31., 8., 10., 20., -15., -42., 32., 7., -19., 7., 34., * -11., -15., 26., 21., 1., 22., 12., -2., 275., 777.,-318., *-320.,-208., 47., 429.,-523., 8., -35.,-224.,-450., -66., -7., * -8.,-231., 55., 6., -28., -51., -81., 48., 9., 2., -10., * 54., 16., 112., 69., -33., 120., -47., 5., -19., -17., -23., * -40., -22., -21., -7., -30., 15., 3./ IF (IFIRST.EQ.0) GO TO 510 IFIRST = 0 C (THROUGH STATEMENT 510) SET UP CONSTANT PARAMETERS IN FIRST CALL TO C SUBROUTINE. C SET UP VALUES OF XMLATP, TUP, TLP, AND DAYNOP WHICH ARE NOT EQUAL TO C UT, MAGNETIC LOCAL TIME, AND DAYNO, RESPECTIVELY. XMLATP = -361. IF (XMLATP.EQ.XMLAT) XMLATP = 0. TUP = -25. IF (TUP.EQ.UT) TUP = 0. TL = UT + (XMLON - 69.)/15. TLP = -25. IF (TLP.EQ.TL) TLP = 0. DAYNOP = -366. IF (DAYNOP.EQ.DAYNO) DAYNOP = 0. C (THROUGH STATEMENT 100) SELECT ONLY THOSE TERMS IN SERIES FOR WHICH C COEFFICIENTS A ARE DEFINED TO BE NON-ZERO. I = 0 DO 100 KP=1,3 LST = 4 - KP LEND = 2 + KP DO 100 LP = LST,LEND L = LP - 3 IF (MOD(KP+LP,2) .NE.0) GO TO 100 DO 90 NP=2,8 N = NP - 1 IF (KP.NE.3.AND.N.GT.6) GO TO 90 IF (IABS(L).EQ.2.AND.N.GT.5) GO TO 90 DO 80 MP = 1,9 M = MP - 5 IF (IABS(M).GT.N) GO TO 80 IF (IABS(M).GT.3.AND.IABS(L).EQ.2) GO TO 80 IF (MOD(N-M,2).NE.0) GO TO 80 I = I + 1 KF(I) = KP LF (I)= LP NF(I) = NP MF(I) = MP 80 CONTINUE 90 CONTINUE 100 CONTINUE IMAX = I FT(1,1) = .75*SQRT(6.E0)/3.1415926535898 FT(1,2) = 2.E0*FT(1,1) FT(1,3) = 1.E0 FT(2,1) = FT(1,1) FT(2,2) = -FT(1,2) FT(2,3) = 1.E0 FT(3,1) = FT(2,2) FT(3,2) = 0. FT (3,3) = 1.E0 HRANG= 3.1415926535898/12. DANG = 3.1415926535898/182.62 SQ2 = SQRT(2.E0) RAD = 180./3.1415926535898 RB = -6.671E6*5.2E-5 C RB IS -(EARTH RADIUS + 3.E5 M) TIMES DIPOLE MAGNETIC FIELD AT POLE AT DO 400 I=1,IMAX MM = IABS(MF(I) - 5) C JF GIVES APPROPRIATE INDEX OF LEGENDRE POLYNOMIALS AS ORDERED BETWEEN C STATEMENTS 530 AND 595. 400 JF(I) = (2*(NF(I) + 7*MM) - (MM - 1)**2 + 4)/4 C (THROUGH STATEMENT 500) COMPUTE RR (DEFINED AS R(N,M)*R(N-1,M)) AND R C (DEFINED AS R(N-1,M)**2 + R(N-2,M)**2) NEEDED FOR LEGENDRE POLYNOMI C GENERATING RECURSION RELATIONS, WHERE R(N,M) IS DEFINED AS C SQRT(N**2 - M**2)/SQRT(4*N**2 - 1). ORDERING IS SAME AS FOR P(N,M) J = 0 DO 500 MP=1,5 M = MP - 1 XM = M IF (M.NE.0) Q(MP) = SQRT((2.*XM + 1.)/(2.*XM)) DO 500 NP = MP,8,2 N = NP - 1 XNS = N*N XNMS = (N-1)**2 J = J + 1 RS(J) = (XNS - XM*XM)/(4.*XNS - 1.) RSM = (XNMS - XM*XM)/(4.*XNMS - 1.) RR(J) = SQRT(RS(J)*RSM) IF (NP.NE.MP) RSRS(J) = RSM + RS(J - 1) 500 CONTINUE 510 CONTINUE IF (IUTAV.LT.0.OR.IUTAV.GT.1) GO TO 988 IF (IABS(ISEASAV-2).GT.2) GO TO 988 C (THROUGH STATEMENT 530) IF SEASONAL HARMONIC AMPLITUDES ARE DIFFERENT C PREVIOUS CALL TO THIS SUBROUTINE, RECOMPUTE THEM. ICPT = 0 IF (ISEASAV.EQ.ISVP) GO TO 524 ICPT = 1 ISVP = ISEASAV C (THROUGH STATEMENT 530) FS(1), FS(2), FS(3) ARE FACTORS FOR AMPLITUDE C SEMIANNUAL, ANNUAL, YEARLY AVERAGE COMPONENTS, RESPECTIVELY. C IF ISEASAV = 0, COMPUTE FS FOR GIVEN DAY OF THE YEAR. IF (ISEASAV.EQ.0)GO TO 525 C IF ISEASAV = 4, USE ONLY YEARLY AVERAGE COMPONENT. IF (ISEASAV.EQ.4) GO TO 527 C IF ISEASAV = 1 - 3, COMPUTE FS FOR APPROPRIATE SEASONAL AVERAGE. DO 521 K=1,3 521 FS(K) = FT(ISEASAV,K) GO TO 530 524 CONTINUE IF (ISEASAV.NE.0) GO TO 530 IF (DAYNO.EQ.DAYNOP) GO TO 530 525 DAYNOP = DAYNO ICPT = 1 ANG = (DAYNO + 9.)*DANG FS(1) = SQ2*COS(2.*ANG) FS(2) = SQ2*COS(ANG) FS(3) = 1. GO TO 530 527 FS(1) = 0. FS(2) = 0. FS(3) = 1. 530 CONTINUE C IF MAGNETIC LATITUDE IS SAME AS IN PREVIOUS CALL TO THIS SUBROUTINE, C STATEMENT 596. IF (XMLAT.EQ.XMLATP) GO TO 596 ICPT = 1 XMLATP = XMLAT CT = SIN(XMLAT/RAD) CTS = CT*CT ST = SQRT(1. - CTS) RBT = RB*SQRT(.25 + .75*CTS) C (THROUGH STATEMENT 595) CALCULATE LEGENDRE POLYNOMIALS P(N,M) AS WELL C DEFINED AS (DP(N,M)/D(COLATITUDE))/(RB*CT). J = 0 DO 595 MP = 1,5 C FOR MP=1, P=P(N,M). FOR MP.GT.1, P=P(N,M)/ST. THIS DIFFERENCE IS SO C PROGRAM NEVER DIVIDES BY ST. J = J + 1 XM = MP - 1 MPP = MP + 2 IF (MP.GT.1) GO TO 550 X = 1. P(1) = 1.E0 XZ = 2.*ST/RB VP(1) = 0. GO TO 560 550 P(J) = Q(MP)*X X = P(J)*ST VP(J) = XM*P(J)/RB XZ = 2.*ST*ST/RB 560 DO 590 NP = MPP,8,2 J = J + 1 Z = 0. ZP = 0. IF (NP.EQ.MPP) GO TO 570 Z = RR(J-1)*P(J-2) ZP = RR(J-1) *VP(J-2) 570 P(J) = ((CTS - RSRS(J))*P(J-1) - Z)/RR(J) 590 VP(J) = ((CTS - RSRS(J))*VP(J-1) - ZP - XZ*P(J-1))/RR(J) 595 CONTINUE 596 CONTINUE C (THROUGH STATEMENT 600) CALCULATE ARRAYS OF FOURIER COEFFICIENTS, WIT C INDICATING HARMONIC OF UT AND MPF INDICATING HARMONIC OF MAGNETIC L C TIME. IF ARRAYS ARE SAME AS IN PREVIOUS CALL TO THIS SUBROUTINE, S C STATEMENT 601. IF (ICPT.EQ.0) GO TO 601 DO 597 MPF = 1,9 DO 597 LP=1,5 PA(LP,MPF) = 0. 597 VA(LP,MPF) = 0. DO 600 I=1,IMAX LP = LF(I) MPF = MF(I) J = JF(I) X = A(I)*FS(KF(I)) PA(LP,MPF) = PA(LP,MPF) + X*P(J) VA(LP,MPF) = VA(LP,MPF) + X*VP(J) 600 CONTINUE 601 CONTINUE C (THROUGH STATEMENT 607) CALCULATE FOURIER COEFFICIENTS PB AND VB AT G C FOR HARMONICS OF TL. C IF UT IS SAME AS IN PREVIOUS CALL TO THIS SUBROUTINE, SKIP TO STATEME IF (UT.EQ.TUP) GO TO 603 TUP = UT ICPT = 1 TUA = UT*HRANG SL = SIN(TUA) CL = COS(TUA) FUT(3) = 1. FUT(2) = SQ2*CL FUT(4) = SQ2*SL FUT(1) = CL*FUT(2) - SL*FUT(4) FUT(5) = CL*FUT(4) + SL*FUT(2) 603 CONTINUE IF (ICPT.EQ.0) GO TO 608 DO 607 MPF = 1,9 PB(MPF) = 0. VB(MPF) = 0. DO 605 LP=1,5 IF (IUTAV.NE.0.AND.LP.NE.3) GO TO 605 PB(MPF) = PB(MPF) + FUT(LP)*PA(LP,MPF) VB(MPF) = VB(MPF) + FUT(LP)*VA(LP,MPF) 605 CONTINUE 607 CONTINUE C TL IS MAGNETIC LOCAL TIME. 608 TL = UT + (XMLON - 69.)/15. C IF TL IS SAME AS IN PREVIOUS CALL TO THIS SUBROUTINE, SKIP TO STATEME IF (TL.EQ.TLP) GO TO 630 TLP = TL C (THROUGH STATEMENT 610) CALCULATE SINES AND COSINES, TIMES SQ2, OF HA C OF MAGNETIC LOCAL TIME. TLA = TL*HRANG SL = SIN(TLA) CL = COS(TLA) SML(1) = SQ2*SL CML(1) = SQ2*CL DO 610 M=2,4 SML(M) = CL*SML(M-1) + SL*CML(M-1) 610 CML(M) = CL*CML(M-1) - SL*SML(M-1) C CALCULATE POT, VE, AND VU BY SUMMING FOURIER COEFFICIENTS MULTIPLIED C APPROPRIATE SINES AND COSINES. 630 POT = 0. VE = 0. VU = 0. DO 640 M=1,4 MPF = M+5 MMF = 5 - M XM = M POT = POT + PB(MPF)*SML(M) + PB(MMF)*CML(M) VE = VE + VB(MPF)*SML(M) + VB(MMF)*CML(M) 640 VU = VU + XM*(PB(MPF)*CML(M) - PB(MMF)*SML(M)) POT = POT*ST + PB(5) VE = VE + VB(5) VU = VU/RBT GO TO 999 988 POT = -1/IFIRST VU = -1/IFIRST VE = -1/IFIRST 999 RETURN END SUBROUTINE FUNC(NPDE,NZP2,ZN,TM,UM,UZN,AN,BN,CN) SAVE PARAMETER(KMX=96,MMX=46,MMX1=47,MMX2=48) include "solars.h" REAL ZN(NZP2),UM(NPDE,NZP2),AN(NPDE,NZP2),BN(NPDE,NZP2), 1CN(NPDE,NZP2),UZN(NPDE,NZP2) COMMON/SOLVTR/TP(MMX),DA(MMX),SHI(MMX),ATP(MMX),DAZ(MMX), 1SHIZ(MMX),ATPZ(MMX),ATPZZ(MMX),BNTR(MMX),CNTR(MMX),BRTR,QQOP(MMX) 2,XLOP(MMX),SHA(KMX),SHAZ(KMX),SHII(KMX),DAA(KMX) COMMON/TRAVLH/RK(50),ALP(20),RB(20),RKM(60) M1=KMX-MMX DO 1 KK=2,MMX1 K=KK-1 M=M1+K AN(1,KK)=DA(K)/(SHA(K)*SHA(K)) BN(1,KK)=BNTR(K)/SHA(K)-DA(K)*SHAZ(K)/(SHA(K)**3) CN(1,KK)=QOP(M)+QQOP(K)+(CNTR(K)-XLOP(K))*UM(1,KK) 1 CONTINUE AN(1,1)=AN(1,2) BN(1,1)=BN(1,2) CN(1,1)=CN(1,2) AN(1,MMX2)=AN(1,MMX1) BN(1,MMX2)=BN(1,MMX1) CN(1,MMX2)=CN(1,MMX1) RETURN END SUBROUTINE GTM(RLATG,RLONG,RLATMP,RLONMP,RLATM,RLONM,DIP,DEC,W,N) SAVE C **** TRANSFORMS GEOGRAPHIC COORDINATES TO GEOMAGNETIC, C **** CALCULATES DIP AND DECLINATION. C **** C **** RLATG(N), RLONG(N) -- N-DIMENSIONAL ARRAYS OF GEOGRAPHIC C **** LATITUDES AND CORRESPONDING LONGITUDES. (RADIANS) C **** C **** RLATMP, RLONMP -- GEOGRAPHIC COORDINATES OF GEOMAGNETIC C **** NORTH POLE. (RADIANS) C **** C **** RLATM(N), RLONM(N) -- OUTPUT ARRAYS OF GEOMAGNETIC C **** COORDINATES. (RADIANS) C **** C **** DIP(N), DEC(N) -- OUTPUT ARRAYS OF DIP AND DECLINATION. C **** C **** W(N,4) -- WORKING ARRAY. C **** C **** N -- NUMBER OF (LAT,LON) POINTS TO BE TRANSFORMED. C **** DIMENSION RLATG(N),RLONG(N),RLATM(N),RLONM(N),DIP(N),DEC(N),W(N,4) DATA E/1.E-10/ SINLAM=SIN(RLATMP) COSLAM=COS(RLATMP) DO 1 I=1,N W(I,1)=SIN(RLATG(I)) W(I,2)=COS(RLATG(I)) W(I,3)=SIN(RLONG(I)+E-RLONMP) W(I,4)=COS(RLONG(I)+E-RLONMP) W(I,4)=SINLAM*W(I,1)+COSLAM*W(I,2)*W(I,4) RLONM(I)=ATAN2(W(I,3)*W(I,2),(W(I,4)*SINLAM-W(I,1))/COSLAM) RLATM(I)=ASIN(W(I,4)) C DEC(I)=ATAN2(COSLAM,(SINLAM-W(I,1)*W(I,4))/(W(I,2)*W(I,3))) DEC(I)=ATAN2(COSLAM*W(I,2)*W(I,3),SINLAM-W(I,1)*W(I,4)) DEC(I)=-DEC(I) DIP(I)=ATAN(2.*TAN(RLATM(I))) 1 CONTINUE RETURN ENTRY MTG(RLATG,RLONG,RLATMP,RLONMP,RLATM,RLONM,W,N) C **** INVERSE TRANSFORMATION C **** C **** PARAMETERS AS ABOVE EXCEPT INPUT -- RLATM,RLONM C **** OUTPUT -- RLATG,RLONG C **** SINLAM=SIN(RLATMP) COSLAM=COS(RLATMP) SINLOM=SIN(RLONMP) COSLOM=COS(RLONMP) DO 2 I=1,N W(I,1)=SIN(RLATM(I)) W(I,2)=COS(RLATM(I)) W(I,3)=SIN(RLONM(I)) W(I,4)=COS(RLONM(I)) RLATG(I)=SINLAM*W(I,1)-COSLAM*W(I,2)*W(I,4) W(I,3)=W(I,3)*W(I,2) W(I,4)=-(RLATG(I)*SINLAM-W(I,1))/COSLAM RLATG(I)=ASIN(RLATG(I)) RLONG(I)=ATAN2(SINLOM*W(I,4)+COSLOM*W(I,3),COSLOM*W(I,4)-SINLOM A*W(I,3)) 2 CONTINUE RETURN END CDIR$ NOLIST PROGRAM GWAVE2D CDIR$ BOUNDS SAVE c c This program is used to illustrate the linear wave produced by a c gaussian wave form in time. Note that the horizontal is periodic c with fixed wavelength scale PARAMETER (MX=21,ITMX=21,MZ=96,KMX=96,MT=50,NV=2,KMXP=96) PARAMETER (ITX=12) c PARAMETER (ITX=288) PARAMETER (IMXP2=MX+1) C include "blank.h" include "solars.h" include "sodium.h" COMMON/TRAVLH/RK(50),ALP(20),RB(20),RKM(60) COMMON/NOZTRF/XNNOZ(KMX) COMMON/EDDTRF/EDY(KMX) COMMON/WINDTRF/UN(KMX),VN(KMX),WN(KMX),UI(KMX),VI(KMX),WI(KMX) 1,WGAM(KMX),DWGAM(KMX),UIT,VUT COMMON/INDEXX/ITIME,IAUR,ISOLPRO COMMON/PERTRF/TNO(KMX),TNP(KMX),FDIFP(KMX) COMMON/IONTRFF/XNPI(KMX),XNNI(KMX),XNEEE(KMX) C DIMENSION ZPP(MZ),WOUT(7,MX,MZ),WOUTT(5,MX,MZ) c DIMENSION ZPP(MZ),X(MX),WOUT(7,MX,MZ),WOUTT(5,MX,MZ) c DIMENSION ZPP(MZ),X(MX),WOUT(7,MX,MZ),WOUTT(5,MX,MZ), c 1SHTO(MZ) C common/plt4/ AWGAM(ITX,KMX),AVGAM(ITX,KMX),AXNASP(ITX,KMX), 1 AXNAS(ITX,KMX),TIMES(ITX),ZHTT(ITX,KMX) dimension fplt(itx,kmx,4),vp(4) equivalence(fplt,awgam) character*8 flab(4) character*56 toplab data flab /'WGAM ','VGAM ','XNASP ','XNAS '/ c COMMON/TIMETRF/TIMEE common/iyrday/IYD COMMON/OXOXOX2/O3OR(KMX,-1:IMXP2),XNOX(KMX), 1 OOXR(KMX,-1:IMXP2),FNOX(KMX,-1:IMXP2),XNOX1, 1 PS2B(-1:IMXP2) COMMON /PARA/ CP,RG,GA,H,G,TEMPO,DTO,TO,WO, < IZM,XKX,XKZ,OMEGO,DR,PI,ALPHA,ALTO,DZP,ZPO < ,DX,XO,IXM C COMMON/NOZNOZ2/SNO2NO(KMX,-1:IMXP2),RNONOZ(KMX,-1:IMXP2), 1 FNNOZ(KMX,-1:IMXP2) DATA DX/400.0e+5/,XO/0.0/,DZP/0.2/ > ,ZPO/-14.0/ c common/ehist/shto(mz),eox(mx,mz),eo(mx,mz),eo3(mx,mz),ehox(mx,mz), + eh(mx,mz),eho2(mx,mz),eoh(mx,mz),enoz(mx,mz),eno(mx,mz), + eno2(mx,mz),en4s(mx,mz),enas(mx,mz),enasp(mx,mz),ene(mx,mz), + etion(mx,mz),eo2(mx,mz),en2(mx,mz),eo1d(mx,mz),ete(mx,mz), + eti(mx,mz),etn(mx,mz),eiop(mx,mz),en2d(mx,mz),enh2o(mx,mz), + enh2(mx,mz),ench4(mx,mz),enh2o2(mx,mz),enco(mx,mz),enco2(mx,mz) + ,enax(mx,mz),enao(mx,mz),enao2(mx,mz),enaoh(mx,mz) c c Arrays in /pcontour/ are for contouring (see plt.f): C C HTINT(NHTINT) = heights at which to interpolate C (set to 66,68,...,198,200 by BF, 5/90) C FINT(MX,NHTINT) = interpolated field for contouring C PARAMETER(NHTINT=68,HT1=66.,DHT=2.) common/pcontour/ ETNN(MX,MZ),UWIND(MX,MZ),VWIND(MX,MZ), + WWIND(MX,MZ),ZHT(MX,MZ), + PKE(MX,MZ),pui(mx,mz),pvi(mx,mz),pwi(mx,mz),pwgam(mx,mz), + POX(MX,MZ),PNE(MX,MZ),PO(MX,MZ),PO3(MX,MZ),PHOX(MX,MZ), + PH(MX,MZ),POH(MX,MZ),PHO2(MX,MZ),PNOZ(MX,MZ),PNO(MX,MZ), + PNO2(MX,MZ),PN4S(MX,MZ),PLNAS(MX,MZ),PLNASP(MX,MZ), + eun(mx,mz),ewn(mx,mz),eke(mx,mz),UWINDZ(MX,MZ), + EDDT(MX,MZ),TNPER(MX,MZ),HTINT(NHTINT),FINT(MX,NHTINT),x(mx) dimension GINT(ITX,NHTINT) COMMON/EDDYTRE/FDIFO(KMX) COMMON/WIND/UU(KMX),WW(KMX) C COMMON/FIELDS2/FT(KMX,-1:IMXP2),FNO2(KMX,-1:IMXP2), 1 FNO(KMX,-1:IMXP2),FNN2(KMX,-1:IMXP2),FNAR(KMX,-1:IMXP2), 2 FNHE(KMX,-1:IMXP2),FNNO(KMX,-1:IMXP2),FNN2D(KMX,-1:IMXP2), 3 FNN4S(KMX,-1:IMXP2),FRJ(KMX,-1:IMXP2),FW(KMX,-1:IMXP2), 4 FNHOX(KMX,-1:IMXP2),PPN2D(KMX,-1:IMXP2),FNE(KMX,-1:IMXP2), 5 PPN4S(KMX,-1:IMXP2),FK4O2P(KMX,-1:IMXP2), 6 FK5O2P(KMX,-1:IMXP2),FF107,FTE(KMX,-1:IMXP2), 7 FDIFK(KMX,-1:IMXP2),FU(KMX,-1:IMXP2),FNAS(KMX,-1:IMXP2), 8 FNAO(KMX,-1:IMXP2),FNAO2(KMX,-1:IMXP2),FNAOH(KMX,-1:IMXP2) C COMMON/FIELDT2/FNH2O(KMX,-1:IMXP2),FNH2O2(KMX,-1:IMXP2), 1 FNO1D(KMX,-1:IMXP2),FNH2(KMX,-1:IMXP2),FNOH(KMX,-1:IMXP2), 2 FNHO2(KMX,-1:IMXP2),FNO3(KMX,-1:IMXP2),FNH(KMX,-1:IMXP2), 3 FNCH4(KMX,-1:IMXP2),FNCO(KMX,-1:IMXP2),FNCO2(KMX,-1:IMXP2), 4 FNNO2(KMX,-1:IMXP2) C COMMON/SODIUMP/PNA(KMXP,-1:IMXP2),XLNA(KMXP,-1:IMXP2), 1XLBNA(-1:IMXP2),PNAI(KMXP,-1:IMXP2),XLNAI(KMXP,-1:IMXP2), 2XLBNAI(-1:IMXP2),RNAO(KMXP,-1:IMXP2),RNAO2(KMXP,-1:IMXP2), 3RNAOH(KMXP,-1:IMXP2) C CALL OPNGKS INUMXY=0 CHARSZ = 0.025 CHSZNEG = -CHARSZ EXPSZ = 0.019 DO 50 I=1,NHTINT 50 HTINT(I) = HT1-DHT+FLOAT(I)*DHT C MXM=MX MZM=MZ F107=70. F107A=70. IYD=76080 DAY=80. STL=12. GLAT=18.3 GLONG=0. RE=6371.E+5 BOLTZ=1.38E-16 ITIME=0 ISOLPRO=0 UT=0. c c If IW < 0 restart will read from abs(iw), otherwise c it will write to iw c IW=-90 C IW=-5 CALL RESTART(UT,IW) DO 15 IX=1,MX X(IX)=XO+(IX-1)*DX 15 CONTINUE DO 25 IZ=1,MZ ZP(IZ)=(IZ-1)*DZP+ZPO ZPP(IZ)=ZP(IZ) 25 CONTINUE DO 88 J=1,MZ EDDYC=2.0E-6 EDDYMB=8.5E-7 ZPMB=-9.0 EDDYLB=8.0E-8 EZB=-14. TURZP=-6.5 FDIFO(J)=EDDYC*EXP((TURZP-ZP(J))) IF(ZP(J).LE.TURZP) FDIFO(J)=EDDYMB*EXP(ALOG(EDDYC/EDDYMB)*(ZP(J)- 1ZPMB)/(TURZP-ZPMB)) IF(ZP(J).LE.ZPMB) FDIFO(J)=EDDYLB*EXP(ALOG(EDDYMB/EDDYLB)*(ZP(J)- 1ZP(1))/(ZPMB-EZB)) XNAPCO2(J)=1.E-20 XNAPH2O(J)=1.E-20 XNAOP(J)=1.E-20 XNAPN2(J)=1.E-20 88 CONTINUE DTIME=300. C**************************** DO 500 IT=1,ITX C**************************** c write(6,"('500 loop: it=',i3,' itx=',i3)") it,itx TIME=DTIME+(IT-1)*DTIME TIMEE=TIME/3600. TIMES(IT)=TIMEE C ******************************************************* C C RAY YOU ONLY REQIURE KNOWLEDGE OF GRID C THEN A SINGLE CALL TO SUBROUTINE TIDE C C CALL TIDES(TIME,X,MXM,ZPP,MZM,TNO,SHTO,WOUTT) ISEASAV=0 IUTAV=0 GMLAT=29.7 GMLONG=7.8 UTT=TIMEE-4. IF(UTT.LT.0) UTT=UTT+24. IF(UTT.GT.24.) UTT=UTT-24. DAYP=DAY C CALL EFIELD(GMLAT,GMLONG,DAYP,UTT,ISEASAV,IUTAV,POT,VU,VE) C UIT=VE*1.E+2 C VUT=VU*1.E+2 UIT=0. VUT=0. C C C ******************************************************* DO 444 I=1,MX DO 444 J=1,MZ EDDT(I,J)=0. C UWIND(I,J)=WOUTT(1,I,J)*1.E+2 C VWIND(I,J)=WOUTT(2,I,J)*1.E+2 C WWIND(I,J)=WOUTT(3,I,J)*SHTO(J) C TNPER(I,J)=WOUTT(4,I,J) C ZHT(I,J)=ZPHT(J)+WOUTT(5,I,J)*1.E-5 UWIND(I,J)=0. VWIND(I,J)=0. WWIND(I,J)=0. TNPER(I,J)=0. ZHT(I,J)=ZPHT(J) EUN(I,J)=VWIND(I,J) EWN(I,J)=WWIND(I,J) ETN(I,J)=TNO(J)+TNPER(I,J) EKE(I,J)=FDIFO(J)+EDDT(I,J) FNO2(J,I)=EO2(I,J) FNO(J,I)=EO(I,J) FNO3(J,I)=EO3(I,J) FNOX(J,I)=EOX(I,J) FNN2(J,I)=EN2(I,J) FNNOZ(J,I)=ENOZ(I,J) FNNO(J,I)=ENO(I,J) FNNO2(J,I)=ENO2(I,J) FNN2D(J,I)=EN2D(I,J) FNN4S(J,I)=EN4S(I,J) FNCH4(J,I)=ENCH4(I,J) FNH2(J,I)=ENH2(I,J) FNCO2(J,I)=ENCO2(I,J) FNCO(J,I)=ENCO(I,J) FNHOX(J,I)=EHOX(I,J) FNH2O(J,I)=ENH2O(I,J) FNH(J,I)=EH(I,J) FNHO2(J,I)=EHO2(I,J) FNOH(J,I)=EOH(I,J) FNH2O2(J,I)=ENH2O2(I,J) FNAS(J,I)=ENAS(I,J) FNHE(J,I)=ENASP(I,J) FNAR(J,I)=ENAX(I,J) FNAO(J,I)=ENAO(I,J) FNAO2(J,I)=ENAO2(I,J) FNAOH(J,I)=ENAOH(I,J) 444 CONTINUE DO 445 I=1,MX DO 446 J=1,MZ UN(J)=UWIND(I,J) VN(J)=VWIND(I,J) WN(J)=WWIND(I,J) EDY(J)=EKE(I,J) TNP(J)=TNPER(I,J) FDIFP(J)=EDDT(I,J) XNOX(J)=EOX(I,J) XNO(J)=EO(I,J) XNO3(J)=EO3(I,J) XNHOX(J)=EHOX(I,J) XNH(J)=EH(I,J) XNOH(J)=EOH(I,J) XNHO2(J)=EHO2(I,J) XNNOZ(J)=ENOZ(I,J) XNNO(J)=ENO(I,J) XNNO2(J)=ENO2(I,J) XN4S(J)=EN4S(I,J) XNAS(J)=ENAS(I,J) XNASP(J)=ENASP(I,J) XNAX(J)=ENAX(I,J) XNE(J)=ENE(I,J) XNPI(J)=ETION(I,J) XNO2(J)=EO2(I,J) XNN2(J)=EN2(I,J) XNO1D(J)=EO1D(I,J) RHO(J)=(16.*XNO(J)+32.*XNO2(J)+28.*XNN2(J))*1.66E-24 TN(J)=ETN(I,J) TE(J)=ETE(I,J) TI(J)=ETI(I,J) XIOP(J)=EIOP(I,J) XN2D(J)=EN2D(I,J) XNH2O(J)=ENH2O(I,J) XNH2(J)=ENH2(I,J) XNCH4(J)=ENCH4(I,J) XNH2O2(J)=ENH2O2(I,J) XNCO(J)=ENCO(I,J) XNCO2(J)=ENCO2(I,J) UU(J)=VWIND(I,J) WW(J)=WWIND(I,J)/SHTO(J) 446 CONTINUE CALL COLUMN(UT) CALL SOLHEAT(UT) CALL DENMOD(UT,DTIME) C CALL NADIFSV(UT,DTIME) CALL COMPSEU(DTIME,I,IT) DO 447 J=1,MZ ENE(I,J)=XNE(J) ETION(I,J)=XNPI(J) EO1D(I,J)=XNO1D(J) ETE(I,J)=TE(J) ETI(I,J)=TI(J) ETN(I,J)=TN(J) EIOP(I,J)=XIOP(J) EN2D(I,J)=XN2D(J) PUI(I,J)=UI(J) PVI(I,J)=VI(J) PWI(I,J)=WI(J) PWGAM(I,J)=WGAM(J) 447 CONTINUE 445 CONTINUE DS=0.2 SB=-14. CALL FACE2(DTIME,DS,SB,DX) DO 450 I=1,MX DO 450 J=1,MZ EO2(I,J)=FNO2(J,I) EO(I,J)=FNO(J,I) EO3(I,J)=FNO3(J,I) EOX(I,J)=FNOX(J,I) EN2(I,J)=FNN2(J,I) ENOZ(I,J)=FNNOZ(J,I) ENO(I,J)=FNNO(J,I) ENO2(I,J)=FNNO2(J,I) EN4S(I,J)=FNN4S(J,I) ENCH4(I,J)=FNCH4(J,I) ENH2(I,J)=FNH2(J,I) ENCO2(I,J)=FNCO2(J,I) ENCO(I,J)=FNCO(J,I) EHOX(I,J)=FNHOX(J,I) ENH2O(I,J)=FNH2O(J,I) EH(I,J)=FNH(J,I) EHO2(I,J)=FNHO2(J,I) EOH(I,J)=FNOH(J,I) ENH2O2(I,J)=FNH2O2(J,I) ENASP(I,J)=FNHE(J,I) ENAX(I,J)=FNAR(J,I) FNAS(J,I)=FNAR(J,I)/(1.+RNAO(J,I)+RNAO2(J,I)+RNAOH(J,I)) ENAS(I,J)=FNAS(J,I) FNAO(J,I)=FNAS(J,I)*RNAO(J,I) ENAO(I,J)=FNAO(J,I) FNAO2(J,I)=FNAS(J,I)*RNAO2(J,I) ENAO2(I,J)=FNAO2(J,I) FNAOH(J,I)=FNAS(J,I)*RNAOH(J,I) ENAOH(I,J)=FNAOH(J,I) 450 CONTINUE DO 548 J=1,MZ AVGAM(IT,J)=PVI(10,J) AWGAM(IT,J)=PWGAM(10,J) AXNASP(IT,J)=ALOG10(AMAX1(ENASP(10,J),1.E-20)) AXNAS(IT,J)=ALOG10(AMAX1(ENAS(10,J),1.E-20)) ZHTT(IT,J)=ZHT(10,J) 999 FORMAT(1X,I3,2X,5E12.3) 548 CONTINUE C************************ C IF(MOD(IT,12).EQ.0) GO TO 449 c IF(MOD(IT,144).EQ.0) GO TO 449 IF(MOD(IT,4).EQ.0) GO TO 449 GO TO 500 449 CONTINUE C************************ DO 448 I=1,MX DO 448 J=1,MZ PKE(I,J)=ALOG10(EKE(I,J)) POX(I,J)=FNOX(J,I) PO(I,J)=FNO(J,I) PO3(I,J)=ALOG10(FNO3(J,I)) PHOX(I,J)=ALOG10(FNHOX(J,I)) PH(I,J)=ALOG10(FNH(J,I)) POH(I,J)=ALOG10(FNOH(J,I)) PHO2(I,J)=ALOG10(FNHO2(J,I)) PNOZ(I,J)=ALOG10(FNNOZ(J,I)) PNO(I,J)=ALOG10(FNNO(J,I)) PNO2(I,J)=ALOG10(FNNO2(J,I)) C PNE(I,J)=ALOG10(AMAX1(ENE(I,J),1.E-20)) PNE(I,J)=ALOG10(AMAX1(ETION(I,J),1.E-20)) PN4S(I,J)=ALOG10(FNN4S(J,I)) PLNAS(I,J)=ALOG10(AMAX1(FNAS(J,I),1.E-20)) PLNASP(I,J)=ALOG10(AMAX1(FNHE(J,I),1.E-20)) 448 CONTINUE c c Contour at current time: call plt 500 continue c c Contour with time on x-axis, zp on y-axis: call cpset(times,itx,zp,kmx,vp,xmid) finc = -6. write(6,"('gwave2d contour 4 fields with zp on y-axis:', + ' time=',f6.2,' f107=',f5.1,' day=',i5)") timee,f107,iyd do ip=1,4 call cpcnrc(fplt(1,1,ip),itx,itx,kmx,0.,0.,finc,1,-1,-1634B) call labrect(times,itx,zp,kmx,'TIME','ZPRES',0.) call clearstr(toplab) write(toplab,"('FIELD=',a,' TIME=',f5.2,' F107=',f5.1, + ' DAY=',i5)") flab(ip),timee,f107,iyd call wrlab(toplab(1:lenstr(toplab)),xmid,vp(4)+.05,.018) call frame enddo c c Contour with time on x-axis, ht on y-axis: call cpset(times,itx,htint,nhtint,vp,xmid) write(6,"('gwave2d contour 4 fields with ht on y-axis:', + ' time=',f6.2,' f107=',f5.1,' day=',i5)") timee,f107,iyd do ip=1,4 call twodint(fplt(1,1,ip),zhtt,itx,kmx,gint,htint,nhtint,0,0) call cpcnrc(fplt(1,1,ip),itx,itx,kmx,0.,0.,finc,1,-1,-1634B) call labrect(times,itx,htint,nhtint,'TIME','HT (KM)',0.) call clearstr(toplab) write(toplab,"('FIELD=',a,' TIME=',f5.2,' F107=',f5.1, + ' DAY=',i5)") flab(ip),timee,f107,iyd call wrlab(toplab(1:lenstr(toplab)),xmid,vp(4)+.05,.018) call frame enddo c c If IW < 0 restart will read from abs(iw), otherwise c it will write to iw c c IW=1 IW=91 CALL RESTART(UT,IW) CALL CLSGKS STOP END subroutine twodint(fin,fht,nx,ny,fout,hts,nhts,ilog,iprnt) c c Interpolate 2d field fin(nx,ny) to hts(nhts) heights. c Interpolated output field is returned in fout(nx,nhts) c (All heights are in km) c c On input: c fin(nx,ny) = input field to be interpolated c (pressure points are in second dimension) c fht(nx,ny) = height field corresponding to fin c (pressure points are in second dimension) c nx,ny = dimensions of fin and fht (will be 21,96 c for use with Robles twogw model) c hts(nhts) = array of target heights at which fin is to be found c (hts(1) < min(fht) and hts(nhts) < max(fht)) c nhts = number of target heights c ilog = log interpolation flag: if ilog = 1, then do a log c interpolation; if ilog.ne.1, do linear interpolation c iprnt = print flag: if iprnt=1 then print out various stuff, c otherwise twodint works silently unless an error is c detected c c On output: c fout(nx,nhts) = interpolated output field c (interpolation height points in second dimension) c (input fields are unchanged) c dimension fin(nx,ny),fht(nx,ny),fout(nx,nhts),hts(nhts) c c Check input: c if (iprnt.eq.1) write(6,"(' twodint: on entry: nx ny=',2i4, + ' nhts=',i4,' ilog=',i2,' hts=',/(6f13.3))") + nx,ny,nhts,ilog,(hts(i),i=1,nhts) if (nx.le.0.or.ny.le.0) then write(6,"(' >>> twodint error: bad nx ny=',2i6)") nx,ny stop 'twodint' endif if (nhts.le.0) then write(6,"(' >>> twodint error: bad nhts=',i6)") nhts stop 'twodint' endif c c Find min/max of fht and check against hts array: c fhtmax = -1.e36 fhtmin = +1.e36 do 100 ix = 1,nx do 100 iy = 1,ny fhtmax = amax1(fhtmax,fht(ix,iy)) fhtmin = amin1(fhtmin,fht(ix,iy)) 100 continue if (iprnt.eq.1) write(6,"(' twodint: fhtmin=',f12.3,' fhtmax=', + f12.3,' hts(1)=',f12.3,' hts(nhts)=',f12.3)") + fhtmin,fhtmax,hts(1),hts(nhts) if (hts(1).le.fhtmin) then write(6,"(' >>> twodint error: hts(1) below min height: ', + 'hts(1)=',f12.3,' fhtmin=',f12.3)") hts(1),fhtmin stop 'twodint' endif if (hts(nhts).ge.fhtmax) then write(6,"(' >>> twodint error: hts(nhts) above max height: ', + 'hts(nhts)=',f12.2,' fhtmax=',f12.2)") hts(nhts),fhtmax stop 'twodint' endif c c X loop: c do 200 ix = 1,nx c c Height loop: c do 225 ih = 1,nhts c c hts array should be monotonically increasing: c if (ih.gt.1.and.hts(ih).lt.hts(ih-1)) then write(6,"(' >>> twodint error: hts not monotonically ', + 'increasing: ih=',i3,' hts(ih)=',f12.2,' hts(ih-1)=', + f12.2)") ih,hts(ih),hts(ih-1) stop 'twodint' endif c c Find indices in fht that bracket desired height: c (fht(ix,ialt1) below hts(ih), and fht(ix,ialt2) above) c do 250 iy = 1,ny-1 if (hts(ih).ge.fht(ix,iy).and.hts(ih).le.fht(ix,iy+1)) then ialt1 = iy ialt2 = iy+1 goto 255 endif 250 continue write(6,"(' >>> twodint error: could not find index ', + 'in fht to hts: ix=',i3,' ih=',i3,' hts(ih)=',f12.2)") + ix,ih,hts(ih) stop 'twodint' 255 continue if (iprnt.eq.1.and.mod(ix,7).eq.0) + write(6,"(' twodint: ix=',i3,' ih=',i3, + ' hts(ih)=',f12.3,' ialt1=',i3,' fht(ix,ialt1)=',f12.3, + ' ialt2=',i3,' fht(ix,ialt2)=',f12.3)") + ix,ih,hts(ih),ialt1,fht(ix,ialt1),ialt2,fht(ix,ialt2) c c Do log interpolation: c if (ilog.eq.1) then rlogarg = fin(ix,ialt2) / fin(ix,ialt1) if (rlogarg.le.0.) then write(6,"(' >>> twodint error: rlogarg <= 0: rlogarg=', + e12.4,' ix=',i3,' ih=',i3,' hts(ih)=',f12.3,' ialt1,2=', + 2i3,/' fht(ix,ialt1)=',f12.3,' fht(ix,ialt2)=',f12.3, + /' fin(ix,ialt1)=',e12.4,' fin(ix,ialt2)=',e12.4)") + rlogarg,ix,ih,hts(ih),ialt1,ialt2,fht(ix,ialt1), + fht(ix,ialt2),fin(ix,ialt1),fin(ix,ialt2) stop 'rlogarg' endif exparg = (alog(fin(ix,ialt2) / fin(ix,ialt1)) / + (fht(ix,ialt2) - fht(ix,ialt1))) * + (hts(ih) - fht(ix,ialt1)) fout(ix,ih) = fin(ix,ialt1) * exp(exparg) if (iprnt.eq.1.and.mod(ix,7).eq.0) + write(6,"(' twodint log interp: ix=',i3, + ' ih=',i3,' hts(ih)=',f12.3,' fout(ix,ih)=',e12.4)") + ix,ih,hts(ih),fout(ix,ih) else c c Do linear interpolation: c f1 = (hts(ih)-fht(ix,ialt1)) / (fht(ix,ialt2)-fht(ix,ialt1)) fout(ix,ih) = f1*fin(ix,ialt2) + (1.-f1)*fin(ix,ialt1) if (iprnt.eq.1.and.mod(ix,7).eq.0) + write(6,"(' twodint linear interp: ix=',i3, + ' ih=',i3,' hts(ih)=',f12.3,' fout(ix,ih)=',e12.4)") + ix,ih,hts(ih),fout(ix,ih) endif c c End height loop: c 225 continue c c End x loop: 200 continue return end SUBROUTINE IONCOMP(H,TE,AM,AN2,CO2,H2O,O2,O3,O1, 1ANO1,ANO2,O2S,HNO3,QIO2P,QINOP,O2COL,ALPH1,ALPH3) SAVE COMMON/QIONDC/AR(54),ISWTC,ELEC COMMON/PIONTR/PHOXO2,PHOXNO,PHOXI,PHOXT ALPH4 = 8.5E-8 QO2X=QIO2P R6 = 1.E-9 R7 = 1.E-9 R8 = 1.E-9 R14 = 1.E-9 R15 = 1.E-9 R16 = 1.E-9 R22 = 1.E-9 R23 = 1.E-9 R24 = 1.E-9 R25 = 7.E-11 R41 = 1.5E-9 R42 = 1.E-9 R43 = 1.E-9 R47 = 2.8E-28 R44 = 1.E-9 R45 = 2.E-10 R46 = 1.4E-9 R48 = 3.E-10 RN2 = 1.E-31 RN3 = 1.5E-10 RN4 = 1.5E-10 RN5 = 2.5E-10 RN6 = 1.1E-10 RN7 = 6.E-10 RN8 = 5.5E-10 RN9 = 1.1E-11 RN10 = 2.5E-12 RN11 = 1.2E-10 RN12 = 4.3E-10 RN13 = 2.5E-10 RN14 = 4.8E-11 RN15 = 4.E-10 RN16 = 1.4E-10 RN17 = 1.9E-10 RN18 = 8.E-10 RN19 = 4.E-10 RN20 = 2.E-10 RN21 = 1.5E-11 RN22 = 1.3E-10 RN23 = 8.E-10 RN26 = 1.E-9 RN29 = 1.2E-9 RN30 = 1.4E-9 RN31 = 3.E-10 RN32 = 2.E-10 RN33 = 5.8E-10 RN34 = 3.E-28 RN35 = 4.7E-29 RN37 = 1.E-9 RN38 = 1.6E-9 RN39 = 8.E-10 RN40 = 3.E-9 RN41 = 2.8E-9 R49 = 4.4E-10 S1 = 0. S2 = 0. S3 = 0. S4 = 0. S5 = 0. S6 = 0. S7 = 0. S8 = 0. S9 = 0. S10 = 0. S11 = 0. S12 = 0. I=1 ELEC=100. C 14 FORMAT(F15.2) NH=1 QNO=QINOP QO2=QIO2P ALPH2=3.E-6 R1 = 2.E-31*(300./TE)**4.4 R2 = 1.5E6/(TE**5.4*EXP(2450./TE)) R3 = 7.E-30*(300./TE)**3. R5 = 1.8E-28*(308./TE)**4.7 R9 = 2.E-31*(300./TE)**4.4 R10 = 1.5E6/(TE**5.4*EXP(2150./TE)) R11 = 7.E-30*(300./TE)**3. R13 = 1.E-27*(308./TE)**4.7 R17 = 2.E-31*(300./TE)**4.4 R18 = 1.5E6/(TE**5.4*EXP(1800./TE)) R19 = 7.E-30*(300./TE)**3. R21 = 1.E-27*(308./TE)**4.7 R26 = 2.4E-27*(300./TE)**4. R27 = 1.36E11/(TE**5.*EXP(8360./TE)) R28 = 9.E-28*(300./TE)**4. R29 = 6.9E11/(TE**5.*EXP(7670./TE)) R30 = 9.E-28*(300./TE)**4. R31 = 2.1E11/(TE**5.*EXP(6540./TE)) R36 = 2.3E-27*(300./TE)**4. R37 = 1.95E11/(TE**5.*EXP(11000./TE)) R38 = 3.4E-27*(300./TE)**4. R39 = 9.6E11/(TE**5.*EXP(17100./TE)) R32 = 9.E-28*(300./TE)**4. R33 = 1.26E11/(TE**5.*EXP(5830/TE)) R34 = 9.E-28*(300./TE)**4. R35 = 2.3E10/(TE**5.*EXP(5000./TE)) R4 = 3.11E4/(TE**4.*EXP(4590./TE)) R12 = 3.11E4/(TE**4.*EXP(4025./TE)) R20 = 3.11E4/(TE**4.*EXP(3335./TE)) R40 = 2.6E-30*(300./TE)**3.2 RN1 = 1.4E-29*(300./TE)*EXP(-600./TE) RN24 = 3.1E-31*(300./TE)**2.5 RN25 = 6.3E-32*(300./TE)**4.2 RN27 = 4.7E-31*(300./TE)**1.9 RN28 = 1.8E-31*(300./TE)**2.5 RN36 = 9.E-12*(TE/300.)**1.5 ALAM = 0. SUMT = 0. TNWEW=TE IABC=0 30 ALAM1 = ALAM*ALPH4 REC1 = (ALPH1+ALAM1)*ELEC REC2 = (ALPH2+ALAM1)*ELEC REC3 = (ALPH3+ALAM1)*ELEC C19 = R49*ANO1+(R40*O2+R47*H2O)*AM+REC3 C20 = C19/(R48*O1) C21 = R41*H2O+R42*O3+R48*O1+REC2 C22 = R40*O2*AM/C21 AO2 = QO2/(R48*O1*(C20-C22)) IF(AO2 .GT. 1.E7) AO2=1.E7 AO4 = C22*AO2 AO5 = R42*O3*AO4/(R43*H2O+REC2) C23 = H2O*(R41*AO4+R43*AO5+R47*AM*AO2) AO2H = C23/((R44+R45)*H2O+REC2) AHHOH = R44*H2O*AO2H/(R46*H2O+REC2) C1 = (R1*AN2+R3*CO2+R5*H2O)*AM C2 = R2*AM+R6*CO2+R8*H2O C3 = R4*AM+R7*H2O C4 = R1*AN2*AM/(C2+REC2) IABC=IABC+1 C5 = (R3*CO2*AM+R6*CO2*C4)/(C3+REC2) ANO = (QNO+R49*ANO1*AO2)/(C1+REC1-R2*AM*C4-R4*AM*C5) ANON1 = C4*ANO ANOC1 = C5*ANO C6 = (R9*AN2+R11*CO2+R13*H2O)*AM C7 = R10*AM+R14*CO2+R16*H2O C8 = R12*AM+R15*H2O C9 = R9*AN2*AM/(C7+REC2) C10 = (R11*CO2*AM+R14*CO2*C9)/(C8+REC2) C11 = (R5*AM*ANO+R7*ANOC1+R8*ANON1)*H2O ANOH1 = C11/(C6+REC2-(R10*C9+R12*C10)*AM) ANOHN = C9*ANOH1 ANOHC = C10*ANOH1 C12 = (R17*AN2+R19*CO2+R21*H2O)*AM C13 = R18*AM+R22*CO2+R24*H2O C14 = R20*AM+R23*H2O C15 = R17*AN2*AM/(C13+REC2) C16 = (R19*AM+R22*C15)*CO2/(C14+REC2) C17 = (R13*AM*ANOH1+R15*ANOHC+R16*ANOHN)*H2O ANOH2 = C17/(C12+REC2-AM*(R18*C15+R20*C16)) ANOH2N = C15*ANOH2 ANOH2C = C16*ANOH2 C18 = (R21*AM*ANOH2+R23*ANOH2C+R24*ANOH2N)*H2O ANOH3 = C18/(R25*H2O+REC2) C24 = R34*AM*H2O/(R35*AM+REC2) C25 = (R34*H2O+R33-R35*C24)*AM+REC2 C26 = R32*AM*H2O/C25 C27 = (R32*H2O+R31-R33*C26)*AM+REC2 C28 = R30*AM*H2O/C27 C29 = (R30*H2O+R29-R31*C28)*AM+REC2 C30 = R28*AM*H2O/C29 C31 = (R28*H2O+R27-R29*C30)*AM+REC2 C32 = R26*AM*H2O/C31 C33 = R25*H2O*ANOH3 C34 = R36*AM*H2O C35 = (R26*H2O+R37-R27*C32)*AM+REC2 C36 = R46*H2O*AHHOH C37 = R38*AM*H2O C38 = R37*AM C39 = (R36*H2O+R39)*AM+REC2 C40 = R45*H2O*AO2H C41 = R39*AM C42 = R38*AM*H2O+REC2 C43 = C42*(C35*C36+C33*C38)+C35*C37*C40 C44 = C42*(C34*C38-C35*C39)+C35*C37*C41 W2 = -C43/C44 W1 = (C40+C41*W2)/C42 W3 = (C33+C34*W2)/C35 W4 = C32*W3 W5 = C30*W4 W6 = C28*W5 W7 = C26*W6 W8 = C24*W7 SUM1 = ANON1+ANOC1+ANOH1+ANOHN SUM2 = ANOHC+ANOH2+ANOH2N+ANOH2C+ANOH3 SUM3 = AO4+AO5+AO2H+AHHOH SUM4 = SUM1+SUM2+SUM3 SUM5 = W1+W2+W3+W4+W5+W6+W7+W8 SUMT = ANO+AO2+SUM4+SUM5 ALPH5 = ALPH4*SUMT GA1 = (RN3+RN4)*O1+RN7*O3+RN20*O2S+RN23*ANO2+RN41*HNO3 GA2 = (RN24*O2+RN25*AN2+RN34*H2O+RN35*CO2)*AM G1 = GA1+GA2+S1+ALPH5 GA3 = RN17*O1+(RN18+RN19)*O3+RN29*ANO2+RN40*HNO3 G2 = GA3+(RN27*O2+RN28*AN2)*AM+S2+ALPH5 G3 = RN5*O1+RN8*CO2+RN10*ANO1+S3+ALPH5 G4 = RN6*O1+RN9*ANO1+RN32*ANO2+RN39*HNO3+S4+ALPH5 G5 = RN11*O3+RN38*HNO3+S5+ALPH5 G6 = S6+ALPH5 G7 = RN12*CO2+RN13*ANO1+RN15*O1+RN30*H2O+S7+ALPH5 G8 = RN14*ANO1+RN16*O1+RN22*O3+S8+ALPH5 G9 = RN21*ANO1+S9+ALPH5 G10 = RN26*O2+S10+ALPH5 G11 = RN37*O2+S11+ALPH5 G12 = RN31*O3+RN33*CO2+S12+ALPH5 BL10 = RN25*AN2*AM/G10 BL7 = (RN24*O2*AM+RN26*O2*BL10)/G7 BL12 = (RN34*H2O*AM+RN30*H2O*BL7)/G12 BL8 = (RN35*AM+RN12*BL7+RN33*BL12)*CO2/G8 BL2 = RN4*O1/G2 BLA2 = RN36*O3/G2 BLB11 = RN28*AN2*AM BL11 = BLB11*BL2/G11 BLA11 = BLB11*BLA2/G11 BL9 = (RN13*BL7+RN14*BL8)*ANO1/G9 BLB3 = RN18*O3+RN27*O2*AM BLC3 = RN7*O3+RN15*O1*BL7+RN22*O3*BL8 BLD3 = BLB3*BL2+RN31*O3*BL12+RN37*O2*BL11 BL3 = (BLC3+BLD3)/G3 BLA3 = (BLB3*BLA2+RN37*O2*BLA11)/G3 BL4 = (RN8*CO2*BL3+RN16*O1*BL8)/G4 BLA4 = RN8*CO2*BLA3/G4 BLB5 = RN23*ANO2+RN9*ANO1*BL4+RN10*ANO1*BL3 BLC5 = RN21*ANO1*BL9+RN29*ANO2*BL2 BL5 = (BLB5+BLC5)/G5 BLA5 = (RN9*ANO1*BLA4+RN10*ANO1*BLA3+RN29*ANO2*BLA2)/G5 BLB6 = HNO3*(RN41+RN40*BL2+RN39*BL4+RN38*BL5) BL6 = (BLB6+RN32*ANO2*BL4+RN11*O3*BL5)/G6 BLC6 = HNO3*(RN40*BLA2+RN39*BLA4+RN38*BLA5) BLA6 = (BLC6+RN32*ANO2*BLA4+RN11*O3*BLA5)/G6 COE1 = (RN1*O2+RN2*AN2)*O2+RN5*O1*BLA3 COE2 = RN6*O1*BLA4+RN19*O3*BLA2 COE3 = RN5*O1*BL3+RN6*O1*BL4+RN19*O3*BL2 AL1 = (COE1+COE2)/(G1-COE3) AL2 = BL2*AL1+BLA2 AL3 = BL3*AL1+BLA3 AL4 = BL4*AL1+BLA4 AL5 = BL5*AL1+BLA5 AL6 = BL6*AL1+BLA6 AL7 = BL7*AL1 AL8 = BL8*AL1 AL9 = BL9*AL1 AL10 = BL10*AL1 AL11 = BL11*AL1+BLA11 AL12 = BL12*AL1 SUMN1 = AL1+AL2+AL3+AL4+AL5+AL6 SUMN2 = AL7+AL8+AL9+AL10+AL11+AL12 ALAM = SUMN1+SUMN2 ANEG = ELEC*(1.+ALAM) TEST = SUMT-ANEG TEST1 = ABS(TEST) AQDFY=0.01 IF(H.LT.10.) AQDFY=0.05 TEST2=TEST1-AQDFY*ANEG IF(TEST2) 40,40,41 41 AB1=ELEC*SUMT/(1.+ALAM) AB1=ABS(AB1) ELEC=SQRT(AB1) IF(IABC.LT.100) GO TO 30 WRITE(6,792) IABC,ELEC,ALAM,SUMT,ANEG,TEST1,TEST2,AB1 792 FORMAT(2X,I4,2X,7E12.4) C STOP 40 BO2 = AL1*ELEC BO1 = AL2*ELEC BO3 = AL3*ELEC BCO3 = AL4*ELEC BNO2 = AL5*ELEC BNO3 = AL6*ELEC BO4 = AL7*ELEC BCO4 = AL8*ELEC BO2NO = AL9*ELEC BO2N2 = AL10*ELEC BO1N2 = AL11*ELEC BO2H2O = AL12*ELEC ANEG1 = ELEC*ALAM AR(1)=H AR(2)=ELEC AR(3)=ALAM AR(4)=SUMT AR(5)=ANEG1 AR(6)=ANO AR(7)=ANOH1 AR(8)=ANOH2 AR(9)=ANOH3 AR(10)=ANON1 AR(11)=ANOHN AR(12)=ANOH2N AR(13)=ANOC1 AR(14)=ANOHC AR(15)=ANOH2C AR(16)=AO2 AR(17)=AO4 AR(18)=AO5 AR(19)=AO2H AR(20)=AHHOH AR(21)=W1 AR(22)=W2 AR(23)=W3 AR(24)=W4 AR(25)=W5 AR(26)=W6 AR(27)=W7 AR(28)=W8 AR(29)=BO1 AR(30)=BO2 AR(31)=BO3 AR(32)=BO4 AR(33)=BNO2 AR(34)=BNO3 AR(35)=BCO3 AR(36)=BCO4 AR(37)=BO2NO AR(38)=BO2N2 AR(39)=BO1N2 AR(40)=BO2H2O AR(41)=TE AR(42)=AM AR(43)=CO2 AR(44)=H2O AR(45)=O3 AR(46)=O1 AR(47)=O2S AR(48)=ANO1 AR(49)=ANO2 AR(50)=QNO AR(51)=QO2 AR(52)=O2 AR(53)=HNO3 AR(54)=O2COL QIT=QIO2P+QINOP RK5=4.4E-10 ALF1=R40*O2*AM/(ALPH3*ELEC+R40*O2*AM+RK5*ANO1) ALF2=R41*H2O/(R48*O1+ALPH2*ELEC+R41*H2O) ALF3=(R44+R45)*H2O/((R44+R45)*H2O+ALPH2*ELEC) PHOXO2=2.*(0.904*QIT+R48*O1*(0.904*QIT*ALF1/(ALPH2*ELEC+R41*H2O 1+(1.-ALF1)*R48*O1)))*ALF1*ALF2*ALF3/QIT XL1=(R9*AN2+R11*CO2+R13*H2O)*AM+ALPH2*ELEC XL2=R12*AM+R15*H2O+ALPH2*ELEC XL3=R10*AM+R14*CO2+R16*H2O+ALPH2*ELEC GAM1=R9*AN2*AM P1=GAM1*AR(7) P2=R11*AR(7)*CO2*AM+R14*AR(11)*CO2 BET1=1.-(ALPH2*ELEC/(XL1-AM*(R10*GAM1/XL3+R12*(R11*CO2*AM+GAM1* 1R14*CO2)/XL3/XL2))) XL4=(R17*AN2+R19*CO2+R21*H2O)*AM+ALPH2*ELEC XL5=R23*H2O+R20*AM+ALPH2*ELEC XL6=R22*CO2+R24*H2O+R18*AM+ALPH2*ELEC GAM2=R17*AN2*AM P3=GAM2*AR(8) P4=R22*AR(12)*CO2+R19*AR(8)*CO2*AM BET2=1.-(ALPH2*ELEC/(XL4-AM*(R18*GAM2/XL6+R20*(R19*CO2*AM+GAM2* 1R22*CO2)/XL6/XL5))) BET3=R25*H2O/(R25*H2O+ALPH2*ELEC) PHOXNO=2.*BET1*BET2*BET3*(.096+.904*R49*ANO1*(1.+ALPH1*R48*O1/ 1(ALPH2*ELEC+R41*H2O+(1.-ALPH1)*R48*O1))/(ALPH2* 2ELEC+R40*O2*AM+R49*ANO1)) PHOXT=PHOXO2+PHOXNO IF (ISWTC.EQ.0) GO TO 4444 WRITE(6,125) (AR(J),J=1,12) WRITE(6,130) AR(1),(AR(J),J=13,24) WRITE(6,135) AR(1),(AR(J),J=25,36) WRITE(6,140) AR(1),(AR(J),J=37,48) WRITE(6,145) AR(1),AR(52),AR(54),AR(49),AR(53),AR(50),AR(51) 125 FORMAT (7H1HEIGHT,2X,9HELECTRONS,4X,6HLAMBDA,5X,5HTOTAL,5X, * 5HTOTAL,7X,3HNO+,2X,8HNO+(H2O),1X,9HNO+(H2O)2,1X, * 9HNO+(H2O)3,3X,7HNO+(N2),2X,8HNO+(H2O),2X,8HNO+(H2O)/ * 33X,5H+IONS,5X,5H-IONS,56X,4H(N2),5X,5H2(N2)/ * (1X,0PF5.1,2X,1PE10.3,10E10.3)) 130 FORMAT (//7H0HEIGHT,3X,8HNO+(CO2),2X,8HNO+(H2O),2X,8HNO+(H2O),7X, * 3HO2+,7X,3HO4+,7X,3HO5+,2X,8HO2+(H2O),3X,7HH+(H2O),3X, * 7HH+(H2O),2X,8HH+(H2O)2,2X,8HH+(H2O)3,2X,8HH+(H2O)4/ * 23X,5H(CO2),4X,6H2(CO2),46X,4H(OH)/ * (1X,0PF5.1,2X,1PE10.3,11E10.3)) 135 FORMAT (//7H0HEIGHT,3X,8HH+(H2O)5,2X,8HH+(H2O)6,2X,8HH+(H2O)7,2X, * 8HH+(H2O)8,8X,2HO-,7X,3HO2-,7X,3HO3-,7X,3HO4-,6X,4HNO2-, * 6X,4HNO3-,6X,4HCO3-,6X,4HCO4-// * (1X,0PF5.1,2X,1PE10.3,11E10.3)) 140 FORMAT (//7H0HEIGHT,4X,7HO2-(NO),3X,7HO2-(N2),4X,6HO-(N2),2X, * 8HO2-(H2O),6X,4HTEMP,7X,3H(M),5X,5H(CO2),5X,5H(H2O),6X, * 4H(O3),7X,3H(O),6X,4H(O2 ,6X,4H(NO)/110X,8HSINGLET)/ * (1X,0PF5.1,2X,1PE10.3,11E10.3)) 145 FORMAT (//7H0HEIGHT,7X,4H(O2),1X,9HO2 COLUMN,5X,5H(NO2),4X, * 6H(HNO3),4X,6HQ(NO+),4X,6HQ(O2+)// * (1X,0PF5.1,2X,1PE10.3,5E10.3)) 4444 CONTINUE RETURN END SUBROUTINE IONDEN(QTOT,QI,Z,RZUR,PHI,TMO,RLT,RLTM,RLGM,DIP) SAVE DIMENSION QI(3),AMP(3),ALF(3),VAR(3),ZMAX(3),HMAX(3) COMMON/ARECB/VTRAL DATA AMP/1.36,2.44,.66/ DATA ALF/.5,.5,1./ DATA ZMAX(1),ZMAX(2)/110.,180./ DATA HMAX(1),HMAX(2)/10.,34./ PI=ACOS(-1.) SDEC=.39795*SIN(PI*(TMO-3.167)/6.) DEC=ASIN(SDEC) DELP=ABS(ABS(RLT)-PI/2.) IF(DELP.GT.1.E-03) GOTO 5 SEASN=RLT*DEC IF(SEASN.LT.0.) PHI=0. IF(SEASN.GE.0.) PHI=PI 5 R=RZUR/100. CLTM=COS(RLTM) SLTM=SIN(RLTM) XLAM=1.+.5*ALOG(1.+30.*R) VAR(1)=TVEF1(1.15,0.,.4,2.,RLT,R,PHI,DEC) VAR(2)=TVEF1(1.24,.25,.25,XLAM,RLT,R,PHI,DEC) VAR(3)=TVARF2(RLTM,RLGM,DIP,R,PHI,TMO,DEC,PI,CLTM,SLTM) IF(Z.EQ.0.) GOTO 100 ZALF=-4.5*ABS(RLTM)-PI ZBA=240.+10.*CLTM*COS(PI*(TMO/3.-1.5)) ZBAR=ZBA+R*(75.+83.*CLTM*ZETA(DEC,RLTM)) ZMAX(3)=ZBAR+30.*COS(PHI+ZALF) C ZMAX(3)=240.+75.*R+1.5*VTRAL*1.E-2 HMAX(3)=.2*ZMAX(3)+40. IF(Z.LT.ZMAX(3)) HMAX(3)=.2*Z+40. SUM=0. DO 10 I=1,3 ZP=(Z-ZMAX(I))/HMAX(I) CZ=EXP(ALF(I)*(1.-ZP-EXP(-ZP))) QI(I)=AMP(I)*VAR(I)*CZ SUM=SUM+QI(I) 10 CONTINUE QTOT=SUM RETURN 100 CONTINUE DO 110 I=1,3 QI(I)=AMP(I)*VAR(I) 110 CONTINUE QTOT=0. RETURN END FUNCTION TVEF1(A,B,C,D,RLT,R,PHI,DEC) SAVE RF=SQRT(1.+A*R+B*R*R) CSL=COS(RLT) CSX=-CSL*COS(DEC)*COS(PHI)+ZETA(RLT,DEC) CSX2=SQRT(ABS(CSX)) XF=SIGN(CSX2,CSX) VUT=W(C,RLT,PHI) VDIUR=EXP(D*(XF-1.)) TVEF1=RF*VDIUR*VUT RETURN END FUNCTION TVARF2(RLTM,RLGM,DIP,R,PHI,TMO,DEC,PI,CLTM,SLTM) SAVE ALTM=ABS(RLTM) ATMO=TMO*PI/6. SEMI=SEMIAN(ATMO) REQ=1.-.2*R+.6*SQRT(R) SD=ZETA(DEC,RLTM) X=(2.2+(.2+.1*R)*SLTM)*CLTM FF=EXP(-X**6) GG=1.-FF CPD=COS(PHI-.873) EF=COS(PHI+PI/4.) EMF=EF*EF ADIUR=(.9+.32*SD)*(1.+SD*EMF) BQ=COS(ALTM-.2618) AQE=CLTM**8 AQT=AQE*CLTM*CLTM AEQ=AQE*REQ*EXP(.25*(1.-CPD)) EQ=(1.-.4*AQT)*(1.+AEQ*BQ**12)*(1.+.6*AQT*EMF) VEQ=EQ*(1.+.05*SEMI) VDIUR=ADIUR*EXP(-1.1*(CPD+1.)) VLT=(EXP(3.*COS(RLTM*(SIN(PHI)-1.)/2.)))*(1.2-.5*CLTM*CLTM) VLT=VLT*(1.+.05*R*COS(ATMO)*SLTM**3) RTL=SQRT((12.*RLTM+4.*PI/3.)**2+(TMO/2.-3.)**2) VLAT=VLT*(1.-.15*EXP(-RTL)) RF=1.+R+(.204+.03*R)*R*R IF(R-1.1) 1,1,2 2 CQ=1.53*SLTM*SLTM RF=2.39+CQ*(RF-2.39) 1 CONTINUE VUT=YONII(RLTM,RF,R,PHI,TMO,DEC,PI,CLTM,SLTM) POLER=POLAR(RLTM,RLGM,DIP,R,PHI,TMO,DEC,PI,CLTM,SLTM) SHIFT=7.*PI/18. VLONG=1.+.1*(CLTM**3)*COS(2.*(RLGM-SHIFT)) ADIP=ABS(DIP) DP=.15-.5*(1.+R)*(1.-CLTM)*EXP(-.33*(TMO-6.)**2) VDP=1.+DP*EXP(-18.*(ADIP-40.*PI/180.)**2) VDIP=VDP*(1.+.03*SEMI) F2=VDIUR*VLAT*VUT*VEQ*RF*VLONG*VDIP TVARF2=FF*POLER+GG*F2 RETURN END FUNCTION ZETA(A,B) SAVE ZETA=SIN(A)*SIN(B) RETURN END FUNCTION SEMIAN(X) SAVE SEMIAN=.5-COS(X+X)+COS(X) RETURN END FUNCTION YONII(RLTM,RF,R,PHI,TMO,DEC,PI,CLTM,SLTM) SAVE B=1.3+(.139*(1.+COS(RLTM-PI/4.))+.0517*R)*R*R DRF=1./RF W1=PI/6. W2=W1+W1 DE=.1778*R*R ALTM=ABS(RLTM) SNX=SIN(ALTM-.5236) AE=.2*(1.-SNX) BLTM=ABS(ALTM-PI/9.) SX=SIN(BLTM) FE=.13-.06*SX YM=COS(RLTM+DEC) CPHG=COS(PHI) XTC=YM**3*(1.-CPHG)**.25 YTC=-(.15+.3*SIN(ALTM))*XTC T1=AE*(1.+.6*COS(W2*(TMO-4.)))*COS(W1*(TMO-1.)) TRIV=(COS(RLTM-W1))*(COS(W1*(.5*TMO-1.)))**3 TRIV=TRIV+(COS(RLTM+PI/4.))*(COS(W1*(.5*TMO-4.)))**2 QQ=1.+.085*TRIV T2=.7*(QQ+DE*DRF*COS(W2*(TMO-4.3)))*W(B,RLTM,PHI,DEC) T3=FE*COS(W2*(TMO-4.5))+YTC YONII=(T1+T3)*DRF+T2 RETURN END FUNCTION POLAR(RLTM,RLGM,DIP,R,PHI,TMO,DEC,PI,CLTM,SLTM) SAVE T=PI*TMO/12. V=SIN(T) U=COS(T+T) Y=SIN(RLGM/2.) YS=COS(RLGM/2.-PI/20.) Z=SIN(RLGM) ZA=SQRT(ABS(Z)) IF(ZA.LT.1.E-6) ZA=1.E-6 AM=1.+V IF(RLTM) 1,2,2 2 C=-23.5*PI/180. POLAR=(2.+1.2*R)*W(1.2,RLTM,PHI,C)*(1.+.3*V) GOTO 3 1 B=V*(.5*Y-.5*Z-Y**8)-AM*U*(Z/ZA)*EXP(-4.*Y*Y) POLAR=2.5+2.0*R+U*(0.5+(1.3+.2*R)*YS**4) POLAR=POLAR+(1.3+0.5*R)*COS(PHI-PI*(1.+B)) POLAR=POLAR*(1.+0.4*(1.-V*V))*EXP(-1.0*V*YS**4) 3 CONTINUE RETURN END FUNCTION W(B,XI,ETA,DEC) SAVE P=PSI(XI,ETA,DEC) W=EXP(-B*(COS(P)-COS(XI))) RETURN END FUNCTION PSI(XI,ETA,DEC) SAVE PSI=XI+DEC*COS(ETA) RETURN END SUBROUTINE QAURORA(FLUXAR,ALP,ETOTAL) SAVE PARAMETER(KMX=96) include "blank.h" include "solars.h" DATA DELTE/35.E-3/ PI=3.1415926 DO 1 K=1,KMX DENCOL=RHO(K)*SHT(K) X=((DENCOL/4.E-6)**0.606)/ALP FY=3.2333*X**2.56588*EXP(-2.2541*X**0.7297198)+1.106907*X**1.71349 1*EXP(-1.8835444*X**0.86472135) QTI(K)=FLUXAR*ALP*FY/(DELTE*SHT(K)) DENOM=0.94*XNN2(K)+XNO2(K)+0.55*XNO(K) ETAN2=0.94*XNN2(K)*QTI(K)/DENOM QIA(1,K)=0.76*ETAN2 QIA(5,K)=0.24*ETAN2 ETAO2=1.07*XNO2(K)*ETAN2/XNN2(K) QIA(2,K)= 0.67*ETAO2 ETAO=0.59*XNO(K)*ETAN2/XNN2(K) QIA(3,K)=ETAO+0.33*ETAO2 QIA(4,K)=0. 1 CONTINUE RETURN END SUBROUTINE RATECOE(TII,TEE,TNN) SAVE COMMON/TRAVLH/RK(50),ALP(20),RB(20),RKM(60) TR=(TII+TNN)*0.5 T1=0.667*TII+0.333*TNN T2=0.636*TII+0.364*TNN A1=T1/300. A2=A1*A1 A3=A2*A1 A4=A2*A2 B1=T2/300. B2=B1*B1 RK(1)=2.82E-11-7.74E-12*A1+1.073E-12*A2-5.17E-14*A3+9.65E-16*A4 IF(T2.GT.1700.) GO TO 1 RK(2)=1.533E-12-5.92E-13*B1+8.6E-14*B2 GO TO 2 1 RK(2)=2.73E-12-1.155E-12*B1+1.483E-13*B2 2 CONTINUE IF(TR.GE.1500.) GO TO 3 RK(3)=1.4E-10*(300./TR)**0.44 GO TO 4 3 RK(3)=5.2E-11*(TR/300.)**0.2 4 CONTINUE RK(4)=1.E-10 RK(5)=4.4E-10 RK(6)=4.E-10 RK(7)=2.E-10 RK(8)=1.E-12 RK(9)=2.0E-9 RK(10)=2.4E-9 RK(12)=6.E-10 RK(11)=RK(12)*8.*SQRT((TII+TNN/16.)/(TNN+TII/16.))/9. RK(13)=9.4E-10 RK(14)=9.0E-10 RK(15)=9.6E-11 RK(16)=1.6E-10 RK(17)=1.4E-10 RK(18)=1.0E-9 RK(19)=1.2E-10 RK(20)=3.3E-10 RK(21)=6.0E-11 RK(22)=1.3E-10 ALP(1)=4.2E-7*(300./TEE)**0.85 IF(TEE.GE.1200.) GO TO 5 ALP(2)=2.7E-7*(300./TEE)**0.7 GO TO 6 5 ALP(2)=1.6E-7*(300./TEE)**0.55 6 CONTINUE ALP(3)=1.8E-7*(300./TEE)**0.39 ALP(4)=1.0E-7 ALP(5)=3.0E-7 ALP(6)=3.8E-7*(300/TEE) ALP(7)=6.5E-7*(300./TEE)**0.53 C RB(1)=4.4E-12*EXP(-3200./TNN) RB(1)=1.5E-11*EXP(-3600./TNN) RB(2)=5.0E-12 C RB(3)=3.4E-11 RB(3)=1.6E-10*EXP(-460./TNN) C RB(4)=1.0E-12 RB(4)=5.0E-13 RB(5)=3.6E-10*SQRT(TEE/300.) RB(6)=7.E-11 RB(7)=1.06E-5 RB(8)=0. RB(9)=0. RB(10)=5.0E-11 RB(11)=1.8E-12*EXP(-1370./TNN) RB(12)=3.5E-12*EXP(250./TNN) RB(13)=9.3E-12 C RB(15)=1.2E-13*EXP(-2450./TNN) RB(15)=0. RETURN END SUBROUTINE RATECOF(TII,TEE,TNN) SAVE COMMON/TRAVLH/RK(50),ALP(20),RB(20),RKM(60) RKM(8)=3.2E-11*EXP(67./TNN) RKM(9)=1.8E-11*EXP(107./TNN) RKM(10)=2.2E-10 RKM(11)=1.0E-10 RKM(12)=9.59E-34*EXP(480./TNN) RKM(13)=6.0E-34*(300./TNN)**2.8 RKM(14)=6.0E-34*(300./TNN)**2.8 RKM(15)=6.0E-34*(300./TNN)**2.8 RKM(16)=8.0E-12*EXP(-2060./TNN) RKM(17)=2.2E-11*EXP(117./TNN) RKM(18)=3.0E-11*EXP(200./TNN) C RKM(19)=1.0E-11*EXP(-2500./TNN) RKM(19)=0. RKM(20)=1.6E-11*EXP(-4570./TNN) RKM(21)=1.6E-12*EXP(-940./TNN) RKM(22)=4.5E-12*EXP(-242./TNN) RKM(23)=1.7E-11*EXP(416./TNN) C RKM(24)=3.1E-12*EXP(-187./TNN) RKM(24)=0. RKM(25)=7.7E-12*EXP(-2100./TNN) RKM(26)=1.4E-14*EXP(-580./TNN) RKM(27)=2.3E-13*EXP(590./TNN) RKM(28)=5.5E-32*(300./TNN)**1.6 RKM(29)=1.4E-10*EXP(-470./TNN) C RKM(30)=6.0E-12 RKM(30)=4.2E-11*EXP(-350./TNN) C RKM(31)=7.0E-11 C RKM(32)=2.3E-12 C RKM(33)=1.0E-30/TNN**0.8 RKM(31)=4.2E-10*EXP(-950./TNN) RKM(32)=8.3E-11*EXP(-500./TNN) RKM(33)=5.7E-32*(300./TNN)**1.6 RKM(34)=0. C RKM(35)=2.4E-12*EXP(-1710./TNN) C RKM(36)=3.5E-11*EXP(-4550./TNN) C RKM(37)=1.4E-10 RKM(35)=0. RKM(36)=0. RKM(37)=0. RKM(38)=0. RKM(39)=0. RKM(40)=6.6E-33*EXP(-1103./TNN) PATM=0. RKM(41)=1.47E-13*(1.+0.59*PATM) C RKM(42)=4.54E-11*(TNN/300.)**0.4*EXP(-8960./TNN) C RKM(43)=9.0E-10 RKM(42)=0. RKM(43)=0. RETURN END C SUBROUTINE RESTART(UT,IW) c c Read from abs(iw) if iw < 0, or write to iw otherwise c SAVE PARAMETER (MX=21,MZ=96,KMX=96) include "blank.h" include "sodium.h" DIMENSION XNEEE(KMX),XNPI(KMX),XNNI(KMX),XNNOZ(KMX),QNTOT(KMX), 1XIRCOOL(KMX),DSO2(KMX),DO3T(KMX),SPED(KMX),SHAL(KMX), 2PARCD(KMX),QTIN(KMX) COMMON/PERTRF/TNO(KMX),TNP(KMX),FDIFP(KMX) common/ehist/shto(mz),eox(mx,mz),eo(mx,mz),eo3(mx,mz),ehox(mx,mz), + eh(mx,mz),eho2(mx,mz),eoh(mx,mz),enoz(mx,mz),eno(mx,mz), + eno2(mx,mz),en4s(mx,mz),enas(mx,mz),enasp(mx,mz),ene(mx,mz), + etion(mx,mz),eo2(mx,mz),en2(mx,mz),eo1d(mx,mz),ete(mx,mz), + eti(mx,mz),etn(mx,mz),eiop(mx,mz),en2d(mx,mz),enh2o(mx,mz), + enh2(mx,mz),ench4(mx,mz),enh2o2(mx,mz),enco(mx,mz),enco2(mx,mz) + ,enax(mx,mz),enao(mx,mz),enao2(mx,mz),enaoh(mx,mz) c if (iw.eq.0.or.iw.gt.99.or.iw.lt.-99) then write(6,"('>>> restart: bad iw=',i5)") iw stop 'restart' endif c IF(IW.EQ.1) GO TO 999 IF(IW.gt.0) GO TO 999 CO2MIX=350.E-6 lu = abs(iw) read(lu) zp,tno,shto,zpht,sht, + eox,eo,eo3,ehox,eh,eho2,eoh,enoz,eno,eno2,en4s,enas,enasp, + ene,etion,eo2,en2,eo1d,ete,eti,etn,eiop,en2d,enh2o,enh2, + ench4,enh2o2,enco,enco2,enax,enao,enao2,enaoh C DO 700 K=1,KMX C READ (5,800) ZP(K),ZPMS(K),ZPHT(K),ZPMHT(K),TN(K),TNMS(K) C READ (5,800) XNO(K),XOM(K),XNO1D(K),XNN2(K),XN2M(K), C + XNO2(K) C READ (5,800) XO2M(K),SHT(K),SHTMS(K),AMAS(K),AMASS(K), C + RHO(K) C READ (5,800) RHOMS(K),TE(K),TI(K),XNE(K),XNEEE(K), C + XNPI(K) C READ (5,800) XNNI(K),XIOP(K),XINOP(K),XINP(K),XIN2P(K), C + XIO2P(K) C READ (5,800) XN2D(K),XN4S(K),XN4SM(K),XNNO(K),XNNO2(K), C + XNNOZ(K) C READ (5,800) XNHE(K),XNHE(K),XNARG(K),XNARGM(K),XNH2O(K) C + ,XNH2(K) C READ (5,800) XNCH4(K),XNOH(K),XNHO2(K),XNH2O2(K),XNH(K), C + XNHM(K) C READ (5,800) XNHTOT(K),XNCO(K),XNCO2(K),QNTOT(K), C + XIRCOOL(K),DSO2(K) C READ (5,800) DO3T(K),SPED(K),SHAL(K),PARCD(K),QTIN(K), C + XNO3(K) C READ (5,800) XNAS(K),XNASP(K) C GZ(K)=980.665*(1.-3.14466E-4*ZPHT(K)) C IF(K.EQ.1) ZPHT(1)=50. C QHOXI(K)=1.E-20 C SHCO2(K)=1.38E-16*TN(K)/(44.*1.602E-24*GZ(K)) C 700 CONTINUE c C lu = abs(iw) C read(lu) zp,tno,shto,zpht,sht, C + eox,eo,eo3,ehox,eh,eho2,eoh,enoz,eno,eno2,en4s,enas,enasp, C + ene,etion,eo2,en2,eo1d,ete,eti,etn,eiop,en2d,enh2o,enh2, C + ench4,enh2o2,enco,enco2 c DO 701 K=1,KMX GZ(K)=980.665*(1.-3.14466E-4*ZPHT(K)) IF(K.EQ.1) ZPHT(1)=50. QHOXI(K)=1.E-20 SHCO2(K)=1.38E-16*TNO(K)/(44.*1.602E-24*GZ(K)) 701 CONTINUE C TN(1)=TNMS(1) GO TO 998 c c Write to history file: 999 CONTINUE c DO 997 K=1,KMX c WRITE(6,800)ZP(K),ZPMS(K),ZPHT(K),ZPMHT(K),TN(K),TNMS(K) c WRITE(6,800)XNO(K),XOM(K),XNO1D(K),XNN2(K),XN2M(K), c + XNO2(K) c WRITE(6,800)XO2M(K),SHT(K),SHTMS(K),AMAS(K),AMASS(K), c + RHO(K) c WRITE(6,800)RHOMS(K),TE(K),TI(K),XNE(K),XNEEE(K), c + XNPI(K) c WRITE(6,800)XNNI(K),XIOP(K),XINOP(K),XINP(K),XIN2P(K), c + XIO2P(K) c WRITE(6,800)XN2D(K),XN4S(K),XN4SM(K),XNNO(K),XNNO2(K), c + XNNOZ(K) c WRITE(6,800)XNHE(K),XNHE(K),XNARG(K),XNARGM(K),XNH2O(K) c + ,XNH2(K) c WRITE(6,800)XNCH4(K),XNOH(K),XNHO2(K),XNH2O2(K),XNH(K), c + XNHM(K) c WRITE(6,800)XNHTOT(K),XNCO(K),XNCO2(K),QNTOT(K), c + XIRCOOL(K),DSO2(K) c WRITE(6,800)DO3T(K),SPED(K),SHAL(K),PARCD(K),QTIN(K), c + XNO3(K) c WRITE(6,800)XNAS(K),XNASP(K) c 997 CONTINUE lu = abs(iw) write(lu) zp,tno,shto,zpht,sht, + eox,eo,eo3,ehox,eh,eho2,eoh,enoz,eno,eno2,en4s,enas,enasp, + ene,etion,eo2,en2,eo1d,ete,eti,etn,eiop,en2d,enh2o,enh2, + ench4,enh2o2,enco,enco2,enax,enao,enao2,enaoh 800 FORMAT(1X,6E11.3) 998 CONTINUE RETURN END 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 C subroutine tides(time,x,mx,zp,mz,tnms,shtms,wout) dimension wout(5,mx,mz),x(mx),zp(mz),tnms(mz),shtms(mz) dimension hs(mz),us(mz),vs(mz),ts(mz),ws(mz),xint(mz) c Warning: this subroutine assumes dx= HHHH/20 km (0 to HHHH km; c mx=21) and dz=.2 (-14.0 to 1.0; mz=76). If these values are changed c externally, they must be changed here also. c u=positive eastward (m/s), v=positive northward (m/s) c w=positive upward (s-1), zp=pressure scale height (-14.0 to 1.0) HHHH=8000. pi=acos(-1.) hwave=2.*pi/HHHH c Get height vectors of u,v,T for heights zp(i) at t=local time call tide18v(zp,mz,time,us,vs,ts) C Calculate perturbation height do i=1,mz tt=ts(i)/tnms(i) hs(i)=tt/(1.+tt) hs(i)=-shtms(i)*hs(i) end do C Integrate up (Simpson's rule) call qsf(.2,hs,hs,mz) C Calculate vertical velocity from continuity equation k=mz do i=1,mz xint(i)=vs(k)*exp(-zp(k)) k=k-1 end do C Integrate down (negative dz accounted for in eq.) call qsf(.2,xint,xint,mz) k=mz do i=1,mz ws(k)=(hwave/1000.)*(xint(i)*exp(zp(k))+vs(mz)*exp(zp(k)-zp(mz))) k=k-1 end do do 3 i=1,mz do 4 j=1,mx xx=x(j)/1.0e+05 flat=-cos(xx*hwave) slat=sin(xx*hwave) wout(1,j,i)=us(i)*flat wout(2,j,i)=vs(i)*flat wout(3,j,i)=ws(i)*slat wout(4,j,i)=ts(i)*flat wout(5,j,i)=hs(i)*flat 4 continue 3 continue return end subroutine terms (diag,sdiag,sigma,del) c real diag,sdiag,sigma,del c c coded by alan kaylor cline c from fitpack -- january 26, 1987 c a curve and surface fitting package c a product of pleasant valley software c 8603 altus cove, austin, texas 78759, usa c c this subroutine computes the diagonal and superdiagonal c terms of the tridiagonal linear system associated with c spline under tension interpolation. c c on input-- c c sigma contains the tension factor. c c and c c del contains the step size. c c on output-- c c sigma*del*cosh(sigma*del) - sinh(sigma*del) c diag = del*--------------------------------------------. c (sigma*del)**2 * sinh(sigma*del) c c sinh(sigma*del) - sigma*del c sdiag = del*----------------------------------. c (sigma*del)**2 * sinh(sigma*del) c c and c c sigma and del are unaltered. c c this subroutine references package module snhcsh. c c----------------------------------------------------------- c if (sigma .ne. 0.) go to 1 diag = del/3. sdiag = del/6. return 1 sigdel = sigma*del call snhcsh (sinhm,coshm,sigdel,0) denom = sigma*sigdel*(1.+sinhm) diag = (coshm-sinhm)/denom sdiag = sinhm/denom return end subroutine curv1 (n,x,y,slp1,slpn,islpsw,yp,temp, * sigma,ierr) c integer n,islpsw,ierr real x(n),y(n),slp1,slpn,yp(n),temp(n),sigma c c coded by alan kaylor cline c from fitpack -- january 26, 1987 c a curve and surface fitting package c a product of pleasant valley software c 8603 altus cove, austin, texas 78759, usa c c this subroutine determines the parameters necessary to c compute an interpolatory spline under tension through c a sequence of functional values. the slopes at the two c ends of the curve may be specified or omitted. for actual c computation of points on the curve it is necessary to call c the function curv2. c c on input-- c c n is the number of values to be interpolated (n.ge.2). c c x is an array of the n increasing abscissae of the c functional values. c c y is an array of the n ordinates of the values, (i. e. c y(k) is the functional value corresponding to x(k) ). c c slp1 and slpn contain the desired values for the first c derivative of the curve at x(1) and x(n), respectively. c the user may omit values for either or both of these c parameters and signal this with islpsw. c c islpsw contains a switch indicating which slope data c should be used and which should be estimated by this c subroutine, c = 0 if slp1 and slpn are to be used, c = 1 if slp1 is to be used but not slpn, c = 2 if slpn is to be used but not slp1, c = 3 if both slp1 and slpn are to be estimated c internally. c c yp is an array of length at least n. c c temp is an array of length at least n which is used for c scratch storage. c c and c c sigma contains the tension factor. this value indicates c the curviness desired. if abs(sigma) is nearly zero c (e.g. .001) the resulting curve is approximately a c cubic spline. if abs(sigma) is large (e.g. 50.) the c resulting curve is nearly a polygonal line. if sigma c equals zero a cubic spline results. a standard value c for sigma is approximately 1. in absolute value. c c on output-- c c yp contains the values of the second derivative of the c curve at the given nodes. c c ierr contains an error flag, c = 0 for normal return, c = 1 if n is less than 2, c = 2 if x-values are not strictly increasing. c c and c c n, x, y, slp1, slpn, islpsw and sigma are unaltered. c c this subroutine references package modules ceez, terms, c and snhcsh. c c----------------------------------------------------------- c nm1 = n-1 np1 = n+1 ierr = 0 if (n .le. 1) go to 8 if (x(n) .le. x(1)) go to 9 c c denormalize tension factor c sigmap = abs(sigma)*float(n-1)/(x(n)-x(1)) c c approximate end slopes c if (islpsw .ge. 2) go to 1 slpp1 = slp1 go to 2 1 delx1 = x(2)-x(1) delx2 = delx1+delx1 if (n .gt. 2) delx2 = x(3)-x(1) if (delx1 .le. 0. .or. delx2 .le. delx1) go to 9 call ceez (delx1,delx2,sigmap,c1,c2,c3,n) slpp1 = c1*y(1)+c2*y(2) if (n .gt. 2) slpp1 = slpp1+c3*y(3) 2 if (islpsw .eq. 1 .or. islpsw .eq. 3) go to 3 slppn = slpn go to 4 3 delxn = x(n)-x(nm1) delxnm = delxn+delxn if (n .gt. 2) delxnm = x(n)-x(n-2) if (delxn .le. 0. .or. delxnm .le. delxn) go to 9 call ceez (-delxn,-delxnm,sigmap,c1,c2,c3,n) slppn = c1*y(n)+c2*y(nm1) if (n .gt. 2) slppn = slppn+c3*y(n-2) c c set up right hand side and tridiagonal system for yp and c perform forward elimination c 4 delx1 = x(2)-x(1) if (delx1 .le. 0.) go to 9 dx1 = (y(2)-y(1))/delx1 call terms (diag1,sdiag1,sigmap,delx1) yp(1) = (dx1-slpp1)/diag1 temp(1) = sdiag1/diag1 if (n .eq. 2) go to 6 do 5 i = 2,nm1 delx2 = x(i+1)-x(i) if (delx2 .le. 0.) go to 9 dx2 = (y(i+1)-y(i))/delx2 call terms (diag2,sdiag2,sigmap,delx2) diag = diag1+diag2-sdiag1*temp(i-1) yp(i) = (dx2-dx1-sdiag1*yp(i-1))/diag temp(i) = sdiag2/diag dx1 = dx2 diag1 = diag2 5 sdiag1 = sdiag2 6 diag = diag1-sdiag1*temp(nm1) yp(n) = (slppn-dx1-sdiag1*yp(nm1))/diag c c perform back substitution c do 7 i = 2,n ibak = np1-i 7 yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1) return c c too few points c 8 ierr = 1 return c c x-values not strictly increasing c 9 ierr = 2 return end function curv2 (t,n,x,y,yp,sigma) c integer n real t,x(n),y(n),yp(n),sigma c c coded by alan kaylor cline c from fitpack -- january 26, 1987 c a curve and surface fitting package c a product of pleasant valley software c 8603 altus cove, austin, texas 78759, usa c c this function interpolates a curve at a given point c using a spline under tension. the subroutine curv1 should c be called earlier to determine certain necessary c parameters. c c on input-- c c t contains a real value to be mapped onto the interpo- c lating curve. c c n contains the number of points which were specified to c determine the curve. c c x and y are arrays containing the abscissae and c ordinates, respectively, of the specified points. c c yp is an array of second derivative values of the curve c at the nodes. c c and c c sigma contains the tension factor (its sign is ignored). c c the parameters n, x, y, yp, and sigma should be input c unaltered from the output of curv1. c c on output-- c c curv2 contains the interpolated value. c c none of the input parameters are altered. c c this function references package modules intrvl and c snhcsh. c c----------------------------------------------------------- c c determine interval c im1 = intrvl(t,x,n) i = im1+1 c c denormalize tension factor c sigmap = abs(sigma)*float(n-1)/(x(n)-x(1)) c c set up and perform interpolation c del1 = t-x(im1) del2 = x(i)-t dels = x(i)-x(im1) sum = (y(i)*del1+y(im1)*del2)/dels if (sigmap .ne. 0.) go to 1 curv2 = sum-del1*del2*(yp(i)*(del1+dels)+yp(im1)* * (del2+dels))/(6.*dels) return 1 sigdel = sigmap*dels call snhcsh (ss,dummy,sigdel,-1) call snhcsh (s1,dummy,sigmap*del1,-1) call snhcsh (s2,dummy,sigmap*del2,-1) curv2 = sum+(yp(i)*del1*(s1-ss)+yp(im1)*del2*(s2-ss))/ * (sigdel*sigmap*(1.+ss)) return end subroutine ceez (del1,del2,sigma,c1,c2,c3,n) c real del1,del2,sigma,c1,c2,c3 c c coded by alan kaylor cline c from fitpack -- january 26, 1987 c a curve and surface fitting package c a product of pleasant valley software c 8603 altus cove, austin, texas 78759, usa c c this subroutine determines the coefficients c1, c2, and c3 c used to determine endpoint slopes. specifically, if c function values y1, y2, and y3 are given at points x1, x2, c and x3, respectively, the quantity c1*y1 + c2*y2 + c3*y3 c is the value of the derivative at x1 of a spline under c tension (with tension factor sigma) passing through the c three points and having third derivative equal to zero at c x1. optionally, only two values, c1 and c2 are determined. c c on input-- c c del1 is x2-x1 (.gt. 0.). c c del2 is x3-x1 (.gt. 0.). if n .eq. 2, this parameter is c ignored. c c sigma is the tension factor. c c and c c n is a switch indicating the number of coefficients to c be returned. if n .eq. 2 only two coefficients are c returned. otherwise all three are returned. c c on output-- c c c1, c2, and c3 contain the coefficients. c c none of the input parameters are altered. c c this subroutine references package module snhcsh. c c----------------------------------------------------------- c if (n .eq. 2) go to 2 if (sigma .ne. 0.) go to 1 del = del2-del1 c c tension .eq. 0. c c1 = -(del1+del2)/(del1*del2) c2 = del2/(del1*del) c3 = -del1/(del2*del) return c c tension .ne. 0. c 1 call snhcsh (dummy,coshm1,sigma*del1,1) call snhcsh (dummy,coshm2,sigma*del2,1) delp = sigma*(del2+del1)/2. delm = sigma*(del2-del1)/2. call snhcsh (sinhmp,dummy,delp,-1) call snhcsh (sinhmm,dummy,delm,-1) denom = coshm1*(del2-del1)-2.*del1*delp*delm* * (1.+sinhmp)*(1.+sinhmm) c1 = 2.*delp*delm*(1.+sinhmp)*(1.+sinhmm)/denom c2 = -coshm2/denom c3 = coshm1/denom return c c two coefficients c 2 c1 = -1./del1 c2 = -c1 return end subroutine snhcsh (sinhm,coshm,x,isw) c integer isw real sinhm,coshm,x c c coded by alan kaylor cline c from fitpack -- january 26, 1987 c a curve and surface fitting package c a product of pleasant valley software c 8603 altus cove, austin, texas 78759, usa c c this subroutine returns approximations to c sinhm(x) = sinh(x)/x-1 c coshm(x) = cosh(x)-1 c and c coshmm(x) = (cosh(x)-1-x*x/2)/(x*x) c with relative error less than 4.0e-14. c c on input-- c c x contains the value of the independent variable. c c isw indicates the function desired c = -1 if only sinhm is desired, c = 0 if both sinhm and coshm are desired, c = 1 if only coshm is desired, c = 2 if only coshmm is desired, c = 3 if both sinhm and coshmm are desired. c c on output-- c c sinhm contains the value of sinhm(x) if isw .le. 0 or c isw .eq. 3 (sinhm is unaltered if isw .eq.1 or isw .eq. c 2). c c coshm contains the value of coshm(x) if isw .eq. 0 or c isw .eq. 1 and contains the value of coshmm(x) if isw c .ge. 2 (coshm is unaltered if isw .eq. -1). c c and c c x and isw are unaltered. c c----------------------------------------------------------- c data sp14/.227581660976348e-7/, * sp13/.612189863171694e-5/, * sp12/.715314759211209e-3/, * sp11/.398088289992973e-1/, * sq12/.206382701413725e-3/, * sq11/-.611470260009508e-1/, * sq10/.599999999999986e+1/ data sp25/.129094158037272e-9/, * sp24/.473731823101666e-7/, * sp23/.849213455598455e-5/, * sp22/.833264803327242e-3/, * sp21/.425024142813226e-1/, * sq22/.106008515744821e-3/, * sq21/-.449855169512505e-1/, * sq20/.600000000268619e+1/ data sp35/.155193945864942e-9/, * sp34/.511529451668737e-7/, * sp33/.884775635776784e-5/, * sp32/.850447617691392e-3/, * sp31/.428888148791777e-1/, * sq32/.933128831061610e-4/, * sq31/-.426677570538507e-1/, * sq30/.600000145086489e+1/ data sp45/.188070632058331e-9/, * sp44/.545792817714192e-7/, * sp43/.920119535795222e-5/, * sp42/.866559391672985e-3/, * sp41/.432535234960858e-1/, * sq42/.824891748820670e-4/, * sq41/-.404938841672262e-1/, * sq40/.600005006283834e+1/ data cp5/.552200614584744e-9/, * cp4/.181666923620944e-6/, * cp3/.270540125846525e-4/, * cp2/.206270719503934e-2/, * cp1/.744437205569040e-1/, * cq2/.514609638642689e-4/, * cq1/-.177792255528382e-1/, * cq0/.200000000000000e+1/ data zp4/.664418805876835e-8/, * zp3/.218274535686385e-5/, * zp2/.324851059327161e-3/, * zp1/.244515150174258e-1/, * zq2/.616165782306621e-3/, * zq1/-.213163639579425e0/, * zq0/.240000000000000e+2/ c ax = abs(x) if (isw .ge. 0) go to 5 c c sinhm approximation c if (ax .gt. 3.9) go to 2 xs = ax*ax if (ax .gt. 2.2) go to 1 c c sinhm approximation on (0.,2.2) c sinhm = xs*((((sp14*xs+sp13)*xs+sp12)*xs+sp11)*xs+1.)/ . ((sq12*xs+sq11)*xs+sq10) return c c sinhm approximation on (2.2,3.9) c 1 sinhm = xs*(((((sp25*xs+sp24)*xs+sp23)*xs+sp22)*xs+sp21) . *xs+1.)/((sq22*xs+sq21)*xs+sq20) return 2 if (ax .gt. 5.1) go to 3 c c sinhm approximation on (3.9,5.1) c xs = ax*ax sinhm = xs*(((((sp35*xs+sp34)*xs+sp33)*xs+sp32)*xs+sp31) . *xs+1.)/((sq32*xs+sq31)*xs+sq30) return 3 if (ax .gt. 6.1) go to 4 c c sinhm approximation on (5.1,6.1) c xs = ax*ax sinhm = xs*(((((sp45*xs+sp44)*xs+sp43)*xs+sp42)*xs+sp41) . *xs+1.)/((sq42*xs+sq41)*xs+sq40) return c c sinhm approximation above 6.1 c 4 expx = exp(ax) sinhm = (expx-1./expx)/(ax+ax)-1. return c c coshm and (possibly) sinhm approximation c 5 if (isw .ge. 2) go to 7 if (ax .gt. 2.2) go to 6 xs = ax*ax coshm = xs*(((((cp5*xs+cp4)*xs+cp3)*xs+cp2)*xs+cp1) . *xs+1.)/((cq2*xs+cq1)*xs+cq0) if (isw .eq. 0) sinhm = xs*((((sp14*xs+sp13)*xs+sp12) . *xs+sp11)*xs+1.)/((sq12*xs+sq11)*xs+sq10) return 6 expx = exp(ax) coshm = (expx+1./expx)/2.-1. if (isw .eq. 0) sinhm = (expx-1./expx)/(ax+ax)-1. return c c coshmm and (possibly) sinhm approximation c 7 xs = ax*ax if (ax .gt. 2.2) go to 8 coshm = xs*((((zp4*xs+zp3)*xs+zp2)*xs+zp1)*xs+1.)/ . ((zq2*xs+zq1)*xs+zq0) if (isw .eq. 3) sinhm = xs*((((sp14*xs+sp13)*xs+sp12) . *xs+sp11)*xs+1.)/((sq12*xs+sq11)*xs+sq10) return 8 expx = exp(ax) coshm = ((expx+1./expx-xs)/2.-1.)/xs if (isw .eq. 3) sinhm = (expx-1./expx)/(ax+ax)-1. return end C SUBROUTINE QSF C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION VALUES. C C USAGE C CALL QSF (H,Y,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - THE INCREMENT OF ARGUMENT VALUES. C Y - THE INPUT VECTOR OF FUNCTION VALUES. C Z - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE C IDENTICAL WITH Y. C NDIM - THE DIMENSION OF VECTORS Y AND Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 3. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF SIMPSONS RULE TOGETHER WITH NEWTONS 3/8 RULE OR A C COMBINATION OF THESE TWO RULES. TRUNCATION ERROR IS OF C ORDER H**5 (I.E. FOURTH ORDER METHOD). ONLY IN CASE NDIM=3 C TRUNCATION ERROR OF Z(2) IS OF ORDER H**4. C FOR REFERENCE, SEE C (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.71-76. C (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.214-221. C C .................................................................. C SUBROUTINE QSF(H,Y,Z,NDIM) C C DIMENSION Y(*),Z(*) C HT=.3333333*H IF(NDIM-5)7,8,1 C C NDIM IS GREATER THAN 5. PREPARATIONS OF INTEGRATION LOOP 1 SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(3)+AUX1+Y(5)) AUX2=HT*(Y(1)+3.875*(Y(2)+Y(5))+2.625*(Y(3)+Y(4))+Y(6)) SUM2=Y(5)+Y(5) SUM2=SUM2+SUM2 SUM2=AUX2-HT*(Y(4)+SUM2+Y(6)) Z(1)=0. AUX=Y(3)+Y(3) AUX=AUX+AUX Z(2)=SUM2-HT*(Y(2)+AUX+Y(4)) Z(3)=SUM1 Z(4)=SUM2 IF(NDIM-6)5,5,2 C C INTEGRATION LOOP 2 DO 4 I=7,NDIM,2 SUM1=AUX1 SUM2=AUX2 AUX1=Y(I-1)+Y(I-1) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I)) Z(I-2)=SUM1 IF(I-NDIM)3,6,6 3 AUX2=Y(I)+Y(I) AUX2=AUX2+AUX2 AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1)) 4 Z(I-1)=SUM2 5 Z(NDIM-1)=AUX1 Z(NDIM)=AUX2 RETURN 6 Z(NDIM-1)=SUM2 Z(NDIM)=AUX1 RETURN C END OF INTEGRATION LOOP C 7 IF(NDIM-3)12,11,8 C C NDIM IS EQUAL TO 4 OR 5 8 SUM2=1.125*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4)) SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) Z(1)=0. AUX1=Y(3)+Y(3) AUX1=AUX1+AUX1 Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4)) IF(NDIM-5)10,9,9 9 AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5)) 10 Z(3)=SUM1 Z(4)=SUM2 RETURN C C NDIM IS EQUAL TO 3 11 SUM1=HT*(1.25*Y(1)+Y(2)+Y(2)-.25*Y(3)) SUM2=Y(2)+Y(2) SUM2=SUM2+SUM2 Z(3)=HT*(Y(1)+SUM2+Y(3)) Z(1)=0. Z(2)=SUM1 12 RETURN END C This subroutine gives eastward (u), northward (v), and temperature (T) C at a given pressure height (zp) and local time (time) at 18 degrees N. C geographic latitude for a modified version of the Forbes [1982a,b] (parts I C and II) model....modified according to some average non-winter profiles C given by Harper [1981]. The main modifications are in phase of semidiurnal C and diurnal winds above 110 km (to earlier times), and multiplication of the C diurnal wind amplitudes by 0.8 . The following tables give wind values C from zp=-15.0 (approx 50 km) to zp=+5.0 (approx 400 km) in steps of zp=1.0. C Interpolation is done using spline under tension. subroutine tide18v(zp,mz,time,us,vs,ts) dimension zp(mz),us(mz),vs(mz),ts(mz) dimension ua(2,21),va(2,21),ta(2,21) dimension up(2,21),vp(2,21),tp(2,21) dimension store(2,6,21),phz(2),am(2) c the v's in the following data statements are southward data ( (store(1,j,i), j=1,6), i=1,10)/ & 5.,22., 5., 4., 2.,20., & 7.,16., 11.,22., 2.,18., & 10.,10., 18.,15., 2.,15.4, & 15.,4., 26.,10., 2.,12.3, & 25.,21., 40.,6., 2.,8., & 32.,16., 49.,2., 2.,2.7, & 38.,12., 54.,19., 2.,19., & 45.,7., 60.,13., 2.,11.7, & 50.,3., 70.,8., 2.,5., & 50.,23., 78.,3.8, 3.6,0./ data ( (store(1,j,i), j=1,6), i=11,21)/ & 38.,12., 72.,0., 3.8,15., & 30.,5., 37.,12., 4.,7., & 35.,23., 34.,4., 37.,0., & 42.,20., 35.,24., 75.,14.5, & 52.,17., 40.,20.7, 97.,14.5, & 58.,16.5, 43.,20., 120.,14.5, & 57.,17.2, 41.,21.0, 128.,14.5, & 55.,18.6, 40.,22.0, 136.,14.5, & 55.,19.1, 40.,23.5, 142.,14.5, & 55.,19.6, 40.,23.0, 150.,14.5, & 55.,19.6, 40.,23.0, 150.,14.5/ data ( (store(2,j,i), j=1,6), i=1,10)/ & 2.,9.5, 1.,2.7, 1.,2.7, & 1.7,9.0, 2.,.4, 1.,3., & 2.5,8.6, 3.,12., 1.,3.1, & 3.,8.5, 4.,11.7, 1.,3.2, & 5.,8.4, 7.5,11.5, 1.,3.3, & 5.,8.2, 9.,10.5, 1.,3.2, & 3.,8.0, 8.,8., 3.,3.1, & 4.,8., 11.,6., 3.5,2.6, & 9.,8.7, 25.,4.5, 2.5,1.5, & 17.,9.7, 47.,3., 3.,0./ data ( (store(2,j,i), j=1,6), i=11,21)/ & 22.,8.5, 54.,0.0, 12.5,11., & 37.,5.5, 54.,9.0, 25.,10.1, & 47.,3.0, 52.,6., 20.,9.2, & 50.,2.5, 47.,4.0, 17.,8.4, & 42.,0.7, 38.,2.5, 23.,7.4, & 30.,11.9, 35.,1.4, 34.,6.5, & 27.,10.8, 35.,0.5, 44.,6.2, & 26.,10.1, 35.,0.0, 49.,6.0, & 25.,9.8, 35.,11.5, 52.,6.0, & 25.,9.8, 35.,11.5, 55.,6.0, & 25.,9.8, 35.,11.5, 55.,6.0/ am(1)=0.8 am(2)=1.0 phz(1)=0. phz(2)=0. do k=1,2 do i=1,21 ua(k,i)=store(k,1,i)*am(k) up(k,i)=store(k,2,i)+phz(k) va(k,i)=store(k,3,i)*am(k) vp(k,i)=store(k,4,i)+phz(k) ta(k,i)=store(k,5,i) tp(k,i)=store(k,6,i) end do end do call interpv(ua,up,time,zp,mz,us) call interpv(va,vp,time,zp,mz,vs) call interpv(ta,tp,time,zp,mz,ts) c convert v to northward do i=1,mz vs(i)=-vs(i) end do return end subroutine interpv(fa,fp,time,zp,mz,fs) dimension fa(2,21),fp(2,21),ft(21),fs(mz),zz(21),zp(mz) dimension yp(21),temp(21) d=.2617992 s=.5235983 t=time/3600. do i=1,21 C arbitrary height scale (0 to 20 instead of -15 to 5), so we C can have positive argument in interpolation zz(i)=(i-1)*1.0 ft(i)=fa(1,i)*cos(d*(t-fp(1,i)))+fa(2,i)*cos(s*(t-fp(2,i))) end do sigma=2.0 call curv1(21,zz,ft,slp1,slpn,3,yp,temp,sigma,ierr) do i=1,mz C arbitrary height scale again zpr=zp(i)+15. fzpr=curv2(zpr,21,zz,ft,yp,sigma) fs(i)=fzpr end do return end function intrvl (t,x,n) c integer n real t,x(n) c c coded by alan kaylor cline c from fitpack -- january 26, 1987 c a curve and surface fitting package c a product of pleasant valley software c 8603 altus cove, austin, texas 78759, usa c c this function determines the index of the interval c (determined by a given increasing sequence) in which c a given value lies. c c on input-- c c t is the given value. c c x is a vector of strictly increasing values. c c and c c n is the length of x (n .ge. 2). c c on output-- c c intrvl returns an integer i such that c c i = 1 if e t .lt. x(2) , c i = n-1 if x(n-1) .le. t , c otherwise x(i) .le. t .le. x(i+1), c c none of the input parameters are altered. c c----------------------------------------------------------- c save i data i /1/ c tt = t c c check for illegal i c if (i .ge. n) i = n/2 c c check old interval and extremes c if (tt .lt. x(i)) then if (tt .le. x(2)) then i = 1 intrvl = 1 return else il = 2 ih = i end if else if (tt .le. x(i+1)) then intrvl = i return else if (tt .ge. x(n-1)) then i = n-1 intrvl = n-1 return else il = i+1 ih = n-1 end if c c binary search loop c 1 i = (il+ih)/2 if (tt .lt. x(i)) then ih = i else if (tt .gt. x(i+1)) then il = i+1 else intrvl = i return end if go to 1 end subroutine plt c c bf 4/8/93: c Contour arrays from gwave2d (replaces old calcon calls): c PARAMETER (MX=21,ITMX=21,MZ=96,KMX=96,MT=50,NV=2,KMXP=96) PARAMETER(NHTINT=68,HT1=66.,DHT=2.) c common/pcontour/ ETNN(MX,MZ),UWIND(MX,MZ),VWIND(MX,MZ), + WWIND(MX,MZ),ZHT(MX,MZ), + PKE(MX,MZ),pui(mx,mz),pvi(mx,mz),pwi(mx,mz),pwgam(mx,mz), + POX(MX,MZ),PNE(MX,MZ),PO(MX,MZ),PO3(MX,MZ),PHOX(MX,MZ), + PH(MX,MZ),POH(MX,MZ),PHO2(MX,MZ),PNOZ(MX,MZ),PNO(MX,MZ), + PNO2(MX,MZ),PN4S(MX,MZ),PLNAS(MX,MZ),PLNASP(MX,MZ), + eun(mx,mz),ewn(mx,mz),eke(mx,mz),UWINDZ(MX,MZ), + EDDT(MX,MZ),TNPER(MX,MZ),HTINT(NHTINT),FINT(MX,NHTINT),x(mx) parameter (nplt=24) dimension fplt(mx,mz,nplt) equivalence(fplt,etnn) ! etn -> plnasp for contour loop c common/ehist/shto(mz),eox(mx,mz),eo(mx,mz),eo3(mx,mz),ehox(mx,mz), + eh(mx,mz),eho2(mx,mz),eoh(mx,mz),enoz(mx,mz),eno(mx,mz), + eno2(mx,mz),en4s(mx,mz),enas(mx,mz),enasp(mx,mz),ene(mx,mz), + etion(mx,mz),eo2(mx,mz),en2(mx,mz),eo1d(mx,mz),ete(mx,mz), + eti(mx,mz),etn(mx,mz),eiop(mx,mz),en2d(mx,mz),enh2o(mx,mz), + enh2(mx,mz),ench4(mx,mz),enh2o2(mx,mz),enco(mx,mz),enco2(mx,mz) + ,enax(mx,mz),enao(mx,mz),enao2(mx,mz),enaoh(mx,mz) c include "blank.h" COMMON/TIMETRF/TIMEE common/iyrday/IYD c character*8 flab(nplt) character*56 toplab data flab / + 'TN ','UWIND ','VWIND ','WWIND ','ZHT ', + 'EKE ','UI ','VI ','WI ','WGAM ', + 'XNOX ','XNE ','XNO ','XNO3 ','XNHOX ', + 'XNH ','XNHOH ','XNHO2 ','NOZ ','XNNO ', + 'XNNO2 ','XN4S ','XNAS ','XNASP '/ dimension vp(4) c call cpset(x,itmx,zp,kmx,vp,xmid) ! vp(4) and xmid are returned etnn(:,:) = etn(:,:) finc = -6. ! number of contour levels for cpcnrc c c Zp on y-axis: c write(6,"('plt contouring ',i2,' fields with zp on y-axis: ', + ' time=',f5.2,' f107=',f5.1,' day=',i5)") nplt,timee,f107,iyd do ip=1,nplt call cpcnrc(fplt(1,1,ip),itmx,itmx,kmx,0.,0.,finc,1,-1,-1634B) call labrect(x,itmx,zp,kmx,'XDIST','ZPRES',0.) call clearstr(toplab) write(toplab,"('FIELD=',a,' TIME=',f5.1,' F107=',f5.1, + ' DAY=',i5)") flab(ip),timee,f107,iyd call wrlab(toplab(1:lenstr(toplab)),xmid,vp(4)+.05,.018) call frame enddo c c Contour fields interpolated to height scale (ht on y-axis) c (originally added with old calcon by bf 5/1/90) c write(6,"('plt contouring ',i2,' fields with ht on y-axis: ', + ' time=',f5.2,' f107=',f5.1,' day=',i5)") nplt,timee,f107,iyd do ip=1,nplt call twodint(fplt(1,1,ip),zht,itmx,kmx,fint,htint,nhtint,0,0) call cpcnrc(fint,itmx,itmx,nhtint,0.,0.,finc,1,-1,-1634B) call labrect(x,itmx,htint,nhtint,'XDIST','HT (KM)',0.) call clearstr(toplab) write(toplab,"('FIELD=',a,' TIME=',f5.1,' F107=',f5.1, + ' DAY=',i5)") flab(ip),timee,f107,iyd call wrlab(toplab(1:lenstr(toplab)),xmid,vp(4)+.05,.018) call frame enddo c return end c c---------------------------------------------------------------------- c subroutine labrect(xx,nx,yy,ny,xlab,ylab,chsize) c c Draw axes and axis numeric and char labels for any rectangular c plot (not called for elliptical projections) -- uses autograph c c On input: c xx(nx) array of nx x-coord values (e.g., -180 -> 180) c yy(ny) array of ny y-coord values (e.g., -87.5 -> 87.5) c dimension xx(nx),yy(ny) character*(*) xlab,ylab character*56 blank56 data blank56 + /' '/ c call agseti("SET.",4) if (chsize.le.0.) then charsz = .025 else charsz = chsize endif c c x-axis: c call agsetc("LABEL/NAME.","B") call agseti("LINE/NUMBER.",-100) call agsetf("LINE/CHARACTER.",charsz) call agsetc("LINE/TEXT.",xlab) call agsetf ('AXIS/BOTTOM/NUMERIC/WIDTH/MANTISSA.', charsz) c c y-axis: c call agsetc("LABEL/NAME.","L") call agseti("LINE/NUMBER.",100) call agsetf("LINE/CHARACTER.",charsz) call agsetc("LINE/TEXT.",ylab) call agsetf ('AXIS/LEFT/NUMERIC/WIDTH/MANTISSA.', charsz) c c Disable top label: c call agsetc("LABEL/NAME.","T") call agsetr("LABEL/DEF/SUPPRESSION.",1.) c c Draw the background c call agstup(xx,1,0,nx,1, yy,1,0,ny,1) call agback c c Reenable top label: c call agsetc("LABEL/NAME.","T") call agsetr("LABEL/DEF/SUPPRESSION.",0.) c return end c c------------------------------------------------------------------ c subroutine wrlab(lab,xpos,ypos,chsize) character*(*) lab c c Add bottom label to plot centered at xpos,ypos (virtual coords): c call getset(vl,vr,vb,vt,wl,wr,wb,wt,lnlg) if (chsize.le.0.) then charsz = .015 else charsz = chsize endif call set(0.,1.,0.,1.,0.,1.,0.,1.,1) call plchhq(xpos,ypos,lab,charsz,0.,0.) call set(vl,vr,vb,vt,wl,wr,wb,wt,lnlg) return end c c------------------------------------------------------------------ c function lenstr(str) character*(*) str c c Return index to last non-blank char in str c length = len(str) do i=length,1,-1 if (str(i:i).ne.' ') then lenstr = i return endif enddo lenstr = 0 return end c subroutine clearstr(str) c c Set given string to all blanks c character*(*) str length = len(str) do i=1,length str(i:i) = ' ' enddo return end c c------------------------------------------------------------------ c subroutine cpset(x,nx,y,ny,vport,xxmid) c c Prepare conpack for contouring (return vport and xxmid): c dimension vp(4),vport(4),x(nx),y(ny) data vp /.15,.89,.26,.91/ dimension cpcit(10),icplit(10) data cpcit /1.0, 1.5, 2.0, 2.5, 3.0, 4.0, 5.0, 6.0, 7.0, 7.5/ data icplit/ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/ c xmid = 0.5*(vp(1)+vp(2)) call pcseti('QU',2) ! use low quality chars call cpsetr('SPV',1.e36) call cpsetc('ILT','MIN $ZMN$, MAX $ZMX$, INT $CIU$') call cpsetr('ORV',1.e12) call cpseti('LLP',2) call cpsetr('LLS',.02) call cpsetr('RC2',.5) call cpseti('LLO',1) call cpsetr('XC1',x(1)) call cpsetr('XCM',x(nx)) call cpsetr('YC1',y(1)) call cpsetr('YCN',y(ny)) call cpsetr('ILX',xmid) call cpsetr('ILY',-.16) call cpsetr('ILS',.025) call cpseti('ILP',0) do i=1,10 call cpseti('PAI -- parameter array index',i) call cpsetr('CIT -- contour interval table',cpcit(i)) call cpseti('LIT -- label interval table',icplit(i)) enddo call set(vp(1),vp(2),vp(3),vp(4),x(1),x(nx),y(1),y(ny),1) vport(:) = vp(:) xxmid = xmid return end