#include "dims.h" ! subroutine tail(iprint) use input_module,only: power,ctpoten,byimf,f107,f107a,iamie use amie_module,only: hpi_nh_amie,hpi_sh_amie, | pcp_nh_amie,pcp_sh_amie,crad ! am_03/02 the parameterization was changed to fit the parameterization ! from B.Emery ! before the integration of the flux didn't give the right ! hpower index (it was too high eg. POWER=3 resulted into ! an index of 13) ! Ray Roble used snoe values which are fitted to the ! observations ! ! Set auroral parameters. Most of these are optionally read by ! input (time-dependent input of these is not yet available) ! ! This version of tail assumes naurp=3 (only hp,cp,by are input), ! and constant hp,cp,by in time. It also assumes JSWOLD=1 (OLDALFA) ! from the old tail. ! implicit none #include "params.h" ! ! Parameters from /ovalr/ that are set here (or received from input), ! and referenced by orora: fc,alfac,fd,alfad, e30,fd2,alfad2 ! #include "ovalr.h" ! ! The first 15 parameters in ioncr.h are optional inputs (see input): #include "ioncr.h" ! ! Args: integer,intent(in) :: iprint ! ! Local: real :: ec,ed,pi,dtr,e1,e2,rote,h1,h2,roth,rhp,rcp,raur,twak, | twa6,twa21,rot6,rot21,t6,t21,d6,d6v,d21,h6,h21,e21,e22, | raursh,raurnh,thetsh,alfa1,alfa2,e,ut,p0,hpgwsh,hpgwnh, | plevel,hp,cp,arad(2),alfa21,alfa22,c25,c35 real,parameter :: convrt=3.1211e+8 integer,parameter :: ish=1,inh=2 ! south,north hemispheres integer :: i,iut,n ! ! write(6,"('enter tail: /ingpi/ ctpoten, power, byimf=', ! | 3e12.4)") ctpoten,power,byimf ! pi = 4.*atan(1.) dtr = pi/180. e = 1.e-10 crit(1) = 0.261799387 crit(2) = 0.523598775 ! Use AMIE data if (iamie == 1) then theta0(1) = crad(1)*180./pi theta0(2) = crad(2)*180./pi hp = amax1(hpi_sh_amie,hpi_nh_amie) cp = amax1(pcp_sh_amie,pcp_nh_amie) PLEVEL = 2.09 * ALOG(hp) H1 = AMIN1 (2.35, 0.83 + 0.33 * PLEVEL ) H2 = 2.87 + 0.15 * PLEVEL ROTH = (12.18 - 0.89*PLEVEL) * 15. ROTE = (2.62 - 0.55*PLEVEL) * 15. OFFC(1) = 1. OFFC(2) = 1. DSKOFC(1) = 0. DSKOFC(2) = 0. ! RDEG(5) = OFFC(1)*DTR ! RDEG(6) = OFFC(2)*DTR ! RDEG(9) = DSKOFC(1)*DTR ! RDEG(10) = DSKOFC(2)*DTR endif ! ! Set cusp and drizzle parameters alfac, alfad, fc, fd (ovalr.h): ! (power, from input, is in ingpi.h) ! ! ec = 0.1+0.9*power/100. ! pre-13mt ec = 0.01+0.09*power/100. ! kibo alfac = 0.5 ! kibo ! ec = 0.5 ! snoe ! alfac = 1.0 ! snoe ! ed = 0.1+2.*power/100. ! pre-13mt ed = 0.01+0.2*power/100. ! kibo alfad = 0.75 ! kibo ! ed = 0.5 ! snoe ! alfad = 2.0 ! snoe fc = convrt * ec / alfac fd = convrt * ed / alfad C SECOND ALFA REPRESENTING LOW ENERGIES AT HIGH ALTITUDES E21 = 1.E-80 E22 = 1.E-80 ALFA21=0.075 ALFA22=0.075 ALFA20 = 0.5 * (ALFA21 + ALFA22) RALFA2 = (ALFA22 - ALFA21) / (ALFA21 + ALFA22 + E) if (iamie == 1) goto 190 do i=ish,inh theta0(i) = -3.80 + 8.48 * (ctpoten**0.1875) offc(i) = 1.1 phidp0(i) = 85. phidm0(i) = 50. phinp0(i) = 57.5 phinm0(i) = 100. psim(i) = 0.44 * ctpoten psie(i) = -0.56 * ctpoten enddo offa(ish) = 4.3 offa(inh) = 3.7 dskofa(ish) = (-1.26 + 0.15 * byimf) dskofa(inh) = (-1.26 - 0.15 * byimf) dskofc(ish) = (-0.08 + 0.15 * byimf) dskofc(inh) = (-0.08 - 0.15 * byimf) phid(ish) = ((9.39 + 0.21 * byimf - 12.) *15.) phid(inh) = ((9.39 - 0.21 * byimf - 12.) *15.) phin(ish) = ((23.5 + 0.15 * byimf - 12.) *15.) phin(inh) = ((23.5 - 0.15 * byimf - 12.) *15.) pcen(ish) = (-0.168 - 0.027 * byimf) * ctpoten pcen(inh) = (-0.168 + 0.027 * byimf) * ctpoten rr1(:) = -2.6 ! ! Report auroral parameters in degrees: ! if (iprint > 0) then ! write(6,"(/'Tail: input variables:')") write(6,"(' f107 =',e12.4,' f107a=',e12.4)") f107,f107a write(6,"(' ctpoten=',e12.4)") ctpoten write(6,"(' power =',e12.4)") power write(6,"(' byimf =',e12.4)") byimf ! write(6,"(' fkp =',e12.4)") fkp ! write(6,"(/'Tail: /ioncr/ variables (deg south,north):')") write(6,"(' theta0 = ',2e12.4)") theta0 write(6,"(' offa = ',2e12.4)") offa write(6,"(' offc = ',2e12.4)") offc write(6,"(' dskofa = ',2e12.4)") dskofa write(6,"(' dskofc = ',2e12.4)") dskofc write(6,"(' phid = ',2e12.4)") phid write(6,"(' phin = ',2e12.4)") phin write(6,"(' phidp0 = ',2e12.4)") phidp0 write(6,"(' phidm0 = ',2e12.4)") phidm0 write(6,"(' phinp0 = ',2e12.4)") phinp0 write(6,"(' phinm0 = ',2e12.4)") phinm0 write(6,"(' psim = ',2e12.4)") psim write(6,"(' psie = ',2e12.4)") psie write(6,"(' pcen = ',2e12.4)") pcen write(6,"(' ')") endif plevel = 0. if (power >= 0.01) plevel = 2.09 * alog(power) PLEVEL = AMAX1(1.0,PLEVEL) E1 = AMAX1( 0.50, -2.15 + 0.62 * PLEVEL) E2 = 0.95 + 0.117 * power C **** SNOE PARTICLE ENERGY FLUX ! E1 = AMAX1( 0.50, -2.15 + 0.62 * PLEVEL)*1.5 ! kibo C E1 = (0.95 + 0.117 * power) ! E2 = (0.95 + 0.117 * power) ! kibo C E1 = (1.0 + 0.15* power) C E2 = (1.0 + 0.15* power) ! E1 = (1.0 + 0.25* power) ! snoe ! E2 = (1.0 + 0.25* power) ! snoe ROTE = (2.62 - 0.55 * PLEVEL) * 15. H1 = AMIN1( 2.35, 0.83 + 0.33 * PLEVEL ) ! kibo H2 = 2.87 + 0.15 * PLEVEL ! kibo ! H1 = 3.+0.1*power ! snoe ! H2 = 3.+0.1*power ! snoe ROTH = (12.18 - 0.89 * PLEVEL) * 15. C AURORAL PRECIPITATION 135 RHP = 14.20 + 0.96*PLEVEL C FORMULA FOR AMIE POTENTIALS RCP = 3.06 + 8.49 * (ctpoten**0.1875) C FORMULA FOR IMF POTENTIALS RCP = -0.43 + 9.69 * (ctpoten**0.1875) RAUR = max(RCP,RHP) arad(1) = max(rcp,rhp) arad(2) = max(rcp,rhp) C ELECTRON MEAN ENERGIES TWAK = 0.50 TWA6 = 0.36 + 0.48 * PLEVEL TWA21 = AMAX1( 1.00, -1.75 + 0.69 * PLEVEL ) ROT6 = (6.00 - 12.) * 15. ROT21 = (21.00 - 12.) * 15. T6 = 7.00 T21 = 4.00 D6 = -4.0 D6V = 0. D21 = 4.0 H6 = 7.0 H21 = 10.0 E21 = 1.e-80 E22 = 1.e-80 IF (power .LT. 0.01) THEN E1 = 1.E-20 E2 = 1.E-20 EC = 1.E-20 ED = 1.E-20 E21 = 1.E-20 E22 = 1.E-20 FD = 1.E-20 FC = 1.E-20 ENDIF C RAURSH = ARAD(1) RAURNH = ARAD(2) C SET SHIELDING RADIUS FOR FOSSIL WIND C THETSH = ARAD(2) + H1 + H2 THETSH = ARAD(2) + H2 C OLD ALFA ALFA1 = 2. ALFA2 = 3. ! kibo ! ALFA2 = 2. ! snoe ALFA0 = 0.5 * (ALFA1 + ALFA2) RALFA = (ALFA2 - ALFA1) / (ALFA1 + ALFA2 + E) C C **** SET INITIALIZATION FLAG ISTAR=0 C **** C **** INSERT VALUES IN COMMON BLOCK, PARAMS. C **** RRAD(1) = ARAD(1) * DTR RRAD(2) = ARAD(2) * DTR 190 CONTINUE RROTH = ROTH * DTR RROTE = ROTE * DTR H0 = 0.5 * (H1 + H2) * DTR RH = (H2 - H1) / (H1 + H2 + E) E20 = 0.5 * (E21 + E22) RE2 = (E22 - E21) / (E21 + E22) if (iamie == 1) then C Set critical radii: CRIT(1) = theta0 + 5.0 deg C for AMIE CRIT(2) = theta0 + 10.0 deg C CRIT(1) = ((THETA0(1)+THETA0(2))*0.5 + 5.0) * DTR C CRIT(2) = ((THETA0(1)+THETA0(2))*0.5 + 10.0) * DTR C Set critical colatitude crit(2) 40 deg -- G. Lu 5/11/98 C Therefore, crit2 = 40, crit1 = 25-30, depending on theta0 C35 = AMIN1(30.0,(THETA0(1)+THETA0(2))*0.5 + 5.0) C25 = AMAX1(25.,C35) CRIT(1) = C25 * DTR CRIT(2) = 40. * DTR theta0(:) = theta0(:) * dtr offa(:) = offa(:) * dtr offc(:) = offc(:) * dtr dskofa(:) = dskofa(:) * dtr dskofc(:) = dskofc(:) * dtr return endif E0 = 0.5 * (E1 + E2) REE = (E2 - E1) / (E1 + E2) C CALCULATE HEMISPHERIC POWER PI = 3.1415926535898 P0 = E0 * (2.*PI**1.5) * ((6.37E8+1.E7)**2) * ((ARAD(1) 1 *PI) / 180.) * H0 HPGWSH = P0 * (1. + 0.5*REE*RH*COS(RROTH-RROTE) ) / 1.E+16 HPGWNH = HPGWSH * ARAD(2) / ARAD(1) ! ! Convert to radians: theta0(:) = theta0(:) * dtr offa(:) = offa(:) * dtr offc(:) = offc(:) * dtr dskofa(:) = dskofa(:) * dtr dskofc(:) = dskofc(:) * dtr phid(:) = phid(:) * dtr phin(:) = phin(:) * dtr phidp0(:) = phidp0(:) * dtr phidm0(:) = phidm0(:) * dtr phinp0(:) = phinp0(:) * dtr phinm0(:) = phinm0(:) * dtr ! psim(:) = psim(:) * 1000. psie(:) = psie(:) * 1000. pcen(:) = pcen(:) * 1000. C C ADD IN VARIATIONS TO 2*ALFA (SEP 1986) ALFK = TWAK * 0.5 ALF6 = TWA6 * 0.5 ALF21 = TWA21 * 0.5 RROT6 = ROT6 * DTR RROT21 = ROT21 * DTR RD6 = D6 * DTR RD6V = D6V * DTR RD21 = D21 * DTR RH6 = H6 * DTR RH21 = H21 * DTR RT6 = T6 * 15. * DTR RT21 = T21 * 15. * DTR ! ! COMMON /OVALR/ RRAD(2),H0,RH,RROTH,E0,REE,RROTE,FC,ALFAC,FD,ALFAD, ! | ALFK,ALF6,ALF21,RROT6,RROT21,RD6,RD6V,RD21,RH6,RH21,RT6,RT21, ! | ALFA0,RALFA,ALFA20,RALFA2,E20,RE2, ALFA30,E30,FD2,ALFAD2,ED2 ! if (iprint > 0) then write(6,"('Tail: /ovalr/ variables:')") write(6,"(' rrad =',2e12.4)") rrad write(6,"(' h0 =',e12.4)") h0 write(6,"(' rh =',e12.4)") rh write(6,"(' rroth =',e12.4)") rroth write(6,"(' e0 =',e12.4,' (e1,e2=',2e12.4,')')") e0,e1,e2 write(6,"(' ree =',e12.4)") ree write(6,"(' rrote =',e12.4)") rrote write(6,"(' fc =',e12.4,' fd =',e12.4)") fc,fd write(6,"(' alfac =',e12.4,' alfad =',e12.4,' alfk=',e12.4)") | alfac,alfad,alfk write(6,"(' alf6 =',e12.4,' alf21 =',e12.4)") alf6,alf21 write(6,"(' rrot6 =',e12.4,' rrot21=',e12.4)") rrot6,rrot21 write(6,"(' rd6 =',e12.4,' rd6v =',e12.4)") rd6,rd6v write(6,"(' rd21 =',e12.4)") rd21 write(6,"(' rh6 =',e12.4,' rh21 =',e12.4)") rh6,rh21 write(6,"(' rt6 =',e12.4,' rt21 =',e12.4)") rt6,rt21 write(6,"(' alfa0 =',e12.4,' alfa20=',e12.4)") alfa0,alfa20 write(6,"(' ralfa =',e12.4,' ralfa2=',e12.4)") ralfa,ralfa2 write(6,"(' e20 =',e12.4)") e20 write(6,"(' re2 =',e12.4)") re2 write(6,"(' ')") endif end subroutine tail