SUBROUTINE TAIL (SECS) implicit none C **** C **** ROUTINE TO CALCULATE AURORAL CONSTANTS AS FUNCTION OF C **** TIME FOR THE NORMAL CASE USING THE REVISED ALFA (10/86) C **** AND THE NEW POLAR CAP CONVECTION (5/87) C **** SECS=UNIVERSAL TIME IN SECONDS WHERE C **** 0.12 (MDAY.IHR) = 0.0 (UTMDAY.UTHR) C **** 1.0 (MDAY.IHR) = 0.12 (UTMDAY.UTHR) C **** 1.12 (MDAY.IHR) = 1.0 (UTMDAY.UTHR) C **** ! ! Commons: include "params.h" include "cons.h" integer,parameter :: NAURPX=55,NLEX=600 real :: aurps,paramv integer :: npts,ipr,naurp,jswolda,jdith,jdidk COMMON/AURDAT/ AURPS(NLEX,2,NAURPX), NPTS(NAURPX),IPR, NAURP, | PARAMV(NAURPX), JSWOLDA, JDITH, JDIDK EQUIVALENCE (PARAMV(1),HP), (PARAMV(2),CP), (PARAMV(3),BY) ! ! Geophys indices: real :: f107,f107a,ctpoten,hpower,byimf common/ingpi/ f107,f107a,ctpoten,hpower,byimf ! ! AURORAL PARAMETERS IN DEGREES ETC. real :: theta0,offa,offc,dskofa,dskofc,phid,phin,phidp0, | phidm0,phinp0,phinm0,psim,psie,pcen,arad,h1,h2,roth,e1, | e2,rote,ec,ed,alfa1,alfa2,twak,twa6,twa21,rot6,rot21, | d6,d21,h6,h21,t6,t21 COMMON /PARAMD/ THETA0(2),OFFA(2),OFFC(2),DSKOFA(2),DSKOFC(2), | PHID(2),PHIN(2),PHIDP0(2),PHIDM0(2),PHINP0(2),PHINM0(2), | PSIM(2),PSIE(2),PCEN(2),ARAD(2),H1,H2,ROTH,E1,E2,ROTE, | EC,ED,ALFA1,ALFA2,TWAK,TWA6,TWA21,ROT6,ROT21,D6,D21,H6,H21, | T6,T21 ! ! AURORAL PARAMETERS IN RADIANS ETC FOR FLOWV3 integer :: istar,ihem real :: rdeg,psiv,r1,dduumm COMMON /IONCR/ ISTAR,IHEM,RDEG(22),PSIV(6),R1(2), 1 DDUUMM(IMAXMP*JMX0+IMX0*JMX0+2) real :: rrad,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 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 ! ! Amie common: include "amie.h" ! ! Args: real,intent(in) :: secs ! ! Local: integer :: ifrst,i,ihp,ihn,inh,ish,iut,mday,n,ih real :: hp,cp,by,convrt,dtr,e,rhp,rcp,raursh,raurnh,hpgwsh, | hpgwnh,pi,ut,seca,f1,f2,clat,cmlt,plevel,bygd,hp35,hpm35, | e21,e22,alfa21,alfa22,ut24,dispc,disp,raur,d6v,thetsh,p0 CHARACTER(len=8) :: NAMEHA(38) real,external :: terp ! DATA CONVRT/3.1211E8/,DTR/1.7453293E-2/,E/1.E-10/,IFRST/0/ COMMON /RADII/ RHP,RCP,RAURSH,RAURNH,HPGWSH,HPGWNH ! ! HEELIS CASE PLUS AURORA (ASSYMMETRICAL) DATA NAMEHA/ ' H POWER', ' C POTEN', ' IMF BY', ' R1', | ' PHIDM', ' PHIDP', ' PHINM', ' PHINP', ' ARADP,N', | ' ARADN,S', ' OFFAP,N', ' OFFAN,S', ' DKAP,N', ' DKAN,S', | ' PHIDP,N', ' PHIDN,S', ' PHINP,N', ' PHINN,S', ' PCEPP,N', | ' PCEPN,S', ' PCENP,N', ' PCENN,S', 'DPC/DKPN', 'DPC/DKNS', | ' DP/THPN', ' DP/THNS', ' OFFCP,N', ' OFFCN,S', | ' E1 ', ' E2 ', ' H1 ', ' H2 ', ' ROTE ', | ' ROTH ', ' TWA6 ', ' TWA21 ', ' ALFA1 ', ' ALFA2 '/ DATA PI/3.14159265358979/ C IFRST = IFRST + 1 C C **** C **** UNIVERSAL TIME IN HOURS C **** UT = SECS/3600. C C **** INTERPOLATE NAURP PARAMETERS if (npts(54).ne.0) then ! f107 was not defined by getgpi I = 54 F107 = TERP( AURPS(1,1,I), AURPS(1,2,I), UT, NPTS(I) ) IF (NPTS(I) .GT. 1) THEN IF (UT .LT. AURPS(1,1,I) .OR. UT .GT. AURPS(NPTS(I),1,I)) THEN WRITE(6,"(1X,'TAIL: STOP---UT OUT OF BOUNDS, UT', + ' UTMIN UTMAX =',3F7.2,' F107')") + UT,AURPS(1,1,I),AURPS(NPTS(I),1,I) STOP ENDIF ENDIF endif if (npts(55).ne.0) then ! f107a was not defined by getgpi I = 55 F107A = TERP( AURPS(1,1,I), AURPS(1,2,I), UT, NPTS(I) ) IF (NPTS(I) .GT. 1) THEN IF (UT .LT. AURPS(1,1,I) .OR. UT .GT. AURPS(NPTS(I),1,I)) THEN WRITE(6,"(1X,'TAIL: STOP---UT OUT OF BOUNDS, UT', + ' UTMIN UTMAX =',3F7.2,' F107A')") + UT,AURPS(1,1,I),AURPS(NPTS(I),1,I) STOP ENDIF ENDIF endif DO 100 I=1,NAURP if (npts(i).eq.0) goto 100 ! parameter was defined by getgpi IF (NPTS(I).EQ.1) GO TO 99 IF (UT .LT. AURPS(1,1,I) .OR. UT .GT. AURPS(NPTS(I),1,I)) THEN WRITE(6,"(1X,'TAIL: STOP---UT OUT OF BOUNDS, UT UTMIN ', + 'UTMAX =',3F7.2,2X,A8)") UT,AURPS(1,1,I),AURPS(NPTS(I),1,I), + NAMEHA(I) STOP ENDIF 99 PARAMV(I) = TERP(AURPS(1,1,I),AURPS(1,2,I),UT,NPTS(I)) 100 continue C C PLEVEL = 0. IF (HP .GE. 0.01) PLEVEL = 2.09 * ALOG(HP) C **** PUT F107,F107A INTO CONSTANT ARRAY ! (only if they were not defined by getgpi) if (npts(54).ne.0) c(61) = f107 if (npts(55).ne.0) c(62) = f107a C C FIND LIMITS OF BY WHICH ARE VALID FOR MODEL OF (3/89) BYGD = AMIN1(7.,BY) BYGD = AMAX1(-11.,BYGD) IHP = 1 IHN = 2 IF (BY .GT. 0.) THEN IHP = 2 IHN = 1 ENDIF C ASSUME THAT WE ARE ALWAYS DEALING WITH S AND N HEM IN PARAMV INH = 2 ISH = 1 C HP35 = AMIN1(HP,35.) HPM35 = AMAX1(0.,HP-35.) C C SET CUSP AND DRIZZLE PARAMETERS C **** C **** CHANGE CUSP AND DRIZZLE PARAMETERS C **** (IN TGCM3 HAD EC=0.40, ALFAC=0.09, ED=0.05, ALFAD=0.20) C **** (WAS TOO MUCH ED ESPECIALLY.) C EC = 0.1+0.9*HP/100. C EC = 0.01+0.09*HP/100. C ALFAC = 0.5 EC = 0.5 ALFAC = 1.0 C ED = 0.1+2.*HP/100. C ED = 0.01+0.2*HP/100. C ALFAD = 0.75 ED = 0.5 ALFAD = 2.0 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) C***************** IUT = UT + E UT24 = AMOD(UT,24.) MDAY = UT/24. IF (ABS(UT-IUT) .LT. 0.001) WRITE (6,"(1X,'TAIL: UT HP CP BY =', | F8.2,I3,F8.2,3F7.1/1X,'EC ALFAC FC ED ALFAD FD ALFA21,22 ALFA20 |RALFA2=',2F7.3,E10.3,2F7.3,E10.3,4F7.3)") UT,MDAY,UT24,HP,CP,BYIMF |,EC,ALFAC,FC,ED,ALFAD,FD,ALFA21,ALFA22,ALFA20,RALFA2 IF (IAMIE .EQ. 1) GO TO 190 C***************** C OLD ALFA IF (JSWOLDA .EQ. 1) THEN C ALFA1 = 0.91 C ALFA2 = 0.63 + 0.039*HP35 + 0.0022*HPM35 C ALFA1 = 2.0 C ALFA2 = 3.0 C **** SNOE AURORA PARTICLE ALPHA ALFA1 = 2.0 ALFA2 = 2.0 C TWA6 = 0. TWA21 = 0. ELSE ALFA1 = 0. ALFA2 = 0. ENDIF C IF (NAURP .GT. 3) THEN DO 110 N=1,2 R1(N) = PARAMV(4) PHIDM0(N) = PARAMV(5) PHIDP0(N) = PARAMV(6) PHINM0(N) = PARAMV(7) 110 PHINP0(N) = PARAMV(8) ARAD(INH) = PARAMV(9) ARAD(ISH) = PARAMV(10) OFFA(INH) = PARAMV(11) OFFA(ISH) = PARAMV(12) DSKOFA(INH) = PARAMV(13) DSKOFA(ISH) = PARAMV(14) C THIS PART IS NEW (11/10/88) PHID(INH) = PARAMV(15) PHID(ISH) = PARAMV(16) PHIN(INH) = PARAMV(17) PHIN(ISH) = PARAMV(18) PSIE(INH) = -CP * PARAMV(19) PSIM(INH) = CP * (1.-PARAMV(19)) PSIE(ISH) = -CP * PARAMV(20) PSIM(ISH) = CP * (1.-PARAMV(20)) PCEN(INH) = PARAMV(21) * CP PCEN(ISH) = PARAMV(22) * CP IF (JDIDK .EQ. 0) THEN DISPC = PARAMV(23) DSKOFC(INH) = DSKOFA(INH) + DISPC DSKOFC(ISH) = DSKOFA(ISH) + DISPC ELSE DSKOFC(INH) = PARAMV(23) DSKOFC(ISH) = PARAMV(24) DISPC = DSKOFC(INH) - DSKOFA(INH) ENDIF IF (JDITH .EQ. 0) THEN DISP = PARAMV(25) THETA0(INH) = ARAD(INH) - DISP THETA0(ISH) = ARAD(ISH) - DISP ELSE THETA0(INH) = PARAMV(25) THETA0(ISH) = PARAMV(26) DISP = ARAD(INH) - PARAMV(25) ENDIF OFFC(INH) = PARAMV(27) OFFC(ISH) = PARAMV(28) IF(NAURP .GT. 28) THEN E1 = PARAMV(29) E2 = PARAMV(30) H1 = PARAMV(31) H2 = PARAMV(32) ROTE = PARAMV(33) ROTH = PARAMV(34) IF (JSWOLDA .EQ. 0) THEN TWA6 = PARAMV(35) TWA21 = PARAMV(36) ELSE C ALFA1 = 2.0 C ALFA2 = 3.0 C **** SNOE AURORA PARTICLE ALPHA ALFA1 = 2.0 ALFA2 = 2.0 ENDIF GO TO 135 ENDIF ! FOR NAURP .GT. 3 ELSE C MADE NEW MODEL IN 3/89 C ION CONVECTION PARAMETERS: DSKOFC(INH) = -0.08 - 0.15*BYGD DSKOFC(ISH) = -0.08 + 0.15*BYGD PHID(INH) = (9.39 - 0.21 * BYGD - 12.) * 15. PHID(ISH) = (9.39 + 0.21 * BYGD - 12.) * 15. PHIN(INH) = (23.50 - 0.15 * BYGD - 12.) * 15. PHIN(ISH) = (23.50 + 0.15 * BYGD - 12.) * 15. PCEN(INH) = (-0.168 - 0.027 * BYGD) * CP PCEN(ISH) = (-0.168 + 0.027 * BYGD) * CP DO 3010 IH=1,2 R1(IH) = -2.6 IF (IAMIE .EQ. 1) THEN C FORMULA FOR AMIE POTENTIALS THETA0(IH) = -1.92 + 8.10 * (CP**0.1875) ELSE C FORMULA FOR IMF POTENTIALS THETA0(IH) = -3.80 + 8.48 * (CP**0.1875) ENDIF OFFC(IH) = 1.1 PSIM(IH) = 0.44 * CP PSIE(IH) = -0.56 * CP PHIDP0(IH) = 85. PHIDM0(IH) = 50. PHINP0(IH) = 57.5 PHINM0(IH) = 100. C AURORAL PRECIPITATION RHP = 14.20 + 0.96*PLEVEL IF (IAMIE .EQ. 1) THEN C FORMULA FOR AMIE POTENTIALS RCP = 3.06 + 8.49 * (CP**0.1875) ELSE C FORMULA FOR IMF POTENTIALS RCP = -0.43 + 9.69 * (CP**0.1875) ENDIF ARAD(IH) = AMAX1(RHP,RCP) 3010 CONTINUE OFFA(INH) = 3.7 OFFA(ISH) = 4.3 DSKOFA(INH) = -1.26 - 0.15 * BYGD DSKOFA(ISH) = -1.26 + 0.15 * BYGD DISP = ARAD(1) - THETA0(1) DISPC = DSKOFC(1) - DSKOFA(1) ENDIF C E1 = AMAX1( 0.50, -2.15 + 0.62 * PLEVEL) C E2 = 0.95 + 0.117 * HP C **** SNOE PARTICLE ENERGY FLUX C E1 = AMAX1( 0.50, -2.15 + 0.62 * PLEVEL)*1.5 C E1 = (0.95 + 0.117 * HP) C E2 = (0.95 + 0.117 * HP) C E1 = (1.0 + 0.15* HP) C E2 = (1.0 + 0.15* HP) E1 = (1.0 + 0.20* HP) E2 = (1.0 + 0.20* HP) C write(6,"('tail: ut=',f8.3,' hp=',e12.4,' plevel=',e12.4, | ' cp=',e12.4)") ut,hp,plevel,cp write(6,"(' e1=',e12.4,' e2=',e12.4)") e1,e2 C ROTE = (2.62 - 0.55 * PLEVEL) * 15. H1 = AMIN1( 2.35, 0.83 + 0.33 * PLEVEL ) H2 = 2.87 + 0.15 * PLEVEL 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 * (CP**0.1875) C FORMULA FOR IMF POTENTIALS RCP = -0.43 + 9.69 * (CP**0.1875) RAUR = AMAX1(RCP,RHP) C ELECTRON MEAN ENERGIES TWAK = 0.50 IF (NAURP .LE. 28 .AND. JSWOLDA .EQ. 0) THEN TWA6 = 0.36 + 0.48 * PLEVEL TWA21 = AMAX1( 1.00, -1.75 + 0.69 * PLEVEL ) ENDIF 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 140 CONTINUE IF (HP .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 ALFA0 = 0.5 * (ALFA1 + ALFA2) RALFA = (ALFA2 - ALFA1) / (ALFA1 + ALFA2 + E) C IUT = UT + E C IF (ABS(UT-IUT) .LT. 0.001) WRITE (6,603) UT, HP, CP, BYIMF, C | RHP, RCP, RAUR, (THETA0(I),I=1,51), DISPC,ARAD(1),ARAD(2), C | TWA6,TWA21,JSWOLDA,JDIDK,JDITH C 603 FORMAT(1X,'TAIL: ',4X,'UT HP CP BYIMF RHP RCP RAUR =', 7F6.1/ C |1X,'PARAMD=THETA0(2),OFFA(2),OFFC(2),DSKOFA(2),DSKOFC(2),PHID(2)'/ C |1X,' PHIN(2),PHIDP0(2),PHIDM0(2),PHINP0(2),PHINM0(2),PSIM(2)'/ C |1X,' PSIE(2),PCEN(2),ARAD(2),H1,H2,ROTH,E1,E2,ROTE,EC,ED,ALFA1'/ C |1X,' ALFA2,TWAK,TWA6,TWA21,ROT6,ROT21,D6,D21,H6,H21,T6,T21'/ C | 5X, 'PARAMD(1-10) =', 10E10.3/ 5X, 'PARAMD(11-20)=',10E10.3/ C | 5X, 'PARAMD(21-30)=', 10E10.3/ 5X, 'PARAMD(31-40)=',10E10.3/ C | 5X, 'PARAMD(41-50)=', 10E10.3/ 5X, 'PARAMD(51)=',E10.3/ C | 5X, 'DISPC ARAD(1,2) TWA6 TWA21 JSWOLDA,DIDK,DITH =', 5F6.3,3I3) 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 .EQ. 1) RETURN 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) C DO 200 N=1,22 200 RDEG(N) = THETA0(N) * DTR DO 210 N=1,6 210 PSIV(N) = PSIM(N) * 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 RETURN END C